diff -Nru racket-6.12+ppa1/collects/acks/acks.rkt racket-7.0+ppa1/collects/acks/acks.rkt --- racket-6.12+ppa1/collects/acks/acks.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/acks/acks.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,6 +11,7 @@ "The following individuals contributed to the implementation" " and documentation of Racket: " "Claire Alvis, " + "Leif Andersen, " "Yavuz Arkun, " "Ian Barland, " "Eli Barzilay, " @@ -24,32 +25,42 @@ "Richard Cobbe, " "Greg Cooper, " "Ryan Culpepper, " + "Christos Dimoulas, " "Eric Dobson, " "Carl Eastlund, " "Moy Easwaran, " "Will Farr, " "Matthias Felleisen, " - "Michael Filonenko, " + "Dan Feltey, " "Burke Fetscher, " + "Michael Filonenko, " "Robby Findler, " "Kathi Fisler, " "Cormac Flanagan, " + "Spencer Florence, " "Matthew Flatt, " + "Tony Garnock-Jones, " "Sebastian Good, " "Paul Graunke, " "Kathy Gray, " + "Ben Greenman, " "Dan Grossman, " "Arjun Guha, " "Dave Gurnell, " "Tobias Hammer, " + "William Hatch, " "Bruce Hauman, " + "Greg Hendershott, " "Dave Herman, " "Blake Johnson, " + "Alexis King, " "Casey Klein, " + "Alex Knauth, " "Geoffrey S. Knauth, " "Mark Krentel, " "Shriram Krishnamurthi, " "Mario Latendresse, " + "Xiangqi Li, " "Guillaume Marceau, " "Gustavo Massaccesi, " "Jacob Matthews, " @@ -77,11 +88,13 @@ "Asumu Takikawa, " "Kevin Tew, " "Neil Toronto, " + "Milo Turner, " "Dale Vaillancourt, " "Dimitris Vyzovitis, " "Stephanie Weirich, " "Noel Welsh, " "Adam Wick, " "Danny Yoo, " + "Shu-Hung You, " "and " "ChongKai Zhu.")) diff -Nru racket-6.12+ppa1/collects/compiler/cm.rkt racket-7.0+ppa1/collects/compiler/cm.rkt --- racket-6.12+ppa1/collects/compiler/cm.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/cm.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,92 +1,27 @@ #lang racket/base -(require syntax/modcode - syntax/modresolve - syntax/modread - setup/dirs - racket/file - racket/list - racket/path - racket/promise - openssl/sha1 +(require "private/cm-minimal.rkt" + (submod "private/cm-minimal.rkt" cm-internal) + racket/contract/base racket/place - setup/collects - compiler/compilation-path - compiler/private/dep - racket/contract/base) + racket/path + racket/promise) + +(provide (except-out (all-from-out "private/cm-minimal.rkt") + current-path->mode) -(provide make-compilation-manager-load/use-compiled-handler - managed-compile-zo - make-caching-managed-compile-zo - trust-existing-zos - manager-compile-notify-handler - manager-skip-file-handler file-stamp-in-collection file-stamp-in-paths - manager-trace-handler - get-file-sha1 - get-compiled-file-sha1 - with-compile-output - - managed-compiled-context-key - make-compilation-context-error-display-handler - - parallel-lock-client + make-compile-lock compile-lock->parallel-lock-client - - install-module-hashes! (contract-out [current-path->mode (parameter/c (or/c #f (-> path? (and/c path? relative-path?))))])) -(define current-path->mode (make-parameter #f)) - -(define cm-logger (make-logger 'compiler/cm (current-logger))) -(define (default-manager-trace-handler str) - (when (log-level? cm-logger 'debug) - (log-message cm-logger 'debug str (current-inexact-milliseconds)))) - -(struct compile-event (timestamp path action) #:prefab) -(define (log-compile-event path action) - (when (log-level? cm-logger 'info 'compiler/cm) - (log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path) - (compile-event (current-inexact-milliseconds) path action)))) - -(define manager-compile-notify-handler (make-parameter void)) -(define manager-trace-handler (make-parameter default-manager-trace-handler)) -(define indent (make-parameter 0)) -(define trust-existing-zos (make-parameter #f)) -(define manager-skip-file-handler (make-parameter (λ (x) #f))) -(define depth (make-parameter 0)) -(define parallel-lock-client (make-parameter #f)) - -(define managed-compiled-context-key (gensym)) -(define (make-compilation-context-error-display-handler orig) - (lambda (str exn) - (define l (continuation-mark-set->list - (exn-continuation-marks exn) - managed-compiled-context-key)) - (orig (if (null? l) - str - (apply - string-append - str - "\n compilation context...:" - (for/list ([i (in-list l)]) - (format "\n ~a" i)))) - exn))) - (define (file-stamp-in-collection p) (file-stamp-in-paths p (current-library-collection-paths))) -(define (try-file-time p) - (let ([s (file-or-directory-modify-seconds p #f (lambda () #f))]) - (and s - (if (eq? (use-compiled-file-check) 'modify-seconds) - s - 0)))) - (define (file-stamp-in-paths p paths) (let ([p-eles (explode-path (simple-form-path p))]) (let c-loop ([paths paths]) @@ -163,19 +98,6 @@ [else (c-loop (cdr paths))])]))])))) -(define (path*->collects-relative p) - (if (bytes? p) - (let ([q (path->collects-relative (bytes->path p))]) - (if (path? q) - (path->bytes q) - q)) - (path->collects-relative p))) - -(define (collects-relative*->path p cache) - (if (bytes? p) - (bytes->path p) - (hash-ref! cache p (lambda () (collects-relative->path p))))) - (define (reroot-path* base root) (cond [(eq? root 'same) base] @@ -184,668 +106,7 @@ [else (reroot-path base root)])) -(define (trace-printf fmt . args) - (let ([t (manager-trace-handler)]) - (unless (or (eq? t void) - (and (equal? t default-manager-trace-handler) - (not (log-level? cm-logger 'debug)))) - (t (string-append (get-indent-string) - (apply format fmt args)))))) - -(define (get-indent-string) - (build-string (indent) - (λ (x) - (if (and (= 2 (modulo x 3)) - (not (= x (- (indent) 1)))) - #\| - #\space)))) - -(define (get-deps code path) - (define ht - (let loop ([code code] [ht (hash)]) - (define new-ht - (for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))] - [x (in-list (cdr imports))]) - (let* ([r (resolve-module-path-index x path)] - [r (if (pair? r) (cadr r) r)]) - (if (and (path? r) - (not (equal? path r)) - (not (equal? path r)) - (not (equal? path (rkt->ss r)))) - (hash-set ht (path->bytes r) #t) - ht)))) - (for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))] - [subcode (in-list (module-compiled-submodules code non-star?))]) - (loop subcode ht)))) - (for/list ([k (in-hash-keys ht)]) k)) - -(define (get-compilation-path path->mode roots path) - (let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)]) - (build-path dir name))) - -(define (touch path) - (when (eq? 'modify-seconds (use-compiled-file-check)) - (with-compiler-security-guard - (file-or-directory-modify-seconds - path - (current-seconds) - (lambda () - (close-output-port (open-output-file path #:exists 'append))))))) - -(define (try-delete-file path [noisy? #t]) - ;; Attempt to delete, but give up if it doesn't work: - (with-handlers ([exn:fail:filesystem? void]) - (when noisy? (trace-printf "deleting ~a" path)) - (with-compiler-security-guard (delete-file path)))) - -(define (compilation-failure path->mode roots path zo-name date-path reason) - (try-delete-file zo-name) - (trace-printf "failure")) - -;; with-compile-output : path (output-port path -> alpha) -> alpha -(define (with-compile-output path proc) - (call-with-atomic-output-file - path - #:security-guard (pick-security-guard) - proc)) - -(define-syntax-rule - (with-compiler-security-guard expr) - (parameterize ([current-security-guard (pick-security-guard)]) - expr)) - -(define compiler-security-guard (make-parameter #f)) - -(define (pick-security-guard) - (or (compiler-security-guard) - (current-security-guard))) - -(define (get-source-sha1 p) - (with-handlers ([exn:fail:filesystem? (lambda (exn) - (and (path-has-extension? p #".rkt") - (get-source-sha1 (path-replace-extension p #".ss"))))]) - (call-with-input-file* p sha1))) - -(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen) - (let ([l (for/fold ([l null]) ([dep (in-list deps)]) - (and l - (let* ([ext? (external-dep? dep)] - [p (collects-relative*->path (dep->encoded-path dep) collection-cache)]) - (cond - [ext? (let ([v (get-source-sha1 p)]) - (cond - [v (cons (cons (delay v) dep) l)] - [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] - [else #f]))] - [(or (hash-ref up-to-date (simple-form-path p) #f) - ;; Use `compile-root' with `sha1-only?' as #t: - (compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen)) - => (lambda (sh) - (cons (cons (cdr sh) dep) l))] - [must-exist? - ;; apparently, we're forced to use the source of the module, - ;; so compute a sha1 from it instead of the bytecode - (cons (cons (get-source-sha1 p) dep) l)] - [else #f]))))]) - (and l - (let ([p (open-output-string)] - [l (map (lambda (v) - (let ([sha1 (force (car v))] - [dep (cdr v)]) - (unless sha1 - (error 'cm "no SHA-1 for dependency: ~s" dep)) - (cons sha1 dep))) - l)]) - ;; sort by sha1s so that order doesn't matter - (write (sort l stringmode roots path src-sha1 - external-deps external-module-deps reader-deps - up-to-date collection-cache read-src-syntax) - (let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")] - [deps (remove-duplicates (append (get-deps code path) - external-module-deps ; can create cycles if misused! - reader-deps))] - [external-deps (remove-duplicates external-deps)]) - (define (path*->collects-relative/maybe-indirect dep) - (if (and (pair? dep) (eq? 'indirect (car dep))) - (cons 'indirect (path*->collects-relative (cdr dep))) - (path*->collects-relative dep))) - (with-compile-output dep-path - (lambda (op tmp-path) - (let ([deps (append - (map path*->collects-relative/maybe-indirect deps) - (map (lambda (x) - (define d (path*->collects-relative/maybe-indirect x)) - (if (and (pair? d) (eq? 'indirect d)) - (cons 'indirect (cons 'ext (cdr d))) - (cons 'ext d))) - external-deps))]) - (write (list* (version) - (cons (or src-sha1 (get-source-sha1 path)) - (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash())) - (sort deps s-expdate sec)]) - (format "~a-~a-~a ~a:~a:~a" - (date-year d) (date-month d) (date-day d) - (date-hour d) (date-minute d) (date-second d)))) - -(define (verify-times ss-name zo-name) - (when (eq? 'modify-seconds (use-compiled-file-check)) - (define ss-sec (file-or-directory-modify-seconds ss-name)) - (define zo-sec (try-file-time zo-name)) - (cond [(not ss-sec) (error 'compile-zo "internal error")] - [(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a" - zo-name ss-name)] - [(< zo-sec ss-sec) (error 'compile-zo - "date for newly created .zo file (~a @ ~a) ~ - is before source-file date (~a @ ~a)~a" - zo-name (format-time zo-sec) - ss-name (format-time ss-sec) - (if (> ss-sec (current-seconds)) - ", which appears to be in the future" - ""))]))) - -(define-struct ext-reader-guard (proc top) - #:property prop:procedure (struct-field-index proc)) -(define-struct file-dependency (path module?) #:prefab) -(define-struct (file-dependency/options file-dependency) (table) #:prefab) - -(define (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache) - ;; The `path' argument has been converted to .rkt or .ss form, - ;; as appropriate. - ;; External dependencies registered through reader guard and - ;; accomplice-logged events: - (define external-deps null) - (define external-module-deps null) - (define reader-deps null) - (define deps-sema (make-semaphore 1)) - (define done-key (gensym)) - (define (external-dep! p module? indirect?) - (define bstr (path->bytes p)) - (define dep (if indirect? - (cons 'indirect bstr) - bstr)) - (if module? - (set! external-module-deps (cons dep external-module-deps)) - (set! external-deps (cons dep external-deps)))) - (define (reader-dep! p) - (call-with-semaphore - deps-sema - (lambda () - (set! reader-deps (cons (path->bytes p) reader-deps))))) - - ;; Set up a logger to receive and filter accomplice events: - (define accomplice-logger (make-logger #f (current-logger) - ;; Don't propoagate 'cm-accomplice events, so that - ;; enclosing compilations don't see events intended - ;; for this one: - 'none 'cm-accomplice - ;; Propagate everything else: - 'debug)) - (define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice)) - - ;; Compile the code: - (define code - (parameterize ([current-reader-guard - (let* ([rg (current-reader-guard)] - [rg (if (ext-reader-guard? rg) - (ext-reader-guard-top rg) - rg)]) - (make-ext-reader-guard - (lambda (d) - ;; Start by calling the top installed guard to - ;; transform the module path, avoiding redundant - ;; dependencies by avoiding accumulation of these - ;; guards. - (let ([d (rg d)]) - (when (module-path? d) - (let* ([p (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join d #f)))] - [p (if (pair? p) - ;; Create a dependency only if - ;; the corresponding submodule is - ;; declared: - (if (module-declared? d #t) - (car p) - #f) - p)]) - (when (path? p) (reader-dep! p)))) - d)) - rg))] - [current-logger accomplice-logger]) - (with-continuation-mark - managed-compiled-context-key - path - (get-module-code path (path->mode path) compile - (lambda (a b) #f) ; extension handler - #:source-reader read-src-syntax)))) - (define dest-roots (list (car roots))) - (define code-dir (get-compilation-dir path #:modes (list (path->mode path)) #:roots dest-roots)) - - ;; Get all accomplice data: - (let loop () - (let ([l (sync/timeout 0 receiver)]) - (when l - (when (and (eq? (vector-ref l 0) 'info) - (file-dependency? (vector-ref l 2)) - (path? (file-dependency-path (vector-ref l 2)))) - (external-dep! (file-dependency-path (vector-ref l 2)) - (file-dependency-module? (vector-ref l 2)) - (and (file-dependency/options? (vector-ref l 2)) - (hash-ref (file-dependency/options-table (vector-ref l 2)) - 'indirect - #f)))) - (loop)))) - - ;; Write the code and dependencies: - (when code - (with-compiler-security-guard (make-directory* code-dir)) - (with-compile-output zo-name - (lambda (out tmp-name) - (with-handlers ([exn:fail? - (lambda (ex) - (close-output-port out) - (compilation-failure path->mode dest-roots path zo-name #f - (exn-message ex)) - (raise ex))]) - (parameterize ([current-write-relative-directory - (let* ([dir - (let-values ([(base name dir?) (split-path path)]) - (if (eq? base 'relative) - (current-directory) - (path->complete-path base (current-directory))))] - [collects-dir (find-collects-dir)] - [e-dir (explode-path dir)] - [e-collects-dir (explode-path collects-dir)]) - (if (and ((length e-dir) . > . (length e-collects-dir)) - (for/and ([a (in-list e-dir)] - [b (in-list e-collects-dir)]) - (equal? a b))) - ;; `dir' extends `collects-dir': - (cons dir collects-dir) - ;; `dir' doesn't extend `collects-dir': - dir))]) - (let ([b (open-output-bytes)]) - ;; Write bytecode into string - (write code b) - ;; Compute SHA1 over modules within bytecode - (let* ([s (get-output-bytes b)]) - (install-module-hashes! s) - ;; Write out the bytecode with module hash - (write-bytes s out))))) - ;; redundant, but close as early as possible: - (close-output-port out) - ;; Note that we check time and write .deps before returning from - ;; with-compile-output... - (verify-times path tmp-name) - (write-deps code path->mode dest-roots path src-sha1 - external-deps external-module-deps reader-deps - up-to-date collection-cache read-src-syntax))) - (trace-printf "wrote zo file: ~a" zo-name))) - -(define (install-module-hashes! s [start 0] [len (bytes-length s)]) - (define vlen (bytes-ref s (+ start 2))) - (define mode (integer->char (bytes-ref s (+ start 3 vlen)))) - (case mode - [(#\T) - ;; A single module: - (define h (sha1-bytes (open-input-bytes (if (and (zero? start) - (= len (bytes-length s))) - s - (subbytes s start (+ start len)))))) - ;; Write sha1 for module hash: - (bytes-copy! s (+ start 4 vlen) h)] - [(#\D) - ;; A directory form modules and submodules. The format starts with , - ;; and then it's records of the format: - ;; - (define (read-num rel-pos) - (define pos (+ start rel-pos)) - (integer-bytes->integer s #t #f pos (+ pos 4))) - (define count (read-num (+ 4 vlen))) - (for/fold ([pos (+ 8 vlen)]) ([i (in-range count)]) - (define pos-pos (+ pos 4 (read-num pos))) - (define mod-start (read-num pos-pos)) - (define mod-len (read-num (+ pos-pos 4))) - (install-module-hashes! s (+ start mod-start) mod-len) - (+ pos-pos 16)) - (void)] - [else - ;; ?? unknown mode - (void)])) - -(define (actual-source-path path) - (if (file-exists? path) - path - (let ([alt-path (rkt->ss path)]) - (if (file-exists? alt-path) - alt-path - path)))) - -(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen) - (let ([actual-path (actual-source-path orig-path)]) - (unless sha1-only? - ((manager-compile-notify-handler) actual-path) - (trace-printf "maybe-compile-zo starting ~a" actual-path)) - (begin0 - (parameterize ([indent (+ 2 (indent))]) - (let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")] - [zo-exists? (file-exists? zo-name)]) - (if (and zo-exists? (trust-existing-zos)) - (begin - (trace-printf "trusting: ~a" zo-name) - (touch zo-name) - #f) - (let ([src-sha1 (and zo-exists? - deps - (cadr deps) - (get-source-sha1 path))]) - (if (and zo-exists? - src-sha1 - (equal? src-sha1 (and (pair? (cadr deps)) - (caadr deps))) - (equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen) - (cdadr deps))) - (begin - (trace-printf "hash-equivalent: ~a" zo-name) - (touch zo-name) - #f) - ((if sha1-only? values (lambda (build) (build) #f)) - (lambda () - (let* ([lc (parallel-lock-client)] - [_ (when lc (log-compile-event path 'locking))] - [locked? (and lc (lc 'lock zo-name))] - [ok-to-compile? (or (not lc) locked?)]) - (dynamic-wind - (lambda () (void)) - (lambda () - (when ok-to-compile? - (log-compile-event path 'start-compile) - (when zo-exists? (try-delete-file zo-name #f)) - (trace-printf "compiling ~a" actual-path) - (parameterize ([depth (+ (depth) 1)]) - (with-handlers - ([exn:get-module-code? - (lambda (ex) - (compilation-failure path->mode roots path zo-name - (exn:get-module-code-path ex) - (exn-message ex)) - (raise ex))]) - (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache))) - (trace-printf "compiled ~a" actual-path))) - (lambda () - (when lc - (log-compile-event path (if locked? 'finish-compile 'already-done))) - (when locked? - (lc 'unlock zo-name)))))))))))) - (unless sha1-only? - (trace-printf "maybe-compile-zo finished ~a" actual-path))))) - -(define (get-compiled-time path->mode roots path) - (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) - (or (try-file-time (build-path dir "native" (system-library-subpath) - (path-add-extension name (system-type - 'so-suffix)))) - (try-file-time (build-path dir (path-add-extension name #".zo"))))) - -(define (try-file-sha1 path dep-path) - (with-module-reading-parameterization - (lambda () - (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) - (string-append - (call-with-input-file* path sha1) - (with-handlers ([exn:fail:filesystem? (lambda (exn) "")]) - (call-with-input-file* dep-path (lambda (p) (cdadr (read p)))))))))) - -(define (get-compiled-sha1 path->mode roots path) - (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) - (let ([dep-path (build-path dir (path-add-extension name #".dep"))]) - (or (try-file-sha1 (build-path dir "native" (system-library-subpath) - (path-add-extension name (system-type - 'so-suffix))) - dep-path) - (try-file-sha1 (build-path dir (path-add-extension name #".zo")) - dep-path) - ""))) - -(define (different-source-sha1-and-dep-recorded path deps) - (define src-hash (get-source-sha1 path)) - (define recorded-hash (and (pair? (cadr deps)) - (caadr deps))) - (if (equal? src-hash recorded-hash) - #f - (list src-hash recorded-hash))) - -(define (rkt->ss p) - (if (path-has-extension? p #".rkt") - (path-replace-extension p #".ss") - p)) - -(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen) - (define orig-path (simple-form-path path0)) - (define (read-deps path) - (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) - (with-module-reading-parameterization - (lambda () - (call-with-input-file* - (path-add-extension (get-compilation-path path->mode roots path) #".dep") - read))))) - (define (do-check) - (let* ([main-path orig-path] - [alt-path (rkt->ss orig-path)] - [main-path-time (try-file-time main-path)] - [alt-path-time (and (not main-path-time) - (not (eq? alt-path main-path)) - (try-file-time alt-path))] - [path (if alt-path-time alt-path main-path)] - [path-time (or main-path-time alt-path-time)] - [path-zo-time (get-compiled-time path->mode roots path)]) - (cond - [(hash-ref seen path #f) - (error 'compile-zo - "dependency cycle\n involves module: ~a" - path) - #f] - [(not path-time) - (trace-printf "~a does not exist" orig-path) - (or (hash-ref up-to-date orig-path #f) - (let ([stamp (cons (or path-zo-time +inf.0) - (delay (get-compiled-sha1 path->mode roots path)))]) - (hash-set! up-to-date main-path stamp) - (unless (eq? main-path alt-path) - (hash-set! up-to-date alt-path stamp)) - stamp))] - [else - (let ([deps (read-deps path)] - [new-seen (hash-set seen path #t)]) - (define build - (cond - [(not (and (pair? deps) (equal? (version) (car deps)))) - (lambda () - (trace-printf "newer version...") - (maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] - [(> path-time (or path-zo-time -inf.0)) - (trace-printf "newer src... ~a > ~a" path-time path-zo-time) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] - [(different-source-sha1-and-dep-recorded path deps) - => (lambda (difference) - (trace-printf "different src hash... ~a" difference) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] - [(ormap-strict - (lambda (p) - (define ext? (external-dep? p)) - (define d (collects-relative*->path (dep->encoded-path p) collection-cache)) - (define t - (if ext? - (cons (or (try-file-time d) +inf.0) #f) - (compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen))) - (and t - (car t) - (> (car t) (or path-zo-time -inf.0)) - (begin (trace-printf "newer: ~a (~a > ~a)..." - d (car t) path-zo-time) - #t))) - (cddr deps)) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] - [else #f])) - (cond - [(and build sha1-only?) #f] - [else - (when build (build)) - (let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0) - (delay (get-compiled-sha1 path->mode roots path)))]) - (hash-set! up-to-date main-path stamp) - (unless (eq? main-path alt-path) - (hash-set! up-to-date alt-path stamp)) - stamp)]))]))) - (or (hash-ref up-to-date orig-path #f) - (let ([v ((manager-skip-file-handler) orig-path)]) - (and v - (hash-set! up-to-date orig-path v) - v)) - (begin (trace-printf "checking: ~a" orig-path) - (do-check)))) - -(define (ormap-strict f l) - (cond - [(null? l) #f] - [else - (define a (f (car l))) - (define b (ormap-strict f (cdr l))) - (or a b)])) - -(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) - ((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo)) - -(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) - (let ([cache (make-hash)] - [collection-cache (make-hash)]) - (lambda (src) - (parameterize ([current-load/use-compiled - (make-compilation-manager-load/use-compiled-handler/table - cache - collection-cache - #f - #:security-guard security-guard)] - [error-display-handler - (make-compilation-context-error-display-handler - (error-display-handler))]) - (compile-root (or (current-path->mode) - (let ([mode (car (use-compiled-file-paths))]) - (λ (pth) mode))) - (current-compiled-file-roots) - (path->complete-path src) - cache - collection-cache - read-src-syntax - #f - #hash()) - (void))))) - -(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f] - #:security-guard - [security-guard #f]) - (make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash) - delete-zos-when-rkt-file-does-not-exist? - #:security-guard security-guard)) - -(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache - delete-zos-when-rkt-file-does-not-exist? - #:security-guard [security-guard #f]) - - - (define cp->m (current-path->mode)) - (define modes (use-compiled-file-paths)) - (when (and (not cp->m) (null? modes)) - (raise-mismatch-error 'make-compilation-manager-... - "use-compiled-file-paths is '() and current-path->mode is #f")) - (define path->mode (or cp->m (λ (p) (car modes)))) - (let ([orig-eval (current-eval)] - [orig-load (current-load)] - [orig-registry (namespace-module-registry (current-namespace))] - [default-handler (current-load/use-compiled)] - [roots (current-compiled-file-roots)]) - (define (compilation-manager-load-handler path mod-name) - (cond [(or (not mod-name) - ;; Don't trigger compilation if we're not supposed to work with source: - (and (pair? mod-name) - (not (car mod-name)))) - (trace-printf "skipping: ~a mod-name ~s" path mod-name)] - [(not (or (file-exists? path) - (let ([p2 (rkt->ss path)]) - (and (not (eq? path p2)) - (file-exists? p2))))) - (trace-printf "skipping: ~a file does not exist" path) - (when delete-zos-when-rkt-file-does-not-exist? - (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo")) - (when (file-exists? to-delete) - (trace-printf "deleting: ~s" to-delete) - (with-compiler-security-guard (delete-file to-delete))))] - [(if cp->m - (not (equal? (current-path->mode) cp->m)) - (let ([current-cfp (use-compiled-file-paths)]) - (or (null? current-cfp) - (not (equal? (car current-cfp) (car modes)))))) - (if cp->m - (trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s" - path (current-path->mode) cp->m) - (trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s" - path - (use-compiled-file-paths) - (car modes)))] - [(not (equal? roots (current-compiled-file-roots))) - (trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s" - path - (current-compiled-file-roots) - roots)] - [(not (eq? compilation-manager-load-handler - (current-load/use-compiled))) - (trace-printf "skipping: ~a current-load/use-compiled changed ~s" - path (current-load/use-compiled))] - [(not (eq? orig-eval (current-eval))) - (trace-printf "skipping: ~a orig-eval ~s current-eval ~s" - path orig-eval (current-eval))] - [(not (eq? orig-load (current-load))) - (trace-printf "skipping: ~a orig-load ~s current-load ~s" - path orig-load (current-load))] - [(not (eq? orig-registry - (namespace-module-registry (current-namespace)))) - (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" - path orig-registry - (namespace-module-registry (current-namespace)))] - [else - (trace-printf "processing: ~a" path) - (parameterize ([compiler-security-guard security-guard]) - (compile-root path->mode roots path cache collection-cache read-syntax #f #hash())) - (trace-printf "done: ~a" path)]) - (default-handler path mod-name)) - (when (null? roots) - (raise-mismatch-error 'make-compilation-manager-... - "empty current-compiled-file-roots list: " - roots)) - compilation-manager-load-handler)) - - -;; Exported: -(define (get-compiled-file-sha1 path) - (try-file-sha1 path (path-replace-extension path #".dep"))) - -(define (get-file-sha1 path) - (get-source-sha1 path)) +;; ---------------------------------------- (define (make-compile-lock) (define-values (manager-side-chan build-side-chan) (place-channel)) diff -Nru racket-6.12+ppa1/collects/compiler/depend.rkt racket-7.0+ppa1/collects/compiler/depend.rkt --- racket-6.12+ppa1/collects/compiler/depend.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/depend.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,37 @@ +#lang racket/base +(require compiler/compilation-path + compiler/private/dep + setup/collects) + +(provide module-recorded-dependencies) + +(define (module-recorded-dependencies path) + (define collection-cache (make-hash)) + (define (module-dependencies path all-deps) + (define dep-path (path-add-extension (get-compilation-path path) #".dep")) + (define deps (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)] + [exn:fail:read? (lambda (exn) #f)]) + (call-with-input-file* dep-path read))) + (for/fold ([all-deps all-deps]) ([dep (in-list (if (and (list? deps) + (pair? deps) + (pair? (cdr deps))) + (cddr deps) + '()))]) + (define p (collects-relative*->path (dep->encoded-path dep) collection-cache)) + (cond + [(hash-ref all-deps p #f) all-deps] + [else + (define new-deps (hash-set all-deps p #t)) + (cond + [(external-dep? dep) new-deps] + [else (module-dependencies p new-deps)])]))) + (hash-keys (module-dependencies (simplify-path path) #hash()))) + +(define (get-compilation-path path) + (define-values (dir name) (get-compilation-dir+name path)) + (build-path dir name)) + +(define (collects-relative*->path p cache) + (if (bytes? p) + (bytes->path p) + (hash-ref! cache p (lambda () (collects-relative->path p))))) diff -Nru racket-6.12+ppa1/collects/compiler/distribute.rkt racket-7.0+ppa1/collects/compiler/distribute.rkt --- racket-6.12+ppa1/collects/compiler/distribute.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/distribute.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,12 +7,12 @@ setup/cross-system pkg/path setup/main-collects - dynext/filename-version "private/macfw.rkt" "private/windlldir.rkt" "private/elf.rkt" "private/collects-path.rkt" - "private/write-perm.rkt") + "private/write-perm.rkt" + "private/win-dll-list.rkt") (provide assemble-distribution) @@ -32,7 +32,7 @@ (case (cross-system-type) [(windows) #f] [(unix) "bin"] - [(macosx) (if (memq type '(gracketcgc gracket3m)) + [(macosx) (if (memq type '(gracketcgc gracket3m gracketcs)) #f "bin")]))) orig-binaries @@ -48,7 +48,7 @@ (make-directory dest-dir)) (let-values ([(base name dir?) (split-path b)]) (let ([dest (build-path dest-dir name)]) - (if (and (memq type '(gracketcgc gracket3m)) + (if (and (memq type '(gracketcgc gracket3m gracketcs)) (eq? 'macosx (cross-system-type))) (begin (copy-app b dest) @@ -67,7 +67,7 @@ [single-mac-app? (and executables? (eq? 'macosx (cross-system-type)) (= 1 (length types)) - (memq (car types) '(gracketcgc gracket3m)))]) + (memq (car types) '(gracketcgc gracket3m gracketcs)))]) ;; Create directories for libs, collects, and extensions: (let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir) (if single-mac-app? @@ -106,12 +106,17 @@ relative-collects-dir (build-path dest-dir specific-lib-dir "exts") (build-path specific-lib-dir "exts"))))]) - (make-directory* lib-dir) - (make-directory* collects-dir) - (make-directory* exts-dir) ;; Copy libs into place - (install-libs lib-dir types (not executables?)) + (install-libs lib-dir types + #:extras-only? (not executables?) + #:no-dlls? (and (eq? 'windows (cross-system-type)) + executables? + ;; If all executables have "" the the + ;; DLL dir, then no base DLLS are needed + (for/and ([f (in-list orig-binaries)]) + (current-no-dlls? f)))) ;; Copy collections into place + (unless (null? copy-collects) (make-directory* collects-dir)) (for-each (lambda (dir) (for-each (lambda (f) (copy-directory/files* @@ -131,7 +136,7 @@ [sub-dir (build-path 'up relative-dir)] [(and (eq? 'macosx (cross-system-type)) - (memq type '(gracketcgc gracket3m)) + (memq type '(gracketcgc gracket3m gracketcs)) (not single-mac-app?)) (build-path 'up 'up 'up relative-dir)] [else @@ -161,48 +166,35 @@ ;; Done! (void)))))) - (define (install-libs lib-dir types extras-only?) + (define (install-libs lib-dir types + #:extras-only? extras-only? + #:no-dlls? no-dlls?) (case (cross-system-type) [(windows) - (let ([copy-dll (lambda (name) - (copy-file* (search-dll (find-cross-dll-dir) name) - (build-path lib-dir name)))] - [versionize (lambda (template) - (let ([f (search-dll (find-cross-dll-dir) - (format template filename-version-part))]) - (if (file-exists? f) - (format template filename-version-part) - (format template "xxxxxxx"))))]) - (map copy-dll (list - "libiconv-2.dll" - "longdouble.dll")) - (unless extras-only? - (when (or (memq 'racketcgc types) - (memq 'gracketcgc types)) - (map copy-dll - (list - (versionize "libracket~a.dll") - (versionize "libmzgc~a.dll")))) - (when (or (memq 'racket3m types) - (memq 'gracket3m types)) - (map copy-dll - (list - (versionize "libracket3m~a.dll"))))))] + (if no-dlls? + '() + (let ([copy-dll (lambda (name) + (make-directory* lib-dir) + (copy-file* (search-dll name) + (build-path lib-dir name)))]) + (map copy-dll (get-racket-dlls types #:extras-only? extras-only?))))] [(macosx) (unless extras-only? (when (or (memq 'racketcgc types) (memq 'gracketcgc types)) - (copy-framework "Racket" #f lib-dir)) + (copy-framework "Racket" 'cgc lib-dir)) (when (or (memq 'racket3m types) (memq 'gracket3m types)) - (copy-framework "Racket" #t lib-dir)))] + (copy-framework "Racket" '3m lib-dir)) + (when (or (memq 'racketcs types) + (memq 'gracketcs types)) + (copy-framework "Racket" 'cs lib-dir)))] [(unix) (unless extras-only? (let ([lib-plt-dir (build-path lib-dir "plt")]) - (unless (directory-exists? lib-plt-dir) - (make-directory lib-plt-dir)) (let ([copy-bin (lambda (name variant gr?) + (make-directory* lib-plt-dir) (copy-file* (build-path (if gr? (find-lib-dir) (find-console-bin-dir)) @@ -213,10 +205,14 @@ (copy-bin "racket" 'cgc #f)) (when (memq 'racket3m types) (copy-bin "racket" '3m #f)) + (when (memq 'racketcs types) + (copy-bin "racket" 'cs #f)) (when (memq 'gracketcgc types) (copy-bin "gracket" 'cgc #t)) (when (memq 'gracket3m types) - (copy-bin "gracket" '3m #t))) + (copy-bin "gracket" '3m #t)) + (when (memq 'gracketcs types) + (copy-bin "gracket" 'cs #t))) (when (shared-libraries?) (when (or (memq 'racketcgc types) (memq 'gracketcgc types)) @@ -224,36 +220,18 @@ (copy-shared-lib "mzgc" lib-dir)) (when (or (memq 'racket3m types) (memq 'gracket3m types)) - (copy-shared-lib "racket3m" lib-dir)))))])) + (copy-shared-lib "racket3m" lib-dir)) + (when (or (memq 'racketcs types) + (memq 'gracketcs types)) + (copy-shared-lib "racketcs" lib-dir)))))])) - (define (search-dll dll-dir dll) - (if dll-dir - (build-path dll-dir dll) - (let* ([exe-dir - (let ([exec (path->complete-path - (find-executable-path (find-system-path 'exec-file)) - (find-system-path 'orig-dir))]) - (let-values ([(base name dir?) (split-path exec)]) - base))] - [paths (cons - exe-dir - (path-list-string->path-list - (or (getenv "PATH") "") - (list (find-system-path 'sys-dir))))]) - (or (ormap (lambda (p) - (let ([p (build-path p dll)]) - (and (file-exists? p) - p))) - paths) - ;; Can't find it, so just use executable's dir: - (build-path exe-dir dll))))) - - (define (copy-framework name 3m? lib-dir) + (define (copy-framework name variant lib-dir) (let* ([fw-name (format "~a.framework" name)] [sub-dir (build-path fw-name "Versions" - (if 3m? - (format "~a_3m" (version)) - (version)))]) + (case variant + [(3m) (format "~a_3m" (version))] + [(cs) (format "~a_CS" (version))] + [else (version)]))]) (make-directory* (build-path lib-dir sub-dir)) (let* ([fw-name (build-path sub-dir (format "~a" name))] [dll-dir (find-framework fw-name)]) @@ -282,6 +260,7 @@ (define avail-lib-files #f) (define (copy-shared-lib name lib-dir) + (make-directory* lib-dir) (unless avail-lib-files (set! avail-lib-files (directory-list (find-cross-dll-dir)))) (let* ([rx (byte-regexp (string->bytes/latin-1 @@ -304,22 +283,23 @@ (case (cross-system-type) [(windows) (for-each (lambda (b) - (update-dll-dir b "lib")) + (unless (current-no-dlls? b) + (update-dll-dir b "lib"))) binaries)] [(macosx) (if (and (= 1 (length types)) - (memq (car types) '(gracketcgc gracket3m))) + (memq (car types) '(gracketcgc gracket3m gracketcs))) ;; Special case for single GRacket app: (update-framework-path "@executable_path/../Frameworks/" (car binaries) #t) ;; General case: (for-each (lambda (b type) - (update-framework-path (if (memq type '(racketcgc racket3m)) + (update-framework-path (if (memq type '(racketcgc racket3m racketcs)) "@executable_path/../lib/" "@executable_path/../../../lib/" ) b - (memq type '(gracketcgc gracket3m)))) + (memq type '(gracketcgc gracket3m gracketcs)))) binaries types))] [(unix) (for-each (lambda (b type) @@ -645,14 +625,19 @@ (error 'assemble-distribution "file is an original PLT executable, not a stub binary: ~e" b))) - (let ([3m? (equal? (list-ref m 4) #"3")]) + (let ([variant (case (list-ref m 4) + [(#"3") '3m] + [(#"s") 'cs] + [else 'cgc])]) (if (equal? (caddr m) #"r") - (if 3m? - 'gracket3m - 'gracketcgc) - (if 3m? - 'racket3m - 'racketcgc)))) + (case variant + [(3m) 'gracket3m] + [(cs) 'gracketcs] + [else 'gracketcgc]) + (case variant + [(3m) 'racket3m] + [(cs) 'racketcs] + [else 'racketcgc])))) (error 'assemble-distribution "file is not a PLT executable: ~e" b)))))) diff -Nru racket-6.12+ppa1/collects/compiler/embed.rkt racket-7.0+ppa1/collects/compiler/embed.rkt --- racket-6.12+ppa1/collects/compiler/embed.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/embed.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -22,9 +22,9 @@ "private/collects-path.rkt" "private/configdir.rkt" "private/write-perm.rkt" + "private/win-dll-list.rkt" "find-exe.rkt") - (provide/contract [make-embedding-executable (->* (path-string? any/c @@ -60,7 +60,7 @@ #:cmdline (listof string?) #:gracket? any/c #:mred? any/c - #:variant (or/c '3m 'cgc) + #:variant (or/c '3m 'cgc 'cs) #:aux (listof (cons/c symbol? any/c)) #:collects-path (or/c #f path-string? @@ -558,7 +558,7 @@ [_else (error 'create-empbedding-executable "expansion mismatch when getting external paths: ~e" (syntax->datum e))]))))] - + [extra-runtime-paths (filter values (map (lambda (p) @@ -1116,7 +1116,8 @@ early-literal-expressions config? literal-files literal-expressions collects-dest on-extension program-name compiler expand-namespace - src-filter get-extra-imports on-decls-done) + src-filter get-extra-imports on-decls-done + embedded-dlls-box) (let* ([program-name-bytes (if program-name (path->bytes program-name) #"?")] @@ -1248,7 +1249,15 @@ p))) (let ([p (cond [(bytes? p) (bytes->path p)] - [(so-spec? p) (so-find p)] + [(so-spec? p) + (define path (so-find p)) + (cond + [(and path embedded-dlls-box) + (set-box! embedded-dlls-box (cons path (unbox embedded-dlls-box))) + ;; Don't record the path in the executable since we'll + ;; record the whole DLL in the executable + #f] + [else path])] [(and (list? p) (eq? 'lib (car p))) (let ([p (if (null? (cddr p)) @@ -1356,7 +1365,8 @@ #f ; program-name compiler expand-namespace src-filter get-extra-imports - void)) + void + #f)) ; don't accumulate embedded DLLs ;; The old interface: @@ -1501,20 +1511,28 @@ "/") dest mred?)))))) + (define embed-dlls? (and (eq? 'windows (cross-system-type)) + (let ([m (assq 'embed-dlls? aux)]) + (and m (cdr m))))) + (define embedded-dlls-box (and embed-dlls? (box null))) (when (eq? 'windows (cross-system-type)) - (let ([m (or (assq 'dll-dir aux) - (and relative? '(dll-dir . #f)))]) - (if m - (if (cdr m) - (update-dll-dir dest (cdr m)) - ;; adjust relative path, since exe directory can change: - (update-dll-dir dest (find-relative-path* dest (find-cross-dll-dir)))) - ;; Check whether we need an absolute path to DLLs: - (let ([dir (get-current-dll-dir dest)]) - (when (relative-path? dir) - (let-values ([(orig-dir name dir?) (split-path - (path->complete-path orig-exe))]) - (update-dll-dir dest (build-path orig-dir dir)))))))) + (cond + [embed-dlls? + (update-dll-dir dest #t)] + [else + (let ([m (or (assq 'dll-dir aux) + (and relative? '(dll-dir . #f)))]) + (if m + (if (cdr m) + (update-dll-dir dest (cdr m)) + ;; adjust relative path, since exe directory can change: + (update-dll-dir dest (find-relative-path* dest (find-cross-dll-dir)))) + ;; Check whether we need an absolute path to DLLs: + (let ([dir (get-current-dll-dir dest)]) + (when (relative-path? dir) + (let-values ([(orig-dir name dir?) (split-path + (path->complete-path orig-exe))]) + (update-dll-dir dest (build-path orig-dir dir)))))))])) (define (adjust-config-dir) (let ([m (or (assq 'config-dir aux) (and relative? '(config-dir . #f)))] @@ -1567,7 +1585,8 @@ expand-namespace src-filter get-extra-imports - (lambda (outp) (set! pos (file-position outp)))) + (lambda (outp) (set! pos (file-position outp))) + embedded-dlls-box) pos)] [make-full-cmdline (lambda (start decl-end end) @@ -1638,7 +1657,24 @@ 1 1033 ; U.S. English bstr)) - (update-resources dest-exe pe new-rsrcs) + (define new+dll-rsrcs + (if embed-dlls? + (resource-set new-rsrcs + ;; Racket's "user-defined" type for embedded DLLs: + 258 + 1 + 1033 ; U.S. English + (pack-embedded-dlls + (append + (get-racket-dlls + (list + (case (cross-system-type 'gc) + [(3m) (if mred? 'gracket3m 'racket3m)] + [(cgc) (if mred? 'gracketcgc 'racketcgc)] + [(cs) (if mred? 'gracketcs 'racketcs)]))) + (unbox embedded-dlls-box)))) + new-rsrcs)) + (update-resources dest-exe pe new+dll-rsrcs) (values 0 decl-len init-len (+ init-len cmdline-len))] [(and (eq? (cross-system-type) 'macosx) (not unix-starter?)) @@ -1720,7 +1756,8 @@ (lambda () (find-cmdline "configuration" #"cOnFiG:")))] - [typepos (and (or mred? (eq? variant '3m)) + [typepos (and (or mred? (or (eq? variant '3m) + (eq? variant 'cs))) (with-input-from-file dest-exe (lambda () (find-cmdline "exeuctable type" @@ -1743,6 +1780,9 @@ (when (eq? variant '3m) (file-position out (+ typepos 15)) (write-bytes #"3" out)) + (when (eq? variant 'cs) + (file-position out (+ typepos 15)) + (write-bytes #"s" out)) (flush-output out)) (file-position out (+ numpos 7)) (write-bytes #"!" out) @@ -1824,3 +1864,36 @@ (define (find-relative-path* wrt-exe p) (define-values (wrt base name) (split-path (path->complete-path wrt-exe))) (find-relative-path (simplify-path wrt) (simplify-path p))) + +;; To embed DLLs in the executable as resource ID 258: +(define (pack-embedded-dlls name-or-paths) + (define bstrs (for/list ([p (in-list name-or-paths)]) + (file->bytes (if (string? p) + (search-dll p) + p)))) + (define names (for/list ([p (in-list name-or-paths)]) + (if (string? p) + p + (let-values ([(base name dir) (split-path p)]) + (path-element->string name))))) + (define start-pos (+ 4 ; count + ;; name array: + (for/sum ([p (in-list names)]) + (+ 2 (bytes-length (string->bytes/utf-8 p)))) + ;; starting-position array: + (* 4 (add1 (length names))))) + (define-values (rev-offsets total) + (for/fold ([rev-offsets null] [total start-pos]) ([bstr (in-list bstrs)]) + (values (cons total rev-offsets) + (+ total (bytes-length bstr))))) + (apply + bytes-append + (integer->integer-bytes (length names) 4 #t #f) + (append + (for/list ([p (in-list names)]) + (define bstr (string->bytes/utf-8 p)) + (bytes-append (integer->integer-bytes (bytes-length bstr) 2 #t #f) bstr)) + (for/list ([offset (in-list (reverse rev-offsets))]) + (integer->integer-bytes offset 4 #t #f)) + (list (integer->integer-bytes total 4 #t #f)) + bstrs))) diff -Nru racket-6.12+ppa1/collects/compiler/private/cm-minimal.rkt racket-7.0+ppa1/collects/compiler/private/cm-minimal.rkt --- racket-6.12+ppa1/collects/compiler/private/cm-minimal.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/cm-minimal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,764 @@ +#lang racket/base +(require syntax/private/modcode-noctc + syntax/private/modresolve-noctc + syntax/modread + setup/private/dirs + racket/file + racket/list + racket/path + racket/promise + openssl/sha1 + setup/collects + compiler/compilation-path + compiler/private/dep) + +(provide make-compilation-manager-load/use-compiled-handler + managed-compile-zo + make-caching-managed-compile-zo + trust-existing-zos + manager-compile-notify-handler + manager-skip-file-handler + manager-trace-handler + get-file-sha1 + get-compiled-file-sha1 + with-compile-output + + managed-compiled-context-key + make-compilation-context-error-display-handler + + parallel-lock-client + + install-module-hashes! + + current-path->mode) + +(module+ cm-internal + (provide try-file-time + rkt->ss + get-source-sha1)) + +(define current-path->mode (make-parameter #f)) + +(define cm-logger (make-logger 'compiler/cm (current-logger))) +(define (default-manager-trace-handler str) + (when (log-level? cm-logger 'debug) + (log-message cm-logger 'debug str (current-inexact-milliseconds)))) + +(struct compile-event (timestamp path action) #:prefab) +(define (log-compile-event path action) + (when (log-level? cm-logger 'info 'compiler/cm) + (log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path) + (compile-event (current-inexact-milliseconds) path action)))) + +(define manager-compile-notify-handler (make-parameter void)) +(define manager-trace-handler (make-parameter default-manager-trace-handler)) +(define indent (make-parameter 0)) +(define trust-existing-zos (make-parameter #f)) +(define manager-skip-file-handler (make-parameter (λ (x) #f))) +(define depth (make-parameter 0)) +(define parallel-lock-client (make-parameter #f)) + +(define managed-compiled-context-key (gensym)) +(define (make-compilation-context-error-display-handler orig) + (lambda (str exn) + (define l (continuation-mark-set->list + (exn-continuation-marks exn) + managed-compiled-context-key)) + (orig (if (null? l) + str + (apply + string-append + str + "\n compilation context...:" + (for/list ([i (in-list l)]) + (format "\n ~a" i)))) + exn))) + +(define (try-file-time p) + (let ([s (file-or-directory-modify-seconds p #f (lambda () #f))]) + (and s + (if (eq? (use-compiled-file-check) 'modify-seconds) + s + 0)))) + +(define (path*->collects-relative p) + (if (bytes? p) + (let ([q (path->collects-relative (bytes->path p))]) + (if (path? q) + (path->bytes q) + q)) + (path->collects-relative p))) + +(define (collects-relative*->path p cache) + (if (bytes? p) + (bytes->path p) + (hash-ref! cache p (lambda () (collects-relative->path p))))) + +(define (trace-printf fmt . args) + (let ([t (manager-trace-handler)]) + (unless (or (eq? t void) + (and (equal? t default-manager-trace-handler) + (not (log-level? cm-logger 'debug)))) + (t (string-append (get-indent-string) + (apply format fmt args)))))) + +(define (get-indent-string) + (build-string (indent) + (λ (x) + (if (and (= 2 (modulo x 3)) + (not (= x (- (indent) 1)))) + #\| + #\space)))) + +(define (get-deps code path) + (define ht + (let loop ([code code] [ht (hash)]) + (define new-ht + (for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))] + [x (in-list (cdr imports))]) + (let* ([r (resolve-module-path-index x path)] + [r (if (pair? r) (cadr r) r)]) + (if (and (path? r) + (not (equal? path r)) + (not (equal? path r)) + (not (equal? path (rkt->ss r)))) + (hash-set ht (path->bytes r) #t) + ht)))) + (for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))] + [subcode (in-list (module-compiled-submodules code non-star?))]) + (loop subcode ht)))) + (for/list ([k (in-hash-keys ht)]) k)) + +(define (get-compilation-path path->mode roots path) + (let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)]) + (build-path dir name))) + +(define (touch path) + (when (eq? 'modify-seconds (use-compiled-file-check)) + (with-compiler-security-guard + (file-or-directory-modify-seconds + path + (current-seconds) + (lambda () + (close-output-port (open-output-file path #:exists 'append))))))) + +(define (try-delete-file path [noisy? #t]) + ;; Attempt to delete, but give up if it doesn't work: + (with-handlers ([exn:fail:filesystem? void]) + (when noisy? (trace-printf "deleting ~a" path)) + (with-compiler-security-guard (delete-file path)))) + +(define (compilation-failure path->mode roots path zo-name date-path reason) + (try-delete-file zo-name) + (trace-printf "failure")) + +;; with-compile-output : path (output-port path -> alpha) -> alpha +(define (with-compile-output path proc) + (call-with-atomic-output-file + path + #:security-guard (pick-security-guard) + proc)) + +(define-syntax-rule + (with-compiler-security-guard expr) + (parameterize ([current-security-guard (pick-security-guard)]) + expr)) + +(define compiler-security-guard (make-parameter #f)) + +(define (pick-security-guard) + (or (compiler-security-guard) + (current-security-guard))) + +(define (get-source-sha1 p) + (with-handlers ([exn:fail:filesystem? (lambda (exn) + (and (path-has-extension? p #".rkt") + (get-source-sha1 (path-replace-extension p #".ss"))))]) + (call-with-input-file* p sha1))) + +(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen) + (let ([l (for/fold ([l null]) ([dep (in-list deps)]) + (and l + (let* ([ext? (external-dep? dep)] + [p (collects-relative*->path (dep->encoded-path dep) collection-cache)]) + (cond + [ext? (let ([v (get-source-sha1 p)]) + (cond + [v (cons (cons (delay v) dep) l)] + [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] + [else #f]))] + [(or (hash-ref up-to-date (simple-form-path p) #f) + ;; Use `compile-root' with `sha1-only?' as #t: + (compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen)) + => (lambda (sh) + (cons (cons (cdr sh) dep) l))] + [must-exist? + ;; apparently, we're forced to use the source of the module, + ;; so compute a sha1 from it instead of the bytecode + (cons (cons (get-source-sha1 p) dep) l)] + [else #f]))))]) + (and l + (let ([p (open-output-string)] + [l (map (lambda (v) + (let ([sha1 (force (car v))] + [dep (cdr v)]) + (unless sha1 + (error 'cm "no SHA-1 for dependency: ~s" dep)) + (cons sha1 dep))) + l)]) + ;; sort by sha1s so that order doesn't matter + (write (sort l stringmode roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date collection-cache read-src-syntax) + (let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")] + [deps (remove-duplicates (append (get-deps code path) + external-module-deps ; can create cycles if misused! + reader-deps))] + [external-deps (remove-duplicates external-deps)]) + (define (path*->collects-relative/maybe-indirect dep) + (if (and (pair? dep) (eq? 'indirect (car dep))) + (cons 'indirect (path*->collects-relative (cdr dep))) + (path*->collects-relative dep))) + (with-compile-output dep-path + (lambda (op tmp-path) + (let ([deps (append + (map path*->collects-relative/maybe-indirect deps) + (map (lambda (x) + (define d (path*->collects-relative/maybe-indirect x)) + (if (and (pair? d) (eq? 'indirect d)) + (cons 'indirect (cons 'ext (cdr d))) + (cons 'ext d))) + external-deps))]) + (write (list* (version) + (cons (or src-sha1 (get-source-sha1 path)) + (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash())) + (sort deps s-expdate sec)]) + (format "~a-~a-~a ~a:~a:~a" + (date-year d) (date-month d) (date-day d) + (date-hour d) (date-minute d) (date-second d)))) + +(define (verify-times ss-name zo-name) + (when (eq? 'modify-seconds (use-compiled-file-check)) + (define ss-sec (file-or-directory-modify-seconds ss-name)) + (define zo-sec (try-file-time zo-name)) + (cond [(not ss-sec) (error 'compile-zo "internal error")] + [(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a" + zo-name ss-name)] + [(< zo-sec ss-sec) (error 'compile-zo + "date for newly created .zo file (~a @ ~a) ~ + is before source-file date (~a @ ~a)~a" + zo-name (format-time zo-sec) + ss-name (format-time ss-sec) + (if (> ss-sec (current-seconds)) + ", which appears to be in the future" + ""))]))) + +(define-struct ext-reader-guard (proc top) + #:property prop:procedure (struct-field-index proc)) +(define-struct file-dependency (path module?) #:prefab) +(define-struct (file-dependency/options file-dependency) (table) #:prefab) + +(define (compile-zo* path->mode roots path src-sha1 read-src-syntax orig-zo-name up-to-date collection-cache) + ;; The `path' argument has been converted to .rkt or .ss form, + ;; as appropriate. + ;; External dependencies registered through reader guard and + ;; accomplice-logged events: + (define external-deps null) + (define external-module-deps null) + (define reader-deps null) + (define deps-sema (make-semaphore 1)) + (define done-key (gensym)) + (define (external-dep! p module? indirect?) + (define bstr (path->bytes p)) + (define dep (if indirect? + (cons 'indirect bstr) + bstr)) + (if module? + (set! external-module-deps (cons dep external-module-deps)) + (set! external-deps (cons dep external-deps)))) + (define (reader-dep! p) + (call-with-semaphore + deps-sema + (lambda () + (set! reader-deps (cons (path->bytes p) reader-deps))))) + + ;; Set up a logger to receive and filter accomplice events: + (define accomplice-logger (make-logger #f (current-logger) + ;; Don't propoagate 'cm-accomplice events, so that + ;; enclosing compilations don't see events intended + ;; for this one: + 'none 'cm-accomplice + ;; Propagate everything else: + 'debug)) + (define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice)) + + ;; Compile the code: + (define code + (parameterize ([current-reader-guard + (let* ([rg (current-reader-guard)] + [rg (if (ext-reader-guard? rg) + (ext-reader-guard-top rg) + rg)]) + (make-ext-reader-guard + (lambda (d) + ;; Start by calling the top installed guard to + ;; transform the module path, avoiding redundant + ;; dependencies by avoiding accumulation of these + ;; guards. + (let ([d (rg d)]) + (when (module-path? d) + (let* ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join d #f)))] + [p (if (pair? p) + ;; Create a dependency only if + ;; the corresponding submodule is + ;; declared: + (if (module-declared? d #t) + (car p) + #f) + p)]) + (when (path? p) (reader-dep! p)))) + d)) + rg))] + [current-logger accomplice-logger]) + (with-continuation-mark + managed-compiled-context-key + path + (get-module-code path (path->mode path) compile + (lambda (a b) #f) ; extension handler + #:roots (list (car roots)) + #:source-reader read-src-syntax)))) + (define dest-roots (list (car roots))) + (define-values (code-dir code-name) + (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots dest-roots)) + (define zo-name + ;; If we have multiple roots, make sure that compilation uses the first one + (if (pair? (cdr roots)) + (build-path code-dir (path-add-suffix code-name #".zo")) + orig-zo-name)) + + ;; Get all accomplice data: + (let loop () + (let ([l (sync/timeout 0 receiver)]) + (when l + (when (and (eq? (vector-ref l 0) 'info) + (file-dependency? (vector-ref l 2)) + (path? (file-dependency-path (vector-ref l 2)))) + (external-dep! (file-dependency-path (vector-ref l 2)) + (file-dependency-module? (vector-ref l 2)) + (and (file-dependency/options? (vector-ref l 2)) + (hash-ref (file-dependency/options-table (vector-ref l 2)) + 'indirect + #f)))) + (loop)))) + + ;; Write the code and dependencies: + (when code + (with-compiler-security-guard (make-directory* code-dir)) + (with-compile-output zo-name + (lambda (out tmp-name) + (with-handlers ([exn:fail? + (lambda (ex) + (close-output-port out) + (compilation-failure path->mode dest-roots path zo-name #f + (exn-message ex)) + (raise ex))]) + (parameterize ([current-write-relative-directory + (let* ([dir + (let-values ([(base name dir?) (split-path path)]) + (if (eq? base 'relative) + (current-directory) + (path->complete-path base (current-directory))))] + [collects-dir (find-collects-dir)] + [e-dir (explode-path dir)] + [e-collects-dir (explode-path collects-dir)]) + (if (and ((length e-dir) . > . (length e-collects-dir)) + (for/and ([a (in-list e-dir)] + [b (in-list e-collects-dir)]) + (equal? a b))) + ;; `dir' extends `collects-dir': + (cons dir collects-dir) + ;; `dir' doesn't extend `collects-dir': + dir))]) + (let ([b (open-output-bytes)]) + ;; Write bytecode into string + (write code b) + ;; Compute SHA1 over modules within bytecode + (let* ([s (get-output-bytes b)]) + (install-module-hashes! s) + ;; Write out the bytecode with module hash + (write-bytes s out))))) + ;; redundant, but close as early as possible: + (close-output-port out) + ;; Note that we check time and write .deps before returning from + ;; with-compile-output... + (verify-times path tmp-name) + (write-deps code path->mode dest-roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date collection-cache read-src-syntax))) + (trace-printf "wrote zo file: ~a" zo-name))) + +(define (install-module-hashes! s [start 0] [len (bytes-length s)]) + (define vlen (bytes-ref s (+ start 2))) + (define mode (integer->char (bytes-ref s (+ start 3 vlen)))) + (case mode + [(#\B) + ;; A linklet bundle: + (define h (sha1-bytes (open-input-bytes (if (and (zero? start) + (= len (bytes-length s))) + s + (subbytes s start (+ start len)))))) + ;; Write sha1 for bundle hash: + (bytes-copy! s (+ start 4 vlen) h)] + [(#\D) + ;; A linklet directory. The format starts with , + ;; and then it's records of the format: + ;; + (define (read-num rel-pos) + (define pos (+ start rel-pos)) + (integer-bytes->integer s #t #f pos (+ pos 4))) + (define count (read-num (+ 4 vlen))) + (for/fold ([pos (+ 8 vlen)]) ([i (in-range count)]) + (define pos-pos (+ pos 4 (read-num pos))) + (define bund-start (read-num pos-pos)) + (define bund-len (read-num (+ pos-pos 4))) + (install-module-hashes! s (+ start bund-start) bund-len) + (+ pos-pos 16)) + (void)] + [else + ;; ?? unknown mode + (void)])) + +(define (actual-source-path path) + (if (file-exists? path) + path + (let ([alt-path (rkt->ss path)]) + (if (file-exists? alt-path) + alt-path + path)))) + +(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen) + (let ([actual-path (actual-source-path orig-path)]) + (unless sha1-only? + ((manager-compile-notify-handler) actual-path) + (trace-printf "maybe-compile-zo starting ~a" actual-path)) + (begin0 + (parameterize ([indent (+ 2 (indent))]) + (let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")] + [zo-exists? (file-exists? zo-name)]) + (if (and zo-exists? (trust-existing-zos)) + (begin + (trace-printf "trusting: ~a" zo-name) + (touch zo-name) + #f) + (let ([src-sha1 (and zo-exists? + deps + (cadr deps) + (get-source-sha1 path))]) + (if (and zo-exists? + src-sha1 + (equal? src-sha1 (and (pair? (cadr deps)) + (caadr deps))) + (equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen) + (cdadr deps))) + (begin + (trace-printf "hash-equivalent: ~a" zo-name) + (touch zo-name) + #f) + ((if sha1-only? values (lambda (build) (build) #f)) + (lambda () + (let* ([lc (parallel-lock-client)] + [_ (when lc (log-compile-event path 'locking))] + [locked? (and lc (lc 'lock zo-name))] + [ok-to-compile? (or (not lc) locked?)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (when ok-to-compile? + (log-compile-event path 'start-compile) + (when zo-exists? (try-delete-file zo-name #f)) + (trace-printf "compiling ~a" actual-path) + (parameterize ([depth (+ (depth) 1)]) + (with-handlers + ([exn:get-module-code? + (lambda (ex) + (compilation-failure path->mode roots path zo-name + (exn:get-module-code-path ex) + (exn-message ex)) + (raise ex))]) + (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache))) + (trace-printf "compiled ~a" actual-path))) + (lambda () + (log-compile-event path (if (or (not lc) locked?) 'finish-compile 'already-done)) + (when locked? + (lc 'unlock zo-name)))))))))))) + (unless sha1-only? + (trace-printf "maybe-compile-zo finished ~a" actual-path))))) + +(define (get-compiled-time path->mode roots path) + (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) + (or (try-file-time (build-path dir "native" (system-library-subpath) + (path-add-extension name (system-type + 'so-suffix)))) + (try-file-time (build-path dir (path-add-extension name #".zo"))))) + +(define (try-file-sha1 path dep-path) + (with-module-reading-parameterization + (lambda () + (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) + (string-append + (call-with-input-file* path sha1) + (with-handlers ([exn:fail:filesystem? (lambda (exn) "")]) + (call-with-input-file* dep-path (lambda (p) (cdadr (read p)))))))))) + +(define (get-compiled-sha1 path->mode roots path) + (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) + (let ([dep-path (build-path dir (path-add-extension name #".dep"))]) + (or (try-file-sha1 (build-path dir "native" (system-library-subpath) + (path-add-extension name (system-type + 'so-suffix))) + dep-path) + (try-file-sha1 (build-path dir (path-add-extension name #".zo")) + dep-path) + ""))) + +(define (different-source-sha1-and-dep-recorded path deps) + (define src-hash (get-source-sha1 path)) + (define recorded-hash (and (pair? (cadr deps)) + (caadr deps))) + (if (equal? src-hash recorded-hash) + #f + (list src-hash recorded-hash))) + +(define (rkt->ss p) + (if (path-has-extension? p #".rkt") + (path-replace-extension p #".ss") + p)) + +(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen) + (define orig-path (simple-form-path path0)) + (define (read-deps path) + (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) + (with-module-reading-parameterization + (lambda () + (call-with-input-file* + (path-add-extension (get-compilation-path path->mode roots path) #".dep") + read))))) + (define (do-check) + (let* ([main-path orig-path] + [alt-path (rkt->ss orig-path)] + [main-path-time (try-file-time main-path)] + [alt-path-time (and (not main-path-time) + (not (eq? alt-path main-path)) + (try-file-time alt-path))] + [path (if alt-path-time alt-path main-path)] + [path-time (or main-path-time alt-path-time)] + [path-zo-time (get-compiled-time path->mode roots path)]) + (cond + [(hash-ref seen path #f) + (error 'compile-zo + "dependency cycle\n involves module: ~a" + path) + #f] + [(not path-time) + (trace-printf "~a does not exist" orig-path) + (or (hash-ref up-to-date orig-path #f) + (let ([stamp (cons (or path-zo-time +inf.0) + (delay (get-compiled-sha1 path->mode roots path)))]) + (hash-set! up-to-date main-path stamp) + (unless (eq? main-path alt-path) + (hash-set! up-to-date alt-path stamp)) + stamp))] + [else + (let ([deps (read-deps path)] + [new-seen (hash-set seen path #t)]) + (define build + (cond + [(not (and (pair? deps) (equal? (version) (car deps)))) + (lambda () + (trace-printf "newer version...") + (maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] + [(> path-time (or path-zo-time -inf.0)) + (trace-printf "newer src... ~a > ~a" path-time path-zo-time) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] + [(different-source-sha1-and-dep-recorded path deps) + => (lambda (difference) + (trace-printf "different src hash... ~a" difference) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] + [(ormap-strict + (lambda (p) + (define ext? (external-dep? p)) + (define d (collects-relative*->path (dep->encoded-path p) collection-cache)) + (define t + (if ext? + (cons (or (try-file-time d) +inf.0) #f) + (compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen))) + (and t + (car t) + (> (car t) (or path-zo-time -inf.0)) + (begin (trace-printf "newer: ~a (~a > ~a)..." + d (car t) path-zo-time) + #t))) + (cddr deps)) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] + [else #f])) + (cond + [(and build sha1-only?) #f] + [else + (when build (build)) + (let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0) + (delay (get-compiled-sha1 path->mode roots path)))]) + (hash-set! up-to-date main-path stamp) + (unless (eq? main-path alt-path) + (hash-set! up-to-date alt-path stamp)) + stamp)]))]))) + (or (hash-ref up-to-date orig-path #f) + (let ([v ((manager-skip-file-handler) orig-path)]) + (and v + (hash-set! up-to-date orig-path v) + v)) + (begin (trace-printf "checking: ~a" orig-path) + (do-check)))) + +(define (ormap-strict f l) + (cond + [(null? l) #f] + [else + (define a (f (car l))) + (define b (ormap-strict f (cdr l))) + (or a b)])) + +(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) + ((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo)) + +(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) + (let ([cache (make-hash)] + [collection-cache (make-hash)]) + (lambda (src) + (parameterize ([current-load/use-compiled + (make-compilation-manager-load/use-compiled-handler/table + cache + collection-cache + #f + #:security-guard security-guard)] + [error-display-handler + (make-compilation-context-error-display-handler + (error-display-handler))]) + (compile-root (or (current-path->mode) + (let ([mode (car (use-compiled-file-paths))]) + (λ (pth) mode))) + (current-compiled-file-roots) + (path->complete-path src) + cache + collection-cache + read-src-syntax + #f + #hash()) + (void))))) + +(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f] + #:security-guard + [security-guard #f]) + (make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash) + delete-zos-when-rkt-file-does-not-exist? + #:security-guard security-guard)) + +(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache + delete-zos-when-rkt-file-does-not-exist? + #:security-guard [security-guard #f]) + + + (define cp->m (current-path->mode)) + (define modes (use-compiled-file-paths)) + (when (and (not cp->m) (null? modes)) + (raise-mismatch-error 'make-compilation-manager-... + "use-compiled-file-paths is '() and current-path->mode is #f")) + (define path->mode (or cp->m (λ (p) (car modes)))) + (let ([orig-eval (current-eval)] + [orig-load (current-load)] + [orig-registry (namespace-module-registry (current-namespace))] + [default-handler (current-load/use-compiled)] + [roots (current-compiled-file-roots)]) + (define (compilation-manager-load-handler path mod-name) + (cond [(or (not mod-name) + ;; Don't trigger compilation if we're not supposed to work with source: + (and (pair? mod-name) + (not (car mod-name)))) + (trace-printf "skipping: ~a mod-name ~s" path mod-name)] + [(not (or (file-exists? path) + (let ([p2 (rkt->ss path)]) + (and (not (eq? path p2)) + (file-exists? p2))))) + (trace-printf "skipping: ~a file does not exist" path) + (when delete-zos-when-rkt-file-does-not-exist? + (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo")) + (when (file-exists? to-delete) + (trace-printf "deleting: ~s" to-delete) + (with-compiler-security-guard (delete-file to-delete))))] + [(if cp->m + (not (equal? (current-path->mode) cp->m)) + (let ([current-cfp (use-compiled-file-paths)]) + (or (null? current-cfp) + (not (equal? (car current-cfp) (car modes)))))) + (if cp->m + (trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s" + path (current-path->mode) cp->m) + (trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s" + path + (use-compiled-file-paths) + (car modes)))] + [(not (equal? roots (current-compiled-file-roots))) + (trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s" + path + (current-compiled-file-roots) + roots)] + [(not (eq? compilation-manager-load-handler + (current-load/use-compiled))) + (trace-printf "skipping: ~a current-load/use-compiled changed ~s" + path (current-load/use-compiled))] + [(not (eq? orig-eval (current-eval))) + (trace-printf "skipping: ~a orig-eval ~s current-eval ~s" + path orig-eval (current-eval))] + [(not (eq? orig-load (current-load))) + (trace-printf "skipping: ~a orig-load ~s current-load ~s" + path orig-load (current-load))] + [(not (eq? orig-registry + (namespace-module-registry (current-namespace)))) + (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" + path orig-registry + (namespace-module-registry (current-namespace)))] + [else + (trace-printf "processing: ~a" path) + (parameterize ([compiler-security-guard security-guard]) + (compile-root path->mode roots path cache collection-cache read-syntax #f #hash())) + (trace-printf "done: ~a" path)]) + (default-handler path mod-name)) + (when (null? roots) + (raise-mismatch-error 'make-compilation-manager-... + "empty current-compiled-file-roots list: " + roots)) + compilation-manager-load-handler)) + + +;; Exported: +(define (get-compiled-file-sha1 path) + (try-file-sha1 path (path-replace-extension path #".dep"))) + +(define (get-file-sha1 path) + (get-source-sha1 path)) diff -Nru racket-6.12+ppa1/collects/compiler/private/elf.rkt racket-7.0+ppa1/collects/compiler/private/elf.rkt --- racket-6.12+ppa1/collects/compiler/private/elf.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/elf.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -258,6 +258,14 @@ (section-size s))) s))) +;; The `get-data` function takes an offset and must return +;; (values bytes any1 any2) +;; The result of `add-racket-section` is either +;; (values #f #f #f #f) ; => not an ELF file +;; or +;; (values start-pos end-pos any1 any2) +;; where `any1` and `any2` are return through +;; from `get-data`. (define (add-racket-section src-file dest-file section-name get-data) (call-with-input-file* src-file @@ -275,7 +283,7 @@ void))))))) (define (expand-elf in dest-file - ;; Current state parted from `in`: + ;; Current state parsed from `in`: elf sections programs str-section strs total-size ;; New state: section-name ; #f or name of new section diff -Nru racket-6.12+ppa1/collects/compiler/private/macfw.rkt racket-7.0+ppa1/collects/compiler/private/macfw.rkt --- racket-6.12+ppa1/collects/compiler/private/macfw.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/macfw.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,16 +23,17 @@ dest)]) (for-each (lambda (p) (let* ([orig (get-current-framework-path dest p)] - [3m (if (and orig (regexp-match #rx"_3m" orig)) - "_3m" - "")] + [variant (cond + [(and orig (regexp-match #rx"_3m" orig)) "_3m"] + [(and orig (regexp-match #rx"_CS" orig)) "_CS"] + [else ""])] [old-path (or orig - (format "~a.framework/Versions/~a~a/~a" p (version) 3m p))] + (format "~a.framework/Versions/~a~a/~a" p (version) variant p))] [new-path (if as-given? (format "~a" fw-path) (format "~a~a.framework/Versions/~a~a/~a" fw-path - p (version) 3m p))]) + p (version) variant p))]) (get/set-dylib-path dest (byte-regexp (bytes-append diff -Nru racket-6.12+ppa1/collects/compiler/private/mach-o.rkt racket-7.0+ppa1/collects/compiler/private/mach-o.rkt --- racket-6.12+ppa1/collects/compiler/private/mach-o.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/mach-o.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -56,7 +56,8 @@ ;; generally retain the location in a file of an offset that needs to ;; be updated. ;; -(define (add-plt-segment file segdata) +(define (add-plt-segment file segdata + #:name [segment-name #"__PLTSCHEME"]) (let-values ([(p out) (open-input-output-file file #:exists 'update)]) (dynamic-wind void @@ -136,7 +137,8 @@ [nreloc (read-ulong p)] [flags (read-ulong p)]) (when ((+ offset vmsz) . > . (+ cmdssz (if (equal? exe-id #xFeedFacf) 32 28))) - (when (offset . < . min-used) + (when (and (positive? offset) + (offset . < . min-used)) ;; (printf " new min!\n") (set! min-used offset))) ;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz) @@ -276,7 +278,7 @@ (file-position out link-edit-pos) (write-ulong (if link-edit-64? #x19 1) out) ; LC_SEGMENT[_64] (write-ulong new-cmd-sz out) - (display #"__PLTSCHEME\0\0\0\0\0" out) + (display (pad-segment-name segment-name) out) ((if link-edit-64? write-xulong write-ulong) out-addr out) ((if link-edit-64? write-xulong write-ulong) outlen out) ((if link-edit-64? write-xulong write-ulong) out-offset out) @@ -378,6 +380,9 @@ (close-input-port p) (close-output-port out))))) +(define (pad-segment-name bs) + (bytes-append bs (make-bytes (- 16 (bytes-length bs))))) + (define (fix-offset p pos out d base delta) (when (and out (not (zero? delta))) (file-position p (+ pos d)) diff -Nru racket-6.12+ppa1/collects/compiler/private/pe-rsrc.rkt racket-7.0+ppa1/collects/compiler/private/pe-rsrc.rkt --- racket-6.12+ppa1/collects/compiler/private/pe-rsrc.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/pe-rsrc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -454,7 +454,7 @@ (define new-virtual-addr (same-alignment - (section-virtual-addr s) + (pe-section-alignment pe) (for/fold ([pos 0]) ([s2 (in-list (pe-sections pe))] #:unless (eq? s s2)) (max pos diff -Nru racket-6.12+ppa1/collects/compiler/private/windlldir.rkt racket-7.0+ppa1/collects/compiler/private/windlldir.rkt --- racket-6.12+ppa1/collects/compiler/private/windlldir.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/windlldir.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,11 +1,13 @@ (module windlldir racket/base (require racket/port + racket/promise "winutf16.rkt") (provide update-dll-dir - get-current-dll-dir) + get-current-dll-dir + current-no-dlls?) - (define label (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:"))) + (define label (delay/sync (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:")))) (define max-dir-len (* 512 2)) ; sizeof(wchar_t) is 2 (define (update-dll-dir dest path) @@ -17,7 +19,7 @@ (error 'update-dll-dir "path too long: ~e" path)) (let ([m (with-input-from-file dest (lambda () - (regexp-match-positions label (current-input-port))))]) + (regexp-match-positions (force label) (current-input-port))))]) (unless m (error 'update-ddl-dir "cannot find DLL path in file: ~e" dest)) (with-output-to-file dest @@ -26,12 +28,15 @@ (write-bytes path-bytes) (write-byte 0)) #:exists 'update)))) - + (define (get-current-dll-dir dest) (with-input-from-file dest (lambda () - (unless (regexp-match label (current-input-port)) + (unless (regexp-match (force label) (current-input-port)) (error 'get-current-dll-dir "cannot find DLL path in file: ~e" dest)) (let ([p (make-limited-input-port (current-input-port) max-dir-len)]) (let ([m (regexp-match #rx#"(?:[^\0].|.[^\0])*" p)]) - (bytes->path (utf-16-bytes->bytes (car m))))))))) + (bytes->path (utf-16-bytes->bytes (car m)))))))) + + (define (current-no-dlls? dest) + (regexp-match? #rx#"^<" (get-current-dll-dir dest)))) diff -Nru racket-6.12+ppa1/collects/compiler/private/win-dll-list.rkt racket-7.0+ppa1/collects/compiler/private/win-dll-list.rkt --- racket-6.12+ppa1/collects/compiler/private/win-dll-list.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/win-dll-list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#lang racket/base +(require setup/dirs + dynext/filename-version) + +(provide get-racket-dlls + search-dll) + +(define (get-racket-dlls types #:extras-only? [extras-only? #f]) + (define (versionize template) + (let ([f (search-dll (format template filename-version-part))]) + (if (file-exists? f) + (format template filename-version-part) + (format template "xxxxxxx")))) + (append + (list + "libiconv-2.dll" + "longdouble.dll") + (if extras-only? + '() + (cond + [(or (memq 'racketcgc types) + (memq 'gracketcgc types)) + (list + (versionize "libracket~a.dll") + (versionize "libmzgc~a.dll"))] + [(or (memq 'racket3m types) + (memq 'gracket3m types)) + (list + (versionize "libracket3m~a.dll"))] + [(or (memq 'racketcs types) + (memq 'gracketcs types)) + (list + (versionize "libracketcs~a.dll"))])))) + +(define (search-dll dll) + (define dll-dir (find-cross-dll-dir)) + (if dll-dir + (build-path dll-dir dll) + (let* ([exe-dir + (let ([exec (path->complete-path + (find-executable-path (find-system-path 'exec-file)) + (find-system-path 'orig-dir))]) + (let-values ([(base name dir?) (split-path exec)]) + base))] + [paths (cons + exe-dir + (path-list-string->path-list + (or (getenv "PATH") "") + (list (find-system-path 'sys-dir))))]) + (or (ormap (lambda (p) + (let ([p (build-path p dll)]) + (and (file-exists? p) + p))) + paths) + ;; Can't find it, so just use executable's dir: + (build-path exe-dir dll))))) diff -Nru racket-6.12+ppa1/collects/compiler/private/xform.rkt racket-7.0+ppa1/collects/compiler/private/xform.rkt --- racket-6.12+ppa1/collects/compiler/private/xform.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/compiler/private/xform.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -621,6 +621,9 @@ (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) 'function] [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_DELTA)) + 'delta] + [(and (tok? e) (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_DIRECT_FUNCTION)) 'direct-function] [(braces? e) (loop (seq->list (seq-in e)))] @@ -643,6 +646,8 @@ "#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)\n"] [(thread-local) "#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)\n"] + [(delta) + "#define GC_VARIABLE_STACK (((Thread_Local_Variables *)((char *)&scheme_thread_locals_space + scheme_tls_delta))->GC_variable_stack_)\n"] [else "#define GC_VARIABLE_STACK GC_variable_stack\n"])) (if (or gc-variable-stack-through-funcs? @@ -904,7 +909,7 @@ strlen cos cosl sin sinl exp expl pow powl log logl sqrt sqrtl atan2 atan2l frexp isnan isinf fpclass signbit _signbit _fpclass __fpclassify __fpclassifyf __fpclassifyl - _isnan __isfinited __isnanl __isnan __signbit __signbitf __signbitd __signbitl + _isnan __isfinited __isnanl __isnan __signbit __signbitf __signbitd __signbitl __signbitf128 __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf __isinff128 __inline_isnanl __inline_isnan __inline_signbit __inline_signbitf __inline_signbitd __inline_signbitl __builtin_popcount __builtin_clz __builtin_isnan __builtin_isinf __builtin_signbit @@ -1713,6 +1718,7 @@ (or (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC (tok-n (car e))) (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION (tok-n (car e))) (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_DIRECT_FUNCTION (tok-n (car e))) + (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_DELTA (tok-n (car e))) (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL (tok-n (car e)))))) (define (access-modifier? e) diff -Nru racket-6.12+ppa1/collects/data/bit-vector.rkt racket-7.0+ppa1/collects/data/bit-vector.rkt --- racket-6.12+ppa1/collects/data/bit-vector.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/data/bit-vector.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -155,7 +155,8 @@ for/bit-vector for*/bit-vector bit-vector-copy - #f) + #f + check-bitvector) ;; A bit vector is represented as bytes. (serializable-struct bit-vector (words size) diff -Nru racket-6.12+ppa1/collects/db/private/generic/common.rkt racket-7.0+ppa1/collects/db/private/generic/common.rkt --- racket-6.12+ppa1/collects/db/private/generic/common.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/generic/common.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ dbsystem-base% locking% debugging% + disconnect% transactions% statement-cache% isolation-symbol->string @@ -428,7 +429,6 @@ (define statement-cache% (class transactions% - (init-field [cache-statements 'in-transaction]) (inherit call-with-lock get-tx-status check-valid-tx-status diff -Nru racket-6.12+ppa1/collects/db/private/generic/functions.rkt racket-7.0+ppa1/collects/db/private/generic/functions.rkt --- racket-6.12+ppa1/collects/db/private/generic/functions.rkt 2017-10-12 18:23:26.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/generic/functions.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,43 +1,11 @@ #lang racket/base (require racket/vector racket/class - racket/promise - "interfaces.rkt" (only-in "prepared.rkt") - (only-in "sql-data.rkt" sql-null sql-null?)) -(provide connected? - disconnect - connection-dbsystem - dbsystem-name - dbsystem-supported-types - prop:statement - statement? - bind-prepared-statement - prepared-statement-parameter-types - prepared-statement-result-types - virtual-statement? - (rename-out [virtual-statement* virtual-statement]) - query-rows - query-list - query-row - query-maybe-row - query-value - query-maybe-value - query-exec - query - in-query - in-query-helper ;; for contracted in-query macro in db/base - prepare - start-transaction - commit-transaction - rollback-transaction - call-with-transaction - in-transaction? - needs-rollback? - list-tables - table-exists? - group-rows - rows->dict) + "interfaces.rkt") +(provide (all-defined-out)) + +;; See also db-lib:db/private/generic/functions2 ;; == Administrative procedures @@ -47,21 +15,8 @@ (define (disconnect x) (send x disconnect)) -(define (connection-dbsystem x) - (send x get-dbsystem)) - -(define (dbsystem-name x) - (send x get-short-name)) - -(define (dbsystem-supported-types x) - ;; FIXME: make version sensitive? - (send x get-known-types +inf.0)) -;; == Misc procedures - -;; Value of prop:statement should be a function from struct instance to statement. -(define-values (prop:statement prop:statement? prop:statement-ref) - (make-struct-type-property 'prop:statement)) +;; == Statements (define (statement? x) (or (string? x) @@ -69,238 +24,150 @@ (statement-binding? x) (prop:statement? x))) -(define (bind-prepared-statement pst params) - (send pst bind 'bind-prepared-statement params)) - -(define (prepared-statement-parameter-types pst) - (send pst get-param-types)) -(define (prepared-statement-result-types pst) - (send pst get-result-types)) +;; prop:statement : property of (Self Connection -> Statement) +(define-values (prop:statement prop:statement? prop:statement-ref) + (make-struct-type-property 'prop:statement)) ;; A virtual-statement is: ;; - (virtual-statement table gen) ;; where table is a weak-hasheq[connection => prepared-statement] ;; and gen is (dbsystem -> string) -(struct virtual-statement (table gen) - #:property prop:statement - (lambda (stmt c) - (let* ([table (virtual-statement-table stmt)] - [gen (virtual-statement-gen stmt)] - [base-c (send c get-base)]) - (let ([table-pst (and base-c (hash-ref table base-c #f))]) - (or table-pst - (let* ([sql-string (gen (send c get-dbsystem))] - ;; FIXME: virtual-connection:prepare1 handles - ;; fsym = 'virtual-statement case specially - [pst (prepare1 'virtual-statement c sql-string #f)]) - (hash-set! table base-c pst) - pst)))))) - -(define virtual-statement* - (let ([virtual-statement - (lambda (gen) - (virtual-statement (make-weak-hasheq) - (if (string? gen) (lambda (_) gen) gen)))]) - virtual-statement)) - -;; == Query procedures - -;; query1 : connection symbol Statement -> QueryResult -(define (query1 c fsym stmt) - (send c query fsym stmt #f)) - -;; query/rows : connection symbol Statement nat/#f -> rows-result -(define (query/rows c fsym sql want-columns) - (let [(result (query1 c fsym sql))] - (unless (rows-result? result) - (error/want-rows fsym sql #t)) - (let ([got-columns (length (rows-result-headers result))]) - (when (and want-columns (not (= got-columns want-columns))) - (error/column-count fsym sql want-columns got-columns #t))) - result)) - -(define (query/cursor c fsym sql want-columns) - (let ([result (send c query fsym sql #t)]) - (unless (cursor-result? result) - (error/want-cursor fsym sql)) - (let ([got-columns (length (cursor-result-headers result))]) - (when (and want-columns (not (= got-columns want-columns))) - (error/column-count fsym sql want-columns got-columns #t))) - result)) - -(define (rows-result->row fsym rs sql maybe-row? one-column?) - (define rows (rows-result-rows rs)) +(define-struct virtual-statement (table gen) + #:omit-define-syntaxes + #:property prop:statement + (lambda (stmt c) + (let* ([table (virtual-statement-table stmt)] + [gen (virtual-statement-gen stmt)] + [base-c (send c get-base)]) + (let ([table-pst (and base-c (hash-ref table base-c #f))]) + (or table-pst + (let* ([sql-string (gen (send c get-dbsystem))] + ;; FIXME: virtual-connection:prepare1 handles + ;; fsym = 'virtual-statement case specially + [pst (prepare1 'virtual-statement c sql-string #f)]) + (hash-set! table base-c pst) + pst)))))) + +(define (virtual-statement gen) + (make-virtual-statement (make-weak-hasheq) + (if (string? gen) (lambda (_) gen) gen))) + + +;; == Query helper procedures + +;; ResultCheck = #f | 'rows | exact-positive-integer +;; #f = no check, 'rows = want rows-result, n = want rows-result w/ n cols + +;; query1 : Connection Symbol Statement -> QueryResult +(define (query1 c who stmt) + (send c query who stmt #f)) + +;; query/rows : Connection Symbol Statement Nat/#f -> Rows-Result +(define (query/rows c who stmt want-columns) + (check-rows-result who stmt want-columns (query1 c who stmt))) + +;; check-rows-result : Symbol Statement ResultCheck Query-Result -> Rows-Result +(define (check-rows-result who sql want-columns result) + (unless (rows-result? result) + (error/want-rows who sql #t)) + (let ([got-columns (length (rows-result-headers result))]) + (when (and (exact-integer? want-columns) (not (= got-columns want-columns))) + (error/column-count who sql want-columns got-columns #t))) + result) + +;; rows-result->row : Symbol Rows-Result Statement Boolean Boolean -> Vector/Any +(define (rows-result->row who result sql maybe-row? one-column?) + (define rows (rows-result-rows result)) (cond [(null? rows) - (cond [maybe-row? #f] - [else (error/row-count fsym sql 1 0)])] + (if maybe-row? #f (error/row-count who sql 1 0))] [(null? (cdr rows)) (let ([row (car rows)]) - (cond [one-column? (vector-ref row 0)] - [else row]))] - [else (error/row-count fsym sql 1 (length rows))])) + (if one-column? (vector-ref row 0) row))] + [else (error/row-count who sql 1 (length rows))])) -(define (compose-statement fsym c stmt args checktype) +;; compose-statement : Symbol Connection Statement List ResultCheck -> Statement +;; Returns self-contained statement: either string or statement-binding. +(define (compose-statement who c stmt args checktype) (cond [(prop:statement? stmt) (let ([stmt* ((prop:statement-ref stmt) stmt c)]) - (compose-statement fsym c stmt* args checktype))] - [(or (pair? args) - (prepared-statement? stmt) - (virtual-statement? stmt)) - (let ([pst - (cond [(string? stmt) - (prepare1 fsym c stmt #t)] - [(prepared-statement? stmt) - ;; Ownership check done later, by query method. - stmt] - [(statement-binding? stmt) - (error/statement-binding-args fsym stmt args)])]) - (send pst check-results fsym checktype stmt) - (send pst bind fsym args))] + (compose-statement who c stmt* args checktype))] + [(or (pair? args) (prepared-statement? stmt)) + (define pst + (cond [(string? stmt) + (prepare1 who c stmt #t)] + [(prepared-statement? stmt) + ;; Ownership check done later, by query method. + stmt] + [(statement-binding? stmt) + (error/statement-binding-args who stmt args)])) + (send pst check-results who checktype stmt) + (send pst bind who args)] [else ;; no args, and stmt is either string or statement-binding stmt])) -;; Query API procedures +;; query-row* : Symbol Connection Statement List Nat/#f Boolean Boolean -> (varies) +;; Helper for all query operations that expect at most one row returned. +(define (query-row* who c sql args want-columns maybe-row? one-column?) + (let* ([sql (compose-statement who c sql args (or want-columns 'rows))] + [result (query/rows c who sql want-columns)]) + (rows-result->row who result sql maybe-row? one-column?))) + -;; query-rows : connection Statement arg ... -> (listof (vectorof 'a)) -(define (query-rows c sql - #:group [group-fields-list null] - #:group-mode [group-mode null] - . args) +;; == Query API procedures + +;; query-rows0 : connection Statement arg ... -> (listof (vectorof 'a)) +(define (query-rows0 c sql . args) (let* ([sql (compose-statement 'query-rows c sql args 'rows)] - [result (query/rows c 'query-rows sql #f)] - [result - (cond [(not (null? group-fields-list)) - (group-rows-result* 'query-rows result group-fields-list group-mode)] - [else result])]) + [result (query/rows c 'query-rows0 sql #f)]) (rows-result-rows result))) ;; query-list : connection Statement arg ... -> (listof 'a) ;; Expects to get back a rows-result with one field per row. (define (query-list c sql . args) - (let ([sql (compose-statement 'query-list c sql args 1)]) - (map (lambda (v) (vector-ref v 0)) - (rows-result-rows (query/rows c 'query-list sql 1))))) + (let* ([sql (compose-statement 'query-list c sql args 1)] + [result (query/rows c 'query-list sql 1)]) + (map (lambda (v) (vector-ref v 0)) (rows-result-rows result)))) -;; query-row : connection Statement arg ... -> (vector-of 'a) -;; Expects to get back a rows-result of zero or one rows. +;; query-row : Connection Statement SqlDatum ... -> (Vectorof SqlDatum) (define (query-row c sql . args) - (let ([sql (compose-statement 'query-row c sql args 'rows)]) - (rows-result->row 'query-row - (query/rows c 'query-row sql #f) - sql #f #f))) + (query-row* 'query-row c sql args #f #f #f)) -;; query-maybe-row : connection Statement arg ... -> (vector-of 'a) or #f -;; Expects to get back a rows-result of zero or one rows. +;; query-maybe-row : Connection Statement SqlDatum ... -> (Vectorof SqlDatum) or #f (define (query-maybe-row c sql . args) - (let ([sql (compose-statement 'query-maybe-row c sql args 'rows)]) - (rows-result->row 'query-maybe-row - (query/rows c 'query-maybe-row sql #f) - sql #t #f))) + (query-row* 'query-maybe-row c sql args #f #t #f)) -;; query-value : connection string arg ... -> value | raises error -;; Expects to get back a rows-result of exactly one row, exactly one column. +;; query-value : Connection Statement SqlDatum ... -> SqlDatum | raises error (define (query-value c sql . args) - (let ([sql (compose-statement 'query-value c sql args 1)]) - (rows-result->row 'query-value - (query/rows c 'query-value sql 1) - sql #f #t))) + (query-row* 'query-value c sql args 1 #f #t)) -;; query-maybe-value : connection Statement arg ... -> value/#f -;; Expects to get back a rows-result of zero or one rows, exactly one column. +;; query-maybe-value : Connection Statement SqlDatum ... -> SqlDatum or #f (define (query-maybe-value c sql . args) - (let ([sql (compose-statement 'query-maybe-value c sql args 1)]) - (rows-result->row 'query-maybe-value - (query/rows c 'query-maybe-value sql 1) - sql #t #t))) + (query-row* 'query-maybe-value c sql args 1 #t #t)) -;; query-exec : connection Statement arg ... -> void +;; query-exec : Connection Statement SqlDatum ... -> void (define (query-exec c sql . args) (let ([sql (compose-statement 'query-exec c sql args #f)]) (query1 c 'query-exec sql) (void))) -;; query : connection Statement arg ... -> QueryResult +;; query : Connection Statement SqlDatum ... -> QueryResult (define (query c sql . args) (let ([sql (compose-statement 'query c sql args #f)]) (query1 c 'query sql))) -;; ======================================== - -(define (in-query c stmt - #:fetch [fetch-size +inf.0] - #:group [grouping-fields null] - #:group-mode [group-mode null] - . args) - (apply in-query-helper #f c stmt - #:fetch fetch-size - #:group grouping-fields - #:group-mode group-mode - args)) - -(define (in-query-helper vars c stmt - #:fetch [fetch-size +inf.0] - #:group [grouping-fields null] - #:group-mode [group-mode null] - . args) - (when (and (not (null? grouping-fields)) - (< fetch-size +inf.0)) - (error 'in-query "cannot apply grouping to cursor (finite fetch-size)")) - (let* ([check - ;; If grouping, can't check expected arity. - ;; FIXME: should check header includes named fields - (if (null? grouping-fields) vars #f)] - [stmt (compose-statement 'in-query c stmt args (or check 'rows))]) - (cond [(eqv? fetch-size +inf.0) - (in-list/vector->values - (rows-result-rows - (let ([result (query/rows c 'in-query stmt check)]) - (if (null? grouping-fields) - result - (group-rows-result* 'in-query result grouping-fields group-mode)))))] - [else - (let ([cursor (query/cursor c 'in-query stmt check)]) - (in-list-generator/vector->values - (lambda () (send c fetch/cursor 'in-query cursor fetch-size))))]))) - -(define (in-list/vector->values vs) - (make-do-sequence - (lambda () - (values (lambda (p) (vector->values (car p))) - cdr - vs - pair? #f #f)))) - -(define (in-list-generator/vector->values fetch-proc) - ;; fetch-proc : symbol nat -> (U list #f) - ;; state = #f | (cons vector (U state (promise-of state))) - - ;; more-promise : -> (promise-of state) - (define (more-promise) - (delay (let ([more (fetch-proc)]) - ;; note: improper append, list onto promise - (and more (append more (more-promise)))))) - - (make-do-sequence - (lambda () - (values (lambda (p) (vector->values (car p))) - (lambda (p) - (let ([next (cdr p)]) (if (promise? next) (force next) next))) - (force (more-promise)) - pair? #f #f)))) -;; ======================================== +;; == Prepare (define (prepare c stmt) ;; FIXME: handle non-string statements (prepare1 'prepare c stmt #f)) -;; ---- - (define (prepare1 fsym c stmt close-on-exec?) ;; stmt is string (send c prepare fsym stmt close-on-exec?)) -;; ======================================== + +;; == Transactions (define (start-transaction c #:isolation [isolation #f] @@ -333,239 +200,3 @@ (define (needs-rollback? c) (eq? (send c transaction-status 'needs-rollback?) 'invalid)) - -;; ======================================== - -;; list-tables : ... -> (listof string) -;; - lists unqualified table/view/etc names in search path (omit system tables, if possible). -;; Maybe it would be better to just search the current schema only? -;; or maybe mode = 'current | 'search | 'current-or-search (default) -;; - lists unqualified table/view/etc names for given schema (and/or catalog?) -;; - Add option to include system tables? -(define (list-tables c - #:schema [schema 'search-or-current]) - (send c list-tables 'list-tables schema)) - -(define (table-exists? c table-name - #:schema [schema 'search-or-current] - #:case-sensitive? [cs? #f]) - (let ([tables (send c list-tables 'table-exists? schema)]) - (for/or ([table (in-list tables)]) - (if cs? - (string=? table-name table) - (string-ci=? table-name table))))) - -;; list-tables* : ... -> (listof vector) -;; Return full catalog/schema/table/type list. - -;; ======================================== - -;; FIXME: add 'assume-sorted optimization option? - -(define (group-rows result - #:group key-fields-list - #:group-mode [group-mode null]) - (when (null? key-fields-list) - (error 'group-rows "expected at least one grouping field set")) - (group-rows-result* 'group-rows result key-fields-list group-mode)) - -(define (group-rows-result* fsym result key-fields-list group-mode) - (let* ([invert-outer? (not (or (memq 'preserve-null group-mode) - ;; old flag, deprecated: - (memq 'preserve-null-rows group-mode)))] - [as-list? (memq 'list group-mode)] - [headers (rows-result-headers result)] - [total-fields (length headers)] - [name-map (headers->name-map headers)] - [fields-used (make-vector total-fields #f)] - [key-indexes-list - (group-list->indexes fsym name-map total-fields fields-used key-fields-list)] - [residual-length - (for/sum ([x (in-vector fields-used)]) (if x 0 1))]) - (when (= residual-length 0) - (raise-arguments-error fsym "cannot group by all fields" - "grouping field sets" key-fields-list)) - (when (and (> residual-length 1) as-list?) - (raise-arguments-error fsym "expected exactly one residual field when #:group-mode is 'list" - "grouping field sets" key-fields-list - "residual field count" residual-length)) - (let* ([initial-projection - (for/vector #:length total-fields ([i (in-range total-fields)]) i)] - [headers - (group-headers (list->vector headers) - initial-projection - key-indexes-list)] - [rows - (group-rows* fsym - (rows-result-rows result) - initial-projection - key-indexes-list - invert-outer? - as-list?)]) - (rows-result headers rows)))) - -(define (headers->name-map headers) - (for/hash ([header (in-list headers)] - [i (in-naturals)] - #:when (assq 'name header)) - (values (cdr (assq 'name header)) i))) - -(define (group-list->indexes fsym name-map total-fields fields-used key-fields-list) - (let ([key-fields-list (if (list? key-fields-list) key-fields-list (list key-fields-list))]) - (for/list ([key-fields (in-list key-fields-list)]) - (group->indexes fsym name-map total-fields fields-used key-fields)))) - -(define (group->indexes fsym name-map total-fields fields-used key-fields) - (let ([key-fields (if (vector? key-fields) key-fields (vector key-fields))]) - (for/vector ([key-field (in-vector key-fields)]) - (grouping-field->index fsym name-map total-fields fields-used key-field)))) - -(define (grouping-field->index fsym name-map total-fields fields-used key-field) - (let ([key-index - (cond [(string? key-field) - (hash-ref name-map key-field #f)] - [else key-field])]) - (when (string? key-field) - (unless key-index - (raise-arguments-error fsym "bad grouping field" - "given" key-field - "available" (sort (hash-keys name-map) string residual rows with all NULL fields are dropped. - (cond [(null? key-indexes-list) - ;; Apply projection to each row - (cond [as-list? - (unless (= (vector-length projection) 1) - (error/internal - fsym - "list mode requires a single residual column, got ~s" - (vector-length projection))) - (let ([index (vector-ref projection 0)]) - (for/list ([row (in-list rows)]) - (vector-ref row index)))] - [else - (let ([plen (vector-length projection)]) - (for/list ([row (in-list rows)]) - (let ([v (make-vector plen)]) - (for ([i (in-range plen)]) - (vector-set! v i (vector-ref row (vector-ref projection i)))) - v)))])] - [else - (let () - (define key-indexes (car key-indexes-list)) - (define residual-projection - (vector-filter-not (lambda (index) (vector-member index key-indexes)) - projection)) - (define key-row-length (vector-length key-indexes)) - (define (row->key-row row) - (for/vector #:length key-row-length - ([i (in-vector key-indexes)]) - (vector-ref row i))) - (define (residual-all-null? row) - (for/and ([i (in-vector residual-projection)]) - (sql-null? (vector-ref row i)))) - (let* ([key-table (make-hash)] - [r-keys - (for/fold ([r-keys null]) - ([row (in-list rows)]) - (let* ([key-row (row->key-row row)] - [already-seen? (and (hash-ref key-table key-row #f) #t)]) - (unless already-seen? - (hash-set! key-table key-row null)) - (unless (and invert-outer? (residual-all-null? row)) - (hash-set! key-table key-row (cons row (hash-ref key-table key-row)))) - (if already-seen? - r-keys - (cons key-row r-keys))))]) - (for/list ([key (in-list (reverse r-keys))]) - (let ([residuals - (group-rows* fsym - (reverse (hash-ref key-table key)) - residual-projection - (cdr key-indexes-list) - invert-outer? - as-list?)]) - (vector-append key (vector residuals))))))])) - -;; ======================================== - -(define not-given (gensym 'not-given)) - -(define (rows->dict result - #:key key-field/s - #:value value-field/s - #:value-mode [value-mode null]) - (let* ([who 'rows->dict] - [headers (rows-result-headers result)] - [total-fields (length headers)] - [name-map (headers->name-map headers)] - [preserve-null? (memq 'preserve-null value-mode)] - [value-list? (memq 'list value-mode)]) - (define (make-project field/s) - (if (vector? field/s) - (let* ([indexes (group->indexes who name-map total-fields #f field/s)] - [indexes-length (vector-length indexes)]) - (lambda (v) - (for/vector #:length indexes-length ([i (in-vector indexes)]) - (vector-ref v i)))) - (let ([index (grouping-field->index who name-map total-fields #f field/s)]) - (lambda (v) (vector-ref v index))))) - (define get-key (make-project key-field/s)) - (define get-value (make-project value-field/s)) - (define ok-value? - (cond [preserve-null? (lambda (v) #t)] - [(vector? value-field/s) - (lambda (v) (not (for/or ([e (in-vector v)]) (sql-null? e))))] - [else (lambda (v) (not (sql-null? v)))])) - (for/fold ([table '#hash()]) ([row (in-list (if value-list? - (reverse (rows-result-rows result)) - (rows-result-rows result)))]) - (let* ([key (get-key row)] - [value (get-value row)] - [old-value (hash-ref table key (if value-list? '() not-given))]) - (unless (or value-list? - (eq? (hash-ref table key not-given) not-given) - ;; FIXME: okay to coalesce values if equal? - (equal? value old-value)) - (error* who "duplicate value for key" - '("key" value) key - '("values" multi value) (list old-value value))) - (if value-list? - (hash-set table key - (if (ok-value? value) - (cons value old-value) - ;; If all-NULL value, still enter key => '() into dict - old-value)) - (if (ok-value? value) - (hash-set table key value) - table)))))) diff -Nru racket-6.12+ppa1/collects/db/private/pre.rkt racket-7.0+ppa1/collects/db/private/pre.rkt --- racket-6.12+ppa1/collects/db/private/pre.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/pre.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ #lang racket/base -;; Most of db/base and db/sqlite3, used by core Racket (pre-pkg) +;; Minimal db/base and db/sqlite3, used by core Racket (pre-pkg) (require "generic/interfaces.rkt") (provide (struct-out simple-result) @@ -16,8 +16,23 @@ sql-null?) (require "generic/functions.rkt") -(provide (except-out (all-from-out "generic/functions.rkt") - in-query-helper)) +(provide connected? + disconnect + virtual-statement + (rename-out [query-rows0 query-rows]) + query-list + query-row + query-maybe-row + query-value + query-maybe-value + query-exec + query + start-transaction + commit-transaction + rollback-transaction + call-with-transaction + in-transaction? + needs-rollback?) (require "sqlite3/main.rkt") (provide sqlite3-connect diff -Nru racket-6.12+ppa1/collects/db/private/sqlite3/connection.rkt racket-7.0+ppa1/collects/db/private/sqlite3/connection.rkt --- racket-6.12+ppa1/collects/db/private/sqlite3/connection.rkt 2017-10-12 18:23:26.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/sqlite3/connection.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,5 +1,6 @@ #lang racket/base (require racket/class + ffi/file ffi/unsafe ffi/unsafe/atomic ffi/unsafe/custodian @@ -10,7 +11,14 @@ "ffi.rkt" "dbsystem.rkt") (provide connection% - handle-status*) + handle-status* + (protect-out unsafe-load-extension + unsafe-create-function + unsafe-create-aggregate)) + +(define-local-member-name unsafe-load-extension) +(define-local-member-name unsafe-create-function) +(define-local-member-name unsafe-create-aggregate) ;; == Connection @@ -346,7 +354,7 @@ (set! name-counter (add1 name-counter)) (format "λmz_~a" n))) - ;; Reflection + ;; == Reflection (define/public (list-tables fsym schema) (let ([stmt @@ -357,7 +365,41 @@ (for/list ([row (in-list (rows-result-rows result))]) (vector-ref row 0))))) - ;; ---- + ;; == Load Extension + + (define/public (unsafe-load-extension who lib) + (define lib-path (cleanse-path (path->complete-path lib))) + (security-guard-check-file who lib-path '(read execute)) + (call-with-lock who + (lambda () + (HANDLE who (A (sqlite3_enable_load_extension -db 1))) + (HANDLE who (A (sqlite3_load_extension -db lib-path))) + (HANDLE who (A (sqlite3_enable_load_extension -db 0))) + (void)))) + + ;; == Create Function + + (define dont-gc null) + + (define/public (unsafe-create-function who name arity proc) + (define wrapped (wrap-fun name proc)) + (call-with-lock who + (lambda () + (set! dont-gc (cons wrapped dont-gc)) + (HANDLE who (A (sqlite3_create_function_v2 -db name (or arity -1) wrapped)))))) + + (define/public (unsafe-create-aggregate who name arity step final [init #f]) + (define aggbox (box init)) + (define wrapped-step (wrap-agg-step name step aggbox init)) + (define wrapped-final (wrap-agg-final name final aggbox init)) + (call-with-lock who + (lambda () + (set! dont-gc (list* wrapped-step wrapped-final dont-gc)) + (HANDLE who + (A (sqlite3_create_aggregate -db name (or arity -1) + wrapped-step wrapped-final)))))) + + ;; == Error handling (define-syntax HANDLE (syntax-rules () diff -Nru racket-6.12+ppa1/collects/db/private/sqlite3/ffi-constants.rkt racket-7.0+ppa1/collects/db/private/sqlite3/ffi-constants.rkt --- racket-6.12+ppa1/collects/db/private/sqlite3/ffi-constants.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/sqlite3/ffi-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -57,3 +57,8 @@ (define SQLITE_OPEN_FULLMUTEX #x00010000) (define SQLITE_OPEN_SHAREDCACHE #x00020000) (define SQLITE_OPEN_PRIVATECACHE #x00040000) + +;; Create function + +(define SQLITE_UTF8 1) +(define SQLITE_DETERMINISTIC #x800) diff -Nru racket-6.12+ppa1/collects/db/private/sqlite3/ffi.rkt racket-7.0+ppa1/collects/db/private/sqlite3/ffi.rkt --- racket-6.12+ppa1/collects/db/private/sqlite3/ffi.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/db/private/sqlite3/ffi.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -39,14 +39,14 @@ (define-sqlite sqlite3_open (_fun (filename ignored-flags) :: - (filename : _bytes) + ((bytes-append filename #"\0") : _bytes) (db : (_ptr o _sqlite3_database)) -> (result : _int) -> (values db result))) (define-sqlite sqlite3_open_v2 (_fun (filename flags) :: - (filename : _bytes) + ((bytes-append filename #"\0") : _bytes) (db : (_ptr o _sqlite3_database)) (flags : _int) (vfs : _pointer = #f) @@ -63,23 +63,28 @@ (define (trim-and-copy-buffer buffer) (let* ([buffer (string->bytes/utf-8 (string-trim #:left? #f buffer))] [n (bytes-length buffer)] - [rawcopy (malloc (add1 n) 'atomic-interior)] - [copy (make-sized-byte-string rawcopy n)]) - (memcpy copy buffer n) + [rawcopy (malloc (add1 n) 'atomic-interior)]) + (memcpy rawcopy buffer n) (ptr-set! rawcopy _byte n 0) - copy)) + rawcopy)) + +(define (c-string-length p) + (let loop ([i 0]) + (if (zero? (ptr-ref p _byte i)) + i + (loop (add1 i))))) (define (points-to-end? tail sql-buffer) (ptr-equal? tail - (ptr-add sql-buffer (bytes-length sql-buffer)))) + (ptr-add sql-buffer (c-string-length sql-buffer)))) (define-sqlite sqlite3_prepare (_fun (db sql) :: (db : _sqlite3_database) - (sql-buffer : _bytes = (trim-and-copy-buffer sql)) - ((bytes-length sql-buffer) : _int) + (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) + ((c-string-length sql-buffer) : _int) (statement : (_ptr o _sqlite3_statement/null)) - (tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) + (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior) -> (result : _int) -> (values result statement (and tail (not (points-to-end? tail sql-buffer)))))) @@ -87,11 +92,11 @@ (define-sqlite sqlite3_prepare_v2 (_fun (db sql) :: (db : _sqlite3_database) - (sql-buffer : _bytes = (trim-and-copy-buffer sql)) - ((bytes-length sql-buffer) : _int) + (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) + ((c-string-length sql-buffer) : _int) ;; bad prepare statements set statement to NULL, with no error reported (statement : (_ptr o _sqlite3_statement/null)) - (tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) + (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior) -> (result : _int) -> (values result statement (and tail (not (points-to-end? tail sql-buffer))))) @@ -190,9 +195,11 @@ (define-sqlite sqlite3_column_blob (_fun (stmt : _sqlite3_statement) (col : _int) - -> (blob : _bytes) - -> (let ([len (sqlite3_column_bytes stmt col)]) - (bytes-copy (make-sized-byte-string blob len))))) + -> (blob : _pointer) + -> (let* ([len (sqlite3_column_bytes stmt col)] + [bstr (make-bytes len)]) + (memcpy bstr blob len) + bstr))) ;; ---------------------------------------- @@ -215,3 +222,146 @@ (define-sqlite sqlite3_last_insert_rowid (_fun _sqlite3_database -> _int64)) + +;; ---------------------------------------- + +(define SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION 1005) ;; int int* + +(define-sqlite sqlite3_db_config + (_fun _sqlite3_database _int _int (out : (_ptr o _int)) + -> (r : _int) -> r)) ;; FIXME: return out? + +(define-sqlite sqlite3_enable_load_extension + (_fun _sqlite3_database _int -> _int)) + +(define-sqlite sqlite3_load_extension + ;; FIXME: handle error string? + (_fun _sqlite3_database _path (_pointer = #f) (_pointer = #f) + -> _int)) + +;; ---------------------------------------- + +(define-cpointer-type _sqlite3_context) +(define-cpointer-type _sqlite3_value) + +(define-sqlite sqlite3_value_type (_fun _sqlite3_value -> _int)) +(define-sqlite sqlite3_value_double (_fun _sqlite3_value -> _double)) +(define-sqlite sqlite3_value_int64 (_fun _sqlite3_value -> _int64)) +(define-sqlite sqlite3_value_bytes (_fun _sqlite3_value -> _int)) +(define-sqlite sqlite3_value_blob (_fun _sqlite3_value -> _pointer)) +(define-sqlite sqlite3_value_text (_fun _sqlite3_value -> _pointer)) + +(define (pointer->bytes p len) + (define bstr (make-bytes len)) + (memcpy bstr p len) + bstr) + +(define _sqlite3_value* + (make-ctype _sqlite3_value + #f + (lambda (v) + (define type (sqlite3_value_type v)) + (cond [(= type SQLITE_INTEGER) (sqlite3_value_int64 v)] + [(= type SQLITE_FLOAT) (sqlite3_value_double v)] + [(= type SQLITE_TEXT) + (bytes->string/utf-8 (pointer->bytes (sqlite3_value_text v) + (sqlite3_value_bytes v)))] + [(= type SQLITE_BLOB) + (pointer->bytes (sqlite3_value_blob v) + (sqlite3_value_bytes v))] + [else (error '_sqlite3_value* "cannot convert: ~e (type = ~s)" v type)])))) + +(define-sqlite sqlite3_create_function_v2 + (_fun _sqlite3_database + _string/utf-8 + _int + (_int = (+ SQLITE_UTF8 SQLITE_DETERMINISTIC)) + (_pointer = #f) + (_fun _sqlite3_context _int _pointer -> _void) + (_fpointer = #f) + (_fpointer = #f) + (_fpointer = #f) + -> _int)) + +(define-sqlite sqlite3_create_aggregate + (_fun _sqlite3_database + _string/utf-8 + _int + (_int = (+ SQLITE_UTF8 SQLITE_DETERMINISTIC)) + (_pointer = #f) + (_fpointer = #f) + (_fun _sqlite3_context _int _pointer -> _void) + (_fun _sqlite3_context -> _void) + (_fpointer = #f) + -> _int) + #:c-id sqlite3_create_function_v2) + +(define-sqlite sqlite3_aggregate_context + (_fun _sqlite3_context _int -> _pointer)) + +(define-sqlite sqlite3_result_null (_fun _sqlite3_context -> _void)) +(define-sqlite sqlite3_result_int64 (_fun _sqlite3_context _int64 -> _void)) +(define-sqlite sqlite3_result_double (_fun _sqlite3_context _double* -> _void)) +(define-sqlite sqlite3_result_blob + (_fun _sqlite3_context + (buf : _bytes) + (_int = (bytes-length buf)) + (_intptr = SQLITE_TRANSIENT) + -> _void)) +(define-sqlite sqlite3_result_text + (_fun _sqlite3_context + (buf : _string/utf-8) + (_int = (string-utf-8-length buf)) + (_intptr = SQLITE_TRANSIENT) + -> _void)) +(define-sqlite sqlite3_result_error + (_fun _sqlite3_context (s : _string/utf-8) (_int = (string-utf-8-length s)) -> _void)) + +(define ((wrap-fun who proc) ctx argc argp) + (define args (get-args argc argp)) + (call/wrap who ctx (lambda () (sqlite3_result* ctx (apply proc args))))) + +;; sqlite3 supports an "aggregate context" for storing aggregate +;; state, but it's hidden from Racket's GC. So instead we make a +;; closure with Racket-visible state and use sqlite's aggregate +;; context just to tell us whether we need to reset the Racket-level +;; state. The connection object is responsible for preventing the +;; closure from being prematurely collected. + +(define ((wrap-agg-step who proc aggbox agginit) ctx argc argp) + (define args (get-args argc argp)) + (define aggctx (sqlite3_aggregate_context ctx 1)) + (when (zero? (ptr-ref aggctx _byte)) + (set-box! aggbox agginit) + (ptr-set! aggctx _byte 1)) + (set-box! aggbox (call/wrap who ctx (lambda () (apply proc (unbox aggbox) args)))) + (sqlite3_result* ctx 0)) + +(define ((wrap-agg-final who proc aggbox agginit) ctx) + (define aggctx (sqlite3_aggregate_context ctx 1)) + (define r (call/wrap who ctx (lambda () (proc (unbox aggbox))))) + (set-box! aggbox agginit) + (sqlite3_result* ctx r)) + +(define (call/wrap who ctx proc) + (with-handlers + ([(lambda (e) #t) + (lambda (e) + (define err + (format "[racket:~a] ~a" + who + (cond [(exn? e) (exn-message e)] + [else (format "caught non-exception\n caught: ~e" e)]))) + (sqlite3_result_error ctx err))]) + (call-with-continuation-barrier proc))) + +(define (get-args argc argp) + (for/list ([i (in-range argc)]) + (ptr-ref argp _sqlite3_value* i))) + +(define (sqlite3_result* ctx r) + (cond [(fixnum? r) (sqlite3_result_int64 ctx r)] ;; FIXME: fixnum -> int64 + [(real? r) (sqlite3_result_double ctx r)] + [(string? r) (sqlite3_result_text ctx r)] + [(bytes? r) (sqlite3_result_blob ctx r)] + [else (sqlite3_result_error ctx (format "bad result: ~e" r))])) diff -Nru racket-6.12+ppa1/collects/ffi/unsafe/define/conventions.rkt racket-7.0+ppa1/collects/ffi/unsafe/define/conventions.rkt --- racket-6.12+ppa1/collects/ffi/unsafe/define/conventions.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/ffi/unsafe/define/conventions.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,8 +4,7 @@ convention:hyphen->camelcase) (require (for-syntax racket/base racket/syntax - racket/string - syntax/parse)) + racket/string)) (define-syntax (convention:hyphen->underscore id) (format-id id (string-replace (symbol->string (syntax-e id)) "-" "_"))) diff -Nru racket-6.12+ppa1/collects/ffi/unsafe/define.rkt racket-7.0+ppa1/collects/ffi/unsafe/define.rkt --- racket-6.12+ppa1/collects/ffi/unsafe/define.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/ffi/unsafe/define.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -27,6 +27,50 @@ (define-syntax-rule (provide-protected p ...) (provide (protect-out p ...))) +(begin-for-syntax + (define (make-ffi-definer-transformer the-ffi-lib ;; Identifier + provide-form ;; Identifier/#'#f + define-form ;; Identifier + default-make-fail ;; Identifier + make-c-id) ;; Identifier/#'#f + ;; do-make-c-id : Identifier -> Identifier + (define (do-make-c-id id) + (cond [(identifier? make-c-id) + (define result ((syntax-local-value make-c-id) id)) + (unless (identifier? result) + (raise-syntax-error #f "invalid make-c-id result" make-c-id)) + result] + [else id])) + (with-syntax ([the-ffi-lib the-ffi-lib] + [provide provide-form] + [define-form define-form] + [default-make-fail default-make-fail]) + (lambda (stx) + (syntax-parse stx + [(_ s-id:id type:expr + (~seq (~or (~optional (~seq #:c-id c-id:id) + #:defaults ([c-id (do-make-c-id #'s-id)]) + #:name "#:c-id keyword") + (~optional (~seq #:wrap wrapper:expr) + #:defaults ([wrapper #'values]) + #:name "#:wrap keyword") + (~optional (~or (~seq #:make-fail make-fail:expr) + (~seq #:fail fail:expr)) + #:defaults ([make-fail #'default-make-fail]))) + ...)) + (with-syntax ([fail (if (attribute fail) + #'fail + #'(make-fail 's-id))]) + (with-syntax ([def (syntax/loc stx + (define-form s-id + (wrapper (get-ffi-obj 'c-id the-ffi-lib type fail))))]) + (if (syntax-e #'provide) + (syntax/loc stx + (begin + (provide s-id) + def)) + #'def)))]))))) + (define-syntax (define-ffi-definer stx) (syntax-parse stx [(_ define-:id ffi-lib:expr @@ -51,35 +95,11 @@ (raise-type-error 'define-ffi-definer "ffi-lib or #f" v)))) - (define-syntax define- - (with-syntax ([provide #'provide-form]) - (lambda (stx) - (syntax-parse stx - [(_ s-id:id type:expr (~seq (~or (~optional (~seq #:c-id c-id:id) - #:defaults ([c-id #,(if (identifier? (attribute make-c-id)) - #'((syntax-local-value #'make-c-id) #'s-id) - #'#'s-id)]) - #:name "#:c-id keyword") - (~optional (~seq #:wrap wrapper:expr) - #:defaults ([wrapper #'values]) - #:name "#:wrap keyword") - (~optional (~or (~seq #:make-fail make-fail:expr) - (~seq #:fail fail:expr)) - #:defaults ([make-fail #'default-make-fail]))) - (... ...))) - (unless (identifier? #'c-id) - (raise-syntax-error #f - "invalid make-c-id expression" - #'make-c-id)) - (with-syntax ([fail (if (attribute fail) - #'fail - #'(make-fail 's-id))]) - (with-syntax ([def (syntax/loc stx - (define-form s-id (wrapper (get-ffi-obj 'c-id the-ffi-lib type fail))))]) - (if (syntax-e #'provide) - (syntax/loc stx - (begin - (provide s-id) - def)) - #'def)))])))))])) - + (define (the-default-make-fail sym) (default-make-fail sym)) + (define-syntax define- + (make-ffi-definer-transformer + (quote-syntax the-ffi-lib) + (quote-syntax provide-form) + (quote-syntax define-form) + (quote-syntax the-default-make-fail) + (quote-syntax make-c-id))))])) diff -Nru racket-6.12+ppa1/collects/ffi/unsafe/objc.rkt racket-7.0+ppa1/collects/ffi/unsafe/objc.rkt --- racket-6.12+ppa1/collects/ffi/unsafe/objc.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/ffi/unsafe/objc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -219,9 +219,7 @@ (cast (objc_lookUpClass name) _Class _Protocol)))) (define-objc sel_registerName (_fun _string -> _SEL) - #:fail (lambda () (lambda (name) - ;; Fake registration using interned symbols - (cast (string->symbol name) _racket _gcpointer)))) + #:fail (lambda () (lambda (name) #f))) (define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class) #:fail (lambda () #f)) @@ -553,7 +551,10 @@ (define-for-syntax liftable-type? (let ([prims - (syntax->list #'(_id _Class _SEL _void _int _long _float _double _double* _BOOL))]) + (syntax->list #'(_id _Class _SEL + _void _short _ushort _int _uint _long _ulong _intptr _uintptr + _float _double _double* + _BOOL))]) (lambda (t) (and (identifier? t) (ormap (lambda (p) (free-identifier=? t p)) @@ -561,11 +562,36 @@ (define-syntax (type-vector stx) (let ([types (cdr (syntax->list stx))]) - ((if (andmap liftable-type? (cdr (syntax->list stx))) - (lambda (e) - (syntax-local-lift-expression #`(intern-type-vector #,e))) - values) - (quasisyntax/loc stx (vector . #,types))))) + (let ([vec-exp (quasisyntax/loc stx (vector . #,types))] + [type-exprs (cdr (syntax->list stx))]) + (cond + [(andmap liftable-type? type-exprs) + ;; Recognized types => simple lift + (syntax-local-lift-expression #`(intern-type-vector #,vec-exp))] + [(andmap (lambda (type-expr) + (and (identifier? type-expr) + (pair? (identifier-binding type-expr)))) + type-exprs) + ;; Types bound as imports => lift with cache and `#%variable-reference-constant?` check + (let* ([expanded-type-exprs + (map (lambda (type-expr) + (local-expand type-expr 'expression #f)) + type-exprs)] + [expanded-vec-exp #`(vector . #,expanded-type-exprs)]) + (cond + [(andmap identifier? expanded-type-exprs) + (let ([saved-vector-id (syntax-local-lift-expression #'(box #f))]) + (quasisyntax/loc stx + (or (unbox #,saved-vector-id) + (maybe-cache-type-vector-in-box + #,expanded-vec-exp + #,saved-vector-id + (vector #,@(for/list ([expanded-type-expr (in-list expanded-type-exprs)]) + #`(variable-reference-constant? (#%variable-reference #,expanded-type-expr))))))))] + [else expanded-vec-exp]))] + [else + ;; General case: construct type vector every time + vec-exp])))) (define type-vectors (make-hash)) (define (intern-type-vector v) @@ -574,6 +600,12 @@ (hash-set! type-vectors v v) v))) +(define (maybe-cache-type-vector-in-box vec saved-vec-box const?s) + (when (for/and ([c? (in-vector const?s)]) + c?) + (set-box! saved-vec-box vec)) + vec) + ;; ---------------------------------------- (provide define-objc-class @@ -697,11 +729,10 @@ (objc_addClass (cast id _Class _objc_class-pointer)))) (define (add-protocol id proto) - (unless proto - (error 'add-protocol "NULL protocol")) - (if class_addProtocol - (class_addProtocol id proto) - (add-protocol-the-hard-way id proto))) + (when proto + (if class_addProtocol + (class_addProtocol id proto) + (add-protocol-the-hard-way id proto)))) (define (object-get-class id) (if object_getClass diff -Nru racket-6.12+ppa1/collects/ffi/unsafe/os-thread.rkt racket-7.0+ppa1/collects/ffi/unsafe/os-thread.rkt --- racket-6.12+ppa1/collects/ffi/unsafe/os-thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/ffi/unsafe/os-thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base +(require '#%unsafe) + +(provide + (rename-out [unsafe-os-thread-enabled? os-thread-enabled?] + [unsafe-call-in-os-thread call-in-os-thread] + [unsafe-make-os-semaphore make-os-semaphore] + [unsafe-os-semaphore-post os-semaphore-post] + [unsafe-os-semaphore-wait os-semaphore-wait])) diff -Nru racket-6.12+ppa1/collects/ffi/unsafe.rkt racket-7.0+ppa1/collects/ffi/unsafe.rkt --- racket-6.12+ppa1/collects/ffi/unsafe.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/ffi/unsafe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -251,13 +251,12 @@ (syntax-case stx () [(_ var-name lib-name type-expr) (with-syntax ([(p) (generate-temporaries (list #'var-name))]) - (namespace-syntax-introduce - #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) - (define-syntax var-name - (syntax-id-rules (set!) - [(set! var val) (p val)] - [(var . xs) ((p) . xs)] - [var (p)])))))])) + #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) + (define-syntax var-name + (syntax-id-rules (set!) + [(set! var val) (p val)] + [(var . xs) ((p) . xs)] + [var (p)]))))])) ;; Used to convert strings and symbols to a byte-string that names an object (define (get-ffi-obj-name who objname) @@ -468,19 +467,35 @@ #:keep [keep #t] #:atomic? [atomic? #f] #:in-original-place? [orig-place? #f] + #:blocking? [blocking? #f] #:lock-name [lock-name #f] #:async-apply [async-apply #f] #:save-errno [errno #f]) - (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name)) + (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name)) + +;; A lightwegith delay meachnism for a single-argument function when +;; it's ok (but unlikely) to evaluate `expr` more than once and keep +;; the first result: +(define-syntax-rule (delay/cas expr) + (let ([b (box #f)]) + (lambda (arg) + (define f (unbox b)) + (cond + [f (f arg)] + [else + (box-cas! b #f expr) + ((unbox b) arg)])))) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name) +(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name) + (define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply))) + (define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking?))) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi atomic? async-apply)]) + (let ([cb (make-ffi-callback (wrap x))]) (cond [(eq? keep #t) (hash-set! held-callbacks x (make-ephemeron x cb))] [(box? keep) (let ([x (unbox keep)]) @@ -488,7 +503,7 @@ (if (or (null? x) (pair? x)) (cons cb x) cb)))] [(procedure? keep) (keep cb)]) cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place? lock-name)))))) + (lambda (x) (and x (wrap (make-ffi-call x)))))) (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: @@ -512,7 +527,7 @@ (provide _fun) (define-for-syntax _fun-keywords `([#:abi ,#'#f] [#:keep ,#'#t] [#:atomic? ,#'#f] - [#:in-original-place? ,#'#f] [#:lock-name ,#'#f] + [#:in-original-place? ,#'#f] [#:blocking? ,#'#f] [#:lock-name ,#'#f] [#:async-apply ,#'#f] [#:save-errno ,#'#f] [#:retry #f])) (define-syntax (_fun stx) @@ -675,6 +690,7 @@ #,(kwd-ref '#:keep) #,(kwd-ref '#:atomic?) #,(kwd-ref '#:in-original-place?) + #,(kwd-ref '#:blocking?) #,(kwd-ref '#:async-apply) #,(kwd-ref '#:save-errno) #,(kwd-ref '#:lock-name)))]) @@ -763,16 +779,25 @@ ;; utf-16 type (provide _string/ucs-4 _string/utf-16) +(define _bytes+nul + (make-ctype _bytes + (lambda (x) + (and x (let* ([len (bytes-length x)] + [s (make-bytes (add1 len))]) + (bytes-copy! s 0 x 0 len) + s))) + (lambda (x) x))) + ;; 8-bit string encodings, #f is NULL (define ((false-or-op op) x) (and x (op x))) (define* _string/utf-8 - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) (define* _string/locale - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) (define* _string/latin-1 - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) ;; 8-bit string encodings, #f is NULL, can also use bytes and paths @@ -782,13 +807,13 @@ [(path? x) (path->bytes x)] [else (op x)])) (define* _string*/utf-8 - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) (define* _string*/locale - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) (define* _string*/latin-1 - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) ;; A generic _string type that usually does the right thing via a parameter @@ -1059,16 +1084,49 @@ (define-fun-syntax _bytes* (syntax-id-rules (o) [(_ o n) (type: _gcpointer - pre: (let ([bstr (make-sized-byte-string (malloc (add1 n)) n)]) - ;; Ensure a null terminator, so that the result is - ;; compatible with `_bytes`: - (ptr-set! bstr _byte n 0) - bstr) + pre: (make-bytes-argument n) ;; post is needed when this is used as a function output type - post: (x => (make-sized-byte-string x n)))] + post: (x => (receive-bytes-result x n)))] [(_ . xs) (_bytes . xs)] [_ _bytes])) +(define (make-bytes-argument n) + (cond + [(eq? 'racket (system-type 'vm)) + (define bstr (make-sized-byte-string (malloc (add1 n)) n)) + ;; Ensure a null terminator, so that the result is + ;; compatible with `_bytes`: + (ptr-set! bstr _byte n 0) + bstr] + [else (make-bytes n)])) + +(define (receive-bytes-result x n) + (cond + [(eq? 'racket (system-type 'vm)) + (make-sized-byte-string x n)] + [else + (define bstr (make-bytes n)) + (memcpy bstr x n) + bstr])) + +;; _bytes/nul-terminated copies and includes a nul terminator in a +;; way that will be more consistent across Racket implementations +(define _bytes/nul-terminated + (make-ctype _bytes + (lambda (bstr) (and bstr (bytes-append bstr #"\0"))) + (lambda (bstr) (bytes-copy bstr)))) +(provide (rename-out [_bytes/nul-terminated* _bytes/nul-terminated])) +(define-fun-syntax _bytes/nul-terminated* + (syntax-id-rules (o) + [(_ o n) (type: _pointer + pre: (make-bytes n) + ;; post is needed when this is used as a function output type + post: (x => (let ([s (make-bytes n)]) + (memcpy s x n) + s)))] + [(_ . xs) (_bytes/nul-teriminated . xs)] + [_ _bytes/nul-terminated])) + ;; (_array ...+) (provide _array array? array-length array-ptr array-type @@ -1132,7 +1190,7 @@ ;; in-vector like sequence over array (define-:vector-like-gen :array-gen array-ref) -(define-in-vector-like in-array +(define-in-vector-like (in-array check-array) "array" array? array-length :array-gen) (define-sequence-syntax *in-array @@ -1142,6 +1200,7 @@ #'array? #'array-length #'in-array + #'check-array #'array-ref)) ;; (_array/list ...+) @@ -1174,6 +1233,8 @@ (protect-out union-ref union-set!)) (define (_union t . ts) + (unless (and (ctype? t) (andmap ctype? ts)) + (raise-argument-error '_union "list of c types" (cons t ts))) (let ([ts (cons t ts)]) (make-ctype (apply make-union-type ts) (lambda (v) (union-ptr v)) @@ -1181,8 +1242,26 @@ (define-struct union (ptr types)) (define (union-ref u i) + (unless (union? u) + (raise-argument-error 'union-ref "union value" 0 u i)) + (unless (exact-nonnegative-integer? i) + (raise-argument-error 'union-ref "exact-nonnegative-integer?" 1 u i)) + (unless (< i (length (union-types u))) + (raise-arguments-error 'union-ref + "index too large for union" + "index" + i)) (ptr-ref (union-ptr u) (list-ref (union-types u) i))) (define (union-set! u i v) + (unless (union? u) + (raise-argument-error 'union-ref "union value" 0 u i)) + (unless (exact-nonnegative-integer? i) + (raise-argument-error 'union-ref "exact-nonnegative-integer?" 1 u i)) + (unless (< i (length (union-types u))) + (raise-arguments-error 'union-ref + "index too large for union" + "index" + i)) (ptr-set! (union-ptr u) (list-ref (union-types u) i) v)) ;; ---------------------------------------------------------------------------- @@ -1336,14 +1415,15 @@ [(eq? t 'gcpointer) ctype] [(eq? t 'pointer) (let loop ([ctype ctype]) - (if (eq? ctype 'pointer) + (if (or (eq? ctype _pointer) + (eq? ctype 'pointer)) _gcpointer (make-ctype (loop (ctype-basetype ctype)) (ctype-scheme->c ctype) (ctype-c->scheme ctype))))] [else - (raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" + (raise-argument-error '_gcable "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" ctype)])) (define (ctype-coretype c) diff -Nru racket-6.12+ppa1/collects/launcher/launcher.rkt racket-7.0+ppa1/collects/launcher/launcher.rkt --- racket-6.12+ppa1/collects/launcher/launcher.rkt 2017-04-17 14:49:06.000000000 +0000 +++ racket-7.0+ppa1/collects/launcher/launcher.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -72,7 +72,7 @@ (define current-launcher-variant (make-parameter (cross-system-type 'gc) (lambda (v) - (unless (memq v '(3m script-3m cgc script-cgc)) + (unless (memq v '(3m script-3m cgc script-cgc cs script-cs)) (raise-type-error 'current-launcher-variant "variant symbol" @@ -116,26 +116,38 @@ [alt-kind (if (eq? '3m normal-kind) 'cgc '3m)] + [alt2-kind (if (or (eq? '3m normal-kind) + (eq? 'cgc normal-kind)) + 'cs + 'cgc)] [normal (if (variant-available? kind cased-kind-name normal-kind) (list normal-kind) null)] [alt (if (variant-available? kind cased-kind-name alt-kind) (list alt-kind) null)] + [alt2 (if (variant-available? kind cased-kind-name alt2-kind) + (list alt2-kind) + null)] + [kind->script-kind (lambda (kind) + (cond + [(eq? kind '3m) '(script-3m)] + [(eq? kind 'cgc) '(script-cgc)] + [else '(script-cs)]))] [script (if (and (eq? 'macosx (cross-system-type)) (eq? kind 'mred) (pair? normal)) - (if (eq? normal-kind '3m) - '(script-3m) - '(script-cgc)) + (kind->script-kind normal-kind) null)] [script-alt (if (and (memq alt-kind alt) (pair? script)) - (if (eq? alt-kind '3m) - '(script-3m) - '(script-cgc)) - null)]) - (append normal alt script script-alt))) + (kind->script-kind alt-kind) + null)] + [script-alt2 (if (and (memq alt2-kind alt2) + (pair? script)) + (kind->script-kind alt2-kind) + null)]) + (append normal alt alt2 script script-alt script-alt2))) (define (available-gracket-variants) (available-variants 'mred)) @@ -163,7 +175,7 @@ (file-or-directory-permissions dest perms2)))) (define (script-variant? v) - (memq v '(script-3m script-cgc))) + (memq v '(script-3m script-cgc script-cs))) (define (add-file-suffix path variant mred?) (let ([s (variant-suffix diff -Nru racket-6.12+ppa1/collects/net/http-client.rkt racket-7.0+ppa1/collects/net/http-client.rkt --- racket-6.12+ppa1/collects/net/http-client.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/net/http-client.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -54,8 +54,10 @@ (http-conn #f #f #f #f #f #f #f #f #f)) (define (http-conn-live? hc) - (and (http-conn-to hc) - (http-conn-from hc) + (define to (http-conn-to hc)) + (define from (http-conn-from hc)) + (and to (not (port-closed? to)) + from (not (port-closed? from)) #t)) (define (http-conn-liveable? hc) @@ -70,9 +72,13 @@ (define-values (from to) (cond [(list? ssl?) - ;; At this point, we have a tunneled socket to the remote host/port: we do not need to - ;; address it; ignore host-bs, only use port for conn-port-usual? - (match-define (list ssl-ctx? (? input-port? t:from) (? output-port? t:to) abandon-p) ssl?) + ;; At this point, we have a tunneled socket to the remote + ;; host/port: we do not need to address it; ignore host-bs, + ;; only use port for conn-port-usual? + (match-define (list ssl-ctx? + (? input-port? t:from) + (? output-port? t:to) + abandon-p) ssl?) (set-http-conn-abandon-p! hc abandon-p) (set-http-conn-port-usual?! hc (or (and ssl-ctx? (= 443 port)) (and (not ssl-ctx?) (= 80 port)))) @@ -119,7 +125,9 @@ (when from (close-input-port from) (set-http-conn-from! hc #f)) - (set-http-conn-abandon-p! hc #f)) + ;; Doesn't seem necessary because on a reconnect, the same abandon + ;; will be discovered. + #;(set-http-conn-abandon-p! hc #f)) (define (http-conn-abandon! hc) (match-define (http-conn host port port-usual? to from abandon @@ -130,8 +138,10 @@ (define (http-conn-enliven! hc) (when (and (not (http-conn-live? hc)) (http-conn-auto-reconnect? hc)) - (http-conn-open! hc (http-conn-auto-reconnect-host hc) #:ssl? (http-conn-auto-reconnect-ssl? hc) - #:port (http-conn-port hc) #:auto-reconnect? (http-conn-auto-reconnect? hc)))) + (http-conn-open! hc (http-conn-auto-reconnect-host hc) + #:ssl? (http-conn-auto-reconnect-ssl? hc) + #:port (http-conn-port hc) + #:auto-reconnect? (http-conn-auto-reconnect? hc)))) (define (write-chunk out data) (let ([bytes (->bytes data)]) @@ -268,7 +278,6 @@ (define (http-conn-CONNECT-tunnel proxy-host proxy-port target-host target-port #:ssl? [ssl? #f]) (define hc (http-conn-open proxy-host #:port proxy-port #:ssl? #f)) (define connect-string (format "~a:~a" target-host target-port)) - ; (log-net/url-info "http-conn-CONNECT-tunnel tunnel to ~s for ~s" connect-string (url->string url)) (http-conn-send! hc #:method "CONNECT" connect-string #:headers (list (format "Host: ~a" connect-string) "Proxy-Connection: Keep-Alive" @@ -289,7 +298,8 @@ [else ; ssl (define ssl-version (if (boolean? ssl?) 'auto ssl?)) (set-http-conn-port-usual?! hc (= 443 target-port)) - ;; choose between win32 or non-win32 openssl here, then keep code common afterwards + ;; choose between win32 or non-win32 openssl here, then keep + ;; code common afterwards (define-values (p->ssl-ps ssl-abndn-p) (if (or ssl-available? (not win32-ssl-available?)) (values ports->ssl-ports ssl-abandon-port) @@ -306,9 +316,10 @@ #:close-original? #t #:hostname target-host)) - ;; The user of the tunnel relies on ports->ssl-ports' #:close-original? to close/abandon the - ;; underlying ports of the tunnel itself. Therefore the abandon-p sent back to caller is the - ;; ssl-abandon of the wrapped ports. + ;; The user of the tunnel relies on ports->ssl-ports' + ;; #:close-original? to close/abandon the underlying ports + ;; of the tunnel itself. Therefore the abandon-p sent back + ;; to caller is the ssl-abandon of the wrapped ports. (define abandon-p ssl-abndn-p) (values clt-ctx r:from r:to abandon-p)])) @@ -363,8 +374,8 @@ (λ () (thread-wait gunzip-t) (when wait-for-close? - ;; Wait for an EOF from the raw port before we - ;; send an output on the decoding pipe: + ;; Wait for an EOF from the raw port before we send an + ;; output on the decoding pipe: (copy-port raw-response-port (open-output-nowhere))) (close-output-port out))) in] @@ -440,8 +451,8 @@ [http-conn-open! (->* (http-conn? (or/c bytes? string?)) (#:ssl? base-ssl?-tnl/c - #:port (between/c 1 65535) - #:auto-reconnect? boolean?) + #:port (between/c 1 65535) + #:auto-reconnect? boolean?) void?)] [http-conn-close! (-> http-conn? void?)] @@ -453,18 +464,18 @@ (->* (http-conn-liveable? (or/c bytes? string?)) (#:version (or/c bytes? string?) - #:method (or/c bytes? string? symbol?) - #:close? boolean? - #:headers (listof (or/c bytes? string?)) - #:content-decode (listof symbol?) - #:data (or/c false/c bytes? string? data-procedure/c)) + #:method (or/c bytes? string? symbol?) + #:close? boolean? + #:headers (listof (or/c bytes? string?)) + #:content-decode (listof symbol?) + #:data (or/c false/c bytes? string? data-procedure/c)) void)] ;; Derived [http-conn-open (->* ((or/c bytes? string?)) (#:ssl? base-ssl?-tnl/c - #:port (between/c 1 65535) - #:auto-reconnect? boolean?) + #:port (between/c 1 65535) + #:auto-reconnect? boolean?) http-conn?)] [http-conn-CONNECT-tunnel (->* ((or/c bytes? string?) @@ -476,25 +487,25 @@ [http-conn-recv! (->* (http-conn-liveable?) (#:content-decode (listof symbol?) - #:method (or/c bytes? string? symbol?) - #:close? boolean?) + #:method (or/c bytes? string? symbol?) + #:close? boolean?) (values bytes? (listof bytes?) input-port?))] [http-conn-sendrecv! (->* (http-conn-liveable? (or/c bytes? string?)) (#:version (or/c bytes? string?) - #:method (or/c bytes? string? symbol?) - #:headers (listof (or/c bytes? string?)) - #:data (or/c false/c bytes? string? data-procedure/c) - #:content-decode (listof symbol?) - #:close? boolean?) + #:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string? data-procedure/c) + #:content-decode (listof symbol?) + #:close? boolean?) (values bytes? (listof bytes?) input-port?))] [http-sendrecv (->* ((or/c bytes? string?) (or/c bytes? string?)) (#:ssl? base-ssl?-tnl/c - #:port (between/c 1 65535) - #:version (or/c bytes? string?) - #:method (or/c bytes? string? symbol?) - #:headers (listof (or/c bytes? string?)) - #:data (or/c false/c bytes? string? data-procedure/c) - #:content-decode (listof symbol?)) + #:port (between/c 1 65535) + #:version (or/c bytes? string?) + #:method (or/c bytes? string? symbol?) + #:headers (listof (or/c bytes? string?)) + #:data (or/c false/c bytes? string? data-procedure/c) + #:content-decode (listof symbol?)) (values bytes? (listof bytes?) input-port?))])) diff -Nru racket-6.12+ppa1/collects/net/osx-ssl.rkt racket-7.0+ppa1/collects/net/osx-ssl.rkt --- racket-6.12+ppa1/collects/net/osx-ssl.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/net/osx-ssl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,6 +5,8 @@ ffi/unsafe/alloc ffi/unsafe/atomic ffi/unsafe/custodian + ffi/unsafe/schedule + ffi/unsafe/os-thread racket/port racket/format openssl) @@ -39,6 +41,7 @@ (define _CFReadStreamRef (_cpointer/null 'CFReadStreamRef)) (define _CFWriteStreamRef (_cpointer/null 'CFWriteStreamRef)) +(define _CFErrorRef (_cpointer/null 'CFError)) (define _CFRunLoopRef (_cpointer/null 'CFRunLoopRef)) @@ -156,6 +159,14 @@ (define-cf CFWriteStreamGetStatus (_fun _CFWriteStreamRef -> _CFStreamStatus)) +(define-cf CFReadStreamCopyError + (_fun _CFReadStreamRef -> _CFErrorRef) + #:wrap (allocator CFRelease)) +(define-cf CFWriteStreamCopyError + (_fun _CFWriteStreamRef -> _CFErrorRef) + #:wrap (allocator CFRelease)) +(define-cf CFErrorCopyDescription + (_fun _CFErrorRef -> _NSString)) (define-cf CFDictionaryCreate (_fun (_pointer = #f) @@ -177,8 +188,6 @@ [proc4 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) -> _pointer)]) #:malloc-mode 'nonatomic) -(define-racket scheme_signal_received (_fun -> _void)) - (define _pthread (_cpointer/null 'pthread)) (define-racket pthread_create @@ -192,10 +201,12 @@ (define-racket scheme_call_sequence_of_procedures-ptr _fpointer #:c-id scheme_call_sequence_of_procedures) -(define-cf CFRunLoopRun-ptr _fpointer - #:c-id CFRunLoopRun) +(define-cf CFRunLoopGetCurrent (_fun -> _CFRunLoopRef)) +(define-cf CFRunLoopRun (_fun #:blocking? #t _CFRunLoopRef -> _void)) (define-cf CFRunLoopGetCurrent-ptr _fpointer #:c-id CFRunLoopGetCurrent) +(define-cf CFRunLoopRun-ptr _fpointer + #:c-id CFRunLoopRun) (define stop-and-release ((deallocator) @@ -211,36 +222,58 @@ (define (launch-run-loop-in-pthread init-reg more-retain) (define run-loop #f) - (define done (make-semaphore)) - (define (setup r) - ;; Called in atomic mode in arbitrary Racket thread: - (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) - (init-reg run-loop) - (semaphore-post done) - (scheme_signal_received) - #f) - (define (finished) - (free-immobile-cell retainer) - #f) - ;; Retains callbacks until the thread is done: - (define retainer (malloc-immobile-cell - (vector setup finished more-retain))) - (define seq (make-Scheme_Proc_Sequence 4 - #f - CFRunLoopGetCurrent-ptr - ;; `#:aync-apply` moves the following - ;; back to the main thread (in atomic mode): - setup - CFRunLoopRun-ptr - ;; `#:async-apply` here, too: - finished)) - (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) - (unless pth (error "could not start run-loop thread")) - (pthread_detach pth) - - (semaphore-wait done) - (set! done seq) ; retains `seq` until here + (cond + [(os-thread-enabled?) + (define create-done (make-os-semaphore)) + (define retain-done (make-os-semaphore)) + (define setup-done create-done) + (call-in-os-thread + (lambda () + (define rl (CFRunLoopGetCurrent)) + (set! run-loop rl) + (os-semaphore-post create-done) + (os-semaphore-wait retain-done) + (init-reg rl) + (os-semaphore-post setup-done) + (CFRunLoopRun rl) + (void/reference-sink more-retain))) + (os-semaphore-wait create-done) + ;; To be on the safe side, register a finalizer in the Racket thread: + (set! run-loop (CFRetainRunLoop run-loop)) + (os-semaphore-post retain-done) + (os-semaphore-wait setup-done)] + [else + (define done (make-semaphore)) + (define (setup r) + ;; Called in atomic mode in arbitrary Racket thread: + (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) + (init-reg run-loop) + (semaphore-post done) + (unsafe-signal-received) + #f) + (define (finished) + (free-immobile-cell retainer) + #f) + ;; Retains callbacks until the thread is done: + (define retainer (malloc-immobile-cell + (vector setup finished more-retain))) + (define seq (make-Scheme_Proc_Sequence 4 + #f + CFRunLoopGetCurrent-ptr + ;; `#:aync-apply` moves the following + ;; back to the main thread (in atomic mode): + setup + CFRunLoopRun-ptr + ;; `#:async-apply` here, too: + finished)) + (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) + (unless pth (error "could not start run-loop thread")) + (pthread_detach pth) + (semaphore-wait done) + (set! done seq) ; retains `seq` until here + + (void)]) run-loop) ;; ---------------------------------------- @@ -275,20 +308,20 @@ (check-ok (CFReadStreamSetProperty in kCFStreamPropertySSLSettings d)) (check-ok (CFWriteStreamSetProperty out kCFStreamPropertySSLSettings d)) (CFRelease d)) - + (define in-ready (make-semaphore)) (define out-ready (make-semaphore 1)) - + ;; These callback must be retained so that they're not GCed ;; until the run loop is terminated: (define in-callback (lambda (_in evt _null) (void (semaphore-try-wait? in-ready)) (semaphore-post in-ready) - (scheme_signal_received))) + (unsafe-signal-received))) (define out-callback (lambda (_out evt _null) (void (semaphore-try-wait? out-ready)) (semaphore-post out-ready) - (scheme_signal_received))) + (unsafe-signal-received))) (define context (make-CFStreamClientContext 0 #f #f #f #f)) (check-ok (CFReadStreamSetClient in all-evts in-callback context)) @@ -296,7 +329,8 @@ (define run-loop (launch-run-loop-in-pthread - ;; This function will be called as atomic within the scheduler: + ;; This function will be called as atomic within the scheduler + ;; or in a separate OS thread: (lambda (run-loop) (CFReadStreamScheduleWithRunLoop in run-loop kCFRunLoopDefaultMode) (CFWriteStreamScheduleWithRunLoop out run-loop kCFRunLoopDefaultMode)) @@ -304,7 +338,7 @@ (check-ok (CFWriteStreamOpen out)) (check-ok (CFReadStreamOpen in)) - + (let loop () (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusOpening) (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusOpening)) @@ -316,6 +350,13 @@ (raise (exn:fail:network (~a "osx-ssl-connect: connection failed\n" + " message: " (let ([err (if (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError) + (CFReadStreamCopyError in) + (CFWriteStreamCopyError out))]) + (begin0 + (CFErrorCopyDescription err) + (CFRelease err))) + "\n" " address: " host "\n" " port number: " port) (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/collects/net/win32-ssl.rkt racket-7.0+ppa1/collects/net/win32-ssl.rkt --- racket-6.12+ppa1/collects/net/win32-ssl.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/net/win32-ssl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -276,8 +276,8 @@ ;; To stream communication during protocol set-up: (define buffer-size 4096) - (define buffer (make-sized-byte-string (malloc buffer-size 'atomic-interior) - buffer-size)) + (define buffer (malloc buffer-size 'atomic-interior)) + (define tmp-buffer (make-bytes buffer-size)) (call-as-atomic (lambda () @@ -355,8 +355,8 @@ (call-as-nonatomic (lambda () (log-win32-ssl-debug "init context: write ~a" (SecBuffer-cbBuffer out-sb0)) - (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer out-sb0) - (SecBuffer-cbBuffer out-sb0)) + (write-bytes (pointer->bytes (SecBuffer-pvBuffer out-sb0) + (SecBuffer-cbBuffer out-sb0)) o) (flush-output o))) (FreeContextBuffer (SecBuffer-pvBuffer out-sb0)))) @@ -376,7 +376,7 @@ (log-win32-ssl-debug "init context: done") (values ctx (let ([n (get-leftover-bytes)]) - (subbytes buffer 0 n)))] + (pointer->bytes buffer n)))] [(or (= r SEC_I_CONTINUE_NEEDED) (= r SEC_E_INCOMPLETE_MESSAGE)) ;; Pull more data from the server @@ -389,13 +389,15 @@ (define new-buffer (malloc (* 2 buffer-size) 'atomic-interior)) (memcpy new-buffer buffer buffer-size) (set! buffer-size (* 2 buffer-size)) - (set! buffer (make-sized-byte-string new-buffer buffer-size))) + (set! buffer new-buffer) + (set! tmp-buffer (make-bytes buffer-size))) ;; Go back to non-atomic mode for a potentially blocking read: (define n (call-as-nonatomic (lambda () - (read-bytes-avail! buffer i new-data-len buffer-size)))) + (read-bytes-avail! tmp-buffer i 0 (- buffer-size new-data-len))))) (log-win32-ssl-debug "init context: read ~a" n) (when (eof-object? n) (network-error "unexpected EOF")) + (memcpy buffer new-data-len tmp-buffer n) (loop (+ new-data-len n) (if (= r SEC_I_CONTINUE_NEEDED) #f init?))] @@ -441,8 +443,8 @@ sb))) (unless sb (network-error "expected decrypted data")) - (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer sb) - (SecBuffer-cbBuffer sb)) + (write-bytes (pointer->bytes (SecBuffer-pvBuffer sb) + (SecBuffer-cbBuffer sb)) in-post-w) (define remain (or (for/or ([i (in-range 1 4)]) (define sb (ptr-ref out-sb _SecBuffer i)) @@ -711,6 +713,13 @@ (hash-ref win32-ssl-ports p #f)) ;; ---------------------------------------- + +(define (pointer->bytes p len) + (define bstr (make-bytes len)) + (memcpy bstr p len) + bstr) + +;; ---------------------------------------- ;; Initialization (when (eq? 'windows (system-type)) diff -Nru racket-6.12+ppa1/collects/openssl/libcrypto.rkt racket-7.0+ppa1/collects/openssl/libcrypto.rkt --- racket-6.12+ppa1/collects/openssl/libcrypto.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/openssl/libcrypto.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,6 +12,12 @@ ;; Notes on shared library versions when provided by OS ;; ie, VERSION s.t. OS provides "lib{crypto,ssl}.{so,dylib}.$VERSION" ;; +;; As of 1.0.0, OpenSSL has adopted a friendlier version policy (see +;; https://www.openssl.org/policies/releasestrat.html), and recent +;; Linux distros (eg Fedora 27, Debian 9.3 ("stretch")) seem to be +;; using (more) compatible .so versions. +;; +;; Notes on older versions: ;; - Debian and Ubuntu use a few fixed library versions even though ;; actual OpenSSL version changes: ;; - Debian squeeze: lib{crypto,ssl}.so.0.9.8 @@ -30,6 +36,9 @@ '(;; Versionless (eg from devel pkg) "" + "1.1" + "1.0.2" + ;; Compatibility-based version / SONAME "10" ;; Fedora "1.0.0" ;; Debian, Ubuntu @@ -48,8 +57,8 @@ (case (if runtime? (system-type) (cross-system-type)) [(windows) '(so "libeay32")] [(macosx) - ;; Version "1.0.0" is bundled with Racket - '(so "libcrypto" ("1.0.0" #f))] + ;; Version "1.1" is bundled with Racket + '(so "libcrypto" ("1.1" #f))] [else '(so "libcrypto")])) (define libcrypto diff -Nru racket-6.12+ppa1/collects/openssl/libssl.rkt racket-7.0+ppa1/collects/openssl/libssl.rkt --- racket-6.12+ppa1/collects/openssl/libssl.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/openssl/libssl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -18,8 +18,8 @@ (case (if runtime? (system-type) (cross-system-type)) [(windows) '(so "ssleay32")] [(macosx) - ;; Version "1.0.0" is bundled with Racket - '(so "libssl" ("1.0.0" #f))] + ;; Version "1.1" is bundled with Racket + '(so "libssl" ("1.1" #f))] [else '(so "libssl")])) (define libssl diff -Nru racket-6.12+ppa1/collects/openssl/mzssl.rkt racket-7.0+ppa1/collects/openssl/mzssl.rkt --- racket-6.12+ppa1/collects/openssl/mzssl.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/openssl/mzssl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -205,8 +205,6 @@ (or libssl-load-fail-reason libcrypto-load-fail-reason)) -(define 3m? (eq? '3m (system-type 'gc))) - (define libmz (ffi-lib #f)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -281,13 +279,13 @@ (SSL_CTX_ctrl ctx SSL_CTRL_OPTIONS opts #f)) (define-ssl SSL_CTX_set_verify (_fun _SSL_CTX* _int _pointer -> _void)) -(define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _bytes -> _int)) -(define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _bytes _bytes -> _int)) +(define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _path -> _int)) +(define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _path _path -> _int)) (define-ssl SSL_CTX_set_client_CA_list (_fun _SSL_CTX* _X509_NAME* -> _int)) (define-ssl SSL_CTX_set_session_id_context (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_load_client_CA_file (_fun _bytes -> _X509_NAME*/null)) +(define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _path _int -> _int)) +(define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _path _int -> _int)) +(define-ssl SSL_load_client_CA_file (_fun _path -> _X509_NAME*/null)) (define-ssl SSL_CTX_set_cipher_list (_fun _SSL_CTX* _string -> _int)) (define-ssl SSL_free (_fun _SSL* -> _void) @@ -340,10 +338,21 @@ (define-crypto X509_NAME_get_entry (_fun _X509_NAME* _int -> _X509_NAME_ENTRY*/null)) (define-crypto X509_NAME_ENTRY_get_data (_fun _X509_NAME_ENTRY* -> _ASN1_STRING*)) (define-crypto X509_get_ext_d2i (_fun _X509* _int _pointer _pointer -> _STACK*/null)) -(define-crypto sk_num (_fun _STACK* -> _int)) -(define-crypto sk_GENERAL_NAME_value (_fun _STACK* _int -> _GENERAL_NAME-pointer) - #:c-id sk_value) -(define-crypto sk_pop_free (_fun _STACK* _fpointer -> _void)) +(define sk_num + (or (get-ffi-obj 'sk_num libcrypto (_fun _STACK* -> _int) + (lambda () #f)) + (get-ffi-obj 'OPENSSL_sk_num libcrypto (_fun _STACK* -> _int) + (make-not-available 'sk_num)))) +(define sk_GENERAL_NAME_value + (or (get-ffi-obj 'sk_value libcrypto (_fun _STACK* _int -> _GENERAL_NAME-pointer) + (lambda () #f)) + (get-ffi-obj 'OPENSSL_sk_value libcrypto (_fun _STACK* _int -> _GENERAL_NAME-pointer) + (make-not-available "sk_GENERAL_NAME_value")))) +(define sk_pop_free + (or (get-ffi-obj 'sk_pop_free libcrypto (_fun _STACK* _fpointer -> _void) + (lambda () #f)) + (get-ffi-obj 'OPENSSL_sk_pop_free libcrypto (_fun _STACK* _fpointer -> _void) + (make-not-available "sk_pop_free")))) ;; (define-crypto X509_get_default_cert_area (_fun -> _string)) (define-crypto X509_get_default_cert_dir (_fun -> _string)) @@ -513,14 +522,6 @@ server?) #:mutable) -(define (make-immobile-bytes n) - (if 3m? - ;; Allocate the byte string via malloc: - (let ([p (malloc 'atomic-interior n)]) - (make-sized-byte-string p n)) - ;; Normal byte string is immobile: - (make-bytes n))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Errors @@ -715,13 +716,12 @@ (path->complete-path (cleanse-path pathname) (current-directory))]) (security-guard-check-file who path '(read)) - (let ([path (path->bytes path)]) - (atomically ;; for to connect ERR_get_error to `load-it' - (let ([n (load-it ctx path)]) - (unless (or (= n 1) try?) - (error who "load failed from: ~e ~a" - pathname - (get-error-message (ERR_get_error)))))))))) + (atomically ;; for to connect ERR_get_error to `load-it' + (let ([n (load-it ctx path)]) + (unless (or (= n 1) try?) + (error who "load failed from: ~e ~a" + pathname + (get-error-message (ERR_get_error))))))))) (define (ssl-load-certificate-chain! ssl-context-or-listener pathname) (ssl-load-... 'ssl-load-certificate-chain! @@ -1020,7 +1020,7 @@ ;; call to SSL_read must use the same arguments. ;; Use xfer-buffer so we have a consistent buffer to use with ;; SSL_read across calls to the port's write function. - (let-values ([(xfer-buffer) (make-immobile-bytes BUFFER-SIZE)] + (let-values ([(xfer-buffer) (make-bytes BUFFER-SIZE)] [(got-r got-w) (make-pipe)] [(must-read-len) #f]) (make-input-port/read-to-peek @@ -1156,7 +1156,7 @@ ;; call to SSL_write must use the same arguments. ;; Use xfer-buffer so we have a consistent buffer to use with ;; SSL_write across calls to the port's write function. - (let ([xfer-buffer (make-immobile-bytes BUFFER-SIZE)] + (let ([xfer-buffer (make-bytes BUFFER-SIZE)] [buffer-mode (or (file-stream-buffer-mode (mzssl-o mzssl)) 'bloack)] [flush-ch (make-channel)] [must-write-len #f]) @@ -1694,7 +1694,7 @@ ;; it. (begin (start-atomic) - (let* ([done (cast 1 _scheme _pointer)] + (let* ([done (ptr-add #f 1)] [v (register-process-global #"OpenSSL-support-initializing" done)]) (if v ;; Some other place is initializing: diff -Nru racket-6.12+ppa1/collects/pkg/dirs-catalog.rkt racket-7.0+ppa1/collects/pkg/dirs-catalog.rkt --- racket-6.12+ppa1/collects/pkg/dirs-catalog.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/dirs-catalog.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,6 +14,7 @@ (provide create-dirs-catalog) (module+ main + (define immediate? #f) (define link? #f) (define merge? #f) (define check-metadata? #f) @@ -21,6 +22,8 @@ (command-line #:once-each + ["--immediate" "Check given directories as immediate packages" + (set! immediate? #t)] ["--link" "Install packages as links" (set! link? #t)] ["--merge" "Preserve existing packages in catalog" @@ -34,6 +37,7 @@ (create-dirs-catalog catalog-path ;; a list: dir + #:immediate? immediate? #:status-printf (if quiet? void printf) #:link? link? #:merge? merge? @@ -41,6 +45,7 @@ (define (create-dirs-catalog catalog-path dirs + #:immediate? [immediate? #f] #:status-printf [status-printf void] #:link? [link? #f] #:merge? [merge? #f] @@ -55,21 +60,31 @@ ;; further into the package) (for ([src-dir (in-list dirs)]) (when (directory-exists? src-dir) - (let loop ([src-dir src-dir]) + (define (check-content src-dir) (for ([f (in-list (directory-list src-dir))]) (define src-f (build-path src-dir f)) - (cond - [(file-exists? (build-path src-f "info.rkt")) - (define f-name (path->string f)) - (when (hash-ref found f-name #f) - (error 'pack-local - "found package ~a multiple times: ~a and ~a" - f-name - (hash-ref found f-name) - src-f)) - (hash-set! found f-name src-f)] - [(directory-exists? src-f) - (loop src-f)]))))) + (check-path src-f f))) + (define (check-path src-f f) + (cond + [(file-exists? (build-path src-f "info.rkt")) + (define f-name (path->string f)) + (when (hash-ref found f-name #f) + (error 'pack-local + "found package ~a multiple times: ~a and ~a" + f-name + (hash-ref found f-name) + src-f)) + (hash-set! found f-name src-f)] + [(directory-exists? src-f) + (check-content src-f)])) + (cond + [(and immediate? + (let-values ([(base name dir?) (split-path src-dir)]) + (and (path? name) + name))) + => (lambda (f) (check-path src-dir f))] + [else + (check-content src-dir)]))) (unless merge? (when (directory-exists? (build-path catalog-path "pkg")) diff -Nru racket-6.12+ppa1/collects/pkg/main.rkt racket-7.0+ppa1/collects/pkg/main.rkt --- racket-6.12+ppa1/collects/pkg/main.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -150,7 +150,9 @@ #:install-force-flags (install-force-flags ...) #:install-clone-flags (install-clone-flags ...) #:update-deps-flags (update-deps-flags ...) - #:install-copy-flags (install-copy-flags ...) + #:install-copy-flags/pre-clone (install-copy-flags/pre-clone ...) + #:install-copy-flags/unclone (install-copy-flags/unclone ...) + #:install-copy-flags/post-clone (install-copy-flags/post-clone ...) #:install-copy-defns (install-copy-defns ...) #:install-copy-checks (install-copy-checks ...)) (replace-context @@ -173,7 +175,8 @@ #:once-each update-deps-flags ... #:once-any - install-copy-flags ... + install-copy-flags/pre-clone ... + install-copy-flags/post-clone ... #:once-any scope-flags ... #:once-each @@ -269,7 +272,9 @@ #:once-each update-deps-flags ... #:once-any - install-copy-flags ... + install-copy-flags/pre-clone ... + install-copy-flags/unclone ... + install-copy-flags/post-clone ... #:once-any scope-flags ... #:once-each @@ -306,13 +311,14 @@ install-copy-checks ... (define clone-path (and (eq? a-type 'clone) (path->complete-path clone))) + (define lookup? (or lookup unclone)) (define setup-collects (with-pkg-lock (parameterize ([current-pkg-catalogs (and catalog (list (catalog->url catalog)))]) (pkg-update (for/list ([pkg-source (in-list pkg-source)]) (cond - [lookup + [lookup? (pkg-desc pkg-source a-type name checksum #f #:path clone-path)] [else @@ -341,7 +347,7 @@ (and binary 'binary) (and binary-lib 'binary-lib)) #:force-strip? force - #:lookup-for-clone? lookup + #:lookup-for-clone? lookup? #:multi-clone-behavior (or multi-clone (if batch 'fail @@ -710,12 +716,15 @@ #:update-deps-flags ([#:bool update-deps () "For `search-ask' or `search-auto', also update dependencies"] [#:bool ignore-implies () "When updating, treat `implies' like other dependencies"]) - #:install-copy-flags + #:install-copy-flags/pre-clone ([#:bool link () ("Link a directory package source in place (default for a directory)")] [#:bool static-link () ("Link in place, promising collections do not change")] [#:bool copy () ("Treat directory sources the same as other sources")] - [(#:str dir #f) clone () ("Clone Git and GitHub package sources to and link")] - [#:bool source () ("Strip packages' built elements before installing; implies --copy")] + [(#:str dir #f) clone () ("Clone Git and GitHub package sources to and link")]) + #:install-copy-flags/unclone + ([#:bool unclone () ("Unclones when currently a clone; alias for --lookup")]) + #:install-copy-flags/post-clone + ([#:bool source () ("Strip packages' built elements before installing; implies --copy")] [#:bool binary () ("Strip packages' source elements before installing; implies --copy")] [#:bool binary-lib () ("Strip source & documentation before installing; implies --copy")]) #:install-copy-defns diff -Nru racket-6.12+ppa1/collects/pkg/private/catalog-copy.rkt racket-7.0+ppa1/collects/pkg/private/catalog-copy.rkt --- racket-6.12+ppa1/collects/pkg/private/catalog-copy.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/private/catalog-copy.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -121,32 +121,34 @@ (for/hash ([(k v) (in-hash details)]) (values k (select-info-version v)))) (parameterize ([db:current-pkg-catalog-file dest-path]) - (db:set-catalogs! '("local")) - (db:set-pkgs! "local" - (for/list ([(k v) (in-hash vers-details)]) - (db:pkg k "local" - (hash-ref v 'author "") - (hash-ref v 'source "") - (hash-ref v 'checksum "") - (hash-ref v 'description "")))) - (for ([(k v) (in-hash vers-details)]) - (define t (hash-ref v 'tags '())) - (unless (null? t) - (db:set-pkg-tags! k "local" t))) - (for ([(k v) (in-hash vers-details)]) - (define mods (hash-ref v 'modules '())) - (unless (null? mods) - (define cs (hash-ref v 'checksum "")) - (db:set-pkg-modules! k "local" cs mods))) - (for ([(k v) (in-hash vers-details)]) - (define deps (hash-ref v 'dependencies '())) - (unless (null? deps) - (define cs (hash-ref v 'checksum "")) - (db:set-pkg-dependencies! k "local" cs deps))) - (for ([(k v) (in-hash vers-details)]) - (define ring (hash-ref v 'ring #f)) - (when ring - (db:set-pkg-ring! k "local" ring))))] + (db:call-with-pkgs-transaction + (lambda () + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" + (for/list ([(k v) (in-hash vers-details)]) + (db:pkg k "local" + (hash-ref v 'author "") + (hash-ref v 'source "") + (hash-ref v 'checksum "") + (hash-ref v 'description "")))) + (for ([(k v) (in-hash vers-details)]) + (define t (hash-ref v 'tags '())) + (unless (null? t) + (db:set-pkg-tags! k "local" t))) + (for ([(k v) (in-hash vers-details)]) + (define mods (hash-ref v 'modules '())) + (unless (null? mods) + (define cs (hash-ref v 'checksum "")) + (db:set-pkg-modules! k "local" cs mods))) + (for ([(k v) (in-hash vers-details)]) + (define deps (hash-ref v 'dependencies '())) + (unless (null? deps) + (define cs (hash-ref v 'checksum "")) + (db:set-pkg-dependencies! k "local" cs deps))) + (for ([(k v) (in-hash vers-details)]) + (define ring (hash-ref v 'ring #f)) + (when ring + (db:set-pkg-ring! k "local" ring))))))] [else (define pkg-path (build-path dest-path "pkg")) (make-directory* pkg-path) diff -Nru racket-6.12+ppa1/collects/pkg/private/path.rkt racket-7.0+ppa1/collects/pkg/private/path.rkt --- racket-6.12+ppa1/collects/pkg/private/path.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/private/path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,8 @@ (require racket/path racket/file racket/list - racket/function) + racket/function + "rename-dir.rkt") (provide (all-defined-out)) @@ -55,15 +56,15 @@ ;; pick a new name: (loop (string->path (format "sub~a" i)) (add1 i))] [(not (equal? sub orig-sub)) - (rename-file-or-directory (build-path pkg-dir orig-sub) - (build-path pkg-dir sub)) + (rename-directory (build-path pkg-dir orig-sub) + (build-path pkg-dir sub)) sub] [else sub]))) ;; Move content of `sub` out: (define sub-path (apply build-path (cons sub (cdr path)))) (for ([f (in-list sub-l)]) - (rename-file-or-directory (build-path pkg-dir sub-path f) - (build-path pkg-dir f))) + (rename-directory (build-path pkg-dir sub-path f) + (build-path pkg-dir f))) ;; Remove directory that we moved files out of: (delete-directory/files (build-path pkg-dir sub))) diff -Nru racket-6.12+ppa1/collects/pkg/private/remove.rkt racket-7.0+ppa1/collects/pkg/private/remove.rkt --- racket-6.12+ppa1/collects/pkg/private/remove.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/private/remove.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,7 +11,8 @@ "params.rkt" "print.rkt" "get-info.rkt" - "trash.rkt") + "trash.rkt" + "rename-dir.rkt") (provide remove-package pkg-remove) @@ -64,7 +65,7 @@ (select-trash-dest pkg-name)) => (lambda (trash-dest) (printf/flush "Moving ~a to trash: ~a\n" pkg-name trash-dest) - (rename-file-or-directory pkg-dir trash-dest))] + (rename-directory pkg-dir trash-dest))] [else (delete-directory/files pkg-dir)])]))) diff -Nru racket-6.12+ppa1/collects/pkg/private/rename-dir.rkt racket-7.0+ppa1/collects/pkg/private/rename-dir.rkt --- racket-6.12+ppa1/collects/pkg/private/rename-dir.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/pkg/private/rename-dir.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ +#lang racket/base +(require racket/file) + +(provide rename-directory) + +(define (rename-directory old-path new-path) + (cond + [(eq? 'windows (system-type)) + (with-handlers* ([(lambda (exn) + (and (exn:fail:filesystem:errno? exn) + (let ([errno (exn:fail:filesystem:errno-errno exn)]) + (and (eq? 'windows (cdr errno)) + (eqv? (car errno) 5))))) ; ERROR_ACCESS_DENIED + (lambda (exn) + ;; ERROR_ACCESS_DENIED can mean that a file within the + ;; directory is open. We can't just rename the directory + ;; in that case, but we can copy it. + (copy-directory/files old-path new-path + #:keep-modify-seconds? #t + #:preserve-links? #t) + (delete-directory/files old-path))]) + (rename-file-or-directory old-path new-path))] + [else + (rename-file-or-directory old-path new-path)])) diff -Nru racket-6.12+ppa1/collects/racket/cmdline.rkt racket-7.0+ppa1/collects/racket/cmdline.rkt --- racket-6.12+ppa1/collects/racket/cmdline.rkt 2017-04-12 22:00:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/cmdline.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -49,6 +49,13 @@ [(null? lst) null] [(keyword? (syntax-e (car lst))) lst] [else (at-next-keyword (cdr lst))])) + (define (check-ok-flag flag) + (unless (regexp-match? #rx"^([-+][^-+]$|(--|[+][+])[^-+])" (syntax-e flag)) + (serror "bad flag string" flag)) + (when (regexp-match? #rx"^[-+][0-9]$" (syntax-e flag)) + (serror "number flag not allowed" flag)) + (when (regexp-match? #rx"^(-h|--help)$" (syntax-e flag)) + (serror "pre-defined flag not allowed" flag))) (let ([lst (syntax->list stx)]) (unless lst (raise-syntax-error #f "bad syntax (misuse of `.')" stx)) @@ -99,17 +106,22 @@ ([flags (syntax-case (car sublines) () [((flag ...) . rest) - (begin + (let ([flags (syntax->list #'(flag ...))]) (unless (andmap (lambda (x) (string? (syntax-e x))) - (syntax->list #'(flag ...))) + flags) (serror - "flag specification is not a string or sequence of strings" - #'(flag ...))) + "flag specification is not a string or sequence of strings" + (syntax-case (car sublines) () + [(flags . rest) + #'flags]))) + (for-each check-ok-flag flags) #'(flag ...))] [(flag . rest) (string? (syntax-e #'flag)) - #'(flag)] + (begin + (check-ok-flag #'flag) + #'(flag))] [else (serror "clause does not start with flags")])]) (syntax-case* (car sublines) (=>) id=? diff -Nru racket-6.12+ppa1/collects/racket/contract/combinator.rkt racket-7.0+ppa1/collects/racket/contract/combinator.rkt --- racket-6.12+ppa1/collects/racket/contract/combinator.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/combinator.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -27,10 +27,6 @@ make-contract - prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test - prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts @@ -55,6 +51,7 @@ build-compound-type-name contract-stronger? + contract-equivalent? list-contract? contract-first-order @@ -109,7 +106,9 @@ [-make-flat-contract make-flat-contract] [-build-chaperone-contract-property build-chaperone-contract-property] [-build-flat-contract-property build-flat-contract-property]) - skip-projection-wrapper?) + skip-projection-wrapper? + + contract-pos/neg-doubling) (define skip-projection-wrapper? (make-parameter #f)) @@ -127,6 +126,7 @@ #:val-first-projection [val-first-projection #f] #:projection [projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:list-contract? [is-list-contract #f]) (:make-chaperone-contract #:name name @@ -138,6 +138,7 @@ #:projection (maybe-add-wrapper add-projection-chaperone-check projection) #:stronger stronger + #:equivalent equivalent #:list-contract? is-list-contract))]) make-chaperone-contract)) @@ -150,6 +151,7 @@ #:late-neg-projection [late-neg-proj #f] #:projection [get-projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:generate [generate #f] #:exercise [exercise #f] #:list-contract? [is-list-contract? (λ (c) #f)]) @@ -163,6 +165,7 @@ #:projection (maybe-add-wrapper add-prop-chaperone-check get-projection) #:stronger stronger + #:equivalent equivalent #:generate generate #:exercise exercise #:list-contract? is-list-contract?)) @@ -221,6 +224,7 @@ #:val-first-projection [val-first-projection #f] #:projection [projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:list-contract? [is-list-contract #f]) (:make-flat-contract #:name name @@ -229,6 +233,7 @@ #:val-first-projection (force-val-first-eq val-first-projection) #:projection (force-projection-eq projection) #:stronger stronger + #:equivalent equivalent #:list-contract? is-list-contract))]) make-flat-contract)) @@ -240,6 +245,7 @@ #:val-first-projection [val-first-projection #f] #:projection [projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:generate [generate (λ (ctc) (λ (fuel) #f))] #:list-contract? [is-list-contract (λ (c) #f)]) (:build-flat-contract-property @@ -252,6 +258,7 @@ #:projection (and projection (λ (c) (force-projection-eq (projection c)))) #:stronger stronger + #:equivalent equivalent #:generate generate #:list-contract? is-list-contract))]) build-flat-contract-property)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/and.rkt racket-7.0+ppa1/collects/racket/contract/private/and.rkt --- racket-6.12+ppa1/collects/racket/contract/private/and.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/and.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -62,6 +62,11 @@ (pairwise-stronger-contracts? (base-and/c-ctcs this) (base-and/c-ctcs that)))) +(define (and-equivalent? this that) + (and (base-and/c? that) + (pairwise-equivalent-contracts? (base-and/c-ctcs this) + (base-and/c-ctcs that)))) + (define (and/c-generate? ctc) (cond [(and/c-check-nonneg ctc real?) => values] @@ -147,6 +152,7 @@ #:name and-name #:first-order and-first-order #:stronger and-stronger? + #:equivalent and-equivalent? #:generate and/c-generate?)) (define-struct (chaperone-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc @@ -156,6 +162,7 @@ #:name and-name #:first-order and-first-order #:stronger and-stronger? + #:equivalent and-equivalent? #:generate and/c-generate?)) (define-struct (impersonator-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc @@ -165,6 +172,7 @@ #:name and-name #:first-order and-first-order #:stronger and-stronger? + #:equivalent and-equivalent? #:generate and/c-generate?)) (define-syntax (and/c stx) @@ -274,15 +282,25 @@ [else exact-integer?])) (define (integer-in-stronger this that) - (define this-start (or (integer-in-ctc-start this) -inf.0)) - (define this-end (or (integer-in-ctc-end this) +inf.0)) (cond [(integer-in-ctc? that) + (define this-start (or (integer-in-ctc-start this) -inf.0)) + (define this-end (or (integer-in-ctc-end this) +inf.0)) (define that-start (or (integer-in-ctc-start that) -inf.0)) (define that-end (or (integer-in-ctc-end that) +inf.0)) (<= that-start this-start this-end that-end)] [else #f])) +(define (integer-in-equivalent this that) + (cond + [(integer-in-ctc? that) + (define this-start (or (integer-in-ctc-start this) -inf.0)) + (define this-end (or (integer-in-ctc-end this) +inf.0)) + (define that-start (or (integer-in-ctc-start that) -inf.0)) + (define that-end (or (integer-in-ctc-end that) +inf.0)) + (and (= that-start this-start) (= this-end that-end))] + [else #f])) + (define (integer-in-generate ctc) (define start (integer-in-ctc-start ctc)) (define end (integer-in-ctc-end ctc)) @@ -311,6 +329,7 @@ #:name integer-in-name #:first-order integer-in-first-order #:stronger integer-in-stronger + #:equivalent integer-in-equivalent #:generate integer-in-generate)) (struct renamed-integer-in integer-in-ctc (name) @@ -319,6 +338,7 @@ #:name (λ (ctc) (renamed-integer-in-name ctc)) #:first-order integer-in-first-order #:stronger integer-in-stronger + #:equivalent integer-in-equivalent #:generate integer-in-generate)) (define (geo-dist p) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arr-d.rkt racket-7.0+ppa1/collects/racket/contract/private/arr-d.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arr-d.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arr-d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -545,7 +545,7 @@ (if (base-->d-rest-ctc ctc) (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f) (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f))))) -(define (->d-stronger? this that) (eq? this that)) +(define (->d-equivalent? this that) (eq? this that)) ;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that ;; is under the contract, and "dr???" refers to the arguments & the results of the function that @@ -580,4 +580,5 @@ #:late-neg-projection (late-neg-->d-proj impersonate-procedure) #:name (->d-name #|print-as-method-if-method?|# #t) #:first-order ->d-first-order - #:stronger ->d-stronger?)) + #:equivalent ->d-equivalent? + #:stronger ->d-equivalent?)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arr-i.rkt racket-7.0+ppa1/collects/racket/contract/private/arr-i.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arr-i.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arr-i.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -317,6 +317,7 @@ (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f) (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f))))) #:exercise exercise->i + #:equivalent (λ (this that) (eq? this that)) #:stronger (λ (this that) (eq? this that)))) ;; WRONG (struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arrow-common.rkt racket-7.0+ppa1/collects/racket/contract/private/arrow-common.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arrow-common.rkt 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arrow-common.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -349,8 +349,8 @@ #:missing-party [missing-party #f]) (define num-values (length results)) (define blame-case (if case-context - (blame-add-context blame (format "the ~a case of" - (n->th (+ case-context 1)))) + (blame-add-context blame + (nth-case-of (+ case-context 1))) blame)) (raise-blame-error (blame-add-range-context blame-case) #:missing-party missing-party @@ -360,8 +360,7 @@ num-values (if (= num-values 1) "" "s"))) (define (blame-add-nth-arg-context blame n) - (blame-add-context blame - (format "the ~a argument of" (n->th n)))) + (blame-add-context blame (nth-argument-of n))) (define (raise-wrong-number-of-args-error blame #:missing-party [missing-party #f] val diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arrow-higher-order.rkt racket-7.0+ppa1/collects/racket/contract/private/arrow-higher-order.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arrow-higher-order.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arrow-higher-order.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -560,7 +560,7 @@ [n (in-naturals 1)]) ((get/build-late-neg-projection dom) (blame-add-context orig-blame - (format "the ~a argument of" (n->th (if method? (sub1 n) n))) + (nth-argument-of (if method? (sub1 n) n)) #:swap? #t)))) (define rest-blame (if (ellipsis-rest-arg-ctc? rest) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arrow-val-first.rkt racket-7.0+ppa1/collects/racket/contract/private/arrow-val-first.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arrow-val-first.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arrow-val-first.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -588,6 +588,13 @@ (sort (map cons kwds kwd-args) keyword* raw-optional-doms this->*)]) + ;; call sort-keywords for the duplicate variable check + (sort-keywords stx (append (syntax->list #'man-dom-kwds) (syntax->list #'opt-dom-kwds))) (values #'man-dom #'man-dom-kwds @@ -1549,6 +1558,7 @@ (λ (val) ((cblame val) #f)))) #:stronger ->-stronger + #:equivalent ->-equivalent #:generate ->-generate #:exercise ->-exercise #:val-first-projection val-first-proj @@ -1574,6 +1584,29 @@ (not (base->-rngs that))) (not (base->-pre? this)) (not (base->-pre? that)) + (not (base->-post? this)) + (not (base->-post? that)))) + +(define (->-equivalent this that) + (and (base->? that) + (= (length (base->-doms that)) + (length (base->-doms this))) + (= (base->-min-arity this) (base->-min-arity that)) + (andmap contract-struct-equivalent? (base->-doms that) (base->-doms this)) + (= (length (base->-kwd-infos this)) + (length (base->-kwd-infos that))) + (for/and ([this-kwd-info (base->-kwd-infos this)] + [that-kwd-info (base->-kwd-infos that)]) + (and (equal? (kwd-info-kwd this-kwd-info) + (kwd-info-kwd that-kwd-info)) + (contract-struct-equivalent? (kwd-info-ctc that-kwd-info) + (kwd-info-ctc this-kwd-info)))) + (if (base->-rngs this) + (and (base->-rngs that) + (andmap contract-struct-equivalent? (base->-rngs this) (base->-rngs that))) + (not (base->-rngs that))) + (not (base->-pre? this)) + (not (base->-pre? that)) (not (base->-post? this)) (not (base->-post? that)))) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/arr-util.rkt racket-7.0+ppa1/collects/racket/contract/private/arr-util.rkt --- racket-6.12+ppa1/collects/racket/contract/private/arr-util.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/arr-util.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -94,17 +94,20 @@ (cond [(null? lst) (list x)] [else - (let ([fst-kwd (syntax-e (car (syntax-e (car lst))))] - [x-kwd (syntax-e (car (syntax-e x)))]) - (cond - [(equal? x-kwd fst-kwd) - (raise-syntax-error #f - "duplicate keyword" - stx - (car x))] - [(keywordlist stx)]) + (when l + (for ([thing (in-list (cdr (syntax->list stx)))]) + (when (keyword? (syntax-e thing)) + (unless (equal? (syntax-e thing) '#:limit-context) + (raise-syntax-error 'contract + (format "did not expect keyword ~a" (syntax-e thing)) + stx + thing)))))) + (syntax-case stx () + [(_ c v pos neg #:limit-context limit-context-expression) + (with-syntax ([name (syntax-local-infer-name stx)]) + (syntax/loc stx + (apply-contract c v pos neg 'name + (build-source-location #f) + limit-context-expression)))] [(_ c v pos neg name loc) (syntax/loc stx - (apply-contract c v pos neg name loc))] + (apply-contract c v pos neg name loc #f))] [(_ c v pos neg) (with-syntax ([name (syntax-local-infer-name stx)]) - (syntax/loc stx - (apply-contract c v pos neg 'name - (build-source-location #f))))] - [(_ c v pos neg src) - (raise-syntax-error 'contract - (string-append - "please update contract application to new protocol " - "(either 4 or 6 arguments)"))])) + (syntax/loc stx + (apply-contract c v pos neg 'name + (build-source-location #f) + #f)))])) -(define (apply-contract c v pos neg name loc) +(define (apply-contract c v pos neg name loc context-limit) (let ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (define clnp (contract-late-neg-projection c)) @@ -72,7 +85,8 @@ (or pos "false") (if clnp #f neg) - #t)) + #t + #:context-limit context-limit)) (cond [clnp (with-contract-continuation-mark (cons blame neg) @@ -156,6 +170,7 @@ #`(#,maker '#,stx (λ () #,arg) '#,(syntax-local-infer-name stx) + 'recursive-contract-val->lnp-not-yet-initialized #,(if list-contract? #'#t #'#f) #,@(if (equal? (syntax-e type) '#:flat) (list (if extra-delay? #'#t #'#f)) @@ -193,6 +208,7 @@ (unless (list-contract? forced-ctc) (raise-argument-error 'recursive-contract "list-contract?" forced-ctc))) (set-recursive-contract-ctc! ctc forced-ctc) + (set-recursive-contract-blame->val-np->val! ctc (make-blame->val-np->val ctc)) (when (and (pair? old-name) (pair? (cdr old-name))) ;; this guard will be #f when we are forcing this contract ;; in a nested which (which can make the `cddr` below fail) @@ -203,30 +219,48 @@ forced-ctc] [else current])) -(define (recursive-contract-late-neg-projection ctc) - (cond - [(recursive-contract-list-contract? ctc) - (λ (blame) - (define r-ctc (force-recursive-contract ctc)) - (define f (get/build-late-neg-projection r-ctc)) - (define blame-known (blame-add-context blame #f)) - (λ (val neg-party) - (unless (list? val) - (raise-blame-error blame-known #:missing-party neg-party - val - '(expected: "list?" given: "~e") - val)) - ((f blame-known) val neg-party)))] - [else - (λ (blame) +(define (make-blame->val-np->val ctc) + (define list-check? (recursive-contract-list-contract? ctc)) + (define blame-accepting-func-cell (make-thread-cell #f #t)) + (define (do-list-check val neg-party blame-known) + (when list-check? + (unless (list? val) + (raise-blame-error blame-known #:missing-party neg-party + val + '(expected: "list?" given: "~e") + val)))) + (λ (blame) + (cond + [(thread-cell-ref blame-accepting-func-cell) + => + (λ (blame-accepting-func) (blame-accepting-func blame))] + [else (define r-ctc (force-recursive-contract ctc)) (define f (get/build-late-neg-projection r-ctc)) - (define blame-known (blame-add-context blame #f)) - (define f-blame-known (make-thread-cell #f)) + (define val-neg-party-acceptor (make-thread-cell #f #t)) (λ (val neg-party) - (unless (thread-cell-ref f-blame-known) - (thread-cell-set! f-blame-known (f blame-known))) - ((thread-cell-ref f-blame-known) val neg-party)))])) + (cond + [(thread-cell-ref val-neg-party-acceptor) + => + (λ (f) (f val neg-party))] + [else + (thread-cell-set! blame-accepting-func-cell + (λ (blame) + (λ (val neg-party) + ((thread-cell-ref val-neg-party-acceptor) val neg-party)))) + (do-list-check val neg-party blame) + (define f-of-blame 'f-of-blame-not-yet-set) + (thread-cell-set! val-neg-party-acceptor + (λ (val neg-party) + (do-list-check val neg-party blame) + (f-of-blame val neg-party))) + (set! f-of-blame (f blame)) + (f-of-blame val neg-party)]))]))) + +(define (recursive-contract-late-neg-projection ctc) + (λ (blame) + (force-recursive-contract ctc) + ((recursive-contract-blame->val-np->val ctc) blame))) (define (flat-recursive-contract-late-neg-projection ctc) (cond @@ -253,7 +287,7 @@ ((f blame-known) val neg-party)))])] [else (recursive-contract-late-neg-projection ctc)])) -(define (recursive-contract-stronger this that) (equal? this that)) +(define (recursive-contract-equivalent this that) (equal? this that)) (define ((recursive-contract-first-order ctc) val) (cond @@ -270,7 +304,11 @@ (force-recursive-contract ctc) (contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))]))) -(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?) +(struct recursive-contract ([name #:mutable] + thunk + [ctc #:mutable] + [blame->val-np->val #:mutable] + list-contract?) #:property prop:recursive-contract (λ (this) (force-recursive-contract this) (recursive-contract-ctc this))) @@ -282,7 +320,8 @@ #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection flat-recursive-contract-late-neg-projection - #:stronger recursive-contract-stronger + #:stronger recursive-contract-equivalent + #:equivalent recursive-contract-equivalent #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) (struct chaperone-recursive-contract recursive-contract () @@ -292,7 +331,8 @@ #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection recursive-contract-late-neg-projection - #:stronger recursive-contract-stronger + #:stronger recursive-contract-equivalent + #:equivalent recursive-contract-equivalent #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) (struct impersonator-recursive-contract recursive-contract () @@ -302,6 +342,7 @@ #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection recursive-contract-late-neg-projection - #:stronger recursive-contract-stronger + #:stronger recursive-contract-equivalent + #:equivalent recursive-contract-equivalent #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/blame.rkt racket-7.0+ppa1/collects/racket/contract/private/blame.rkt --- racket-6.12+ppa1/collects/racket/contract/private/blame.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/blame.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -31,41 +31,96 @@ (define invariant-assertion-party (string->uninterned-symbol "invariant-assertion")) (define (blame=? a b equal?/recur) - (and (equal?/recur (blame-source a) (blame-source b)) - (equal?/recur (blame-value a) (blame-value b)) - (equal?/recur (blame-contract a) (blame-contract b)) - (equal?/recur (blame-positive a) (blame-positive b)) - (equal?/recur (blame-negative a) (blame-negative b)) - (equal?/recur (blame-original? a) (blame-original? b)) - (equal?/recur (blame-context a) (blame-context b)) - (equal?/recur (blame-top-known? a) (blame-top-known? b)) - (equal?/recur (blame-important a) (blame-important b)) - (equal?/recur (blame-missing-party? a) (blame-missing-party? b)))) + (and (or (and (blame-no-swap? a) (blame-no-swap? b)) + (and (blame-yes-swap? a) (blame-yes-swap? b))) + (equal?/recur (blame-context-frame a) (blame-context-frame b)) + (equal?/recur (blame-and-more a) (blame-and-more b)))) + +(define (combine-them x y) + (bitwise-xor x (* 3 y))) + +(define (blame-hash/combine b hash/recur combine-them) + (combine-them (hash/recur (blame-no-swap? b)) + (combine-them (hash/recur (blame-context-frame b)) + (hash/recur (blame-and-more b))))) (define (blame-hash b hash/recur) - (bitwise-xor (hash/recur (blame-source b)) - (hash/recur (blame-value b)) - (hash/recur (blame-contract b)) - (hash/recur (blame-positive b)) - (hash/recur (blame-negative b)) - (hash/recur (blame-original? b)) - (hash/recur (blame-context b)) - (hash/recur (blame-top-known? b)) - (hash/recur (blame-important b)) - (hash/recur (blame-missing-party? b)))) + (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor x (* 3 y))))) +(define (blame-secondary-hash b hash/recur) + (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor (* 5 x) y)))) ;; missing-party? field is #t when the missing party ;; is still missing and it is #f when the missing party ;; has been filled in (or if it was filled in from the start) -(define-struct blame - [source value build-name positive negative original? context top-known? important missing-party? - extra-fields] +(define-struct all-the-info + [positive + negative + source value build-name important missing-party? context-limit extra-fields] + #:transparent) + +;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?) +;; context : string? +(define-struct blame (context-frame and-more) + #:property prop:equal+hash + (list blame=? blame-hash blame-secondary-hash)) + +(define-struct (blame-no-swap blame) () + #:property prop:equal+hash + (list blame=? blame-hash blame-secondary-hash)) +(define-struct (blame-yes-swap blame) () #:property prop:equal+hash - (list blame=? blame-hash blame-hash)) + (list blame=? blame-hash blame-secondary-hash)) + +(define (blame->all-the-info b) + (let loop ([b b]) + (cond + [(blame? b) (loop (blame-and-more b))] + [else b]))) +(define (blame-source b) (all-the-info-source (blame->all-the-info b))) +(define (blame-value b) (all-the-info-value (blame->all-the-info b))) +(define (blame-important b) (all-the-info-important (blame->all-the-info b))) +(define (blame-missing-party? b) (all-the-info-missing-party? (blame->all-the-info b))) +(define (blame-contract b) ((all-the-info-build-name (blame->all-the-info b)))) +(define (blame-extra-fields b) (all-the-info-extra-fields (blame->all-the-info b))) +(define (blame-context-limit b) (all-the-info-context-limit (blame->all-the-info b))) + +(define (blame-get-info b f) + (let loop ([b b] + [swapped? #f]) + (cond + [(blame-yes-swap? b) (loop (blame-and-more b) (not swapped?))] + [(blame-no-swap? b) (loop (blame-and-more b) swapped?)] + [else (f b swapped?)]))) +(define (blame-original? b) (blame-get-info b (λ (all-the-info swapped?) (not swapped?)))) +(define (blame-swapped? b) (blame-get-info b (λ (all-the-info swapped?) swapped?))) +(define (blame-positive b) + (blame-get-info b (λ (all-the-info swapped?) + (if swapped? + (all-the-info-negative all-the-info) + (all-the-info-positive all-the-info))))) +(define (blame-negative b) + (blame-get-info b (λ (all-the-info swapped?) + (if swapped? + (all-the-info-positive all-the-info) + (all-the-info-negative all-the-info))))) + +(define (blame-context b) + (let loop ([top (blame-context-frame b)] + [b (blame-and-more b)]) + (cond + [(all-the-info? b) + ;; there is a dummy #f at the end + ;; but it might be dropped if the + ;; context is limited, so we don't + ;; include it in the list + (if top (list top) '())] + [else (cons top (loop (blame-context-frame b) + (blame-and-more b)))]))) (define -make-blame (let ([make-blame - (lambda (source value build-name positive negative original?) + (λ (source value build-name positive negative original? + #:context-limit [context-limit #f]) (unless (srcloc? source) (raise-argument-error 'make-blame "srcloc?" 0 source value build-name positive negative original?)) @@ -76,68 +131,200 @@ (unless positive (raise-type-error 'make-blame "(not/c #f)" 3 source value build-name positive negative original?)) - (make-blame - source - value - build-name - (list positive) - (and negative (list negative)) - original? - '() - #t - #f - (not negative) - '()))]) + (unless (or (not context-limit) + (exact-nonnegative-integer? context-limit)) + (raise-argument-error 'make-blame + (format "~s" '(or/c #f natural?)) + context-limit)) + (define build/memo-name + (let* ([uniq (box #f)] + [ans uniq]) + (λ () + (when (eq? uniq ans) + (set! ans (build-name))) + ans))) + (define all-the-info + (make-all-the-info + (list positive) + (and negative (list negative)) + source + value + build/memo-name + #f + (not negative) + context-limit + '())) + ;; we always start with a yes-swap or no-swap struct + ;; so be careful in other parts of the code to ignore + ;; it, as appropriate. + (if original? + (blame-no-swap #f all-the-info) + (blame-yes-swap #f all-the-info)))]) make-blame)) -;; s : (or/c string? #f) (define (blame-add-context b s #:important [name #f] #:swap? [swap? #f]) - (define new-original? (if swap? (not (blame-original? b)) (blame-original? b))) - (define new-context (if s (cons s (blame-context b)) (blame-context b))) - (struct-copy - blame b - [original? new-original?] - [positive (if swap? (blame-negative b) (blame-positive b))] - [negative (if swap? (blame-positive b) (blame-negative b))] - [important (if name (important name new-original?) (blame-important b))] - [context new-context] - [top-known? #t])) - -(struct important (name sense-swapped?)) - -(define (blame-add-unknown-context b) - (define old (blame-context b)) - (struct-copy - blame b - [top-known? #f] - [context (if (blame-top-known? b) - (blame-context b) - (cons "..." (blame-context b)))])) + (unless (blame? b) + (raise-argument-error 'blame-add-context + "blame?" + 0 + b s)) + (unless (or (string? s) + (not s)) + (raise-argument-error 'blame-add-context + (format "~s" '(or/c string? #f)) + 1 + b s)) + (cond + [(string? s) + (do-blame-add-context b s name swap?)] + [else b])) + +;; this has become a no op. it seems to never have been +;; documented. probably exported because of the Great +;; Extra Export ScrewUp that happened years back +(define (blame-add-unknown-context b) b) -(define (blame-contract b) ((blame-build-name b))) +(define (do-blame-add-context b s name swap?) + (define context-limit (blame-context-limit b)) + (cond + [(and context-limit + ;; if we are not tracking context, + ;; we are not updating the name + ;; at the top of the messages either + ;(not name) + ) + (cond + [(not (zero? context-limit)) + ;; if the limit is zero, we skip this case, + ;; which has the effect of always keeping only + ;; the dummy context frame + (define-values (limited-b dropped-swap?) (drop-to-limit b context-limit)) + (if (equal? dropped-swap? swap?) + (blame-no-swap s limited-b) + (blame-yes-swap s limited-b))] + [swap? + (if (blame-yes-swap? b) + (blame-no-swap (blame-context-frame b) (blame-and-more b)) + (blame-yes-swap (blame-context-frame b) (blame-and-more b)))] + [else b])] + [else + (define blame-yes/no-swap (if swap? blame-yes-swap blame-no-swap)) + (define inside-part + (cond + [name + (let loop ([inner-b b]) + (cond + [(blame-yes-swap? inner-b) + (blame-yes-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] + [(blame-no-swap? inner-b) + (blame-no-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] + [else + (define new-original? (if swap? (not (blame-original? b)) (blame-original? b))) + ;; in this case, we need to make a new blame record + (struct-copy + all-the-info inner-b + [important (if name + (important name new-original?) + (all-the-info-important inner-b))])]))] + [else b])) + (if swap? + (blame-yes-swap s inside-part) + (blame-no-swap s inside-part))])) + +(define (drop-to-limit b context-limit) + (define short-enough? + (let loop ([b b] + [n (- context-limit 1)]) + (cond + [(all-the-info? b) #t] + [(blame? b) + (if (zero? n) + #f + (loop (blame-and-more b) (- n 1)))]))) + (cond + [short-enough? (values b #f)] + [else + (define swapped? #f) + (define limited-b + (let loop ([b b] + [n (- context-limit 1)]) + (cond + [(= n 0) + (let loop ([b b] + [swap? #f]) + (cond + [(blame-yes-swap? b) (loop (blame-and-more b) (not swap?))] + [(blame-no-swap? b) (loop (blame-and-more b) swap?)] + [else + (set! swapped? swap?) + b]))] + [(blame-no-swap? b) + (blame-no-swap (blame-context-frame b) + (loop (blame-and-more b) (- n 1)))] + [(blame-yes-swap? b) + (blame-yes-swap (blame-context-frame b) + (loop (blame-and-more b) (- n 1)))]))) + (values limited-b swapped?)])) + +(struct important (name sense-swapped?) #:transparent) (define (blame-swap b) - (struct-copy - blame b - [original? (not (blame-original? b))] - [positive (blame-negative b)] - [negative (blame-positive b)])) - + (cond + [(blame-yes-swap? b) + (blame-no-swap (blame-context-frame b) (blame-and-more b))] + [(blame-no-swap? b) + (blame-yes-swap (blame-context-frame b) (blame-and-more b))])) (define (blame-replace-negative b new-neg) - (struct-copy blame b [negative (list new-neg)])) + (update-the-info + b + (λ (an-all-the-info swap?) + (if swap? + (all-the-info-replace-positive an-all-the-info new-neg) + (all-the-info-replace-negative an-all-the-info new-neg))))) (define (blame-replace-positive b new-pos) - (struct-copy blame b [positive (list new-pos)])) + (update-the-info + b + (λ (an-all-the-info swap?) + (if swap? + (all-the-info-replace-negative an-all-the-info new-pos) + (all-the-info-replace-positive an-all-the-info new-pos))))) +(define (all-the-info-replace-positive an-all-the-info new-pos) + (struct-copy + all-the-info an-all-the-info + [positive (list new-pos)])) -(define (blame-update blame-info extra-positive extra-negative) - (ensure-blame-known 'blame-update blame-info) - (struct-copy - blame - blame-info - [positive (cons extra-positive (blame-positive blame-info))] - [negative (cons extra-negative (blame-negative blame-info))])) +(define (all-the-info-replace-negative an-all-the-info new-neg) + (struct-copy + all-the-info an-all-the-info + [negative (list new-neg)])) + +(define (blame-update b extra-positive extra-negative) + (ensure-blame-known 'blame-update b) + (update-the-info + b + (λ (an-all-the-info swap?) + (if swap? + (struct-copy + all-the-info an-all-the-info + [positive (cons extra-negative (all-the-info-positive an-all-the-info))] + [negative (cons extra-positive (all-the-info-negative an-all-the-info))]) + (struct-copy + all-the-info an-all-the-info + [positive (cons extra-positive (all-the-info-positive an-all-the-info))] + [negative (cons extra-negative (all-the-info-negative an-all-the-info))]))))) + +(define (update-the-info b f) + (let loop ([b b] + [swap? #f]) + (cond + [(blame-yes-swap? b) + (blame-yes-swap (blame-context-frame b) (loop (blame-and-more b) (not swap?)))] + [(blame-no-swap? b) + (blame-no-swap (blame-context-frame b) (loop (blame-and-more b) swap?))] + [else (f b swap?)]))) (define (ensure-blame-known who blame) (unless (and (blame-positive blame) @@ -154,9 +341,6 @@ (define (show-blame-positive b) (show-blame blame-positive b)) (define (show-blame-negative b) (show-blame blame-negative b)) -(define (blame-swapped? b) - (not (blame-original? b))) - (define-struct (exn:fail:contract:blame exn:fail:contract) [object] #:transparent) @@ -187,7 +371,7 @@ raw-blame] [else (blame-add-missing-party raw-blame missing-party)])) - + (raise (make-exn:fail:contract:blame ((current-blame-format) @@ -197,25 +381,21 @@ blame))) (define (blame-add-missing-party b missing-party) - (define (check-and-fail) - (unless (blame-missing-party? b) - (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" - (if (blame-swapped? b) (blame-positive b) (blame-negative b)) - missing-party))) (cond [(not missing-party) b] - [(blame-swapped? b) - (check-and-fail) - (struct-copy blame b - [positive (or (blame-positive b) - (list missing-party))] - [missing-party? #f])] [else - (check-and-fail) - (struct-copy blame b - [negative (or (blame-negative b) - (list missing-party))] - [missing-party? #f])])) + (unless (blame-missing-party? b) + (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" + (if (blame-swapped? b) (blame-positive b) (blame-negative b)) + missing-party)) + (update-the-info + b + (λ (an-all-the-info swap?) + (struct-copy + all-the-info an-all-the-info + [negative (or (all-the-info-negative an-all-the-info) + (list missing-party))] + [missing-party? #f])))])) (define (blame-fmt->-string blame fmt) (cond @@ -280,7 +460,7 @@ (define source-message (source-location->string (blame-source blme))) (define context (blame-context blme)) - (define context-lines (if (null? context) + (define context-lines (if (or (null? context) (not context)) #f (apply string-append (for/list ([context (in-list context)] @@ -389,11 +569,14 @@ (raise-argument-error 'blame-add-extra-field "string?" 2 b name field)) - (struct-copy - blame b - [extra-fields (cons (format " ~a: ~a" name field) - (blame-extra-fields b))])) - + (update-the-info + b + (λ (an-all-the-info swap?) + (struct-copy + all-the-info an-all-the-info + [extra-fields (cons (format " ~a: ~a" name field) + (blame-extra-fields b))])))) + ;; combine-lines : (-> (listof (or/c string? #f))) string?) ;; combines each of 'lines' into a single message, dropping #fs, ;; and otherwise guaranteeing that each string is on its own line, @@ -438,10 +621,8 @@ [(path? x) (path->relative-string/library x)] [else x])) - (define (from-info x) - (convert-blame-singleton (last x))) - + (convert-blame-singleton (last x))) (define (convert-blame-party x) (let ((preface diff -Nru racket-6.12+ppa1/collects/racket/contract/private/box.rkt racket-7.0+ppa1/collects/racket/contract/private/box.rkt --- racket-6.12+ppa1/collects/racket/contract/private/box.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/box.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -101,11 +101,35 @@ (contract-struct-stronger? this-content-r that-content-r)] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-struct-stronger? this-content-r that-content-r) - (contract-struct-stronger? that-content-w this-content-w))] + (if (and (eq? this-content-r this-content-w) + (eq? that-content-r that-content-w)) + ;; if the original box/c didn't specify a separate read and write + ;; contract, we end up in this case + (contract-struct-equivalent? this-content-r that-content-r) + (and (contract-struct-stronger? this-content-r that-content-r) + (contract-struct-stronger? that-content-w this-content-w)))] [else #f])] [else #f])) +(define (box/c-equivalent this that) + (cond + [(base-box/c? that) + (define this-content-w (base-box/c-content-w this)) + (define this-content-r (base-box/c-content-r this)) + (define this-immutable (base-box/c-immutable this)) + (define that-content-w (base-box/c-content-w that)) + (define that-content-r (base-box/c-content-r that)) + (define that-immutable (base-box/c-immutable that)) + (and (equal? this-immutable that-immutable) + (cond + [(or (equal? this-immutable 'immutable) + (and (eq? this-content-r this-content-w) + (eq? that-content-r that-content-w))) + (contract-struct-equivalent? this-content-r that-content-r)] + [else + (and (contract-struct-equivalent? this-content-r that-content-r) + (contract-struct-equivalent? that-content-w this-content-w))]))] + [else #f])) (define-struct (flat-box/c base-box/c) () #:property prop:custom-write custom-write-property-proc @@ -114,6 +138,7 @@ #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger + #:equivalent box/c-equivalent #:late-neg-projection (λ (ctc) (define content-ctc (get/build-late-neg-projection (base-box/c-content-w ctc))) @@ -137,29 +162,45 @@ (define r-vfp (get/build-late-neg-projection elem-r-ctc)) (λ (blame) (define box-blame (add-box-context blame)) - (define pos-elem-r-proj (r-vfp box-blame)) - (define neg-elem-w-proj (w-vfp (blame-swap box-blame))) - (λ (val neg-party) - (define blame+neg-party (cons blame neg-party)) - (cond - [(check-box/c-np ctc val blame) - => - (λ (f) (f neg-party))] - [else - (if (and (immutable? val) (not (chaperone? val))) - (box-immutable (pos-elem-r-proj (unbox val) neg-party)) - (chaperone/impersonate-box - val - (λ (b v) - (with-contract-continuation-mark - blame+neg-party - (pos-elem-r-proj v neg-party))) - (λ (b v) - (with-contract-continuation-mark - blame+neg-party - (neg-elem-w-proj v neg-party))) - impersonator-prop:contracted ctc - impersonator-prop:blame (blame-add-missing-party blame neg-party)))]))))) + (define-values (filled? maybe-pos-elem-r-proj maybe-neg-elem-w-proj) + (contract-pos/neg-doubling (r-vfp box-blame) + (w-vfp (blame-swap box-blame)))) + (define (make-val-np/proc pos-elem-r-proj neg-elem-w-proj) + (λ (val neg-party) + (define blame+neg-party (cons blame neg-party)) + (cond + [(check-box/c-np ctc val blame) + => + (λ (f) (f neg-party))] + [else + (if (and (immutable? val) (not (chaperone? val))) + (box-immutable (pos-elem-r-proj (unbox val) neg-party)) + (chaperone/impersonate-box + val + (λ (b v) + (with-contract-continuation-mark + blame+neg-party + (pos-elem-r-proj v neg-party))) + (λ (b v) + (with-contract-continuation-mark + blame+neg-party + (neg-elem-w-proj v neg-party))) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party)))]))) + (cond + [filled? + (make-val-np/proc maybe-pos-elem-r-proj maybe-neg-elem-w-proj)] + [else + (define tc (make-thread-cell #f)) + (λ (val neg-party) + (cond + [(thread-cell-ref tc) + => + (λ (f) (f val neg-party))] + [else + (define proc (make-val-np/proc (maybe-pos-elem-r-proj) (maybe-neg-elem-w-proj))) + (thread-cell-set! tc proc) + (proc val neg-party)]))])))) (define-struct (chaperone-box/c base-box/c) () #:property prop:custom-write custom-write-property-proc @@ -168,6 +209,7 @@ #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger + #:equivalent box/c-equivalent #:late-neg-projection (ho-late-neg-projection chaperone-box))) (define-struct (impersonator-box/c base-box/c) () @@ -177,6 +219,7 @@ #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger + #:equivalent box/c-equivalent #:late-neg-projection (ho-late-neg-projection impersonate-box))) (define-syntax (box/c stx) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/case-arrow.rkt racket-7.0+ppa1/collects/racket/contract/private/case-arrow.rkt --- racket-6.12+ppa1/collects/racket/contract/private/case-arrow.rkt 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/case-arrow.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -217,8 +217,8 @@ (blame-add-context (blame-add-context blame - (format "the ~a case of" (n->th (+ (car f) 1)))) - "the domain of" + (nth-case-of (+ (car f) 1))) + "the domain of" #:swap? #t))) dom-ctcs+case-nums) (map (let ([memo '()]) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/ds.rkt racket-7.0+ppa1/collects/racket/contract/private/ds.rkt --- racket-6.12+ppa1/collects/racket/contract/private/ds.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/ds.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -229,13 +229,15 @@ ctc-field-val)] ...) (values f-x ...))) - (define (stronger-lazy-contract? a b) + (define (stronger/equivalent-lazy-contract? + a b + contract-struct-stronger/equivalent?) (and (contract-predicate b) (let ([a-sel (contract-get a selector-indices)] [b-sel (contract-get b selector-indices)]) (if (contract-struct? a-sel) (if (contract-struct? b-sel) - (contract-struct-stronger? a-sel b-sel) + (contract-struct-stronger/equivalent? a-sel b-sel) #f) (if (contract-struct? b-sel) #f @@ -321,7 +323,13 @@ #:projection lazy-contract-proj #:name lazy-contract-name #:first-order (lambda (ctc) predicate) - #:stronger stronger-lazy-contract?)) + #:equivalent (λ (this that) + (stronger/equivalent-lazy-contract? + this that + contract-struct-equivalent?)) + #:stronger (λ (this that) (stronger/equivalent-lazy-contract? + this that + contract-struct-stronger?)))) (define-values (contract-type contract-maker contract-predicate contract-get contract-set) (make-struct-type 'the-contract diff -Nru racket-6.12+ppa1/collects/racket/contract/private/exists.rkt racket-7.0+ppa1/collects/racket/contract/private/exists.rkt --- racket-6.12+ppa1/collects/racket/contract/private/exists.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/exists.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -36,6 +36,7 @@ #:first-order (λ (ctc) (λ (x) #t)) ;; ??? #:late-neg-projection ∀∃-late-neg-proj #:stronger (λ (this that) (equal? this that)) + #:equivalent (λ (this that) (equal? this that)) #:generate (λ (ctc) (cond [(∀∃/c-neg? ctc) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/guts.rkt racket-7.0+ppa1/collects/racket/contract/private/guts.rkt --- racket-6.12+ppa1/collects/racket/contract/private/guts.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/guts.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -22,6 +22,7 @@ build-compound-type-name contract-stronger? + contract-equivalent? list-contract? contract-first-order @@ -82,9 +83,14 @@ raise-predicate-blame-error-failure n->th + nth-argument-of + nth-element-of + nth-case-of false/c-contract - true/c-contract) + true/c-contract + + contract-pos/neg-doubling) (define (contract-custom-write-property-proc stct port mode) (define (write-prefix) @@ -123,9 +129,7 @@ (or (simple-flat-contract? x) (let ([c (coerce-contract/f x)]) (and c - (or (chaperone-contract-struct? c) - (and (prop:opt-chaperone-contract? c) - ((prop:opt-chaperone-contract-get-test c) c))))))) + (chaperone-contract-struct? c))))) (define (simple-flat-contract? x) (or (and (procedure? x) (procedure-arity-includes? x 1)) @@ -229,6 +233,10 @@ (contract-struct-stronger? (coerce-contract 'contract-stronger? a) (coerce-contract 'contract-stronger? b))) +(define (contract-equivalent? a b) + (contract-struct-equivalent? (coerce-contract 'contract-equivalent? a) + (coerce-contract 'contract-equivalent? b))) + ;; coerce-flat-contract : symbol any/c -> contract (define (coerce-flat-contract name x) (define ctc (coerce-contract/f x)) @@ -557,6 +565,11 @@ (and (predicate-contract? that) (predicate-contract-sane? that) ((predicate-contract-pred that) this-val)))) + #:equivalent + (λ (this that) + (define this-val (eq-contract-val this)) + (and (eq-contract? that) + (eq? this-val (eq-contract-val that)))) #:list-contract? (λ (c) (null? (eq-contract-val c))))) (define false/c-contract (make-eq-contract #f #f)) @@ -576,6 +589,11 @@ (and (predicate-contract? that) (predicate-contract-sane? that) ((predicate-contract-pred that) this-val)))) + #:equivalent + (λ (this that) + (define this-val (equal-contract-val this)) + (and (equal-contract? that) + (equal? this-val (equal-contract-val that)))) #:generate (λ (ctc) (define v (equal-contract-val ctc)) @@ -597,6 +615,13 @@ (and (predicate-contract? that) (predicate-contract-sane? that) ((predicate-contract-pred that) this-val)))) + #:equivalent + (λ (this that) + (define this-val (=-contract-val this)) + (or (and (=-contract? that) + (= this-val (=-contract-val that))) + (and (between/c-s? that) + (= (between/c-s-low that) this-val (between/c-s-high that))))) #:generate (λ (ctc) (define v (=-contract-val ctc)) @@ -659,6 +684,17 @@ (and (char<=? that-low this-low) (char<=? this-high that-high))] [else #f])) + #:equivalent + (λ (this that) + (cond + [(char-in/c? that) + (define this-low (char-in/c-low this)) + (define this-high (char-in/c-high this)) + (define that-low (char-in/c-low that)) + (define that-high (char-in/c-high that)) + (and (char=? that-low this-low) + (char=? this-high that-high))] + [else #f])) #:generate (λ (ctc) (define low (char->integer (char-in/c-low ctc))) @@ -668,6 +704,10 @@ (λ () (integer->char (+ low (random delta)))))))) +(define (regexp/c-equivalent this that) + (and (regexp/c? that) + (equal? (regexp/c-reg this) (regexp/c-reg that)))) + (define-struct regexp/c (reg name) #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract @@ -679,9 +719,13 @@ (and (or (string? x) (bytes? x)) (regexp-match? reg x)))) #:name (λ (ctc) (regexp/c-reg ctc)) - #:stronger - (λ (this that) - (and (regexp/c? that) (equal? (regexp/c-reg this) (regexp/c-reg that)))))) + #:stronger regexp/c-equivalent + #:equivalent regexp/c-equivalent)) + +(define (predicate-contract-equivalent this that) + (and (predicate-contract? that) + (procedure-closure-contents-eq? (predicate-contract-pred this) + (predicate-contract-pred that)))) ;; sane? : boolean -- indicates if we know that the predicate is well behaved ;; (for now, basically amounts to trusting primitive procedures) @@ -689,11 +733,8 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property - #:stronger - (λ (this that) - (and (predicate-contract? that) - (procedure-closure-contents-eq? (predicate-contract-pred this) - (predicate-contract-pred that)))) + #:stronger predicate-contract-equivalent + #:equivalent predicate-contract-equivalent #:name (λ (ctc) (predicate-contract-name ctc)) #:first-order (λ (ctc) (predicate-contract-pred ctc)) #:late-neg-projection @@ -879,3 +920,47 @@ [(2) "nd"] [(3) "rd"] [else "th"]))) + +(define (nth-element-of/alloc n) + (format "the ~a element of" (n->th n))) +(define (nth-argument-of/alloc n) + (format "the ~a argument of" (n->th n))) +(define (nth-case-of/alloc n) + (format "the ~a case of" (n->th n))) + +(define-syntax (define-precompute/simple stx) + (syntax-case stx () + [(_ fn fn/alloc lower-bound-stx upper-bound-stx) + (let () + (define lower-bound (syntax-e #'lower-bound-stx)) + (define upper-bound (syntax-e #'upper-bound-stx)) + (define (n->id n) + (string->symbol (format "precomputed-~a" n))) + #`(begin + #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))]) + #`(define #,(n->id i) (fn/alloc #,i))) + (define (fn n) + (case n + #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))]) + #`[(#,i) #,(n->id i)]) + [else (fn/alloc n)]))))])) + +(define-precompute/simple nth-element-of nth-element-of/alloc 0 10) +(define-precompute/simple nth-argument-of nth-argument-of/alloc 1 7) +(define-precompute/simple nth-case-of nth-case-of/alloc 1 2) + +(define-syntax-rule + (contract-pos/neg-doubling e1 e2) + (contract-pos/neg-doubling/proc (λ () e1) (λ () e2))) +(define doubling-cm-key (gensym 'racket/contract-doubling-mark)) +(define (contract-pos/neg-doubling/proc t1 t2) + (define depth + (or (continuation-mark-set-first (current-continuation-marks) + doubling-cm-key) + 0)) + (cond + [(> depth 5) + (values #f t1 t2)] + [else + (with-continuation-mark doubling-cm-key (+ depth 1) + (values #t (t1) (t2)))])) \ No newline at end of file diff -Nru racket-6.12+ppa1/collects/racket/contract/private/hash.rkt racket-7.0+ppa1/collects/racket/contract/private/hash.rkt --- racket-6.12+ppa1/collects/racket/contract/private/hash.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/hash.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -81,9 +81,6 @@ ;; ... --> boolean ;; returns #t when it called raise-blame-error, #f otherwise (define (check-hash/c dom-ctc immutable flat? val blame neg-party) - ;(define dom-ctc (base-hash/c-dom ctc)) - ;(define immutable (base-hash/c-immutable ctc)) - ;(define flat? (flat-hash/c? ctc)) (cond [(hash? val) (cond @@ -172,13 +169,25 @@ (contract-struct-stronger? this-rng that-rng))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-struct-stronger? this-dom that-dom) - (contract-struct-stronger? that-dom this-dom) - (contract-struct-stronger? this-rng that-rng) - (contract-struct-stronger? that-rng this-rng))] + (and (contract-struct-equivalent? this-dom that-dom) + (contract-struct-equivalent? this-rng that-rng))] [else #f])] [else #f])) +(define (hash/c-equivalent this that) + (cond + [(base-hash/c? that) + (define this-dom (base-hash/c-dom this)) + (define this-rng (base-hash/c-rng this)) + (define this-immutable (base-hash/c-immutable this)) + (define that-dom (base-hash/c-dom that)) + (define that-rng (base-hash/c-rng that)) + (define that-immutable (base-hash/c-immutable that)) + (and (equal? this-immutable that-immutable) + (contract-struct-equivalent? this-dom that-dom) + (contract-struct-equivalent? this-rng that-rng))] + [else #f])) + (define-struct (flat-hash/c base-hash/c) () #:omit-define-syntaxes #:property prop:custom-write custom-write-property-proc @@ -187,6 +196,7 @@ #:name hash/c-name #:first-order hash/c-first-order #:stronger hash/c-stronger + #:equivalent hash/c-equivalent #:late-neg-projection (λ (ctc) (define dom-ctc (base-hash/c-dom ctc)) @@ -215,18 +225,46 @@ (define dom-proc (get/build-late-neg-projection dom-ctc)) (define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc))) (λ (blame) - (define pos-dom-proj (dom-proc (blame-add-key-context blame #f))) - (define neg-dom-proj (dom-proc (blame-add-key-context blame #t))) - (define pos-rng-proj (rng-proc (blame-add-value-context blame #f))) - (define neg-rng-proj (rng-proc (blame-add-value-context blame #t))) - (λ (val neg-party) - (cond - [(check-hash/c dom-ctc immutable flat? val blame neg-party) - val] - [else - (handle-the-hash val neg-party - pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj) - chaperone-or-impersonate-hash ctc blame)]))))) + (define-values (dom-filled? maybe-pos-dom-proj maybe-neg-dom-proj) + (contract-pos/neg-doubling (dom-proc (blame-add-key-context blame #f)) + (dom-proc (blame-add-key-context blame #t)))) + (define-values (rng-filled? maybe-pos-rng-proj maybe-neg-rng-proj) + (contract-pos/neg-doubling (rng-proc (blame-add-value-context blame #f)) + (rng-proc (blame-add-value-context blame #t)))) + (cond + [(and dom-filled? rng-filled?) + (λ (val neg-party) + (cond + [(check-hash/c dom-ctc immutable flat? val blame neg-party) + val] + [else + (handle-the-hash val neg-party + maybe-pos-dom-proj maybe-neg-dom-proj + (λ (v) maybe-pos-rng-proj) (λ (v) maybe-neg-rng-proj) + chaperone-or-impersonate-hash ctc blame)]))] + [else + (define tc (make-thread-cell #f)) + (λ (val neg-party) + (define-values (pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj) + (cond + [(thread-cell-ref tc) + => + (λ (v) (values (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4)))] + [else + (define pos-dom-proj (maybe-pos-dom-proj)) + (define neg-dom-proj (maybe-neg-dom-proj)) + (define pos-rng-proj (maybe-pos-rng-proj)) + (define neg-rng-proj (maybe-neg-rng-proj)) + (thread-cell-set! tc (vector pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)) + (values pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)])) + (cond + [(check-hash/c dom-ctc immutable flat? val blame neg-party) + val] + [else + (handle-the-hash val neg-party + pos-dom-proj neg-dom-proj + (λ (v) pos-rng-proj) (λ (v) neg-rng-proj) + chaperone-or-impersonate-hash ctc blame)]))])))) (define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?)) (define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?)) @@ -274,6 +312,7 @@ #:name hash/c-name #:first-order hash/c-first-order #:stronger hash/c-stronger + #:equivalent hash/c-equivalent #:late-neg-projection (ho-projection chaperone-hash))) (define-struct (impersonator-hash/c base-hash/c) () @@ -284,6 +323,7 @@ #:name hash/c-name #:first-order hash/c-first-order #:stronger hash/c-stronger + #:equivalent hash/c-equivalent #:late-neg-projection (ho-projection impersonate-hash))) @@ -312,6 +352,7 @@ (contract-first-order-passes? (rng-f k) v)))))) (define (hash/dc-stronger this that) #f) +(define (hash/dc-equivalent this that) #f) (define ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc) (define dom-ctc (base-hash/dc-dom ctc)) @@ -346,6 +387,7 @@ (build-flat-contract-property #:name hash/dc-name #:first-order hash/dc-first-order + #:equivalent hash/dc-equivalent #:stronger hash/dc-stronger)) (struct chaperone-hash/dc base-hash/dc () @@ -355,6 +397,7 @@ #:name hash/dc-name #:first-order hash/dc-first-order #:stronger hash/dc-stronger + #:equivalent hash/dc-equivalent #:late-neg-projection (hash/dc-late-neg-projection chaperone-hash))) (struct impersonator-hash/dc base-hash/dc () #:property prop:custom-write custom-write-property-proc @@ -363,6 +406,7 @@ #:name hash/dc-name #:first-order hash/dc-first-order #:stronger hash/dc-stronger + #:equivalent hash/dc-equivalent #:late-neg-projection (hash/dc-late-neg-projection impersonate-hash))) (define (build-hash/dc dom dep-rng here name-info immutable kind) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/helpers.rkt racket-7.0+ppa1/collects/racket/contract/private/helpers.rkt --- racket-6.12+ppa1/collects/racket/contract/private/helpers.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/helpers.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,7 +13,10 @@ (require setup/main-collects racket/struct-info - (for-template racket/base)) + (only-in racket/private/list-predicates empty? cons?) + (for-template racket/base + (only-in racket/private/list-predicates + empty? cons?))) (define (update-loc stx loc) (datum->syntax stx (syntax-e stx) loc)) @@ -189,6 +192,8 @@ string<=? #:key symbol->string))) +-- also add empty? and cons? to the above + |# (define known-good-syms-ht @@ -365,7 +370,10 @@ (void? . #t) (weak-box? . #t) (will-executor? . #t) - (zero? . #t))) + (zero? . #t) + ;; from racket/private/list-predicates + (empty? . #t) + (cons? . #t))) (define (known-good-contract? id) (define r-id (syntax-e id)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/list.rkt racket-7.0+ppa1/collects/racket/contract/private/list.rkt --- racket-6.12+ppa1/collects/racket/contract/private/list.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -107,6 +107,28 @@ (contract-struct-stronger? this-elem hd-ctc) (contract-struct-stronger? (ne->pe-ctc this) tl-ctc))] [else #f])) + +(define (listof-equivalent this that) + (define this-elem (listof-ctc-elem-c this)) + (cond + [(listof-ctc? that) + (define that-elem (listof-ctc-elem-c that)) + (cond + [(pe-listof-ctc? this) (and (pe-listof-ctc? that) + (contract-struct-equivalent? this-elem that-elem))] + [(im-listof-ctc? this) + (and (im-listof-ctc? that) + (contract-struct-equivalent? this-elem that-elem) + (contract-struct-equivalent? (im-listof-ctc-last-c this) + (im-listof-ctc-last-c that)))] + [else (contract-struct-equivalent? this-elem that-elem)])] + [(the-cons/c? that) + (define hd-ctc (the-cons/c-hd-ctc that)) + (define tl-ctc (the-cons/c-tl-ctc that)) + (and (ne-listof-ctc? this) + (contract-struct-equivalent? this-elem hd-ctc) + (contract-struct-equivalent? (ne->pe-ctc this) tl-ctc))] + [else #f])) (define (raise-listof-blame-error blame val empty-ok? neg-party) (raise-blame-error blame #:missing-party neg-party val @@ -219,6 +241,7 @@ #:generate listof-generate #:exercise listof-exercise #:stronger listof-stronger + #:equivalent listof-equivalent #:list-contract? (λ (c) (not (im-listof-ctc? c))))) (define chap-prop (build-chaperone-contract-property @@ -228,6 +251,7 @@ #:generate listof-generate #:exercise listof-exercise #:stronger listof-stronger + #:equivalent listof-equivalent #:list-contract? (λ (c) (not (im-listof-ctc? c))))) (define full-prop (build-contract-property @@ -237,6 +261,7 @@ #:generate listof-generate #:exercise listof-exercise #:stronger listof-stronger + #:equivalent listof-equivalent #:list-contract? (λ (c) (not (im-listof-ctc? c))))) (struct listof-ctc (elem-c)) @@ -382,6 +407,20 @@ (contract-struct-stronger? this-tl that))] [else #f])) +(define (cons/c-equivalent? this that) + (define this-hd (the-cons/c-hd-ctc this)) + (define this-tl (the-cons/c-tl-ctc this)) + (cond + [(the-cons/c? that) + (define that-hd (the-cons/c-hd-ctc that)) + (define that-tl (the-cons/c-tl-ctc that)) + (and (contract-struct-equivalent? this-hd that-hd) + (contract-struct-equivalent? this-tl that-tl))] + [(ne-listof-ctc? that) + (define elem-ctc (listof-ctc-elem-c that)) + (and (contract-struct-equivalent? this-hd elem-ctc) + (contract-struct-equivalent? this-tl (ne->pe-ctc that)))] + [else #f])) (define (cons/c-generate ctc) (define ctc-car (the-cons/c-hd-ctc ctc)) @@ -405,6 +444,7 @@ #:name cons/c-name #:first-order cons/c-first-order #:stronger cons/c-stronger? + #:equivalent cons/c-equivalent? #:generate cons/c-generate #:list-contract? cons/c-list-contract?)) (define-struct (chaperone-cons/c the-cons/c) () @@ -415,6 +455,7 @@ #:name cons/c-name #:first-order cons/c-first-order #:stronger cons/c-stronger? + #:equivalent cons/c-equivalent? #:generate cons/c-generate #:list-contract? cons/c-list-contract?)) (define-struct (impersonator-cons/c the-cons/c) () @@ -425,6 +466,7 @@ #:name cons/c-name #:first-order cons/c-first-order #:stronger cons/c-stronger? + #:equivalent cons/c-equivalent? #:generate cons/c-generate #:list-contract? cons/c-list-contract?)) @@ -496,6 +538,7 @@ dep-val)))))) (define (cons/dc-stronger? this that) #f) +(define (cons/dc-equivalent? this that) #f) (define (cons/dc-generate ctc) (define undep-ctc (the-cons/dc-undep ctc)) @@ -526,6 +569,7 @@ #:name cons/dc-name #:first-order cons/dc-first-order #:stronger cons/dc-stronger? + #:equivalent cons/dc-equivalent? #:generate cons/dc-generate)) (struct chaperone-cons/dc the-cons/dc () @@ -536,6 +580,7 @@ #:name cons/dc-name #:first-order cons/dc-first-order #:stronger cons/dc-stronger? + #:equivalent cons/dc-equivalent? #:generate cons/dc-generate)) (struct impersonator-cons/dc the-cons/dc () @@ -546,6 +591,7 @@ #:name cons/dc-name #:first-order cons/dc-first-order #:stronger cons/dc-stronger? + #:equivalent cons/dc-equivalent? #:generate cons/dc-generate)) (define-syntax (cons/dc stx) @@ -669,6 +715,13 @@ (contract-struct-stronger? this-s that-elem-ctc)))] [else #f])) +(define (list/c-equivalent this that) + (cond + [(generic-list/c? that) + (pairwise-equivalent-contracts? (generic-list/c-args this) + (generic-list/c-args that))] + [else #f])) + (struct generic-list/c (args)) (struct flat-list/c generic-list/c () @@ -680,6 +733,7 @@ #:generate list/c-generate #:exercise list/c-exercise #:stronger list/c-stronger + #:equivalent list/c-equivalent #:late-neg-projection (λ (c) (λ (blame) @@ -757,13 +811,7 @@ (expected-a-list val blame #:missing-party neg-party)])))) (define (add-list-context blame i) - (blame-add-context blame (format "the ~a~a element of" - i - (case (modulo i 10) - [(1) "st"] - [(2) "nd"] - [(3) "rd"] - [else "th"])))) + (blame-add-context blame (nth-element-of i))) (struct chaperone-list/c generic-list/c () #:property prop:custom-write custom-write-property-proc @@ -774,6 +822,7 @@ #:generate list/c-generate #:exercise list/c-exercise #:stronger list/c-stronger + #:equivalent list/c-equivalent #:late-neg-projection list/c-chaperone/other-late-neg-projection #:list-contract? (λ (c) #t))) @@ -786,6 +835,7 @@ #:generate list/c-generate #:exercise list/c-exercise #:stronger list/c-stronger + #:equivalent list/c-equivalent #:late-neg-projection list/c-chaperone/other-late-neg-projection #:list-contract? (λ (c) #t))) @@ -882,6 +932,17 @@ (contract-struct-stronger? suf that-elem)))] [else #f])) +(define (*list/c-equivalent this that) + (define this-prefix (*list-ctc-prefix this)) + (define this-suffix (*list-ctc-suffix this)) + (cond + [(*list-ctc? that) + (define that-prefix (*list-ctc-prefix that)) + (define that-suffix (*list-ctc-suffix that)) + (and (contract-struct-equivalent? this-prefix that-prefix) + (pairwise-equivalent-contracts? this-suffix that-suffix))] + [else #f])) + (define (*list/c-late-neg-projection ctc start-index flat?) (define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc))) (define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc))) @@ -959,6 +1020,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #t)) #:list-contract? (λ (c) #t))) (struct chaperone-*list/c *list-ctc () @@ -969,6 +1031,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f)) #:list-contract? (λ (c) #t))) (struct impersonator-*list/c *list-ctc () @@ -979,6 +1042,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f)) #:list-contract? (λ (c) #t))) @@ -1022,6 +1086,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #t)) #:list-contract? (λ (c) #t))) @@ -1033,6 +1098,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f)) #:list-contract? (λ (c) #t))) @@ -1044,6 +1110,7 @@ #:generate *list/c-generate #:exercise *list/c-exercise #:stronger *list/c-stronger + #:equivalent *list/c-equivalent #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f)) #:list-contract? (λ (c) #t))) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/misc.rkt racket-7.0+ppa1/collects/racket/contract/private/misc.rkt --- racket-6.12+ppa1/collects/racket/contract/private/misc.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/misc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -50,6 +50,7 @@ if/c pairwise-stronger-contracts? + pairwise-equivalent-contracts? check-two-args suggest/c @@ -119,6 +120,15 @@ (< that-x this-low))])] [else #f])) +(define (between/c-equivalent this that) + (define this-low (between/c-s-low this)) + (define this-high (between/c-s-high this)) + (cond + [(between/c-s? that) + (and (= (between/c-s-low that) this-low) + (= this-high (between/c-s-high that)))] + [else #f])) + (define (between/c-first-order ctc) (define n (between/c-s-low ctc)) (define m (between/c-s-high ctc)) @@ -193,6 +203,7 @@ [(= n m) `(=/c ,n)] [else ])])) #:stronger between/c-stronger + #:equivalent between/c-equivalent #:first-order between/c-first-order #:generate between/c-generate)) (define-struct (renamed-between/c between/c-s) (name)) @@ -246,14 +257,41 @@ #:generate (λ (ctc) (define x (-ctc-x ctc)) - (λ (fuel) - (λ () - (rand-choice - [1/10 (-/+ +inf.0)] - [1/10 (-/+ x 0.01)] - [4/10 (-/+ x (random))] - [else (-/+ x (random 4294967087))])))) - #:stronger -ctc-stronger)) + (cond + [(and (= x +inf.0) (equal? name '/c)) + (λ (fuel) #f)] + [(and (= x -inf.0) (equal? name '>/c)) + (λ (fuel) + (λ () + (rand-choice + [1/10 +inf.0] + [2/10 (random)] + [2/10 (- (random))] + [2/10 (random 4294967087)] + [2/10 (- (random 4294967087))] + [else 0])))] + [else + (λ (fuel) + (λ () + (rand-choice + [1/10 (-/+ +inf.0)] + [1/10 (-/+ x 0.01)] + [4/10 (-/+ x (random))] + [else (-/+ x (random 4294967087))])))])) + #:stronger -ctc-stronger + #:equivalent -ctc-equivalent)) (define (-ctc-stronger this that) (define this-x (-ctc-x this)) @@ -263,7 +301,8 @@ [(and (<-ctc? this) (<-ctc? that)) (<= this-x (-ctc-x that))] [(and (>-ctc? this) (>-ctc? that)) - (>= this-x (-ctc-x that))])] + (>= this-x (-ctc-x that))] + [else #f])] [(between/c-s? that) (cond [(<-ctc? this) @@ -273,6 +312,17 @@ (and (= (between/c-s-high that) +inf.0) (<= (between/c-s-low that) this-x))])])) +(define (-ctc-equivalent this that) + (define this-x (-ctc-x this)) + (cond + [(-ctc? that) + (cond + [(and (<-ctc? this) (<-ctc? that)) + (= this-x (-ctc-x that))] + [(and (>-ctc? this) (>-ctc? that)) + (= this-x (-ctc-x that))] + [else #f])] + [else #f])) (struct -ctc (x)) (struct <-ctc -ctc () @@ -330,6 +380,10 @@ (and (syntax-ctc? that) (contract-struct-stronger? (syntax-ctc-ctc this) (syntax-ctc-ctc that)))) + #:equivalent (λ (this that) + (and (syntax-ctc? that) + (contract-struct-equivalent? (syntax-ctc-ctc this) + (syntax-ctc-ctc that)))) #:first-order (λ (ctc) (define ? (flat-contract-predicate (syntax-ctc-ctc ctc))) (λ (v) @@ -405,6 +459,11 @@ (contract-struct-stronger? (promise-base-ctc-ctc this) (promise-base-ctc-ctc that)))) +(define (promise-ctc-equivalent? this that) + (and (promise-base-ctc? that) + (contract-struct-equivalent? (promise-base-ctc-ctc this) + (promise-base-ctc-ctc that)))) + (struct promise-base-ctc (ctc)) (struct chaperone-promise-ctc promise-base-ctc () #:property prop:custom-write custom-write-property-proc @@ -413,6 +472,7 @@ #:name promise-contract-name #:late-neg-projection promise-contract-late-neg-proj #:stronger promise-ctc-stronger? + #:equivalent promise-ctc-equivalent? #:first-order (λ (ctc) promise?))) (struct promise-ctc promise-base-ctc () #:property prop:custom-write custom-write-property-proc @@ -421,6 +481,7 @@ #:name promise-contract-name #:late-neg-projection promise-contract-late-neg-proj #:stronger promise-ctc-stronger? + #:equivalent promise-ctc-equivalent? #:first-order (λ (ctc) promise?))) ;; (parameter/c in/out-ctc) @@ -487,16 +548,26 @@ (and (contract-struct-stronger? (parameter/c-out this) (parameter/c-out that)) (contract-struct-stronger? (parameter/c-in that) - (parameter/c-in this))))))) - + (parameter/c-in this))))) + #:equivalent + (λ (this that) + (and (parameter/c? that) + (and (contract-struct-equivalent? (parameter/c-out this) + (parameter/c-out that)) + (contract-struct-equivalent? (parameter/c-in that) + (parameter/c-in this))))))) + +(define (procedure-arity-includes-equivalent? this that) + (and (procedure-arity-includes/c? that) + (= (procedure-arity-includes/c-n this) + (procedure-arity-includes/c-n that)))) (define-struct procedure-arity-includes/c (n) #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property - #:stronger (λ (this that) (and (procedure-arity-includes/c? that) - (= (procedure-arity-includes/c-n this) - (procedure-arity-includes/c-n that)))) + #:stronger procedure-arity-includes-equivalent? + #:equivalent procedure-arity-includes-equivalent? #:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc))) #:first-order (λ (ctc) (define n (procedure-arity-includes/c-n ctc)) @@ -556,6 +627,7 @@ (build-flat-contract-property #:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn) #:stronger (λ (this that) (any/c? that)) + #:equivalent (λ (this that) (any/c? that)) #:name (λ (ctc) 'any/c) #:generate (λ (ctc) (λ (fuel) @@ -583,6 +655,7 @@ (build-flat-contract-property #:late-neg-projection none-curried-late-neg-proj #:stronger (λ (this that) #t) + #:equivalent (λ (this that) (none/c? that)) #:name (λ (ctc) (none/c-name ctc)) #:first-order (λ (ctc) (λ (val) #f)))) @@ -665,12 +738,21 @@ (define (prompt-tag/c-stronger? this that) (and (base-prompt-tag/c? that) - (andmap (λ (this that) (contract-struct-stronger? this that)) - (base-prompt-tag/c-ctcs this) - (base-prompt-tag/c-ctcs that)) - (andmap (λ (this that) (contract-struct-stronger? this that)) - (base-prompt-tag/c-call/ccs this) - (base-prompt-tag/c-call/ccs that)))) + (pairwise-stronger-contracts? + (base-prompt-tag/c-ctcs this) + (base-prompt-tag/c-ctcs that)) + (pairwise-stronger-contracts? + (base-prompt-tag/c-call/ccs this) + (base-prompt-tag/c-call/ccs that)))) + +(define (prompt-tag/c-equivalent? this that) + (and (base-prompt-tag/c? that) + (pairwise-equivalent-contracts? + (base-prompt-tag/c-ctcs this) + (base-prompt-tag/c-ctcs that)) + (pairwise-equivalent-contracts? + (base-prompt-tag/c-call/ccs this) + (base-prompt-tag/c-call/ccs that)))) ;; (listof contract) (listof contract) (define-struct base-prompt-tag/c (ctcs call/ccs)) @@ -682,6 +764,7 @@ #:late-neg-projection (prompt-tag/c-late-neg-proj #t) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? + #:equivalent prompt-tag/c-equivalent? #:name prompt-tag/c-name)) (define-struct (impersonator-prompt-tag/c base-prompt-tag/c) () @@ -691,6 +774,7 @@ #:late-neg-projection (prompt-tag/c-late-neg-proj #f) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? + #:equivalent prompt-tag/c-equivalent? #:name prompt-tag/c-name)) @@ -742,6 +826,12 @@ (base-continuation-mark-key/c-ctc this) (base-continuation-mark-key/c-ctc that)))) +(define (continuation-mark-key/c-equivalent? this that) + (and (base-continuation-mark-key/c? that) + (contract-struct-equivalent? + (base-continuation-mark-key/c-ctc this) + (base-continuation-mark-key/c-ctc that)))) + (define-struct base-continuation-mark-key/c (ctc)) (define-struct (chaperone-continuation-mark-key/c @@ -753,6 +843,7 @@ #:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key) #:first-order (λ (ctc) continuation-mark-key?) #:stronger continuation-mark-key/c-stronger? + #:equivalent continuation-mark-key/c-equivalent? #:name continuation-mark-key/c-name)) (define-struct (impersonator-continuation-mark-key/c @@ -764,6 +855,7 @@ #:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key) #:first-order (λ (ctc) continuation-mark-key?) #:stronger continuation-mark-key/c-stronger? + #:equivalent continuation-mark-key/c-equivalent? #:name continuation-mark-key/c-name)) ;; evt/c : Contract * -> Contract @@ -822,9 +914,20 @@ ;; evt/c-stronger? : Contract Contract -> Boolean (define (evt/c-stronger? this that) - (define this-ctcs (chaperone-evt/c-ctcs this)) - (define that-ctcs (chaperone-evt/c-ctcs that)) - (pairwise-stronger-contracts? this-ctcs that-ctcs)) + (cond + [(chaperone-evt/c? that) + (define this-ctcs (chaperone-evt/c-ctcs this)) + (define that-ctcs (chaperone-evt/c-ctcs that)) + (pairwise-stronger-contracts? this-ctcs that-ctcs)] + [else #f])) + +(define (evt/c-equivalent? this that) + (cond + [(chaperone-evt/c? that) + (define this-ctcs (chaperone-evt/c-ctcs this)) + (define that-ctcs (chaperone-evt/c-ctcs that)) + (pairwise-equivalent-contracts? this-ctcs that-ctcs)] + [else #f])) ;; ctcs - Listof (define-struct chaperone-evt/c (ctcs) @@ -833,6 +936,7 @@ #:late-neg-projection evt/c-proj #:first-order evt/c-first-order #:stronger evt/c-stronger? + #:equivalent evt/c-equivalent? #:name evt/c-name)) ;; channel/c @@ -890,6 +994,12 @@ (base-channel/c-ctc this) (base-channel/c-ctc that)))) +(define (channel/c-equivalent? this that) + (and (base-channel/c? that) + (contract-struct-equivalent? + (base-channel/c-ctc this) + (base-channel/c-ctc that)))) + (define-struct base-channel/c (ctc)) (define-struct (chaperone-channel/c base-channel/c) @@ -900,6 +1010,7 @@ #:late-neg-projection (channel/c-late-neg-proj chaperone-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? + #:equivalent channel/c-equivalent? #:name channel/c-name)) (define-struct (impersonator-channel/c base-channel/c) @@ -910,6 +1021,7 @@ #:late-neg-projection (channel/c-late-neg-proj impersonate-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? + #:equivalent channel/c-equivalent? #:name channel/c-name)) @@ -979,12 +1091,15 @@ (if (flat-contract? ctc) (flat-named-contract name (flat-contract-predicate ctc)) (let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)]) - (define (stronger? this other) + (define (rename-contract-stronger? this other) (contract-struct-stronger? ctc other)) + (define (rename-contract-equivalent? this other) + (contract-struct-equivalent? ctc other)) (make-contract #:name name #:late-neg-projection (get/build-late-neg-projection ctc) #:first-order (contract-first-order ctc) - #:stronger stronger? + #:stronger rename-contract-stronger? + #:equivalent rename-contract-equivalent? #:list-contract? (list-contract? ctc)))))) (define (if/c predicate then/c else/c) @@ -1062,6 +1177,16 @@ (loop (cdr c1s) (cdr c2s)))] [else #f]))) +(define (pairwise-equivalent-contracts? c1s c2s) + (let loop ([c1s c1s] + [c2s c2s]) + (cond + [(and (null? c1s) (null? c2s)) #t] + [(and (pair? c1s) (pair? c2s)) + (and (contract-struct-equivalent? (car c1s) (car c2s)) + (loop (cdr c1s) (cdr c2s)))] + [else #f]))) + (define (suggest/c _ctc field message) (define ctc (coerce-contract 'suggest/c _ctc)) (unless (string? field) @@ -1082,7 +1207,8 @@ #:name (contract-name ctc) #:first-order (contract-first-order ctc) #:late-neg-projection (λ (b) (ctc-lnp (blame-add-extra-field b field message))) - #:stronger (λ (this that) (contract-stronger? ctc that)) + #:stronger (λ (this that) (contract-struct-stronger? ctc that)) + #:equivalent (λ (this that) (contract-struct-equivalent? ctc that)) #:list-contract? (list-contract? ctc))) (define (flat-contract-with-explanation ? #:name [name (object-name ?)]) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/object.rkt racket-7.0+ppa1/collects/racket/contract/private/object.rkt --- racket-6.12+ppa1/collects/racket/contract/private/object.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/object.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -59,11 +59,15 @@ (build-contract-property #:late-neg-projection (λ (ctc) + (define flds (object-contract-fields ctc)) + (define fld-ctcs (object-contract-field-ctcs ctc)) + (define mtds (object-contract-methods ctc)) + (define mtd-ctcs (object-contract-method-ctcs ctc)) (λ (blame) + (define p-app + (make-wrapper-object blame mtds mtd-ctcs flds fld-ctcs)) (λ (val neg-party) - (make-wrapper-object ctc val blame neg-party - (object-contract-methods ctc) (object-contract-method-ctcs ctc) - (object-contract-fields ctc) (object-contract-field-ctcs ctc))))) + (p-app ctc val neg-party)))) #:name (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) (object-contract-fields ctc) @@ -124,6 +128,9 @@ [(subclass/c? that) (subclass? (subclass/c-% this) (subclass/c-% that))] [else #f])) + #:equivalent (λ (this that) + (and (subclass/c? that) + (equal? (subclass/c-% this) (subclass/c-% that)))) #:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%))))) (define (subclass?/c %) (unless (class? %) @@ -141,6 +148,10 @@ (interface-extension? (implementation/c-<%> this) (implementation/c-<%> that))] [else #f])) + #:equivalent (λ (this that) + (and (implementation/c? that) + (equal? (implementation/c-<%> this) + (implementation/c-<%> that)))) #:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>))))) (define (implementation?/c <%>) @@ -181,6 +192,10 @@ (interface-extension? this-<%> that-<%>)] [else #f])] [else #f])) + #:equivalent + (λ (this that) + (and (is-a?-ctc? that) + (equal? (is-a?-ctc-<%> this) (is-a?-ctc-<%> that)))) #:name (λ (ctc) (define <%> (is-a?-ctc-<%> ctc)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/opt.rkt racket-7.0+ppa1/collects/racket/contract/private/opt.rkt --- racket-6.12+ppa1/collects/racket/contract/private/opt.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/opt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -236,7 +236,7 @@ (optres-superlifts an-optres) (bind-lifts (optres-lifts an-optres) - #`(make-opt-contract + #`(make-an-opt-contract (λ (ctc) (λ (blame) #,(bind-superlifts @@ -246,7 +246,11 @@ (λ (this that) #f) (vector) (begin-lifted (box #f)) - #,(optres-chaperone an-optres)))) + #,(optres-chaperone an-optres) + #,(let ([f (optres-flat an-optres)]) + (if f + #`(λ (val) #,f) + #'#f))))) #`(coerce-contract '#,error-name-sym #,exp)))) ;; this macro optimizes 'e' as a contract, @@ -324,7 +328,7 @@ (optres-superlifts an-optres) (bind-lifts (optres-lifts an-optres) - #`(make-opt-contract + #`(make-an-opt-contract (λ (ctc) (λ (blame) (λ (val) @@ -333,7 +337,11 @@ (λ (this that) #f) (vector) (begin-lifted (box #f)) - #,(optres-chaperone an-optres))))) + #,(optres-chaperone an-optres) + #,(let ([f (optres-flat an-optres)]) + (if f + #`(λ (val) #,f) + #'#f)))))) (values f1 f2)))])) ;; optimized contracts @@ -346,18 +354,48 @@ (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) (make-struct-type-property 'original-contract)) +(define (make-an-opt-contract proj name stronger stronger-vars stamp + chaperone? flat) + (cond + [flat + (make-flat-opt-contract proj name stronger stronger-vars stamp flat)] + [chaperone? + (make-chaperone-opt-contract proj name stronger stronger-vars stamp)] + [else + (make-impersonator-opt-contract proj name stronger stronger-vars stamp)])) + ;; the stronger-vars don't seem to be used anymore for stronger; probably ;; they should be folded into the lifts and then there should be a separate ;; setup for consolidating stronger checks -(define-struct opt-contract (proj name stronger stronger-vars stamp chaperone?) - #:property prop:opt-chaperone-contract (λ (ctc) (opt-contract-chaperone? ctc)) - #:property prop:custom-write (λ (val port mode) (fprintf port "#" (opt-contract-name val))) +(define-struct opt-contract (proj name stronger stronger-vars stamp)) + +(define (opt-contract-stronger-proc this that) + (and (opt-contract? that) + (eq? (opt-contract-stamp this) (opt-contract-stamp that)) + ((opt-contract-stronger this) this that))) + +(define-struct (flat-opt-contract opt-contract) (predicate) + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) + #:property prop:flat-contract + (build-flat-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + #:first-order (λ (ctc) (flat-opt-contract-predicate ctc)) + #:name (λ (ctc) (opt-contract-name ctc)) + #:stronger opt-contract-stronger-proc)) +(define-struct (chaperone-opt-contract opt-contract) () + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + #:name (λ (ctc) (opt-contract-name ctc)) + #:stronger opt-contract-stronger-proc)) +(define-struct (impersonator-opt-contract opt-contract) () + #:property prop:custom-write + (λ (val port mode) (fprintf port "#" (opt-contract-name val))) #:property prop:contract (build-contract-property #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) #:name (λ (ctc) (opt-contract-name ctc)) - #:stronger - (λ (this that) - (and (opt-contract? that) - (eq? (opt-contract-stamp this) (opt-contract-stamp that)) - ((opt-contract-stronger this) this that))))) + #:stronger opt-contract-stronger-proc)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/orc.rkt racket-7.0+ppa1/collects/racket/contract/private/orc.rkt --- racket-6.12+ppa1/collects/racket/contract/private/orc.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/orc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -110,6 +110,14 @@ (single-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) +(define (single-or/c-equivalent? this that) + (or (and (single-or/c? that) + (contract-struct-equivalent? (single-or/c-ho-ctc this) + (single-or/c-ho-ctc that)) + (pairwise-equivalent-contracts? (single-or/c-flat-ctcs this) + (single-or/c-flat-ctcs that))) + (generic-or/c-equivalent? this that))) + (define (generic-or/c-stronger? this that) (define this-sub-ctcs (or/c-sub-contracts this)) (define that-sub-ctcs (or/c-sub-contracts that)) @@ -119,6 +127,15 @@ (for/or ([that-sub-ctc (in-list that-sub-ctcs)]) (contract-struct-stronger? this-sub-ctc that-sub-ctc))))) +(define (generic-or/c-equivalent? this that) + (define this-sub-ctcs (or/c-sub-contracts this)) + (define that-sub-ctcs (or/c-sub-contracts that)) + (and this-sub-ctcs + that-sub-ctcs + (pairwise-equivalent-contracts? + (sort this-sub-ctcs < #:key (λ (x) (equal-hash-code (contract-name x)))) + (sort that-sub-ctcs < #:key (λ (x) (equal-hash-code (contract-name x))))))) + (define (or/c-sub-contracts ctc) (cond [(single-or/c? ctc) @@ -215,6 +232,7 @@ #:name single-or/c-name #:first-order single-or/c-first-order #:stronger single-or/c-stronger? + #:equivalent single-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (cons (single-or/c-ho-ctc ctc) (single-or/c-flat-ctcs ctc)))) @@ -229,6 +247,7 @@ #:name single-or/c-name #:first-order single-or/c-first-order #:stronger single-or/c-stronger? + #:equivalent single-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (cons (single-or/c-ho-ctc ctc) (single-or/c-flat-ctcs ctc)))) @@ -316,6 +335,14 @@ (multi-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) +(define (multi-or/c-equivalent? this that) + (or (and (multi-or/c? that) + (pairwise-equivalent-contracts? (multi-or/c-ho-ctcs this) + (multi-or/c-ho-ctcs that)) + (pairwise-equivalent-contracts? (multi-or/c-flat-ctcs this) + (multi-or/c-flat-ctcs that))) + (generic-or/c-equivalent? this that))) + (define (mult-or/c-list-contract? c) (and (for/and ([c (in-list (multi-or/c-flat-ctcs c))]) (list-contract? c)) @@ -335,6 +362,7 @@ #:name multi-or/c-name #:first-order multi-or/c-first-order #:stronger multi-or/c-stronger? + #:equivalent multi-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (append (multi-or/c-ho-ctcs ctc) (multi-or/c-flat-ctcs ctc)))) @@ -349,6 +377,7 @@ #:name multi-or/c-name #:first-order multi-or/c-first-order #:stronger multi-or/c-stronger? + #:equivalent multi-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (append (multi-or/c-ho-ctcs ctc) (multi-or/c-flat-ctcs ctc)))) @@ -394,7 +423,7 @@ #f))] [else #f]))) (generic-or/c-stronger? this that))) - + #:equivalent generic-or/c-equivalent? #:first-order (λ (ctc) (flat-or/c-pred ctc)) @@ -470,6 +499,7 @@ #:name first-or/c-name #:first-order first-or/c-first-order #:stronger multi-or/c-stronger? + #:equivalent multi-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) #:list-contract? first-or/c-list-contract?)) @@ -480,6 +510,7 @@ #:name first-or/c-name #:first-order first-or/c-first-order #:stronger generic-or/c-stronger? + #:equivalent generic-or/c-equivalent? #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) #:list-contract? first-or/c-list-contract?)) @@ -526,6 +557,15 @@ (parameterize ([recur? #f]) (contract-struct-stronger? (get-flat-rec-me this) that))] [else #f]))) + #:equivalent + (let ([recur? (make-parameter #t)]) + (λ (this that) + (cond + [(equal? this that) #t] + [(recur?) + (parameterize ([recur? #f]) + (contract-struct-equivalent? (get-flat-rec-me this) that))] + [else #f]))) #:first-order (λ (ctc) (λ (v) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/parametric.rkt racket-7.0+ppa1/collects/racket/contract/private/parametric.rkt --- racket-6.12+ppa1/collects/racket/contract/private/parametric.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/parametric.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -53,6 +53,24 @@ (apply (polymorphic-contract-body that) instances))] [else #f])] [else #f])) + #:equivalent + (λ (this that) + (cond + [(polymorphic-contract? that) + (define this-vars (polymorphic-contract-vars this)) + (define that-vars (polymorphic-contract-vars that)) + (define this-barrier/c (polymorphic-contract-barrier this)) + (define that-barrier/c (polymorphic-contract-barrier that)) + (cond + [(and (eq? this-barrier/c that-barrier/c) + (= (length this-vars) (length that-vars))) + (define instances + (for/list ([var (in-list this-vars)]) + (this-barrier/c #t var))) + (contract-struct-equivalent? (apply (polymorphic-contract-body this) instances) + (apply (polymorphic-contract-body that) instances))] + [else #f])] + [else #f])) #:late-neg-projection (lambda (c) (lambda (orig-blame) @@ -104,6 +122,7 @@ #:name (lambda (c) (barrier-contract-name c)) #:first-order (λ (c) (barrier-contract-pred c)) #:stronger (λ (this that) (eq? this that)) + #:equivalent (λ (this that) (eq? this that)) #:late-neg-projection (lambda (c) (define mk (barrier-contract-make c)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/prop.rkt racket-7.0+ppa1/collects/racket/contract/private/prop.rkt --- racket-6.12+ppa1/collects/racket/contract/private/prop.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/prop.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,6 +12,7 @@ contract-struct-val-first-projection contract-struct-late-neg-projection contract-struct-stronger? + contract-struct-equivalent? contract-struct-generate contract-struct-exercise contract-struct-list-contract? @@ -34,11 +35,7 @@ make-contract make-chaperone-contract make-flat-contract - - prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test - + prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts @@ -66,6 +63,7 @@ first-order projection stronger + equivalent generate exercise val-first-projection @@ -115,60 +113,86 @@ (and get-projection (get-projection c))) -(define trail (make-parameter #f)) -(define (contract-struct-stronger? a b) - (cond - [(and (or (flat-contract-struct? a) - (chaperone-contract-struct? a)) - (equal? a b)) - #t] - [else - (define prop (contract-struct-property a)) - (define stronger? (contract-property-stronger prop)) - (cond - [(stronger? a b) - ;; optimistically try skip some of the more complex work below - #t] - [(and (flat-contract-struct? a) (prop:any/c? b)) #t] ;; is the flat-check needed here? - [(let ([th (trail)]) - (and th - (for/or ([(a2 bs-h) (in-hash th)]) - (and (eq? a a2) - (for/or ([(b2 _) (in-hash bs-h)]) - (eq? b b2)))))) - #t] - [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) - (parameterize ([trail (or (trail) (make-hasheq))]) - (define trail-h (trail)) - (let ([a-h (hash-ref trail-h a #f)]) +(define (contract-struct-stronger/equivalent? + a b + trail + contract-property-stronger/equivalent + special-or/c-any/c-handling?) + (let loop ([a a][b b]) + (cond + [(and (or (flat-contract-struct? a) + (chaperone-contract-struct? a)) + (equal? a b)) + #t] + [else + (define prop (contract-struct-property a)) + (define stronger/equivalent? (contract-property-stronger/equivalent prop)) + (cond + [(stronger/equivalent? a b) + ;; optimistically try skip some of the more complex work below + #t] + [(and special-or/c-any/c-handling? + (flat-contract-struct? a) + (prop:any/c? b)) + ;; is the flat-check needed here? + #t] + [(let ([th (trail)]) + (and th + (for/or ([(a2 bs-h) (in-hash th)]) + (and (eq? a a2) + (for/or ([(b2 _) (in-hash bs-h)]) + (eq? b b2)))))) + #t] + [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) + (parameterize ([trail (or (trail) (make-hasheq))]) + (define trail-h (trail)) + (let ([a-h (hash-ref trail-h a #f)]) + (cond + [a-h + (hash-set! a-h b #t)] + [else + (define a-h (make-hasheq)) + (hash-set! trail-h a a-h) + (hash-set! a-h b #t)])) + (loop (if (prop:recursive-contract? a) + ((prop:recursive-contract-unroll a) a) + a) + (if (prop:recursive-contract? b) + ((prop:recursive-contract-unroll b) b) + b)))] + [special-or/c-any/c-handling? + ;; the 'later?' flag avoids checking + ;; (stronger? a b) in the first iteration, + ;; since it was checked in the "optimistically" + ;; branch above + (let loop ([b b] [later? #f]) (cond - [a-h - (hash-set! a-h b #t)] + [(and later? (stronger/equivalent? a b)) + #t] + [(prop:orc-contract? b) + (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) + (for/or ([sub-contract (in-list sub-contracts)]) + (loop sub-contract #t))] [else - (define a-h (make-hasheq)) - (hash-set! trail-h a a-h) - (hash-set! a-h b #t)])) - (contract-struct-stronger? (if (prop:recursive-contract? a) - ((prop:recursive-contract-unroll a) a) - a) - (if (prop:recursive-contract? b) - ((prop:recursive-contract-unroll b) b) - b)))] - [else - ;; the 'later?' flag avoids checking - ;; (stronger? a b) in the first iteration, - ;; since it was checked in the "optimistically" - ;; branch above - (let loop ([b b] [later? #f]) - (cond - [(and later? (stronger? a b)) - #t] - [(prop:orc-contract? b) - (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) - (for/or ([sub-contract (in-list sub-contracts)]) - (loop sub-contract #t))] - [else - #f]))])])) + #f]))] + [else #f])]))) + +(define stronger-trail (make-parameter #f)) +(define (contract-struct-stronger? a b) + (contract-struct-stronger/equivalent? + a b + stronger-trail + contract-property-stronger + #t)) + +(define equivalent-trail (make-parameter #f)) +(define (contract-struct-equivalent? a b) + (contract-struct-stronger/equivalent? + a b + equivalent-trail + contract-property-equivalent + #f)) + (define (contract-struct-generate c) (define prop (contract-struct-property c)) @@ -221,15 +245,6 @@ chaperone-contract-property-guard (list (cons prop:contract chaperone-contract-property->contract-property)))) -;; this property is so the opt'd contracts can -;; declare that they are chaperone'd; the property -;; is a function that extracts a boolean from the -;; original struct -(define-values (prop:opt-chaperone-contract - prop:opt-chaperone-contract? - prop:opt-chaperone-contract-get-test) - (make-struct-type-property 'prop:opt-chaperone-contract)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Flat Contract Property @@ -275,13 +290,14 @@ (define-logger racket/contract) -(define ((build-property mk default-name proc-name first-order?) +(define ((build-property mk default-name proc-name first-order? equivalent-equal?) #:name [get-name #f] #:first-order [get-first-order #f] #:projection [get-projection #f] #:val-first-projection [get-val-first-projection #f] #:late-neg-projection [get-late-neg-projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:generate [generate (λ (ctc) (λ (fuel) #f))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (c) #f)]) @@ -317,6 +333,7 @@ (or get-first-order get-any?) get-projection (or stronger weakest) + (or equivalent (if equivalent-equal? equal? weakest)) generate exercise get-val-first-projection (cond @@ -338,25 +355,19 @@ (define build-contract-property (procedure-rename - (build-property make-contract-property 'anonymous-contract 'build-contract-property #f) + (build-property make-contract-property 'anonymous-contract 'build-contract-property #f #f) 'build-contract-property)) (define build-flat-contract-property (procedure-rename (build-property (compose make-flat-contract-property make-contract-property) - 'anonymous-flat-contract 'build-flat-contract-property #t) + 'anonymous-flat-contract 'build-flat-contract-property #t #t) 'build-flat-contract-property)) -(define (blame-context-projection-wrapper proj) - (λ (ctc) - (define c-proj (proj ctc)) - (λ (blame) - (c-proj (blame-add-unknown-context blame))))) - (define build-chaperone-contract-property (procedure-rename (build-property (compose make-chaperone-contract-property make-contract-property) - 'anonymous-chaperone-contract 'build-chaperone-contract-property #f) + 'anonymous-chaperone-contract 'build-chaperone-contract-property #f #t) 'build-chaperone-contract-property)) (define (get-any? c) any?) @@ -396,7 +407,7 @@ (define-struct make-contract [ name first-order projection val-first-projection late-neg-projection - stronger generate exercise list-contract? ] + stronger equivalent generate exercise list-contract? ] #:omit-define-syntaxes #:property prop:custom-write (λ (stct port display?) @@ -417,7 +428,7 @@ (define-struct make-chaperone-contract [ name first-order projection val-first-projection late-neg-projection - stronger generate exercise list-contract? ] + stronger equivalent generate exercise list-contract? ] #:omit-define-syntaxes #:property prop:custom-write (λ (stct port display?) @@ -438,7 +449,7 @@ (define-struct make-flat-contract [ name first-order projection val-first-projection late-neg-projection - stronger generate exercise list-contract? ] + stronger equivalent generate exercise list-contract? ] #:omit-define-syntaxes #:property prop:custom-write (λ (stct port display?) @@ -457,13 +468,14 @@ #:exercise (lambda (c) (make-flat-contract-exercise c)) #:list-contract? (λ (c) (make-flat-contract-list-contract? c)))) -(define ((build-contract mk default-name proc-name first-order?) +(define ((build-contract mk default-name proc-name first-order? equivalent-equal?) #:name [name #f] #:first-order [first-order #f] #:projection [projection #f] #:val-first-projection [val-first-projection #f] #:late-neg-projection [late-neg-projection #f] #:stronger [stronger #f] + #:equivalent [equivalent #f] #:generate [generate (λ (ctc) (λ (fuel) #f))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? #f]) @@ -498,6 +510,7 @@ [else #f])] [else late-neg-projection]) (or stronger weakest) + (or equivalent (if equivalent-equal? equal? weakest)) generate exercise (and list-contract? #t))) @@ -515,7 +528,7 @@ (define make-contract (procedure-rename - (build-contract make-make-contract 'anonymous-contract 'make-contract #f) + (build-contract make-make-contract 'anonymous-contract 'make-contract #f #f) 'make-contract)) (define make-chaperone-contract @@ -523,7 +536,7 @@ (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract 'make-chaperone-contract - #f) + #f #t) 'make-chaperone-contract)) (define make-flat-contract @@ -531,7 +544,7 @@ (build-contract make-make-flat-contract 'anonymous-flat-contract 'make-flat-contract - #t) + #t #t) 'make-flat-contract)) ;; property should be bound to a function that accepts the contract and diff -Nru racket-6.12+ppa1/collects/racket/contract/private/provide.rkt racket-7.0+ppa1/collects/racket/contract/private/provide.rkt --- racket-6.12+ppa1/collects/racket/contract/private/provide.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/provide.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -259,7 +259,8 @@ id-rename (stx->srcloc-expr srcloc-id) 'provide/contract - pos-module-source) + pos-module-source + #f) #,@(if provide? (list #`(provide (rename-out [#,id-rename external-name]))) null))) @@ -279,7 +280,8 @@ id-rename srcloc-expr contract-error-name - pos-module-source) + pos-module-source + context-limit) (define-values (arrow? the-valid-app-shapes) (syntax-case ctrct (-> ->* ->i) [(-> . _) @@ -306,7 +308,8 @@ id '#,name-for-blame #,pos-module-source - #,srcloc-expr)) + #,srcloc-expr + #,context-limit)) #,@(if arrow? (list #`(define extra-neg-party-argument-fn (wrapped-extra-arg-arrow-extra-neg-party-argument @@ -351,15 +354,17 @@ (raise-syntax-error #f "expected an identifier" stx #'new-id)) (unless (identifier? #'orig-id) (raise-syntax-error #f "expected an identifier" stx #'orig-id)) - (define-values (pos-blame-party-expr srcloc-expr name-for-blame) + (define-values (pos-blame-party-expr srcloc-expr name-for-blame context-limit) (let loop ([kwd-args (syntax->list #'(kwd-args ...))] [pos-blame-party-expr #'(quote-module-path)] [srcloc-expr #f] - [name-for-blame #f]) + [name-for-blame #f] + [context-limit #f]) (cond [(null? kwd-args) (values pos-blame-party-expr (or srcloc-expr (stx->srcloc-expr stx)) - (or name-for-blame #'new-id))] + (or name-for-blame #'new-id) + context-limit)] [else (define kwd (car kwd-args)) (cond @@ -370,7 +375,8 @@ (loop (cddr kwd-args) (cadr kwd-args) srcloc-expr - name-for-blame)] + name-for-blame + context-limit)] [(equal? (syntax-e kwd) '#:srcloc) (when (null? (cdr kwd-args)) (raise-syntax-error #f "expected a keyword argument to follow #:srcloc" @@ -378,7 +384,8 @@ (loop (cddr kwd-args) pos-blame-party-expr (cadr kwd-args) - name-for-blame)] + name-for-blame + context-limit)] [(equal? (syntax-e kwd) '#:name-for-blame) (when (null? (cdr kwd-args)) (raise-syntax-error #f "expected a keyword argument to follow #:name-for-blame" @@ -391,11 +398,23 @@ (loop (cddr kwd-args) pos-blame-party-expr srcloc-expr - name-for-blame)] + name-for-blame + context-limit)] + [(equal? (syntax-e kwd) '#:context-limit) + (when (null? (cdr kwd-args)) + (raise-syntax-error #f "expected an expression to follow #:context-limit" + stx)) + (loop (cddr kwd-args) + pos-blame-party-expr + srcloc-expr + name-for-blame + (cadr kwd-args))] [else (raise-syntax-error #f - "expected one of the keywords #:pos-source, #:srcloc, or #:name-for-blame" + (string-append + "expected one of the keywords" + " #:pos-source, #:srcloc, #:name-for-blame, or #:context-limit") stx (car kwd-args))])]))) (internal-function-to-be-figured-out #'ctrct @@ -405,10 +424,11 @@ #'new-id srcloc-expr 'define-module-boundary-contract - pos-blame-party-expr))])])) + pos-blame-party-expr + context-limit))])])) ;; ... -> (values (or/c #f (-> neg-party val)) blame) -(define (do-partial-app ctc val name pos-module-source source) +(define (do-partial-app ctc val name pos-module-source source context-limit) (define p (parameterize ([warn-about-val-first? #f]) ;; when we're building the val-first projection ;; here we might be needing the plus1 arity @@ -419,7 +439,8 @@ name (λ () (contract-name ctc)) pos-module-source - #f #t)) + #f #t + #:context-limit context-limit)) (with-contract-continuation-mark (cons blme 'no-negative-party) ; we don't know the negative party yet ;; computing neg-accepter may involve some front-loaded checking. instrument @@ -1165,7 +1186,8 @@ [field-name (in-list field-names)]) ((get/build-late-neg-projection ctc) (blame-add-context blame - (format "the ~a field of" field-name))))) + (format "the ~a field of" field-name) + #:swap? #t)))) (chaperone-struct-type struct-type (λ (a b c d e f g h) (values a b c d e f g h)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/struct-dc.rkt racket-7.0+ppa1/collects/racket/contract/private/struct-dc.rkt --- racket-6.12+ppa1/collects/racket/contract/private/struct-dc.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/struct-dc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -673,7 +673,44 @@ (procedure-closure-contents-eq? (dep-dep-proc this-subcontract) (dep-dep-proc that-subcontract)))] - [else #t])))) + [else #f])))) + +(define (struct/dc-equivalent? this that) + (and (base-struct/dc? that) + (eq? (base-struct/dc-pred this) (base-struct/dc-pred that)) + (let ([this-inv (get-invariant this)] + [that-inv (get-invariant that)]) + (cond + [(and (not this-inv) (not that-inv)) #t] + [(and this-inv that-inv) + (procedure-closure-contents-eq? (invariant-dep-proc this-inv) + (invariant-dep-proc that-inv))] + [else #f])) + (for/and ([this-subcontract (in-list (base-struct/dc-subcontracts this))] + [that-subcontract (in-list (base-struct/dc-subcontracts that))]) + (cond + [(and (indep? this-subcontract) + (indep? that-subcontract)) + (and (or (and (mutable? this-subcontract) + (mutable? that-subcontract)) + (and (immutable? this-subcontract) + (immutable? that-subcontract)) + (and (lazy-immutable? this-subcontract) + (lazy-immutable? that-subcontract))) + (contract-struct-equivalent? (indep-ctc this-subcontract) + (indep-ctc that-subcontract)))] + [(and (dep? this-subcontract) + (dep? that-subcontract)) + (and (or (and (dep-mutable? this-subcontract) + (dep-mutable? that-subcontract)) + (and (dep-immutable? this-subcontract) + (dep-immutable? that-subcontract)) + (and (dep-lazy-immutable? this-subcontract) + (dep-lazy-immutable? that-subcontract))) + (procedure-closure-contents-eq? + (dep-dep-proc this-subcontract) + (dep-dep-proc that-subcontract)))] + [else #f])))) (define (get-invariant sc) (for/or ([sub (base-struct/dc-subcontracts sc)] @@ -700,6 +737,7 @@ #:first-order struct/dc-first-order #:late-neg-projection struct/dc-late-neg-proj #:stronger struct/dc-stronger? + #:equivalent struct/dc-equivalent? #:generate struct/dc-generate #:exercise struct/dc-exercise)) @@ -710,6 +748,7 @@ #:first-order struct/dc-flat-first-order #:late-neg-projection struct/dc-late-neg-proj #:stronger struct/dc-stronger? + #:equivalent struct/dc-equivalent? #:generate struct/dc-generate #:exercise struct/dc-exercise)) @@ -720,6 +759,7 @@ #:first-order struct/dc-first-order #:late-neg-projection struct/dc-late-neg-proj #:stronger struct/dc-stronger? + #:equivalent struct/dc-equivalent? #:generate struct/dc-generate #:exercise struct/dc-exercise)) diff -Nru racket-6.12+ppa1/collects/racket/contract/private/vector.rkt racket-7.0+ppa1/collects/racket/contract/private/vector.rkt --- racket-6.12+ppa1/collects/racket/contract/private/vector.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/contract/private/vector.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -126,6 +126,15 @@ (contract-struct-stronger? that-elem this-elem))])] [else #f])) +(define (vectorof-equivalent this that) + (cond + [(base-vectorof? that) + (and (equal? (base-vectorof-immutable this) + (base-vectorof-immutable that)) + (contract-struct-equivalent? (base-vectorof-elem this) + (base-vectorof-elem that)))] + [else #f])) + (define-struct (flat-vectorof base-vectorof) () #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract @@ -143,11 +152,12 @@ (for ([x (in-vector val)]) (vfp+blame x neg-party)) val))) + #:equivalent vectorof-equivalent #:stronger vectorof-stronger)) (define (blame-add-element-of-context blame #:swap? [swap? #f]) (blame-add-context blame "an element of" #:swap? swap?)) - + (define (vectorof-late-neg-ho-projection chaperone-or-impersonate-vector) (λ (ctc) (define elem-ctc (base-vectorof-elem ctc)) @@ -158,20 +168,54 @@ (define pos-blame (blame-add-element-of-context blame)) (define neg-blame (blame-add-element-of-context blame #:swap? #t)) (define vfp (get/build-late-neg-projection elem-ctc)) - (define elem-pos-proj (vfp pos-blame)) - (define elem-neg-proj (vfp neg-blame)) - (define checked-ref (λ (neg-party) - (define blame+neg-party (cons pos-blame neg-party)) - (λ (vec i val) - (with-contract-continuation-mark - blame+neg-party - (elem-pos-proj val neg-party))))) - (define checked-set (λ (neg-party) - (define blame+neg-party (cons neg-blame neg-party)) - (λ (vec i val) - (with-contract-continuation-mark - blame+neg-party - (elem-neg-proj val neg-party))))) + (define-values (filled? elem-pos-proj elem-neg-proj) + (contract-pos/neg-doubling (vfp pos-blame) (vfp neg-blame))) + (define-values (checked-ref checked-set) + (cond + [filled? + (define checked-ref (λ (neg-party) + (define blame+neg-party (cons pos-blame neg-party)) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + (elem-pos-proj val neg-party))))) + (define checked-set (λ (neg-party) + (define blame+neg-party (cons neg-blame neg-party)) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + (elem-neg-proj val neg-party))))) + (values checked-ref checked-set)] + [else + (define ref-tc (make-thread-cell #f)) + (define set-tc (make-thread-cell #f)) + (define checked-ref (λ (neg-party) + (define blame+neg-party (cons pos-blame neg-party)) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + (define real-elem-pos-proj + (cond + [(thread-cell-ref ref-tc) => values] + [else + (define real-elem-pos-proj (elem-pos-proj)) + (thread-cell-set! ref-tc real-elem-pos-proj) + real-elem-pos-proj])) + (real-elem-pos-proj val neg-party))))) + (define checked-set (λ (neg-party) + (define blame+neg-party (cons neg-blame neg-party)) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + (define real-elem-neg-proj + (cond + [(thread-cell-ref set-tc) => values] + [else + (define real-elem-neg-proj (elem-neg-proj)) + (thread-cell-set! set-tc real-elem-neg-proj) + real-elem-neg-proj])) + (real-elem-neg-proj val neg-party))))) + (values checked-ref checked-set)])) (cond [(flat-contract? elem-ctc) (define p? (flat-contract-predicate elem-ctc)) @@ -181,35 +225,39 @@ (check val raise-blame #f) ;; avoid traversing large vectors ;; unless `eager` is specified - (if (and (or (equal? eager #t) - (and eager (<= (vector-length val) eager))) - (immutable? val) - (not (chaperone? val))) - (begin (for ([e (in-vector val)]) - (unless (p? e) - (elem-pos-proj e neg-party))) - val) - (chaperone-or-impersonate-vector - val - (checked-ref neg-party) - (checked-set neg-party) - impersonator-prop:contracted ctc - impersonator-prop:blame (blame-add-missing-party blame neg-party))))] + (cond + [(and (or (equal? eager #t) + (and eager (<= (vector-length val) eager))) + (immutable? val) + (not (chaperone? val))) + (for ([e (in-vector val)]) + (unless (p? e) + (elem-pos-proj e neg-party))) + val] + [else + (chaperone-or-impersonate-vector + val + (checked-ref neg-party) + (checked-set neg-party) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))]))] [else - (λ (val neg-party) + (λ (val neg-party) (define (raise-blame val . args) (apply raise-blame-error blame #:missing-party neg-party val args)) (check val raise-blame #f) - (if (and (immutable? val) (not (chaperone? val))) - (vector->immutable-vector - (for/vector #:length (vector-length val) ([e (in-vector val)]) - (elem-pos-proj e neg-party))) - (chaperone-or-impersonate-vector - val - (checked-ref neg-party) - (checked-set neg-party) - impersonator-prop:contracted ctc - impersonator-prop:blame (blame-add-missing-party blame neg-party))))])))) + (cond + [(and (immutable? val) (not (chaperone? val))) + (vector->immutable-vector + (for/vector #:length (vector-length val) ([e (in-vector val)]) + (elem-pos-proj e neg-party)))] + [else + (chaperone-or-impersonate-vector + val + (checked-ref neg-party) + (checked-set neg-party) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))]))])))) (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get) (make-impersonator-property 'prop:neg-blame-party)) @@ -220,6 +268,7 @@ (build-chaperone-contract-property #:name vectorof-name #:first-order vectorof-first-order + #:equivalent vectorof-equivalent #:stronger vectorof-stronger #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector))) @@ -229,6 +278,7 @@ (build-contract-property #:name vectorof-name #:first-order vectorof-first-order + #:equivalent vectorof-equivalent #:stronger vectorof-stronger #:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector))) @@ -250,7 +300,10 @@ 'racket/contract:contract (vector this-one (list #'vecof) null))))])) -(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f] #:eager [eager #t]) +(define/subexpression-pos-prop (vectorof c + #:immutable [immutable 'dont-care] + #:flat? [flat? #f] + #:eager [eager #t]) (define ctc (if flat? (coerce-flat-contract 'vectorof c) @@ -334,7 +387,6 @@ (contract-first-order-passes? c e))))) (define (vector/c-stronger this that) - ;(define-struct base-vector/c (elems immutable)) (define this-elems (base-vector/c-elems this)) (define this-immutable (base-vector/c-immutable this)) (cond @@ -372,6 +424,15 @@ [else #f])] [else #f])) +(define (vector/c-equivalent this that) + (cond + [(base-vector/c? that) + (and (equal? (base-vector/c-immutable this) + (base-vector/c-immutable that)) + (pairwise-equivalent-contracts? (base-vector/c-elems this) + (base-vector/c-elems that)))] + [else #f])) + (define-struct (flat-vector/c base-vector/c) () #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract @@ -379,6 +440,7 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger + #:equivalent vector/c-equivalent #:late-neg-projection (λ (ctc) (λ (blame) @@ -398,37 +460,70 @@ (let ([elem-ctcs (base-vector/c-elems ctc)] [immutable (base-vector/c-immutable ctc)]) (λ (blame) - (let ([elem-pos-projs (for/vector #:length (length elem-ctcs) - ([c (in-list elem-ctcs)] - [i (in-naturals)]) - ((get/build-late-neg-projection c) - (blame-add-context blame (format "the ~a element of" (n->th i)))))] - [elem-neg-projs (for/vector #:length (length elem-ctcs) - ([c (in-list elem-ctcs)] - [i (in-naturals)]) - ((get/build-late-neg-projection c) - (blame-add-context blame (format "the ~a element of" (n->th i)) - #:swap? #t)))]) - (λ (val neg-party) - (check-vector/c ctc val blame neg-party) - (define blame+neg-party (cons blame neg-party)) - (if (and (immutable? val) (not (chaperone? val))) - (apply vector-immutable - (for/list ([e (in-vector val)] - [i (in-naturals)]) - ((vector-ref elem-pos-projs i) e neg-party))) - (vector-wrapper - val - (λ (vec i val) - (with-contract-continuation-mark - blame+neg-party - ((vector-ref elem-pos-projs i) val neg-party))) - (λ (vec i val) - (with-contract-continuation-mark - blame+neg-party - ((vector-ref elem-neg-projs i) val neg-party))) - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))))))) + (define-values (filled? maybe-elem-pos-projs maybe-elem-neg-projs) + (contract-pos/neg-doubling + (for/vector #:length (length elem-ctcs) + ([c (in-list elem-ctcs)] + [i (in-naturals)]) + ((get/build-late-neg-projection c) + (blame-add-context blame (nth-element-of i)))) + (for/vector #:length (length elem-ctcs) + ([c (in-list elem-ctcs)] + [i (in-naturals)]) + ((get/build-late-neg-projection c) + (blame-add-context blame (nth-element-of i) #:swap? #t))))) + (cond + [filled? + (λ (val neg-party) + (check-vector/c ctc val blame neg-party) + (define blame+neg-party (cons blame neg-party)) + (if (and (immutable? val) (not (chaperone? val))) + (apply vector-immutable + (for/list ([e (in-vector val)] + [i (in-naturals)]) + ((vector-ref maybe-elem-pos-projs i) e neg-party))) + (vector-wrapper + val + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + ((vector-ref maybe-elem-pos-projs i) val neg-party))) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + ((vector-ref maybe-elem-neg-projs i) val neg-party))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))] + [else + (define pos-tc (make-thread-cell #f)) + (define neg-tc (make-thread-cell #f)) + (define (get-projs tc get-ele-projs) + (cond + [(thread-cell-ref tc) => values] + [else + (define projs (get-ele-projs)) + (thread-cell-set! tc projs) + projs])) + (λ (val neg-party) + (check-vector/c ctc val blame neg-party) + (define blame+neg-party (cons blame neg-party)) + (if (and (immutable? val) (not (chaperone? val))) + (apply vector-immutable + (for/list ([e (in-vector val)] + [i (in-naturals)]) + ((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) e neg-party))) + (vector-wrapper + val + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + ((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) val neg-party))) + (λ (vec i val) + (with-contract-continuation-mark + blame+neg-party + ((vector-ref (get-projs neg-tc maybe-elem-neg-projs) i) val neg-party))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))]))))) (define-struct (chaperone-vector/c base-vector/c) () #:property prop:custom-write custom-write-property-proc @@ -437,6 +532,7 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger + #:equivalent vector/c-equivalent #:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector))) (define-struct (impersonator-vector/c base-vector/c) () @@ -446,6 +542,7 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger + #:equivalent vector/c-equivalent #:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector))) (define-syntax (wrap-vector/c stx) diff -Nru racket-6.12+ppa1/collects/racket/extflonum.rkt racket-7.0+ppa1/collects/racket/extflonum.rkt --- racket-6.12+ppa1/collects/racket/extflonum.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/extflonum.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -21,4 +21,5 @@ for/extflvector for*/extflvector extflvector-copy - 0.0T0) + 0.0T0 + check-extflonum) diff -Nru racket-6.12+ppa1/collects/racket/fasl.rkt racket-7.0+ppa1/collects/racket/fasl.rkt --- racket-6.12+ppa1/collects/racket/fasl.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/fasl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,30 +1,571 @@ #lang racket/base +(require (for-syntax racket/base) + "private/truncate-path.rkt") (provide s-exp->fasl fasl->s-exp) -(define (s-exp->fasl v [out #f]) - (when out - (unless (output-port? out) - (raise-argument-error 'fasl->s-exp "(or/c output-port? #f)" out))) - (let ([p (or out - (open-output-bytes))]) - (parameterize ([current-namespace (make-base-namespace)]) - (write (compile `(quote ,v)) p)) - (if out - (void) - (get-output-bytes p)))) - -(define (fasl->s-exp b) - (unless (or (bytes? b) - (input-port? b)) - (raise-arguments-error 'fasl->s-exp "(or/c bytes? input-port?)" b)) - (let ([p (if (bytes? b) - (open-input-bytes b) - b)]) - (let ([e (parameterize ([read-accept-compiled #t]) - (read p))]) - (if (compiled-expression? e) - (parameterize ([current-namespace (make-base-namespace)]) - (eval e)) - e)))) +;; ---------------------------------------- + +(define-for-syntax constants (make-hasheq)) + +(define-syntax (define-constants stx) + (syntax-case stx () + [(_ [id n] ...) + (begin + (for ([id (in-list (syntax->list #'(id ...)))] + [n (in-list (syntax->list #'(n ...)))]) + (hash-set! constants (syntax-e id) (syntax-e n))) + #'(begin + (define id n) ...))])) + +(define-syntax (constant-case stx) + (syntax-case stx (else) + [(_ e [(id ...) rhs ...] ... [else else-rhs ...]) + (with-syntax ([((n ...) ...) + (for/list ([ids (in-list (syntax->list #'((id ...) ...)))]) + (for/list ([id (in-list (syntax->list ids))]) + (hash-ref constants (syntax-e id))))]) + #'(case e [(n ...) rhs ...] ... [else else-rhs ...]))])) + +;; ---------------------------------------- + +;; There is no versioning of the fasl format, so don't change the +;; numbers below --- only add to the set + +(define-constants + (fasl-graph-def-type 1) + (fasl-graph-ref-type 2) + + (fasl-false-type 3) + (fasl-true-type 4) + (fasl-null-type 5) + (fasl-void-type 6) + (fasl-eof-type 7) + + (fasl-integer-type 8) + (fasl-flonum-type 9) + (fasl-single-flonum-type 10) + (fasl-rational-type 11) + (fasl-complex-type 12) + (fasl-char-type 13) + + (fasl-symbol-type 14) + (fasl-unreadable-symbol-type 15) + (fasl-uninterned-symbol-type 16) + (fasl-keyword-type 17) + (fasl-string-type 18) + (fasl-immutable-string-type 19) + (fasl-bytes-type 20) + (fasl-immutable-bytes-type 21) + (fasl-path-type 22) + (fasl-relative-path-type 23) + + (fasl-pregexp-type 24) + (fasl-regexp-type 25) + (fasl-byte-pregexp-type 26) + (fasl-byte-regexp-type 27) + + (fasl-list-type 28) + (fasl-list*-type 29) + (fasl-pair-type 30) + (fasl-vector-type 31) + (fasl-immutable-vector-type 32) + (fasl-box-type 33) + (fasl-immutable-box-type 34) + (fasl-prefab-type 35) + (fasl-hash-type 36) + (fasl-immutable-hash-type 37) + + (fasl-srcloc 38) + + ;; Unallocated numbers here are for future extensions + + ;; 100 to 255 is used for small integers: + (fasl-small-integer-start 100)) + +(define fasl-lowest-small-integer -10) +(define fasl-highest-small-integer (- 255 (- fasl-small-integer-start fasl-lowest-small-integer) 1)) +(define fasl-prefix #"racket/fasl:") +(define fasl-prefix-length (bytes-length fasl-prefix)) + +(define-constants + (fasl-hash-eq-variant 0) + (fasl-hash-equal-variant 1) + (fasl-hash-eqv-variant 2)) + +;; ---------------------------------------- + +(define (s-exp->fasl v + [orig-o #f] + #:keep-mutable? [keep-mutable? #f]) + (when orig-o + (unless (output-port? orig-o) + (raise-argument-error 'fasl->s-exp "(or/c output-port? #f)" orig-o))) + (define o (or orig-o (open-output-bytes))) + (define shared (make-hasheq)) + (define shared-counter 0) + ;; Find shared symbols and similar for compactness. We don't try to + ;; save general graph structure, leaving that to `serialize`. + (let loop ([v v]) + (cond + [(or (symbol? v) + (keyword? v) + (string? v) + (bytes? v) + (path? v)) + (hash-update! shared v add1 0)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (loop (unbox v))] + [(prefab-struct-key v) + (loop (struct->vector v))] + [else (void)])) + (define exploded-base-dir 'not-ready) + (define exploded-wrt-rel-dir 'not-ready) + (define (path->relative-path-elements v) + (when (and (eq? exploded-base-dir 'not-ready) + (path? v)) + (define wr-dir (current-write-relative-directory)) + (define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir))) + (define base-dir (and wr-dir (if (pair? wr-dir) (cdr wr-dir) wr-dir))) + (set! exploded-base-dir (and base-dir (explode-path base-dir))) + (set! exploded-wrt-rel-dir + (if (eq? base-dir wrt-dir) + '() + (list-tail (explode-path wrt-dir) + (length exploded-base-dir))))) + (and exploded-base-dir + (path? v) + (let ([exploded (explode-path v)]) + (and (for/and ([base-p (in-list exploded-base-dir)] + [p (in-list exploded)]) + (equal? base-p p)) + ((length exploded) . >= . (length exploded-base-dir)) + (let loop ([exploded-wrt-rel-dir exploded-wrt-rel-dir ] + [rel (list-tail exploded (length exploded-base-dir))]) + (cond + [(null? exploded-wrt-rel-dir) rel] + [(and (pair? rel) + (equal? (car rel) (car exploded-wrt-rel-dir))) + (loop (cdr exploded-wrt-rel-dir) (cdr rel))] + [else (append (for/list ([p (in-list exploded-wrt-rel-dir)]) + 'up) + rel)])))))) + (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v))) + ;; The fasl formal prefix: + (write-bytes fasl-prefix o) + ;; Write content to a string, so we can measure it + (define bstr + (let ([o (open-output-bytes)]) + (let loop ([v v]) + (cond + [(not (eq? (hash-ref shared v 1) 1)) + (define c (hash-ref shared v)) + (cond + [(negative? c) + (write-byte fasl-graph-ref-type o) + (write-fasl-integer (sub1 (- c)) o)] + [else + (define pos shared-counter) + (set! shared-counter (add1 shared-counter)) + (write-byte fasl-graph-def-type o) + (write-fasl-integer pos o) + (hash-remove! shared v) + (loop v) + (hash-set! shared v (- (add1 pos)))])] + [(not v) + (write-byte fasl-false-type o)] + [(eq? v #t) + (write-byte fasl-true-type o)] + [(null? v) + (write-byte fasl-null-type o)] + [(void? v) + (write-byte fasl-void-type o)] + [(eof-object? v) + (write-byte fasl-eof-type o)] + [(exact-integer? v) + (cond + [(<= fasl-lowest-small-integer v fasl-highest-small-integer) + (write-byte (+ fasl-small-integer-start (- v fasl-lowest-small-integer)) o)] + [else + (write-byte fasl-integer-type o) + (write-fasl-integer v o)])] + [(flonum? v) + (write-byte fasl-flonum-type o) + (write-bytes (real->floating-point-bytes v 8 #f) o)] + [(single-flonum? v) + (write-byte fasl-single-flonum-type o) + (write-bytes (real->floating-point-bytes v 4 #f) o)] + [(rational? v) + (write-byte fasl-rational-type o) + (loop (numerator v)) + (loop (denominator v))] + [(complex? v) + (write-byte fasl-complex-type o) + (loop (real-part v)) + (loop (imag-part v))] + [(char? v) + (write-byte fasl-char-type o) + (write-fasl-integer (char->integer v) o)] + [(symbol? v) + (cond + [(symbol-interned? v) + (write-byte fasl-symbol-type o)] + [(symbol-unreadable? v) + (write-byte fasl-unreadable-symbol-type o)] + [else + (write-byte fasl-uninterned-symbol-type o)]) + (define bstr (string->bytes/utf-8 (symbol->string v))) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)] + [(keyword? v) + (write-byte fasl-keyword-type o) + (define bstr (string->bytes/utf-8 (keyword->string v))) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)] + [(string? v) + (write-fasl-integer (if (treat-immutable? v) fasl-immutable-string-type fasl-string-type) o) + (write-fasl-string v o)] + [(bytes? v) + (write-fasl-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o) + (write-fasl-bytes v o)] + [(path-for-some-system? v) + (define rel-elems (path->relative-path-elements v)) + (cond + [rel-elems + (write-byte fasl-relative-path-type o) + (loop (for/list ([p (in-list rel-elems)]) + (if (path? p) (path-element->bytes p) p)))] + [else + (write-byte fasl-path-type o) + (write-fasl-bytes (path->bytes v) o) + (loop (path-convention-type v))])] + [(and (srcloc? v) (let ([src (srcloc-source v)]) + (or (not src) + (path-for-some-system? src) + (string? src) + (bytes? src) + (symbol? src)))) + (define src (srcloc-source v)) + (define new-src + (cond + [(and (path? src) + (not (path->relative-path-elements src))) + ;; Convert to a string + (truncate-path src)] + [else src])) + (write-fasl-integer fasl-srcloc o) + (loop new-src) + (loop (srcloc-line v)) + (loop (srcloc-column v)) + (loop (srcloc-position v)) + (loop (srcloc-span v))] + [(pair? v) + (cond + [(pair? (cdr v)) + (define-values (n normal-list?) + (let loop ([v v] [len 0]) + (cond + [(null? v) (values len #t)] + [(pair? v) (loop (cdr v) (add1 len))] + [else (values len #f)]))) + (write-byte (if normal-list? fasl-list-type fasl-list*-type) o) + (write-fasl-integer n o) + (let ploop ([v v]) + (cond + [(pair? v) + (loop (car v)) + (ploop (cdr v))] + [else + (unless normal-list? + (loop v))]))] + [else + (write-byte fasl-pair-type o) + (loop (car v)) + (loop (cdr v))])] + [(vector? v) + (write-byte (if (treat-immutable? v) fasl-immutable-vector-type fasl-vector-type) o) + (write-fasl-integer (vector-length v) o) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (write-byte (if (treat-immutable? v) fasl-immutable-box-type fasl-box-type) o) + (loop (unbox v))] + [(prefab-struct-key v) + => (lambda (k) + (write-byte fasl-prefab-type o) + (loop k) + (define vec (struct->vector v)) + (write-fasl-integer (sub1 (vector-length vec)) o) + (for ([e (in-vector vec 1)]) + (loop e)))] + [(hash? v) + (write-byte (if (treat-immutable? v) fasl-immutable-hash-type fasl-hash-type) o) + (write-byte (cond + [(hash-eq? v) fasl-hash-eq-variant] + [(hash-eqv? v) fasl-hash-eqv-variant] + [else fasl-hash-equal-variant]) + o) + (write-fasl-integer (hash-count v) o) + (hash-for-each v (lambda (k v) (loop k) (loop v)) #t)] + [(regexp? v) + (write-byte (if (pregexp? v) fasl-pregexp-type fasl-regexp-type)) + (write-fasl-string (object-name v) o)] + [(byte-regexp? v) + (write-byte (if (byte-pregexp? v) fasl-byte-pregexp-type fasl-byte-regexp-type)) + (write-fasl-bytes (object-name v) o)] + [else + (raise-arguments-error 'fasl-write + "cannot write value" + "value" v)])) + (get-output-bytes o #t))) + ;; Record the number of entries in the shared-value table that is + ;; used by `fasl-graph-ref-type` and `fasl-graph-ref-type`: + (write-fasl-integer shared-counter o) + ;; Record the byte-string size of the encoded data: + (write-fasl-integer (bytes-length bstr) o) + ;; Write the encoded data to `o` + (write-bytes bstr o) + (if orig-o + (void) + (get-output-bytes o))) + +;; ---------------------------------------- + +;; For input parsing internally, in place of an input port, use a +;; mutable pair containing a byte string and position + +(define (fasl->s-exp orig-i + #:datum-intern? [intern? #t]) + (define init-i (cond + [(bytes? orig-i) (mcons orig-i 0)] + [(input-port? orig-i) orig-i] + [else (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" orig-i)])) + (unless (bytes=? (read-bytes/exactly fasl-prefix-length init-i) fasl-prefix) + (read-error "unrecognized prefix")) + (define shared-count (read-fasl-integer init-i)) + (define shared (make-vector shared-count)) + (define len (read-fasl-integer init-i)) + + (define i (if (mpair? init-i) + init-i + ;; Faster to work with a byte string: + (let ([bstr (read-bytes/exactly len init-i)]) + (mcons bstr 0)))) + + (define (intern v) (if intern? (datum-intern-literal v) v)) + (let loop () + (define type (read-byte/no-eof i)) + (constant-case + type + [(fasl-graph-def-type) + (define pos (read-fasl-integer i)) + (define v (loop)) + (unless (pos . < . shared-count) + (read-error "bad graph index")) + (vector-set! shared pos v) + v] + [(fasl-graph-ref-type) + (define pos (read-fasl-integer i)) + (unless (pos . < . shared-count) + (read-error "bad graph index")) + (vector-ref shared pos)] + [(fasl-false-type) #f] + [(fasl-true-type) #t] + [(fasl-null-type) null] + [(fasl-void-type) (void)] + [(fasl-eof-type) eof] + [(fasl-integer-type) (intern (read-fasl-integer i))] + [(fasl-flonum-type) (floating-point-bytes->real (read-bytes/exactly 8 i) #f)] + [(fasl-single-flonum-type) (real->single-flonum (floating-point-bytes->real (read-bytes/exactly 4 i) #f))] + [(fasl-rational-type) (intern (/ (loop) (loop)))] + [(fasl-complex-type) (intern (make-rectangular (loop) (loop)))] + [(fasl-char-type) (intern (integer->char (read-fasl-integer i)))] + [(fasl-symbol-type) (string->symbol (read-fasl-string i))] + [(fasl-unreadable-symbol-type) (string->unreadable-symbol (read-fasl-string i))] + [(fasl-uninterned-symbol-type) (string->uninterned-symbol (read-fasl-string i))] + [(fasl-keyword-type) (string->keyword (read-fasl-string i))] + [(fasl-string-type) (read-fasl-string i)] + [(fasl-immutable-string-type) (intern (string->immutable-string (read-fasl-string i)))] + [(fasl-bytes-type) (read-fasl-bytes i)] + [(fasl-immutable-bytes-type) (intern (bytes->immutable-bytes (read-fasl-bytes i)))] + [(fasl-path-type) (bytes->path (read-fasl-bytes i) + (loop))] + [(fasl-relative-path-type) + (define wrt-dir (current-load-relative-directory)) + (define rel-elems (for/list ([p (in-list (loop))]) + (if (bytes? p) (bytes->path-element p) p))) + (cond + [wrt-dir (apply build-path wrt-dir rel-elems)] + [(null? rel-elems) (build-path 'same)] + [else (apply build-path rel-elems)])] + [(fasl-pregexp-type) (intern (pregexp (read-fasl-string i)))] + [(fasl-regexp-type) (intern (regexp (read-fasl-string i)))] + [(fasl-byte-pregexp-type) (intern (byte-pregexp (read-fasl-bytes i)))] + [(fasl-byte-regexp-type) (intern (byte-regexp (read-fasl-bytes i)))] + [(fasl-list-type) + (define len (read-fasl-integer i)) + (for/list ([j (in-range len)]) + (loop))] + [(fasl-pair-type) + (cons (loop) (loop))] + [(fasl-list*-type) + (define len (read-fasl-integer i)) + (let ploop ([len len]) + (if (zero? len) + (loop) + (cons (loop) (ploop (sub1 len)))))] + [(fasl-vector-type fasl-immutable-vector-type) + (define len (read-fasl-integer i)) + (define vec (for/vector #:length len ([j (in-range len)]) + (loop))) + (if (eqv? type fasl-immutable-vector-type) + (vector->immutable-vector vec) + vec)] + [(fasl-box-type) (box (loop))] + [(fasl-immutable-box-type) (box-immutable (loop))] + [(fasl-prefab-type) + (define key (loop)) + (define len (read-fasl-integer i)) + (apply make-prefab-struct + key + (for/list ([j (in-range len)]) + (loop)))] + [(fasl-hash-type) + (define ht (constant-case + (read-byte/no-eof i) + [(fasl-hash-eq-variant) (make-hasheq)] + [(fasl-hash-eqv-variant) (make-hasheqv)] + [else (make-hash)])) + (define len (read-fasl-integer i)) + (for ([j (in-range len)]) + (hash-set! ht (loop) (loop))) + ht] + [(fasl-immutable-hash-type) + (define ht (constant-case + (read-byte/no-eof i) + [(fasl-hash-eq-variant) #hasheq()] + [(fasl-hash-eqv-variant) #hasheqv()] + [else #hash()])) + (define len (read-fasl-integer i)) + (for/fold ([ht ht]) ([j (in-range len)]) + (hash-set ht (loop) (loop)))] + [(fasl-srcloc) + (srcloc (loop) (loop) (loop) (loop) (loop))] + [else + (cond + [(type . >= . fasl-small-integer-start) + (+ (- type fasl-small-integer-start) fasl-lowest-small-integer)] + [else + (read-error "unrecognized fasl tag" "tag" type)])]))) + +;; ---------------------------------------- + +;; Integer encoding: +;; -124 to 127 = direct (as 2's complement) +;; 128 => 2-byte little-endian integer +;; 129 => 4-byte little-endian integer +;; 130 => 8-byte little-endian integer +;; 131 => # of ASCII hex digits followed by digits + +(define (write-fasl-integer i o) + (cond + [(<= -124 i 127) + (if (negative? i) + (write-byte (+ i 256) o) + (write-byte i o))] + [(<= -32768 i 32767) + (write-byte 128 o) + (write-bytes (integer->integer-bytes i 2 #t #f) o)] + [(<= -2147483648 i 2147483647) + (write-byte 129 o) + (write-bytes (integer->integer-bytes i 4 #t #f) o)] + [(<= -9223372036854775808 i 9223372036854775807) + (write-byte 130 o) + (write-bytes (integer->integer-bytes i 8 #t #f) o)] + [else + (write-byte 131 o) + (define s (format "~x" i)) ; always ASCII + (write-fasl-integer (string-length s) o) + (write-string s o)])) + +(define (write-fasl-string v o) + (define bstr (string->bytes/utf-8 v)) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)) + +(define (write-fasl-bytes v o) + (write-fasl-integer (bytes-length v) o) + (write-bytes v o)) + +;; ---------------------------------------- + +(define (read-error s . args) + (apply raise-arguments-error + 'fasl-read + (string-append "error parsing fasl stream;\n" + " " s) + args)) + +(define (read-byte/no-eof i) + (cond + [(mpair? i) + (define pos (mcdr i)) + (unless (pos . < . (bytes-length (mcar i))) + (read-error "truncated stream")) + (set-mcdr! i (add1 pos)) + (bytes-ref (mcar i) pos)] + [else + (define b (read-byte i)) + (when (eof-object? b) + (read-error "truncated stream")) + b])) + +(define (read-bytes/exactly n i) + (cond + [(mpair? i) + (define pos (mcdr i)) + (unless ((+ pos n) . <= . (bytes-length (mcar i))) + (read-error "truncated stream")) + (set-mcdr! i (+ pos n)) + (subbytes (mcar i) pos (+ pos n))] + [else + (define bstr (read-bytes n i)) + (unless (and (bytes? bstr) (= n (bytes-length bstr))) + (read-error "truncated stream")) + bstr])) + +(define (read-fasl-integer i) + (define b (read-byte/no-eof i)) + (cond + [(<= b 127) b] + [(>= b 132) (- b 256)] + [(eqv? b 128) + (integer-bytes->integer (read-bytes/exactly 2 i) #f #f)] + [(eqv? b 129) + (integer-bytes->integer (read-bytes/exactly 4 i) #f #f)] + [(eqv? b 130) + (integer-bytes->integer (read-bytes/exactly 8 i) #f #f)] + [(eqv? b 131) + (define len (read-fasl-integer i)) + (define str (read-string len i)) + (unless (and (string? str) (= len (string-length str))) + (read-error "truncated stream at number")) + (string->number str 16)] + [else + (read-error "internal error on integer mode")])) + +(define (read-fasl-string i) + (define len (read-fasl-integer i)) + (define bstr (read-bytes/exactly len i)) + (bytes->string/utf-8 bstr)) + +(define (read-fasl-bytes i) + (define len (read-fasl-integer i)) + (read-bytes/exactly len i)) diff -Nru racket-6.12+ppa1/collects/racket/file.rkt racket-7.0+ppa1/collects/racket/file.rkt --- racket-6.12+ppa1/collects/racket/file.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/file.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -53,7 +53,7 @@ (let loop ([path path]) (cond [(or (link-exists? path) (file-exists? path)) - (delete-file path)] + (delete-file* path)] [(directory-exists? path) (for-each (lambda (e) (loop (build-path path e))) (directory-list path)) @@ -62,6 +62,24 @@ (when must-exist? (raise-not-a-file-or-directory 'delete-directory/files path))]))) +(define (delete-file* path) + (cond + [(eq? 'windows (system-type)) + ;; Deleting a file doesn't remove the file name from the + ;; parent directory until all references are closed, and + ;; other processes (like the search indexer) might open + ;; files. So, try to move a file to the temp directory, + ;; then delete from there. That way, the enclosing directory + ;; can still be deleted. The move might fail if the + ;; temp directory is on a different volume, though. + (define tmp (make-temporary-file)) + (unless (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (rename-file-or-directory path tmp #t) + #t) + (delete-file path)) + (delete-file tmp)] + [else (delete-file path)])) + (define (raise-not-a-file-or-directory who path) (raise (make-exn:fail:filesystem @@ -172,16 +190,35 @@ base-dir)) (let ([tmpdir (find-system-path 'temp-dir)]) (let loop ([s (current-seconds)] - [ms (inexact->exact (truncate (current-inexact-milliseconds)))]) + [ms (inexact->exact (truncate (current-inexact-milliseconds)))] + [tries 0]) (let ([name (let ([n (format template (format "~a~a" s ms))]) (cond [base-dir (build-path base-dir n)] [(relative-path? n) (build-path tmpdir n)] [else n]))]) - (with-handlers ([exn:fail:filesystem:exists? + (with-handlers ([(lambda (exn) + (or (exn:fail:filesystem:exists? exn) + (and (exn:fail:filesystem:errno? exn) + (let ([errno (exn:fail:filesystem:errno-errno exn)]) + (and (eq? 'windows (cdr errno)) + (eqv? (car errno) 5) ; ERROR_ACCESS_DENIED + ;; On Windows, if the target path refers to a file + ;; that has been deleted but is still open + ;; somehere, then an access-denied error is reported + ;; instead of a file-exists error; there appears + ;; to be no way to detect that it was really a + ;; file-still-exists error. Try again for a while. + ;; There's still a small chance that this will + ;; fail, but it's vanishingly small at 32 tries. + ;; If ERROR_ACCESS_DENIED really is the right + ;; error (e.g., because the target directory is not + ;; writable), we'll take longer to get there. + (tries . < . 32)))))) (lambda (x) ;; try again with a new name (loop (- s (random 10)) - (+ ms (random 10))))]) + (+ ms (random 10)) + (add1 tries)))]) (if copy-from (if (eq? copy-from 'directory) (make-directory name) diff -Nru racket-6.12+ppa1/collects/racket/fixnum.rkt racket-7.0+ppa1/collects/racket/fixnum.rkt --- racket-6.12+ppa1/collects/racket/fixnum.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/fixnum.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,4 +28,5 @@ for/fxvector for*/fxvector fxvector-copy - 0) + 0 + check-fxvector) diff -Nru racket-6.12+ppa1/collects/racket/flonum.rkt racket-7.0+ppa1/collects/racket/flonum.rkt --- racket-6.12+ppa1/collects/racket/flonum.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/flonum.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,7 +28,8 @@ for/flvector for*/flvector flvector-copy - 0.0) + 0.0 + check-flvector) (define (flrandom r) (if (pseudo-random-generator? r) diff -Nru racket-6.12+ppa1/collects/racket/gui/dynamic.rkt racket-7.0+ppa1/collects/racket/gui/dynamic.rkt --- racket-6.12+ppa1/collects/racket/gui/dynamic.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/gui/dynamic.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,18 +1,16 @@ #lang racket/base -(require ffi/unsafe) +(require ffi/unsafe + ffi/unsafe/global) (provide gui-available? gui-dynamic-require) -(define scheme_register_process_global - (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer))) - (define (gui-available?) (and ;; Never available in non-0 phases: (zero? (variable-reference->phase (#%variable-reference))) ;; Must be instantiated: - (scheme_register_process_global "GRacket-support-initialized" #f) + (register-process-global #"GRacket-support-initialized" #f) (with-handlers ([exn:fail? (lambda (exn) #f)]) ;; Fails if `mred/private/dynamic' is not declared ;; (without loading it if not): diff -Nru racket-6.12+ppa1/collects/racket/HISTORY.txt racket-7.0+ppa1/collects/racket/HISTORY.txt --- racket-6.12+ppa1/collects/racket/HISTORY.txt 2018-01-15 14:07:52.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,3 +1,9 @@ +Version 7.0, July 2018 +Replace the macro expander with a new, Racket-implemented expander +Add an initial implementation of Racket on Chez Scheme (in the + source distribution) +Bug repairs and other changes noted in the documentation + Version 6.12, January 2018 Bug repairs and other changes noted in the documentation diff -Nru racket-6.12+ppa1/collects/racket/kernel/init.rkt racket-7.0+ppa1/collects/racket/kernel/init.rkt --- racket-6.12+ppa1/collects/racket/kernel/init.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/kernel/init.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,5 +1,5 @@ -#lang racket/kernel -(#%require "../private/top-int.rkt") +(module init '#%kernel + (#%require "../private/top-int.rkt") -(#%provide (all-from racket/kernel) - #%top-interaction) + (#%provide (all-from '#%kernel) + #%top-interaction)) diff -Nru racket-6.12+ppa1/collects/racket/linklet.rkt racket-7.0+ppa1/collects/racket/linklet.rkt --- racket-6.12+ppa1/collects/racket/linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,88 @@ +#lang racket/base +(require '#%linklet) + +(provide linklet? + + compile-linklet + recompile-linklet + eval-linklet + instantiate-linklet + + linklet-import-variables + linklet-export-variables + + linklet-directory? + hash->linklet-directory + linklet-directory->hash + + linklet-bundle? + hash->linklet-bundle + linklet-bundle->hash + + instance? + make-instance + instance-name + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + variable-reference->instance + + correlated? + datum->correlated + correlated->datum + correlated-e + correlated-property + correlated-property-symbol-keys + + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span) + +;; The `#%kernel` primitive table is more primitive than the +;; `#%kernel` module: +(define kernel (primitive-table '#%kernel)) +(define-syntax-rule (bounce id ...) + (begin (define id (hash-ref kernel 'id)) ...)) +(bounce syntax? + syntax-e + datum->syntax + syntax->datum + syntax-property + syntax-property-symbol-keys + + syntax-source + syntax-line + syntax-column + syntax-position + syntax-span) + +(define (correlated? e) + (syntax? e)) + +(define (datum->correlated d [srcloc #f]) + (datum->syntax #f d srcloc)) + +(define (correlated-e e) + (syntax-e e)) + +(define (correlated->datum e) + (syntax->datum e)) + +(define correlated-property + (case-lambda + [(e k) (syntax-property e k)] + [(e k v) (syntax-property e k v)])) + +(define (correlated-property-symbol-keys e) + (syntax-property-symbol-keys e)) + +(define (correlated-source s) (syntax-source s)) +(define (correlated-line s) (syntax-line s)) +(define (correlated-column s) (syntax-column s)) +(define (correlated-position s) (syntax-position s)) +(define (correlated-span s) (syntax-span s)) diff -Nru racket-6.12+ppa1/collects/racket/list.rkt racket-7.0+ppa1/collects/racket/list.rkt --- racket-6.12+ppa1/collects/racket/list.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -61,7 +61,8 @@ remf remf*) -(require (for-syntax racket/base)) +(require (for-syntax racket/base) + racket/private/list-predicates) (define (first x) (if (and (pair? x) (list? x)) @@ -111,8 +112,6 @@ (cdr l) (raise-argument-error 'rest "(and/c list? (not/c empty?))" l))) -(define (cons? l) (pair? l)) -(define (empty? l) (null? l)) (define empty '()) (define (make-list n x) diff -Nru racket-6.12+ppa1/collects/racket/match/define-forms.rkt racket-7.0+ppa1/collects/racket/match/define-forms.rkt --- racket-6.12+ppa1/collects/racket/match/define-forms.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/define-forms.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -76,6 +76,8 @@ (define-syntax (match-lambda** stx) (syntax-parse stx [(_ (~and clauses [(pats ...) . rhs]) ...) + (when (null? (syntax-e #'(rhs ...))) + (raise-syntax-error #f "expected at least one clause to match-lambda**" stx)) (with-syntax* ([vars (generate-temporaries (car (syntax-e #'((pats ...) ...))))] [body #`(match*/derived vars #,stx clauses ...)]) (syntax/loc stx (lambda vars body)))])) @@ -95,18 +97,25 @@ (match*/derived #,(append* idss) #,stx [(patss ... ...) (let () body1 body ...)])))])) - (define-syntax (match-let*-values stx) + ;; note: match-let*-values/derived is *not* provided + (define-syntax (match-let*-values/derived stx) (syntax-parse stx - [(_ () body1 body ...) + [(_ orig-stx () body1 body ...) (syntax/loc stx (let () body1 body ...))] - [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...) + [(_ orig-stx ([(pats ...) rhs] rest-pats ...) body1 body ...) (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) (quasisyntax/loc stx (let-values ([(ids ...) rhs]) - (match*/derived (ids ...) #,stx + (match*/derived (ids ...) orig-stx [(pats ...) #,(syntax/loc stx - (match-let*-values (rest-pats ...) - body1 body ...))]))))])) + (match-let*-values/derived + orig-stx (rest-pats ...) + body1 body ...))]))))])) + + (define-syntax (match-let*-values stx) + (syntax-parse stx + [(_ (~and cl ([(pats ...) rhs:expr] ...)) body1 body ...) + (quasisyntax/loc stx (match-let*-values/derived #,stx cl body1 body ...))])) ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good @@ -122,50 +131,69 @@ (letrec ([nm (lambda vars loop-body)]) (nm init-exp ...))))] [(_ ([pat init-exp:expr] ...) body1 body ...) - (syntax/loc stx (match-let-values ([(pat) init-exp] ...) body1 body ...))])) + (quasisyntax/loc stx + ;; use of match*/derived instead of match-let-values fixes #1431 + ;; alternatively, we could have created let-values/derived but + ;; that is not really necessary + (match*/derived [init-exp ...] #,stx [(pat ...) (let () body1 body ...)]))])) - (define-syntax-rule (match-let* ([pat exp] ...) body1 body ...) - (match-let*-values ([(pat) exp] ...) body1 body ...)) + (define-syntax (match-let* stx) + (syntax-parse stx + [(_ ([pat rhs:expr] ...) body1 body ...) + (quasisyntax/loc stx + (match-let*-values/derived + #,stx + ([(pat) rhs] ...) + body1 body ...))])) + + ;; note: match-define-values/derived is *not* provided + ;; it may be useful enough to suggest we should provide it... + (define-syntax (match-define-values/derived stx) + (syntax-parse stx + [(_ orig-stx (pats ...) rhs:expr) + (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))] + [(pb-ids ...) (pats->bound-vars parse-id (syntax->list #'(pats ...)))]) + (quasisyntax/loc stx + (define-values (pb-ids ...) + (let-values ([(ids ...) rhs]) + (match*/derived (ids ...) orig-stx + [(pats ...) (values pb-ids ...)])))))])) (define-syntax (match-letrec stx) (syntax-parse stx [(_ ((~and cl [pat exp]) ...) body1 body ...) (quasisyntax/loc stx - (let () - #,@(for/list ([c (in-syntax #'(cl ...))] - [p (in-syntax #'(pat ...))] - [e (in-syntax #'(exp ...))]) - (quasisyntax/loc c (match-define #,p #,e))) - body1 body ...))])) + (let () + #,@(for/list ([c (in-syntax #'(cl ...))] + [p (in-syntax #'(pat ...))] + [e (in-syntax #'(exp ...))]) + (quasisyntax/loc c + (match-define-values/derived #,stx (#,p) #,e))) + body1 body ...))])) (define-syntax (match-letrec-values stx) (syntax-parse stx [(_ ((~and cl [(pat ...) exp]) ...) body1 body ...) (quasisyntax/loc stx - (let () - #,@(for/list ([c (in-syntax #'(cl ...))] - [p (in-syntax #'((pat ...) ...))] - [e (in-syntax #'(exp ...))]) - (quasisyntax/loc c (match-define-values #,p #,e))) - body1 body ...))])) + (let () + #,@(for/list ([c (in-syntax #'(cl ...))] + [ps (in-syntax #'((pat ...) ...))] + [e (in-syntax #'(exp ...))]) + (quasisyntax/loc c + (match-define-values/derived #,stx #,ps #,e))) + body1 body ...))])) (define-syntax (match-define stx) (syntax-parse stx [(_ pat rhs:expr) - (let ([p (parse-id #'pat)]) - (with-syntax ([vars (bound-vars p)]) - (quasisyntax/loc stx - (define-values vars (match*/derived (rhs) #,stx - [(pat) (values . vars)])))))])) + (quasisyntax/loc stx + (match-define-values/derived #,stx (pat) rhs))])) (define-syntax (match-define-values stx) (syntax-parse stx [(_ (pats ...) rhs:expr) - (with-syntax ([(ids ...) (pats->bound-vars parse-id (syntax->list #'(pats ...)))]) - (syntax/loc stx - (define-values (ids ...) - (match/values rhs - [(pats ...) (values ids ...)]))))])) + (quasisyntax/loc stx + (match-define-values/derived #,stx (pats ...) rhs))])) (define-syntax (define/match stx) (syntax-parse stx diff -Nru racket-6.12+ppa1/collects/racket/match/gen-match.rkt racket-7.0+ppa1/collects/racket/match/gen-match.rkt --- racket-6.12+ppa1/collects/racket/match/gen-match.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/gen-match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -24,9 +24,8 @@ (with-disappeared-uses (syntax-parse clauses [([pats . rhs] ...) - (parameterize ([orig-stx stx]) - (unless (syntax->list es) - (raise-syntax-error 'match* "expected a sequence of expressions to match" es))) + (unless (syntax->list es) + (raise-syntax-error 'match* "expected a sequence of expressions to match" es)) (define/with-syntax form-name (syntax-case stx () [(fname . _) @@ -80,6 +79,9 @@ (syntax-property (quasisyntax/loc stx (let ([xs exprs*] ...) - (define (outer-fail) raise-error) - body)) + (let ([outer-fail + #,(syntax-property + #'(λ () raise-error) + 'typechecker:called-in-tail-position #t)]) + body))) 'feature-profile:pattern-matching #t)]))) diff -Nru racket-6.12+ppa1/collects/racket/match/parse-helper.rkt racket-7.0+ppa1/collects/racket/match/parse-helper.rkt --- racket-6.12+ppa1/collects/racket/match/parse-helper.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/parse-helper.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,10 +2,9 @@ (require (for-template racket/base) syntax/boundmap + syntax/apply-transformer racket/struct-info - ;macro-debugger/emit - "patterns.rkt" - "syntax-local-match-introduce.rkt") + "patterns.rkt") (provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform trans-match trans-match* parse-struct @@ -170,20 +169,16 @@ error-msg) (let* ([expander* (syntax-local-value expander)] [transformer (accessor expander*)] - ;; this transformer might have been defined w/ `syntax-id-rules' - [transformer (if (set!-transformer? transformer) - (set!-transformer-procedure transformer) - transformer)]) + [transformer-proc (if (set!-transformer? transformer) + (set!-transformer-procedure transformer) + transformer)]) (unless transformer (raise-syntax-error #f error-msg expander*)) - (define introducer (make-syntax-introducer)) - (parameterize ([current-match-introducer introducer]) - (let* ([mstx (introducer (syntax-local-introduce stx))] - [mresult (if (procedure-arity-includes? transformer 2) - (transformer expander* mstx) - (transformer mstx))] - [result (syntax-local-introduce (introducer mresult))]) - ;(emit-local-step stx result #:id expander) - (parse result))))) + (parse (local-apply-transformer + (λ (stx) (if (procedure-arity-includes? transformer-proc 2) + (transformer-proc expander* stx) + (transformer-proc stx))) + stx + 'expression)))) ;; raise an error, blaming stx (define (match:syntax-err stx msg) diff -Nru racket-6.12+ppa1/collects/racket/match/parse.rkt racket-7.0+ppa1/collects/racket/match/parse.rkt --- racket-6.12+ppa1/collects/racket/match/parse.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/parse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -117,15 +117,21 @@ (ddk? #'dd) (let* ([count (ddk? #'dd)] [min (if (number? count) count #f)] - [ps (syntax->list #'(p ...))]) - (GSeq (cons (list (rearm+parse #'lp)) - (for/list ([p ps]) (list (parse p)))) - (cons min (map (lambda _ 1) ps)) - (cons #f (map (lambda _ 1) ps)) - ;; vars in lp are lists, vars elsewhere are not - (cons #f (map (lambda _ #t) ps)) - (Null (Dummy (syntax/loc stx _))) - #f))] + [ps (syntax->list #'(p ...))] + ;; parsed versions of ps and lp + [parsed-ps (map parse ps)] + [parsed-lp (rearm+parse #'lp)]) + ;; duplicates within *one* of the ps is fine, but duplicates + ;; *accross multiple* of the ps is an error, at least for now + (check-list-no-order-duplicates (cons parsed-lp parsed-ps)) + (GSeq (cons (list parsed-lp) + (for/list ([p parsed-ps]) (list p))) + (cons min (map (lambda _ 1) ps)) + (cons #f (map (lambda _ 1) ps)) + ;; vars in lp are lists, vars elsewhere are not + (cons #f (map (lambda _ #t) ps)) + (Null (Dummy (syntax/loc stx _))) + #f))] [(list-no-order p ...) (ormap ddk? (syntax->list #'(p ...))) (raise-syntax-error @@ -133,14 +139,19 @@ stx (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] [(list-no-order p ...) - (let ([ps (syntax->list #'(p ...))]) - (GSeq (for/list ([p ps]) (list (rearm+parse p))) - (map (lambda _ 1) ps) - (map (lambda _ 1) ps) - ;; all of these patterns get bound to only one thing - (map (lambda _ #t) ps) - (Null (Dummy (syntax/loc stx _))) - #f))] + (let* ([ps (syntax->list #'(p ...))] + ;; parsed versions of ps + [parsed-ps (map rearm+parse ps)]) + ;; duplicates within *one* of the ps is fine, but duplicates + ;; *accross multiple* of the ps is an error, at least for now + (check-list-no-order-duplicates parsed-ps) + (GSeq (for/list ([p parsed-ps]) (list p)) + (map (lambda _ 1) ps) + (map (lambda _ 1) ps) + ;; all of these patterns get bound to only one thing + (map (lambda _ #t) ps) + (Null (Dummy (syntax/loc stx _))) + #f))] [(list) (Null (Dummy (syntax/loc stx _)))] [(mlist) (Null (Dummy (syntax/loc stx _)))] [(list ..) @@ -196,4 +207,21 @@ (or (parse-literal (syntax-e #'v)) (raise-syntax-error 'match "syntax error in pattern" disarmed-stx))])) +;; -------------------------------------------------------------- + +;; check-list-no-order-duplicates : [Listof Pat] -> Void +(define (check-list-no-order-duplicates pats) + ;; Duplicate identifiers within *one* pat is fine, but + ;; duplicate identifiers across multiple pats is an error. + ;; Using the `bound-vars` function on each pat separately + ;; should merge duplicate identifiers within each *one*. + ;; So, duplicate identifiers in the appended list must be + ;; duplicates across multiple. + (define vars (apply append (map bound-vars pats))) + (define dup (check-duplicate-identifier vars)) + (when dup + (raise-syntax-error 'list-no-order "unexpected duplicate identifier" dup))) + +;; -------------------------------------------------------------- + ;; (trace parse) diff -Nru racket-6.12+ppa1/collects/racket/match/patterns.rkt racket-7.0+ppa1/collects/racket/match/patterns.rkt --- racket-6.12+ppa1/collects/racket/match/patterns.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/patterns.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,8 +12,6 @@ get-key (struct-out Row))) -(define orig-stx (make-parameter #f)) - (define-struct Pat () #:transparent) ;; v is an identifier (define-struct (Var Pat) (v) diff -Nru racket-6.12+ppa1/collects/racket/match/syntax-local-match-introduce.rkt racket-7.0+ppa1/collects/racket/match/syntax-local-match-introduce.rkt --- racket-6.12+ppa1/collects/racket/match/syntax-local-match-introduce.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/match/syntax-local-match-introduce.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,15 +1,8 @@ #lang racket/base -(provide syntax-local-match-introduce - current-match-introducer) - -(define current-match-introducer - (make-parameter - (lambda (x) - (error 'syntax-local-match-introduce "not expanding match expander form")))) +(provide syntax-local-match-introduce) (define (syntax-local-match-introduce x) (unless (syntax? x) (raise-argument-error 'syntax-local-match-introduce "syntax?" x)) - ((current-match-introducer) x)) - + (syntax-local-introduce x)) diff -Nru racket-6.12+ppa1/collects/racket/path.rkt racket-7.0+ppa1/collects/racket/path.rkt --- racket-6.12+ppa1/collects/racket/path.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -124,6 +124,7 @@ ;; Arguments must be in simple form (define (find-relative-path directory filename + #:more-than-same? [more-than-same? #t] #:more-than-root? [more-than-root? #f] #:normalize-case? [normalize-case? #t]) (let ([dir (do-explode-path 'find-relative-path directory)] @@ -142,7 +143,11 @@ (equal? (normalize (cadr dir)) (normalize (cadr file))))) (let loop ([dir (cdr dir)] [file (cdr file)]) - (cond [(null? dir) (if (null? file) filename (apply build-path file))] + (cond [(null? dir) (if (null? file) + (if more-than-same? + filename + (build-path 'same)) + (apply build-path file))] [(null? file) (apply build-path/convention-type (if (string? filename) (system-path-convention-type) diff -Nru racket-6.12+ppa1/collects/racket/place/private/th-place.rkt racket-7.0+ppa1/collects/racket/place/private/th-place.rkt --- racket-6.12+ppa1/collects/racket/place/private/th-place.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/place/private/th-place.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -58,7 +58,7 @@ (lambda () (with-continuation-mark parameterization-key - orig-paramz + (get-original-parameterization) (parameterize ([current-namespace (make-base-namespace)] [current-custodian cust] [exit-handler (lambda (v) diff -Nru racket-6.12+ppa1/collects/racket/port.rkt racket-7.0+ppa1/collects/racket/port.rkt --- racket-6.12+ppa1/collects/racket/port.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -928,10 +928,14 @@ (evt 'write-spec-evt (list v))))) (values in out)))) +(define unspecified (gensym)) + (define input-port-append - (lambda (close-orig? . ports) + (lambda (close-orig? #:name [name unspecified] . ports) (make-input-port - (map object-name ports) + (if (eq? name unspecified) + (map object-name ports) + name) (lambda (str) ;; Reading is easy -- read from the first port, ;; and get rid of it if the result is eof diff -Nru racket-6.12+ppa1/collects/racket/pretty.rkt racket-7.0+ppa1/collects/racket/pretty.rkt --- racket-6.12+ppa1/collects/racket/pretty.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/pretty.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -734,10 +734,12 @@ [else (list (make-unquoted 'cons) (car obj) (cdr obj))])) (define (convert-hash obj expr?) - (let ([l (hash-map obj (lambda (k v) - (if expr? - (list k v) - (cons k (make-hide v)))))]) + (let ([l (hash-map obj + (lambda (k v) + (if expr? + (list k v) + (cons k (make-hide v)))) + #t)]) (if expr? (cons (make-unquoted (if (hash-eq? obj) diff -Nru racket-6.12+ppa1/collects/racket/private/class-c-old.rkt racket-7.0+ppa1/collects/racket/private/class-c-old.rkt --- racket-6.12+ppa1/collects/racket/private/class-c-old.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/class-c-old.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -177,27 +177,50 @@ [c (in-list (class/c-method-contracts ctc))]) (and c ((contract-late-neg-projection c) (blame-add-method-context blame name))))) - (define external-field-projections (for/list ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (define pos-blame (blame-add-field-context blame f #:swap? #f)) (define neg-blame (blame-add-field-context blame f #:swap? #t)) - (and c - (let ([p-pos ((contract-late-neg-projection c) - pos-blame)] - [p-neg ((contract-late-neg-projection c) - neg-blame)]) - (cons (lambda (x pos-party) - (define blame+pos-party (cons pos-blame pos-party)) - (with-contract-continuation-mark - blame+pos-party + (cond + [c + (define-values (filled? maybe-p-pos maybe-p-neg) + (contract-pos/neg-doubling ((contract-late-neg-projection c) pos-blame) + ((contract-late-neg-projection c) neg-blame))) + (cond + [filled? + (cons (lambda (x pos-party) + (define blame+pos-party (cons pos-blame pos-party)) + (with-contract-continuation-mark + blame+pos-party + (maybe-p-pos x pos-party))) + (lambda (x neg-party) + (define blame+neg-party (cons neg-blame neg-party)) + (with-contract-continuation-mark + blame+neg-party + (maybe-p-neg x neg-party))))] + [else + (define tc-pos (make-thread-cell #f)) + (define tc-neg (make-thread-cell #f)) + (cons (lambda (x pos-party) + (define blame+pos-party (cons pos-blame pos-party)) + (with-contract-continuation-mark + blame+pos-party + (define p-pos (or (thread-cell-ref tc-pos) + (let ([p-pos (maybe-p-pos)]) + (thread-cell-set! tc-pos p-pos) + p-pos))) (p-pos x pos-party))) - (lambda (x neg-party) - (define blame+neg-party (cons neg-blame neg-party)) - (with-contract-continuation-mark - blame+neg-party - (p-neg x neg-party)))))))) + (lambda (x neg-party) + (define blame+neg-party (cons neg-blame neg-party)) + (with-contract-continuation-mark + blame+neg-party + (define p-neg (or (thread-cell-ref tc-neg) + (let ([p-neg (maybe-p-neg)]) + (thread-cell-set! tc-neg p-neg) + p-neg))) + (p-neg x neg-party))))])] + [else #f]))) ;; zip the inits and contracts together for ordered selection (define inits+contracts @@ -439,20 +462,52 @@ (define internal-field-projections (for/list ([f (in-list (internal-class/c-inherit-fields internal-ctc))] [c (in-list (internal-class/c-inherit-field-contracts internal-ctc))]) - (and c - (let* ([blame-acceptor (contract-late-neg-projection c)] - [p-pos (blame-acceptor blame)] - [p-neg (blame-acceptor bswap)]) - (cons (lambda (x pos-party) - (define blame+pos-party (cons blame pos-party)) - (with-contract-continuation-mark - blame+pos-party + (cond + [c + (define blame-acceptor (contract-late-neg-projection c)) + (define-values (filled? maybe-p-pos maybe-p-neg) + (contract-pos/neg-doubling (blame-acceptor blame) + (blame-acceptor bswap))) + (cond + [filled? + (cons (lambda (x pos-party) + (define blame+pos-party (cons blame pos-party)) + (with-contract-continuation-mark + blame+pos-party + (maybe-p-pos x pos-party))) + (lambda (x neg-party) + (define blame+neg-party (cons blame neg-party)) + (with-contract-continuation-mark + blame+neg-party + (maybe-p-neg x neg-party))))] + [else + (define tc-pos (make-thread-cell #f)) + (define tc-neg (make-thread-cell #f)) + (cons (lambda (x pos-party) + (define blame+pos-party (cons blame pos-party)) + (with-contract-continuation-mark + blame+pos-party + (define p-pos + (cond + [(thread-cell-ref tc-pos) => values] + [else + (define p-pos (maybe-p-pos)) + (thread-cell-set! tc-pos p-pos) + p-pos])) (p-pos x pos-party))) - (lambda (x neg-party) - (define blame+neg-party (cons blame neg-party)) - (with-contract-continuation-mark - blame+neg-party - (p-neg x neg-party)))))))) + (lambda (x neg-party) + (define blame+neg-party (cons blame neg-party)) + (with-contract-continuation-mark + blame+neg-party + (define p-neg + (cond + [(thread-cell-ref tc-neg) => values] + [else + (define p-neg (maybe-p-neg)) + (thread-cell-set! tc-neg p-neg) + p-neg])) + (p-neg x neg-party))))])] + [else #f]))) (define override-projections (for/list ([m (in-list (internal-class/c-overrides internal-ctc))] @@ -885,9 +940,7 @@ (check-one-stronger class/c-inits class/c-init-contracts this that) ;; check both ways for fields (since mutable) - (check-one-stronger class/c-fields class/c-field-contracts this that) - (check-one-stronger class/c-fields class/c-field-contracts that this) - + (check-one-equivalent class/c-fields class/c-field-contracts this that) ;; inherits (check-one-stronger internal-class/c-inherits internal-class/c-inherit-contracts @@ -918,6 +971,36 @@ (all-included? (class/c-absents that) (class/c-absents this)))] [else #f])) +(define (class/c-equivalent this that) + (define this-internal (class/c-internal this)) + (cond + [(class/c? that) + (define that-internal (class/c-internal that)) + (and + (check-one-equivalent class/c-methods class/c-method-contracts this that) + (check-one-equivalent class/c-inits class/c-init-contracts this that) + (check-one-equivalent class/c-fields class/c-field-contracts this that) + (check-one-equivalent internal-class/c-inherits internal-class/c-inherit-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-inherit-fields internal-class/c-inherit-field-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-inherit-fields internal-class/c-inherit-field-contracts + that-internal this-internal) + (check-one-equivalent internal-class/c-supers internal-class/c-super-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-inners internal-class/c-inner-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-overrides internal-class/c-override-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-augments internal-class/c-augment-contracts + this-internal that-internal) + (check-one-equivalent internal-class/c-augrides internal-class/c-augride-contracts + this-internal that-internal) + (equal? (class/c-opaque? this) (class/c-opaque? that)) + (equal? (class/c-absent-fields that) (class/c-absent-fields this)) + (equal? (class/c-absents that) (class/c-absents this)))] + [else #f])) + (define (all-included? this-items that-items) (for/and ([this-item (in-list this-items)]) (for/or ([that-item (in-list that-items)]) @@ -983,6 +1066,14 @@ (and (equal? this-name that-name) (contract-stronger? this-ctc that-ctc))))) +(define (check-one-equivalent names-sel ctcs-sel this that) + (for/and ([this-name (in-list (names-sel this))] + [this-ctc (in-list (ctcs-sel this))]) + (for/or ([that-name (in-list (names-sel that))] + [that-ctc (in-list (ctcs-sel that))]) + (and (equal? this-name that-name) + (contract-equivalent? this-ctc that-ctc))))) + (define-struct class/c (methods method-contracts fields field-contracts inits init-contracts absents absent-fields @@ -994,6 +1085,7 @@ #:late-neg-projection class/c-late-neg-proj #:name build-class/c-name #:stronger class/c-stronger + #:equivalent class/c-equivalent #:first-order (λ (ctc) (λ (cls) @@ -1412,6 +1504,11 @@ (contract-stronger? (base-instanceof/c-class-ctc this) (base-instanceof/c-class-ctc that)))) +(define (instanceof/c-equivalent this that) + (and (base-instanceof/c? that) + (contract-equivalent? (base-instanceof/c-class-ctc this) + (base-instanceof/c-class-ctc that)))) + (define-struct base-instanceof/c (class-ctc) #:property prop:custom-write custom-write-property-proc #:property prop:contract @@ -1421,9 +1518,10 @@ (λ (ctc) (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc))) #:first-order instanceof/c-first-order + #:equivalent instanceof/c-equivalent #:stronger instanceof/c-stronger)) -(define (instanceof/c cctc) +(define/subexpression-pos-prop (instanceof/c cctc) (let ([ctc (coerce-contract 'instanceof/c cctc)]) (make-base-instanceof/c ctc))) @@ -1458,10 +1556,9 @@ (define fields (base-object/c-fields ctc)) (define field-contracts (base-object/c-field-contracts ctc)) (λ (blame) + (define p-app (make-wrapper-class blame methods method-contracts fields field-contracts)) (λ (val neg-party) - (make-wrapper-class - val blame neg-party - methods method-contracts fields field-contracts)))) + (p-app val neg-party)))) (define (check-object-contract obj methods fields fail) (unless (object? obj) @@ -1495,14 +1592,24 @@ (object/c-width-subtype? this that))] [else #f])) +(define (object/c-equivalent this that) + (cond + [(base-object/c? that) + (and + (equal? (base-object/c-methods that) + (base-object/c-methods this)) + (equal? (base-object/c-fields that) + (base-object/c-fields this)) + (check-one-object/equivalent base-object/c-methods base-object/c-method-contracts this that) + (check-one-object/equivalent base-object/c-fields base-object/c-field-contracts this that))] + [else #f])) + (define (object/c-common-methods-stronger? this that) (check-one-object base-object/c-methods base-object/c-method-contracts this that)) (define (object/c-common-fields-stronger? this that) ;; check both ways for fields (since mutable) - (and - (check-one-object base-object/c-fields base-object/c-field-contracts this that) - (check-one-object base-object/c-fields base-object/c-field-contracts that this))) + (check-one-object/equivalent base-object/c-fields base-object/c-field-contracts this that)) ;; True if `this` has at least as many field / method names as `that` (define (object/c-width-subtype? this that) @@ -1515,13 +1622,23 @@ ;; See `check-one-stronger`. The difference is that this one only checks the ;; names that are in both this and that. (define (check-one-object names-sel ctcs-sel this that) + (check-one-object/common-names names-sel ctcs-sel this that contract-stronger?)) + +;; Similar to `check-one-object`, but compare common fields/methods with +;; `contract-equivalent?` +(define (check-one-object/equivalent names-sel ctcs-sel this that) + (check-one-object/common-names names-sel ctcs-sel this that contract-equivalent?)) + +;; Extract names (using `names-sel`) and contracts (`ctcs-sel`) from objects `this` and `that`. +;; For all contracts with the same name, compare the contracts using `compare-ctcs`. +(define (check-one-object/common-names names-sel ctcs-sel this that compare-ctcs) (for/and ([this-name (in-list (names-sel this))] [this-ctc (in-list (ctcs-sel this))]) (or (not (member this-name (names-sel that))) (for/or ([that-name (in-list (names-sel that))] [that-ctc (in-list (ctcs-sel that))]) (and (equal? this-name that-name) - (contract-stronger? + (compare-ctcs (if (just-check-existence? this-ctc) any/c this-ctc) @@ -1542,6 +1659,7 @@ (base-object/c-fields ctc) (base-object/c-field-contracts ctc))) #:first-order object/c-first-order + #:equivalent object/c-equivalent #:stronger object/c-stronger)) (define (build-object/c-type-name name method-names method-ctcs field-names field-ctcs) @@ -1579,18 +1697,50 @@ ;; make-wrapper-object: contract object blame neg-party ;; (listof symbol) (listof contract?) (listof symbol) (listof contract?) ;; -> wrapped object -(define (make-wrapper-object ctc obj blame neg-party methods method-contracts fields field-contracts) - (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) - (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] - [new-cls (make-wrapper-class (object-ref obj) ;; TODO: object-ref audit - blame neg-party - methods method-contracts fields field-contracts)]) - (impersonate-struct obj object-ref (λ (o c) new-cls) ;; TODO: object-ref audit - impersonator-prop:contracted ctc - impersonator-prop:original-object original-obj))) +(define (make-wrapper-object blame methods method-contracts fields field-contracts) + (define p-app + (make-wrapper-class blame methods method-contracts fields field-contracts)) + (λ (ctc obj neg-party) + (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) + (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] + [new-cls (p-app (object-ref obj) ;; TODO: object-ref audit + neg-party)]) + (impersonate-struct obj object-ref (λ (o c) new-cls) ;; TODO: object-ref audit + impersonator-prop:contracted ctc + impersonator-prop:original-object original-obj)))) + + +(define (make-wrapper-class blame methods method-contracts fields field-contracts) + (define method-projs + (for/list ([c (in-list method-contracts)] + [m (in-list methods)]) + (cond + [(and c (not (just-check-existence? c))) + (define blame* (blame-add-context blame (format "the ~a method in" m) + #:important m)) + ((contract-late-neg-projection c) blame*)] + [else #f]))) + + (define-values (filled? maybe-pos-field-projs maybe-neg-field-projs) + (contract-pos/neg-doubling + (for/list ([f (in-list fields)] + [c (in-list field-contracts)]) + (cond + [(just-check-existence? c) #f] + [else + (define prj (contract-late-neg-projection c)) + (prj (blame-add-field-context blame f #:swap? #f))])) + (for/list ([f (in-list fields)] + [c (in-list field-contracts)]) + (cond + [(just-check-existence? c) #f] + [else + (define prj (contract-late-neg-projection c)) + (prj (blame-add-field-context blame f #:swap? #t))])))) + (define tc (and (not filled?) (make-thread-cell #f))) -(define (make-wrapper-class cls blame neg-party methods method-contracts fields field-contracts) + (λ (cls neg-party) (let* ([name (class-name cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] @@ -1683,33 +1833,59 @@ (vector-copy! meths 0 (class-methods cls)) ;; Now apply projections (for ([m (in-list methods)] - [c (in-list method-contracts)]) + [c (in-list method-contracts)] + [method-proj (in-list method-projs)]) (when c - (unless (just-check-existence? c) + (when method-proj (define i (hash-ref method-ht m)) - (define p ((contract-late-neg-projection c) - (blame-add-context blame (format "the ~a method in" m) - #:important m))) - (vector-set! meths i (make-method (p (vector-ref meths i) neg-party) m)))))) - + (vector-set! meths i (make-method (method-proj (vector-ref meths i) neg-party) m)))))) + ;; Handle external field contracts (unless (null? fields) - (for ([f (in-list fields)] - [c (in-list field-contracts)]) - (unless (just-check-existence? c) - (define fi (hash-ref field-ht f)) - (define prj (contract-late-neg-projection c)) - (define p-pos (prj (blame-add-field-context blame f #:swap? #f))) - (define p-neg (prj (blame-add-field-context blame f #:swap? #t))) - (hash-set! field-ht f (field-info-extend-external fi - (lambda args - (with-contract-continuation-mark - (cons blame neg-party) - (apply p-pos args))) - (lambda args - (with-contract-continuation-mark - (cons blame neg-party) - (apply p-neg args))) - neg-party))))) + (define (install-new-fields pos-field-projs neg-field-projs) + (for ([f (in-list fields)] + [c (in-list field-contracts)] + [p-pos (in-list pos-field-projs)] + [p-neg (in-list neg-field-projs)]) + (unless (just-check-existence? c) + (define fi (hash-ref field-ht f)) + (hash-set! field-ht f (field-info-extend-external + fi + (lambda args + (with-contract-continuation-mark + (cons blame neg-party) + (apply p-pos args))) + (lambda args + (with-contract-continuation-mark + (cons blame neg-party) + (apply p-neg args))) + neg-party))))) + (cond + [filled? (install-new-fields maybe-pos-field-projs maybe-neg-field-projs)] + [(thread-cell-ref tc) + => + (λ (pr) (install-new-fields (car pr) (cdr pr)))] + [else + (define pos-field-projs (maybe-pos-field-projs)) + (define neg-field-projs (maybe-neg-field-projs)) + (thread-cell-set! tc (cons pos-field-projs neg-field-projs)) + (install-new-fields pos-field-projs neg-field-projs)])) - (copy-seals cls c))) + (copy-seals cls c)))) + +;; evaluates `e`, unless we are 5 deep nested in evaluating +;; thing wrapped in limit-depth; in that case, just return #f +;; without evaluating `e` +(define-syntax-rule + (limit-depth e) + (limit-depth/proc (λ () e))) +(define (limit-depth/proc thunk) + (define current-depth + (or (continuation-mark-set-first (current-continuation-marks) depth-cm-key) + 0)) + (cond + [(< current-depth 5) + (with-continuation-mark depth-cm-key (+ current-depth 1) + (thunk))] + [else #f])) +(define depth-cm-key (gensym 'racket/contract-fields-stronger?-depth-limit)) diff -Nru racket-6.12+ppa1/collects/racket/private/classidmap.rkt racket-7.0+ppa1/collects/racket/private/classidmap.rkt --- racket-6.12+ppa1/collects/racket/private/classidmap.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/classidmap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,8 @@ (require syntax/stx (for-syntax racket/base) - (for-template racket/base + (for-template racket/stxparam + racket/base racket/unsafe/undefined "class-wrapped.rkt" "class-undef.rkt")) @@ -29,7 +30,7 @@ (list* 'apply id this (reverse (cons args accum)))]))) (define (find the-finder name src) - (let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))]) + (let ([this-id (syntax-parameter-value the-finder)]) (datum->syntax this-id name src))) ;; Check Syntax binding info: diff -Nru racket-6.12+ppa1/collects/racket/private/class-internal.rkt racket-7.0+ppa1/collects/racket/private/class-internal.rkt --- racket-6.12+ppa1/collects/racket/private/class-internal.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/class-internal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -529,7 +529,7 @@ ;; optional argument; need to wrap arg expression (cons (with-syntax ([expr (syntax/loc #'expr - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) (#%expression expr)))]) (syntax/loc (car vars) (id expr))) @@ -539,7 +539,7 @@ #'vars)]) (let ([l (syntax/loc stx (lambda (the-obj . vars) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) body1 body ...)))]) (syntax-track-origin (with-syntax ([l (rearm (add-method-property l) stx)]) @@ -563,7 +563,7 @@ [name (mk-name name)]) (let ([cl (syntax/loc stx (case-lambda [(the-obj . vars) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) body1 body ...)] ...))]) (syntax-track-origin (with-syntax ([cl (rearm (add-method-property cl) stx)]) @@ -1571,6 +1571,7 @@ rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup + (define-syntax-parameter the-finder #f) (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)] ... @@ -1659,7 +1660,7 @@ #, ;; Attach srcloc (useful for profiling) (quasisyntax/loc stx (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) (syntax-parameterize ([super-instantiate-param (lambda (stx) diff -Nru racket-6.12+ppa1/collects/racket/private/collect.rkt racket-7.0+ppa1/collects/racket/private/collect.rkt --- racket-6.12+ppa1/collects/racket/private/collect.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/collect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,33 @@ -(module collect '#%kernel - (#%require '#%utils) - (#%provide find-col-file - collection-path - collection-file-path - find-library-collection-paths - find-library-collection-links)) +(module pre-base '#%kernel + (#%require "qq-and-or.rkt" + "path.rkt" + "kw.rkt") + + (#%provide new:collection-path + new:collection-file-path) + + (define-values (new:collection-path) + (let ([collection-path (new-lambda (collection + #:fail [fail (lambda (s) + (raise + (exn:fail:filesystem + (string-append "collection-path: " s) + (current-continuation-marks))))] + . collections) + (collection-path fail collection collections))]) + collection-path)) + + (define-values (new:collection-file-path) + (let ([collection-file-path (new-lambda (file-name + collection + #:check-compiled? [check-compiled? + (and (path-string? file-name) + (regexp-match? #rx".[.]rkt$" file-name))] + #:fail [fail (lambda (s) + (raise + (exn:fail:filesystem + (string-append "collection-file-path: " s) + (current-continuation-marks))))] + . collections) + (collection-file-path fail check-compiled? file-name collection collections))]) + collection-file-path))) diff -Nru racket-6.12+ppa1/collects/racket/private/cond.rkt racket-7.0+ppa1/collects/racket/private/cond.rkt --- racket-6.12+ppa1/collects/racket/private/cond.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/cond.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ ;; cond (module cond '#%kernel - (#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel)) + (#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel "gen-temp.rkt")) (define-syntaxes (=>) (lambda (stx) diff -Nru racket-6.12+ppa1/collects/racket/private/define-et-al.rkt racket-7.0+ppa1/collects/racket/private/define-et-al.rkt --- racket-6.12+ppa1/collects/racket/private/define-et-al.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/define-et-al.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -184,14 +184,7 @@ `(begin (define-values ,defined-names - ,(let ([core (make-core name (and inspector 'inspector) super-id/struct: field-names)]) - (if inspector - `(let-values ([(inspector) ,inspector]) - (if (if inspector (not (inspector? inspector)) #f) - (raise-argument-error 'define-struct "(or/c inspector? #f)" inspector) - (void)) - ,core) - core))) + ,(make-core name inspector super-id/struct: field-names)) (define-syntaxes (,name) ,stx-info)) stx)]) (if super-id diff -Nru racket-6.12+ppa1/collects/racket/private/define-struct.rkt racket-7.0+ppa1/collects/racket/private/define-struct.rkt --- racket-6.12+ppa1/collects/racket/private/define-struct.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/define-struct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -518,7 +518,13 @@ [prune (lambda (stx) (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))] [reflect-name-expr (if reflect-name-expr - (quasisyntax (check-reflection-name 'fm #,reflect-name-expr)) + (syntax-case reflect-name-expr (quote) + [(quote id) + (identifier? #'id) + ;; No need to generate run-time test for a symbol: + reflect-name-expr] + [else + (quasisyntax (check-reflection-name 'fm #,reflect-name-expr))]) (quasisyntax '#,id))]) (define struct-name-size (string-length (symbol->string (syntax-e id)))) diff -Nru racket-6.12+ppa1/collects/racket/private/ellipses.rkt racket-7.0+ppa1/collects/racket/private/ellipses.rkt --- racket-6.12+ppa1/collects/racket/private/ellipses.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/ellipses.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,12 +1,17 @@ (module ellipses '#%kernel (#%require (for-syntax '#%kernel)) - (#%provide ... _) + (#%provide ... _ ~? ~@) (define-syntaxes (...) (lambda (stx) (raise-syntax-error #f "ellipses not allowed as an expression" stx))) + (define-syntaxes (~?) + (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))) + (define-syntaxes (~@) + (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))) + (define-syntaxes (_) (lambda (stx) (raise-syntax-error #f "wildcard not allowed as an expression" stx)))) diff -Nru racket-6.12+ppa1/collects/racket/private/for.rkt racket-7.0+ppa1/collects/racket/private/for.rkt --- racket-6.12+ppa1/collects/racket/private/for.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/for.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ "member.rkt" "reverse.rkt" "sort.rkt" + "performance-hint.rkt" '#%unsafe '#%flfxnum (for-syntax '#%kernel @@ -387,6 +388,9 @@ (raise-syntax-error #f "illegal outside of a loop or comprehension binding" stx)) + (define-syntax-rule (unless-unsafe e) + (unless (variable-reference-from-unsafe? (#%variable-reference)) e)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; streams & sequences @@ -582,14 +586,17 @@ #f #f)))))) + (define (check-range a b step) + (unless (real? a) (raise-argument-error 'in-range "real?" a)) + (unless (real? b) (raise-argument-error 'in-range "real?" b)) + (unless (real? step) (raise-argument-error 'in-range "real?" step))) + (define in-range (case-lambda [(b) (in-range 0 b 1)] [(a b) (in-range a b 1)] [(a b step) - (unless (real? a) (raise-argument-error 'in-range "real?" a)) - (unless (real? b) (raise-argument-error 'in-range "real?" b)) - (unless (real? step) (raise-argument-error 'in-range "real?" step)) + (check-range a b step) (let* ([cont? (if (step . >= . 0) (lambda (x) (< x b)) (lambda (x) (> x b)))] @@ -599,16 +606,20 @@ (define (:integer-gen v) (values values #f add1 0 (lambda (i) (i . < . v)) #f #f)) + (begin-encourage-inline + (define (check-naturals n) + (unless (and (integer? n) + (exact? n) + (n . >= . 0)) + (raise-argument-error 'in-naturals + "exact-nonnegative-integer?" + n)))) + (define in-naturals (case-lambda [() (in-naturals 0)] [(n) - (unless (and (integer? n) - (exact? n) - (n . >= . 0)) - (raise-argument-error 'in-naturals - "exact-nonnegative-integer?" - n)) + (check-naturals n) (make-range n add1 #f)])) (define-values (struct:list-stream @@ -633,8 +644,10 @@ #f #f)))))) + (define (check-list l) + (unless (list? l) (raise-argument-error 'in-list "list?" l))) (define (in-list l) - (unless (list? l) (raise-argument-error 'in-list "list?" l)) + (check-list l) (make-list-stream l)) (define (:list-gen l) @@ -776,11 +789,15 @@ ([-first (format-id #'PREFIX "~a-first" #'PREFIX)] [-next (format-id #'PREFIX "~a-next" #'PREFIX)] [-VAL (format-id #'PREFIX "~a-~a" #'PREFIX #'VAL)] + [CHECK-SEQ (format-id #'def "check-~a" #'IN-HASH-SEQ)] [AS-EXPR-SEQ (format-id #'def "default-~a" #'IN-HASH-SEQ)]) #'(begin + (begin-encourage-inline + (define (CHECK-SEQ ht) + (unless (HASHTYPE? ht) + (raise-argument-error 'IN-HASH-SEQ ERR-STR ht)))) (define (AS-EXPR-SEQ ht) - (unless (HASHTYPE? ht) - (raise-argument-error 'IN-HASH-SEQ ERR-STR ht)) + (CHECK-SEQ ht) (make-do-sequence (lambda () (:hash-gen ht -VAL -first -next)))) (define-sequence-syntax IN-HASH-SEQ (lambda () #'AS-EXPR-SEQ) @@ -793,7 +810,7 @@ ;;outer bindings ([(ht) ht-expr]) ;; outer check - (unless (HASHTYPE? ht) (AS-EXPR-SEQ ht)) + (unless-unsafe (CHECK-SEQ ht)) ;; loop bindings ([i (-first ht)]) ;; pos check @@ -861,18 +878,22 @@ (define-syntax define-in-vector-like (syntax-rules () - [(define-in-vector-like in-vector-name + [(define-in-vector-like (in-vector-name check-vector-name) type-name-str vector?-id vector-length-id :vector-gen-id) - (define in-vector-name - (case-lambda - [(v) (in-vector-name v 0 #f 1)] - [(v start) (in-vector-name v start #f 1)] - [(v start stop) (in-vector-name v start stop 1)] - [(v start stop step) - (let-values (([v start stop step] - (normalise-inputs 'in-vector-name type-name-str vector?-id vector-length-id - v start stop step))) - (make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))])) + (begin + (define in-vector-name + (case-lambda + [(v) (in-vector-name v 0 #f 1)] + [(v start) (in-vector-name v start #f 1)] + [(v start stop) (in-vector-name v start stop 1)] + [(v start stop step) + (let-values (([v start stop step] + (normalise-inputs 'in-vector-name type-name-str vector?-id vector-length-id + v start stop step))) + (make-do-sequence (lambda () (:vector-gen-id v start stop step))))])) + (define (check-vector-name v) + (unless (vector?-id v) + (raise-argument-error 'in-vector-name type-name-str v))))])) (define-syntax define-:vector-like-gen (syntax-rules () @@ -900,12 +921,14 @@ vector?-id unsafe-vector-length-id in-vector-id + check-vector-id unsafe-vector-ref-id) (define (in-vector-like stx) (with-syntax ([in-vector-name in-vector-name] [type-name type-name-str] [vector? vector?-id] [in-vector in-vector-id] + [check-vector check-vector-id] [unsafe-vector-length unsafe-vector-length-id] [unsafe-vector-ref unsafe-vector-ref-id]) (syntax-case stx () @@ -916,8 +939,7 @@ (:do-in ;;outer bindings ([(vec len) (let ([vec vec-expr]) - (unless (vector? vec) - (in-vector vec)) + (check-vector vec) (values vec (unsafe-vector-length vec)))]) ;; outer check #f @@ -981,7 +1003,7 @@ (define-:vector-like-gen :vector-gen unsafe-vector-ref) - (define-in-vector-like in-vector + (define-in-vector-like (in-vector check-vector) "vector" vector? vector-length :vector-gen) (define-sequence-syntax *in-vector @@ -991,11 +1013,12 @@ #'vector? #'unsafe-vector-length #'in-vector + #'check-vector #'unsafe-vector-ref)) (define-:vector-like-gen :string-gen string-ref) - (define-in-vector-like in-string + (define-in-vector-like (in-string check-string) "string" string? string-length :string-gen) (define-sequence-syntax *in-string @@ -1005,11 +1028,12 @@ #'string? #'unsafe-string-length #'in-string + #'check-string #'string-ref)) (define-:vector-like-gen :bytes-gen unsafe-bytes-ref) - (define-in-vector-like in-bytes + (define-in-vector-like (in-bytes check-bytes) "bytes" bytes? bytes-length :bytes-gen) (define-sequence-syntax *in-bytes @@ -1019,6 +1043,7 @@ #'bytes? #'unsafe-bytes-length #'in-bytes + #'check-bytes #'unsafe-bytes-ref)) (define-:vector-like-gen :flvector-gen unsafe-flvector-ref) @@ -1878,9 +1903,8 @@ ;; outer bindings: ([(start) a] [(end) b] [(inc) step]) ;; outer check: - (unless (and (real? start) (real? end) (real? inc)) - ;; let `in-range' report the error: - (in-range start end inc)) + ;; let `check-range' report the error: + (unless-unsafe (check-range start end inc)) ;; loop bindings: ([pos start]) ;; pos check @@ -1920,9 +1944,8 @@ ;; outer bindings: ([(start) start-expr]) ;; outer check: - (unless (exact-nonnegative-integer? start) - ;; let `in-naturals' report the error: - (in-naturals start)) + ;; let `check-naturals' report the error: + (unless-unsafe (check-naturals start)) ;; loop bindings: ([pos start]) ;; pos check @@ -1951,7 +1974,7 @@ ;;outer bindings ([(lst) lst-expr]) ;; outer check - (unless (list? lst) (in-list lst)) + (unless-unsafe (check-list lst)) ;; loop bindings ([lst lst]) ;; pos check @@ -2005,7 +2028,7 @@ ;;outer bindings ([(lst) lst-expr]) ;; outer check - (unless (stream? lst) (in-stream lst)) + (unless (unless-unsafe (stream? lst)) (in-stream lst)) ;; loop bindings ([lst lst]) ;; pos check diff -Nru racket-6.12+ppa1/collects/racket/private/gen-temp.rkt racket-7.0+ppa1/collects/racket/private/gen-temp.rkt --- racket-6.12+ppa1/collects/racket/private/gen-temp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/gen-temp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,18 @@ +;;---------------------------------------------------------------------- +;; stateful syntax support + +(module gen-temp '#%kernel + (define-values (intro) #f) + (define-values (counter) 0) + (define-values (gen-temp-id) + ;; Even though we gensym, using an introducer helps the + ;; syntax system simplify renamings that can't apply + ;; to other identifiers (when the generated identifier + ;; is used as a binding id) + (lambda (pfx) + (if intro + (void) + (set! intro (make-syntax-introducer))) + (set! counter (add1 counter)) + (intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter)))))) + (#%provide gen-temp-id)) diff -Nru racket-6.12+ppa1/collects/racket/private/immediate-default.rkt racket-7.0+ppa1/collects/racket/private/immediate-default.rkt --- racket-6.12+ppa1/collects/racket/private/immediate-default.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/immediate-default.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,45 @@ +(module kw '#%kernel + (#%require "define.rkt" + "small-scheme.rkt" + "stxcase-scheme.rkt" + (for-template '#%kernel)) + + (#%provide immediate-default?) + + ;; A default-argument expression counts as an "immediate default" + ;; if it syntactically (before expansion) matches + ;; + ;; = [*] + ;; | ' + ;; | ' | '() + ;; | (void) | null | eof + ;; = #t | #f | | + ;; | | + ;; + ;; where the plain [*] possibility matches only + ;; if the literal's syntax transferred to '#%datum is bound to + ;; `#%datum` from `racket/base`. + + (define (immediate-default? expr) + (let ([immediate-literal? + (lambda (v) + (or (boolean? v) + (number? v) + (char? v) + (and (string? v) + ((string-length v) . < . 8)) + (and (bytes? v) + ((bytes-length v) . < . 8))))]) + (or (and (immediate-literal? (syntax-e expr)) + (free-identifier=? (quote-syntax #%datum) (datum->syntax expr '#%datum))) + (syntax-case expr (quote void null eof) + [(quote s-exp) (let ([v (syntax-e #'s-exp)]) + (or (and (symbol? v) + (or (symbol-interned? v) + (symbol-unreadable? v))) + (null? v) + (immediate-literal? v)))] + [(void) #t] + [null #t] + [eof #t] + [_ #f]))))) diff -Nru racket-6.12+ppa1/collects/racket/private/kw.rkt racket-7.0+ppa1/collects/racket/private/kw.rkt --- racket-6.12+ppa1/collects/racket/private/kw.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/kw.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,7 +4,8 @@ "more-scheme.rkt" (only '#%unsafe unsafe-chaperone-procedure - unsafe-impersonate-procedure) + unsafe-impersonate-procedure + unsafe-undefined) (for-syntax '#%kernel '#%unsafe "procedure-alias.rkt" @@ -16,7 +17,8 @@ "norm-define.rkt" "qqstx.rkt" "sort.rkt" - "kw-prop-key.rkt")) + "kw-prop-key.rkt" + "immediate-default.rkt")) (#%provide new-lambda new-λ new-define @@ -39,6 +41,149 @@ syntax-procedure-alias-property syntax-procedure-converted-arguments-property)) + ;; A `lambda` with just optional arguments is expanded to a form + ;; `case-lambda` that dispatches to a core `lambda`, where `core` + ;; takes all arguments. Arguments that are not supplied to the + ;; `case-lambda` wrapper are replaced by either `unsafe-undefined` + ;; or an immediate default when the `core` function is called. See + ;; "immediate-default.rkt" for the definition of immediate-default + ;; expressions. + ;; + ;; If the original `lambda` has a "rest" argument, then it is passed + ;; as a regular argument to the core `lambda`. + ;; + ;; For example, + ;; + ;; (lambda (x [y (+ 1 2)] [z '3] . r) + ;; ) + ;; + ;; becomes + ;; + ;; (let ([core (lambda (_x _y _z _r) + ;; (let* ([x _x] + ;; [y (if (eq? _y unsafe-undefined) + ;; (+ 1 2) + ;; _y)] + ;; [z (if (#%expression #f) '3 _z)] ; `if` for TR + ;; [r _r]) + ;; ))]) + ;; (case-lambda + ;; [(x) (code x unsafe-undefined '3 null)] + ;; [(x y z . r) (code x y z r)] + ;; [(x y) (code x y '3 null)])) + ;; + ;; The "_"-prefixed argument names in the `core` `lambda` and the + ;; `let*` sequence reflect the way that default-argument expressions + ;; can refer only to earlier arguments. The order shown for the + ;; `case-lambda` clauses reflects how the current expansion orders a + ;; clause for just the required arguments first, and then it has + ;; clauses for the optional arguments in reverse order. + ;; + ;; The use of `(if (#%expression #f) '3 _z)` instead of `_z` has no + ;; effect on the compiled code, because the optimizer will simplify + ;; it to `_z`, but the `(#%expression #f)` is annotated for Typed + ;; Racket to ensure that the expression '3 contributes to type + ;; checking of the function. + ;; + ;; For keyword arguments, a `core` `lambda` similarly receives all + ;; arguments, with each keyword argument before all others and in + ;; order of sorted keywords. In addition, there's an intermediate + ;; `unpack` `lambda` that receives the keyword arguments in list + ;; form as the first two arguments, with the remaining arguments + ;; like the core; the job of the intermediate `unpack` `lambda` is + ;; to parse the lists while exploiting the fact that the lists are + ;; ordered. + ;; + ;; For example, + ;; + ;; (lambda (x [y (+ 1 2)] #:b [b 'b] #:a [a (add1 b)] [z 3] . r) + ;; ) + ;; + ;; becomes + ;; + ;; (let ([core (lambda (_a _b _x _y _z _r) + ;; (let* ([x _x] + ;; [_y (if (eq? _y unsafe-undefined) + ;; (+ 1 2) + ;; _y)] + ;; [b (if (#%expression #f) '3 _b)] + ;; [a (if (eq? _a unsafe-undefined) + ;; (add1 b) + ;; _a2)] + ;; [z (if (#%expression #f) '3 _z)] + ;; [r _r]) + ;; ))]) + ;; (let ([unpack (lambda (kws args _x _y _z _r) + ;; (let* ([has-a? (and (pair? kws) + ;; (eq? '#:a (car kws)))] + ;; [_a (if has-a? (car args) unsafe-undefined)] + ;; [kws (if has-a? (cdr kws) kws)] + ;; [args (if has-a? (cdr args) args)] + ;; [has-b? (pair? args)] + ;; [_b (if has-b? (car args) 'b)]) + ;; (core _a _b _x _y _z _r)))]) + ;; (make-optional-keyword-procedure + ;; ... + ;; ;; Entry point when at least one keyword argument is provided: + ;; (case-lambda + ;; [(kw args x) (unpack kw args x unsafe-undefined '3 null)] + ;; [(kws args x y z . r) (unpack kws args x y z r)] + ;; [(kws args x y) (unpack kws args x y '3 null)]) + ;; ... + ;; ;; Entry point when no keywords are provided: + ;; (case-lambda + ;; [(x) (unpack null null x unsafe-undefined '3 null)] + ;; [(x y z . r) (unpack null null x y z r)] + ;; [(x y) (unpack null null x y '3 null)])))) + ;; + ;; If the example is the right-hand side of `(define f ...)`, then + ;; `core` is flattened into the definition context as described + ;; further below, and some calls expand as follows: + ;; + ;; (f 10) => (core unsafe-undefined 'b '10 unsafe-undefined '3 '()) + ;; (f 10 #:a 'a) => (core 'a 'b '10 unsafe-undefined '3 '()) + ;; (f 10 #:b bee #:a 'a) => (core 'a bee '10 unsafe-undefined '3 '()) + ;; (f 10 11) => (core unsafe-undefined 'b '10 '11 '3 '()) + ;; (f 10 11 12 13) => (core unsafe-undefined 'b '10 '11 '12 (list '13)) + ;; + ;; + ;; Another example, illustrating a mandatory keyword argument: + ;; + ;; (lambda (#:x x #:y [y (add1 x)]) ) + ;; + ;; becomes + ;; + ;; (let ([core (lambda (_x _y) + ;; (let* ([x _x] + ;; [y (if (eq? _y unsafe-undefined) + ;; (add1 x) + ;; _y)]) + ;; ))]) + ;; (let ([unpack + ;; (lambda (kws args) + ;; (let* ([_x (car args)] ; no check needed + ;; [kws (cdr kws)] + ;; [args (cdr args)] + ;; [has-y? (pair? kws)] + ;; [_y (if has-y? (car args) unsafe-undefined)]) + ;; (core _x _y)))]) + ;; (naming-constructor + ;; ... + ;; (case-lambda + ;; [(kws args) (unpack kw args)]) + ;; ...))) + ;; + ;; Finally, `(define (f ...) )` or `(define f (lambda (...) + ;; ))` with keyword arguments expands to bind `f` as a macro, + ;; and some `_f` is bound to the expansion illustrated above, except + ;; that the `core` and `unpack` bindings are flattened into the + ;; definition context. That way, uses of the `f` macro can typically + ;; expand to a direct call to the corresponding `core` function, + ;; statically parsing the supplied keyword arguments and passing + ;; `unsafe-undefined` or an immediate default in place of unsupplied + ;; arguments. This macro-binding approach is used only when `f` has + ;; keyword arguments. + ;; ---------------------------------------- (define-values (prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref) @@ -266,7 +411,8 @@ (apply proc null null args)))] [(proc plain-proc) (make-optional-keyword-procedure - (make-keyword-checker null #f (procedure-arity proc)) + (make-keyword-checker null #f (and (procedure? proc) ; reundant check helps purity inference + (procedure-arity proc))) proc null #f @@ -394,21 +540,21 @@ [([id default] . rest) (identifier? (syntax id)) (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest #t)]) - #'(plain (id . opt-ids) ([id default #:opt] . opts) kws need-kw rest))] + #'(plain ([id default] . opt-ids) ([id default #:opt] . opts) kws need-kw rest))] [(kw id . rest) (and (identifier? #'id) (keyword? (syntax-e #'kw))) (begin (check-kw #'kw) (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)]) - #'(plain opt-ids ([id #f #:kw-req] . opts) ([kw id #t] . kws) (kw . need-kw) rest)))] + #'(plain opt-ids ([id #f #:kw-req] . opts) ([kw id #t #f] . kws) (kw . need-kw) rest)))] [(kw [id default] . rest) (and (identifier? #'id) (keyword? (syntax-e #'kw))) (begin (check-kw #'kw) (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)]) - #'(plain opt-ids ([id default #:kw-opt] . opts) ([kw id #f] . kws) need-kw rest)))] + #'(plain opt-ids ([id default #:kw-opt] . opts) ([kw id #f default] . kws) need-kw rest)))] [(kw) (keyword? (syntax-e #'kw)) (begin @@ -446,9 +592,9 @@ (lambda args body1 body ...))) ;; Handle keyword or optional arguments: (with-syntax ([((plain-id ...) - (opt-id ...) + ([opt-id pos-opt-expr] ...) ([id opt-expr kind] ...) - ([kw kw-id kw-req] ...) + ([kw kw-id kw-req kw-opt-expr] ...) need-kw rest) (parse-formals stx #'args)]) @@ -464,13 +610,20 @@ [ids (syntax->list #'(id ...))] [plain-ids (syntax->list #'(plain-id ...))] [kw-reqs (syntax->list #'(kw-req ...))] - [kw-args (generate-temporaries kws)] ; to hold supplied value - [kw-arg?s (generate-temporaries kws)] ; to indicated whether it was supplied + [kw-args (generate-temporaries kws)] ; supplied value + [kw-arg?s (generate-temporaries kws)] ; temporary to indicate whether supplied [opt-args (generate-temporaries opts)] ; supplied value - [opt-arg?s (generate-temporaries opts)] ; whether supplied + [get-not-supplieds (lambda (opt-exprs) + (map (lambda (opt-expr) + (if (immediate-default? opt-expr) + opt-expr + #'unsafe-undefined)) + opt-exprs))] + [opt-not-supplieds (get-not-supplieds (syntax->list #'(pos-opt-expr ...)))] + [kw-not-supplieds (get-not-supplieds (syntax->list #'(kw-opt-expr ...)))] [needed-kws (sort (syntax->list #'need-kw) (lambda (a b) (keywordsyntax stx '#%app)) (parse-app (datum->syntax #f (cons #'new-app stx) stx) (lambda (n) @@ -1143,12 +1296,12 @@ [all-kws (let loop ([all-kws all-kws]) (cond [(null? all-kws) null] - [(keywordnumber start) 0)] - [end (or (string->number end) 0)]) - (with-input-from-file exe - (lambda () - (file-position (current-input-port) start) - (read-bytes (max 0 (- end start)))))))] - [p (open-input-bytes s)]) - (let loop () - (let ([e (parameterize ([read-accept-compiled #t] - [read-accept-reader #t] - [read-accept-lang #t] - [read-on-demand-source #t]) - (read p))]) - (unless (eof-object? e) - ((current-eval) e) - (loop)))))))) diff -Nru racket-6.12+ppa1/collects/racket/private/map.rkt racket-7.0+ppa1/collects/racket/private/map.rkt --- racket-6.12+ppa1/collects/racket/private/map.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/map.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,13 +4,28 @@ (module map '#%kernel (#%require "small-scheme.rkt" "define.rkt" - "performance-hint.rkt") + "performance-hint.rkt" + "kw.rkt" + '#%paramz + (for-syntax '#%kernel)) (#%provide (rename map2 map) (rename for-each2 for-each) (rename andmap2 andmap) (rename ormap2 ormap)) - + + (define-syntaxes (or-unsafe) + (lambda (stx) + (let-values ([(es) (cdr (syntax-e stx))]) + (let-values ([(e) (car (if (syntax? es) + (syntax-e es) + es))]) + (datum->syntax #f + (list (quote-syntax if) + (quote-syntax (variable-reference-from-unsafe? (#%variable-reference))) + (quote-syntax #t) + e)))))) + ;; ------------------------------------------------------------------------- (begin-encourage-inline @@ -19,22 +34,23 @@ (let ([map (case-lambda [(f l) - (if (and (procedure? f) - (procedure-arity-includes? f 1) - (list? l)) + (if (or-unsafe (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l))) (let loop ([l l]) (cond [(null? l) null] [else (let ([r (cdr l)]) ; so `l` is not necessarily retained during `f` (cons (f (car l)) (loop r)))])) - (map f l))] + (gen-map f (list l)))] [(f l1 l2) - (if (and (procedure? f) - (procedure-arity-includes? f 2) - (list? l1) - (list? l2) - (= (length l1) (length l2))) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2)))) (let loop ([l1 l1] [l2 l2]) (cond [(null? l1) null] @@ -43,30 +59,32 @@ [r2 (cdr l2)]) (cons (f (car l1) (car l2)) (loop r1 r2)))])) - (map f l1 l2))] - [(f l . args) (apply map f l args)])]) + (gen-map f (list l1 l2)))] + [(f l . args) (gen-map f (cons l args))])]) map)) (define for-each2 (let ([for-each (case-lambda [(f l) - (if (and (procedure? f) - (procedure-arity-includes? f 1) - (list? l)) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l))) (let loop ([l l]) (cond [(null? l) (void)] [else (let ([r (cdr l)]) (begin (f (car l)) (loop r)))])) - (for-each f l))] + (gen-for-each f (list l)))] [(f l1 l2) - (if (and (procedure? f) - (procedure-arity-includes? f 2) - (list? l1) - (list? l2) - (= (length l1) (length l2))) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2)))) (let loop ([l1 l1] [l2 l2]) (cond [(null? l1) (void)] @@ -75,17 +93,18 @@ [r2 (cdr l2)]) (begin (f (car l1) (car l2)) (loop r1 r2)))])) - (for-each f l1 l2))] - [(f l . args) (apply for-each f l args)])]) + (gen-for-each f (list l1 l2)))] + [(f l . args) (gen-for-each f (cons l args))])]) for-each)) (define andmap2 (let ([andmap (case-lambda [(f l) - (if (and (procedure? f) - (procedure-arity-includes? f 1) - (list? l)) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l))) (if (null? l) #t (let loop ([l l]) @@ -95,13 +114,14 @@ (let ([r (cdr l)]) (and (f (car l)) (loop r)))]))) - (andmap f l))] + (gen-andmap f (list l)))] [(f l1 l2) - (if (and (procedure? f) - (procedure-arity-includes? f 2) - (list? l1) - (list? l2) - (= (length l1) (length l2))) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2)))) (if (null? l1) #t (let loop ([l1 l1] [l2 l2]) @@ -112,17 +132,18 @@ [r2 (cdr l2)]) (and (f (car l1) (car l2)) (loop r1 r2)))]))) - (andmap f l1 l2))] - [(f l . args) (apply andmap f l args)])]) + (gen-andmap f (list l1 l2)))] + [(f l . args) (gen-andmap f (cons l args))])]) andmap)) (define ormap2 (let ([ormap (case-lambda [(f l) - (if (and (procedure? f) - (procedure-arity-includes? f 1) - (list? l)) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l))) (if (null? l) #f (let loop ([l l]) @@ -131,13 +152,14 @@ [else (let ([r (cdr l)]) (or (f (car l)) (loop r)))]))) - (ormap f l))] + (gen-ormap f (list l)))] [(f l1 l2) - (if (and (procedure? f) - (procedure-arity-includes? f 2) - (list? l1) - (list? l2) - (= (length l1) (length l2))) + (if (or-unsafe + (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2)))) (if (null? l1) #f (let loop ([l1 l1] [l2 l2]) @@ -148,6 +170,126 @@ [r2 (cdr l2)]) (or (f (car l1) (car l2)) (loop r1 r2)))]))) - (ormap f l1 l2))] - [(f l . args) (apply ormap f l args)])]) - ormap)))) + (gen-ormap f (list l1 l2)))] + [(f l . args) (gen-ormap f (cons l args))])]) + ormap))) + + + ;; ------------------------------------------------------------------------- + + (define (check-args who f ls) + (unless (procedure? f) + (raise-argument-error who "procedure?" f)) + (let loop ([prev-len #f] [ls ls] [i 1]) + (unless (null? ls) + (let ([l (car ls)]) + (unless (list? l) + (raise-argument-error who "list?" l)) + (let ([len (length l)]) + (when (and prev-len + (not (= len prev-len))) + (raise-arguments-error who "all lists must have same size" + "first list length" prev-len + "other list length" len + "procedure" f)) + (loop len (cdr ls) (add1 i)))))) + (unless (procedure-arity-includes? f (length ls)) + (define-values (required-keywords optional-keywords) (procedure-keywords f)) + (apply raise-arguments-error who + (if (pair? required-keywords) + (string-append "argument mismatch;\n" + " the given procedure expects keyword arguments") + (string-append "argument mismatch;\n" + " the given procedure's expected number of arguments does not match" + " the given number of lists")) + "given procedure" (unquoted-printing-string + (or (let ([n (object-name f)]) + (and (symbol? n) + (symbol->string n))) + "#")) + (append + (let ([a (procedure-arity f)]) + (cond + [(pair? required-keywords) + null] + [(integer? a) + (list "expected" a)] + [(arity-at-least? a) + (list "expected" (unquoted-printing-string + (string-append "at least " (number->string (arity-at-least-value a)))))] + [else + null])) + (cond + [(pair? required-keywords) + null] + [else + (list "given" (length ls))]) + (cond + [(pair? required-keywords) + (list "required keywords" + (unquoted-printing-string + (apply string-append + (cdr + (let loop ([kws required-keywords]) + (cond + [(null? kws) null] + [else (list* " " + (string-append "#:" + (keyword->string (car kws))) + (loop (cdr kws)))]))))))] + [else + null]) + (let ([w (quotient (error-print-width) (length ls))]) + (if (w . > . 10) + (list "argument lists..." + (unquoted-printing-string + (apply string-append + (let loop ([ls ls]) + (cond + [(null? ls) null] + [else (cons (string-append "\n " + ((error-value->string-handler) + (car ls) + w)) + (loop (cdr ls)))]))))) + null)))))) + + (define (gen-map f ls) + (or-unsafe (check-args 'map f ls)) + (let loop ([ls ls]) + (cond + [(null? (car ls)) null] + [else + (let ([next-ls (map2 cdr ls)]) + (cons (apply f (map2 car ls)) + (loop next-ls)))]))) + + (define (gen-for-each f ls) + (or-unsafe (check-args 'for-each f ls)) + (let loop ([ls ls]) + (unless (null? (car ls)) + (let ([next-ls (map2 cdr ls)]) + (apply f (map2 car ls)) + (loop next-ls))))) + + (define (gen-andmap f ls) + (or-unsafe (check-args 'andmap f ls)) + (let loop ([ls ls]) + (cond + [(null? (car ls)) #t] + [(null? (cdar ls)) (apply f (map2 car ls))] + [else (let ([next-ls (map2 cdr ls)]) + (and (apply f (map2 car ls)) + (loop next-ls)))]))) + + (define (gen-ormap f ls) + (or-unsafe (check-args 'ormap f ls)) + (let loop ([ls ls]) + (cond + [(null? (car ls)) #f] + [(null? (cdar ls)) (apply f (map2 car ls))] + [else (let ([next-ls (map2 cdr ls)]) + (or (apply f (map2 car ls)) + (loop next-ls)))]))) + + (void)) diff -Nru racket-6.12+ppa1/collects/racket/private/misc.rkt racket-7.0+ppa1/collects/racket/private/misc.rkt --- racket-6.12+ppa1/collects/racket/private/misc.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/misc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,8 +4,8 @@ (module misc '#%kernel (#%require "small-scheme.rkt" "define.rkt" "path.rkt" "old-path.rkt" - "path-list.rkt" "executable-path.rkt" "collect.rkt" - "reading-param.rkt" "load.rkt" + "path-list.rkt" "executable-path.rkt" + "reading-param.rkt" "../repl.rkt" (for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt")) ;; ------------------------------------------------------------------------- @@ -81,30 +81,7 @@ ;; ------------------------------------------------------------------------- - (define (read-eval-print-loop) - (let repl-loop () - ;; This prompt catches all error escapes, including from read and print. - (call-with-continuation-prompt - (lambda () - (let ([v ((current-prompt-read))]) - (unless (eof-object? v) - (call-with-values - (lambda () - ;; This prompt catches escapes during evaluation. - ;; Unlike the outer prompt, the handler prints - ;; the results. - (call-with-continuation-prompt - (lambda () - (let ([w (cons '#%top-interaction v)]) - ((current-eval) (if (syntax? v) - (namespace-syntax-introduce - (datum->syntax #f w v)) - w)))))) - (lambda results (for-each (current-print) results))) - ;; Abort to loop. (Calling `repl-loop' directory would not be a tail call.) - (abort-current-continuation (default-continuation-prompt-tag))))) - (default-continuation-prompt-tag) - (lambda args (repl-loop))))) + (define load/cd (lambda (n) @@ -254,12 +231,12 @@ load/cd load-relative load-relative-extension path-list-string->path-list find-executable-path - collection-path collection-file-path load/use-compiled guard-evt channel-get channel-try-get channel-put port? writeln displayln println - find-library-collection-paths - find-library-collection-links bytes-environment-variable-name? string-environment-variable-name? getenv putenv - call-with-default-reading-parameterization)) + call-with-default-reading-parameterization + + ;; From '#%kernel, but re-exported for compatibility: + collection-path collection-file-path)) diff -Nru racket-6.12+ppa1/collects/racket/private/more-scheme.rkt racket-7.0+ppa1/collects/racket/private/more-scheme.rkt --- racket-6.12+ppa1/collects/racket/private/more-scheme.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/more-scheme.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -201,7 +201,7 @@ (error 'with-handlers "exception handler used out of context"))) - (define handler-prompt-key (make-continuation-prompt-tag)) + (define handler-prompt-key (make-continuation-prompt-tag 'handler-prompt-tag)) (define (call-handled-body bpz handle-proc body-thunk) ;; Disable breaks here, so that when the exception handler jumps @@ -337,50 +337,52 @@ (printf "cpu time: ~s real time: ~s gc time: ~s\n" cpu user gc) (apply values v)))]))) - (define-values (hash-update hash-update! hash-has-key? hash-ref!) - (let* ([not-there (gensym)] - [up (lambda (who mut? set ht key xform default) - (unless (and (hash? ht) - (if mut? - (not (immutable? ht)) - (immutable? ht))) - (raise-argument-error who (if mut? "(and/c hash? (not/c immutable?))" "(and/c hash? immutable?)") ht)) - (unless (and (procedure? xform) - (procedure-arity-includes? xform 1)) - (raise-argument-error who "(any/c . -> . any/c)" xform)) - (let ([v (hash-ref ht key default)]) - (if (eq? v not-there) - (raise-mismatch-error who "no value found for key: " key) - (set ht key (xform v)))))]) - (let ([hash-update - (case-lambda - [(ht key xform default) - (up 'hash-update #f hash-set ht key xform default)] - [(ht key xform) - (hash-update ht key xform not-there)])] - [hash-update! - (case-lambda - [(ht key xform default) - (up 'hash-update! #t hash-set! ht key xform default)] - [(ht key xform) - (hash-update! ht key xform not-there)])] - [hash-has-key? - (lambda (ht key) - (unless (hash? ht) - (raise-argument-error 'hash-has-key? "hash?" 0 ht key)) - (not (eq? not-there (hash-ref ht key not-there))))] - [hash-ref! - (lambda (ht key new) - (unless (and (hash? ht) - (not (immutable? ht))) - (raise-argument-error 'hash-ref! "(and/c hash? (not/c immutable?))" 0 ht key new)) - (let ([v (hash-ref ht key not-there)]) - (if (eq? not-there v) - (let ([n (if (procedure? new) (new) new)]) - (hash-set! ht key n) - n) - v)))]) - (values hash-update hash-update! hash-has-key? hash-ref!)))) + (define not-there (gensym)) + + (define (do-hash-update who mut? set ht key xform default) + (unless (variable-reference-from-unsafe? (#%variable-reference)) + (unless (and (hash? ht) + (if mut? + (not (immutable? ht)) + (immutable? ht))) + (raise-argument-error who (if mut? "(and/c hash? (not/c immutable?))" "(and/c hash? immutable?)") ht)) + (unless (and (procedure? xform) + (procedure-arity-includes? xform 1)) + (raise-argument-error who "(any/c . -> . any/c)" xform))) + (let ([v (hash-ref ht key default)]) + (if (eq? v not-there) + (raise-mismatch-error who "no value found for key: " key) + (set ht key (xform v))))) + + (define hash-update + (case-lambda + [(ht key xform default) + (do-hash-update 'hash-update #f hash-set ht key xform default)] + [(ht key xform) + (hash-update ht key xform not-there)])) + + (define hash-update! + (case-lambda + [(ht key xform default) + (do-hash-update 'hash-update! #t hash-set! ht key xform default)] + [(ht key xform) + (hash-update! ht key xform not-there)])) + + (define (hash-has-key? ht key) + (unless (hash? ht) + (raise-argument-error 'hash-has-key? "hash?" 0 ht key)) + (not (eq? not-there (hash-ref ht key not-there)))) + + (define (hash-ref! ht key new) + (unless (and (hash? ht) + (not (immutable? ht))) + (raise-argument-error 'hash-ref! "(and/c hash? (not/c immutable?))" 0 ht key new)) + (let ([v (hash-ref ht key not-there)]) + (if (eq? not-there v) + (let ([n (if (procedure? new) (new) new)]) + (hash-set! ht key n) + n) + v))) (#%provide case old-case do parameterize parameterize* current-parameterization call-with-parameterization diff -Nru racket-6.12+ppa1/collects/racket/private/path-list.rkt racket-7.0+ppa1/collects/racket/private/path-list.rkt --- racket-6.12+ppa1/collects/racket/private/path-list.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/path-list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,11 +4,7 @@ (#%provide path-list-string->path-list) (define-values (path-list-string->path-list) - (let ((r (byte-regexp (string->bytes/utf-8 - (let ((sep (if (eq? (system-type) 'windows) - ";" - ":"))) - (format "([^~a]*)~a(.*)" sep sep))))) + (let ((r #f) (cons-path (lambda (default s l) (let ([s (if (eq? (system-type) 'windows) (regexp-replace* #rx#"\"" s #"") @@ -18,6 +14,12 @@ (cons (bytes->path s) l)))))) (lambda (s default) + (unless r + (set! r (byte-regexp (string->bytes/utf-8 + (let ((sep (if (eq? (system-type) 'windows) + ";" + ":"))) + (format "([^~a]*)~a(.*)" sep sep)))))) (unless (or (bytes? s) (string? s)) (raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s)) diff -Nru racket-6.12+ppa1/collects/racket/private/pre-base.rkt racket-7.0+ppa1/collects/racket/private/pre-base.rkt --- racket-6.12+ppa1/collects/racket/private/pre-base.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/pre-base.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,6 +19,7 @@ "norm-arity.rkt" "performance-hint.rkt" "top-int.rkt" + "collect.rkt" '#%builtin ; so it's attached (for-syntax "kw.rkt" "norm-define.rkt")) @@ -159,32 +160,6 @@ (+ min (random d prng)))])]) random))) - (define-values (new:collection-path) - (let ([collection-path (new-lambda (collection - #:fail [fail (lambda (s) - (raise - (exn:fail:filesystem - (string-append "collection-path: " s) - (current-continuation-marks))))] - . collections) - (collection-path fail collection collections))]) - collection-path)) - - (define-values (new:collection-file-path) - (let ([collection-file-path (new-lambda (file-name - collection - #:check-compiled? [check-compiled? - (and (path-string? file-name) - (regexp-match? #rx".[.]rkt$" file-name))] - #:fail [fail (lambda (s) - (raise - (exn:fail:filesystem - (string-append "collection-file-path: " s) - (current-continuation-marks))))] - . collections) - (collection-file-path fail check-compiled? file-name collection collections))]) - collection-file-path)) - (define-syntaxes (module-begin) (lambda (stx) (let-values ([(l) (syntax->list stx)]) @@ -248,7 +223,8 @@ assq assv assoc prop:incomplete-arity prop:method-arity-error list-pair? interned-char? true-object? - random) + random + collection-path collection-file-path) (all-from "reqprov.rkt") (all-from-except "for.rkt" define-in-vector-like diff -Nru racket-6.12+ppa1/collects/racket/private/primitive-table.rkt racket-7.0+ppa1/collects/racket/private/primitive-table.rkt --- racket-6.12+ppa1/collects/racket/private/primitive-table.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/primitive-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table)) + +;; By using only `primitive-table` directly, that's the only function +;; needed for bootstrapping situations (that might even replace the +;; linklet implementation otherwise). + +(provide import-from-primitive-table) + +(define-syntax import-from-primitive-table + (syntax-rules () + [(_ (table-name ...) [id import-id]) + ;; Linklet-flattening tools can recognize this specific pattern + ;; to substitute a static reference for a dynamic lookup + (define import-id (hash-ref (or (primitive-table 'table-name) ...) 'id #f))] + [(_ table-name [id import-id]) + (import-from-primitive-table (table-name) [id import-id])] + [(_ tables id) + (import-from-primitive-table tables [id id])] + [(_ tables bind ...) + (begin + (import-from-primitive-table tables bind) + ...)])) diff -Nru racket-6.12+ppa1/collects/racket/private/qqstx.rkt racket-7.0+ppa1/collects/racket/private/qqstx.rkt --- racket-6.12+ppa1/collects/racket/private/qqstx.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/qqstx.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,7 @@ ;; #%qqstx : quasisyntax (module qqstx '#%kernel - (#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" + (#%require "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "template.rkt" (for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt")) (#%provide quasisyntax @@ -105,13 +105,11 @@ [ctx (datum->syntax #'x 'ctx #'x)]) (convert-k (datum->syntax stx - (list* (syntax temp) - (quote-syntax ...) - rest-v) + (cons #'(~@! . temp) rest-v) stx stx) (with-syntax ([check check-splicing-list-id]) - (cons #'[(temp (... ...)) (check x (quote-syntax ctx))] + (cons #'[temp (check x (quote-syntax ctx))] bindings)))))]) (loop (syntax rest) depth (lambda () diff -Nru racket-6.12+ppa1/collects/racket/private/reqprov.rkt racket-7.0+ppa1/collects/racket/private/reqprov.rkt --- racket-6.12+ppa1/collects/racket/private/reqprov.rkt 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/reqprov.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1071,7 +1071,7 @@ (list-ref super-v 3))) (list-ize (list-ref v 4) (and super-v - (list-ref super-v 3))))))) + (list-ref super-v 4))))))) (raise-syntax-error #f "identifier is not bound to struct type information" @@ -1177,12 +1177,12 @@ (datum->syntax (import-orig-stx i) (list #'just-meta - (import-req-mode i) + (import-orig-mode i) (list #'for-meta (import-mode i) (list #'rename (import-src-mod-path i) - (syntax-local-introduce (import-local-id i)) + (import-local-id i) (import-src-sym i)))) (import-orig-stx i))) @@ -1192,25 +1192,26 @@ (define-syntax (local-require stx) (when (eq? 'expression (syntax-local-context)) (raise-syntax-error #f "not allowed in an expression context" stx)) - (syntax-case stx [] - [(_ spec ...) - (let*-values ([(imports sources) - (expand-import - (datum->syntax - stx - (list* #'only-meta-in 0 (syntax->list #'(spec ...))) - stx))] - [(names) (map import-local-id imports)] - [(reqd-names) - (let ([ctx (syntax-local-get-shadower (datum->syntax #f (gensym)))]) - (map (lambda (n) (datum->syntax ctx (syntax-e n) n)) names))] - [(renamed-imports) (map rename-import imports reqd-names)] - [(raw-specs) (map import->raw-require-spec renamed-imports)] - [(lifts) (map syntax-local-lift-require raw-specs reqd-names)]) - (with-syntax ([(name ...) names] - [(lifted ...) lifts]) - (syntax/loc stx (define-syntaxes (name ...) - (values (make-rename-transformer (quote-syntax lifted)) ...)))))])) + (let ([stx (syntax-local-introduce stx)]) + (syntax-case stx [] + [(_ spec ...) + (let*-values ([(imports sources) + (expand-import + (datum->syntax + stx + (list* #'only-meta-in 0 (syntax->list #'(spec ...))) + stx))] + [(names) (map import-local-id imports)] + [(reqd-names) + (let ([ctx (syntax-local-get-shadower (datum->syntax #f (gensym)))]) + (map (lambda (n) (datum->syntax ctx (syntax-e n) n)) names))] + [(renamed-imports) (map rename-import imports reqd-names)] + [(raw-specs) (map import->raw-require-spec renamed-imports)] + [(lifts) (map syntax-local-lift-require raw-specs reqd-names)]) + (with-syntax ([(name ...) (map syntax-local-introduce names)] + [(lifted ...) (map syntax-local-introduce lifts)]) + (syntax/loc stx (define-syntaxes (name ...) + (values (make-rename-transformer (quote-syntax lifted)) ...)))))]))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ) diff -Nru racket-6.12+ppa1/collects/racket/private/reverse.rkt racket-7.0+ppa1/collects/racket/private/reverse.rkt --- racket-6.12+ppa1/collects/racket/private/reverse.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/reverse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,20 +1,16 @@ (module reverse '#%kernel - (#%provide alt-reverse) - - (define-values (alt-reverse) - (if (eval-jit-enabled) - (let-values ([(reverse) - (lambda (l) - (if (list? l) - (void) - (raise-argument-error 'reverse "list?" l)) - (letrec-values ([(loop) - (lambda (a l) - (if (null? l) - a - (loop (cons (car l) a) (cdr l))))]) - (loop null l)))]) - reverse) - reverse))) - + (#%provide (rename reverse alt-reverse)) + (define-values (reverse) + (lambda (l) + (if (variable-reference-from-unsafe? (#%variable-reference)) + (void) + (if (list? l) + (void) + (raise-argument-error 'reverse "list?" l))) + (letrec-values ([(loop) + (lambda (a l) + (if (null? l) + a + (loop (cons (car l) a) (cdr l))))]) + (loop null l))))) diff -Nru racket-6.12+ppa1/collects/racket/private/sc.rkt racket-7.0+ppa1/collects/racket/private/sc.rkt --- racket-6.12+ppa1/collects/racket/private/sc.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/sc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -494,451 +494,6 @@ `(cons/#f ,(cadr e1) ,e2) `(append/#f ,e1 ,e2))) - ;; ---------------------------------------------------------------------- - ;; Output generator - - ;; Takes a syntax pattern, an environment prototype, and - ;; a keyword symbol list, and produces an expander - ;; that takes an environment and produces syntax. - ;; - ;; If the environment prototype is #f, it produces a list of - ;; variables used in the pattern, instead. This is useful for - ;; determining what kind of environment (and prototype) to construct - ;; for the pattern. - ;; - ;; An environment for an expander is a list*; see the note above, - ;; under "Input Matcher", for details. - ;; - (-define (make-pexpand p proto-r k dest s-exp?) - (-define top p) - ;; Helper function: avoid generating completely new symbols - ;; for substitution. Instead, try to generate normal symbols - ;; with a standard prefix, so that the symbols can be shared. - (-define sub-gensym (let ([cnt 0] - [prefix (let pfx-loop ([pfx "_pat"]) - (if (let loop ([p p]) - (cond - [(symbol? p) - (let ([s (symbol->string p)]) - (and ((string-length s) . > . (string-length pfx)) - (string=? pfx (substring s 0 (string-length pfx)))))] - [(syntax? p) (loop (syntax-e p))] - [(pair? p) (or (loop (car p)) (loop (cdr p)))] - [(vector? p) (loop (vector->list p))] - [(box? p) (loop (unbox p))] - [(struct? p) (loop (struct->vector p))] - [else #f])) - (pfx-loop (string-append "_" pfx)) - pfx))]) - (lambda () - (set! cnt (add1 cnt)) - (string->symbol (format "~a~a" prefix cnt))))) - ;; The pattern expander: - (-define (expander p proto-r local-top use-ellipses? use-tail-pos hash! need-list?) - (cond - [(and use-ellipses? (ellipsis? p)) - (let*-values ([(p-head) (stx-car p)] - [(el-count rest-p last-el) - (let loop ([p (stx-cdr (stx-cdr p))][el-count 0][last-el (stx-car (stx-cdr p))]) - (if (and (stx-pair? p) - (...? (stx-car p))) - (loop (stx-cdr p) (add1 el-count) (stx-car p)) - (values el-count p last-el)))] - [(p-head) (let loop ([el-count el-count]) - (if (zero? el-count) - p-head - (datum->syntax - #f - (list (loop (sub1 el-count)) (quote-syntax ...)))))] - [(nestings) (and proto-r (get-ellipsis-nestings p-head k))]) - (when (null? nestings) - (apply - raise-syntax-error - 'syntax - "no pattern variables before ellipsis in template" - (pick-specificity - top - last-el))) - (let* ([proto-rr+deep?s (and proto-r - (map (lambda (nesting) - (ellipsis-sub-env nesting proto-r top local-top)) - nestings))] - [proto-rr-deep (and proto-r - ;; the ones that we had to unwrap: - (let loop ([l proto-rr+deep?s]) - (cond - [(null? l) null] - [(cdar l) (loop (cdr l))] - [else (cons (caar l) (loop (cdr l)))])))] - [proto-rr-shallow (and proto-r - ;; the ones that we leave alone for these ellipsis: - (let loop ([l proto-rr+deep?s]) - (cond - [(null? l) null] - [(cdar l) (cons (caar l) (loop (cdr l)))] - [else (loop (cdr l))])))] - [__ (unless (null? proto-rr-shallow) - (when (null? proto-rr-deep) - (apply - raise-syntax-error - 'syntax - "too many ellipses in template" - (pick-specificity - top - last-el))))] - [rest (expander rest-p proto-r local-top #t use-tail-pos hash! need-list?)] - [ehead (expander p-head (and proto-r (append proto-rr-shallow proto-rr-deep)) p-head #t #f hash! - (or need-list? (positive? el-count)))]) - (if proto-r - `(lambda (r) - ,(let ([pre (let ([deeps - (let ([valses - ;; Generate one binding per nested use. This will duplicate - ;; bindings if a pattern variable is used multiple times; that's - ;; good if the uses are in different nesting levels (which could be - ;; ok if there are extra ellipses around them), but it might also - ;; create redundant entries. - (map (lambda (var) - (apply-list-ref 'r (stx-memq*-pos (list var) proto-r) use-tail-pos)) - proto-rr-deep)]) - (cond - [(and (= 1 (length valses)) - (= 0 el-count) - (null? proto-rr-shallow) - (equal? ehead '(lambda (r) (car r)))) - ;; Common case: one item in list, no map needed: - (car valses)] - [(and (= 2 (length valses)) - (= 0 el-count) - (null? proto-rr-shallow) - (equal? ehead '(lambda (r) (list (car r) (cadr r))))) - ;; Another common case: a maintained pair - `(map - (lambda (a b) (list a b)) - ,@valses)] - [else - ;; General case: - (letrec ([wrap (lambda (expr el-count) - (if (zero? el-count) - expr - (wrap `(apply append ,expr) - (sub1 el-count))))]) - (wrap - `(map - (lambda vals - (,ehead - ,(if (null? proto-rr-shallow) - 'vals - '(append shallows vals)))) - ,@valses) - el-count))]))]) - (if (null? proto-rr-shallow) - deeps - `(let ([shallows - (list ,@(map (lambda (var) - (apply-list-ref 'r (stx-memq*-pos var proto-r) use-tail-pos)) - proto-rr-shallow))]) - ,deeps)))] - [post (apply-to-r rest)]) - (let ([v (if (eq? post 'null) - pre - `(append ,pre ,post))]) - (if (and (not need-list?) (syntax? p) (not s-exp?)) - ;; Keep srcloc, properties, etc.: - (let ([small-dest (datum->syntax p - 'dest - p - p)]) - `(datum->syntax/shape (quote-syntax ,small-dest) ,v)) - v)))) - ;; variables were hashed - (void))))] - [(stx-pair? p) - (let ([hd (stx-car p)]) - (if (and use-ellipses? - (...? hd)) - (if (and (stx-pair? (stx-cdr p)) - (stx-null? (stx-cdr (stx-cdr p)))) - (let ([dp (stx-car (stx-cdr p))]) - (expander dp proto-r dp #f use-tail-pos hash! need-list?)) - (raise-syntax-error - 'syntax - "misplaced ellipsis in template" - top - hd)) - (let ([ehd (expander hd proto-r hd use-ellipses? use-tail-pos hash! #f)] - [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash! need-list?)]) - (if proto-r - `(lambda (r) - ,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym s-exp?)) - ;; variables were hashed - (void)))))] - [(stx-vector? p #f) - (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) - (if proto-r - `(lambda (r) - (list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(stx-box? p) - (let ([e (expander (unbox (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) - (if proto-r - `(lambda (r) - (box (,(if s-exp? 'values 'syntax-e) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(and (syntax? p) - (struct? (syntax-e p)) - (prefab-struct-key (syntax-e p))) - (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)]) - (if proto-r - `(lambda (r) - (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) - (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) - ;; variables were hashed - (void)))] - [(identifier? p) - (if (stx-memq p k) - (if proto-r - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) - (void)) - (if proto-r - (let ((x (stx-memq p proto-r))) - (if x - `(lambda (r) ,(apply-list-ref 'r (stx-memq-pos p proto-r) use-tail-pos)) - (begin - (when (and use-ellipses? - (...? p)) - (raise-syntax-error - 'syntax - "misplaced ellipsis in template" - top - p)) - (check-not-pattern p proto-r) - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))))) - (unless (and (...? p) - use-ellipses?) - (hash! p))))] - [(null? p) - ;; Not syntax, so avoid useless syntax info - (if proto-r - `(lambda (r) null) - (void))] - [else (if proto-r - `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) - (void))])) - (let* ([ht (if proto-r - #f - (make-hasheq))] - [in-order null] ; same content as ht, but in deterministic order - [l (expander p proto-r p #t - (and proto-r (sub1 (length proto-r))) - (if proto-r - #f - (lambda (r) - (let ([l (hash-ref ht (syntax-e r) null)]) - (let ([pr (and (pair? l) - (ormap (lambda (i) - (and (bound-identifier=? (mcar i) r) i)) - l))]) - (if pr - (set-mcdr! pr (cons r (mcdr pr))) - (let ([pr (mcons r (list r))]) - (set! in-order (cons pr in-order)) - (hash-set! ht (syntax-e r) (cons pr l)))))))) - #f)]) - (if proto-r - `(lambda (r) - ,(let ([main (let ([build (apply-to-r l)]) - (if (or s-exp? - (and (pair? build) - (eq? (car build) 'pattern-substitute))) - build - (let ([small-dest ;; In case dest has significant structure... - (and dest (datum->syntax - dest - 'dest - dest - dest))]) - `(datum->syntax/shape (quote-syntax ,small-dest) - ,build))))]) - (if (multiple-ellipsis-vars? p proto-r) - `(catch-ellipsis-error - (lambda () ,main) - (quote ,p) - ;; This is a trick to minimize the syntax structure we keep: - (quote-syntax ,(datum->syntax #f '... p))) - main))) - (let ([l in-order]) - (values - ;; Get list of unique vars: - (map mcar l) - ;; All ids, including duplicates: - (map mcdr l)))))) - - ;; apply-to-r creates an S-expression that applies - ;; rest to `r', but it also optimizes ((lambda (r) E) r) - ;; as simply E. - (-define (apply-to-r rest) - (if (and (pair? rest) - (eq? (car rest) 'lambda) - (equal? (cadr rest) '(r))) - (caddr rest) - `(,rest r))) - - ;; creates an S-expression that conses h and t, - ;; with optimizations. If h and t are quoted - ;; versions of the car and cdr of p, then return - ;; a quoted as the "optimization" --- one that - ;; is necessary to preserve the syntax wraps - ;; associated with p. - (-define (apply-cons stx h t p sub-gensym s-exp?) - (cond - [(and (pair? h) - (if s-exp? - (eq? (car h) 'quote) - (eq? (car h) 'quote-syntax)) - (eq? (cadr h) (stx-car p)) - (or (eq? t 'null) - (and - (pair? t) - (eq? (car t) (car h)) - (eq? (cadr t) (stx-cdr p))))) - `(,(if s-exp? 'quote 'quote-syntax) ,p)] - [(and (pair? t) - (eq? (car t) 'pattern-substitute)) - ;; fold h into the existing pattern-substitute: - (cond - [(and (pair? h) - (or (eq? (car h) 'quote-syntax) - (eq? (car h) 'quote)) - (eq? (cadr h) (stx-car p))) - ;; Just extend constant part: - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) - ,(let ([v (cons (cadr h) (cadadr t))]) - ;; We exploit the fact that we're - ;; building an S-expression to - ;; preserve the source's distinction - ;; between (x y) and (x . (y)). - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) - . ,(cddr t))] - [(and (pair? h) - (eq? (car t) #| = 'pattern-substitute |# (car h))) - ;; Combine two pattern substitutions: - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) - ,(let ([v (cons (cadadr h) (cadadr t))]) - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) - ,@(cddr h) ;; <-- WARNING: potential quadratic expansion - . ,(cddr t))] - [else - ;; General case: add a substitution: - (let* ([id (sub-gensym)] - [expr (cons id (cadadr t))] - [expr (if (syntax? stx) - (datum->syntax stx - expr - stx - stx - stx) - expr)]) - `(pattern-substitute - (,(if s-exp? 'quote 'quote-syntax) ,expr) - ,id ,h - . ,(cddr t)))])] - [(not s-exp?) - (cond - [(eq? t 'null) - (apply-cons stx h - `(pattern-substitute (quote-syntax ())) - p - sub-gensym - s-exp?)] - - [(and (pair? t) - (eq? (car t) 'quote-syntax) - (stx-smaller-than? (cdr t) 10)) - ;; Shift into `pattern-substitute' mode with an intitial constant. - ;; (Only do this for small constants, so we don't traverse - ;; big constants when looking for substitutions.) - (apply-cons stx h - `(pattern-substitute ,t) - p - sub-gensym - s-exp?)] - [else - ;; Shift into `pattern-substitute' with an initial substitution: - (apply-cons stx h - (let ([id (sub-gensym)]) - `(pattern-substitute (quote-syntax ,id) - ,id ,t)) - p - sub-gensym - s-exp?)])] - [else - ;; In S-expression mode, `cons' on, but collapse to `list' - ;; or `list*' if possible: - (cond - [(eq? t 'null) - (list 'list h)] - [(and (pair? t) - (eq? (car t) 'list)) - (list* 'list h (cdr t))] - [(and (pair? t) - (or (eq? (car t) 'list*) - (eq? (car t) 'cons))) - (list* 'list* h (cdr t))] - [else - (list 'cons h t)])])) - - (-define (stx-smaller-than? stx sz) - (sz . > . (stx-size stx (add1 sz)))) - - (-define (stx-size stx up-to) - (cond - [(up-to . < . 1) 0] - [(syntax? stx) (stx-size (syntax-e stx) up-to)] - [(pair? stx) (let ([s1 (stx-size (car stx) up-to)]) - (+ s1 (stx-size (cdr stx) (- up-to s1))))] - [(vector? stx) (stx-size (vector->list stx) up-to)] - [(struct? stx) (stx-size (struct->vector stx) up-to)] - [(box? stx) (add1 (stx-size (unbox stx) (sub1 up-to)))] - [else 1])) - - ;; Generates a list-ref expression; if use-tail-pos - ;; is not #f, then the argument list is really a list* - ;; (see the note under "Input Matcher") and in that case - ;; use-tail-pos is a number indicating the list-tail - ;; position of the last element - (-define (apply-list-ref e p use-tail-pos) - (cond - [(and use-tail-pos (= p use-tail-pos)) - (cond - [(eq? p 0) e] - [(eq? p 1) `(cdr ,e)] - [(eq? p 2) `(cddr ,e)] - [(eq? p 3) `(cdddr ,e)] - [(eq? p 4) `(cddddr ,e)] - [else `(list-tail ,e ,p)])] - [(eq? p 0) `(car ,e)] - [(eq? p 1) `(cadr ,e)] - [(eq? p 2) `(caddr ,e)] - [(eq? p 3) `(cadddr ,e)] - [else `(list-ref ,e ,p)])) - ;; Returns a list that nests a pattern variable as deeply as it ;; is ellipsed. Escaping ellipses are detected. (-define get-ellipsis-nestings @@ -978,72 +533,6 @@ (sub (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipses?)] [else '()])))) - ;; Checks whether the given nesting matches a nesting in the - ;; environment prototype, returning the prototype entry if it is - ;; found, and signaling an error otherwise. If the prototype - ;; entry should be unwrapped by one, it is, and the resulting - ;; prototype is paired with #f. Otherwise, the prototype is left - ;; alone and paired with #t. There may be multiple matches; in that - ;; case, prefer unwrapping to not unwrapping (because the other one - ;; must be for a different sub-template nuder a shared ellipsis). - (-define ellipsis-sub-env - (lambda (nesting proto-r src detail-src) - (let ([vs (map (lambda (proto) - (let ([start (if (pair? proto) - (car proto) - proto)]) - (let loop ([c start] [n nesting] [unwrap? (pair? proto)]) - (cond - [(and (pair? c) (pair? n)) - (loop (car c) (car n) #t)] - [(pair? n) - (loop c (car n) #f)] - [(and (syntax? c) (syntax? n)) - (if (bound-identifier=? c n) - (cons (if unwrap? start proto) - (not unwrap?)) - #f)] - [else #f])))) - proto-r)]) - (unless (ormap values vs) - (apply - raise-syntax-error - 'syntax - "too few ellipses for pattern variable in template" - (pick-specificity - src - (let loop ([n nesting]) - (if (syntax? n) - n - (loop (car n))))))) - (or (ormap (lambda (v) (and v (not (cdr v)) v)) vs) - (ormap values vs))))) - - (-define (extract-vars proto-r) - (map (lambda (i) - (let loop ([i i]) - (if (syntax? i) - i - (loop (car i))))) - proto-r)) - - ;; Checks that a variable is not in the prototype - ;; environment, and specifically not an ellipsed - ;; variable. - (-define (check-not-pattern ssym proto-r) - (for-each (lambda (p) - (when (pair? p) - (let loop ([l (car p)]) - (cond - [(syntax? l) - (when (bound-identifier=? l ssym) - (raise-syntax-error - 'syntax - "missing ellipsis with pattern variable in template" - ssym))] - [else (loop (car l))])))) - proto-r)) - ;; Tests if x is an ellipsing pattern of the form ;; (blah ... . blah2) (-define (ellipsis? x) @@ -1067,77 +556,6 @@ (loop (cdr nestings))) (loop (cdr nestings)))))) - ;; Determines whether any ellipsis has multiple pattern - ;; variables so that a run-time check on the pattern-variable - ;; matching length will be needed - (-define (multiple-ellipsis-vars? p proto-r) - (let loop ([p p]) - (cond - [(ellipsis? p) - (or (eq? 'multi (multiple-pattern-vars (stx-car p) proto-r)) - (loop (stx-cdr (stx-cdr p))))] - [(stx-pair? p) - (let ([hd (stx-car p)]) - (if (and (identifier? hd) - (...? hd)) - #f - (or (loop hd) - (loop (stx-cdr p)))))] - [(stx-vector? p #f) - (loop (vector->list (syntax-e p)))] - [(stx-box? p) - (loop (unbox (syntax-e p)))] - [(and (syntax? p) - (prefab-struct-key (syntax-e p))) - (loop (cdr (vector->list (struct->vector (syntax-e p)))))] - [else #f]))) - - ;; Determines whether a given expression, which is under ellipses, - ;; has multiple pattern variables or the same variable at different - ;; depths; returns 'multi if so, some other internal accumulator otherwise - (-define (multiple-pattern-vars p proto-r) - (let loop ([p p] [use-ellipsis? #t] [depth 0] [found #f]) - (cond - [(identifier? p) - (if (ormap (lambda (l) - (and - (pair? l) ;; only need to track repeats - (let loop ([l l]) - (cond - [(syntax? l) - (bound-identifier=? l p)] - [else (loop (car l))])))) - proto-r) - (cond - [(not found) (cons p depth)] - [(and (bound-identifier=? p (car found)) - (= depth (cdr found))) - found] - [else 'multi]) - found)] - [(and use-ellipsis? (ellipsis? p)) - (let ([new-found (loop (stx-car p) #t (add1 depth) found)]) - (if (eq? new-found 'multi) - new-found - (loop (stx-cdr (stx-cdr p)) #t depth new-found)))] - [(stx-pair? p) - (let ([hd (stx-car p)]) - (if (and (identifier? hd) - (...? hd)) - (loop (stx-cdr p) #f depth found) - (let ([new-found (loop (stx-car p) #t depth found)]) - (if (eq? new-found 'multi) - new-found - (loop (stx-cdr p) #t depth new-found)))))] - [(stx-vector? p #f) - (loop (vector->list (syntax-e p)) use-ellipsis? depth found)] - [(stx-box? p) - (loop (unbox (syntax-e p)) use-ellipsis? depth found)] - [(and (syntax? p) - (prefab-struct-key (syntax-e p))) - (loop (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipsis? depth found)] - [else found]))) - (-define (no-ellipses? stx) (cond [(stx-pair? stx) @@ -1188,7 +606,6 @@ (s-exp-mapping-ref (set!-transformer-procedure v) 1)) (#%provide (protect make-match&env get-match-vars make-interp-match - make-pexpand make-syntax-mapping syntax-pattern-variable? syntax-mapping-depth syntax-mapping-valvar make-s-exp-mapping s-exp-pattern-variable? diff -Nru racket-6.12+ppa1/collects/racket/private/sort.rkt racket-7.0+ppa1/collects/racket/private/sort.rkt --- racket-6.12+ppa1/collects/racket/private/sort.rkt 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/sort.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,8 +17,7 @@ number of elements.) The source uses macros to optimize some common cases (eg, no `getkey' -function, or precompiled versions with inlinable common comparison -predicates) -- they are local macros so they're not left in the compiled +function) -- they are local macros so they're not left in the compiled code. |# @@ -151,34 +150,6 @@ (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-)) (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))) - ;; - - - - - - - - - - - - - - - - - - - - - - - - - ;; Precompiling of standard comparison functions - ;; for standard data types - ;; - - - - - - - - - - - - - - - - - - - - - - - - - (define precompiled-sorts - (let ([sorts (make-hasheq)]) - (define-syntax-rule (precomp less-than? more ...) - (let ([sort-proc - (λ (A n) (sort-internal-body A less-than? n #f))]) - (hash-set! sorts less-than? sort-proc) - (hash-set! sorts more sort-proc) ...)) - ;; for comparison ops provided by racket/base we build - ;; fast precompiled versions - (precomp unsafe-fl< unsafe-fl<=) - (precomp unsafe-fl> unsafe-fl>=) - (precomp i< i<=) - (precomp i> i>=) - (precomp < <=) - (precomp > >=) - (precomp string? string>=?) - (precomp string-ci? string-ci>=?) - (precomp char? char>=?) - (precomp keywordstr x) (if (bytes? x) (bytes->string/utf-8 x) x)) - (define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x))) - (define-syntax-rule (tweak unwrap wrap convert) - (let ([tweaked (tweaker (unwrap rx) n)]) - ;; the tweaker is allowed to return a regexp - (if (or (regexp? tweaked) (byte-regexp? tweaked)) - tweaked - (wrap (convert tweaked))))) - (define (run-tweak) - (cond [(pregexp? rx) (tweak object-name pregexp ->str)] - [(regexp? rx) (tweak object-name regexp ->str)] - [(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)] - [(byte-regexp? rx) (tweak object-name byte-regexp ->bts)] - ;; allow getting a string, so if someone needs to go - ;; from a string to a regexp, there's no penalty - ;; because of the intermediate regexp being recreated - [(string? rx) (tweak (lambda (x) x) regexp ->str)] - [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] - [else (raise-argument-error - 'regexp-tweaker - "(or/c regexp? byte-regexp? string? bytes?)" - rx)])) - (let ([key (cons n rx)]) - (or (hash-ref t key #f) - (let ([rx* (run-tweak)]) (hash-set! t key rx*) rx*)))))) + (define no-empty-edge-table (make-hash)) + (define (no-empty-edge-matches rx n) + (define (tweaker rx n) + (if (bytes? rx) + (bytes-append #"(?:" rx #")(?<=" + (make-bytes n (char->integer #\.)) #")") + (format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.))))) + (define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x)) + (define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x))) + (define-syntax-rule (tweak unwrap wrap convert) + (let ([tweaked (tweaker (unwrap rx) n)]) + ;; the tweaker is allowed to return a regexp + (if (or (regexp? tweaked) (byte-regexp? tweaked)) + tweaked + (wrap (convert tweaked))))) + (define (run-tweak) + (cond [(pregexp? rx) (tweak object-name pregexp ->str)] + [(regexp? rx) (tweak object-name regexp ->str)] + [(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)] + [(byte-regexp? rx) (tweak object-name byte-regexp ->bts)] + ;; allow getting a string, so if someone needs to go + ;; from a string to a regexp, there's no penalty + ;; because of the intermediate regexp being recreated + [(string? rx) (tweak (lambda (x) x) regexp ->str)] + [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] + [else (raise-argument-error + 'regexp-tweaker + "(or/c regexp? byte-regexp? string? bytes?)" + rx)])) + (let ([key (cons n rx)]) + (or (hash-ref no-empty-edge-table key #f) + (let ([rx* (run-tweak)]) (hash-set! no-empty-edge-table key rx*) rx*)))) (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f] [prefix #""]) @@ -112,13 +114,7 @@ ;; Helper macro for the regexp functions below, with some utilities. (define (bstring-length s) (if (bytes? s) (bytes-length s) (string-length s))) - (define no-empty-edge-matches - (make-regexp-tweaker - (lambda (rx n) - (if (bytes? rx) - (bytes-append #"(?:" rx #")(?<=" - (make-bytes n (char->integer #\.)) #")") - (format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.))))))) + (define-syntax-rule (regexp-loop name loop start end pattern string ipre success-choose failure-k diff -Nru racket-6.12+ppa1/collects/racket/private/stxcase.rkt racket-7.0+ppa1/collects/racket/private/stxcase.rkt --- racket-6.12+ppa1/collects/racket/private/stxcase.rkt 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/stxcase.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,130 +5,7 @@ (#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe "ellipses.rkt" (for-syntax "stx.rkt" "small-scheme.rkt" - "member.rkt" "sc.rkt" '#%kernel)) - - (-define (datum->syntax/shape orig datum) - (if (syntax? datum) - datum - ;; Keeps 'paren-shape and any other properties: - (datum->syntax orig datum orig orig))) - - (-define (catch-ellipsis-error thunk sexp sloc) - ((let/ec esc - (with-continuation-mark - exception-handler-key - (lambda (exn) - (esc - (lambda () - (if (exn:break? exn) - (raise exn) - (raise-syntax-error - 'syntax - "incompatible ellipsis match counts for template" - sexp - sloc))))) - (let ([v (thunk)]) - (lambda () v)))))) - - (-define substitute-stop 'dummy) - - ;; pattern-substitute optimizes a pattern substitution by - ;; merging variables that look up the same simple mapping - (-define-syntax pattern-substitute - (lambda (stx) - (let ([pat (stx-car (stx-cdr stx))] - [subs (stx->list (stx-cdr (stx-cdr stx)))]) - (let ([ht-common (make-hash)] - [ht-map (make-hasheq)]) - ;; Determine merges: - (let loop ([subs subs]) - (unless (null? subs) - (let ([id (syntax-e (car subs))] - [expr (cadr subs)]) - (when (or (identifier? expr) - (and (stx-pair? expr) - (memq (syntax-e (stx-car expr)) - '(car cadr caddr cadddr - cdr cddr cdddr cddddr - list-ref list-tail)) - (stx-pair? (stx-cdr expr)) - (identifier? (stx-car (stx-cdr expr))))) - (let ([s-expr (syntax->datum expr)]) - (let ([new-id (hash-ref ht-common s-expr #f)]) - (if new-id - (hash-set! ht-map id new-id) - (hash-set! ht-common s-expr id)))))) - (loop (cddr subs)))) - ;; Merge: - (let ([new-pattern (if (zero? (hash-count ht-map)) - pat - (let loop ([stx pat]) - (cond - [(pair? stx) - (let ([a (loop (car stx))] - [b (loop (cdr stx))]) - (if (and (eq? a (car stx)) - (eq? b (cdr stx))) - stx - (cons a b)))] - [(symbol? stx) - (let ([new-id (hash-ref ht-map stx #f)]) - (or new-id stx))] - [(syntax? stx) - (let ([new-e (loop (syntax-e stx))]) - (if (eq? (syntax-e stx) new-e) - stx - (datum->syntax stx new-e stx stx)))] - [(vector? stx) - (list->vector (map loop (vector->list stx)))] - [(box? stx) (box (loop (unbox stx)))] - [else stx])))]) - (datum->syntax (quote-syntax here) - `(apply-pattern-substitute - ,new-pattern - (quote ,(let loop ([subs subs]) - (cond - [(null? subs) null] - [(hash-ref ht-map (syntax-e (car subs)) #f) - ;; Drop mapped id - (loop (cddr subs))] - [else - (cons (car subs) (loop (cddr subs)))]))) - . ,(let loop ([subs subs]) - (cond - [(null? subs) null] - [(hash-ref ht-map (syntax-e (car subs)) #f) - ;; Drop mapped id - (loop (cddr subs))] - [else - (cons (cadr subs) (loop (cddr subs)))]))) - stx)))))) - - (-define apply-pattern-substitute - (lambda (stx sub-ids . sub-vals) - (let loop ([stx stx]) - (cond - [(pair? stx) (let ([a (loop (car stx))] - [b (loop (cdr stx))]) - (if (and (eq? a (car stx)) - (eq? b (cdr stx))) - stx - (cons a b)))] - [(symbol? stx) - (let sloop ([sub-ids sub-ids][sub-vals sub-vals]) - (cond - [(null? sub-ids) stx] - [(eq? stx (car sub-ids)) (car sub-vals)] - [else (sloop (cdr sub-ids) (cdr sub-vals))]))] - [(syntax? stx) - (let ([new-e (loop (syntax-e stx))]) - (if (eq? (syntax-e stx) new-e) - stx - (datum->syntax/shape stx new-e)))] - [(vector? stx) - (list->vector (map loop (vector->list stx)))] - [(box? stx) (box (loop (unbox stx)))] - [else stx])))) + "gen-temp.rkt" "member.rkt" "sc.rkt" '#%kernel)) (-define interp-match (lambda (pat e literals immediate=?) @@ -502,103 +379,6 @@ m))))]))) x))))))) - (begin-for-syntax - (define-values (gen-template) - (lambda (x s-exp?) - (-define here-stx (quote-syntax here)) - (unless (and (stx-pair? x) - (let ([rest (stx-cdr x)]) - (and (stx-pair? rest) - (stx-null? (stx-cdr rest))))) - (raise-syntax-error - #f - "bad form" - x)) - (syntax-arm - (datum->syntax - here-stx - (let ([pattern (stx-car (stx-cdr x))]) - (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)]) - (let ([var-bindings - (map - (lambda (var) - (and (let ([v (syntax-local-value var (lambda () #f))]) - (and (if s-exp? - (s-exp-pattern-variable? v) - (syntax-pattern-variable? v)) - v)))) - unique-vars)]) - (if (and (or (null? var-bindings) - (not (ormap (lambda (x) x) var-bindings))) - (no-ellipses? pattern)) - ;; Constant template: - (list (if s-exp? - (quote-syntax quote) - (quote-syntax quote-syntax)) - pattern) - ;; Non-constant: - (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings]) - (if (null? bindings) - null - (let ([rest (loop (cdr vars) - (cdr bindings))]) - (if (car bindings) - (cons (let loop ([v (car vars)] - [d (if s-exp? - (s-exp-mapping-depth (car bindings)) - (syntax-mapping-depth (car bindings)))]) - (if (zero? d) - v - (loop (list v) (sub1 d)))) - rest) - rest))))] - [non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings]) - (if (null? bindings) - null - (let ([rest (loop (cdr vars) - (cdr bindings))]) - (if (car bindings) - rest - (cons (car vars) rest)))))]) - (let ([build-from-template - ;; Even if we don't use the builder, we need to check - ;; for a well-formed pattern: - (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)] - [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss]) - (cond - [(null? bindings) null] - [(car bindings) - (cons - (syntax-property - (let ([id (if s-exp? - (s-exp-mapping-valvar (car bindings)) - (syntax-mapping-valvar (car bindings)))]) - (datum->syntax - id - (syntax-e id) - x)) - 'disappeared-use - (map syntax-local-introduce (car all-varss))) - (loop (cdr vars) (cdr bindings) (cdr all-varss)))] - [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))]) - (if (identifier? pattern) - ;; Simple syntax-id lookup: - (car r) - ;; General case: - (list (datum->syntax - here-stx - build-from-template - pattern) - (let ([len (length r)]) - (cond - [(zero? len) (quote-syntax ())] - [(= len 1) (car r)] - [else - (cons (quote-syntax list*) r)])))))))))) - x))))) - - (-define-syntax syntax (lambda (stx) (gen-template stx #f))) - (-define-syntax datum (lambda (stx) (gen-template stx #t))) - - (#%provide (all-from "ellipses.rkt") syntax-case** syntax datum + (#%require "template.rkt") + (#%provide (all-from "ellipses.rkt") syntax-case** syntax syntax/loc datum (for-syntax syntax-pattern-variable?))) diff -Nru racket-6.12+ppa1/collects/racket/private/stxloc.rkt racket-7.0+ppa1/collects/racket/private/stxloc.rkt --- racket-6.12+ppa1/collects/racket/private/stxloc.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/stxloc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -35,28 +35,6 @@ [(sc stxe kl . clause) (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)]))) - (-define (relocate loc stx) - (if (or (syntax-source loc) - (syntax-position loc)) - (datum->syntax stx - (syntax-e stx) - loc - stx) - stx)) - - ;; Like syntax, but also takes a syntax object - ;; that supplies a source location for the - ;; resulting syntax object. - (-define-syntax syntax/loc - (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? #f - [(_ loc pattern) - (if (if (symbol? (syntax-e #'pattern)) - (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) - #f) - (syntax (syntax pattern)) - (syntax (relocate loc (syntax pattern))))]))) - (-define-syntax quote-syntax/prune (lambda (stx) (syntax-case** #f #t stx () free-identifier=? #f @@ -77,4 +55,5 @@ stx #'id))]))) - (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _)) + (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case + ... _ ~? ~@)) diff -Nru racket-6.12+ppa1/collects/racket/private/stxparamkey.rkt racket-7.0+ppa1/collects/racket/private/stxparamkey.rkt --- racket-6.12+ppa1/collects/racket/private/stxparamkey.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/stxparamkey.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,116 +2,107 @@ (module stxparamkey '#%kernel (#%require "small-scheme.rkt" "define.rkt" "stxcase.rkt" "stxloc.rkt" "with-stx.rkt") - - (-define-struct wrapped-renamer (renamer)) - - (define-values (struct:parameter-binding make-parameter-binding parameter-binding? parameter-binding-ref parameter-binding-set!) - (make-struct-type 'parameter-binding #f 2 0 #f null (current-inspector) #f '(0 1))) - (define parameter-binding-val (make-struct-field-accessor parameter-binding-ref 0)) - (define parameter-binding-param (make-struct-field-accessor parameter-binding-ref 1)) - - (define (parameter-binding-rt-target pbr) - (rename-transformer-target (wrapped-renamer-renamer (parameter-binding-val pbr)))) - (define-values (struct:parameter-binding-rt make-parameter-binding-rt parameter-binding-rt? parameter-binding-rt-ref parameter-binding-rt-set!) - (make-struct-type 'parameter-binding-rt struct:parameter-binding 0 0 #f (list (cons prop:rename-transformer parameter-binding-rt-target)) (current-inspector) #f)) - + ;; Consulted before the expander's table, for use by compile-time + ;; code wrapped by a run-time-phased `syntax-parameterize`: + (define current-parameter-environment (make-parameter #hasheq())) + + ;; Wrap the value for a syntax parameter in a `parameter-value` struct, + ;; so that we can distinguish it from rename transformers that arrive + ;; at the value + (define-values (struct:parameter-value make-parameter-value parameter-value? parameter-value-ref parameter-value-set!) + (make-struct-type 'parameter-value #f 1 0 #f null (current-inspector) #f '(0))) + (define parameter-value-content (make-struct-field-accessor parameter-value-ref 0)) + + (define (wrap-parameter-value who/must-be-transformer v) + (unless (or (not who/must-be-transformer) (rename-transformer? v)) + (raise-argument-error who/must-be-transformer + "rename-transformer?" + v)) + (make-parameter-value v)) + + (define (extend-parameter-environment env binds) + (with-syntax ([((key sp-id) ...) binds]) + (let loop ([ht (current-parameter-environment)] + [keys (syntax->datum #'(key ...))] + [ids (syntax->list #'(sp-id ...))]) + (cond + [(null? keys) ht] + [else (loop (hash-set ht (car keys) (car ids)) + (cdr keys) + (cdr ids))])))) + + ;; Used to propagate to a submodule, where the parameter + ;; will get a frash key as the submodule compilation starts + (define (update-parameter-keys ids binds) + (let loop ([ids (syntax->list ids)] + [binds (syntax->list binds)]) + (cond + [(null? ids) null] + [else + (with-syntax ([(key rhs) (car binds)] + [new-key (syntax-parameter-key (syntax-local-value (car ids)))]) + (cons #'[new-key rhs] + (loop (cdr ids) (cdr binds))))]))) + + (define (apply-syntax-parameter sp stx) + (let ([v (syntax-parameter-key-value (syntax-parameter-key sp) + (syntax-parameter-default-id sp))]) + (apply-transformer v stx #'set!))) + (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!) - (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0 '(0 1))) + (make-struct-type 'syntax-parameter #f 2 0 #f (list (cons prop:set!-transformer apply-syntax-parameter)) (current-inspector) 0 '(0 1))) + + (define (syntax-parameter-default-id sp) + (syntax-parameter-ref sp 0)) + + (define (syntax-parameter-key sp) + (syntax-parameter-ref sp 1)) (define (rename-transformer-parameter-target rtp) - (define t (syntax-parameter-target rtp)) - ;; XXX (syntax-transforming?) is not always true when the - ;; prop:rename-transformer procedure is evaluated. I think this is - ;; because it used to test rename-transformer? + (define key (syntax-parameter-key rtp)) + (define default-id (syntax-parameter-default-id rtp)) + ;; (syntax-transforming?) is not always true when the + ;; prop:rename-transformer procedure is evaluated, because it is + ;; used to test the rename-transformer (define lt (if (syntax-transforming?) - (syntax-local-get-shadower t #t) - t)) + (rename-transformer-target (syntax-parameter-key-value key default-id)) + default-id)) (syntax-property lt 'not-free-identifier=? #t)) (define-values (struct:rename-transformer-parameter make-rename-transformer-parameter rename-transformer-parameter? rename-transformer-parameter-ref rename-transformer-parameter-set!) (make-struct-type 'rename-transformer-parameter struct:syntax-parameter 0 0 #f (list (cons prop:rename-transformer rename-transformer-parameter-target)) (current-inspector) #f)) - (define (syntax-parameter-target sp) - (syntax-parameter-ref sp 1)) - - ;; If it is a rename-transformer-parameter, then we need to get the - ;; parameter and not what it points to, otherwise, we can keep - ;; going. + (define (syntax-parameter-key-value key default-id) + (define id (hash-ref + (current-parameter-environment) + key + (lambda () #f))) + (let loop ([id (or id default-id)]) + (define-values (val next-id) (syntax-local-value/immediate id (lambda () (values #f #f)))) + (cond + [(parameter-value? val) (parameter-value-content val)] + [next-id + ;; Some part of expansion introduced a rename transformer + ;; between our identifier and its binding + (loop next-id)] + [else val]))) + (define (syntax-parameter-local-value id) - (let*-values - ([(rt* rt-target) - (syntax-local-value/immediate id (lambda () (values #f #f)))] - [(rt) (if (syntax-parameter? rt*) - rt* - (or (and rt-target - (syntax-local-value rt-target - (λ () rt-target))) - rt*))] - [(sp) (if (set!-transformer? rt) - (set!-transformer-procedure rt) - rt)]) - sp)) - - (define (syntax-parameter-local-value-pre id) - (define-values (rt* rt-target) - (syntax-local-value/immediate id (λ () (values #f #f)))) - (cond - [(not rt-target) - rt*] - [(syntax-parameter? rt*) - rt-target] - [(parameter-binding? rt*) - rt*] - [else - (syntax-parameter-local-value-pre rt-target)])) - - (define (syntax-parameter-local-value-for-parameter target) - (or (syntax-parameter-local-value-pre (syntax-local-get-shadower target #t)) - (syntax-parameter-local-value-pre target))) - - (define (target-value target) - (syntax-local-value (syntax-local-get-shadower target #t) - (lambda () - (syntax-local-value - target - (lambda () #f))))) - - (define (syntax-parameter-target-value target) - (let* ([v (target-value target)] - [v (if (parameter-binding? v) - (or (let ([id ((parameter-binding-param v))]) - (and id - (let ([v (syntax-local-value id)]) - (parameter-binding-val v)))) - (parameter-binding-val v)) - v)]) - (if (wrapped-renamer? v) - (wrapped-renamer-renamer v) - v))) - - (define (syntax-parameter-target-parameter target) - (let ([v (syntax-parameter-local-value-for-parameter target)]) - (parameter-binding-param v))) - - (define (convert-renamer must-be-renamer?-stx v) - (when must-be-renamer?-stx - (unless (rename-transformer? v) - (raise-syntax-error #f "rename-transformer-parameter must be bound to rename-transformer" must-be-renamer?-stx))) - ((if must-be-renamer?-stx - make-parameter-binding-rt - make-parameter-binding) - (if (rename-transformer? v) - (make-wrapped-renamer v) - v) - ;; compile-time parameter needed for `splicing-syntax-parameterize': - (make-parameter #f))) + (let loop ([id id]) + (define-values (sp next-id) (syntax-local-value/immediate id (lambda () (values #f #f)))) + (cond + [(syntax-parameter? sp) sp] + [next-id + ;; Might be a rename of a syntax-parameter binding + (loop next-id)] + [else #f]))) (define (apply-transformer v stx set!-stx) (cond [(rename-transformer? v) - (with-syntax ([target (rename-transformer-target v)]) + (with-syntax ([target (rename-transformer-target v)]) (syntax-case stx () [(set! id _expr) (free-identifier=? #'set! set!-stx) @@ -143,14 +134,16 @@ stx #f)])) - - (#%provide convert-renamer + (#%provide wrap-parameter-value + current-parameter-environment + extend-parameter-environment + update-parameter-keys apply-transformer syntax-parameter? make-syntax-parameter rename-transformer-parameter? make-rename-transformer-parameter syntax-parameter-local-value - syntax-parameter-target - syntax-parameter-target-value - syntax-parameter-target-parameter)) + syntax-parameter-key + syntax-parameter-default-id + syntax-parameter-key-value)) diff -Nru racket-6.12+ppa1/collects/racket/private/stxparam.rkt racket-7.0+ppa1/collects/racket/private/stxparam.rkt --- racket-6.12+ppa1/collects/racket/private/stxparam.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/stxparam.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,15 +4,17 @@ (for-syntax '#%kernel "stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt" + "more-scheme.rkt" "stxloc.rkt" "stxparamkey.rkt")) - (#%provide (for-syntax do-syntax-parameterize)) + (#%provide (for-syntax do-syntax-parameterize) + let-local-keys) - (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok? keep-orig?) + (define-for-syntax (do-syntax-parameterize stx letrec-syntaxes-id empty-body-ok? keep-ids?) (syntax-case stx () - [(_ ([id val] ...) body ...) + [(-syntax-parameterize ([id val] ...) body ...) (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([((gen-id must-be-renamer?) ...) + (with-syntax ([((gen-id local-key who/must-be-renamer) ...) (map (lambda (id) (unless (identifier? id) (raise-syntax-error @@ -28,10 +30,10 @@ stx id)) (list - (syntax-local-get-shadower - (syntax-local-introduce (syntax-parameter-target sp)) - #t) - (rename-transformer-parameter? sp)))) + (car (generate-temporaries '(stx-param))) + (syntax-parameter-key sp) + (and (rename-transformer-parameter? sp) + #'-syntax-parameterize)))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup @@ -46,15 +48,29 @@ #f "missing body expression(s)" stx))) - (with-syntax ([let-syntaxes let-syntaxes-id] - [(orig ...) (if keep-orig? - (list ids) - #'())]) + (with-syntax ([letrec-syntaxes letrec-syntaxes-id] + [(kept-id ...) (if keep-ids? + #'(id ...) + '())]) (syntax/loc stx - (let-syntaxes ([(gen-id) - (convert-renamer - (if must-be-renamer? (quote-syntax val) #f) - val)] - ...) - orig ... - body ...)))))]))) + (letrec-syntaxes ([(gen-id) (wrap-parameter-value 'who/must-be-renamer val)] + ...) + kept-id ... + (let-local-keys ([local-key gen-id] ...) + body ...))))))])) + + (define-syntax (let-local-keys stx) + (if (eq? 'expression (syntax-local-context)) + (let-values ([(expr opaque-expr) + (syntax-case stx () + [(_ ([local-key id] ...) body ...) + (parameterize ([current-parameter-environment + (extend-parameter-environment + (current-parameter-environment) + #'([local-key id] ...))]) + (syntax-local-expand-expression + #'(let-values () body ...) + #t))])]) + opaque-expr) + (with-syntax ([stx stx]) + #'(#%expression stx))))) diff -Nru racket-6.12+ppa1/collects/racket/private/stx.rkt racket-7.0+ppa1/collects/racket/private/stx.rkt --- racket-6.12+ppa1/collects/racket/private/stx.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/stx.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,7 @@ ;; basic syntax utilities (module stx '#%kernel - + (#%declare #:cross-phase-persistent) ;; These utilities facilitate operations on syntax objects. ;; A syntax object that represents a parenthesized sequence ;; can contain a mixture of cons cells and syntax objects, @@ -197,18 +197,6 @@ (loop s))]) (values pre post (= m n))))) - (define-values (intro) #f) - (define-values (gen-temp-id) - ;; Even though we gensym, using an introducer helps the - ;; syntax system simplify renamings that can't apply - ;; to other identifiers (when the generated identifier - ;; is used as a binding id) - (lambda (pfx) - (if intro - (void) - (set! intro (make-syntax-introducer))) - (intro (datum->syntax #f (gensym pfx))))) - (#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list? stx-car stx-cdr stx->list stx-vector? stx-vector-ref @@ -216,5 +204,4 @@ stx-prefab? stx-check/esc cons/#f append/#f stx-rotate stx-rotate* - split-stx-list - gen-temp-id)) + split-stx-list)) diff -Nru racket-6.12+ppa1/collects/racket/private/template.rkt racket-7.0+ppa1/collects/racket/private/template.rkt --- racket-6.12+ppa1/collects/racket/private/template.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/template.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,727 @@ +(module template '#%kernel +(#%require "stx.rkt" "small-scheme.rkt" "performance-hint.rkt" + (rename "small-scheme.rkt" define -define) + (rename "small-scheme.rkt" define-syntax -define-syntax) + "ellipses.rkt" + (for-syntax "stx.rkt" "small-scheme.rkt" + (rename "small-scheme.rkt" define -define) + (rename "small-scheme.rkt" define-syntax -define-syntax) + "member.rkt" "sc.rkt" '#%kernel)) +(#%provide syntax + syntax/loc + datum + ~? ~@ + ~@! signal-absent-pvar + (protect + (for-syntax attribute-mapping + attribute-mapping? + attribute-mapping-name + attribute-mapping-var + attribute-mapping-depth + attribute-mapping-check + metafunction metafunction?))) + +;; ============================================================ +;; Syntax of templates + +;; A Template (T) is one of: +;; - pattern-variable +;; - constant (including () and non-pvar identifiers) +;; - (metafunction . T) +;; - (H . T) +;; - (H ... . T), (H ... ... . T), etc +;; - (... T) -- escapes inner ..., ~?, ~@ +;; - (~? T T) +;; - #(T*) -- actually, vector->list interpreted as T +;; - #s(prefab-struct-key T*) -- likewise + +;; A HeadTemplate (H) is one of: +;; - T +;; - (~? H) +;; - (~? H H) +;; - (~@ . T) + +(define-syntax ~@! #f) ;; private, escape-ignoring version of ~@, used by unsyntax-splicing + +;; ============================================================ +;; Compile-time + +;; Parse template syntax into a Guide (AST--the name is left over from +;; when the "guide" was a data structure interpreted at run time). + +;; The AST representation is designed to coincide with the run-time +;; support, so compilation is just (datum->syntax #'here guide). The +;; variants listed below are the ones recognized and treated specially +;; by other functions (eg optimize-resyntax, relocate-guide). + +;; A Guide (G) is one of: +;; - (list 't-resyntax Expr Expr G) +;; - (list 't-const Expr) ;; constant +;; - (list 't-var Id) ;; trusted pattern variable +;; - (list 't-list G ...) +;; - (list 't-list* G ... G) +;; - (list 't-append HG G) +;; - (list 't-orelse G G) +;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions +;; -- where Subst = Nat ;; replace nth car with arg +;; | 'tail Nat ;; replace nth cdr with arg +;; | 'append Nat ;; replace nth car by appending arg +;; | 'recur Nat ;; replace nth car by recurring on it with arg +;; - other expression (must be pair!) + +;; A HeadGuide (HG) is one of: +;; - (list 'h-t G) +;; - other expression (must be pair!) + +;; A PVar is (pvar Id Id Id/#f Nat/#f) +;; +;; The first identifier (var) is from the syntax-mapping or attribute-binding. +;; The second (lvar) is a local variable name used to hold its value (or parts +;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a +;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see +;; below) if it needs to be checked. +;; +;; The depth-delta associated with a depth>0 pattern variable is the difference +;; between the pattern variable's depth and the depth at which it is used. (For +;; depth 0 pvars, it's #f.) For example, in +;; +;; (with-syntax ([x #'0] +;; [(y ...) #'(1 2)] +;; [((z ...) ...) #'((a b) (c d))]) +;; (template (((x y z) ...) ...))) +;; +;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta +;; for z is 0. The depth-delta (or depth "delay") is also the depth of the +;; ellipsis form where the variable begins to be iterated over. That is, the +;; template above should be interpreted roughly as +;; +;; (let ([Lx (pvar-value-of x)] +;; [Ly (pvar-value-of y)] +;; [Lz (pvar-value-of z)]) +;; (for/list ([Lz (in-list Lz)]) ;; depth 0 +;; (for/list ([Ly (in-list Ly)] ;; depth 1 +;; [Lz (in-list Lz)]) +;; (___ Lx Ly Lz ___)))) + +(begin-for-syntax + + (define here-stx (quote-syntax here)) + + (define template-logger (make-logger 'template (current-logger))) + + ;; (struct pvar (var lvar check dd) #:prefab) + (define-values (struct:pv pvar pvar? pvar-ref pvar-set!) + (make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3))) + (define (pvar-var pv) (pvar-ref pv 0)) + (define (pvar-lvar pv) (pvar-ref pv 1)) + (define (pvar-check pv) (pvar-ref pv 2)) + (define (pvar-dd pv) (pvar-ref pv 3)) + + ;; An Attribute is an identifier statically bound to a syntax-mapping + ;; (see sc.rkt) whose valvar is an identifier statically bound to an + ;; attribute-mapping. + + ;; (struct attribute-mapping (var name depth check) ...) + ;; check : #f (trusted) or Id, ref to Checker + ;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) ) + (define-values (struct:attribute-mapping attribute-mapping attribute-mapping? + attribute-mapping-ref _attribute-mapping-set!) + (make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector) + (lambda (self stx) + (if (attribute-mapping-check self) + (let ([source-name + (or (let loop ([p (syntax-property stx 'disappeared-use)]) + (cond [(identifier? p) p] + [(pair? p) (or (loop (car p)) (loop (cdr p)))] + [else #f])) + (attribute-mapping-name self))]) + (define code + `(,(attribute-mapping-check self) + ,(attribute-mapping-var self) + ,(attribute-mapping-depth self) + #t + (quote-syntax ,source-name))) + (datum->syntax here-stx code stx)) + (attribute-mapping-var self))))) + (define (attribute-mapping-var a) (attribute-mapping-ref a 0)) + (define (attribute-mapping-name a) (attribute-mapping-ref a 1)) + (define (attribute-mapping-depth a) (attribute-mapping-ref a 2)) + (define (attribute-mapping-check a) (attribute-mapping-ref a 3)) + + ;; (struct metafunction (var)) + (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!) + (make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector))) + (define (metafunction-var mf) (metafunction-ref mf 0)) + + (define (ht-guide? x) + (if (and (pair? x) (eq? (car x) 'h-t)) #t #f)) + (define (ht-guide-t x) + (if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f)) + + (define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list)))) + (define (const-guide-v x) + (if (eq? (car x) 't-list) + null + (let ([e (cadr x)]) + (if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e))))) + + (define (cons-guide g1 g2) + (cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))] + [(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))] + [else (list 't-list* g1 g2)])) + + ;; ---------------------------------------- + ;; Parsing templates + + ;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id)) + (define (parse-template ctx t stx?) + ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] + (define env (make-hasheq)) + + ;; wrong-syntax : Syntax Format-String Any ... -> (error) + (define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x)) + + ;; disappeared-uses : (Listof Id) + (define disappeared-uses null) + ;; disappeared! : Id -> Void + (define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses))) + + ;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide) + (define (parse-t t depth esc?) + (cond [(stx-pair? t) + (if (identifier? (stx-car t)) + (parse-t-pair/command t depth esc?) + (parse-t-pair/dots t depth esc?))] + [else (parse-t-nonpair t depth esc?)])) + + ;; parse-t-pair/command : Stx Nat Boolean -> ... + ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) + (define (parse-t-pair/command t depth esc?) + (cond [esc? + (parse-t-pair/dots t depth esc?)] + [(parse-form t (quote-syntax ...) 1) + => (lambda (t) + (disappeared! (car t)) + (define-values (drivers guide) (parse-t (cadr t) depth #t)) + ;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _) + (values drivers `(t-escaped ,guide)))] + [(parse-form t (quote-syntax ~?) 2) + => (lambda (t) + (disappeared! (car t)) + (define t1 (cadr t)) + (define t2 (caddr t)) + (define-values (drivers1 guide1) (parse-t t1 depth esc?)) + (define-values (drivers2 guide2) (parse-t t2 depth esc?)) + (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] + [(lookup-metafun (stx-car t)) + => (lambda (mf) + (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported")) + (disappeared! (stx-car t)) + (define-values (drivers guide) (parse-t (stx-cdr t) depth esc?)) + (values drivers + `(t-metafun ,(metafunction-var mf) ,guide + (quote-syntax + ,(let ([tstx (and (syntax? t) t)]) + (datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))] + [else (parse-t-pair/dots t depth esc?)])) + + ;; parse-t-pair/dots : Stx Nat Boolean -> ... + ;; t is a stx pair; check for dots + (define (parse-t-pair/dots t depth esc?) + (define head (stx-car t)) + (define-values (tail nesting) + (let loop ([tail (stx-cdr t)] [nesting 0]) + (if (and (not esc?) (stx-pair? tail) + (let ([x (stx-car tail)]) + (and (identifier? x) (free-identifier=? x (quote-syntax ...))))) + (begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting))) + (values tail nesting)))) + (if (zero? nesting) + (parse-t-pair/normal t depth esc?) + (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] + [(tdrivers tguide) (parse-t tail depth esc?)]) + (when (dset-empty? hdrivers) + (wrong-syntax head "no pattern variables before ellipsis in template")) + (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) + (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one + (stx-car (stx-drop nesting t))]) + ;; FIXME: improve error message? + (wrong-syntax bad-dots "too many ellipses in template"))) + ;; hdrivers is (listof (dsetof pvar)) + (define hdriverss ;; per level + (let loop ([i 0]) + (if (< i nesting) + (cons (dset-filter hdrivers (pvar/dd<=? (+ depth i))) + (loop (add1 i))) + null))) + (define at-stx (datum->syntax #f '... head)) + (define hg + (let loop ([hdriverss hdriverss]) + (cond [(null? (cdr hdriverss)) + (let ([cons? (ht-guide? hguide)] + [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) + `(t-dots ,cons? ,hguide ,(car hdriverss) + (quote ,head) (quote-syntax ,at-stx)))] + [else (let ([inner (loop (cdr hdriverss))]) + `(t-dots #f ,inner ,(car hdriverss) + (quote ,head) (quote-syntax ,at-stx)))]))) + (values (dset-union hdrivers tdrivers) + (if (equal? tguide '(t-list)) + (resyntax t hg) + (resyntax t `(t-append ,hg ,tguide))))))) + + ;; parse-t-pair/normal : Stx Nat Boolean -> ... + ;; t is a normal stx pair + (define (parse-t-pair/normal t depth esc?) + (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) + (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) + (values (dset-union hdrivers tdrivers) + (resyntax t + (if (ht-guide? hguide) + (let ([hguide (ht-guide-t hguide)]) + (if (and (const-guide? hguide) (const-guide? tguide)) + (const-guide t) + (cons-guide hguide tguide))) + (if (equal? tguide '(t-list)) + hguide + `(t-append ,hguide ,tguide)))))) + + ;; parse-t-nonpair : Syntax Nat Boolean -> ... + ;; PRE: t is not a stxpair + (define (parse-t-nonpair t depth esc?) + (define td (if (syntax? t) (syntax-e t) t)) + (cond [(identifier? t) + (cond [(and (not esc?) + (or (free-identifier=? t (quote-syntax ...)) + (free-identifier=? t (quote-syntax ~?)) + (free-identifier=? t (quote-syntax ~@)))) + (wrong-syntax t "illegal use")] + [(lookup-metafun t) + (wrong-syntax t "illegal use of syntax metafunction")] + [(lookup t depth) + => (lambda (pvar) + (disappeared! t) + (values (dset pvar) + (cond [(pvar-check pvar) + => (lambda (check) + `(#%expression + (,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))] + [else `(t-var ,(pvar-lvar pvar))])))] + [else (values (dset) (const-guide t))])] + [(vector? td) + (define-values (drivers guide) (parse-t (vector->list td) depth esc?)) + (values drivers + (cond [(const-guide? guide) (const-guide t)] + [else (resyntax t `(t-vector ,guide))]))] + [(prefab-struct-key td) + => (lambda (key) + (define-values (drivers guide) + (let ([elems (cdr (vector->list (struct->vector td)))]) + (parse-t elems depth esc?))) + (values drivers + (cond [(const-guide? guide) (const-guide t)] + [else (resyntax t `(t-struct (quote ,key) ,guide))])))] + [(box? td) + (define-values (drivers guide) (parse-t (unbox td) depth esc?)) + (values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))] + [else (values (dset) (const-guide t))])) + + ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide) + (define (parse-h h depth esc?) + (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1)) + => (lambda (h) + (disappeared! (car h)) + (define-values (drivers guide) (parse-h (cadr h) depth esc?)) + (values drivers `(h-orelse ,guide null)))] + [(and (not esc?) (parse-form h (quote-syntax ~?) 2)) + => (lambda (h) + (disappeared! (car h)) + (define-values (drivers1 guide1) (parse-h (cadr h) depth esc?)) + (define-values (drivers2 guide2) (parse-h (caddr h) depth esc?)) + (values (dset-union drivers1 drivers2) + (if (and (ht-guide? guide1) (ht-guide? guide2)) + `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) + `(h-orelse ,guide1 ,guide2))))] + [(and (stx-pair? h) + (let ([h-head (stx-car h)]) + (and (identifier? h-head) + (or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?)) + (free-identifier=? h-head (quote-syntax ~@!)))))) + (disappeared! (stx-car h)) + (define-values (drivers guide) (parse-t (stx-cdr h) depth esc?)) + (values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))] + [else + (define-values (drivers guide) (parse-t h depth esc?)) + (values drivers `(h-t ,guide))])) + + ;; lookup : Identifier Nat -> PVar/#f + (define (lookup id depth) + (define (make-pvar var check pvar-depth) + (cond [(zero? pvar-depth) + (pvar var var check #f)] + [(>= depth pvar-depth) + (pvar var (gentemp) check (- depth pvar-depth))] + [(zero? depth) + (wrong-syntax id "missing ellipsis with pattern variable in template")] + [else + (wrong-syntax id "too few ellipses for pattern variable in template")])) + (define (hash-ref! h k proc) + (let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*)))) + (let ([v (syntax-local-value id (lambda () #f))]) + (cond [(syntax-pattern-variable? v) + (hash-ref! env (cons v depth) + (lambda () + (define pvar-depth (syntax-mapping-depth v)) + (define attr + (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) + (and (attribute-mapping? attr) attr))) + (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) + (define check (and attr (attribute-mapping-check attr))) + (make-pvar var check pvar-depth)))] + [(s-exp-pattern-variable? v) + (hash-ref! env (cons v depth) + (lambda () + (define pvar-depth (s-exp-mapping-depth v)) + (define var (s-exp-mapping-valvar v)) + (make-pvar var #f pvar-depth)))] + [else + ;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute + (for-each + (lambda (pfx) + (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) + (if (and (syntax-pattern-variable? pfx-v) + (let ([valvar (syntax-mapping-valvar pfx-v)]) + (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) + (wrong-syntax id "undefined nested attribute of attribute `~a'" + (syntax-e pfx)) + (void)))) + (dotted-prefixes id)) + #f]))) + + ;; resyntax : Stx Guide -> Guide + (define (resyntax t0 g) + (if (and stx? (syntax? t0)) + (cond [(const-guide? g) (const-guide t0)] + [else (optimize-resyntax t0 g)]) + g)) + + ;; optimize-resyntax : Syntax Guide -> Guide + (define (optimize-resyntax t0 g) + (define HOLE (datum->syntax #f '_)) + (define (finish i rt rs re) + (values (sub1 i) (reverse rs) (reverse re) + (datum->syntax t0 (apply list* (reverse rt)) t0 t0))) + (define (loop-gs list*? gs i rt rs re) + (cond [(null? gs) + (finish i (cons null rt) rs re)] + [(and list*? (null? (cdr gs))) + (loop-g (car gs) i rt rs re)] + [else + (define g0 (car gs)) + (cond [(const-guide? g0) + (let ([const (const-guide-v g0)]) + (loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))] + [(eq? (car g0) 't-subst) ;; (t-subst LOC STX ) + (let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _) + [subargs (list-tail g0 3)]) + (loop-gs list*? (cdr gs) (add1 i) (cons subt rt) + (list* i 'recur rs) (cons `(list . ,subargs) re)))] + [else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt) + (cons i rs) (cons g0 re))])])) + (define (loop-g g i rt rs re) + (cond [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)] + [(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)] + [(eq? (car g) 't-append) + (loop-g (caddr g) (add1 i) (cons HOLE rt) + (list* i 'append rs) (cons (cadr g) re))] + [(eq? (car g) 't-const) + (let ([const (const-guide-v g)]) + (finish i (cons const rt) rs re))] + [else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))])) + (define-values (npairs substs exprs t*) (loop-g g 0 null null null)) + (cond [(and substs + ;; Tunable condition for choosing whether to create a t-subst. + ;; Avoid creating useless (t-subst loc stx '(tail 0) g). + (<= (length substs) (* 2 npairs))) + #;(log-message template-logger 'debug + (format "OPTIMIZED ~s" (syntax->datum t0)) #f) + `(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)] + [else + #;(log-message template-logger 'debug + (format "NOT opt ~s" (syntax->datum t0)) #f) + (let ([rep (datum->syntax t0 'STX t0 t0)]) + `(t-resyntax #f (quote-syntax ,rep) ,g))])) + + ;; const-guide : Any -> Guide + (define (const-guide x) + (cond [(null? x) `(t-list)] + [(not stx?) `(t-const (quote ,x))] + [(syntax? x) `(t-const (quote-syntax ,x))] + [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))])) + + (let-values ([(drivers guide) (parse-t t 0 #f)]) + (values (dset->list drivers) guide disappeared-uses))) + + ;; parse-form : Stx Id Nat -> (list[arity+1] Syntax) + (define (parse-form stx form-id arity) + (and (stx-pair? stx) + (let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)]) + (and (identifier? stx-h) (free-identifier=? stx-h form-id) + (let ([stx-tl (stx->list stx-t)]) + (and (list? stx-tl) + (= (length stx-tl) arity) + (cons stx-h stx-tl))))))) + + ;; lookup-metafun : Identifier -> Metafunction/#f + (define (lookup-metafun id) + (define v (syntax-local-value id (lambda () #f))) + (and (metafunction? v) v)) + + (define (dotted-prefixes id) + (let* ([id-string (symbol->string (syntax-e id))] + [dot-locations + (let loop ([i 0]) + (if (< i (string-length id-string)) + (if (eqv? (string-ref id-string i) #\.) + (cons i (loop (add1 i))) + (loop (add1 i))) + null))]) + (map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc)))) + dot-locations))) + + (define (pvar/dd<=? expected-dd) + (lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd))))) + + (define gentemp-counter 0) + (define (gentemp) + (set! gentemp-counter (add1 gentemp-counter)) + ((make-syntax-introducer) + (datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter))))) + + (define (stx-drop n x) + (if (zero? n) x (stx-drop (sub1 n) (stx-cdr x)))) + + ;; ---------------------------------------- + ;; Deterministic Sets + ;; FIXME: detect big unions, use hash table + + (define (dset . xs) xs) + (define (dset-empty? ds) (null? ds)) + (define (dset-filter ds pred) (filter pred ds)) + (define (dset->list ds) ds) + (define (dset-union ds1 ds2) + (if (pair? ds1) + (let ([elem (car ds1)]) + (if (member elem ds2) + (dset-union (cdr ds1) ds2) + (dset-union (cdr ds1) (cons (car ds1) ds2)))) + ds2)) + + (define (filter keep? xs) + (if (pair? xs) + (if (keep? (car xs)) + (cons (car xs) (filter keep? (cdr xs))) + (filter keep? (cdr xs))) + null)) + + ;; ---------------------------------------- + ;; Relocating (eg, syntax/loc) + + ;; Only relocate if relocation would affect a syntax pair originating + ;; from template structure. For example (x,y are pvars): + ;; (syntax/loc loc-stx (1 2 3)) => relocate + ;; (syntax/loc loc-stx y) => don't relocate + ;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x! + ;; Deciding whether to relocate after the fact is hard. But with explicit + ;; t-resyntax, it's much easier. + + ;; relocate-guide : Syntax Guide Id -> Guide + (define (relocate-guide ctx g0 loc-id) + (define (loop g) + (define gtag (car g)) + (cond [(eq? gtag 't-resyntax) + `(t-resyntax ,loc-id . ,(cddr g))] + [(eq? gtag 't-const) + `(t-relocate ,g ,loc-id)] + [(eq? gtag 't-subst) + `(t-subst ,loc-id . ,(cddr g))] + ;; ---- + [(eq? gtag 't-escaped) + `(t-escaped ,(loop (cadr g)))] + [(eq? gtag 't-orelse) + `(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))] + ;; ---- + ;; Nothing else should be relocated + [else g])) + (loop g0)) + + ;; ---------------------------------------- + + ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax + (define (do-template ctx tstx loc-id stx?) + (define-values (pvars pre-guide disappeared-uses) + (parse-template ctx tstx stx?)) + (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide)) + (define ell-pvars (filter pvar-dd pvars)) + (define pre-code + (if (const-guide? guide) + (if stx? `(quote-syntax ,tstx) `(quote ,tstx)) + (let ([lvars (map pvar-lvar ell-pvars)] + [valvars (map pvar-var ell-pvars)]) + `(let (,@(map list lvars valvars)) + ,(datum->syntax here-stx guide))))) + (define code (syntax-arm (datum->syntax here-stx pre-code ctx))) + (syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses))) + ) + +(define-syntax (syntax stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 2)) + (do-template stx (cadr s) #f #t) + (raise-syntax-error #f "bad syntax" stx))) + +(define-syntax (syntax/loc stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 3)) + (let ([loc-id (quote-syntax loc)]) + (define code + `(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))]) + ,(do-template stx (caddr s) loc-id #t))) + (syntax-arm (datum->syntax here-stx code stx))) + (raise-syntax-error #f "bad syntax" stx))) + +(define-syntax (datum stx) + (define s (syntax->list stx)) + (if (and (list? s) (= (length s) 2)) + (do-template stx (cadr s) #f #f) + (raise-syntax-error #f "bad syntax" stx))) + +;; check-loc : Symbol Any -> (U Syntax #f) +;; Raise exn if not syntax. Returns same syntax if suitable for srcloc +;; (ie, if at least syntax-source or syntax-position set), #f otherwise. +(define (check-loc who x) + (if (syntax? x) + (if (or (syntax-source x) (syntax-position x)) + x + #f) + (raise-argument-error who "syntax?" x))) + +;; ============================================================ +;; Run-time support + +;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)] +(define-syntax (t-dots stx) + (define s (syntax->list stx)) + (define cons? (syntax-e (list-ref s 1))) + (define head (list-ref s 2)) + (define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar) + (define in-stx (list-ref s 4)) + (define at-stx (list-ref s 5)) + (cond + ;; Case 1: (x ...) where x is trusted + [(and cons? (let ([head-s (syntax->list head)]) + (and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var)))) + head] + ;; General case + [else + ;; var-value-expr : Id Id/#'#f -> Expr[List] + (define (var-value-expr lvar check) + (if (syntax-e check) `(,check ,lvar 1 #f #f) lvar)) + (define lvars (map pvar-lvar drivers)) + (define checks (map pvar-check drivers)) + (define code + `(let ,(map list lvars (map var-value-expr lvars checks)) + ,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void)) + ,(if cons? + `(map (lambda ,lvars ,head) . ,lvars) + `(apply append (map (lambda ,lvars ,head) . ,lvars))))) + (datum->syntax here-stx code stx)])) + +(define-syntaxes (t-orelse h-orelse) + (let () + (define (orelse-transformer stx) + (define s (syntax->list stx)) + (datum->syntax here-stx + `(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s))))) + (values orelse-transformer orelse-transformer))) + +(#%require (rename '#%kernel t-const #%expression) + (rename '#%kernel t-var #%expression) + ;; (rename '#%kernel t-append append) + (rename '#%kernel t-list list) + (rename '#%kernel t-list* list*) + (rename '#%kernel t-escaped #%expression) + (rename '#%kernel t-vector list->vector) + (rename '#%kernel t-box box-immutable) + (rename '#%kernel h-t list)) + +(begin-encourage-inline + +(define (t-append xs ys) (if (null? ys) xs (append xs ys))) +(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx)) +(define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g)) +(define (t-orelse* g1 g2) + ((let/ec escape + (with-continuation-mark + absent-pvar-escape-key + (lambda () (escape g2)) + (let ([v (g1)]) (lambda () v)))))) +(define (t-struct key g) (apply make-prefab-struct key g)) +(define (t-metafun mf g stx) + (mf (datum->syntax stx (cons (stx-car stx) g) stx stx))) +(define (h-splice g in-stx at-stx) + (if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx))) + +#| end begin-encourage-inline |#) + +;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax +;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs) +;; There is one arg for each index in substs. See also defn of Guide above. +(define (t-subst loc stx substs . args) + (define (loop/mode s i mode seek substs args) + (cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))] + [(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))] + [(eq? mode 'tail) (car args)] + [(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))] + [(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args)) + (loop (cdr s) (add1 i) substs (cdr args)))])) + (define (loop s i substs args) + (cond [(null? substs) s] + [(symbol? (car substs)) + (loop/mode s i (car substs) (cadr substs) (cddr substs) args)] + [else (loop/mode s i #f (car substs) (cdr substs) args)])) + (define v (loop (syntax-e stx) 0 substs args)) + (datum->syntax stx v (or loc stx) stx)) + +(define absent-pvar-escape-key (gensym 'absent-pvar-escape)) + +;; signal-absent-pvar : -> escapes or #f +;; Note: Only escapes if in ~? form. +(define (signal-absent-pvar) + (let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)]) + (if escape (escape) #f))) + +;; error/splice : Any Stx Stx -> (escapes) +(define (error/splice r in-stx at-stx) + (raise-syntax-error 'syntax + (format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx)) + +;; check-same-length : Stx Stx List ... -> Void +(define check-same-length + (case-lambda + [(in at a) (void)] + [(in at a b) + (if (= (length a) (length b)) + (void) + (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" + (list in '...) at))] + [(in at a . bs) + (define alen (length a)) + (for-each (lambda (b) + (if (= alen (length b)) + (void) + (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" + (list in '...) at))) + bs)])) + +) diff -Nru racket-6.12+ppa1/collects/racket/private/top-int.rkt racket-7.0+ppa1/collects/racket/private/top-int.rkt --- racket-6.12+ppa1/collects/racket/private/top-int.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/top-int.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,4 @@ -(module pre-base '#%kernel +(module top-int '#%kernel (#%require (for-syntax '#%kernel)) (#%provide #%top-interaction) diff -Nru racket-6.12+ppa1/collects/racket/private/truncate-path.rkt racket-7.0+ppa1/collects/racket/private/truncate-path.rkt --- racket-6.12+ppa1/collects/racket/private/truncate-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/truncate-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(provide truncate-path) + +;; Drop information from the path `p` in the same way as marshaling a +;; path in a srcloc as part of compiled code +(define (truncate-path p) + (define-values (base1 name1 dir?) (split-path p)) + (cond + [(path? base1) + (define-values (base2 name2 dir?) (split-path base1)) + (cond + [(not base2) + ;; Path at a root + (path->string p)] + [(symbol? name2) + ;; "." or ".." before a name + (string-append ".../" (path-elem->string name1))] + [else + (string-append ".../" (path->string name2) "/" (path-elem->string name1))])] + [(eq? base1 'relative) + (path-elem->string name1)] + [else + ;; Path is a root, ".", or ".." + (path->string p)])) + +(define (path-elem->string p) + (cond + [(eq? p 'same) "."] + [(eq? p 'up) ".."] + [else (path->string p)])) diff -Nru racket-6.12+ppa1/collects/racket/private/vector-wraps.rkt racket-7.0+ppa1/collects/racket/private/vector-wraps.rkt --- racket-6.12+ppa1/collects/racket/private/vector-wraps.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/vector-wraps.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,12 +17,13 @@ for/fXvector for*/fXvector fXvector-copy - fXzero) + fXzero + check-fXvector) (... (begin (define-:vector-like-gen :fXvector-gen unsafe-fXvector-ref) - (define-in-vector-like in-fXvector* + (define-in-vector-like (in-fXvector* check-fXvector) fXvector-str fXvector? fXvector-length :fXvector-gen) (define-sequence-syntax in-fXvector @@ -32,6 +33,7 @@ #'fXvector? #'unsafe-fXvector-length #'in-fXvector* + #'check-fXvector #'unsafe-fXvector-ref)) (define (unsafe-fXvector-copy! vec dest-start flv start end) diff -Nru racket-6.12+ppa1/collects/racket/private/with-stx.rkt racket-7.0+ppa1/collects/racket/private/with-stx.rkt --- racket-6.12+ppa1/collects/racket/private/with-stx.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/private/with-stx.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,7 +4,7 @@ (module with-stx '#%kernel (#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt" (for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt" - "sc.rkt" "qq-and-or.rkt" "cond.rkt")) + "gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt")) (-define (with-syntax-fail stx) (raise-syntax-error diff -Nru racket-6.12+ppa1/collects/racket/promise.rkt racket-7.0+ppa1/collects/racket/promise.rkt --- racket-6.12+ppa1/collects/racket/promise.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/promise.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -26,7 +26,11 @@ (define-struct (running-thread running) (thread)) ;; used in promise/sync until it's forced -(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema)) +(define-struct syncinfo ([thunk #:mutable] done-evt done-sema access-sema) + ;; We don't want to apply a `syncinfo`, but declaring the `syncinfo` + ;; as a procedure tells `promise-forced?` when the promise is not + ;; yet forced + #:property prop:procedure (case-lambda)) (define-struct (promise/sync promise) () #:property prop:custom-write diff -Nru racket-6.12+ppa1/collects/racket/provide-syntax.rkt racket-7.0+ppa1/collects/racket/provide-syntax.rkt --- racket-6.12+ppa1/collects/racket/provide-syntax.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/provide-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,27 +4,18 @@ (for-syntax syntax-local-provide-introduce)) (require (for-syntax racket/base + syntax/apply-transformer "provide-transform.rkt")) -(define-for-syntax orig-insp (variable-reference->module-declaration-inspector - (#%variable-reference))) - -(define-for-syntax current-provide-introducer - (make-parameter (lambda (x) (error "not expanding provide form")))) - (define-for-syntax (syntax-local-provide-introduce x) (unless (syntax? x) (raise-argument-error 'syntax-local-introduce-provide "syntax?" x)) - ((current-provide-introducer) x)) + (syntax-local-introduce x)) (define-for-syntax (make-provide-macro proc) (make-provide-transformer (lambda (stx modes) - (let* ([i (make-syntax-introducer)] - [d-stx (syntax-disarm stx orig-insp)] - [new-stx (parameterize ([current-provide-introducer i]) - (i (proc (i d-stx))))]) - (expand-export (syntax-rearm new-stx stx) modes))))) + (expand-export (local-apply-transformer proc stx 'expression) modes)))) (define-syntax (define-provide-syntax stx) (syntax-case stx () diff -Nru racket-6.12+ppa1/collects/racket/repl.rkt racket-7.0+ppa1/collects/racket/repl.rkt --- racket-6.12+ppa1/collects/racket/repl.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/repl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +(module repl '#%kernel + (#%declare #:cross-phase-persistent) + (#%provide read-eval-print-loop) + + (define-values (read-eval-print-loop) + (lambda () + (letrec-values ([(repl-loop) + (lambda () + ;; This prompt catches all error escapes, including from read and print. + (call-with-continuation-prompt + (lambda () + (let-values ([(v) ((current-prompt-read))]) + (if (eof-object? v) + (void) + (begin + (call-with-values + (lambda () + ;; This prompt catches escapes during evaluation. + ;; Unlike the outer prompt, the handler prints + ;; the results. + (call-with-continuation-prompt + (lambda () + (let-values ([(w) (cons '#%top-interaction v)]) + ((current-eval) (if (syntax? v) + (namespace-syntax-introduce + (datum->syntax #f w v)) + w)))))) + (lambda results (for-each (current-print) results))) + ;; Abort to loop. (Calling `repl-loop` directly would not be a tail call.) + (abort-current-continuation (default-continuation-prompt-tag)))))) + (default-continuation-prompt-tag) + (lambda args (repl-loop))))]) + (repl-loop))))) diff -Nru racket-6.12+ppa1/collects/racket/require-syntax.rkt racket-7.0+ppa1/collects/racket/require-syntax.rkt --- racket-6.12+ppa1/collects/racket/require-syntax.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/require-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,27 +3,19 @@ (provide define-require-syntax (for-syntax syntax-local-require-introduce)) -(require (for-syntax racket/base "require-transform.rkt")) - -(define-for-syntax orig-insp (variable-reference->module-declaration-inspector - (#%variable-reference))) - -(define-for-syntax current-require-introducer - (make-parameter (lambda (x) (error "not expanding require form")))) +(require (for-syntax racket/base + syntax/apply-transformer + "require-transform.rkt")) (define-for-syntax (syntax-local-require-introduce x) (unless (syntax? x) (raise-argument-error 'syntax-local-introduce-require "syntax?" x)) - ((current-require-introducer) x)) + (syntax-local-introduce x)) (define-for-syntax (make-require-macro proc) (make-require-transformer (lambda (stx) - (let* ([i (make-syntax-introducer)] - [d-stx (syntax-disarm stx orig-insp)] - [new-stx (parameterize ([current-require-introducer i]) - (i (proc (i d-stx))))]) - (expand-import (syntax-rearm new-stx stx)))))) + (expand-import (local-apply-transformer proc stx 'expression))))) (define-syntax (define-require-syntax stx) (syntax-case stx () diff -Nru racket-6.12+ppa1/collects/racket/runtime-path.rkt racket-7.0+ppa1/collects/racket/runtime-path.rkt --- racket-6.12+ppa1/collects/racket/runtime-path.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/runtime-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -186,7 +186,8 @@ (path-of #,(datum->syntax #'orig-stx - `(,#'this-expression-source-file)))) + `(,#'this-expression-source-file) + #'orig-stx))) #'void)]) (apply to-values (resolve-paths (#%variable-reference) get-dir diff -Nru racket-6.12+ppa1/collects/racket/splicing.rkt racket-7.0+ppa1/collects/racket/splicing.rkt --- racket-6.12+ppa1/collects/racket/splicing.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/splicing.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,7 +19,8 @@ splicing-letrec-values splicing-letrec-syntaxes+values splicing-local - splicing-syntax-parameterize) + splicing-syntax-parameterize + splicing-parameterize) (module syntax/loc/props racket/base (require (for-syntax racket/base)) @@ -293,28 +294,24 @@ (define-syntax (ssp-let-syntaxes stx) (syntax-case stx () - [(_ ([(id) rhs] ...) (orig-id ...) body ...) - (with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))]) - #'(begin - ;; Evaluate each RHS only once: - (define-syntax splicing-temp rhs) ... - ;; Partially expand `body' to push down `let-syntax': - (expand-ssp-body (id ...) (splicing-temp ...) (orig-id ...) body) - ...))])) + [(_ ([(id) rhs] ...) orig-id ... (llk binds body ...)) + #'(begin + ;; Evaluate each RHS only once: + (define-syntax id rhs) ... + ;; Partially expand `body' to push down `let-syntax': + (expand-ssp-body binds [orig-id ...] body) + ...)])) (define-syntax (expand-ssp-body stx) (syntax-case stx () - [(_ (sp-id ...) (temp-id ...) (orig-id ...) body) + [(_ binds orig-ids body) (let ([ctx (syntax-local-make-definition-context #f #f)]) - (for ([sp-id (in-list (syntax->list #'(sp-id ...)))] - [temp-id (in-list (syntax->list #'(temp-id ...)))]) - (syntax-local-bind-syntaxes (list sp-id) - #`(syntax-local-value (quote-syntax #,temp-id)) - ctx)) - (let ([body (local-expand #'(force-expand body) - (syntax-local-context) - null ;; `force-expand' actually determines stopping places - ctx)]) + (let ([body (parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) #'binds)]) + (local-expand #'(force-expand body) + (syntax-local-context) + null ;; `force-expand' actually determines stopping places + ctx))]) (let ([body ;; Extract expanded body out of `body': (syntax-case body (quote) @@ -330,24 +327,23 @@ #%declare ) [(begin expr ...) (syntax/loc/props body - (begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))] + (begin (expand-ssp-body binds orig-ids expr) ...))] [(define-values (id ...) rhs) (syntax/loc/props body (define-values (id ...) - (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) - rhs)))] + (let-local-keys binds rhs)))] [(define-syntaxes ids rhs) (syntax/loc/props body - (define-syntaxes ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + (define-syntaxes ids (wrap-param-et rhs binds)))] [(begin-for-syntax e ...) (syntax/loc/props body - (begin-for-syntax (wrap-param-et e (orig-id ...) (temp-id ...)) ...))] + (begin-for-syntax (wrap-param-et e binds) ...))] [(module . _) body] [(module* name #f form ...) (datum->syntax body (list #'module* #'name #f #`(expand-ssp-module-begin - (sp-id ...) (temp-id ...) (orig-id ...) + binds orig-ids #,body name form ...)) body)] [(module* . _) body] @@ -355,37 +351,34 @@ [(#%provide . _) body] [(#%declare . _) body] [expr (syntax/loc body - (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) - expr))]))))])) + (let-local-keys binds expr))]))))])) (define-syntax (expand-ssp-module-begin stx) (syntax-case stx () - [(_ (sp-id ...) (temp-id ...) (orig-id ...) mod-form mod-name-id body-form ...) + [(_ binds orig-ids mod-form mod-name-id body-form ...) (unless (eq? (syntax-local-context) 'module-begin) (raise-syntax-error #f "only allowed in module-begin context" stx)) - (let ([ctx (syntax-local-make-definition-context #f #f)]) - (for ([sp-id (in-list (syntax->list #'(sp-id ...)))] - [temp-id (in-list (syntax->list #'(temp-id ...)))]) - (syntax-local-bind-syntaxes (list sp-id) - #`(syntax-local-value (quote-syntax #,temp-id)) - ctx)) - (let* ([forms (syntax->list #'(body-form ...))] - ; emulate how the macroexpander expands module bodies and introduces #%module-begin - [body (if (= (length forms) 1) - (let ([body (local-expand (car forms) 'module-begin #f ctx)]) - (syntax-case body (#%plain-module-begin) - [(#%plain-module-begin . _) body] - [_ (datum->syntax #'mod-form (list '#%module-begin body) #'mod-form)])) - (datum->syntax #'mod-form (list* '#%module-begin forms) #'mod-form))] - [body (syntax-property body 'enclosing-module-name (syntax-e #'mod-name-id))] - [body (local-expand body 'module-begin #f ctx)]) - (syntax-case body (#%plain-module-begin) - [(#%plain-module-begin form ...) - (syntax/loc/props body - (#%plain-module-begin - (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) form) ...))] - [_ (raise-syntax-error - #f "expansion of #%module-begin is not a #%plain-module-begin form" body)])))])) + (with-syntax ([new-binds (update-parameter-keys #'orig-ids #'binds)]) + (parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) + #'new-binds)]) + (let* ([forms (syntax->list #'(body-form ...))] + ;; emulate how the macroexpander expands module bodies and introduces #%module-begin + [body (if (= (length forms) 1) + (let ([body (local-expand (car forms) 'module-begin #f)]) + (syntax-case body (#%plain-module-begin) + [(#%plain-module-begin . _) body] + [_ (datum->syntax #'mod-form (list '#%module-begin body) #'mod-form)])) + (datum->syntax #'mod-form (list* '#%module-begin forms) #'mod-form))] + [body (syntax-property body 'enclosing-module-name (syntax-e #'mod-name-id))] + [body (local-expand body 'module-begin #f)]) + (syntax-case body (#%plain-module-begin) + [(#%plain-module-begin form ...) + (syntax/loc/props body + (#%plain-module-begin + (expand-ssp-body new-binds orig-ids form) ...))] + [_ (raise-syntax-error + #f "expansion of #%module-begin is not a #%plain-module-begin form" body)]))))])) (define-syntax (letrec-syntaxes/trans stx) (syntax-case stx () @@ -408,20 +401,14 @@ 'certify-mode 'transparent)])) -(define-for-syntax (parameter-of id) - (let ([sp (syntax-parameter-local-value id)]) - (syntax-parameter-target-parameter - (syntax-parameter-target sp)))) - (begin-for-syntax (define-syntax (wrap-param-et stx) (syntax-case stx () - [(_ e (orig-id ...) (temp-id ...)) + [(_ e binds) (let ([as-expression (lambda () - #'(parameterize ([(parameter-of (quote-syntax orig-id)) - (quote-syntax temp-id)] - ...) + #'(parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) (quote-syntax binds))]) e))]) (if (eq? (syntax-local-context) 'expression) (as-expression) @@ -437,17 +424,17 @@ quote-syntax) [(begin form ...) (syntax/loc/props e - (begin (wrap-param-et form (orig-id ...) (temp-id ...)) ...))] + (begin (wrap-param-et form binds) ...))] [(define-syntaxes . _) e] [(begin-for-syntax . _) e] [(define-values ids rhs) (syntax/loc/props e - (define-values ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + (define-values ids (wrap-param-et rhs binds)))] [(module . _) e] [(module* n #f form ...) (datum->syntax e - (syntax-e #'(module* n #f (wrap-param-et form (orig-id ...) (temp-id ...)) ...)) + (syntax-e #'(module* n #f (wrap-param-et form binds) ...)) e e)] [(module* . _) e] @@ -456,3 +443,65 @@ [(#%declare . _) e] [(quote-syntax . _) e] [else (as-expression)]))))]))) + +;; ---------------------------------------- + +(define-syntax (splicing-parameterize stx) + (syntax-case stx () + [(_ ([param value] ...) body ...) + (with-syntax ([(param/checked ...) + (for/list ([param-stx (in-list (syntax->list #'(param ...)))]) + #`(let ([param-val #,param-stx]) + (unless (parameter? param-val) + (raise-argument-error 'splicing-parameterize "parameter?" param-val)) + param-val))]) + (if (eq? (syntax-local-context) 'expression) + #'(parameterize ([param/checked value] ...) + body ...) + (let ([introduce (make-syntax-introducer #t)]) + (with-syntax ([scopeless-id (datum->syntax #f 'scopeless-id)] + [scoped-id (introduce (datum->syntax #f 'scoped-id))] + [(scoped-body ...) (map introduce (syntax->list #'(body ...)))] + ; make sure the parameterization can be GC’d at the top/module level + [(free-parameterization-expr ...) + (case (syntax-local-context) + [(top-level module) #'((set! new-parameterization #f))] + [else #'()])]) + #'(begin + (define new-parameterization + (parameterize ([param/checked value] ...) + (current-parameterization))) + (splicing-parameterize-body + scopeless-id scoped-id new-parameterization scoped-body) ... + free-parameterization-expr ...)))))])) + +(define-syntax (splicing-parameterize-body stx) + (syntax-case stx () + [(_ scopeless-id scoped-id parameterization body) + (let* ([introducer (make-syntax-delta-introducer #'scoped-id #'scopeless-id)] + [unintro (λ (stx) (introducer stx 'remove))] + [expanded-body (local-expand #'body (syntax-local-context) + (kernel-form-identifier-list))]) + (kernel-syntax-case expanded-body #f + [(begin new-body ...) + (syntax/loc/props expanded-body + (begin + (splicing-parameterize-body parameterization new-body) + ...))] + [(define-values ids rhs) + (quasisyntax/loc/props expanded-body + (define-values #,(map (maybe unintro) (syntax->list #'ids)) + (call-with-parameterization parameterization (λ () rhs))))] + [(define-syntaxes ids rhs) + (quasisyntax/loc/props expanded-body + (define-syntaxes #,(map (maybe unintro) (syntax->list #'ids)) rhs))] + [(begin-for-syntax . _) expanded-body] + [(module . _) (unintro expanded-body)] + [(module* . _) expanded-body] + [(#%require . _) (unintro expanded-body)] + [(#%provide . _) expanded-body] + [(#%declare . _) expanded-body] + [expr + (syntax/loc/props expanded-body + (call-with-parameterization parameterization (λ () expr)))]))])) + diff -Nru racket-6.12+ppa1/collects/racket/stream.rkt racket-7.0+ppa1/collects/racket/stream.rkt --- racket-6.12+ppa1/collects/racket/stream.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/stream.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -317,10 +317,12 @@ (raise-syntax-error (syntax-e #'derived-stx) "missing body expression after sequence bindings" stx #'body)) - #`(sequence->stream - (in-generator - (#,derived-stx #,stx () clauses - (yield (let () . body)) - (values)))))])) + (with-syntax ([((pre-body ...) body*) (split-for-body stx #'body)]) + #`(sequence->stream + (in-generator + (#,derived-stx #,stx () clauses + pre-body ... + (yield (let () . body*)) + (values))))))])) (values (make-for/stream #'for/fold/derived) (make-for/stream #'for*/fold/derived)))) diff -Nru racket-6.12+ppa1/collects/racket/string.rkt racket-7.0+ppa1/collects/racket/string.rkt --- racket-6.12+ppa1/collects/racket/string.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,9 +19,8 @@ [(s1 s2 s3 s4 strs) (apply string-append s1 s2 s3 s4 strs)] [(str . strss) (apply apply string-append str strss)])) -(require (only-in racket/list add-between)) - -(define none (gensym)) +(require (only-in racket/list add-between) + (only-in racket/unsafe/undefined [unsafe-undefined none])) (define (string-join strs [sep " "] #:before-first [before-first none] @@ -29,8 +28,12 @@ #:after-last [after-last none]) (unless (and (list? strs) (andmap string? strs)) (raise-argument-error 'string-join "(listof string?)" strs)) + (unless (or (string? before-first) (eq? before-first none)) + (raise-argument-error 'string-join "string?" before-first)) (unless (string? sep) (raise-argument-error 'string-join "string?" sep)) + (unless (or (string? after-last) (eq? after-last none)) + (raise-argument-error 'string-join "string?" after-last)) (let* ([r (if (or (null? strs) (null? (cdr strs))) strs (add-between strs sep #:before-last before-last))] @@ -38,6 +41,24 @@ [r (if (eq? before-first none) r (cons before-first r))]) (apply string-append r))) +;; Cache for string-replace and string-split and similar functions: +;; A mutable string weakly holds a immutable copy until it is collected +;; or modified (and used as a argument of string-replace, string-split, ...). +;; The immutable copy weakly holds the regexp that is used in string-replace. +;; Using string->immutable-string directly in string-replace is not a useful +;; because the immutable copy could be immediately collected. + +(define immutable-cache (make-weak-hasheq)) +(define (string->immutable-string/cache str) + (if (immutable? str) + str + (let ([old (hash-ref immutable-cache str #f)]) + (if (and old (string=? str old)) + old + (let ([new (string->immutable-string str)]) + (hash-set! immutable-cache str new) + new))))) + ;; Utility for the functions below: get a string or a regexp and return a list ;; of the regexp (strings are converted using `regexp-quote'), and versions ;; that match at the beginning/end. @@ -47,8 +68,11 @@ (hash-set! t none spaces) (hash-set! t+ none spaces)) (λ (who rx +?) - (hash-ref! (if +? t+ t) rx - (λ () (let* ([s (cond [(string? rx) (regexp-quote rx)] + (define rx* (if (string? rx) + (string->immutable-string/cache rx) + rx)) + (hash-ref! (if +? t+ t) rx* + (λ () (let* ([s (cond [(string? rx) (regexp-quote rx*)] [(regexp? rx) (string-append "(?:" (object-name rx) ")")] [else (raise-argument-error @@ -104,26 +128,7 @@ (string-join (internal-split 'string-normalize-spaces str sep trim? +?) space)) - -;; Caches for string-replace: -;; A mutable string weakly holds a immutable copy until it is collected -;; or modified (and used as a argument of string-replace). -;; The immutable copy weakly holds the regexp that is used in string-replace. -;; Using string->immutable-string directly in string-replace is not a useful -;; because the immutable copy could be immediately collected. - -(define immutable-cache (make-weak-hasheq)) -(define (string->immutable-string/cache str) - (if (immutable? str) - str - (let ([old (hash-ref immutable-cache str #f)]) - (if (and old (string=? str old)) - old - (let ([new (string->immutable-string str)]) - (hash-set! immutable-cache str new) - new))))) - -(define replace-cache (make-weak-hash)) +(define replace-cache (make-weak-hasheq)) (define (string-replace str from to #:all? [all? #t]) (unless (string? str) (raise-argument-error 'string-replace "string?" str)) (unless (string? to) (raise-argument-error 'string-replace "string?" to)) diff -Nru racket-6.12+ppa1/collects/racket/stxparam-exptime.rkt racket-7.0+ppa1/collects/racket/stxparam-exptime.rkt --- racket-6.12+ppa1/collects/racket/stxparam-exptime.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/stxparam-exptime.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,14 +9,11 @@ (define-values (syntax-parameter-value) (lambda (id) - (let* ([v (syntax-local-value id (lambda () #f))] - [v (if (set!-transformer? v) - (set!-transformer-procedure v) - v)]) + (let* ([v (syntax-local-value id (lambda () #f))]) (unless (syntax-parameter? v) (raise-argument-error 'syntax-parameter-value "syntax-parameter?" v)) - (let ([target (syntax-parameter-target v)]) - (syntax-parameter-target-value target))))) + (syntax-parameter-key-value (syntax-parameter-key v) + (syntax-parameter-default-id v))))) (define-values (make-parameter-rename-transformer) (lambda (id) diff -Nru racket-6.12+ppa1/collects/racket/stxparam.rkt racket-7.0+ppa1/collects/racket/stxparam.rkt --- racket-6.12+ppa1/collects/racket/stxparam.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/stxparam.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,7 +7,8 @@ "stxparam-exptime.rkt" "private/stxcase-scheme.rkt" "private/small-scheme.rkt" - "private/stxloc.rkt" "private/stxparamkey.rkt")) + "private/stxloc.rkt" + "private/stxparamkey.rkt")) (#%provide define-syntax-parameter define-rename-transformer-parameter @@ -20,27 +21,24 @@ [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) #'(begin - (define-syntax gen-id (convert-renamer #f init-val)) - (define-syntax id - (let ([gen-id #'gen-id]) - (make-set!-transformer - (make-syntax-parameter - (lambda (stx) - (let ([v (syntax-parameter-target-value gen-id)]) - (apply-transformer v stx #'set!))) - gen-id))))))])) + (define-syntax gen-id (wrap-parameter-value #f init-val)) + (define-syntax id + (let ([key (gensym)]) + (make-syntax-parameter + (quote-syntax gen-id) + key)))))])) (define-syntax (define-rename-transformer-parameter stx) (syntax-case stx () [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) #'(begin - (define-syntax gen-id (convert-renamer #'init-val init-val)) + (define-syntax gen-id (wrap-parameter-value 'define-rename-transformer-parameter init-val)) (define-syntax id - (let ([gen-id #'gen-id]) + (let ([key (gensym)]) (make-rename-transformer-parameter - #f - gen-id)))))])) + #'gen-id ; needed if `key` is not set + key)))))])) (define-syntax (syntax-parameterize stx) - (do-syntax-parameterize stx #'let-syntaxes #f #f))) + (do-syntax-parameterize stx #'letrec-syntaxes #f #f))) diff -Nru racket-6.12+ppa1/collects/racket/syntax.rkt racket-7.0+ppa1/collects/racket/syntax.rkt --- racket-6.12+ppa1/collects/racket/syntax.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -185,21 +185,23 @@ (define (generate-temporary [stx 'g]) (car (generate-temporaries (list stx)))) -;; Applies the renaming of intdefs to stx. +;; Included for backwards compatibility. (define (internal-definition-context-apply intdefs stx) - (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)]) - (with-syntax ([(q astx) qastx]) #'astx))) + ; The old implementation of internal-definition-context-apply implicitly converted its stx argument + ; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that + ; behavior here: + (internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add)) -(define (syntax-local-eval stx [intdef0 #f]) +(define (syntax-local-eval stx [intdefs '()]) (let* ([name (generate-temporary)] - [intdefs (syntax-local-make-definition-context intdef0)]) + [intdef (syntax-local-make-definition-context)]) (syntax-local-bind-syntaxes (list name) #`(call-with-values (lambda () #,stx) list) + intdef intdefs) - (internal-definition-context-seal intdefs) (apply values - (syntax-local-value (internal-definition-context-apply intdefs name) - #f intdefs)))) + (syntax-local-value (internal-definition-context-introduce intdef name) + #f intdef)))) (define-syntax (with-syntax* stx) (syntax-case stx () diff -Nru racket-6.12+ppa1/collects/racket/unsafe/ops.rkt racket-7.0+ppa1/collects/racket/unsafe/ops.rkt --- racket-6.12+ppa1/collects/racket/unsafe/ops.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/racket/unsafe/ops.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -35,7 +35,12 @@ unsafe-make-security-guard-at-root unsafe-set-on-atomic-timeout! unsafe-abort-current-continuation/no-wind - unsafe-call-with-composable-continuation/no-wind) + unsafe-call-with-composable-continuation/no-wind + unsafe-os-thread-enabled? + unsafe-call-in-os-thread + unsafe-make-os-semaphore + unsafe-os-semaphore-post + unsafe-os-semaphore-wait) (rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure] [new:unsafe-chaperone-procedure unsafe-chaperone-procedure]) (prefix-out unsafe- diff -Nru racket-6.12+ppa1/collects/raco/main.rkt racket-7.0+ppa1/collects/raco/main.rkt --- racket-6.12+ppa1/collects/raco/main.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/raco/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,18 +6,21 @@ ;; `for-label', otherwise it could get a .zo anyway. (module main '#%kernel - (#%require '#%min-stx + (#%require '#%paramz ;; Need to make sure they're here: '#%builtin) - (module test '#%kernel) - (let-values ([(cmdline) (current-command-line-arguments)]) - (if (and (positive? (vector-length cmdline)) - (equal? "setup" (vector-ref cmdline 0))) - (parameterize ([current-command-line-arguments - (list->vector - (cdr - (vector->list cmdline)))]) + (if (if (positive? (vector-length cmdline)) + (equal? "setup" (vector-ref cmdline 0)) + #f) + (with-continuation-mark + parameterization-key + (extend-parameterization + (continuation-mark-set-first #f parameterization-key) + current-command-line-arguments + (list->vector + (cdr + (vector->list cmdline)))) (dynamic-require 'setup/main #f)) (dynamic-require 'raco/raco #f)))) diff -Nru racket-6.12+ppa1/collects/setup/cross-system.rkt racket-7.0+ppa1/collects/setup/cross-system.rkt --- racket-6.12+ppa1/collects/setup/cross-system.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/cross-system.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,12 +7,13 @@ (define cross-system-table #f) -(define system-type-symbols '(os word gc link machine so-suffix so-mode fs-change)) +(define system-type-symbols '(os word gc vm link machine so-suffix so-mode fs-change)) (define (compute-cross!) (unless cross-system-table (define lib-dir (find-lib-dir)) (define ht (and lib-dir + (eq? (system-type 'vm) 'racket) ; only the Racket VM supports cross-compilation, for now (let ([f (build-path lib-dir "system.rktd")]) (and (file-exists? f) (let ([ht (call-with-default-reading-parameterization @@ -49,7 +50,7 @@ (unless (memq mode system-type-symbols) (raise-argument-error 'cross-system-type - "(or/c 'os 'word 'gc 'link 'machine 'so-suffix 'so-mode 'fs-change)" + "(or/c 'os 'word 'gc 'vm 'link 'machine 'so-suffix 'so-mode 'fs-change)" mode)) (compute-cross!) (or (hash-ref cross-system-table mode #f) @@ -58,10 +59,10 @@ (define (cross-system-library-subpath [mode (begin (compute-cross!) (cross-system-type 'gc))]) - (unless (memq mode '(#f 3m cgc)) + (unless (memq mode '(#f 3m cgc cs)) (raise-argument-error 'cross-system-library-subtype - "(or/c #f '3m 'cgc)" + "(or/c #f '3m 'cgc 'cs)" mode)) (compute-cross!) (define bstr (hash-ref cross-system-table 'library-subpath #f)) @@ -71,7 +72,8 @@ (define path (bytes->path bstr conv)) (case mode [(#f cgc) path] - [(3m) (build-path path (bytes->path #"3m" conv))])] + [(3m) (build-path path (bytes->path #"3m" conv))] + [(cs) (build-path path (bytes->path #"cs" conv))])] [else (system-library-subpath mode)])) (define (cross-installation?) diff -Nru racket-6.12+ppa1/collects/setup/main.rkt racket-7.0+ppa1/collects/setup/main.rkt --- racket-6.12+ppa1/collects/setup/main.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,18 +9,84 @@ ;; `for-label', otherwise it could get a .zo anyway. ;; Also, do not `require' any module that is compiled. That constraint -;; essentially restrcts this module to `require's of '#%... modules. +;; essentially restricts this module to `require's of '#%... modules. (module main '#%kernel - (#%require '#%min-stx - '#%utils ; for find-main-collects + (#%require '#%utils ; for find-main-collects + '#%paramz ;; Need to make sure they're here: - '#%builtin) + '#%builtin + (for-syntax '#%kernel)) (module test '#%kernel) + + ;; ---------------------------------------- + ;; Some minimal syntax extensions to '#%kernel + + (define-syntaxes (parameterize) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (let-values ([(bindings) (apply append + (map syntax->list (syntax->list (car s))))]) + (datum->syntax + (quote-syntax here) + (list 'with-continuation-mark + 'parameterization-key + (list* 'extend-parameterization + '(continuation-mark-set-first #f parameterization-key) + bindings) + (list* 'let-values () + (cdr s)))))))) + + (define-syntaxes (and) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (if (null? s) + (quote-syntax #t) + (if (null? (cdr s)) + (car s) + (datum->syntax (quote-syntax here) + (list 'if (car s) (cons 'and (cdr s)) #f))))))) + + (define-syntaxes (or) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (if (null? s) + (quote-syntax #f) + (if (null? (cdr s)) + (car s) + (datum->syntax (quote-syntax here) + (list 'let-values (list (list (list 'x) + (car s))) + (list 'if 'x 'x (cons 'or (cdr s)))))))))) + + (define-syntaxes (let) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (datum->syntax + (quote-syntax here) + (if (symbol? (syntax-e (car s))) + (let-values ([(clauses) + (map (lambda (c) + (syntax->list c)) + (syntax->list (cadr s)))]) + (list 'letrec-values (list (list (list (car s)) + (list* 'lambda + (map car clauses) + (cddr s)))) + (cons (car s) (map cadr clauses)))) + (list* 'let-values (map (lambda (c) + (let-values ([(c) (syntax->list c)]) + (cons (list (car c)) + (cdr c)))) + (syntax->list (car s))) + (cdr s))))))) + + ;; ---------------------------------------- - (when (file-stream-port? (current-output-port)) - (file-stream-buffer-mode (current-output-port) 'line)) + (if (file-stream-port? (current-output-port)) + (file-stream-buffer-mode (current-output-port) 'line) + (void)) (define-values (make-kernel-namespace) (lambda () @@ -36,30 +102,6 @@ [current-namespace (make-kernel-namespace)]) ((dynamic-require 'setup/private/command-name 'get-names)))) - ;; Poor-man's processing of the command-line flags to drop strings - ;; that will not be parsed as flags by "parse-cmdline.rkt". We don't - ;; want to load "parse-cmdline.rkt" because it takes a long time with - ;; bytecode files disabled, and we're not yet sure whether to trust - ;; bytecode files that do exist. - (define-values (filter-flags) - (lambda (flags) - (if (or (null? flags) - (not (regexp-match? #rx"^-" (car flags))) - (equal? "-l" (car flags))) - null - (if (equal? "-P" (car flags)) - (if ((length flags) . > . 5) - (filter-flags (list-tail flags 5)) - null) - (if (or (equal? "--mode" (car flags)) - (equal? "--doc-pdf" (car flags))) - (if (pair? (cdr flags)) - (filter-flags (cddr flags)) - null) - (cons (car flags) (filter-flags (cdr flags)))))))) - - (define-values (flags) (filter-flags (vector->list (current-command-line-arguments)))) - (define-values (member) (lambda (a l) (if (null? l) @@ -68,6 +110,69 @@ l (member a (cdr l)))))) + (define-values (go-module) 'setup/setup-go) + (define-values (print-loading-sources?) #f) + + ;; Poor-man's processing of the command-line flags to drop strings + ;; that will not be parsed as flags by "parse-cmdline.rkt". We don't + ;; want to load "parse-cmdline.rkt" because it takes a long time with + ;; bytecode files disabled, and we're not yet sure whether to trust + ;; bytecode files that do exist. + (define-values (filter-flags) + (lambda (queued-flags flags) + (let ([flags (if (pair? queued-flags) + (cons (car queued-flags) flags) + flags)] + [queued-flags (if (pair? queued-flags) + (cdr queued-flags) + '())]) + (if (or (null? flags) + (not (regexp-match? #rx"^-" (car flags))) + (member (car flags) + ;; Flags that end flag processing: + '("-l" "--pkgs" "--"))) + queued-flags + (if (equal? "-P" (car flags)) + (if ((length flags) . > . 5) + (filter-flags queued-flags (list-tail flags 5)) + queued-flags) + (if (member (car flags) + ;; Flags that take 1 argument: + '("--mode" "--doc-pdf" + "-j" "--jobs" "--workers")) + (if (pair? (cdr flags)) + (filter-flags queued-flags (cddr flags)) + queued-flags) + (if (or (equal? "--boot" (car flags)) + (equal? "--chain" (car flags))) + ;; Record an alternate boot module and [additional] compiled-file root + (if (and (pair? (cdr flags)) + (pair? (cddr flags))) + (begin + (set! go-module (list 'file (cadr flags))) + (set! print-loading-sources? #t) + (let ([root (path->complete-path (caddr flags))]) + (current-compiled-file-roots + (if (equal? "--boot" (car flags)) + (list root) + (cons root (current-compiled-file-roots))))) + (cons (car flags) + (filter-flags queued-flags (cddr flags)))) + queued-flags) + ;; Check for combined flags and split them apart: + (if (regexp-match? #rx"^-([^-].+)" (car flags)) + (filter-flags (append + (map (lambda (c) + (string #\- c)) + (cdr (string->list (car flags)))) + queued-flags) + (cdr flags)) + ;; A flag with no argument: + (cons (car flags) + (filter-flags queued-flags (cdr flags))))))))))) + + (define-values (flags) (filter-flags '() (vector->list (current-command-line-arguments)))) + ;; Checks whether a flag is present: (define-values (on?) (lambda (flag-name) @@ -83,8 +188,9 @@ (define-values (main-collects-relative->path) (let ([main-collects #f]) (lambda (p) - (unless main-collects - (set! main-collects (find-main-collects))) + (if main-collects + (void) + (set! main-collects (find-main-collects))) (if (and (pair? p) (eq? 'collects (car p))) (apply build-path main-collects @@ -99,11 +205,13 @@ (on? "-n")) ;; Don't use .zos, in case they're out of date, and don't load ;; cm: - (when (or (on? "--clean") - (on? "-c")) - (use-compiled-file-paths null) - (print-bootstrapping "triggered by command-line `--clean` or `-c`")) - + (if (or (on? "--clean") + (on? "-c")) + (begin + (use-compiled-file-paths null) + (print-bootstrapping "triggered by command-line `--clean` or `-c`")) + (void)) + ;; Load the cm instance to be installed while loading Setup PLT. ;; This has to be dynamic, so we get a chance to turn off compiled ;; file loading, and so it can be in a separate namespace. @@ -124,8 +232,9 @@ ;; compiled files. (let loop ([skip-zo/reason (and (null? (use-compiled-file-paths)) "empty use-compiled-file-paths")]) - (when skip-zo/reason - (print-bootstrapping skip-zo/reason)) + (if skip-zo/reason + (print-bootstrapping skip-zo/reason) + (void)) ((call-with-escape-continuation (lambda (escape) ;; Create a new namespace, and also install load handlers @@ -138,7 +247,11 @@ [current-load (let ([orig-load (current-load)]) (if skip-zo/reason - orig-load + (if print-loading-sources? + (lambda (path modname) + (log-message (current-logger) 'info 'compiler/cm (format "loading ~a" path)) + (orig-load path modname)) + orig-load) (lambda (path modname) (if (regexp-match? #rx#"[.]zo$" (path->bytes path)) ;; It's a .zo: @@ -158,9 +271,10 @@ (eq? (car dep) 'indirect)) (cdr dep) dep)]) - (unless (and (pair? dep) - (eq? (car dep) 'ext)) - (dynamic-require (main-collects-relative->path dep) #f)))) + (if (and (pair? dep) + (eq? (car dep) 'ext)) + (void) + (dynamic-require (main-collects-relative->path dep) #f)))) (cddr deps)))) ;; Not a .zo! Don't use .zo files at all... (escape (lambda () @@ -177,7 +291,7 @@ ;; If something goes wrong, of course, give up on .zo files. (parameterize ([uncaught-exception-handler (lambda (exn) - (when (exn:break? exn) (exit 1)) + (if (exn:break? exn) (exit 1) (void)) (if skip-zo/reason (escape (lambda () (raise exn))) @@ -187,16 +301,17 @@ (format "uncaught exn: ~s" exn)))))))]) ;; Here's the main dynamic load of "cm.rkt": (let ([mk - (dynamic-require 'compiler/cm + (dynamic-require 'compiler/private/cm-minimal 'make-compilation-manager-load/use-compiled-handler)] [trust-zos - (dynamic-require 'compiler/cm 'trust-existing-zos)]) + (dynamic-require 'compiler/private/cm-minimal 'trust-existing-zos)]) ;; Return the two extracted functions: (lambda () (values mk trust-zos)))))))))]) - (when (on? "--trust-zos") - (trust-zos #t)) + (if (on? "--trust-zos") + (trust-zos #t) + (void)) (current-load/use-compiled (mk)))) ;; This has to be dynamic, so we get a chance to turn off ;; .zo use and turn on the compilation manager. - ((dynamic-require 'setup/setup-go 'go) original-compiled-file-paths)) + ((dynamic-require go-module 'go) original-compiled-file-paths)) diff -Nru racket-6.12+ppa1/collects/setup/private/command-name.rkt racket-7.0+ppa1/collects/setup/private/command-name.rkt --- racket-6.12+ppa1/collects/setup/private/command-name.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/private/command-name.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -20,9 +20,9 @@ ;; then claim to be the "setup" command: ;; if the program name is "racket", assume that there's a "racket -l setup" ;; going on in there and also claim to be the "raco setup" command - (if (if (equal? (path->string name) "raco") + (if (if (regexp-match? #rx"^raco(?:|3m|cgc|cs)$" (path->string name)) #t - (equal? (path->string name) "racket")) + (regexp-match? #rx"^racket(?:|3m|cgc|cs)$" (path->string name))) (values "raco setup" (string-append (regexp-replace* #rx"racket$" diff -Nru racket-6.12+ppa1/collects/setup/private/dirs.rkt racket-7.0+ppa1/collects/setup/private/dirs.rkt --- racket-6.12+ppa1/collects/setup/private/dirs.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/private/dirs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -75,6 +75,7 @@ (define-config config:pkgs-search-dirs 'pkgs-search-dirs to-path) (define-config config:cgc-suffix 'cgc-suffix values) (define-config config:3m-suffix '3m-suffix values) +(define-config config:cs-suffix 'cs-suffix values) (define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t))) (define-config config:doc-search-url 'doc-search-url values) (define-config config:doc-open-url 'doc-open-url values) @@ -84,6 +85,7 @@ (provide get-absolute-installation? get-cgc-suffix get-3m-suffix + get-cs-suffix get-doc-search-url get-doc-open-url get-installation-name @@ -92,6 +94,7 @@ (define (get-absolute-installation?) (force config:absolute-installation?)) (define (get-cgc-suffix) (force config:cgc-suffix)) (define (get-3m-suffix) (force config:3m-suffix)) +(define (get-cs-suffix) (force config:cs-suffix)) (define (get-doc-search-url) (or (force config:doc-search-url) "http://docs.racket-lang.org/local-redirect/index.html")) (define (get-doc-open-url) (force config:doc-open-url)) diff -Nru racket-6.12+ppa1/collects/setup/setup-cmdline.rkt racket-7.0+ppa1/collects/setup/setup-cmdline.rkt --- racket-6.12+ppa1/collects/setup/setup-cmdline.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/setup-cmdline.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -108,6 +108,12 @@ [("--unused-pkg-deps") "Check for unused package-dependency declarations" (add-flags '((check-dependencies #t) (check-unused-dependencies #t)))] + [("--chain") path dir "Select a continuation other than `setup/setup-go`" + ;; This flag is handled by `setup/main` + (void)] + [("--boot") path dir "Like `--chain`, but use compiled only from " + ;; This flag is handled by `setup/main` + (void)] #:help-labels " ------------------------------ users ------------------------------ " #:once-each diff -Nru racket-6.12+ppa1/collects/setup/variant.rkt racket-7.0+ppa1/collects/setup/variant.rkt --- racket-6.12+ppa1/collects/setup/variant.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/setup/variant.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,30 +6,39 @@ (provide variant-suffix) -(define plain-mz-is-cgc? +(define plain-variant (delay/sync (cond - [(cross-installation?) - (eq? 'cgc (cross-system-type 'gc))] - [else - (let* ([dir (find-console-bin-dir)] - [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] - [(equal? #".dll" (system-type 'so-suffix)) - ;; in cygwin so-suffix is ".dll" - "racket.exe"] - [else "racket"])] - [f (build-path dir exe)]) - (and (file-exists? f) - (with-input-from-file f - (lambda () - (regexp-match? #rx#"bINARy tYPe:..c" - (current-input-port))))))]))) + [(cross-installation?) + (if (eq? 'chez-scheme (cross-system-type 'vm)) + 'cs + (cross-system-type 'gc))] + [else + (let* ([dir (find-console-bin-dir)] + [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] + [(equal? #".dll" (system-type 'so-suffix)) + ;; in cygwin so-suffix is ".dll" + "racket.exe"] + [else "racket"])] + [f (build-path dir exe)]) + (and (file-exists? f) + (with-input-from-file f + (lambda () + (define m (regexp-match #rx#"bINARy tYPe:..(.)" + (current-input-port))) + (cond + [(not m) '3m] + [(equal? (cadr m) #"c") 'cgc] + [(equal? (cadr m) #"s") 'cs] + [else '3m])))))]))) (define (variant-suffix variant cased?) (let ([r (case variant [(3m script-3m) (or (get-3m-suffix) - (if (force plain-mz-is-cgc?) "3m" ""))] + (if (eq? '3m (force plain-variant)) "" "3m"))] [(cgc script-cgc) (or (get-cgc-suffix) - (if (force plain-mz-is-cgc?) "" "CGC"))] + (if (eq? 'cgc (force plain-variant)) "" "CGC"))] + [(cs script-cs) (or (get-cs-suffix) + (if (eq? 'cs (force plain-variant)) "" "CS"))] [else (error 'variant-suffix "unknown variant: ~e" variant)])]) (if cased? r (string-downcase r)))) diff -Nru racket-6.12+ppa1/collects/syntax/apply-transformer.rkt racket-7.0+ppa1/collects/syntax/apply-transformer.rkt --- racket-6.12+ppa1/collects/syntax/apply-transformer.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/apply-transformer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,55 @@ +#lang racket/base + +(require (for-template racket/base) + racket/syntax) + +(provide local-apply-transformer) + +(define ((make-quoting-transformer transformer-proc) stx) + (syntax-case stx () + [(_ form) + (let ([result (transformer-proc #'form)]) + (unless (syntax? result) + (raise-arguments-error 'local-apply-transformer + "received value from syntax expander was not syntax" + "received" result)) + #`(quote #,result))])) + +(define (local-apply-transformer transformer stx context [intdef-ctxs '()]) + (unless (or (set!-transformer? transformer) + (and (procedure? transformer) + (procedure-arity-includes? transformer 1))) + (raise-argument-error 'local-apply-transformer + "(or/c (-> syntax? syntax?) set!-transformer?)" + transformer)) + (unless (syntax? stx) + (raise-argument-error 'local-apply-transformer "syntax?" stx)) + (unless (or (eq? context 'expression) + (eq? context 'top-level) + (eq? context 'module) + (eq? context 'module-begin) + (list? context)) + (raise-argument-error 'local-apply-transformer + "(or/c 'expression 'top-level 'module 'module-begin list?)" + context)) + (unless (and (list? intdef-ctxs) + (andmap internal-definition-context? intdef-ctxs)) + (raise-argument-error 'local-apply-transformer + "(listof internal-definition-context?)" + intdef-ctxs)) + (unless (syntax-transforming?) + (raise-arguments-error 'local-apply-transformer "not currently expanding")) + (let* ([intdef-ctx (syntax-local-make-definition-context #f #f)] + [transformer-proc (if (set!-transformer? transformer) + (set!-transformer-procedure transformer) + transformer)] + [transformer-id (internal-definition-context-introduce + intdef-ctx + (generate-temporary 'local-apply-transformer))] + [intdef-ctxs* (cons intdef-ctx intdef-ctxs)]) + (syntax-local-bind-syntaxes + (list transformer-id) + #`(quote #,(make-quoting-transformer transformer-proc)) + intdef-ctx) + (syntax-case (local-expand #`(#,transformer-id #,stx) context '() intdef-ctxs*) (quote) + [(quote form) #'form]))) diff -Nru racket-6.12+ppa1/collects/syntax/contract.rkt racket-7.0+ppa1/collects/syntax/contract.rkt --- racket-6.12+ppa1/collects/syntax/contract.rkt 2017-04-07 18:22:42.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -96,24 +96,28 @@ [(eq? source 'unknown) #'(quote "unknown")] [(eq? source 'from-macro) - (if (syntax? ctx) - (get-source-expr (extract-source ctx) #f) - (get-source-expr 'unknown #f))] + (get-source-expr (extract-source ctx) #f)] [(string? source) #`(quote #,source)] [(syntax? source) #`(quote #,(source-location->string source))] [(module-path-index? source) - ;; FIXME: extend collapse-module-path-index to accept #f, return rel mod path - (let* ([here (current-load-relative-directory)] - [collapsed - (collapse-module-path-index source (or here (build-path 'same)))]) - (cond [(and (path? collapsed) here) - #`(quote #,collapsed)] - [(path? collapsed) - (let-values ([(rel base) (module-path-index-split source)]) - #`(quote #,rel))] - [else - #`(quote #,(format "~s" collapsed))]))])) + ;; FIXME: This assumes that if source is relative, it is relative to + ;; the current self-index (the module currently being compiled). That + ;; should usually be the case, but it's not necessarily true. + (define collapsed (collapse-module-path-index source)) + (cond [(eq? collapsed #f) + #'(quote-module-path)] + [(relative-module-path? collapsed) + #`(relative-source (variable-reference->module-path-index + (#%variable-reference)) + '#,collapsed)] + [else #`(quote #,collapsed)])])) +(define (relative-module-path? mp) + (or (string? mp) (path? mp) + (and (pair? mp) (eq? (car mp) 'submod) + (let ([base (cadr mp)]) (or (string? base) (path? base)))))) + +;; extract-source : (U Syntax #f) -> (U ModulePathIndex 'use-site 'unknown) (define (extract-source stx) (let ([id (syntax-case stx () [(x . _) (identifier? #'x) #'x] @@ -124,3 +128,17 @@ (cond [(list? b) (car b)] ;; module-path-index [else 'use-site])) 'unknown))) + +(module source racket/base + (provide relative-source) + (define (relative-source base-mpi rel-mod-path) + (define r + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join rel-mod-path base-mpi)))) + (cond [(pair? r) + (cons 'submod r)] + [(symbol? r) + (list 'quote r)] + [else r]))) +(require (for-template (submod "." source))) diff -Nru racket-6.12+ppa1/collects/syntax/kerncase.rkt racket-7.0+ppa1/collects/syntax/kerncase.rkt --- racket-6.12+ppa1/collects/syntax/kerncase.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/kerncase.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -102,6 +102,7 @@ case-lambda if quote + quote-syntax letrec-syntaxes+values with-continuation-mark #%expression @@ -109,6 +110,7 @@ #%top #%datum #%variable-reference + #%plain-module-begin module module* #%provide #%require #%declare)))) (provide kernel-syntax-case diff -Nru racket-6.12+ppa1/collects/syntax/modcode.rkt racket-7.0+ppa1/collects/syntax/modcode.rkt --- racket-6.12+ppa1/collects/syntax/modcode.rkt 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/modcode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,14 +1,11 @@ #lang racket/base (require racket/contract/base - racket/list - racket/path - "modread.rkt") + "private/modcode-noctc.rkt") -(provide moddep-current-open-input-file - exn:get-module-code - exn:get-module-code? - exn:get-module-code-path - make-exn:get-module-code) +(provide (except-out (all-from-out "private/modcode-noctc.rkt") + get-module-code + get-module-path + get-metadata-path)) (provide/contract [get-module-code @@ -40,249 +37,3 @@ (#:roots (listof (or/c path-string? 'same))) #:rest (listof (or/c path-string? 'same)) path?)]) - -(define moddep-current-open-input-file - (make-parameter open-input-file)) - -(define (resolve s) - (if (complete-path? s) - s - (let ([d (current-load-relative-directory)]) - (if d (path->complete-path s d) s)))) - -(define (date>=? a bm) - (and a - (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (file-or-directory-modify-seconds a))]) - (and am (if bm (>= am bm) #t))))) - -(define (read-one orig-path path src? read-src-syntax) - (define p ((moddep-current-open-input-file) path)) - (when src? (port-count-lines! p)) - (define (reader) - (define-values (base name dir?) (split-path orig-path)) - (define unchecked-v - (with-module-reading-parameterization - (lambda () - ;; In case we're reading a .zo, we need to set - ;; the load-relative directory for unmarshaling - ;; path literals. - (parameterize ([current-load-relative-directory - (if (path? base) base (current-directory))]) - (read-src-syntax path p))))) - (when (eof-object? unchecked-v) - (error 'read-one "empty file; expected a module declaration in: ~a" path)) - (define sym - (string->symbol - (bytes->string/utf-8 (path->bytes (path-replace-extension name #"")) #\?))) - (define checked-v (check-module-form unchecked-v sym path)) - (unless (eof-object? (read p)) - (error 'read-one - "file has more than one expression; expected a module declaration only in: ~a" - path)) - (if (and (syntax? checked-v) (compiled-expression? (syntax-e checked-v))) - (syntax-e checked-v) - checked-v)) - (define (closer) (close-input-port p)) - (dynamic-wind void reader closer)) - -(define-struct (exn:get-module-code exn:fail) (path)) - -(define (reroot-path* base root) - (cond - [(eq? root 'same) base] - [(relative-path? root) (build-path base root)] - [else (reroot-path base root)])) - -;; : (or/c path-string? 'same) -> (or/c path? 'same) -(define (path-string->path ps) - (if (string? ps) (string->path ps) ps)) - -;; : (listof (or/c path-string? 'same)) -> (listof (or/c path? 'same)) -(define (root-strs->roots root-strs) - (map path-string->path root-strs)) - -(define (get-metadata-path - #:roots [root-strs (current-compiled-file-roots)] - base-str . arg-strs) - (define base (path-string->path base-str)) - (define roots (root-strs->roots root-strs)) - (define args (root-strs->roots arg-strs)) - (cond - [(or (equal? roots '(same)) (null? roots)) - (apply build-path base args)] - [else - (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) - (define p (apply build-path (reroot-path* base root) args)) - (and (file-exists? p) p)) - (apply build-path (reroot-path* base (car roots)) args))])) - -(define (get-module-path - path0-str - #:roots [root-strs (current-compiled-file-roots)] - #:submodule? [submodule? #f] - #:sub-path [sub-path/kw "compiled"] - [sub-path sub-path/kw] - #:choose [choose (lambda (src zo so) #f)] - #:rkt-try-ss? [rkt-try-ss? #t]) - (define path0 (path-string->path path0-str)) - (define roots (root-strs->roots root-strs)) - (define resolved-path (resolve path0)) - (define-values (path0-rel path0-file path0-dir?) (split-path path0)) - (define-values (main-src-file alt-src-file) - (if rkt-try-ss? - (let* ([b (path->bytes path0-file)] - [len (bytes-length b)]) - (cond - [(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4)))) - ;; .rkt => try .rkt then .ss - (values path0-file - (bytes->path (bytes-append (subbytes b 0 (- len 4)) - #".ss")))] - [else - ;; No search path - (values path0-file #f)])) - (values path0-file #f))) - (define main-src-path - (if (eq? main-src-file path0-file) - resolved-path - (build-path path0-rel main-src-file))) - (define alt-src-path - (and alt-src-file - (if (eq? alt-src-file path0-file) - resolved-path - (build-path path0-rel alt-src-file)))) - (define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) - (define main-src-date - (file-or-directory-modify-seconds main-src-path #f (lambda () #f))) - (define alt-src-date - (and alt-src-path - (not main-src-date) - (file-or-directory-modify-seconds alt-src-path #f (lambda () #f)))) - (define src-date (or main-src-date alt-src-date)) - (define src-file (if alt-src-date alt-src-file main-src-file)) - (define src-path (if alt-src-date alt-src-path main-src-path)) - (define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date))) - (define (get-so file) - (get-metadata-path #:roots roots - path0-base - sub-path - "native" - (system-library-subpath) - (path-add-extension file (system-type 'so-suffix)))) - (define zo - (get-metadata-path #:roots roots - path0-base - sub-path - (path-add-extension src-file #".zo"))) - (define alt-zo - (and try-alt? - (get-metadata-path #:roots roots - path0-base - sub-path - (path-add-extension alt-src-file #".zo")))) - (define so (get-so src-file)) - (define alt-so (and try-alt? (get-so alt-src-file))) - (define prefer (choose src-path zo so)) - (cond - ;; Use .zo, if it's new enough - [(or (eq? prefer 'zo) - (and (not prefer) - (pair? roots) - (or (date>=? zo src-date) - (and try-alt? - (date>=? alt-zo src-date))))) - (let ([zo (if (date>=? zo src-date) - zo - (if (and try-alt? (date>=? alt-zo src-date)) - alt-zo - zo))]) - (values (simple-form-path zo) 'zo))] - ;; Maybe there's an .so? Use it only if we don't prefer source - ;; and only if there's no submodule path. - [(and (not submodule?) - (or (eq? prefer 'so) - (and (not prefer) - (pair? roots) - (or (date>=? so src-date) - (and try-alt? - (date>=? alt-so src-date)))))) - (let ([so (if (date>=? so src-date) - so - (if (and try-alt? (date>=? alt-so src-date)) - alt-so - so))]) - (values (simple-form-path so) 'so))] - ;; Use source if it exists - [(or (eq? prefer 'src) src-date) - (values (simple-form-path src-path) 'src)] - ;; Report a not-there error - [else (raise (make-exn:get-module-code - (format "get-module-code: no such file: ~e" resolved-path) - (current-continuation-marks) - #f))])) - -(define (get-module-code - path0-str - #:roots [root-strs (current-compiled-file-roots)] - #:submodule-path [submodule-path '()] - #:sub-path [sub-path/kw "compiled"] - [sub-path sub-path/kw] - #:compile [compile/kw compile] - [compiler compile/kw] - #:extension-handler [ext-handler/kw #f] - [ext-handler ext-handler/kw] - #:choose [choose (lambda (src zo so) #f)] - #:notify [notify void] - #:source-reader [read-src-syntax read-syntax] - #:rkt-try-ss? [rkt-try-ss? #t]) - (define path0 (path-string->path path0-str)) - (define roots (root-strs->roots root-strs)) - (define-values (path type) - (get-module-path - path0 - #:roots roots - #:submodule? (pair? submodule-path) - #:sub-path sub-path - #:choose choose - #:rkt-try-ss? rkt-try-ss?)) - (define (extract-submodule m [sm-path submodule-path]) - (cond - [(null? sm-path) m] - [else - (extract-submodule - (or (for/or ([c (in-list (append (module-compiled-submodules m #t) - (module-compiled-submodules m #f)))]) - (and (eq? (last (module-compiled-name c)) (car sm-path)) - c)) - (raise - (make-exn:get-module-code - (format "get-module-code: cannot find submodule: ~e" sm-path) - (current-continuation-marks) - #f))) - (cdr sm-path))])) - (case type - [(zo) - (notify path) - (extract-submodule (read-one path0 path #f read-syntax))] - [(so) - (if ext-handler - (begin - (notify path) - (ext-handler path #f)) - (raise (make-exn:get-module-code - (format "get-module-code: cannot use extension file; ~e" path) - (current-continuation-marks) - path)))] - [(src) - (notify path) - (define (compile-one) - (define-values (path0-base path0-name path0-dir?) (split-path path0)) - (parameterize ([current-load-relative-directory - (if (path? path0-base) path0-base (current-directory))]) - (compiler (read-one path0 path #t read-src-syntax)))) - (if (null? submodule-path) - ;; allow any result: - (compile-one) - ;; expect a compiled-module result: - (extract-submodule (compile-one)))])) diff -Nru racket-6.12+ppa1/collects/syntax/moddep.rkt racket-7.0+ppa1/collects/syntax/moddep.rkt --- racket-6.12+ppa1/collects/syntax/moddep.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/moddep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,24 +10,49 @@ (all-from-out "modresolve.rkt") show-import-tree) - (define (show-import-tree module-path) - (let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""]) - (printf "~a~a~a\n" indent path fs) - (let ([code (get-module-code path)]) - (let ([imports (module-compiled-imports code)]) - (define ((mk-loop fs) i) - (let ([p (resolve-module-path-index i path)]) - (unless (symbol? p) - (loop p - (format " ~a" indent) - fs)))) - (for-each (lambda (i) - (for-each - (mk-loop (case (car i) - [(0) ""] - [(1) " [for-syntax]"] - [(-1) " [for-syntax]"] - [(#f) " [for-label]"] - [else (format " [for-meta ~a]" (car i))])) - (cdr i))) - imports)))))) + (define (show-import-tree module-path + #:dag? [dag? #f] + #:path-to [given-path-to #f]) + (define path-to (and given-path-to (simplify-path (resolve-module-path given-path-to #f)))) + (define seen (and dag? (make-hash))) + (let loop ([path (resolve-module-path module-path #f)] [indent ""] [fs ""] [phase 0] [accum '()]) + (unless path-to + (printf "~a~a~a ~a\n" indent path fs phase)) + (when (equal? path-to path) + (let ([accum (let loop ([accum (cons (list indent path fs phase) accum)]) + (cond + [(null? accum) null] + [(hash-ref seen accum #f) null] + [else + (hash-set! seen accum #t) + (cons (car accum) (loop (cdr accum)))]))]) + (for ([i (in-list (reverse accum))]) + (apply printf "~a~a~a ~a\n" i)))) + (unless (and seen (hash-ref seen (cons path phase) #f)) + (when seen (hash-set! seen (cons path phase) #t)) + (define plain-path (if (pair? path) (cadr path) path)) + (let ([code (get-module-code plain-path + #:submodule-path (if (pair? path) (cddr path) '()))]) + (let ([imports (module-compiled-imports code)] + [accum (cons (list indent path fs phase) accum)]) + (define ((mk-loop phase-shift fs) i) + (let ([p (resolve-module-path-index i plain-path)]) + (unless (symbol? p) + (loop (if (path? p) + (simplify-path p) + (list* 'submod (simplify-path (cadr p)) (cddr p))) + (format " ~a" indent) + fs + (and phase phase-shift (+ phase phase-shift)) + accum)))) + (for-each (lambda (i) + (for-each + (mk-loop (car i) + (case (car i) + [(0) ""] + [(1) " [for-syntax]"] + [(-1) " [for-template]"] + [(#f) " [for-label]"] + [else (format " [for-meta ~a]" (car i))])) + (cdr i))) + imports))))))) diff -Nru racket-6.12+ppa1/collects/syntax/modread.rkt racket-7.0+ppa1/collects/syntax/modread.rkt --- racket-6.12+ppa1/collects/syntax/modread.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/modread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,9 +1,6 @@ (module modread racket/base - (require racket/contract/base) - - (provide with-module-reading-parameterization) - (provide/contract - [check-module-form ((or/c syntax? eof-object?) (or/c symbol? list?) (or/c string? path? false/c) . -> . any)]) + (provide with-module-reading-parameterization + check-module-form) (define (with-module-reading-parameterization thunk) (call-with-default-reading-parameterization @@ -19,6 +16,13 @@ expected-name filename name)) (define (check-module-form exp expected-module filename) + (unless (or (syntax? exp) (eof-object? exp)) + (raise-argument-error 'check-module-form "(or/c syntax? eof-object?)" exp)) + (unless (or (symbol? expected-module) (list? expected-module)) + (raise-argument-error 'check-module-form "(or/c symbol? list?)" list)) + (unless (or (not filename) (path-string? filename)) + (raise-argument-error 'check-module-form "(or/c path-string? false/c)" list)) + (cond [(or (eof-object? exp) (eof-object? (syntax-e exp))) (and filename (error 'load-handler diff -Nru racket-6.12+ppa1/collects/syntax/modresolve.rkt racket-7.0+ppa1/collects/syntax/modresolve.rkt --- racket-6.12+ppa1/collects/syntax/modresolve.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/modresolve.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,132 +1,6 @@ #lang racket/base (require racket/contract/base - racket/path - "private/modhelp.rkt") - -(define (force-relto relto dir? #:path? [path? #t]) - (let ([relto (if (and (pair? relto) - (eq? (car relto) 'submod)) - (cadr relto) - relto)] - [submod (if (and (pair? relto) - (eq? (car relto) 'submod)) - (cddr relto) - null)]) - (cond [(path-string? relto) - (values (and path? - (if dir? - (let-values ([(base n d?) (split-path relto)]) - (when d? - (error 'resolve-module-path-index - "given a directory path instead of a file path: ~e" relto)) - (if (eq? base 'relative) - (or (current-load-relative-directory) (current-directory)) - base)) - relto)) - submod)] - [(pair? relto) (values relto submod)] - [(not dir?) - (values - (and path? - (error 'resolve-module-path-index - "can't resolve \"self\" with non-path relative-to: ~e" relto)) - submod)] - [(procedure? relto) (force-relto (relto) dir? #:path? path?)] - [else (values (and path? (current-directory)) submod)]))) - -(define (path-ss->rkt p) - (if (path-has-extension? p #".ss") - (path-replace-extension p #".rkt") - p)) - -(define (combine-submod v p) - (if (null? p) - v - (list* 'submod v p))) - -(define (flatten base orig-p) - (let loop ([accum '()] [p orig-p]) - (cond - [(null? p) (combine-submod base (reverse accum))] - [(equal? (car p) "..") - (if (null? accum) - (error 'resolve-module-path "too many \"..\"s: ~s" - (combine-submod base orig-p)) - (loop (cdr accum) (cdr p)))] - [else (loop (cons (car p) accum) (cdr p))]))) - -(define (resolve-module-path s [relto #f]) - ;; relto should be a complete path, #f, or procedure that returns a - ;; complete path - (define (get-dir) (force-relto relto #t)) - (cond [(symbol? s) - ;; use resolver handler: - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join s #f)))] - [(string? s) - ;; Parse Unix-style relative path string - (define-values (dir submod) (get-dir)) - (path-ss->rkt - (apply build-path dir (explode-relpath-string s)))] - [(and (or (not (pair? s)) (not (list? s))) (not (path? s))) - #f] - [(or (path? s) (eq? (car s) 'file)) - (let ([p (if (path? s) s (expand-user-path (cadr s)))]) - (define-values (d submod) (get-dir)) - (path-ss->rkt - (path->complete-path - p - (if (path-string? d) - d - (or (current-load-relative-directory) - (current-directory))))))] - [(or (eq? (car s) 'lib) - (eq? (car s) 'quote) - (eq? (car s) 'planet)) - ;; use resolver handler in this case, too: - (define-values (d submod) (force-relto relto #f #:path? #f)) - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join s #f)))] - [(eq? (car s) 'submod) - (define r (cond - [(or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (define-values (d submod) (force-relto relto #f)) - (combine-submod d submod)] - [else (resolve-module-path (cadr s) relto)])) - (define base-submods (if (and (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (pair? r)) - (cddr r) - null)) - (define base (if (pair? r) (cadr r) r)) - (flatten base (append base-submods - (if (equal? (cadr s) "..") (cdr s) (cddr s))))] - [else #f])) - -(define (resolve-module-path-index mpi [relto #f]) - ;; relto must be a complete path - (let-values ([(path base) (module-path-index-split mpi)]) - (if path - (resolve-module-path path (resolve-possible-module-path-index base relto)) - (let () - (define sm (module-path-index-submodule mpi)) - (define-values (dir submod) (force-relto relto #f)) - (combine-submod (path-ss->rkt dir) (if (and sm submod) - (append submod sm) - (or sm submod))))))) - -(define (resolve-possible-module-path-index base [relto #f]) - (cond [(module-path-index? base) - (resolve-module-path-index base relto)] - [(and (resolved-module-path? base) - (path? (resolved-module-path-name base))) - (resolved-module-path-name base)] - [relto relto] - [else #f])) - + "private/modresolve-noctc.rkt") (define rel-to-path-string/c (or/c path-string? (cons/c 'submod (cons/c path-string? (listof symbol?))))) diff -Nru racket-6.12+ppa1/collects/syntax/parse/define.rkt racket-7.0+ppa1/collects/syntax/parse/define.rkt --- racket-6.12+ppa1/collects/syntax/parse/define.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/define.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,11 +8,11 @@ (define-syntax (define-simple-macro stx) (syntax-parse stx - [(define-simple-macro (~and (macro:id . _) pattern) . body) + [(define-simple-macro (macro:id . pattern) . body) #`(define-syntax macro (syntax-parser/template #,((make-syntax-introducer) stx) - [pattern . body]))])) + [((~var macro id) . pattern) . body]))])) (define-simple-macro (define-syntax-parser macro:id option-or-clause ...) (define-syntax macro diff -Nru racket-6.12+ppa1/collects/syntax/parse/experimental/dset.rkt racket-7.0+ppa1/collects/syntax/parse/experimental/dset.rkt --- racket-6.12+ppa1/collects/syntax/parse/experimental/dset.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/experimental/dset.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -#lang racket/base - -;; A dset is an `equal?`-based set, but it preserves order based on -;; the history of additions, so that if items are added in a -;; deterministic order, they come back out in a deterministic order. - -(provide dset - dset-empty? - dset->list - dset-add - dset-union - dset-subtract - dset-filter) - -(define dset - (case-lambda - [() (hash)] - [(e) (hash e 0)])) - -(define (dset-empty? ds) - (zero? (hash-count ds))) - -(define (dset->list ds) - (map cdr - (sort (for/list ([(k v) (in-hash ds)]) - (cons v k)) - < - #:key car))) - -(define (dset-add ds e) - (if (hash-ref ds e #f) - ds - (hash-set ds e (hash-count ds)))) - -(define (dset-union ds1 ds2) - (cond - [((hash-count ds1) . > . (hash-count ds2)) - (dset-union ds2 ds1)] - [else - (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) - (dset-add ds2 e))])) - -(define (dset-subtract ds1 ds2) - ;; ! takes O(size(ds2)) time ! - (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) - (if (hash-ref ds2 e #f) - r - (dset-add r e)))) - -(define (dset-filter ds pred) - (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) - (if (pred e) - (dset-add r e) - r))) diff -Nru racket-6.12+ppa1/collects/syntax/parse/experimental/template.rkt racket-7.0+ppa1/collects/syntax/parse/experimental/template.rkt --- racket-6.12+ppa1/collects/syntax/parse/experimental/template.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/experimental/template.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,492 +1,17 @@ #lang racket/base -(require (for-syntax racket/base - "dset.rkt" - racket/syntax - syntax/parse/private/minimatch - racket/private/stx ;; syntax/stx - racket/private/sc) - syntax/parse/private/residual - racket/private/stx - racket/performance-hint - racket/private/promise) -(provide template - template/loc - datum-template - quasitemplate - quasitemplate/loc - define-template-metafunction - ?? - ?@) - -;; ============================================================ -;; Syntax of templates - -;; A Template (T) is one of: -;; - pattern-variable -;; - constant (including () and non-pvar identifiers) -;; - (metafunction . T) -;; - (H . T) -;; - (H ... . T), (H ... ... . T), etc -;; - (?? T T) -;; - #(T*) -;; - #s(prefab-struct-key T*) -;; * (unsyntax expr) - -;; A HeadTemplate (H) is one of: -;; - T -;; - (?? H) -;; - (?? H H) -;; - (?@ . T) -;; * (unquote-splicing expr) - -(define-syntaxes (?? ?@) - (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) - (values tx tx))) - -(define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing - -;; ============================================================ -;; Compile-time - -;; Parse template syntax into a Guide (AST--the name is left over from -;; when the "guide" was a data structure interpreted at run time). - -;; The AST representation is designed to coincide with the run-time -;; support, so compilation is just (datum->syntax #'here guide). - -;; A Guide (G) is one of: -;; - (list 't-resyntax G) ;; template is syntax; re-syntax result -;; - (list 't-const) ;; constant -;; - (list 't-var PVar Boolean) ;; pattern variable -;; - (list 't-cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr} -;; - (list 't-vector G) ;; template is non-syntax vector -;; - (list 't-struct G) ;; template is non-syntax prefab struct -;; - (list 't-box G) ;; template is non-syntax box -;; - (list 't-dots HG (listof (listof PVar)) Nat G/#f #f Boolean) -;; - (list 't-dots G (listof (listof PVar)) Nat G/#f #t Boolean) -;; - (list 't-append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr} -;; - (list 't-escaped G) -;; - (list 't-orelse G G) -;; - (list 't-metafun Id G) -;; - (list 't-relocate G Id) ;; relocate syntax -;; - (list 't-resyntax/loc G Id) ;; like t-resyntax, but use alt srcloc -;; For 't-var and 't-dots, the final boolean indicates whether the template -;; fragment is in the left-hand side of an orelse (??). - -;; A HeadGuide (HG) is one of: -;; - (list 'h-t G) -;; - (list 'h-orelse HG HG/#f) -;; - (list 'h-splice G) - -;; A PVar is (pvar Id Id Boolean Nat/#f) -;; -;; The first identifier (var) is from the syntax-mapping or attribute-binding. -;; The second (lvar) is a local variable name used to hold its value (or parts -;; thereof) in ellipsis iteration. The boolean is #f if var is trusted to have a -;; (Listof^depth Syntax) value, #t if it needs to be checked. -;; -;; The depth-delta associated with a depth>0 pattern variable is the difference -;; between the pattern variable's depth and the depth at which it is used. (For -;; depth 0 pvars, it's #f.) For example, in -;; -;; (with-syntax ([x #'0] -;; [(y ...) #'(1 2)] -;; [((z ...) ...) #'((a b) (c d))]) -;; (template (((x y) ...) ...))) -;; -;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for -;; z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis -;; form at which the variable should be moved to the loop-env. That is, the -;; template above should be interpreted as roughly similar to -;; -;; (let ([x (pvar-value-of x)] -;; [y (pvar-value-of y)] -;; [z (pvar-value-of z)]) -;; (for ([Lz (in-list z)]) ;; depth 0 -;; (for ([Ly (in-list y)] ;; depth 1 -;; [Lz (in-list Lz)]) -;; (___ x Ly Lz ___)))) - -(begin-for-syntax - - (define-logger template) - - (struct pvar (var lvar check? dd) #:prefab) - (struct template-metafunction (var)) - - (define (ht-guide? x) (match x [(list 'h-t _) #t] [_ #f])) - (define (ht-guide-t x) (match x [(list 'h-t g) g])) - - (define const-guide '(t-const)) - (define (const-guide? x) (equal? x const-guide)) - - ;; ---------------------------------------- - ;; Parsing templates - - ;; parse-template : Syntax Boolean -> (values (listof PVar) Guide) - (define (parse-template t stx?) - ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] - (define env (make-hasheq)) - - ;; parse-t : Stx Nat Boolean Boolean -> (values (dsetof PVar) Guide) - (define (parse-t t depth esc? in-try?) - (cond [(stx-pair? t) - (if (identifier? (stx-car t)) - (parse-t-pair/command t depth esc? in-try?) - (parse-t-pair/dots t depth esc? in-try?))] - [else (parse-t-nonpair t depth esc? in-try?)])) - - ;; parse-t-pair/command : Stx Nat Boolean Boolean -> ... - ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) - (define (parse-t-pair/command t depth esc? in-try?) - (syntax-case t (??) - [(DOTS template) - (and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(drivers guide) (parse-t #'template depth #t in-try?)]) - (values drivers `(t-escaped ,guide)))] - [(?? t1 t2) - (not esc?) - (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc? #t)] - [(drivers2 guide2) (parse-t #'t2 depth esc? in-try?)]) - (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] - [(mf-id . _) - (and (not esc?) (lookup-metafun #'mf-id)) - (let-values ([(mf) (lookup-metafun #'mf-id)] - [(drivers guide) (parse-t (stx-cdr t) depth esc? in-try?)]) - (unless stx? (wrong-syntax "metafunctions not supported" #'mf-id)) - (values drivers `(t-metafun ,(template-metafunction-var mf) ,guide)))] - [_ (parse-t-pair/dots t depth esc? in-try?)])) - - ;; parse-t-pair/dots : Stx Nat Boolean Boolean -> ... - ;; t is a stx pair; check for dots - (define (parse-t-pair/dots t depth esc? in-try?) - (define head (stx-car t)) - (define-values (tail nesting) - (let loop ([tail (stx-cdr t)] [nesting 0]) - (if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail))) - (loop (stx-cdr tail) (add1 nesting)) - (values tail nesting)))) - (if (zero? nesting) - (parse-t-pair/normal t depth esc? in-try?) - (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)] - [(tdrivers tguide) - (if (null? tail) - (values (dset) #f) - (parse-t tail depth esc? in-try?))]) - (when (dset-empty? hdrivers) - (wrong-syntax head "no pattern variables before ellipsis in template")) - (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) - (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one - (stx-car (stx-drop nesting t))]) - ;; FIXME: improve error message? - (wrong-syntax bad-dots "too many ellipses in template"))) - ;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level - (define hdriverss ;; per level - (for/list ([i (in-range nesting)]) - (dset-filter hdrivers (pvar/dd<=? (+ depth i))))) - (define new-hdriverss ;; per level - (let loop ([raw hdriverss] [last (dset)]) - (cond [(null? raw) null] - [else - (define new-hdrivers (dset->list (dset-subtract (car raw) last))) - (cons new-hdrivers (loop (cdr raw) (car raw)))]))) - (values (dset-union hdrivers tdrivers) - (let ([cons? (ht-guide? hguide)] - [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) - (resyntax t `(t-dots ,hguide ,new-hdriverss ,nesting ,tguide ,cons? ,in-try?))))))) - - ;; parse-t-pair/normal : Stx Nat Boolean Boolean -> ... - ;; t is a normal stx pair - (define (parse-t-pair/normal t depth esc? in-try?) - (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc? in-try?)) - (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc? in-try?)) - (values (dset-union hdrivers tdrivers) - (let ([kind (if (ht-guide? hguide) 't-cons/p 't-append/p)] - [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) - (resyntax t `(,kind ,hguide ,tguide))))) - - ;; parse-t-nonpair : Stx Nat Boolean Boolean -> ... - ;; PRE: t is not a stxpair - (define (parse-t-nonpair t depth esc? in-try?) - (syntax-case t (?? ?@) - [id - (identifier? #'id) - (cond [(and (not esc?) - (or (free-identifier=? #'id (quote-syntax ...)) - (free-identifier=? #'id (quote-syntax ??)) - (free-identifier=? #'id (quote-syntax ?@)))) - (wrong-syntax #'id "illegal use")] - [(lookup-metafun #'id) - (wrong-syntax t "illegal use of syntax metafunction")] - [(lookup #'id depth) - => (lambda (pvar) (values (dset pvar) `(t-var ,pvar ,in-try?)))] - [else (values (dset) const-guide)])] - [vec - (vector? (syntax-e #'vec)) - (let-values ([(drivers guide) - (parse-t (vector->list (syntax-e #'vec)) depth esc? in-try?)]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-vector ,guide)))))] - [pstruct - (prefab-struct-key (syntax-e #'pstruct)) - (let-values ([(drivers guide) - (let ([elems (cdr (vector->list (struct->vector (syntax-e #'pstruct))))]) - (parse-t elems depth esc? in-try?))]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-struct ,guide)))))] - [#&template - (let-values ([(drivers guide) - (parse-t #'template depth esc? in-try?)]) - (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-box ,guide)))))] - [const - (values (dset) const-guide)])) - - ;; parse-h : Syntax Nat Boolean Boolean -> (values (dsetof PVar) HeadGuide) - (define (parse-h h depth esc? in-try?) - (syntax-case h (?? ?@ ?@!) - [(?? t) - (not esc?) - (let-values ([(drivers guide) (parse-h #'t depth esc? #t)]) - (values drivers `(h-orelse ,guide #f)))] - [(?? t1 t2) - (not esc?) - (let-values ([(drivers1 guide1) (parse-h #'t1 depth esc? #t)] - [(drivers2 guide2) (parse-h #'t2 depth esc? in-try?)]) - (values (dset-union drivers1 drivers2) - (if (and (ht-guide? guide1) (ht-guide? guide2)) - `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) - `(h-orelse ,guide1 ,guide2))))] - [(?@ . _) - (not esc?) - (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) - (values drivers `(h-splice ,guide)))] - [(?@! . _) - (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) - (values drivers `(h-splice ,guide)))] - [t - (let-values ([(drivers guide) (parse-t #'t depth esc? in-try?)]) - (values drivers `(h-t ,guide)))])) - - ;; lookup : Identifier Nat -> PVar/#f - (define (lookup id depth) - (define variable? (if stx? syntax-pattern-variable? s-exp-pattern-variable?)) - (let ([v (syntax-local-value/record id variable?)]) - (cond [(syntax-pattern-variable? v) - (hash-ref! env (cons v depth) - (lambda () - (define pvar-depth (syntax-mapping-depth v)) - (define attr - (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) - (and (attribute-mapping? attr) attr))) - (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) - (define check? (and attr (not (attribute-mapping-syntax? attr)))) - (cond [(zero? pvar-depth) - (pvar var var check? #f)] - [(>= depth pvar-depth) - (define lvar (car (generate-temporaries #'(pv_)))) - (pvar var lvar check? (- depth pvar-depth))] - [else - (wrong-syntax id "missing ellipses with pattern variable in template")])))] - [(s-exp-pattern-variable? v) - (hash-ref! env (cons v depth) - (lambda () - (define pvar-depth (s-exp-mapping-depth v)) - (define var (s-exp-mapping-valvar v)) - (define check? #f) - (cond [(zero? pvar-depth) - (pvar var var #f #f)] - [(>= depth pvar-depth) - (define lvar (car (generate-temporaries #'(pv_)))) - (pvar var lvar #f (- depth pvar-depth))] - [else - (wrong-syntax id "missing ellipses with pattern variable in template")])))] - [else - ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute - (for ([pfx (in-list (dotted-prefixes id))]) - (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) - (when (and (syntax-pattern-variable? pfx-v) - (let ([valvar (syntax-mapping-valvar pfx-v)]) - (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) - (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) - #f]))) - - ;; resyntax : Stx Guide -> Guide - (define (resyntax t g) (if (and stx? (syntax? t)) `(t-resyntax ,g) g)) - - (let-values ([(drivers guide) (parse-t t 0 #f #f)]) - (values (dset->list drivers) guide))) - - ;; lookup-metafun : Identifier -> Metafunction/#f - (define (lookup-metafun id) - (syntax-local-value/record id template-metafunction?)) - - (define (dotted-prefixes id) - (let* ([id-string (symbol->string (syntax-e id))] - [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) - (for/list ([loc (in-list dot-locations)]) - (datum->syntax id (string->symbol (substring id-string 0 loc)))))) - - (define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...)))) - - (define (cons/p-guide g1 g2) - (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/p ,g1 ,g2))) - - (define ((pvar/dd<=? expected-dd) x) - (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))) - - (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) - - (define (restx ctx v) (if (syntax? ctx) (datum->syntax ctx v ctx ctx) v)) - - ;; ---------------------------------------- - ;; Relocating (eg, template/loc) - - ;; Only relocate if relocation would affect a syntax pair originating - ;; from template structure. For example: - ;; (template/loc loc-stx (1 2 3)) => okay - ;; (template/loc loc-stx pvar) => don't relocate - - ;; relocate-guide : Guide Id -> Guide - (define (relocate-guide g0 loc-id) - (define (error/no-relocate) - (wrong-syntax #f "cannot apply syntax location to template")) - (define (loop g) - (match g - [(list 't-resyntax g1) - (list 't-resyntax/loc g1 loc-id)] - [(list 't-const) - `(t-relocate ,g ,loc-id)] - ;; ---- - [(list 't-escaped g1) - (list 't-escaped (loop g1))] - [(list 't-orelse g1 g2) - (list 't-orelse (loop g1) (loop g2))] - ;; ---- - ;; Variables shouldn't be relocated. - [(list 't-var pvar in-try?) g] - ;; ---- - ;; Otherwise, cannot relocate: t-metafun, anything else? - [_ (error/no-relocate)])) - (loop g0)) - - ;; ---------------------------------------- - ;; Compilation - - ;; compile-guide : Guide -> Syntax[Expr] - (define (compile-guide g) (datum->syntax #'here g)) - - ;; ---------------------------------------- - - ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax - (define (do-template ctx tstx loc-id stx?) - (with-disappeared-uses - (parameterize ((current-syntax-context ctx)) - (define-values (pvars pre-guide) (parse-template tstx stx?)) - (define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide)) - (syntax-arm - (with-syntax ([t tstx] - [quote-template (if stx? #'quote-syntax #'quote)] - [((var . pvar-val-var) ...) - (for/list ([pvar (in-list pvars)] #:when (pvar-dd pvar)) - (cons (pvar-lvar pvar) (pvar-var pvar)))]) - #`(let ([var pvar-val-var] ...) - (let ([tstx0 (quote-template t)]) - (#,(compile-guide guide) tstx0)))))))) - ) - -(define-syntax (template stx) - (syntax-case stx () - [(template t) - (do-template stx #'t #f #t)] - [(template t #:properties _) - (begin - (log-template-error "template #:properties argument no longer supported: ~e" stx) - (do-template stx #'t #f))])) - -(define-syntax (template/loc stx) - (syntax-case stx () - [(template/loc loc-expr t) - (syntax-arm - (with-syntax ([main-expr (do-template stx #'t #'loc-var #t)]) - #'(let ([loc-var (handle-loc '?/loc loc-expr)]) - main-expr)))])) - - -(define-syntax (datum-template stx) - (syntax-case stx () - [(datum-template t) - (do-template stx #'t #f #f)])) - -(define (handle-loc who x) - (if (syntax? x) x (raise-argument-error who "syntax?" x))) - -;; ============================================================ - -(begin-for-syntax - ;; process-quasi : Syntax -> (list Syntax[with-syntax-bindings] Syntax[expr]) - (define (process-quasi t0) - (define bindings null) - (define (add! binding) (set! bindings (cons binding bindings))) - (define (process t depth) - (define (loop t) (process t depth)) - (define (loop- t) (process t (sub1 depth))) - (define (loop+ t) (process t (add1 depth))) - (syntax-case t (unsyntax unsyntax-splicing quasitemplate) - [(unsyntax expr) - (cond [(zero? depth) - (with-syntax ([(us) (generate-temporaries #'(us))] - [ctx (datum->syntax #'expr 'ctx #'expr)]) - (add! (list #'us #'(check-unsyntax expr (quote-syntax ctx)))) - #'us)] - [else - (restx t (cons (stx-car t) (loop- (stx-cdr t))))])] - [((unsyntax-splicing expr) . _) - (cond [(zero? depth) - (with-syntax ([(us) (generate-temporaries #'(us))] - [ctx (datum->syntax #'expr 'ctx #'expr)]) - (add! (list #'us #'(check-unsyntax-splicing expr (quote-syntax ctx)))) - (restx t (cons #'(?@! . us) (loop (stx-cdr t)))))] - [else - (let ([tcar (stx-car t)] - [tcdr (stx-cdr t)]) - (restx t (cons (restx tcar (cons (stx-car tcar) (loop- (stx-cdr tcar)))) - (loop tcdr))))])] - [(quasitemplate _) - (restx t (cons (stx-car t) (loop+ (stx-cdr t))))] - [unsyntax - (raise-syntax-error #f "misuse within quasitemplate" t0 t)] - [unsyntax-splicing - (raise-syntax-error #f "misuse within quasitemplate" t0 t)] - [_ - (let ([d (if (syntax? t) (syntax-e t) t)]) - (cond [(pair? d) (restx t (cons (loop (car d)) (loop (cdr d))))] - [(vector? d) (restx t (list->vector (loop (vector->list d))))] - [(box? d) (restx t (box (loop (unbox d))))] - [(prefab-struct-key d) - => (lambda (key) - (apply make-prefab-struct key (loop (cdr (vector->list (struct->vector d))))))] - [else t]))])) - (define t* (process t0 0)) - (list (reverse bindings) t*))) - -(define-syntax (quasitemplate stx) - (syntax-case stx () - [(quasitemplate t) - (with-syntax ([(bindings t*) (process-quasi #'t)]) - #'(with-syntax bindings (template t*)))])) - -(define-syntax (quasitemplate/loc stx) - (syntax-case stx () - [(quasitemplate/loc loc-expr t) - (with-syntax ([(bindings t*) (process-quasi #'t)]) - #'(with-syntax bindings - (template/loc (handle-loc 'quasitemplate/loc loc-expr) t*)))])) - -(define (check-unsyntax v ctx) - (datum->syntax ctx v ctx)) -(define (check-unsyntax-splicing v ctx) - (unless (stx-list? v) (raise-argument-error 'unsyntax-splicing "syntax->list" v)) - (datum->syntax ctx v ctx)) +(require (for-syntax racket/base) + (only-in racket/private/template + metafunction)) +(provide (rename-out [syntax template] + [syntax/loc template/loc] + [quasisyntax quasitemplate] + [quasisyntax/loc quasitemplate/loc] + [~? ??] + [~@ ?@]) + define-template-metafunction) ;; ============================================================ +;; Metafunctions (define-syntax (define-template-metafunction stx) (syntax-case stx () @@ -495,191 +20,17 @@ [(dsm id expr) (identifier? #'id) (with-syntax ([(internal-id) (generate-temporaries #'(id))]) - #'(begin (define internal-id expr) - (define-syntax id - (template-metafunction (quote-syntax internal-id)))))])) - - -;; ============================================================ -;; Run-time support - -;; Template transcription involves traversing the template syntax object, -;; substituting pattern variables etc. The interpretation of the template is -;; known at compile time, but we still need the template syntax at run time, -;; because it is the basis for generated syntax objects (via datum->syntax). - -;; A template fragment (as opposed to the whole template expression) is compiled -;; to a function of type (Stx -> Stx). It receives the corresponding template -;; stx fragment as its argument. Pattern variables are passed through the -;; environment. We rely on Racket's inliner and optimizer to simplify the -;; resulting code to nearly first-order so that a new tree of closures is not -;; allocated for each template transcription. + #'(begin (define internal-id (make-hygienic-metafunction expr)) + (define-syntax id (metafunction (quote-syntax internal-id)))))])) -;; Note: as an optimization, we track syntax vs non-syntax pairs in the template -;; so we can generate more specific code (hopefully smaller and faster). - -(define-syntax (t-var stx) - (syntax-case stx () - [(t-var #s(pvar var lvar check? _) in-try?) - (cond [(syntax-e #'check?) - #`(lambda (stx) (check-stx stx lvar in-try?))] - [else - #`(lambda (stx) lvar)])])) - -(define-syntax (t-dots stx) - (syntax-case stx () - ;; Case 1: (x ...) where x is trusted. - [(t-dots (t-var #s(pvar _ lvar #f _) _) _drivers 1 #f #t _) - (begin - (log-template-debug "dots case 1: (x ...) where x is trusted") - #'(lambda (stx) lvar))] - ;; General case - [(t-dots head ((#s(pvar _ lvar check? _) ...) ...) nesting tail cons? in-try?) - (let ([cons? (syntax-e #'cons?)] - [lvarss (map syntax->list (syntax->list #'((lvar ...) ...)))] - [check?ss (syntax->datum #'((check? ...) ...))]) - (log-template-debug "dots general case: nesting = ~s, cons? = ~s, #vars = ~s" - (syntax-e #'nesting) cons? (apply + (map length lvarss))) - ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise - ;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)] - ;; -> Syntax[(Listof AccElem) -> (Listof AccElem)] - (define (gen-level lvars check?s inner) - (with-syntax ([(lvar ...) lvars] - [(var-value ...) (map var-value-expr lvars check?s)]) - #`(lambda (acc) - (let loop ([acc acc] [lvar var-value] ...) - (check-same-length lvar ...) - (if (and (pair? lvar) ...) - (loop (let ([lvar (car lvar)] ...) - (#,inner acc)) ;; inner has free refs to {var ...} - (cdr lvar) ...) - acc))))) - ;; var-value-expr : Id Boolean -> Syntax[List] - (define (var-value-expr lvar check?) - (if check? #`(check-list/depth stx #,lvar 1 in-try?) lvar)) - (define head-loop-code - (let nestloop ([lvarss lvarss] [check?ss check?ss] [old-lvars null] [old-check?s null]) - (cond [(null? lvarss) - #'(lambda (acc) (cons (head stx) acc))] - [else - (define lvars* (append (car lvarss) old-lvars)) - (define check?s* (append (car check?ss) old-check?s)) - (gen-level lvars* check?s* - (nestloop (cdr lvarss) (cdr check?ss) lvars* check?s*))]))) - (if cons? - #`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const))) - #`(t-dots* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))))])) - -(begin-encourage-inline - -(define (stx-cadr x) (stx-car (stx-cdr x))) -(define (stx-cddr x) (stx-cdr (stx-cdr x))) -(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) -(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) -(define (restx basis val) - (if (syntax? basis) (datum->syntax basis val basis basis) val)) - -(define ((t-resyntax g) stx) (datum->syntax stx (g (syntax-e stx)) stx stx)) -(define ((t-relocate g loc) stx) - (define new-stx (g stx)) - (datum->syntax new-stx (syntax-e new-stx) loc new-stx)) -(define ((t-resyntax/loc g loc) stx) - (datum->syntax stx (g (syntax-e stx)) loc stx)) - -(define ((t-const) stx) stx) -(define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx)))) -(define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx)))) -(define ((t-dots* h n t) stx) (revappend* (h (car stx)) (t (stx-drop (add1 n) stx)))) -(define ((t-dots1* h n t) stx) (revappend (h (car stx)) (t (stx-drop (add1 n) stx)))) -(define ((t-escaped g) stx) (g (stx-cadr stx))) -(define ((t-orelse g1 g2) stx) - (with-handlers ([absent-pvar? (lambda (e) (if g2 (g2 (stx-caddr stx)) null))]) - (g1 (stx-cadr stx)))) -(define ((t-vector g) stx) (list->vector (g (vector->list stx)))) -(define ((t-box g) stx) (box (g (unbox stx)))) -(define ((t-struct g) stx) - (define key (prefab-struct-key stx)) - (define elems (cdr (vector->list (struct->vector stx)))) - (apply make-prefab-struct key (g elems))) -(define ((t-metafun mf g) stx) - (define stx* (if (syntax? stx) stx (datum->syntax #f stx))) - (define v (restx stx* (cons (stx-car stx) (g (stx-cdr stx))))) - (apply-metafun mf stx* v)) -(define ((h-t g) stx) (list (g stx))) -(define (h-orelse g1 g2) (t-orelse g1 g2)) -(define ((h-splice g) stx) - (let ([r (g (stx-cdr stx))]) - (or (stx->list r) (error/splice stx r)))) -#| end begin-encourage-inline |#) +(define current-template-metafunction-introducer + (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) -(define (apply-metafun mf stx v) +(define ((make-hygienic-metafunction transformer) stx) (define mark (make-syntax-introducer)) (define old-mark (current-template-metafunction-introducer)) (parameterize ((current-template-metafunction-introducer mark)) - (define r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))) + (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx)))))) (unless (syntax? r) (raise-syntax-error #f "result of template metafunction was not syntax" stx)) (old-mark (mark r)))) - -(define (error/splice stx r) - (raise-syntax-error 'template "splicing template did not produce a syntax list" stx)) - -;; revappend* : (Listof (Listof X)) (Listof X) -> (Listof X) -(define (revappend* xss ys) - (if (null? xss) ys (revappend* (cdr xss) (append (car xss) ys)))) - -;; revappend : (Listof X) (Listof X) -> (Listof X) -(define (revappend xs ys) - (if (null? xs) ys (revappend (cdr xs) (cons (car xs) ys)))) - -(define current-template-metafunction-introducer - (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) - -;; Used to indicate absent pvar in template; ?? catches -;; Note: not an exn, don't need continuation marks -(struct absent-pvar (ctx)) - -(define (check-stx ctx v in-try?) - (cond [(syntax? v) v] - [(promise? v) (check-stx ctx (force v) in-try?)] - [(and in-try? (eq? v #f)) (raise (absent-pvar ctx))] - [else (err/not-syntax ctx v)])) - -(define (check-list/depth ctx v0 depth0 in-try?) - (let depthloop ([v v0] [depth depth0]) - (cond [(zero? depth) v] - [(and (= depth 1) (list? v)) v] - [else - (let loop ([v v]) - (cond [(null? v) - null] - [(pair? v) - (let ([new-car (depthloop (car v) (sub1 depth))] - [new-cdr (loop (cdr v))]) - ;; Don't copy unless necessary - (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) - v - (cons new-car new-cdr)))] - [(promise? v) - (loop (force v))] - [(and in-try? (eq? v #f)) - (raise (absent-pvar ctx))] - [else (err/not-syntax ctx v0)]))]))) - -;; FIXME: use raise-syntax-error instead, pass stx args -(define check-same-length - (case-lambda - [(a) (void)] - [(a b) - (unless (= (length a) (length b)) - (error 'syntax "incompatible ellipsis match counts for template"))] - [(a . bs) - (define alen (length a)) - (for ([b (in-list bs)]) - (unless (= alen (length b)) - (error 'template "incompatible ellipsis match counts for template")))])) - -;; Note: slightly different from error msg in syntax/parse/private/residual: -;; here says "contains" instead of "is bound to", because might be within list -(define (err/not-syntax ctx v) - (raise-syntax-error #f (format "attribute contains non-syntax value\n value: ~e" v) ctx)) diff -Nru racket-6.12+ppa1/collects/syntax/parse/pre.rkt racket-7.0+ppa1/collects/syntax/parse/pre.rkt --- racket-6.12+ppa1/collects/syntax/parse/pre.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/pre.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,7 +12,8 @@ syntax-parse-state-ref syntax-parse-state-set! syntax-parse-state-update! - syntax-parse-state-cons!) + syntax-parse-state-cons! + syntax-parse-track-literals) (define not-given (gensym)) @@ -44,3 +45,6 @@ (check-update 'syntax-parse-state-cons!) (define old (hash-ref (current-state) key default)) (current-state (hash-set (current-state) key (cons value old)))) + +(define (syntax-parse-track-literals stx #:introduce? [introduce? #t]) + (track-literals 'syntax-parse-track-literals stx #:introduce? introduce?)) diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/lib.rkt racket-7.0+ppa1/collects/syntax/parse/private/lib.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/lib.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/lib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require "sc.rkt" "keywords.rkt" + (only-in "residual.rkt" state-cons!) (for-syntax syntax/parse/private/residual-ct) (for-syntax racket/base)) @@ -83,4 +84,5 @@ "not within the dynamic extent of a macro transformation" #:attr value (syntax-local-value #'x (lambda () notfound)) #:fail-when (eq? (attribute value) notfound) #f - #:fail-unless (pred (attribute value)) #f)) + #:fail-unless (pred (attribute value)) #f + #:do [(state-cons! 'literals #'x)])) diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/parse.rkt racket-7.0+ppa1/collects/syntax/parse/private/parse.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/parse.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/parse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -211,6 +211,7 @@ #:splicing? #f #:decls (new-declenv null) #:context stx)]) + (define no-fail? (patterns-cannot-fail? (list pattern))) (let ([expr (syntax-case rest () [( expr ) #'expr] @@ -219,14 +220,18 @@ (with-syntax ([(a ...) attrs] [(#s(attr name _ _) ...) attrs] [pattern pattern] + [es0 (if no-fail? #'#f #'#t)] [(def ...) defs] [expr expr]) #'(defattrs/unpack (a ...) (let* ([x (datum->syntax #f expr)] [cx x] [pr (ps-empty x x)] - [es #f] - [fh0 (syntax-patterns-fail x)]) + [es es0] + [fh0 (syntax-patterns-fail + (normalize-context 'define/syntax-parse + '|define/syntax-parse pattern| + x))]) (parameterize ((current-syntax-context x)) def ... (#%expression @@ -401,6 +406,9 @@ (options-select-value chunks '#:context #:default #'x)) (define colon-notation? (not (assq '#:disable-colon-notation chunks))) + (define track-literals? + (or (assq '#:track-literals chunks) + (eq? (syntax-e #'body-mode) 'one-template))) (define-values (decls0 defs) (get-decls+defs chunks #t #:context #'ctx)) ;; for-clause : stx -> (values pattern stx (listof stx)) @@ -422,13 +430,16 @@ [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) ((body-sequence) (syntax-case rest () - [(e0 e ...) #'(let () e0 e ...)] + [(e0 e ...) + #'(let () e0 e ...)] [_ (raise-syntax-error #f "expected non-empty clause body" #'ctx clause)])) (else (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))]) (values pattern body-expr defs2)))] [_ (raise-syntax-error #f "expected clause" #'ctx clause)])) + (define (wrap-track-literals stx) + (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx)) (unless (stx-list? clauses-stx) (raise-syntax-error #f "expected sequence of clauses" #'ctx)) (define-values (patterns body-exprs defs2s) @@ -446,25 +457,26 @@ (parameterize ((current-syntax-context (cadr ctx0)) (current-state '#hasheq()) (current-state-writable? #f)) - (with ([fail-handler fh0] - [cut-prompt fh0] - [undo-stack null]) - #,(cond [(pair? patterns) - (with-syntax ([matrix - (optimize-matrix - (for/list ([pattern (in-list patterns)] - [body-expr (in-list body-exprs)]) - (pk1 (list pattern) body-expr)))]) - #'(parse:matrix ((x cx pr es)) matrix)) - #| - (with-syntax ([(alternative ...) - (for/list ([pattern (in-list patterns)] - [body-expr (in-list body-exprs)]) - #`(parse:S x cx #,pattern pr es #,body-expr))]) - #`(try alternative ...)) - |#] - [else - #`(fail (failure* pr es))]))))))))])) + #,(wrap-track-literals + #`(with ([fail-handler fh0] + [cut-prompt fh0] + [undo-stack null]) + #,(cond [(pair? patterns) + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + (pk1 (list pattern) body-expr)))]) + #'(parse:matrix ((x cx pr es)) matrix)) + #| + (with-syntax ([(alternative ...) + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + #`(parse:S x cx #,pattern pr es #,body-expr))]) + #`(try alternative ...)) + |#] + [else + #`(fail (failure* pr es))])))))))))])) ;; ---- diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/rep.rkt racket-7.0+ppa1/collects/syntax/parse/private/rep.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/rep.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/rep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ racket/contract/base "make.rkt" "minimatch.rkt" + syntax/apply-transformer syntax/private/id-table syntax/stx syntax/keyword @@ -616,13 +617,8 @@ ;; expand-pattern : pattern-expander Syntax -> Syntax (define (expand-pattern pe stx) - (let* ([proc (pattern-expander-proc pe)] - [introducer (make-syntax-introducer)] - [mstx (introducer (syntax-local-introduce stx))] - [mresult (parameterize ([current-syntax-parse-pattern-introducer introducer]) - (proc mstx))] - [result (syntax-local-introduce (introducer mresult))]) - result)) + (let ([proc (pattern-expander-proc pe)]) + (local-apply-transformer proc stx 'expression))) ;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) (define (parse-ellipsis-head-pattern stx decls) @@ -1267,6 +1263,9 @@ [(cons (list '#:undo undo-stx stmts) rest) (cons (action:undo stmts) (parse-pattern-sides rest decls))] + [(cons (list '#:cut cut-stx) rest) + (cons (action:cut) + (parse-pattern-sides rest decls))] ['() '()])) @@ -1607,6 +1606,7 @@ ;; parse-directive-table (define parse-directive-table (list* (list '#:context check-expression) + (list '#:track-literals) common-parse-directive-table)) ;; rhs-directive-table @@ -1632,7 +1632,8 @@ (list '#:and check-expression) (list '#:post check-expression) (list '#:do check-stmt-list) - (list '#:undo check-stmt-list))) + (list '#:undo check-stmt-list) + (list '#:cut))) ;; fail-directive-table (define fail-directive-table diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/residual-ct.rkt racket-7.0+ppa1/collects/syntax/parse/private/residual-ct.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/residual-ct.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/residual-ct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,7 +19,6 @@ prop:pattern-expander pattern-expander? pattern-expander-proc - current-syntax-parse-pattern-introducer syntax-local-syntax-parse-pattern-introduce) (define-logger syntax-parse) @@ -94,10 +93,5 @@ (define get-proc (get-proc-getter pat-expander)) (get-proc pat-expander)) -(define current-syntax-parse-pattern-introducer - (make-parameter - (lambda (stx) - (error 'syntax-local-syntax-parse-pattern-introduce "not expanding syntax-parse pattern")))) - (define (syntax-local-syntax-parse-pattern-introduce stx) - ((current-syntax-parse-pattern-introducer) stx)) + (syntax-local-introduce stx)) diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/residual.rkt racket-7.0+ppa1/collects/syntax/parse/private/residual.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/residual.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/residual.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,35 +10,8 @@ (require (for-syntax racket/private/sc "residual-ct.rkt")) (provide (for-syntax (all-from-out "residual-ct.rkt"))) -(begin-for-syntax - ;; == from runtime.rkt - - (provide make-attribute-mapping - attribute-mapping? - attribute-mapping-var - attribute-mapping-name - attribute-mapping-depth - attribute-mapping-syntax?) - - (define-struct attribute-mapping (var name depth syntax?) - #:omit-define-syntaxes - #:property prop:procedure - (lambda (self stx) - (if (attribute-mapping-syntax? self) - #`(#%expression #,(attribute-mapping-var self)) - (let ([source-name - (or (let loop ([p (syntax-property stx 'disappeared-use)]) - (cond [(identifier? p) p] - [(pair? p) (or (loop (car p)) (loop (cdr p)))] - [else #f])) - (attribute-mapping-name self))]) - #`(let ([value #,(attribute-mapping-var self)]) - (if (syntax-list^depth? '#,(attribute-mapping-depth self) value) - value - (check/force-syntax-list^depth '#,(attribute-mapping-depth self) - value - (quote-syntax #,source-name)))))))) - ) +(require racket/private/template) +(provide (for-syntax attribute-mapping attribute-mapping?)) ;; ============================================================ ;; Run-time @@ -54,10 +27,10 @@ this-context-syntax attribute attribute-binding + check-attr-value stx-list-take stx-list-drop/cx datum->syntax/with-clause - check/force-syntax-list^depth check-literal* error/null-eh-match begin-for-syntax/once @@ -113,7 +86,7 @@ (if (attribute-mapping? value) #`(quote #,(make-attr (attribute-mapping-name value) (attribute-mapping-depth value) - (attribute-mapping-syntax? value))) + (if (attribute-mapping-check value) #f #t))) #'(quote #f))) #'(quote #f)))])) @@ -136,60 +109,28 @@ (if (syntax? x) x cx) (sub1 n))))) -;; check/force-syntax-list^depth : nat any id -> (listof^depth syntax) -;; Checks that value is (listof^depth syntax); forces promises. -;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already. -(define (check/force-syntax-list^depth depth value0 source-id) - (define (bad sub-depth sub-value) - (attribute-not-syntax-error depth value0 source-id sub-depth sub-value)) - (define (loop depth value) - (cond [(promise? value) - (loop depth (force value))] - [(zero? depth) - (if (syntax? value) value (bad depth value))] - [else (loop-list depth value)])) - (define (loop-list depth value) - (cond [(promise? value) - (loop-list depth (force value))] - [(pair? value) - (let ([new-car (loop (sub1 depth) (car value))] - [new-cdr (loop-list depth (cdr value))]) - ;; Don't copy unless necessary - (if (and (eq? new-car (car value)) - (eq? new-cdr (cdr value))) - value - (cons new-car new-cdr)))] - [(null? value) - null] - [else - (bad depth value)])) - (loop depth value0)) - -(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value) - (raise-syntax-error #f - (format (string-append "bad attribute value for syntax template" - "\n attribute value: ~e" - "\n expected for attribute: ~a" - "\n sub-value: ~e" - "\n expected for sub-value: ~a") - value0 - (describe-depth depth0) - sub-value - (describe-depth sub-depth)) - source-id)) - -(define (describe-depth depth) - (cond [(zero? depth) "syntax"] - [else (format "list of depth ~s of syntax" depth)])) - -;; syntax-list^depth? : nat any -> boolean -;; Returns true iff value is (listof^depth syntax). -(define (syntax-list^depth? depth value) - (if (zero? depth) - (syntax? value) - (and (list? value) - (for/and ([part (in-list value)]) - (syntax-list^depth? (sub1 depth) part))))) +;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) +(define (check-attr-value v0 depth0 base? ctx) + (define (bad kind v) + (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx)) + (define (depthloop depth v) + (if (zero? depth) + (if base? (baseloop v) v) + (let listloop ([v v] [root? #t]) + (cond [(null? v) null] + [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))] + [new-cdr (listloop (cdr v) #f)]) + (cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v] + [else (cons new-car new-cdr)]))] + [(promise? v) (listloop (force v) root?)] + [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))] + [else (bad 'list v)])))) + (define (baseloop v) + (cond [(syntax? v) v] + [(promise? v) (baseloop (force v))] + [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] + [else (bad 'syntax v)])) + (depthloop depth0 v0)) ;; datum->syntax/with-clause : any -> syntax (define (datum->syntax/with-clause x) @@ -312,7 +253,8 @@ maybe-add-state-undo current-state current-state-writable? - state-cons!) + state-cons! + track-literals) (define (unwind-to undos base) ;; PRE: undos = (list* proc/hash ... base) @@ -338,3 +280,21 @@ (define (state-cons! key value) (define state (current-state)) (current-state (hash-set state key (cons value (hash-ref state key null))))) + +(define (track-literals who v #:introduce? [introduce? #t]) + (unless (syntax? v) + (raise-argument-error who "syntax?" v)) + (let* ([literals (hash-ref (current-state) 'literals '())]) + (if (null? literals) + v + (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals)) + (for/list ([literal (in-list literals)]) + (if (identifier? literal) + (syntax-local-introduce literal) + literal)) + literals)] + [old-val (syntax-property v 'disappeared-use)]) + (syntax-property v 'disappeared-use + (if old-val + (cons literals* old-val) + literals*)))))) diff -Nru racket-6.12+ppa1/collects/syntax/parse/private/runtime.rkt racket-7.0+ppa1/collects/syntax/parse/private/runtime.rkt --- racket-6.12+ppa1/collects/syntax/parse/private/runtime.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/parse/private/runtime.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -106,8 +106,9 @@ (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] [(stmp ...) (generate-temporaries #'(name ...))]) #'(letrec-syntaxes+values - ([(stmp) (make-attribute-mapping (quote-syntax vtmp) - 'name 'depth 'syntax?)] ...) + ([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth + (if 'syntax? #f (quote-syntax check-attr-value)))] + ...) ([(vtmp) value] ...) (letrec-syntaxes+values ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) @@ -143,8 +144,8 @@ [(stmp ...) (generate-temporaries #'(name ...))]) #'(begin (define-values (vtmp ...) (apply values packed)) (define-syntax stmp - (make-attribute-mapping (quote-syntax vtmp) - 'name 'depth 'syntax?)) + (attribute-mapping (quote-syntax vtmp) 'name 'depth + (if 'syntax? #f (quote-syntax check-attr-value)))) ... (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) ...)))])) diff -Nru racket-6.12+ppa1/collects/syntax/private/modcode-noctc.rkt racket-7.0+ppa1/collects/syntax/private/modcode-noctc.rkt --- racket-6.12+ppa1/collects/syntax/private/modcode-noctc.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/private/modcode-noctc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,266 @@ +#lang racket/base +(require racket/list + racket/path + "../modread.rkt") + +(provide moddep-current-open-input-file + exn:get-module-code + exn:get-module-code? + exn:get-module-code-path + make-exn:get-module-code + + get-module-code + get-module-path + get-metadata-path) + +(define moddep-current-open-input-file + (make-parameter open-input-file)) + +(define (resolve s) + (if (complete-path? s) + s + (let ([d (current-load-relative-directory)]) + (if d (path->complete-path s d) s)))) + +(define (date>=? a bm) + (and a + (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (file-or-directory-modify-seconds a))]) + (and am (if bm (>= am bm) #t))))) + +(define (read-one orig-path path src? read-src-syntax) + (define p ((moddep-current-open-input-file) path)) + (when src? (port-count-lines! p)) + (define (reader) + (define-values (base name dir?) (split-path orig-path)) + (define unchecked-v + (with-module-reading-parameterization + (lambda () + ;; In case we're reading a .zo, we need to set + ;; the load-relative directory for unmarshaling + ;; path literals. + (parameterize ([current-load-relative-directory + (if (path? base) base (current-directory))]) + (read-src-syntax path p))))) + (when (eof-object? unchecked-v) + (error 'read-one "empty file; expected a module declaration in: ~a" path)) + (define sym + (string->symbol + (bytes->string/utf-8 (path->bytes (path-replace-extension name #"")) #\?))) + (define checked-v (check-module-form unchecked-v sym path)) + (unless (eof-object? (read p)) + (error 'read-one + "file has more than one expression; expected a module declaration only in: ~a" + path)) + (if (and (syntax? checked-v) (compiled-expression? (syntax-e checked-v))) + (syntax-e checked-v) + checked-v)) + (define (closer) (close-input-port p)) + (dynamic-wind void reader closer)) + +(define-struct (exn:get-module-code exn:fail) (path)) + +(define (reroot-path* base root) + (cond + [(eq? root 'same) base] + [(relative-path? root) (build-path base root)] + [else (reroot-path base root)])) + +;; : (or/c path-string? 'same) -> (or/c path? 'same) +(define (path-string->path ps) + (if (string? ps) (string->path ps) ps)) + +;; : (listof (or/c path-string? 'same)) -> (listof (or/c path? 'same)) +(define (root-strs->roots root-strs) + (map path-string->path root-strs)) + +(define (get-metadata-path + #:roots [root-strs (current-compiled-file-roots)] + base-str . arg-strs) + (define base (path-string->path base-str)) + (define roots (root-strs->roots root-strs)) + (define args (root-strs->roots arg-strs)) + (cond + [(or (equal? roots '(same)) (null? roots)) + (apply build-path base args)] + [else + (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) + (define p (apply build-path (reroot-path* base root) args)) + (and (file-exists? p) p)) + (apply build-path (reroot-path* base (car roots)) args))])) + +(define (default-compiled-sub-path) + (let ([l (use-compiled-file-paths)]) + (if (pair? l) + (car l) + "compiled"))) + +(define (get-module-path + path0-str + #:roots [root-strs (current-compiled-file-roots)] + #:submodule? [submodule? #f] + #:sub-path [sub-path/kw (default-compiled-sub-path)] + [sub-path sub-path/kw] + #:choose [choose (lambda (src zo so) #f)] + #:rkt-try-ss? [rkt-try-ss? #t]) + (define path0 (path-string->path path0-str)) + (define roots (root-strs->roots root-strs)) + (define resolved-path (resolve path0)) + (define-values (path0-rel path0-file path0-dir?) (split-path path0)) + (define-values (main-src-file alt-src-file) + (if rkt-try-ss? + (let* ([b (path->bytes path0-file)] + [len (bytes-length b)]) + (cond + [(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4)))) + ;; .rkt => try .rkt then .ss + (values path0-file + (bytes->path (bytes-append (subbytes b 0 (- len 4)) + #".ss")))] + [else + ;; No search path + (values path0-file #f)])) + (values path0-file #f))) + (define main-src-path + (if (eq? main-src-file path0-file) + resolved-path + (build-path path0-rel main-src-file))) + (define alt-src-path + (and alt-src-file + (if (eq? alt-src-file path0-file) + resolved-path + (build-path path0-rel alt-src-file)))) + (define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) + (define main-src-date + (file-or-directory-modify-seconds main-src-path #f (lambda () #f))) + (define alt-src-date + (and alt-src-path + (not main-src-date) + (file-or-directory-modify-seconds alt-src-path #f (lambda () #f)))) + (define src-date (or main-src-date alt-src-date)) + (define src-file (if alt-src-date alt-src-file main-src-file)) + (define src-path (if alt-src-date alt-src-path main-src-path)) + (define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date))) + (define (get-so file) + (get-metadata-path #:roots roots + path0-base + sub-path + "native" + (system-library-subpath) + (path-add-extension file (system-type 'so-suffix)))) + (define zo + (get-metadata-path #:roots roots + path0-base + sub-path + (path-add-extension src-file #".zo"))) + (define alt-zo + (and try-alt? + (get-metadata-path #:roots roots + path0-base + sub-path + (path-add-extension alt-src-file #".zo")))) + (define so (get-so src-file)) + (define alt-so (and try-alt? (get-so alt-src-file))) + (define prefer (choose src-path zo so)) + (cond + ;; Use .zo, if it's new enough + [(or (eq? prefer 'zo) + (and (not prefer) + (pair? roots) + (or (date>=? zo src-date) + (and try-alt? + (date>=? alt-zo src-date))))) + (let ([zo (if (date>=? zo src-date) + zo + (if (and try-alt? (date>=? alt-zo src-date)) + alt-zo + zo))]) + (values (simple-form-path zo) 'zo))] + ;; Maybe there's an .so? Use it only if we don't prefer source + ;; and only if there's no submodule path. + [(and (not submodule?) + (or (eq? prefer 'so) + (and (not prefer) + (pair? roots) + (or (date>=? so src-date) + (and try-alt? + (date>=? alt-so src-date)))))) + (let ([so (if (date>=? so src-date) + so + (if (and try-alt? (date>=? alt-so src-date)) + alt-so + so))]) + (values (simple-form-path so) 'so))] + ;; Use source if it exists + [(or (eq? prefer 'src) src-date) + (values (simple-form-path src-path) 'src)] + ;; Report a not-there error + [else (raise (make-exn:get-module-code + (format "get-module-code: no such file: ~e" resolved-path) + (current-continuation-marks) + #f))])) + +(define (get-module-code + path0-str + #:roots [root-strs (current-compiled-file-roots)] + #:submodule-path [submodule-path '()] + #:sub-path [sub-path/kw (default-compiled-sub-path)] + [sub-path sub-path/kw] + #:compile [compile/kw compile] + [compiler compile/kw] + #:extension-handler [ext-handler/kw #f] + [ext-handler ext-handler/kw] + #:choose [choose (lambda (src zo so) #f)] + #:notify [notify void] + #:source-reader [read-src-syntax read-syntax] + #:rkt-try-ss? [rkt-try-ss? #t]) + (define path0 (path-string->path path0-str)) + (define roots (root-strs->roots root-strs)) + (define-values (path type) + (get-module-path + path0 + #:roots roots + #:submodule? (pair? submodule-path) + #:sub-path sub-path + #:choose choose + #:rkt-try-ss? rkt-try-ss?)) + (define (extract-submodule m [sm-path submodule-path]) + (cond + [(null? sm-path) m] + [else + (extract-submodule + (or (for/or ([c (in-list (append (module-compiled-submodules m #t) + (module-compiled-submodules m #f)))]) + (and (eq? (last (module-compiled-name c)) (car sm-path)) + c)) + (raise + (make-exn:get-module-code + (format "get-module-code: cannot find submodule: ~e" sm-path) + (current-continuation-marks) + #f))) + (cdr sm-path))])) + (case type + [(zo) + (notify path) + (extract-submodule (read-one path0 path #f read-syntax))] + [(so) + (if ext-handler + (begin + (notify path) + (ext-handler path #f)) + (raise (make-exn:get-module-code + (format "get-module-code: cannot use extension file; ~e" path) + (current-continuation-marks) + path)))] + [(src) + (notify path) + (define (compile-one) + (define-values (path0-base path0-name path0-dir?) (split-path path0)) + (parameterize ([current-load-relative-directory + (if (path? path0-base) path0-base (current-directory))]) + (compiler (read-one path0 path #t read-src-syntax)))) + (if (null? submodule-path) + ;; allow any result: + (compile-one) + ;; expect a compiled-module result: + (extract-submodule (compile-one)))])) diff -Nru racket-6.12+ppa1/collects/syntax/private/modresolve-noctc.rkt racket-7.0+ppa1/collects/syntax/private/modresolve-noctc.rkt --- racket-6.12+ppa1/collects/syntax/private/modresolve-noctc.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/collects/syntax/private/modresolve-noctc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,130 @@ +#lang racket/base +(require racket/path + "modhelp.rkt") + +(provide resolve-module-path + resolve-module-path-index) + +(define (force-relto relto dir? #:path? [path? #t]) + (let ([relto (if (and (pair? relto) + (eq? (car relto) 'submod)) + (cadr relto) + relto)] + [submod (if (and (pair? relto) + (eq? (car relto) 'submod)) + (cddr relto) + null)]) + (cond [(path-string? relto) + (values (and path? + (if dir? + (let-values ([(base n d?) (split-path relto)]) + (when d? + (error 'resolve-module-path-index + "given a directory path instead of a file path: ~e" relto)) + (if (eq? base 'relative) + (or (current-load-relative-directory) (current-directory)) + base)) + relto)) + submod)] + [(pair? relto) (values relto submod)] + [(not dir?) + (values + (and path? + (error 'resolve-module-path-index + "can't resolve \"self\" with non-path relative-to: ~e" relto)) + submod)] + [(procedure? relto) (force-relto (relto) dir? #:path? path?)] + [else (values (and path? (current-directory)) submod)]))) + +(define (path-ss->rkt p) + (if (path-has-extension? p #".ss") + (path-replace-extension p #".rkt") + p)) + +(define (combine-submod v p) + (if (null? p) + v + (list* 'submod v p))) + +(define (flatten base orig-p) + (let loop ([accum '()] [p orig-p]) + (cond + [(null? p) (combine-submod base (reverse accum))] + [(equal? (car p) "..") + (if (null? accum) + (error 'resolve-module-path "too many \"..\"s: ~s" + (combine-submod base orig-p)) + (loop (cdr accum) (cdr p)))] + [else (loop (cons (car p) accum) (cdr p))]))) + +(define (resolve-module-path s [relto #f]) + ;; relto should be a complete path, #f, or procedure that returns a + ;; complete path + (define (get-dir) (force-relto relto #t)) + (cond [(symbol? s) + ;; use resolver handler: + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join s #f)))] + [(string? s) + ;; Parse Unix-style relative path string + (define-values (dir submod) (get-dir)) + (path-ss->rkt + (apply build-path dir (explode-relpath-string s)))] + [(and (or (not (pair? s)) (not (list? s))) (not (path? s))) + #f] + [(or (path? s) (eq? (car s) 'file)) + (let ([p (if (path? s) s (expand-user-path (cadr s)))]) + (define-values (d submod) (get-dir)) + (path-ss->rkt + (path->complete-path + p + (if (path-string? d) + d + (or (current-load-relative-directory) + (current-directory))))))] + [(or (eq? (car s) 'lib) + (eq? (car s) 'quote) + (eq? (car s) 'planet)) + ;; use resolver handler in this case, too: + (define-values (d submod) (force-relto relto #f #:path? #f)) + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join s #f)))] + [(eq? (car s) 'submod) + (define r (cond + [(or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (define-values (d submod) (force-relto relto #f)) + (combine-submod d submod)] + [else (resolve-module-path (cadr s) relto)])) + (define base-submods (if (and (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (pair? r)) + (cddr r) + null)) + (define base (if (pair? r) (cadr r) r)) + (flatten base (append base-submods + (if (equal? (cadr s) "..") (cdr s) (cddr s))))] + [else #f])) + +(define (resolve-module-path-index mpi [relto #f]) + ;; relto must be a complete path + (let-values ([(path base) (module-path-index-split mpi)]) + (if path + (resolve-module-path path (resolve-possible-module-path-index base relto)) + (let () + (define sm (module-path-index-submodule mpi)) + (define-values (dir submod) (force-relto relto #f)) + (combine-submod (path-ss->rkt dir) (if (and sm submod) + (append submod sm) + (or sm submod))))))) + +(define (resolve-possible-module-path-index base [relto #f]) + (cond [(module-path-index? base) + (resolve-module-path-index base relto)] + [(and (resolved-module-path? base) + (path? (resolved-module-path-name base))) + (resolved-module-path-name base)] + [relto relto] + [else #f])) diff -Nru racket-6.12+ppa1/collects/xml/private/structures.rkt racket-7.0+ppa1/collects/xml/private/structures.rkt --- racket-6.12+ppa1/collects/xml/private/structures.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/collects/xml/private/structures.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -50,7 +50,7 @@ v (raise-blame-error blame #:missing-party neg-party - v "not in permissive mode")))) + v '("not in permissive mode" given: "~e") v)))) #:first-order (lambda (v) #t))) diff -Nru racket-6.12+ppa1/debian/changelog racket-7.0+ppa1/debian/changelog --- racket-6.12+ppa1/debian/changelog 2018-04-28 22:24:34.000000000 +0000 +++ racket-7.0+ppa1/debian/changelog 2018-07-27 22:22:40.000000000 +0000 @@ -1,8 +1,39 @@ -racket (6.12+ppa1-1~trusty2) trusty; urgency=medium +racket (7.0+ppa1-1~trusty1) trusty; urgency=medium * PPA release - -- Asumu Takikawa Sat, 28 Apr 2018 14:30:00 -0800 + -- Asumu Takikawa Fri, 27 Jul 2018 15:15:00 -0800 + +racket (6.90.0.901+ppa1-1~bionic1) bionic; urgency=medium + + * PPA release (beta) + + -- Asumu Takikawa Thu, 28 Jun 2018 13:30:00 -0800 + +racket (6.12+dfsg1-2) unstable; urgency=medium + + * Bug fix: "hostname verification with OpenSSL fails", thanks to + Benjamin Barenblat (Closes: #877427). Cherry pick upstream pull + request 2041. + + -- David Bremner Tue, 08 May 2018 09:24:44 -0400 + +racket (6.12+dfsg1-1) unstable; urgency=medium + + * New upstream release + * Install man pages for racket, drracket, and raco + * drop "Recommends libunique", thanks to Jeremy Bicha (Closes: + #885816). It seems that -singleInstance is not actually working in + in 6.11, so no loss of functionality. + + -- David Bremner Sun, 11 Mar 2018 09:44:59 -0500 + +racket (6.11+dfsg1-1) unstable; urgency=medium + + * New upstream release + * Use new logo (thanks to Asumu Takikawa) + + -- David Bremner Sat, 23 Dec 2017 15:26:58 -0400 racket (6.10.1+dfsg1-1) unstable; urgency=medium diff -Nru racket-6.12+ppa1/debian/control racket-7.0+ppa1/debian/control --- racket-6.12+ppa1/debian/control 2018-04-28 22:24:51.000000000 +0000 +++ racket-7.0+ppa1/debian/control 2018-07-27 22:20:13.000000000 +0000 @@ -17,7 +17,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, racket-common (= ${source:Version}) Recommends: racket-doc (>= ${source:Upstream-Version}), libglib2.0-0, libpangocairo-1.0-0, libjpeg-turbo8, libpng16-16, - libgtk2.0-0, libgdk-pixbuf2.0-0, libunique-1.0-0, libssl1.0.0 + libgtk2.0-0, libgdk-pixbuf2.0-0, libssl1.0.0 Breaks: plt-scheme (<<5.0~) Replaces: plt-scheme (<<5.0~) Provides: plt-scheme diff -Nru racket-6.12+ppa1/debian/racket-doc.lintian-overrides racket-7.0+ppa1/debian/racket-doc.lintian-overrides --- racket-6.12+ppa1/debian/racket-doc.lintian-overrides 2018-04-28 22:23:07.000000000 +0000 +++ racket-7.0+ppa1/debian/racket-doc.lintian-overrides 2018-07-27 22:20:37.000000000 +0000 @@ -1,2 +1,2 @@ # this is merely quoted example link to adsense, not actual use -racket-doc: privacy-breach-google-adsense usr/share/doc/racket/web-server/templates.html +racket-doc: privacy-breach-google-adsense usr/share/doc/racket/web-server/templates.html (choke on: "google-analytics.com/ga.js') diff -Nru racket-6.12+ppa1/debian/racket.manpages racket-7.0+ppa1/debian/racket.manpages --- racket-6.12+ppa1/debian/racket.manpages 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/debian/racket.manpages 2018-07-27 22:16:39.000000000 +0000 @@ -0,0 +1,3 @@ +share/pkgs/drracket/drracket/drracket.1 +collects/racket/racket.1 +collects/raco/raco.1 diff -Nru racket-6.12+ppa1/etc/config.rktd racket-7.0+ppa1/etc/config.rktd --- racket-6.12+ppa1/etc/config.rktd 2018-01-26 21:12:14.000000000 +0000 +++ racket-7.0+ppa1/etc/config.rktd 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -#hash((build-stamp . "") (catalogs . ("https://download.racket-lang.org/releases/6.12/catalog/" #f)) (doc-search-url . "https://download.racket-lang.org/releases/6.12/doc/local-redirect/index.html")) +#hash((build-stamp . "") (catalogs . ("https://download.racket-lang.org/releases/7.0/catalog/" #f)) (doc-search-url . "https://download.racket-lang.org/releases/7.0/doc/local-redirect/index.html")) diff -Nru racket-6.12+ppa1/README racket-7.0+ppa1/README --- racket-6.12+ppa1/README 2018-01-26 21:12:14.000000000 +0000 +++ racket-7.0+ppa1/README 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ This is the Racket | Source -distribution for version 6.12. +distribution for version 7.0. This distribution provides source for the Racket run-time system; for build and installation instructions, see "src/README". @@ -12,7 +12,7 @@ The distribution has been configured so that when you install or update packages, the package catalog at - https://download.racket-lang.org/releases/6.12/catalog/ + https://download.racket-lang.org/releases/7.0/catalog/ is consulted first. Visit http://racket-lang.org/ for more Racket resources. diff -Nru racket-6.12+ppa1/share/links.rktd racket-7.0+ppa1/share/links.rktd --- racket-6.12+ppa1/share/links.rktd 2018-01-26 21:12:13.000000000 +0000 +++ racket-7.0+ppa1/share/links.rktd 2018-07-27 22:12:02.000000000 +0000 @@ -175,7 +175,9 @@ ("sasl" "pkgs/sasl-doc") (root "pkgs/slideshow-exe") (root "pkgs/slideshow-plugin") + (root "pkgs/srfi-lib-nonfree") (root "pkgs/srfi-doc") + (root "pkgs/srfi-doc-nonfree") (root "pkgs/syntax-color-doc") (root "pkgs/web-server-lib") (root "pkgs/unix-socket-lib") diff -Nru racket-6.12+ppa1/share/pkgs/2d/info.rkt racket-7.0+ppa1/share/pkgs/2d/info.rkt --- racket-6.12+ppa1/share/pkgs/2d/info.rkt 2018-01-26 21:07:20.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/2d/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.0") (define deps (quote ("2d-lib" "2d-doc"))) (define implies (quote ("2d-lib" "2d-doc"))) (define pkg-desc "2d syntax") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.0") (define deps (quote ("2d-lib" "2d-doc"))) (define implies (quote ("2d-lib" "2d-doc"))) (define pkg-desc "2d syntax") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/2d-doc/info.rkt racket-7.0+ppa1/share/pkgs/2d-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/2d-doc/info.rkt 2018-01-26 21:07:20.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/2d-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "2d") (define version "1.0") (define deps (quote ("base" "2d-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc" "syntax-color-doc" "syntax-color-lib"))) (define pkg-desc "Documentation part of \"2d\"") (define pkg-authors (quote (robby))) (define scribblings (quote (("scribblings/2d.scrbl" () ("Syntax Extensions"))))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "2d") (define version "1.0") (define deps (quote ("base" "2d-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc" "syntax-color-doc" "syntax-color-lib"))) (define pkg-desc "Documentation part of \"2d\"") (define pkg-authors (quote (robby))) (define scribblings (quote (("scribblings/2d.scrbl" () ("Syntax Extensions"))))))) diff -Nru racket-6.12+ppa1/share/pkgs/2d-lib/info.rkt racket-7.0+ppa1/share/pkgs/2d-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/2d-lib/info.rkt 2018-01-26 21:07:20.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/2d-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "2d") (define version "1.1") (define deps (quote (("base" #:version "6.6.0.3") "scribble-lib" "syntax-color-lib"))) (define pkg-desc "Implementation (no documentation) part of \"2d\"") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "2d") (define version "1.1") (define deps (quote (("base" #:version "6.90.0.19") "scribble-lib" "syntax-color-lib"))) (define pkg-desc "Implementation (no documentation) part of \"2d\"") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/2d-lib/private/readtable.rkt racket-7.0+ppa1/share/pkgs/2d-lib/private/readtable.rkt --- racket-6.12+ppa1/share/pkgs/2d-lib/private/readtable.rkt 2018-01-26 20:35:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/2d-lib/private/readtable.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -132,7 +132,7 @@ /recursive)]))] [else (/recursive - (input-port-append #f (open-input-string "#2") port) + (input-port-append #f (open-input-string "#2") port #:name (object-name port)) #f previous-readtable)])) diff -Nru racket-6.12+ppa1/share/pkgs/algol60/info.rkt racket-7.0+ppa1/share/pkgs/algol60/info.rkt --- racket-6.12+ppa1/share/pkgs/algol60/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/algol60/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "algol60") (define build-deps (quote ("at-exp-lib" "rackunit-lib" "racket-doc" "scribble-doc" "scribble-lib" "drracket-tool-lib" "drracket-plugin-lib"))) (define drracket-name "Algol 60") (define drracket-tools (quote (("tool.rkt")))) (define drracket-tool-names (quote ("Algol 60"))) (define scribblings (quote (("algol60.scrbl" () (experimental 40))))) (define deps (quote ("base" "compatibility-lib" "drracket-plugin-lib" "errortrace-lib" "gui-lib" "parser-tools-lib" "string-constants-lib"))) (define pkg-desc "An implementation of the Algol60 language") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "algol60") (define build-deps (quote ("at-exp-lib" "rackunit-lib" "racket-doc" "scribble-doc" "scribble-lib" "drracket-tool-lib" "drracket-plugin-lib"))) (define drracket-name "Algol 60") (define drracket-tools (quote (("tool.rkt")))) (define drracket-tool-names (quote ("Algol 60"))) (define scribblings (quote (("algol60.scrbl" () (experimental 40))))) (define deps (quote ("base" "compatibility-lib" "drracket-plugin-lib" "errortrace-lib" "gui-lib" "parser-tools-lib" "string-constants-lib"))) (define pkg-desc "An implementation of the Algol60 language") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/at-exp-lib/info.rkt racket-7.0+ppa1/share/pkgs/at-exp-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/at-exp-lib/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/at-exp-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Libraries for @-expressions") (define pkg-authors (quote (eli mflatt))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Libraries for @-expressions") (define pkg-authors (quote (eli mflatt))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/at-exp-lib/scribble/reader.rkt racket-7.0+ppa1/share/pkgs/at-exp-lib/scribble/reader.rkt --- racket-6.12+ppa1/share/pkgs/at-exp-lib/scribble/reader.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/at-exp-lib/scribble/reader.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -354,7 +354,7 @@ (maybe-merge (make-stx (read-bytes (cdadr m) inp)) r)))] [(*peek #rx#"^$") (if end-token - (read-error* 'eof "missing closing `~a'" end-token) + (read-error* 'eof "missing closing `~a`" end-token) (done-items r))] [else (internal-error 'get-lines*)]))) @@ -563,7 +563,7 @@ (lambda (char inp source-name line-num col-num position) (let ([m (*regexp-match #rx#"^([^|]*)\\|" inp)]) (unless m - (raise-read-error "unbalanced `|'" source-name + (raise-read-error "unbalanced `|`" source-name line-num col-num position #f)) (datum->syntax #f (string->symbol (bytes->string/utf-8 (cadr m))) diff -Nru racket-6.12+ppa1/share/pkgs/base/info.rkt racket-7.0+ppa1/share/pkgs/base/info.rkt --- racket-6.12+ppa1/share/pkgs/base/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/base/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "6.12") (define deps (quasiquote ("racket-lib" ("racket" #:version (unquote version))))) (define implies (quote (core))) (define pkg-desc "Racket libraries that are currently always available") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "7.0") (define deps (quasiquote ("racket-lib" ("racket" #:version (unquote version))))) (define implies (quote (core))) (define pkg-desc "Racket libraries that are currently always available") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/cext-lib/info.rkt racket-7.0+ppa1/share/pkgs/cext-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/cext-lib/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/cext-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "dynext-lib" "scheme-lib"))) (define implies (quote ("dynext-lib"))) (define pkg-desc "Tools for managing C extensions, such as `raco ctool`") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "dynext-lib" "scheme-lib"))) (define implies (quote ("dynext-lib"))) (define pkg-desc "Tools for managing C extensions, such as `raco ctool`") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/class-iop-lib/info.rkt racket-7.0+ppa1/share/pkgs/class-iop-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/class-iop-lib/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/class-iop-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.6")))) (define pkg-authors (quote (ryanc))) (define test-responsibles (quote ((all ryanc)))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.6")))) (define pkg-authors (quote (ryanc))) (define test-responsibles (quote ((all ryanc)))))) diff -Nru racket-6.12+ppa1/share/pkgs/compatibility/info.rkt racket-7.0+ppa1/share/pkgs/compatibility/info.rkt --- racket-6.12+ppa1/share/pkgs/compatibility/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compatibility/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("compatibility-lib" "compatibility-doc"))) (define implies (quote ("compatibility-lib" "compatibility-doc"))) (define pkg-desc "Libraries that implement legacy interfaces") (define pkg-authors (quote (eli mflatt robby samth))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("compatibility-lib" "compatibility-doc"))) (define implies (quote ("compatibility-lib" "compatibility-doc"))) (define pkg-desc "Libraries that implement legacy interfaces") (define pkg-authors (quote (eli mflatt robby samth))))) diff -Nru racket-6.12+ppa1/share/pkgs/compatibility-doc/info.rkt racket-7.0+ppa1/share/pkgs/compatibility-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/compatibility-doc/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compatibility-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "compatibility-lib" "pconvert-lib" "sandbox-lib" "compiler-lib" "gui-lib" "racket-doc"))) (define pkg-desc "documentation part of \"compatibility\"") (define pkg-authors (quote (eli mflatt robby samth))) (define build-deps (quote ("data-doc" "mzscheme-doc" "scheme-lib"))) (define update-implies (quote ("compatibility-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "compatibility-lib" "pconvert-lib" "sandbox-lib" "compiler-lib" "gui-lib" "racket-doc"))) (define pkg-desc "documentation part of \"compatibility\"") (define pkg-authors (quote (eli mflatt robby samth))) (define build-deps (quote ("data-doc" "mzscheme-doc" "scheme-lib"))) (define update-implies (quote ("compatibility-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/compatibility-lib/info.rkt racket-7.0+ppa1/share/pkgs/compatibility-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/compatibility-lib/info.rkt 2018-01-26 21:07:22.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compatibility-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "net-lib" "sandbox-lib"))) (define pkg-desc "implementation (no documentation) part of \"compatibility\"") (define pkg-authors (quote (eli mflatt robby samth))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "net-lib" "sandbox-lib"))) (define pkg-desc "implementation (no documentation) part of \"compatibility\"") (define pkg-authors (quote (eli mflatt robby samth))))) diff -Nru racket-6.12+ppa1/share/pkgs/compatibility-lib/mzlib/contract.rkt racket-7.0+ppa1/share/pkgs/compatibility-lib/mzlib/contract.rkt --- racket-6.12+ppa1/share/pkgs/compatibility-lib/mzlib/contract.rkt 2018-01-26 20:34:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compatibility-lib/mzlib/contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -170,9 +170,6 @@ :prop:chaperone-contract :prop:contract :prop:flat-contract - :prop:opt-chaperone-contract - :prop:opt-chaperone-contract-get-test - :prop:opt-chaperone-contract? :skip-projection-wrapper? :opt/c :define-opt/c)) @@ -187,6 +184,7 @@ (require racket/contract/combinator) ;; exports from racket/contract/combinator as of 5.3.5 ;; except some cleanup that tried to happen in late 2015 +;; and the removal of three opt-contract related exports in 2018 (provide blame-add-unknown-context blame-context blame-contract blame-negative blame-original? blame-positive blame-replace-negative blame-source blame-swap blame-swapped? blame-update blame-value blame? build-chaperone-contract-property build-compound-type-name @@ -198,7 +196,7 @@ exn:fail:contract:blame-object exn:fail:contract:blame? flat-contract-property? impersonator-prop:contracted make-chaperone-contract make-contract make-exn:fail:contract:blame make-flat-contract prop:chaperone-contract prop:contract - prop:contracted prop:flat-contract prop:opt-chaperone-contract - prop:opt-chaperone-contract-get-test prop:opt-chaperone-contract? raise-blame-error + prop:contracted prop:flat-contract + raise-blame-error skip-projection-wrapper? struct:exn:fail:contract:blame define/final-prop exn:fail:contract:blame blame-add-context define/subexpression-pos-prop) diff -Nru racket-6.12+ppa1/share/pkgs/compatibility-lib/mzlib/private/contract-object.rkt racket-7.0+ppa1/share/pkgs/compatibility-lib/mzlib/private/contract-object.rkt --- racket-6.12+ppa1/share/pkgs/compatibility-lib/mzlib/private/contract-object.rkt 2018-01-26 20:34:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compatibility-lib/mzlib/private/contract-object.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -286,10 +286,12 @@ ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) #:projection (lambda (blame) - (lambda (val) - (make-wrapper-object ctc val blame #f + (define p-app + (make-wrapper-object blame (list 'method-name ...) (list method-ctc-var ...) - (list 'field-name ...) (list field-ctc-var ...)))) + '(field-name ...) (list field-ctc-var ...))) + (lambda (val) + (p-app ctc val #f))) #:first-order (lambda (val) (let/ec ret diff -Nru racket-6.12+ppa1/share/pkgs/compiler/info.rkt racket-7.0+ppa1/share/pkgs/compiler/info.rkt --- racket-6.12+ppa1/share/pkgs/compiler/info.rkt 2018-01-26 21:07:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("compiler-lib"))) (define implies (quote ("compiler-lib"))) (define pkg-desc "Racket compilation tools, such as `raco exe'") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("compiler-lib"))) (define implies (quote ("compiler-lib"))) (define pkg-desc "Racket compilation tools, such as `raco exe'") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/commands/decompile.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/commands/decompile.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/commands/decompile.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/commands/decompile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,6 +11,7 @@ (string->symbol (short-program+command-name))) (define force? #f) +(define to-linklets? #f) (define source-files (command-line @@ -24,6 +25,8 @@ (raise-user-error (get-name) "not a valid column count: ~a" n)) (pretty-print-columns num))] + [("--linklet") "Decompile to linklets" + (set! to-linklets? #t)] #:args source-or-bytecode-file source-or-bytecode-file)) @@ -85,6 +88,7 @@ [print-graph #t]) (pretty-write (decompile + #:to-linklets? to-linklets? (call-with-input-file* (if (file-exists? alt-file) alt-file zo-file) (lambda (in) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/commands/exe.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/commands/exe.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/commands/exe.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/commands/exe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,7 +10,7 @@ (define very-verbose (make-parameter #f)) (define gui (make-parameter #f)) -(define 3m (make-parameter #t)) +(define variant (make-parameter (system-type 'gc))) (define launcher (make-parameter #f)) (define exe-output (make-parameter #f)) @@ -41,6 +41,8 @@ (list "-A" (path->string (find-system-path 'addon-dir))) (remove "-U" (exe-embedded-flags))))) (launcher #t)] + [("--embed-dlls") "On Windows, embed DLLs in the executable" + (exe-aux (cons (cons 'embed-dlls? #t) (exe-aux)))] [("--config-path") path "Set as configuration directory for executable" (exe-embedded-config-path path)] [("--collects-path") path "Set as main collects for executable" @@ -54,9 +56,11 @@ [("--orig-exe") "Use original executable instead of stub" (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))] [("--3m") "Generate using 3m variant" - (3m #t)] + (variant '3m)] [("--cgc") "Generate using CGC variant" - (3m #f)] + (variant 'cgc)] + [("--cs") "Generate using CS variant" + (variant 'cs)] #:multi [("++aux") aux-file "Extra executable info (based on suffix)" (let ([auxes (extract-aux-from-path (path->complete-path aux-file))]) @@ -106,7 +110,7 @@ dest))))))) (cond [(launcher) - (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)]) + (parameterize ([current-launcher-variant (variant)]) ((if (gui) make-gracket-launcher make-racket-launcher) @@ -123,7 +127,7 @@ (mzc:create-embedding-executable dest #:mred? (gui) - #:variant (if (3m) '3m 'cgc) + #:variant (variant) #:verbose? (very-verbose) #:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime)) (map (lambda (l) `(#t (lib ,l))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,42 +1,37 @@ #lang racket/base -(require compiler/zo-parse +(require racket/linklet + compiler/zo-parse + compiler/zo-marshal syntax/modcollapse racket/port racket/match racket/list racket/set - racket/path) + racket/path + (only-in '#%linklet compiled-position->primitive) + "private/deserialize.rkt") (provide decompile) ;; ---------------------------------------- (define primitive-table - ;; Figure out number-to-id mapping for kernel functions in `primitive' - (let ([bindings - (let ([ns (make-base-empty-namespace)]) - (parameterize ([current-namespace ns]) - (namespace-require ''#%kernel) - (namespace-require ''#%unsafe) - (namespace-require ''#%flfxnum) - (namespace-require ''#%extfl) - (namespace-require ''#%futures) - (namespace-require ''#%foreign) - (for/list ([l (namespace-mapped-symbols)]) - (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) - (compile l))))))] - [table (make-hash)]) - (for ([b (in-list bindings)]) - (let ([v (and (cdr b) - (zo-parse - (open-input-bytes - (with-output-to-bytes - (λ () (write (cdr b)))))))]) - (let ([n (match v - [(struct compilation-top (_ _ prefix (struct primval (n)))) n] - [else #f])]) - (hash-set! table n (car b))))) - table)) + (let ([value-names (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require ''#%kernel) + (namespace-require ''#%unsafe) + (namespace-require ''#%flfxnum) + (namespace-require ''#%extfl) + (namespace-require ''#%futures) + (namespace-require ''#%foreign) + (namespace-require ''#%paramz) + (for/hasheq ([name (in-list (namespace-mapped-symbols))]) + (values (namespace-variable-value name #t (lambda () #f)) + name))))]) + (for/hash ([i (in-naturals)] + #:break (not (compiled-position->primitive i))) + (define v (compiled-position->primitive i)) + (values i (or (hash-ref value-names v #f) `',v))))) (define (list-ref/protect l pos who) (list-ref l pos) @@ -47,291 +42,215 @@ ;; ---------------------------------------- -(define-struct glob-desc (vars num-tls num-stxs num-lifts)) +(define-struct glob-desc (vars)) ;; Main entry: -(define (decompile top) - (let ([stx-ht (make-hasheq)]) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - (expose-module-path-indexes - `(begin - ,@defns - ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))] - [else (error 'decompile "unrecognized: ~e" top)]))) - -(define (expose-module-path-indexes e) - ;; This is a nearly general replace-in-graph function. (It seems like a lot - ;; of work to expose module path index content and sharing, though.) - (define ht (make-hasheq)) - (define mconses null) - (define (x-mcons a b) - (define m (mcons a b)) - (set! mconses (cons (cons m (cons a b)) mconses)) - m) - (define main - (let loop ([e e]) +(define (decompile top #:to-linklets? [to-linklets? #f]) + (cond + [(linkl-directory? top) + (cond + [to-linklets? + (cons + 'linklet-directory + (apply + append + (for/list ([(k v) (in-hash (linkl-directory-table top))]) + (list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))] + [else + (define main (hash-ref (linkl-directory-table top) '() #f)) + (cond + [(and main + (hash-ref (linkl-bundle-table main) 'decl #f)) + (decompile-module-with-submodules top '() main)] + [main + (decompile-single-top main)] + [else + (decompile-multi-top top)])])] + [(linkl-bundle? top) + (cond + [to-linklets? + (cons + 'linklet-bundle + (apply + append + (for/list ([(k v) (in-hash (linkl-bundle-table top))]) + (case (and (not to-linklets?) k) + [(stx-data) + (list '#:stx-data (decompile-data-linklet v))] + [else + (list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))] + [else + (decompile-module top)])] + [(linkl? top) + (decompile-linklet top)] + [else `(quote ,top)])) + +(define (decompile-module-with-submodules l-dir name-list main-l) + (decompile-module main-l + (lambda () + (for/list ([(k l) (in-hash (linkl-directory-table l-dir))] + #:when (and (list? k) + (= (length k) (add1 (length name-list))) + (for/and ([s1 (in-list name-list)] + [s2 (in-list k)]) + (eq? s1 s2)))) + (decompile-module-with-submodules l-dir k l))))) + +(define (decompile-module l [get-nested (lambda () '())]) + (define ht (linkl-bundle-table l)) + (define phases (sort (for/list ([k (in-hash-keys ht)] + #:when (exact-integer? k)) + k) + <)) + (define-values (mpi-vector requires provides) + (let ([data-l (hash-ref ht 'data #f)] + [decl-l (hash-ref ht 'decl #f)]) + (define (zo->linklet l) + (let ([o (open-output-bytes)]) + (zo-marshal-to (linkl-bundle (hasheq 'data l)) o) + (parameterize ([read-accept-compiled #t]) + (define b (read (open-input-bytes (get-output-bytes o)))) + (hash-ref (linklet-bundle->hash b) 'data)))) (cond - [(hash-ref ht e #f)] - [(module-path-index? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (define-values (name base) (module-path-index-split e)) - (placeholder-set! ph (x-mcons '#%modidx - (x-mcons (loop name) - (x-mcons (loop base) - null)))) - ph] - [(pair? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph (cons (loop (car e)) - (loop (cdr e)))) - ph] - [(mpair? e) - (define m (mcons #f #f)) - (hash-set! ht e m) - (set! mconses (cons (cons m (cons (loop (mcar e)) - (loop (mcdr e)))) - mconses)) - m] - [(box? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph (box (loop (unbox e)))) - ph] - [(vector? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - (for/vector #:length (vector-length e) ([i (in-vector e)]) - (loop i))) - ph] - [(hash? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - ((cond - [(hash-eq? ht) - make-hasheq-placeholder] - [(hash-eqv? ht) - make-hasheqv-placeholder] - [else make-hash-placeholder]) - (for/list ([(k v) (in-hash e)]) - (cons (loop k) (loop v))))) - ph] - [(prefab-struct-key e) - => (lambda (k) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - (apply make-prefab-struct - k - (map loop - (cdr (vector->list (struct->vector e)))))) - ph)] + [(and data-l + decl-l) + (define data-i (instantiate-linklet (zo->linklet data-l) + (list deserialize-instance))) + (define decl-i (instantiate-linklet (zo->linklet decl-l) + (list deserialize-instance + data-i))) + (values (instance-variable-value data-i '.mpi-vector) + (instance-variable-value decl-i 'requires) + (instance-variable-value decl-i 'provides))] + [else (values '#() '() '#hasheqv())]))) + (define (phase-wrap phase l) + (case phase + [(0) l] + [(1) `((for-syntax ,@l))] + [(-1) `((for-template ,@l))] + [(#f) `((for-label ,@l))] + [else `((for-meta ,phase ,@l))])) + `(module ,(hash-ref ht 'name 'unknown) .... + (require ,@(apply + append + (for/list ([phase+mpis (in-list requires)]) + (phase-wrap (car phase+mpis) + (map collapse-module-path-index (cdr phase+mpis)))))) + (provide ,@(apply + append + (for/list ([(phase ht) (in-hash provides)]) + (phase-wrap phase (hash-keys ht))))) + ,@(let loop ([phases phases] [depth 0]) + (cond + [(null? phases) '()] + [(= depth (car phases)) + (append + (decompile-linklet (hash-ref ht (car phases)) #:just-body? #t) + (loop (cdr phases) depth))] + [else + (define l (loop phases (add1 depth))) + (define (convert-syntax-definition s wrap) + (match s + [`(let ,bindings ,body) + (convert-syntax-definition body + (lambda (rhs) + `(let ,bindings + ,rhs)))] + [`(begin (.set-transformer! ',id ,rhs) ',(? void?)) + `(define-syntaxes ,id ,(wrap rhs))] + [`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?)) + `(define-syntaxes ,ids ,(wrap `(values . ,rhss)))] + [_ #f])) + (let loop ([l l] [accum '()]) + (cond + [(null? l) (if (null? accum) + '() + `((begin-for-syntax ,@(reverse accum))))] + [(convert-syntax-definition (car l) values) + => (lambda (s) + (append (loop null accum) + (cons s (loop (cdr l) null))))] + [else + (loop (cdr l) (cons (car l) accum))]))])) + ,@(get-nested) + ,@(let ([l (hash-ref ht 'stx-data #f)]) + (if l + `((begin-for-all + (define (.get-syntax-literal! pos) + .... + ,(decompile-data-linklet l) + ....))) + null)))) + +(define (decompile-single-top b) + (define forms (decompile-linklet (hash-ref (linkl-bundle-table b) 0) #:just-body? #t)) + (if (= (length forms) 1) + (car forms) + `(begin ,@forms))) + +(define (decompile-multi-top ld) + `(begin + ,@(let loop ([i 0]) + (define b (hash-ref (linkl-directory-table ld) (list (string->symbol (format "~a" i))) #f)) + (define l (and b (hash-ref (linkl-bundle-table b) 0 #f))) + (cond + [l (append (decompile-linklet l #:just-body? #t) + (loop (add1 i)))] + [else null])))) + +(define (decompile-linklet l #:just-body? [just-body? #f]) + (match l + [(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?)) + (define closed (make-hasheq)) + (define globs (glob-desc + (append + (list 'root) + (apply append importss) + exports + internals + lifts))) + (define body-l + (for/list ([form (in-list body)]) + (decompile-form form globs '(#%globals) closed))) + (if just-body? + body-l + `(linklet + ,importss + ,exports + '(import-shapes: ,@(for/list ([imports (in-list importss)] + [import-shapes (in-list import-shapess)] + #:when #t + [import (in-list imports)] + [import-shape (in-list import-shapes)] + #:when import-shape) + `[,import ,import-shape])) + ,@body-l))])) + +(define (decompile-data-linklet l) + (match l + [(struct linkl (_ _ _ _ _ _ _ (list vec-def (struct def-values (_ deser-lam))) _ _)) + (match deser-lam + [(struct lam (_ _ _ _ _ _ _ _ _ (struct seq ((list vec-copy! _))))) + (match vec-copy! + [(struct application (_ (list _ _ (struct application (_ (list mpi-vector inspector bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec)))))) + (decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec)] + [else + (decompile-linklet l)])] [else - e]))) - (define l (make-reader-graph (cons main mconses))) - (for ([i (in-list (cdr l))]) - (set-mcar! (car i) (cadr i)) - (set-mcdr! (car i) (cddr i))) - (car l)) - -(define (decompile-prefix a-prefix stx-ht) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs src-insp-desc)) - (let ([lift-ids (for/list ([i (in-range num-lifts)]) - (gensym 'lift))] - [stx-ids (map (lambda (i) (gensym 'stx)) - stxs)]) - (values (glob-desc - (append - (map (lambda (tl) - (match tl - [#f '#%linkage] - [(? symbol?) (string->symbol (format "_~a" tl))] - [(struct global-bucket (name)) - (string->symbol (format "_~a" name))] - [(struct module-variable (modidx sym pos phase constantness)) - (if (and (module-path-index? modidx) - (let-values ([(n b) (module-path-index-split modidx)]) - (and (not n) (not b)))) - (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s~a@~s~a" - sym - (match constantness - ['constant ":c"] - ['fixed ":f"] - [(function-shape a pm?) - (if pm? ":P" ":p")] - [(struct-type-shape c) ":t"] - [(constructor-shape a) ":mk"] - [(predicate-shape) ":?"] - [(accessor-shape c) ":ref"] - [(mutator-shape c) ":set!"] - [else ""]) - (mpi->string modidx) - (if (zero? phase) - "" - (format "/~a" phase)))))] - [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) - toplevels) - stx-ids - (if (null? stx-ids) null '(#%stx-array)) - lift-ids) - (length toplevels) - (length stxs) - num-lifts) - (list* - `(quote inspector ,src-insp-desc) - ;; `(quote tls ,toplevels) - (map (lambda (stx id) - `(define ,id ,(if stx - `(#%decode-syntax - ,(decompile-stx (stx-content stx) stx-ht)) - #f))) - stxs stx-ids))))] - [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) - -(define (decompile-stx stx stx-ht) - (or (hash-ref stx-ht stx #f) - (let ([p (mcons #f #f)]) - (hash-set! stx-ht stx p) - (match stx - [(stx-obj datum wrap srcloc props tamper-status) - (set-mcar! p (case tamper-status - [(clean) 'wrap] - [(tainted) 'wrap-tainted] - [(armed) 'wrap-armed])) - (set-mcdr! p (mcons - (cond - [(pair? datum) - (cons (decompile-stx (car datum) stx-ht) - (let loop ([l (cdr datum)]) - (cond - [(null? l) null] - [(pair? l) - (cons (decompile-stx (car l) stx-ht) - (loop (cdr l)))] - [else - (decompile-stx l stx-ht)])))] - [(vector? datum) - (for/vector ([e (in-vector datum)]) - (decompile-stx e stx-ht))] - [(box? datum) - (box (decompile-stx (unbox datum) stx-ht))] - [else datum]) - (let* ([l (mcons wrap null)] - [l (if (hash-count props) - (mcons props l) - l)] - [l (if srcloc - (mcons srcloc l) - l)]) - l))) - p])))) - -(define (mpi->string modidx) - (cond - [(symbol? modidx) modidx] - [else - (collapse-module-path-index modidx)])) - -(define (decompile-module mod-form orig-stack stx-ht mod-name) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] - [(stack) (append '(#%modvars) orig-stack)] - [(closed) (make-hasheq)]) - `(,mod-name ,(if (symbol? name) name (last name)) .... - (quote self ,self-modidx) - (quote internal-context - ,(if (stx? internal-context) - `(#%decode-syntax - ,(decompile-stx (stx-content internal-context) stx-ht)) - internal-context)) - (quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)]) - (values phase - (for/hash ([(sym id) (in-hash ht)]) - (values sym - (if (eq? id #t) - #t - `(#%decode-syntax - ,(decompile-stx (stx-content id) stx-ht)))))))) - (quote language-info ,lang-info) - ,@(if (null? flags) '() (list `(quote ,flags))) - ,@(let ([l (apply - append - (for/list ([req (in-list requires)] - #:when (pair? (cdr req))) - (define l (for/list ([mpi (in-list (cdr req))]) - (define p (mpi->string mpi)) - (if (path? p) - (let ([d (current-load-relative-directory)]) - (path->string (if d - (find-relative-path (simplify-path d #t) - (simplify-path p #f) - #:more-than-root? #t) - p))) - p))) - (if (eq? 0 (car req)) - l - `((,@(case (car req) - [(#f) `(for-label)] - [(1) `(for-syntax)] - [else `(for-meta ,(car req))]) - ,@l)))))]) - (if (null? l) - null - `((require ,@l)))) - (provide ,@(apply - append - (for/list ([p (in-list provides)]) - (define phase (car p)) - (define l - (for/list ([pv (in-list (append (cadr p) (caddr p)))]) - (match pv - [(struct provided (name src src-name nom-src src-phase protected?)) - (define n (if (eq? name src-name) - name - `(rename-out [,src-name ,name]))) - (if protected? - `(protect-out ,n) - n)]))) - (if (or (null? l) (eq? phase 0)) - l - `((,@(case phase - [(#f) `(for-label)] - [(1) `(for-syntax)] - [else `(for-meta ,phase)]) - ,@l)))))) - ,@defns - ,@(for/list ([submod (in-list pre-submodules)]) - (decompile-module submod orig-stack stx-ht 'module)) - ,@(for/list ([b (in-list syntax-bodies)]) - (let loop ([n (sub1 (car b))]) - (if (zero? n) - (cons 'begin - (for/list ([form (in-list (cdr b))]) - (decompile-form form globs stack closed stx-ht))) - (list 'begin-for-syntax (loop (sub1 n)))))) - ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - body) - ,@(for/list ([submod (in-list post-submodules)]) - (decompile-module submod orig-stack stx-ht 'module*))))] - [else (error 'decompile-module "huh?: ~e" mod-form)])) - -(define (decompile-form form globs stack closed stx-ht) + (decompile-linklet l)])] + [else + (decompile-linklet l)])) + +(define (decompile-form form globs stack closed) (match form - [(? mod?) - (decompile-module form stack stx-ht 'module)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl @@ -344,29 +263,10 @@ ,(decompile-expr (inline-variant-inline rhs) globs stack closed) ,(decompile-expr (inline-variant-direct rhs) globs stack closed)) (decompile-expr rhs globs stack closed)))] - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - `(define-syntaxes ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () - ,@defns - ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] - [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) - `(begin-for-syntax - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () - ,@defns - ,@(for/list ([rhs (in-list exprs)]) - (decompile-form rhs globs '(#%globals) closed stx-ht)))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) + (decompile-form form globs stack closed)) forms))] - [(struct splice (forms)) - `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - forms))] - [(struct req (reqs dummy)) - `(#%require . (#%decode-syntax ,reqs))] [else (decompile-expr form globs stack closed)])) @@ -417,12 +317,12 @@ (match expr [(struct toplevel (depth pos const? ready?)) (decompile-tl expr globs stack closed #f)] - [(struct varref (tl dummy)) - `(#%variable-reference ,(if (eq? tl #t) - ' - (decompile-tl tl globs stack closed #t)))] - [(struct topsyntax (depth pos midpt)) - (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] + [(struct varref (tl dummy constant? from-unsafe?)) + `(#%variable-reference . ,(cond + [(not tl) '()] + [(eq? tl #t) '()] + [(symbol? tl) (list tl)] ; primitive + [else (list (decompile-tl tl globs stack closed #t))]))] [(struct primval (id)) (hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))] [(struct assign (id rhs undef-ok?)) @@ -558,20 +458,9 @@ '() (list (for/list ([pos (in-list (sort (set->list tl-map) <))]) - (define tl-pos - (cond - [(or (pos . < . (glob-desc-num-tls globs)) - (zero? (glob-desc-num-stxs globs))) - pos] - [(= pos (glob-desc-num-tls globs)) - 'stx] - [else - (+ pos (glob-desc-num-stxs globs))])) - (if (eq? tl-pos 'stx) - '#%syntax - (list-ref/protect (glob-desc-vars globs) - tl-pos - 'lam)))))))) + (list-ref/protect (glob-desc-vars globs) + pos + 'lam))))))) ,(decompile-expr body globs (append captures (append vars rest-vars)) @@ -585,6 +474,249 @@ ;; ---------------------------------------- +(define (decompile-deserialize mpis inspector bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec) + ;; Names for shared values: + (define shared (for/vector ([i (in-range (+ num-mutables num-shares))]) + (string->symbol (format "~a:~a" + (if (i . < . num-mutables) + 'mutable + 'shared) + i)))) + (define (infer-name! d i) + (when (pair? d) + (define new-name + (case (car d) + [(deserialize-scope) 'scope] + [(srcloc) 'srcloc] + [else #f])) + (when new-name + (vector-set! shared i (string->symbol (format "~a:~a" new-name i)))))) + + (define mutables (make-vector num-mutables #f)) + ;; Make mutable shells + (for/fold ([pos 0]) ([i (in-range num-mutables)]) + (define-values (d next-pos) + (decode-shell mutable-vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! mutables i d) + (infer-name! d i) + next-pos) + + ;; Construct shared values + (define shareds (make-vector num-shares #f)) + (for/fold ([pos 0]) ([i (in-range num-shares)]) + (define-values (d next-pos) + (decode share-vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! shareds i d) + (infer-name! d (+ i num-mutables)) + next-pos) + + ;; Fill in mutable shells + (define-values (fill-pos rev-fills) + (for/fold ([pos 0] [rev-fills null]) ([i (in-range num-mutables)] + [v (in-vector shared)]) + (define-values (fill next-pos) + (decode-fill! v mutable-fill-vec pos mpis inspector bulk-binding-registry shared)) + (values next-pos (if fill + (cons fill rev-fills) + rev-fills)))) + + ;; Construct the final result + (define-values (result done-pos) + (decode result-vec 0 mpis inspector bulk-binding-registry shared)) + + `(let (,(for/list ([i (in-range num-mutables)]) + `(,(vector-ref shared i) ,(vector-ref mutables i)))) + (let* (,(for/list ([i (in-range num-shares)]) + `(,(vector-ref shared (+ i num-mutables)) ,(vector-ref shareds i)))) + ,@(reverse rev-fills) + ,result))) + +;; Decode the construction of a mutable variable +(define (decode-shell vec pos mpis inspector bulk-binding-registry shared) + (case (vector-ref vec pos) + [(#:box) (values (list 'box #f) (add1 pos))] + [(#:vector) (values `(make-vector ,(vector-ref vec (add1 pos))) (+ pos 2))] + [(#:hash) (values (list 'make-hasheq) (add1 pos))] + [(#:hasheq) (values (list 'make-hasheq) (add1 pos))] + [(#:hasheqv) (values (list 'make-hasheqv) (add1 pos))] + [else (decode vec pos mpis inspector bulk-binding-registry shared)])) + +;; The decoder that is used for most purposes +(define (decode vec pos mpis inspector bulk-binding-registry shared) + (define-syntax decodes + (syntax-rules () + [(_ (id ...) rhs) (decodes #:pos (add1 pos) (id ...) rhs)] + [(_ #:pos pos () rhs) (values rhs pos)] + [(_ #:pos pos ([#:ref id0] id ...) rhs) + (let-values ([(id0 next-pos) (let ([i (vector-ref vec pos)]) + (if (exact-integer? i) + (values (vector-ref shared i) (add1 pos)) + (decode vec pos mpis inspector bulk-binding-registry shared)))]) + (decodes #:pos next-pos (id ...) rhs))] + [(_ #:pos pos (id0 id ...) rhs) + (let-values ([(id0 next-pos) (decode vec pos mpis inspector bulk-binding-registry shared)]) + (decodes #:pos next-pos (id ...) rhs))])) + (define-syntax-rule (decode* (deser id ...)) + (decodes (id ...) `(deser ,id ...))) + (case (vector-ref vec pos) + [(#:ref) + (values (vector-ref shared (vector-ref vec (add1 pos))) + (+ pos 2))] + [(#:inspector) (values inspector (add1 pos))] + [(#:bulk-binding-registry) (values bulk-binding-registry (add1 pos))] + [(#:syntax #:datum->syntax) + (decodes + (content [#:ref context] [#:ref srcloc]) + `(deserialize-syntax + ,content + ,context + ,srcloc + #f + #f + ,inspector))] + [(#:syntax+props) + (decodes + (content [#:ref context] [#:ref srcloc] props tamper) + `(deserialize-syntax + ,content + ,context + ,srcloc + ,props + ,tamper + ,inspector))] + [(#:srcloc) + (decode* (srcloc source line column position span))] + [(#:quote) + (values (vector-ref vec (add1 pos)) (+ pos 2))] + [(#:mpi) + (values `(vector-ref ,mpis ,(vector-ref vec (add1 pos))) + (+ pos 2))] + [(#:box) + (decode* (box-immutable v))] + [(#:cons) + (decode* (cons a d))] + [(#:list #:vector #:set #:seteq #:seteqv) + (define len (vector-ref vec (add1 pos))) + (define r (make-vector len)) + (define next-pos + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (v next-pos) (decodes #:pos pos (v) v)) + (vector-set! r i v) + next-pos)) + (values `(,(case (vector-ref vec pos) + [(#:list) 'list] + [(#:vector) 'vector] + [(#:set) 'set] + [(#:seteq) 'seteq] + [(#:seteqv) 'seteqv]) + ,@(vector->list r)) + next-pos)] + [(#:hash #:hasheq #:hasheqv) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k v) (list* v k l)))) + (values `(,(case (vector-ref vec pos) + [(#:hash) 'hash] + [(#:hasheq) 'hasheq] + [(#:hasheqv) 'hasheqv]) + ,@(reverse l)) + next-pos)] + [(#:prefab) + (define-values (key next-pos) (decodes #:pos (add1 pos) (k) k)) + (define len (vector-ref vec next-pos)) + (define-values (r done-pos) + (for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)]) + (decodes #:pos pos (v) (cons v r)))) + (values `(make-prefab-struct ',key ,@(reverse r)) + done-pos)] + [(#:scope) + (decode* (deserialize-scope))] + [(#:scope+kind) + (decode* (deserialize-scope kind))] + [(#:multi-scope) + (decode* (deserialize-multi-scope name scopes))] + [(#:shifted-multi-scope) + (decode* (deserialize-shifted-multi-scope phase multi-scope))] + [(#:table-with-bulk-bindings) + (decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))] + [(#:bulk-binding-at) + (decode* (deserialize-bulk-binding-at scopes bulk))] + [(#:representative-scope) + (decode* (deserialize-representative-scope kind phase))] + [(#:module-binding) + (decode* (deserialize-full-module-binding + module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings))] + [(#:simple-module-binding) + (decode* (deserialize-simple-module-binding module sym phase nominal-module))] + [(#:local-binding) + (decode* (deserialize-full-local-binding key free=id))] + [(#:bulk-binding) + (decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))] + [(#:provided) + (decode* (deserialize-provided binding protected? syntax?))] + [else + (values `(quote ,(vector-ref vec pos)) (add1 pos))])) + +;; Decode the filling of mutable values, which has its own encoding +;; variant +(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared) + (case (vector-ref vec pos) + [(#f) (values #f (add1 pos))] + [(#:set-box!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (values `(set-box! ,v ,c) + next-pos)] + [(#:set-vector!) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (define-values (c next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (values (cons `(vector-set! ,v ,i ,c) l) + next-pos))) + (values `(begin ,@(reverse l)) next-pos)] + [(#:set-hash!) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (define-values (key next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (define-values (val done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (values (cons `(hash-set! ,v ,key ,val) l) + done-pos))) + (values `(begin ,@(reverse l)) next-pos)] + [(#:scope-fill!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (values `(deserialize-scope-fill! ,v ,c) + next-pos)] + [(#:representative-scope-fill!) + (define-values (a next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (define-values (d done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (values `(deserialize-representative-scope-fill! ,v ,a ,d) + done-pos)] + [else + (error 'deserialize "bad fill encoding: ~v" (vector-ref vec pos))])) + + +;; ---------------------------------------- + #; (begin (require scheme/pretty) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -#lang racket/base - -(require racket/match racket/contract compiler/zo-parse) - -(define (alpha-vary-ctop top) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)])) -(define (alpha-vary-prefix p) - (struct-copy prefix p - [toplevels - (map (match-lambda - [(and sym (? symbol?)) - (gensym sym)] - [other - other]) - (prefix-toplevels p))])) - -(provide/contract - [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/batch.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/batch.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/batch.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/batch.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,50 +1,9 @@ #lang racket/base - -#| -Here's the idea: - -- Take a module's bytecode -- Recursively get all the bytecode for modules that the target requires -- After reading it, prune everything that isn't at phase 0 (the runtime phase) - -- Now that we have all the modules, the next step is to merge them into a single - module --- Although actually we collapse them into the top-level, not a module -- To do that, we iterate through all the modules doing two things as we go: --- Incrementing all the global variable references by all the references in all - the modules ---- So if A has 5, then B's start at index 5 and so on --- Replacing module variable references with the actual global variables - corresponding to those variables ---- So if A's variable 'x' is in global slot 4, then if B refers to it, it - directly uses slot 4, rather than a module-variable slot - -- At that point we have all the module code in a single top-level, but many - toplevels won't be used because a library function isn't really used -- So, we do a "garbage collection" on elements of the prefix -- First, we create a dependency graph of all toplevels and the initial scope -- Then, we do a DFS on the initial scope and keep all those toplevels, throwing - away the construction of everything else - [XXX: This may be broken because of side-effects.] - -- Now we have a small amount code, but because we want to go back to source, - we need to fix it up a bit; because different modules may've used the same - names -- So, we do alpha-renaming, but it's easy because names are only used in the - compilation-top prefix structure - -[TODO] - -- Next, we decompile -- Then, it will pay to do dead code elimination and inlining, etc. -|# - (require racket/cmdline racket/set raco/command-name "main.rkt") - (let ([output-file (make-parameter #f)]) (command-line #:program (short-program+command-name) #:multi diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,169 @@ +#lang racket/base +(require (only-in '#%linklet primitive->compiled-position) + racket/set + compiler/zo-structs + "run.rkt" + "name.rkt") + +(provide wrap-bundle) + +(define (wrap-bundle body internals lifts excluded-module-mpis get-merge-info) + (define-values (runs + import-keys + ordered-importss + import-shapess + any-syntax-literals? + any-transformer-registers? + saw-zero-pos-toplevel?) + (get-merge-info)) + + (define module-name 'demodularized) + (define (primitive v) + (primval (or (primitive->compiled-position v) + (error "cannot find primitive" v)))) + + (define new-linkl + (linkl module-name + (list* (if any-syntax-literals? '(.get-syntax-literal!) '()) + (if any-transformer-registers? '(.set-transformer!) '()) + ordered-importss) + (list* (if any-syntax-literals? (list (function-shape 1 #f)) '()) + (if any-transformer-registers? (list (function-shape 2 #f)) '()) + import-shapess) + '() ; exports + internals + lifts + #hasheq() + body + (for/fold ([m 0]) ([r (in-list runs)]) + (max m (linkl-max-let-depth (run-linkl r)))) + saw-zero-pos-toplevel?)) + + (define data-linkl + (linkl 'data + '((deserialize-module-path-indexes)) + '((#f)) + '(.mpi-vector) + '() + '() + #hasheq() + (list + (def-values (list (toplevel 0 2 #f #f)) ; .mpi-vector + (application (toplevel 2 1 #f #f) ; deserialize-module-path-indexes + ;; Construct two vectors: one for mpi construction, and + ;; another for selecting the slots that are externally referenced + ;; mpis (where the selection vector matches th `import-keys` order). + ;; If all import keys are primitive modules, then we just make + ;; a vector with those specs in order, but if there's a more + ;; complex mpi, then we have to insert extra slots in the first + ;; vector to hold intermediate mpi constructions. + ;; We could do better here by sharing common tails. + (let loop ([import-keys import-keys] + [specs (list (box module-name))] + [results (list 0)]) + (cond + [(null? import-keys) + (list (list->vector (reverse specs)) + (list->vector (reverse results)))] + [else + (define path/submod+phase (car import-keys)) + (define path (car path/submod+phase)) + (cond + [(symbol? path) + (loop (cdr import-keys) + (cons (vector `(quote ,path)) specs) + (cons (length specs) results))] + [(path? path) + (define-values (i new-specs) + (begin + (let mpi-loop ([mpi (hash-ref excluded-module-mpis path)]) + (define-values (name base) (module-path-index-split mpi)) + (cond + [(and (not name) (not base)) + (values 0 specs)] + [(not base) + (values (length specs) (cons (vector name) specs))] + [else + (define-values (next-i next-specs) (mpi-loop base)) + (values (length next-specs) (cons (vector name next-i) next-specs))])))) + (loop (cdr import-keys) + new-specs + (cons i results))] + [else + (error 'wrap-bundle "unrecognized import path shape: ~s" path)])]))))) + 16 + #f)) + + (define decl-linkl + (let ([deserialize-pos 1] + [module-use-pos 2] + [mpi-vector-pos 3] + [exports-pos 4]) + (linkl 'decl + '((deserialize + module-use) + (.mpi-vector)) + '((#f) + (#f)) + '(self-mpi requires provides phase-to-link-modules) + '() + '() + #hasheq() + (list + (def-values (list (toplevel 0 (+ exports-pos 0) #f #f)) ; .self-mpi + (application (primitive vector-ref) + (list (toplevel 2 mpi-vector-pos #f #f) + '0))) + (def-values (list (toplevel 0 (+ exports-pos 1) #f #f)) ; requires + (let ([arg-count 9]) + (application (toplevel arg-count deserialize-pos #f #f) + (list + (toplevel arg-count mpi-vector-pos #f #f) + #f #f 0 '#() 0 '#() '#() + (list->vector + (let loop ([phases (sort (set->list + (for/set ([path/submod+phase (in-list import-keys)]) + (cdr path/submod+phase))) + <)]) + (cond + [(null? phases) (list '())] + [else + (define phase (car phases)) + (define n (for/sum ([path/submod+phase (in-list import-keys)]) + (if (eqv? phase (cdr path/submod+phase)) 1 0))) + (append `(#:cons #:list ,(add1 n) ,(- 0 phase)) + (apply + append + (for/list ([path/submod+phase (in-list import-keys)] + [i (in-naturals 1)] + #:when (eqv? phase (cdr path/submod+phase))) + `(#:mpi ,i))) + (loop (cdr phases)))]))))))) + (def-values (list (toplevel 0 (+ exports-pos 2) #f #f)) ; provides + (application (primitive hasheqv) null)) + (def-values (list (toplevel 0 (+ exports-pos 3) #f #f)) ; phase-to-link-modules + (let ([depth 2]) + (application (primitive hasheqv) + (list 0 + (let ([depth (+ depth (length import-keys))]) + (application (primitive list) + (for/list ([path/submod+phase (in-list import-keys)] + [i (in-naturals 1)]) + (let ([depth (+ depth 2)]) + (application (toplevel depth module-use-pos #f #f) + (list + (let ([depth (+ depth 2)]) + (application (primitive vector-ref) + (list + (toplevel depth mpi-vector-pos #f #f) + i))) + (cdr path/submod+phase)))))))))))) + (+ 32 (length import-keys)) + #f))) + + ;; By not including a 'stx-data linklet, we get a default + ;; linklet that supplies #f for any syntax-literal reference. + + (linkl-bundle (hasheq 0 new-linkl + 'data data-linkl + 'decl decl-linkl))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/find.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/find.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/find.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/find.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,164 @@ +#lang racket/base +(require racket/set + compiler/zo-parse + syntax/modcode + racket/linklet + "../private/deserialize.rkt" + "module-path.rkt" + "run.rkt") + +(provide find-modules + current-excluded-modules) + +(struct mod (compiled zo)) ; includes submodules; `zo` is #f for excluded +(struct one-mod (compiled zo decl)) ; module without submodules + +(define current-excluded-modules (make-parameter (set))) + +(define (find-modules orig-path #:submodule [submod '()]) + (define mods (make-hash)) ; path -> mod + (define one-mods (make-hash)) ; path+submod -> one-mod + (define runs-done (make-hash)) ; path+submod+phase -> #t + (define runs null) ; list of `run` + (define excluded-module-mpis (make-hash)) ; path -> mpi + + (define (find-modules! orig-path+submod exclude?) + (define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod)) + (define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '())) + (define path (normal-case-path (simplify-path (path->complete-path orig-path)))) + + (unless (hash-ref mods path #f) + (define-values (zo-path kind) (get-module-path path)) + (unless (eq? kind 'zo) + (error 'demodularize "not available in bytecode form\n path: ~a" path)) + (define zo (and (not exclude?) + (call-with-input-file zo-path zo-parse))) + (define compiled (parameterize ([read-accept-compiled #t] + [current-load-relative-directory + (let-values ([(dir file-name dir?) (split-path path)]) + dir)]) + (call-with-input-file zo-path read))) + (hash-set! mods path (mod compiled zo))) + + (unless (hash-ref one-mods (cons path submod) #f) + (define m (hash-ref mods path)) + (define compiled (mod-compiled m)) + (define zo (mod-zo m)) + + (define (raise-no-submod) + (error 'demodularize "no such submodule\n path: ~a\n submod: ~a" + path submod)) + (define one-compiled + (let loop ([compiled compiled] [submod submod]) + (cond + [(linklet-bundle? compiled) + (unless (null? submod) (raise-no-submod)) + compiled] + [else + (cond + [(null? submod) + (or (hash-ref (linklet-directory->hash compiled) #f #f) + (raise-no-submod))] + [else + (loop (or (hash-ref (linklet-directory->hash compiled) (car submod) #f) + (raise-no-submod)) + (cdr submod))])]))) + (define one-zo + (cond + [(not zo) #f] + [(linkl-bundle? zo) + (unless (null? submod) (raise-no-submod)) + zo] + [else + (or (hash-ref (linkl-directory-table zo) submod #f) + (raise-no-submod))])) + + (define h (linklet-bundle->hash one-compiled)) + (define data-linklet (hash-ref h 'data #f)) + (define decl-linklet (hash-ref h 'decl #f)) + (unless data-linklet + (error 'demodularize "could not find module path metadata\n path: ~a\n submod: ~a" + path submod)) + (unless decl-linklet + (error 'demodularize "could not find module metadata\n path: ~a\n submod: ~a" + path submod)) + + (define data-instance (instantiate-linklet data-linklet + (list deserialize-instance))) + (define decl (instantiate-linklet decl-linklet + (list deserialize-instance + data-instance))) + + (hash-set! one-mods (cons path submod) (one-mod one-compiled one-zo decl)) + + ;; Transitive requires + + (define reqs (instance-variable-value decl 'requires)) + + (for ([phase+reqs (in-list reqs)] + #:when (car phase+reqs) + [req (in-list (cdr phase+reqs))]) + (define path/submod (module-path-index->path req path submod)) + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (unless (symbol? req-path) + (find-modules! path/submod + ;; Even if this module is excluded, traverse it to get all + ;; modules that it requires, so that we don't duplicate those + ;; modules by accessing them directly + (or exclude? (set-member? (current-excluded-modules) req-path))))))) + + (define (find-phase-runs! orig-path+submod orig-mpi #:phase [phase 0]) + (define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod)) + (define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '())) + (define path (normal-case-path (simplify-path (path->complete-path orig-path)))) + (define path/submod (if (pair? submod) (cons path submod) path)) + + (unless (hash-ref runs-done (cons (cons path submod) phase) #f) + (define one-m (hash-ref one-mods (cons path submod) #f)) + (when (one-mod-zo one-m) ; not excluded + (define decl (one-mod-decl one-m)) + + (define linkl (hash-ref (linkl-bundle-table (one-mod-zo one-m)) phase #f)) + (define uses + (list* + ;; The first implicit import might get used for syntax literals; + ;; recognize it with a 'syntax-literals "phase" + (cons path/submod 'syntax-literals) + ;; The second implicit import might get used to register a macro; + ;; we'll map those registrations to the same implicit import: + '(#%transformer-register . transformer-register) + (for/list ([u (hash-ref (instance-variable-value decl 'phase-to-link-modules) + phase + null)]) + (define path/submod (module-path-index->path (module-use-module u) path submod)) + + ;; In case the import turns out to stay imported: + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (hash-set! excluded-module-mpis req-path (module-path-index-reroot (module-use-module u) orig-mpi)) + + (cons path/submod (module-use-phase u))))) + + (define r (run (if (null? submod) path (cons path submod)) phase linkl uses)) + (hash-set! runs-done (cons (cons path submod) phase) #t) + + (define reqs (instance-variable-value decl 'requires)) + (for* ([phase+reqs (in-list reqs)] + #:when (car phase+reqs) + [req (in-list (cdr phase+reqs))]) + (define at-phase (- phase (car phase+reqs))) + (define path/submod (module-path-index->path req path submod)) + (define full-mpi (module-path-index-reroot req orig-mpi)) + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (unless (or (symbol? req-path) + (set-member? (current-excluded-modules) req-path)) + (find-phase-runs! path/submod full-mpi #:phase at-phase))) + + ;; Adding after requires, so that `runs` ends up in the + ;; reverse order that we want to emit code + (when linkl (set! runs (cons r runs)))))) + + (find-modules! (cons orig-path submod) #f) + (find-phase-runs! (cons orig-path submod) (module-path-index-join #f #f)) + + (values (reverse runs) + excluded-module-mpis)) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,164 @@ +#lang racket/base +(require racket/match + racket/set + compiler/zo-structs + "remap.rkt") + +;; Prune unnused definitions, +;; * soundly, with a simple approximation of `pure?`, by default +;; * unsoundly, assuming all definitions are pure, optionally + +(provide gc-definitions) + +(define (gc-definitions body internals lifts internals-pos + #:assume-pure? assume-pure?) + (define used (make-hasheqv)) ; pos -> 'used or thunk + (define graph (make-hasheq)) + + (define (used-pos! pos) + (when (pos . >= . internals-pos) + (define v (hash-ref used pos #f)) + (hash-set! used pos 'used) + (when (procedure? v) + (v)))) + + (define (used! b) + (match b + [(toplevel depth pos const? ready?) + (used-pos! pos)] + [(inline-variant direct inline) + (used! direct) + (used! inline)] + [(closure code gen-id) + (unless (hash-ref graph gen-id #f) + (hash-set! graph gen-id #t) + (used! code))] + [(let-one rhs body type unused?) + (used! rhs) + (used! body)] + [(let-void count boxes? body) + (used! body)] + [(install-value count pos boxes? rhs body) + (used! rhs) + (used! body)] + [(let-rec procs body) + (for-each used! procs) + (used! body)] + [(boxenv pos body) + (used! body)] + [(application rator rands) + (used! rator) + (for-each used! rands)] + [(branch tst thn els) + (used! tst) + (used! thn) + (used! els)] + [(with-cont-mark key val body) + (used! key) + (used! val) + (used! body)] + [(beg0 forms) + (for-each used! forms)] + [(seq forms) + (for-each used! forms)] + [(varref toplevel dummy constant? unsafe?) + (used! toplevel) + (used! dummy)] + [(assign id rhs undef-ok?) + (used! id) + (used! rhs)] + [(apply-values proc args-expr) + (used! proc) + (used! args-expr)] + [(with-immed-mark key def-val body) + (used! key) + (used! def-val) + (used! body)] + [(case-lam name clauses) + (for-each used! clauses)] + [_ + (cond + [(lam? b) + (define tl-map (lam-toplevel-map b)) + (when tl-map + (for/set ([pos (in-set tl-map)]) + (when (pos . >= . internals-pos) + (used-pos! pos)))) + (used! (lam-body b))] + [else (void)])])) + + (define (pure? b) + (match b + [(closure code gen-id) #t] + [(inline-variant direct inline) #t] + [(case-lam name clauses) #t] + [_ (lam? b)])) + + (for ([b (in-list body)]) + (match b + [(def-values ids rhs) + (define done? #f) + (define (used-rhs!) + (unless done? + (set! done? #t) + (used! rhs)) + ;; All in group are used together: + (for-each used! ids)) + (for ([id (in-list ids)]) + (define pos (toplevel-pos id)) + (cond + [(eq? 'used (hash-ref used pos #f)) + (used-rhs!)] + [else + (hash-set! used pos used-rhs!)])) + (unless (or assume-pure? + (pure? rhs)) + (used-rhs!))] + [_ (used! b)])) + + ;; Anything not marked as used at this point can be dropped + (define new-internals + (for/list ([name (in-list internals)] + [pos (in-naturals internals-pos)] + #:when (or (eq? 'used (hash-ref used pos #f)) + (begin + (log-debug "drop ~s" name) + #f))) + name)) + + (define lifts-pos (+ internals-pos (length internals))) + (define new-lifts + (for/list ([name (in-list lifts)] + [pos (in-naturals lifts-pos)] + #:when (or (eq? 'used (hash-ref used pos #f)) + (begin + (log-debug "drop ~s" name) + #f))) + name)) + + (define old-pos-to-new-pos (make-hasheqv)) + (for/fold ([new-pos internals-pos]) ([name (in-list (append internals lifts))] + [pos (in-naturals internals-pos)]) + (cond + [(eq? 'used (hash-ref used pos #f)) + (hash-set! old-pos-to-new-pos pos new-pos) + (add1 new-pos)] + [else new-pos])) + + (define used-body + ;; Drop unused definitions + (for/list ([b (in-list body)] + #:when (match b + [(def-values ids rhs) + (for/or ([id (in-list ids)]) + (eq? 'used (hash-ref used (toplevel-pos id) #f)))] + [else (not (void? b))])) + b)) + + (define new-body (remap-positions used-body + (lambda (pos) + (if (pos . < . internals-pos) + pos + (hash-ref old-pos-to-new-pos pos))))) + + (values new-body new-internals new-lifts)) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,288 +0,0 @@ -#lang racket/base - -(require racket/match - racket/list - racket/dict - racket/contract - compiler/zo-parse - "util.rkt") - -; XXX Use efficient set structure -(define (gc-toplevels top) - (match top - [(struct compilation-top (max-let-depth binding-namess top-prefix form)) - (define lift-start - (prefix-lift-start top-prefix)) - (define max-depgraph-index - (+ (prefix-num-lifts top-prefix) - lift-start)) - (define top-node max-depgraph-index) - (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty))) - (define build-graph! (make-build-graph! DEP-GRAPH)) - (define _void (build-graph! (list top-node) form)) - (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node)) - (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node - (define ordered-stxs (sort stxs <=)) - (define (lift? i) (lift-start . <= . i)) - (define-values (lifts normal-tls) (partition lift? ordered-used-tls)) - (define new-prefix - (make-prefix - (length lifts) - (for/list ([i normal-tls]) - (list-ref (prefix-toplevels top-prefix) i)) - (for/list ([i ordered-stxs]) - (list-ref (prefix-stxs top-prefix) i)))) - (define new-lift-start - (prefix-lift-start new-prefix)) - ; XXX This probably breaks max-let-depth - (define new-form - ((gc-toplevels-form - (lambda (pos) (index<=? pos ordered-used-tls)) - (lambda (pos) - (if (lift? pos) - (+ new-lift-start (index<=? pos lifts)) - (index<=? pos normal-tls))) - (lambda (stx-pos) - (index<=? stx-pos ordered-stxs)) - (prefix-syntax-start new-prefix)) - form)) - (log-debug (format "Total TLS: ~S" (length normal-tls))) - (log-debug (format "Used TLS: ~S" normal-tls)) - (log-debug (format "Total lifts: ~S" (length lifts))) - (log-debug (format "Used lifts: ~S" lifts)) - (log-debug (format "Total stxs: ~S" (length stxs))) - (log-debug (format "Used stxs: ~S" ordered-stxs)) - (make-compilation-top - max-let-depth - #hash() - new-prefix - new-form)])) - -(define-struct refs (tl stx) #:transparent) - -(define (make-build-graph! DEP-GRAPH) - (define (build-graph!* form lhs) - (match form - [(struct def-values (ids rhs)) - (define new-lhs (map toplevel-pos ids)) - ; If we require one, we should require all, so make them reference each other - (for-each (lambda (tl) (build-graph! new-lhs tl)) ids) - (build-graph! new-lhs rhs)] - [(? def-syntaxes?) - (error 'build-graph "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'build-graph "Doesn't handle syntax")] - [(struct inline-variant (direct inline)) - (build-graph! lhs direct)] - [(struct req (reqs dummy)) - (build-graph! lhs dummy)] - [(? mod?) - (error 'build-graph "Doesn't handle modules")] - [(struct seq (forms)) - (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(struct splice (forms)) - (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (build-graph! lhs body)] - [(and c (struct closure (code gen-id))) - (build-graph! lhs code)] - [(and cl (struct case-lam (name clauses))) - (for-each (lambda (l) (build-graph! lhs l)) - clauses)] - [(struct let-one (rhs body flonum? unused?)) - (build-graph! lhs rhs) - (build-graph! lhs body)] - [(and f (struct let-void (count boxes? body))) - (build-graph! lhs body)] - [(and f (struct install-value (_ _ _ rhs body))) - (build-graph! lhs rhs) - (build-graph! lhs body)] - [(struct let-rec (procs body)) - (for-each (lambda (l) (build-graph! lhs l)) procs) - (build-graph! lhs body)] - [(and f (struct boxenv (_ body))) - (build-graph! lhs body)] - [(and f (struct toplevel (_ pos _ _))) - (for-each (lambda (lhs) - (dict-update! DEP-GRAPH lhs - (match-lambda - [(struct refs (tls stxs)) - (make-refs (list* pos tls) stxs)]))) - lhs)] - [(and f (struct topsyntax (_ pos _))) - (for-each (lambda (lhs) - (dict-update! DEP-GRAPH lhs - (match-lambda - [(struct refs (tls stxs)) - (make-refs tls (list* pos stxs))]))) - lhs)] - [(struct application (rator rands)) - (for-each (lambda (f) (build-graph! lhs f)) - (list* rator rands))] - [(struct branch (test then else)) - (for-each (lambda (f) (build-graph! lhs f)) - (list test then else))] - [(struct with-cont-mark (key val body)) - (for-each (lambda (f) (build-graph! lhs f)) - (list key val body))] - [(struct with-immed-mark (key val body)) - (for-each (lambda (f) (build-graph! lhs f)) - (list key val body))] - [(struct beg0 (seq)) - (for-each (lambda (f) (build-graph! lhs f)) - seq)] - [(struct varref (tl dummy)) - (build-graph! lhs tl) - (build-graph! lhs dummy)] - [(and f (struct assign (id rhs undef-ok?))) - (build-graph! lhs id) - (build-graph! lhs rhs)] - [(struct apply-values (proc args-expr)) - (build-graph! lhs proc) - (build-graph! lhs args-expr)] - [(and f (struct primval (id))) - (void)] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - (void)] - [(and v (not (? form?))) - (void)])) - (define-values (first-build-graph!** build-graph!**) - (build-form-memo build-graph!* #:void? #t)) - (define (build-graph! lhs form) (first-build-graph!** form lhs)) - build-graph!) - -(define (graph-dfs g start-node) - (define visited? (make-hasheq)) - (define (visit-tl n tls stxs) - (if (hash-has-key? visited? n) - (values tls stxs) - (match (dict-ref g n) - [(struct refs (n-tls n-stxs)) - (hash-set! visited? n #t) - (define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs))) - (values (list* n new-tls1) - new-stxs2)]))) - (define stx-visited? (make-hasheq)) - (define (visit-stx n) - (if (hash-has-key? stx-visited? n) - #f - (begin (hash-set! stx-visited? n #t) - n))) - (visit-tl start-node empty empty)) - -; index<=? : number? (listof number?) -> (or/c number? false/c) -; returns the index of n in l and assumes that l is sorted by <= -(define (index<=? n l) - (match l - [(list) #f] - [(list-rest f l) - (cond - [(= n f) - 0] - [(< n f) - #f] - [else - (let ([rec (index<=? n l)]) - (if rec (add1 rec) rec))])])) - -(define (identity x) x) -(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt) - (define (inner-update form) - (match form - [(struct def-values (ids rhs)) - (if (ormap (compose keep? toplevel-pos) ids) - (make-def-values (map update ids) - (update rhs)) - #f)] - [(? def-syntaxes?) - (error 'gc-tls "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'gc-tls "Doesn't handle syntax")] - [(struct req (reqs dummy)) - (make-req reqs (update dummy))] - [(? mod?) - (error 'gc-tls "Doesn't handle modules")] - [(struct seq (forms)) - (make-seq (filter identity (map update forms)))] - [(struct splice (forms)) - (make-splice (filter identity (map update forms)))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (struct-copy lam l - [toplevel-map #f] ; consevrative - [body (update body)])] - [(and c (struct closure (code gen-id))) - (struct-copy closure c - [code (update code)])] - [(and cl (struct case-lam (name clauses))) - (struct-copy case-lam cl - [clauses (map update clauses)])] - [(struct let-one (rhs body type unused?)) - (make-let-one (update rhs) (update body) type unused?)] - [(and f (struct let-void (count boxes? body))) - (struct-copy let-void f - [body (update body)])] - [(and f (struct install-value (_ _ _ rhs body))) - (struct-copy install-value f - [rhs (update rhs)] - [body (update body)])] - [(struct let-rec (procs body)) - (make-let-rec (map update procs) (update body))] - [(and f (struct boxenv (_ body))) - (struct-copy boxenv f [body (update body)])] - [(and f (struct toplevel (_ pos _ _))) - (struct-copy toplevel f - [pos (update-tl pos)])] - [(and f (struct topsyntax (_ pos _))) - (struct-copy topsyntax f - [pos (update-ts pos)] - [midpt new-ts-midpt])] - [(struct application (rator rands)) - (make-application - (update rator) - (map update rands))] - [(struct branch (test then else)) - (make-branch - (update test) - (update then) - (update else))] - [(struct with-cont-mark (key val body)) - (make-with-cont-mark - (update key) - (update val) - (update body))] - [(struct beg0 (seq)) - (make-beg0 (map update seq))] - [(struct varref (tl dummy)) - (make-varref (update tl) (update dummy))] - [(and f (struct assign (id rhs undef-ok?))) - (struct-copy assign f - [id (update id)] - [rhs (update rhs)])] - [(struct apply-values (proc args-expr)) - (make-apply-values - (update proc) - (update args-expr))] - [(and f (struct primval (id))) - f] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - f] - [(and v (not (? form?))) - v] - )) - (define-values (first-update update) - (build-form-memo inner-update)) - first-update) - -(provide/contract - [gc-toplevels (compilation-top? . -> . compilation-top?)]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/import.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/import.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/import.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/import.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out import)) + +(struct import (name shape [pos #:mutable])) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/info.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/info.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/info.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/info.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -#lang info - -(define test-responsibles '((all jay))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/main.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/main.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/main.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,91 +1,63 @@ #lang racket/base -(require compiler/cm - compiler/zo-marshal - "alpha.rkt" - "gc-toplevels.rkt" +(require racket/set + compiler/cm + "find.rkt" + "name.rkt" "merge.rkt" - "module.rkt" - "mpi.rkt" - "nodep.rkt" - "replace-modidx.rkt") + "gc.rkt" + "bundle.rkt" + "write.rkt") + +(provide demodularize -(provide current-excluded-modules garbage-collect-toplevels-enabled - recompile-enabled - demodularize) + current-excluded-modules + recompile-enabled) (define garbage-collect-toplevels-enabled (make-parameter #f)) (define recompile-enabled (make-parameter #f)) (define logger (make-logger 'demodularizer (current-logger))) -(define (demodularize file-to-batch [output-file #f]) - (parameterize ([current-logger logger]) - (define-values (base name must-be-dir?) (split-path file-to-batch)) - (when must-be-dir? - (error 'demodularize "Cannot run on directory: ~a" file-to-batch)) - (unless (file-exists? file-to-batch) - (error 'demodularize "File does not exist: ~a" file-to-batch)) - - ;; Compile +(define (demodularize input-file [given-output-file #f]) + (parameterize ([current-logger logger] + [current-excluded-modules (for/set ([path (in-set (current-excluded-modules))]) + (normal-case-path (simplify-path (path->complete-path path))))]) + (log-info "Compiling module") (parameterize ([current-namespace (make-base-empty-namespace)]) - (managed-compile-zo file-to-batch)) - - (define merged-zo-path - (or output-file - (path-add-suffix file-to-batch #"_merged.zo"))) - - ;; Transformations - (define path-cache (make-hasheq)) - - (log-info "Removing dependencies") - (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) - (parameterize ([MODULE-PATHS path-cache]) - (nodep-file file-to-batch))) - - (log-info "Merging modules") - (define batch-merge - (parameterize ([MODULE-PATHS path-cache]) - (merge-compilation-top get-modvar-rewrite batch-nodep))) - - (define batch-gcd - (if (garbage-collect-toplevels-enabled) - (begin - (log-info "GC-ing top-levels") - (gc-toplevels batch-merge)) - batch-merge)) - - (log-info "Alpha-varying top-levels") - (define batch-alpha - (alpha-vary-ctop batch-gcd)) - - (log-info "Replacing self-modidx") - (define batch-replace-modidx - (replace-modidx batch-alpha top-self-modidx)) - - (define batch-modname - (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) - (log-info (format "Modularizing into ~a" batch-modname)) - (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) - - (log-info "Writing merged zo") - (void - (with-output-to-file - merged-zo-path - (lambda () - (zo-marshal-to batch-mod (current-output-port))) - #:exists 'replace)) - - (void - (when (recompile-enabled) - (define recomp - (compiled-expression-recompile - (parameterize ([read-accept-compiled #t]) - (call-with-input-file merged-zo-path read)))) - (call-with-output-file merged-zo-path - (lambda (out) - (write recomp out)) - #:exists 'replace))))) + (managed-compile-zo input-file)) + + (log-info "Finding modules") + (define-values (runs excluded-module-mpis) (find-modules input-file)) + + (log-info "Selecting names") + (define-values (names internals lifts imports) (select-names runs)) + + (log-info "Merging linklets") + (define-values (body first-internal-pos get-merge-info) + (merge-linklets runs names internals lifts imports)) + + (log-info "GCing definitions") + (define-values (new-body new-internals new-lifts) + (gc-definitions body internals lifts first-internal-pos + #:assume-pure? (garbage-collect-toplevels-enabled))) + + (log-info "Bundling linklet") + (define bundle (wrap-bundle new-body new-internals new-lifts + excluded-module-mpis + get-merge-info)) + + (log-info "Writing bytecode") + (define output-file (or given-output-file + (path-add-suffix input-file #"_merged.zo"))) + (write-module output-file bundle) + (when (recompile-enabled) + (log-info "Recompiling and rewriting bytecode") + (define zo (compiled-expression-recompile + (parameterize ([read-accept-compiled #t]) + (call-with-input-file* output-file read)))) + (call-with-output-file* output-file + #:exists 'replace + (lambda (out) (write zo out)))))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,229 +1,144 @@ #lang racket/base - -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt" - "mpi.rkt" - "nodep.rkt" - "update-toplevels.rkt") - -(define MODULE-TOPLEVEL-OFFSETS (make-hasheq)) - -(define current-get-modvar-rewrite (make-parameter #f)) -(define (merge-compilation-top get-modvar-rewrite top) - (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (new-max-let-depth new-prefix gen-new-forms) - (merge-form max-let-depth prefix form)) - (define total-tls (length (prefix-toplevels new-prefix))) - (define total-stxs (length (prefix-stxs new-prefix))) - (define total-lifts (prefix-num-lifts new-prefix)) - (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S" total-tls)) - (log-debug (format "total stxs ~S" total-stxs)) - (log-debug (format "num-lifts ~S" total-lifts)) - (for ([i (in-naturals)] - [p (in-list (prefix-toplevels new-prefix))]) - (log-debug (format "new-prefix tls\t~v ~v" i p))) - (make-compilation-top - new-max-let-depth #hash() new-prefix - (make-splice (gen-new-forms new-prefix)))] - [else (error 'merge "unrecognized: ~e" top)]))) - -(define (merge-forms max-let-depth prefix forms) - (if (empty? forms) - (values max-let-depth prefix (lambda _ empty)) - (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] - [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) - (values rmax-let-depth - rprefix - (lambda args - (append (apply gen-fform args) - (apply gen-rforms args))))))) - -(define (merge-form max-let-depth prefix form) - (match form - [(? mod?) - (merge-module max-let-depth prefix form)] - [(struct seq (forms)) - (merge-forms max-let-depth prefix forms)] - [(struct splice (forms)) - (merge-forms max-let-depth prefix forms)] - [else - (values max-let-depth prefix (lambda _ (list form)))])) - -(define (index-of v l) - (for/or ([e (in-list l)] - [i (in-naturals)] - #:when (eq? e v)) - i)) - -(define (merge-prefix root-prefix mod-prefix) - (match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix) - (match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix) - (make-prefix (+ root-num-lifts mod-num-lifts) - (append root-toplevels mod-toplevels) - (append root-stxs mod-stxs) - root-src-insp-desc)) - -(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) - -(define (compute-new-modvar mv rw) - (match mv - [(struct module-variable (modidx sym pos phase constantness)) - (match rw - [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx))) - (define tl (provide->toplevel sym pos)) - (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) - (match-define (toplevel-offset-rewriter rewrite-fun meta) - (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda () - (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) - (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) - (define res (rewrite-fun tl)) - (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" - sym pos (mpi->path* modidx) tl meta res)) - res])])) - -(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels) - (define-values - (i new-toplevels remap) - (for/fold ([i 0] - [new-toplevels empty] - [remap empty]) - ([tl (in-list mod-toplevels)] - [idx (in-naturals)]) - (log-debug (format "[~S] mod-prefix tls\t~v ~v" - name idx tl)) - (match tl - [(and mv (struct module-variable (modidx sym pos phase constantness))) - (define rw ((current-get-modvar-rewrite) modidx)) - ;; XXX We probably don't need to deal with #f phase - (unless (or (not phase) (zero? phase)) - (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) - (cond - ; Primitive module like #%paramz - [(symbol? rw) - (log-debug (format "~S from ~S" sym rw)) - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))] - [(module-path-index? rw) - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))] - [(modvar-rewrite? rw) - (values i - new-toplevels - (list* (compute-new-modvar mv rw) remap))] - [else - (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] - [tl +(require compiler/zo-structs + "run.rkt" + "name.rkt" + "import.rkt" + "remap.rkt") + +(provide merge-linklets) + +(define (merge-linklets runs names internals lifts imports) + (define (syntax-literals-import? path/submod+phase) + (eq? (cdr path/submod+phase) 'syntax-literals)) + (define (transformer-register-import? path/submod+phase) + (eq? (cdr path/submod+phase) 'transformer-register)) + + ;; Pick an order for the remaining imports: + (define import-keys (for/list ([path/submod+phase (in-hash-keys imports)] + ;; References to a 'syntax-literals "phase" are + ;; references to the implicit syntax-literals + ;; module; drop those: + #:unless (or (syntax-literals-import? path/submod+phase) + (transformer-register-import? path/submod+phase))) + path/submod+phase)) + + (define any-syntax-literals? + (for/or ([path/submod+phase (in-hash-keys imports)]) + (syntax-literals-import? path/submod+phase))) + (define any-transformer-registers? + (for/or ([path/submod+phase (in-hash-keys imports)]) + (transformer-register-import? path/submod+phase))) + (define syntax-literals-pos 1) + (define transformer-register-pos (+ (if any-syntax-literals? 1 0) + syntax-literals-pos)) + (define import-counter (+ (if any-transformer-registers? 1 0) + transformer-register-pos)) + + ;; Map each remaining import to its position + (define ordered-importss + (for/list ([key (in-list import-keys)]) + (define ordered-imports (hash-ref imports key)) + (for ([name (in-list ordered-imports)]) + (define i (hash-ref names (cons key name))) + (set-import-pos! i import-counter) + (set! import-counter (add1 import-counter))) + ordered-imports)) + ;; Keep all the same import shapes + (define import-shapess + (for/list ([key (in-list import-keys)]) + (for/list ([name (in-list (hash-ref imports key))]) + (import-shape (hash-ref names (cons key name)))))) + + ;; Map all syntax-literal references to the same import. + ;; We could update each call to the access to use a suitable + ;; vector index. + (for ([(path/submod+phase imports) (in-hash imports)] + #:when (syntax-literals-import? path/submod+phase) + [name (in-list imports)]) + (define i (hash-ref names (cons path/submod+phase name))) + (set-import-pos! i syntax-literals-pos)) + + ;; Map the transformer-register import, if any + (let* ([path/submod+phase '(#%transformer-register . transformer-register)] + [imports (hash-ref imports path/submod+phase null)]) + (for ([name (in-list imports)]) + (define i (hash-ref names (cons path/submod+phase name))) + (set-import-pos! i transformer-register-pos))) + + ;; Map internals and lifts to positions + (define first-internal-pos import-counter) + (define positions + (for/hash ([name (in-list (append internals lifts))] + [i (in-naturals first-internal-pos)]) + (values name i))) + + ;; For each linklet that we merge, make a mapping from + ;; the linklet's old position to new names (which can + ;; then be mapped to new positions): + (define (make-position-mapping r) + (define h (make-hasheqv)) + (define linkl (run-linkl r)) + (define importss (linkl-importss linkl)) + (define pos 1) + (for ([imports (in-list importss)] + [use (in-list (run-uses r))]) + (for ([name (in-list imports)]) + (hash-set! h pos (find-name names use name)) + (set! pos (add1 pos)))) + (define path/submod+phase (cons (run-path/submod r) (run-phase r))) + (for ([name (in-list (append (linkl-exports linkl) + (linkl-internals linkl) + (linkl-lifts linkl)))] + [pos (in-naturals pos)]) + (hash-set! h pos (find-name names path/submod+phase name))) + h) + + ;; Do we need the implicit initial variable for `(#%variable-reference)`? + ;; The slot will be reserved whether we use it or not, but the + ;; slot is not necessarily initialized if we don't need it. + (define saw-zero-pos-toplevel? #f) + + (define body + (apply + append + (for/list ([r (in-list runs)]) + (define pos-to-name/import (make-position-mapping r)) + (define (remap-toplevel-pos pos) (cond - [(and new-#f-idx (not tl)) - (log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v" - name idx (+ i toplevel-offset) new-#f-idx)) - (values i - new-toplevels - (list* new-#f-idx remap))] + [(zero? pos) + ;; Implicit variable for `(#%variable-reference)` stays in place: + (set! saw-zero-pos-toplevel? #t) + 0] [else - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))])]))) - ; XXX This would be more efficient as a vector - (values (reverse new-toplevels) - (reverse remap))) - -(define (merge-module max-let-depth top-prefix mod-form) - (match mod-form - [(struct mod (name srcname self-modidx - mod-prefix provides requires body syntax-bodies - unexported mod-max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (define top-toplevels (prefix-toplevels top-prefix)) - (define toplevel-offset (length top-toplevels)) - (define topsyntax-offset (length (prefix-stxs top-prefix))) - (define lift-offset (prefix-num-lifts top-prefix)) - (define mod-toplevels (prefix-toplevels mod-prefix)) - (define new-#f-idx - (index-of #f top-toplevels)) - (when new-#f-idx - (log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing" - name new-#f-idx))) - (define-values (new-mod-toplevels toplevel-remap) - (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)) - (define num-mod-toplevels - (length toplevel-remap)) - (define mod-stxs - (length (prefix-stxs mod-prefix))) - (define mod-num-lifts - (prefix-num-lifts mod-prefix)) - (define new-mod-prefix - (struct-copy prefix mod-prefix - [toplevels new-mod-toplevels])) - (define offset-meta (vector name srcname self-modidx)) - (log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S" - offset-meta - (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f)) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx - (toplevel-offset-rewriter - (lambda (n) - (log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta) - (list-ref toplevel-remap n)) - offset-meta)) - (unless (= (length toplevel-remap) - (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S" - mod-toplevels toplevel-remap)) - (log-debug (format "[~S] Incrementing toplevels by ~a" - name - toplevel-offset)) - (log-debug (format "[~S] Incrementing lifts by ~a" - name - lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" - name - (length mod-toplevels) - (length new-mod-toplevels))) - (values (max max-let-depth mod-max-let-depth) - (merge-prefix top-prefix new-mod-prefix) - (lambda (top-prefix) - (log-debug (format "[~S] Updating top-levels" name)) - (define top-lift-start (prefix-lift-start top-prefix)) - (define mod-lift-start (prefix-lift-start mod-prefix)) - (define total-lifts (prefix-num-lifts top-prefix)) - (define max-toplevel (+ top-lift-start total-lifts)) - (define update - (update-toplevels - (lambda (n) - (define new-idx - (cond - [(mod-lift-start . <= . n) - (log-debug (format "[~S] ~v is a lift" - name n)) - (define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift)) - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl] - [else - ;; xxx maybe change this to a vector after it is made to make this efficient - (list-ref toplevel-remap n)])) - (log-debug (format "[~S] ~v is remapped to ~v" - name n new-idx)) - new-idx) - (lambda (n) - (+ n topsyntax-offset)) - (prefix-syntax-start top-prefix))) - (map update body)))])) - -(provide/contract - [merge-compilation-top (-> get-modvar-rewrite/c - compilation-top? - compilation-top?)]) + (define new-name/import (hash-ref pos-to-name/import pos)) + (if (import? new-name/import) + (import-pos new-name/import) + (hash-ref positions new-name/import))])) + + (remap-positions (linkl-body (run-linkl r)) + remap-toplevel-pos + #:application-hook + (lambda (rator rands remap) + ;; Check for a `(.get-syntax-literal! ')` call + (cond + [(and (toplevel? rator) + (let ([i (hash-ref pos-to-name/import (toplevel-pos rator))]) + (and (import? i) + (eqv? syntax-literals-pos (import-pos i))))) + ;; This is a `(.get-syntax-literal! ')` call + (application (remap rator) + ;; To support syntax objects, change the offset + rands)] + [else #f])))))) + + (values body + first-internal-pos + ;; Communicates into to `wrap-bundle`: + (lambda () + (values runs + import-keys + ordered-importss + import-shapess + any-syntax-literals? + any-transformer-registers? + saw-zero-pos-toplevel?)))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +#lang racket/base +(require syntax/modresolve) + +(provide module-path-index->path + module-path-index-reroot) + +(define (module-path-index->path req path submod) + (define mpi (module-path-index-build req path submod)) + + (define p (resolve-module-path-index mpi path)) + + ;; Make sure a path name is normalized + (define p-path (if (pair? p) (cadr p) p)) + (define p-submod (if (pair? p) (cddr p) '())) + (define p-simple-path (if (path? p-path) + (normal-case-path (simplify-path p-path)) + p-path)) + + ;; Combine path back with submod + (if (null? p-submod) + p-simple-path + (cons p-simple-path p-submod))) + +(define (module-path-index-build req path submod) + (module-path-index-reroot req + (if (null? submod) + (module-path-index-join #f #f) + (module-path-index-join `(submod "." ,@submod) + (module-path-index-join #f #f))))) + +(define (module-path-index-reroot req root-mpi) + (let loop ([req req]) + (define-values (mod-path base) (module-path-index-split req)) + (cond + [(not mod-path) root-mpi] + [else + (module-path-index-join mod-path + (and base (loop base)))]))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/module.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -#lang racket/base - -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt") - -(define (->module-path-index s) - (if (module-path-index? s) - s - (module-path-index-join `(quote ,s) #f))) - -(define (wrap-in-kernel-module name srcname lang-info self-modidx top) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (reqs new-forms) - (partition req? (splice-forms form))) - (define requires - (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) - (make-compilation-top - 0 - #hash() - (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix)) - (make-mod name srcname - self-modidx - prefix - empty ; provides - (list (cons 0 requires)) - new-forms - empty ; syntax-body - (list) ; unexported - max-let-depth - (make-toplevel 0 0 #f #f) ; dummy - lang-info - #t - (hash) ; no names visible via `module->namespace` - empty - empty - empty))])) - -(provide/contract - [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -#lang racket/base - -(require racket/contract - syntax/modresolve) - -(define current-module-path (make-parameter #f)) - -(define (mpi->string modidx) - (cond - [(symbol? modidx) modidx] - [else - (mpi->path! modidx)])) - -(define MODULE-PATHS (make-parameter #f)) -(define (mpi->path! mpi) - (hash-ref! - (MODULE-PATHS) mpi - (lambda () - (define _pth - (resolve-module-path-index mpi (current-module-path))) - (cond - [(path? _pth) (simplify-path _pth #t)] - [(and (pair? _pth) - (path? (cadr _pth))) - (list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))] - [else _pth])))) -(define (mpi->path* mpi) - (hash-ref (MODULE-PATHS) mpi - (lambda () - (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) - -(define submod-path/c - (cons/c 'submod - (cons/c (or/c symbol? path?) - (listof symbol?)))) - -(provide/contract - [MODULE-PATHS (parameter/c (or/c false/c hash?))] - [current-module-path (parameter/c (or/c path-string? submod-path/c))] - [mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))] - [mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/name.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/name.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/name.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/name.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,61 @@ +#lang racket/base +(require compiler/zo-structs + "run.rkt" + "import.rkt") + +(provide select-names + find-name) + +(define (select-names runs) + (define names (make-hash)) ; path/submod+phase+sym -> symbol + (define used-names (make-hasheq)) + (define internals (box '())) + (define lifts (box '())) + (define imports (make-hash)) ; path/submod+phase -> list-of-sym + + ;; Reserve the syntax-literals and transformer-register names: + (hash-set! used-names '.get-syntax-literal! #t) + (hash-set! used-names '.set-transformer! #t) + + (define (pick-name name) + (let loop ([try-name name] [i 0]) + (cond + [(hash-ref used-names try-name #f) + (let ([i (add1 i)]) + (loop (string->symbol (format "~a_~a" name i)) i))] + [else + (hash-set! used-names try-name #t) + try-name]))) + + (for ([r (in-list (reverse runs))]) ; biases names to starting module + (define linkl (run-linkl r)) + (define path/submod+phase (cons (run-path/submod r) (run-phase r))) + + ;; Process local definitions, first + (define (select-names! name-list category) + (for ([name (in-list name-list)]) + (define new-name (pick-name name)) + (hash-set! names (cons path/submod+phase name) new-name) + (set-box! category (cons new-name (unbox category))))) + + (select-names! (linkl-exports linkl) internals) + (select-names! (linkl-internals linkl) internals) + (select-names! (linkl-lifts linkl) lifts)) + + ;; Record any imports that will remain as imports; anything + ;; not yet mapped must be a leftover import + (for ([r (in-list runs)]) + (define linkl (run-linkl r)) + (for ([import-names (in-list (linkl-importss linkl))] + [import-shapes (in-list (linkl-import-shapess linkl))] + [use (in-list (run-uses r))]) + (for ([name (in-list import-names)] + [shape (in-list import-shapes)]) + (unless (hash-ref names (cons use name) #f) + (hash-set! imports use (cons name (hash-ref imports use null))) + (hash-set! names (cons use name) (import name shape #f)))))) + + (values names (unbox internals) (unbox lifts) imports)) + +(define (find-name names use name) + (hash-ref names (cons use name))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -#lang racket/base - -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt" - "mpi.rkt" - racket/set) - -(define current-excluded-modules (make-parameter (set))) - -(define ZOS (make-parameter #f)) -(define MODULE-IDX-MAP (make-parameter #f)) -(define PHASE*MODULE-CACHE (make-parameter #f)) - -(define (nodep-file file-to-batch) - (define idx-map (make-hash)) - (parameterize ([ZOS (make-hash)] - [MODULE-IDX-MAP idx-map] - [PHASE*MODULE-CACHE (make-hasheq)]) - (define (get-modvar-rewrite modidx) - (define pth (mpi->path* modidx)) - (hash-ref idx-map pth - (lambda () - (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) - (match (get-nodep-module-code/path file-to-batch 0) - [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) - (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) - -(define (path->comp-top pth submod) - (hash-ref! (ZOS) (cons pth submod) - (λ () - (define zo (call-with-input-file pth zo-parse)) - (if submod - (extract-submod zo submod) - zo)))) - -(define (extract-submod zo submod) - (define m (compilation-top-code zo)) - (struct-copy compilation-top - zo - [code (let loop ([m m]) - (if (and (pair? (mod-name m)) - (equal? submod (cdr (mod-name m)))) - m - (or (ormap loop (mod-pre-submodules m)) - (ormap loop (mod-post-submodules m)))))])) - -(define (excluded? pth) - (and (path? pth) - (set-member? (current-excluded-modules) (path->string pth)))) - -(define (get-nodep-module-code/index mpi phase) - (define pth (mpi->path! mpi)) - (cond - [(symbol? pth) - (hash-set! (MODULE-IDX-MAP) pth pth) - pth] - [(excluded? pth) - (hash-set! (MODULE-IDX-MAP) pth mpi) - mpi] - [else - (get-nodep-module-code/path pth phase)])) - -(define-struct @phase (phase code)) -(define-struct modvar-rewrite (modidx provide->toplevel)) -(define-struct module-code (modvar-rewrite lang-info ctop)) -(define @phase-ctop (compose module-code-ctop @phase-code)) - -(define (get-nodep-module-code/path pth phase) - (define MODULE-CACHE - (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) - (if (hash-ref MODULE-CACHE pth #f) - #f - (hash-ref! - MODULE-CACHE pth - (lambda () - (define-values (base file dir?) (split-path (if (path-string? pth) - pth - (cadr pth)))) - (define base-directory - (if (path? base) - (path->complete-path base (current-directory)) - (current-directory))) - (define-values (modvar-rewrite lang-info ctop) - (begin - (log-debug (format "Load ~S @ ~S" pth phase)) - (nodep/dir - (parameterize ([current-load-relative-directory base-directory]) - (path->comp-top - (build-compiled-path - base - (path-add-suffix file #".zo")) - (and (pair? pth) (cddr pth)))) - pth - phase))) - (when (and phase (zero? phase)) - (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) - (make-@phase - phase - (make-module-code modvar-rewrite lang-info ctop)))))) - -(define (nodep/dir top pth phase) - (define pth* - (cond - [(string? pth) (string->path pth)] - [(list? pth) (cadr pth)] - [else pth])) - (parameterize ([current-module-path pth*]) - (nodep top phase))) - -(define (nodep top phase) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) - (values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))] - [else (error 'nodep "unrecognized: ~e" top)])) - -(define (nodep-form form phase) - (if (mod? form) - (let-values ([(modvar-rewrite lang-info mods) - (nodep-module form phase)]) - (values modvar-rewrite lang-info (make-splice mods))) - (error 'nodep-form "Doesn't support non mod forms"))) - -; XXX interning is hack to fix test/add04.ss and provide/contract renaming -(define (intern s) (string->symbol (symbol->string s))) -(define (construct-provide->toplevel prefix provides) - (define provide-ht (make-hasheq)) - (for ([tl (prefix-toplevels prefix)] - [i (in-naturals)]) - (when (symbol? tl) - (hash-set! provide-ht (intern tl) i))) - (lambda (sym pos) - (define isym (intern sym)) - (log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix)) - (define res - (hash-ref provide-ht isym - (lambda () - (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))) - (log-debug (format "Looked up ~S@~a and got ~v" sym pos res)) - res)) - -(define (nodep-module mod-form phase) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies - unexported max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (define new-prefix prefix) - ;; Cache all the mpi paths - (for-each (match-lambda - [(and mv (struct module-variable (modidx sym pos phase constantness))) - (mpi->path! modidx)] - [tl - (void)]) - (prefix-toplevels new-prefix)) - (define mvs (filter module-variable? (prefix-toplevels new-prefix))) - (log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs)) - (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) - lang-info - (append (requires->modlist requires phase) - (if (and phase (zero? phase)) - (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx - new-prefix provides requires body empty - unexported max-let-depth dummy lang-info internal-context #hash() - empty empty empty))) - (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) - empty))))] - [else (error 'nodep-module "huh?: ~e" mod-form)])) - -(define (+* l r) - (if (and l r) (+ l r) #f)) - -(define (requires->modlist requires current-phase) - (apply append - (map - (match-lambda - [(list-rest req-phase mpis) - (define phase (+* current-phase req-phase)) - (apply append - (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))]) - requires))) - -(define (all-but-last l) - (reverse (rest (reverse l)))) - -(define REQUIRED (make-hasheq)) -(define (extract-modules ct) - (cond - [(compilation-top? ct) - (match (compilation-top-code ct) - [(and m (? mod?)) - (list m)] - [(struct splice (mods)) - mods])] - [(symbol? ct) - (if (hash-has-key? REQUIRED ct) - empty - (begin - (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] - [(module-path-index? ct) - (if (hash-has-key? REQUIRED ct) - empty - (begin - (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] - [(not ct) - empty] - [(@phase? ct) - (extract-modules (@phase-ctop ct))] - [else - (error 'extract-modules "Unknown extraction: ~S" ct)])) - -(define get-modvar-rewrite/c - (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))) -(provide/contract - [struct modvar-rewrite - ([modidx module-path-index?] - [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] - [get-modvar-rewrite/c contract?] - [current-excluded-modules (parameter/c generic-set?)] - [nodep-file (-> path-string? - (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/remap.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/remap.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/remap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/remap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,79 @@ +#lang racket/base +(require racket/match + racket/set + compiler/zo-structs) + +(provide remap-positions) + +(define (remap-positions body + remap-toplevel-pos ; integer -> integer + #:application-hook [application-hook (lambda (rator rands remap) #f)]) + (define graph (make-hasheq)) + (make-reader-graph + (for/list ([b (in-list body)]) + (let remap ([b b]) + (match b + [(toplevel depth pos const? ready?) + (define new-pos (remap-toplevel-pos pos)) + (toplevel depth new-pos const? ready?)] + [(def-values ids rhs) + (def-values (map remap ids) (remap rhs))] + [(inline-variant direct inline) + (inline-variant (remap direct) (remap inline))] + [(closure code gen-id) + (cond + [(hash-ref graph gen-id #f) + => (lambda (ph) ph)] + [else + (define ph (make-placeholder #f)) + (hash-set! graph gen-id ph) + (define cl (closure (remap code) gen-id)) + (placeholder-set! ph cl) + cl])] + [(let-one rhs body type unused?) + (let-one (remap rhs) (remap body) type unused?)] + [(let-void count boxes? body) + (let-void count boxes? (remap body))] + [(install-value count pos boxes? rhs body) + (install-value count pos boxes? (remap rhs) (remap body))] + [(let-rec procs body) + (let-rec (map remap procs) (remap body))] + [(boxenv pos body) + (boxenv pos (remap body))] + [(application rator rands) + (cond + [(application-hook rator rands (lambda (b) (remap b))) + => (lambda (v) v)] + [else + ;; Any other application + (application (remap rator) (map remap rands))])] + [(branch tst thn els) + (branch (remap tst) (remap thn) (remap els))] + [(with-cont-mark key val body) + (with-cont-mark (remap key) (remap val) (remap body))] + [(beg0 forms) + (beg0 (map remap forms))] + [(seq forms) + (seq (map remap forms))] + [(varref toplevel dummy constant? unsafe?) + (varref (remap toplevel) (remap dummy) constant? unsafe?)] + [(assign id rhs undef-ok?) + (assign (remap id) (remap rhs) undef-ok?)] + [(apply-values proc args-expr) + (apply-values (remap proc) (remap args-expr))] + [(with-immed-mark key def-val body) + (with-immed-mark (remap key) (remap def-val) (remap body))] + [(case-lam name clauses) + (case-lam name (map remap clauses))] + [_ + (cond + [(lam? b) + (define tl-map (lam-toplevel-map b)) + (define new-tl-map + (and tl-map + (for/set ([pos (in-set tl-map)]) + (remap-toplevel-pos pos)))) + (struct-copy lam b + [body (remap (lam-body b))] + [toplevel-map new-tl-map])] + [else b])]))))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -#lang racket/base - -(require racket/match - racket/vector - racket/struct - "util.rkt") - -(provide replace-modidx) - -(define (replace-modidx expr self-modidx) - (define (inner-update e) - (match e - [(app prefab-struct-key (and key (not #f))) - (apply make-prefab-struct key - (map update - (struct->list e)))] - [(? module-path-index?) - (define-values (path mpi) (module-path-index-split e)) - (if (not path) - self-modidx - (module-path-index-join path (update mpi)))] - [(cons a b) - (cons (update a) (update b))] - [(? vector?) - (vector-map update e)] - [else e])) - (define-values (first-update update) - (build-form-memo inner-update)) - (first-update expr)) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/run.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/run.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/run.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/run.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out run)) + +(struct run (path/submod phase linkl uses)) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -#lang racket/base - -(require racket/match - racket/contract - compiler/zo-structs - "util.rkt") - -(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) - (define (inner-update form) - (match form - [(struct def-values (ids rhs)) - (make-def-values (map update ids) - (update rhs))] - [(? def-syntaxes?) - (error 'increment "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'increment "Doesn't handle syntax")] - [(struct inline-variant (direct inline)) - (update direct)] - [(struct req (reqs dummy)) - (make-req reqs (update dummy))] - [(? mod?) - (error 'increment "Doesn't handle modules")] - [(struct seq (forms)) - (make-seq (map update forms))] - [(struct splice (forms)) - (make-splice (map update forms))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (struct-copy lam l - [toplevel-map #f] ; conservative - [body (update body)])] - [(and c (struct closure (code gen-id))) - (struct-copy closure c - [code (update code)])] - [(and cl (struct case-lam (name clauses))) - (define new-clauses - (map update clauses)) - (struct-copy case-lam cl - [clauses new-clauses])] - [(struct let-one (rhs body type unused?)) - (make-let-one (update rhs) (update body) type unused?)] - [(and f (struct let-void (count boxes? body))) - (struct-copy let-void f - [body (update body)])] - [(and f (struct install-value (_ _ _ rhs body))) - (struct-copy install-value f - [rhs (update rhs)] - [body (update body)])] - [(struct let-rec (procs body)) - (make-let-rec (map update procs) (update body))] - [(and f (struct boxenv (_ body))) - (struct-copy boxenv f [body (update body)])] - [(and f (struct toplevel (_ pos _ _))) - (struct-copy toplevel f - [pos (toplevel-updater pos)])] - [(and f (struct topsyntax (_ pos _))) - (struct-copy topsyntax f - [pos (topsyntax-updater pos)] - [midpt topsyntax-new-midpt])] - [(struct application (rator rands)) - (make-application - (update rator) - (map update rands))] - [(struct branch (test then else)) - (make-branch - (update test) - (update then) - (update else))] - [(struct with-cont-mark (key val body)) - (make-with-cont-mark - (update key) - (update val) - (update body))] - [(struct with-immed-mark (key val body)) - (make-with-immed-mark - (update key) - (update val) - (update body))] - [(struct beg0 (seq)) - (make-beg0 (map update seq))] - [(struct varref (tl dummy)) - (make-varref (update tl) (update dummy))] - [(and f (struct assign (id rhs undef-ok?))) - (struct-copy assign f - [id (update id)] - [rhs (update rhs)])] - [(struct apply-values (proc args-expr)) - (make-apply-values - (update proc) - (update args-expr))] - [(and f (struct primval (id))) - f] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - f] - [(and f (not (? form?))) - f] - )) - (define-values (first-update update) - (build-form-memo inner-update)) - first-update) - -(provide/contract - [update-toplevels - ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?) - (exact-nonnegative-integer? . -> . exact-nonnegative-integer?) - exact-nonnegative-integer? - . -> . - (form? . -> . form?))]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/util.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/util.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/util.rkt 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/util.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -#lang racket/base - -(require racket/contract - compiler/zo-parse) - -(define (prefix-syntax-start pre) - (length (prefix-toplevels pre))) - -(define (prefix-lift-start pre) - (define syntax-start (prefix-syntax-start pre)) - (define total-stxs (length (prefix-stxs pre))) - (+ syntax-start total-stxs (if (zero? total-stxs) 0 1))) - -(struct nothing ()) - -(define-syntax-rule (eprintf* . args) (void)) - -(define (build-form-memo inner-update #:void? [void? #f]) - (define memo (make-hasheq)) - (define (update form . args) - (eprintf* "Updating on ~a\n" form) - (define fin - (cond - [(hash-ref memo form #f) - => (λ (x) - (eprintf* "Found in memo table\n") - x)] - [else - (eprintf* "Not in memo table\n") - (let () - (define ph (make-placeholder (nothing))) - (hash-set! memo form ph) - (define nv (nothing)) - (dynamic-wind void - (λ () - (set! nv (apply inner-update form args))) - (λ () - (if (nothing? nv) - (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form) - (begin - (placeholder-set! ph nv) - (hash-set! memo form nv))))) - nv)])) - (eprintf* "Updating on ~a ---->\n ~a\n" form fin) - fin) - (define (first-update form . args) - (eprintf* "Top level update on ~a\n" form) - (define final (apply update form args)) - (eprintf* "Top level update on ~a ---->\n ~a\n" form final) - (define fin (make-reader-graph final)) - (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin) - fin) - (values first-update update)) - -(define lang-info/c - (or/c #f (vector/c module-path? symbol? any/c))) - - -(define (build-compiled-path base name) - (build-path - (cond [(path? base) base] - [(eq? base 'relative) 'same] - [(eq? base #f) (error 'batch "Impossible")]) - "compiled" - name)) - - -(provide/contract - [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)] - [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)] - [eprintf ((string?) () #:rest (listof any/c) . ->* . void)] - [build-form-memo - (((unconstrained-domain-> any/c)) - (#:void? boolean?) - . ->* . - (values (unconstrained-domain-> any/c) - (unconstrained-domain-> any/c)))] - [lang-info/c contract?] - [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/write.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/write.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/write.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/write.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,11 @@ +#lang racket/base +(require compiler/zo-marshal) + +(provide write-module) + +(define (write-module output-file bundle) + (call-with-output-file* + output-file + #:exists 'truncate/replace + (lambda (o) + (zo-marshal-to bundle o)))) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/private/deserialize.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/private/deserialize.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/compiler/private/deserialize.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/compiler/private/deserialize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,121 @@ +#lang racket/base +(require racket/linklet) + +;; Re-implement just enough deserialization to deal with 'decl +;; linklets, so we can get `required`, etc. + +(provide deserialize-instance + (struct-out module-use)) + +(struct module-use (module phase)) +(struct provided (binding protected? syntax?)) + +(define (deserialize-module-path-indexes gen-vec order-vec) + (define gen (make-vector (vector-length gen-vec) #f)) + (for ([d (in-vector gen-vec)] + [i (in-naturals)]) + (vector-set! + gen + i + (cond + [(eq? d 'top) (error 'deserialize-module-path-indexes "expected top")] + [(box? d) (module-path-index-join #f #f)] + [else + (module-path-index-join (vector-ref d 0) + (and ((vector-length d) . > . 1) + (vector-ref gen (vector-ref d 1))))]))) + (for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)]) + (vector-ref gen p))) + +(define (deserialize mpis inspector bulk-binding-registry + num-mutables mutable-vec + num-shared shared-vec + mutable-fill-vec + result-vec) + (unless (zero? num-mutables) (error 'deserialize "mutables not supported")) + + (define shared-vs (make-vector num-shared #f)) + (define shared-rest + (for/fold ([r (vector->list shared-vec)]) ([i (in-range num-shared)]) + (define-values (v rest) (decode r mpis shared-vs)) + (vector-set! shared-vs i v) + rest)) + (unless (null? shared-rest) + (error 'deserialize "unexpected leftover serialized form for shared: ~s" shared-rest)) + + (define-values (v v-rest) (decode (vector->list result-vec) mpis shared-vs)) + (unless (null? v-rest) + (error 'deserialize "unexpected leftover serialized form: ~s" v-rest)) + + v) + +(define (decode r mpis shared-vs) + (let loop ([r r]) + (define (discard r n) + (for/fold ([r (cdr r)]) ([i (in-range n)]) + (define-values (v v-rest) (loop r)) + v-rest)) + (cond + [(null? r) (error 'deserialize "unexpected end of serialized form")] + [else + (define i (car r)) + (case i + [(#:ref) + (values (vector-ref shared-vs (cadr r)) (cddr r))] + [(#:inspector) + (values 'inspector (cdr r))] + [(#:cons) + (define-values (a a-rest) (loop (cdr r))) + (define-values (d d-rest) (loop a-rest)) + (values (cons a d) d-rest)] + [(#:list) + (define-values (rev rest) + (for/fold ([accum '()] [r (cddr r)]) ([i (in-range (cadr r))]) + (define-values (a a-rest) (loop r)) + (values (cons a accum) a-rest))) + (values (reverse rev) rest)] + [(#:mpi) + (values (vector-ref mpis (cadr r)) (cddr r))] + [(#:hash #:hasheq #:hasheqv) + (define ht (case i + [(#:hash) (hash)] + [(#:hasheq) (hasheq)] + [(#:hasheqv) (hasheqv)])) + (for/fold ([ht ht] [r (cddr r)]) ([i (in-range (cadr r))]) + (define-values (k k-rest) (loop r)) + (define-values (v v-rest) (loop k-rest)) + (values (hash-set ht k v) v-rest))] + [(#:provided) + (define-values (bdg bdg-rest) (loop (cdr r))) + (define-values (prot? prot?-rest) (loop bdg-rest)) + (define-values (stx? stx?-rest) (loop prot?-rest)) + (values (provided bdg prot? stx?) stx?-rest)] + [(#:module-binding) + (values 'binding (discard r 10))] + [(#:simple-module-binding) + (values 'binding (discard r 4))] + [else + (cond + [(or (symbol? i) + (number? i) + (string? i) + (null? i) + (hash? i) + (boolean? i)) + (values i (cdr r))] + [else + (error 'deserialize "unsupported instruction: ~s" i)])])]))) + +(define (syntax-module-path-index-shift . args) + (error 'syntax-module-path-index-shift "not supported")) + +(define (syntax-shift-phase-level . args) + (error 'syntax-shift-phase-level "not supported")) + +(define deserialize-instance + (make-instance 'deserialize #f 'constant + 'deserialize-module-path-indexes deserialize-module-path-indexes + 'syntax-module-path-index-shift syntax-module-path-index-shift + 'syntax-shift-phase-level syntax-shift-phase-level + 'module-use module-use + 'deserialize deserialize)) diff -Nru racket-6.12+ppa1/share/pkgs/compiler-lib/info.rkt racket-7.0+ppa1/share/pkgs/compiler-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/compiler-lib/info.rkt 2018-01-26 21:07:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/compiler-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.5.0.2") "scheme-lib" "rackunit-lib" "zo-lib"))) (define implies (quote ("zo-lib"))) (define pkg-desc "implementation (no documentation) part of \"compiler\"") (define pkg-authors (quote (mflatt))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.5.0.2") "scheme-lib" "rackunit-lib" "zo-lib"))) (define implies (quote ("zo-lib"))) (define pkg-desc "implementation (no documentation) part of \"compiler\"") (define pkg-authors (quote (mflatt))) (define version "1.7"))) diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/boundary-view.rkt racket-7.0+ppa1/share/pkgs/contract-profile/boundary-view.rkt --- racket-6.12+ppa1/share/pkgs/contract-profile/boundary-view.rkt 2018-01-26 20:35:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/boundary-view.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -117,7 +117,7 @@ #:exists 'replace (lambda () (for ([contract+key (in-list contracts->keys)]) - (printf "[~a] = ~a\n" + (printf "[~a] = ~s\n" (cdr contract+key) (car contract+key))))))) diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/info.rkt racket-7.0+ppa1/share/pkgs/contract-profile/info.rkt --- racket-6.12+ppa1/share/pkgs/contract-profile/info.rkt 2018-01-26 21:07:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "contract-profile") (define deps (quote (("base" #:version "6.3") "math-lib" ("profile-lib" #:version "1.1")))) (define build-deps (quote ("racket-doc" "scribble-lib" "rackunit-lib"))) (define pkg-desc "Profiling tool for contracts") (define pkg-authors (quote (stamourv))) (define raco-commands (quote (("contract-profile" contract-profile/raco "profile overhead from contracts" #f)))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "contract-profile") (define deps (quote (("base" #:version "6.3") "math-lib" ("profile-lib" #:version "1.1")))) (define build-deps (quote ("racket-doc" "scribble-lib" "rackunit-lib"))) (define pkg-desc "Profiling tool for contracts") (define pkg-authors (quote (stamourv))) (define raco-commands (quote (("contract-profile" contract-profile/raco "profile overhead from contracts" #f)))))) diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/main.rkt racket-7.0+ppa1/share/pkgs/contract-profile/main.rkt --- racket-6.12+ppa1/share/pkgs/contract-profile/main.rkt 2018-01-26 20:35:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -114,7 +114,7 @@ (make-srcloc-shortener all-blames blame-source)) (define (format-contract/loc c s) (string-append - (~a (blame-contract c) #:limit-marker limit-dots #:width location-width) + (~s (blame-contract c) #:limit-marker limit-dots #:width location-width) (~a (format-samples-time s) "\n") (~a (srcloc->string (shorten-source c)) #:limit-marker limit-dots @@ -146,8 +146,12 @@ (blame-value (contract-sample-blame x))) g) > #:key length)]) - (display (~a " " (blame-value (contract-sample-blame (car x))) - #:limit-marker limit-dots #:width location-width)) + (define indent " ") + (display (string-append + indent + (~s (blame-value (contract-sample-blame (car x))) + #:limit-marker limit-dots + #:width (- location-width (string-length indent))))) (displayln (format-samples-time x))) (newline)) diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/scribblings/contract-profile.scrbl racket-7.0+ppa1/share/pkgs/contract-profile/scribblings/contract-profile.scrbl --- racket-6.12+ppa1/share/pkgs/contract-profile/scribblings/contract-profile.scrbl 2018-01-26 20:35:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/scribblings/contract-profile.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -107,20 +107,6 @@ } ] -} - -@defproc[(contract-profile-thunk - [thunk (-> any)] - [#:module-graph-view-file module-graph-view-file (or/c path-string #f) #f] - [#:boundary-view-file boundary-view-file (or/c path-string #f) #f] - [#:boundary-view-key-file boundary-view-key-file (or/c path-string #f) #f] - [#:report-space-efficient? report-space-efficient? any/c #f]) - any]{ - Like @racket[contract-profile], but as a function which takes a thunk to - profile as argument. -} - - @examples[#:eval contract-profile-eval #:preserve-source-locations (define/contract (sum* numbers) (-> (listof integer?) integer?) @@ -139,4 +125,25 @@ (contract-profile (vector-max* (make-vector 10 (range (expt 10 7))))) ] +} + +@defproc[(contract-profile-thunk + [thunk (-> any)] + [#:module-graph-view-file module-graph-view-file (or/c path-string #f) #f] + [#:boundary-view-file boundary-view-file (or/c path-string #f) #f] + [#:boundary-view-key-file boundary-view-key-file (or/c path-string #f) #f] + [#:report-space-efficient? report-space-efficient? any/c #f]) + any]{ + Like @racket[contract-profile], but as a function which takes a thunk to + profile as argument. +} + + +@examples[#:eval contract-profile-eval #:preserve-source-locations + + (contract-profile-thunk + (lambda () + (sum* (range (expt 10 7))))) +] + @(close-eval contract-profile-eval) diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/scribblings/eval-log.txt racket-7.0+ppa1/share/pkgs/contract-profile/scribblings/eval-log.txt --- racket-6.12+ppa1/share/pkgs/contract-profile/scribblings/eval-log.txt 2018-01-26 20:35:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/scribblings/eval-log.txt 2018-07-27 22:12:02.000000000 +0000 @@ -16,7 +16,7 @@ #"") ((contract-profile (sum* (range (expt 10 7)))) ((3) 0 () 0 () () (q values 49999995000000)) - #"Running time is 20.68% contracts\n529/2555 ms\n\n(-> (listof integer?) integer?) 528.5 ms\n#::-1 \n sum* 528.5 ms\n\n" + #"Running time is 47.84% contracts\n1094/2287 ms\n\n(-> (listof integer?) integer?) 1094 ms\n#::-1 \n sum* 1094 ms\n\n" #"") ((define/contract (vector-max* vec-of-numbers) @@ -30,5 +30,9 @@ #"") ((contract-profile (vector-max* (make-vector 10 (range (expt 10 7))))) ((3) 0 () 0 () () (q values 499999950000000)) - #"Running time is 93.25% contracts\n4453/4775 ms\n\n(-> (vectorof (listof any/c)) integer?) 2055.5 ms\n#::-1 \n vector-max* 2055.5 ms\n\n(-> (listof integer?) integer?) 2397 ms\n#::-1 \n sum* 2397 ms\n\n" + #"Running time is 93.76% contracts\n4180/4458 ms\n\n(-> (vectorof (listof any/c)) integer?) 1939 ms\n#::-1 \n vector-max* 1939 ms\n\n(-> (listof integer?) integer?) 2241 ms\n#::-1 \n sum* 2241 ms\n\n" + #"") +((contract-profile-thunk (lambda () (sum* (range (expt 10 7))))) + ((3) 0 () 0 () () (q values 49999995000000)) + #"Running time is 44.16% contracts\n908/2056 ms\n\n(-> (listof integer?) integer?) 908 ms\n#::-1 \n sum* 908 ms\n\n" #"") diff -Nru racket-6.12+ppa1/share/pkgs/contract-profile/utils.rkt racket-7.0+ppa1/share/pkgs/contract-profile/utils.rkt --- racket-6.12+ppa1/share/pkgs/contract-profile/utils.rkt 2018-01-26 20:35:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/contract-profile/utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -31,8 +31,8 @@ (define (format-blame b) (format (string-append "#\n") (blame-positive b) (blame-negative b) (blame-contract b) (blame-value b) (blame-source b))) diff -Nru racket-6.12+ppa1/share/pkgs/data/info.rkt racket-7.0+ppa1/share/pkgs/data/info.rkt --- racket-6.12+ppa1/share/pkgs/data/info.rkt 2018-01-26 21:07:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/data/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("data-lib" "data-enumerate-lib" "data-doc"))) (define implies (quote ("data-lib" "data-enumerate-lib" "data-doc"))) (define pkg-desc "Data strucutures") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("data-lib" "data-enumerate-lib" "data-doc"))) (define implies (quote ("data-lib" "data-enumerate-lib" "data-doc"))) (define pkg-desc "Data strucutures") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/data-doc/info.rkt racket-7.0+ppa1/share/pkgs/data-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/data-doc/info.rkt 2018-01-26 21:07:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/data-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"data\"") (define pkg-authors (quote (ryanc))) (define build-deps (quote ("data-lib" "data-enumerate-lib" "racket-doc" "scribble-lib" "plot-lib" "math-doc" "math-lib" "pict-doc" "pict-lib"))) (define update-implies (quote ("data-lib" "data-enumerate-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"data\"") (define pkg-authors (quote (ryanc))) (define build-deps (quote ("data-lib" "data-enumerate-lib" "racket-doc" "scribble-lib" "plot-lib" "math-doc" "math-lib" "pict-doc" "pict-lib"))) (define update-implies (quote ("data-lib" "data-enumerate-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/data-enumerate-lib/info.rkt racket-7.0+ppa1/share/pkgs/data-enumerate-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/data-enumerate-lib/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/data-enumerate-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.8.0.2") "data-lib" "math-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) of \"data/enumerate\"") (define pkg-authors (quote (maxsnew jay robby))) (define version "1.3"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.8.0.2") "data-lib" "math-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) of \"data/enumerate\"") (define pkg-authors (quote (maxsnew jay robby))) (define version "1.3"))) diff -Nru racket-6.12+ppa1/share/pkgs/data-lib/info.rkt racket-7.0+ppa1/share/pkgs/data-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/data-lib/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/data-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.2.900.6")))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"data\"") (define pkg-authors (quote (ryanc))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.2.900.6")))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"data\"") (define pkg-authors (quote (ryanc))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/datalog/info.rkt racket-7.0+ppa1/share/pkgs/datalog/info.rkt --- racket-6.12+ppa1/share/pkgs/datalog/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/datalog/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "datalog") (define scribblings (quote (("scribblings/datalog.scrbl" (multi-page) (language))))) (define compile-omit-paths (quote ("tests"))) (define deps (quote ("base" "parser-tools-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib" "rackunit-lib"))) (define pkg-desc "An implementation of the Datalog language") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "datalog") (define scribblings (quote (("scribblings/datalog.scrbl" (multi-page) (language))))) (define compile-omit-paths (quote ("tests"))) (define deps (quote ("base" "parser-tools-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib" "rackunit-lib"))) (define pkg-desc "An implementation of the Datalog language") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/datalog/lang/reader.rkt racket-7.0+ppa1/share/pkgs/datalog/lang/reader.rkt --- racket-6.12+ppa1/share/pkgs/datalog/lang/reader.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/datalog/lang/reader.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -26,7 +26,7 @@ (define (this-read-syntax [src #f] [in (current-input-port)]) ((make-syntax-delta-introducer #'here #f) - (quasisyntax/loc src + (quasisyntax #,(compile-program (parameterize ([current-source-name src]) (parse-program in)))) diff -Nru racket-6.12+ppa1/share/pkgs/db/info.rkt racket-7.0+ppa1/share/pkgs/db/info.rkt --- racket-6.12+ppa1/share/pkgs/db/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.1") (define collection (quote multi)) (define deps (quote ("db-lib" "db-doc" "base"))) (define implies (quote ("db-lib" "db-doc"))) (define pkg-desc "Database connectivity") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("db-lib" "db-doc" "base"))) (define implies (quote ("db-lib" "db-doc"))) (define pkg-desc "Database connectivity") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/connect.scrbl racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/connect.scrbl --- racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/connect.scrbl 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/connect.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -294,6 +294,7 @@ [#:character-mode character-mode (or/c 'wchar 'utf-8 'latin-1) 'wchar] + [#:quirks quirks (listof symbol?) null] [#:use-place use-place boolean? #f]) connection?]{ @@ -308,13 +309,35 @@ attempts to determine and enforce specific types for query parameters. See @secref["odbc-types"] for more details. - By default, connections use ODBC's @tt{SQL_C_WCHAR}-based character - encoding (as UTF-16) to send and receive Unicode character - data. Unfortunately, some drivers' support for this method is - buggy. To use @tt{SQL_C_CHAR} instead, set @racket[character-mode] - to @racket['utf-8] or @racket['latin-1], depending on which encoding - the driver uses. + The @racket[character-mode] argument controls the handling of + character data; the following values are supported: + @itemlist[ + + @item{@racket['wchar] (the default) -- use @tt{SQL_C_WCHAR} and + treat the data as UTF-16 (or UTF-32/UCS-4 when the driver manager is + iODBC)} + + @item{@racket['utf-8] -- use @tt{SQL_C_CHAR} and treat the data as + UTF-8} + + @item{@racket['latin-1] -- use @tt{SQL_C_CHAR} and treat the data as + Latin-1. Characters not in Latin-1 are replaced with @racket[#\?].} + + ] + + The @racket[quirks] argument represents a list of flags to modify + the behavior of the connection. The following quirks are currently + supported: + @itemlist[ + + @item{@racket['no-c-bigint] --- Don't use @tt{SQL_C_NUMERIC} to + fetch @tt{NUMERIC}/@tt{DECIMAL} values.} + + @item{@racket['no-c-numeric] --- Don't use @tt{SQL_C_BIGINT} to bind + parameters or fetch field values.} + + ] See @secref["odbc-status"] for notes on specific ODBC drivers and recommendations for connection options. @@ -323,6 +346,8 @@ proxy is returned; see @secref["ffi-concurrency"]. If the connection cannot be made, an exception is raised. + + @history[#:changed "1.3" @elem{Added @racket[#:quirks] argument.}] } @defproc[(odbc-driver-connect [connection-string string?] @@ -334,6 +359,7 @@ [#:character-mode character-mode (or/c 'wchar 'utf-8 'latin-1) 'wchar] + [#:quirks quirks (listof symbol?) null] [#:use-place use-place boolean? #f]) connection?]{ @@ -345,6 +371,8 @@ driver. The other arguments are the same as in @racket[odbc-connect]. If the connection cannot be made, an exception is raised. + + @history[#:changed "1.3" @elem{Added @racket[#:quirks] argument.}] } @defproc[(odbc-data-sources) diff -Nru racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/notes.scrbl racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/notes.scrbl --- racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/notes.scrbl 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/notes.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -177,7 +177,7 @@ (@hyperlink["http://www.iodbc.org"]{iODBC}), which is included (in @tt{/usr/lib}) in Mac OS version 10.2 onwards.} -@item{On Linux, the driver manager is @tt{libodbc.so.1} +@item{On Linux, the driver manager is @tt{libodbc.so.{2,1}} (@hyperlink["http://www.unixodbc.org"]{unixODBC}---iODBC is not supported). It is available from the @tt{unixodbc} package in Debian/Ubuntu and in the @tt{unixODBC} package in Red Hat.} @@ -195,88 +195,99 @@ of a particular data source. The following sections describe the configurations that this library -has been tested with. +has been tested with. Reports of success or failure on other platforms +or with other drivers would be appreciated. -Reports of success or failure on other platforms or with other drivers -would be appreciated. -@;{ -** There's no reason to actually use the following drivers. They're just -** useful for testing ODBC support. +@subsection{DB2 ODBC Driver} -@subsection{PostgreSQL ODBC Driver} +IBM DB2 ODBC drivers were tested with the following software configuration: -The PostgreSQL ODBC driver version 09.00.0300 has been tested on -@bold{win32} and @bold{linux}. +@itemlist[ +@item{Platform: Centos 7.4 on x86_64} +@item{Database: DB2 Express-C for Linux x64 v11.1} +@item{Driver: ODBC for DB2 (included with DB2 Express-C)} +] -To get specific parameter type information, set the following Data -Source options: @tt{Protocol = 7.4} and @tt{UserServerSidePrepare = -1}, and use the @racket[#:strict-parameter-types?] connection option. +This driver seems to require environment variables to be set using the +provided scripts (eg, @tt{source /home/db2inst1/sqllib/db2profile}). -Older versions of the driver, including version 08.03.0200, provided -by Ubuntu 11.04, seem to have a bug in the character mode this library -uses by default; use the @racket[#:character-mode 'utf-8] connection -option as a workaround. +Known issues: +@itemlist[ -@subsection{MySQL ODBC Driver} +@item{The driver does not support the standard @tt{SQL_C_NUMERIC} +structure for retrieving @tt{DECIMAL}/@tt{NUMERIC} fields. -The MySQL ODBC driver version 5.1.6-1 has been tested on @bold{win32} -and @bold{linux}. +@bold{Fix: } Use @racket[#:quirks '(no-c-numeric)] with @racket[odbc-connect].} -Avoid using the @racket[#:strict-parameter-types?] connection option, -as the driver assigns all parameters the type @tt{varchar}. +] -@subsection{SQLite3 ODBC Driver} +@subsection{Oracle ODBC Driver} -Avoid using the @racket[#:strict-parameter-types?] connection option, -as the driver assigns all parameters the type @tt{longvarchar}. -Furthermore, this driver interprets the declared types of columns -strictly, replacing nonconforming values in query results with -@tt{NULL}. All computed columns, even those with explicit @tt{CAST}s, -seem to be returned as @tt{text}. -} +Oracle ODBC drivers were tested with the following software configuration: -@subsection{DB2 ODBC Driver} +@itemlist[ +@item{Platform: Centos 7.4 on x86_64} +@item{Database: Oracle XE 11g (11.2.0)} +@item{Drivers: Oracle Instant Client ODBC (11.2.0 and 12.2.0)} +] -The driver from IBM DB2 Express-C v9.7 has been tested on Ubuntu 11.04 -(32-bit only). +Typical installations of the drivers require the @tt{LD_LIBRARY_PATH} +environment variable to be set to the driver's installed @tt{lib} +directory (ie, the directory containing @tt{libsqora.so}) so the +driver can find its sibling shared libraries. + +Known issues: +@itemlist[ + +@item{With the @racket[#:strict-parameter-types? #t] option, +parameters seem to be always assigned the type @tt{varchar}. + +@bold{Fix: } Leave strict parameter types off (the default).} + +@item{The driver does not support the @tt{SQL_C_BIGINT} format for +parameters or result fields. Consequently, passing large integers as +query parameters may fail. + +@bold{Fix: } Use @racket[#:quirks '(no-c-bigint)] with +@racket[odbc-connect].} + +@item{A field of type @tt{TIME} causes the driver to return garbage +for the typeid and type parameters. This usually causes an error with +a message like ``unsupported type; typeid: -29936'', but with a random +typeid value. (Oracle appears not to have a @tt{TIME} type, so this +bug might only appear when a value is explicitly @tt{CAST} as +@tt{TIME}---for some reason, that doesn't produce an error.)} + +@item{Attempting to quit Racket with a connection still open may cause +Racket to hang. Specifically, the problem seems to be in the driver's +@tt{_fini} function. -For a typical installation where the instance resides at -@tt{/home/db2inst1}, set the following option in the Driver -configuration: @tt{Driver = -/home/db2inst1/sqllib/lib32/libdb2.so}. (The path would presumably be -different for a 64-bit installation.) +@bold{Fix: } Close connections before exiting, either explicitly using +@racket[disconnect] or by shutting down their custodians.} -The DB2 driver does not seem to accept a separate argument for the -database to connect to; it must be the same as the Data Source name. +] -@subsection{Oracle ODBC Driver} +@subsection{SQL Server ODBC Driver} + +Microsoft SQL Server ODBC drivers were tested with the following +software configuration: -The driver from Oracle Database 10g Release 2 Express Edition has been -tested on Ubuntu 11.04 (32-bit only). +@itemlist[ +@item{Platform: Windows 10 on x86_64} +@item{Database: SQL Server Express 2017} +@item{Drivers: ODBC Driver 13 for SQL Server, SQL Server Native Client 11.0} +] -It seems the @tt{ORACLE_HOME} and @tt{LD_LIBRARY_PATH} environment -variables must be set according to the @tt{oracle_env.{csh,sh}} script -for the driver to work. - -Columns of type @tt{TIME} can cause a memory error (ie, Racket -crashes). This seems to be due to a -@hyperlink["http://forums.oracle.com/forums/thread.jspa?threadID=572661"]{bug} -in Oracle's ODBC driver, but I do not yet have a workaround. - -@;{ -Maybe Oracle bug? See: - http://forums.oracle.com/forums/thread.jspa?threadID=572661 - http://stackoverflow.com/questions/38435/ - http://forums.oracle.com/forums/thread.jspa?threadID=856713 -} +Known issues: +@itemlist[ -@subsection{SQL Server ODBC Driver} +@item{If queries are nested or interleaved---that is, a second query +is executed before the first query's results are completely +consumed---the driver might signal an error ``Connection is busy with +results for another command (SQLSTATE: HY000)''. -Basic SQL Server support has been verified on Windows, -but the automated test suite has not yet been adapted and run. +@bold{Fix: } Set the @tt{MARS_Connection} data source option to @tt{Yes} (see +@hyperlink["https://stackoverflow.com/questions/9017264/why-only-some-users-get-the-error-connection-is-busy"]{this page}). The ODBC Manager GUI does not expose the option, but it can be added @hyperlink["https://serverfault.com/questions/302169/odbc-sql-server-how-do-i-turn-on-multiple-active-result-sets"]{by editing the registry}.} -The ``SQL Server'' driver refuses to accept @tt{NUMERIC} or -@tt{DECIMAL} parameters, producing the error ``Invalid precision value -(SQLSTATE: HY104).'' If possible, use the ``Native SQL Server'' -driver instead. +] diff -Nru racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/util.scrbl racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/util.scrbl --- racket-6.12+ppa1/share/pkgs/db-doc/db/scribblings/util.scrbl 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-doc/db/scribblings/util.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -6,7 +6,8 @@ racket/runtime-path "config.rkt" (for-label db db/util/datetime db/util/geometry db/util/postgresql - db/util/testing db/util/cassandra)) + db/util/testing db/util/cassandra + db/unsafe/sqlite3)) @(define-runtime-path log-file "log-for-util.rktd") @(define the-eval (make-pg-eval log-file #t)) @@ -306,4 +307,82 @@ on demand, as each fetch would introduce additional latency. } +@;{========================================} + +@section[#:tag "unsafe-sqlite3"]{Unsafe SQLite3 Extensions} + +The procedures documented in this section are @emph{unsafe}. + +In the functions below, the connection argument must be a SQLite +connection; otherwise, an exception is raised. + +@defmodule[db/unsafe/sqlite3]{ +@history[#:added "1.4"]} + +@defproc[(sqlite3-load-extension [c connection?] + [extension-path path-string?]) + void?]{ + +Load the @hyperlink["https://www.sqlite.org/loadext.html"]{extension +library} at @racket[extension-path] for use by the connection +@racket[c]. If the current security guard does not grant read and +execute permission on @racket[extension-path], an exception is raised. + +@;{ cf https://www.sqlite.org/lang_corefunc.html#load_extension } +} + +@defproc[(sqlite3-create-function [c connection?] + [name (or/c string? symbol?)] + [arity (or/c exact-nonnegative-integer? #f)] + [func procedure?]) + void?]{ + +Creates a normal function named @racket[name] available to the +connection @racket[c]. The @racket[arity] argument determines the +legal number of arguments; if @racket[arity] is @racket[#f] then any +number of arguments is allowed (up to the system-determined +maximum). Different implementations can be provided for different +arities of the same name. +} + +@defproc[(sqlite3-create-aggregate [c connection?] + [name (or/c string? symbol?)] + [arity (or/c exact-nonnegative-integer? #f)] + [init-acc any/c] + [step-func procedure?] + [final-func procedure?]) + void?]{ + +Like @racket[sqlite3-create-aggregate], but creates an aggregate +function. The implementation of an aggregate function are like the +arguments of @racket[fold]: + +@itemlist[ + +@item{@racket[init-acc] is the initial accumulator value.} + +@item{@racket[step-func] receives @racket[arity]+1 arguments: the +current accumulator value, followed by the arguments of the current +``step''; the function's result becomes the accumulator value for the +next step. The step arguments are SQLite values; the accumulator +argument and result can be arbitrary Racket values.} + +@item{@racket[final-func] receives one argument: the final accumulator +value; the function produces the result of the aggregate function, +which must be a SQLite value.} + +] + +The following relationship roughly holds: + +@racketblock[ +(begin (sqlite3-create-aggregate c "agg" 1 init-acc step-func final-func) + (query-value c "select agg(expr) from table")) += (final-func + (for/fold ([accum init-acc]) + ([v (in-query c "select expr from table")]) + (step-func accum v))) +] +} + @(close-eval the-eval) diff -Nru racket-6.12+ppa1/share/pkgs/db-doc/info.rkt racket-7.0+ppa1/share/pkgs/db-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/db-doc/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.2") (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("data-doc" "srfi-lite-lib" "web-server-doc" "base" "scribble-lib" "sandbox-lib" "web-server-lib" ("db-lib" "1.2") "racket-doc"))) (define update-implies (quote ("db-lib"))) (define pkg-desc "documentation part of \"db\"") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("data-doc" "srfi-lite-lib" "web-server-doc" "base" "scribble-lib" "sandbox-lib" "web-server-lib" "db-lib" "racket-doc"))) (define update-implies (quote ("db-lib"))) (define pkg-desc "documentation part of \"db\"") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/base.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/base.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/base.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/base.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -77,7 +77,7 @@ ;; ============================================================ -(require db/private/generic/functions) +(require db/private/generic/functions2) (define fetch-size/c (or/c exact-positive-integer? +inf.0)) @@ -315,5 +315,6 @@ #:notice-handler (or/c 'output 'error) #:strict-parameter-types? boolean? #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:quirks (listof symbol?) #:use-place boolean?) data-source?)]) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/main.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/main.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/main.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -97,6 +97,7 @@ #:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:quirks (listof symbol?) #:use-place boolean?) connection?)] [odbc-driver-connect @@ -104,6 +105,7 @@ (#:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:quirks (listof symbol?) #:use-place boolean?) connection?)] [odbc-data-sources diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/odbc.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/odbc.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/odbc.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/odbc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,6 +12,7 @@ #:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:quirks (listof symbol?) #:use-place boolean?) connection?)] [odbc-driver-connect @@ -19,6 +20,7 @@ (#:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:quirks (listof symbol?) #:use-place boolean?) connection?)] [odbc-data-sources diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/dsn.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/dsn.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/dsn.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/dsn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -208,4 +208,4 @@ (define odbc-data-source (mk-specialized 'odbc-data-source 'odbc 0 '(#:dsn #:user #:password #:notice-handler - #:strict-parameter-types? #:character-mode #:use-place))) + #:strict-parameter-types? #:character-mode #:quirks #:use-place))) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/functions2.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/functions2.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/functions2.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/functions2.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,369 @@ +#lang racket/base +(require racket/vector + racket/class + racket/promise + db/private/generic/interfaces + db/private/generic/functions + (only-in db/private/generic/sql-data sql-null sql-null?)) +(provide (all-from-out db/private/generic/functions) + (all-defined-out)) + +;; ======================================== +;; Administrative procedures + +(define (connection-dbsystem x) + (send x get-dbsystem)) + +(define (dbsystem-name x) + (send x get-short-name)) + +(define (dbsystem-supported-types x) + ;; FIXME: make version sensitive? + (send x get-known-types +inf.0)) + + +;; ======================================== +;; Statements + +(define (bind-prepared-statement pst params) + (send pst bind 'bind-prepared-statement params)) + +(define (prepared-statement-parameter-types pst) + (send pst get-param-types)) +(define (prepared-statement-result-types pst) + (send pst get-result-types)) + + +;; ======================================== +;; Query + +;; query-rows : connection Statement arg ... -> (listof (vectorof 'a)) +(define (query-rows c sql + #:group [group-fields-list null] + #:group-mode [group-mode null] + . args) + (let* ([sql (compose-statement 'query-rows c sql args 'rows)] + [result (query/rows c 'query-rows sql #f)] + [result + (cond [(null? group-fields-list) result] + [else (group-rows-result* 'query-rows result group-fields-list group-mode)])]) + (rows-result-rows result))) + +;; in-query : Connection Statement Param ... -> Sequence +(define (in-query c stmt + #:fetch [fetch-size +inf.0] + #:group [grouping-fields null] + #:group-mode [group-mode null] + . args) + (apply in-query-helper #f c stmt + #:fetch fetch-size + #:group grouping-fields + #:group-mode group-mode + args)) + +(define (in-query-helper vars c stmt + #:fetch [fetch-size +inf.0] + #:group [grouping-fields null] + #:group-mode [group-mode null] + . args) + (when (and (not (null? grouping-fields)) + (< fetch-size +inf.0)) + (error 'in-query "cannot apply grouping to cursor (finite fetch-size)")) + (let* ([check + ;; If grouping, can't check expected arity. + ;; FIXME: should check header includes named fields + (if (null? grouping-fields) vars #f)] + [stmt (compose-statement 'in-query c stmt args (or check 'rows))]) + (cond [(eqv? fetch-size +inf.0) + (in-list/vector->values + (rows-result-rows + (let ([result (query/rows c 'in-query stmt check)]) + (if (null? grouping-fields) + result + (group-rows-result* 'in-query result grouping-fields group-mode)))))] + [else + (let ([cursor (query/cursor c 'in-query stmt check)]) + (in-list-generator/vector->values + (lambda () (send c fetch/cursor 'in-query cursor fetch-size))))]))) + +(define (in-list/vector->values vs) + (make-do-sequence + (lambda () + (values (lambda (p) (vector->values (car p))) + cdr + vs + pair? #f #f)))) + +(define (in-list-generator/vector->values fetch-proc) + ;; fetch-proc : symbol nat -> (U list #f) + ;; state = #f | (cons vector (U state (promise-of state))) + + ;; more-promise : -> (promise-of state) + (define (more-promise) + (delay (let ([more (fetch-proc)]) + ;; note: improper append, list onto promise + (and more (append more (more-promise)))))) + + (make-do-sequence + (lambda () + (values (lambda (p) (vector->values (car p))) + (lambda (p) + (let ([next (cdr p)]) (if (promise? next) (force next) next))) + (force (more-promise)) + pair? #f #f)))) + +;; query/cursor : Connection Symbol Statement Nat/#f -> Cursor-Result +(define (query/cursor c who sql want-columns) + (let ([result (send c query who sql #t)]) + (check-cursor-result who sql want-columns result))) + +;; check-cursor-result : Symbol Statement Nat/#f Query-Result -> Cursor-Result +(define (check-cursor-result who sql want-columns result) + (unless (cursor-result? result) + (error/want-cursor who sql)) + (let ([got-columns (length (cursor-result-headers result))]) + (when (and want-columns (not (= got-columns want-columns))) + (error/column-count who sql want-columns got-columns #t))) + result) + + +;; ======================================== +;; Information-Schema + +;; list-tables : ... -> (listof string) +;; - lists unqualified table/view/etc names in search path (omit system tables, if possible). +;; Maybe it would be better to just search the current schema only? +;; or maybe mode = 'current | 'search | 'current-or-search (default) +;; - lists unqualified table/view/etc names for given schema (and/or catalog?) +;; - Add option to include system tables? +(define (list-tables c + #:schema [schema 'search-or-current]) + (send c list-tables 'list-tables schema)) + +(define (table-exists? c table-name + #:schema [schema 'search-or-current] + #:case-sensitive? [cs? #f]) + (let ([tables (send c list-tables 'table-exists? schema)]) + (for/or ([table (in-list tables)]) + (if cs? + (string=? table-name table) + (string-ci=? table-name table))))) + +;; list-tables* : ... -> (listof vector) +;; Return full catalog/schema/table/type list. + + +;; ======================================== +;; Grouping Rows + +;; FIXME: add 'assume-sorted optimization option? + +(define (group-rows result + #:group key-fields-list + #:group-mode [group-mode null]) + (when (null? key-fields-list) + (error 'group-rows "expected at least one grouping field set")) + (group-rows-result* 'group-rows result key-fields-list group-mode)) + +(define (group-rows-result* fsym result key-fields-list group-mode) + (let* ([invert-outer? (not (or (memq 'preserve-null group-mode) + ;; old flag, deprecated: + (memq 'preserve-null-rows group-mode)))] + [as-list? (memq 'list group-mode)] + [headers (rows-result-headers result)] + [total-fields (length headers)] + [name-map (headers->name-map headers)] + [fields-used (make-vector total-fields #f)] + [key-indexes-list + (group-list->indexes fsym name-map total-fields fields-used key-fields-list)] + [residual-length + (for/sum ([x (in-vector fields-used)]) (if x 0 1))]) + (when (= residual-length 0) + (raise-arguments-error fsym "cannot group by all fields" + "grouping field sets" key-fields-list)) + (when (and (> residual-length 1) as-list?) + (raise-arguments-error fsym "expected exactly one residual field when #:group-mode is 'list" + "grouping field sets" key-fields-list + "residual field count" residual-length)) + (let* ([initial-projection + (for/vector #:length total-fields ([i (in-range total-fields)]) i)] + [headers + (group-headers (list->vector headers) + initial-projection + key-indexes-list)] + [rows + (group-rows* fsym + (rows-result-rows result) + initial-projection + key-indexes-list + invert-outer? + as-list?)]) + (rows-result headers rows)))) + +(define (headers->name-map headers) + (for/hash ([header (in-list headers)] + [i (in-naturals)] + #:when (assq 'name header)) + (values (cdr (assq 'name header)) i))) + +(define (group-list->indexes fsym name-map total-fields fields-used key-fields-list) + (let ([key-fields-list (if (list? key-fields-list) key-fields-list (list key-fields-list))]) + (for/list ([key-fields (in-list key-fields-list)]) + (group->indexes fsym name-map total-fields fields-used key-fields)))) + +(define (group->indexes fsym name-map total-fields fields-used key-fields) + (let ([key-fields (if (vector? key-fields) key-fields (vector key-fields))]) + (for/vector ([key-field (in-vector key-fields)]) + (grouping-field->index fsym name-map total-fields fields-used key-field)))) + +(define (grouping-field->index fsym name-map total-fields fields-used key-field) + (let ([key-index + (cond [(string? key-field) + (hash-ref name-map key-field #f)] + [else key-field])]) + (when (string? key-field) + (unless key-index + (raise-arguments-error fsym "bad grouping field" + "given" key-field + "available" (sort (hash-keys name-map) string residual rows with all NULL fields are dropped. + (cond [(null? key-indexes-list) + ;; Apply projection to each row + (cond [as-list? + (unless (= (vector-length projection) 1) + (error/internal + fsym + "list mode requires a single residual column, got ~s" + (vector-length projection))) + (let ([index (vector-ref projection 0)]) + (for/list ([row (in-list rows)]) + (vector-ref row index)))] + [else + (let ([plen (vector-length projection)]) + (for/list ([row (in-list rows)]) + (let ([v (make-vector plen)]) + (for ([i (in-range plen)]) + (vector-set! v i (vector-ref row (vector-ref projection i)))) + v)))])] + [else + (let () + (define key-indexes (car key-indexes-list)) + (define residual-projection + (vector-filter-not (lambda (index) (vector-member index key-indexes)) + projection)) + (define key-row-length (vector-length key-indexes)) + (define (row->key-row row) + (for/vector #:length key-row-length + ([i (in-vector key-indexes)]) + (vector-ref row i))) + (define (residual-all-null? row) + (for/and ([i (in-vector residual-projection)]) + (sql-null? (vector-ref row i)))) + (let* ([key-table (make-hash)] + [r-keys + (for/fold ([r-keys null]) + ([row (in-list rows)]) + (let* ([key-row (row->key-row row)] + [already-seen? (and (hash-ref key-table key-row #f) #t)]) + (unless already-seen? + (hash-set! key-table key-row null)) + (unless (and invert-outer? (residual-all-null? row)) + (hash-set! key-table key-row (cons row (hash-ref key-table key-row)))) + (if already-seen? + r-keys + (cons key-row r-keys))))]) + (for/list ([key (in-list (reverse r-keys))]) + (let ([residuals + (group-rows* fsym + (reverse (hash-ref key-table key)) + residual-projection + (cdr key-indexes-list) + invert-outer? + as-list?)]) + (vector-append key (vector residuals))))))])) + + +;; ======================================== +;; Rows Result as Dictionary + +(define (rows->dict result + #:key key-field/s + #:value value-field/s + #:value-mode [value-mode null]) + (let* ([who 'rows->dict] + [headers (rows-result-headers result)] + [total-fields (length headers)] + [name-map (headers->name-map headers)] + [preserve-null? (memq 'preserve-null value-mode)] + [value-list? (memq 'list value-mode)]) + (define (make-project field/s) + (if (vector? field/s) + (let* ([indexes (group->indexes who name-map total-fields #f field/s)] + [indexes-length (vector-length indexes)]) + (lambda (v) + (for/vector #:length indexes-length ([i (in-vector indexes)]) + (vector-ref v i)))) + (let ([index (grouping-field->index who name-map total-fields #f field/s)]) + (lambda (v) (vector-ref v index))))) + (define get-key (make-project key-field/s)) + (define get-value (make-project value-field/s)) + (define ok-value? + (cond [preserve-null? (lambda (v) #t)] + [(vector? value-field/s) + (lambda (v) (not (for/or ([e (in-vector v)]) (sql-null? e))))] + [else (lambda (v) (not (sql-null? v)))])) + (for/fold ([table '#hash()]) ([row (in-list (if value-list? + (reverse (rows-result-rows result)) + (rows-result-rows result)))]) + (let* ([key (get-key row)] + [value (get-value row)] + [old-value (hash-ref table key (if value-list? '() not-given))]) + (unless (or value-list? + (eq? (hash-ref table key not-given) not-given) + ;; FIXME: okay to coalesce values if equal? + (equal? value old-value)) + (error* who "duplicate value for key" + '("key" value) key + '("values" multi value) (list old-value value))) + (if value-list? + (hash-set table key + (if (ok-value? value) + (cons value old-value) + ;; If all-NULL value, still enter key => '() into dict + old-value)) + (if (ok-value? value) + (hash-set table key value) + table)))))) + +(define not-given (gensym 'not-given)) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/place-server.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/place-server.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/place-server.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/place-server.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -22,7 +22,7 @@ (list 'error string)) where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) - | (list 'odbc string string/#f string/#f boolean symbol) + | (list 'odbc string string/#f string/#f boolean symbol symbol-list) |# (define (connection-server client-chan) (let loop () @@ -46,17 +46,19 @@ #:mode mode #:busy-retry-delay busy-retry-delay #:busy-retry-limit busy-retry-limit)] - [(list 'odbc dsn user password strict-param? char-mode) + [(list 'odbc dsn user password strict-param? char-mode quirks) (odbc-connect #:dsn dsn #:user user #:password password #:strict-parameter-types? strict-param? #:character-mode char-mode + #:quirks quirks #:use-place #f)] - [(list 'odbc-driver connection-string strict-param? char-mode) + [(list 'odbc-driver connection-string strict-param? char-mode quirks) (odbc-driver-connect connection-string #:strict-parameter-types? strict-param? #:character-mode char-mode + #:quirks quirks #:use-place #f)])] [p (new proxy-server% (connection c) (channel conn-chan))]) (pchan-put conn-chan (list 'ok)) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/sql-convert.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/sql-convert.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/generic/sql-convert.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/generic/sql-convert.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,27 +2,38 @@ (require racket/math) (provide exact->decimal-string ;; odbc, tests (?) + scaled-integer->decimal-string ;; odbc exact->scaled-integer ;; pg, odbc inexact->scaled-integer) ;; pg ;; ======================================== ;; exact->decimal-string : exact -> string or #f -;; always includes decimal point (define (exact->decimal-string n) - (let* ([whole-part (truncate n)] - [fractional-part (- (abs n) (abs whole-part))] - [scaled (exact->scaled-integer fractional-part)]) - (and scaled - (let* ([ma (car scaled)] - [ex (cdr scaled)] - [ma-str (number->string ma)]) - (if (zero? ex) - (number->string whole-part) - (string-append (number->string whole-part) - "." - (make-string (- ex (string-length ma-str)) #\0) - ma-str)))))) + (cond [(exact->scaled-integer n) + => (lambda (ma+ex) + (scaled-integer->decimal-string (car ma+ex) (cdr ma+ex)))] + [else #f])) + +;; scaled-integer->decimal-string : Int Int -> String +;; Given M and E, converts (M * 10^-E) to a decimal string. +;; If E>0, then there is a decimal point and exactly E digits after it. +(define (scaled-integer->decimal-string ma ex) + (cond [(zero? ex) (number->string ma)] + [(< ex 0) + (string-append (number->string ma) (make-string ex #\0))] + [(> ex 0) + (define mstr (number->string (abs ma))) + (define len (string-length mstr)) + (cond [(<= len ex) + (string-append (if (negative? ma) "-0." "0.") + (make-string (- ex len) #\0) + mstr)] + [else + (string-append (if (negative? ma) "-" "") + (substring mstr 0 (- len ex)) + "." + (substring mstr (- len ex) len))])])) ;; exact->scaled-integer : exact-rational -> (cons int int) or #f ;; Given x, returns (cons M E) s.t. x = (M * 10^-E) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/connection.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/connection.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/connection.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/connection.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,6 +12,7 @@ db/private/generic/sql-convert "ffi.rkt" "ffi-constants.rkt" + "../generic/sql-convert.rkt" "dbsystem.rkt") (provide connection% handle-status* @@ -29,9 +30,14 @@ env notice-handler char-mode) + (init-field quirks) ;; (Listof Symbol) (init strict-parameter-types?) (super-new) + ;; -- Quirks -- + (define/private (quirk-c-bigint-ok?) (not (memq 'no-c-bigint quirks))) + (define/private (quirk-c-numeric-ok?) (not (memq 'no-c-numeric quirks))) + ;; Custodian shutdown can cause disconnect even in the middle of ;; operation (with lock held). So use (A _) around any FFI calls, ;; check still connected. @@ -115,7 +121,7 @@ [param-typeid (in-list (send pst get-param-typeids))]) (load-param fsym db stmt i param param-typeid))]) (handle-status fsym (A (SQLExecute stmt)) stmt) - (strong-void param-bufs)) + (void/reference-sink param-bufs)) (define result-dvecs (send pst get-result-dvecs)) (set-result-descriptors stmt result-dvecs) (define rows @@ -147,115 +153,156 @@ (send pst after-exec #f)))])))))) (define/private (load-param fsym db stmt i param typeid) - ;; NOTE: param buffers must not move between bind and execute - ;; So use buffer utils from ffi.rkt (copy-buffer, etc) - (define (bind ctype sqltype buf [prec 0] [scale 0]) - (let* ([lenbuf - (int->buffer (if buf (bytes-length buf) SQL_NULL_DATA))] - [status - (A (SQLBindParameter stmt i SQL_PARAM_INPUT ctype sqltype prec scale buf lenbuf))]) - (handle-status fsym status stmt) - (if buf (cons buf lenbuf) lenbuf))) - ;; If the typeid is UNKNOWN, then choose appropriate type based on data, - ;; but respect typeid if known. - (define unknown-type? (= typeid SQL_UNKNOWN_TYPE)) - (cond [(string? param) + ;; typeid-or : Integer -> Integer + ;; Replace SQL_UNKNOWN_TYPE with given alternative typeid + (define (typeid-or alt-typeid) (if (= typeid SQL_UNKNOWN_TYPE) alt-typeid typeid)) + + ;; bind : Integer Integer (U Bytes #f) [Byte Byte] -> Any + ;; NOTE: param buffers must not move between bind and execute. + ;; Returns refs that must not be GC'd until after SQLExecute. + (define (bind ctype sqltype value [prec 0] [scale 0]) + (define lenbuf + (bytes->non-moving-pointer + (integer->integer-bytes (if value (bytes-length value) SQL_NULL_DATA) sizeof-SQLLEN #t))) + (define-values (valbuf vallen) + (cond [(bytes? value) (values (bytes->non-moving-pointer value) (bytes-length value))] + [(eq? value #f) (values #f 0)] + [else (error 'bind "internal error: bad value: ~e" value)])) + (define status + (A (SQLBindParameter stmt i ctype sqltype prec scale valbuf vallen lenbuf))) + (handle-status fsym status stmt) + (if valbuf (cons valbuf lenbuf) lenbuf)) + + ;; do-load-number : (U Real (Cons Integer Nat)) Integer -> Any + (define (do-load-number param typeid) + (cond [(or (= typeid SQL_NUMERIC) (= typeid SQL_DECIMAL)) + ;; param = (cons mantissa exponent), scaled integer + (define ma (car param)) + (define ex (cdr param)) + (define prec (if (zero? ma) 1 (+ 1 (order-of-magnitude (abs ma))))) + (define prec* (max prec ex)) + (cond [(quirk-c-numeric-ok?) + (let* (;; ODBC docs claim max precision is 15 ... + [sign-byte (if (negative? ma) 0 1)] ;; FIXME: negative is 2 in ODBC 3.5 ??? + [digits-bytess + ;; 16 bytes of unsigned little-endian data (4 chunks of 4 bytes) + (let loop ([i 0] [ma (abs ma)]) + (if (< i 4) + (let-values ([(q r) (quotient/remainder ma (expt 2 32))]) + (cons (integer->integer-bytes r 4 #f #f) + (loop (add1 i) q))) + null))] + [numeric-bytes + (apply bytes-append (bytes prec* ex sign-byte) digits-bytess)]) + ;; Call bind first. + (bind SQL_C_NUMERIC typeid numeric-bytes prec* ex) + ;; Then set descriptor attributes. + (set-numeric-descriptors (A (SQLGetStmtAttr/HDesc stmt SQL_ATTR_APP_PARAM_DESC)) + i prec* ex numeric-bytes))] + [else + (define s (scaled-integer->decimal-string ma ex)) + (bind SQL_C_CHAR typeid (string->bytes/latin-1 s) prec* ex)])] + [(or (= typeid SQL_INTEGER) + (= typeid SQL_SMALLINT) + (= typeid SQL_TINYINT)) + (bind SQL_C_LONG typeid (integer->integer-bytes param sizeof-SQLLONG #t))] + [(or (= typeid SQL_BIGINT)) + ;; Oracle errors without diagnostic record (!!) on BIGINT param + ;; -> http://stackoverflow.com/questions/338609 + (cond [(quirk-c-bigint-ok?) + (bind SQL_C_SBIGINT typeid (integer->integer-bytes param 8 #t))] + [else + (bind SQL_C_CHAR typeid (string->bytes/latin-1 (number->string param)))])] + [(or (= typeid SQL_FLOAT) + (= typeid SQL_REAL) + (= typeid SQL_DOUBLE)) + (bind SQL_C_DOUBLE typeid (real->floating-point-bytes (exact->inexact param) 8))] + ;; -- UNKNOWN -- + [(= typeid SQL_UNKNOWN_TYPE) + (cond [(int32? param) + (do-load-number param SQL_INTEGER)] + [(int64? param) + (do-load-number param SQL_BIGINT)] + [else ;; real + (do-load-number param SQL_DOUBLE)])] + ;; -- Otherwise error -- + [else + (error 'load-param "internal error: bad type `~a` for parameter: ~e" + typeid param)])) + + ;; -- load-param body -- + (cond [(or (real? param) (pair? param)) + (do-load-number param typeid)] + [(string? param) (case char-mode ((wchar) - (bind SQL_C_WCHAR (if unknown-type? SQL_WVARCHAR typeid) + (bind SQL_C_WCHAR (typeid-or SQL_WVARCHAR) (case WCHAR-SIZE ((2) (cpstr2 param)) ((4) (cpstr4 param))))) ((utf-8) - (bind SQL_C_CHAR (if unknown-type? SQL_VARCHAR typeid) - (copy-buffer (string->bytes/utf-8 param)))) + (bind SQL_C_CHAR (typeid-or SQL_VARCHAR) (string->bytes/utf-8 param))) ((latin-1) - (bind SQL_C_CHAR (if unknown-type? SQL_VARCHAR typeid) - (copy-buffer (string->bytes/latin-1 param (char->integer #\?))))))] + (bind SQL_C_CHAR (typeid-or SQL_VARCHAR) + (string->bytes/latin-1 param (char->integer #\?)))))] [(bytes? param) - (bind SQL_C_BINARY (if unknown-type? SQL_BINARY typeid) - (copy-buffer param))] - [(pair? param) ;; Represents numeric/decimal decomposed as scaled integer - (let* ([ma (car param)] - [ex (cdr param)] - ;; ODBC docs claim max precision is 15 ... - [prec-byte (if (zero? ma) 1 (+ 1 (order-of-magnitude (abs ma))))] - [sign-byte (if (negative? ma) 0 1)] ;; FIXME: negative is 2 in ODBC 3.5 ??? - [digits-bytess - ;; 16 bytes of unsigned little-endian data (4 chunks of 4 bytes) - (let loop ([i 0] [ma (abs ma)]) - (if (< i 4) - (let-values ([(q r) (quotient/remainder ma (expt 2 32))]) - (cons (integer->integer-bytes r 4 #f #f) - (loop (add1 i) q))) - null))] - [numeric-bytes - (apply bytes-append (bytes prec-byte ex sign-byte) digits-bytess)] - [numeric-buffer (copy-buffer numeric-bytes)]) - ;; Example: http://support.microsoft.com/kb/181254 - ;; and: http://msdn.microsoft.com/en-us/library/ms712567%28v=vs.85%29.aspx - ;; Call bind first. - (bind SQL_C_NUMERIC typeid numeric-buffer prec-byte ex) - ;; Then set descriptor attributes. - (set-numeric-descriptors (A (SQLGetStmtAttr/HDesc stmt SQL_ATTR_APP_PARAM_DESC)) - i prec-byte ex numeric-buffer))] - [(real? param) - (cond [(or (= typeid SQL_NUMERIC) (= typeid SQL_DECIMAL)) - (bind SQL_C_CHAR typeid - (copy-buffer (marshal-decimal fsym i param)))] - [(or (and unknown-type? (int32? param)) - (= typeid SQL_INTEGER) - (= typeid SQL_SMALLINT) - (= typeid SQL_BIGINT) - (= typeid SQL_TINYINT)) - ;; Oracle errors without diagnostic record (!!) on BIGINT param - ;; -> http://stackoverflow.com/questions/338609 - ;; FIXME: find a better solution, eg check driver for BIGINT support (?) - (if (= typeid SQL_BIGINT) - (bind SQL_C_SBIGINT SQL_BIGINT - (copy-buffer (integer->integer-bytes param 8 #t))) - (bind SQL_C_LONG (if unknown-type? SQL_INTEGER typeid) - (copy-buffer (integer->integer-bytes param 4 #t))))] - [else - (bind SQL_C_DOUBLE (if unknown-type? SQL_DOUBLE typeid) - (copy-buffer - (real->floating-point-bytes (exact->inexact param) 8)))])] + (bind SQL_C_BINARY (typeid-or SQL_BINARY) param (bytes-length param))] [(boolean? param) (bind SQL_C_LONG SQL_BIT - (copy-buffer (int->buffer (if param 1 0))))] + (integer->integer-bytes (if param 1 0) sizeof-SQLLONG #t))] [(sql-date? param) (bind SQL_C_TYPE_DATE SQL_TYPE_DATE - (copy-buffer - (let* ([x param] - [y (sql-date-year x)] - [m (sql-date-month x)] - [d (sql-date-day x)]) - (bytes-append (integer->integer-bytes y 2 #t) - (integer->integer-bytes m 2 #f) - (integer->integer-bytes d 2 #f)))))] + (let* ([x param] + [y (sql-date-year x)] + [m (sql-date-month x)] + [d (sql-date-day x)]) + (bytes-append (integer->integer-bytes y 2 #t) + (integer->integer-bytes m 2 #f) + (integer->integer-bytes d 2 #f))))] + [(sql-time? param) + (cond [(= typeid SQL_SS_TIME2) + (bind SQL_C_BINARY typeid + (let* ([x param] + [h (sql-time-hour x)] + [m (sql-time-minute x)] + [s (sql-time-second x)] + [ns (sql-time-nanosecond x)]) + (bytes-append (integer->integer-bytes h 2 #f) + (integer->integer-bytes m 2 #f) + (integer->integer-bytes s 2 #f) + (integer->integer-bytes 0 2 #f) + (let ([ns (* 100 (quotient ns 100))]) + (integer->integer-bytes ns 4 #f)))) + 12 7)] + [else + (bind SQL_C_TYPE_TIME SQL_TYPE_TIME + (let* ([x param] + [h (sql-time-hour x)] + [m (sql-time-minute x)] + [s (sql-time-second x)]) + (bytes-append (integer->integer-bytes h 2 #f) + (integer->integer-bytes m 2 #f) + (integer->integer-bytes s 2 #f))))])] [(sql-time? param) (bind SQL_C_TYPE_TIME SQL_TYPE_TIME - (copy-buffer - (let* ([x param] - [h (sql-time-hour x)] - [m (sql-time-minute x)] - [s (sql-time-second x)]) - (bytes-append (integer->integer-bytes h 2 #f) - (integer->integer-bytes m 2 #f) - (integer->integer-bytes s 2 #f)))))] + (let* ([x param] + [h (sql-time-hour x)] + [m (sql-time-minute x)] + [s (sql-time-second x)]) + (bytes-append (integer->integer-bytes h 2 #f) + (integer->integer-bytes m 2 #f) + (integer->integer-bytes s 2 #f))))] [(sql-timestamp? param) - (bind SQL_C_TYPE_TIMESTAMP - (if unknown-type? SQL_TYPE_TIMESTAMP typeid) - (copy-buffer - (let ([x param]) - (bytes-append - (integer->integer-bytes (sql-timestamp-year x) 2 #f) - (integer->integer-bytes (sql-timestamp-month x) 2 #f) - (integer->integer-bytes (sql-timestamp-day x) 2 #f) - (integer->integer-bytes (sql-timestamp-hour x) 2 #f) - (integer->integer-bytes (sql-timestamp-minute x) 2 #f) - (integer->integer-bytes (sql-timestamp-second x) 2 #f) - (integer->integer-bytes (sql-timestamp-nanosecond x) 4 #f)))))] + (bind SQL_C_TYPE_TIMESTAMP (typeid-or SQL_TYPE_TIMESTAMP) + (let ([x param]) + (bytes-append + (integer->integer-bytes (sql-timestamp-year x) 2 #f) + (integer->integer-bytes (sql-timestamp-month x) 2 #f) + (integer->integer-bytes (sql-timestamp-day x) 2 #f) + (integer->integer-bytes (sql-timestamp-hour x) 2 #f) + (integer->integer-bytes (sql-timestamp-minute x) 2 #f) + (integer->integer-bytes (sql-timestamp-second x) 2 #f) + (integer->integer-bytes (sql-timestamp-nanosecond x) 4 #f))))] [(sql-null? param) (bind SQL_C_CHAR SQL_VARCHAR #f)] [else (error/internal* fsym "cannot convert given value to SQL type" @@ -275,9 +322,9 @@ [else (void)]))) (define/private (set-numeric-descriptors hdesc i prec ex buf) - (A (SQLSetDescField/Int hdesc i SQL_DESC_TYPE SQL_C_NUMERIC) - (SQLSetDescField/Int hdesc i SQL_DESC_PRECISION prec) - (SQLSetDescField/Int hdesc i SQL_DESC_SCALE ex) + (A (SQLSetDescField/SmallInt hdesc i SQL_DESC_TYPE SQL_C_NUMERIC) + (SQLSetDescField/SmallInt hdesc i SQL_DESC_PRECISION prec) + (SQLSetDescField/SmallInt hdesc i SQL_DESC_SCALE ex) (when buf (SQLSetDescField/Ptr hdesc i SQL_DESC_DATA_PTR buf (bytes-length buf))))) (define/private (fetch* fsym stmt result-typeids end-box limit) @@ -327,14 +374,16 @@ (let-values ([(status ind) (A (SQLGetData stmt i ctype buf 0))]) (handle-status fsym status stmt) (cond [(= ind SQL_NULL_DATA) sql-null] - [else (let ([in (open-input-bytes buf)]) - (for/list ([size (in-list sizes)]) - (case size - ((1) (read-byte in)) - ((2) (integer-bytes->integer (read-bytes 2 in) #f)) - ((4) (integer-bytes->integer (read-bytes 4 in) #f)) - (else (error/internal - 'get-int-list "bad size: ~e" size)))))])))) + [else (parse-int-list buf sizes)])))) + (define (parse-int-list buf sizes) + (let ([in (open-input-bytes buf)]) + (for/list ([size (in-list sizes)]) + (case size + ((1) (read-byte in)) + ((2) (integer-bytes->integer (read-bytes 2 in) #f)) + ((4) (integer-bytes->integer (read-bytes 4 in) #f)) + (else (error/internal + 'get-int-list "bad size: ~e" size)))))) (define (get-varbuf ctype ntlen convert) ;; ntlen is null-terminator length (1 for char data, 0 for binary, ??? for wchar) @@ -422,25 +471,35 @@ (get-string)] [(or (= typeid SQL_DECIMAL) (= typeid SQL_NUMERIC)) - (let ([fields (get-int-list '(1 1 1 4 4 4 4) SQL_ARD_TYPE)]) - (cond [(list? fields) - (let* ([precision (first fields)] - [scale (second fields)] - [sign (case (third fields) ((0) -1) ((1) 1))] - [ma (let loop ([lst (cdddr fields)]) - (if (pair? lst) - (+ (* (loop (cdr lst)) (expt 2 32)) - (car lst)) - 0))]) - ;; (eprintf "numeric: ~s\n" fields) - (* sign ma (expt 10 (- scale))))] - [(sql-null? fields) sql-null]))] + (cond [(quirk-c-numeric-ok?) + (let ([fields (get-int-list '(1 1 1 4 4 4 4) SQL_ARD_TYPE)]) + (cond [(list? fields) + (let* ([precision (first fields)] + [scale (second fields)] + [sign (case (third fields) ((0) -1) ((1) 1))] + [ma (let loop ([lst (cdddr fields)]) + (if (pair? lst) + (+ (* (loop (cdr lst)) (expt 2 32)) + (car lst)) + 0))]) + ;; (eprintf "numeric: ~s\n" fields) + (* sign ma (expt 10 (- scale))))] + [(sql-null? fields) sql-null]))] + [else + (define s (get-string/latin-1)) + (or (string->number s 10 'number-or-false 'decimal-as-exact) + (error 'get-column "internal error getting numeric field: ~e" s))])] [(or (= typeid SQL_SMALLINT) (= typeid SQL_INTEGER) (= typeid SQL_TINYINT)) (get-int 4 SQL_C_LONG)] [(or (= typeid SQL_BIGINT)) - (get-int 8 SQL_C_SBIGINT)] + (cond [(quirk-c-bigint-ok?) + (get-int 8 SQL_C_SBIGINT)] + [else + (define s (get-string/latin-1)) + (or (string->number s 10 'number-or-false 'decimal-as-exact) + (error 'get-column "internal error getting bigint field: ~e" s))])] [(or (= typeid SQL_REAL) (= typeid SQL_FLOAT) (= typeid SQL_DOUBLE)) @@ -449,7 +508,7 @@ (case (get-int 4 SQL_C_LONG) ((0) #f) ((1) #t) - (else 'get-column "internal error: SQL_BIT"))] + (else (error 'get-column "internal error: SQL_BIT")))] [(or (= typeid SQL_BINARY) (= typeid SQL_VARBINARY)) (get-bytes)] @@ -461,6 +520,14 @@ (let ([fields (get-int-list '(2 2 2) SQL_C_TYPE_TIME)]) (cond [(list? fields) (apply sql-time (append fields (list 0 #f)))] [(sql-null? fields) sql-null]))] + [(= typeid SQL_SS_TIME2) + (define buf (get-bytes)) + (cond [(sql-null? buf) sql-null] + [else + ;;(eprintf "-- ss_time2 : ~s\n" (bytes->list buf)) + (let ([fields (parse-int-list buf '(2 2 2 2 4))]) + (define-values (h m s _pad ns) (apply values fields)) + (sql-time h m s ns #f))])] [(= typeid SQL_TYPE_TIMESTAMP) (let ([fields (get-int-list '(2 2 2 2 2 2 4) SQL_C_TYPE_TIMESTAMP)]) (cond [(list? fields) (apply sql-timestamp (append fields (list #f)))] @@ -734,7 +801,8 @@ (SQLGetDiagRec handle-type handle 1)]) (case mode ((error) - (raise-sql-error who sqlstate message + (raise-sql-error who sqlstate + (or message "") `((code . ,sqlstate) (message . ,message) (native-errcode . ,native-errcode)))) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/dbsystem.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/dbsystem.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/dbsystem.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/dbsystem.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -94,7 +94,7 @@ ((typeid) name) ... ((*typeid) *name) ... (else - (lambda (fsym index param) + (lambda (fsym param) (error/unsupported-type fsym x)))))))) (define (mk-check typeid pred #:contract-parts [ctc-parts #f]) @@ -109,9 +109,9 @@ (define (check-numeric fsym param) (define (bad note) (error/no-convert fsym "ODBC" "numeric" param note)) - (unless (rational? param) (bad "")) + (unless (and (rational? param) (exact? param)) (bad "(expected exact rational)")) (let ([scaled (exact->scaled-integer (inexact->exact param))]) - (unless scaled (bad "")) + (unless scaled (bad "(bad denominator for exact decimal)")) (let ([ma (car scaled)] [ex (cdr scaled)]) ;; check (abs ma) fits in 16*8 bits, ex fits in char @@ -131,6 +131,7 @@ (12 varchar string?) (91 date sql-date?) (92 time sql-time?) + (-154 time2 sql-time?) (93 timestamp sql-timestamp?) (-1 longvarchar string?) (-2 binary bytes?) @@ -190,9 +191,14 @@ (110 interval-day-second #f) (111 interval-hour-minute #f) (112 interval-hour-second #f) - (113 interval-minute-second #f)) + (113 interval-minute-second #f) + + ;; SQL Server extensions + (-154 time 0) + ) (define (supported-typeid? x) (case x ((0 1 2 3 4 5 6 7 8 9 12 91 92 93 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10) #t) + ((-154) #t) (else #f))) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/ffi-constants.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/ffi-constants.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/ffi-constants.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/ffi-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -68,6 +68,9 @@ (define SQL_WVARCHAR -9) (define SQL_WLONGVARCHAR -10) +(define SQL_SS_TIME2 -154) +(define SQL_C_SS_TIME2 #x4000) + (define SQL_CODE_YEAR 1) (define SQL_CODE_MONTH 2) (define SQL_CODE_DAY 3) @@ -169,8 +172,15 @@ (define SQL_C_INTERVAL_HOUR_TO_SECOND SQL_INTERVAL_HOUR_TO_SECOND) (define SQL_C_INTERVAL_MINUTE_TO_SECOND SQL_INTERVAL_MINUTE_TO_SECOND) -(define SQL_C_SBIGINT (+ SQL_BIGINT SQL_SIGNED_OFFSET)) -(define SQL_C_UBIGINT (+ SQL_BIGINT SQL_UNSIGNED_OFFSET)) +(define SQL_C_SBIGINT (+ SQL_BIGINT SQL_SIGNED_OFFSET)) ;; = int64_t +(define SQL_C_SLONG (+ SQL_C_LONG SQL_SIGNED_OFFSET)) ;; = long +(define SQL_C_SSHORT (+ SQL_C_SHORT SQL_SIGNED_OFFSET)) +(define SQL_C_STINYINT (+ SQL_TINYINT SQL_SIGNED_OFFSET)) +(define SQL_C_UBIGINT (+ SQL_BIGINT SQL_UNSIGNED_OFFSET)) +(define SQL_C_ULONG (+ SQL_C_LONG SQL_UNSIGNED_OFFSET)) +(define SQL_C_USHORT (+ SQL_C_SHORT SQL_UNSIGNED_OFFSET)) +(define SQL_C_UTINYINT (+ SQL_TINYINT SQL_UNSIGNED_OFFSET)) + (define SQL_C_VARBOOKMARK SQL_C_BINARY) (define SQL_TYPE_NULL 0) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/ffi.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/ffi.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/ffi.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/ffi.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -15,95 +15,62 @@ (define _sqllen _long) (define _sqlulen _ulong) +;; https://docs.microsoft.com/en-us/sql/odbc/reference/odbc-64-bit-information +(define sizeof-SQLLONG 4) ;; yes, even on 64-bit environments +(define sizeof-SQLLEN (ctype-sizeof _sqllen)) + (define _sqlsmallint _sshort) (define _sqlusmallint _ushort) (define _sqlinteger _sint) (define _sqluinteger _uint) (define _sqlreturn _sqlsmallint) -(define-ffi-definer define-mz #f) - -(define-mz scheme_utf16_to_ucs4 - (_fun (src srcstart srcend) :: - (src : _bytes) - (srcstart : _intptr) - (srcend : _intptr) - (#f : _pointer) ;; No buffer so it'll allocate for us. - (0 : _intptr) - (clen : (_ptr o _intptr)) - (1 : _intptr) - -> (out : _gcpointer) - -> (begin (ptr-set! out _int32 clen 0) - (values out clen)))) - -(define-mz scheme_ucs4_to_utf16 - (_fun (src srcstart srcend) :: - (src : _string/ucs-4) - (srcstart : _intptr) - (srcend : _intptr) - (#f : _pointer) ;; No buffer so it'll allocate for us. - (0 : _intptr) - (clen : (_ptr o _intptr)) - (1 : _intptr) - -> (out : _gcpointer) - -> (begin (ptr-set! out _int16 clen 0) - (values out clen)))) - -(define-mz scheme_make_sized_char_string - (_fun (chars clen copy?) :: - (chars : _gcpointer) - (clen : _intptr) - (copy? : _bool) - -> _racket)) - -(define scheme_make_sized_byte_string/string - (get-ffi-obj 'scheme_make_sized_byte_string #f - (_fun (buf len) :: - (buf : _string/ucs-4) - (len : _intptr) - (#t : _bool) - -> _racket))) - ;; For dealing with param buffers, which must not be moved by GC -(define (copy-buffer buffer) - (let* ([buffer (if (string? buffer) (string->bytes/utf-8 buffer) buffer)] - [n (bytes-length buffer)] - [rawcopy (malloc (add1 n) 'atomic-interior)] - [copy (make-sized-byte-string rawcopy n)]) - (memcpy copy buffer n) - (ptr-set! rawcopy _byte n 0) - copy)) - -(define (int->buffer n) - (let ([copy (make-sized-byte-string (malloc 4 'atomic-interior) 4)]) - (integer->integer-bytes n 4 #t (system-big-endian?) copy 0) - copy)) - -(define (cpstr2 str) - (let-values ([(shorts slen) (scheme_ucs4_to_utf16 str 0 (string-length str))]) - (let* ([n (* slen 2)] - [rawcopy (malloc (add1 n) 'atomic-interior)] - [copy (make-sized-byte-string rawcopy n)]) - (memcpy copy shorts n) - (ptr-set! rawcopy _byte n 0) - copy))) - -(define (cpstr4 str) - (copy-buffer (scheme_make_sized_byte_string/string str (* (string-length str) 4)))) - -(define (mkstr2 buf len fresh?) - (let-values ([(chars clen) (scheme_utf16_to_ucs4 buf 0 (quotient len 2))]) - (scheme_make_sized_char_string chars clen #f))) - -(define (mkstr4 buf len fresh?) - (scheme_make_sized_char_string buf (quotient len 4) (not fresh?))) - -;; ======================================== - -;; Used in connection.rkt; silly hack to keep optimizer from eliminating ref to -;; things that shouldn't be GC'd. Depends on no cross-module inlining. -(define (strong-void x) (void)) +;; bytes->non-moving-pointer : Bytes -> NonMovingPointer +(define (bytes->non-moving-pointer bs) + (define len (bytes-length bs)) + ;; Note: avoid (malloc 0); returns #f, SQL Server driver treats as SQL NULL! + (define copy (malloc (max 1 len) 'atomic-interior)) + (memcpy copy bs len) + copy) + +;; cpstr{2,4} : String -> Bytes +;; Converts string to utf16/ucs4 (platform-endian) bytes. +(define (cpstr2 s) + (string->bytes* s "platform-UTF-16" "platform-UTF-8")) +(define (cpstr4 s) + (string->bytes* s (if (system-big-endian?) "UTF-32BE" "UTF-32LE") "UTF-8")) + +;; mkstr{2,4} : Bytes Nat _ -> String +;; Converts utf16/ucs4 (platform-endian) to string. +(define (mkstr2 buf [len (bytes-length buf)] [fresh? #f]) + (bytes->string* buf len "platform-UTF-16" "platform-UTF-8")) +(define (mkstr4 buf [len (bytes-length buf)] [fresh? #f]) + (bytes->string* buf len (if (system-big-endian?) "UTF-32BE" "UTF-32LE") "UTF-8")) + +;; bytes->string* : Bytes String -> String +(define (bytes->string* b len benc [senc "UTF-8"]) + (define conv (bytes-open-converter benc senc)) + (define-values (b* nconv status) (bytes-convert conv b 0 len)) + (bytes-close-converter conv) + (case status + [(complete) + (bytes->string/utf-8 b*)] + [else + (error 'bytes->string* "invalid ~a encoding\n bytes: ~e" b)])) + +;; string->bytes* : String String -> Bytes +(define (string->bytes* s benc [senc "UTF-8"]) + (define b (string->bytes/utf-8 s)) + (define conv (bytes-open-converter senc benc)) + (define-values (b* nconv status) (bytes-convert conv b)) + (bytes-close-converter conv) + (case status + [(complete) + b*] + [else + (error 'string->bytes* "unable to convert to ~a\n string: ~e" s)])) ;; ======================================== @@ -130,7 +97,7 @@ [else ;; Other unixes use unixodbc, which defines WCHAR as 16-bit ;; for compat w/ Windows (even though Linux wchar_t is 32-bit) - (values (ffi-lib "libodbc" '("1" #f) #:fail (lambda () #f)) + (values (ffi-lib "libodbc" '("2" "1" #f) #:fail (lambda () #f)) 2)])))) (define-ffi-definer define-odbc odbc-lib @@ -275,16 +242,16 @@ -> _sqlreturn)) (define-odbc SQLBindParameter - (_fun (handle param-num iomode c-type sql-type column-size digits value len-or-ind) :: + (_fun (handle param-num c-type sql-type column-size digits value len len-or-ind) :: (handle : _sqlhstmt) (param-num : _sqlusmallint) - (iomode : _sqlsmallint) + (_sqlsmallint = SQL_PARAM_INPUT) (c-type : _sqlsmallint) (sql-type : _sqlsmallint) (column-size : _sqlulen) (digits : _sqlsmallint) (value : _pointer) ;; must be pinned until after SQLExecute called - ((if (bytes? value) (bytes-length value) 0) : _sqllen) ;; ignored for fixed-length data + (len : _sqllen) ;; ignored for fixed-length data (len-or-ind : _pointer) ;; _sqllen-pointer) -> _sqlreturn)) @@ -329,6 +296,8 @@ -> (values status (and (ok-status? status) column-buf + ;; Oracle returns garbage column name/len for TIME columns + (<= 0 column-len (bytes-length column-buf)) (bytes->string/utf-8 column-buf #f 0 column-len)) data-type size digits nullable))) @@ -358,13 +327,13 @@ -> (and (ok-status? status) valptr)) #:c-id SQLGetStmtAttr) -(define-odbc SQLSetDescField/Int +(define-odbc SQLSetDescField/SmallInt (_fun (handle recno fieldid intval) :: (handle : _sqlhdesc) (recno : _sqlsmallint) (fieldid : _sqlsmallint) (intval : _intptr) ;; declared SQLPOINTER; cast - (buflen : _sqlinteger = 0) + (buflen : _sqlinteger = SQL_IS_SMALLINT) -> (status : _sqlreturn)) #:c-id SQLSetDescField) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/main.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/main.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/private/odbc/main.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/private/odbc/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,9 +17,10 @@ #:notice-handler [notice-handler void] #:strict-parameter-types? [strict-parameter-types? #f] #:character-mode [char-mode 'wchar] + #:quirks [quirks '()] #:use-place [use-place #f]) (cond [use-place - (place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode) + (place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode quirks) odbc-proxy%)] [else (let ([notice-handler (make-handler notice-handler "notice")]) @@ -34,15 +35,17 @@ (db db) (notice-handler notice-handler) (strict-parameter-types? strict-parameter-types?) - (char-mode char-mode))))))))])) + (char-mode char-mode) + (quirks quirks))))))))])) (define (odbc-driver-connect connection-string #:notice-handler [notice-handler void] #:strict-parameter-types? [strict-parameter-types? #f] #:character-mode [char-mode 'wchar] + #:quirks [quirks '()] #:use-place [use-place #f]) (cond [use-place - (place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode) + (place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode quirks) odbc-proxy%)] [else (let ([notice-handler (make-handler notice-handler "notice")]) @@ -57,7 +60,8 @@ (db db) (notice-handler notice-handler) (strict-parameter-types? strict-parameter-types?) - (char-mode char-mode))))))))])) + (char-mode char-mode) + (quirks quirks))))))))])) (define (odbc-data-sources) (define server-buf (make-bytes 1024)) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/db/unsafe/sqlite3.rkt racket-7.0+ppa1/share/pkgs/db-lib/db/unsafe/sqlite3.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/db/unsafe/sqlite3.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/db/unsafe/sqlite3.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,50 @@ +#lang racket/base +(require racket/class + db/private/sqlite3/connection) +(provide + (protect-out sqlite3-load-extension + sqlite3-create-function + sqlite3-create-aggregate)) + +(define (sqlite3-load-extension c ext-path) + (define who 'sqlite3-load-extension) + (unless (is-a? c connection%) + (raise-argument-error who "sqlite3 connection" 0 c ext-path)) + (unless (path-string? ext-path) + (raise-argument-error who "path-string?" 1 c ext-path)) + (send c unsafe-load-extension who ext-path) + (void)) + +(define (sqlite3-create-function c name arity proc) + (define who 'sqlite3-create-function) + (define (bad index expected) + (raise-argument-error who expected index c name arity proc)) + (unless (is-a? c connection%) + (bad 0 "sqlite3 connection")) + (unless (or (string? name) (symbol? name)) + (bad 1 "(or/c string? symbol?)")) + (unless (or (exact-nonnegative-integer? arity) (eq? arity #f)) + (bad 2 "(or/c exact-nonnegative-integer? #f)")) + (unless (procedure? proc) + (bad 3 "procedure?")) + (let ([name (if (symbol? name) (symbol->string name) name)]) + (send c unsafe-create-function who name arity proc)) + (void)) + +(define (sqlite3-create-aggregate c name arity init step final) + (define who 'sqlite3-create-aggregate) + (define (bad index expected) + (raise-argument-error who expected index c name arity step final init)) + (unless (is-a? c connection%) + (bad 0 "sqlite3 connection")) + (unless (or (string? name) (symbol? name)) + (bad 1 "(or/c string? symbol?)")) + (unless (or (exact-nonnegative-integer? arity) (eq? arity #f)) + (bad 2 "(or/c exact-nonnegative-integer? #f)")) + (unless (procedure? step) + (bad 3 "procedure?")) + (unless (procedure? final) + (bad 4 "procedure?")) + (let ([name (if (symbol? name) (symbol->string name) name)]) + (send c unsafe-create-aggregate who name arity step final init)) + (void)) diff -Nru racket-6.12+ppa1/share/pkgs/db-lib/info.rkt racket-7.0+ppa1/share/pkgs/db-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/db-lib/info.rkt 2018-01-26 21:07:26.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/db-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.2") (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.2.900.17") "unix-socket-lib" "sasl-lib"))) (define pkg-desc "implementation (no documentation) part of \"db\"") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define version "1.4") (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.90.0.24") "unix-socket-lib" "sasl-lib"))) (define pkg-desc "implementation (no documentation) part of \"db\"") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt racket-7.0+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt --- racket-6.12+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1016,12 +1016,18 @@ (collection-file-path "mf.gif" "icons"))]) (and (send bitmap ok?) (make-object image-snip% bitmap)))) + + (define (deinprogramm-path? path) + (let ((rel (path->collects-relative path))) + (and (pair? rel) + (eq? 'collects (car rel)) + (equal? #"deinprogramm" (cadr rel))))) ;; teaching-languages-error-display-handler : ;; (string (union TST exn) -> void) -> string exn -> void ;; adds in the bug icon, if there are contexts to display (define (teaching-languages-error-display-handler msg exn) - + (if (exn? exn) (display (get-rewriten-error-message exn) (current-error-port)) (eprintf "uncaught exception: ~e" exn)) @@ -1044,7 +1050,11 @@ ((not cms) '()) ((findf (lambda (mark) (and mark - (or (path? (car mark)) + (or (and (path? (car mark)) + ;; exclude paths that result from macro expansion, + ;; specifically define-record-procedures + ;; see racket/drracket#157 + (not (deinprogramm-path? (car mark)))) (symbol? (car mark))))) cms) => (lambda (mark) diff -Nru racket-6.12+ppa1/share/pkgs/deinprogramm/info.rkt racket-7.0+ppa1/share/pkgs/deinprogramm/info.rkt --- racket-6.12+ppa1/share/pkgs/deinprogramm/info.rkt 2018-01-26 21:07:28.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/deinprogramm/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "deinprogramm-signature" "drracket" "drracket-plugin-lib" "errortrace-lib" "gui-lib" "htdp-lib" "pconvert-lib" "scheme-lib" "string-constants-lib" "trace" "wxme-lib"))) (define build-deps (quote ("at-exp-lib" "htdp-doc" "racket-doc" "racket-index" "rackunit-lib" "scribble-lib"))) (define pkg-desc "Teaching languages for _Die Macht der Abstraktion_") (define implies (quote ("deinprogramm-signature"))) (define pkg-authors (quote (sperber))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "deinprogramm-signature" "drracket" "drracket-plugin-lib" "errortrace-lib" "gui-lib" "htdp-lib" "pconvert-lib" "scheme-lib" "string-constants-lib" "trace" "wxme-lib"))) (define build-deps (quote ("at-exp-lib" "htdp-doc" "racket-doc" "racket-index" "rackunit-lib" "scribble-lib"))) (define pkg-desc "Teaching languages for _Die Macht der Abstraktion_") (define implies (quote ("deinprogramm-signature"))) (define pkg-authors (quote (sperber))))) diff -Nru racket-6.12+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature.rkt racket-7.0+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature.rkt --- racket-6.12+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature.rkt 2018-01-26 20:35:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -56,7 +56,11 @@ (display name port) (display ">" port))) (else - (display "#" port))))) + (display "#" port)))) + #:property prop:procedure + (lambda (self . rest) + (raise (make-exn:fail:contract (format "expected a function after the parenthesis, but received ~v" self) + (current-continuation-marks))))) (define (make-signature name enforcer syntax-promise #:arbitrary-promise (arbitrary-promise (delay #f)) @@ -90,7 +94,6 @@ (raise (make-exn:fail:contract (or message (format "got ~e" obj)) (current-continuation-marks)))))) - (define (signature-violation obj signature msg blame) ((signature-violation-proc) obj signature msg blame)) diff -Nru racket-6.12+ppa1/share/pkgs/deinprogramm-signature/info.rkt racket-7.0+ppa1/share/pkgs/deinprogramm-signature/info.rkt --- racket-6.12+ppa1/share/pkgs/deinprogramm-signature/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/deinprogramm-signature/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "drracket-plugin-lib" "gui-lib" "htdp-lib" "scheme-lib" "srfi-lib" "string-constants-lib"))) (define pkg-desc "Signature support for teaching languages for _Die Macht der Abstraktion_") (define pkg-authors (quote (sperber))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "drracket-plugin-lib" "gui-lib" "htdp-lib" "scheme-lib" "srfi-lib" "string-constants-lib"))) (define pkg-desc "Signature support for teaching languages for _Die Macht der Abstraktion_") (define pkg-authors (quote (sperber))))) diff -Nru racket-6.12+ppa1/share/pkgs/distributed-places/info.rkt racket-7.0+ppa1/share/pkgs/distributed-places/info.rkt --- racket-6.12+ppa1/share/pkgs/distributed-places/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/distributed-places/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("distributed-places-lib" "distributed-places-doc"))) (define implies (quote ("distributed-places-lib" "distributed-places-doc"))) (define pkg-desc "Libraries for distributed computations") (define pkg-authors (quote (tewk))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("distributed-places-lib" "distributed-places-doc"))) (define implies (quote ("distributed-places-lib" "distributed-places-doc"))) (define pkg-desc "Libraries for distributed computations") (define pkg-authors (quote (tewk))))) diff -Nru racket-6.12+ppa1/share/pkgs/distributed-places-doc/info.rkt racket-7.0+ppa1/share/pkgs/distributed-places-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/distributed-places-doc/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/distributed-places-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "distributed-places-lib" "racket-doc" "sandbox-lib" "scribble-lib"))) (define update-implies (quote ("distributed-places-lib"))) (define pkg-desc "documentation part of \"distributed-places\"") (define pkg-authors (quote (tewk))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "distributed-places-lib" "racket-doc" "sandbox-lib" "scribble-lib"))) (define update-implies (quote ("distributed-places-lib"))) (define pkg-desc "documentation part of \"distributed-places\"") (define pkg-authors (quote (tewk))))) diff -Nru racket-6.12+ppa1/share/pkgs/distributed-places-lib/info.rkt racket-7.0+ppa1/share/pkgs/distributed-places-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/distributed-places-lib/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/distributed-places-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"distributed-places\"") (define pkg-authors (quote (tewk))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"distributed-places\"") (define pkg-authors (quote (tewk))))) diff -Nru racket-6.12+ppa1/share/pkgs/draw/info.rkt racket-7.0+ppa1/share/pkgs/draw/info.rkt --- racket-6.12+ppa1/share/pkgs/draw/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("draw-lib" "draw-doc"))) (define implies (quote ("draw-lib" "draw-doc"))) (define pkg-desc "Drawing libraries") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("draw-lib" "draw-doc"))) (define implies (quote ("draw-lib" "draw-doc"))) (define pkg-desc "Drawing libraries") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/draw-doc/info.rkt racket-7.0+ppa1/share/pkgs/draw-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/draw-doc/info.rkt 2018-01-26 21:07:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("gui-doc" "pict-doc" "at-exp-lib" "base" "gui-lib" "pict-lib" "scribble-lib" "draw-lib" "racket-doc"))) (define update-implies (quote ("draw-lib"))) (define pkg-desc "documentation part of \"draw\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("gui-doc" "pict-doc" "at-exp-lib" "base" "gui-lib" "pict-lib" "scribble-lib" "draw-lib" "racket-doc"))) (define update-implies (quote ("draw-lib"))) (define pkg-desc "documentation part of \"draw\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/draw-lib/info.rkt racket-7.0+ppa1/share/pkgs/draw-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/draw-lib/info.rkt 2018-01-26 21:07:34.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.10.1.2") ("draw-i386-macosx-2" #:platform "i386-macosx") ("draw-x86_64-macosx-2" #:platform "x86_64-macosx") ("draw-ppc-macosx-2" #:platform "ppc-macosx") ("draw-win32-i386-2" #:platform "win32\\i386") ("draw-win32-x86_64-2" #:platform "win32\\x86_64") ("draw-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg") ("draw-x11-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("draw-ttf-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define pkg-desc "implementation (no documentation) part of \"draw\"") (define pkg-authors (quote (mflatt))) (define version "1.13"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.10.1.2") ("draw-i386-macosx-3" #:platform "i386-macosx") ("draw-x86_64-macosx-3" #:platform "x86_64-macosx") ("draw-ppc-macosx-3" #:platform "ppc-macosx") ("draw-win32-i386-3" #:platform "win32\\i386") ("draw-win32-x86_64-3" #:platform "win32\\x86_64") ("draw-x86_64-linux-natipkg-3" #:platform "x86_64-linux-natipkg") ("draw-x11-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("draw-ttf-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define pkg-desc "implementation (no documentation) part of \"draw\"") (define pkg-authors (quote (mflatt))) (define version "1.13"))) diff -Nru racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/private/lzw.rkt racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/private/lzw.rkt --- racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/private/lzw.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/private/lzw.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -66,6 +66,7 @@ (next-entry-index (+ clear-code 2)) (compression-size (add1 code-size)) (compression-threshold (* clear-code 2)) + (just-emit? #f) (pos 0) (bitstream (make-input-bitstream bstr))) (for ([i (in-range clear-code)]) @@ -77,7 +78,8 @@ (vector-set! entries i -1)) (set! next-entry-index (+ clear-code 2)) (set! compression-size (add1 code-size)) - (set! compression-threshold (* clear-code 2)))] + (set! compression-threshold (* clear-code 2)) + (set! just-emit? #f))] [root-value (lambda (code) (let loop ([code code]) @@ -87,8 +89,15 @@ (loop pred)))))] [increase-compression-size! (lambda () - (set! compression-size (min 12 (add1 compression-size))) - (set! compression-threshold (* compression-threshold 2)))] + (cond + [(= compression-size 12) + ;; 12 is the maximum compression size, so go into + ;; "just emit" mode, which doesn't add new entries + ;; until a reset + (set! just-emit? #t)] + [else + (set! compression-size (add1 compression-size)) + (set! compression-threshold (* compression-threshold 2))]))] [add-entry (lambda (entry pred) (when (>= pred next-entry-index) @@ -102,7 +111,7 @@ result))] [code-depth (lambda (code) - (let loop ([depth 0][code code]) + (let loop ([depth 0] [code code]) (let ([pred (vector-ref preds code)]) (if (negative? pred) depth @@ -130,7 +139,7 @@ (loop -1)] [(= code end-of-input) (void)] - [(= last-code -1) + [(or just-emit? (= last-code -1)) (output-code-string code) (loop code)] [else diff -Nru racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/cairo-lib.rkt racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/cairo-lib.rkt --- racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/cairo-lib.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/cairo-lib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,11 +11,13 @@ [(macosx) (ffi-lib "libpng16.16.dylib") (ffi-lib "libexpat.1.dylib") + (ffi-lib "libuuid.1.dylib") (ffi-lib "libfreetype.6.dylib") (ffi-lib "libfontconfig.1.dylib")] [(windows) (ffi-lib "zlib1.dll") - (ffi-lib "libintl-8.dll") + (ffi-lib "libiconv-2.dll") + (ffi-lib "libintl-9.dll") (ffi-lib "libpng16-16.dll") (ffi-lib "libexpat-1.dll") (ffi-lib "libfreetype-6.dll") diff -Nru racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/glib.rkt racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/glib.rkt --- racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/glib.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/glib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,11 +11,11 @@ (define-runtime-lib glib-lib [(unix) (ffi-lib "libglib-2.0" '("0" ""))] [(macosx) - (ffi-lib "libintl.8.dylib") + (ffi-lib "libintl.9.dylib") (ffi-lib "libglib-2.0.0.dylib")] [(windows) (ffi-lib "libiconv-2.dll") - (ffi-lib "libintl-8.dll") + (ffi-lib "libintl-9.dll") (ffi-lib "libglib-2.0-0.dll")]) (define-runtime-lib gmodule-lib diff -Nru racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/pango.rkt racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/pango.rkt --- racket-6.12+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/pango.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/draw-lib/racket/draw/unsafe/pango.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,8 +9,12 @@ (define-runtime-lib pango-lib [(unix) (ffi-lib "libpango-1.0" '("0" ""))] - [(macosx) (ffi-lib "libpango-1.0.0.dylib")] - [(windows) (ffi-lib "libpango-1.0-0.dll")]) + [(macosx) + (ffi-lib "libfribidi.0.dylib") + (ffi-lib "libpango-1.0.0.dylib")] + [(windows) + (ffi-lib "libfribidi-0.dll") + (ffi-lib "libpango-1.0-0.dll")]) (define-runtime-lib pangowin32-lib [(unix) #f] @@ -25,7 +29,8 @@ (ffi-lib "libpangoft2-1.0.0.dylib") (ffi-lib "libpangocairo-1.0.0.dylib")] [(windows) - (ffi-lib "libintl-8.dll") + (ffi-lib "libiconv-2.dll") + (ffi-lib "libintl-9.dll") (ffi-lib "libpangowin32-1.0-0.dll") (ffi-lib "libexpat-1.dll") (ffi-lib "libfreetype-6.dll") diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/HISTORY.txt racket-7.0+ppa1/share/pkgs/drracket/drracket/HISTORY.txt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/HISTORY.txt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,13 @@ ------------------------------ + Version 7.0 +------------------------------ + + . Exectuable creation under windows can embed DLLs (making the + executables stand-alone). + + . misc bug fixes and documentation improvements + +------------------------------ Version 6.12 ------------------------------ diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/private/expanding-place.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/private/expanding-place.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/private/expanding-place.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/private/expanding-place.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -214,7 +214,6 @@ (transform-module path (namespace-syntax-introduce stx) raise-hopeless-syntax-error)) - (ep-log-info "expanding-place.rkt: 09 starting expansion") (define log-io? (log-level? expanding-place-logger 'warning)) (define-values (in out) (if (or log-io? no-annotations?) @@ -226,10 +225,12 @@ (thread (λ () (catch-and-log in the-io)))] [no-annotations? (thread (λ () (catch-and-check-non-empty in the-io)))]) + (ep-log-info "expanding-place.rkt: 09 starting expansion") (define expanded (parameterize ([current-output-port out] [current-error-port out]) (expand transformed-stx))) + (ep-log-info "expanding-place.rkt: 10 finished expansion") (define no-io-happened? (cond [(or log-io? no-annotations?) @@ -239,12 +240,13 @@ (channel-put old-registry-chan (namespace-module-registry (current-namespace))) (place-channel-put pc-status-expanding-place 'finished-expansion) - (ep-log-info "expanding-place.rkt: 10 expanded") + (ep-log-info "expanding-place.rkt: 11 getting handler results") (define handler-results (filter values (for/list ([handler (in-list handlers)] #:unless (handler-monitor-pc handler)) + (ep-log-info (format "expanding-place.rkt: handler ~s" (handler-key handler))) (let/ec k (define proc-res (with-handlers ([exn:fail? @@ -266,7 +268,7 @@ the-source orig-cust))) (list (handler-key handler) proc-res))))) - (ep-log-info "expanding-place.rkt: 11 handlers finished") + (ep-log-info "expanding-place.rkt: 12 handlers finished") (define compiled-bytes (cond [(and no-annotations? @@ -282,7 +284,7 @@ (write compiled bp)) (get-output-bytes bp)] [else #f])) - (ep-log-info "expanding-place.rkt: 12 compile finished") + (ep-log-info "expanding-place.rkt: 13 compile finished") (parameterize ([current-custodian orig-cust]) (thread @@ -295,7 +297,7 @@ (and compiled-bytes (vector name lang compiled-bytes))))))) (semaphore-wait sema) - (ep-log-info "expanding-place.rkt: 13 finished"))))) + (ep-log-info "expanding-place.rkt: 14 finished"))))) (thread (λ () diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/private/language.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/private/language.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/private/language.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/private/language.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -777,7 +777,8 @@ (if (boolean? mred-launcher) mred-launcher (eq? base 'mred)) - use-copy?)))))) + use-copy? + #:aux aux)))))) ;; create-executable-gui : (union #f (is-a?/c top-level-area-container<%>)) @@ -817,7 +818,10 @@ (string-constant stand-alone-explanatory-label) (string-constant distribution-explanatory-label))) (parent type-panel) - (callback (lambda (rb e) + (callback (lambda (rb e) + (when embed-checkbox + (send embed-checkbox enable + (not (equal? 0 (send rb get-selection))))) (preferences:set 'drracket:create-executable-gui-type (case (send rb get-selection) [(0) 'launcher] @@ -883,6 +887,17 @@ (define (enable-minus) (send minus-button enable (pair? (send aux-paths get-selections)))) (enable-minus) + + (define embed-checkbox + (and (equal? (system-type) 'windows) + (new check-box% + [label (string-constant embed-dlls?)] + [parent type/base-panel] + [callback + (λ (_1 _2) + (preferences:set 'drracket:create-executable-gui-embed-dlls? + (send embed-checkbox get-value)))] + [value (preferences:get 'drracket:create-executable-gui-embed-dlls?)]))) (define (reset-filename-suffix) (let ([s (send filename-text-field get-value)]) @@ -910,7 +925,7 @@ (define (browse-callback) (let ([ftf (send filename-text-field get-value)]) - (let-values ([(base name _) + (let-values ([(base name _) (if (path-string? ftf) (split-path ftf) (values (current-directory) "" #f))]) @@ -1012,6 +1027,11 @@ 'no-show) (send filename-text-field get-value) (apply append + (if (and embed-checkbox + (not (equal? 0 (send type-rb get-selection))) + (send embed-checkbox get-value)) + (list '(embed-dlls? . #t)) + (list)) (for/list ([i (in-range (send aux-paths get-number))]) (extract-aux-from-path (send aux-paths get-data i)))))])) @@ -1122,7 +1142,8 @@ transformer-module-language-spec init-code gui? - use-copy?) + use-copy? + #:aux [aux '()]) (with-handlers ([(λ (x) #f) ;exn:fail? (λ (x) @@ -1191,9 +1212,10 @@ [to-be-embedded-module-specs (map (λ (x) (list #f x)) pre-to-be-embedded-module-specs3)]) - - (create-embedding-executable + + (create-embedding-executable executable-filename + #:aux aux #:mred? gui? #:verbose? #f ;; verbose? #:modules to-be-embedded-module-specs @@ -1214,7 +1236,8 @@ transformer-module-language-spec init-code gui? - use-copy?) + use-copy? + #:aux [aux '()]) (create-distribution-for-executable distribution-filename gui? @@ -1225,7 +1248,8 @@ transformer-module-language-spec init-code gui? - use-copy?)))) + use-copy? + #:aux aux)))) ;; create-distribution-for-executable : ... -> void (see docs) (define (create-distribution-for-executable distribution-filename @@ -1346,7 +1370,8 @@ transformer-module-language-spec init-code gui? - use-copy?) + use-copy? + #:aux [aux '()]) (with-handlers ([(λ (x) #f) ;exn:fail? (λ (x) diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/private/main.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/private/main.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/private/main.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/private/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -110,6 +110,7 @@ (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket)))) +(preferences:set-default 'drracket:create-executable-gui-embed-dlls? #t boolean?) (drr:set-default 'drracket:logger-gui-tab-panel-level 0 (λ (x) (and (exact-integer? x) (<= 0 x 5)))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -231,6 +231,7 @@ (invalidate-blue-box-region) (set! mouse-in-blue-box? b) (invalidate-blue-box-region) + (trigger-buffer-changed-callback #:now? #t) (end-edit-sequence))) (define/public (update-locked b) (preferences:set 'drracket:syncheck:contracts-locked? b) @@ -425,16 +426,16 @@ (inner (void) on-lexer-valid valid?) (when valid? (trigger-buffer-changed-callback))) - (define/private (trigger-buffer-changed-callback) + (define/private (trigger-buffer-changed-callback #:now? [now? #f]) (when (or locked? mouse-in-blue-box? (not the-strs)) (set! update-the-strs-coroutine #f) - (start-the-timer))) - (define/private (start-the-timer) + (start-the-timer now?))) + (define/private (start-the-timer now?) (unless timer-running? (set! timer-running? #t) - (send timer start 300 #t))) + (send timer start (if now? 10 300) #t))) (define update-the-strs-coroutine #f) @@ -475,7 +476,7 @@ (end-edit-sequence))] [#f (void)]))] [else - (start-the-timer)])) + (start-the-timer #f)])) (define/private (compute-tag+rng maybe-pause pos) (define basic-info @@ -518,41 +519,41 @@ (null? require-candidates)) #f] [else - (define-values (start end) - (let loop ([pos pos]) - (define-values (this-token-start this-token-end) - (get-token-range pos)) - (cond - [(member (classify-position pos) '(symbol keyword)) - (get-token-range pos)] - [(zero? pos) (values #f #f)] - [else - (maybe-pause) - (loop (- pos 1))]))) - (cond - [(and start end) - (define id (string->symbol (get-text start end))) - (define xref (load-collections-xref)) - (define default (list start end #f #f #f)) - (or (for/or ([require-candidate (in-list require-candidates)]) - (maybe-pause) - (define mp (path->module-path require-candidate #:cache (get-path->pkg-cache))) - (define definition-tag (xref-binding->definition-tag xref (list mp id) #f)) - (cond - [definition-tag - (define-values (path url-tag) (xref-tag->path+anchor xref definition-tag)) - (cond - [path - (list start - end - definition-tag - path - url-tag)] - [else #f])] - [else #f])) - default)] - [else #f])])) + (let loop ([pos pos]) + (cond + [(member (classify-position pos) '(symbol keyword)) + (define-values (start end) (get-token-range pos)) + (cond + [(and start end) + (define candidate (try-to-find-docs start end + maybe-pause + require-candidates)) + (or candidate (loop (- pos 1)))] + [else (loop (- pos 1))])] + [(zero? pos) #f] + [else + (maybe-pause) + (loop (- pos 1))]))])) + (define/private (try-to-find-docs start end maybe-pause require-candidates) + (define id (string->symbol (get-text start end))) + (define xref (load-collections-xref)) + (for/or ([require-candidate (in-list require-candidates)]) + (maybe-pause) + (define mp (path->module-path require-candidate #:cache (get-path->pkg-cache))) + (define definition-tag (xref-binding->definition-tag xref (list mp id) #f)) + (cond + [definition-tag + (define-values (path url-tag) (xref-tag->path+anchor xref definition-tag)) + (cond + [path + (list start + end + definition-tag + path + url-tag)] + [else #f])] + [else #f]))) (define/augment (on-insert where len) (define docs-im (get-docs-im)) diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/private/syncheck/gui.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/private/syncheck/gui.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/private/syncheck/gui.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/private/syncheck/gui.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1051,7 +1051,11 @@ (define/public (syncheck:add-prefixed-require-reference req-text req-pos-left - req-pos-right) + req-pos-right + prefix + prefix-src + prefix-left + prefix-right) (hash-set! prefix-table (list req-text req-pos-left req-pos-right) #t)) (define/public (syncheck:add-unused-require req-text @@ -2185,9 +2189,11 @@ (list defs-text (list-ref lst 0) (list-ref lst 1)))) (define name-dup? (build-name-dup? name-dup-pc name-dup-id known-dead-place-channels)) (send defs-text syncheck:add-id-set to-be-renamed/poss/fixed name-dup?)] - [`#(syncheck:add-prefixed-require-reference ,id-pos-left ,id-pos-right) + [`#(syncheck:add-prefixed-require-reference ,id-pos-left ,id-pos-right + ,prefix ,prefix-left ,prefix-right) (send defs-text syncheck:add-prefixed-require-reference - defs-text id-pos-left id-pos-right)] + defs-text id-pos-left id-pos-right + prefix defs-text prefix-left prefix-right)] [`#(syncheck:add-unused-require ,req-pos-left ,req-pos-right) (send defs-text syncheck:add-unused-require defs-text req-pos-left req-pos-right)])) diff -Nru racket-6.12+ppa1/share/pkgs/drracket/drracket/tool-lib.rkt racket-7.0+ppa1/share/pkgs/drracket/drracket/tool-lib.rkt --- racket-6.12+ppa1/share/pkgs/drracket/drracket/tool-lib.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/drracket/tool-lib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1879,15 +1879,16 @@ (proc-doc/names drracket:language:create-executable-gui - ((or/c false/c (is-a?/c top-level-window<%>)) - (or/c false/c string?) + ((or/c #f (is-a?/c top-level-window<%>)) + (or/c #f string?) (or/c #t 'launcher 'standalone 'distribution) (or/c #t 'mzscheme 'mred) . -> . - (or/c false/c + (or/c #f (list/c (or/c 'no-show 'launcher 'stand-alone 'distribution) (or/c 'no-show 'mred 'mzscheme) - string?))) + string? + (listof (cons/c symbol? any/c))))) (parent program-name show-type show-base) @{Opens a dialog to prompt the user about their choice of executable. If @racket[show-type] is @racket[#t], the user is prompted about diff -Nru racket-6.12+ppa1/share/pkgs/drracket/info.rkt racket-7.0+ppa1/share/pkgs/drracket/info.rkt --- racket-6.12+ppa1/share/pkgs/drracket/info.rkt 2018-01-26 21:07:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "data-lib" "compiler-lib" ("base" #:version "6.2.900.15") "planet-lib" "compatibility-lib" ("draw-lib" #:version "1.7") "errortrace-lib" "macro-debugger-text-lib" "parser-tools-lib" "pconvert-lib" "pict-lib" "profile-lib" "sandbox-lib" ("scribble-lib" #:version "1.11") ("snip-lib" #:version "1.2") ("string-constants-lib" #:version "1.17") "typed-racket-lib" "wxme-lib" ("gui-lib" #:version "1.32") ("racket-index" #:version "1.2") "racket-doc" "html-lib" "images-lib" ("icons" #:version "1.2") "typed-racket-more" "trace" ("macro-debugger" #:version "1.1") "net-lib" "tex-table" "htdp-lib" ("drracket-plugin-lib" #:version "1.1") "gui-pkg-manager-lib" "drracket-tool-lib" "drracket-tool-doc" "pict-snip-lib" "option-contract-lib" "syntax-color-lib"))) (define build-deps (quote ("mzscheme-doc" "net-doc" "planet-doc" "compatibility-doc" "string-constants-doc" "draw-doc" "errortrace-doc" "gui-doc" "pict-doc" "profile-doc" "r5rs-doc" "at-exp-lib" "rackunit-lib"))) (define implies (quote ("drracket-plugin-lib" "drracket-tool-lib"))) (define pkg-desc "The DrRacket programming environment") (define pkg-authors (quote (robby))) (define version "1.8"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "data-lib" "compiler-lib" ("base" #:version "6.2.900.15") "planet-lib" "compatibility-lib" ("draw-lib" #:version "1.7") "errortrace-lib" "macro-debugger-text-lib" "parser-tools-lib" "pconvert-lib" "pict-lib" "profile-lib" "sandbox-lib" ("scribble-lib" #:version "1.11") ("snip-lib" #:version "1.2") ("string-constants-lib" #:version "1.19") "typed-racket-lib" "wxme-lib" ("gui-lib" #:version "1.32") ("racket-index" #:version "1.2") "racket-doc" "html-lib" "images-lib" ("icons" #:version "1.2") "typed-racket-more" "trace" ("macro-debugger" #:version "1.1") "net-lib" "tex-table" "htdp-lib" ("drracket-plugin-lib" #:version "1.1") "gui-pkg-manager-lib" "drracket-tool-lib" "drracket-tool-doc" "pict-snip-lib" "option-contract-lib" "syntax-color-lib"))) (define build-deps (quote ("mzscheme-doc" "net-doc" "planet-doc" "compatibility-doc" "string-constants-doc" "draw-doc" "errortrace-doc" "gui-doc" "pict-doc" "profile-doc" "r5rs-doc" "at-exp-lib" "rackunit-lib"))) (define implies (quote ("drracket-plugin-lib" "drracket-tool-lib"))) (define pkg-desc "The DrRacket programming environment") (define pkg-authors (quote (robby))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-plugin-lib/info.rkt racket-7.0+ppa1/share/pkgs/drracket-plugin-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/drracket-plugin-lib/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-plugin-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.1") (define deps (quote ("base" "compatibility-lib"))) (define pkg-desc "DrRacket's plugin API") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.1") (define deps (quote ("base" "compatibility-lib"))) (define pkg-desc "DrRacket's plugin API") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool/info.rkt racket-7.0+ppa1/share/pkgs/drracket-tool/info.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("drracket-tool-lib" "drracket-tool-doc"))) (define implies (quote ("drracket-tool-lib" "drracket-tool-doc"))) (define pkg-desc "Programmatic interface to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("drracket-tool-lib" "drracket-tool-doc"))) (define implies (quote ("drracket-tool-lib" "drracket-tool-doc"))) (define pkg-desc "Programmatic interface to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-doc/info.rkt racket-7.0+ppa1/share/pkgs/drracket-tool-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool-doc/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "drracket-tool-lib"))) (define build-deps (quote ("racket-doc" "gui-doc" "gui-lib" "drracket"))) (define pkg-desc "Docs for the programmatic interface to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))) (define version "1.0"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "drracket-tool-lib"))) (define build-deps (quote ("racket-doc" "gui-doc" "gui-lib" "drracket"))) (define pkg-desc "Docs for the programmatic interface to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))) (define version "1.0"))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl racket-7.0+ppa1/share/pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl --- racket-6.12+ppa1/share/pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -106,7 +106,7 @@ @definterface[syncheck-annotations<%> ()]{ Classes implementing this interface are - accceptors of information about a traversal + acceptors of information about a traversal of syntax objects. See @racket[make-traversal]. Do not implement this interface directly, as it @@ -175,12 +175,14 @@ [end exact-nonnegative-integer?] [id symbol?] [label any/c] + [definition-tag definition-tag?] [path any/c] [tag any/c]) void?]{ Called to indicate that there is something that has documentation between the range @racket[start] and @racket[end]. The documented identifier's name is given by @racket[id] and the docs are found in the html file @racket[path] at the html tag @racket[tag]. + The @racket[definition-tag] argument matches the documented definition. The @racket[label] argument describes the binding for use in the menu item (although it may be longer than 200 characters). } @@ -289,13 +291,21 @@ @defmethod[(syncheck:add-prefixed-require-reference [req-src (not/c #f)] [req-pos-left exact-nonnegative-integer?] - [req-pos-right exact-nonnegative-integer?]) + [req-pos-right exact-nonnegative-integer?] + [prefix symbol?] + [prefix-src any/c] + [prefix-left (or/c #f exact-nonnegative-integer?)] + [prefix-right (or/c #f exact-nonnegative-integer?)]) void?]{ This method is called for each @racket[require] in the program that has a @racket[_prefix] or @racket[_prefix-all-except] around it in fully expanded form (i.e., it seems to come from a @racket[prefix-in] - or a similar form). The method is passed - the location of the @racket[require] in the original program. + or a similar form). + + The method is passed the location of the @racket[require] + in the original program, as well as the prefix (as a symbol) + and the source locations of the prefix (if they are + available). } @defmethod[(syncheck:add-unused-require diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/contract-traversal.rkt racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/contract-traversal.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/contract-traversal.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/contract-traversal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,6 +16,8 @@ ;; coloring-plans : hash[stx -o-> (listof color)] (define coloring-plans (make-hash)) + + (define already-jumped-ids (make-free-id-table)) (let loop ([stx stx]) (add-to-map stx 'racket/contract:contract-on-boundary boundary-start-map) @@ -30,7 +32,7 @@ (for ([(start-k start-val) (in-hash boundary-start-map)]) (for ([start-stx (in-list start-val)]) (do-contract-traversal start-stx #t - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map #t))) @@ -39,7 +41,7 @@ (for ([(start-k start-val) (in-hash internal-start-map)]) (for ([start-stx (in-list start-val)]) (do-contract-traversal start-stx #f - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map #f))) @@ -58,7 +60,7 @@ (add-mouse-over stx (string-constant cs-contract-unk-obligation))]))) (define (do-contract-traversal start-stx boundary-contract? - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map polarity) (let ploop ([stx start-stx] [polarity polarity]) @@ -84,11 +86,11 @@ (base-color stx (not polarity) boundary-contract? coloring-plans)) (for ([stx (in-list (hash-ref domain-map id '()))]) (do-contract-traversal stx boundary-contract? - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map (not polarity))) (for ([stx (in-list (hash-ref range-map id '()))]) (do-contract-traversal stx boundary-contract? - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map polarity))]))] [else @@ -125,8 +127,11 @@ (base-color #'id polarity boundary-contract? coloring-plans) (for ([binder (in-list binders)]) (base-color binder polarity boundary-contract? coloring-plans) - (for ([rhs (in-list (free-id-table-ref binding-inits binder '()))]) - (ploop rhs polarity)))] + (define visited? (free-id-table-ref already-jumped-ids binder #f)) + (unless visited? + (free-id-table-set! already-jumped-ids binder #t) + (for ([rhs (in-list (free-id-table-ref binding-inits binder '()))]) + (ploop rhs polarity))))] [else (call-give-up)])])] [const (let ([val (syntax-e #'const)]) @@ -158,10 +163,10 @@ ;; branches are considered separately and thus calling give-up ;; on one side will not pollute the other side. (do-contract-traversal #'b boundary-contract? - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map polarity) (do-contract-traversal #'c boundary-contract? - coloring-plans + coloring-plans already-jumped-ids low-binders binding-inits domain-map range-map polarity)] ;; [(begin expr ...) (void)] [(begin0 fst rst ...) @@ -212,7 +217,7 @@ (and (list? ib) (let ([src (list-ref ib 0)]) (let-values ([(base rel) (module-path-index-split src)]) - (member base '('#%kernel racket racket/base scheme scheme/base))))))) + (member base '('#%kernel '#%runtime racket racket/base scheme scheme/base))))))) (define (give-up stx boundary-contract? coloring-plans) (let loop ([stx stx]) @@ -245,3 +250,42 @@ (cons plan (hash-ref coloring-plans stx '())))) + +(module+ test + (let () + (define port + (open-input-string + #<<>> + #lang racket + (define posn/c + (->i ([msg 'posn]) + (res (msg) + (-> posn/c)))) +>> + )) + (port-count-lines! port) + (define expanded + (parameterize ([current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (expand + (read-syntax + (build-path "afilethatdoesnotexist.rkt") + port)))) + (define low-binders (make-free-id-table)) + (define binding-inits (make-free-id-table)) + (let loop ([stx expanded]) + (syntax-case stx () + [(define-values (x) e) + (and (identifier? #'x) + (equal? (syntax-e #'define-values) 'define-values)) + (begin (when (equal? (syntax-e #'x) 'posn/c) + (free-id-table-set! binding-inits #'x (list #'e))) + (free-id-table-set! low-binders #'x (list #'x)) + (loop #'e))] + [(a . b) + (begin + (loop #'a) + (loop #'b))] + [x (void)])) + (annotate-contracts expanded low-binders binding-inits))) + diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/syncheck-intf.rkt racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/syncheck-intf.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/syncheck-intf.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/syncheck-intf.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -69,8 +69,9 @@ (define/public (syncheck:add-jump-to-definition text start end id filename submods) (void)) (define/public (syncheck:add-definition-target source pos-left pos-right id mods) (void)) (define/public (syncheck:color-range source start finish style-name) (void)) - (define/public (syncheck:add-prefixed-require-reference req-src req-pos-left req-pos-right - prefix-in-src prefix-in-pos) + (define/public (syncheck:add-prefixed-require-reference + req-src req-pos-left req-pos-right + prefix prefix-src prefix-pos-left prefix-pos-right) (void)) (define/public (syncheck:add-unused-require req-src req-pos-left req-pos-right) (void)) (super-new))) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt 2018-01-26 20:35:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -456,7 +456,7 @@ (loop spec #f))] [(just-meta phase specs ...) (for ([spec (in-list (syntax->list #'(specs ...)))]) - (handle-phaseless-spec spec (add-to-level (syntax-e #'phase))))] + (loop spec level))] [else (handle-phaseless-spec spec level)]))) (define (handle-phaseless-spec stx level) @@ -1156,14 +1156,22 @@ (send defs-text syncheck:add-require-open-menu req-source start end file)) (when phaseless-require-spec/module-lang-require - (define has-prefix? + (define prefix (syntax-case* phaseless-require-spec/module-lang-require (prefix prefix-all-except) symbolic-compare? - [(prefix . _) #t] - [(prefix-all-except . _) #t] + [(prefix pfx . _) #'pfx] + [(prefix-all-except pfx . _) #'pfx] [other #f])) - (when has-prefix? - (send defs-text syncheck:add-prefixed-require-reference req-source start end))))))) + (when prefix + (define prefix-source (find-source-editor prefix)) + (define prefix-start (and prefix-source + (syntax-position prefix) + (- (syntax-position prefix) 1))) + (define prefix-end (and prefix-start + (syntax-span prefix) + (+ prefix-start (syntax-span prefix)))) + (send defs-text syncheck:add-prefixed-require-reference req-source start end + (syntax-e prefix) prefix-source prefix-start prefix-end))))))) ;; get-require-filename : sexp-or-module-path-index namespace string[directory] -> filename or #f ;; finds the filename corresponding to the require in stx @@ -1472,7 +1480,9 @@ (log syncheck:add-require-open-menu _text start-pos end-pos file) (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag) (log syncheck:add-id-set to-be-renamed/poss dup-name?) - (log syncheck:add-prefixed-require-reference _req-src req-pos-left req-pos-right) + (log syncheck:add-prefixed-require-reference + _req-src req-pos-left req-pos-right + prefix _prefix-src prefix-start prefix-end) (log syncheck:add-unused-require _req-src req-pos-left req-pos-right) (define/public (get-trace) (reverse trace)) diff -Nru racket-6.12+ppa1/share/pkgs/drracket-tool-lib/info.rkt racket-7.0+ppa1/share/pkgs/drracket-tool-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/drracket-tool-lib/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/drracket-tool-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.2.900.10") "scribble-lib" ("string-constants-lib" #:version "1.12") "scribble-lib" "racket-index" "gui-lib"))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "Code implementing programmatic interfaces to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.2.900.10") "scribble-lib" ("string-constants-lib" #:version "1.12") "scribble-lib" "racket-index" "gui-lib"))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "Code implementing programmatic interfaces to some IDE tools that DrRacket supports") (define pkg-authors (quote (robby))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/ds-store/info.rkt racket-7.0+ppa1/share/pkgs/ds-store/info.rkt --- racket-6.12+ppa1/share/pkgs/ds-store/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/ds-store/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "ds-store") (define deps (quote ("ds-store-lib" "ds-store-doc" "base"))) (define implies (quote ("ds-store-lib" "ds-store-doc"))) (define pkg-desc "Libraries for manipulating \".DS_Store\" files") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "ds-store") (define deps (quote ("ds-store-lib" "ds-store-doc" "base"))) (define implies (quote ("ds-store-lib" "ds-store-doc"))) (define pkg-desc "Libraries for manipulating \".DS_Store\" files") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/ds-store-doc/info.rkt racket-7.0+ppa1/share/pkgs/ds-store-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/ds-store-doc/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/ds-store-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "ds-store") (define deps (quote ("base" "scribble-lib" "racket-doc" "ds-store-lib"))) (define update-implies (quote ("ds-store-lib"))) (define scribblings (quote (("ds-store.scrbl")))) (define pkg-desc "documentation part of \"ds-store\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "ds-store") (define deps (quote ("base" "scribble-lib" "racket-doc" "ds-store-lib"))) (define update-implies (quote ("ds-store-lib"))) (define scribblings (quote (("ds-store.scrbl")))) (define pkg-desc "documentation part of \"ds-store\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/ds-store-lib/info.rkt racket-7.0+ppa1/share/pkgs/ds-store-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/ds-store-lib/info.rkt 2018-01-26 21:08:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/ds-store-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "ds-store") (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"ds-store\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "ds-store") (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"ds-store\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/dynext-lib/info.rkt racket-7.0+ppa1/share/pkgs/dynext-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/dynext-lib/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/dynext-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Library for running a C compiler/linker") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Library for running a C compiler/linker") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/eli-tester/info.rkt racket-7.0+ppa1/share/pkgs/eli-tester/info.rkt --- racket-6.12+ppa1/share/pkgs/eli-tester/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/eli-tester/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "rackunit-lib"))) (define pkg-desc "Testing framework") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "rackunit-lib"))) (define pkg-desc "Testing framework") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/eopl/info.rkt racket-7.0+ppa1/share/pkgs/eopl/info.rkt --- racket-6.12+ppa1/share/pkgs/eopl/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/eopl/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "eopl") (define deps (quote ("base" "compatibility-lib"))) (define scribblings (quote (("eopl.scrbl" () (teaching -20))))) (define build-deps (quote ("rackunit-lib" "racket-doc" "scribble-lib"))) (define pkg-desc "Teaching language for _Essentials of Programming Languages_") (define pkg-authors (quote (dvanhorn))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "eopl") (define deps (quote ("base" "compatibility-lib"))) (define scribblings (quote (("eopl.scrbl" () (teaching -20))))) (define build-deps (quote ("rackunit-lib" "racket-doc" "scribble-lib"))) (define pkg-desc "Teaching language for _Essentials of Programming Languages_") (define pkg-authors (quote (dvanhorn))))) diff -Nru racket-6.12+ppa1/share/pkgs/errortrace/info.rkt racket-7.0+ppa1/share/pkgs/errortrace/info.rkt --- racket-6.12+ppa1/share/pkgs/errortrace/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/errortrace/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("errortrace-lib" "errortrace-doc"))) (define implies (quote ("errortrace-lib" "errortrace-doc"))) (define pkg-desc "Instrumentation tools for debugging") (define pkg-authors (quote (mflatt robby florence))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("errortrace-lib" "errortrace-doc"))) (define implies (quote ("errortrace-lib" "errortrace-doc"))) (define pkg-desc "Instrumentation tools for debugging") (define pkg-authors (quote (mflatt robby florence))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/errortrace-doc/errortrace/scribblings/errortrace.scrbl racket-7.0+ppa1/share/pkgs/errortrace-doc/errortrace/scribblings/errortrace.scrbl --- racket-6.12+ppa1/share/pkgs/errortrace-doc/errortrace/scribblings/errortrace.scrbl 2018-01-26 20:34:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/errortrace-doc/errortrace/scribblings/errortrace.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -31,7 +31,7 @@ @commandline{racket -l errortrace -t @nonterm{prog}}} - @item{If you program is a non-module top-level sequence of + @item{If your program is a non-module top-level sequence of definitions and expressions, you can instead add @racketblock[(require errortrace)] to the beginning of the program or start Racket with the @Flag{l} option before the diff -Nru racket-6.12+ppa1/share/pkgs/errortrace-doc/info.rkt racket-7.0+ppa1/share/pkgs/errortrace-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/errortrace-doc/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/errortrace-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("racket-doc" "base" "errortrace-lib" "scribble-lib"))) (define update-implies (quote ("errortrace-lib"))) (define pkg-desc "documentation part of \"errortrace\"") (define pkg-authors (quote (mflatt robby florence))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("racket-doc" "base" "errortrace-lib" "scribble-lib"))) (define update-implies (quote ("errortrace-lib"))) (define pkg-desc "documentation part of \"errortrace\"") (define pkg-authors (quote (mflatt robby florence))))) diff -Nru racket-6.12+ppa1/share/pkgs/errortrace-lib/info.rkt racket-7.0+ppa1/share/pkgs/errortrace-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/errortrace-lib/info.rkt 2018-01-26 21:08:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/errortrace-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.6.0.3") "source-syntax"))) (define pkg-desc "implementation (no documentation) part of \"errortrace\"") (define pkg-authors (quote (mflatt robby florence))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.6.0.3") "source-syntax"))) (define pkg-desc "implementation (no documentation) part of \"errortrace\"") (define pkg-authors (quote (mflatt robby florence))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/frtime/info.rkt racket-7.0+ppa1/share/pkgs/frtime/info.rkt --- racket-6.12+ppa1/share/pkgs/frtime/info.rkt 2018-01-26 21:08:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/frtime/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "frtime") (define name "FrTime") (define compile-omit-paths (quote ("demos" "tests"))) (define test-omit-paths (quote ("demos"))) (define scribblings (quote (("scribblings/frtime.scrbl" () (experimental 50))))) (define deps (quote ("srfi-lite-lib" "base" "compatibility-lib" "drracket" "gui-lib" "pict-lib" "string-constants-lib"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the FrTime language") (define pkg-authors (quote (jay gcooper))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "frtime") (define name "FrTime") (define compile-omit-paths (quote ("demos" "tests"))) (define test-omit-paths (quote ("demos"))) (define scribblings (quote (("scribblings/frtime.scrbl" () (experimental 50))))) (define deps (quote ("srfi-lite-lib" "base" "compatibility-lib" "drracket" "gui-lib" "pict-lib" "string-constants-lib"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the FrTime language") (define pkg-authors (quote (jay gcooper))))) diff -Nru racket-6.12+ppa1/share/pkgs/future-visualizer/info.rkt racket-7.0+ppa1/share/pkgs/future-visualizer/info.rkt --- racket-6.12+ppa1/share/pkgs/future-visualizer/info.rkt 2018-01-26 21:08:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/future-visualizer/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "data-lib" "draw-lib" "pict-lib" "gui-lib"))) (define build-deps (quote ("scheme-lib" "scribble-lib" "racket-doc" "rackunit-lib"))) (define pkg-desc "Graphical performance tools for using futures") (define pkg-authors (quote (jamesswaine))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "data-lib" "draw-lib" "pict-lib" "gui-lib"))) (define build-deps (quote ("scheme-lib" "scribble-lib" "racket-doc" "rackunit-lib"))) (define pkg-desc "Graphical performance tools for using futures") (define pkg-authors (quote (jamesswaine))))) diff -Nru racket-6.12+ppa1/share/pkgs/future-visualizer-typed/info.rkt racket-7.0+ppa1/share/pkgs/future-visualizer-typed/info.rkt --- racket-6.12+ppa1/share/pkgs/future-visualizer-typed/info.rkt 2018-01-26 21:08:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/future-visualizer-typed/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "future-visualizer" "typed-racket-lib"))) (define pkg-desc "type declarations for \"future-visualizer\"") (define pkg-authors (quote (jamesswaine))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "future-visualizer" "typed-racket-lib"))) (define pkg-desc "type declarations for \"future-visualizer\"") (define pkg-authors (quote (jamesswaine))))) diff -Nru racket-6.12+ppa1/share/pkgs/games/gcalc/gcalc.rkt racket-7.0+ppa1/share/pkgs/games/gcalc/gcalc.rkt --- racket-6.12+ppa1/share/pkgs/games/gcalc/gcalc.rkt 2018-01-26 20:35:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/games/gcalc/gcalc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,6 +8,11 @@ (require racket/gui "../show-scribbling.rkt" racket/unit) (provide game@) +(define game@ (unit (import) (export) + +;;;============================================================================ +;;; Customizations etc + (define customs '()) (define (add-custom! name get set type desc) (set! customs (append customs (list (make-custom name get set type desc))))) @@ -18,10 +23,6 @@ (begin (define var default) (add-custom! 'var (λ() var) (λ(v) (set! var v)) type description))])) -(define game@ (unit (import) (export) - -;;;============================================================================ -;;; Customizations etc (defcustom EVAL-NOW #t 'bool "Evaluate immediately on application") (defcustom EVAL-DEPTH 18 '(int 100) "Evaluation depth limit") diff -Nru racket-6.12+ppa1/share/pkgs/games/info.rkt racket-7.0+ppa1/share/pkgs/games/info.rkt --- racket-6.12+ppa1/share/pkgs/games/info.rkt 2018-01-26 21:08:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/games/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "games") (define scribblings (quote (("scribblings/games.scrbl" (multi-page) (gui-library))))) (define gracket-launcher-libraries (list "main.rkt")) (define gracket-launcher-names (list "PLT Games")) (define deps (quote ("base" "draw-lib" "drracket" ("gui-lib" #:version "1.16") "net-lib" "htdp-lib" "math-lib" "scribble-lib" "racket-index" "sgl" "srfi-lib" "string-constants-lib" ("data-enumerate-lib" #:version "1.2") "typed-racket-lib" "typed-racket-more"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "pict-lib" "rackunit-lib" "htdp-doc"))) (define pkg-desc "Games") (define pkg-authors (quote (mflatt robby))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "games") (define scribblings (quote (("scribblings/games.scrbl" (multi-page) (gui-library))))) (define gracket-launcher-libraries (list "main.rkt")) (define gracket-launcher-names (list "PLT Games")) (define deps (quote ("base" "draw-lib" "drracket" ("gui-lib" #:version "1.16") "net-lib" "htdp-lib" "math-lib" "scribble-lib" "racket-index" "sgl" "srfi-lib" "string-constants-lib" ("data-enumerate-lib" #:version "1.2") "typed-racket-lib" "typed-racket-more"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "pict-lib" "rackunit-lib" "htdp-doc"))) (define pkg-desc "Games") (define pkg-authors (quote (mflatt robby))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/games/lights-out/board.rkt racket-7.0+ppa1/share/pkgs/games/lights-out/board.rkt --- racket-6.12+ppa1/share/pkgs/games/lights-out/board.rkt 2018-01-26 20:35:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/games/lights-out/board.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -74,7 +74,7 @@ [(random) (random-board (send random-slider get-value))] [(empty) - (build-vector + (build-vector (send random-slider get-value) (lambda (x) (make-vector (send random-slider get-value) 'o)))] [(prebuilt) @@ -84,13 +84,6 @@ (define (to-vectors lsts) (apply vector (map (λ (x) (apply vector x)) lsts))) - '(define (build-vector n f) - (list->vector - (let loop ([n n]) - (cond - [(zero? n) null] - [else (cons (f (- n 1)) (loop (- n 1)))])))) - (define (random-board n) (let* ([choices (let loop ([i n] @@ -138,7 +131,7 @@ (let loop ([choices choices] [n choice]) (cond - [(zero? n) + [(zero? n) ;(printf "choose: ~a\n" (car choices)) (set! choice-coordinates (car choices)) (cdr choices)] diff -Nru racket-6.12+ppa1/share/pkgs/games/mines/mines.rkt racket-7.0+ppa1/share/pkgs/games/mines/mines.rkt --- racket-6.12+ppa1/share/pkgs/games/mines/mines.rkt 2018-01-26 20:35:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/games/mines/mines.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -352,7 +352,9 @@ (if (zero? nc) (autoclick-surrounding x y) (set-near-hilite t x y)))) - (when (and ready? (= cover-count THE-BOMB-COUNT)) (win)))))] + (when (and ready? (= cover-count THE-BOMB-COUNT)) + (clear-area-hilite) + (win)))))] [paint-one ; draw one tile (lambda (t x y) (let ([xloc (* x TILE-HW)] diff -Nru racket-6.12+ppa1/share/pkgs/gui/info.rkt racket-7.0+ppa1/share/pkgs/gui/info.rkt --- racket-6.12+ppa1/share/pkgs/gui/info.rkt 2018-01-26 21:08:08.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("gui-lib" "gui-doc"))) (define implies (quote ("gui-lib" "gui-doc"))) (define pkg-desc "Graphical user interface toolkit") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("gui-lib" "gui-doc"))) (define implies (quote ("gui-lib" "gui-doc"))) (define pkg-desc "Graphical user interface toolkit") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-doc/info.rkt racket-7.0+ppa1/share/pkgs/gui-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/gui-doc/info.rkt 2018-01-26 21:08:08.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("scheme-lib" "syntax-color-doc" "at-exp-lib" "draw-doc" "draw-lib" "scribble-lib" "snip-lib" "string-constants-lib" "syntax-color-lib" "wxme-lib" "gui-lib" "pict-lib" "racket-doc" "string-constants-doc" "xrepl-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("gui-lib"))) (define pkg-desc "documentation part of \"gui\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("scheme-lib" "syntax-color-doc" "at-exp-lib" "draw-doc" "draw-lib" "scribble-lib" "snip-lib" "string-constants-lib" "syntax-color-lib" "wxme-lib" "gui-lib" "pict-lib" "racket-doc" "string-constants-doc" "xrepl-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("gui-lib"))) (define pkg-desc "documentation part of \"gui\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/arrow-toggle-snip.scrbl racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/arrow-toggle-snip.scrbl --- racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/arrow-toggle-snip.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/arrow-toggle-snip.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,37 @@ +#lang scribble/doc +@(require "common.rkt" (for-label mrlib/arrow-toggle-snip)) + +@title{Arrow Toggle Snip} + +@defmodule[mrlib/arrow-toggle-snip] + +@defclass[arrow-toggle-snip% snip% ()]{ + +Represents a toggle control, displayed as a right-facing arrow (off or +``closed'') or a downward-facing arrow (on or ``open''). + +The size of the arrow is determined by the style (and font) applied to +the snip. The arrow is drawn inscribed in a square resting on the +baseline, but the snip reports its size (usually) as the same as a +capital @litchar{X}; this means that the snip should look good next to +text (in the same style) no matter whether base-aligned or +top-aligned. + +@defconstructor[([callback (-> boolean? any) void])]{ + +The @racket[on-up] and @racket[on-down] callbacks are called when the +snip is toggled. +} + +@defmethod[(get-toggle-state) boolean?]{ + +Get the control's state. +} + +@defmethod[(set-toggle-state [v boolean?]) void?]{ + +Sets the control's state. If the new state is different from the +previous state, the appropriate callback is called. +} + +} diff -Nru racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/expandable-snip.scrbl racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/expandable-snip.scrbl --- racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/expandable-snip.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/expandable-snip.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,52 @@ +#lang scribble/doc +@(require "common.rkt" (for-label mrlib/expandable-snip)) + +@title{Expandable Snip} + +@defmodule[mrlib/expandable-snip] + +@defclass[expandable-snip% editor-snip% ()]{ + +An expandable snip allows the user to toggle between two +views---``open'' and ``closed''---implemented by two text +editors. Typically the closed view is a concise summary and the open +view contains more detailed information. The syntax browser snip is an +example of an expandable snip. + +@defconstructor/auto-super[([layout (or/c 'append 'replace) 'append] + [closed-editor (is-a?/c text%) (new text%)] + [open-editor (is-a?/c text%) (new text%)] + [open/close-callback + (-> (is-a?/c expandable-snip%) boolean? any) + void])]{ + +The @racket[open/close-callback] is called when the snip state is +toggled. It is called with the expandable snip object and a boolean +that indicates whether the new state is open. + +In closed mode, the toggle arrow and @racket[closed-editor] are +displayed adjacent on a single line. In open mode, the layout is +controlled by the @racket[layout] argument as follows: +@itemlist[ + +@item{@racket['append] --- The first line is unchanged (that is, it +contains both toggle arrow and @racket[closed-editor]), and +@racket[open-editor] is displayed on the second line.} + +@item{@racket['replace] --- The toggle arrow and the +@racket[open-editor] are displayed on a single line. The +@racket[closed-editor] is not displayed.} + +] +} + +@defmethod[(get-open-editor) (is-a?/c text%)]{ + +Get the editor for the open mode. +} + +@defmethod[(get-closed-editor) (is-a?/c text%)]{ + +Gets the editor for the closed mode. +} +} diff -Nru racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/mrlib.scrbl racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/mrlib.scrbl --- racket-6.12+ppa1/share/pkgs/gui-doc/mrlib/scribblings/mrlib.scrbl 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-doc/mrlib/scribblings/mrlib.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -6,9 +6,11 @@ @table-of-contents[] @include-section["aligned-pasteboard/aligned-pasteboard.scrbl"] +@include-section["arrow-toggle-snip.scrbl"] @include-section["bitmap-label.scrbl"] @include-section["cache-image-snip.scrbl"] @include-section["close-icon.scrbl"] +@include-section["expandable-snip.scrbl"] @include-section["gif.scrbl"] @include-section["graph/graph.scrbl"] @include-section["hierlist/hierlist.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -772,7 +772,7 @@ (or (for/or ([v (in-list line)]) (and (vector? v) (vec->color v))) - (vec->color #'(0 0 0)))) + (vec->color #(0 0 0)))) (define (props->style-delta line) (define sd (new style-delta%)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/racket.rkt racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/racket.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/racket.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/racket.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1529,7 +1529,7 @@ (define token (send text classify-position click-pos)) (define-values (start end) (cond - [(memq token '(string comment)) (word-based)] + [(memq token '(string comment text)) (word-based)] [(and (equal? token 'other) (let-values ([(start end) (send text get-token-range click-pos)]) (and start diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/text.rkt racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/text.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/framework/private/text.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/framework/private/text.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -559,8 +559,8 @@ (or (and (path? id) (path? filename) (or (equal? id filename) ;; "fast path" check - (equal? (normal-case-path (normalize-path (get-filename))) - (normal-case-path (normalize-path id))))) + (equal? (normal-case-path (simplify-path filename #f)) + (normal-case-path (simplify-path id #f))))) (and (symbol? port-name-identifier) (symbol? id) (equal? port-name-identifier id))))) @@ -2295,31 +2295,48 @@ [(is-a? s string-snip%) (loop (send s next))] [else #f]))) + + ;; Saving in text when wxme is needed looses data, + ;; therefore if the user refuses to change file formats + ;; abort save. + (define/augment (can-save-file? name format) + (define needs-wxme? + (and (not (all-string-snips)) + (eq? format 'same) + (eq? 'text (get-file-format)))) + (define format-converted + (and needs-wxme? + (or (not (preferences:get 'framework:verify-change-format)) + (message-box/custom + (string-constant warning) + (string-constant save-as-binary-format) + (string-constant convert-format) + (string-constant keep-format) + (string-constant dont-save) + #f + '(disallow-close default=3) + 3 + #:dialog-mixin frame:focus-table-mixin)))) + (define continue-saving? + (case format-converted + [(1 #t) + (set-file-format 'standard) + #t] + [(2) #t] + [(3) #f])) + (and continue-saving? (inner #t can-save-file? name format))) (define/augment (on-save-file name format) - (let ([all-strings? (all-string-snips)]) - (cond - [(and all-strings? - (eq? format 'same) - (eq? 'standard (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - (string-constant save-as-plain-text) - (string-constant yes) - (string-constant no) - #:dialog-mixin frame:focus-table-mixin))) - (set-file-format 'text)] - [(and (not all-strings?) - (eq? format 'same) - (eq? 'text (get-file-format)) - (or (not (preferences:get 'framework:verify-change-format)) - (gui-utils:get-choice - (string-constant save-in-drs-format) - (string-constant yes) - (string-constant no) - #:dialog-mixin frame:focus-table-mixin))) - (set-file-format 'standard)] - [else (void)])) + (when (and (all-string-snips) + (eq? format 'same) + (eq? 'standard (get-file-format)) + (or (not (preferences:get 'framework:verify-change-format)) + (gui-utils:get-choice + (string-constant save-as-plain-text) + (string-constant yes) + (string-constant no) + #:dialog-mixin frame:focus-table-mixin))) + (set-file-format 'text)) (inner (void) on-save-file name format)) (super-new))) @@ -3451,11 +3468,14 @@ (handle-evt done-evt (λ (v) - (let ([nth-pos (cdr (at-peek-n data (- kr 1)))]) + (let* ([nth (at-peek-n data (- kr 1))] + [nth-pos (cdr nth)]) (set! position - (list (car nth-pos) - (+ 1 (cadr nth-pos)) - (+ 1 (caddr nth-pos))))) + (if (eof-object? (car nth)) + nth-pos + (list (car nth-pos) + (+ 1 (cadr nth-pos)) + (+ 1 (caddr nth-pos)))))) (set! data (at-dequeue-n data kr)) (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/info.rkt racket-7.0+ppa1/share/pkgs/gui-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/info.rkt 2018-01-26 21:08:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "data-lib" ("base" #:version "6.11.0.1") "syntax-color-lib" ("draw-lib" #:version "1.13") ("snip-lib" #:version "1.2") "wxme-lib" "pict-lib" "scheme-lib" "scribble-lib" ("string-constants-lib" #:version "1.14") "option-contract-lib" "2d-lib" "compatibility-lib" "tex-table" ("gui-i386-macosx" #:platform "i386-macosx") ("gui-x86_64-macosx" #:platform "x86_64-macosx") ("gui-ppc-macosx" #:platform "ppc-macosx") ("gui-win32-i386" #:platform "win32\\i386") ("gui-win32-x86_64" #:platform "win32\\x86_64") ("gui-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"gui\"") (define pkg-authors (quote (mflatt robby))) (define version "1.33"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "data-lib" ("base" #:version "6.11.0.1") "syntax-color-lib" ("draw-lib" #:version "1.13") ("snip-lib" #:version "1.2") "wxme-lib" "pict-lib" "scheme-lib" "scribble-lib" ("string-constants-lib" #:version "1.14") "option-contract-lib" "2d-lib" "compatibility-lib" "tex-table" ("gui-i386-macosx" #:platform "i386-macosx") ("gui-x86_64-macosx" #:platform "x86_64-macosx") ("gui-ppc-macosx" #:platform "ppc-macosx") ("gui-win32-i386" #:platform "win32\\i386") ("gui-win32-x86_64" #:platform "win32\\x86_64") ("gui-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"gui\"") (define pkg-authors (quote (mflatt robby))) (define version "1.33"))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/installer.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/installer.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/installer.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/installer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,7 +23,7 @@ (define (do-installer path coll user? tethered?) (define variants (available-mred-variants)) (when (memq (cross-system-type) mred-exe-systems) - (for ([v variants] #:when (memq v '(3m cgc))) + (for ([v variants] #:when (memq v '(3m cgc cs))) (parameterize ([current-launcher-variant v]) (create-embedding-executable (prep-dir (mred-program-launcher-path "MrEd" @@ -38,7 +38,7 @@ #:aux `((relative? . ,(not user?))))))) ;; add a mred-text executable that uses the -z flag (preferring a script) (define tether-mode (and tethered? (if user? 'addon 'config))) - (for ([vs '((script-3m 3m) (script-cgc cgc))]) + (for ([vs '((script-3m 3m) (script-cgc cgc) (script-cs cs))]) (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) @@ -54,7 +54,7 @@ [single-instance? . #f])))))) ;; add bin/mred script under OS X (when (eq? 'macosx (cross-system-type)) - (for ([v variants] #:when (memq v '(script-3m script-cgc))) + (for ([v variants] #:when (memq v '(script-3m script-cgc script-cs))) (parameterize ([current-launcher-variant v]) (make-gracket-launcher #:tether-mode tether-mode diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -931,6 +931,8 @@ (let ([cocoa-win (get-cocoa-window)]) (for ([r (in-list reg-blits)]) (tellv cocoa-win removeChildWindow: (vector-ref r 0)) + ; removeChildWindow doesn't hide the window + (tellv (vector-ref r 0) orderOut: #f) (release (vector-ref r 0)) (scheme_remove_gc_callback (vector-ref r 1)))) (set! reg-blits null)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/frame.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/frame.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/frame.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/frame.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -46,6 +46,7 @@ ;; called in atomic mode (define (send-screen-change-notifications flags) + (reset-menu-bar!) (when (zero? (bitwise-and flags 1)) ;; discard the "about to change" notifications (for ([b (in-hash-values all-windows)]) (define f (weak-box-value b)) @@ -128,7 +129,12 @@ (send wx install-wait-cursor) (send wx install-mb) (queue-window-event wx (lambda () - (send wx on-activate #t)))))))] + (send wx on-activate #t))))))) + ;; If the fake root became main (because no other windows exist), + ;; we need to hide it again to avoid it getting stuck in the window list. + (when (and root-fake-frame (ptr-equal? self (send root-fake-frame get-cocoa))) + (tellv self orderFront: #f) + (tellv self orderOut: #f))] [-a _void (windowDidBecomeKey: [_id notification]) (when (tell #:type _BOOL self isVisible) (when wxb @@ -387,7 +393,8 @@ (define fs? (fullscreened?)) (set! unshown-fullscreen? fs?) (tellv cocoa setReleasedWhenClosed: #:type _BOOL #f) - (tellv cocoa close)) + (tellv cocoa close) + (tellv (tell NSApplication sharedApplication) removeWindowsItem: cocoa)) (force-window-focus))) (register-frame-shown this on?) (let ([num (tell #:type _NSInteger cocoa windowNumber)]) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/menu-bar.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/menu-bar.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/menu-bar.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/menu-bar.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,7 +12,8 @@ (provide (protect-out menu-bar% - get-menu-bar-height)) + get-menu-bar-height + reset-menu-bar!)) (import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) @@ -70,20 +71,33 @@ (define current-mb #f) ;; Used to detect mouse click on the menu bar: -(define in-menu-bar-range - (let ([f (tell #:type _NSRect - (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0) - frame)]) - (let ([x (NSPoint-x (NSRect-origin f))] - [w (NSSize-width (NSRect-size f))] - [y (+ (NSPoint-y (NSRect-origin f)) - (NSSize-height (NSRect-size f)))]) - (lambda (p) - (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) - (and (<= x (NSPoint-x p) (+ x w)) - (<= (- y h) (NSPoint-y p) y))))))) +(define (reset-menu-bar!) + (define screens (tell NSScreen screens)) + (define mb-screens + (if (and (version-10.9-or-later?) + (tell #:type _BOOL NSScreen screensHaveSeparateSpaces)) + (for/list ([i (in-range (tell #:type _NSUInteger screens count))]) + (tell screens objectAtIndex: #:type _NSUInteger i)) + (list (tell screens objectAtIndex: #:type _NSUInteger 0)))) + (define x+w+ys + (for/list ([screen (in-list mb-screens)]) + (define f (tell #:type _NSRect screen frame)) + (define x (NSPoint-x (NSRect-origin f))) + (define w (NSSize-width (NSRect-size f))) + (define y (+ (NSPoint-y (NSRect-origin f)) + (NSSize-height (NSRect-size f)))) + (list x w y))) + (set-menu-bar-hooks! + (lambda (p flipped?) + (let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)]) + (for/or ([x+w+y (in-list x+w+ys)]) + (define x (car x+w+y)) + (define w (cadr x+w+y)) + (define y (caddr x+w+y)) + (and (<= x (NSPoint-x p) (+ x w)) + (<= (- y h) (if flipped? (- y (NSPoint-y p)) (NSPoint-y p)) y))))))) -(set-menu-bar-hooks! in-menu-bar-range) +(reset-menu-bar!) ;; Init menu bar (let ([app (tell NSApplication sharedApplication)] diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -209,7 +209,9 @@ (define buttons (if (version-10.6-or-later?) (tell #:type _NSUInteger NSEvent pressedMouseButtons) 0)) - (define mods (tell #:type _NSUInteger NSEvent modifierFlags)) + (define mods (if (version-10.6-or-later?) + (tell #:type _NSUInteger NSEvent modifierFlags) + 0)) (define (maybe v mask sym) (if (zero? (bitwise-and v mask)) null diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/queue.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/queue.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/queue.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/queue.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -35,7 +35,7 @@ queue-event yield) -(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray NSMenu) ;; Extreme hackery to hide original arguments from ;; NSApplication, because NSApplication wants to turn @@ -82,6 +82,8 @@ (queue-file-event (string->path filename)) (post-dummy-event)] [-a _void (applicationDidFinishLaunching: [_id notification]) + ;; Create an empty windows menu for right clicking in the dock + (tell app setWindowsMenu: (tell (tell NSMenu alloc) init)) (unless got-file? (queue-start-empty-event))] [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) @@ -177,7 +179,7 @@ ;; that, so there's an additional hack above. (define-appserv CGDisplayRegisterReconfigurationCallback (_fun (_fun #:atomic? #t _uint32 _uint32 -> _void) _pointer -> _int32)) -(define (on-screen-changed display flags) +(define (on-screen-changed display flags) (screen-changed-callback flags) (post-dummy-event)) (define screen-changed-callback void) @@ -248,12 +250,12 @@ ;; the CoreFoundation run loop (define _CFIndex _uint) -(define _CFStringRef _NSString) +(define _CFStringRef _pointer) ; don't use NSString, because we don't want to acquire/release (define-cstruct _CFSocketContext ([version _CFIndex] [info _pointer] [retain (_fun _pointer -> _pointer)] [release (_fun _pointer -> _void)] - [copyDescription (_fun _pointer -> _CFStringRef)])) + [copyDescription (_fun _pointer -> _NSString)])) (define (sock_retain v) #f) (define (sock_release v) (void)) (define (sock_copy_desc v) "sock") @@ -302,13 +304,13 @@ ;; icon. (But why does that happen?) (define _Boolean _BOOL) -(define-cf kCFRunLoopCommonModes _pointer) +(define-cf kCFRunLoopCommonModes _CFStringRef) (define-cf CFRunLoopObserverCreate (_fun _pointer ; CFAllocatorRef _int ; CFOptionFlags _Boolean ; repeats? _CFIndex ; order (_fun #:atomic? #t _pointer _int _pointer -> _void) - _pointer ; CFRunLoopObserverContext + _CFStringRef ; CFRunLoopObserverContext -> _pointer)) (define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void)) (define-cf CFRunLoopGetMain (_fun -> _pointer)) @@ -324,6 +326,50 @@ (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes)) ;; ------------------------------------------------------------ +;; Detecting menu-bar clicks: +;; In 10.13 and later, detecting a menu-bar click by NSSystemDefined +;; doesn't work, so we have to install a lower-level event tap. + +(define mb-detect-box (box #f)) +(define-cg CGEventTapCreate (_fun _uint32 _uint32 _uint32 _uint64 + (_fun #:atomic? #t + #:keep mb-detect-box + _pointer _uint32 _id _pointer -> _id) + _pointer + -> _pointer)) +(define-cf CFMachPortCreateRunLoopSource (_fun _pointer _pointer _long -> _pointer)) +(define-cf CFRunLoopGetCurrent (_fun -> _pointer)) +(define-cg CGEventGetLocation (_fun _pointer -> _NSPoint)) +(define-appkit NSEventTrackingRunLoopMode _CFStringRef) + +(define in-menu-bar-detected? #f) + +(define (menu-bar-tap-callback proxy type evt data) + (when (in-menu-bar-range? (CGEventGetLocation evt) #t) + (set! in-menu-bar-detected? #t)) + evt) + +(define kCGSessionEventTap 1) +(define kCGAnnotatedSessionEventTap 2) +(define kCGHeadInsertEventTap 0) +(define kCGEventTapOptionDefault 0) ; => active +(define NX_LMOUSEDOWN 1) +(define NX_RMOUSEDOWN 3) +(define menu-bar-tap + (and (version-10.13-or-later?) + (CGEventTapCreate kCGSessionEventTap #; kCGAnnotatedSessionEventTap + kCGHeadInsertEventTap + kCGEventTapOptionDefault + (bitwise-ior + (1 . arithmetic-shift . NX_LMOUSEDOWN) + (1 . arithmetic-shift . NX_RMOUSEDOWN)) + menu-bar-tap-callback + (malloc-immobile-cell mb-detect-box)))) +(when menu-bar-tap + (define src (CFMachPortCreateRunLoopSource #f menu-bar-tap 0)) + (CFRunLoopAddSource (CFRunLoopGetCurrent) src kCFRunLoopCommonModes)) + +;; ------------------------------------------------------------ ;; Cocoa event pump (define-cocoa NSDefaultRunLoopMode _id) ; more specifically an _NSString, but we don't need a conversion @@ -337,7 +383,7 @@ (define front-hook (lambda () (values #f #f))) (define (set-front-hook! proc) (set! front-hook proc)) -(define in-menu-bar-range? (lambda (p) #f)) +(define in-menu-bar-range? (lambda (p flipped?) #f)) (define (set-menu-bar-hooks! r?) (set! in-menu-bar-range? r?)) @@ -346,12 +392,21 @@ (define avoid-mouse-key-until #f) +;; Check for menu-bar click to trigger `on-demand` callbacks. +;; Why not use a delegate on NSMenu? Because that's a less convenient +;; time to call arbitrary Racket code. It might be better to do that +;; using `call-as-nonatomic-retry-point` and `constrained-reply`, but +;; I'm not sure, and I'll stick with this for now. (define (check-menu-bar-click evt) - (if (and evt - (= 14 (tell #:type _NSUInteger evt type)) - (= 7 (tell #:type _short evt subtype)) - (not (tell evt window)) - (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow))) + (if (if menu-bar-tap + (and in-menu-bar-detected? + (set! in-menu-bar-detected? #f) + #t) + (and evt + (= NSSystemDefined (tell #:type _NSUInteger evt type)) + (= 7 (tell #:type _short evt subtype)) + (not (tell evt window)) + (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow) #f))) ;; Mouse down in the menu bar: (let-values ([(f e) (front-hook)]) (when e diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,6 +14,7 @@ define-cf define-appserv define-appkit + define-cg as-objc-allocation as-objc-allocation-with-retain clean-up-deleted @@ -27,7 +28,8 @@ version-10.7-or-later? version-10.9-or-later? version-10.10-or-later? - version-10.11-or-later?) + version-10.11-or-later? + version-10.13-or-later?) with-autorelease call-with-autorelease define-mz) @@ -36,11 +38,13 @@ (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) (define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices"))) (define appkit-lib (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))) +(define cg-lib (ffi-lib (format "/System/Library/Frameworks/CoreGraphics.framework/CoreGraphics"))) (define-ffi-definer define-cocoa cocoa-lib) (define-ffi-definer define-cf cf-lib) (define-ffi-definer define-appserv appserv-lib) (define-ffi-definer define-appkit appkit-lib) +(define-ffi-definer define-cg cg-lib) (define delete-me null) @@ -92,3 +96,5 @@ (NSAppKitVersionNumber . >= . 1331)) (define (version-10.11-or-later?) (NSAppKitVersionNumber . >= . 1404)) +(define (version-10.13-or-later?) + (NSAppKitVersionNumber . >= . 1561)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/window.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/window.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/window.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/window.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -299,6 +299,8 @@ (define << arithmetic-shift) +(define _ptr-to-id (_ptr i _id)) + (define (do-key-event wxb event self down? mod-change? wheel) (define type (tell #:type _ushort event type)) (define key-down? (= (bitwise-and type #b1111) NSKeyDown)) @@ -319,7 +321,7 @@ (parameterize ([current-insert-text inserted-text] [current-set-mark set-mark]) (let ([array (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event + initWithObjects: #:type _ptr-to-id event count: #:type _NSUInteger 1)]) (tellv self interpretKeyEvents: array) (tellv array release)))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/panel.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/panel.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/panel.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/panel.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,7 +28,8 @@ (define-gtk gtk_event_box_set_visible_window (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) -(define-gtk gtk_widget_get_visible (_fun _GtkWidget -> _gboolean)) +(define-gtk gtk_widget_get_visible (_fun _GtkWidget -> _gboolean) + #:fail (lambda () #f)) (define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/unique.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/unique.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/unique.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/unique.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -98,6 +98,8 @@ (define-gdk g_application_get_is_remote (_fun _GtkApplication -> _gboolean) #:make-fail make-not-available) +(define-gdk g_application_register (_fun _GtkApplication _pointer _pointer -> _gboolean) + #:make-fail make-not-available) (define-gdk g_application_run (_fun _GtkApplication _int (_vector i _string) -> _gboolean) #:make-fail make-not-available) (define-gdk g_application_command_line_get_arguments @@ -123,11 +125,12 @@ (define (do-single-instance/gtk) (define app (gtk_application_new (build-app-name) APPLICATION_HANDLES_COMMAND_LINE)) - (when app + (when (and app + (g_application_register app #f #f)) (define args (for/vector ([i (current-command-line-arguments)]) (path->string (path->complete-path i)))) - (g_application_run app (vector-length args) args) (when (g_application_get_is_remote app) + (g_application_run app (vector-length args) args) (exit 0)) (connect-activate app) (connect-command-line app))) @@ -164,7 +167,7 @@ (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" b)) #\?)))) "")]) (string->bytes/utf-8 - (format "org.racket-lang.~a" + (format "org.racket-lang.u~a" (encode (format "~a~a~a" host path (version))))))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/window.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/window.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/window.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/window.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -890,13 +890,11 @@ (define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) (define (flush-display) (try-to-sync-refresh) - (gdk_window_process_all_updates) (gdk_display_flush (gdk_display_get_default))) (define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) (define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) (define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void)) -(define-gdk gdk_window_process_all_updates (_fun -> _void)) (define-gdk gdk_window_ensure_native (_fun _GdkWindow -> _gboolean) ;; Requires 2.18 #:fail (lambda () (lambda (win) #f))) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2963,7 +2963,7 @@ (+ p (snip->count snip))) ;; found the right snip (let ([s-pos p] - [p (+ p (do-find-position-in-snip dc X topy snip x how-close-box))]) + [p (+ p (do-find-position-in-snip dc X topy snip x how-close-box w))]) (set! write-locked? wl?) (set! flow-locked? fl?) (values snip s-pos p)))))))))]) @@ -3025,7 +3025,8 @@ [maybe-box? [how-close #f]]) (do-find-position-in-line #f i x ateol? onit? how-close)) - (define/private (do-find-position-in-snip dc X Y snip x how-close) + ;; snip-width : (or/c real? #f) -- only #f when how-close is also #f. + (define/private (do-find-position-in-snip dc X Y snip x how-close snip-width) (cond [read-locked? 0] [(x . < . 0) @@ -3037,16 +3038,26 @@ [fl? flow-locked?]) (set! write-locked? #t) (set! flow-locked? #t) - (let ([c (snip->count snip)]) - (if ((send snip partial-offset dc X Y c) . <= . x) - (begin - (when how-close - (set-box! how-close 100.0)) - (set! write-locked? wl?) - (set! flow-locked? fl?) - c) - + (cond + [(= c 1) + (set! write-locked? wl?) + (set! flow-locked? fl?) + (when how-close + (set-box! how-close + (if ((- snip-width x) . < . x) + (- snip-width x) + (- x)))) + 0] + [((send snip partial-offset dc X Y c) . <= . x) + (begin + (when how-close + (set-box! how-close 100.0)) + (set! write-locked? wl?) + (set! flow-locked? fl?) + c)] + + [else ;; binary search for position within snip: (let loop ([range c] [i (quotient c 2)] @@ -3066,7 +3077,7 @@ (- dl x)))) (set! write-locked? wl?) (set! flow-locked? fl?) - (+ i offset))))))))))])) + (+ i offset)))))))])))])) (def/public (find-line [real? y] [maybe-box? [onit? #f]]) (when onit? @@ -4808,7 +4819,7 @@ (let ([_total-width (- _total-width w)]) ;; get best breaking position: ;; (0.1 is hopefully a positive value smaller than any character) - (let ([origc (do-find-position-in-snip dc _total-width Y snip (- maxw _total-width 0.1) #f)]) + (let ([origc (do-find-position-in-snip dc _total-width Y snip (- maxw _total-width 0.1) #f #f)]) ;; get legal breaking position before optimal: (let-boxes ([b (+ p origc 1)]) (find-wordbreak b #f 'line) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/arrow-toggle-snip.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/arrow-toggle-snip.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/arrow-toggle-snip.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/arrow-toggle-snip.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,179 @@ +#lang racket/base +(require racket/class + racket/gui/base) +(provide arrow-toggle-snip%) + +;; arrow-toggle-snip% represents a togglable state, displayed as a right-facing +;; arrow (off or "closed") or a downward-facing arrow (on or "open"). + +;; The size of the arrow is determined by the style (and font) applied to the +;; snip. The arrow is drawn inscribed in a square resting on the baseline, but +;; the snip reports its size (usually) as the same as a capital "X"; this means +;; that the snip should look good next to text (in the same style) no matter +;; whether base-aligned or top-aligned. + +;; ------------------------------------------------------------ +;; Paths and gradients, in terms of 100x100 box + +(define (down-arrow-path scale yb) + (define (tx x) (* scale x)) + (define (ty y) (+ yb (* scale y))) + (define p (new dc-path%)) + (send* p + [move-to (tx 10) (ty 40)] + [line-to (tx 90) (ty 40)] + [line-to (tx 50) (ty 75)] + [line-to (tx 10) (ty 40)] + [close]) + p) + +(define (down-arrow-gradient scale xb yb) + (define (tx x) (+ xb (* scale x))) + (define (ty y) (+ yb (* scale y))) + (new linear-gradient% + [x0 (tx 50)] [y0 (ty 40)] + [x1 (tx 50)] [y1 (ty 75)] + [stops + (list (list 0 (make-object color% 240 240 255)) + (list 1 (make-object color% 128 128 255)))])) + +(define (right-arrow-path scale yb) + (define (tx x) (* scale x)) + (define (ty y) (+ yb (* scale y))) + (define p (new dc-path%)) + (send* p + [move-to (tx 40) (ty 10)] + [line-to (tx 75) (ty 50)] + [line-to (tx 40) (ty 90)] + [line-to (tx 40) (ty 10)] + [close]) + p) + +(define (right-arrow-gradient scale xb yb) + (define (tx x) (+ xb (* scale x))) + (define (ty y) (+ yb (* scale y))) + (new linear-gradient% + [x0 (tx 40)] [y0 (ty 50)] + [x1 (tx 75)] [y1 (ty 50)] + [stops + (list (list 0 (make-object color% 240 240 255)) + (list 1 (make-object color% 128 128 255)))])) + +;; ------------------------------------------------------------ + +(define arrow-toggle-snip% + (class snip% + (inherit get-admin get-flags get-style set-flags set-count) + (init [open? #f]) + (init-field [callback void] + [size #f]) + (field [state (if open? 'down 'up)]) ; (U 'up 'down 'up-click 'down-click) + (super-new) + (set-count 1) + (set-flags (cons 'handles-events (get-flags))) + + (define/override (copy) + (new arrow-toggle-snip% (callback callback) (open? state) (size size))) + + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (define old-brush (send dc get-brush)) + (define old-pen (send dc get-pen)) + (define old-smoothing (send dc get-smoothing)) + (define-values (size dy*) (get-target-size* dc)) + (define scale-factor (/ size 100)) + (define arrow-path + (case state + [(up up-click) (right-arrow-path scale-factor dy*)] + [(down down-click) (down-arrow-path scale-factor dy*)])) + (define arrow-gradient + (case state + [(up up-click) (right-arrow-gradient scale-factor x (+ dy* y))] + [(down down-click) (down-arrow-gradient scale-factor x (+ dy* y))])) + ;; Draw arrow + (send* dc + [set-pen "black" 0 'solid] + [set-brush (new brush% [gradient arrow-gradient])] + [set-smoothing 'aligned] + [draw-path arrow-path x y]) + ;; Restore + (send* dc + [set-brush old-brush] + [set-pen old-pen])) + + (define/override (get-extent dc x y w h descent space lspace rspace) + (define-values (size dy) (get-target-size* dc)) + (set-box/f! descent 0) + (set-box/f! space 0) + (set-box/f! lspace 0) + (set-box/f! rspace 0) + (set-box/f! w size) + (set-box/f! h (+ size dy))) + + ;; get-target-size* : -> (values Real Real) + ;; Returns size of drawn square and dy to drop to baseline so whole + ;; snip takes up same space as "X". (This is a hack because baseline + ;; alignment would cause problems elsewhere.) + (define/private (get-target-size* dc) + (define-values (xw xh xd xa) + (send dc get-text-extent "X" (send (get-style) get-font))) + (let ([size (or size (* xh 0.6))]) + (values size (max 0 (- xh xd size))))) + + (define/override (on-event dc x y editorx editory evt) + (define-values (arrow-snip-width dh) (get-target-size* dc)) + (define arrow-snip-height (+ arrow-snip-width dh)) + (let ([snip-evt-x (- (send evt get-x) x)] + [snip-evt-y (- (send evt get-y) y)]) + (cond + [(send evt button-down? 'left) + (set-state (case state + [(up) 'up-click] + [else 'down-click]))] + [(send evt button-up? 'left) + (cond [(and (<= 0 snip-evt-x arrow-snip-width) + (<= 0 snip-evt-y arrow-snip-height)) + (set-state (case state + [(down down-click) 'up] + [else 'down]))] + [else + (set-state (case state + [(down down-click) 'down] + [else 'up]))])] + [(and (send evt get-left-down) + (send evt dragging?)) + (cond [(and (<= 0 snip-evt-x arrow-snip-width) + (<= 0 snip-evt-y arrow-snip-height)) + (set-state (case state + [(down down-click) 'down-click] + [else 'up-click]))] + [else + (set-state (case state + [(down down-click) 'down] + [else 'up]))])])) + (super on-event dc x y editorx editory evt)) + + (define/public (get-toggle-state) + (case state [(down down-click) #t] [else #f])) + + (define/public (set-toggle-state new-state) + (set-state (if new-state 'down 'up))) + + (define/private (set-state new-state) + (unless (eq? state new-state) + (define old-toggled? (get-toggle-state)) + (set! state new-state) + (let ([admin (get-admin)]) + (when admin + (define-values (size dy) (get-target-size* (send admin get-dc))) + (send admin needs-update this 0 0 size (+ size dy)))) + (define new-toggled? (get-toggle-state)) + (unless (equal? new-toggled? old-toggled?) + (callback new-toggled?)))) + + (define/override (adjust-cursor dc x y editorx editory event) + arrow-snip-cursor) + )) + +(define (set-box/f! b v) (when (box? b) (set-box! b v))) + +(define arrow-snip-cursor (make-object cursor% 'arrow)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/expandable-snip.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/expandable-snip.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/expandable-snip.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/expandable-snip.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,158 @@ +#lang racket/base +(require racket/class + racket/gui/base + "arrow-toggle-snip.rkt") +(provide inherit-styles-editor-snip% + expandable-snip%) + +;; inherit-styles-editor-snip% propagates the style list of its enclosing +;; editor to its own editor. + +(define inherit-styles-editor-snip% + (class editor-snip% + (inherit get-admin get-editor) + (init-field [inherit-styles? #t]) + (super-new) + (define/override (set-admin a) + (super set-admin a) + (define new-admin (get-admin)) + (when (and inherit-styles? new-admin) + (define sl (send (send new-admin get-editor) get-style-list)) + (update-style-list sl))) + ;; hook for additional action on style-list change: + (define/public (update-style-list sl) + (send (get-editor) set-style-list sl)))) + +;; ============================================================ + +;; An expandable snip consists of three parts: an arrow toggle snip, +;; the summary text, and the expanded text. The arrow toggles between +;; closed and open mode. In closed mode, only the toggle snip and +;; summary text are displayed adjacent on a single line. There are two +;; layout options for open mode: +;; - 'append: The first line is unchanged, and the expanded text is +;; displayed on the second line. +;; - 'replace: The summary text is replaced with the expanded text. + +;; expandable-snip% +(define expandable-snip% + (class inherit-styles-editor-snip% + (inherit get-editor + get-admin) + (init [closed-editor (new text%)] + [open-editor (new text%)] + [callback void]) + (init-field [layout 'append]) ;; (U 'replace 'append) + (super-new) + + (field [open? #f]) + + (field [open-es (new editor-snip% (editor open-editor) (with-border? #f))]) + (send open-es set-margin 0 0 0 0) + (send open-es set-inset 0 0 0 0) + + (field [closed-es (new editor-snip% (editor closed-editor) (with-border? #f))]) + (send closed-es set-margin 0 0 0 0) + (send closed-es set-inset 0 0 0 0) + + (let ([outer-t (get-editor)]) + (define (toggle-callback now-open?) + (unless (eq? now-open? open?) + (set! open? now-open?) + (refresh-contents) + (callback now-open?))) + (send* outer-t + [insert (new arrow-toggle-snip% [callback toggle-callback])] + [change-style top-aligned 0 (send outer-t last-position)] + ;; Can't base-align; messes up with 'replace layout + ;; [change-style base-aligned 0 1] + [hide-caret #t] + [lock #t])) + + (define/public (get-open-editor) (send open-es get-editor)) + (define/public (get-closed-editor) (send closed-es get-editor)) + + (define/public (get-open-state) open?) + (define/public (set-open-state v) + (let ([v (and v #t)]) + (unless (eq? open? v) + (set! open? v) + (refresh-contents)))) + + (define/override (update-style-list sl) + (super update-style-list sl) + (define outer-t (get-editor)) + (define standard (send sl find-named-style "Standard")) + (with-unlock outer-t + (send outer-t change-style standard 0 (send outer-t last-position)))) + + ;; if layout is 'replace, editor contains + ;; - open? = #f : [turn-snip][closed-es] + ;; - open? = #t : [turn-snip][open-es] + ;; if layout is 'append, editor contains + ;; - open? = #f : [turn-snip][closed-es] + ;; - open? = #t : [turn-snip][closed-es]\n[open-es] + + (define/private (refresh-contents) + (define outer-t (get-editor)) + (with-unlock outer-t + (send outer-t release-snip closed-es) + (send outer-t release-snip open-es) + (send outer-t delete 1 (send outer-t last-position)) + (when (or (not open?) (eq? layout 'append)) + (send outer-t insert closed-es (send outer-t last-position))) + (when (and open? (eq? layout 'append)) + (send outer-t insert "\n" (send outer-t last-position))) + (when open? + (send outer-t insert open-es (send outer-t last-position))) + (send outer-t change-style top-aligned 0 (send outer-t last-position)))) + + (refresh-contents) + )) + +(define top-aligned (make-object style-delta% 'change-alignment 'top)) +(define base-aligned (make-object style-delta% 'change-alignment 'base)) + +;; (with-unlock text-expression . body) +(define-syntax with-unlock + (syntax-rules () + [(with-unlock text . body) + (let* ([t text] [locked? (send t is-locked?)]) + (dynamic-wind + (lambda () + (send* t + (begin-edit-sequence #f) + (lock #f))) + (lambda () . body) + (lambda () + (send* t + (lock locked?) + (end-edit-sequence)))))])) + +;; ============================================================ + +(module+ main + (provide (all-defined-out)) + (define f (new frame% (label "test") (height 400) (width 600))) + (define t (new text%)) + (define ec (new editor-canvas% (editor t) (parent f))) + (send f show #t) + + (send t insert "Here's what's I'm talking about,\na nice expandable snip: ") + + (define es (new expandable-snip% (with-border? #t) (layout 'append))) + ;;(send es set-margin 0 0 0 0) + + (send* (send es get-closed-editor) + [insert "alphabet"] + ;; [hide-caret #t] + [lock #t]) + + (send* (send es get-open-editor) + [insert "abcdefg\nhijklmno\npqrstuv\nwxyz"] + ;; [hide-caret #t] + [lock #t]) + + (send t insert es) + (send t hide-caret #t) + (send t lock #t)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/hierlist/hierlist-unit.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/hierlist/hierlist-unit.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/hierlist/hierlist-unit.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/hierlist/hierlist-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,6 +3,7 @@ racket/unit mred/mred-sig mrlib/include-bitmap + mrlib/arrow-toggle-snip "hierlist-sig.rkt") ;; Previously was a rename-in from mzlib/list, but @@ -44,95 +45,16 @@ (define arrow-snip-class (make-object snip-class%)) (send arrow-snip-class set-classname "hier-arrow") (define arrow-snip% - (class snip% + (class arrow-toggle-snip% + (inherit get-toggle-state set-toggle-state set-snipclass set-count) (init callback) - (inherit get-admin set-flags get-flags set-count set-snipclass get-style) - (rename-super [super-get-extent get-extent]) - (define size-calculated? #f) - (define size orig-size) - (define width-fraction 1/2) - (define on? #f) - (define click-callback callback) - (define clicked? #f) - (private* - [set-sizes - (lambda (dc) - (let* ([s (get-style)] - [h (send s get-text-height dc)] - [d (send s get-text-descent dc)] - [a (send s get-text-space dc)]) - (set! size (max orig-size (- h d a))) - (set! size-calculated? #t) - (set! arrow-size size)))] - [get-width (lambda () size)] - [get-height (lambda () size)] - [update - (lambda () - (send (get-admin) needs-update this 0 0 (get-width) (get-height)))]) - (override* - [get-extent (lambda (dc x y w h descent space lspace rspace) - (super-get-extent dc x y w h descent space lspace rspace) - (unless size-calculated? (set-sizes dc)) - (when w (set-box! w (get-width))) - (when h (set-box! h (get-height))) - (when descent (set-box! descent 0)) - (when space (set-box! space 0)))] - [partial-offset (lambda (dc x y len) - (unless size-calculated? (set-sizes dc)) - (if (zero? len) - 0 - (get-width)))] - [draw (lambda (dc x y left top right bottom dx dy draw-caret) - (unless size-calculated? (set-sizes dc)) - (let* ([bitmap (if clicked? - (if on? down-click-bitmap up-click-bitmap) - (if on? down-bitmap up-bitmap))] - [bw (send bitmap get-width)] - [bh (send bitmap get-height)]) - (send dc draw-bitmap-section bitmap - (+ x (max 0 (- (/ size 2) (/ bw 2)))) - (+ y (max 0 (- (/ size 2) (/ bh 2)))) - 0 0 (min bw (+ size 2)) (min bh (+ size 2)) - 'solid - (send the-color-database find-color "black") - (send bitmap get-loaded-mask))))] - [size-cache-invalid (lambda () (set! size-calculated? #f))] - [on-event - (lambda (dc x y mediax mediay event) - (let ([in-range? - (and (<= 0 (- (send event get-x) x) (get-width)) - (<= 0 (- (send event get-y) y) (get-height)))]) - (cond - [(send event button-down?) - (when in-range? - (unless clicked? - (set! clicked? #t) - (update)))] - [(send event button-up?) - (when clicked? - (set! clicked? #f) - (update)) - (when in-range? - (on (not on?)) - (click-callback this))] - [(send event dragging?) - (unless (or (and clicked? in-range?) - (and (not clicked?) (not in-range?))) - (set! clicked? (not clicked?)) - (update))] - [else (when clicked? - (set! clicked? #f) - (update))])))] - [copy (lambda () (make-object arrow-snip% click-callback))]) - (public* - [on (case-lambda - [(v) (set! on? v) (update)] - [() on?])]) - - (super-make-object) + (super-new [callback (lambda (new-state) (callback this))] + [size 14]) ;; 14 is close to previous size (set-snipclass arrow-snip-class) - (set-count 1) - (set-flags (cons 'handles-events (get-flags))))) + (define/public on + (case-lambda + [() (get-toggle-state)] + [(v) (set-toggle-state v)])))) ;; Hack to get whitespace matching width of arrow: derive a new ;; class that overrides the `draw' method to do nothing. diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/hierlist.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/hierlist.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/hierlist.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/hierlist.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,7 @@ -#lang scheme/base +#lang racket/base (require mzlib/unit - scheme/gui/base + racket/gui/base "hierlist/hierlist-sig.rkt" "hierlist/hierlist-unit.rkt") @@ -9,29 +9,27 @@ (provide-signature-elements hierlist^) -#| +;; ============================================================ -;; Testing -(define f (make-object frame% "test")) +(module+ demo +(require racket/class) + +(define f (make-object frame% (format "test ~s" (version)))) (define p (make-object horizontal-panel% f)) -(define c (make-object (class hierarchical-list% args - (override - [on-item-opened - (lambda (i) - (let ([f (send i user-data)]) - (when f (f i))))] - [on-select - (lambda (i) - (printf "Selected: ~a\n" - (if i - (send (send i get-editor) get-flattened-text) - i)))] - [on-double-select - (lambda (s) - (printf "Double-click: ~a\n" - (send (send s get-editor) get-flattened-text)))]) - (sequence (apply super-init args))) - p)) +(define c (make-object (class hierarchical-list% + (define/override (on-item-opened i) + (let ([f (send i user-data)]) + (when f (f i)))) + (define/override (on-select i) + (printf "Selected: ~a\n" + (if i + (send (send i get-editor) get-flattened-text) + i))) + (define/override (on-double-select s) + (printf "Double-click: ~a\n" + (send (send s get-editor) get-flattened-text))) + (super-new)) + p)) (define a (send c new-list)) (send (send a get-editor) insert "First Item: List") @@ -58,8 +56,12 @@ (define y (send c new-item)) (send (send y get-editor) insert "y") +(define z (send c new-list)) +(send (send z get-editor) insert "a multi-line\nlabel") +(send (send (send z new-item) get-editor) insert "Sub1") +(send (send (send z new-item) get-editor) insert "Sub2") + (send f show #t) (yield (make-semaphore)) - -|# +) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1098,10 +1098,14 @@ (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) (let ([p (- (make-rectangular dx dy) (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) - (send dc draw-text (text-string np-atomic-shape) - (real-part p) - (imag-part p) - #f 0 θ))))])) + (define-values (x-scale y-scale) (send dc get-scale)) + (define-values (ox oy) (send dc get-origin)) + (send dc set-origin (+ ox (real-part p)) (+ oy (imag-part p))) + (send dc set-scale x-scale (* y-scale (text-y-scale np-atomic-shape))) + (send dc draw-text (text-string np-atomic-shape) + 0 0 #f 0 θ) + (send dc set-scale x-scale y-scale) + (send dc set-origin ox oy))))])) (define (polygon-pulled-points->path pulled-points) (define path (new dc-path%)) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/syntax-browser.rkt racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/syntax-browser.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/mrlib/syntax-browser.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/mrlib/syntax-browser.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,8 +14,8 @@ racket/gui/base racket/match racket/contract - (prefix-in : racket/base) - "include-bitmap.rkt") + (only-in racket/base [read :read]) + "expandable-snip.rkt") (define orig-output-port (current-output-port)) (define (oprintf . args) (apply fprintf orig-output-port args)) @@ -67,7 +67,7 @@ (define-struct range (stx start end)) (define syntax-snip% - (class editor-snip% + (class expandable-snip% (init-field main-stx) (unless (syntax? main-stx) @@ -79,67 +79,11 @@ (define/override (write stream) (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx))))) - (define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx)) - (define output-text (new text:hide-caret/selection%)) (define output-text-filled-in? #f) (define info-text (new text:hide-caret/selection%)) (define info-port (make-text-port info-text)) - (define/private (make-modern text) - (send text change-style - (make-object style-delta% 'change-family 'modern) - 0 - (send text last-position))) - - (define path '()) - (define next-push 0) - (define/private (push!) - (set! path (cons next-push path)) - (set! next-push 0)) - (define/private (pop!) - (set! next-push (+ (car path) 1)) - (set! path (cdr path))) - - (define/private (populate-range-ht) - ;; range-start-ht : hash-table[obj -o> number] - (define range-start-ht (make-hasheq)) - - ;; range-ht : hash-table[obj -o> (listof (cons number number))] - (define range-ht (make-hasheq)) - - (let* ([range-pretty-print-pre-hook - (λ (x port) - (push!) - (let ([stx-object (hash-ref paths-ht path (λ () #f))]) - (hash-set! range-start-ht stx-object (send output-text last-position))))] - [range-pretty-print-post-hook - (λ (x port) - (let ([stx-object (hash-ref paths-ht path (λ () #f))]) - (when stx-object - (let ([range-start (hash-ref range-start-ht stx-object (λ () #f))]) - (when range-start - (hash-set! range-ht - stx-object - (cons - (cons - range-start - (send output-text last-position)) - (hash-ref range-ht stx-object (λ () null)))))))) - (pop!))]) - - ;; reset `path' and `next-push' for use in pp hooks. - (set! path '()) - (set! next-push 0) - (parameterize ([current-output-port (make-text-port output-text)] - [pretty-print-pre-print-hook range-pretty-print-pre-hook] - [pretty-print-post-print-hook range-pretty-print-post-hook] - [pretty-print-columns 30]) - (pretty-print datum) - (make-modern output-text))) - - (values range-start-ht range-ht)) - (define/private (show-info stx) (insert/big "General Info\n") (piece-of-info "Source" (syntax-source stx)) @@ -232,8 +176,7 @@ (send info-text last-position)))) (define/private (insert/big str) - (let ([sd (make-object style-delta% 'change-bold)]) - (send sd set-delta-foreground "Navy") + (let ([sd (make-big-style-delta)]) (let ([pos (send info-text last-position)]) (send info-text insert str (send info-text last-position) @@ -242,6 +185,11 @@ sd pos (send info-text last-position))))) + + (define/private (make-big-style-delta) + (define sd (make-object style-delta% 'change-bold)) + (send sd set-delta-foreground "Navy") + sd) (define/private (optional-newline) (unless (equal? @@ -264,26 +212,63 @@ (make-modern info-text) (send info-text lock #t) (send info-text end-edit-sequence)) - - (define outer-t (new text:hide-caret/selection%)) - (inherit get-admin) - (define/override (set-admin a) - (super set-admin a) - (define new-admin (get-admin)) - (when new-admin - (define sl (send (send new-admin get-editor) get-style-list)) - (send outer-t set-style-list sl) - (define standard (send sl find-named-style "Standard")) - (send outer-t lock #f) - (send outer-t change-style standard 0 (send outer-t last-position)) - (send outer-t lock #t) - (send info-text set-style-list sl) - (send output-text set-style-list sl))) - + ;; ---- + + (inherit show-border set-tight-text-fit) + + (define/override (update-style-list sl) + (super update-style-list sl) + (send summary-t set-style-list sl) + (send inner-t set-style-list sl) + (send info-text set-style-list sl) + (send info-header-t set-style-list sl) + (send info-snip update-style-list sl) + (send output-text set-style-list sl)) + + (define summary-t (new text:hide-caret/selection%)) + (define inner-t (new text:hide-caret/selection%)) + (define info-header-t (new text:hide-caret/selection%)) + + (send summary-t insert (format "~s" main-stx)) + (make-modern summary-t) + + (send info-header-t insert "Syntax Info") + (send info-header-t change-style (make-big-style-delta) + 0 (send info-header-t last-position)) + (make-modern info-header-t) + (send info-header-t lock #t) + (define info-snip (new expandable-snip% + (closed-editor info-header-t) + (open-editor info-text) + (layout 'replace) + (with-border? #t))) + + (send inner-t insert (instantiate editor-snip% () + (editor output-text) + (with-border? #f) + (left-margin 0) + (top-margin 0) + (right-margin 0) + (bottom-margin 0) + (left-inset 0) + (top-inset 0) + (right-inset 0) + (bottom-inset 0))) + (send inner-t insert " ") + (send inner-t insert info-snip) + (send inner-t change-style (make-object style-delta% 'change-alignment 'top) + 0 (send inner-t last-position)) + + (send output-text lock #t) + (send info-text lock #t) + (send inner-t lock #t) + (send summary-t lock #t) + (super-instantiate () - (editor outer-t) (with-border? #f) + (closed-editor summary-t) + (open-editor inner-t) (left-margin 3) (top-margin 0) (right-margin 0) @@ -291,77 +276,20 @@ (left-inset 1) (top-inset 0) (right-inset 0) - (bottom-inset 0)) - - (define inner-t (new text:hide-caret/selection%)) - (define inner-es (instantiate editor-snip% () - (editor inner-t) - (with-border? #f) - (left-margin 0) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 0) - (top-inset 0) - (right-inset 0) - (bottom-inset 0))) - - (define details-shown? #t) - - (inherit show-border set-tight-text-fit) - (define/private (hide-details) - (when details-shown? - (send outer-t lock #f) - (show-border #f) - (set-tight-text-fit #t) - (send outer-t release-snip inner-es) - (send outer-t delete (send outer-t last-position)) - (send outer-t lock #t) - (set! details-shown? #f))) - - (define/private (show-details) - (unless details-shown? - (fill-in-output-text) - (send outer-t lock #f) - (show-border #t) - (set-tight-text-fit #f) - (send outer-t insert #\newline - (send outer-t last-position) - (send outer-t last-position)) - (send outer-t insert inner-es - (send outer-t last-position) - (send outer-t last-position)) - (send outer-t lock #t) - (set! details-shown? #t))) - - (let () - - (send outer-t insert (new turn-snip% - [on-up (λ () (hide-details))] - [on-down (λ () (show-details))])) - (send outer-t insert (format "~s\n" main-stx)) - (send outer-t insert inner-es) - (make-modern outer-t) - - (send inner-t insert (instantiate editor-snip% () - (editor output-text) - (with-border? #f) - (left-margin 0) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 0) - (top-inset 0) - (right-inset 0) - (bottom-inset 0))) - (send inner-t insert (make-object editor-snip% info-text)) - (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)) + (bottom-inset 0) + (callback + (lambda (details-shown?) + (fill-in-output-text) + (show-border details-shown?) + (set-tight-text-fit (not details-shown?))))) (define/private (fill-in-output-text) (unless output-text-filled-in? (set! output-text-filled-in? #t) + (send output-text begin-edit-sequence) (send output-text lock #f) - (define-values (range-start-ht range-ht) (populate-range-ht)) + (define-values (range-start-ht range-ht) + (populate-range-ht main-stx output-text)) (define ranges (sort (apply append @@ -386,18 +314,14 @@ (unless (null? ranges) (let ([rng (car ranges)]) (show-range (range-stx rng) (range-start rng) (range-end rng)))) + (send output-text end-edit-sequence) (send output-text lock #t))) - - (send output-text lock #t) - (send info-text lock #t) - (send inner-t lock #t) - (send outer-t lock #t) - - (hide-details) - + (inherit set-snipclass) (set-snipclass snip-class))) - + +;; ------------------------------------------------------------ + ;; record-paths : val -> hash-table[path -o> syntax-object] (define (syntax-object->datum/record-paths val) (define path '()) @@ -463,6 +387,65 @@ val])) ht))) +;; populate-range-ht : Datum text% +;; -> (values Hash[Datum -> Nat] Hash[Datum -> (listof (cons Nat Nat))]) +(define (populate-range-ht main-stx output-text) + (define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx)) + + ;; range-start-ht : hash-table[obj -o> number] + (define range-start-ht (make-hasheq)) + + ;; range-ht : hash-table[obj -o> (listof (cons number number))] + (define range-ht (make-hasheq)) + + (define path '()) + (define next-push 0) + (define (push!) + (set! path (cons next-push path)) + (set! next-push 0)) + (define (pop!) + (set! next-push (+ (car path) 1)) + (set! path (cdr path))) + + (let* ([range-pretty-print-pre-hook + (λ (x port) + (push!) + (let ([stx-object (hash-ref paths-ht path (λ () #f))]) + (hash-set! range-start-ht stx-object (send output-text last-position))))] + [range-pretty-print-post-hook + (λ (x port) + (let ([stx-object (hash-ref paths-ht path (λ () #f))]) + (when stx-object + (let ([range-start (hash-ref range-start-ht stx-object (λ () #f))]) + (when range-start + (hash-set! range-ht + stx-object + (cons + (cons + range-start + (send output-text last-position)) + (hash-ref range-ht stx-object (λ () null)))))))) + (pop!))]) + + ;; reset `path' and `next-push' for use in pp hooks. + (set! path '()) + (set! next-push 0) + (parameterize ([current-output-port (make-text-port output-text)] + [pretty-print-pre-print-hook range-pretty-print-pre-hook] + [pretty-print-post-print-hook range-pretty-print-post-hook] + [pretty-print-columns 30]) + (pretty-write datum) + (make-modern output-text))) + + (values range-start-ht range-ht)) + +(define (make-modern text) + (send text change-style + (make-object style-delta% 'change-family 'modern) + 0 + (send text last-position))) + + (module+ test (let ([x (datum->syntax #f 'x #f #f)] [y (datum->syntax #f 'y #f #f)]) @@ -488,118 +471,6 @@ (void (send green-style-delta set-delta-foreground "forest green")) (define small-style (make-object style-delta% 'change-size 4)) - (define turn-snip% - (class snip% - - (init-field on-up on-down) - - ;; state : (union 'up 'down 'up-click 'down-click)) - (init-field [state 'up]) - - (define/override (copy) - (instantiate turn-snip% () - (on-up on-up) - (on-down on-down) - (state state))) - - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (let ([bitmap (case state - [(up) up-bitmap] - [(down) down-bitmap] - [(up-click) up-click-bitmap] - [(down-click) down-click-bitmap])]) - (cond - [(send bitmap ok?) - (send dc draw-bitmap bitmap x y)] - [(send dc draw-rectangle x y 10 10) - (send dc drawline x y 10 10)]))) - - - (define/override (get-extent dc x y w h descent space lspace rspace) - (set-box/f! descent 0) - (set-box/f! space 0) - (set-box/f! lspace 0) - (set-box/f! rspace 0) - (set-box/f! w arrow-snip-width) - (set-box/f! h arrow-snip-height)) - - (define/override (on-event dc x y editorx editory evt) - (let ([snip-evt-x (- (send evt get-x) x)] - [snip-evt-y (- (send evt get-y) y)]) - (cond - [(send evt button-down? 'left) - (set-state (case state - [(up) 'up-click] - [(down) 'down-click] - [else 'down-click]))] - [(and (send evt button-up? 'left) - (<= 0 snip-evt-x arrow-snip-width) - (<= 0 snip-evt-y arrow-snip-height)) - (set-state (case state - [(up up-click) - (on-down) - 'down] - [(down down-click) - (on-up) - 'up] - [else 'down]))] - [(send evt button-up? 'left) - (set-state (case state - [(up up-click) 'up] - [(down down-click) 'down] - [else 'up]))] - [(and (send evt get-left-down) - (send evt dragging?) - (<= 0 snip-evt-x arrow-snip-width) - (<= 0 snip-evt-y arrow-snip-height)) - (set-state (case state - [(up up-click) 'up-click] - [(down down-click) 'down-click] - [else 'up-click]))] - [(and (send evt get-left-down) - (send evt dragging?)) - (set-state (case state - [(up up-click) 'up] - [(down down-click) 'down] - [else 'up-click]))] - [else - (super on-event dc x y editorx editory evt)]))) - - (inherit get-admin) - (define/private (set-state new-state) - (unless (eq? state new-state) - (set! state new-state) - (let ([admin (get-admin)]) - (when admin - (send admin needs-update this 0 0 arrow-snip-width arrow-snip-height))))) - - (define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor) - - (super-instantiate ()) - - (inherit get-flags set-flags) - (set-flags (cons 'handles-events (get-flags))))) - - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - - (define down-bitmap (include-bitmap (lib "icons/turn-down.png") 'png)) - (define up-bitmap (include-bitmap (lib "icons/turn-up.png") 'png)) - (define down-click-bitmap (include-bitmap (lib "icons/turn-down-click.png") 'png)) - (define up-click-bitmap (include-bitmap (lib "icons/turn-up-click.png") 'png)) - (define arrow-snip-height - (max 10 - (send up-bitmap get-height) - (send down-bitmap get-height) - (send up-click-bitmap get-height) - (send down-click-bitmap get-height))) - (define arrow-snip-width - (max 10 - (send up-bitmap get-width) - (send down-bitmap get-width) - (send up-click-bitmap get-width) - (send down-click-bitmap get-width))) - (define arrow-snip-cursor (make-object cursor% 'arrow)) - ;; make-text-port : text -> port ;; builds a port from a text object. (define (make-text-port text) diff -Nru racket-6.12+ppa1/share/pkgs/gui-lib/racket/gui/installer.rkt racket-7.0+ppa1/share/pkgs/gui-lib/racket/gui/installer.rkt --- racket-6.12+ppa1/share/pkgs/gui-lib/racket/gui/installer.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-lib/racket/gui/installer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,7 +19,7 @@ (define variants (available-mred-variants)) (define tether-mode (and tethered? (if user? 'addon 'config))) ;; add a gracket-text executable that uses the -z flag (preferring a script) - (for ([vs '((script-3m 3m) (script-cgc cgc))]) + (for ([vs '((script-3m 3m) (script-cgc cgc) (script-cs cs))]) (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) @@ -35,7 +35,7 @@ [single-instance? . #f] [relative? . ,(not (or user? tethered?))])))))) ;; add a bin/gracket (in addition to lib/gracket) - (for ([vs '((script-3m 3m) (script-cgc cgc))]) + (for ([vs '((script-3m 3m) (script-cgc cgc) (script-cs cs))]) (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) diff -Nru racket-6.12+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt racket-7.0+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt 2018-01-26 21:08:20.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "gui-lib" ("string-constants-lib" #:version "1.9")))) (define pkg-desc "implementation (no documentation) part of \"gui-pkg-manager\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "gui-lib" ("string-constants-lib" #:version "1.9")))) (define pkg-desc "implementation (no documentation) part of \"gui-pkg-manager\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp/info.rkt racket-7.0+ppa1/share/pkgs/htdp/info.rkt --- racket-6.12+ppa1/share/pkgs/htdp/info.rkt 2018-01-26 21:08:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("htdp-lib" "htdp-doc"))) (define implies (quote ("htdp-lib" "htdp-doc"))) (define pkg-desc "Teaching languages for _How to Design Programs_") (define pkg-authors (quote (matthias mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("htdp-lib" "htdp-doc"))) (define implies (quote ("htdp-lib" "htdp-doc"))) (define pkg-desc "Teaching languages for _How to Design Programs_") (define pkg-authors (quote (matthias mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-doc/info.rkt racket-7.0+ppa1/share/pkgs/htdp-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/htdp-doc/info.rkt 2018-01-26 21:08:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "at-exp-lib" "draw-lib" "gui-lib" "htdp-lib" "plai" "sandbox-lib" "pict-lib"))) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "compatibility-doc" "draw-doc" "drracket" "gui-doc" "pict-doc" "racket-doc"))) (define update-implies (quote ("htdp-lib"))) (define pkg-desc "documentation part of \"htdp\"") (define pkg-authors (quote (matthias mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "at-exp-lib" "draw-lib" "gui-lib" "htdp-lib" "plai" "sandbox-lib" "pict-lib"))) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "compatibility-doc" "draw-doc" "drracket" "gui-doc" "pict-doc" "racket-doc"))) (define update-implies (quote ("htdp-lib"))) (define pkg-desc "documentation part of \"htdp\"") (define pkg-authors (quote (matthias mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/batch-io.scrbl racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/batch-io.scrbl --- racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/batch-io.scrbl 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/batch-io.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -201,6 +201,9 @@ } ] +@defproc[(file-exists? [f string?]) boolean?]{determines whether a file +with the given name exists in the current directory.} + @(parameterize ([current-directory here]) (with-handlers ([exn:fail:filesystem? void]) (delete-file "output.txt"))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image-guide.scrbl racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image-guide.scrbl --- racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image-guide.scrbl 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image-guide.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -402,7 +402,7 @@ @section[#:tag "nitty-gritty"]{The Nitty Gritty of Pixels, Pens, and Lines} The image library treats coordinates as if they are in the upper-left corner -of each pixel, and infinitesimally small (unlike pixels which have some area). +of each pixel, and infinitesimally small (unlike pixels, which have some area). Thus, when drawing a solid @racket[square] of whose side-length is 10, the image library colors in all of the pixels enclosed by the @racket[square] starting at the upper @@ -422,6 +422,12 @@ Specifically, the upper and left-hand lines around the square are within the bounding box, but the lower and right-hand lines are just outside. +@margin-note{If you are reading along with this section using + @seclink["top" #:doc '(lib "scribblings/drracket/drracket.scrbl")]{DrRacket}, + note that DrRacket clips images to their bounding boxes when rendering them + in the interactions window; read on for the ramifications but know for now that + what you see in the example results here will not be exactly the same as + what you see in the interactions window for that reason.} This kind of rectangle is useful when putting rectangles next to each other and avoiding extra thick lines on the interior. For example, consider building a grid like this: @@ -508,7 +514,7 @@ (rectangle 100 100 'solid (make-color 2 2 2 50)))] To understand why, we must look more carefully at how alpha blending and image equality work. Image equality's definition is straightforward: two images -are equality if they are both drawn the same. That is, image equality +are equal if they are both drawn the same. That is, image equality is defined by simply drawing the two shapes on a white background and then comparing all of the pixels for the two drawings (it is implemented more efficiently in some cases, however). @@ -535,5 +541,5 @@ Going back to the two example rectangles, the drawing library multiplies @code{50/255} by @racket[1] for the first shape and multiplies @code{50/255} by @racket[2] for the second shape (since they -are both drawn on a white background). Then rounds them to integers, which +are both drawn on a white background). Then it rounds them to integers, which results in @racket[0] for both colors, making the images the same. diff -Nru racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/universe.scrbl racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/universe.scrbl --- racket-6.12+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/universe.scrbl 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/universe.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -961,8 +961,9 @@ @item{a number,} @item{a boolean,} @item{a char, or} - @item{a list of S-expressions, or} - @item{a prefab struct of S-expressions.} + @item{a list of S-expressions,} + @item{a prefab struct of S-expressions, or} + @item{a byte string.} ] Note the @racket[list] clause includes @racket[empty] of course. @@ -1243,8 +1244,10 @@ Evaluating a @racket[universe] expression starts a server. Visually it opens a console window on which you can see that worlds join, which messages are - received from which world, and which messages are sent to which world. For - convenience, the console also has two buttons: one for shutting down a + received from which world, and which messages are sent to which world. + Messages that are too long are truncated before they are displayed. + + For convenience, the console also has two buttons: one for shutting down a universe and another one for re-starting it. The latter functionality is especially useful during the integration of the various pieces of a distributed program. diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/batch-io.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/batch-io.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/batch-io.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/batch-io.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,6 +23,9 @@ ;; all reader functions consume the name of a file f: ;; -- f must be a file name (string) in the same folder as the program + ;; String -> Boolean + file-exists? + ;; String -> String ;; read the specified file as a string read-file diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/check-aux.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/check-aux.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/check-aux.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/check-aux.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -94,6 +94,7 @@ (cond [(empty? x) true] [(string? x) true] + [(bytes? x) true] [(symbol? x) true] [(number? x) true] [(boolean? x) true] diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/image-more.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/image-more.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/image-more.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/image-more.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1597,7 +1597,10 @@ (define (freeze/internal x y w h image) (cond - [(or (zero? w) (zero? h)) image] + [(or (zero? w) (zero? h)) + ;; ensures that we never return an image with an embedded `text` in + ;; it which, in turn, guarantees that we can flip the result + (rectangle w h 'solid 'black)] [else (define bm (make-bitmap w h)) (define bdc (make-object bitmap-dc% bm)) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/pad.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/pad.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/pad.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/pad.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,7 @@ ;; provide basic elements for game pad clause in big-bang: the icon, pad-event? -(require racket/runtime-path) +(require mrlib/include-bitmap) (provide ;; bitmap @@ -17,8 +17,7 @@ ;; --------------------------------------------------------------------------------------------------- -(define-runtime-path gamepad-path "gamepad.png") -(define game-pad (read-bitmap gamepad-path 'png/alpha #f #t)) +(define game-pad (include-bitmap "gamepad.png" 'png/alpha)) (unless (send game-pad ok?) (error 'big-bang "the game pad icon isn't available; please report error")) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/universe.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/universe.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/universe.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/universe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -69,12 +69,12 @@ (field [universe - (new checked-cell% - [value0 universe0] - [ok? check-with] - [display (if (string? state) - (and (not (string=? "OliverFlatt" state)) state) - (and state "your server's state"))])]) + (new checked-cell% + [value0 universe0] + [ok? check-with] + [display (if (string? state) + (and (not (string=? "OliverFlatt" state)) state) + (and state "your server's state"))])]) ;; ----------------------------------------------------------------------- ;; dealing with events @@ -90,7 +90,7 @@ (define (handler e) (stop! e)) (with-handlers ([exn? handler]) (define ___ (begin 'dummy body ...)) - (define n (if (object-name name) (object-name name) name)) + (define n (if (object-name name) (object-name name) name)) (define nxt (name (send universe get) a ...)) (cond [(stop-the-world? nxt) (stop! (stop-the-world-world nxt))] @@ -114,7 +114,10 @@ (define n (iworld-name w)) (if (memq w iworlds) (with-handlers ((exn:fail? (lambda (e) (kill w "broadcast failed to ~a")))) - (send gui add (format "-> ~a: ~a" n p)) + (define p-for-display (format "~a" p)) + (if (<= (string-length p-for-display) 100) + (send gui add (format "-> ~a: ~a" n p-for-display)) + (send gui add (format "-> ~a: ~a" n (substring p-for-display 0 99)))) (iworld-send w p)) (send gui add (format "~s not on list" n)))) lm)) @@ -124,7 +127,10 @@ (send gui add (format "~a signed up" (iworld-name iworld)))) (def/cback private (pmsg iworld r) on-msg - (send gui add (format "~a ->: ~a" (iworld-name iworld) r))) + (let ([r-for-display (format "~a" r)]) + (if (<= (string-length r-for-display) 100) + (send gui add (format "~a ->: ~a" (iworld-name iworld) r)) + (send gui add (format "~a ->: ~a" (iworld-name iworld) (substring r-for-display 0 99)))))) (def/cback private (pdisconnect iworld) on-disconnect (kill iworld "~a !! closed port")) @@ -149,11 +155,11 @@ (field [iworlds '()] ;; [Listof World] [gui - (if (and (string? state) (string=? "OliverFlatt" state)) - (new dummy-gui%) - (new gui% - [stop-server (lambda () (stop! (send universe get)))] - [stop-and-restart (lambda () (restart))]))] + (if (and (string? state) (string=? "OliverFlatt" state)) + (new dummy-gui%) + (new gui% + [stop-server (lambda () (stop! (send universe get)))] + [stop-and-restart (lambda () (restart))]))] [dr:custodian (current-custodian)] [the-custodian (make-custodian)]) @@ -192,17 +198,18 @@ (define/private (restart) ;; I am running in a custodian that is about to be killed, ;; so let's switch to one up in the hierarchy - (let ([old-t (current-thread)] - [go (make-semaphore)]) - (parameterize ([current-custodian dr:custodian]) - (thread (lambda () - (sync old-t go) - (start!)))) - (send gui add "stopping the universe") - (send gui add "----------------------------------") - (for-each iworld-close iworlds) - (custodian-shutdown-all the-custodian) - (semaphore-post go))) + [define old-thread (current-thread)] + [define all-done? (make-semaphore)] + (parameterize ([current-custodian dr:custodian]) + (thread + (lambda () + (sync old-thread all-done?) + (start!)))) + (send gui add "stopping the universe") + (send gui add "----------------------------------") + (for-each iworld-close iworlds) + (custodian-shutdown-all the-custodian) + (semaphore-post all-done?)) (define/public (stop! msg) (send gui show #f) @@ -234,25 +241,26 @@ (define-struct iworld (in out name info) #; #:transparent) ;; World = (make-iworld IPort OPort Symbol [Listof Sexp]) -(define (iw* n) (make-iworld (current-input-port) (current-output-port) n '())) -(define iworld1 (iw* "iworld1")) -(define iworld2 (iw* "iworld2")) -(define iworld3 (iw* "iworld3")) - (define (iworld=? u v) (check-arg 'iworld=? (iworld? u) 'iworld "first" u) (check-arg 'iworld=? (iworld? v) 'iworld "second" v) (eq? u v)) -;; IWorld -> Void -(define (iworld-close p) - (close-output-port (iworld-out p)) - (close-input-port (iworld-in p))) +(define (iw* n) (make-iworld (current-input-port) (current-output-port) n '())) +(define iworld1 (iw* "iworld1")) +(define iworld2 (iw* "iworld2")) +(define iworld3 (iw* "iworld3")) ;; IPort OPort Sexp -> IWorld (define (create-iworld i o info) (make-iworld i o info "info field not available")) +;; IWorld -> Void +(define (iworld-close p) + (with-handlers ([exn:fail? void]) + (close-output-port (iworld-out p)) + (close-input-port (iworld-in p)))) + ;; Player S-exp -> Void (define (iworld-send p sexp) (tcp-send (iworld-out p) sexp)) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/world.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/world.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/2htdp/private/world.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/2htdp/private/world.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,7 +9,7 @@ "pad.rkt" (only-in 2htdp/image scale overlay/align rotate empty-image) htdp/error - mzlib/runtime-path + mrlib/include-bitmap mrlib/bitmap-label (only-in mrlib/image-core definitely-same-image?) string-constants @@ -484,12 +484,12 @@ ; (define make-new-world (new-world world%)) ;; ----------------------------------------------------------------------------- -(define-runtime-path break-btn:path '(lib "icons/break.png")) +(define break-btn:bmap (include-bitmap (lib "icons/break.png"))) (define break-button:label - ((bitmap-label-maker (string-constant break-button-label) break-btn:path) '_)) + ((bitmap-label-maker (string-constant break-button-label) break-btn:bmap) '_)) -(define-runtime-path image-button:path '(lib "icons/file.gif")) -(define image-button:label ((bitmap-label-maker "Images" image-button:path) '_)) +(define image-button:bmap (include-bitmap (lib "icons/file.gif"))) +(define image-button:label ((bitmap-label-maker "Images" image-button:bmap) '_)) (define aworld% (class world% diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/info.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/info.rkt 2018-01-26 21:08:28.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.8.0.2") "compatibility-lib" "draw-lib" ("drracket-plugin-lib" #:version "1.1") "errortrace-lib" "html-lib" "images-gui-lib" "images-lib" "net-lib" "pconvert-lib" "plai-lib" "r5rs-lib" "sandbox-lib" "scheme-lib" "scribble-lib" "slideshow-lib" "snip-lib" "srfi-lite-lib" ("string-constants-lib" #:version "1.13") "typed-racket-lib" "typed-racket-more" "web-server-lib" "wxme-lib" ("gui-lib" #:version "1.7") "deinprogramm-signature" "pict-lib"))) (define build-deps (quote ("racket-index" "at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"htdp\"") (define pkg-authors (quote (matthias mflatt robby))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.8.0.2") "compatibility-lib" "draw-lib" ("drracket-plugin-lib" #:version "1.1") "errortrace-lib" "html-lib" "images-gui-lib" "images-lib" "net-lib" "pconvert-lib" "plai-lib" "r5rs-lib" "sandbox-lib" "scheme-lib" "scribble-lib" "slideshow-lib" "snip-lib" "srfi-lite-lib" ("string-constants-lib" #:version "1.13") "typed-racket-lib" "typed-racket-more" "web-server-lib" "wxme-lib" ("gui-lib" #:version "1.7") "deinprogramm-signature" "pict-lib"))) (define build-deps (quote ("racket-index" "at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"htdp\"") (define pkg-authors (quote (matthias mflatt robby))) (define version "1.7"))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,6 +17,7 @@ [beginner-define define] [beginner-define-struct define-struct] [beginner-lambda lambda] + [beginner-lambda λ] [beginner-app #%app] [beginner-top #%top] [beginner-cond cond] diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-beginner.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,6 +23,7 @@ [beginner-define define] [beginner-define-struct define-struct] [beginner-lambda lambda] + [beginner-lambda λ] [beginner-app #%app] [beginner-top #%top] [beginner-cond cond] diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-intermediate.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-intermediate.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-intermediate.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-intermediate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,6 +16,7 @@ [intermediate-define define] [intermediate-define-struct define-struct] [intermediate-pre-lambda lambda] + [intermediate-pre-lambda λ] [intermediate-app #%app] [beginner-top #%top] [intermediate-local local] diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-langs.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-langs.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/htdp-langs.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/htdp-langs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,7 @@ #lang scheme + +(provide tool@) + (require string-constants framework (prefix-in et: errortrace/stacktrace) @@ -37,598 +40,619 @@ build-test-engine) (lib "test-engine/test-display.scm") deinprogramm/signature/signature) + +(require setup/collects) + +(define o (current-output-port)) +(define (oprintf . args) (apply fprintf o args)) - - (provide tool@) - - (define o (current-output-port)) - (define (oprintf . args) (apply fprintf o args)) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define drs-eventspace (current-eventspace)) - - ;; tracing? : boolean - ;; teachpacks : (listof require-spec) - (define-struct (htdp-lang-settings drscheme:language:simple-settings) - (tracing? teachpacks true/false/empty-as-ids?)) - (define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) - (define teachpacks-field-index (+ (procedure-arity drscheme:language:simple-settings) 1)) - - (define image-string "") - - ;; module-based-language-extension : (implements drscheme:language:module-based-language<%>) - ;; -> (implements drscheme:language:module-based-language<%>) - ;; changes the default settings and sets a few more paramters during `on-execute' - (define (module-based-language-extension super%) - (class* super% () - - (inherit get-sharing-printing get-abbreviate-cons-as-list) - - (define/override (default-settings) - (make-htdp-lang-settings - #t - 'constructor - 'repeating-decimal - (get-sharing-printing) - #t - 'none - #f - (preferences:get 'drracket:htdp:last-set-teachpacks/multi-lib) - #f)) - - (define/override (default-settings? s) - (and (super default-settings? s) - (not (htdp-lang-settings-tracing? s)) - (null? (htdp-lang-settings-teachpacks s)) - (not (htdp-lang-settings-true/false/empty-as-ids? s)))) - - (define/override (marshall-settings x) - (list (super marshall-settings x) - (htdp-lang-settings-tracing? x) - (htdp-lang-settings-teachpacks x) - (htdp-lang-settings-true/false/empty-as-ids? x))) - - (define/override (unmarshall-settings x) - (cond - [(and (list? x) - (or (= (length x) 3) - (= (length x) 4)) - (boolean? (list-ref x 1)) - (list-of-require-specs? (list-ref x 2)) - (implies (= (length x) 4) - (boolean? (list-ref x 3)))) - (define drs-settings (super unmarshall-settings (first x))) - (make-htdp-lang-settings - (drscheme:language:simple-settings-case-sensitive drs-settings) - (drscheme:language:simple-settings-printing-style drs-settings) - (drscheme:language:simple-settings-fraction-style drs-settings) - (drscheme:language:simple-settings-show-sharing drs-settings) - (drscheme:language:simple-settings-insert-newlines drs-settings) - (drscheme:language:simple-settings-annotations drs-settings) - (cadr x) - (caddr x) - (if (= (length x) 4) - (list-ref x 3) - #f))] - [else (default-settings)])) - - (define/private (list-of-require-specs? l) - (and (list? l) - (andmap (λ (x) - (and (list? x) - (andmap (λ (x) (or (string? x) (symbol? x))) x))) - l))) - - (inherit get-allow-sharing? get-use-function-output-syntax? - get-accept-quasiquote? get-read-accept-dot) - (define/override (config-panel parent) - (sharing/not-config-panel (get-allow-sharing?) (get-accept-quasiquote?) parent)) - - (define/override (on-execute settings run-in-user-thread) - (let ([drs-namespace (current-namespace)] - [set-result-module-name - ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f #t)] - [scheme-test-module-name - ((current-module-name-resolver) '(lib "test-engine/racket-tests.ss") #f #f #t)] - [scheme-signature-module-name - ((current-module-name-resolver) - '(lib "deinprogramm/signature/signature-english.rkt") #f #f #t)] - [tests-on? (preferences:get 'test-engine:enable?)]) - (run-in-user-thread - (lambda () - (when (getenv "PLTDRHTDPNOCOMPILED") (use-compiled-file-paths '())) - (read-accept-quasiquote (get-accept-quasiquote?)) - (namespace-attach-module drs-namespace ''drscheme-secrets) - (namespace-attach-module drs-namespace set-result-module-name) - (error-display-handler teaching-languages-error-display-handler) - (error-value->string-handler - (λ (x y) (teaching-languages-error-value->string settings x y))) - (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval))) - (error-print-source-location #f) - (read-decimal-as-inexact #f) - (read-accept-dot (get-read-accept-dot)) - (namespace-attach-module drs-namespace scheme-test-module-name) - (namespace-require scheme-test-module-name) - (namespace-attach-module drs-namespace scheme-signature-module-name) - (namespace-require scheme-signature-module-name) - ;; hack: the test-engine code knows about the test~object name; we do, too - (namespace-set-variable-value! 'test~object (build-test-engine)) - ;; record signature violations with the test engine - (signature-violation-proc - (lambda (obj signature message blame) - (cond - ((namespace-variable-value 'test~object #f (lambda () #f)) - => (lambda (engine) - (send (send engine get-info) signature-failed - obj signature message blame)))))) - (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) - (test-execute tests-on?) - (signature-checking-enabled? (get-preference 'signatures:enable-checking? (lambda () #t))) - (test-format (make-formatter (λ (v o) (render-value/format v settings o 40))))))) - (super on-execute settings run-in-user-thread) - - ;; set the global-port-print-handler after the super class because the super sets it too +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define drs-eventspace (current-eventspace)) + + ;; tracing? : boolean + ;; teachpacks : (listof require-spec) + (define-struct (htdp-lang-settings drscheme:language:simple-settings) + (tracing? teachpacks true/false/empty-as-ids?)) + (define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) + (define teachpacks-field-index (+ (procedure-arity drscheme:language:simple-settings) 1)) + + (define image-string "") + + ;; module-based-language-extension : (implements drscheme:language:module-based-language<%>) + ;; -> (implements drscheme:language:module-based-language<%>) + ;; changes the default settings and sets a few more paramters during `on-execute' + (define (module-based-language-extension super%) + (class* super% () + + (inherit get-sharing-printing get-abbreviate-cons-as-list) + + (define/override (default-settings) + (make-htdp-lang-settings + #t + 'constructor + 'repeating-decimal + (get-sharing-printing) + #t + 'none + #f + (preferences:get 'drracket:htdp:last-set-teachpacks/multi-lib) + #f)) + + (define/override (default-settings? s) + (and (super default-settings? s) + (not (htdp-lang-settings-tracing? s)) + (null? (htdp-lang-settings-teachpacks s)) + (not (htdp-lang-settings-true/false/empty-as-ids? s)))) + + (define/override (marshall-settings x) + (list (super marshall-settings x) + (htdp-lang-settings-tracing? x) + (htdp-lang-settings-teachpacks x) + (htdp-lang-settings-true/false/empty-as-ids? x))) + + (define/override (unmarshall-settings x) + (cond + [(and (list? x) + (or (= (length x) 3) + (= (length x) 4)) + (boolean? (list-ref x 1)) + (list-of-require-specs? (list-ref x 2)) + (implies (= (length x) 4) + (boolean? (list-ref x 3)))) + (define drs-settings (super unmarshall-settings (first x))) + (make-htdp-lang-settings + (drscheme:language:simple-settings-case-sensitive drs-settings) + (drscheme:language:simple-settings-printing-style drs-settings) + (drscheme:language:simple-settings-fraction-style drs-settings) + (drscheme:language:simple-settings-show-sharing drs-settings) + (drscheme:language:simple-settings-insert-newlines drs-settings) + (drscheme:language:simple-settings-annotations drs-settings) + (cadr x) + (caddr x) + (if (= (length x) 4) + (list-ref x 3) + #f))] + [else (default-settings)])) + + (define/private (list-of-require-specs? l) + (and (list? l) + (andmap (λ (x) + (and (list? x) + (andmap (λ (x) (or (string? x) (symbol? x))) x))) + l))) + + (inherit get-allow-sharing? get-use-function-output-syntax? + get-accept-quasiquote? get-read-accept-dot) + (define/override (config-panel parent) + (sharing/not-config-panel (get-allow-sharing?) (get-accept-quasiquote?) parent)) + + (define/override (on-execute settings run-in-user-thread) + (let ([drs-namespace (current-namespace)] + [set-result-module-name + ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f #t)] + [scheme-test-module-name + ((current-module-name-resolver) '(lib "test-engine/racket-tests.ss") #f #f #t)] + [scheme-signature-module-name + ((current-module-name-resolver) + '(lib "deinprogramm/signature/signature-english.rkt") #f #f #t)] + [tests-on? (preferences:get 'test-engine:enable?)]) (run-in-user-thread (lambda () - (define my-setup-printing-parameters - (drscheme:language:make-setup-printing-parameters)) - (global-port-print-handler - (λ (value port [depth 0]) - (teaching-language-render-value/format my-setup-printing-parameters - value settings port 'infinity)))))) - - (define/private (teaching-languages-error-value->string settings v len) - (let ([sp (open-output-string)]) - (set-printing-parameters settings (λ () (print v sp))) - (flush-output sp) - (let ([s (get-output-string sp)]) - (cond - [(<= (string-length s) len) s] - [else (string-append (substring s 0 (- len 3)) "...")])))) - - ;; set-printing-parameters : settings ( -> TST) -> TST - ;; is implicitly exposed to the stepper. watch out! -- john - (define/public (set-printing-parameters settings thunk) - (define img-str "#") - (define (is-image? val) - (or (is-a? val ic:image%) ;; 2htdp/image - (is-a? val cache-image-snip%) ;; htdp/image - (is-a? val image-snip%) ;; literal image constant - (is-a? val bitmap%))) ;; works in other places, so include it here too - (define tfe-ids? (htdp-lang-settings-true/false/empty-as-ids? settings)) - (parameterize ([pc:booleans-as-true/false tfe-ids?] - [pc:add-make-prefix-to-constructor #t] - [print-boolean-long-form #t] - [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] - [pc:current-print-convert-hook - (let ([ph (pc:current-print-convert-hook)]) - (lambda (val basic sub) - (cond - [(and (not tfe-ids?) (equal? val '())) ''()] - [(equal? val set!-result) '(void)] - [else (ph val basic sub)])))] - [pretty-print-show-inexactness #t] - [pretty-print-exact-as-decimal #t] - [pretty-print-print-hook - (let ([oh (pretty-print-print-hook)]) - (λ (val display? port) - (if (and (not (port-writes-special? port)) - (is-image? val)) - (begin (display img-str port) - (string-length img-str)) - (oh val display? port))))] - [pretty-print-size-hook - (let ([oh (pretty-print-size-hook)]) - (λ (val display? port) - (if (and (not (port-writes-special? port)) - (is-image? val)) - (string-length img-str) - (oh val display? port))))] - [pc:use-named/undefined-handler - (lambda (x) - (and (get-use-function-output-syntax?) - (procedure? x) - (object-name x)))] - [pc:named/undefined-handler - (lambda (x) - (string->symbol - (format "function:~a" (object-name x))))]) - (thunk))) - - (define/override (render-value/format value settings port width) - (teaching-language-render-value/format drscheme:language:setup-printing-parameters - value settings port width)) - (define/override (render-value value settings port) - (teaching-language-render-value/format drscheme:language:setup-printing-parameters - value settings port 'infinity)) - - (define/private (teaching-language-render-value/format setup-printing-parameters - value settings port width) - ;; set drscheme's printing parameters - (setup-printing-parameters - (λ () - ;; then adjust the settings for the teaching languages - (set-printing-parameters - settings - (λ () - (let-values ([(converted-value write?) - (call-with-values - (lambda () - (drscheme:language:simple-module-based-language-convert-value - value settings)) - (case-lambda - [(converted-value) (values converted-value #t)] - [(converted-value write?) (values converted-value write?)]))]) - (let ([pretty-out (if write? pretty-write pretty-print)]) - (cond - [(drscheme:language:simple-settings-insert-newlines settings) - (if (number? width) - (parameterize ([pretty-print-columns width]) - (pretty-out converted-value port)) - (pretty-out converted-value port))] - [else - (parameterize ([pretty-print-columns 'infinity]) - (pretty-out converted-value port)) - (newline port)])))))) - settings - width)) - - (super-new))) - - ;; sharing/not-config-panel : boolean boolean parent - ;; -> (case-> (-> settings) (settings -> void)) - ;; constructs the config-panel for a language without a sharing option. - (define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent) - (define parent (make-object vertical-panel% _parent)) - (define input-panel (new group-box-panel% - [parent parent] - [label (string-constant input-syntax)] - [alignment '(left center)])) + (when (getenv "PLTDRHTDPNOCOMPILED") (use-compiled-file-paths '())) + (read-accept-quasiquote (get-accept-quasiquote?)) + (namespace-attach-module drs-namespace ''drscheme-secrets) + (namespace-attach-module drs-namespace set-result-module-name) + (error-display-handler teaching-languages-error-display-handler) + (error-value->string-handler + (λ (x y) (teaching-languages-error-value->string settings x y))) + (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval))) + (error-print-source-location #f) + (read-decimal-as-inexact #f) + (read-accept-dot (get-read-accept-dot)) + (namespace-attach-module drs-namespace scheme-test-module-name) + (namespace-require scheme-test-module-name) + (namespace-attach-module drs-namespace scheme-signature-module-name) + (namespace-require scheme-signature-module-name) + ;; hack: the test-engine code knows about the test~object name; we do, too + (namespace-set-variable-value! 'test~object (build-test-engine)) + ;; record signature violations with the test engine + (signature-violation-proc + (lambda (obj signature message blame) + (cond + ((namespace-variable-value 'test~object #f (lambda () #f)) + => (lambda (engine) + (send (send engine get-info) signature-failed + obj signature message blame)))))) + (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) + (test-execute tests-on?) + (signature-checking-enabled? + (get-preference 'signatures:enable-checking? (lambda () #t))) + (test-format (make-formatter (λ (v o) (render-value/format v settings o 40))))))) + (super on-execute settings run-in-user-thread) + + ;; set the global-port-print-handler after the super class because the super sets it too + (run-in-user-thread + (lambda () + (define my-setup-printing-parameters + (drscheme:language:make-setup-printing-parameters)) + (global-port-print-handler + (λ (value port [depth 0]) + (teaching-language-render-value/format my-setup-printing-parameters + value settings port 'infinity)))))) + + (define/private (teaching-languages-error-value->string settings v len) + (let ([sp (open-output-string)]) + (set-printing-parameters settings (λ () (print v sp))) + (flush-output sp) + (let ([s (get-output-string sp)]) + (cond + [(<= (string-length s) len) s] + [else (string-append (substring s 0 (- len 3)) "...")])))) + + ;; set-printing-parameters : settings ( -> TST) -> TST + ;; is implicitly exposed to the stepper. watch out! -- john + (define/public (set-printing-parameters settings thunk) + (define img-str "#") + (define (is-image? val) + (or (is-a? val ic:image%) ;; 2htdp/image + (is-a? val cache-image-snip%) ;; htdp/image + (is-a? val image-snip%) ;; literal image constant + (is-a? val bitmap%))) ;; works in other places, so include it here too + (define tfe-ids? (htdp-lang-settings-true/false/empty-as-ids? settings)) + (parameterize ([pc:booleans-as-true/false tfe-ids?] + [pc:add-make-prefix-to-constructor #t] + [print-boolean-long-form #t] + [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] + [pc:current-print-convert-hook + (let ([ph (pc:current-print-convert-hook)]) + (lambda (val basic sub) + (cond + [(and (not tfe-ids?) (equal? val '())) ''()] + [(equal? val set!-result) '(void)] + [(signature? val) + (or (signature-name val) + ')] + [(bytes? val) + (if (< (bytes-length val) 100) + val + (bytes-append (subbytes val 0 99) #"... truncated"))] + [else (ph val basic sub)])))] + [pretty-print-show-inexactness #t] + [pretty-print-exact-as-decimal #t] + [pretty-print-print-hook + (let ([oh (pretty-print-print-hook)]) + (λ (val display? port) + (if (and (not (port-writes-special? port)) + (is-image? val)) + (begin (display img-str port) + (string-length img-str)) + (oh val display? port))))] + [pretty-print-size-hook + (let ([oh (pretty-print-size-hook)]) + (λ (val display? port) + (if (and (not (port-writes-special? port)) + (is-image? val)) + (string-length img-str) + (oh val display? port))))] + [pc:use-named/undefined-handler + (lambda (x) + (and (get-use-function-output-syntax?) + (procedure? x) + (object-name x)))] + [pc:named/undefined-handler + (lambda (x) + (string->symbol + (format "function:~a" (object-name x))))]) + (thunk))) + + (define/override (render-value/format value settings port width) + (teaching-language-render-value/format drscheme:language:setup-printing-parameters + value settings port width)) + (define/override (render-value value settings port) + (teaching-language-render-value/format drscheme:language:setup-printing-parameters + value settings port 'infinity)) + + (define/private (teaching-language-render-value/format setup-printing-parameters + value settings port width) + ;; set drscheme's printing parameters + (setup-printing-parameters + (λ () + ;; then adjust the settings for the teaching languages + (set-printing-parameters + settings + (λ () + (let-values ([(converted-value write?) + (call-with-values + (lambda () + (drscheme:language:simple-module-based-language-convert-value + value settings)) + (case-lambda + [(converted-value) (values converted-value #t)] + [(converted-value write?) (values converted-value write?)]))]) + (let ([pretty-out (if write? pretty-write pretty-print)]) + (cond + [(drscheme:language:simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-out converted-value port)) + (pretty-out converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-out converted-value port)) + (newline port)])))))) + settings + width)) + + (super-new))) + + ;; sharing/not-config-panel : boolean boolean parent + ;; -> (case-> (-> settings) (settings -> void)) + ;; constructs the config-panel for a language without a sharing option. + (define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent) + (define parent (make-object vertical-panel% _parent)) + (define input-panel (new group-box-panel% + [parent parent] + [label (string-constant input-syntax)] + [alignment '(left center)])) - (define output-panel (new group-box-panel% - [parent parent] - [label (string-constant output-syntax)] - [alignment '(left center)])) + (define output-panel (new group-box-panel% + [parent parent] + [label (string-constant output-syntax)] + [alignment '(left center)])) - (define tp-group-box (new group-box-panel% - [label (string-constant teachpacks)] - [parent parent] - [alignment '(center top)])) - (define tp-panel (new vertical-panel% - [parent tp-group-box] - [alignment '(center center)] - [stretchable-width #f] - [stretchable-height #f])) + (define tp-group-box (new group-box-panel% + [label (string-constant teachpacks)] + [parent parent] + [alignment '(center top)])) + (define tp-panel (new vertical-panel% + [parent tp-group-box] + [alignment '(center center)] + [stretchable-width #f] + [stretchable-height #f])) - (define case-sensitive (make-object check-box% - (string-constant case-sensitive-label) - input-panel - void)) - (define insert-newlines (new check-box% - [label (string-constant use-pretty-printer-label)] - [parent output-panel] - [callback void])) - (define tracing (new check-box% - [parent output-panel] - [label (string-constant tracing-enable-tracing)] - [callback void])) - - (define radiobox-parent-panel (new vertical-panel% - [parent output-panel] - [stretchable-height #f])) - (define radiobox-labels '()) - (define (mk-radiobox label choices) - (define hp (new horizontal-panel% - [parent radiobox-parent-panel] - [stretchable-height #f])) - (new horizontal-panel% [parent hp] [stretchable-width #t]) - (set! radiobox-labels (cons (new message% [label label] [parent hp]) - radiobox-labels)) - (new radio-box% - [label #f] - [parent hp] - [choices choices])) - - (define output-style (mk-radiobox - (string-constant output-style-label) - (if accept-quasiquote? - (list (string-constant constructor-printing-style) - (string-constant quasiquote-printing-style) - (string-constant write-printing-style)) - (list (string-constant constructor-printing-style) - (string-constant write-printing-style))))) - (define output-tfe (mk-radiobox - (string-constant true-false-empty-style-label) - (list (string-constant true-false-empty-style-read) - (string-constant true-false-empty-style-ids)))) - (define fraction-style - (mk-radiobox (string-constant fraction-style) - (list (string-constant use-mixed-fractions) - (string-constant use-repeating-decimals)))) - - (define show-sharing #f) - - (define (get-biggest-width lst) - (for/fold ([s 0]) - ([lab (in-list lst)]) - (define-values (w h) (send lab get-graphical-min-size)) - (max w s))) - - (let* ([rbs (list output-style output-tfe fraction-style)] - [min-width (get-biggest-width rbs)]) - (for ([par (in-list rbs)]) - (send par min-width min-width))) + (define case-sensitive (make-object check-box% + (string-constant case-sensitive-label) + input-panel + void)) + (define insert-newlines (new check-box% + [label (string-constant use-pretty-printer-label)] + [parent output-panel] + [callback void])) + (define tracing (new check-box% + [parent output-panel] + [label (string-constant tracing-enable-tracing)] + [callback void])) + + (define radiobox-parent-panel (new vertical-panel% + [parent output-panel] + [stretchable-height #f])) + (define radiobox-labels '()) + (define (mk-radiobox label choices) + (define hp (new horizontal-panel% + [parent radiobox-parent-panel] + [stretchable-height #f])) + (new horizontal-panel% [parent hp] [stretchable-width #t]) + (set! radiobox-labels (cons (new message% [label label] [parent hp]) + radiobox-labels)) + (new radio-box% + [label #f] + [parent hp] + [choices choices])) + + (define output-style (mk-radiobox + (string-constant output-style-label) + (if accept-quasiquote? + (list (string-constant constructor-printing-style) + (string-constant quasiquote-printing-style) + (string-constant write-printing-style)) + (list (string-constant constructor-printing-style) + (string-constant write-printing-style))))) + (define output-tfe (mk-radiobox + (string-constant true-false-empty-style-label) + (list (string-constant true-false-empty-style-read) + (string-constant true-false-empty-style-ids)))) + (define fraction-style + (mk-radiobox (string-constant fraction-style) + (list (string-constant use-mixed-fractions) + (string-constant use-repeating-decimals)))) + + (define show-sharing #f) + + (define (get-biggest-width lst) + (for/fold ([s 0]) + ([lab (in-list lst)]) + (define-values (w h) (send lab get-graphical-min-size)) + (max w s))) + + (let* ([rbs (list output-style output-tfe fraction-style)] + [min-width (get-biggest-width rbs)]) + (for ([par (in-list rbs)]) + (send par min-width min-width))) - (define tps '()) + (define tps '()) - (when allow-sharing-config? - (set! show-sharing - (new check-box% - [parent output-panel] - [label (string-constant sharing-printing-label)] - [callback void]))) + (when allow-sharing-config? + (set! show-sharing + (new check-box% + [parent output-panel] + [label (string-constant sharing-printing-label)] + [callback void]))) - ;; set the characteristics of the GUI - (send _parent set-alignment 'center 'center) - (send parent stretchable-height #f) - (send parent stretchable-width #f) - (send parent set-alignment 'center 'center) + ;; set the characteristics of the GUI + (send _parent set-alignment 'center 'center) + (send parent stretchable-height #f) + (send parent stretchable-width #f) + (send parent set-alignment 'center 'center) - (case-lambda - [() - (make-htdp-lang-settings - (send case-sensitive get-value) - (if accept-quasiquote? - (case (send output-style get-selection) - [(0) 'constructor] - [(1) 'quasiquote] - [(2) 'write]) - (case (send output-style get-selection) - [(0) 'constructor] - [(1) 'write])) - (case (send fraction-style get-selection) - [(0) 'mixed-fraction] - [(1) 'repeating-decimal]) - (and allow-sharing-config? (send show-sharing get-value)) - (send insert-newlines get-value) - 'none - (send tracing get-value) - tps - (equal? (send output-tfe get-selection) 1))] - [(settings) - (send case-sensitive set-value - (drscheme:language:simple-settings-case-sensitive settings)) - (send output-style set-selection - (if accept-quasiquote? - (case (drscheme:language:simple-settings-printing-style settings) - [(constructor) 0] - [(quasiquote) 1] - [(print trad-write write) 2]) - (case (drscheme:language:simple-settings-printing-style settings) - [(constructor) 0] - [(quasiquote) 0] - [(print trad-write write) 1]))) - (send fraction-style set-selection - (case (drscheme:language:simple-settings-fraction-style settings) - [(mixed-fraction) 0] - [(repeating-decimal) 1])) - (when allow-sharing-config? - (send show-sharing set-value - (drscheme:language:simple-settings-show-sharing settings))) - (send insert-newlines set-value - (drscheme:language:simple-settings-insert-newlines settings)) - (set! tps (htdp-lang-settings-teachpacks settings)) - (send tp-panel change-children (λ (l) '())) - (if (null? tps) - (new message% - [parent tp-panel] - [label (string-constant teachpacks-none)]) - (for-each - (λ (tp) (new message% - [parent tp-panel] - [label (format "~s" tp)])) - tps)) - (send tracing set-value (htdp-lang-settings-tracing? settings)) - (send output-tfe set-selection - (if (htdp-lang-settings-true/false/empty-as-ids? settings) - 1 - 0)) - (void)])) - - (define simple-htdp-language% - (class* drscheme:language:simple-module-based-language% (htdp-language<%>) - (init-field sharing-printing - abbreviate-cons-as-list - allow-sharing? - manual - reader-module - (use-function-output-syntax? #f) - (accept-quasiquote? #t) - (read-accept-dot #f) - (style-delta #f)) - (define/public (get-sharing-printing) sharing-printing) - (define/public (get-abbreviate-cons-as-list) abbreviate-cons-as-list) - (define/public (get-allow-sharing?) allow-sharing?) - (define/public (get-manual) manual) - (define/public (get-use-function-output-syntax?) use-function-output-syntax?) - (define/public (get-accept-quasiquote?) accept-quasiquote?) - (define/public (get-read-accept-dot) read-accept-dot) - ;(define/override (get-one-line-summary) one-line-summary) - (define/public (get-htdp-style-delta) style-delta) - - (super-new [language-url "http://www.htdp.org/"]))) - - (define (language-extension %) - (class % - (inherit get-manual) - - (define/override (extra-repl-information settings port) - (define welcome (drscheme:rep:get-welcome-delta)) - (define (go str sd) - (let* ([s (make-object string-snip% str)] - [sl (editor:get-standard-style-list)] - [std (send sl find-named-style "Standard")] - [style (send sl find-or-create-style std sd)]) - (send s set-style style) - (write-special s port))) + (case-lambda + [() + (make-htdp-lang-settings + (send case-sensitive get-value) + (if accept-quasiquote? + (case (send output-style get-selection) + [(0) 'constructor] + [(1) 'quasiquote] + [(2) 'write]) + (case (send output-style get-selection) + [(0) 'constructor] + [(1) 'write])) + (case (send fraction-style get-selection) + [(0) 'mixed-fraction] + [(1) 'repeating-decimal]) + (and allow-sharing-config? (send show-sharing get-value)) + (send insert-newlines get-value) + 'none + (send tracing get-value) + tps + (equal? (send output-tfe get-selection) 1))] + [(settings) + (send case-sensitive set-value + (drscheme:language:simple-settings-case-sensitive settings)) + (send output-style set-selection + (if accept-quasiquote? + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 1] + [(print trad-write write) 2]) + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 0] + [(print trad-write write) 1]))) + (send fraction-style set-selection + (case (drscheme:language:simple-settings-fraction-style settings) + [(mixed-fraction) 0] + [(repeating-decimal) 1])) + (when allow-sharing-config? + (send show-sharing set-value + (drscheme:language:simple-settings-show-sharing settings))) + (send insert-newlines set-value + (drscheme:language:simple-settings-insert-newlines settings)) + (set! tps (htdp-lang-settings-teachpacks settings)) + (send tp-panel change-children (λ (l) '())) + (if (null? tps) + (new message% + [parent tp-panel] + [label (string-constant teachpacks-none)]) + (for-each + (λ (tp) (new message% + [parent tp-panel] + [label (format "~s" tp)])) + tps)) + (send tracing set-value (htdp-lang-settings-tracing? settings)) + (send output-tfe set-selection + (if (htdp-lang-settings-true/false/empty-as-ids? settings) + 1 + 0)) + (void)])) + + (define simple-htdp-language% + (class* drscheme:language:simple-module-based-language% (htdp-language<%>) + (init-field sharing-printing + abbreviate-cons-as-list + allow-sharing? + manual + reader-module + (use-function-output-syntax? #f) + (accept-quasiquote? #t) + (read-accept-dot #f) + (style-delta #f)) + (define/public (get-sharing-printing) sharing-printing) + (define/public (get-abbreviate-cons-as-list) abbreviate-cons-as-list) + (define/public (get-allow-sharing?) allow-sharing?) + (define/public (get-manual) manual) + (define/public (get-use-function-output-syntax?) use-function-output-syntax?) + (define/public (get-accept-quasiquote?) accept-quasiquote?) + (define/public (get-read-accept-dot) read-accept-dot) + ;(define/override (get-one-line-summary) one-line-summary) + (define/public (get-htdp-style-delta) style-delta) + + (super-new [language-url "http://www.htdp.org/"]))) + + (define (language-extension %) + (class % + (inherit get-manual) + + (define/override (extra-repl-information settings port) + (define welcome (drscheme:rep:get-welcome-delta)) + (define (go str sd) + (let* ([s (make-object string-snip% str)] + [sl (editor:get-standard-style-list)] + [std (send sl find-named-style "Standard")] + [style (send sl find-or-create-style std sd)]) + (send s set-style style) + (write-special s port))) - (define tps (htdp-lang-settings-teachpacks settings)) + (define tps (htdp-lang-settings-teachpacks settings)) - (unless (null? tps) - (go "Teachpack" welcome) + (unless (null? tps) + (go "Teachpack" welcome) + (cond + [(= 1 (length tps)) + (go ": " welcome) + (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta))] + [(= 2 (length tps)) + (go "s: " welcome) + (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta)) + (go " and " welcome) + (go (tp-require->str (cadr tps)) (drscheme:rep:get-dark-green-delta))] + [else + (go "s: " welcome) + (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta)) + (let loop ([these-tps (cdr tps)]) + (cond + [(null? (cdr these-tps)) + (go ", and " welcome) + (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta))] + [else + (go ", " welcome) + (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta)) + (loop (cdr these-tps))]))]) + (go "." welcome) + (newline port))) + + (define/override (first-opened settings) + (define-values (mod name) + (create-empty-module (get-module) + (htdp-lang-settings-teachpacks settings))) + (eval mod) + (dynamic-require `',name #f) + (current-namespace (module->namespace `',name))) + + (define/private (tp-require->str tp) + (match tp + [`(lib ,x) + (define m (regexp-match #rx"teachpack/(2?htdp/(.*))$" x)) + (cond + [m + (define long-name (list-ref m 1)) + (define short-name (list-ref m 2)) + (if (regexp-match #rx"htdp/image[.]" long-name) + long-name + short-name)] + [else (format "~s" tp)])] + [_ (format "~s" tp)])) + + (inherit get-module get-transformer-module get-init-code + use-namespace-require/copy?) + (define/override (create-executable setting parent program-filename) + (let ([dist-filename + (drscheme:language:put-executable + parent program-filename + 'distribution + #t + (string-constant save-a-mred-distribution))]) + (when dist-filename + (drscheme:language:create-distribution-for-executable + dist-filename + #t + (λ (exe-name) + (create-htdp-lang-executable program-filename exe-name reader-module)))))) + + (define/private (symbol-append x y) + (string->symbol + (string-append + (symbol->string x) + (symbol->string y)))) + + (inherit get-htdp-style-delta) + (define/override (get-style-delta) + (get-htdp-style-delta)) + + (inherit get-reader set-printing-parameters) + + (define/override (front-end/complete-program port settings) + (expand-teaching-program port + (get-reader) + (get-module) + (htdp-lang-settings-teachpacks settings))) + + (define/override (front-end/interaction port settings) + (let ([t (super front-end/interaction port settings)] + [start? #t] + [done? #f]) + (λ () (cond - [(= 1 (length tps)) - (go ": " welcome) - (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta))] - [(= 2 (length tps)) - (go "s: " welcome) - (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta)) - (go " and " welcome) - (go (tp-require->str (cadr tps)) (drscheme:rep:get-dark-green-delta))] + [start? + (set! start? #f) + #'(#%plain-app reset-tests)] + [done? eof] [else - (go "s: " welcome) - (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta)) - (let loop ([these-tps (cdr tps)]) + (let ([ans (parameterize ([read-accept-lang #f]) + (t))]) (cond - [(null? (cdr these-tps)) - (go ", and " welcome) - (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta))] + [(eof-object? ans) + (set! done? #t) + #`(test)] [else - (go ", " welcome) - (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta)) - (loop (cdr these-tps))]))]) - (go "." welcome) - (newline port))) - - (define/override (first-opened settings) - (define-values (mod name) - (create-empty-module (get-module) - (htdp-lang-settings-teachpacks settings))) - (eval mod) - (dynamic-require `',name #f) - (current-namespace (module->namespace `',name))) - - (define/private (tp-require->str tp) - (match tp - [`(lib ,x) - (define m (regexp-match #rx"teachpack/(2?htdp/(.*))$" x)) - (cond - [m - (define long-name (list-ref m 1)) - (define short-name (list-ref m 2)) - (if (regexp-match #rx"htdp/image[.]" long-name) - long-name - short-name)] - [else (format "~s" tp)])] - [_ (format "~s" tp)])) - - (inherit get-module get-transformer-module get-init-code - use-namespace-require/copy?) - (define/override (create-executable setting parent program-filename) - (let ([dist-filename - (drscheme:language:put-executable - parent program-filename - 'distribution - #t - (string-constant save-a-mred-distribution))]) - (when dist-filename - (drscheme:language:create-distribution-for-executable - dist-filename - #t - (λ (exe-name) - (create-htdp-lang-executable program-filename exe-name reader-module)))))) - - (define/private (symbol-append x y) - (string->symbol - (string-append - (symbol->string x) - (symbol->string y)))) - - (inherit get-htdp-style-delta) - (define/override (get-style-delta) - (get-htdp-style-delta)) - - (inherit get-reader set-printing-parameters) - - (define/override (front-end/complete-program port settings) - (expand-teaching-program port - (get-reader) - (get-module) - (htdp-lang-settings-teachpacks settings))) - - (define/override (front-end/interaction port settings) - (let ([t (super front-end/interaction port settings)] - [start? #t] - [done? #f]) - (λ () - (cond - [start? - (set! start? #f) - #'(#%plain-app reset-tests)] - [done? eof] - [else - (let ([ans (parameterize ([read-accept-lang #f]) - (t))]) - (cond - [(eof-object? ans) - (set! done? #t) - #`(test)] - [else - ans]))])))) - - - (define keywords #f) - (define/augment (capability-value key) - (case key - [(drscheme:autocomplete-words) - (unless keywords - ;; complete with everything, which is wrong .. - (set! keywords (text:get-completions/manuals #f))) - keywords] - [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] - [(drscheme:special:insert-lambda) #f] - [(drscheme:help-context-term) - (let* ([m (get-module)] - [m (and m (pair? m) (pair? (cdr m)) (cadr m))] - [m (and m (regexp-match #rx"^(lang/[^/.]+).ss$" m))] - [m (and m (cadr m))]) - (if m + ans]))])))) + + + (define keywords #f) + (define/augment (capability-value key) + (case key + [(drscheme:autocomplete-words) + (unless keywords + ;; complete with everything, which is wrong .. + (set! keywords (text:get-completions/manuals #f))) + keywords] + [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] + [(drscheme:special:insert-lambda) #f] + [(drscheme:help-context-term) + (let* ([m (get-module)] + [m (and m (pair? m) (pair? (cdr m)) (cadr m))] + [m (and m (regexp-match #rx"^(lang/[^/.]+).ss$" m))] + [m (and m (cadr m))]) + (if m (format "O:{ L:~a T:teachpack T:picturing-programs }" m) (error 'drscheme:help-context-term "internal error: unexpected module spec")))] - [(tests:test-menu tests:dock-menu) #t] - [else (inner (drscheme:language:get-capability-default key) - capability-value - key)])) - - (define htdp-teachpack-callbacks - (drscheme:unit:make-teachpack-callbacks - (λ (settings) - (map (λ (x) (tp-require->str x)) - (htdp-lang-settings-teachpacks settings))) - (λ (settings parent) - (define old-tps (htdp-lang-settings-teachpacks settings)) - (define tp-dirs (list "htdp" "2htdp")) - (define labels (list (string-constant teachpack-pre-installed/htdp) - (string-constant teachpack-pre-installed/2htdp))) - (define tp-syms '(htdp-teachpacks 2htdp-teachpacks)) - (define-values (tp-to-remove tp-to-add) - (get-teachpack-from-user parent tp-dirs labels tp-syms old-tps)) - (define new-tps (let ([removed (if tp-to-remove - (remove tp-to-remove old-tps) - old-tps)]) - (if (or (not tp-to-add) (member tp-to-add old-tps)) - removed - (append removed (list tp-to-add))))) - (when (member tp-to-add old-tps) - (message-box (string-constant drscheme) - (format (string-constant already-added-teachpack) - (tp-require->str tp-to-add)) - #:dialog-mixin frame:focus-table-mixin)) + [(tests:test-menu tests:dock-menu) #t] + [else (inner (drscheme:language:get-capability-default key) + capability-value + key)])) + + (define htdp-teachpack-callbacks + (drscheme:unit:make-teachpack-callbacks + (λ (settings) + (map (λ (x) (tp-require->str x)) + (htdp-lang-settings-teachpacks settings))) + (λ (settings parent) + (define old-tps (htdp-lang-settings-teachpacks settings)) + (define tp-dirs (list "htdp" "2htdp")) + (define labels (list (string-constant teachpack-pre-installed/htdp) + (string-constant teachpack-pre-installed/2htdp))) + (define tp-syms '(htdp-teachpacks 2htdp-teachpacks)) + (define-values (tp-to-remove tp-to-add) + (get-teachpack-from-user parent tp-dirs labels tp-syms old-tps)) + (define new-tps (let ([removed (if tp-to-remove + (remove tp-to-remove old-tps) + old-tps)]) + (if (or (not tp-to-add) (member tp-to-add old-tps)) + removed + (append removed (list tp-to-add))))) + (when (member tp-to-add old-tps) + (message-box (string-constant drscheme) + (format (string-constant already-added-teachpack) + (tp-require->str tp-to-add)) + #:dialog-mixin frame:focus-table-mixin)) + (preferences:set 'drracket:htdp:last-set-teachpacks/multi-lib new-tps) + (make-htdp-lang-settings + (drscheme:language:simple-settings-case-sensitive settings) + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (drscheme:language:simple-settings-annotations settings) + (htdp-lang-settings-tracing? settings) + new-tps + (htdp-lang-settings-true/false/empty-as-ids? settings))) + (λ (settings name) + (let ([new-tps (filter (λ (x) (not (equal? (tp-require->str x) name))) + (htdp-lang-settings-teachpacks settings))]) (preferences:set 'drracket:htdp:last-set-teachpacks/multi-lib new-tps) (make-htdp-lang-settings (drscheme:language:simple-settings-case-sensitive settings) @@ -639,547 +663,533 @@ (drscheme:language:simple-settings-annotations settings) (htdp-lang-settings-tracing? settings) new-tps - (htdp-lang-settings-true/false/empty-as-ids? settings))) - (λ (settings name) - (let ([new-tps (filter (λ (x) (not (equal? (tp-require->str x) name))) - (htdp-lang-settings-teachpacks settings))]) - (preferences:set 'drracket:htdp:last-set-teachpacks/multi-lib new-tps) - (make-htdp-lang-settings - (drscheme:language:simple-settings-case-sensitive settings) - (drscheme:language:simple-settings-printing-style settings) - (drscheme:language:simple-settings-fraction-style settings) - (drscheme:language:simple-settings-show-sharing settings) - (drscheme:language:simple-settings-insert-newlines settings) - (drscheme:language:simple-settings-annotations settings) - (htdp-lang-settings-tracing? settings) - new-tps - (htdp-lang-settings-true/false/empty-as-ids? settings)))) - (λ (settings) - (preferences:set 'drracket:htdp:last-set-teachpacks/multi-lib '()) - (make-htdp-lang-settings - (drscheme:language:simple-settings-case-sensitive settings) - (drscheme:language:simple-settings-printing-style settings) - (drscheme:language:simple-settings-fraction-style settings) - (drscheme:language:simple-settings-show-sharing settings) - (drscheme:language:simple-settings-insert-newlines settings) - (drscheme:language:simple-settings-annotations settings) - (htdp-lang-settings-tracing? settings) - '() - (htdp-lang-settings-true/false/empty-as-ids? settings))))) + (htdp-lang-settings-true/false/empty-as-ids? settings)))) + (λ (settings) + (preferences:set 'drracket:htdp:last-set-teachpacks/multi-lib '()) + (make-htdp-lang-settings + (drscheme:language:simple-settings-case-sensitive settings) + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (drscheme:language:simple-settings-annotations settings) + (htdp-lang-settings-tracing? settings) + '() + (htdp-lang-settings-true/false/empty-as-ids? settings))))) - (inherit-field reader-module) - (define/override (get-reader-module) reader-module) - (define/override (get-metadata modname settings) - (define parsed-tps - (marshall-teachpack-settings - (htdp-lang-settings-teachpacks settings))) - (string-append - (apply string-append - (map (λ (x) (string-append x "\n")) - htdp-save-file-prefix)) - (format "#reader~s~s\n" - reader-module - `((modname ,modname) - (read-case-sensitive - ,(drscheme:language:simple-settings-case-sensitive settings)) - (teachpacks ,parsed-tps) - (htdp-settings - ,(for/vector ([e (in-vector (htdp-lang-settings->vector settings))] - [i (in-naturals)]) - (cond - [(= i teachpacks-field-index) parsed-tps] - [else e]))))))) - - (inherit default-settings) - (define/override (metadata->settings metadata) - (define table (massage-metadata (metadata->table metadata))) - (define ssv (assoc 'htdp-settings table)) - (cond - [ssv - (define settings-list (vector->list (cadr ssv))) - (define settings-list-len (length settings-list)) - (cond - [(or (equal? settings-list-len - (procedure-arity make-htdp-lang-settings)) - (equal? settings-list-len - (- (procedure-arity make-htdp-lang-settings) 1))) - (define new-settings-list - (for/list ([i (in-naturals)] - [e (in-list settings-list)]) - (cond - [(= i teachpacks-field-index) - (unmarshall-teachpack-settings e)] - [else e]))) - (if (= settings-list-len (procedure-arity make-htdp-lang-settings)) - (apply make-htdp-lang-settings new-settings-list) - (apply make-htdp-lang-settings (append new-settings-list '(#f))))] - [else - (default-settings)])] - [else (default-settings)])) - - ;; these are used for the benefit of v5.3.6 and earlier drracket's - ;; specifically, those language doesn't work right with teachpack - ;; paths of the form (lib "a/b/c.rkt"), but they do with ones of the - ;; form (lib "c.rkt" "a" "b"), so we do that conversion here when - ;; sending out a file that might go into 5.3.6. - - (define/private (unmarshall-teachpack-settings obj) - (cond - [(list? obj) - (for/list ([obj (in-list obj)]) - (match obj - [`(lib ,(? string? s1) ,(? string? s2) ...) - `(lib ,(apply string-append (add-between (append s2 (list s1)) "/")))] - [else obj]))] - [else obj])) - - (define/private (marshall-teachpack-settings obj) - (define (has-slashes? s) (regexp-match? #rx"/" s)) - (cond - [(list? obj) - (for/list ([obj (in-list obj)]) - (match obj - [`(lib ,(? (and/c string? has-slashes?) s)) - (define split (regexp-split #rx"/" s)) - `(lib ,(last split) ,@(reverse (cdr (reverse split))))] - [else obj]))] - [else obj])) - - (define/private (massage-metadata md) - (if (and (list? md) - (andmap (λ (x) (and (pair? x) (symbol? (car x)))) md)) - md - '())) - - (define/private (metadata->table metadata) - (with-handlers ((exn:fail:read? (λ (x) #f))) - (let ([p (open-input-string metadata)]) - (regexp-match #rx"\n#reader" p) ;; skip to reader - (read p) ;; skip module - (read p)))) - - (define/override (get-metadata-lines) 3) - - (super-new))) - - - - (define (stepper-settings-language %) - (if (implementation? % stepper-language<%>) - (class* % (stepper-language<%>) - (init-field stepper:supported) - (init-field stepper:enable-let-lifting) - (init-field stepper:show-lambdas-as-lambdas) - (define/override (stepper:supported?) stepper:supported) - (define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting) - (define/override (stepper:show-lambdas-as-lambdas?) stepper:show-lambdas-as-lambdas) - (super-new)) - (class* % () - (init stepper:supported) - (init stepper:enable-let-lifting) - (init stepper:show-lambdas-as-lambdas) - (super-new)))) - - (define (debugger-settings-language %) - (if (implementation? % debugger-language<%>) - (class* % (debugger-language<%>) - (init-field [debugger:supported #f]) - (define/override (debugger:supported?) debugger:supported) - (super-new)) - (class % - (init [debugger:supported #f]) - (super-new)))) - - ;; filter/hide-ids : syntax[list] -> listof syntax - (define (filter/hide-ids ids) - ;; When a `define-values' or `define-syntax' declaration - ;; is macro-generated, if the defined name also originates - ;; from a macro, then the name is hidden to anything - ;; that wasn't generated by the same macro invocation. This - ;; hiding relies on renaming at the symbol level, and it's - ;; exposed by the fact that `syntax-e' of the identifier - ;; returns a different name than `identifier-binding'. - (filter - (lambda (id) - (let ([ib (identifier-binding id)]) - ;; ib should always be a 4-elem list, but - ;; check, just in case: - (or (not (pair? ib)) - (eq? (syntax-e id) - (cadr ib))))) - (syntax->list ids))) + (inherit-field reader-module) + (define/override (get-reader-module) reader-module) + (define/override (get-metadata modname settings) + (define parsed-tps + (marshall-teachpack-settings + (htdp-lang-settings-teachpacks settings))) + (string-append + (apply string-append + (map (λ (x) (string-append x "\n")) + htdp-save-file-prefix)) + (format "#reader~s~s\n" + reader-module + `((modname ,modname) + (read-case-sensitive + ,(drscheme:language:simple-settings-case-sensitive settings)) + (teachpacks ,parsed-tps) + (htdp-settings + ,(for/vector ([e (in-vector (htdp-lang-settings->vector settings))] + [i (in-naturals)]) + (cond + [(= i teachpacks-field-index) parsed-tps] + [else e]))))))) + + (inherit default-settings) + (define/override (metadata->settings metadata) + (define table (massage-metadata (metadata->table metadata))) + (define ssv (assoc 'htdp-settings table)) + (cond + [ssv + (define settings-list (vector->list (cadr ssv))) + (define settings-list-len (length settings-list)) + (cond + [(or (equal? settings-list-len + (procedure-arity make-htdp-lang-settings)) + (equal? settings-list-len + (- (procedure-arity make-htdp-lang-settings) 1))) + (define new-settings-list + (for/list ([i (in-naturals)] + [e (in-list settings-list)]) + (cond + [(= i teachpacks-field-index) + (unmarshall-teachpack-settings e)] + [else e]))) + (if (= settings-list-len (procedure-arity make-htdp-lang-settings)) + (apply make-htdp-lang-settings new-settings-list) + (apply make-htdp-lang-settings (append new-settings-list '(#f))))] + [else + (default-settings)])] + [else (default-settings)])) + + ;; these are used for the benefit of v5.3.6 and earlier drracket's + ;; specifically, those language doesn't work right with teachpack + ;; paths of the form (lib "a/b/c.rkt"), but they do with ones of the + ;; form (lib "c.rkt" "a" "b"), so we do that conversion here when + ;; sending out a file that might go into 5.3.6. + + (define/private (unmarshall-teachpack-settings obj) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? string? s1) ,(? string? s2) ...) + `(lib ,(apply string-append (add-between (append s2 (list s1)) "/")))] + [else obj]))] + [else obj])) + + (define/private (marshall-teachpack-settings obj) + (define (has-slashes? s) (regexp-match? #rx"/" s)) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? (and/c string? has-slashes?) s)) + (define split (regexp-split #rx"/" s)) + `(lib ,(last split) ,@(reverse (cdr (reverse split))))] + [else obj]))] + [else obj])) + + (define/private (massage-metadata md) + (if (and (list? md) + (andmap (λ (x) (and (pair? x) (symbol? (car x)))) md)) + md + '())) + + (define/private (metadata->table metadata) + (with-handlers ((exn:fail:read? (λ (x) #f))) + (let ([p (open-input-string metadata)]) + (regexp-match #rx"\n#reader" p) ;; skip to reader + (read p) ;; skip module + (read p)))) + + (define/override (get-metadata-lines) 3) + + (super-new))) + + + + (define (stepper-settings-language %) + (if (implementation? % stepper-language<%>) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (init-field stepper:enable-let-lifting) + (init-field stepper:show-lambdas-as-lambdas) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting) + (define/override (stepper:show-lambdas-as-lambdas?) stepper:show-lambdas-as-lambdas) + (super-new)) + (class* % () + (init stepper:supported) + (init stepper:enable-let-lifting) + (init stepper:show-lambdas-as-lambdas) + (super-new)))) + + (define (debugger-settings-language %) + (if (implementation? % debugger-language<%>) + (class* % (debugger-language<%>) + (init-field [debugger:supported #f]) + (define/override (debugger:supported?) debugger:supported) + (super-new)) + (class % + (init [debugger:supported #f]) + (super-new)))) + + ;; filter/hide-ids : syntax[list] -> listof syntax + (define (filter/hide-ids ids) + ;; When a `define-values' or `define-syntax' declaration + ;; is macro-generated, if the defined name also originates + ;; from a macro, then the name is hidden to anything + ;; that wasn't generated by the same macro invocation. This + ;; hiding relies on renaming at the symbol level, and it's + ;; exposed by the fact that `syntax-e' of the identifier + ;; returns a different name than `identifier-binding'. + (filter + (lambda (id) + (let ([ib (identifier-binding id)]) + ;; ib should always be a 4-elem list, but + ;; check, just in case: + (or (not (pair? ib)) + (eq? (syntax-e id) + (cadr ib))))) + (syntax->list ids))) - ; - ; - ; - ; ; ; ; - ; ; ; ; - ; ; ; ; - ; ; ;; ;;; ; ;; ;; ; ; ;; ;; ;;; ; ;; ; ;; ;;; ;;; ; ; - ; ;; ; ; ; ;; ; ; ;; ;; ;; ; ; ; ;; ; ;; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; ; ; ; ; ;;;; ; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ;;;;; ;;; ; ; - ; ; - ; ; ; - ; ;;;; - - - ;; this inspector should be powerful enough to see - ;; any structure defined in the user's namespace - (define drscheme-inspector (current-inspector)) - (eval `(,#'module drscheme-secrets mzscheme - (provide drscheme-inspector) - (define drscheme-inspector ,drscheme-inspector))) - (namespace-require ''drscheme-secrets) - - - - ; - ; - ; - ; - ; - ; ; - ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; - ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; - ; - ; - ; - - - - - (define mf-note - (let ([bitmap - (make-object bitmap% - (collection-file-path "mf.gif" "icons"))]) - (and (send bitmap ok?) - (make-object image-snip% bitmap)))) - - ;; teaching-languages-error-display-handler : - ;; (string (union TST exn) -> void) -> string exn -> void - ;; adds in the bug icon, if there are contexts to display - (define (teaching-languages-error-display-handler msg exn) - (if (exn? exn) - (display (get-rewriten-error-message exn) (current-error-port)) - (eprintf "uncaught exception: ~e" exn)) - (eprintf "\n") - - ;; need to flush here so that error annotations inserted in next line - ;; don't get erased if this output were to happen after the insertion - (flush-output (current-error-port)) - + ; + ; + ; + ; ; ; ; + ; ; ; ; + ; ; ; ; + ; ; ;; ;;; ; ;; ;; ; ; ;; ;; ;;; ; ;; ; ;; ;;; ;;; ; ; + ; ;; ; ; ; ;; ; ; ;; ;; ;; ; ; ; ;; ; ;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; ; ; ; ; ;;;; ; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ;;;;; ;;; ; ; + ; ; + ; ; ; + ; ;;;; + + + ;; this inspector should be powerful enough to see + ;; any structure defined in the user's namespace + (define drscheme-inspector (current-inspector)) + (eval `(,#'module drscheme-secrets mzscheme + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) + (namespace-require ''drscheme-secrets) + + + + ; + ; + ; + ; + ; + ; ; + ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; + ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; + ; + ; + ; + + + + + (define mf-note + (let ([bitmap (make-object bitmap% (collection-file-path "mf.gif" "icons"))]) + (and (send bitmap ok?) + (make-object image-snip% bitmap)))) + + ;; teaching-languages-error-display-handler : + ;; (string (union TST exn) -> void) -> string exn -> void + ;; adds in the bug icon, if there are contexts to display + (define (teaching-languages-error-display-handler msg exn) + (if (exn? exn) + (display (get-rewriten-error-message exn) (current-error-port)) + (eprintf "uncaught exception: ~e" exn)) + (eprintf "\n") + + ;; need to flush here so that error annotations inserted in next line + ;; don't get erased if this output were to happen after the insertion + (flush-output (current-error-port)) + + [define rep (drscheme:rep:current-rep)] + (when (and (is-a? rep drscheme:rep:text<%>) (eq? (send rep get-err-port) (current-error-port))) + [define to-highlight + (cond + [(exn:srclocs? exn) ((exn:srclocs-accessor exn) exn)] + [(not (exn? exn)) '()] + [else ; (exn? exn) + + ;; continuation-mark -> boolean? + ;; is tihs a good path for highlighting? + (define (good? mark) + (cond + [(boolean? mark) #f] + [else (define ppath (car mark)) + (or (and (path? ppath) + ;; exclude paths that result from macro expansion, + ;; specifically define-record-procedures + ;; see racket/drracket#157 + ;; MF: I added this as adviced by Mike S., + ;; but I am not sure I need this at all. + (not (let ([rel (path->collects-relative ppath)]) + (and (pair? rel) + (eq? 'collects (car rel)) + (equal? #"lang" (cadr rel)))))) + (symbol? ppath))])) + + [define cms (exn-continuation-marks exn)] + [define lcm (continuation-mark-set->list cms teaching-languages-continuation-mark-key)] + + (cond + [(not lcm) '()] ;; MF: I don't understand how this could possibly hold + [(for/first ((m lcm) #:when (good? m)) (list (apply make-srcloc m))) => values] + [else '()])])] + + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + ;; need to make sure that the user's eventspace is still the same and still running here? + (send rep highlight-errors to-highlight #f)))))) + + ;; with-mark : syntax syntax exact-nonnegative-integer -> syntax + ;; a member of stacktrace-imports^ + ;; guarantees that the continuation marks associated with + ;; teaching-languages-continuation-mark-key are members of the debug-source type + (define (with-mark source-stx expr phase) + [define source (syntax-source source-stx)] + [define line (syntax-line source-stx)] + [define col (syntax-column source-stx)] + [define alpha (syntax-position source-stx)] + [define span (syntax-span source-stx)] + (define delta (- phase base-phase)) + (if (and (or (symbol? source) (path? source)) (number? alpha) (number? span)) + (with-syntax ([expr expr] + [mark (list source line col alpha span)] + [tlcmk teaching-languages-continuation-mark-key] + [wcm (syntax-shift-phase-level #'with-continuation-mark delta)] + [quot (syntax-shift-phase-level #'quote delta)]) + #`(wcm (quot tlcmk) (quot mark) expr)) + expr)) + + (define base-phase (variable-reference->module-base-phase (#%variable-reference))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; profiling infrastructure. Not used. + ;; + + (define profile-key (gensym)) + (define (profiling-enabled) #f) + (define (initialize-profile-point . x) (void)) + (define (register-profile-start . x) #f) + (define (register-profile-done . x) (void)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test coverage + ;; + + (define test-coverage-enabled (make-parameter #t)) + (define current-test-coverage-info (make-thread-cell #f)) + + (define (initialize-test-coverage-point expr) + (unless (thread-cell-ref current-test-coverage-info) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-test-coverage-info ht) (let ([rep (drscheme:rep:current-rep)]) - (when (and (is-a? rep drscheme:rep:text<%>) - (eq? (send rep get-err-port) (current-error-port))) - (let ([to-highlight - (cond - [(exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn)] - [(exn? exn) - (let ([cms (continuation-mark-set->list - (exn-continuation-marks exn) - teaching-languages-continuation-mark-key)]) - (cond - ((not cms) '()) - ((findf (lambda (mark) - (and mark - (or (path? (car mark)) - (symbol? (car mark))))) - cms) - => (lambda (mark) - (apply (lambda (source line col pos span) - (list (make-srcloc source line col pos span))) - mark))) - (else '())))] - [else '()])]) - - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - ;; need to make sure that the user's eventspace is still the same - ;; and still running here? - (send rep highlight-errors to-highlight #f)))))))) - - ;; with-mark : syntax syntax exact-nonnegative-integer -> syntax - ;; a member of stacktrace-imports^ - ;; guarantees that the continuation marks associated with - ;; teaching-languages-continuation-mark-key are members of the debug-source type - (define (with-mark source-stx expr phase) - (let ([source (syntax-source source-stx)] - [line (syntax-line source-stx)] - [col (syntax-column source-stx)] - [start-position (syntax-position source-stx)] - [span (syntax-span source-stx)]) - (if (and (or (symbol? source) (path? source)) - (number? start-position) - (number? span)) - (with-syntax ([expr expr] - [mark (list source line col start-position span)] - [teaching-languages-continuation-mark-key - teaching-languages-continuation-mark-key] - [wcm (syntax-shift-phase-level #'with-continuation-mark - (- phase base-phase))] - [quot (syntax-shift-phase-level #'quote (- phase base-phase))]) - #`(wcm (quot teaching-languages-continuation-mark-key) - (quot mark) - expr)) - expr))) - - (define base-phase - (variable-reference->module-base-phase (#%variable-reference))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; profiling infrastructure. Not used. - ;; - - (define profile-key (gensym)) - (define (profiling-enabled) #f) - (define (initialize-profile-point . x) (void)) - (define (register-profile-start . x) #f) - (define (register-profile-done . x) (void)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test coverage - ;; - - (define test-coverage-enabled (make-parameter #t)) - (define current-test-coverage-info (make-thread-cell #f)) - - (define (initialize-test-coverage-point expr) - (unless (thread-cell-ref current-test-coverage-info) - (let ([ht (make-hasheq)]) - (thread-cell-set! current-test-coverage-info ht) - (let ([rep (drscheme:rep:current-rep)]) - (when rep - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (define sl (editor:get-standard-style-list)) - (define on-s (send sl find-named-style test-coverage-on-style-name)) - (define off-s (send sl find-named-style test-coverage-off-style-name)) - (send rep set-test-coverage-info ht on-s off-s #f)))))))) - (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when ht - (hash-set! ht expr #;(box #f) (mcons #f #f))))) - - (define (test-covered expr) - (let* ([ht (or (thread-cell-ref current-test-coverage-info) - (error 'htdp-langs - "internal-error: no test-coverage table"))] - [v (hash-ref ht expr - (lambda () - (error 'htdp-langs - "internal-error: expression not found: ~.s" - expr)))]) - #; (lambda () (set-box! v #t)) - (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))) + (when rep + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (define sl (editor:get-standard-style-list)) + (define on-s (send sl find-named-style test-coverage-on-style-name)) + (define off-s (send sl find-named-style test-coverage-off-style-name)) + (send rep set-test-coverage-info ht on-s off-s #f)))))))) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when ht + (hash-set! ht expr #;(box #f) (mcons #f #f))))) + + (define (test-covered expr) + (let* ([ht (or (thread-cell-ref current-test-coverage-info) + (error 'htdp-langs + "internal-error: no test-coverage table"))] + [v (hash-ref ht expr + (lambda () + (error 'htdp-langs + "internal-error: expression not found: ~.s" + expr)))]) + #; (lambda () (set-box! v #t)) + (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))) - (define-values/invoke-unit et:stacktrace@ - (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) + (define-values/invoke-unit et:stacktrace@ + (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) - ;; add-annotation : boolean (sexp -> value) -> sexp -> value - ;; adds debugging and test coverage information to `sexp' and calls `oe' - (define (add-annotation tracing? oe) - (let ([teaching-language-eval-handler - (lambda (exp) - (let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))] - [annotated - (if is-compiled? - exp - (let* ([et-annotated (et:annotate-top (expand exp) - (namespace-base-phase))] - [tr-annotated - (if tracing? - (drscheme:tracing:annotate (expand et-annotated)) - et-annotated)]) - tr-annotated))]) - (oe annotated)))]) - teaching-language-eval-handler)) + ;; add-annotation : boolean (sexp -> value) -> sexp -> value + ;; adds debugging and test coverage information to `sexp' and calls `oe' + (define (add-annotation tracing? oe) + (let ([teaching-language-eval-handler + (lambda (exp) + (let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))] + [annotated + (if is-compiled? + exp + (let* ([et-annotated (et:annotate-top (expand exp) + (namespace-base-phase))] + [tr-annotated + (if tracing? + (drscheme:tracing:annotate (expand et-annotated)) + et-annotated)]) + tr-annotated))]) + (oe annotated)))]) + teaching-language-eval-handler)) -; -; -; -; -; ; ;;; ; ; ; ;;; -; ;;; ;;; ;;; ;;; ;;; -; ;;; ;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;; ;; ;;; ;;;; ;;;; ;;; ;; ;;;; ;;; ; -; ;;;;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;; ;;; ;;;; ;;;;;;; ;; ;;; ;;;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;; -; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; -; ;;;;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;;;; ;;;; ;;; ;;; ;;;;;; ;;; -; ;;; ;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; -; ;;; ;;; -; ;;; ;;;;;; -; -; - - - ;; add-htdp-language : (instanceof htdp-language<%>) -> void - (define (add-htdp-language o) - (drscheme:language-configuration:add-language - o - #:allow-executable-creation? #t)) - - (define (phase1) (void)) - - ;; phase2 : -> void - (define (phase2) - (define htdp-language% - (stepper-settings-language - (debugger-settings-language - ((drscheme:language:get-default-mixin) - (language-extension - (drscheme:language:module-based-language->language-mixin - (module-based-language-extension - (drscheme:language:simple-module-based-language->module-based-language-mixin - simple-htdp-language%)))))))) + ; + ; + ; + ; + ; ; ;;; ; ; ; ;;; + ; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;; ;; ;;; ;;;; ;;;; ;;; ;; ;;;; ;;; ; + ; ;;;;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;; ;;; ;;;; ;;;;;;; ;; ;;; ;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;;;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;;;; ;;;; ;;; ;;; ;;;;;; ;;; + ; ;;; ;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; + ; ;;; ;;; + ; ;;; ;;;;;; + ; + ; + + + ;; add-htdp-language : (instanceof htdp-language<%>) -> void + (define (add-htdp-language o) + (drscheme:language-configuration:add-language + o + #:allow-executable-creation? #t)) + + (define (phase1) (void)) + + ;; phase2 : -> void + (define (phase2) + (define htdp-language% + (stepper-settings-language + (debugger-settings-language + ((drscheme:language:get-default-mixin) + (language-extension + (drscheme:language:module-based-language->language-mixin + (module-based-language-extension + (drscheme:language:simple-module-based-language->module-based-language-mixin + simple-htdp-language%)))))))) - (add-htdp-language - (instantiate htdp-language% () - (one-line-summary (string-constant advanced-one-line-summary)) - (module '(lib "lang/htdp-advanced.ss")) - (manual #"advanced") - (language-position - (list (string-constant teaching-languages) - (string-constant how-to-design-programs) - (string-constant advanced-student))) - (language-id "plt:advanced-student") - (language-numbers '(-500 -500 5)) - (sharing-printing #t) - (abbreviate-cons-as-list #t) - (allow-sharing? #t) - (reader-module '(lib "htdp-advanced-reader.ss" "lang")) - (debugger:supported #t) - (stepper:supported #f) - (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #t))) + (add-htdp-language + (instantiate htdp-language% () + (one-line-summary (string-constant advanced-one-line-summary)) + (module '(lib "lang/htdp-advanced.ss")) + (manual #"advanced") + (language-position + (list (string-constant teaching-languages) + (string-constant how-to-design-programs) + (string-constant advanced-student))) + (language-id "plt:advanced-student") + (language-numbers '(-500 -500 5)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "htdp-advanced-reader.ss" "lang")) + (debugger:supported #t) + (stepper:supported #f) + (stepper:enable-let-lifting #t) + (stepper:show-lambdas-as-lambdas #t))) - (add-htdp-language - (instantiate htdp-language% () - (one-line-summary (string-constant intermediate/lambda-one-line-summary)) - (module '(lib "lang/htdp-intermediate-lambda.ss")) - (manual #"intermediate-lambda") - (language-position - (list (string-constant teaching-languages) - (string-constant how-to-design-programs) - (string-constant intermediate-student/lambda))) - (language-id "plt:intermediate-student/lambda") - (style-delta (let ([match (regexp-match-positions - "lambda" - (string-constant intermediate-student/lambda))]) - (if match - (let ([pos (car match)]) - (list (list (make-object style-delta% 'change-family 'modern) - (car pos) - (cdr pos)))) - #f))) - (language-numbers '(-500 -500 4)) - (sharing-printing #f) - (abbreviate-cons-as-list #t) - (allow-sharing? #f) - (reader-module '(lib "htdp-intermediate-lambda-reader.ss" "lang")) - (stepper:supported #t) - (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #t))) + (add-htdp-language + (instantiate htdp-language% () + (one-line-summary (string-constant intermediate/lambda-one-line-summary)) + (module '(lib "lang/htdp-intermediate-lambda.ss")) + (manual #"intermediate-lambda") + (language-position + (list (string-constant teaching-languages) + (string-constant how-to-design-programs) + (string-constant intermediate-student/lambda))) + (language-id "plt:intermediate-student/lambda") + (style-delta (let ([match (regexp-match-positions + "lambda" + (string-constant intermediate-student/lambda))]) + (if match + (let ([pos (car match)]) + (list (list (make-object style-delta% 'change-family 'modern) + (car pos) + (cdr pos)))) + #f))) + (language-numbers '(-500 -500 4)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "htdp-intermediate-lambda-reader.ss" "lang")) + (stepper:supported #t) + (stepper:enable-let-lifting #t) + (stepper:show-lambdas-as-lambdas #t))) - (add-htdp-language - (instantiate htdp-language% () - (one-line-summary (string-constant intermediate-one-line-summary)) - (module '(lib "lang/htdp-intermediate.ss")) - (manual #"intermediate") - (language-position - (list (string-constant teaching-languages) - (string-constant how-to-design-programs) - (string-constant intermediate-student))) - (language-id "plt:intermediate-student") - (language-numbers '(-500 -500 3)) - (sharing-printing #f) - (abbreviate-cons-as-list #t) - (allow-sharing? #f) - (use-function-output-syntax? #t) - (reader-module '(lib "htdp-intermediate-reader.ss" "lang")) - (stepper:supported #t) - (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #f))) + (add-htdp-language + (instantiate htdp-language% () + (one-line-summary (string-constant intermediate-one-line-summary)) + (module '(lib "lang/htdp-intermediate.ss")) + (manual #"intermediate") + (language-position + (list (string-constant teaching-languages) + (string-constant how-to-design-programs) + (string-constant intermediate-student))) + (language-id "plt:intermediate-student") + (language-numbers '(-500 -500 3)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (use-function-output-syntax? #t) + (reader-module '(lib "htdp-intermediate-reader.ss" "lang")) + (stepper:supported #t) + (stepper:enable-let-lifting #t) + (stepper:show-lambdas-as-lambdas #f))) - (add-htdp-language - (instantiate htdp-language% () - (one-line-summary (string-constant beginning/abbrev-one-line-summary)) - (module '(lib "lang/htdp-beginner-abbr.ss")) - (manual #"beginning-abbr") - (language-position - (list (string-constant teaching-languages) - (string-constant how-to-design-programs) - (string-constant beginning-student/abbrev))) - (language-id "plt:beginning-student/abbrev") - (language-numbers '(-500 -500 2)) - (sharing-printing #f) - (abbreviate-cons-as-list #t) - (allow-sharing? #f) - (reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang")) - (stepper:supported #t) - (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #f))) + (add-htdp-language + (instantiate htdp-language% () + (one-line-summary (string-constant beginning/abbrev-one-line-summary)) + (module '(lib "lang/htdp-beginner-abbr.ss")) + (manual #"beginning-abbr") + (language-position + (list (string-constant teaching-languages) + (string-constant how-to-design-programs) + (string-constant beginning-student/abbrev))) + (language-id "plt:beginning-student/abbrev") + (language-numbers '(-500 -500 2)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang")) + (stepper:supported #t) + (stepper:enable-let-lifting #t) + (stepper:show-lambdas-as-lambdas #f))) - (add-htdp-language - (instantiate htdp-language% () - (one-line-summary (string-constant beginning-one-line-summary)) - (module '(lib "lang/htdp-beginner.ss")) - (manual #"beginning") - (language-position - (list (string-constant teaching-languages) - (string-constant how-to-design-programs) - (string-constant beginning-student))) - (language-numbers '(-500 -500 1)) - (language-id "plt:beginning-student") - (sharing-printing #f) - (abbreviate-cons-as-list #f) - (allow-sharing? #f) - (accept-quasiquote? #f) - (reader-module '(lib "htdp-beginner-reader.ss" "lang")) - (stepper:supported #t) - (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #f)))) - - (define test-coverage-on-style-name "plt:htdp:test-coverage-on") - (define test-coverage-off-style-name "plt:htdp:test-coverage-off") - (define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name)) - (define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name)) - - (color-prefs:add-color-scheme-entry test-coverage-on-style-pref - #:style test-coverage-on-style-name - "black" - "white") - (color-prefs:add-color-scheme-entry test-coverage-off-style-pref - #:style test-coverage-off-style-name - "orange" - "indianred" - #:background "black") - (color-prefs:add-to-preferences-panel - "HtDP Languages" - (λ (parent) - (color-prefs:build-color-selection-panel parent - test-coverage-on-style-pref - test-coverage-on-style-name - (string-constant test-coverage-on)) - (color-prefs:build-color-selection-panel parent - test-coverage-off-style-pref - test-coverage-off-style-name - (string-constant test-coverage-off) - #:background? #t))))) + (add-htdp-language + (instantiate htdp-language% () + (one-line-summary (string-constant beginning-one-line-summary)) + (module '(lib "lang/htdp-beginner.ss")) + (manual #"beginning") + (language-position + (list (string-constant teaching-languages) + (string-constant how-to-design-programs) + (string-constant beginning-student))) + (language-numbers '(-500 -500 1)) + (language-id "plt:beginning-student") + (sharing-printing #f) + (abbreviate-cons-as-list #f) + (allow-sharing? #f) + (accept-quasiquote? #f) + (reader-module '(lib "htdp-beginner-reader.ss" "lang")) + (stepper:supported #t) + (stepper:enable-let-lifting #t) + (stepper:show-lambdas-as-lambdas #f)))) + + (define test-coverage-on-style-name "plt:htdp:test-coverage-on") + (define test-coverage-off-style-name "plt:htdp:test-coverage-off") + (define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name)) + (define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name)) + + (color-prefs:add-color-scheme-entry test-coverage-on-style-pref + #:style test-coverage-on-style-name + "black" + "white") + (color-prefs:add-color-scheme-entry test-coverage-off-style-pref + #:style test-coverage-off-style-name + "orange" + "indianred" + #:background "black") + (color-prefs:add-to-preferences-panel + "HtDP Languages" + (λ (parent) + (color-prefs:build-color-selection-panel parent + test-coverage-on-style-pref + test-coverage-on-style-name + (string-constant test-coverage-on)) + (color-prefs:build-color-selection-panel parent + test-coverage-off-style-pref + test-coverage-off-style-name + (string-constant test-coverage-off) + #:background? #t))))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/posn.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/posn.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/posn.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/posn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,6 +4,7 @@ (provide struct:posn make-posn posn? posn-x posn-y set-posn-x! set-posn-y! beginner-posn* + (for-syntax EXPECTED-FUNCTION-NAME) (rename-out (posn posn-id)) (rename-out (posn* posn))) @@ -12,6 +13,9 @@ ; (rename-in lang/prim (first-order->higher-order f2h)) (for-syntax racket/base)) +(define-for-syntax EXPECTED-FUNCTION-NAME + "expected a function after the open parenthesis, but found a structure type (do you mean ~a)") + (define-match-expander posn* ;; the match expander (lambda (stx) @@ -27,9 +31,8 @@ ;; a signature [x (identifier? #'x) #'posn-signature] ;; everything else remains a syntax error - [_ - (let ([stx* (cons #'posn-signature (cdr (syntax-e stx)))]) - (datum->syntax stx stx*))]))) + [(f . x) + (raise-syntax-error #f (format EXPECTED-FUNCTION-NAME "make-posn") #'f)]))) (define-match-expander beginner-posn* ;; the match expander @@ -42,7 +45,8 @@ ;; a signature [x (identifier? #'x) (raise-syntax-error #f "this variable is not defined" stx)] ;; everything else remains a syntax error - [_ (raise-syntax-error #f "this function is not defined" stx)]))) + [(f . x) + (raise-syntax-error #f (format EXPECTED-FUNCTION-NAME "make-posn") #'f)]))) (struct posn (x y) #:mutable @@ -56,4 +60,4 @@ ;; name `make-posn': (define (make-posn x y) (posn x y)) -(define posn-signature (signature (predicate posn?))) +(define posn-signature (signature posn (predicate posn?))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/create-htdp-executable.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/create-htdp-executable.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/create-htdp-executable.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/create-htdp-executable.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,6 +12,7 @@ (define (create-htdp-lang-executable program-filename exe-name reader-module) (create-embedding-executable exe-name + #:aux '((embed-dlls? . #t)) #:modules `((#f ,reader-module) (#f (lib "wxme/read.ss")) (#f (lib "mred/mred.ss")) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/signature-syntax.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/signature-syntax.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/signature-syntax.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/signature-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,6 +13,8 @@ (for-syntax stepper/private/syntax-property) (for-syntax "firstorder.rkt")) +(module+ test (provide signature?)) + (define-for-syntax (phase-lift stx) (with-syntax ((?stx stx)) (with-syntax ((?stx1 (syntax/loc stx #'?stx))) ; attach the occurrence position to the syntax object diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/teach.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/teach.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/lang/private/teach.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/lang/private/teach.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -84,8 +84,9 @@ (define-for-syntax EXPECTED-MATCH-PATTERN "expected a pattern--answer clause after the expression following `match', but nothing's there") +#; (define-for-syntax EXPECTED-FUNCTION-NAME - "expected a function after the open parenthesis, but found a structure name") + "expected a function after the open parenthesis, but found a structure type (do you mean ~a)") (define-for-syntax EXPECTED-MUTABLE "expected a mutable variable after set!, but found a variable that cannot be modified: ~a") @@ -897,7 +898,7 @@ [(getter-id ...) getter-names]) (define defns (quasisyntax/loc stx - (define-values (#,parametric-signature-name def-proc-name ...) + (define-values (#,signature-name #,parametric-signature-name def-proc-name ...) (let () (define-values (type-descriptor raw-constructor @@ -972,13 +973,11 @@ (make-inspector))) #,@(map-with-index (lambda (i name field-name) - (quasisyntax/loc stx - (define #,name - (let ([raw (make-struct-field-accessor + #`(define #,name + (make-struct-field-accessor raw-generic-access #,i - '#,field-name)]) - raw)))) + '#,field-name))) getter-names fields) #,@(map-with-index (lambda (i name field-name) @@ -993,8 +992,8 @@ fields) (define #,predicate-name raw-predicate) (define #,constructor-name raw-constructor) - - (define #,signature-name (signature (predicate raw-predicate))) + + (define #,signature-name (signature #,signature-name (predicate raw-predicate))) #,(if setters? (quasisyntax/loc stx @@ -1022,7 +1021,7 @@ arbs)))) sig)))) - (values #;#,signature-name #,parametric-signature-name proc-name ...))))) + (values #,signature-name #,parametric-signature-name proc-name ...))))) ;; --- IN --- (stepper-syntax-property defns 'stepper-black-box-expr stx))))) ;; -------------------------------------------------------------------------------- @@ -1121,17 +1120,16 @@ [(self . args) (raise-syntax-error #f - EXPECTED-FUNCTION-NAME + (format EXPECTED-FUNCTION-NAME (format "make-~a" (syntax-e #'name_))) stx #'self)] [else (raise-syntax-error #f - (format "structure type; do you mean make-~a" - (syntax-e #'name_)) + (format "structure type; do you mean make-~a" (syntax-e #'name_)) stx stx) - #;#'#,signature-name + #'#,signature-name ]))) ;; support `shared' (make-info (lambda () compile-info))))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,10 @@ Stepper ------- +Changes for 7.0: + +Bug fixes, refactoring. + Changes for 6.12: None. diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -198,8 +198,9 @@ (lambda (exp tail-bound pre-break? procedure-name-info) ;; annotate an exp with a stepper/skipto or stepper-skipto/discard - ;; label - (define (dont-annotate traversal) + ;; label. If force-discard? is true, then we use a discarding + ;; reconstruction regardless of the tag + (define (dont-annotate) ;; mutable, to catch free vars. Mutated several times, we ;; only care about the last. A bit yecchy. (define free-vars-captured #f) @@ -212,7 +213,7 @@ (set! free-vars-captured free-vars) stx)) - (define annotated (skipto/auto exp traversal subterm-recur)) + (define annotated (skipto/auto exp #f subterm-recur)) (vector (wcm-wrap skipto-mark annotated) free-vars-captured)) @@ -676,10 +677,9 @@ free-vars)] [error 'maybe-final-val-wrap "stepper internal error 20080527"])) - (cond [(stepper-syntax-property exp 'stepper-skipto) - (dont-annotate 'rebuild)] - [(stepper-syntax-property exp 'stepper-skipto/discard) - (dont-annotate 'discard)] + (cond [(or (stepper-syntax-property exp 'stepper-skipto) + (stepper-syntax-property exp 'stepper-skipto/discard)) + (dont-annotate)] [(to-be-skipped? exp) (vector (wcm-wrap "supposed to be skipped" exp) null)] @@ -1035,7 +1035,7 @@ #`(begin #,exp (#%plain-app #,(make-opaque-exp-break exp)))] [(stepper-syntax-property exp 'stepper-skipto) - (skipto/auto exp 'rebuild annotate/module-top-level)] + (skipto/auto exp #f annotate/module-top-level)] [else (syntax-case exp (#%app #%plain-app call-with-values define-values define-syntaxes #%require #%provide #%declare begin #%plain-lambda lambda diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/macro-unwind.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/macro-unwind.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/macro-unwind.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/macro-unwind.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -78,7 +78,7 @@ (#%plain-lambda args1 (#%plain-app (#%plain-app proc p) . args2)) . args3) (and (eq? (syntax->datum #'proc) 'extract-if-lazy-proc) - (equal? (syntax->datum (cdr (syntax-e #'args1))) + (equal? (syntax->datum (datum->syntax #f (cdr (syntax-e #'args1)))) (syntax->datum #'args2))) (recur-on-pieces #'args3 settings)] [(#%plain-app exp ...) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/model.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/model.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/model.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/model.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -494,6 +494,7 @@ ;; step through a single expanded expression. (define (step-through-expression expanded) (define annotated (a:annotate expanded break show-lambdas-as-lambdas?)) + (log-stepper-debug "expression successfully annotated") (parameterize (;; I think this parameterization is pointless in the #lang world [test-engine:test-silence #t]) (eval-syntax annotated))) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/reconstruct.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/reconstruct.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/reconstruct.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/reconstruct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -428,7 +428,7 @@ use-lifted-names render-settings)) (skipto/auto expr - 'discard + #t ;; transformer: (lambda (expr) ;; reconstruct the source by attaching the keyword to the result of @@ -659,7 +659,7 @@ (syntax->list #`vars-stx) lifting-indices)]) (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))]) - (let ([exp (skipto/auto exp 'discard (lambda (exp) exp))]) + (let ([exp (skipto/auto exp #t (lambda (exp) exp))]) (cond [(stepper-syntax-property exp 'stepper-black-box-expr) ;; the hint contains the original syntax @@ -699,7 +699,7 @@ (define (reconstruct-top-level source reconstructed) (skipto/auto source - 'discard + #t (lambda (source) (kernel:kernel-syntax-case source #f diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,19 +10,25 @@ "shared-typed.rkt") #;(provide/contract - [skipto/auto (syntax? (symbols 'rebuild 'discard) - (syntax? . -> . syntax?) - . -> . - syntax?)] + [skipto/auto (syntax? + (syntax? syntax? . -> . syntax?) + (syntax? . -> . syntax?) + . -> . + syntax?)] [in-closure-table (-> any/c boolean?)] [attach-info (-> syntax? syntax? syntax?)] [transfer-info (-> syntax? syntax? syntax?)]) (provide - (contract-out [syntax->hilite-datum - ((syntax?) (#:ignore-highlight? boolean?) . ->* . any)] ; sexp with explicit tags - [syntax->interned-datum (-> syntax? any)]) - skipto/auto + (contract-out + [syntax->hilite-datum + ((syntax?) (#:ignore-highlight? boolean?) . ->* . any)] ; sexp with explicit tags + [syntax->interned-datum (-> syntax? any)] + [skipto/auto (-> syntax? boolean? (-> syntax? syntax?) + syntax?)] + [check-path (-> syntax? (listof symbol?) syntax?)] + ) + attach-info transfer-info *unevaluated* @@ -126,29 +132,29 @@ ;; (cons 'both (list trace trace)) ;; null -(define (swap-args 2-arg-fun) - (lambda (x y) - (2-arg-fun y x))) - -(define second-arg (lambda (dc y) y)) - -(define (up-mapping traversal fn) - (unless (symbol? fn) - (error 'up-mapping "expected symbol for stepper traversal, given: ~v" fn)) - (case traversal - [(rebuild) (case fn - [(car) (lambda (stx new) (cons new (cdr stx)))] - [(cdr) (lambda (stx new) (cons (car stx) new))] - [(syntax-e) (swap-args rebuild-stx)] - [(both-l both-r) (lambda (stx a b) (cons a b))] - [else (error 'up-mapping "unexpected symbol in up-mapping (1): ~v" fn)])] - [(discard) (case fn - [(car) second-arg] - [(cdr) second-arg] - [(syntax-e) second-arg] - [(both-l) (lambda (stx a b) a)] - [(both-r) (lambda (stx a b) b)] - [else (error 'up-mapping "unexpected symbol in up-mapping (2): ~v" fn)])])) +;; given a symbol, return the corresponding +;; "rebuilding" outward traversal function +(define (rebuild-up-fn fn) + (case fn + [(car) (λ (stx new) (cons new (cdr stx)))] + [(cdr) (λ (stx new) (cons (car stx) new))] + [(syntax-e) (λ (stx new) (rebuild-stx new stx))] + [(both-l both-r) (lambda (stx a b) (cons a b))] + [else (raise-argument-error 'rebuild-up-fn + "legal traversal symbol" + 0 fn)])) + +;; given a symbol, return the corresponding +;; "discard" outward traversal function +;; (basically, just return (λ (x y) y)) +(define (discard-up-fn fn) + (case fn + [(car cdr syntax-e) (λ (stx new) new)] + [(both-l) (lambda (stx a b) a)] + [(both-r) (lambda (stx a b) b)] + [else (raise-argument-error 'discard-up-fn + "legal traversal symbol" + 0 fn)])) ;; like car, but provide a useful error message if given a non-pair (define (noisy-car arg) @@ -158,34 +164,60 @@ ;; like cdr, but provide a useful error message if given a non-pair (define (noisy-cdr arg) (cond [(pair? arg) (cdr arg)] - [else (raise-argument-error 'noisy-car "pair in syntax traversal" 0 arg)])) + [else (raise-argument-error 'noisy-cdr "pair in syntax traversal" 0 arg)])) ;; like syntax-e, but provide a useful error message if given a non-syntax-object (define (noisy-syntax-e arg) (cond [(syntax? arg) (syntax-e arg)] - [else (raise-argument-error 'noisy-car "syntax object in syntax traversal" 0 arg)])) + [else (raise-argument-error 'noisy-syntax-e "syntax object in syntax traversal" 0 arg)])) ;; map a symbol in '(car cdr syntax-e) to the appropriate projector -(define (down-mapping fn) +(define (down-fn-finder fn) (case fn [(car) noisy-car] [(cdr) noisy-cdr] [(syntax-e) noisy-syntax-e] [else (error 'down-mapping "called on something other than 'car, 'cdr, & 'syntax-e: ~v" fn)])) -(define (update fn-list val fn traversal) - (if (null? fn-list) - (fn val) - (let ([up (up-mapping traversal (car fn-list))]) - (case (car fn-list) - [(both-l both-r) (up val - (update (cadr fn-list) (car val) fn traversal) - (update (caddr fn-list) (cdr val) fn traversal))] - [else (let ([down (down-mapping (car fn-list))]) - (up val (update (cdr fn-list) (down val) fn traversal)))])))) - +;; given a list of traversal symbols[*] and a val and a core-fn and an up-fn-finder, +;; use the traversal symbols to find the target expression, apply the core-fn to +;; it, and the use the up-fn-finder to rebuild the syntax object +;; If the stx is a syntax? object and the fn-list is not empty, infer the +;; existence of a syntax unwrap and re-wrap +;; [*] actually, it can be a tree... it looks like both-l and both-r +;; split annotation into a tree where one path is for the car of the syntax +;; pair and the other is for the cdr. I think this is only used by lazy. +(define (update fn-list stx core-fn up-fn-finder) + (cond + [(null? fn-list) (core-fn stx)] + [else + (define fn (car fn-list)) + ;; NB this is bogus in the case of both-l and both-r: + (define rest-fns (cdr fn-list)) + (cond + [(syntax? stx) + (define up (up-fn-finder 'syntax-e)) + (up stx (update fn-list (syntax-e stx) core-fn up-fn-finder))] + ;; simply ignore the syntax-e symbol + ;; (this clause should not be necessary after the now-obsolete syntax-e label is + ;; removed everywhere): + [(equal? fn 'syntax-e) + (update rest-fns stx core-fn up-fn-finder)] + [(member fn '(both-l both-r)) + (define up (up-fn-finder fn)) + (up stx + (update (cadr fn-list) (car stx) core-fn up-fn-finder) + (update (caddr fn-list) (cdr stx) core-fn up-fn-finder))] + [else + (define up (up-fn-finder fn)) + (define down (down-fn-finder (car fn-list))) + (up stx (update rest-fns (down stx) core-fn up-fn-finder))])])) + +;; for debugging, do the "down" part only +(define (check-path stx fn-list) + (update fn-list stx (λ (x) x) discard-up-fn)) - #;(display (equal? (update '(cdr cdr car both-l (car) (cdr)) +#;(display (equal? (update '(cdr cdr car both-l (car) (cdr)) `(a . (b ((1) c . 2) d)) (lambda (x) (+ x 1)) 'rebuild) @@ -193,26 +225,31 @@ ;; skipto/auto : syntax? -;; (symbols 'rebuild 'discard) +;; (syntax? syntax? . -> . syntax?) ;; (syntax? . -> . syntax?) ;; "skips over" part of a tree to find a subtree indicated by the ;; stepper-skipto property at the root of the tree, and applies ;; the transformer to it. If no stepper-skipto or stepper-skipto/discard ;; property is present, apply the transformer to the whole tree. -;; If the traversal argument is 'rebuild, the -;; result of transformation is embedded again in the same tree. if the -;; traversal argument is 'discard, the result of the transformation is the -;; result of this function -(define (skipto/auto stx traversal transformer) - (cond [(or (stepper-syntax-property stx 'stepper-skipto) - (stepper-syntax-property stx 'stepper-skipto/discard)) - => - (lambda (x) (update x stx - (lambda (y) - (skipto/auto y traversal transformer)) - traversal))] - [else (transformer stx)])) - +;; The rebuild-mapper is used to rebuild the tree (one rebuilder +;; rebuilds the tree, the other just discards the context completely). +(define (skipto/auto stx force-discard? transformer) + (cond + [(stepper-syntax-property stx 'stepper-skipto) + => + (lambda (x) (update x stx + (lambda (stx) + (skipto/auto stx force-discard? transformer)) + (if force-discard? + discard-up-fn + rebuild-up-fn)))] + [(stepper-syntax-property stx 'stepper-skipto/discard) + => + (lambda (x) (update x stx + (lambda (stx) + (skipto/auto stx force-discard? transformer)) + discard-up-fn))] + [else (transformer stx)])) ;; take info from source expressions to reconstructed expressions @@ -364,44 +401,41 @@ (module+ test (require rackunit) - - - (check-equal? (syntax->datum (skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c) 'stepper-skipto - '(syntax-e cdr car))) + '(cdr car))) 'stepper-skipto - '(syntax-e cdr car)) - 'discard + '(cdr car)) + #t (lambda (x) x))) 'c) (define (lifted-name sym) - (syntax->datum (get-lifted-var sym))) -(define cd-stx - (datum->syntax #f 'cd)) - -(check-equal? (lifted-name (datum->syntax #f 'ab)) 'lifter-ab-0) -(check-equal? (lifted-name cd-stx) 'lifter-cd-1) -(check-equal? (lifted-name (datum->syntax #f 'ef)) 'lifter-ef-2) -(check-equal? (lifted-name cd-stx) 'lifter-cd-1) - -(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle))) -(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle #t))) -(check-equal? (stepper-syntax-property #`13 'stepper-hint) #f) -(check-equal? (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) - 'stepper-hint) 'yes) -(check-equal? - (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 - 'stepper-hint - 'no) - 'stepper-hint 'yes) - 'stepper-hint) - 'yes) -(check-equal? (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg) 'stepper-hint) 'yes) -(check-equal? (syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg)) 13) -) + (syntax->datum (get-lifted-var sym))) + (define cd-stx + (datum->syntax #f 'cd)) + + (check-equal? (lifted-name (datum->syntax #f 'ab)) 'lifter-ab-0) + (check-equal? (lifted-name cd-stx) 'lifter-cd-1) + (check-equal? (lifted-name (datum->syntax #f 'ef)) 'lifter-ef-2) + (check-equal? (lifted-name cd-stx) 'lifter-cd-1) + + (check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle))) + (check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle #t))) + (check-equal? (stepper-syntax-property #`13 'stepper-hint) #f) + (check-equal? (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) + 'stepper-hint) 'yes) + (check-equal? + (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 + 'stepper-hint + 'no) + 'stepper-hint 'yes) + 'stepper-hint) + 'yes) + (check-equal? (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg) 'stepper-hint) 'yes) + (check-equal? (syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg)) 13) + ) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/syntax-property.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/syntax-property.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/syntax-property.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/syntax-property.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -69,6 +69,9 @@ stepper-use-val-as-final stepper-lifted-name lazy-op + ;; used temporarily to help locate syntax expressions + ;; when adding new skipto annotations: + finder )) @@ -85,10 +88,10 @@ ;; commonly used values for stepper-syntax-property: -(define skipto/cdr `(syntax-e cdr)) -(define skipto/cddr `(syntax-e cdr cdr)) -(define skipto/first `(syntax-e car)) -(define skipto/second `(syntax-e cdr car)) -(define skipto/third `(syntax-e cdr cdr car)) -(define skipto/fourth `(syntax-e cdr cdr cdr car)) +(define skipto/cdr `(cdr)) +(define skipto/cddr `(cdr cdr)) +(define skipto/first `(car)) +(define skipto/second `(cdr car)) +(define skipto/third `(cdr cdr car)) +(define skipto/fourth `(cdr cdr cdr car)) (define skipto/firstarg (append skipto/cdr skipto/second)) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/xml-snip-helpers.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/xml-snip-helpers.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/stepper/private/xml-snip-helpers.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/stepper/private/xml-snip-helpers.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,9 @@ (require xml/xml syntax/readerr - racket/gui + racket/gui/base + racket/class + racket/list "syntax-property.rkt") (provide xml-read-special @@ -108,22 +110,30 @@ [pos (wrapped-pos xexpr)] [line (wrapped-line xexpr)] [col (wrapped-col xexpr)] - [raw-stxs (list (send snip read-special text line col pos))]) - (with-syntax ([(stxs ...) raw-stxs]) - (if (and (is-a? snip scheme-snip<%>) - (send snip get-splice?)) - (with-syntax ([err (syntax/loc - (car (last-pair raw-stxs)) - (error 'scheme-splice-box "expected a list, found: ~e" lst))]) - #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)]) - (if (list? lst) - lst - err)) - 'stepper-xml-hint - 'from-splice-box)) - #`,#,(stepper-syntax-property #`(begin stxs ...) - 'stepper-xml-hint - 'from-scheme-box))))] + [raw-stx (send snip read-special text line col pos)]) + (if (and (is-a? snip scheme-snip<%>) + (send snip get-splice?)) + (datum->syntax + #f + (list 'unquote-splicing + (stepper-syntax-property + (datum->syntax + #f + `(let ([lst ,raw-stx]) + (if (list? lst) + lst + ,(datum->syntax + #f + '(error 'scheme-splice-box + "expected a list, found: ~e" lst) + raw-stx)))) + 'stepper-xml-hint + 'from-splice-box))) + (datum->syntax + #f + (list 'unquote (stepper-syntax-property (datum->syntax #f (list 'begin raw-stx)) + 'stepper-xml-hint + 'from-scheme-box)))))] [else xexpr]))) ;; eliminate-whitespace-in-list (listof xexpr) -> (listof xexpr) diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt racket-7.0+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt --- racket-6.12+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,12 @@ ------------------------------------------------------------------------ +Version 7.0 [Fri Jun 29 13:21:58 EDT 2018] + +* errors from tested expression no longer abort unit testing + (errors in expected expressions still do) +* fixed error message and highlighting for struct creation and access +* added uni-code lambda to BSL, BSL+, and ISL+ + +------------------------------------------------------------------------ Version 6.12 [Fri Nov 3 13:09:49 EDT 2017] * added file-exists? to batch-io diff -Nru racket-6.12+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt racket-7.0+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt --- racket-6.12+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt 2018-01-26 20:36:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,6 +17,7 @@ "test-info.scm") (require (for-syntax stepper/private/syntax-property)) +(require syntax/macro-testing) (provide check-expect ;; syntax : (check-expect ) @@ -80,11 +81,12 @@ (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) (define src-info (with-stepper-syntax-properties (['stepper-skip-completely #t]) - #`(list #,@(list #`(quote #,(syntax-source stx)) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))) + #`(list #,@(list #`(quote #,(syntax-source stx)) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))))) + (define test-expr-checked-for-syntax-error #`(convert-compile-time-error #,test-expr)) (if (eq? 'module (syntax-local-context)) #`(define #,bogus-name #,(stepper-syntax-property @@ -94,27 +96,27 @@ (insert-test test-engine (lambda () #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - (syntax/loc stx (void))))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-engine)))))))) + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr-checked-for-syntax-error) + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + (syntax/loc stx (void))))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-engine)))))))) 'stepper-skipto (append skipto/third ;; first let* binding skipto/third ;; second let* binding @@ -134,25 +136,25 @@ (insert-test test-engine (lambda () #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(syntax/loc stx (void)))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-engine)))))))))) + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr-checked-for-syntax-error) + #,(syntax/loc stx (void)))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-engine)))))))))) (define-for-syntax (check-context?) (let ([c (syntax-local-context)]) @@ -242,7 +244,7 @@ (cond [(boolean? r) r] [else - ; (error-check (lambda (v) #f) name "expected a boolean" #t) + ; (error-check (lambda (v) #f) name "expected a boolean" #t) (check-result (format "~a [as predicate in check-satisfied]" name) boolean? "boolean" r)])) ;; maker (lambda (src format v1 _v2 _) (make-satisfied-failed src format v1 name)) @@ -412,21 +414,18 @@ [exn:fail? (lambda (e) (define msg (get-rewriten-error-message e)) - (if (and (pair? kind) (eq? 'check-satisfied (car kind))) - (list (unsatisfied-error src (test-format) (cadr kind) msg e) - 'error e) - (list (unexpected-error src (test-format) expect msg e) - 'error e)))]) + (cons (if (and (pair? kind) (eq? 'check-satisfied (car kind))) + (unsatisfied-error src (test-format) (cadr kind) msg e) + (unexpected-error src (test-format) expect msg e)) + (list 'error e)))]) (define test-val (test)) - (cond [(check expect test-val range) (list #t test-val #f)] - [else (list (maker src (test-format) test-val expect range) - test-val - #f)]))]) - (cond [(check-fail? result) - (define c (send test-engine get-info)) - (send c check-failed result (check-fail-src result) exn) - (if exn (raise exn) #f)] - [else #t]))) + (define passes? (check expect test-val range)) + (cons (or passes? (maker src (test-format) test-val expect range)) (list test-val #f)))]) + (define failed? (check-fail? result)) + (cond [(not failed?) #t] + [else (define c (send test-engine get-info)) + (send c check-failed result (check-fail-src result) exn) + #f]))) ;;Wishes (struct exn:fail:wish exn:fail (name args)) @@ -580,8 +579,3 @@ (provide scheme-test-data test-format test-execute test-silence error-handler signature-test-info% build-test-engine) - -; (check-satisfied 1 equal?) -; (check-satisfied 1 (values odd?)) -; (check-satisfied (random 10) 11) -; (test) diff -Nru racket-6.12+ppa1/share/pkgs/html/info.rkt racket-7.0+ppa1/share/pkgs/html/info.rkt --- racket-6.12+ppa1/share/pkgs/html/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/html/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("html-lib" "html-doc"))) (define implies (quote ("html-lib" "html-doc"))) (define pkg-desc "HTML parsing and generation") (define pkg-authors (quote (jay mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("html-lib" "html-doc"))) (define implies (quote ("html-lib" "html-doc"))) (define pkg-desc "HTML parsing and generation") (define pkg-authors (quote (jay mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/html-doc/info.rkt racket-7.0+ppa1/share/pkgs/html-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/html-doc/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/html-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("scribble-lib" "html-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("html-lib"))) (define pkg-desc "documentation part of \"html\"") (define pkg-authors (quote (jay mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("scribble-lib" "html-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("html-lib"))) (define pkg-desc "documentation part of \"html\"") (define pkg-authors (quote (jay mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/html-lib/info.rkt racket-7.0+ppa1/share/pkgs/html-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/html-lib/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/html-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"html\"") (define pkg-authors (quote (jay mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"html\"") (define pkg-authors (quote (jay mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/icons/info.rkt racket-7.0+ppa1/share/pkgs/icons/info.rkt --- racket-6.12+ppa1/share/pkgs/icons/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/icons/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "icons") (define deps (quote ("base"))) (define pkg-desc "An assortment of images") (define pkg-authors (quote (ntoronto robby))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "icons") (define deps (quote ("base"))) (define pkg-desc "An assortment of images") (define pkg-authors (quote (ntoronto robby))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/images/info.rkt racket-7.0+ppa1/share/pkgs/images/info.rkt --- racket-6.12+ppa1/share/pkgs/images/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/images/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("images-lib" "images-gui-lib" "images-doc"))) (define implies (quote ("images-lib" "images-gui-lib" "images-doc"))) (define pkg-desc "Functions (and docs and tests) for constructing icons and logos") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("images-lib" "images-gui-lib" "images-doc"))) (define implies (quote ("images-lib" "images-gui-lib" "images-doc"))) (define pkg-desc "Functions (and docs and tests) for constructing icons and logos") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/images-doc/info.rkt racket-7.0+ppa1/share/pkgs/images-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/images-doc/info.rkt 2018-01-26 21:08:32.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/images-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("images-lib" "draw-doc" "gui-doc" "pict-doc" "slideshow-doc" "typed-racket-doc" "draw-lib" "gui-lib" "pict-lib" "racket-doc" "scribble-lib" "slideshow-lib" "typed-racket-lib"))) (define update-implies (quote ("images-lib"))) (define pkg-desc "Documentation for images-lib") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("images-lib" "draw-doc" "gui-doc" "pict-doc" "slideshow-doc" "typed-racket-doc" "draw-lib" "gui-lib" "pict-lib" "racket-doc" "scribble-lib" "slideshow-lib" "typed-racket-lib"))) (define update-implies (quote ("images-lib"))) (define pkg-desc "Documentation for images-lib") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/images-gui-lib/info.rkt racket-7.0+ppa1/share/pkgs/images-gui-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/images-gui-lib/info.rkt 2018-01-26 21:08:34.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/images-gui-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "gui-lib" "string-constants-lib"))) (define pkg-desc "Functions for constructing icons and logos") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "gui-lib" "string-constants-lib"))) (define pkg-desc "Functions for constructing icons and logos") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/images-lib/info.rkt racket-7.0+ppa1/share/pkgs/images-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/images-lib/info.rkt 2018-01-26 21:08:34.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/images-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "typed-racket-lib" "scribble-lib"))) (define pkg-desc "Functions for constructing icons and logos") (define pkg-authors (quote (ntoronto))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "typed-racket-lib" "scribble-lib"))) (define pkg-desc "Functions for constructing icons and logos") (define pkg-authors (quote (ntoronto))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/lazy/base/lang/reader.rkt racket-7.0+ppa1/share/pkgs/lazy/base/lang/reader.rkt --- racket-6.12+ppa1/share/pkgs/lazy/base/lang/reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/lazy/base/lang/reader.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +lazy/base \ No newline at end of file diff -Nru racket-6.12+ppa1/share/pkgs/lazy/base.rkt racket-7.0+ppa1/share/pkgs/lazy/base.rkt --- racket-6.12+ppa1/share/pkgs/lazy/base.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/lazy/base.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,869 @@ +#lang racket/base + +(require (for-syntax racket/base + racket/syntax) + (for-syntax stepper/private/syntax-property)) + + ;; ~ = lazy (or delayed) + ;; ! = strict (or forced) + ;; (See below for app-related names) + + ;; -------------------------------------------------------------------------- + ;; Syntax utilities + + ;; taken & modified from swindle/misc.rkt + (provide defsubst) ; useful utility + (define-syntax (defsubst-process stx) + (syntax-case stx () + [(_ name (acc ...)) + #'(define-syntax (name stx) + (syntax-case stx () acc ...))] + [(_ name (acc ...) id subst . more) (identifier? #'id) + #'(defsubst-process + name (acc ... + (id (identifier? #'id) #'subst) + ((id x (... ...)) #'(subst x (... ...)))) + . more)] + [(_ name (acc ...) n+a subst . more) + #'(defsubst-process name (acc ... (n+a #'subst)) . more)])) + (define-syntax defsubst + (syntax-rules () + [(_ (name . args) subst . more) + (defsubst-process name () (name . args) subst . more)] + [(_ name subst . more) + (defsubst-process name () name subst . more)])) + + ;; utility for defining ~foo but make it look like # + (define-syntax (define* stx) + (syntax-case stx () + [(_ ~name val) (identifier? #'~name) + (let* ([~str (symbol->string (syntax-e #'~name))] + [str (string->symbol (regexp-replace #rx"^[~*]" ~str ""))]) + (with-syntax ([name (datum->syntax #'~name str #'~name)]) + #'(define ~name (let ([name val]) (mark-lazy name)))))] + [(_ (~name . xs) body ...) (identifier? #'~name) + #'(define* ~name (lambda xs body ...))])) + + ;; -------------------------------------------------------------------------- + ;; Delay/force etc + + (require "force.rkt") + + (provide ~) + + ;; the exposed `!' (and other similar !s) must be a special form in the lazy + ;; language -- but this is achieved through the lazy #%app (~!%app below) + ;; that treats it (and the others) specially: uses mzscheme's application + (define-for-syntax strict-names + (syntax->list #'(! !! !list !!list !values !!values))) + + ;; -------------------------------------------------------------------------- + ;; Stepper utility fns + + (define-for-syntax (stepper-hide-operator stx) + (stepper-syntax-property stx 'stepper-skipto (append skipto/cdr skipto/second))) + (define-for-syntax (stepper-add-lazy-op-prop stx) + (stepper-syntax-property stx 'lazy-op #t)) + + (define-syntax (hidden-car stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (car arg)))])) + + (define-syntax (hidden-cdr stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (cdr arg)))])) + + (define-syntax (hidden-! stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (! arg)))])) + + (define-syntax (mark-as-lazy-op stx) + (syntax-case stx () + [(_ arg) + (identifier? #'arg) + (stepper-add-lazy-op-prop (syntax/loc stx arg))] + [(_ arg) #'arg])) + + (define-syntax (hidden-~ stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (~ arg)))])) + + ;; -------------------------------------------------------------------------- + ;; Determine laziness + + (define-values (lazy-proc lazy-proc?) + (let-values ([(type make pred ref set) + (make-struct-type + 'lazy-proc #f 1 0 #f null (current-inspector) 0)]) + (values make pred))) + (defsubst (lazy? x) (if (lazy-proc? x) #t (struct-constructor-procedure? x))) + ;; a version that works on any value + (defsubst (mark-lazy x) (if (procedure? x) (lazy-proc x) x)) + + ;; a few primitive constructors + (define ~cons (lazy-proc cons)) + (define ~list (lazy-proc list)) + (define ~list* (lazy-proc list*)) + (define ~vector (lazy-proc vector)) + (define ~box (lazy-proc box)) + ;; values is special, see below + + ;; -------------------------------------------------------------------------- + ;; Implicit begin & multiple values + + ;; This is used for implicit body begins. It is slightly complex since it + ;; should still be possible to use it for splicing up macro contents, so + ;; definitions are used with a normal begin. The actual body turns into one + ;; promise that, when forced, forces each of its expressions and returns the + ;; last value. This effectively ties evaluation of all expressions in one + ;; package, so (~begin foo bar) will always evaluate `foo' when the value of + ;; `bar' is forced. + (define-syntax ~begin + (let ([ids (syntax->list + #'(~define ~define-values define-syntax define-syntaxes + define-struct struct require provide))]) + (define (definition? stx) + (ormap (lambda (id) (free-identifier=? id stx)) ids)) + (lambda (stx) + (syntax-case stx () + ;; optimize simple cases + [(_) #'(begin)] + [(_ expr) #'expr] + [(_ expr ...) + (let loop ([exprs #'(expr ...)] [defs '()]) + (syntax-case exprs () + [((head . rest) expr ...) + (definition? #'head) + (loop #'(expr ...) (cons #'(head . rest) defs))] + ;; only definitions + [() #`(begin #,@(reverse defs))] + ;; single expr + [(expr) #`(begin #,@(reverse defs) expr)] + [(expr ...) + #`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))])))) + + ;; redefined to use lazy-proc and ~begin + (define-syntax (~lambda stx) + (syntax-case stx () + [(_ args body0 body ...) + (let ([n (syntax-local-name)]) + (with-syntax ([lam (syntax-property + (syntax/loc stx + (lambda args (~begin body0 body ...))) + 'inferred-name n)]) + (syntax/loc stx (lazy-proc lam))))])) + (provide (rename-out [~lambda λ])) + +; (defsubst +; (~define (f . xs) body0 body ...) (define f (~lambda xs body0 body ...)) +; (~define v x) (define v x)) + ;; STC: define ~define to add stepper-properties + ;; had to duplicate some stuff from ~lambda + (define-syntax (~define stx) + (define (attach-inferred-name stx fn-name-stx) + (syntax-property + (stepper-syntax-property + (stepper-syntax-property + stx + 'stepper-define-type 'shortened-proc-define) + 'stepper-proc-define-name fn-name-stx) + 'inferred-name fn-name-stx)) + ; duplicated some stuff from ~lambda so I could add stepper-properties + (syntax-case stx () + [(_ (f . args) body0 body ...) + (quasisyntax/loc stx + (define f + (lazy-proc + #,(attach-inferred-name + #'(lambda args (~begin body0 body ...)) + #'f) + )))] + [(_ name expr) #'(define name expr)])) + + (defsubst + (~let [(x v) ...] body0 body ...) + (let ([x v] ...) (~begin body0 body ...)) + (~let name [(x v) ...] body0 body ...) + (let name [(x v) ...] (~begin body0 body ...))) + (defsubst (~let* [(x v) ...] body0 body ...) + (let* ([x v] ...) (~begin body0 body ...))) + (defsubst (~letrec [(x v) ...] body0 body ...) + (letrec ([x v] ...) (~begin body0 body ...))) + + ;; parameterize should force its arguments + (defsubst (~parameterize ([param val] ...) body ...) + ;; like ~begin, delaying the whole thing is necessary to tie the evaluation + ;; to whenever the value is actually forced + (hidden-~ (parameterize ([param (hidden-! val)] ...) (~begin body ...)))) + + ;; Multiple values are problematic: Racket promises can use multiple + ;; values, but to carry that out `call-with-values' should be used in all + ;; places that deal with multiple values, which will make the whole thing + ;; much slower (about twice in tight loops) -- but multiple values are rarely + ;; used (spceifically, students never use them). So `values' is redefined to + ;; produce a first-class tuple-holding struct, and `split-values' turns that + ;; into multiple values. + ;; STC: add inspector for lazy stepper + (struct multiple-values (values) #:inspector (make-inspector)) + (define (split-values x) + (let ([x (! x)]) + (if (multiple-values? x) (apply values (multiple-values-values x)) x))) + (define-syntax (hidden-split-values stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (split-values arg)))])) + ;; Force and split resulting values. + (define (!values x) + (split-values (! x))) + ;; Similar, but forces the actual values too. + (define (!!values x) + (let ([x (! x)]) + (if (multiple-values? x) + (apply values (map ! (multiple-values-values x))) + x))) + + (define* ~values + (lambda xs (multiple-values xs))) + + ;; Redefine multiple-value constructs so they split the results + (defsubst (~define-values (v ...) body) + (define-values (v ...) (hidden-split-values body))) + (defsubst (~let-values ([(x ...) v] ...) body ...) + (let-values ([(x ...) (split-values v)] ...) (~begin body ...))) + (defsubst (~let*-values ([(x ...) v] ...) body ...) + (let*-values ([(x ...) (split-values v)] ...) (~begin body ...))) + (defsubst (~letrec-values ([(x ...) v] ...) body ...) + (letrec-values ([(x ...) (split-values v)] ...) (~begin body ...))) + + ;; Redefine things that return multiple values. + ;; (todo: only stuff necessary for the datatypes are done, more needed) + (define* (~make-struct-type . args) + (let ([args (!!list args)]) + (call-with-values (lambda () (apply make-struct-type args)) ~values))) + + ;; -------------------------------------------------------------------------- + ;; Applications + + ;; Basic names: + ;; `app': syntax, calls a function over given arguments + ;; `apply': function, last argument is a list of arguments to the function + ;; Conventions: + ;; `!*---': forces args when needed (depending on the function) + ;; doesn't force the function (internal use only) + ;; `!---': forces function, and forces args when needed + ;; `~!---': adds a delay wrapper to the application (uses the above) + ;; (this is a macro in the `apply' case too) + ;; `~!*---': like the previous, but does not force the function (internal) + ;; Provided stuff: + ;; `~!%app': provided as `#%app' -- similar to `~!app' but treats a few + ;; application kinds as special (mostly all kinds of forces) + ;; `!apply': provided as `apply' (no need to provide `~!apply', since all + ;; function calls are delayed by `#%app') + + (define (extract-if-lazy-proc f) + (or (procedure-extract-target f) f)) + (define-syntax (!*app stx) + (syntax-case stx () + [(_ f x ...) + (let ([$$ (lambda (stx) + (stepper-syntax-property + stx + 'stepper-skipto + (append skipto/cddr + `(both-l () (car)))))] + [$ (lambda (stx) + (stepper-syntax-property + stx + 'stepper-skipto + (append skipto/cdr + skipto/first)))]) + (with-syntax* ([(y ...) (for/list ([decl (in-list (syntax->list #'(x ...)))]) + (if (keyword? (syntax->datum decl)) + decl + (generate-temporary decl)))] + [(y-ids ...) (filter (λ (decl) (not (keyword? (syntax->datum decl)))) + (syntax->list #'(y ...)))]) + ;; use syntax/loc for better errors etc + (with-syntax ([lazy (syntax/loc stx ((extract-if-lazy-proc p) y ...))] + [strict (syntax/loc stx (p (hidden-! y-ids) ...))]) + (quasisyntax/loc stx + ((lambda (p y ...) + #,($$ #'(if (lazy? p) lazy strict))) + f x ...) + #;(let ([p f] [y x] ...) + ;; #,($$ #`(if (lazy? p) lazy strict)) + (if (lazy? p) lazy strict))))))])) + + (defsubst (!app f x ...) (!*app (hidden-! (mark-as-lazy-op f)) x ...)) + (defsubst (~!*app f x ...) (hidden-~ (!*app f x ...))) + (defsubst (~!app f x ...) (hidden-~ (!app f x ...))) + + (define-for-syntax (toplevel?) + (memq (syntax-local-context) + '(top-level module module-begin))) ; not sure about module-begin + + ;; What happens when encoutering a toplevel non-definition expression? + (provide toplevel-forcer) + (define toplevel-forcer (make-parameter !)) + + (provide (rename-out [~!%app #%app])) ; all applications are delayed + (define-syntax (~!%app stx) ; provided as #%app + #;(define (unwinder stx rec) + (syntax-case stx (!) + [(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body) + (with-syntax ([(f x ...) (rec #'(f x ...))]) + #'(f x ...))])) + #;(define (stepper-annotate stx) + (let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)] + [stx (stepper-syntax-property stx 'stepper-skip-double-break #t)]) + stx)) + (syntax-case stx (~) + [(_ ~ x) (syntax/loc stx (~ x))] ; not really needed + [(_ f x ...) + (cond [(let ([f #'f]) + (and (identifier? f) + (ormap (lambda (s) (free-identifier=? f s)) + strict-names))) + ;; strict function => special forms => use plain application + (syntax/loc stx (f x ...))] + [(toplevel?) + ;; toplevel expressions are always forced + (syntax/loc stx ((toplevel-forcer) (!app f x ...)))] + [else (syntax/loc stx (~!app f x ...))])])) + + (define (!*apply f . xs) + (let ([xs (!list (apply list* xs))]) + (apply f (if (lazy? f) xs (map ! xs))))) + (define* (!apply f . xs) + (let ([f (! f)] [xs (!list (apply list* xs))]) + (apply f (if (lazy? f) xs (map ! xs))))) + (defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs))) + (defsubst (~!apply f . xs) (hidden-~ (!apply f . xs))) + + (provide (rename-out [!apply apply])) ; can only be used through #%app => delayed + + ;; do the same special treatment for toplevel variable expressions + (provide (rename-out [!top #%top])) + (define-syntax (!top stx) + (syntax-case stx () + [(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))])) + + ;; used for explicitly strict/lazy calls + (defsubst (strict-call f x ...) (hidden-~ (f (! x) ...))) + (defsubst (lazy-call f x ...) (hidden-~ (f x ...))) + + ;; -------------------------------------------------------------------------- + ;; Special forms that are now functions + + ;; Since these things are rarely used as functions, they are defined as + ;; macros that expand to the function form when used as an expression. + + (define* *if + (case-lambda [(e1 e2 e3) (if (! e1) e2 e3)] + [(e1 e2 ) (when (! e1) e2 )])) + (defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3)) + (~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 )) + ~if *if) + + (define* (*and . xs) + (let ([xs (!list xs)]) + (or (null? xs) + (let loop ([x (car xs)] [xs (cdr xs)]) + (if (null? xs) x (and (! x) (loop (car xs) (cdr xs)))))))) + (define-syntax !and + (syntax-rules () + [(_) (and)] + [(_ x ... y) (and (hidden-! x) ... y)])) + (defsubst (~and x ...) (hidden-~ (!and x ...)) ~and *and) + + (define* (*or . xs) + (let ([xs (!list xs)]) + (and (pair? xs) + (let loop ([x (car xs)] [xs (cdr xs)]) + (if (null? xs) x (or (! x) (loop (car xs) (cdr xs)))))))) + (define-syntax !or + (syntax-rules () + [(_) (or)] + [(_ x ... y) (or (hidden-! x) ... y)])) + (defsubst (~or x ...) (hidden-~ (!or x ...)) ~or *or) + + ;; -------------------------------------------------------------------------- + ;; Special forms that are still special forms since they use ~begin + + (defsubst (~begin0 x y ...) ; not using ~begin, but equivalent + (hidden-~ (let ([val (hidden-! x)]) (hidden-! y) ... val))) + + (defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...)))) + (defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...)))) + + ;; -------------------------------------------------------------------------- + ;; Misc stuff + + ;; Just for fun... + (defsubst (~set! id expr) (hidden-~ (set! id (hidden-! expr)))) + ;; The last ! above is needed -- without it: + ;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a) + ;; goes into an infinite loop. (Thanks to Jos Koot) + + (define* (~set-mcar! mpair val) (~ (set-mcar! (! mpair) val))) + (define* (~set-mcdr! mpair val) (~ (set-mcdr! (! mpair) val))) + (define* (~vector-set! vec i val) (~ (vector-set! (! vec) (! i) val))) + (define* (~set-box! box val) (~ (set-box! (! box) val))) + + ;; not much to do with these besides inserting strictness points and ~begin + ; for stepper: change else to #t test, add new error else branch + (define-syntax (~cond stx) + (syntax-case stx () + [(_ clause ...) ; stepper needs the loc of the full clause + (with-syntax + ([(new-clause ...) + (map + (λ (c) + (with-syntax ([(test body ...) c]) + (with-syntax + ([new-test + (syntax-case #'test (else) + [else ; for stepper + (stepper-syntax-property #'#t 'stepper-else #t)] + [x (syntax/loc #'x (hidden-! x))])]) + (syntax/loc c (new-test (~begin body ...)))))) + (syntax->list #'(clause ...)))] + [new-else-body (syntax/loc stx (error 'cond "should not get here"))]) + (quasisyntax/loc stx + (hidden-~ + #,(syntax/loc stx + (cond + new-clause ... + [else new-else-body])))))])) + (defsubst (~case v [keys body ...] ...) + (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...))) + + ;; Doing this will print the whole thing, but problems with infinite things + (define* (~error . args) (apply error (!! args))) + + ;; I/O shows the whole thing + (define* (~printf fmt . args) (apply printf (! fmt) (!! args))) + (define* (~fprintf p fmt . args) (apply fprintf (! p) (! fmt) (!! args))) + (define* (~display x . port) (apply display (!! x) (!!list port))) + (define* (~write x . port) (apply write (!! x) (!!list port))) + (define* (~print x . port) (apply print (!! x) (!!list port))) + + ;; -------------------------------------------------------------------------- + ;; Equality functions + + ;; All of these try to stop if the promises are the same. + + (define* (~eq? . args) + (or (apply eq? (!list args)) (apply eq? (!!list args)))) + + (define* (~eqv? . args) + (or (apply eqv? (!list args)) (apply eqv? (!!list args)))) + + ;; for `equal?' we must do a recursive scan + (define (equal2? x y) + (cond [(pair? x) (and (pair? y) + (~equal? (car x) (car y)) + (~equal? (cdr x) (cdr y)))] + [(vector? x) + (let ([k (vector-length x)]) + (and (vector? y) + (= k (vector-length y)) + (let loop ([i 0]) + (or (= i k) + (and (~equal? (vector-ref x i) (vector-ref y i)) + (loop (add1 i)))))))] + [(struct? x) + (and (struct? y) + (let-values ([(xtype xskipped?) (struct-info x)] + [(ytype yskipped?) (struct-info y)]) + (and xtype ytype (not xskipped?) (not yskipped?) + (eq? xtype ytype) + (let*-values ([(name initk autok ref set imms spr skp?) + (struct-type-info xtype)] + [(k) (+ initk autok)]) + (let loop ([i 0]) + (or (= i k) (and (~equal? (ref x i) (ref y i)) + (loop (add1 i)))))))))] + [(box? x) (and (box? y) (~equal? (unbox x) (unbox y)))] + [else #f])) + (define* (~equal? x y . args) + (let ([args (!list args)]) + (if (pair? args) + (and (~equal? x y) (apply ~equal? x (cdr args))) + (or (equal? x y) + (let ([x (! x)] [y (! y)]) + (or (equal? x y) (equal2? x y))))))) + + ;; -------------------------------------------------------------------------- + ;; List functions + + (define* (~list? x) (list? (!list x))) ; must force the whole list + (define* (~length l) (length (!list l))) ; for these + + (define* (~car x) (car (! x))) ; these are for internal use: ~!app will do + (define* (~cdr x) (cdr (! x))) ; this job when using this language + (define* (~caar x) (car (! (car (! x))))) + (define* (~cadr x) (car (! (cdr (! x))))) + (define* (~cdar x) (cdr (! (car (! x))))) + (define* (~cddr x) (cdr (! (cdr (! x))))) + (define* (~caaar x) (car (! (~caar x)))) + (define* (~caadr x) (car (! (~cadr x)))) + (define* (~cadar x) (car (! (~cdar x)))) + (define* (~caddr x) (car (! (~cddr x)))) + (define* (~cdaar x) (cdr (! (~caar x)))) + (define* (~cdadr x) (cdr (! (~cadr x)))) + (define* (~cddar x) (cdr (! (~cdar x)))) + (define* (~cdddr x) (cdr (! (~cddr x)))) + (define* (~caaaar x) (car (! (~caaar x)))) + (define* (~caaadr x) (car (! (~caadr x)))) + (define* (~caadar x) (car (! (~cadar x)))) + (define* (~caaddr x) (car (! (~caddr x)))) + (define* (~cadaar x) (car (! (~cdaar x)))) + (define* (~cadadr x) (car (! (~cdadr x)))) + (define* (~caddar x) (car (! (~cddar x)))) + (define* (~cadddr x) (car (! (~cdddr x)))) + (define* (~cdaaar x) (cdr (! (~caaar x)))) + (define* (~cdaadr x) (cdr (! (~caadr x)))) + (define* (~cdadar x) (cdr (! (~cadar x)))) + (define* (~cdaddr x) (cdr (! (~caddr x)))) + (define* (~cddaar x) (cdr (! (~cdaar x)))) + (define* (~cddadr x) (cdr (! (~cdadr x)))) + (define* (~cdddar x) (cdr (! (~cddar x)))) + (define* (~cddddr x) (cdr (! (~cdddr x)))) + + (define* (~list-ref l k) + (let ([k (! k)]) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'list-ref "non-negative exact integer" 1 l k)) + (let loop ([k k] [l (! l)]) + (cond [(not (pair? l)) + (raise-type-error 'list-ref "proper list" l)] + [(zero? k) (car l)] + [else (loop (sub1 k) (! (cdr l)))])))) + (define* (~list-tail l k) + (let ([k (! k)]) + (unless (exact-nonnegative-integer? k) + (raise-type-error 'list-tail "non-negative exact integer" 1 l k)) + (let loop ([k k] [l l]) ; don't force here -- unlike list-ref + (cond [(zero? k) l] + [else (let ([l (! l)]) + (unless (pair? l) + (raise-type-error 'list-tail "list" l)) + (loop (sub1 k) (cdr l)))])))) + + (define* (~append . xs) + (let ([xs (!list xs)]) + (cond [(null? xs) '()] + [(null? (cdr xs)) (car xs)] + [else (let ([ls (~ (apply ~append (cdr xs)))]) + (let loop ([l (! (car xs))]) + (if (null? l) + ls + (cons (car l) (~ (loop (! (cdr l))))))))]))) + + ;; useful utility for many list functions below + (define (!cdr l) (! (cdr l))) + + (define-syntax (deflistiter stx) + (syntax-case stx (extra: null ->) + [(deflistiter (?~name ?proc ?args ... ?l . ?ls) + null -> ?base + ?loop -> ?step-single ?step-multiple) + #'(deflistiter (?~name ?proc ?args ... ?l . ?ls) + extra: + null -> ?base + ?loop -> ?step-single ?step-multiple)] + [(deflistiter (?~name ?proc ?args ... ?l . ?ls) + extra: [?var ?init] ... + null -> ?base + ?loop -> ?step-single ?step-multiple) + (with-syntax ([?name (let* ([x (symbol->string (syntax-e #'?~name))] + [x (regexp-replace #rx"^~" x "")] + [x (string->symbol x)]) + (datum->syntax #'?~name x #'?~name))]) + #'(define* ?~name + (case-lambda + [(?proc ?args ... ?l) + (let ([?proc (hidden-! ?proc)]) + (let ?loop ([?l (hidden-! ?l)] [?var ?init] ...) + (if (null? ?l) + ?base + ?step-single)))] + [(?proc ?args ... ?l . ?ls) + (let ([?proc (hidden-! ?proc)]) + (let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...) + (if (ormap null? ?ls) + (if (andmap null? ?ls) + ?base + (error '?name "all lists must have same size")) + ?step-multiple)))])))])) + + ;; These use the `*' version of app/ly, to avoid forcing the function over + ;; and over -- `deflistiter' forces it on entry + (deflistiter (~map proc l . ls) + null -> '() + loop -> (cons (~!*app proc (car l)) (~ (loop (! (cdr l))))) + (cons (~!*apply proc (map car ls)) (~ (loop (map !cdr ls))))) + (deflistiter (~for-each proc l . ls) + null -> (void) + loop -> (begin (! (!*app proc (car l))) (loop (! (cdr l)))) + (begin (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) + (deflistiter (~andmap proc l . ls) + null -> #t + loop -> (and (! (!*app proc (car l))) (loop (! (cdr l)))) + (and (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) + (deflistiter (~ormap proc l . ls) + null -> #f + loop -> (or (! (!*app proc (car l))) (loop (! (cdr l)))) + (or (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) + (deflistiter (foldl proc init l . ls) + extra: [acc init] + null -> acc + loop -> + (~ (loop (! (cdr l)) (~!*app proc (car l) acc))) + (~ (loop (map !cdr ls) + (~!*apply proc (append (map car ls) (list acc)))))) + (deflistiter (foldr proc init l . ls) + null -> init + loop -> + (~!*app proc (car l) (~ (loop (! (cdr l))))) + (~!*apply proc (append (map car ls) (list (~ (loop (map !cdr ls))))))) + + (define (do-member name = elt list) ; no currying for procedure names + ;; `elt', `=', and `name' are always forced values + (let loop ([list (! list)]) + (cond [(null? list) #f] + [(not (pair? list)) (error name "not a proper list: ~e" list)] + [(= elt (! (car list))) list] + [else (loop (! (cdr list)))]))) + (define* (~member elt list) (do-member 'member ~equal? (! elt) list)) + (define* (~memq elt list) (do-member 'memq ~eq? (! elt) list)) + (define* (~memv elt list) (do-member 'memv ~eqv? (! elt) list)) + + (define (do-assoc name = key alist) ; no currying for procedure names + ;; `key', `=', and `name' are always forced values + (let loop ([alist (! alist)]) + (cond [(null? alist) #f] + [(not (pair? alist)) (error name "not a proper list: ~e" alist)] + [else (let ([cell (! (car alist))]) + (cond [(not (pair? cell)) + (error name "non-pair found in list: ~e" cell)] + [(= (! (car cell)) key) cell] + [else (loop (! (cdr alist)))]))]))) + (define* (~assoc key alist) (do-assoc 'assoc ~equal? (! key) alist)) + (define* (~assq key alist) (do-assoc 'assq ~eq? (! key) alist)) + (define* (~assv key alist) (do-assoc 'assv ~eqv? (! key) alist)) + + (define* (~reverse list) + (let ([list (!list list)]) + (reverse list))) + + ;; -------------------------------------------------------------------------- + ;; Extra functionality that is useful for lazy list stuff + + (define* (take n l) + (let ([n0 (! n)]) + (unless (exact-nonnegative-integer? n0) + (raise-type-error 'take "non-negative exact integer" 0 n0 l)) + (let loop ([n n0] [l l]) + (if (zero? n) + '() + (let ([l (! l)]) + (cond [(null? l) + ;; it would be fine to force the whole list (since we now + ;; know it's finite), but doing so means keeping a reference + ;; to its head, which can lead to memory leaks. + (error 'take "index ~e too large for input list" n0)] + [(pair? l) (cons (car l) (~ (loop (sub1 n) (cdr l))))] + [else (error 'take "not a proper list: ~e" l)])))))) + + ;; not like Haskell's `cycle' that consumes a list + (define* (cycle . l) + (letrec ([r (~ (~append (! l) r))]) + r)) + + ;; -------------------------------------------------------------------------- + ;; mzlib/list functionality + + ;; These are a hack, they're not the same due to different error + ;; messages (and they work with improper lists too). + (define* (rest x) (~cdr x)) + (define* (first x) (~car x)) + (define* (second x) (~cadr x)) + (define* (third x) (~caddr x)) + (define* (fourth x) (~cadddr x)) + (define* (fifth x) (~car (~cddddr x))) + (define* (sixth x) (~cadr (~cddddr x))) + (define* (seventh x) (~caddr (~cddddr x))) + (define* (eighth x) (~cadddr (~cddddr x))) + (define* (cons? x) (pair? (! x))) + (define* empty null) + (define* (empty? x) (null? (! x))) + + (define (do-remove name item list =) + (let ([= (! =)]) + (let loop ([list (! list)]) + (cond [(null? list) list] + [(not (pair? list)) + (error name "not a proper list: ~e" list)] + [(!*app = item (car list)) (cdr list)] + [else (cons (car list) (~ (loop (! (cdr list)))))])))) + (define* remove + (case-lambda [(item list ) (do-remove 'remove item list ~equal?)] + [(item list =) (do-remove 'remove item list =)])) + (define* (remq item list) (do-remove 'remq item list ~eq?)) + (define* (remv item list) (do-remove 'remv item list ~eqv?)) + + (define (do-remove* name items list =) + (let ([= (! =)] [items (!list items)]) + (let loop ([list (! list)]) + (cond [(null? list) list] + [(not (pair? list)) + (error name "not a proper list: ~e" list)] + [else + (let ([xs (~ (loop (! (cdr list))))]) + (if (memf (lambda (item) (!*app = item (car list))) items) + xs + (cons (car list) xs)))])))) + (define* remove* + (case-lambda [(items list ) (do-remove* 'remove* items list ~equal?)] + [(items list =) (do-remove* 'remove* items list =)])) + (define* (remq* items list) (do-remove* 'remq* items list ~eq?)) + (define* (remv* items list) (do-remove* 'remv* items list ~eqv?)) + + (define* (memf pred list) + (let ([pred (! pred)]) + (let loop ([list (! list)]) + (cond [(null? list) #f] + [(not (pair? list)) (error 'memf "not a proper list: ~e" list)] + [(! (!*app pred (car list))) list] + [else (loop (! (cdr list)))])))) + + (define* (findf pred list) + (~car (memf pred list))) + + (define* (assf pred alist) + (let ([pred (! pred)]) + (let loop ([alist (! alist)]) + (cond [(null? alist) #f] + [(not (pair? alist)) (error 'assf "not a proper list: ~e" alist)] + [else (let ([cell (! (car alist))]) + (cond [(not (pair? cell)) + (error 'assf "non-pair found in list: ~e" cell)] + [(!*app pred (car cell)) cell] + [else (loop (! (cdr alist)))]))])))) + + (define* (filter pred list) + (let ([pred (! pred)]) + (let loop ([list (! list)]) + (cond [(null? list) list] + [(pair? list) + (let ([x (car list)] + [xs (~ (loop (! (cdr list))))]) + (if (! (!*app pred x)) (cons x xs) xs))] + [else (error 'filter "not a proper list: ~e" list)])))) + + (require (only-in racket/base [sort !sort])) + (define* (sort list less?) + (let ([less? (! less?)]) + (!sort (!list list) (lambda (x y) (! (!*app less? x y)))))) + + ;; -------------------------------------------------------------------------- + ;; mzlib/etc functionality + + (require (only-in racket/bool boolean=? symbol=?)) + (define* true #t) + (define* false #f) + + (define* (identity x) x) + ;; no need for dealing with multiple values since students don't use them + (define* (compose . fs) + (let ([fs (!list fs)]) + (cond [(null? fs) identity] + [(null? (cdr fs)) (car fs)] + [else (let ([fs (reverse fs)]) + (lambda xs + (let loop ([fs (cdr fs)] + [x (~!apply (car fs) xs)]) + (if (null? fs) + x + (loop (cdr fs) (~!app (car fs) x))))))]))) + + (define* (build-list n f) + (let ([n (! n)] [f (! f)]) + (unless (exact-nonnegative-integer? n) + (error 'build-list "~s must be an exact integer >= 0" n)) + (unless (procedure? f) + (error 'build-list "~s must be a procedure" f)) + (let loop ([i 0]) + (if (>= i n) + '() + (cons (~ (f i)) (~ (loop (add1 i)))))))) + + ;; -------------------------------------------------------------------------- + ;; Provide everything except some renamed stuff + + (define-syntax (provide-strict-names stx) + #`(provide #,@strict-names)) + (provide-strict-names) + + (define-syntax (renaming-provide stx) + (syntax-case stx () + [(_ id ...) + (with-syntax + ([(~id ...) + (map (lambda (id) + (let* ([str (symbol->string (syntax-e id))] + [~id (string->symbol (string-append "~" str))]) + (datum->syntax id ~id id))) + (syntax->list #'(id ...)))]) + #'(provide (except-out (all-from-out racket/base) module #%app apply #%top λ + id ...) + (rename-out [~id id] ...)))])) + (renaming-provide + lambda define let let* letrec parameterize + values define-values let-values let*-values letrec-values make-struct-type + cons list list* vector box + if and or begin begin0 when unless + set! set-mcar! set-mcdr! vector-set! set-box! + cond case error printf fprintf display write print + eq? eqv? equal? + list? length list-ref list-tail append map for-each andmap ormap + member memq memv assoc assq assv reverse + caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar + caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr) + + (provide + ;; multiple values (see above) + split-values + ;; explicit strict/lazy calls + strict-call lazy-call + ;; `list' stuff + first second third fourth fifth sixth seventh eighth rest cons? empty empty? + foldl foldr remove remq remv remove* remq* remv* memf findf assf filter + sort + ;; `etc' stuff + true false boolean=? symbol=? identity compose build-list + ;; extra stuff for lazy Scheme + take cycle) + + +#| +;; Some tests +(cadr (list (/ 1 0) 1 (/ 1 0))) -> 1 +(foldl + 0 '(1 2 3 4)) -> 10 +(foldl (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 +(foldl (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 +(foldr + 0 '(1 2 3 4)) -> 10 +(foldr (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 +(foldr (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 +(define ones (cons 1 ones)) +(take 5 (foldr cons '() ones)) -> (1 1 1 1 1) +(define a (list (/ 1 0) 2 (/ 3 0))) +(caadr (map list a)) -> 2 +(cadr (map + a a)) -> 4 +(andmap even? '(1 2 3 4)) -> #f +(ormap even? '(1 2 3 4)) -> #t +(ormap even? '(1 21 3 41)) -> #f +(andmap even? (list 1 2 3 (/ 4 0))) -> #f +|# diff -Nru racket-6.12+ppa1/share/pkgs/lazy/info.rkt racket-7.0+ppa1/share/pkgs/lazy/info.rkt --- racket-6.12+ppa1/share/pkgs/lazy/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/lazy/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "lazy") (define scribblings (quote (("lazy.scrbl" () (experimental 50))))) (define drracket-tools (quote (("lazy-tool.rkt")))) (define drracket-tool-names (quote ("Lazy Racket"))) (define deps (quote ("base" "drracket-plugin-lib" "htdp-lib" "string-constants-lib" "compatibility-lib"))) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "eli-tester" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Lazy Racket language") (define pkg-authors (quote (eli stchang))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "lazy") (define scribblings (quote (("lazy.scrbl" () (experimental 50))))) (define drracket-tools (quote (("lazy-tool.rkt")))) (define drracket-tool-names (quote ("Lazy Racket"))) (define deps (quote ("base" "drracket-plugin-lib" "htdp-lib" "string-constants-lib" "compatibility-lib"))) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "eli-tester" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Lazy Racket language") (define pkg-authors (quote (eli stchang))))) diff -Nru racket-6.12+ppa1/share/pkgs/lazy/lazy.rkt racket-7.0+ppa1/share/pkgs/lazy/lazy.rkt --- racket-6.12+ppa1/share/pkgs/lazy/lazy.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/lazy/lazy.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,865 +1,6 @@ -#lang racket/base +#lang lazy/base -(require (for-syntax racket/base) - (for-syntax stepper/private/syntax-property)) - - ;; ~ = lazy (or delayed) - ;; ! = strict (or forced) - ;; (See below for app-related names) - - ;; -------------------------------------------------------------------------- - ;; Syntax utilities - - ;; taken & modified from swindle/misc.rkt - (provide defsubst) ; useful utility - (define-syntax (defsubst-process stx) - (syntax-case stx () - [(_ name (acc ...)) - #'(define-syntax (name stx) - (syntax-case stx () acc ...))] - [(_ name (acc ...) id subst . more) (identifier? #'id) - #'(defsubst-process - name (acc ... - (id (identifier? #'id) #'subst) - ((id x (... ...)) #'(subst x (... ...)))) - . more)] - [(_ name (acc ...) n+a subst . more) - #'(defsubst-process name (acc ... (n+a #'subst)) . more)])) - (define-syntax defsubst - (syntax-rules () - [(_ (name . args) subst . more) - (defsubst-process name () (name . args) subst . more)] - [(_ name subst . more) - (defsubst-process name () name subst . more)])) - - ;; utility for defining ~foo but make it look like # - (define-syntax (define* stx) - (syntax-case stx () - [(_ ~name val) (identifier? #'~name) - (let* ([~str (symbol->string (syntax-e #'~name))] - [str (string->symbol (regexp-replace #rx"^[~*]" ~str ""))]) - (with-syntax ([name (datum->syntax #'~name str #'~name)]) - #'(define ~name (let ([name val]) (mark-lazy name)))))] - [(_ (~name . xs) body ...) (identifier? #'~name) - #'(define* ~name (lambda xs body ...))])) - - ;; -------------------------------------------------------------------------- - ;; Delay/force etc - - (require "force.rkt") - - (provide ~) - - ;; the exposed `!' (and other similar !s) must be a special form in the lazy - ;; language -- but this is achieved through the lazy #%app (~!%app below) - ;; that treats it (and the others) specially: uses mzscheme's application - (define-for-syntax strict-names - (syntax->list #'(! !! !list !!list !values !!values))) - - ;; -------------------------------------------------------------------------- - ;; Stepper utility fns - - (define-for-syntax (stepper-hide-operator stx) - (stepper-syntax-property stx 'stepper-skipto (append skipto/cdr skipto/second))) - (define-for-syntax (stepper-add-lazy-op-prop stx) - (stepper-syntax-property stx 'lazy-op #t)) - - (define-syntax (hidden-car stx) - (syntax-case stx () - [(_ arg) (stepper-hide-operator (syntax/loc stx (car arg)))])) - - (define-syntax (hidden-cdr stx) - (syntax-case stx () - [(_ arg) (stepper-hide-operator (syntax/loc stx (cdr arg)))])) - - (define-syntax (hidden-! stx) - (syntax-case stx () - [(_ arg) (stepper-hide-operator (syntax/loc stx (! arg)))])) - - (define-syntax (mark-as-lazy-op stx) - (syntax-case stx () - [(_ arg) - (identifier? #'arg) - (stepper-add-lazy-op-prop (syntax/loc stx arg))] - [(_ arg) #'arg])) - - (define-syntax (hidden-~ stx) - (syntax-case stx () - [(_ arg) (stepper-hide-operator (syntax/loc stx (~ arg)))])) - - ;; -------------------------------------------------------------------------- - ;; Determine laziness - - (define-values (lazy-proc lazy-proc?) - (let-values ([(type make pred ref set) - (make-struct-type - 'lazy-proc #f 1 0 #f null (current-inspector) 0)]) - (values make pred))) - (defsubst (lazy? x) (if (lazy-proc? x) #t (struct-constructor-procedure? x))) - ;; a version that works on any value - (defsubst (mark-lazy x) (if (procedure? x) (lazy-proc x) x)) - - ;; a few primitive constructors - (define ~cons (lazy-proc cons)) - (define ~list (lazy-proc list)) - (define ~list* (lazy-proc list*)) - (define ~vector (lazy-proc vector)) - (define ~box (lazy-proc box)) - ;; values is special, see below - - ;; -------------------------------------------------------------------------- - ;; Implicit begin & multiple values - - ;; This is used for implicit body begins. It is slightly complex since it - ;; should still be possible to use it for splicing up macro contents, so - ;; definitions are used with a normal begin. The actual body turns into one - ;; promise that, when forced, forces each of its expressions and returns the - ;; last value. This effectively ties evaluation of all expressions in one - ;; package, so (~begin foo bar) will always evaluate `foo' when the value of - ;; `bar' is forced. - (define-syntax ~begin - (let ([ids (syntax->list - #'(~define ~define-values define-syntax define-syntaxes - define-struct struct require provide))]) - (define (definition? stx) - (ormap (lambda (id) (free-identifier=? id stx)) ids)) - (lambda (stx) - (syntax-case stx () - ;; optimize simple cases - [(_) #'(begin)] - [(_ expr) #'expr] - [(_ expr ...) - (let loop ([exprs #'(expr ...)] [defs '()]) - (syntax-case exprs () - [((head . rest) expr ...) - (definition? #'head) - (loop #'(expr ...) (cons #'(head . rest) defs))] - ;; only definitions - [() #`(begin #,@(reverse defs))] - ;; single expr - [(expr) #`(begin #,@(reverse defs) expr)] - [(expr ...) - #`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))])))) - - ;; redefined to use lazy-proc and ~begin - (define-syntax (~lambda stx) - (syntax-case stx () - [(_ args body0 body ...) - (let ([n (syntax-local-name)]) - (with-syntax ([lam (syntax-property - (syntax/loc stx - (lambda args (~begin body0 body ...))) - 'inferred-name n)]) - (syntax/loc stx (lazy-proc lam))))])) - (provide (rename-out [~lambda λ])) - -; (defsubst -; (~define (f . xs) body0 body ...) (define f (~lambda xs body0 body ...)) -; (~define v x) (define v x)) - ;; STC: define ~define to add stepper-properties - ;; had to duplicate some stuff from ~lambda - (define-syntax (~define stx) - (define (attach-inferred-name stx fn-name-stx) - (syntax-property - (stepper-syntax-property - (stepper-syntax-property - stx - 'stepper-define-type 'shortened-proc-define) - 'stepper-proc-define-name fn-name-stx) - 'inferred-name fn-name-stx)) - ; duplicated some stuff from ~lambda so I could add stepper-properties - (syntax-case stx () - [(_ (f . args) body0 body ...) - (quasisyntax/loc stx - (define f - (lazy-proc - #,(attach-inferred-name - #'(lambda args (~begin body0 body ...)) - #'f) - )))] - [(_ name expr) #'(define name expr)])) - - (defsubst - (~let [(x v) ...] body0 body ...) - (let ([x v] ...) (~begin body0 body ...)) - (~let name [(x v) ...] body0 body ...) - (let name [(x v) ...] (~begin body0 body ...))) - (defsubst (~let* [(x v) ...] body0 body ...) - (let* ([x v] ...) (~begin body0 body ...))) - (defsubst (~letrec [(x v) ...] body0 body ...) - (letrec ([x v] ...) (~begin body0 body ...))) - - ;; parameterize should force its arguments - (defsubst (~parameterize ([param val] ...) body ...) - ;; like ~begin, delaying the whole thing is necessary to tie the evaluation - ;; to whenever the value is actually forced - (hidden-~ (parameterize ([param (hidden-! val)] ...) (~begin body ...)))) - - ;; Multiple values are problematic: Racket promises can use multiple - ;; values, but to carry that out `call-with-values' should be used in all - ;; places that deal with multiple values, which will make the whole thing - ;; much slower (about twice in tight loops) -- but multiple values are rarely - ;; used (spceifically, students never use them). So `values' is redefined to - ;; produce a first-class tuple-holding struct, and `split-values' turns that - ;; into multiple values. - ;; STC: add inspector for lazy stepper - (struct multiple-values (values) #:inspector (make-inspector)) - (define (split-values x) - (let ([x (! x)]) - (if (multiple-values? x) (apply values (multiple-values-values x)) x))) - (define-syntax (hidden-split-values stx) - (syntax-case stx () - [(_ arg) (stepper-hide-operator (syntax/loc stx (split-values arg)))])) - ;; Force and split resulting values. - (define (!values x) - (split-values (! x))) - ;; Similar, but forces the actual values too. - (define (!!values x) - (let ([x (! x)]) - (if (multiple-values? x) - (apply values (map ! (multiple-values-values x))) - x))) - - (define* ~values - (lambda xs (multiple-values xs))) - - ;; Redefine multiple-value constructs so they split the results - (defsubst (~define-values (v ...) body) - (define-values (v ...) (hidden-split-values body))) - (defsubst (~let-values ([(x ...) v] ...) body ...) - (let-values ([(x ...) (split-values v)] ...) (~begin body ...))) - (defsubst (~let*-values ([(x ...) v] ...) body ...) - (let*-values ([(x ...) (split-values v)] ...) (~begin body ...))) - (defsubst (~letrec-values ([(x ...) v] ...) body ...) - (letrec-values ([(x ...) (split-values v)] ...) (~begin body ...))) - - ;; Redefine things that return multiple values. - ;; (todo: only stuff necessary for the datatypes are done, more needed) - (define* (~make-struct-type . args) - (let ([args (!!list args)]) - (call-with-values (lambda () (apply make-struct-type args)) ~values))) - - ;; -------------------------------------------------------------------------- - ;; Applications - - ;; Basic names: - ;; `app': syntax, calls a function over given arguments - ;; `apply': function, last argument is a list of arguments to the function - ;; Conventions: - ;; `!*---': forces args when needed (depending on the function) - ;; doesn't force the function (internal use only) - ;; `!---': forces function, and forces args when needed - ;; `~!---': adds a delay wrapper to the application (uses the above) - ;; (this is a macro in the `apply' case too) - ;; `~!*---': like the previous, but does not force the function (internal) - ;; Provided stuff: - ;; `~!%app': provided as `#%app' -- similar to `~!app' but treats a few - ;; application kinds as special (mostly all kinds of forces) - ;; `!apply': provided as `apply' (no need to provide `~!apply', since all - ;; function calls are delayed by `#%app') - - (define (extract-if-lazy-proc f) - (or (procedure-extract-target f) f)) - (define-syntax (!*app stx) - (syntax-case stx () - [(_ f x ...) - (let ([$$ (lambda (stx) - (stepper-syntax-property - stx - 'stepper-skipto - (append skipto/cddr - `(both-l () (car)))))] - [$ (lambda (stx) - (stepper-syntax-property - stx - 'stepper-skipto - (append skipto/cdr - skipto/first)))]) - (with-syntax ([(y ...) (generate-temporaries #'(x ...))]) - ;; use syntax/loc for better errors etc - (with-syntax ([lazy (syntax/loc stx ((extract-if-lazy-proc p) y ...))] - [strict (syntax/loc stx (p (hidden-! y) ...))]) - (quasisyntax/loc stx - ((lambda (p y ...) - #,($$ #'(if (lazy? p) lazy strict))) - f x ...) - #;(let ([p f] [y x] ...) - ;; #,($$ #`(if (lazy? p) lazy strict)) - (if (lazy? p) lazy strict))))))])) - - (defsubst (!app f x ...) (!*app (hidden-! (mark-as-lazy-op f)) x ...)) - (defsubst (~!*app f x ...) (hidden-~ (!*app f x ...))) - (defsubst (~!app f x ...) (hidden-~ (!app f x ...))) - - (define-for-syntax (toplevel?) - (memq (syntax-local-context) - '(top-level module module-begin))) ; not sure about module-begin - - ;; What happens when encoutering a toplevel non-definition expression? - (provide toplevel-forcer) - (define toplevel-forcer (make-parameter !)) - - (provide (rename-out [~!%app #%app])) ; all applications are delayed - (define-syntax (~!%app stx) ; provided as #%app - #;(define (unwinder stx rec) - (syntax-case stx (!) - [(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body) - (with-syntax ([(f x ...) (rec #'(f x ...))]) - #'(f x ...))])) - #;(define (stepper-annotate stx) - (let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)] - [stx (stepper-syntax-property stx 'stepper-skip-double-break #t)]) - stx)) - (syntax-case stx (~) - ;; the usual () shorthand for null - [(_) #'null] - [(_ ~ x) (syntax/loc stx (~ x))] ; not really needed - [(_ f x ...) - (cond [(let ([f #'f]) - (and (identifier? f) - (ormap (lambda (s) (free-identifier=? f s)) - strict-names))) - ;; strict function => special forms => use plain application - (syntax/loc stx (f x ...))] - [(toplevel?) - ;; toplevel expressions are always forced - (syntax/loc stx ((toplevel-forcer) (!app f x ...)))] - [else (syntax/loc stx (~!app f x ...))])])) - - (define (!*apply f . xs) - (let ([xs (!list (apply list* xs))]) - (apply f (if (lazy? f) xs (map ! xs))))) - (define* (!apply f . xs) - (let ([f (! f)] [xs (!list (apply list* xs))]) - (apply f (if (lazy? f) xs (map ! xs))))) - (defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs))) - (defsubst (~!apply f . xs) (hidden-~ (!apply f . xs))) - - (provide (rename-out [!apply apply])) ; can only be used through #%app => delayed - - ;; do the same special treatment for toplevel variable expressions - (provide (rename-out [!top #%top])) - (define-syntax (!top stx) - (syntax-case stx () - [(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))])) - - ;; used for explicitly strict/lazy calls - (defsubst (strict-call f x ...) (hidden-~ (f (! x) ...))) - (defsubst (lazy-call f x ...) (hidden-~ (f x ...))) - - ;; -------------------------------------------------------------------------- - ;; Special forms that are now functions - - ;; Since these things are rarely used as functions, they are defined as - ;; macros that expand to the function form when used as an expression. - - (define* *if - (case-lambda [(e1 e2 e3) (if (! e1) e2 e3)] - [(e1 e2 ) (when (! e1) e2 )])) - (defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3)) - (~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 )) - ~if *if) - - (define* (*and . xs) - (let ([xs (!list xs)]) - (or (null? xs) - (let loop ([x (car xs)] [xs (cdr xs)]) - (if (null? xs) x (and (! x) (loop (car xs) (cdr xs)))))))) - (define-syntax !and - (syntax-rules () - [(_) (and)] - [(_ x ... y) (and (hidden-! x) ... y)])) - (defsubst (~and x ...) (hidden-~ (!and x ...)) ~and *and) - - (define* (*or . xs) - (let ([xs (!list xs)]) - (and (pair? xs) - (let loop ([x (car xs)] [xs (cdr xs)]) - (if (null? xs) x (or (! x) (loop (car xs) (cdr xs)))))))) - (define-syntax !or - (syntax-rules () - [(_) (or)] - [(_ x ... y) (or (hidden-! x) ... y)])) - (defsubst (~or x ...) (hidden-~ (!or x ...)) ~or *or) - - ;; -------------------------------------------------------------------------- - ;; Special forms that are still special forms since they use ~begin - - (defsubst (~begin0 x y ...) ; not using ~begin, but equivalent - (hidden-~ (let ([val (hidden-! x)]) (hidden-! y) ... val))) - - (defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...)))) - (defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...)))) - - ;; -------------------------------------------------------------------------- - ;; Misc stuff - - ;; Just for fun... - (defsubst (~set! id expr) (hidden-~ (set! id (hidden-! expr)))) - ;; The last ! above is needed -- without it: - ;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a) - ;; goes into an infinite loop. (Thanks to Jos Koot) - - (define* (~set-mcar! mpair val) (~ (set-mcar! (! mpair) val))) - (define* (~set-mcdr! mpair val) (~ (set-mcdr! (! mpair) val))) - (define* (~vector-set! vec i val) (~ (vector-set! (! vec) (! i) val))) - (define* (~set-box! box val) (~ (set-box! (! box) val))) - - ;; not much to do with these besides inserting strictness points and ~begin - ; for stepper: change else to #t test, add new error else branch - (define-syntax (~cond stx) - (syntax-case stx () - [(_ clause ...) ; stepper needs the loc of the full clause - (with-syntax - ([(new-clause ...) - (map - (λ (c) - (with-syntax ([(test body ...) c]) - (with-syntax - ([new-test - (syntax-case #'test (else) - [else ; for stepper - (stepper-syntax-property #'#t 'stepper-else #t)] - [x (syntax/loc #'x (hidden-! x))])]) - (syntax/loc c (new-test (~begin body ...)))))) - (syntax->list #'(clause ...)))] - [new-else-body (syntax/loc stx (error 'cond "should not get here"))]) - (quasisyntax/loc stx - (hidden-~ - #,(syntax/loc stx - (cond - new-clause ... - [else new-else-body])))))])) - (defsubst (~case v [keys body ...] ...) - (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...))) - - ;; Doing this will print the whole thing, but problems with infinite things - (define* (~error . args) (apply error (!! args))) - - ;; I/O shows the whole thing - (define* (~printf fmt . args) (apply printf (! fmt) (!! args))) - (define* (~fprintf p fmt . args) (apply fprintf (! p) (! fmt) (!! args))) - (define* (~display x . port) (apply display (!! x) (!!list port))) - (define* (~write x . port) (apply write (!! x) (!!list port))) - (define* (~print x . port) (apply print (!! x) (!!list port))) - - ;; -------------------------------------------------------------------------- - ;; Equality functions - - ;; All of these try to stop if the promises are the same. - - (define* (~eq? . args) - (or (apply eq? (!list args)) (apply eq? (!!list args)))) - - (define* (~eqv? . args) - (or (apply eqv? (!list args)) (apply eqv? (!!list args)))) - - ;; for `equal?' we must do a recursive scan - (define (equal2? x y) - (cond [(pair? x) (and (pair? y) - (~equal? (car x) (car y)) - (~equal? (cdr x) (cdr y)))] - [(vector? x) - (let ([k (vector-length x)]) - (and (vector? y) - (= k (vector-length y)) - (let loop ([i 0]) - (or (= i k) - (and (~equal? (vector-ref x i) (vector-ref y i)) - (loop (add1 i)))))))] - [(struct? x) - (and (struct? y) - (let-values ([(xtype xskipped?) (struct-info x)] - [(ytype yskipped?) (struct-info y)]) - (and xtype ytype (not xskipped?) (not yskipped?) - (eq? xtype ytype) - (let*-values ([(name initk autok ref set imms spr skp?) - (struct-type-info xtype)] - [(k) (+ initk autok)]) - (let loop ([i 0]) - (or (= i k) (and (~equal? (ref x i) (ref y i)) - (loop (add1 i)))))))))] - [(box? x) (and (box? y) (~equal? (unbox x) (unbox y)))] - [else #f])) - (define* (~equal? x y . args) - (let ([args (!list args)]) - (if (pair? args) - (and (~equal? x y) (apply ~equal? x (cdr args))) - (or (equal? x y) - (let ([x (! x)] [y (! y)]) - (or (equal? x y) (equal2? x y))))))) - - ;; -------------------------------------------------------------------------- - ;; List functions - - (define* (~list? x) (list? (!list x))) ; must force the whole list - (define* (~length l) (length (!list l))) ; for these - - (define* (~car x) (car (! x))) ; these are for internal use: ~!app will do - (define* (~cdr x) (cdr (! x))) ; this job when using this language - (define* (~caar x) (car (! (car (! x))))) - (define* (~cadr x) (car (! (cdr (! x))))) - (define* (~cdar x) (cdr (! (car (! x))))) - (define* (~cddr x) (cdr (! (cdr (! x))))) - (define* (~caaar x) (car (! (~caar x)))) - (define* (~caadr x) (car (! (~cadr x)))) - (define* (~cadar x) (car (! (~cdar x)))) - (define* (~caddr x) (car (! (~cddr x)))) - (define* (~cdaar x) (cdr (! (~caar x)))) - (define* (~cdadr x) (cdr (! (~cadr x)))) - (define* (~cddar x) (cdr (! (~cdar x)))) - (define* (~cdddr x) (cdr (! (~cddr x)))) - (define* (~caaaar x) (car (! (~caaar x)))) - (define* (~caaadr x) (car (! (~caadr x)))) - (define* (~caadar x) (car (! (~cadar x)))) - (define* (~caaddr x) (car (! (~caddr x)))) - (define* (~cadaar x) (car (! (~cdaar x)))) - (define* (~cadadr x) (car (! (~cdadr x)))) - (define* (~caddar x) (car (! (~cddar x)))) - (define* (~cadddr x) (car (! (~cdddr x)))) - (define* (~cdaaar x) (cdr (! (~caaar x)))) - (define* (~cdaadr x) (cdr (! (~caadr x)))) - (define* (~cdadar x) (cdr (! (~cadar x)))) - (define* (~cdaddr x) (cdr (! (~caddr x)))) - (define* (~cddaar x) (cdr (! (~cdaar x)))) - (define* (~cddadr x) (cdr (! (~cdadr x)))) - (define* (~cdddar x) (cdr (! (~cddar x)))) - (define* (~cddddr x) (cdr (! (~cdddr x)))) - - (define* (~list-ref l k) - (let ([k (! k)]) - (unless (exact-nonnegative-integer? k) - (raise-type-error 'list-ref "non-negative exact integer" 1 l k)) - (let loop ([k k] [l (! l)]) - (cond [(not (pair? l)) - (raise-type-error 'list-ref "proper list" l)] - [(zero? k) (car l)] - [else (loop (sub1 k) (! (cdr l)))])))) - (define* (~list-tail l k) - (let ([k (! k)]) - (unless (exact-nonnegative-integer? k) - (raise-type-error 'list-tail "non-negative exact integer" 1 l k)) - (let loop ([k k] [l l]) ; don't force here -- unlike list-ref - (cond [(zero? k) l] - [else (let ([l (! l)]) - (unless (pair? l) - (raise-type-error 'list-tail "list" l)) - (loop (sub1 k) (cdr l)))])))) - - (define* (~append . xs) - (let ([xs (!list xs)]) - (cond [(null? xs) '()] - [(null? (cdr xs)) (car xs)] - [else (let ([ls (~ (apply ~append (cdr xs)))]) - (let loop ([l (! (car xs))]) - (if (null? l) - ls - (cons (car l) (~ (loop (! (cdr l))))))))]))) - - ;; useful utility for many list functions below - (define (!cdr l) (! (cdr l))) - - (define-syntax (deflistiter stx) - (syntax-case stx (extra: null ->) - [(deflistiter (?~name ?proc ?args ... ?l . ?ls) - null -> ?base - ?loop -> ?step-single ?step-multiple) - #'(deflistiter (?~name ?proc ?args ... ?l . ?ls) - extra: - null -> ?base - ?loop -> ?step-single ?step-multiple)] - [(deflistiter (?~name ?proc ?args ... ?l . ?ls) - extra: [?var ?init] ... - null -> ?base - ?loop -> ?step-single ?step-multiple) - (with-syntax ([?name (let* ([x (symbol->string (syntax-e #'?~name))] - [x (regexp-replace #rx"^~" x "")] - [x (string->symbol x)]) - (datum->syntax #'?~name x #'?~name))]) - #'(define* ?~name - (case-lambda - [(?proc ?args ... ?l) - (let ([?proc (hidden-! ?proc)]) - (let ?loop ([?l (hidden-! ?l)] [?var ?init] ...) - (if (null? ?l) - ?base - ?step-single)))] - [(?proc ?args ... ?l . ?ls) - (let ([?proc (hidden-! ?proc)]) - (let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...) - (if (ormap null? ?ls) - (if (andmap null? ?ls) - ?base - (error '?name "all lists must have same size")) - ?step-multiple)))])))])) - - ;; These use the `*' version of app/ly, to avoid forcing the function over - ;; and over -- `deflistiter' forces it on entry - (deflistiter (~map proc l . ls) - null -> '() - loop -> (cons (~!*app proc (car l)) (~ (loop (! (cdr l))))) - (cons (~!*apply proc (map car ls)) (~ (loop (map !cdr ls))))) - (deflistiter (~for-each proc l . ls) - null -> (void) - loop -> (begin (! (!*app proc (car l))) (loop (! (cdr l)))) - (begin (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) - (deflistiter (~andmap proc l . ls) - null -> #t - loop -> (and (! (!*app proc (car l))) (loop (! (cdr l)))) - (and (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) - (deflistiter (~ormap proc l . ls) - null -> #f - loop -> (or (! (!*app proc (car l))) (loop (! (cdr l)))) - (or (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) - (deflistiter (foldl proc init l . ls) - extra: [acc init] - null -> acc - loop -> - (~ (loop (! (cdr l)) (~!*app proc (car l) acc))) - (~ (loop (map !cdr ls) - (~!*apply proc (append (map car ls) (list acc)))))) - (deflistiter (foldr proc init l . ls) - null -> init - loop -> - (~!*app proc (car l) (~ (loop (! (cdr l))))) - (~!*apply proc (append (map car ls) (list (~ (loop (map !cdr ls))))))) - - (define (do-member name = elt list) ; no currying for procedure names - ;; `elt', `=', and `name' are always forced values - (let loop ([list (! list)]) - (cond [(null? list) #f] - [(not (pair? list)) (error name "not a proper list: ~e" list)] - [(= elt (! (car list))) list] - [else (loop (! (cdr list)))]))) - (define* (~member elt list) (do-member 'member ~equal? (! elt) list)) - (define* (~memq elt list) (do-member 'memq ~eq? (! elt) list)) - (define* (~memv elt list) (do-member 'memv ~eqv? (! elt) list)) - - (define (do-assoc name = key alist) ; no currying for procedure names - ;; `key', `=', and `name' are always forced values - (let loop ([alist (! alist)]) - (cond [(null? alist) #f] - [(not (pair? alist)) (error name "not a proper list: ~e" alist)] - [else (let ([cell (! (car alist))]) - (cond [(not (pair? cell)) - (error name "non-pair found in list: ~e" cell)] - [(= (! (car cell)) key) cell] - [else (loop (! (cdr alist)))]))]))) - (define* (~assoc key alist) (do-assoc 'assoc ~equal? (! key) alist)) - (define* (~assq key alist) (do-assoc 'assq ~eq? (! key) alist)) - (define* (~assv key alist) (do-assoc 'assv ~eqv? (! key) alist)) - - (define* (~reverse list) - (let ([list (!list list)]) - (reverse list))) - - ;; -------------------------------------------------------------------------- - ;; Extra functionality that is useful for lazy list stuff - - (define* (take n l) - (let ([n0 (! n)]) - (unless (exact-nonnegative-integer? n0) - (raise-type-error 'take "non-negative exact integer" 0 n0 l)) - (let loop ([n n0] [l l]) - (if (zero? n) - '() - (let ([l (! l)]) - (cond [(null? l) - ;; it would be fine to force the whole list (since we now - ;; know it's finite), but doing so means keeping a reference - ;; to its head, which can lead to memory leaks. - (error 'take "index ~e too large for input list" n0)] - [(pair? l) (cons (car l) (~ (loop (sub1 n) (cdr l))))] - [else (error 'take "not a proper list: ~e" l)])))))) - - ;; not like Haskell's `cycle' that consumes a list - (define* (cycle . l) - (letrec ([r (~ (~append (! l) r))]) - r)) - - ;; -------------------------------------------------------------------------- - ;; mzlib/list functionality - - ;; These are a hack, they're not the same due to different error - ;; messages (and they work with improper lists too). - (define* (rest x) (~cdr x)) - (define* (first x) (~car x)) - (define* (second x) (~cadr x)) - (define* (third x) (~caddr x)) - (define* (fourth x) (~cadddr x)) - (define* (fifth x) (~car (~cddddr x))) - (define* (sixth x) (~cadr (~cddddr x))) - (define* (seventh x) (~caddr (~cddddr x))) - (define* (eighth x) (~cadddr (~cddddr x))) - (define* (cons? x) (pair? (! x))) - (define* empty null) - (define* (empty? x) (null? (! x))) - - (require (only-in racket/list [last-pair !last-pair])) - (define* (last-pair list) (!last-pair (!list list))) - - (define (do-remove name item list =) - (let ([= (! =)]) - (let loop ([list (! list)]) - (cond [(null? list) list] - [(not (pair? list)) - (error name "not a proper list: ~e" list)] - [(!*app = item (car list)) (cdr list)] - [else (cons (car list) (~ (loop (! (cdr list)))))])))) - (define* remove - (case-lambda [(item list ) (do-remove 'remove item list ~equal?)] - [(item list =) (do-remove 'remove item list =)])) - (define* (remq item list) (do-remove 'remq item list ~eq?)) - (define* (remv item list) (do-remove 'remv item list ~eqv?)) - - (define (do-remove* name items list =) - (let ([= (! =)] [items (!list items)]) - (let loop ([list (! list)]) - (cond [(null? list) list] - [(not (pair? list)) - (error name "not a proper list: ~e" list)] - [else - (let ([xs (~ (loop (! (cdr list))))]) - (if (memf (lambda (item) (!*app = item (car list))) items) - xs - (cons (car list) xs)))])))) - (define* remove* - (case-lambda [(items list ) (do-remove* 'remove* items list ~equal?)] - [(items list =) (do-remove* 'remove* items list =)])) - (define* (remq* items list) (do-remove* 'remq* items list ~eq?)) - (define* (remv* items list) (do-remove* 'remv* items list ~eqv?)) - - (define* (memf pred list) - (let ([pred (! pred)]) - (let loop ([list (! list)]) - (cond [(null? list) #f] - [(not (pair? list)) (error 'memf "not a proper list: ~e" list)] - [(!*app pred (car list)) list] - [else (loop (! (cdr list)))])))) - - (define* (assf pred alist) - (let ([pred (! pred)]) - (let loop ([alist (! alist)]) - (cond [(null? alist) #f] - [(not (pair? alist)) (error 'assf "not a proper list: ~e" alist)] - [else (let ([cell (! (car alist))]) - (cond [(not (pair? cell)) - (error 'assf "non-pair found in list: ~e" cell)] - [(!*app pred (car cell)) cell] - [else (loop (! (cdr alist)))]))])))) - - (define* (filter pred list) - (let ([pred (! pred)]) - (let loop ([list (! list)]) - (cond [(null? list) list] - [(pair? list) - (let ([x (car list)] - [xs (~ (loop (! (cdr list))))]) - (if (! (!*app pred x)) (cons x xs) xs))] - [else (error 'filter "not a proper list: ~e" list)])))) - - (require (only-in racket/base [sort !sort])) - (define* (sort list less?) - (let ([less? (! less?)]) - (!sort (!list list) (lambda (x y) (! (!*app less? x y)))))) - - ;; -------------------------------------------------------------------------- - ;; mzlib/etc functionality - - (require (only-in racket/bool boolean=? symbol=?)) - (define* true #t) - (define* false #f) - - (define* (identity x) x) - ;; no need for dealing with multiple values since students don't use them - (define* (compose . fs) - (let ([fs (!list fs)]) - (cond [(null? fs) identity] - [(null? (cdr fs)) (car fs)] - [else (let ([fs (reverse fs)]) - (lambda xs - (let loop ([fs (cdr fs)] - [x (~!apply (car fs) xs)]) - (if (null? fs) - x - (loop (cdr fs) (~!app (car fs) x))))))]))) - - (define* (build-list n f) - (let ([n (! n)] [f (! f)]) - (unless (exact-nonnegative-integer? n) - (error 'build-list "~s must be an exact integer >= 0" n)) - (unless (procedure? f) - (error 'build-list "~s must be a procedure" f)) - (let loop ([i 0]) - (if (>= i n) - '() - (cons (~ (f i)) (~ (loop (add1 i)))))))) - - ;; -------------------------------------------------------------------------- - ;; Provide everything except some renamed stuff - - (define-syntax (provide-strict-names stx) - #`(provide #,@strict-names)) - (provide-strict-names) - - (define-syntax (renaming-provide stx) - (syntax-case stx () - [(_ id ...) - (with-syntax - ([(~id ...) - (map (lambda (id) - (let* ([str (symbol->string (syntax-e id))] - [~id (string->symbol (string-append "~" str))]) - (datum->syntax id ~id id))) - (syntax->list #'(id ...)))]) - #'(provide (except-out (all-from-out racket/base) module #%app apply #%top λ - id ...) - (rename-out [~id id] ...)))])) - (renaming-provide - lambda define let let* letrec parameterize - values define-values let-values let*-values letrec-values make-struct-type - cons list list* vector box - if and or begin begin0 when unless - set! set-mcar! set-mcdr! vector-set! set-box! - cond case error printf fprintf display write print - eq? eqv? equal? - list? length list-ref list-tail append map for-each andmap ormap - member memq memv assoc assq assv reverse - caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar - caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr) - - (provide - ;; multiple values (see above) - split-values - ;; explicit strict/lazy calls - strict-call lazy-call - ;; `list' stuff - first second third fourth fifth sixth seventh eighth rest cons? empty empty? - foldl foldr last-pair remove remq remv remove* remq* remv* memf assf filter - sort - ;; `etc' stuff - true false boolean=? symbol=? identity compose build-list - ;; extra stuff for lazy Scheme - take cycle) - - -#| -;; Some tests -(cadr (list (/ 1 0) 1 (/ 1 0))) -> 1 -(foldl + 0 '(1 2 3 4)) -> 10 -(foldl (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 -(foldl (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 -(foldr + 0 '(1 2 3 4)) -> 10 -(foldr (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 -(foldr (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 -(define ones (cons 1 ones)) -(take 5 (foldr cons '() ones)) -> (1 1 1 1 1) -(define a (list (/ 1 0) 2 (/ 3 0))) -(caadr (map list a)) -> 2 -(cadr (map + a a)) -> 4 -(andmap even? '(1 2 3 4)) -> #f -(ormap even? '(1 2 3 4)) -> #t -(ormap even? '(1 21 3 41)) -> #f -(andmap even? (list 1 2 3 (/ 4 0))) -> #f -|# +(require (except-in lazy/list + take)) +(provide (all-from-out lazy/base + lazy/list)) diff -Nru racket-6.12+ppa1/share/pkgs/lazy/list.rkt racket-7.0+ppa1/share/pkgs/lazy/list.rkt --- racket-6.12+ppa1/share/pkgs/lazy/list.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/lazy/list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,249 @@ +#lang lazy/base + +(require + (prefix-in ! racket/list) + (except-in + racket/list + first second third fourth fifth sixth seventh eighth + rest last-pair + make-list + take drop split-at takef dropf splitf-at + take-right drop-right split-at-right takef-right dropf-right splitf-at-right + add-between + append* + flatten + remove-duplicates + filter-map count partition + range + append-map + filter-not + argmin argmax)) + +(provide (all-from-out racket/list) + last-pair + take drop split-at takef dropf splitf-at + take-right drop-right split-at-right takef-right dropf-right splitf-at-right + add-between + append* + flatten + remove-duplicates + filter-map count partition + range + append-map + filter-not + argmin argmax) + +;; lazy versions of exports from racket/list +;; --------------------------------------------------------------------------------------------------- + +(define (last-pair p) + (let ([p (! p)]) + (unless (pair? p) + (raise-argument-error 'last-pair "pair?" p)) + (let loop ([p p]) + (define next (! (cdr p))) + (if (pair? next) (loop next) p)))) + +(define (make-list n v) + (let ([n (! n)]) + (unless (exact-nonnegative-integer? n) + (raise-argument-error 'make-list "exact-nonnegative-integer?" 0 n v)) + (let loop ([n n] + [acc '()]) + (if (zero? n) acc + (loop (sub1 n) (cons v acc)))))) + +(define (take l n) + (let ([n (! n)]) + (unless (exact-nonnegative-integer? n) + (raise-argument-error 'take "exact-nonnegative-integer?" 1 l n)) + (let loop ([n n] [l l]) + (if (zero? n) + '() + (let ([l (! l)]) + (cond [(null? l) + ;; it would be fine to force the whole list (since we now + ;; know it's finite), but doing so means keeping a reference + ;; to its head, which can lead to memory leaks. + (raise-arguments-error 'take + "index is too large for input list" + "index" n)] + [(pair? l) (cons (car l) (loop (sub1 n) (! (cdr l))))] + [else (raise-argument-error 'take "list?" l)])))))) + +(define (split-at l n) + (let ([n (! n)]) + (unless (exact-nonnegative-integer? n) + (raise-argument-error 'split-at "exact-nonnegative-integer?" 1 l n)) + (let loop ([n n] [l l]) + (if (zero? n) + (values '() l) + (let ([l (! l)]) + (cond [(null? l) + ;; see comment for `take` + (raise-arguments-error 'split-at + "index is too large for input list" + "index" n)] + [(pair? l) + (define-values (a b) (loop (sub1 n) (! (cdr l)))) + (values (cons (car l) a) b)] + [else (raise-argument-error 'split-at "list?" l)])))))) + +(define (drop lst pos) + (list-tail lst pos)) + +(define (takef lst pred) + (let ([pred (! pred)]) + (unless (procedure? pred) + (raise-argument-error 'takef "procedure?" 1 lst pred)) + (let loop ([lst (! lst)]) + (cond + [(and (pair? lst) (! (pred (car lst)))) + (cons (car lst) (loop (cdr lst)))] + [else '()])))) + +(define (dropf lst pred) + (let ([pred (! pred)]) + (unless (procedure? pred) + (raise-argument-error 'takef "procedure?" 1 lst pred)) + (let loop ([lst (! lst)]) + (cond + [(and (pair? lst) (! (pred (car lst)))) + (loop (cdr lst))] + [else lst])))) + +(define (splitf-at lst pred) + (let ([pred (! pred)]) + (unless (procedure? pred) + (raise-argument-error 'takef "procedure?" 1 lst pred)) + (let loop ([lst (! lst)]) + (cond + [(and (pair? lst) (! (pred (car lst)))) + (define-values (a b) (loop (cdr lst))) + (values (cons (car lst) a) b)] + [else (values '() lst)])))) + +(define (take-right l n) + (drop l (- (improper-length l) n))) + +(define (drop-right l n) + (take l (- (improper-length l) n))) + +(define (split-at-right l n) + (split-at l (- (improper-length l) n))) + +(define (takef-right l pred) + (improper-reverse (takef (improper-reverse l) pred))) + +(define (dropf-right l pred) + (improper-reverse (dropf (improper-reverse l) pred))) + +(define (splitf-at-right l pred) + (improper-reverse (splitf-at (improper-reverse l) pred))) + +;; keyword arguments currently do not work to due Lazy Racket limitations +(define (add-between lst v + #:before-first [before-first '()] + #:before-last [before-last v] + #:after-last [after-last '()] + #:splice? [splice? #f]) + (define middle + (let ([lst (!list lst)]) + (cons (car lst) + (let loop ([lst (cdr lst)]) + (cond + [(null? lst) '()] + [else ((if splice? append list*) + (if (null? (cdr lst)) before-last v) + (if splice? (list (car lst)) (car lst)) + (loop (cdr lst)))]))))) + (if splice? + (append before-first middle after-last) + middle)) + +(define (append* . args) + (define-values (head tail) (split-at-right args 1)) + (apply append (append head (apply append tail)))) + +(define (flatten v) + (let ([v (! v)]) + (cond + [(pair? v) (append (flatten (car v)) (flatten (cdr v)))] + [(null? v) '()] + [else (list v)]))) + +(define (remove-duplicates lst [same? equal?] #:key [extract-key (λ (x) x)]) + (let loop ([lst (!list lst)]) + (if (null? lst) '() + (cons (car lst) (loop (remove* (list (car lst)) lst + (λ (a b) (same? (extract-key a) (extract-key b))))))))) + +(define (filter-map proc lst . lsts) + (let loop ([lsts (cons lst lsts)]) + (cond + [(null? (! (car lsts))) '()] + [else + (define result (apply proc (map car lsts))) + (if result + (cons result (loop (map cdr lsts))) + (loop (map cdr lsts)))]))) + +(define (count proc lst . lsts) + (let loop ([lsts (cons lst lsts)] + [acc 0]) + (cond + [(null? (! (car lsts))) acc] + [else + (define result (apply proc (map car lsts))) + (loop (map cdr lsts) (if result (add1 acc) acc))]))) + +(define (partition pred lst) + (let loop ([lst (!list lst)]) + (cond + [(null? lst) (values '() '())] + [else + (define-values (a b) (loop (cdr lst))) + (if (pred (car lst)) + (values (cons (car lst) a) b) + (values a (cons (car lst) b)))]))) + +(define range + (case-lambda + [(end) (range 0 end)] + [(start end) (range start end 1)] + [(start end step) + (let loop ([n start]) + (cond + [(if (positive? step) + (n . >= . end) + (n . <= . end)) '()] + [else + (cons n (loop (+ n step)))]))])) + +(define (append-map proc lst . lsts) + (append* (apply map proc lst lsts))) + +(define (filter-not pred lst) + (filter (λ (x) (not (pred x))) lst)) + +(define (argmin proc lst) + (!argmin proc (!list lst))) + +(define (argmax proc lst) + (!argmax proc (!list lst))) + +;; internal utility functions +;; --------------------------------------------------------------------------------------------------- + +(define (improper-length lst) + (let loop ([n 0] [lst (! lst)]) + (cond + [(pair? lst) (loop (add1 n) (! (cdr lst)))] + [else n]))) + +(define (improper-reverse lst) + (let loop ([lst (! lst)] + [acc '()]) + (cond + [(pair? lst) (loop (! (cdr lst)) (cons (car lst) acc))] + [else acc]))) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger/info.rkt racket-7.0+ppa1/share/pkgs/macro-debugger/info.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "class-iop-lib" "compatibility-lib" "data-lib" "gui-lib" "images-lib" "images-gui-lib" "parser-tools-lib" "macro-debugger-text-lib" ("draw-lib" #:version "1.7")))) (define build-deps (quote ("racket-index" "rackunit-lib" "scribble-lib" "racket-doc"))) (define pkg-desc "The macro debugger tool") (define pkg-authors (quote (ryanc))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "class-iop-lib" "compatibility-lib" "data-lib" "gui-lib" "images-lib" "images-gui-lib" "parser-tools-lib" "macro-debugger-text-lib" ("draw-lib" #:version "1.7")))) (define build-deps (quote ("racket-index" "rackunit-lib" "scribble-lib" "racket-doc"))) (define pkg-desc "The macro debugger tool") (define pkg-authors (quote (ryanc))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger/tests/macro-debugger/tests/syntax-errors.rkt racket-7.0+ppa1/share/pkgs/macro-debugger/tests/macro-debugger/tests/syntax-errors.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger/tests/macro-debugger/tests/syntax-errors.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger/tests/macro-debugger/tests/syntax-errors.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -198,7 +198,7 @@ (testKE (lambda () (define-values (x) 1)) [#:rename+error-step rename-lambda]) (testKE (lambda () (define-values (x) 1) . 2) - [#:rename+error-step rename-lambda]) + #:error-step) (testKE (lambda () (begin (define-values (x) 1) . 2)) [#:rename+error-step rename-lambda]) (testKE (lambda () (begin (define-values (x) 1) . 2) 3) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "class-iop-lib" "parser-tools-lib"))) (define pkg-desc "The macro debugger tool with a console interface") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "db-lib" "class-iop-lib" "parser-tools-lib"))) (define pkg-desc "The macro debugger tool with a console interface") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/get-references.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/get-references.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/get-references.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/private/get-references.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -122,8 +122,8 @@ (void)] [(p:variable z1 z2 rs ?1) (void)] - [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift) - (recur locals check body)] + [(p:module z1 z2 rs ?1 locals tag rename check tag2 check2 ?3 body shift) + (recur locals check check2 body)] [(p:#%module-begin z1 z2 rs ?1 me body ?2 subs) (recur body subs)] [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/profile.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/profile.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/profile.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/analysis/profile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,10 @@ #lang racket/base (require racket/list + racket/match + racket/dict racket/set racket/string + racket/format racket/cmdline (rename-in racket/match [match-define defmatch]) racket/pretty @@ -9,8 +12,10 @@ syntax/id-table syntax/modresolve syntax/modcode + setup/collects ;; setup/path-to-relative macro-debugger/model/deriv "private/util.rkt") +(provide (all-defined-out)) ;; term-size : Syntaxish -> Nat ;; Rough measure of the size of a term. @@ -33,204 +38,149 @@ (+ (term-size k) (term-size v))))] [else 1])))))) -;; ---- - -;; A ProfInfo is (profinfo Hash[Nat => (Listof Occ)] Nat Nat) -;; The hash maps each phase to a DeltaTable. - -;; An Occ is (list Context Integer) -;; -- code size delta (|expanded| - |original|) -(struct profinfo (phases init-size final-size) #:mutable) - -(define (make-profinfo) (profinfo (make-hash) 0 0)) - -(define (profinfo-add! profinfo phase occ) - (define phases (profinfo-phases profinfo)) - (hash-set! phases phase (cons occ (hash-ref phases phase null)))) - -;; ---- - -;; profile : (Listof ModulePath) -> ProfInfo -(define (profile modpaths) - (define profinfo (make-profinfo)) - (for ([modpath (in-list modpaths)]) - (define-values (compiled deriv) (get-module-code/trace modpath)) - (set-profinfo-init-size! profinfo - (+ (term-size (node-z1 deriv)) (profinfo-init-size profinfo))) - (set-profinfo-final-size! profinfo - (+ (term-size (node-z2 deriv)) (profinfo-final-size profinfo))) - (profile/deriv deriv profinfo)) - (profinfo->profile profinfo)) - -;; ---- - -;; A Profile is (list Nat Nat Hash[Nat => PhaseProfile]) -;; A PhaseProfile is (Listof ProfileEntry) -;; A ProfileEntry is (list Identifier IndirectStats DirectStats) -;; A DirectStats is (list Nat Nat Nat Real (Listof Nat)) -;; -- total, mean (rounded), count, stddev, raw data -;; An IndirectStats is Nat -- total +(define (sqr x) (* x x)) -(define (pe->total pe) (second pe)) -(define (pe->direct pe) (first (third pe))) -(define (pe->count pe) (third (third pe))) -(define (pe->totalmean pe) (/ (pe->total pe) (pe->count pe))) -(define (pe->directmean pe) (/ (pe->direct pe) (pe->count pe))) +(define (push! b x) (set-box! b (cons x (unbox b)))) -(define (profinfo->profile profinfo) - (list (profinfo-init-size profinfo) - (profinfo-final-size profinfo) - (for/hash ([(ph occs) (in-hash (profinfo-phases profinfo))]) - (parameterize ((phase ph)) - (define direct (occs->direct-table occs)) - (define indirect (occs->indirect-table occs)) - (define entries - (for/list ([(id direct) (in-free-id-table direct)]) - (list id (free-id-table-ref indirect id 0) direct))) - (values ph entries))))) - -;; A DirectTable is FreeIdTable[DirectStats] -;; An IndirectTable is FreeIdTable[IndirectStats] - -(define (occs->direct-table occs) - (define t (make-free-id-table)) - (for ([occ (in-list occs)]) - (defmatch (list (cons macro-id context) delta) occ) - (free-id-table-set! t macro-id (cons delta (free-id-table-ref t macro-id null)))) - (define dt (make-free-id-table)) - (for ([(id deltas) (in-free-id-table t)]) - (free-id-table-set! dt id (deltas->direct-stats deltas))) - dt) +;; enclosing-modpath : Parameterof ModulePath/#f +(define enclosing-modpath (make-parameter #f)) -(define (deltas->direct-stats deltas) - (define sum (apply + deltas)) - (define count (length deltas)) - (define mean (/ sum count)) - (define imean (exact->inexact mean)) - (define var (/ (for/sum ([delta (in-list deltas)]) (sqr (- delta imean))) count)) - (list sum (round mean) count (sqrt var) deltas)) +;; nice-modpath : ModulePath/ModulePathIndex [Datum/#f] -> Datum +(define (nice-modpath mod) + (define rmp0 + (cond [(module-path-index? mod) + (unless (enclosing-modpath) + (error 'nice-modpath "enclosing modpath not set")) + (resolve-module-path-index mod (enclosing-modpath))] + [else (resolve-module-path mod)])) + (let loop ([rmp rmp0]) + (match rmp + [(? path?) + (match (path->collects-relative rmp #:cache nice-modpath-cache) + [(list* 'collects parts) + (define (bytes->string b) (path->string (bytes->path b))) + `(lib ,(string-join (map bytes->string parts) "/"))] + [(? path? p) (path->string p)])] + [(? symbol?) `(quote ,rmp)] + [(list* 'submod "." submodnames) + (match (and (enclosing-modpath) (nice-modpath (enclosing-modpath))) + [(list* 'submod enc-base enc-submodnames) + `(submod ,enc-base ,@(append enc-submodnames submodnames))] + [(? values enc-base) + `(submod ,enc-base ,@submodnames)] + [#f (error 'nice-modpath "relative submod path: ~e => ~e" mod rmp)])] + [(list* 'submod ".." submodnames) + (error 'nice-modpath "relative (up) submod path: ~e => ~e" mod rmp)] + [(list* 'submod base submodnames) + `(submod ,(loop base) ,@submodnames)] + [_ + (eprintf "nice-modpath: ~e, ~e\n" mod (enclosing-modpath)) + (eprintf " rmp0 = ~e\n" rmp0) + (eprintf " rmp = ~e\n" rmp) + (error 'nice-modpath "invalid")]))) + +(define nice-modpath-cache (make-hash)) + +;; ============================================================ +;; Raw Data Collection + +;; A moc (macro occurrence) is (moc Context Nat Nat Integer) +(struct moc (ctx init-size final-size adj) #:prefab) +(define (moc-phase m) (fr-phase (car (moc-ctx m)))) + +;; adj is adjustment for local expansion, usually negative + +;; Context is (listof Frame); Frame is (fr Id Nat) +;; (list (fr m2 0) (fr m1 0)) means an expansion of m2 at phase 0, +;; where the reference was produced by m1 at phase 0, which (probably) +;; occurred in the original program +(struct fr (id phase) #:prefab) + +(define (fr=? f1 f2) + (match* [f1 f2] + [[(fr id1 ph1) (fr id2 ph2)] + (and (= ph1 ph2) (free-identifier=? id1 id2 ph1))])) +(define (fr-hash-code f) + (match f [(fr id ph) (+ ph (equal-hash-code (identifier-binding-symbol id ph)))])) + +(define (context? v) (and (list? v) (andmap fr? v))) +(define (context=? ctx1 ctx2) + (and (= (length ctx1) (length ctx2)) (andmap fr=? ctx1 ctx2))) +(define (context-hash-code ctx) + (apply + (map fr-hash-code ctx))) + +(define-custom-hash-types fr-hash #:key? fr? + fr=? fr-hash-code) +(define-custom-hash-types ctx-hash #:key? context? + context=? context-hash-code) -(define (occs->indirect-table occs) - (define it (make-free-id-table)) - (for ([occ (in-list occs)]) - (defmatch (list context0 delta) occ) - (defmatch (cons macro-id context) (remove-duplicates context0 id/f=?)) - ;; Now context has no duplicates and does not contain macro-id. - (for ([ctx-id (in-list (cons macro-id context))]) - (free-id-table-set! it ctx-id (+ delta (free-id-table-ref it ctx-id 0))))) - it) - -(define (id/f=? a b) - (cond [(and (identifier? a) (identifier? b)) - (free-identifier=? a b (phase))] - [else (eq? a b)])) - -;; print-profile : Profile -;; #:sort (U 'total 'direct 'totalmean 'directmean) -;; #:excludes (Listof (Id Nat -> Boolean)) -;; -> Void -(define (print-profile pr - #:sort [sort-order 'total] - #:excludes [excludes null]) - (match pr - [(list init-size final-size p) - (printf "Initial code size: ~s\n" init-size) - (printf "Final code size: ~s\n" final-size) - (for ([(ph pes) (in-hash p)]) - (printf "~a\n" (make-string 40 #\-)) - (printf "Phase ~s\n" ph) - (parameterize ((phase ph)) - (for ([pe (in-list (sort pes > #:key (sort-order->key sort-order)))] - #:unless (for/or ([exclude (in-list excludes)]) (exclude (car pe) ph))) - (print-entry pe))) - (printf "\n"))])) - -(define (sort-order->key so) - (case so - [(total) pe->total] - [(direct) pe->direct] - [(totalmean) pe->totalmean] - [(directmean) pe->directmean])) - -;; make-exclude : String -> (Id Nat -> Boolean) -(define ((make-exclude prefix) id ph) - (match (identifier-binding id ph) - [(list* def-mpi def-sym _) - (let loop ([mod (mpi->module-path def-mpi)]) - (match mod - [(? string?) (string-prefix? mod prefix)] - [(? symbol?) (loop (symbol->string mod))] - [(? path?) (loop (path->string mod))] - [(list 'submod mod _ ...) (loop mod)] - [(list 'file mod) (loop mod)] - [(list 'lib mod) (loop mod)] - [_ #f]))] - [_ #f])) +;; ---------------------------------------- -(define (print-entry e) - (match e - [(list id indirect (list dtotal dmean dcount dstddev ddeltas)) - (unless (and (zero? indirect) (zero? dtotal)) - (printf "~a\n" (id->string id)) - (printf " total: ~s, mean: ~s\n" - indirect (round (/ indirect dcount))) - (printf " direct: ~s, mean: ~s, count: ~s, stddev: ~s\n" - dtotal dmean dcount dstddev))])) +;; A ScopeTable is Hash[ScopeInt => Context] -(define (id->string id) - (match (identifier-binding id (phase)) - [(list* def-mpi def-sym nom-mpi nom-sym def-phase _) - (define at-phase - (cond [(zero? def-phase) ""] - [else (format " at phase ~s" def-phase)])) - (cond [(eq? def-sym nom-sym) - (format "~s (defined in ~s~a)" - def-sym (mpi->module-path def-mpi) at-phase)] - [else - (format "~s (defined as ~s in ~s~a)" - nom-sym def-sym (mpi->module-path def-mpi) at-phase)])] - ['lexical - (format "~s (lexical)" (syntax-e id))] - [#f - (format "~s (top-level)" (syntax-e id))])) +;; get-new-scope : Syntax Syntax Nat -> ScopeInt +(define (get-new-scope x mx phase) + (define xi (get-macro-scopes x phase)) + (define mxi (get-macro-scopes mx phase)) + (define diff (set-subtract mxi xi)) + (match diff + [(list scope) scope] + [_ (error 'get-new-scope "bad scopes diff: ~e" diff)])) -(define (sqr x) (* x x)) +;; get-macro-scopes : Syntax Nat -> (listof ScopeInt) +(define (get-macro-scopes x phase) + (append* (for/list ([ph (in-range (add1 phase))]) + (for/list ([v (in-list (hash-ref (syntax-debug-info x ph) 'context))] + #:when (eq? (vector-ref v 1) 'macro)) + (vector-ref v 0))))) + +;; get-macro-scope : Syntax ScopeTable Nat -> ScopeInt/#f +;; Returns the last macro scope present in the table. +(define (get-macro-scope x h phase) + (define mscopes (sort (get-macro-scopes x phase) >)) + (for/first ([mscope (in-list mscopes)] #:when (hash-ref h mscope #f)) + mscope)) ;; ---------------------------------------- ;; phase : (Parameterof Nat) (define phase (make-parameter 0)) -;; scope=>context : Hash[Integer => (Listof Identifier)] -;; Maps macro scopes to contexts. -(define scope=>context (make-hash)) +;; moc-box : Parameterof (Boxof MOC) +(define moc-box (make-parameter #f)) -;; profile/deriv : Derivation ProfInfo -> Void +;; profile/top : Deriv -> (Listof MOC) +(define (profile/top deriv) + (define mocs (box null)) + (parameterize ((phase 0)) + (profile/deriv deriv mocs (make-hash))) + (unbox mocs)) + +;; profile/deriv : Derivation (Boxof MOC) -> Void ;; Record size deltas from all macro steps of deriv in profinfo. -(define (profile/deriv deriv profinfo) +(define (profile/deriv deriv mocs scope=>context) (define (recur . ds) (for ([d (in-list ds)]) (cond [(list? d) (for-each recur d)] - [else (profile/deriv d profinfo)]))) + [else (profile/deriv d mocs scope=>context)]))) (define (recur/phase-up . ds) - (parameterize ((phase (add1 (phase)))) (apply recur ds))) + (parameterize ((phase (add1 (phase)))) (recur ds))) ;; Handle individual variants (#%expression (match deriv ;; ==== [(mrule z1 z2 rs ?1 me1 locals me2 ?2 etx next) - (define macro-id (and (pair? rs) (car rs))) - (define macro-scope (and z1 me1 (get-new-scope z1 me1))) - (define z1-scope (get-macro-scope z1)) + (define macro-id (and (pair? rs) (resolves->macro-id rs (phase)))) + (define macro-scope (and z1 me1 (get-new-scope z1 me1 (phase)))) + (define z1-scope (get-macro-scope z1 scope=>context (phase))) (define context (hash-ref scope=>context z1-scope null)) + (define context* (cons (fr macro-id (phase)) context)) (when (and macro-id macro-scope) - (hash-set! scope=>context macro-scope (cons macro-id context))) + (hash-set! scope=>context macro-scope context*)) (recur locals next) (when macro-id - ;; FIXME: macro gets "charged" for local-expansion! - (define delta (- (term-size etx) (term-size z1))) (define adj (apply + (map profile/local (or locals null)))) - (profinfo-add! profinfo (phase) (list (cons macro-id context) (+ delta adj))) + (push! mocs (moc context* (term-size z1) (term-size etx) adj)) (when #f (eprintf "* macro-id ~e\n" macro-id) (eprintf " ctx = ~e\n" context) @@ -267,8 +217,8 @@ (void)] [(p:variable z1 z2 rs ?1) (void)] - [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift) - (recur locals check body)] + [(p:module z1 z2 rs ?1 locals tag rename check tag2 check2 ?3 body shift) + (recur locals check check2 body)] [(p:#%module-begin z1 z2 rs ?1 me body ?2 subs) (recur body subs)] [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals) @@ -303,15 +253,31 @@ (recur rhss body)] [(p:letrec-values _ _ _ _ renames rhss body) (recur rhss body)] - [(p:letrec-syntaxes+values _ _ _ _ srenames prep sbindrhss vrenames vrhss body tag) - (recur prep sbindrhss vrhss body)] + [(p:letrec-syntaxes+values z1 _ rs _ srenames prep sbindrhss vrenames vrhss body tag) + (recur prep sbindrhss vrhss body) + (when tag ;; means syntax bindings get dropped + (define rhss-size + (for/sum ([bind (in-list (or sbindrhss null))]) + (+ (term-size (node-z2 (bind-syntaxes-rhs bind))) + ;; 2 for (svars . (srhs . ())) pairs + ;; FIXME: also count svars term-size (in srename?) + 2))) + (define lsv-id (and (pair? rs) (resolves->macro-id rs (phase)))) + (define z1-scope (get-macro-scope z1 scope=>context (phase))) + (define context (hash-ref scope=>context z1-scope null)) + (define context* (cons (fr lsv-id (phase)) context)) + (when lsv-id + (push! mocs (moc context* 0 0 (- rhss-size))) + (when #f + (eprintf "* lsv-id-id = ~e\n" lsv-id) + (eprintf " ctx = ~e\n" context))))] [(p:provide _ _ _ _ inners ?2) (recur inners)] [(p:require _ _ _ _ locals) (recur locals)] - [(p:submodule _ _ _ _ exp) ;; FIXME! + [(p:submodule _ _ _ _ exp) (recur exp)] - [(p:submodule* _ _ _ _) ;; FIXME! + [(p:submodule* _ _ _ _) (void)] [(p:#%stratified-body _ _ _ _ bderiv) (recur bderiv)] @@ -388,34 +354,296 @@ (eprintf "! adjust by ~s for ~e\n" adj l))) adj) -;; get-new-scope : Syntax Syntax -> Integer -(define (get-new-scope x mx) - (define xi (get-macro-scopes x)) - (define mxi (get-macro-scopes mx)) - (define diff (set-subtract mxi xi)) - (match diff - [(list scope) scope] - [_ (error 'get-new-scope "bad scopes diff: ~e" diff)])) +(define (resolves->macro-id rs phase) + ;; For application, want #%app, not procedure name; this might not + ;; be optimal for rename-transformers, though. + (define mlast (last rs)) + (for/first ([id (in-list rs)] #:when (free-identifier=? id mlast phase)) id)) + +;; ============================================================ +;; Processing + +;; ProfInfo = +;; (profinfo Dict[Frame => (Listof Integer)] Dict[Frame => Integer] Integer Integer) +(struct profinfo (init-size final-size mocs) #:mutable) + +(define (new-profinfo) (profinfo 0 0 null)) + +(define (profinfo-update! pi init-size final-size mocs) + (set-profinfo-init-size! pi (+ (profinfo-init-size pi) init-size)) + (set-profinfo-final-size! pi (+ (profinfo-final-size pi) final-size)) + (set-profinfo-mocs! pi (append mocs (profinfo-mocs pi)))) + +;; print-profinfo : ProfInfo +;; #:sort (U 'total 'direct 'totalmean 'directmean) +;; #:excludes (Listof (Id Nat -> Boolean)) +;; -> Void +(define (print-profinfo pr + #:sort [sort-order 'total] + #:excludes [excludes null]) + (match-define (profinfo init-size final-size mocs) pr) + (printf "Initial code size: ~s\n" init-size) + (printf "Final code size : ~s\n" final-size) + (printf "========================================\n") + (define phases (hash-keys (for/hash ([m (in-list mocs)]) (values (moc-phase m) #t)))) + (for ([phase (in-list (sort phases <))]) + (define entries (mocs->profile-entries mocs phase)) + (printf "Phase ~s\n" phase) + (for-each print-entry (sort entries > #:key (sort-order->key sort-order))) + (printf "----------------------------------------\n\n"))) + +;; ProfileEntry[K] = (list K IndirectStats DirectStats) +;; DirectStats = (list Integer Integer Nat Nat Real) +;; -- total, mean (rounded), count, stddev +;; An IndirectStats is Integer -- total +(define (pe->total pe) (second pe)) +(define (pe->direct pe) (first (third pe))) +(define (pe->count pe) (third (third pe))) +(define (pe->totalmean pe) (/ (pe->total pe) (pe->count pe))) +(define (pe->directmean pe) (/ (pe->direct pe) (pe->count pe))) -(define (get-macro-scopes x) - (sort (append* - (for/list ([ph (in-range (add1 (phase)))]) - (define xi (hash-ref (syntax-debug-info x (phase)) 'context)) - (for/list ([v (in-list xi)] - #:when (eq? (vector-ref v 1) 'macro)) - (vector-ref v 0)))) - <)) - -(define (get-macro-scope x) - (define mscopes (get-macro-scopes x)) - (and (pair? mscopes) (apply max mscopes))) +;; mocs->profile-entries : (Listof MOC) -> (Listof ProfileEntry) +(define (mocs->profile-entries mocs phase) + (define direct-d (make-mutable-fr-hash)) + (define indirect-d (make-mutable-fr-hash)) + (for ([m (in-list mocs)] #:when (= (moc-phase m) phase)) + (match-define (moc ctx init-size final-size adj) m) + (match-define (cons fr0 ctx*) ctx) + (define delta (+ (- final-size init-size) adj)) + (dict-set! direct-d fr0 (cons delta (dict-ref direct-d fr0 null))) + (for ([f (in-list (remove-duplicates ctx fr=?))]) + (dict-set! indirect-d f (+ (dict-ref indirect-d f 0) delta)))) + (for/list ([(f directs) (in-dict direct-d)]) + (define indirect (dict-ref indirect-d f 0)) + (list f indirect (deltas->direct-stats directs)))) -;; ==== +;; deltas->direct-stats : (Listof Integer) -> (List Int Int Nat Real) +(define (deltas->direct-stats deltas) + (define sum (apply + deltas)) + (define count (length deltas)) + (define mean (/ sum count)) + (define imean (exact->inexact mean)) + (define var (/ (for/sum ([delta (in-list deltas)]) (sqr (- delta imean))) count)) + (list sum (round mean) count (sqrt var))) + +;; sort-order->key : Symbol -> (ProfileEntry -> Real) +(define (sort-order->key so) + (case so + [(total) pe->total] + [(direct) pe->direct] + [(totalmean) pe->totalmean] + [(directmean) pe->directmean])) + +;; make-exclude : String -> (Id Nat -> Boolean) +(define ((make-exclude prefix) id ph) + (match (identifier-binding id ph) + [(list* def-mpi def-sym _) + (let loop ([mod (mpi->module-path def-mpi)]) + (match mod + [(? string?) (string-prefix? mod prefix)] + [(? symbol?) (loop (symbol->string mod))] + [(? path?) (loop (path->string mod))] + [(list 'submod mod _ ...) (loop mod)] + [(list 'file mod) (loop mod)] + [(list 'lib mod) (loop mod)] + [_ #f]))] + [_ #f])) + +;; print-entry : ProfileEntry[Frame] -> Void +(define (print-entry e) + (match-define (list key indirect (list* dtotal dmean dcount dstddev _)) e) + (unless (and (zero? indirect) (zero? dtotal)) + (printf "~a\n" (frame->string key)) + (printf " total: ~s, mean: ~s\n" + indirect (round (/ indirect dcount))) + (printf " direct: ~s, mean: ~s, count: ~s, stddev: ~a\n" + dtotal dmean dcount (~r #:precision 2 dstddev)))) + +;; frame->string : Frame -> String +(define (frame->string f) + (match-define (fr id phase) f) + (id->string id phase)) + +;; id->string : Identifier Nat -> String +(define (id->string id phase) + (match (identifier-binding id phase) + [(list* def-mpi def-sym nom-mpi nom-sym def-phase _) + (define at-phase (if (zero? def-phase) "" (format " at phase ~s" def-phase))) + (define at-src (mpi->module-path def-mpi)) + (cond [(eq? def-sym nom-sym) + (format "~s (defined in ~s~a)" def-sym at-src at-phase)] + [else + (format "~s (defined as ~s in ~s~a)" nom-sym def-sym at-src at-phase)])] + ['lexical + (format "~s (lexical)" (syntax-e id))] + [#f + (format "~s (top-level)" (syntax-e id))])) + +;; ============================================================ +;; External representations + +;; mod->external : ModulePath/ModulePathIndex -> String +(define (mod->external m) (format "~s" (mod->external* m))) + +;; mod->external* : ModulePath/ModulePathIndex -> Datum +(define (mod->external* m) + (or (hash-ref mod->external-cache m #f) + (let ([ext (mod->external** m)]) + (hash-set! mod->external-cache m ext) + ext))) +(define mod->external-cache (make-weak-hash)) +(define (mod->external** m) (nice-modpath m)) + +;; frame->external : Frame -> (list String*3) +(define (frame->external f) + (or (dict-ref frame->external-cache f #f) + (let ([ext (frame->external* f)]) + (dict-set! frame->external-cache f ext) + ext))) +(define frame->external-cache (make-weak-fr-hash)) +(define (frame->external* f) + (match f [(fr id phase) (map (lambda (v) (format "~s" v)) (id->external id phase))])) + +;; id->external : Identifier Nat ModulePath -> (list Datum*3) +(define (id->external id phase) + (match (identifier-binding id phase) + [(list* def-mpi def-sym nom-mpi nom-sym def-phase _) + (define src + (cond [(here-mpi? def-mpi) (nice-modpath (enclosing-modpath))] + [else (nice-modpath def-mpi)])) + (list nom-sym src (list 'def def-sym def-phase))] + ['lexical + (list (syntax-e id) (nice-modpath (enclosing-modpath)) (list 'lex phase))] + [#f + (list (syntax-e id) 'top '(top))])) + +;; ============================================================ +;; DB Schema +(require db/base db/sqlite3) + +(define SCHEMA-VERSION 1) + +;; get-profile-db : Path -> DB +(define (get-profile-db db-file) + (define db (sqlite3-connect #:database db-file #:mode 'create)) + (cond [(table-exists? db "racket_macro_profiler_meta") + (define schema-version + (query-maybe-value db "select value from racket_macro_profiler_meta where key = ?" + "schema version")) + (unless (equal? schema-version SCHEMA-VERSION) + (error 'profile "incompatible database file\n file: ~e" db-file))] + [else (call-with-transaction db (lambda () (setup-db db)))]) + db) + +;; setup-db : DB -> Void +(define (setup-db db) + ;; ---- meta ---- + (query-exec + db (~a "create table racket_macro_profiler_meta " + "(key text primary key, value any)")) + (query-exec db "insert into racket_macro_profiler_meta (key, value) values (?, ?)" + "schema version" SCHEMA-VERSION) + ;; ---- raw data ---- + (query-exec + db (~a "create table id_module " + "(id integer primary key, mod text, unique (mod))")) + (query-exec + db (~a "create table id_macro " + "(id integer primary key, m_sym text, m_src text, m_etc text, " + "unique (m_sym, m_src, m_etc))")) + (query-exec + db (~a "create table mocs " + "(expmod integer, ctr integer, start integer, end integer, adj integer, " + "primary key (expmod, ctr), " + "foreign key (expmod) references id_module (id) on delete cascade)")) + (query-exec + db (~a "create table mocctx " + "(expmod integer, ctr integer, depth integer, macro integer, phase integer, " + "primary key (expmod, ctr, depth), " + "foreign key (expmod, ctr) references mocs (expmod, ctr) on delete cascade, " + "foreign key (macro) references id_macro (id) on delete cascade)")) + ;; ---- views ---- + (query-exec + db (~a "create view mocs_direct " + "as select expmod, ctr, macro, phase, (end - start + adj) as cost " + "from mocs natural inner join mocctx " + "where mocctx.depth = 0")) + (query-exec + db (~a "create view mocs_indirect " + "as select distinct expmod, ctr, macro, phase, (end - start + adj) as cost " + "from mocs natural inner join mocctx")) + (query-exec + db (~a "create view cost_direct as " + "select macro, phase, " + " sum(cost) as dtotal, count(ctr) as dcount, avg(cost) as dmean " + "from mocs_direct group by macro, phase")) + (query-exec + db (~a "create view cost_indirect as " + "select macro, phase, sum(cost) as itotal " + "from mocs_indirect group by macro, phase")) + (query-exec + db (~a "create view cost_summary_pre as " + "select macro, phase, " + " dcount, dtotal, dmean, itotal, (1.0 * itotal / dcount) as imean " + "from cost_direct natural inner join cost_indirect")) + (query-exec + db (~a "create view cost_summary as " + "select m_sym, m_src, m_etc, phase, dcount, dtotal, dmean, itotal, imean " + "from cost_summary_pre inner join id_macro on (cost_summary_pre.macro = id_macro.id)")) + ) + +(define frame=>key (make-weak-fr-hash)) +(define (frame->key db f) + (define (notfound) + (match-define (list f-sym f-src f-etc) (frame->external f)) + (or (query-maybe-value db "select id from id_macro where m_sym = ? and m_src = ? and m_etc = ?" + f-sym f-src f-etc) + (let ([next (add1 (query-value db "select coalesce(max(id),0) from id_macro"))]) + (query-exec db "insert into id_macro (id, m_sym, m_src, m_etc) values (?,?,?,?)" + next f-sym f-src f-etc) + next))) + (dict-ref! frame=>key f notfound)) + +(define mod=>key (make-weak-hash)) +(define (mod->key db m) + (define (notfound) + (define ext (mod->external m)) + (or (query-maybe-value db "select id from id_module where mod = ?" ext) + (let ([next (add1 (query-value db "select coalesce(max(id),0) from id_module"))]) + (query-exec db "insert into id_module (id, mod) values (?,?)" next ext) + next))) + (dict-ref! mod=>key m notfound)) + +;; db-update! : DB ModulePath (Listof MOC) -> ProfInfo +(define (db-update! db modpath mocs) + (define mod-id (mod->key db modpath)) + (query-exec db "delete from mocs where expmod = ?" mod-id) + (query-exec db "delete from mocctx where expmod = ?" mod-id) + (for ([m (in-list mocs)] [ctr (in-naturals)]) + (match-define (moc ctx init final adj) m) + (query-exec db "insert into mocs (expmod, ctr, start, end, adj) values (?,?,?,?,?)" + mod-id ctr init final adj) + (for ([f (in-list ctx)] [depth (in-naturals)]) + (query-exec db "insert into mocctx (expmod, ctr, depth, macro, phase) values (?,?,?,?,?)" + mod-id ctr depth (frame->key db f) (fr-phase f))))) + +;; db-has-mod? : DB ModulePath -> Boolean +(define (db-has-mod? db rmodpath) + (define mod-ext (mod->external rmodpath)) + (cond [(query-maybe-value db "select id from id_module where mod = ?" mod-ext) + => (lambda (mod-id) + (not (zero? (query-value db "select count(*) from mocs where expmod = ?" mod-id))))] + [else #f])) + +;; ============================================================ (module+ main (define mode 'auto) (define the-sort-order 'total) (define the-excludes null) + (define print-summary? #t) + (define the-db-file #f) + (define always-update-db? #t) (define (->modpath x) (cond [(string? x) @@ -429,6 +657,20 @@ (read (open-input-string x))])] [else x])) + (define (process-mod rmodpath db profinfo) + (parameterize ((enclosing-modpath rmodpath)) + (printf "profiling ~s\n" (nice-modpath rmodpath)) + (define-values (compiled deriv) (get-module-code/trace rmodpath)) + (define mocs (profile/top deriv)) + (when profinfo + (profinfo-update! profinfo + (term-size (node-z1 deriv)) + (term-size (node-z2 deriv)) + mocs)) + (when db + (call-with-transaction db + (lambda () (db-update! db rmodpath mocs)))))) + (command-line #:program (short-program+command-name) #:once-each @@ -442,12 +684,36 @@ (unless (memq so '(total totalmean direct directmean)) (error 'profile "expected one of (total, totalmean, direct, or directmean) for sort order, given: ~a" so)) (set! the-sort-order so))] + [("-q" "--quiet") + "Do not print summary" + (set! print-summary? #f)] + [("-d" "--database") db-file + "Store profile information in sqlite3 db file" + (set! the-db-file db-file)] + [("-t" "--trust") + "Trust existing profile information in the db file" + (set! always-update-db? #f)] #:multi [("-x" "--exclude") prefix "Exclude macros defined in modules starting with from output" (set! the-excludes (cons (make-exclude prefix) the-excludes))] #:args module-path (let () - (print-profile (profile (map ->modpath module-path)) - #:sort the-sort-order - #:excludes the-excludes))) + (define modpaths (map ->modpath module-path)) + (define db (and the-db-file (get-profile-db the-db-file))) + (define profinfo (and print-summary? (new-profinfo))) + ;; ---- + (for ([modpath (in-list modpaths)]) + (define rmodpath (resolve-module-path modpath)) + (cond [(or profinfo always-update-db? (not (db-has-mod? db rmodpath))) + (with-handlers ([exn:fail? + (lambda (e) + (eprintf "ERROR processing ~e\n" rmodpath) + ((error-display-handler) (exn-message e) e))]) + (process-mod rmodpath db profinfo))] + [else (eprintf "skipping ~s\n" (nice-modpath rmodpath))])) + ;; ---- + (when db + (disconnect db)) + (when profinfo + (print-profinfo profinfo #:sort the-sort-order #:excludes the-excludes)))) (void)) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-c.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-c.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-c.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-c.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -53,9 +53,9 @@ (define-struct (prule base) () #:transparent) (define-struct (p:variable prule) () #:transparent) -;; (make-p:module PrepareEnv ?stx stx ?Deriv ?stx ?exn Deriv ?stx) +;; (make-p:module PrepareEnv ?stx stx ?Deriv ?stx ?Deriv ?exn Deriv ?stx) ;; (make-p:#%module-begin Stx ModuleBegin/Phase ?exn) -(define-struct (p:module prule) (prep tag rename check tag2 ?3 body shift) +(define-struct (p:module prule) (prep tag rename check tag2 check2 ?3 body shift) #:transparent) (define-struct (p:#%module-begin prule) (me body ?2 subs) #:transparent) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-parser.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-parser.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-parser.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-parser.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,7 +28,7 @@ (parser (options (start Expansion) (src-pos) - (tokens basic-empty-tokens basic-tokens prim-tokens renames-tokens) + (tokens basic-empty-tokens basic-tokens prim-tokens) (end EOF) #| (debug "/tmp/DEBUG-PARSER.txt") |# (error deriv-error)) @@ -36,7 +36,7 @@ ;; tokens (skipped-token-values visit resolve next next-group return - enter-macro macro-pre-transform macro-post-transform exit-macro + enter-macro macro-pre-x macro-post-x exit-macro enter-prim exit-prim enter-block block->list block->letrec splice enter-list exit-list @@ -45,72 +45,93 @@ local-bind enter-bind exit-bind exit-local-bind local-value-result local-value-binding phase-up module-body - renames-lambda - renames-case-lambda - renames-let - renames-letrec-syntaxes - renames-block + lambda-renames + let-renames + letrec-syntaxes-renames + block-renames rename-one rename-list tag IMPOSSIBLE - start + start start-top start-ecte top-non-begin prepare-env) ;; Entry point (productions (Expansion - [(start EE/Lifts) $2] - [(start EE/Lifts/Interrupted) $2] - [(start ExpandCTE) $2] - [(start ExpandCTE/Interrupted) $2])) + [(start-ecte ExpandCTE) $2] + [(start-ecte ExpandCTE/Interrupted) $2] + [(MainExpand) $1] + [(MainExpand/Interrupted) $1])) (productions/I + ;; ---------------------------------------- + ;; ./trace.rkt expand/compile-time-evals + (ExpandCTE ;; The first 'Eval' is there for---I believe---lazy phase 1 initialization. - [(visit start (? Eval) (? CheckImmediateMacro/Lifts) - top-non-begin start (? EE) (? Eval) return) - (make ecte $1 $9 $3 $4 $7 $8)] - [(visit start Eval CheckImmediateMacro/Lifts - top-begin (? NextExpandCTEs) return) - (begin - (unless (list? $6) - (error "NextExpandCTEs returned non-list ~s" $6)) - (make ecte $1 $7 $3 $4 - (make p:begin $5 $7 (list (stx-car $5)) #f - (make lderiv (cdr (stx->list $5)) - (and $7 (cdr (stx->list $7))) - #f - $6)) - null))]) - - (CheckImmediateMacro/Lifts - [((? CheckImmediateMacro)) - $1] - [(CheckImmediateMacro lift-loop) - (let ([e1 (wderiv-e1 $1)] - [e2 $2]) - (make lift-deriv e1 e2 $1 $2 (make p:stop $2 $2 null #f)))]) + [(visit (? MainExpandToTop) top-non-begin (? MainExpand) (? Eval) return) + (make ecte $1 $6 null $2 $4 $5)] + [(visit MainExpandToTop top-begin (? NextExpandCTEs) return) + (make ecte $1 $5 null $2 + (let ([b-e1 $3] [b-e2 $5]) + (make p:begin b-e1 b-e2 (list (stx-car b-e1)) #f + (derivs->lderiv (stx-cdr b-e1) $4))) + null)]) (NextExpandCTEs (#:skipped null) [() null] [(next (? ExpandCTE) (? NextExpandCTEs)) (cons $2 $3)]) - ;; Expand with possible lifting - (EE/Lifts - [((? EE)) $1] - [(EE lift-loop (? EE/Lifts)) - (let ([e1 (wderiv-e1 $1)] - [e2 (wderiv-e2 $3)]) - (make lift-deriv e1 e2 $1 $2 $3))]) + ;; ---------------------------------------- + ;; src/eval/main.rkt expand and expand-to-top-form + + (MainExpand + [(start-top (? PTLL)) $2]) + + (MainExpandToTop + [(start-top (? PTLL)) $2]) + + (PTLL ;; per-top-level loop + [(visit (? ECL) return) + $2] + [(visit ECL (? EE)) + (let ([e2 (and $3 (node-z2 $3))]) + (make ecte $1 e2 null $2 $3 null))] + [(visit ECL lift-loop (? PTLL)) + (make lift-deriv $1 (wderiv-e2 $4) $2 $3 $4)] + [(visit ECL prim-begin ! (? NextPTLLs) return) + (make ecte $1 $6 null $2 + (let* ([b-e1 (and $2 (node-z2 $2))] + [ld (and b-e1 (derivs->lderiv (stx-cdr b-e1) $5))]) + (make p:begin b-e1 $6 (list (stx-car b-e1)) $4 ld)) + null)] + [(visit ECL prim-begin-for-syntax ! (? PrepareEnv) (? NextPTLLs) return) + (make ecte $1 $7 null $2 + (let* ([b-e1 (and $2 (node-z2 $2))] + [ld (and b-e1 (derivs->lderiv (stx-cdr b-e1) $6))]) + (make p:begin-for-syntax b-e1 $7 (list (stx-car b-e1)) $4 $5 ld null)) + null)]) + + (NextPTLLs + (#:skipped null) + [() null] + [(next (? PTLL) (? NextPTLLs)) (cons $2 $3)]) + + (ECL ;; expand-capturing-lifts + [((? CheckImmediateMacro)) $1]) + + ;; ---------------------------------------- + ;; EE = src/expander/expand/main.rkt expand + ;; CheckImmediateMacro = like EE but with ctx w/ only-immediate?=#t ;; Expand, convert lifts to let (rhs of define-syntaxes, mostly) (EE/LetLifts [((? EE)) $1] - [(EE lift/let-loop (? EE/LetLifts)) + [(EE letlift-loop (? EE/LetLifts)) (let ([initial (wderiv-e1 $1)] [final (wderiv-e2 $3)]) (make lift/let-deriv initial final $1 $2 $3))]) @@ -154,7 +175,7 @@ [(visit Resolves tag (? EE/k)) (let ([next ($4 $3 $2)]) (make tagrule $1 (wderiv-e2 next) $3 next))] - [(visit opaque) + [(visit opaque-expr) (make p:stop $1 $2 null #f)]) (EE/k @@ -173,8 +194,7 @@ (MacroStep (#:args e1 rs next) - [(enter-macro ! macro-pre-transform (? LocalActions) - macro-post-transform ! exit-macro) + [(enter-macro ! macro-pre-x (? LocalActions) macro-post-x ! exit-macro) (let ([e2 (and next (wderiv-e2 next))]) (make mrule e1 e2 rs $2 $3 $4 (and $5 (car $5)) $6 $7 next))]) @@ -197,7 +217,7 @@ local-pre (? LocalExpand/Inner) OptLifted local-post OptOpaqueExpr exit-local) (make local-expansion $1 $8 $2 $3 $4 $5 $6 $7)] - [(lift) + [(lift-expr) (make local-lift (cdr $1) (car $1))] [(lift-statement) (make local-lift-end $1)] @@ -230,11 +250,7 @@ [(local-mess) ;; Represents subsequence of event stream incoherent due to ;; jump (eg, macro catches exn raised from within local-expand). - (make local-mess $1)] - ;; -- Not really local actions, but can occur during evaluation - ;; called 'expand' (not 'local-expand') within transformer - [(start (? EE)) #f] - [(start (? CheckImmediateMacro)) #f]) + (make local-mess $1)]) (LocalExpand/Inner [(start (? EE)) $2] @@ -244,7 +260,7 @@ [(lift-loop) $1] [() #f]) (OptOpaqueExpr - [(opaque) $1] + [(opaque-expr) $1] [() #f]) (OptPhaseUp [(phase-up) #t] @@ -268,7 +284,6 @@ [((? PrimLambda)) ($1 e1 e2 rs)] [((? PrimCaseLambda)) ($1 e1 e2 rs)] [((? PrimLetValues)) ($1 e1 e2 rs)] - [((? PrimLet*Values)) ($1 e1 e2 rs)] [((? PrimLetrecValues)) ($1 e1 e2 rs)] [((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)] [((? PrimSTOP)) ($1 e1 e2 rs)] @@ -283,15 +298,19 @@ (PrimModule (#:args e1 e2 rs) [(prim-module ! (? PrepareEnv) OptTag rename-one - (? OptCheckImmediateMacro) OptTag ! + (? OptCheckImmediateMacro) (? OptTagAndCheckImmediateMacro) ! (? EE) rename-one) - (make p:module e1 e2 rs $2 $3 $4 $5 $6 $7 $8 $9 $10)]) + (make p:module e1 e2 rs $2 $3 $4 $5 $6 (and $7 (car $7)) (and $7 (cadr $7)) $8 $9 $10)]) (OptTag [() #f] [(tag) $1]) (OptCheckImmediateMacro [() #f] [((? CheckImmediateMacro)) $1]) + (OptTagAndCheckImmediateMacro + [() (list #f #f)] + [(tag) (list $1 #f)] + [(tag (? CheckImmediateMacro)) (list $1 $2)]) ;; FIXME: workaround for problem in expander instrumentation: ;; observer not propagated correctly to expand_all_provides @@ -299,7 +318,7 @@ ;; instead appear directly here (Prim#%ModuleBegin (#:args e1 e2 rs) - [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) (? Eval) next (? ExpandSubmodules)) + [(prim-module-begin ! rename-one (? ModuleBegin/Phase) (? Eval) next (? ExpandSubmodules)) (make p:#%module-begin e1 e2 rs $2 $3 $4 (for/or ([la (in-list $5)]) (and (local-exn? la) (local-exn-exn la))) @@ -408,9 +427,9 @@ ;; Simple expressions (PrimExpression (#:args e1 e2 rs) - [(prim-expression ! (? EE)) + [(prim-#%expression ! (? EE)) (make p:#%expression e1 e2 rs $2 $3 #f)] - [(prim-expression EE tag) + [(prim-#%expression EE tag) (make p:#%expression e1 e2 rs #f $2 $3)]) (PrimIf @@ -420,7 +439,7 @@ (PrimWCM (#:args e1 e2 rs) - [(prim-wcm ! (? EE) next (? EE) next (? EE)) + [(prim-with-continuation-mark ! (? EE) next (? EE) next (? EE)) (make p:wcm e1 e2 rs $2 $3 $5 $7)]) ;; Sequence-containing expressions @@ -444,7 +463,7 @@ ;; Binding expressions (PrimLambda (#:args e1 e2 rs) - [(prim-lambda ! renames-lambda (? EB)) + [(prim-lambda ! lambda-renames (? EB)) (make p:lambda e1 e2 rs $2 $3 $4)]) (PrimCaseLambda @@ -459,41 +478,28 @@ [() null]) (CaseLambdaClause - [(! renames-case-lambda (? EB)) + [(! lambda-renames (? EB)) (make clc $1 $2 $3)]) (PrimLetValues (#:args e1 e2 rs) - [(prim-let-values ! renames-let (? NextEEs) next-group (? EB/EL)) + [(prim-let-values ! let-renames (? NextEEs) next-group (? EB/EL)) (make p:let-values e1 e2 rs $2 $3 $4 $6)]) - ;; There's no primitive `let*-values`, anymore - (PrimLet*Values - (#:args e1 e2 rs) - ;; let*-values with bindings is "macro-like" - [(prim-let*-values !!) - (make mrule e1 e2 rs $2 #f null #f #f #f #f)] - [(prim-let*-values (? EE)) - (let* ([next-e1 (wderiv-e1 $2)]) - (make mrule e1 e2 rs #f e1 null next-e1 #f next-e1 $2))] - ;; No bindings... model as "let" - [(prim-let*-values renames-let (? NextEEs) next-group (? EB)) - (make p:let-values e1 e2 rs #f $2 $3 $5)]) - (PrimLetrecValues (#:args e1 e2 rs) - [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB/EL)) + [(prim-letrec-values ! let-renames (? NextEEs) next-group (? EB/EL)) (make p:letrec-values e1 e2 rs $2 $3 $4 $6)]) (PrimLetrecSyntaxes+Values (#:args e1 e2 rs) - [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes + [(prim-letrec-syntaxes+values ! letrec-syntaxes-renames (? PrepareEnv) (? NextBindSyntaxess) next-group (? EB/EL) OptTag) (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 $5 #f null $7 $8)] - [(prim-letrec-syntaxes+values renames-letrec-syntaxes + [(prim-letrec-syntaxes+values letrec-syntaxes-renames PrepareEnv NextBindSyntaxess next-group prim-letrec-values - renames-let (? NextEEs) next-group (? EB/EL) OptTag) + let-renames (? NextEEs) next-group (? EB/EL) OptTag) (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $4 $7 $8 $10 $11)]) ;; Atomic expressions @@ -528,11 +534,12 @@ (PrimVarRef (#:args e1 e2 rs) - [(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)]) + [(prim-#%variable-reference !) + (make p:#%variable-reference e1 e2 rs $2)]) (PrimStratifiedBody (#:args e1 e2 rs) - [(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)]) + [(prim-#%stratified ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)]) (PrimBeginForSyntax (#:args e1 e2 rs) @@ -562,10 +569,10 @@ ;; Blocks ;; EB Answer = BlockDerivation (EB - [(enter-block renames-block (? BlockPass1) block->list (? EL)) + [(enter-block block-renames (? BlockPass1) block->list (? EL)) (make bderiv $1 (and $5 (wlderiv-es2 $5)) $2 $3 'list $5)] - [(enter-block renames-block BlockPass1 block->letrec (? EE)) + [(enter-block block-renames BlockPass1 block->letrec (? EE)) (make bderiv $1 (and $5 (list (wderiv-e2 $5))) $2 $3 'letrec $5)]) @@ -618,3 +625,7 @@ [(next (? EE) (? EL*)) (cons $2 $3)]) ))) + +(define (derivs->lderiv es1 ds) + (define es2 (map node-z2 ds)) + (lderiv (stx->list es1) (and es2 (andmap values es2)) #f ds)) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-tokens.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-tokens.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-tokens.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/deriv-tokens.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,11 +3,10 @@ "deriv.rkt") (provide (all-defined-out)) -;; NOTE: trace.rkt also depends on some token numbers -;; eg for enter-macro, local-value, etc - (define-tokens basic-empty-tokens (start ; . + start-top ; . + start-ecte ; . next ; . next-group ; . phase-up ; . @@ -26,8 +25,8 @@ (visit ; syntax resolve ; identifier enter-macro ; syntax - macro-pre-transform ; syntax - macro-post-transform ; (cons syntax syntax) + macro-pre-x ; syntax + macro-post-x ; (cons syntax syntax) exit-macro ; syntax enter-prim ; syntax exit-prim ; syntax @@ -43,10 +42,10 @@ module-body ; (list-of (cons syntax boolean)) syntax-error ; exn lift-loop ; syntax = new form (let or begin; let if for_stx) - lift/let-loop ; syntax = new let form + letlift-loop ; syntax = new let form module-lift-loop ; syntaxes = def-lifts, in reverse order lifted (???) module-lift-end-loop ; syntaxes = statement-lifts ++ provide-lifts, in order lifted - lift ; (cons (listof id) syntax) + lift-expr ; (cons (listof id) syntax) lift-statement ; syntax lift-require ; (cons syntax (cons syntax syntax)) lift-provide ; syntax @@ -57,13 +56,17 @@ exit-local ; syntax local-bind ; (listof identifier) - opaque ; opaque-syntax + opaque-expr ; opaque-syntax variable ; (cons identifier identifier) tag ; syntax rename-one ; syntax rename-list ; (list-of syntax) + lambda-renames ; (cons syntax syntax) + let-renames ; (cons (listof syntax) syntax) + letrec-syntaxes-renames ; (cons (listof syntax) (cons (listof syntax) syntax)) + block-renames ; (cons syntax syntax) ... contains both pre+post top-begin ; identifier @@ -77,145 +80,132 @@ local-mess ; (listof event) )) -(define-tokens renames-tokens - (renames-lambda ; (cons syntax syntax) - renames-case-lambda ; (cons syntax syntax) - renames-let ; (cons (listof syntax) syntax) - renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) - renames-block ; (cons syntax syntax) ... different, contains both pre+post - )) - ;; Empty tokens (define-tokens prim-tokens - (prim-module prim-#%module-begin + (prim-module prim-module-begin prim-define-syntaxes prim-define-values - prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda - prim-case-lambda prim-let-values prim-let*-values prim-letrec-values + prim-if prim-with-continuation-mark + prim-begin prim-begin0 prim-#%app prim-lambda + prim-case-lambda prim-let-values prim-letrec-values prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop prim-quote prim-quote-syntax prim-require prim-require-for-syntax prim-require-for-template prim-provide prim-set! - prim-expression - prim-varref - prim-#%stratified-body + prim-#%expression + prim-#%variable-reference + prim-#%stratified prim-begin-for-syntax prim-submodule prim-submodule* )) -;; ** Signals to tokens +;; ** Events to tokens + +;; token-mapping : Hash[ Symbol => TokenConstructor/#t ] +(define token-mapping + (hasheq + 'EOF #t + 'error token-syntax-error + 'start token-start + 'start-top token-start-top + 'start-ecte token-start-ecte + 'top-begin token-top-begin + 'top-non-begin token-top-non-begin + 'local-remark token-local-remark + 'local-artificial-step token-local-artificial-step + 'local-value-binding token-local-value-binding + 'local-mess token-local-mess + + 'visit token-visit + 'resolve token-resolve + 'return token-return + 'next token-next + 'enter-list token-enter-list + 'exit-list token-exit-list + 'enter-prim token-enter-prim + 'exit-prim token-exit-prim + 'enter-macro token-enter-macro + 'exit-macro token-exit-macro + 'enter-block token-enter-block + 'splice token-splice + 'block->list token-block->list + 'next-group token-next-group + 'block->letrec token-block->letrec + 'let-renames token-let-renames + 'lambda-renames token-lambda-renames + 'letrec-syntaxes-renames token-letrec-syntaxes-renames + 'macro-pre-x token-macro-pre-x + 'macro-post-x token-macro-post-x + 'module-body token-module-body + 'block-renames token-block-renames + 'phase-up #t + 'prepare-env #t + 'exit-local-bind #t + + 'prim-stop #t + 'prim-module #t + 'prim-module-begin #t + 'prim-define-syntaxes #t + 'prim-define-values #t + 'prim-if #t + 'prim-with-continuation-mark #t + 'prim-begin #t + 'prim-begin0 #t + 'prim-#%app #t + 'prim-lambda #t + 'prim-case-lambda #t + 'prim-let-values #t + 'prim-letrec-values #t + 'prim-letrec-syntaxes+values #t + 'prim-#%datum #t + 'prim-#%top #t + 'prim-quote #t + 'prim-quote-syntax #t + 'prim-require #t + 'prim-require-for-syntax #t + 'prim-require-for-template #t + 'prim-provide #t + 'prim-set! #t + 'prim-let*-values #t + 'prim-#%variable-reference #t + 'prim-#%expression #t + 'prim-#%stratified #t + 'prim-begin-for-syntax #t + 'prim-submodule #t + 'prim-submodule* #t + + 'variable token-variable + 'enter-check token-enter-check + 'exit-check token-exit-check + 'lift-loop token-lift-loop + 'lift-expr token-lift-expr + 'enter-local token-enter-local + 'exit-local token-exit-local + 'local-pre token-local-pre + 'local-post token-local-post + 'lift-statement token-lift-statement + 'module-lift-end-loop token-module-lift-end-loop + 'letlift-loop token-letlift-loop + 'module-lift-loop token-module-lift-loop + 'start token-start + 'tag token-tag + 'local-bind token-local-bind + 'enter-bind token-enter-bind + 'exit-bind token-exit-bind + 'opaque-expr token-opaque-expr + 'rename-list token-rename-list + 'rename-one token-rename-one + 'lift-require token-lift-require + 'lift-provide token-lift-provide + 'track-origin token-track-origin + 'local-value token-local-value + 'local-value-result token-local-value-result + 'start-top token-start-top + )) -(define signal-mapping - ;; (number/#f symbol [token-constructor]) - `(;; Emitted from Scheme - (#f EOF) - (#f error ,token-syntax-error) - (#f start ,token-start) - (#f top-begin ,token-top-begin) - (#f top-non-begin ,token-top-non-begin) - (#f local-remark ,token-local-remark) - (#f local-artificial-step ,token-local-artificial-step) - (#f local-value-binding ,token-local-value-binding) - (#f local-mess ,token-local-mess) - - ;; Standard signals - (0 visit ,token-visit) - (1 resolve ,token-resolve) - (2 return ,token-return) - (3 next ,token-next) - (4 enter-list ,token-enter-list) - (5 exit-list ,token-exit-list) - (6 enter-prim ,token-enter-prim) - (7 exit-prim ,token-exit-prim) - (8 enter-macro ,token-enter-macro) - (9 exit-macro ,token-exit-macro) - (10 enter-block ,token-enter-block) - (11 splice ,token-splice) - (12 block->list ,token-block->list) - (13 next-group ,token-next-group) - (14 block->letrec ,token-block->letrec) - (16 renames-let ,token-renames-let) - (17 renames-lambda ,token-renames-lambda) - (18 renames-case-lambda ,token-renames-case-lambda) - (19 renames-letrec-syntaxes ,token-renames-letrec-syntaxes) - (20 phase-up) - (21 macro-pre-transform ,token-macro-pre-transform) - (22 macro-post-transform ,token-macro-post-transform) - (23 module-body ,token-module-body) - (24 renames-block ,token-renames-block) - - (100 prim-stop) - (101 prim-module) - (102 prim-#%module-begin) - (103 prim-define-syntaxes) - (104 prim-define-values) - (105 prim-if) - (106 prim-wcm) - (107 prim-begin) - (108 prim-begin0) - (109 prim-#%app) - (110 prim-lambda) - (111 prim-case-lambda) - (112 prim-let-values) - (113 prim-letrec-values) - (114 prim-letrec-syntaxes+values) - (115 prim-#%datum) - (116 prim-#%top) - (117 prim-quote) - (118 prim-quote-syntax) - (119 prim-require) - (120 prim-require-for-syntax) - (121 prim-require-for-template) - (122 prim-provide) - (123 prim-set!) - (124 prim-let*-values) - (125 variable ,token-variable) - (126 enter-check ,token-enter-check) - (127 exit-check ,token-exit-check) - (128 lift-loop ,token-lift-loop) - (129 lift ,token-lift) - (130 enter-local ,token-enter-local) - (131 exit-local ,token-exit-local) - (132 local-pre ,token-local-pre) - (133 local-post ,token-local-post) - (134 lift-statement ,token-lift-statement) - (135 lift-end-loop ,token-module-lift-end-loop) - (136 lift/let-loop ,token-lift/let-loop) - (137 module-lift-loop ,token-module-lift-loop) - (138 prim-expression) - (141 start ,token-start) - (142 tag ,token-tag) - (143 local-bind ,token-local-bind) - (144 enter-bind ,token-enter-bind) - (145 exit-bind ,token-exit-bind) - (146 opaque ,token-opaque) - (147 rename-list ,token-rename-list) - (148 rename-one ,token-rename-one) - (149 prim-varref) - (150 lift-require ,token-lift-require) - (151 lift-provide ,token-lift-provide) - (152 track-origin ,token-track-origin) - (153 local-value ,token-local-value) - (154 local-value-result ,token-local-value-result) - (155 prim-#%stratified-body) - (156 prim-begin-for-syntax) - (157 prepare-env) - (158 prim-submodule) - (159 prim-submodule*) - (160 exit-local-bind) - )) - -(define (signal->symbol sig) - (if (symbol? sig) - sig - (cadr (assv sig signal-mapping)))) - -(define token-mapping (map cdr signal-mapping)) - -(define (tokenize sig val pos) - (let ([p (assv sig token-mapping)]) - (cond [(not p) - (error 'tokenize "bad signal: ~s" sig)] - [(null? (cdr p)) - (make-position-token sig pos pos)] - [else - (make-position-token ((cadr p) val) pos pos)]))) +(define (tokenize key val pos) + (cond [(hash-ref token-mapping key #f) + => (lambda (make-token) + (if (procedure? make-token) + (make-position-token (make-token val) pos pos) + (make-position-token key pos pos)))] + [else (error 'tokenize "bad signal: ~s" key)])) diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/reductions.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/reductions.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/reductions.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/reductions.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -76,7 +76,7 @@ [#:when (or (not (identifier? e1)) (not (bound-identifier=? e1 e2))) [#:walk e2 'resolve-variable]])] - [(Wrap p:module (e1 e2 rs ?1 prep tag rename check tag2 ?3 body shift)) + [(Wrap p:module (e1 e2 rs ?1 prep tag rename check tag2 check2 ?3 body shift)) (R [#:hide-check rs] [! ?1] [#:pattern ?form] @@ -93,6 +93,8 @@ [#:when tag2 [#:in-hole ?body [#:walk tag2 'tag-module-begin]]] + [#:when check2 + [Expr ?body check2]] [#:pass2] [! ?3] [Expr ?body body] diff -Nru racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/trace.rkt racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/trace.rkt --- racket-6.12+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/trace.rkt 2018-01-26 20:36:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/macro-debugger-text-lib/macro-debugger/model/trace.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -95,7 +95,7 @@ (define macro-stack null) ;; (listof (cons (U stx 'local-bind) nat)) (define (add! x y) (set! counter (add1 counter)) - (set! events (cons (cons (signal->symbol x) y) events))) + (set! events (cons (cons x y) events))) (define add!/check (let ([limit (trace-macro-limit)] [handler (trace-limit-handler)] @@ -104,14 +104,14 @@ (lambda (x y) (add! x y) (case x - ((8) ;; enter-macro + ((enter-macro) (set! limit-counter (add1 limit-counter)) (when (>= limit-counter limit) (set! limit (handler limit-counter)))) - ((21) ;; macro-pre-transform + ((macro-pre-x) (let ([rec (cons y counter)]) (set! macro-stack (cons rec macro-stack)))) - ((22) ;; macro-post-transform + ((macro-post-x) (cond [(and (pair? macro-stack) (eq? (car (car macro-stack)) (cdr y))) (set! macro-stack (cdr macro-stack))] @@ -127,20 +127,20 @@ (set! events sfx) (set! counter (cdr top)) (add! 'local-mess (reverse pfx)) - (add! 'macro-post-transform y))] + (add! 'macro-post-x y))] [else (loop (cdr ms))])))])) - ((143) ;; local-bind + ((local-bind) (let ([rec (cons 'local-bind counter)]) (set! macro-stack (cons rec macro-stack)))) - ((160) ;; exit-local-bind + ((exit-local-bind) (let ([top (car macro-stack)]) (cond [(eq? (car top) 'local-bind) (set! macro-stack (cdr macro-stack))] [else ;; Jumped! (error 'trace "internal error: cannot handle catch within bind")]))) - ((153) ;; local-value + ((local-value) (set! last-local-value-id y)) - ((154) ;; local-value-result + ((local-value-result) (add! 'local-value-binding (and y (identifier-binding last-local-value-id))) (set! last-local-value-id #f)))))) @@ -188,7 +188,7 @@ e))])) (emit 'return e2) e2) - (emit 'start) + (emit 'start-ecte) (expand/cte (namespace-syntax-introduce (datum->syntax #f stx)))) ;; eval-compile-time-part : syntax boolean -> void diff -Nru racket-6.12+ppa1/share/pkgs/main-distribution/info.rkt racket-7.0+ppa1/share/pkgs/main-distribution/info.rkt --- racket-6.12+ppa1/share/pkgs/main-distribution/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/main-distribution/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("2d" "algol60" "at-exp-lib" "compatibility" "contract-profile" "compiler" "data" "datalog" "db" "deinprogramm" "draw" "draw-doc" "draw-lib" "drracket" "drracket-tool" "eopl" "errortrace" "future-visualizer" "future-visualizer-typed" "frtime" "games" "gui" "htdp" "html" "icons" "images" "lazy" "macro-debugger" "macro-debugger-text-lib" "make" "math" "mysterx" "mzcom" "mzscheme" "net" "net-cookies" "optimization-coach" "option-contract" "parser-tools" "pconvert-lib" "pict" "pict-snip" "picturing-programs" "plai" "planet" "plot" "preprocessor" "profile" "r5rs" "r6rs" "racket-doc" "distributed-places" "racket-cheat" "racket-index" "racket-lib" "racklog" "rackunit" "rackunit-typed" "readline" "realm" "redex" "sandbox-lib" "sasl" "schemeunit" "scribble" "serialize-cstruct-lib" "sgl" "shell-completion" "slatex" "slideshow" "snip" "srfi" "string-constants" "swindle" "syntax-color" "trace" "typed-racket" "typed-racket-more" "unix-socket" "web-server" "wxme" "xrepl" "ds-store"))) (define pkg-desc "A package that combines all of the packages in the main Racket distribution") (define pkg-authors (quote (eli jay matthias mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("2d" "algol60" "at-exp-lib" "compatibility" "contract-profile" "compiler" "data" "datalog" "db" "deinprogramm" "draw" "draw-doc" "draw-lib" "drracket" "drracket-tool" "eopl" "errortrace" "future-visualizer" "future-visualizer-typed" "frtime" "games" "gui" "htdp" "html" "icons" "images" "lazy" "macro-debugger" "macro-debugger-text-lib" "make" "math" "mysterx" "mzcom" "mzscheme" "net" "net-cookies" "optimization-coach" "option-contract" "parser-tools" "pconvert-lib" "pict" "pict-snip" "picturing-programs" "plai" "planet" "plot" "preprocessor" "profile" "r5rs" "r6rs" "racket-doc" "distributed-places" "racket-cheat" "racket-index" "racket-lib" "racklog" "rackunit" "rackunit-typed" "readline" "realm" "redex" "sandbox-lib" "sasl" "schemeunit" "scribble" "serialize-cstruct-lib" "sgl" "shell-completion" "slatex" "slideshow" "snip" "srfi" "string-constants" "swindle" "syntax-color" "trace" "typed-racket" "typed-racket-more" "unix-socket" "web-server" "wxme" "xrepl" "ds-store"))) (define pkg-desc "A package that combines all of the packages in the main Racket distribution") (define pkg-authors (quote (eli jay matthias mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/make/info.rkt racket-7.0+ppa1/share/pkgs/make/info.rkt --- racket-6.12+ppa1/share/pkgs/make/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/make/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "make") (define scribblings (quote (("make.scrbl" (multi-page) (tool-library))))) (define deps (quote ("scheme-lib" "base" "cext-lib" "compiler-lib" "compatibility-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "Simple timestamp- and dependency-triggered actions") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "make") (define scribblings (quote (("make.scrbl" (multi-page) (tool-library))))) (define deps (quote ("scheme-lib" "base" "cext-lib" "compiler-lib" "compatibility-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "Simple timestamp- and dependency-triggered actions") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/math/info.rkt racket-7.0+ppa1/share/pkgs/math/info.rkt --- racket-6.12+ppa1/share/pkgs/math/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/math/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("math-lib" "math-doc"))) (define implies (quote ("math-lib" "math-doc"))) (define pkg-desc "Functions and data structures useful for working with numbers and collections of numbers, along with docs and tests") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("math-lib" "math-doc"))) (define implies (quote ("math-lib" "math-doc"))) (define pkg-desc "Functions and data structures useful for working with numbers and collections of numbers, along with docs and tests") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/math-doc/info.rkt racket-7.0+ppa1/share/pkgs/math-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/math-doc/info.rkt 2018-01-26 21:08:36.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/math-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("at-exp-lib" "math-lib" "plot-doc" "plot-gui-lib" "racket-doc" "sandbox-lib" "scribble-lib" "typed-racket-doc" "typed-racket-lib" "2d-lib"))) (define update-implies (quote ("math-lib"))) (define pkg-desc "Math library documentation") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("at-exp-lib" "math-lib" "plot-doc" "plot-gui-lib" "racket-doc" "sandbox-lib" "scribble-lib" "typed-racket-doc" "typed-racket-lib" "2d-lib"))) (define update-implies (quote ("math-lib"))) (define pkg-desc "Math library documentation") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/math-lib/info.rkt racket-7.0+ppa1/share/pkgs/math-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/math-lib/info.rkt 2018-01-26 21:08:40.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/math-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.11.0.6") "r6rs-lib" "typed-racket-lib" "typed-racket-more" ("math-i386-macosx" #:platform "i386-macosx") ("math-x86_64-macosx" #:platform "x86_64-macosx") ("math-ppc-macosx" #:platform "ppc-macosx") ("math-win32-i386" #:platform "win32\\i386") ("math-win32-x86_64" #:platform "win32\\x86_64") ("math-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define build-deps (quote ())) (define pkg-desc "Math library") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.11.0.6") "r6rs-lib" "typed-racket-lib" "typed-racket-more" ("math-i386-macosx" #:platform "i386-macosx") ("math-x86_64-macosx" #:platform "x86_64-macosx") ("math-ppc-macosx" #:platform "ppc-macosx") ("math-win32-i386" #:platform "win32\\i386") ("math-win32-x86_64" #:platform "win32\\x86_64") ("math-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")))) (define build-deps (quote ())) (define pkg-desc "Math library") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/math-lib/math/private/number-theory/number-theory.rkt racket-7.0+ppa1/share/pkgs/math-lib/math/private/number-theory/number-theory.rkt --- racket-6.12+ppa1/share/pkgs/math-lib/math/private/number-theory/number-theory.rkt 2018-01-26 20:36:38.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/math-lib/math/private/number-theory/number-theory.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -58,7 +58,7 @@ (define *VERY-SMALL-PRIME-LIMIT* 1000) ; Determines the size of the pre-built table of very small primes -(define *SMALL-FACORIZATION-LIMIT* *VERY-SMALL-PRIME-LIMIT*) +(define *SMALL-FACTORIZATION-LIMIT* *VERY-SMALL-PRIME-LIMIT*) ; Determines whether to use naive factorization or Pollards rho method. @@ -125,7 +125,7 @@ ;;; PRIMES ;;; -(: odd-prime? : Natural -> Boolean) +(: odd-prime? : Integer -> Boolean) (define (odd-prime? n) (and (odd? n) (prime? n))) @@ -307,7 +307,7 @@ (: factorize : Natural -> (Listof (List Natural Natural))) (define (factorize n) - (if (< n *SMALL-FACORIZATION-LIMIT*) ; NOTE: Do measurement of best cut + (if (< n *SMALL-FACTORIZATION-LIMIT*) ; NOTE: Do measurement of best cut (factorize-small n) (factorize-large n))) @@ -356,7 +356,7 @@ (: pollard-factorize : Natural -> (Listof (List Natural Natural))) (define (pollard-factorize n) - (if (< n *SMALL-FACORIZATION-LIMIT*) + (if (< n *SMALL-FACTORIZATION-LIMIT*) (factorize-small n) (cond [(= n 1) '()] @@ -587,7 +587,7 @@ ;;; (: divisors : Integer -> (Listof Natural)) -; return the positive divisorts of n +; return the positive divisors of n (define (divisors n) (cond [(zero? n) '()] [else (define n+ (if (positive? n) n (- n))) diff -Nru racket-6.12+ppa1/share/pkgs/mysterx/info.rkt racket-7.0+ppa1/share/pkgs/mysterx/info.rkt --- racket-6.12+ppa1/share/pkgs/mysterx/info.rkt 2018-01-26 21:08:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/mysterx/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "mysterx") (define scribblings (quote (("scribblings/mysterx.scrbl" (multi-page) (legacy))))) (define deps (quote ("scheme-lib" "base"))) (define build-deps (quote ("racket-doc" "at-exp-lib" "scribble-lib"))) (define pkg-desc "Legacy library for working with COM on Windows") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "mysterx") (define scribblings (quote (("scribblings/mysterx.scrbl" (multi-page) (legacy))))) (define deps (quote ("scheme-lib" "base"))) (define build-deps (quote ("racket-doc" "at-exp-lib" "scribble-lib"))) (define pkg-desc "Legacy library for working with COM on Windows") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/mzcom/info.rkt racket-7.0+ppa1/share/pkgs/mzcom/info.rkt --- racket-6.12+ppa1/share/pkgs/mzcom/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/mzcom/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "mzcom") (define install-collection "installer.rkt") (define scribblings (quote (("mzcom.scrbl" () (interop))))) (define deps (quote ("base" "compatibility-lib"))) (define build-deps (quote ("scheme-lib" "racket-doc" "mysterx" "scribble-lib"))) (define pkg-desc "COM control to instantate a Racket instance") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "mzcom") (define install-collection "installer.rkt") (define scribblings (quote (("mzcom.scrbl" () (interop))))) (define deps (quote ("base" "compatibility-lib"))) (define build-deps (quote ("scheme-lib" "racket-doc" "mysterx" "scribble-lib"))) (define pkg-desc "COM control to instantate a Racket instance") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/mzscheme/info.rkt racket-7.0+ppa1/share/pkgs/mzscheme/info.rkt --- racket-6.12+ppa1/share/pkgs/mzscheme/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/mzscheme/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("mzscheme-lib" "mzscheme-doc"))) (define implies (quote ("mzscheme-lib" "mzscheme-doc"))) (define pkg-desc "The legacy MzScheme language") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("mzscheme-lib" "mzscheme-doc"))) (define implies (quote ("mzscheme-lib" "mzscheme-doc"))) (define pkg-desc "The legacy MzScheme language") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/mzscheme-doc/info.rkt racket-7.0+ppa1/share/pkgs/mzscheme-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/mzscheme-doc/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/mzscheme-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"mzscheme\"") (define pkg-authors (quote (mflatt))) (define build-deps (quote ("compatibility-lib" "r5rs-doc" "r5rs-lib" "racket-doc" "scheme-lib" "scribble-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"mzscheme\"") (define pkg-authors (quote (mflatt))) (define build-deps (quote ("compatibility-lib" "r5rs-doc" "r5rs-lib" "racket-doc" "scheme-lib" "scribble-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/mzscheme-lib/info.rkt racket-7.0+ppa1/share/pkgs/mzscheme-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/mzscheme-lib/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/mzscheme-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" ("base" #:version "6.5.0.2")))) (define pkg-desc "implementation (no documentation) part of \"mzscheme\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" ("base" #:version "6.5.0.2")))) (define pkg-desc "implementation (no documentation) part of \"mzscheme\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/net/info.rkt racket-7.0+ppa1/share/pkgs/net/info.rkt --- racket-6.12+ppa1/share/pkgs/net/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("net-lib" "net-doc"))) (define implies (quote ("net-lib" "net-doc"))) (define pkg-desc "Networking libraries") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("net-lib" "net-doc"))) (define implies (quote ("net-lib" "net-doc"))) (define pkg-desc "Networking libraries") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/net-cookies/info.rkt racket-7.0+ppa1/share/pkgs/net-cookies/info.rkt --- racket-6.12+ppa1/share/pkgs/net-cookies/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-cookies/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define name "HTTP Cookies (RFC6265)") (define deps (quote ("net-cookies-lib" "net-cookies-doc"))) (define implies (quote ("net-cookies-lib" "net-cookies-doc"))) (define version "1.1.3"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define name "HTTP Cookies (RFC6265)") (define deps (quote ("net-cookies-lib" "net-cookies-doc"))) (define implies (quote ("net-cookies-lib" "net-cookies-doc"))) (define version "1.1.3"))) diff -Nru racket-6.12+ppa1/share/pkgs/net-cookies-doc/info.rkt racket-7.0+ppa1/share/pkgs/net-cookies-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/net-cookies-doc/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-cookies-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define pkg-desc "documentation part of \"net-cookies\"") (define deps (quote ("base"))) (define update-implies (quote ("net-cookies-lib"))) (define build-deps (quote ("net-cookies-lib" "racket-doc" "web-server-lib" "web-server-doc" "net-doc" "scribble-lib"))) (define version "1.1.3"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define pkg-desc "documentation part of \"net-cookies\"") (define deps (quote ("base"))) (define update-implies (quote ("net-cookies-lib"))) (define build-deps (quote ("net-cookies-lib" "racket-doc" "web-server-lib" "web-server-doc" "net-doc" "scribble-lib"))) (define version "1.1.3"))) diff -Nru racket-6.12+ppa1/share/pkgs/net-cookies-lib/info.rkt racket-7.0+ppa1/share/pkgs/net-cookies-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/net-cookies-lib/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-cookies-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define pkg-desc "implementation (no documentation) part of \"net-cookies\"") (define deps (quote ("srfi-lite-lib" "base"))) (define version "1.1.3"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define pkg-desc "implementation (no documentation) part of \"net-cookies\"") (define deps (quote ("srfi-lite-lib" "base"))) (define version "1.1.3"))) diff -Nru racket-6.12+ppa1/share/pkgs/net-doc/info.rkt racket-7.0+ppa1/share/pkgs/net-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/net-doc/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"net\"") (define pkg-authors (quote (mflatt))) (define build-deps (quote ("compatibility-lib" "net-lib" "racket-doc" "scribble-lib" "web-server-doc" "web-server-lib"))) (define update-implies (quote ("net-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "documentation part of \"net\"") (define pkg-authors (quote (mflatt))) (define build-deps (quote ("compatibility-lib" "net-lib" "racket-doc" "scribble-lib" "web-server-doc" "web-server-lib"))) (define update-implies (quote ("net-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/net-doc/net/scribblings/imap.scrbl racket-7.0+ppa1/share/pkgs/net-doc/net/scribblings/imap.scrbl --- racket-6.12+ppa1/share/pkgs/net-doc/net/scribblings/imap.scrbl 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-doc/net/scribblings/imap.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -247,7 +247,7 @@ (listof (cons/c exact-nonnegative-integer? (listof pair?)))]{ -Returns information must like @racket[imap-get-messages], but includes +Returns information much like @racket[imap-get-messages], but includes information reported asynchronously by the server (e.g., to notify a client with some other client changes a message attribute). Instead of reporting specific requested information for specific messages, the @@ -314,7 +314,7 @@ @racket[imap-get-expunges]. @examples[ -(eval:alts (imap-get-message imap '(1 3 5) '(uid header)) +(eval:alts (imap-get-messages imap '(1 3 5) '(uid header)) '((107 #"From: larry@stooges.com ...") (110 #"From: moe@stooges.com ...") (112 #"From: curly@stooges.com ..."))) diff -Nru racket-6.12+ppa1/share/pkgs/net-lib/info.rkt racket-7.0+ppa1/share/pkgs/net-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/net-lib/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/net-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "base"))) (define pkg-desc "implementation (no documentation) part of \"net\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "base"))) (define pkg-desc "implementation (no documentation) part of \"net\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/optimization-coach/info.rkt racket-7.0+ppa1/share/pkgs/optimization-coach/info.rkt --- racket-6.12+ppa1/share/pkgs/optimization-coach/info.rkt 2018-01-26 21:08:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/optimization-coach/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "3.0") (define deps (quote (("base" #:version "6.2.900.6") ("drracket" #:version "1.6") ("typed-racket-lib" #:version "1.7") "profile-lib" "rackunit-lib" "gui-lib" "data-lib" "source-syntax" "images-lib" "sandbox-lib" "string-constants-lib"))) (define build-deps (quote ("scribble-lib"))) (define pkg-desc "Optimization Coach Plug-In for DrRacket.") (define pkg-authors (quote (stamourv))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "3.0") (define deps (quote (("base" #:version "6.2.900.6") ("drracket" #:version "1.6") ("typed-racket-lib" #:version "1.7") "profile-lib" "rackunit-lib" "gui-lib" "data-lib" "source-syntax" "images-lib" "sandbox-lib" "string-constants-lib"))) (define build-deps (quote ("scribble-lib"))) (define pkg-desc "Optimization Coach Plug-In for DrRacket.") (define pkg-authors (quote (stamourv))))) diff -Nru racket-6.12+ppa1/share/pkgs/option-contract/info.rkt racket-7.0+ppa1/share/pkgs/option-contract/info.rkt --- racket-6.12+ppa1/share/pkgs/option-contract/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/option-contract/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.0") (define deps (quote ("option-contract-lib" "option-contract-doc"))) (define pkg-authors (quote (chrdimo robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.0") (define deps (quote ("option-contract-lib" "option-contract-doc"))) (define pkg-authors (quote (chrdimo robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/option-contract-doc/info.rkt racket-7.0+ppa1/share/pkgs/option-contract-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/option-contract-doc/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/option-contract-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.17") "option-contract-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-authors (quote (chrdimo robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.17") "option-contract-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-authors (quote (chrdimo robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/option-contract-lib/info.rkt racket-7.0+ppa1/share/pkgs/option-contract-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/option-contract-lib/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/option-contract-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.17")))) (define pkg-authors (quote (chrdimo robby))) (define pkg-desc "Experimental libraries for option contracts"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.0") (define deps (quote (("base" #:version "6.2.900.17")))) (define pkg-authors (quote (chrdimo robby))) (define pkg-desc "Experimental libraries for option contracts"))) diff -Nru racket-6.12+ppa1/share/pkgs/parser-tools/info.rkt racket-7.0+ppa1/share/pkgs/parser-tools/info.rkt --- racket-6.12+ppa1/share/pkgs/parser-tools/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/parser-tools/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("parser-tools-lib" "parser-tools-doc"))) (define implies (quote ("parser-tools-lib" "parser-tools-doc"))) (define pkg-desc "Lex- and Yacc-style parsing tools") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("parser-tools-lib" "parser-tools-doc"))) (define implies (quote ("parser-tools-lib" "parser-tools-doc"))) (define pkg-desc "Lex- and Yacc-style parsing tools") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/parser-tools-doc/info.rkt racket-7.0+ppa1/share/pkgs/parser-tools-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/parser-tools-doc/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/parser-tools-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("scheme-lib" "racket-doc" "syntax-color-doc" "parser-tools-lib" "scribble-lib"))) (define update-implies (quote ("parser-tools-lib"))) (define pkg-desc "documentation part of \"parser-tools\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define build-deps (quote ("scheme-lib" "racket-doc" "syntax-color-doc" "parser-tools-lib" "scribble-lib"))) (define update-implies (quote ("parser-tools-lib"))) (define pkg-desc "documentation part of \"parser-tools\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/parser-tools-lib/info.rkt racket-7.0+ppa1/share/pkgs/parser-tools-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/parser-tools-lib/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/parser-tools-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"parser-tools\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"parser-tools\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/pconvert-lib/info.rkt racket-7.0+ppa1/share/pkgs/pconvert-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/pconvert-lib/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pconvert-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define deps (quote ("base" "compatibility-lib"))) (define collection (quote multi)) (define pkg-desc "Legacy library for printing Racket values") (define version "1.1") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define deps (quote ("base" "compatibility-lib"))) (define collection (quote multi)) (define pkg-desc "Legacy library for printing Racket values") (define version "1.1") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/pict/info.rkt racket-7.0+ppa1/share/pkgs/pict/info.rkt --- racket-6.12+ppa1/share/pkgs/pict/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("pict-lib" "pict-doc"))) (define implies (quote ("pict-lib" "pict-doc"))) (define pkg-desc "Building pictures with functional combinators") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("pict-lib" "pict-doc"))) (define implies (quote ("pict-lib" "pict-doc"))) (define pkg-desc "Building pictures with functional combinators") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/pict-doc/info.rkt racket-7.0+ppa1/share/pkgs/pict-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/pict-doc/info.rkt 2018-01-26 21:08:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "draw-doc" "gui-doc" "slideshow-doc" "draw-lib" "gui-lib" "scribble-lib" "slideshow-lib" "pict-lib" "racket-doc" "scribble-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("pict-lib"))) (define pkg-desc "documentation part of \"pict\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "draw-doc" "gui-doc" "slideshow-doc" "draw-lib" "gui-lib" "scribble-lib" "slideshow-lib" "pict-lib" "racket-doc" "scribble-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("pict-lib"))) (define pkg-desc "documentation part of \"pict\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/pict-doc/pict/scribblings/code.scrbl racket-7.0+ppa1/share/pkgs/pict-doc/pict/scribblings/code.scrbl --- racket-6.12+ppa1/share/pkgs/pict-doc/pict/scribblings/code.scrbl 2018-01-26 20:36:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-doc/pict/scribblings/code.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -392,7 +392,7 @@ @(require (for-label (only-in scribble/manual codeblock))) -@defproc[(codeblock-pict [code string?] [#:keep-lang-line? keep? any/c #t]) pict?]{ +@defproc[(codeblock-pict [code-string string?] [#:keep-lang-line? keep? any/c #t]) pict?]{ Like Scribble's @racket[codeblock] but generates picts. diff -Nru racket-6.12+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl racket-7.0+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl --- racket-6.12+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl 2018-01-26 20:36:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -21,7 +21,7 @@ @defmodule*/no-declare[(pict)]{ The @racketmodname[pict] library is one of the standard Racket functional picture libraries (the other being @racketmodname[2htdp/image #:indirect]). -This library was original designed for use with +This library was originally designed for use with @seclink[#:doc '(lib "scribblings/slideshow/slideshow.scrbl") "top"]{Slideshow}, and is re-provided by the @racketmodname[slideshow] language.} diff -Nru racket-6.12+ppa1/share/pkgs/pict-lib/info.rkt racket-7.0+ppa1/share/pkgs/pict-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/pict-lib/info.rkt 2018-01-26 21:08:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "draw-lib" "syntax-color-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"pict\"") (define pkg-authors (quote (mflatt robby))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "draw-lib" "syntax-color-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"pict\"") (define pkg-authors (quote (mflatt robby))) (define version "1.7"))) diff -Nru racket-6.12+ppa1/share/pkgs/pict-lib/pict/code.rkt racket-7.0+ppa1/share/pkgs/pict-lib/pict/code.rkt --- racket-6.12+ppa1/share/pkgs/pict-lib/pict/code.rkt 2018-01-26 20:36:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-lib/pict/code.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -205,18 +205,23 @@ (define (token-class->color c) (case c [(symbol) id-color] - [(keyword) id-color] ; We don't have a keyword color? + [(keyword) keyword-color] [(white-space) "white"] [(comment) comment-color] [(no-color) base-color] [(parenthesis) base-color] ; really? pict has no color for parens? [(string) literal-color] [(constant) literal-color] - [(hash-colon-keyword) keyword-color] + [(hash-colon-keyword) base-color] [else "black"])) ; 'other, or others. to align with DrRacket + (define (in-keyword-list? token) + (member token (current-keyword-list))) (define (token->pict t) (match-define `(,token . ,type) t) - (colorize (tt token) (token-class->color type))) + (define color + (cond [(in-keyword-list? token) keyword-color] + [else (token-class->color type)])) + (colorize (tt token) color)) (define (not-newline? x) (not (equal? (car x) "\n"))) (define lines (let loop ([ts ts]) diff -Nru racket-6.12+ppa1/share/pkgs/pict-lib/pict/main.rkt racket-7.0+ppa1/share/pkgs/pict-lib/pict/main.rkt --- racket-6.12+ppa1/share/pkgs/pict-lib/pict/main.rkt 2018-01-26 20:36:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-lib/pict/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -234,7 +234,7 @@ (define (does-draw-restore-the-state-after-being-called? draw) (define bdc (new bitmap-dc% [bitmap (make-bitmap 1 1)])) - (randomize-state bdc) + (prandomize-state bdc) (define old-state (get-dc-state bdc)) (draw bdc 0 0) (equal? (get-dc-state bdc) old-state)) @@ -242,16 +242,16 @@ ;; randomizes some portions of the state of the given dc; ;; doesn't pick random values for things that the 'dc' ;; function promises not to change (e.g. the pen/brush style). -(define (randomize-state dc) - (send dc set-origin (random-real) (random-real)) - (send dc set-pen (random-color) (random 255) 'solid) - (send dc set-brush (random-color) 'solid) - (send dc set-alpha (random)) - (send dc set-text-background (random-color)) - (send dc set-text-foreground (random-color)) +(define (prandomize-state dc) + (send dc set-origin (prandom-real) (prandom-real)) + (send dc set-pen (prandom-color) (prandom 255) 'solid) + (send dc set-brush (prandom-color) 'solid) + (send dc set-alpha (prandom)) + (send dc set-text-background (prandom-color)) + (send dc set-text-foreground (prandom-color)) (send dc set-text-mode 'transparent) (send dc set-font (send the-font-list find-or-create-font - (+ 1 (random 254)) + (+ 1 (prandom 254)) (pick-one 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system) (pick-one 'normal 'italic 'slant) @@ -260,13 +260,23 @@ ;; at the moment, so we don't randomize it #; (send dc set-transformation - (vector (vector (random-real) (random-real) (random-real) - (random-real) (random-real) (random-real)) - (random-real) (random-real) (random-real) (random-real) (random-real)))) + (vector (vector (prandom-real) (prandom-real) (prandom-real) + (prandom-real) (prandom-real) (prandom-real)) + (prandom-real) (prandom-real) (prandom-real) (prandom-real) (prandom-real)))) -(define (random-real) (+ (random 1000) (random))) -(define (random-color) (make-object color% (random 255) (random 255) (random 255))) -(define (pick-one . args) (list-ref args (random (length args)))) +(define (prandom-real) (+ (prandom 1000) (prandom))) +(define (prandom-color) (make-object color% (prandom 255) (prandom 255) (prandom 255))) +(define (pick-one . args) (list-ref args (prandom (length args)))) +(define pict-psrg + (make-pseudo-random-generator)) +(define prandom + (case-lambda + [() + (parameterize ([current-pseudo-random-generator pict-psrg]) + (random))] + [(x) + (parameterize ([current-pseudo-random-generator pict-psrg]) + (random x))])) (define (get-dc-state dc) (vector (pen->vec (send dc get-pen)) diff -Nru racket-6.12+ppa1/share/pkgs/pict-snip/info.rkt racket-7.0+ppa1/share/pkgs/pict-snip/info.rkt --- racket-6.12+ppa1/share/pkgs/pict-snip/info.rkt 2018-01-26 21:08:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-snip/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("pict-snip-lib" "pict-snip-doc"))) (define implies (quote ("pict-snip-lib" "pict-snip-doc"))) (define pkg-desc "Build snips out of picts") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("pict-snip-lib" "pict-snip-doc"))) (define implies (quote ("pict-snip-lib" "pict-snip-doc"))) (define pkg-desc "Build snips out of picts") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/pict-snip-doc/info.rkt racket-7.0+ppa1/share/pkgs/pict-snip-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/pict-snip-doc/info.rkt 2018-01-26 21:08:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-snip-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("pict-snip-lib" "gui-doc" "pict-doc" "pict-lib" "racket-doc" "scribble-lib" "snip-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("pict-snip-lib"))) (define pkg-desc "documentation part of \"pict\"") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("pict-snip-lib" "gui-doc" "pict-doc" "pict-lib" "racket-doc" "scribble-lib" "snip-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("pict-snip-lib"))) (define pkg-desc "documentation part of \"pict\"") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/pict-snip-lib/info.rkt racket-7.0+ppa1/share/pkgs/pict-snip-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/pict-snip-lib/info.rkt 2018-01-26 21:08:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pict-snip-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("draw-lib" "snip-lib" "pict-lib" "wxme-lib" "base"))) (define build-deps (quote ("rackunit-lib" "gui-lib"))) (define pkg-desc "implementation (no documentation) part of \"pict-snip\"") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("draw-lib" "snip-lib" "pict-lib" "wxme-lib" "base"))) (define build-deps (quote ("rackunit-lib" "gui-lib"))) (define pkg-desc "implementation (no documentation) part of \"pict-snip\"") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/picturing-programs/info.rkt racket-7.0+ppa1/share/pkgs/picturing-programs/info.rkt --- racket-6.12+ppa1/share/pkgs/picturing-programs/info.rkt 2018-01-26 21:08:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/picturing-programs/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "gui-lib" "snip-lib" "htdp-lib"))) (define build-deps (quote ("racket-doc" "htdp-doc" "scribble-lib"))) (define pkg-desc "Teaching libraries for _Picturing Programs_") (define pkg-authors (quote (sbloch))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "gui-lib" "snip-lib" "htdp-lib"))) (define build-deps (quote ("racket-doc" "htdp-doc" "scribble-lib"))) (define pkg-desc "Teaching libraries for _Picturing Programs_") (define pkg-authors (quote (sbloch))))) diff -Nru racket-6.12+ppa1/share/pkgs/pkgs.rktd racket-7.0+ppa1/share/pkgs/pkgs.rktd --- racket-6.12+ppa1/share/pkgs/pkgs.rktd 2018-01-26 21:12:13.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/pkgs.rktd 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -#hash(("games" . #s((sc-pkg-info pkg-info 3) (catalog "games") "0714494b7e16407072ad0048163e8477af2d675a" #t "games")) ("ds-store-lib" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-lib") "a7ed25d34ef2565bd7fb3bad5a6e596e07509958" #t "ds-store")) ("scheme-lib" . #s(pkg-info (catalog "scheme-lib") "de670cedc171f3678e59f9d780e6d944d4b6a086" #t)) ("wxme-lib" . #s(pkg-info (catalog "wxme-lib") "56be8e531cced09d3c3ae9fc58934bdbad9b7920" #t)) ("redex-gui-lib" . #s(pkg-info (catalog "redex-gui-lib") "76085d3b2ce7de9c54015be78161ceea37c59438" #t)) ("plot-lib" . #s(pkg-info (catalog "plot-lib") "e34c5cf5192d2cdc7f0bd8f6d4221de171a39182" #t)) ("net-cookies-doc" . #s(pkg-info (catalog "net-cookies-doc") "551ba741dc65dda3d0cb4819c3d2438e3c893d6b" #t)) ("net-cookies-lib" . #s(pkg-info (catalog "net-cookies-lib") "96ff20cd91ba8d8082e46b60de737a34e0e7db90" #t)) ("errortrace-doc" . #s(pkg-info (catalog "errortrace-doc") "104c0b4b878fa5939a3cade2df876a6b9a45859f" #t)) ("unix-socket-doc" . #s(pkg-info (catalog "unix-socket-doc") "1c5c54762338f429d11067d8dcd0caa08b43b65f" #t)) ("wxme" . #s(pkg-info (catalog "wxme") "ee066e8fe91f4573ebc269c1366e3fcefebf5c1d" #t)) ("macro-debugger-text-lib" . #s(pkg-info (catalog "macro-debugger-text-lib") "98415d32fa1472da5327b3eee5fd1fc28d1c27ba" #t)) ("drracket-tool-doc" . #s(pkg-info (catalog "drracket-tool-doc") "a49e1114afe966b6ca4496d52639c6c10094d262" #t)) ("trace" . #s((sc-pkg-info pkg-info 3) (catalog "trace") "6e4c7bd2c9caefecbb2a468507520e88525f40f7" #t "trace")) ("plai-doc" . #s((sc-pkg-info pkg-info 3) (catalog "plai-doc") "53572f6435c1ec46cf364476d2cea9d09460e7b3" #t "plai")) ("rackunit-lib" . #s(pkg-info (catalog "rackunit-lib") "14ea0d8bc1d3641f395a107584d44d37983d6601" #t)) ("planet-lib" . #s(pkg-info (catalog "planet-lib") "189b13b192b346dd2d9b8a641b1b2f45b144599e" #t)) ("rackunit-typed" . #s((sc-pkg-info pkg-info 3) (catalog "rackunit-typed") "727116fbff8ae1979ab6d6e39dc5469e18443009" #t "typed")) ("images-gui-lib" . #s(pkg-info (catalog "images-gui-lib") "9f01931ee9b10637fa6f0617117d1d4c730f3cb0" #t)) ("drracket-tool-lib" . #s(pkg-info (catalog "drracket-tool-lib") "b0f41f1943e6d410cce78104ea0e62f50b258502" #t)) ("sasl-doc" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-doc") "d8535994778c7d8558e344fc680b85b10b290976" #t "sasl")) ("web-server-doc" . #s(pkg-info (catalog "web-server-doc") "b621a570e9d7cbb166130624e3c2dbdad198cfce" #t)) ("unix-socket-lib" . #s(pkg-info (catalog "unix-socket-lib") "50dfb2a17f0bdef98531b4f5aec5de9a9ebe3dbb" #t)) ("readline-doc" . #s(pkg-info (catalog "readline-doc") "72d3478368cd0ba54a18611f8712b6f2a5f69233" #t)) ("redex-benchmark" . #s(pkg-info (catalog "redex-benchmark") "d8d6499a5cb6da350cd80398d40d89950e198388" #t)) ("dynext-lib" . #s(pkg-info (catalog "dynext-lib") "d2acaedddcce36897f00ffa05545d512f89a0f51" #t)) ("xrepl-lib" . #s(pkg-info (catalog "xrepl-lib") "a6160657357c2c2f39041842004ddc9867108bc8" #t)) ("data-enumerate-lib" . #s(pkg-info (catalog "data-enumerate-lib") "24b4d198cd73364c4664caa2458c3d076e71fc53" #t)) ("class-iop-lib" . #s(pkg-info (catalog "class-iop-lib") "3887471740eca3f10a403e42af55d7010ed078e7" #t)) ("sgl" . #s((sc-pkg-info pkg-info 3) (catalog "sgl") "643c6e64b4eaedbda82e66cee9af96bce57595cb" #t "sgl")) ("ds-store-doc" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-doc") "c61ead19419ca262c7ec91e8d35594799dbf441d" #t "ds-store")) ("zo-lib" . #s(pkg-info (catalog "zo-lib") "7535c63c8a883bb55242995b9769130b3cabb393" #t)) ("scribble-doc" . #s(pkg-info (catalog "scribble-doc") "12871bb7c7a9e2c842dd5a485ea4112df23a9564" #t)) ("string-constants" . #s(pkg-info (catalog "string-constants") "a7e7cb3b7c490de1754416c390b9ef34e82daed0" #t)) ("pconvert-lib" . #s(pkg-info (catalog "pconvert-lib") "863c9189d46e03fd41d8216c431bdc0984ae3a0a" #t)) ("syntax-color-doc" . #s(pkg-info (catalog "syntax-color-doc") "c68088fb6179f807f2753eda422763d11960f6df" #t)) ("gui-lib" . #s(pkg-info (catalog "gui-lib") "891896fd1cfabdd3329e070209b04f3a149d859a" #t)) ("algol60" . #s((sc-pkg-info pkg-info 3) (catalog "algol60") "18268cdcb837f207492231fd6765467f66aa6bd8" #t "algol60")) ("errortrace" . #s(pkg-info (catalog "errortrace") "e63c664f79bb05c15f84ec9e42e6a7f9b8966bd2" #t)) ("planet-doc" . #s(pkg-info (catalog "planet-doc") "eb2b051c3bb9831312110c2a54406548209cd9c7" #t)) ("profile-lib" . #s((sc-pkg-info pkg-info 3) (catalog "profile-lib") "d5002b06076eb5ae1613a1db1955973a501a879a" #t "profile")) ("racket-doc" . #s(pkg-info (catalog "racket-doc") "fdfd22e846792e3d2e8aa7c3a40808f9740af988" #t)) ("mzcom" . #s((sc-pkg-info pkg-info 3) (catalog "mzcom") "f67f4ca73b6c8918f0cf0fb446029c176a5c2197" #t "mzcom")) ("option-contract" . #s(pkg-info (catalog "option-contract") "2084c53e08bbe60ba07b09ed612e112365a8d0e5" #t)) ("mysterx" . #s((sc-pkg-info pkg-info 3) (catalog "mysterx") "968f1e19be033bebe3a41d6beda05a065c69e51b" #t "mysterx")) ("errortrace-lib" . #s(pkg-info (catalog "errortrace-lib") "f7873118981ce8f2e132d643cbf00cf9c03505ec" #t)) ("icons" . #s((sc-pkg-info pkg-info 3) (catalog "icons") "549650174f71bec06662eb059bffdc1f54ad7967" #t "icons")) ("gui-pkg-manager-lib" . #s(pkg-info (catalog "gui-pkg-manager-lib") "3d20e0e9f8a4cf690d20a2b9e5a4e524fe455408" #t)) ("r5rs" . #s(pkg-info (catalog "r5rs") "5dda556b4101bf6bebd85f962c05c296db7f0e5b" #t)) ("readline" . #s(pkg-info (catalog "readline") "b4938f521213f777ded05d86fa234e6028dda243" #t)) ("html-lib" . #s(pkg-info (catalog "html-lib") "95fc62eba84556b5994baebe680ae76f1fb45ec5" #t)) ("lazy" . #s((sc-pkg-info pkg-info 3) (catalog "lazy") "311f73e5e9dc758f1f07719f06e2847b2a162d7f" #t "lazy")) ("profile" . #s(pkg-info (catalog "profile") "7e480569da7e6671d6667830701fe3ee875f0f52" #t)) ("db-doc" . #s(pkg-info (catalog "db-doc") "b0ff08cde75ffd9f31bd9c0cc922664de75901a9" #t)) ("compatibility" . #s(pkg-info (catalog "compatibility") "1e0f09985626cc419e9ecd9d6f850a001f2c9a8b" #t)) ("redex-lib" . #s(pkg-info (catalog "redex-lib") "d3c7836f7e7b49744860fd6a15c0330c12458b3b" #t)) ("racket-lib" . #s(pkg-info (catalog "racket-lib") "810b69bd48b5b2111c0f7d548f54005d38cd51e9" #f)) ("htdp" . #s(pkg-info (catalog "htdp") "bb8382812181fb0cba8258638395fdc00a76fa81" #t)) ("sandbox-lib" . #s(pkg-info (catalog "sandbox-lib") "6faf43eb89878ff8f359afe826738d0fa846f0c9" #t)) ("macro-debugger" . #s(pkg-info (catalog "macro-debugger") "deb9e63dda79b649a9a03f43e53bc9285acaecaf" #t)) ("typed-racket-lib" . #s(pkg-info (catalog "typed-racket-lib") "bc4937da03f82eaef5babe57e62da3635a1b6e12" #t)) ("profile-doc" . #s(pkg-info (catalog "profile-doc") "8370a7fface294bffd3fc6dff1b6d7d11a02b35c" #t)) ("parser-tools-doc" . #s(pkg-info (catalog "parser-tools-doc") "49f722387bebd7991f10b7129979488bc62070b3" #t)) ("tex-table" . #s((sc-pkg-info pkg-info 3) (catalog "tex-table") "4f46ed56204b7ef6b01e22c4e032c665d65deab2" #t "mrlib")) ("distributed-places-lib" . #s(pkg-info (catalog "distributed-places-lib") "12f9e11df668b6be4e146403ffe3cb5df30732a2" #t)) ("math-doc" . #s(pkg-info (catalog "math-doc") "cb00a98771c5cbd38ebd6fb2a3f414cc692bcd47" #t)) ("string-constants-doc" . #s(pkg-info (catalog "string-constants-doc") "45ecf1e0dd8adbd2256e6151b7a5aec535d1b3f1" #t)) ("option-contract-doc" . #s(pkg-info (catalog "option-contract-doc") "2281f23855d1c56bda098498f53250b495c1444b" #t)) ("scribble" . #s(pkg-info (catalog "scribble") "6e82a86093cb7ca9ea1b07d3a381937904c7dc92" #t)) ("draw-lib" . #s(pkg-info (catalog "draw-lib") "988ebde72a7329f2c5586f2ff2de9e0daf7de783" #t)) ("deinprogramm-signature" . #s(pkg-info (catalog "deinprogramm-signature") "d48f22b247b053b7510aa4826b1e30647e1578c1" #t)) ("plai-lib" . #s((sc-pkg-info pkg-info 3) (catalog "plai-lib") "597fc0a37d16d2f1b8785e3d3f0de35d2eee7e7f" #t "plai")) ("r5rs-lib" . #s(pkg-info (catalog "r5rs-lib") "bb1e4352f17e912ac030d00f50dee4e2d89bbd95" #t)) ("typed-racket-more" . #s(pkg-info (catalog "typed-racket-more") "dbc01dde29997cf8eca4efd1330623fd3dda1004" #t)) ("drracket" . #s(pkg-info (catalog "drracket") "5c8ca8ca6a53bda3e6f7593577ecc3da79218146" #t)) ("unix-socket" . #s(pkg-info (catalog "unix-socket") "dcda14ea91fed60006c3b7d1059c0ad2cb8a2c5c" #t)) ("typed-racket-compatibility" . #s(pkg-info (catalog "typed-racket-compatibility") "71d338cdad6ea66092ff26799acbcea9bc404a19" #t)) ("web-server" . #s(pkg-info (catalog "web-server") "ac1aefac7979bee22131cf5d8045a1621d50bfb5" #t)) ("preprocessor" . #s((sc-pkg-info pkg-info 3) (catalog "preprocessor") "0e46ea639603060447229afefcbdbd82e3e78461" #t "preprocessor")) ("pict" . #s(pkg-info (catalog "pict") "d5eb9846050b0a83a10ab5a4f229ad34aa14792b" #t)) ("string-constants-lib" . #s(pkg-info (catalog "string-constants-lib") "73af8313c79078c64bd69c79ae565695b8b03c49" #t)) ("future-visualizer-typed" . #s(pkg-info (catalog "future-visualizer-typed") "903259a1cb98cd73b8c1de45df20885bd8868aaa" #t)) ("images" . #s(pkg-info (catalog "images") "66860c5d295a5494e5bbd7686cdaa87323ef9ff2" #t)) ("realm" . #s((sc-pkg-info pkg-info 3) (catalog "realm") "538c20cfa9d6bccf15f559fc79d27e7a876960b7" #t "realm")) ("images-doc" . #s(pkg-info (catalog "images-doc") "9fb9a522837e695329687ef8427b036baf77edc7" #t)) ("base" . #s(pkg-info (catalog "base") "842e2b328663a51a11b18ef6c0f971647227a231" #t)) ("xrepl" . #s(pkg-info (catalog "xrepl") "c337926fd43d1ecbfbe6c86bfacfd156a47af79b" #t)) ("html-doc" . #s(pkg-info (catalog "html-doc") "c7d655a24f878e5a50f0fe41e8eff25158d0ed43" #t)) ("scribble-html-lib" . #s(pkg-info (catalog "scribble-html-lib") "5416ad005d64366a5f85911d03155932a34edbaf" #t)) ("srfi-lite-lib" . #s(pkg-info (catalog "srfi-lite-lib") "6f8659c9c903ff1ee9c94250e3878eba915c5df7" #t)) ("distributed-places-doc" . #s(pkg-info (catalog "distributed-places-doc") "d50595d33c6dba95def8e40c4ea0ec9ae8734647" #t)) ("gui" . #s(pkg-info (catalog "gui") "902f0cb01de31665e02dc6c64397d8de95ebde6b" #t)) ("sasl" . #s((sc-pkg-info pkg-info 3) (catalog "sasl") "988c36604be3ca860b26801c45a01dd4aad8628b" #t "sasl")) ("parser-tools-lib" . #s(pkg-info (catalog "parser-tools-lib") "c979ba6d4e1616ed27e5da85d73726343c44c515" #t)) ("drracket-plugin-lib" . #s(pkg-info (catalog "drracket-plugin-lib") "51e24f3c890323fbf97d1cdd80a12bbe8203d1b4" #t)) ("readline-lib" . #s(pkg-info (catalog "readline-lib") "0e38086653ebacac7d227454df68f6b5e67efb06" #t)) ("main-distribution" . #s(pkg-info (catalog "main-distribution") "fd230051d9990fa5298338f9b56351d987147acf" #f)) ("pict-lib" . #s(pkg-info (catalog "pict-lib") "80962fd21ab63e5e55ccd73c4644c6e891d95a43" #t)) ("plot-gui-lib" . #s(pkg-info (catalog "plot-gui-lib") "796d08b9475be0dd39d7f48881984adc5db777b8" #t)) ("optimization-coach" . #s(pkg-info (catalog "optimization-coach") "6da9286ee0dabefc95f51f620375ea329446b6c1" #t)) ("net" . #s(pkg-info (catalog "net") "badaf679833b746ab7b8d8ddb9e55518fb05e9d9" #t)) ("r5rs-doc" . #s(pkg-info (catalog "r5rs-doc") "46ad8669f796ba9c50d8b698e6cf1551c76b7ab6" #t)) ("redex-doc" . #s(pkg-info (catalog "redex-doc") "5245d253456b2ab6f1ef21792c0f555ba4e73be3" #t)) ("shell-completion" . #s((sc-pkg-info pkg-info 3) (catalog "shell-completion") "a0decd321e00f455439178dcbbc5ebf59392c1ed" #t "shell-completion")) ("mzscheme-doc" . #s(pkg-info (catalog "mzscheme-doc") "b6c74d204f848558cda44bc50bf811509390cfa0" #t)) ("compiler" . #s(pkg-info (catalog "compiler") "0e4be9aa093943a338f4a9e8be7212ed883091bf" #t)) ("xrepl-doc" . #s(pkg-info (catalog "xrepl-doc") "b2a1543272b452fd1f3c9aef7403e0556bcfe937" #t)) ("syntax-color" . #s(pkg-info (catalog "syntax-color") "2f5248a0532a4a3ba0786aab5aa253c9a5637dc7" #t)) ("slideshow-lib" . #s(pkg-info (catalog "slideshow-lib") "81f9308acfe781305bf51926d22fb086ed65395c" #t)) ("eopl" . #s((sc-pkg-info pkg-info 3) (catalog "eopl") "f02f69b8fb8d489d167c0972c804ea63e83b76f8" #t "eopl")) ("cext-lib" . #s(pkg-info (catalog "cext-lib") "55d25f6eef9800d10066418a6dc49dc97c05aa3d" #t)) ("compatibility-lib" . #s(pkg-info (catalog "compatibility-lib") "6e7c6038296d8c3323cbcc0e33d64bb924a58a5d" #t)) ("redex-pict-lib" . #s(pkg-info (catalog "redex-pict-lib") "e2368eeaac3cd36d539dd73803e0fa0257619c4f" #t)) ("redex" . #s(pkg-info (catalog "redex") "f69d57baf1da8a200a9fca57f7ecc23659f44d6a" #t)) ("sasl-lib" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-lib") "dbd5fa986d9e2c1d28da5bc07f899019d8cfb9ef" #t "sasl")) ("htdp-lib" . #s(pkg-info (catalog "htdp-lib") "e385292543056ee3a43ad9fe20bffa512f322403" #t)) ("testing-util-lib" . #s(pkg-info (catalog "testing-util-lib") "1112804826cb2106dcd195cde2ee3d7f60ce6586" #t)) ("html" . #s(pkg-info (catalog "html") "87576922d1edd1278962bb47802114d995149ea4" #t)) ("htdp-doc" . #s(pkg-info (catalog "htdp-doc") "a9a37ee0cf1ced7475bd937dbd418aee318a2454" #t)) ("pict-snip" . #s(pkg-info (catalog "pict-snip") "cb7d13722537c1996ac9b81a88ba1b684bca1246" #t)) ("plai" . #s(pkg-info (catalog "plai") "54c151044f2e38f28009f1b969498c4bfb0f17a9" #t)) ("compatibility-doc" . #s(pkg-info (catalog "compatibility-doc") "10d4c9d0271d81355db8ee5df4e9351f09980635" #t)) ("snip-lib" . #s(pkg-info (catalog "snip-lib") "65d03919b8e4aa9a8aaa64171bc3ab4242083f05" #t)) ("contract-profile" . #s((sc-pkg-info pkg-info 3) (catalog "contract-profile") "d90bbf5ea488551ab1aa27833ee460496caaef1e" #t "contract-profile")) ("gui-doc" . #s(pkg-info (catalog "gui-doc") "6cb3b25490f0a1f1d912ad90baa39899d5328b81" #t)) ("typed-racket" . #s(pkg-info (catalog "typed-racket") "11e7ae651558024c0060ebd7292e55646d5558c9" #t)) ("data" . #s(pkg-info (catalog "data") "6fbc955e2962cff075dfbf95fd61703e6ce62e2b" #t)) ("net-doc" . #s(pkg-info (catalog "net-doc") "9a96802fba64cd15a7aba46d4c57ccba47b11069" #t)) ("planet" . #s(pkg-info (catalog "planet") "21bf70042a2fada81039eff4ea312051d2bc80ad" #t)) ("srfi" . #s(pkg-info (catalog "srfi") "c00631779a566b7bf0464d7908f1aca8f7ac7713" #t)) ("eli-tester" . #s(pkg-info (catalog "eli-tester") "2d2a692d6bbb7cafd56da054aee10126956d149b" #t)) ("data-lib" . #s(pkg-info (catalog "data-lib") "6357893aa8b7f37916181651b58c0057b51abb5e" #t)) ("plot-compat" . #s(pkg-info (catalog "plot-compat") "1c7b011d21af36e57ba42de930b9627edb0b034e" #t)) ("typed-racket-doc" . #s(pkg-info (catalog "typed-racket-doc") "23efaab44737eb6e83d820bd8df7e5ffaff5cb8b" #t)) ("srfi-lib" . #s(pkg-info (catalog "srfi-lib") "573b4d717d42ecdf9a60ddf0502dfcce80414f42" #t)) ("pict-snip-doc" . #s(pkg-info (catalog "pict-snip-doc") "dd0801d399bd929ba3d6b00c0454b753eb4918ef" #t)) ("draw" . #s(pkg-info (catalog "draw") "09e20fc7a9a105a3ea8547e38302fc4af00631ba" #t)) ("srfi-doc" . #s(pkg-info (catalog "srfi-doc") "e7daeb684a3e427cb27524fb11d13a04a9078259" #t)) ("math" . #s(pkg-info (catalog "math") "79054d63cbada868bb1a2cbd8594d588574d7f3b" #t)) ("snip" . #s(pkg-info (catalog "snip") "415b64ba36560b8ab177d7d3d97cd640136e30c1" #t)) ("option-contract-lib" . #s(pkg-info (catalog "option-contract-lib") "ee150a2fada04b3fc31c2f7360aa0f6e11029df8" #t)) ("racket-cheat" . #s((sc-pkg-info pkg-info 3) (catalog "racket-cheat") "6577b9da6392e96971e9ed6598b9223f82a11d95" #t "racket-cheat")) ("rackunit-doc" . #s(pkg-info (catalog "rackunit-doc") "12420b761edbd1ad63adf22b919f216094018f10" #t)) ("racket-index" . #s(pkg-info (catalog "racket-index") "076ceb0a724e381eaa3d1b790919206c705ad730" #t)) ("schemeunit" . #s((sc-pkg-info pkg-info 3) (catalog "schemeunit") "40863a38c853e99b4da1a6f50c4589672193f959" #t "schemeunit")) ("rackunit-plugin-lib" . #s(pkg-info (catalog "rackunit-plugin-lib") "a6f23772301c93e9aab4ce6db65de0da4f0d8bda" #t)) ("scribble-text-lib" . #s(pkg-info (catalog "scribble-text-lib") "5ae0d630771eea1494015b47564de6d06ac778a7" #t)) ("picturing-programs" . #s(pkg-info (catalog "picturing-programs") "a37e8fa42b0dea5bfbdf7f5e9c6fe5db360f4e88" #t)) ("plot" . #s(pkg-info (catalog "plot") "669bd805a1d0ccd0e20b592eaddf894b21dd021a" #t)) ("mzscheme" . #s(pkg-info (catalog "mzscheme") "9398cb525ce2b95cd805b8dc4d3889b7ae058e50" #t)) ("serialize-cstruct-lib" . #s(pkg-info (catalog "serialize-cstruct-lib") "64ea66070c50624eae78745f975cb9205c39c50e" #t)) ("data-doc" . #s(pkg-info (catalog "data-doc") "9af9050723579436c25320abd06b70b8a181812f" #t)) ("frtime" . #s((sc-pkg-info pkg-info 3) (catalog "frtime") "e017337f79a65338a71a2afbf159bf28cd736e76" #t "frtime")) ("2d-lib" . #s((sc-pkg-info pkg-info 3) (catalog "2d-lib") "5e607f0a11ff0af7e8f40c7a846f0b355e0d045f" #t "2d")) ("drracket-tool" . #s(pkg-info (catalog "drracket-tool") "5d93d32d8378be1c06c5f455f8fd24aad6f6eaf4" #t)) ("r6rs" . #s(pkg-info (catalog "r6rs") "02fddf29a24d1a7b14a75fabfc4abdf2be33d6a7" #t)) ("source-syntax" . #s((sc-pkg-info pkg-info 3) (catalog "source-syntax") "af01289ab1b09f35451af5b0b8b215f46923222d" #t "syntax")) ("distributed-places" . #s(pkg-info (catalog "distributed-places") "ededcefd72018d44379942cff2d1b53f19141a68" #t)) ("pict-snip-lib" . #s(pkg-info (catalog "pict-snip-lib") "02f1c7645acc61eae2017735855235fcf1de8202" #t)) ("db-lib" . #s(pkg-info (catalog "db-lib") "1058272a18f1c6785635653abe7852035b64b501" #t)) ("make" . #s((sc-pkg-info pkg-info 3) (catalog "make") "d764904661287dba3e16356fbb922e5b55b91640" #t "make")) ("net-cookies" . #s(pkg-info (catalog "net-cookies") "0c43038a279f0d7c26a3c0a9183843fc7b406ff3" #t)) ("swindle" . #s((sc-pkg-info pkg-info 3) (catalog "swindle") "af25a760e05bb254c5700dd8dab478ee4afdfbe2" #t "swindle")) ("mzscheme-lib" . #s(pkg-info (catalog "mzscheme-lib") "88e57e71150bcfcbf05ce549768aae10b89bb5ed" #t)) ("compiler-lib" . #s(pkg-info (catalog "compiler-lib") "8921c26c498e920aca398df7afb0ab486636430f" #t)) ("redex-examples" . #s(pkg-info (catalog "redex-examples") "9b5fc2d7be1f7cfe1eb15ba1d944a6ab8db39544" #t)) ("ds-store" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store") "e011736223cfd87066b109153f1c8148da55e3aa" #t "ds-store")) ("deinprogramm" . #s(pkg-info (catalog "deinprogramm") "83c4a67ce98b8fa29e23eb3ad505d382de992e18" #t)) ("rackunit" . #s(pkg-info (catalog "rackunit") "feea8898ebaa461c55e9cdb4c5ab4f90e8f21e2d" #t)) ("db" . #s(pkg-info (catalog "db") "7c46f82b61019ff099443319c62d875f2cf88fdf" #t)) ("2d-doc" . #s((sc-pkg-info pkg-info 3) (catalog "2d-doc") "e16514a841aa513668b7a2eed3a6ed125084e960" #t "2d")) ("web-server-lib" . #s(pkg-info (catalog "web-server-lib") "b16f5ba817c470fb570c859a28677610869d6b80" #t)) ("math-lib" . #s(pkg-info (catalog "math-lib") "e2f578e4bd7cf1ae4106976a3ff1fdeb84a04ca6" #t)) ("2d" . #s(pkg-info (catalog "2d") "60d96aad8b1d5f799a3f410884e1f8a50df9e8ee" #t)) ("r6rs-lib" . #s(pkg-info (catalog "r6rs-lib") "01f97065f1ae56d58630a62ccd805f4898cb1cfe" #t)) ("slatex" . #s((sc-pkg-info pkg-info 3) (catalog "slatex") "2c2541e0c700efba5a68ec2a4b2e17923ae0057b" #t "slatex")) ("plot-doc" . #s(pkg-info (catalog "plot-doc") "170581bc9986a932d0c0a0d71e0200969f341942" #t)) ("draw-doc" . #s(pkg-info (catalog "draw-doc") "1b73386f9deb779115150c2bc8889f272885f066" #t)) ("rackunit-gui" . #s(pkg-info (catalog "rackunit-gui") "7754e861d16beaba2949cb81109d3bfecb02208b" #t)) ("images-lib" . #s(pkg-info (catalog "images-lib") "06e3a61c590c27231019f070489ebf86caad2804" #t)) ("net-lib" . #s(pkg-info (catalog "net-lib") "072086da39b6813c6dac057736f769b880f7a6e4" #t)) ("pict-doc" . #s(pkg-info (catalog "pict-doc") "4e4e0df6882182ae2fdf53aab1910f7219f58bb8" #t)) ("r6rs-doc" . #s(pkg-info (catalog "r6rs-doc") "fb49f53eaa30106c352a6f7bc8c865bbd3f16ce0" #t)) ("syntax-color-lib" . #s(pkg-info (catalog "syntax-color-lib") "dbd9fd13014af5a4f12ce9bfea4fcbf79b564840" #t)) ("slideshow-exe" . #s(pkg-info (catalog "slideshow-exe") "b1e6af193af1640e85373e4310fa6c198e8ca202" #t)) ("at-exp-lib" . #s(pkg-info (catalog "at-exp-lib") "39aa817ddf1fd60635cf3c924d7dd423865ee9f5" #t)) ("datalog" . #s((sc-pkg-info pkg-info 3) (catalog "datalog") "6d15c446619360eab34598f525d4c645faee1113" #t "datalog")) ("future-visualizer" . #s(pkg-info (catalog "future-visualizer") "95a21d5a999ca2a8456a4bf5358baf8ebb33642a" #t)) ("racklog" . #s((sc-pkg-info pkg-info 3) (catalog "racklog") "9260c3586f319b36d9f3c484b4b6c9b85d0915fe" #t "racklog")) ("scribble-lib" . #s(pkg-info (catalog "scribble-lib") "4dbbf2797bc19682c75be9aeb7f3401f46848e3a" #t)) ("slideshow-doc" . #s(pkg-info (catalog "slideshow-doc") "f3d6fbf761236b71d077e7e118f6b1b88c608d9a" #t)) ("parser-tools" . #s(pkg-info (catalog "parser-tools") "f6dad40e22701a05bed08ad46d4e831f05b42dad" #t)) ("slideshow-plugin" . #s(pkg-info (catalog "slideshow-plugin") "f2ee76768297f390d7aa7454d4d77688858f3489" #t)) ("slideshow" . #s(pkg-info (catalog "slideshow") "acf5ef7e5c5a1f155893c15e7851fe3bc78972d5" #t))) +#hash(("slideshow-plugin" . #s(pkg-info (catalog "slideshow-plugin") "cc74c9f85d1ef48e2f260dbe08f3bb8a650be99f" #t)) ("pconvert-lib" . #s(pkg-info (catalog "pconvert-lib") "68ce827d3677b4c351301a3dfba9bcc0f1a6f704" #t)) ("scribble" . #s(pkg-info (catalog "scribble") "d5490702bf3fea8fa2fc9e79d56b2a09320f21dc" #t)) ("gui" . #s(pkg-info (catalog "gui") "e11a3b3760379ffb063c05686b4834e483e9bd2f" #t)) ("parser-tools-doc" . #s(pkg-info (catalog "parser-tools-doc") "3acdcd66f1a362be6d1d75f1ce5807ffb67b1ac0" #t)) ("net-cookies-doc" . #s(pkg-info (catalog "net-cookies-doc") "4e56ffbf499d87d509ed60c7b40dc8b261cd6cee" #t)) ("db-doc" . #s(pkg-info (catalog "db-doc") "36c8ff8cbb43465aeacb0b23f06a00e517729549" #t)) ("slideshow-lib" . #s(pkg-info (catalog "slideshow-lib") "be1cb2b1578896c7e225cd86163494d0953d5ca1" #t)) ("drracket-tool" . #s(pkg-info (catalog "drracket-tool") "96f690ede797edf63a6b32d569fbecd804f85510" #t)) ("string-constants-doc" . #s(pkg-info (catalog "string-constants-doc") "92fa90bb2ba80fd460f4e9182cfe32836e0ab599" #t)) ("tex-table" . #s((sc-pkg-info pkg-info 3) (catalog "tex-table") "5cdbbe0b0913e1d985e42efcb10db899bd73050a" #t "mrlib")) ("pict-snip-lib" . #s(pkg-info (catalog "pict-snip-lib") "9b5b0432b537447e167a2e76492480ec28ef3ed3" #t)) ("syntax-color-lib" . #s(pkg-info (catalog "syntax-color-lib") "01f5e34594a46ef3e6e1e96d98fc2d7fcc04da9c" #t)) ("eli-tester" . #s(pkg-info (catalog "eli-tester") "77fac086923c7ed7aee6032ed4bbf03d674e0343" #t)) ("realm" . #s((sc-pkg-info pkg-info 3) (catalog "realm") "3fd9982bd73cd6c16864d8beb19f3fdc1fbefd2c" #t "realm")) ("pict" . #s(pkg-info (catalog "pict") "d9b9ad41d3416d69b7056822870bcfc4e10e78e6" #t)) ("rackunit" . #s(pkg-info (catalog "rackunit") "17d64ffc1246a7062de7e3863afffe60a5d7e177" #t)) ("future-visualizer" . #s(pkg-info (catalog "future-visualizer") "1c0e166f9d571be78882b15991e5ffe1df4be16b" #t)) ("net-doc" . #s(pkg-info (catalog "net-doc") "1d85d4e5d2fe1d8a01879af9b3ab335025b60fec" #t)) ("deinprogramm" . #s(pkg-info (catalog "deinprogramm") "38398b099be05dd1b5c06634589178f82533c494" #t)) ("r6rs-lib" . #s(pkg-info (catalog "r6rs-lib") "7f88a4833679f722bff188d35b2dfd011ee690c4" #t)) ("math-lib" . #s(pkg-info (catalog "math-lib") "85fc0c52f4708be871f349343949de5c2757391e" #t)) ("plai" . #s(pkg-info (catalog "plai") "174ae32363ac50f176c7818f56f526c22e8ff1a1" #t)) ("plai-lib" . #s((sc-pkg-info pkg-info 3) (catalog "plai-lib") "b968bd4fc7948baf8d90f7d91b4f16257c2a99c7" #t "plai")) ("data-doc" . #s(pkg-info (catalog "data-doc") "fd855a5d95395e26b2958fda6850d7f0342f2374" #t)) ("plai-doc" . #s((sc-pkg-info pkg-info 3) (catalog "plai-doc") "ef21982c626be3e54e3c6d135622afa02c79696b" #t "plai")) ("cext-lib" . #s(pkg-info (catalog "cext-lib") "4d303c7ec3c707dc9b89dcca3e2da1aaef396d90" #t)) ("srfi-lib" . #s(pkg-info (catalog "srfi-lib") "d3ba67230f4f5092ac67b55bdda0948010559f88" #t)) ("gui-doc" . #s(pkg-info (catalog "gui-doc") "9d0a391450017e24344818c9658287e3c60a7fa0" #t)) ("scribble-html-lib" . #s(pkg-info (catalog "scribble-html-lib") "ccb749a3aeb1f9bbc5c6d563575d87e0a692b5a2" #t)) ("html" . #s(pkg-info (catalog "html") "15a4470ee892391f39647b065321b92fa3b80c35" #t)) ("distributed-places-doc" . #s(pkg-info (catalog "distributed-places-doc") "9da52a0e854653030b57acfede246722e764c39b" #t)) ("ds-store-doc" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-doc") "765c0ad6a515296a0b4acb4615549b591d900f80" #t "ds-store")) ("string-constants-lib" . #s(pkg-info (catalog "string-constants-lib") "2032859a8404c15e17112a8dd38c453056cee48a" #t)) ("preprocessor" . #s((sc-pkg-info pkg-info 3) (catalog "preprocessor") "a899ed458c2d6fb2e69d74930faeb6ff6a151e23" #t "preprocessor")) ("plot-lib" . #s(pkg-info (catalog "plot-lib") "e41a222ada4333dfe7d90c3a4ae177090bab2d21" #t)) ("snip-lib" . #s(pkg-info (catalog "snip-lib") "dc609e65f2db9b6d9115f2622351b4f749e1fbb9" #t)) ("rackunit-lib" . #s(pkg-info (catalog "rackunit-lib") "e0a410504ec50d1573ccfd194b5df86014733dd2" #t)) ("scribble-text-lib" . #s(pkg-info (catalog "scribble-text-lib") "63c5bf0490f750ebaaf38c82f4638ea0111f50c1" #t)) ("r6rs-doc" . #s(pkg-info (catalog "r6rs-doc") "ead5b86ec3afcf9b129f5aeb1e1925a493276bb8" #t)) ("net-cookies" . #s(pkg-info (catalog "net-cookies") "7375973ff08a504cc4c95d0ded2e79b65654bc9b" #t)) ("pict-lib" . #s(pkg-info (catalog "pict-lib") "8106b3f11f500fcf6ddd13ffb4883b6c78b91195" #t)) ("srfi-lite-lib" . #s(pkg-info (catalog "srfi-lite-lib") "d815acc04663a578acf711b681b8101dd5616b2b" #t)) ("wxme-lib" . #s(pkg-info (catalog "wxme-lib") "efce62e171b69558cf939fb4f6c179dce80c4081" #t)) ("planet-doc" . #s(pkg-info (catalog "planet-doc") "a20b21a49605e09c6e51ee6425c1d1f4a3320f37" #t)) ("picturing-programs" . #s(pkg-info (catalog "picturing-programs") "2424b9d3f7817be114e5795438a7ec97df70fa9f" #t)) ("unix-socket-doc" . #s(pkg-info (catalog "unix-socket-doc") "c7b91580739bc7a9b11a6588e635001009578adb" #t)) ("xrepl-lib" . #s(pkg-info (catalog "xrepl-lib") "a704456e2136ee58fff158e59ddbb257a493b0fa" #t)) ("net" . #s(pkg-info (catalog "net") "c678cbb28951b5bdbacda41c3d451c6e924fa0fd" #t)) ("class-iop-lib" . #s(pkg-info (catalog "class-iop-lib") "02ed582c846fde5437d06ab73a473b3d895f0d3b" #t)) ("redex-lib" . #s(pkg-info (catalog "redex-lib") "b574e7cfc50ecdb755538480cf0a98917d59f61a" #t)) ("gui-pkg-manager-lib" . #s(pkg-info (catalog "gui-pkg-manager-lib") "029f68413217a2655a6c74319300eddd5f0c3428" #t)) ("eopl" . #s((sc-pkg-info pkg-info 3) (catalog "eopl") "4595057a3fae87d294e8dda399644702736a2183" #t "eopl")) ("plot-compat" . #s(pkg-info (catalog "plot-compat") "99837e76f3cf3bbd5260699e085a0f49beb47af5" #t)) ("syntax-color" . #s(pkg-info (catalog "syntax-color") "0da29f75312c3cd2f7c24ec372122ec8b928ee9f" #t)) ("errortrace-doc" . #s(pkg-info (catalog "errortrace-doc") "f9229a8877ddd9b381061c258244d907f073c796" #t)) ("web-server-lib" . #s(pkg-info (catalog "web-server-lib") "c3fbe7186451d0ec36052e214ed53f33c0c0ce12" #t)) ("errortrace" . #s(pkg-info (catalog "errortrace") "c0bd9f1a10871313a02778e8e1e70cec66b3e0ea" #t)) ("redex-examples" . #s(pkg-info (catalog "redex-examples") "d237f2e48ad7416daa8820f46478e05d6a453511" #t)) ("profile" . #s(pkg-info (catalog "profile") "0af09775b0e27365bd16b09421d5424ba221f0dd" #t)) ("scribble-lib" . #s(pkg-info (catalog "scribble-lib") "2327f6199cb905df2fb1fbe860a63e29d4c67395" #t)) ("macro-debugger" . #s(pkg-info (catalog "macro-debugger") "2d1805c62713762386e5953574884b043c217ca6" #t)) ("distributed-places-lib" . #s(pkg-info (catalog "distributed-places-lib") "1a612e0d9cccda72710f8e36cbac6b6ed0bc273a" #t)) ("typed-racket-more" . #s(pkg-info (catalog "typed-racket-more") "7f26ea212adfc486bafa48ab1725aa7c29940d84" #t)) ("web-server-doc" . #s(pkg-info (catalog "web-server-doc") "7729f6d5630208f4520759661d9f97d39b540191" #t)) ("base" . #s(pkg-info (catalog "base") "f7f5be26f18909138c18a44a89ebb89023ee0fee" #t)) ("option-contract-lib" . #s(pkg-info (catalog "option-contract-lib") "3085167ea58a01808049540d3f4032899d00edaa" #t)) ("scribble-doc" . #s(pkg-info (catalog "scribble-doc") "918176ee533deec9b5f5015c0415cb331f9bb664" #t)) ("schemeunit" . #s((sc-pkg-info pkg-info 3) (catalog "schemeunit") "dee32b1ca870b90daae9f813faf3edb99642e1ec" #t "schemeunit")) ("sandbox-lib" . #s(pkg-info (catalog "sandbox-lib") "665c51e7a8eabb1c225d28e0aae7c2ac9375d008" #t)) ("compatibility-lib" . #s(pkg-info (catalog "compatibility-lib") "85788ca2c06c1ffccd7d0ae3ba86bb78a63e8655" #t)) ("htdp-lib" . #s(pkg-info (catalog "htdp-lib") "c750154f0d1d2bc2b7f82d80c43de84e13ff2d5f" #t)) ("drracket" . #s(pkg-info (catalog "drracket") "81af517bcc4a619daed959c57cf12c03b4f79c13" #t)) ("scheme-lib" . #s(pkg-info (catalog "scheme-lib") "e4f90f2c83476d83004b8577112eb2e681965fd7" #t)) ("rackunit-plugin-lib" . #s(pkg-info (catalog "rackunit-plugin-lib") "5d03cf1a34a88381f508ce6622b9708de8fade02" #t)) ("gui-lib" . #s(pkg-info (catalog "gui-lib") "b9939da811038b5b162a33d60760c4328ffa5826" #t)) ("redex-benchmark" . #s(pkg-info (catalog "redex-benchmark") "9daa7a9408ff1009b5b9d1e68fe0782be4ff858e" #t)) ("typed-racket" . #s(pkg-info (catalog "typed-racket") "79809dde0d9f794740d5d3e7261abc4960e365fd" #t)) ("mzscheme" . #s(pkg-info (catalog "mzscheme") "4c7e9fde42d96c4dc3c0cc1d9b61d45ea66ed535" #t)) ("planet" . #s(pkg-info (catalog "planet") "6f0409b351966d9fdefba3b83607018097577b33" #t)) ("distributed-places" . #s(pkg-info (catalog "distributed-places") "94c6e477aa89aa6c2285ec39b276c493cd3c5bfb" #t)) ("unix-socket" . #s(pkg-info (catalog "unix-socket") "f69aef30dd15c47aa1c672e1da6c0d4d793a0ded" #t)) ("draw" . #s(pkg-info (catalog "draw") "e0b56fff7a4e363f49a77ca17a8210af0a519b04" #t)) ("mzscheme-lib" . #s(pkg-info (catalog "mzscheme-lib") "ac76d4de7f293dc14c6d5df2d6434efc8e389bc6" #t)) ("images-lib" . #s(pkg-info (catalog "images-lib") "3d52c3295923e3424addd07e071274d48e4f6c22" #t)) ("deinprogramm-signature" . #s(pkg-info (catalog "deinprogramm-signature") "6b47fceb682a352fc7333ac6d2583098f07931ca" #t)) ("pict-doc" . #s(pkg-info (catalog "pict-doc") "ad596a6e7209240ff98c3b6dd609f8a455247458" #t)) ("lazy" . #s((sc-pkg-info pkg-info 3) (catalog "lazy") "bc7cc763a425221b02e4cfcf0e01ba3d53c2931c" #t "lazy")) ("ds-store" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store") "8ecdc9c39992985ba97df7ee3b7e08dcf1a3520d" #t "ds-store")) ("srfi-doc" . #s(pkg-info (catalog "srfi-doc") "63524dadcc25c987e4ac0b9c7d44a5e5118ebbbb" #t)) ("readline-lib" . #s(pkg-info (catalog "readline-lib") "39fd859b9ccbe30d86b56b8a882b060de21815e4" #t)) ("unix-socket-lib" . #s(pkg-info (catalog "unix-socket-lib") "ed609fe9671b5ad0df000b5674d66438ae6d01cd" #t)) ("rackunit-gui" . #s(pkg-info (catalog "rackunit-gui") "78cb719b7761590c2c5bb9edc87f74467ddb6af4" #t)) ("compatibility-doc" . #s(pkg-info (catalog "compatibility-doc") "5b9b1937f5dafd2b1472839215b7b5254083d051" #t)) ("compatibility" . #s(pkg-info (catalog "compatibility") "bc6eb109b8faf9c60b2f03ba0555d00ac9d3eb8a" #t)) ("data" . #s(pkg-info (catalog "data") "c4c321637d30d377a418da21347739349fccf18f" #t)) ("pict-snip-doc" . #s(pkg-info (catalog "pict-snip-doc") "27ad5e7da3288abad39cb07fcf296bb8024f3e3a" #t)) ("net-cookies-lib" . #s(pkg-info (catalog "net-cookies-lib") "9e81dba724723059b29a90cf38176f398081cc4c" #t)) ("r6rs" . #s(pkg-info (catalog "r6rs") "4b5d261acd3bb8517ec7eb2c3de2df020bdf3ec3" #t)) ("wxme" . #s(pkg-info (catalog "wxme") "2aea6f214e09c408ce1f23da393a7a9552f772e1" #t)) ("htdp-doc" . #s(pkg-info (catalog "htdp-doc") "12afbaed0dbb0955042035df5e04a5ce51eceb62" #t)) ("option-contract-doc" . #s(pkg-info (catalog "option-contract-doc") "83a4cacf727a6e9caf6ba2a03ccda2ddb1bf6aaf" #t)) ("html-doc" . #s(pkg-info (catalog "html-doc") "ad52707f20e4b38987742c68706d9ea580c08ef0" #t)) ("future-visualizer-typed" . #s(pkg-info (catalog "future-visualizer-typed") "3a74404ecf64a7a1629862ac7f836b9638984b98" #t)) ("drracket-tool-lib" . #s(pkg-info (catalog "drracket-tool-lib") "74c7bb851a6b165eb01fcca8404354ce1c020c78" #t)) ("racket-index" . #s(pkg-info (catalog "racket-index") "39aa7a57f7d111f91f19474f22bec1f88d219c2e" #t)) ("racklog" . #s((sc-pkg-info pkg-info 3) (catalog "racklog") "f3d22b531459b3a70213b849cf887ab04ac14ddf" #t "racklog")) ("slideshow-doc" . #s(pkg-info (catalog "slideshow-doc") "9d7dd73c8f17914414f84f9f517113d937dceda9" #t)) ("plot" . #s(pkg-info (catalog "plot") "cb80fe0ced093002c1e6b4972522bdb2826e6c57" #t)) ("drracket-tool-doc" . #s(pkg-info (catalog "drracket-tool-doc") "e39a9ec4cf0e512a75168083c1b7585f50475c5f" #t)) ("errortrace-lib" . #s(pkg-info (catalog "errortrace-lib") "b658eaf3e8df1a070b96a517518dca331e594357" #t)) ("html-lib" . #s(pkg-info (catalog "html-lib") "e51427681ee39b4bd554f6e95b8a8736760cbbf9" #t)) ("plot-gui-lib" . #s(pkg-info (catalog "plot-gui-lib") "2a7f7275474269a313b34daa6acfd4b3d3ac7cb2" #t)) ("compiler-lib" . #s(pkg-info (catalog "compiler-lib") "3847fc1da82185a3d9ffb0ca881b744c2f88ccca" #t)) ("redex-pict-lib" . #s(pkg-info (catalog "redex-pict-lib") "6e8152270472a9e62c1a9121444d8c692779aaf4" #t)) ("db-lib" . #s(pkg-info (catalog "db-lib") "2d67b88b429c2fe9b2a7989b0958b0dbf76c4e06" #t)) ("testing-util-lib" . #s(pkg-info (catalog "testing-util-lib") "a98d58bb3e5dcfa25284749261b176ef3e8c7475" #t)) ("mzcom" . #s((sc-pkg-info pkg-info 3) (catalog "mzcom") "5ef8fed93da4bd459f3d7750edb7e0d034dc1837" #t "mzcom")) ("plot-doc" . #s(pkg-info (catalog "plot-doc") "d872655c0e9bdada4ac54a3be22b92f0686aaf60" #t)) ("string-constants" . #s(pkg-info (catalog "string-constants") "41ec556b205e8b4a4bae47b596453c2843e20126" #t)) ("2d-lib" . #s((sc-pkg-info pkg-info 3) (catalog "2d-lib") "84a7c6679c3d51814d22630bbb06fa8f2423cfb4" #t "2d")) ("2d-doc" . #s((sc-pkg-info pkg-info 3) (catalog "2d-doc") "f6542c714cb701c59ecd199cabbe0449d9348afd" #t "2d")) ("macro-debugger-text-lib" . #s(pkg-info (catalog "macro-debugger-text-lib") "31922a9c185a402fe8e3da2649bff982a02d1294" #t)) ("profile-doc" . #s(pkg-info (catalog "profile-doc") "331eabe29dc177e24edf0b34b1a1b32346615fea" #t)) ("make" . #s((sc-pkg-info pkg-info 3) (catalog "make") "670a4c73bb20112c3ef83425fd1c088b160bd995" #t "make")) ("typed-racket-lib" . #s(pkg-info (catalog "typed-racket-lib") "b88d0935d230fb2ffe448c15cc9ff684d029f4b3" #t)) ("srfi" . #s(pkg-info (catalog "srfi") "6529df57c88ea3440f8b9ec9f2dbe2afae552d7a" #t)) ("sasl-lib" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-lib") "7bbf6dead64d40ceb158e1d5c990dc13217a9966" #t "sasl")) ("slideshow-exe" . #s(pkg-info (catalog "slideshow-exe") "c2c49d89f6533a6a41b25e1f83440ed544242cfc" #t)) ("htdp" . #s(pkg-info (catalog "htdp") "2c19559a051d906b2e6b488495c2129dffb46a47" #t)) ("images" . #s(pkg-info (catalog "images") "30e509539c77e397c1c7961d3856fd87a87d3a9b" #t)) ("optimization-coach" . #s(pkg-info (catalog "optimization-coach") "dbdc4ef1ff6cb527fe5daf77acfb51c7ccd5e25f" #t)) ("net-lib" . #s(pkg-info (catalog "net-lib") "ae2a5d897757cf6e38073381b4157f9893741657" #t)) ("r5rs-doc" . #s(pkg-info (catalog "r5rs-doc") "7e5ce1e96ff9a7f553d2532a928f0d9546c96a73" #t)) ("icons" . #s((sc-pkg-info pkg-info 3) (catalog "icons") "163eb43b52c6a48af449912869dd571781cd4628" #t "icons")) ("mysterx" . #s((sc-pkg-info pkg-info 3) (catalog "mysterx") "51473eb0b8b73a197d1f5d157d6463daea3a2e1e" #t "mysterx")) ("redex-gui-lib" . #s(pkg-info (catalog "redex-gui-lib") "5c2714bdb7d7cc354b8731d9e4b6a2bd87d6b8d3" #t)) ("redex-doc" . #s(pkg-info (catalog "redex-doc") "c4dfeee6c563c12def169540d0dd2475d833f0aa" #t)) ("redex" . #s(pkg-info (catalog "redex") "23be1bcc4196980d573977ae04d26456b2678c9e" #t)) ("math-doc" . #s(pkg-info (catalog "math-doc") "94280d9b379ff142c251d11f1dc3474448b03261" #t)) ("option-contract" . #s(pkg-info (catalog "option-contract") "4ea2a879344aa7c53ced48e2d718ee40556b189b" #t)) ("racket-lib" . #s(pkg-info (catalog "racket-lib") "570306a2bfa6057fe18693a08af23debf5fb1a3d" #f)) ("ds-store-lib" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-lib") "fa4534b45fb9bee211da626a0a49427d2d78570f" #t "ds-store")) ("sasl-doc" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-doc") "3fae6f15bfc1855a58cf249f4060b4e124f73c52" #t "sasl")) ("syntax-color-doc" . #s(pkg-info (catalog "syntax-color-doc") "a7a6922f347622dac7f1f76e5f3e77d6e7c29bdc" #t)) ("web-server" . #s(pkg-info (catalog "web-server") "38ed57fd4e5a5ba815ee68e4746ab5901a7c346a" #t)) ("compiler" . #s(pkg-info (catalog "compiler") "e18e230f86637db277d6a641b9a7a174165253b7" #t)) ("racket-doc" . #s(pkg-info (catalog "racket-doc") "f29847ec6c8f726cd0c22d5b4adeea1da2862049" #t)) ("draw-lib" . #s(pkg-info (catalog "draw-lib") "5a68e5f34628108e05e8644d2287dada792c5f20" #t)) ("drracket-plugin-lib" . #s(pkg-info (catalog "drracket-plugin-lib") "c458b98ceea4482b6d4bf3dafabc2e46de51eb01" #t)) ("sgl" . #s((sc-pkg-info pkg-info 3) (catalog "sgl") "32966b2a4754a481ad596302ced7b1e50e4431fa" #t "sgl")) ("data-lib" . #s(pkg-info (catalog "data-lib") "9ac328c1410894820b142bac436266681b2b893b" #t)) ("images-gui-lib" . #s(pkg-info (catalog "images-gui-lib") "ebe833747a5eda2efb8345c6f7b170abeffd6198" #t)) ("racket-cheat" . #s((sc-pkg-info pkg-info 3) (catalog "racket-cheat") "4b534407f1173bfded042577a70665b295b50f27" #t "racket-cheat")) ("images-doc" . #s(pkg-info (catalog "images-doc") "421602019728558dcf1882c702f3786bcf71f723" #t)) ("typed-racket-doc" . #s(pkg-info (catalog "typed-racket-doc") "6fb9ffd5b72030e098ae6f3033f9a1d89e78dfed" #t)) ("at-exp-lib" . #s(pkg-info (catalog "at-exp-lib") "0cdc34a5b24d909f79105bbfcaf5fb412ba8f343" #t)) ("zo-lib" . #s(pkg-info (catalog "zo-lib") "bd9efab25737ac234423c9e77877dea266e5cc5b" #t)) ("readline" . #s(pkg-info (catalog "readline") "6ea5fc05529a18bcf64e6a58c3596404a94225c8" #t)) ("xrepl-doc" . #s(pkg-info (catalog "xrepl-doc") "f2337d2e70f83a1afaac94c3db3b2fe633bc59fb" #t)) ("snip" . #s(pkg-info (catalog "snip") "2c72a81c24d6e74af4d3f7c730aee21f4426c5a2" #t)) ("source-syntax" . #s((sc-pkg-info pkg-info 3) (catalog "source-syntax") "7957f84ae3ad4159e4f52528ddbadbe8709a2868" #t "syntax")) ("shell-completion" . #s((sc-pkg-info pkg-info 3) (catalog "shell-completion") "af01314e9bc7b1aa12b0d2a1196c5ec4526ab6d6" #t "shell-completion")) ("pict-snip" . #s(pkg-info (catalog "pict-snip") "64b086f36b25e341d2ed6b71f574ee19b90e0da8" #t)) ("r5rs-lib" . #s(pkg-info (catalog "r5rs-lib") "64663b35cd3bdade0b3ec045af813fccd0fa3592" #t)) ("slideshow" . #s(pkg-info (catalog "slideshow") "602410663ed102040eb45fce3abeb31f26fa62e0" #t)) ("mzscheme-doc" . #s(pkg-info (catalog "mzscheme-doc") "fd9f445b9dfa4682ebad6dc8b707639b6ffd6b4b" #t)) ("swindle" . #s((sc-pkg-info pkg-info 3) (catalog "swindle") "05c49cbb8896ee0066c3882a38a3e6fdc8bc085c" #t "swindle")) ("parser-tools" . #s(pkg-info (catalog "parser-tools") "9681a696f20a9fa1a889be9fc1a9db5b3f6f734a" #t)) ("typed-racket-compatibility" . #s(pkg-info (catalog "typed-racket-compatibility") "1b021cd3e5af207d987556218280300bf0ae9c16" #t)) ("contract-profile" . #s((sc-pkg-info pkg-info 3) (catalog "contract-profile") "15c91346fad423fc3e5a6d44edf1e05bf58b9769" #t "contract-profile")) ("srfi-doc-nonfree" . #s(pkg-info (catalog "srfi-doc-nonfree") "373b06ec086f3b9428624493858eaf07463c7eaa" #t)) ("serialize-cstruct-lib" . #s(pkg-info (catalog "serialize-cstruct-lib") "badf97f330e00067a297bba7c8eb72bc91799e02" #t)) ("draw-doc" . #s(pkg-info (catalog "draw-doc") "757da969a9ffab85b65b0af40d8fc2eccdcae062" #t)) ("parser-tools-lib" . #s(pkg-info (catalog "parser-tools-lib") "b925aa24c87aa1c2e5419dbaf716f927765ebcd3" #t)) ("data-enumerate-lib" . #s(pkg-info (catalog "data-enumerate-lib") "32ce2ffdc60174c03aaa3ee2aa91ada1678296eb" #t)) ("math" . #s(pkg-info (catalog "math") "5f14a163570b09d4fd1f6b344b418533f01461f6" #t)) ("rackunit-typed" . #s((sc-pkg-info pkg-info 3) (catalog "rackunit-typed") "63e6012ca82a9aecc92f6b5ca36eac3a30345919" #t "typed")) ("srfi-lib-nonfree" . #s(pkg-info (catalog "srfi-lib-nonfree") "e0e49eef62d77402b65a5dc37ed60c32dc13c150" #t)) ("dynext-lib" . #s(pkg-info (catalog "dynext-lib") "c95fa3cb971e6f581c7c22e474a377584e32a243" #t)) ("trace" . #s((sc-pkg-info pkg-info 3) (catalog "trace") "ef6ab2130f28fb8f1f0940e7c80405a23064e072" #t "trace")) ("slatex" . #s((sc-pkg-info pkg-info 3) (catalog "slatex") "f9144652b003db69721f219fea5eecf5a1c29f75" #t "slatex")) ("frtime" . #s((sc-pkg-info pkg-info 3) (catalog "frtime") "8a88eb5663a56695388855a15bfd3c5bd66441ec" #t "frtime")) ("r5rs" . #s(pkg-info (catalog "r5rs") "e629816bb3d0a74fcbb0d4dd8c27b7ffec2a82cb" #t)) ("main-distribution" . #s(pkg-info (catalog "main-distribution") "34484fc4a83e34411f170f40e7a4b9b7d6659360" #f)) ("planet-lib" . #s(pkg-info (catalog "planet-lib") "735aa6caba27a43774d279149b4e53c192ecd51c" #t)) ("rackunit-doc" . #s(pkg-info (catalog "rackunit-doc") "609e361d537fc2a18ec61c9aac216dfae1ea669d" #t)) ("db" . #s(pkg-info (catalog "db") "5020470b19b092c9527f2a090e67052d02794dba" #t)) ("games" . #s((sc-pkg-info pkg-info 3) (catalog "games") "ab5d609176a250b05b1b11d76620e1944c346cb3" #t "games")) ("2d" . #s(pkg-info (catalog "2d") "c8fa649d1819a7d303e08ac7f4d89d481009782c" #t)) ("profile-lib" . #s((sc-pkg-info pkg-info 3) (catalog "profile-lib") "64e6ce703cdbced9082837d00c6db2a7c224c55d" #t "profile")) ("algol60" . #s((sc-pkg-info pkg-info 3) (catalog "algol60") "42cd3b3bf596099c482cd1b0a36f0589f43a64a2" #t "algol60")) ("readline-doc" . #s(pkg-info (catalog "readline-doc") "33fe47f24d4afd2b0bb09137ef994b1045b24421" #t)) ("xrepl" . #s(pkg-info (catalog "xrepl") "b674ccfac2221d492672150c7ee1330e012f2e6a" #t)) ("datalog" . #s((sc-pkg-info pkg-info 3) (catalog "datalog") "22aeb3133d33d0e597bbbd6e472e7b471e0ba31d" #t "datalog")) ("sasl" . #s((sc-pkg-info pkg-info 3) (catalog "sasl") "443482780be6666a88dd0c2ccbc622aaba511889" #t "sasl"))) diff -Nru racket-6.12+ppa1/share/pkgs/plai/info.rkt racket-7.0+ppa1/share/pkgs/plai/info.rkt --- racket-6.12+ppa1/share/pkgs/plai/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define deps (quote ("plai-doc" "plai-lib" "base"))) (define pkg-desc "Teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))) (define implies (quote ("plai-lib" "plai-doc"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define deps (quote ("plai-doc" "plai-lib" "base"))) (define pkg-desc "Teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))) (define implies (quote ("plai-lib" "plai-doc"))))) diff -Nru racket-6.12+ppa1/share/pkgs/plai-doc/info.rkt racket-7.0+ppa1/share/pkgs/plai-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/plai-doc/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "plai") (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define primary-file "main.rkt") (define scribblings (quote (("scribblings/plai.scrbl" (multi-page) (teaching -20))))) (define deps (quote ("scheme-lib" "srfi-lite-lib" "base" "gui-lib" "sandbox-lib" "web-server-lib" "plai-lib"))) (define build-deps (quote ("at-exp-lib" "eli-tester" "pconvert-lib" "rackunit-lib" "racket-doc" "web-server-doc" "scribble-lib" "drracket-tool-lib"))) (define pkg-desc "Documentation for teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "plai") (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define primary-file "main.rkt") (define scribblings (quote (("scribblings/plai.scrbl" (multi-page) (teaching -20))))) (define deps (quote ("scheme-lib" "srfi-lite-lib" "base" "gui-lib" "sandbox-lib" "web-server-lib" "plai-lib"))) (define build-deps (quote ("at-exp-lib" "eli-tester" "pconvert-lib" "rackunit-lib" "racket-doc" "web-server-doc" "scribble-lib" "drracket-tool-lib"))) (define pkg-desc "Documentation for teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/plai-lib/info.rkt racket-7.0+ppa1/share/pkgs/plai-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/plai-lib/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "plai") (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define primary-file "main.rkt") (define release-note-files (list (list "PLAI" "HISTORY.txt"))) (define deps (quote ("scheme-lib" "srfi-lite-lib" "base" "gui-lib" "sandbox-lib" "web-server-lib"))) (define build-deps (quote ("at-exp-lib" "eli-tester" "pconvert-lib" "rackunit-lib" "drracket-tool-lib"))) (define pkg-desc "Implementation (no documentation) for teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "plai") (define blurb (quote ("Language levels for the Programming Languages: Application and Interpretation textbook"))) (define homepage "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/") (define primary-file "main.rkt") (define release-note-files (list (list "PLAI" "HISTORY.txt"))) (define deps (quote ("scheme-lib" "srfi-lite-lib" "base" "gui-lib" "sandbox-lib" "web-server-lib"))) (define build-deps (quote ("at-exp-lib" "eli-tester" "pconvert-lib" "rackunit-lib" "drracket-tool-lib"))) (define pkg-desc "Implementation (no documentation) for teaching languages for _Programming Languages: Application and Interpretation_") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/plai-lib/tests/datatype-exports.rkt racket-7.0+ppa1/share/pkgs/plai-lib/tests/datatype-exports.rkt --- racket-6.12+ppa1/share/pkgs/plai-lib/tests/datatype-exports.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai-lib/tests/datatype-exports.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,7 +9,7 @@ (syntax-case stx () [(_ module-name) (let ([exports (syntax-local-module-exports (syntax->datum #'module-name))]) - #`(quote #,(cdaddr exports)))])) + #`(quote #,(cdr (assoc 0 exports))))])) (test (sort (exports-of 'ex) string-cistring) => diff -Nru racket-6.12+ppa1/share/pkgs/plai-lib/tests/gc/run-test.rkt racket-7.0+ppa1/share/pkgs/plai-lib/tests/gc/run-test.rkt --- racket-6.12+ppa1/share/pkgs/plai-lib/tests/gc/run-test.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai-lib/tests/gc/run-test.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -47,7 +47,7 @@ (test-mutator (build-path here "other-mutators" "top.rkt")) =error> - #rx"unbound identifier in module\n in: frozzle" + #rx"unbound identifier.*in: frozzle" (capture-output (test-mutator (build-path here "other-mutators" "printing.rkt"))) => diff -Nru racket-6.12+ppa1/share/pkgs/plai-lib/tests/gc2/run-test.rkt racket-7.0+ppa1/share/pkgs/plai-lib/tests/gc2/run-test.rkt --- racket-6.12+ppa1/share/pkgs/plai-lib/tests/gc2/run-test.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plai-lib/tests/gc2/run-test.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -47,7 +47,7 @@ (test-mutator (build-path here "other-mutators" "top.rkt")) =error> - #rx"unbound identifier in module\n in: frozzle" + #rx"unbound identifier.*in: frozzle" (capture-output (test-mutator (build-path here "other-mutators" "printing.rkt"))) => diff -Nru racket-6.12+ppa1/share/pkgs/planet/info.rkt racket-7.0+ppa1/share/pkgs/planet/info.rkt --- racket-6.12+ppa1/share/pkgs/planet/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/planet/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("planet-lib" "planet-doc"))) (define implies (quote ("planet-lib" "planet-doc"))) (define pkg-desc "Legacy support for automatic package distribution") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("planet-lib" "planet-doc"))) (define implies (quote ("planet-lib" "planet-doc"))) (define pkg-desc "Legacy support for automatic package distribution") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/planet-doc/info.rkt racket-7.0+ppa1/share/pkgs/planet-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/planet-doc/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/planet-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("planet-lib" "scribble-lib" "base"))) (define pkg-desc "documentation part of \"planet\"") (define pkg-authors (quote (mflatt robby))) (define build-deps (quote ("racket-doc" "scribble-doc"))) (define update-implies (quote ("planet-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("planet-lib" "scribble-lib" "base"))) (define pkg-desc "documentation part of \"planet\"") (define pkg-authors (quote (mflatt robby))) (define build-deps (quote ("racket-doc" "scribble-doc"))) (define update-implies (quote ("planet-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/planet-lib/info.rkt racket-7.0+ppa1/share/pkgs/planet-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/planet-lib/info.rkt 2018-01-26 21:08:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/planet-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.2.900.6")))) (define pkg-desc "implementation (no documentation) part of \"planet\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.2.900.6")))) (define pkg-desc "implementation (no documentation) part of \"planet\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot/info.rkt racket-7.0+ppa1/share/pkgs/plot/info.rkt --- racket-6.12+ppa1/share/pkgs/plot/info.rkt 2018-01-26 21:08:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("plot-lib" "plot-gui-lib" "plot-doc"))) (define implies (quote ("plot-lib" "plot-gui-lib" "plot-doc"))) (define pkg-desc "Functions (and docs and tests) for plotting") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("plot-lib" "plot-gui-lib" "plot-doc"))) (define implies (quote ("plot-lib" "plot-gui-lib" "plot-doc"))) (define pkg-desc "Functions (and docs and tests) for plotting") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-compat/info.rkt racket-7.0+ppa1/share/pkgs/plot-compat/info.rkt --- racket-6.12+ppa1/share/pkgs/plot-compat/info.rkt 2018-01-26 21:08:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-compat/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "plot-gui-lib" "draw-lib" "plot-lib" "snip-lib"))) (define build-deps (quote ())) (define pkg-desc "Compatibility library for Plot 5.1.3 and earlier") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "plot-gui-lib" "draw-lib" "plot-lib" "snip-lib"))) (define build-deps (quote ())) (define pkg-desc "Compatibility library for Plot 5.1.3 and earlier") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/info.rkt racket-7.0+ppa1/share/pkgs/plot-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/plot-doc/info.rkt 2018-01-26 21:08:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "plot-lib" "plot-gui-lib"))) (define build-deps (quote ("db-doc" "db-lib" "draw-doc" "draw-lib" "gui-doc" "gui-lib" "pict-doc" "pict-lib" "plot-compat" "racket-doc" "scribble-lib" "slideshow-doc" "slideshow-lib" "srfi-doc"))) (define update-implies (quote ("plot-lib"))) (define pkg-desc "Documentation for plot") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "plot-lib" "plot-gui-lib"))) (define build-deps (quote ("db-doc" "db-lib" "draw-doc" "draw-lib" "gui-doc" "gui-lib" "pict-doc" "pict-lib" "plot-compat" "racket-doc" "scribble-lib" "slideshow-doc" "slideshow-lib" "srfi-doc"))) (define update-implies (quote ("plot-lib"))) (define pkg-desc "Documentation for plot") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt --- racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ db plot plot/utils + plot/snip (only-in racket/sequence sequence/c))) (provide (all-defined-out) @@ -16,6 +17,7 @@ pict db plot + plot/snip plot/utils) sequence/c)) diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/contracts.scrbl racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/contracts.scrbl --- racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/contracts.scrbl 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/contracts.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -32,9 +32,23 @@ @defthing[anchor/c contract? #:value (one-of/c 'top-left 'top 'top-right 'left 'center 'right - 'bottom-left 'bottom 'bottom-right)]{ + 'bottom-left 'bottom 'bottom-right + 'auto)]{ The contract for @(racket anchor) arguments and parameters, such as @(racket plot-legend-anchor). -} + +The @racket['auto] anchor will place labels so they are visible on the plot +area. This anchor type is useful for @(racket point-label) and similar +renderers where the labeled point might be at the edge of the plot area and +the user does not wish to calculate the exact anchor for the label. + +The @racket['auto] anchor will choose one of the @racket['bottom-left], +@racket['bottom-right], @racket['top-left] or @racket['top-right] placements, +in that order, and will use the first one that would result in the label being +completely visible. + +The @racket['auto] anchor is only valid for placement of text labels, for all +other use cases, the @racket['auto] anchor is always the same as +@racket['bottom-left].} @defthing[color/c contract? #:value (or/c (list/c real? real? real?) string? symbol? @@ -102,7 +116,7 @@ 'circle7 'circle8 'bullet 'fullcircle1 'fullcircle2 'fullcircle3 'fullcircle4 'fullcircle5 'fullcircle6 - 'fullcircle7 'fullcircle8)]{ + 'fullcircle7 'fullcircle8 'none)]{ A list containing the symbols that are valid @(racket points) symbols. } diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl --- racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -136,6 +136,16 @@ Use these along with @racket[x-axis] and @racket[y-axis] renderers if you want axes that intersect the origin or some other point. } +@deftogether[((defparam plot-x-tick-labels? draw? boolean? #:value #t) + (defparam plot-y-tick-labels? draw? boolean? #:value #t) + (defparam plot-z-tick-labels? draw? boolean? #:value #t) + (defparam plot-x-far-tick-labels? draw? boolean? #:value #f) + (defparam plot-y-far-tick-labels? draw? boolean? #:value #f) + (defparam plot-z-far-tick-labels? draw? boolean? #:value #f))]{ +When any of these is @racket[#f], the corresponding labels for the ticks on the axis are not drawn. +These parameters work together with the parameters like @racket[plot-x-axis?] that control the drawing of the axes; i.e. tick labels won't be drawn unless the axis itself is drawn. +} + @defparam[plot-animating? animating? boolean? #:value #f]{ When @(racket #t), certain renderers draw simplified plots to speed up drawing. @(plot-name) sets it to @(racket #t), for example, when a user is clicking and dragging a 3D plot to rotate it. @@ -250,6 +260,22 @@ The default width, pen color/width/style, and opacity used by @racket[error-bars]. } +@section{Candlesticks} + +@deftogether[((defparam candlestick-width width (>=/c 0) #:value 1) + (defparam candlestick-up-color color plot-color/c #:value 2) + (defparam candlestick-down-color color plot-color/c #:value 1) + (defparam candlestick-line-width pen-width (>=/c 0) #:value 1) + (defparam candlestick-line-style pen-style plot-pen-style/c #:value 'solid) + (defparam candlestick-alpha alpha (real-in 0 1) #:value 2/3))]{ +The default width, pen color/width/style, and opacity used by @racket[candlesticks]. Both the up (a candle whose +open value is lower than its close value) color and the down (a candle whose open value is higher than its close +value) color can be specified independently. The width parameter will be important to specify if your x-axis is +in units like days, weeks, or months. Because dates are actually represented as seconds from an epoch, your +width should take that into consideration. For example, a width of 86400 may be useful for x-axis values in days +as there are 86400 seconds in a day. This candle will be exactly one day in width. +} + @section{Contours and Contour Intervals} @deftogether[( diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/plotting.scrbl racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/plotting.scrbl --- racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/plotting.scrbl 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/plotting.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -94,7 +94,7 @@ } @defproc[(plot-snip [ ] ...) - (is-a?/c snip%)] + (is-a?/c 2d-plot-snip%)] @defproc[(plot3d-snip [ ] ...) (is-a?/c snip%)] @defproc[(plot-frame [ ] ...) @@ -107,6 +107,10 @@ Use @(racket plot-frame) and @(racket plot3d-frame) to create a @(racket frame%) regardless of the value of @(racket plot-new-window?). The frame is initially hidden. Use @(racket plot-snip) and @(racket plot3d-snip) to create an interactive @(racket snip%) regardless of the value of @(racket plot-new-window?). + +The @racket[snip%] objects returned by @racket[plot-snip] can be used to +construct interactive plots. See @secref["2d-plot-snip-interactive-overlays"] +for more details. } @section{Non-GUI Plotting Procedures} diff -Nru racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/renderer2d.scrbl racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/renderer2d.scrbl --- racket-6.12+ppa1/share/pkgs/plot-doc/plot/scribblings/renderer2d.scrbl 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-doc/plot/scribblings/renderer2d.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -160,6 +160,26 @@ (vector 6 36 10)))))] } +@defproc[(candlesticks + [candles (sequence/c (sequence/c #:min-count 5 real?))] + [#:x-min x-min (or/c rational? #f) #f] [#:x-max x-max (or/c rational? #f) #f] + [#:y-min y-min (or/c rational? #f) #f] [#:y-max y-max (or/c rational? #f) #f] + [#:up-color up-color plot-color/c (candlestick-up-color)] + [#:down-color down-color plot-color/c (candlestick-down-color)] + [#:line-width line-width (>=/c 0) (candlestick-line-width)] + [#:line-style line-style plot-pen-style/c (candlestick-line-style)] + [#:width width (>=/c 0) (candlestick-width)] + [#:alpha alpha (real-in 0 1) (candlestick-alpha)] + ) renderer2d?]{ +Returns a renderer that draws candlesticks. This is most common when plotting historical prices for financial +instruments. The first element in each vector of @(racket candles) comprises the x-axis coordinate; the second, third, +fourth, and fifth elements in each vector comprise the open, high, low, and close, respectively, of the y-axis coordinates. +@interaction[#:eval plot-eval + (plot (list (candlesticks (list (vector 2 4 12 4 8) + (vector 4 16 20 8 12) + (vector 6 24 36 10 24)))))] +} + @section{2D Line Renderers} @defproc[(function [f (real? . -> . real?)] @@ -528,7 +548,13 @@ [#:label label (or/c string? #f) #f] ) renderer2d?]{ Returns a renderer that draws rectangles. -The rectangles are given as a sequence of sequences of intervals---each inner sequence defines the bounds of a rectangle. For example, + +The rectangles are given as a sequence of sequences of intervals---each inner +sequence defines the bounds of a rectangle. Any of the bounds can be +@racket[-inf.0] or @racket[+inf.0], in which case the rectangle extents to the +edge of the plot area in the respective direction. + +For example, @interaction[#:eval plot-eval (plot (rectangles (list (vector (ivl -1 0) (ivl -1 1)) (vector (ivl 0 2) (ivl 1 2)))))] } @@ -718,6 +744,27 @@ The remaining labeled-point functions are defined in terms of this one. } +@defproc[(point-pict + [v (sequence/c real?)] + [pict pict?] + [#:anchor anchor anchor/c (label-anchor)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] + [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] + [#:alpha alpha (real-in 0 1) (label-alpha)] + ) renderer2d?]{ +Returns a renderer that draws a point with a pict as the label. + +@interaction[#:eval plot-eval + (require pict) + (plot (list (function sqr 0 2) + (point-pict (vector 1 1) (standard-fish 40 15))))] + +The remaining labeled-pict functions are defined in terms of this one. +} + @defproc[(function-label [f (real? . -> . real?)] [x real?] [label (or/c string? #f) #f] [#:color color plot-color/c (plot-foreground)] @@ -741,6 +788,19 @@ #:anchor 'right)))] } +@defproc[(function-pict + [f (real? . -> . real?)] [x real?] [pict pict?] + [#:anchor anchor anchor/c (label-anchor)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] + [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] + [#:alpha alpha (real-in 0 1) (label-alpha)] + ) renderer2d?]{ +Returns a renderer that draws a point with a pict as the label on a function's graph. +} + @defproc[(inverse-label [f (real? . -> . real?)] [y real?] [label (or/c string? #f) #f] [#:color color plot-color/c (plot-foreground)] @@ -759,6 +819,20 @@ Returns a renderer that draws a labeled point on a function's inverted graph. } +@defproc[(inverse-pict + [f (real? . -> . real?)] [y real?] [pict pict?] + [#:anchor anchor anchor/c (label-anchor)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] + [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] + [#:alpha alpha (real-in 0 1) (label-alpha)] + ) renderer2d?]{ +Returns a renderer that draws a point with a pict as the label on a function's inverted graph. +} + + @defproc[(parametric-label [f (real? . -> . (sequence/c real?))] [t real?] [label (or/c string? #f) #f] [#:color color plot-color/c (plot-foreground)] @@ -777,6 +851,19 @@ Returns a renderer that draws a labeled point on a parametric function's graph. } +@defproc[(parametric-pict + [f (real? . -> . (sequence/c real?))] [t real?] [pict pict?] + [#:anchor anchor anchor/c (label-anchor)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] + [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] + [#:alpha alpha (real-in 0 1) (label-alpha)] + ) renderer2d?]{ +Returns a renderer that draws a point with a pict as the label on a parametric function's graph. +} + @defproc[(polar-label [f (real? . -> . real?)] [θ real?] [label (or/c string? #f) #f] @@ -795,3 +882,113 @@ ) renderer2d?]{ Returns a renderer that draws a labeled point on a polar function's graph. } + + +@defproc[(polar-pict + [f (real? . -> . real?)] [θ real?] [pict pict?] + [#:anchor anchor anchor/c (label-anchor)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] + [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] + [#:alpha alpha (real-in 0 1) (label-alpha)] + ) renderer2d?]{ +Returns a renderer that draws a point with a pict as the label on a polar function's graph. +} + +@section[#:tag "2d-plot-snip-interactive-overlays"]{Interactive Overlays for 2D plots} + +@defmodule[plot/snip] + +A plot @racket[snip%] object returned by @racket[plot-snip] can be set up to +provide interactive overlays. This feature can be used, for example, to show +the current value of the plot function at the mouse cursor. + +If the code below is evaluated in DrRacket, the resulting plot will show a +vertical line tracking the mouse and the current plot position is shown on a +label. This is achieved by adding a mouse callback to the plot snip returned +by @racket[plot-snip]. When the mouse callback is invoked, it will add a +@racket[vrule] at the current X position and a @racket[point-label] at the +current value of the plotted function. + +@racketblock[ +(require plot) +(define snip (plot-snip (function sin) #:x-min -5 #:x-max 5)) +(define (mouse-callback snip event x y) + (if (and x y) + (send snip set-overlay-renderers + (list (vrule x) + (point-label (vector x (sin x))))) + (send snip set-overlay-renderers #f))) +(send snip set-mouse-event-callback mouse-callback) +snip] + +Here are a few hints for adding common interactive elements to racket plots: + +@itemlist[ + +@item{The @racket[hrule] and @racket[vrule] renderers can be used to draw +horizontal and vertical lines that track the mouse position} + +@item{The @racket[rectangles] renderer can be used to highlight a region on +the plot. For example, to highlight a vertical region between @racket[_xmin] +and @racket[_xmax], you can use: + +@racketblock[ +(rectangles (list (vector (ivl _xmin _xmax) (ivl -inf.0 +inf.0))) + #:alpha 0.2)] +} + +@item{A @racket[point-label] renderer can be used to add a point with a +string label to the plot. To add only the label, use @racket['none] as the +value for the @racket[#:point-sym] argument.} + +@item{A @racket[point-pict] renderer can be used to add a point with an +attached @racketmodname[pict] instead of a string label. This can be used to +draw fancy labels (for example with rounded corners), or any other type of +graphics element.} + +@item{A @racket[points] renderer can be used to mark specific locations on +the plot, without specifying a label for them} +] + +@defclass[2d-plot-snip% snip% ()]{ + +An instance of this class is returned by @racket[plot-snip]. + +@defmethod[(set-mouse-event-callback [callback (or/c plot-mouse-event-callback/c #f)]) any/c]{ + +Set a callback function to be invoked with mouse events from the snip. The +callback is invoked with the actual snip object, the @racket[mouse-event%] and +the X, Y position of the mouse in plot coordinates (i.e., the coordinate system +used by the renderers in the plot). The X and Y values are +@racket[#f] when the mouse is outside the plot area (for example, when the +mouse is over the axis area). + +When a callback is installed, the default zoom functionality of the plot snips +is disabled. This can be restored by calling +@racket[set-mouse-event-callback] with a @racket[#f] argument. + +} + +@defmethod[(set-overlay-renderers [renderers (or/c (treeof renderer2d?) #f)]) any/c]{ + +Set a collection of renderers to be drawn +on top of the existing plot. This can be any combination of 2D renderers, but +it will not be able to modify the axes or the dimensions of the plot area. +Only one set of overlay renderers can be installed; calling this method a +second time will replace the previous overlays. Specifying @racket[#f] as the +renderers will cause overlays to be disabled. + +} +} + +@defthing[plot-mouse-event-callback/c contract? #:value (-> (is-a?/c snip%) + (is-a?/c mouse-event%) + (or/c real? #f) + (or/c real? #f) + any/c)]{ +A contract for callback functions passed to @racket[set-mouse-event-callback]. +} + diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/info.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/info.rkt 2018-01-26 21:08:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "plot-lib" "math-lib" ("gui-lib" #:version "1.18") "snip-lib" "typed-racket-lib" "typed-racket-more"))) (define build-deps (quote ())) (define pkg-desc "Plot GUI interface") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "plot-lib" "math-lib" ("gui-lib" #:version "1.18") "snip-lib" "typed-racket-lib" "typed-racket-more"))) (define build-deps (quote ())) (define pkg-desc "Plot GUI interface") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/gui.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/gui.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/gui.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/gui.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,9 +16,8 @@ (super-new))) -(define (make-snip-frame snip width height label) - (define (make-snip w h) snip) - +(define (make-snip-frame make-snip width height label) + (define frame (new snip-frame% [label label] [width (+ 20 width)] [height (+ 20 height)])) diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-types.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-types.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-types.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-types.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,10 +9,9 @@ (-> (Instance Bitmap%) Plot-Parameters (-> Boolean Rect Positive-Integer Positive-Integer - (Values (Instance Bitmap%) Rect (-> Rect Rect))) + (Values (Instance Bitmap%) (U #f (Instance 2D-Plot-Area%)))) Rect - Rect - (-> Rect Rect) + (U #f (Instance 2D-Plot-Area%)) Positive-Integer Positive-Integer (Instance Snip%))) @@ -28,7 +27,7 @@ (Instance Snip%))) (define-type Make-Snip-Frame - (-> (Instance Snip%) + (-> (-> Positive-Integer Positive-Integer (Instance Snip%)) Positive-Real Positive-Real String diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-untyped.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-untyped.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-untyped.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/lazy-snip-untyped.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,10 +13,10 @@ (define (-make-2d-plot-snip init-bm saved-plot-parameters - make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height) + make-bm plot-bounds-rect area width height) (make-2d-plot-snip init-bm saved-plot-parameters - make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height)) + make-bm plot-bounds-rect area width height)) (define (-make-3d-plot-snip init-bm saved-plot-parameters diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -57,7 +57,7 @@ (define bounds-rect (get-bounds-rect renderer-list x-min x-max y-min y-max)) (: make-bm (-> Boolean Rect Positive-Integer Positive-Integer - (Values (Instance Bitmap%) Rect (-> Rect Rect)))) + (Values (Instance Bitmap%) (U #f (Instance 2D-Plot-Area%))))) (define (make-bm anim? bounds-rect width height) (: area (U #f (Instance 2D-Plot-Area%))) (define area #f) @@ -78,27 +78,11 @@ (plot-area new-area renderer-list)) width height))) - - (: area-bounds->plot-bounds (-> Rect Rect)) - (define (area-bounds->plot-bounds rect) - (let ([area (assert area values)]) - (match-define (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max)) rect) - (let ([area-x-min (assert area-x-min values)] - [area-x-max (assert area-x-max values)] - [area-y-min (assert area-y-min values)] - [area-y-max (assert area-y-max values)]) - (match-define (vector x-min y-min) (send area dc->plot (vector area-x-min area-y-min))) - (match-define (vector x-max y-max) (send area dc->plot (vector area-x-max area-y-max))) - (vector (ivl x-min x-max) (ivl y-min y-max))))) - - (values bm (send (assert area values) get-area-bounds-rect) area-bounds->plot-bounds)) + (values bm area)) - (define-values (bm area-bounds-rect area-bounds->plot-bounds) - (make-bm #f bounds-rect width height)) + (define-values (bm area) (make-bm #f bounds-rect width height)) - (make-2d-plot-snip - bm saved-plot-parameters - make-bm bounds-rect area-bounds-rect area-bounds->plot-bounds width height))])) + (make-2d-plot-snip bm saved-plot-parameters make-bm bounds-rect area width height))])) ;; =================================================================================================== ;; Plot to a frame @@ -130,12 +114,13 @@ [(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)] [(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)] [else - (define snip + (: make-snip (-> Positive-Integer Positive-Integer (Instance Snip%))) + (define (make-snip width height) (plot-snip renderer-tree #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:width width #:height height #:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)) - (make-snip-frame snip width height (if title (format "Plot: ~a" title) "Plot"))])) + (make-snip-frame make-snip width height (if title (format "Plot: ~a" title) "Plot"))])) ;; =================================================================================================== ;; Plot to a frame or a snip, depending on (plot-new-window?) diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -151,14 +151,15 @@ [(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)] [(and z-min (not (rational? z-min))) (fail/kw "#f or rational" '#:z-min z-min)] [(and z-max (not (rational? z-max))) (fail/kw "#f or rational" '#:z-max z-max)]) - - (define snip + + (: make-snip (-> Positive-Integer Positive-Integer (Instance Snip%))) + (define (make-snip width height) (plot3d-snip renderer-tree #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max #:width width #:height height #:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label #:z-label z-label #:legend-anchor legend-anchor)) - (make-snip-frame snip width height (if title (format "Plot: ~a" title) "Plot"))) + (make-snip-frame make-snip width height (if title (format "Plot: ~a" title) "Plot"))) ;; =================================================================================================== ;; Plot to a frame or a snip, depending on the value of plot-new-window? diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ #lang racket/base -(require racket/gui/base racket/class racket/match racket/list racket/math +(require racket/gui/base racket/class racket/contract racket/match racket/list racket/math plot/private/common/math plot/private/common/format plot/private/common/ticks @@ -8,10 +8,25 @@ plot/private/common/parameter-groups plot/private/common/parameter-group plot/private/common/draw-attribs + plot/private/plot2d/plot-area + plot/private/plot2d/renderer + plot/private/no-gui/plot2d-utils + plot/private/common/contract "worker-thread.rkt" "snip.rkt") -(provide 2d-plot-snip% make-2d-plot-snip) +(define plot-mouse-event-callback/c + (-> (is-a?/c snip%) (is-a?/c mouse-event%) (or/c real? #f) (or/c real? #f) any/c)) +(define 2d-plot-snip%/c + (class/c + (set-mouse-event-callback (->m (or/c plot-mouse-event-callback/c #f) any/c)) + (set-overlay-renderers (->m (or/c (treeof renderer2d?) #f) any/c)))) + +(provide + (contract-out + [make-2d-plot-snip (unconstrained-domain-> (instanceof/c 2d-plot-snip%/c))] + [2d-plot-snip% 2d-plot-snip%/c]) + plot-mouse-event-callback/c) (define update-delay 16) (define show-zoom-message? #t) @@ -21,8 +36,8 @@ (define 2d-plot-snip% (class plot-snip% (init init-bm saved-plot-parameters) - (init-field make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height) - + (init-field make-bm plot-bounds-rect area width height) + (inherit set-bitmap get-bitmap get-saved-plot-parameters refresh @@ -33,25 +48,43 @@ (super-make-object init-bm saved-plot-parameters) (define (set-message-center) - (match-define (vector x-mid y-mid) (rect-center area-bounds-rect)) + (match-define (vector x-mid y-mid) (rect-center (send area get-area-bounds-rect))) (send this set-message-center x-mid y-mid)) (set-message-center) (define/override (copy) - (make-object this% - (get-bitmap) (get-saved-plot-parameters) - make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height)) - + (define c + (make-object this% + (get-bitmap) (get-saved-plot-parameters) + make-bm plot-bounds-rect area width height)) + (when mouse-event-callback + (send c set-mouse-event-callback mouse-event-callback)) + c) + (define left-click-x 0) (define left-click-y 0) (define left-drag-x 0) (define left-drag-y 0) - + (define plot-bounds-rects empty) + + (define (area-bounds->plot-bounds rect) + ;; assumes: (rect-known? rect) + (match-define (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max)) rect) + (match-define (vector x-min y-min) (send area dc->plot (vector area-x-min area-y-min))) + (match-define (vector x-max y-max) (send area dc->plot (vector area-x-max area-y-max))) + (vector (ivl x-min x-max) (ivl y-min y-max))) + + (define (plot-bounds->area-bounds rect) + ;; assumes (rect-known? rect) + (match-define (vector (ivl plot-x-min plot-x-max) (ivl plot-y-min plot-y-max)) rect) + (match-define (vector x-min y-min) (send area plot->dc (vector plot-x-min plot-y-min))) + (match-define (vector x-max y-max) (send area plot->dc (vector plot-x-max plot-y-max))) + (vector (ivl x-min x-max) (ivl y-min y-max))) (define (get-new-area-bounds-rect) - (rect-meet area-bounds-rect + (rect-meet (send area get-area-bounds-rect) (rect-inexact->exact (vector (ivl left-click-x left-drag-x) (ivl left-click-y left-drag-y))))) @@ -96,11 +129,10 @@ (make-bm animating? plot-bounds-rect width height)]))) (λ (animating?) (draw-command animating? plot-bounds-rect width height)) (λ (rth) - (define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds) - (worker-thread-try-get rth (λ () (values #f #f #f)))) + (define-values (new-bm new-area) + (worker-thread-try-get rth (λ () (values #f #f)))) (cond [(is-a? new-bm bitmap%) - (set! area-bounds-rect new-area-bounds-rect) - (set! area-bounds->plot-bounds new-area-bounds->plot-bounds) + (set! area new-area) (set-bitmap new-bm) (set-message-center) #t] @@ -110,8 +142,8 @@ (define (update-plot) (start-update-thread #f) (set-update #t)) - - (define/override (on-event dc x y editorx editory evt) + + (define (zoom-or-unzoom-mouse-event-handler dc x y editorx editory evt) (define evt-type (send evt get-event-type)) (define mouse-x (- (send evt get-x) x)) (define mouse-y (- (send evt get-y) y)) @@ -136,7 +168,98 @@ [(and (not (send evt get-left-down)) (<= 0 mouse-x (send (get-bitmap) get-width)) (<= 0 mouse-y (send (get-bitmap) get-height))) - (set-click-message)])]) + (set-click-message)])])) + + (define mouse-event-callback #f) + (define mouse-event-handler zoom-or-unzoom-mouse-event-handler) + + (define (user-mouse-event-handler dc x y editorx editory evt) + (define mouse-x (- (send evt get-x) x)) + (define mouse-y (- (send evt get-y) y)) + (if (rect-contains? (send area get-area-bounds-rect) (vector mouse-x mouse-y)) + (match-let (((vector px py) (send area dc->plot (vector mouse-x mouse-y)))) + (mouse-event-callback this evt px py)) + (mouse-event-callback this evt #f #f))) + + (define/public (set-mouse-event-callback callback) + (set! mouse-event-callback callback) + (set! mouse-event-handler + (if mouse-event-callback + user-mouse-event-handler + zoom-or-unzoom-mouse-event-handler))) + + (define the-overlay-renderers #f) + + (define/public (set-overlay-renderers renderers) + (set! the-overlay-renderers renderers) + (refresh)) + + (define (draw-overlay-renderers dc x y left top right bottom) + (when the-overlay-renderers + ;; Implementation notes: + ;; + ;; * the `plot-area` routine used to draw plots, expects the origin of + ;; the DC to be set to the origin or (0, 0) of the plot, see + ;; `set-origin` call. + ;; + ;; * Since the DC origin has been adjusted to start at X, Y, the LEFT, + ;; TOP, RIGHT and BOTTOM values have to be adjusted accordingly. + ;; + ;; * plot Y axis grows upwards (lower values are at the bottom, higher + ;; values are at the top), draw context Y axis grows downwards (lower + ;; values are at the top, higher values are at the bottom). This + ;; results in some non-obvious `plot->dc` and `dc->plot` calls. + ;; + ;; * The area bounded by LEFT, TOP, RIGHT and BOTTOM might cover an + ;; area outside the plot area (e.g. where axis are drawn). We need to + ;; intersect the current plot bounds with this area to obtain the + ;; final overlay redraw area. + ;; + ;; * If the redraw area is at the edge of the visible part of the plot + ;; snip, we seem to have an off-by-one error and pixels are "left + ;; over" at the edge. This is adjusted using the `add1`, `sub1` calls + ;; below. + + (match-define (vector (ivl cleft cright) (ivl ctop cbottom)) + (plot-bounds->area-bounds plot-bounds-rect)) + + (define dc-x-min (max cleft (add1 (- left x)))) + (define dc-x-max (min cright (sub1 (- right x)))) + (define dc-y-min (max ctop (add1 (- top y)))) + (define dc-y-max (min cbottom (sub1 (- bottom y)))) + + (when (and (> dc-x-max dc-x-min) (> dc-y-max dc-y-min)) + (define overlay-plot-bounds + (area-bounds->plot-bounds (vector (ivl dc-x-min dc-x-max) (ivl dc-y-min dc-y-max)))) + + (define-values (scale-x scale-y) (send dc get-scale)) + (define-values (origin-x origin-y) (send dc get-origin)) + (send dc set-origin (+ origin-x (* scale-x x)) (+ origin-y (* scale-y y))) + + ;; Use the same plot parameters as the main plot -- this ensures + ;; that any axis transforms (e.g. logarithmic, stretch, etc) are + ;; applied to the overlays as well. We than omit the decorations + ;; and specify a transparent background so the main plot underneath + ;; is visible. + (parameterize/group ([plot-parameters (get-saved-plot-parameters)]) + (parameterize ([plot-decorations? #f] + [plot-background-alpha 0]) + ;; The new overlay area has to be constructed inside the + ;; parameterize call, as it picks up the value of the + ;; plot-decorations? parameter. + (define overlay-area + (make-object 2d-plot-area% + overlay-plot-bounds + '() '() '() '() + dc + dc-x-min dc-y-min + (- dc-x-max dc-x-min) (- dc-y-max dc-y-min))) + (plot-area overlay-area the-overlay-renderers))) + + (send dc set-origin origin-x origin-y)))) + + (define/override (on-event dc x y editorx editory evt) + (apply mouse-event-handler dc x y editorx editory evt '()) (super on-event dc x y editorx editory evt)) (define (draw-selection dc dc-x-min dc-y-min rect) @@ -230,8 +353,9 @@ (super draw dc x y left top right bottom dx dy draw-caret) (when dragging? (parameterize/group ([plot-parameters (get-saved-plot-parameters)]) - (draw-selection dc x y (get-new-area-bounds-rect))))) - + (draw-selection dc x y (get-new-area-bounds-rect)))) + (draw-overlay-renderers dc x y left top right bottom)) + (define/override (resize w h) (when (not (and (= w width) (= h height))) (set! width w) @@ -245,7 +369,7 @@ (define (make-2d-plot-snip init-bm saved-plot-parameters - make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height) + make-bm plot-bounds-rect area width height) (make-object 2d-plot-snip% init-bm saved-plot-parameters - make-bm plot-bounds-rect area-bounds-rect area-bounds->plot-bounds width height)) + make-bm plot-bounds-rect area width height)) diff -Nru racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/snip.rkt racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/snip.rkt --- racket-6.12+ppa1/share/pkgs/plot-gui-lib/plot/snip.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-gui-lib/plot/snip.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(require "private/gui/snip2d.rkt") + +(provide + plot-mouse-event-callback/c + 2d-plot-snip%) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/info.rkt racket-7.0+ppa1/share/pkgs/plot-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/info.rkt 2018-01-26 21:08:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "pict-lib" "db-lib" "srfi-lite-lib" "typed-racket-lib" "typed-racket-more" "compatibility-lib" "math-lib"))) (define build-deps (quote ())) (define pkg-desc "Plot non-GUI interface") (define pkg-authors (quote (ntoronto))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib" "pict-lib" "db-lib" "srfi-lite-lib" "typed-racket-lib" "typed-racket-more" "compatibility-lib" "math-lib"))) (define build-deps (quote ())) (define pkg-desc "Plot non-GUI interface") (define pkg-authors (quote (ntoronto))))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/bitmap.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/bitmap.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/bitmap.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/bitmap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,71 @@ -#lang typed/racket/base +#lang racket/base -(require "no-gui.rkt" +(require typed/untyped-utils + "no-gui.rkt" "private/no-gui/plot-bitmap.rkt") +(provide (all-from-out "no-gui.rkt")) + +(module untyped racket/base + (require "private/no-gui/plot-bitmap.rkt" racket/contract + + racket/class + racket/draw + pict + "utils.rkt" + "private/common/contract.rkt" + "private/common/nonrenderer.rkt" + "private/plot2d/renderer.rkt") + (provide + (contract-out + [untyped-plot + (->* [(treeof (or/c renderer2d? nonrenderer?))] + [#:x-min (or/c real? #f) + #:x-max (or/c real? #f) + #:y-min (or/c real? #f) + #:y-max (or/c real? #f) + #:width (and/c exact-integer? (>/c 0)) + #:height (and/c exact-integer? (>/c 0)) + #:title (or/c string? #f) + #:x-label (or/c string? #f) + #:y-label (or/c string? #f) + #:legend-anchor anchor/c + #:out-file (or/c path? string? output-port? #f) + #:out-kind symbol?] + (is-a?/c bitmap%))] + [untyped-plot3d + (->* [(treeof (or/c renderer3d? nonrenderer?))] + [#:x-min (or/c real? #f) + #:x-max (or/c real? #f) + #:y-min (or/c real? #f) + #:y-max (or/c real? #f) + #:z-min (or/c real? #f) + #:z-max (or/c real? #f) + #:width (and/c exact-integer? (>/c 0)) + #:height (and/c exact-integer? (>/c 0)) + #:angle real? #:altitude real? + #:title (or/c string? #f) + #:x-label (or/c string? #f) + #:y-label (or/c string? #f) + #:z-label (or/c string? #f) + #:legend-anchor anchor/c + #:out-file (or/c path? string? output-port? #f) + #:out-kind symbol?] + (is-a?/c bitmap%))])) + (define untyped-plot3d plot3d) + (define untyped-plot plot)) + + +(require (rename-in "private/no-gui/plot-bitmap.rkt" + [plot typed-plot] + [plot3d typed-plot3d]) + 'untyped) + +(define-typed/untyped-identifier plot + typed-plot + untyped-plot) +(define-typed/untyped-identifier plot3d + typed-plot3d + untyped-plot3d) + +(provide plot plot3d) -(provide (all-from-out "no-gui.rkt") - plot plot3d) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/no-gui.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/no-gui.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/no-gui.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/no-gui.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,12 +23,20 @@ ;; 2D exports (require (rename-in "private/no-gui/plot2d.rkt" - [plot/dc typed-plot/dc]) + [plot/dc typed-plot/dc] + [plot-bitmap typed-plot-bitmap] + [plot-pict typed-plot-pict]) "private/no-gui/plot2d-untyped.rkt") (define-typed/untyped-identifier plot/dc typed-plot/dc untyped-plot/dc) +(define-typed/untyped-identifier plot-bitmap + typed-plot-bitmap + untyped-plot-bitmap) +(define-typed/untyped-identifier plot-pict + typed-plot-pict + untyped-plot-pict) (provide plot/dc @@ -40,7 +48,8 @@ (provide points vector-field - error-bars) + error-bars + candlesticks) (require "private/plot2d/line.rkt") (provide @@ -84,10 +93,15 @@ y-tick-lines tick-grid point-label + point-pict parametric-label + parametric-pict polar-label + polar-pict function-label - inverse-label) + function-pict + inverse-label + inverse-pict) ;; =================================================================================================== ;; 3D exports diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -21,7 +21,8 @@ (case a [(top-left) 'bottom-right] [(top) 'bottom] [(top-right) 'bottom-left] [(right) 'left] [(bottom-right) 'top-left] [(bottom) 'top] [(bottom-left) 'top-right] [(left) 'right] - [(center) 'center])) + [(center) 'center] + [(auto) 'auto])) ;; =================================================================================================== ;; Draw paramter normalization diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,7 @@ ;; Extra drawing functions. -(require typed/racket/draw typed/racket/class racket/match racket/list +(require typed/racket/draw typed/racket/class racket/match racket/list typed/pict (except-in math/base sum) (except-in math/flonum flsum) "math.rkt" @@ -16,21 +16,97 @@ (define sin45 (/ 1.0 (sqrt 2.0))) +(: get-box-corners/anchor (->* [Real Real Real Real] + [Anchor Real Real] + (Listof (Vector Real Real)))) +(define (get-box-corners/anchor x y width height [anchor 'top-left] [angle 0] [dist 0]) + (let ([dist (case anchor + [(top-left bottom-left top-right bottom-right) (* sin45 dist)] + [else dist])]) + (: dxs (Listof Real)) + (define dxs (case anchor + [(top-left left bottom-left) (list (- dist) (- width dist))] + [(top center bottom) (list (* -1/2 width) (* 1/2 width))] + [else (list (- dist width) dist)])) + (: dys (Listof Real)) + (define dys (case anchor + [(top-left top top-right) (list (- dist) (- height dist))] + [(left center right) (list (* -1/2 height) (* 1/2 width))] + [else (list (- dist height) dist)])) + + (for*/list : (Listof (Vector Real Real)) ([dx (in-list dxs)] [dy (in-list dys)]) + (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) + (define rdy (- (* (cos angle) dy) (* (sin angle) dx))) + (vector (+ x rdx) (+ y rdy))))) + +(: resolve-auto-anchor/str (-> (Instance DC<%>) String Real Real Real Real Anchor)) +(define (resolve-auto-anchor/str dc str x y angle dist) + (define region (send dc get-clipping-region)) + (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0)) + (if region + (let loop ([anchors '(bottom-left bottom-right top-left top-right)] + [best : Anchor 'bottom-left] + [best-score -1]) + (if (null? anchors) + best + (let* ((anchor (car anchors)) + (corners (get-box-corners/anchor x y width height anchor angle dist)) + (center (let ((center-sum (foldl + (lambda ([corner : (Vector Real Real)] [sum : (Vector Real Real)]) + (match-define (vector x y) corner) + (match-define (vector sx sy) sum) + (vector (+ x sx) (+ y sy))) + (cast (vector 0 0) (Vector Real Real)) + corners))) + (match-define (vector x y) center-sum) + (define ncorners (length corners)) + (vector (/ x ncorners) (/ y ncorners)))) + (candidates (cons center corners)) + (score (foldl + (lambda ([corner : (Vector Real Real)] [score : Integer]) + (match-define (vector x y) corner) + (+ (if (send region in-region? x y) 1 0) score)) + 0 + candidates))) + (cond + ;; All candidate points are visible, don't bother checking + ;; other anchor locations + ((= score (length candidates)) anchor) + ((> score best-score) (loop (cdr anchors) anchor score)) + (#t (loop (cdr anchors) best best-score)))))) + 'bottom-left)) + +(: resolve-auto-anchor/pict (-> (Instance DC<%>) pict Real Real Real Anchor)) +(define (resolve-auto-anchor/pict dc pict x y dist) + (define region (send dc get-clipping-region)) + (if region + (let () + (define-values (left top width height) (send region get-bounding-box)) + (define anchor-right? (> (+ x dist (pict-width pict)) (+ left width))) + (define anchor-top? (< (- y dist (pict-height pict)) top)) + (if anchor-right? + (if anchor-top? 'top-right 'bottom-right) + (if anchor-top? 'top-left 'bottom-left))) + 'bottom-left)) + (: draw-text/anchor (->* [(Instance DC<%>) String Real Real] [Anchor Real Real] Void)) (define (draw-text/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0]) (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0)) - (let ([dist (case anchor + (define nanchor (if (eq? anchor 'auto) + (resolve-auto-anchor/str dc str x y angle dist) + anchor)) + (let ([dist (case nanchor [(top-left bottom-left top-right bottom-right) (* sin45 dist)] [else dist])]) - (define dx (case anchor - [(top-left left bottom-left) (- dist)] + (define dx (case nanchor + [(top-left left bottom-left auto) (- dist)] [(top center bottom) (* 1/2 width)] [(top-right right bottom-right) (+ width dist)] [else (raise-type-error 'draw-text/anchor "anchor/c" anchor)])) - (define dy (case anchor - [(top-left top top-right) (- dist)] + (define dy (case nanchor + [(top-left top top-right auto) (- dist)] [(left center right) (* 1/2 height)] [(bottom-left bottom bottom-right) (+ height dist)])) (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) @@ -43,24 +119,28 @@ (Listof (Vector Real Real)))) (define (get-text-corners/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0]) (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0)) - (let ([dist (case anchor - [(top-left bottom-left top-right bottom-right) (* sin45 dist)] - [else dist])]) - (: dxs (Listof Real)) - (define dxs (case anchor - [(top-left left bottom-left) (list (- dist) (- width dist))] - [(top center bottom) (list (* -1/2 width) (* 1/2 width))] - [else (list (- dist width) dist)])) - (: dys (Listof Real)) - (define dys (case anchor - [(top-left top top-right) (list (- dist) (- height dist))] - [(left center right) (list (* -1/2 height) (* 1/2 width))] - [else (list (- dist height) dist)])) - - (for*/list : (Listof (Vector Real Real)) ([dx (in-list dxs)] [dy (in-list dys)]) - (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) - (define rdy (- (* (cos angle) dy) (* (sin angle) dx))) - (vector (+ x rdx) (+ y rdy))))) + (define nanchor (if (eq? anchor 'auto) + (resolve-auto-anchor/str dc str x y angle dist) + anchor)) + (get-box-corners/anchor x y width height nanchor angle dist)) + +(: draw-pict/anchor (->* [(Instance DC<%>) pict Real Real] [Anchor Real] Void)) +(define (draw-pict/anchor dc pict x y [anchor 'top-left] [dist 0]) + (define width (pict-width pict)) + (define height (pict-height pict)) + (define nanchor (if (eq? anchor 'auto) + (resolve-auto-anchor/pict dc pict x y dist) + anchor)) + (define dx (case nanchor + [(top-left left bottom-left auto) (- dist)] + [(top center bottom) (* 1/2 width)] + [(top-right right bottom-right) (+ width dist)] + [else (raise-type-error 'draw-text/anchor "anchor/c" anchor)])) + (define dy (case nanchor + [(top-left top top-right auto) (- dist)] + [(left center right) (* 1/2 height)] + [(bottom-left bottom bottom-right) (+ height dist)])) + (draw-pict pict dc (- x dx) (- y dy))) ;; =================================================================================================== ;; Subdividing nonlinearly transformed shapes diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/math.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/math.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/math.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/math.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -146,11 +146,12 @@ ;; =================================================================================================== ;; Vectors +;; The final case was dead code and has been deleted. There are no instances of +;; vector-andmap thattake more than two vectors as arguments. (:: vector-andmap (All (A B C ...) (case-> (-> (-> A Boolean) (Vectorof A) Boolean) - (-> (-> A B Boolean) (Vectorof A) (Vectorof B) Boolean) - (-> (-> A B C ... C Boolean) (Vectorof A) (Vectorof B) (Vectorof C) ... C Boolean)))) + (-> (-> A B Boolean) (Vectorof A) (Vectorof B) Boolean)))) (define vector-andmap (case-lambda [([f : (-> A Boolean)] [as : (Vectorof A)]) @@ -162,27 +163,14 @@ (raise-argument-error 'vector-andmap (format "vector of length ~a" n) 2 f as bs)) (for/and ([a (in-vector as)] [b (in-vector bs)]) - (f a b))] - [(f as bs . vs) - (define n (vector-length as)) - (for ([v (in-list (cons bs vs))] - [i (in-naturals 2)]) - (unless (= (vector-length v) n) - (apply raise-argument-error 'vector-andmap (format "vector of length ~a" n) i f as bs vs))) - (let loop ([i : Nonnegative-Fixnum 0]) - (cond [(< i n) - (and (apply f (vector-ref as n) (vector-ref bs n) - (map (plambda: (C) ([v : (Vectorof C)]) - (vector-ref v n)) - vs)) - (loop (+ i 1)))] - [else #t]))])) + (f a b))])) + +;; As with vector-andmap, dead code has been deleted. (:: vector-ormap (All (A B C ...) (case-> (-> (-> A Boolean) (Vectorof A) Boolean) - (-> (-> A B Boolean) (Vectorof A) (Vectorof B) Boolean) - (-> (-> A B C ... C Boolean) (Vectorof A) (Vectorof B) (Vectorof C) ... C Boolean)))) + (-> (-> A B Boolean) (Vectorof A) (Vectorof B) Boolean)))) (define vector-ormap (case-lambda [([f : (-> A Boolean)] [as : (Vectorof A)]) @@ -194,21 +182,7 @@ (raise-argument-error 'vector-ormap (format "vector of length ~a" n) 2 f as bs)) (for/or ([a (in-vector as)] [b (in-vector bs)]) - (f a b))] - [(f as bs . vs) - (define n (vector-length as)) - (for ([v (in-list (cons bs vs))] - [i (in-naturals 2)]) - (unless (= (vector-length v) n) - (apply raise-argument-error 'vector-ormap (format "vector of length ~a" n) i f as bs vs))) - (let loop ([i : Nonnegative-Fixnum 0]) - (cond [(< i n) - (or (apply f (vector-ref as n) (vector-ref bs n) - (map (plambda: (C) ([v : (Vectorof C)]) - (vector-ref v n)) - vs)) - (loop (+ i 1)))] - [else #f]))])) + (f a b))])) (:: vcross (-> (Vectorof Real) (Vectorof Real) (Vector Real Real Real))) (define (vcross v1 v2) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -12,12 +12,16 @@ plot-z-axis? plot-z-far-axis?)) (define-parameter-group plot-tick-labels - (plot-x-tick-label-anchor + (plot-x-tick-labels? + plot-x-tick-label-anchor plot-x-tick-label-angle + plot-x-far-tick-labels? plot-x-far-tick-label-anchor plot-x-far-tick-label-angle + plot-y-tick-labels? plot-y-tick-label-anchor plot-y-tick-label-angle + plot-y-far-tick-labels? plot-y-far-tick-label-anchor plot-y-far-tick-label-angle)) @@ -89,7 +93,7 @@ Anchor Nonnegative-Real (List Boolean Boolean Boolean Boolean Boolean Boolean) - (List Anchor Real Anchor Real Anchor Real Anchor Real) + (List Boolean Anchor Real Boolean Anchor Real Boolean Anchor Real Boolean Anchor Real) Boolean Boolean) (List Positive-Integer Real Real Nonnegative-Real Boolean Boolean) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -83,6 +83,14 @@ (defparam plot-y-far-axis? Boolean #t) (defparam plot-z-far-axis? Boolean #t) +(defparam plot-x-tick-labels? Boolean #t) +(defparam plot-y-tick-labels? Boolean #t) +(defparam plot-z-tick-labels? Boolean #t) + +(defparam plot-x-far-tick-labels? Boolean #f) +(defparam plot-y-far-tick-labels? Boolean #f) +(defparam plot-z-far-tick-labels? Boolean #f) + (defparam2 plot-x-tick-label-angle angle Real Real 0 (rational 'plot-x-tick-label-angle)) (defparam2 plot-y-tick-label-angle angle Real Real 0 (rational 'plot-y-tick-label-angle)) (defparam2 plot-x-far-tick-label-angle angle Real Real 0 (rational 'plot-x-far-tick-label-angle)) @@ -205,6 +213,15 @@ (defparam error-bar-line-style Plot-Pen-Style 'solid) (defparam2 error-bar-alpha Real Nonnegative-Real 2/3 (unit-ivl 'error-bar-alpha)) +;; Candlesticks + +(defparam2 candlestick-width Real Nonnegative-Real 1 (nonnegative-rational 'candlestick-width)) +(defparam candlestick-up-color Plot-Color 2) +(defparam candlestick-down-color Plot-Color 1) +(defparam2 candlestick-line-width Real Nonnegative-Real 1 (nonnegative-rational 'candlestick-line-width)) +(defparam candlestick-line-style Plot-Pen-Style 'solid) +(defparam2 candlestick-alpha Real Nonnegative-Real 2/3 (unit-ivl 'candlestick-alpha)) + ;; Contours (:: default-contour-colors (-> (Listof Real) (Listof Plot-Color))) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -527,6 +527,7 @@ [else (set-brush brush-color 'transparent) real-sym])) (case line-sym + [(none) void] ; circles [(circle) (make-draw-circle-glyph r)] ; squares @@ -575,6 +576,11 @@ (for ([v (in-list vs)]) (draw-glyph v)))) + (define/public (draw-pict pict v [anchor 'top-left] [dist 0]) + (when (vrational? v) + (match-define (vector x y) v) + (draw-pict/anchor dc pict x y anchor dist))) + ;; =============================================================================================== ;; Legend @@ -608,7 +614,7 @@ (cond [(and x-min x-max) (case (plot-legend-anchor) - [(top-left left bottom-left) x-min] + [(top-left left bottom-left auto) x-min] [(top-right right bottom-right) (- x-max legend-x-size)] [(center bottom top) (- (* 1/2 (+ x-min x-max)) (* 1/2 legend-x-size))])] @@ -619,7 +625,7 @@ (cond [(and y-min y-max) (case (plot-legend-anchor) - [(top-left top top-right) y-min] + [(top-left top top-right auto) y-min] [(bottom-left bottom bottom-right) (- y-max legend-y-size)] [(center left right) (- (* 1/2 (+ y-min y-max)) (* 1/2 legend-y-size))])] diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,9 +3,11 @@ (require (for-syntax racket/base) typed/racket/draw typed/racket/class + typed/pict "type-doc.rkt" "math.rkt") + (provide (all-defined-out)) (deftype (Treeof A) (U A (Listof (Treeof A)))) @@ -13,7 +15,8 @@ (deftype Anchor (U 'top-left 'top 'top-right 'left 'center 'right - 'bottom-left 'bottom 'bottom-right)) + 'bottom-left 'bottom 'bottom-right + 'auto)) (deftype Color (U (List Real Real Real) @@ -60,7 +63,7 @@ 'circle7 'circle8 'bullet 'fullcircle1 'fullcircle2 'fullcircle3 'fullcircle4 'fullcircle5 'fullcircle6 - 'fullcircle7 'fullcircle8))) + 'fullcircle7 'fullcircle8 'none))) (deftype (List-Generator A B) (U (Listof B) (-> A (Listof B)))) @@ -126,4 +129,5 @@ [draw-tick (-> (Vectorof Real) Real Real Void)] [draw-arrow-glyph (-> (Vectorof Real) Real Real Void)] [draw-glyphs (-> (Listof (Vectorof Real)) Point-Sym Nonnegative-Real Void)] + [draw-pict (->* [pict (Vectorof Real)] (Anchor Real) Void)] [draw-legend (-> (Listof legend-entry) Rect Void)])) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,9 +14,13 @@ "../plot2d/plot-area.rkt" "../plot2d/renderer.rkt" "plot2d-utils.rkt" - "evil.rkt") + "evil.rkt" + typed/racket/unsafe) -(provide (all-defined-out)) +(unsafe-provide plot/dc + plot-bitmap + plot-pict + plot-file) ;; =================================================================================================== ;; Plot to a given device context @@ -64,12 +68,6 @@ bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks dc x y width height)) (plot-area area renderer-list))])) -(require (for-syntax racket/base - "plot2d-evil-box.rkt")) - -(begin-for-syntax - (set-box! plot/dc-box #'plot/dc)) - ;; =================================================================================================== ;; Plot to a bitmap diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-untyped.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-untyped.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-untyped.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-untyped.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ (require racket/contract racket/class racket/draw - (for-syntax racket/base "plot2d-evil-box.rkt") + pict "../../utils.rkt" "../common/contract.rkt" "../common/nonrenderer.rkt" @@ -27,7 +27,34 @@ #:x-label (or/c string? #f) #:y-label (or/c string? #f) #:legend-anchor anchor/c] - void?)])) + void?)] + [untyped-plot-bitmap + (->* [(treeof (or/c renderer2d? nonrenderer?))] + [#:x-min (or/c real? #f) + #:x-max (or/c real? #f) + #:y-min (or/c real? #f) + #:y-max (or/c real? #f) + #:title (or/c string? #f) + #:height (or/c real? #f) + #:width (or/c real? #f) + #:x-label (or/c string? #f) + #:y-label (or/c string? #f) + #:legend-anchor anchor/c] + (is-a?/c bitmap%))] + [untyped-plot-pict + (->* [(treeof (or/c renderer2d? nonrenderer?))] + [#:x-min (or/c real? #f) + #:x-max (or/c real? #f) + #:y-min (or/c real? #f) + #:y-max (or/c real? #f) + #:title (or/c string? #f) + #:x-label (or/c string? #f) + #:height (or/c real? #f) + #:width (or/c real? #f) + #:y-label (or/c string? #f) + #:legend-anchor anchor/c] + pict?)])) -(define-syntax untyped-plot/dc - (make-rename-transformer (unbox plot/dc-box))) +(define untyped-plot/dc plot/dc) +(define untyped-plot-pict plot-pict) +(define untyped-plot-bitmap plot-bitmap) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-utils.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-utils.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-utils.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d-utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,9 +9,11 @@ "../common/ticks.rkt" "../plot2d/plot-area.rkt" "../plot2d/renderer.rkt" - "utils.rkt") + "utils.rkt" + typed/racket/unsafe) -(provide (all-defined-out)) +(provide get-renderer-list get-bounds-rect get-ticks) +(unsafe-provide plot-area) (: get-renderer-list (-> Any (Listof renderer2d))) (define (get-renderer-list renderer-tree) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,9 +14,15 @@ "../plot3d/plot-area.rkt" "../plot3d/renderer.rkt" "plot3d-utils.rkt" - "evil.rkt") + "evil.rkt" + typed/racket/unsafe) -(provide (all-defined-out)) + + +(unsafe-provide plot3d/dc + plot3d-bitmap + plot3d-pict + plot3d-file) ;; =================================================================================================== ;; Plot to a given device context diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d-utils.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d-utils.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d-utils.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d-utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,9 +9,11 @@ "../common/ticks.rkt" "../plot3d/plot-area.rkt" "../plot3d/renderer.rkt" - "utils.rkt") + "utils.rkt" + typed/racket/unsafe) -(provide (all-defined-out)) +(provide get-renderer-list get-bounds-rect get-ticks) +(unsafe-provide plot-area) (: get-renderer-list (-> Any (Listof renderer3d))) (define (get-renderer-list renderer-tree) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot-bitmap.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot-bitmap.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot-bitmap.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot-bitmap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,9 +8,10 @@ "../plot2d/renderer.rkt" "../plot3d/renderer.rkt" "plot2d.rkt" - "plot3d.rkt") + "plot3d.rkt" + typed/racket/unsafe) -(provide (all-defined-out)) +(unsafe-provide plot plot3d) (:: plot (->* [(Treeof (U renderer2d nonrenderer))] diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/decoration.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/decoration.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/decoration.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/decoration.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,14 +2,14 @@ ;; Renderers for plot decorations: axes, grids, labeled points, etc. -(require typed/racket/class typed/racket/draw racket/match racket/math racket/list +(require typed/racket/class typed/racket/draw racket/match racket/math racket/list typed/pict plot/utils "../common/type-doc.rkt" "../common/utils.rkt" "clip.rkt" "plot-area.rkt") -(provide (all-defined-out)) +(provide (except-out (all-defined-out) draw-polar-axis-lines draw-polar-axis-ticks)) ;; =================================================================================================== ;; X and Y axes @@ -288,6 +288,24 @@ empty) +(: pict-render-proc (-> pict (Vectorof Real) + Anchor + Plot-Color Plot-Color Nonnegative-Real Nonnegative-Real Point-Sym + Nonnegative-Real + 2D-Render-Proc)) +(define ((pict-render-proc pict v anchor + point-color point-fill-color point-size point-line-width point-sym + alpha) + area) + (send area put-alpha alpha) + ; pict + (send area put-pict pict v anchor (* 1/2 point-size)) + ; point + (send area put-pen point-color point-line-width 'solid) + (send area put-brush point-fill-color 'solid) + (send area put-glyphs (list v) point-sym point-size) + empty) + (:: point-label (->* [(Sequenceof Real)] [(U String #f) @@ -335,6 +353,40 @@ point-size point-line-width point-sym alpha)))])) +(:: point-pict + (->* [(Sequenceof Real) pict] + [#:anchor Anchor + #:point-color Plot-Color + #:point-fill-color (U Plot-Color 'auto) + #:point-size Nonnegative-Real + #:point-line-width Nonnegative-Real + #:point-sym Point-Sym + #:alpha Nonnegative-Real] + renderer2d)) +(define (point-pict v pict + #:anchor [anchor (label-anchor)] + #:point-color [point-color (point-color)] + #:point-fill-color [point-fill-color 'auto] + #:point-size [point-size (label-point-size)] + #:point-line-width [point-line-width (point-line-width)] + #:point-sym [point-sym 'fullcircle] + #:alpha [alpha (label-alpha)]) + (define fail/kw (make-raise-keyword-error 'point-pict)) + (cond + [(not (rational? point-size)) (fail/kw "rational?" '#:point-size point-size)] + [(not (rational? point-line-width)) (fail/kw "rational?" '#:point-line-width point-line-width)] + [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] + [else + (let ([v (sequence-head-vector 'point-pict v 2)]) + (match-define (vector x y) v) + (renderer2d (vector (ivl x x) (ivl y y)) #f #f + (pict-render-proc pict v anchor + point-color (cond [(eq? point-fill-color 'auto) (->pen-color point-color)] + [else point-fill-color]) + point-size point-line-width point-sym + alpha)))])) + + (:: parametric-label (->* [(-> Real (Sequenceof Real)) Real] [(U String #f) @@ -376,6 +428,37 @@ #:point-line-width point-line-width #:point-sym point-sym #:alpha alpha)])) +(:: parametric-pict + (->* [(-> Real (Sequenceof Real)) Real pict] + [#:anchor Anchor + #:point-color Plot-Color + #:point-fill-color (U Plot-Color 'auto) + #:point-size Nonnegative-Real + #:point-line-width Nonnegative-Real + #:point-sym Point-Sym + #:alpha Nonnegative-Real] + renderer2d)) +(define (parametric-pict + f t pict + #:anchor [anchor (label-anchor)] + #:point-color [point-color (point-color)] + #:point-fill-color [point-fill-color 'auto] + #:point-size [point-size (label-point-size)] + #:point-line-width [point-line-width (point-line-width)] + #:point-sym [point-sym 'fullcircle] + #:alpha [alpha (label-alpha)]) + (cond + [(not (rational? t)) (raise-argument-error 'parametric-pict "rational?" 1 f t)] + [else + (point-pict + (sequence-head-vector 'parametric-pict (f t) 2) + pict + #:anchor anchor + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)])) + + (:: polar-label (->* [(-> Real Real) Real] [(U String #f) @@ -416,6 +499,35 @@ #:point-line-width point-line-width #:point-sym point-sym #:alpha alpha)])) +(:: polar-pict + (->* [(-> Real Real) Real pict] + [#:anchor Anchor + #:point-color Plot-Color + #:point-fill-color (U Plot-Color 'auto) + #:point-size Nonnegative-Real + #:point-line-width Nonnegative-Real + #:point-sym Point-Sym + #:alpha Nonnegative-Real] + renderer2d)) +(define (polar-pict + f θ pict + #:anchor [anchor (label-anchor)] + #:point-color [point-color (point-color)] + #:point-fill-color [point-fill-color 'auto] + #:point-size [point-size (label-point-size)] + #:point-line-width [point-line-width (point-line-width)] + #:point-sym [point-sym 'fullcircle] + #:alpha [alpha (label-alpha)]) + (cond + [(not (rational? θ)) (raise-argument-error 'polar-pict "rational?" 1 f θ)] + [else + (point-pict + (polar->cartesian θ (f θ)) pict + #:anchor anchor + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)])) + (:: function-label (->* [(-> Real Real) Real] [(U String #f) @@ -456,6 +568,35 @@ #:point-line-width point-line-width #:point-sym point-sym #:alpha alpha)])) +(:: function-pict + (->* [(-> Real Real) Real pict] + [#:anchor Anchor + #:point-color Plot-Color + #:point-fill-color (U Plot-Color 'auto) + #:point-size Nonnegative-Real + #:point-line-width Nonnegative-Real + #:point-sym Point-Sym + #:alpha Nonnegative-Real] + renderer2d)) +(define (function-pict + f x pict + #:anchor [anchor (label-anchor)] + #:point-color [point-color (point-color)] + #:point-fill-color [point-fill-color 'auto] + #:point-size [point-size (label-point-size)] + #:point-line-width [point-line-width (point-line-width)] + #:point-sym [point-sym 'fullcircle] + #:alpha [alpha (label-alpha)]) + (cond + [(not (rational? x)) (raise-argument-error 'function-pict "rational" 1 f x)] + [else + (point-pict + (vector x (f x)) pict + #:anchor anchor + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)])) + (:: inverse-label (->* [(-> Real Real) Real] [(U String #f) @@ -495,3 +636,32 @@ #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size #:point-line-width point-line-width #:point-sym point-sym #:alpha alpha)])) + +(:: inverse-pict + (->* [(-> Real Real) Real pict] + [#:anchor Anchor + #:point-color Plot-Color + #:point-fill-color (U Plot-Color 'auto) + #:point-size Nonnegative-Real + #:point-line-width Nonnegative-Real + #:point-sym Point-Sym + #:alpha Nonnegative-Real] + renderer2d)) +(define (inverse-pict + f y pict + #:anchor [anchor (label-anchor)] + #:point-color [point-color (point-color)] + #:point-fill-color [point-fill-color 'auto] + #:point-size [point-size (label-point-size)] + #:point-line-width [point-line-width (point-line-width)] + #:point-sym [point-sym 'fullcircle] + #:alpha [alpha (label-alpha)]) + (cond + [(not (rational? y)) (raise-argument-error 'inverse-pict "rational?" 1 f y)] + [else + (point-pict + (vector (f y) y) pict + #:anchor anchor + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)])) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/plot-area.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/plot-area.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/plot-area.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/plot-area.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ #lang typed/racket/base -(require typed/racket/class typed/racket/draw racket/match racket/math racket/list racket/flonum +(require typed/racket/class typed/racket/draw racket/match racket/math racket/list racket/flonum typed/pict (only-in math/flonum fl) "../common/type-doc.rkt" "../common/types.rkt" @@ -65,6 +65,7 @@ [put-glyphs (-> (Listof (Vectorof Real)) Point-Sym Nonnegative-Real Void)] [put-arrow (-> (Vectorof Real) (Vectorof Real) Void)] [put-tick (-> (Vectorof Real) Real Real Void)] + [put-pict (->* [pict (Vectorof Real)] [Anchor Real] Void)] )) (: 2d-plot-area% 2D-Plot-Area%) @@ -330,10 +331,14 @@ ;; ----------------------------------------------------------------------------------------------- ;; Tick label parameters + (: draw-x-tick-labels? Boolean) + (: draw-y-tick-labels? Boolean) (: draw-x-far-tick-labels? Boolean) (: draw-y-far-tick-labels? Boolean) - (define draw-x-far-tick-labels? (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks)))) - (define draw-y-far-tick-labels? (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks)))) + (define draw-x-tick-labels? (plot-x-tick-labels?)) + (define draw-y-tick-labels? (plot-y-tick-labels?)) + (define draw-x-far-tick-labels? (or (plot-x-far-tick-labels?) (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks))))) + (define draw-y-far-tick-labels? (or (plot-y-far-tick-labels?) (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks))))) (: x-tick-label-offset (Vectorof Real)) (: y-tick-label-offset (Vectorof Real)) @@ -354,7 +359,7 @@ (: get-x-tick-label-params (-> (Listof Label-Params))) (define (get-x-tick-label-params) - (if (plot-x-axis?) + (if (and (plot-x-axis?) draw-x-tick-labels?) (get-tick-label-params x-ticks x-tick-label-offset (λ ([x : Real]) (x-tick-value->dc x)) @@ -364,7 +369,7 @@ (: get-y-tick-label-params (-> (Listof Label-Params))) (define (get-y-tick-label-params) - (if (plot-y-axis?) + (if (and (plot-y-axis?) draw-y-tick-labels?) (get-tick-label-params y-ticks y-tick-label-offset (λ ([y : Real]) (y-tick-value->dc y)) @@ -422,14 +427,14 @@ (: max-x-tick-label-height Real) (define max-x-tick-label-height - (if (plot-x-axis?) + (if (and (plot-x-axis?) draw-x-tick-labels?) (apply max 0 (map (λ ([corner : (Vectorof Real)]) (vector-ref corner 1)) (get-relative-corners (get-x-tick-label-params)))) 0)) (: max-y-tick-label-width Real) (define max-y-tick-label-width - (if (plot-y-axis?) + (if (and (plot-y-axis?) draw-y-tick-labels?) (- (apply min 0 (map (λ ([corner : (Vectorof Real)]) (vector-ref corner 0)) (get-relative-corners (get-y-tick-label-params))))) 0)) @@ -761,4 +766,9 @@ (let ([v (exact-vector2d v)]) (when (and v (in-bounds? v)) (send pd draw-tick (plot->dc v) r angle)))) + + (define/public (put-pict pict v [anchor 'top-left] [dist 0]) + (let ([v (exact-vector2d v)]) + (when (and v (in-bounds? v)) + (send pd draw-pict pict (plot->dc v) anchor dist)))) )) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/point.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/point.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/point.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/point.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -249,3 +249,82 @@ (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun (error-bars-render-fun xs ys hs color line-width line-style width alpha)))]))])) + +;; =================================================================================================== +;; Candlesticks + +(: candlesticks-render-fun (-> (Listof Real) (Listof Real) (Listof Real) (Listof Real) (Listof Real) + Plot-Color Plot-Color Nonnegative-Real Plot-Pen-Style + Nonnegative-Real Nonnegative-Real + 2D-Render-Proc)) +(define ((candlesticks-render-fun xs opens highs lows closes up-color down-color line-width line-style width alpha) area) + (define clip-rect (send area get-clip-rect)) + (define radius (* 1/2 width)) + + (send area put-alpha alpha) + (send area put-pen up-color line-width line-style) + (for ([x (in-list xs)] [open (in-list opens)] [high (in-list highs)] [low (in-list lows)] [close (in-list closes)]) + (define v1 (vector x open)) + (define v2 (vector x high)) + (define v3 (vector x low)) + (define v4 (vector x close)) + (define r1 (vector (ivl (- x radius) (+ x radius)) (ivl open close))) + (cond [(> open close) (send area put-pen down-color line-width line-style) + (send area put-line v2 v1) + (send area put-line v4 v3) + (send area put-brush down-color 'solid) + (send area put-rect r1)] + [else (send area put-pen up-color line-width line-style) + (send area put-line v2 v4) + (send area put-line v1 v3) + (send area put-brush up-color 'solid) + (send area put-rect r1)])) + empty) + +(:: candlesticks + (->* [(Sequenceof (Sequenceof Real))] + [#:x-min (U Real #f) #:x-max (U Real #f) + #:y-min (U Real #f) #:y-max (U Real #f) + #:up-color Plot-Color + #:down-color Plot-Color + #:line-width Nonnegative-Real + #:line-style Plot-Pen-Style + #:width Nonnegative-Real + #:alpha Nonnegative-Real] + renderer2d)) +(define (candlesticks candles + #:x-min [x-min #f] #:x-max [x-max #f] + #:y-min [y-min #f] #:y-max [y-max #f] + #:up-color [up-color (candlestick-up-color)] + #:down-color [down-color (candlestick-down-color)] + #:line-width [line-width (candlestick-line-width)] + #:line-style [line-style (candlestick-line-style)] + #:width [width (candlestick-width)] + #:alpha [alpha (candlestick-alpha)]) + (define fail/kw (make-raise-keyword-error 'candlesticks)) + (cond + [(and x-min (not (rational? x-min))) (fail/kw "#f or rational" '#:x-min x-min)] + [(and x-max (not (rational? x-max))) (fail/kw "#f or rational" '#:x-max x-max)] + [(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)] + [(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)] + [(not (rational? line-width)) (fail/kw "rational?" '#:line-width line-width)] + [(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)] + [else + (let* ([candles (sequence->listof-vector 'candlesticks candles 5)] + [candles (filter vrational? candles)]) + (cond [(empty? candles) (renderer2d #f #f #f #f)] + [else + (match-define (list (vector #{xs : (Listof Real)} + #{opens : (Listof Real)} + #{highs : (Listof Real)} + #{lows : (Listof Real)} + #{closes : (Listof Real)}) + ...) + candles) + (let ([x-min (if x-min x-min (- (apply min* xs) width))] + [x-max (if x-max x-max (+ (apply max* xs) width))] + [y-min (if y-min y-min (apply min* lows))] + [y-max (if y-max y-max (apply max* highs))]) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (candlesticks-render-fun xs opens highs lows closes + up-color down-color line-width line-style width alpha)))]))])) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/rectangle.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/rectangle.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot2d/rectangle.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot2d/rectangle.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -18,11 +18,17 @@ 2D-Render-Proc)) (define ((rectangles-render-proc rects color style line-color line-width line-style alpha label) area) + (match-define (vector (ivl bx-min bx-max) (ivl by-min by-max)) (send area get-bounds-rect)) (send area put-pen line-color line-width line-style) (send area put-brush color style) (send area put-alpha alpha) (for ([rect (in-list rects)]) - (send area put-rect rect)) + (match-define (vector (ivl vx-min vx-max) (ivl vy-min vy-max)) rect) + (define x-min (if (or (eqv? vx-min -inf.0) (eqv? vx-min -inf.f)) bx-min vx-min)) + (define x-max (if (or (eqv? vx-max +inf.0) (eqv? vx-max +inf.f)) bx-max vx-max)) + (define y-min (if (or (eqv? vy-min -inf.0) (eqv? vy-min -inf.f)) by-min vy-min)) + (define y-max (if (or (eqv? vy-max +inf.0) (eqv? vy-max +inf.f)) by-max vy-max)) + (send area put-rect (vector (ivl x-min x-max) (ivl y-min y-max)))) (cond [label (rectangle-legend-entry label color style line-color line-width line-style)] [else empty])) @@ -65,8 +71,10 @@ #{y2s : (Listof (U Real #f))})) ...) rects) - (define rxs (filter rational? (append x1s x2s))) - (define rys (filter rational? (append y1s y2s))) + (define (valid? num) + (and (real? num) (not (eqv? num +nan.0)) (not (eqv? num +nan.f)))) + (define rxs (filter valid? (append x1s x2s))) + (define rys (filter valid? (append y1s y2s))) (cond [(or (empty? rxs) (empty? rys)) (renderer2d #f #f #f #f)] [else @@ -74,7 +82,17 @@ [x-max (if x-max x-max (apply max* rxs))] [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) - (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + ;; Only provide bounds if all rectangle dimensions are finite. + ;; Infinite limits mean "extend to the edge of the plot". + ;; + ;; We cannot simply discard infinite limits, as these bounds will + ;; be used for clipping the rectangles and this might result in + ;; rectangles that don't extend all the way to the edge. + (define bounds + (and (rational? x-min) (rational? x-max) + (rational? y-min) (rational? y-max) + (vector (ivl x-min x-max) (ivl y-min y-max)))) + (renderer2d bounds #f default-ticks-fun (rectangles-render-proc rects color style line-color line-width line-style alpha label)))]))])) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -17,11 +17,13 @@ "bsp-trees.rkt" "bsp.rkt") -(provide (all-defined-out) +(provide plot3d-subdivisions plot3d-back-layer plot3d-area-layer plot3d-front-layer - ) + 3D-Plot-Area% + 3d-plot-area% + (struct-out render-tasks)) (define plot3d-back-layer 2) (define plot3d-area-layer 1) @@ -573,13 +575,19 @@ ;; ----------------------------------------------------------------------------------------------- ;; Tick label parameters - + + (: draw-x-tick-labels? Boolean) + (: draw-y-tick-labels? Boolean) + (: draw-z-tick-labels? Boolean) (: draw-x-far-tick-labels? Boolean) (: draw-y-far-tick-labels? Boolean) (: draw-z-far-tick-labels? Boolean) - (define draw-x-far-tick-labels? (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks)))) - (define draw-y-far-tick-labels? (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks)))) - (define draw-z-far-tick-labels? (not (and (plot-z-axis?) (equal? z-ticks z-far-ticks)))) + (define draw-x-tick-labels? (plot-x-tick-labels?)) + (define draw-y-tick-labels? (plot-y-tick-labels?)) + (define draw-z-tick-labels? (plot-z-tick-labels?)) + (define draw-x-far-tick-labels? (or (plot-x-far-tick-labels?) (not (and (plot-x-axis?) (equal? x-ticks x-far-ticks))))) + (define draw-y-far-tick-labels? (or (plot-y-far-tick-labels?) (not (and (plot-y-axis?) (equal? y-ticks y-far-ticks))))) + (define draw-z-far-tick-labels? (or (plot-z-far-tick-labels?) (not (and (plot-z-axis?) (equal? z-ticks z-far-ticks))))) (: sort-ticks (-> (Listof tick) (-> Real FlVector) (Listof tick))) (define/private (sort-ticks ts tick-value->view) @@ -625,7 +633,7 @@ (: get-x-tick-label-params (-> (Listof Label-Params))) (define (get-x-tick-label-params) - (if (plot-x-axis?) + (if (and (plot-x-axis?) draw-x-tick-labels?) (let ([offset (if x-axis-y-min? (vneg (y-axis-dir)) (y-axis-dir))]) (get-tick-label-params (sort-ticks x-ticks (λ ([x : Real]) (x-tick-value->view x))) (λ ([x : Real]) (x-tick-value->dc x)) @@ -635,7 +643,7 @@ (: get-y-tick-label-params (-> (Listof Label-Params))) (define (get-y-tick-label-params) - (if (plot-y-axis?) + (if (and (plot-y-axis?) draw-y-tick-labels?) (let ([offset (if y-axis-x-min? (vneg (x-axis-dir)) (x-axis-dir))]) (get-tick-label-params (sort-ticks y-ticks (λ ([y : Real]) (y-tick-value->view y))) (λ ([y : Real]) (y-tick-value->dc y)) @@ -645,7 +653,7 @@ (: get-z-tick-label-params (-> (Listof Label-Params))) (define (get-z-tick-label-params) - (if (plot-z-axis?) + (if (and (plot-z-axis?) draw-z-tick-labels?) (get-tick-label-params z-ticks (λ ([z : Real]) (z-tick-value->dc z)) #(-1 0) @@ -743,13 +751,13 @@ (: max-x-tick-label-diag (-> Real)) (define (max-x-tick-label-diag) - (if (plot-x-axis?) + (if (and (plot-x-axis?) draw-x-tick-labels?) (max-tick-label-diag (y-axis-dir) max-x-tick-label-width max-x-tick-label-height) 0)) (: max-y-tick-label-diag (-> Real)) (define (max-y-tick-label-diag) - (if (plot-y-axis?) + (if (and (plot-y-axis?) draw-y-far-tick-labels?) (max-tick-label-diag (x-axis-dir) max-y-tick-label-width max-y-tick-label-height) 0)) diff -Nru racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt --- racket-6.12+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt 2018-01-26 20:36:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -58,6 +58,12 @@ plot-x-far-axis? plot-y-far-axis? plot-z-far-axis? + plot-x-tick-labels? + plot-y-tick-labels? + plot-z-tick-labels? + plot-x-far-tick-labels? + plot-y-far-tick-labels? + plot-z-far-tick-labels? plot-x-tick-label-anchor plot-y-tick-label-anchor plot-x-far-tick-label-anchor @@ -143,6 +149,12 @@ error-bar-line-width error-bar-line-style error-bar-alpha + candlestick-width + candlestick-up-color + candlestick-down-color + candlestick-line-width + candlestick-line-style + candlestick-alpha contour-samples contour-levels contour-colors diff -Nru racket-6.12+ppa1/share/pkgs/preprocessor/info.rkt racket-7.0+ppa1/share/pkgs/preprocessor/info.rkt --- racket-6.12+ppa1/share/pkgs/preprocessor/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/preprocessor/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "preprocessor") (define mzscheme-launcher-names (quote ("mzpp" "mztext"))) (define mzscheme-launcher-libraries (quote ("mzpp-run.rkt" "mztext-run.rkt"))) (define scribblings (quote (("scribblings/preprocessor.scrbl" (multi-page) (legacy))))) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "Preprocessors for text with embedded Racket code (mostly replaced by scribble/text)") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "preprocessor") (define mzscheme-launcher-names (quote ("mzpp" "mztext"))) (define mzscheme-launcher-libraries (quote ("mzpp-run.rkt" "mztext-run.rkt"))) (define scribblings (quote (("scribblings/preprocessor.scrbl" (multi-page) (legacy))))) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "Preprocessors for text with embedded Racket code (mostly replaced by scribble/text)") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/profile/info.rkt racket-7.0+ppa1/share/pkgs/profile/info.rkt --- racket-6.12+ppa1/share/pkgs/profile/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/profile/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("profile-lib" "profile-doc"))) (define implies (quote ("profile-lib" "profile-doc"))) (define pkg-desc "Libraries for statistical performance profiling") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("profile-lib" "profile-doc"))) (define implies (quote ("profile-lib" "profile-doc"))) (define pkg-desc "Libraries for statistical performance profiling") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/profile-doc/info.rkt racket-7.0+ppa1/share/pkgs/profile-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/profile-doc/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/profile-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("base" "scribble-lib" "profile-lib" "errortrace-doc" "errortrace-lib" "racket-doc"))) (define update-implies (quote ("profile-lib"))) (define pkg-desc "documentation part of \"profile\"") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("base" "scribble-lib" "profile-lib" "errortrace-doc" "errortrace-lib" "racket-doc"))) (define update-implies (quote ("profile-lib"))) (define pkg-desc "documentation part of \"profile\"") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/profile-doc/profile/scribblings/renderers.scrbl racket-7.0+ppa1/share/pkgs/profile-doc/profile/scribblings/renderers.scrbl --- racket-6.12+ppa1/share/pkgs/profile-doc/profile/scribblings/renderers.scrbl 2018-01-26 20:36:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/profile-doc/profile/scribblings/renderers.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -67,7 +67,7 @@ functions/expressions. (Corresponds to the @racket[node-self] field.)} @item{@tt{N5} --- this is the percentage of @tt{N4} out of the total observed time of the profile. Functions/expressions with high values here can - be good candidates for optimization, But, of course, they can + be good candidates for optimization. But, of course, they can represent doing real work for a caller that needs to be optimized.} @item{@tt{B} and @tt{C} --- these are labels for the callers and callees of the function/expression. Any number of callers and callees can diff -Nru racket-6.12+ppa1/share/pkgs/profile-lib/info.rkt racket-7.0+ppa1/share/pkgs/profile-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/profile-lib/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/profile-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "profile") (define deps (quote ("base" "errortrace-lib"))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"profile\"") (define pkg-authors (quote (eli stamourv))) (define raco-commands (quote (("profile" profile/raco "profile execution time" #f)))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "profile") (define deps (quote ("base" "errortrace-lib"))) (define build-deps (quote ("at-exp-lib" "rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"profile\"") (define pkg-authors (quote (eli stamourv))) (define raco-commands (quote (("profile" profile/raco "profile execution time" #f)))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/r5rs/info.rkt racket-7.0+ppa1/share/pkgs/r5rs/info.rkt --- racket-6.12+ppa1/share/pkgs/r5rs/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r5rs/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("r5rs-lib" "r5rs-doc"))) (define implies (quote ("r5rs-lib" "r5rs-doc"))) (define pkg-desc "Legacy R5RS (Scheme) language") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("r5rs-lib" "r5rs-doc"))) (define implies (quote ("r5rs-lib" "r5rs-doc"))) (define pkg-desc "Legacy R5RS (Scheme) language") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/r5rs-doc/info.rkt racket-7.0+ppa1/share/pkgs/r5rs-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/r5rs-doc/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r5rs-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "scribble-lib" "r5rs-lib" "compatibility-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("r5rs-lib"))) (define pkg-desc "documentation part of \"r5rs\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "scribble-lib" "r5rs-lib" "compatibility-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("r5rs-lib"))) (define pkg-desc "documentation part of \"r5rs\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/r5rs-lib/info.rkt racket-7.0+ppa1/share/pkgs/r5rs-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/r5rs-lib/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r5rs-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"r5rs\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"r5rs\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/r6rs/info.rkt racket-7.0+ppa1/share/pkgs/r6rs/info.rkt --- racket-6.12+ppa1/share/pkgs/r6rs/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r6rs/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("r6rs-lib" "r6rs-doc"))) (define implies (quote ("r6rs-lib" "r6rs-doc"))) (define pkg-desc "Legacy R6RS (Scheme) language") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("r6rs-lib" "r6rs-doc"))) (define implies (quote ("r6rs-lib" "r6rs-doc"))) (define pkg-desc "Legacy R6RS (Scheme) language") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/r6rs-doc/info.rkt racket-7.0+ppa1/share/pkgs/r6rs-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/r6rs-doc/info.rkt 2018-01-26 21:09:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r6rs-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("racket-index" "r5rs-doc" "base" "scribble-lib" "r6rs-lib" "racket-doc"))) (define update-implies (quote ("r6rs-lib"))) (define pkg-desc "documentation part of \"r6rs\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("racket-index" "r5rs-doc" "base" "scribble-lib" "r6rs-lib" "racket-doc"))) (define update-implies (quote ("r6rs-lib"))) (define pkg-desc "documentation part of \"r6rs\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/r6rs-lib/info.rkt racket-7.0+ppa1/share/pkgs/r6rs-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/r6rs-lib/info.rkt 2018-01-26 21:09:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/r6rs-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "r5rs-lib" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"r6rs\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "r5rs-lib" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"r6rs\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/racket-cheat/info.rkt racket-7.0+ppa1/share/pkgs/racket-cheat/info.rkt --- racket-6.12+ppa1/share/pkgs/racket-cheat/info.rkt 2018-01-26 21:09:10.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-cheat/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "racket-cheat") (define deps (quote ("base" "scribble-lib"))) (define build-deps (quote ("db-doc" "db-lib" "drracket" "net-doc" "net-lib" "parser-tools-doc" "parser-tools-lib" "pict-doc" "pict-lib" "racket-doc" "sandbox-lib" "slideshow-doc" "slideshow-lib"))) (define scribblings (quote (("racket-cheat.scrbl" () (getting-started))))) (define pkg-desc "a cheat sheet for Racket") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "racket-cheat") (define deps (quote ("base" "scribble-lib"))) (define build-deps (quote ("db-doc" "db-lib" "drracket" "net-doc" "net-lib" "parser-tools-doc" "parser-tools-lib" "pict-doc" "pict-lib" "racket-doc" "sandbox-lib" "slideshow-doc" "slideshow-lib"))) (define scribblings (quote (("racket-cheat.scrbl" () (getting-started))))) (define pkg-desc "a cheat sheet for Racket") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/info.rkt racket-7.0+ppa1/share/pkgs/racket-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/racket-doc/info.rkt 2018-01-26 21:09:10.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" ("base" #:version "6.5.0.2") "net-lib" "sandbox-lib" ("scribble-lib" #:version "1.14") "racket-index"))) (define build-deps (quote ("rackunit-doc" "compatibility" "errortrace-doc" "typed-racket-doc" "at-exp-lib" "rackunit-lib" "web-server-doc" "gui" "draw" "pict" "parser-tools-doc" "slideshow-doc" "r5rs-doc" "r6rs-doc" "xrepl" "readline" "syntax-color" "scribble-doc" "future-visualizer" "distributed-places" "serialize-cstruct-lib" "cext-lib" "data-doc" "net-doc" "planet-doc" "mzscheme-doc" "compiler-lib" "drracket" "math-doc" "math-lib"))) (define pkg-desc "Base Racket documentation") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" ("base" #:version "6.5.0.2") "net-lib" "sandbox-lib" ("scribble-lib" #:version "1.14") "racket-index"))) (define build-deps (quote ("rackunit-doc" "compatibility" "errortrace-doc" "typed-racket-doc" "at-exp-lib" "rackunit-lib" "web-server-doc" "gui" "draw" "pict" "parser-tools-doc" "slideshow-doc" "r5rs-doc" "r6rs-doc" "xrepl" "readline" "syntax-color" "scribble-doc" "future-visualizer" "distributed-places" "serialize-cstruct-lib" "cext-lib" "data-doc" "net-doc" "planet-doc" "mzscheme-doc" "compiler-lib" "drracket" "math-doc" "math-lib"))) (define pkg-desc "Base Racket documentation") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))))) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/json/json.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/json/json.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/json/json.scrbl 2018-01-26 20:34:14.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/json/json.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -64,7 +64,7 @@ [#:encode encode (or/c 'control 'all) 'control]) any]{ Writes the @racket[x] @tech{jsexpr}, encoded as JSON, to the - @racket[outp] output port. + @racket[out] output port. By default, only ASCII control characters are encoded as ``@tt{\uHHHH}''. If @racket[encode] is given as @racket['all], then diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/catalog-protocol.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -139,8 +139,8 @@ local but required for HTTP). The source for the PLT-hosted @tech{package catalog} is in the -@racket[(collection-file-path "pkg-catalog" "meta")] -directory of the full Racket distribution. +@hyperlink["https://pkgs.racket-lang.org/package/pkg-index"]{pkg-index} +package. @; ---------------------------------------- diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -25,14 +25,16 @@ @commandline{racket -l- pkg/dirs-catalog @nonterm{dest-catalog} @nonterm{dir} ...} -The @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and +The @DFlag{immediate}, @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and @DFlag{quiet} flags correspond to optional keyword arguments of @racket[create-dirs-catalog]. -@history[#:added "6.1.1.6"] +@history[#:added "6.1.1.6" + #:changed "6.90.0.4" @elem{Added @DFlag{immediate}.}] @defproc[(create-dirs-catalog [catalog-path path-string?] [dirs (listof path-string?)] + [#:immediate? immediate? any/c #f] [#:link? link? any/c #f] [#:merge? merge? any/c #f] [#:check-metadata? check-metadata? any/c #f] @@ -43,7 +45,9 @@ a catalog (see @secref["catalog-protocol"]) to list the packages that are contained in each directory specified by @racket[dirs]. Packages are discovered in @racket[dirs] as subdirectories that have an -@filepath{info.rkt} file. +@filepath{info.rkt} file; if @racket[immediate?] is true, then each +directory is @racket[dirs] is checked for an immediate @filepath{info.rkt} +file before checking subdirectories. If @racket[link?] is true, then the catalog specifies that the package should be installed as a directory link, as opposed to copies. @@ -56,4 +60,6 @@ catalog, @racket[create-dirs-catalog] looks for a @racket[pkg-authors] and @racket[pkg-desc] definition in each package's @filepath{info.rkt} file. If either definition is missing and @racket[check-metadata?] is -true, an error is reported.} +true, an error is reported. + +@history[#:changed "6.90.0.4" @elem{Added the @racket[#:immediate] argument.}]} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -707,6 +707,9 @@ To convert a clone-linked package to a normal installation, use @command-ref{update} either with the @DFlag{lookup} flag or with a replacement @tech{package source} that is not a package name.} +@item{@DFlag{unclone} --- An alias for @DFlag{lookup}, which (absent + @DFlag{clone}) has the effect of replacing a link to a repository + clone with a normal package installation.} @item{@DFlag{binary} --- Same as for @command-ref{install}.} @item{@DFlag{source} --- Same as for @command-ref{install}.} @item{@DFlag{scope} @nonterm{scope} --- Selects a @tech{package scope}, the same as for @command-ref{install}.} @@ -741,8 +744,9 @@ when no arguments are provided.} #:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag, and changed the @DFlag{deps} default to depend only on interactive mode.} - #:changed "6.1.1.8" @elem{Added the @DFlag{skip-uninstalled} and @DFlag{pull} flags.}] - #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}} + #:changed "6.1.1.8" @elem{Added the @DFlag{skip-uninstalled} and @DFlag{pull} flags.} + #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.} + #:changed "6.90.0.27" @elem{Added the @DFlag{unclone} flag.}]} @subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... --- Attempts to remove the given packages. By default, if a package is the dependency diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -439,7 +439,7 @@ There are a number of configuration issues relating to DCOM. See -@centerline{@link["http://www.distribucon.com/dcom95.aspx"]{http://www.distribucon.com/dcom95.html}} +@centerline{@link["https://web.archive.org/web/20061013184653/www.distribucon.com/dcom95.html"]{http://www.distribucon.com/dcom95.html}} for more information on how to setup client and server machines for DCOM. diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -240,7 +240,7 @@ @defproc[(windows-error [msg string?] [hresult exact-integer?]) any]{ -Raises an exception. The @racket[msg] strign provides the base error +Raises an exception. The @racket[msg] string provides the base error message, but @racket[hresult] and its human-readable interpretation (if available) are added to the message.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/derived.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/derived.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/derived.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/derived.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -17,6 +17,7 @@ @include-section["schedule.scrbl"] @include-section["port.scrbl"] @include-section["global.scrbl"] +@include-section["os-thread.scrbl"] @include-section["objc.scrbl"] @include-section["ns.scrbl"] @include-section["com.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/objc.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/objc.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/objc.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/objc.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -160,7 +160,8 @@ an Objective-C class or @racket[#f] for the superclass. An optional @racket[#:mixins] clause can specify mixins defined with @racket[define-objc-mixin]. An optional @racket[#:protocols] clause -can specify Objective-C protocols to be implemented by the class. +can specify Objective-C protocols to be implemented by the class, where +a @racket[#f] result for a @racket[protocol-expr] is ignored. Each @racket[field-id] is an instance field that holds a Racket value and that is initialized to @racket[#f] when the object is @@ -203,7 +204,10 @@ (- _void (dealloc) (when bm (done-with-bm bm)))) (void)) -]} +] + +@history[#:changed "6.90.0.26" @elem{Changed @racket[#:protocols] handling to + ignore @racket[#f] expression results.}]} @defform[(define-objc-mixin (class-id superclass-id) maybe-mixins diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,63 @@ +#lang scribble/doc +@(require "utils.rkt" + (for-label ffi/unsafe/os-thread)) + +@title{Operating System Threads} + +@defmodule[ffi/unsafe/os-thread]{The +@racketmodname[ffi/unsafe/os-thread] library provides functions for +running constrained Racket code in a separate thread at the +operating-system level. Except for @racket[os-thread-enabled?], the +functions of @racketmodname[ffi/unsafe/os-thread] are currently +supported only when @racket[(system-type 'vm)] returns +@racket['chez-scheme], and even then only in certain build modes. The +functions raise @racket[exn:fail:unsupported] when not supported.} + +@history[#:added "6.90.0.9"] + + +@defproc[(os-thread-enabled?) boolean?]{ + +Returns @racket[#t] if the other functions of +@racketmodname[ffi/unsafe/os-thread] work without raising +@racket[exn:fail:unsupported], @racket[#f] otherwise.} + + +@defproc[(call-in-os-thread [thunk (-> any)]) void?]{ + +Runs @racket[thunk] in a separate operating-system thread, which runs +concurrently to all Racket threads. + +The @racket[thunk] is run in @tech{atomic mode}, and it must not +inspect its continuation or use any Racket thread functions (such as +@racket[thread] or @racket[current-thread]), any Racket +synchronization functions (such as @racket[semaphore-post] or +@racket[sync]), or any parameters (such as +@racket[current-output-port]). Variables may be safely mutated with +@racket[set!], and vectors, mutable pairs, boxes, mutable structure +fields, and @racket[eq?]- and @racket[eqv?]-based hash tables can be +mutated, but the visibility of mutations to other threads is +unspecified except as synchronized through @racket[os-semaphore-wait] +and @racket[os-semaphore-post].} + + +@defproc[(make-os-semaphore) any]{ + +Creates a semaphore that can be used with @racket[os-semaphore-wait] +and @racket[os-semaphore-post] to synchronize an operating-system +thread with Racket threads and other operating-system threads.} + + +@defproc[(os-semaphore-post [sema any/c]) void?]{ + +Analogous to @racket[semaphore-post], but posts to a semaphore created +by @racket[make-os-semaphore].} + + +@defproc[(os-semaphore-wait [sema any/c]) void?]{ + +Analogous to @racket[semaphore-wait], but waits on a semaphore created +by @racket[make-os-semaphore]. Waiting blocks the current thread; if +the current thread is a Racket thread, then waiting also blocks all +Racket threads.} + diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -138,20 +138,9 @@ @defproc*[([(memmove [cptr cpointer?] + [offset exact-integer? 0] [src-cptr cpointer?] - [count exact-nonnegative-integer?] - [type ctype? _byte]) - void?] - [(memmove [cptr cpointer?] - [offset exact-integer?] - [src-cptr cpointer?] - [count exact-nonnegative-integer?] - [type ctype? _byte]) - void?] - [(memmove [cptr cpointer?] - [offset exact-integer?] - [src-cptr cpointer?] - [src-offset exact-integer?] + [src-offset exact-integer? 0] [count exact-nonnegative-integer?] [type ctype? _byte]) void?])]{ @@ -164,20 +153,9 @@ instances when supplied.} @defproc*[([(memcpy [cptr cpointer?] + [offset exact-integer? 0] [src-cptr cpointer?] - [count exact-nonnegative-integer?] - [type ctype? _byte]) - void?] - [(memcpy [cptr cpointer?] - [offset exact-integer?] - [src-cptr cpointer?] - [count exact-nonnegative-integer?] - [type ctype? _byte]) - void?] - [(memcpy [cptr cpointer?] - [offset exact-integer?] - [src-cptr cpointer?] - [src-offset exact-integer?] + [src-offset exact-integer? 0] [count exact-nonnegative-integer?] [type ctype? _byte]) void?])]{ @@ -186,12 +164,7 @@ and source overlap.} @defproc*[([(memset [cptr cpointer?] - [byte byte?] - [count exact-nonnegative-integer?] - [type ctype? _byte]) - void?] - [(memset [cptr cpointer?] - [offset exact-integer?] + [offset exact-integer? 0] [byte byte?] [count exact-nonnegative-integer?] [type ctype? _byte]) @@ -394,12 +367,13 @@ bytes?]{ Returns a byte string made of the given pointer and the given length. -No copying is done. This can be used as an alternative to make -pointer values accessible in Racket when the size is known. +No copying is performed. Beware that future implementations of Racket +may not support this function (in case of a byte string representation +that combines a size and byte-string content without an indirection). -Beware that the representation of a Racket byte string normally +Beware also that the representation of a Racket byte string normally requires a nul terminator at the end of the byte string (after -@racket[length] bytes), but some function work with a byte-string +@racket[length] bytes), but some functions work with a byte-string representation that has no such terminator---notably @racket[bytes-copy]. diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang scribble/doc @(require "utils.rkt" - (for-label ffi/unsafe/port)) + (for-label ffi/unsafe/port + racket/tcp)) @title{Ports} @@ -26,9 +27,10 @@ Returns an input port and/or output port for the given file descriptor or socket. On Windows, a ``file descriptor'' corresponds to a file -@tt{HANDLE}, while a socket corresponds to a @tt{SOCKET}. One Unix, a -socket is a file descriptor, but using socket-specific functions may -enable socket-specific functionality. +@tt{HANDLE}, while a socket corresponds to a @tt{SOCKET}. On Unix, a +socket is a file descriptor, but using the socket-specific +@racket[unsafe-socket->port] may enable socket-specific functionality, +such as address reporting via @racket[tcp-addresses]. The @racket[name] argument determines the port's name as reported by @racket[object-name]. The @racket[name] must be a UTF-8 encoding that diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -264,21 +264,16 @@ @subsection{Primitive String Types} -The five primitive string types correspond to cases where a C -representation matches Racket's representation without encodings. - -The form @racket[_bytes] form can be used type for Racket byte -strings, which corresponds to C's @cpp{char*} type. In addition to -translating byte strings, @racket[#f] corresponds to the @cpp{NULL} -pointer. +See also @racket[_bytes/nul-terminator] and @racket[_bytes] for +converting between byte strings and C's @cpp{char*} type. @deftogether[( @defthing[_string/ucs-4 ctype?] )]{ A type for Racket's native Unicode strings, which are in UCS-4 format. -These correspond to the C @cpp{mzchar*} type used by Racket. As usual, the types -treat @racket[#f] as @cpp{NULL} and vice versa.} +These correspond to the C @cpp{mzchar*} type used by Racket's C API. +As usual, the type treats @racket[#f] as @cpp{NULL} and vice versa.} @deftogether[( @@ -291,8 +286,9 @@ @defthing[_path ctype?]{ -Simple @cpp{char*} strings, corresponding to Racket's paths. As usual, -the types treat @racket[#f] as @cpp{NULL} and vice versa. +Simple @cpp{char*} strings, corresponding to Racket's @tech[#:doc +reference.scrbl]{path or string}. As usual, the type treats +@racket[#f] as @cpp{NULL} and vice versa. Beware that changing the current directory via @racket[current-directory] does not change the OS-level current @@ -331,7 +327,7 @@ @subsection{Variable Auto-Converting String Type} The @racket[_string/ucs-4] type is rarely useful when interacting with -foreign code, while using @racket[_bytes] is somewhat unnatural, since +foreign code, while using @racket[_bytes/nul-terminator] is somewhat unnatural, since it forces Racket programmers to use byte strings. Using @racket[_string/utf-8], etc., meanwhile, may prematurely commit to a particular encoding of strings as bytes. The @racket[_string] type @@ -476,6 +472,7 @@ [#:async-apply async-apply (or/c #f ((-> any/c) . -> . any/c) box?) #f] [#:lock-name lock-name (or/c string? #f) #f] [#:in-original-place? in-original-place? any/c #f] + [#:blocking? blocking? any/c #f] [#:save-errno save-errno (or/c #f 'posix 'windows) #f] [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) #f] @@ -554,6 +551,18 @@ place of the Racket code may have a different allocator than the original place.} + @item{If @racket[blocking?] is true, then a foreign @tech{callout} + deactivates tracking of the calling OS thread---to the degree + supported by the Racket variant---during the foreign call. The + value of @racket[blocking?] affects only the @tech[#:doc + guide.scrbl]{CS} variant of Racket, where it enable activity + such as garbage collection in other OS threads while the + @tech{callout} blocks. If the blocking @tech{callout} can + invoke any @tech{callbacks} back to Racket, those + @tech{callbacks} must be constructed with a non-@racket[#f] + value of @racket[async-apply], even if they are always applied + in the OS thread used to run Racket.} + @item{Values that are provided to a @tech{callout} (i.e., the underlying callout, and not the replacement produced by a @racket[wrapper], if any) are always considered reachable by the @@ -700,7 +709,8 @@ ] -@history[#:changed "6.3" @elem{Added the @racket[#:lock-name] argument.}]} +@history[#:changed "6.3" @elem{Added the @racket[#:lock-name] argument.} + #:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] argument.}]} @defform/subs[#:literals (->> :: :) (_fun fun-option ... maybe-args type-spec ... ->> type-spec @@ -712,6 +722,7 @@ (code:line #:async-apply async-apply-expr) (code:line #:lock-name lock-name-expr) (code:line #:in-original-place? in-original-place?-expr) + (code:line #:blocking? blocking?-expr) (code:line #:retry (retry-id [arg-id init-expr]))] [maybe-args code:blank (code:line formals ::)] @@ -739,7 +750,8 @@ See @racket[_cprocedure] for information about the @racket[#:abi], @racket[#:save-errno], @racket[#:keep], @racket[#:atomic?], -@racket[#:async-apply], and @racket[#:in-original-place?] options. +@racket[#:async-apply], @racket[#:in-original-place?], and +@racket[#:blocking] options. In its full form, the @racket[_fun] syntax provides an IDL-like language that creates a wrapper function around the @@ -831,7 +843,8 @@ ] @history[#:changed "6.2" @elem{Added the @racket[#:retry] option.} - #:changed "6.3" @elem{Added the @racket[#:lock-name] option.}]} + #:changed "6.3" @elem{Added the @racket[#:lock-name] option.} + #:changed "6.12.0.2" @elem{Added the @racket[#:blocking?] option.}]} @defproc[(function-ptr [ptr-or-proc (or cpointer? procedure?)] [fun-type ctype?]) @@ -1083,13 +1096,55 @@ [_bytes (_bytes o len-expr)]]{ -A @tech{custom function type} that can be used by itself as a simple -type for a byte string as a C pointer. Coercion of a C pointer to -simply @racket[_bytes] (without a specified length) requires that the pointer -refers to a nul-terminated byte string. When the length-specifying form is used -for a function argument, a byte string is allocated with the given -length, including an extra byte for the nul terminator.} +The @racket[_bytes] form by itself corresponds to C's @cpp{char*} +type; a byte string is passed as @racket[_bytes] without any +copying. In the current Racket implementation, a Racket byte string is +normally nul terminated implicitly, but a future implementation of +Racket may not include an implicit nul terminator for byte strings. +See also @racket[_bytes/nul-terminated]. + +In the current Racket implementation, as @racket[_bytes] result, a C +non-NULL @cpp{char*} is wrapped as a Racket byte string without +copying; future Racket implementations may require copying to +represent a C @cpp{char*} result as a Racket byte string. The C result +must have a nul terminator to determine the Racket byte string's +length. + +A @racket[(_bytes o len-expr)] form is a @tech{custom function type}. +As an argument, a byte string is allocated with the given length; in +the current Racket implementation, that byte string includes an extra +byte for the nul terminator (but, again, a future Racket +implementation may not behave that way). As a result, @racket[(_bytes +o len-expr)] wraps a C non-NULL @cpp{char*} pointer as a byte string of +the given length (but, again, a future Racket implementation may copy +the indicated number of bytes to a fresh byte string). + +As usual, @racket[_bytes] treats @racket[#f] as @cpp{NULL} and vice +versa. As a result type, @racket[(_bytes o len-expr)] works only for +non-NULL results.} + + +@defform*[#:id _bytes/nul-terminated + #:literals (o) + [_bytes/nul-terminated + (_bytes/nul-terminated o len-expr)]]{ + +The @racket[_bytes/nul-terminated] type is like @racket[_bytes], but +an explicit nul-terminator byte is added to a byte-string argument, +which implies copying. As a result type, a @cpp{char*} is copied to a +fresh byte string (without an explicit nul terminator). + +When @racket[(_bytes o len-expr)] is used as an argument type, a byte +string of length @racket[len-expr] is allocated. Similarly, when +@racket[(_bytes o len-expr)] is used as a result type, a @cpp{char*} +result is copied to a fresh byte string of length @racket[len-expr]. + +As usual, @racket[_bytes/nul-terminated] treats @racket[#f] as +@cpp{NULL} and vice versa. As a result type, +@racket[(_bytes/nul-terminated o len-expr)] works only for non-NULL +results. +@history[#:added "6.12.0.2"]} @; ------------------------------------------------------------ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/unexported.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/unexported.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/foreign/unexported.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/foreign/unexported.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -45,25 +45,47 @@ @defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?] [abi (or/c #f 'default 'stdcall 'sysv) #f] [save-errno? any/c] - [orig-place? any/c]) + [orig-place? any/c] + [lock-name (or/c #f string?) #f] + [blocking? any/c #f]) procedure?]{ -The primitive mechanism that creates Racket ``callout'' values for +The primitive mechanism that creates Racket @tech{callout} values for @racket[_cprocedure]. The given @racket[ptr] is wrapped in a Racket-callable primitive function that uses the types to specify how values are marshaled.} +@defproc[(ffi-call-maker [in-types (listof ctype?)] [out-type ctype?] + [abi (or/c #f 'default 'stdcall 'sysv) #f] + [save-errno? any/c] + [orig-place? any/c] + [lock-name (or/c #f string?) #f] + [blocking? any/c #f]) + (cpointer . -> . procedure?)]{ + +A curried variant of @racket[ffi-call] that takes the foreign-procedure pointer +separately.} -@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c] + +@defproc[(ffi-callback [proc procedure?] [in-types any/c] [out-type any/c] [abi (or/c #f 'default 'stdcall 'sysv) #f] [atomic? any/c #f] [async-apply (or/c #f ((-> any) . -> . any)) #f]) ffi-callback?]{ The symmetric counterpart of @racket[ffi-call]. It receives a Racket -procedure and creates a callback object, which can also be used as a +procedure and creates a @tech{callback} object, which can also be used as a C pointer.} +@defproc[(ffi-callback-maker [in-types any/c] [out-type any/c] + [abi (or/c #f 'default 'stdcall 'sysv) #f] + [atomic? any/c #f] + [async-apply (or/c #f ((-> any) . -> . any)) #f]) + (procedure? . -> . ffi-callback?)]{ + +A curried variant of @racket[ffi-callback] that takes the callback procedure +separately.} + @defproc[(ffi-callback? [x any/c]) boolean?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/getting-started/getting-started.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/getting-started/getting-started.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/getting-started/getting-started.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/getting-started/getting-started.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -33,9 +33,8 @@ @itemize[ - @item{@italic{@link["http://htdp.org/"]{How to Design Programs}} - is the best place to start. Whenever the book says ``Scheme,'' - you can read it as ``Racket.''} + @item{@italic{@link["http://htdp.org/"]{How to Design Programs, Second Edition}} + is the best place to start.} @item{@other-manual['(lib "web-server/scribblings/tutorial/continue.scrbl")] introduces you to modules and building web applications.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/concurrency.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/concurrency.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/concurrency.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/concurrency.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1,10 +1,11 @@ #lang scribble/doc @(require scribble/manual - scribble/eval + scribble/examples "guide-utils.rkt" - (for-label racket)) + (for-label racket racket/async-channel)) @(define concurrency-eval (make-base-eval)) +@(concurrency-eval '(require racket/contract racket/math)) @(define reference-doc '(lib "scribblings/reference/reference.scrbl")) @@ -268,7 +269,10 @@ threads to coordinate via @tech[#:doc reference-doc]{synchronizable events}. Many values double as events, allowing a uniform way to synchronize threads using different types. Examples of events include channels, ports, threads, -and alarms. +and alarms. This section builds up a number of examples that show how +the combination of events, threads, and @racket[sync] (along with recursive functions) +allow you to implement arbitrarily sophisticated communication protocols +to coordinate concurrent parts of a program. In the next example, a channel and an alarm are used as synchronizable events. The workers @racket[sync] on both so that they can process channel items until the @@ -445,3 +449,153 @@ @racket[sync]. At the same time, @racket[wrap-evt] disables break exceptions during its handler's invocation. +@section{Building Your Own Synchronization Patterns} + +Events also allow you to encode many different communication +patterns between multiple concurrent parts of a program. One +common such pattern is producer-consumer. Here is a way to +implement on variation on it using the above ideas. Generally +speaking, these communication patterns are implemented via +a server loops that uses @racket[sync] to wait for any of +a number of different possibilities to occur and then +reacts them, updating some local state. + +@examples[ + #:eval concurrency-eval + #:label #f + (eval:no-prompt + (define/contract (produce x) + (-> any/c void?) + (channel-put producer-chan x))) + + (eval:no-prompt + (define/contract (consume) + (-> any/c) + (channel-get consumer-chan))) + + (code:comment "private state and server loop") +(eval:no-prompt + (define producer-chan (make-channel)) + (define consumer-chan (make-channel)) + (void + (thread + (λ () + (code:comment "the items variable holds the items that") + (code:comment "have been produced but not yet consumed") + (let loop ([items '()]) + (sync + + (code:comment "wait for production") + (handle-evt + producer-chan + (λ (i) + (code:comment "if that event was chosen,") + (code:comment "we add an item to our list") + (code:comment "and go back around the loop") + (loop (cons i items)))) + + (code:comment "wait for consumption, but only") + (code:comment "if we have something to produce") + (handle-evt + (if (null? items) + never-evt + (channel-put-evt consumer-chan (car items))) + (λ (_) + (code:comment "if that event was chosen,") + (code:comment "we know that the first item item") + (code:comment "has been consumed; drop it and") + (code:comment "and go back around the loop") + (loop (cdr items)))))))))) + + (code:comment "an example (non-deterministic) interaction") + (void + (thread (λ () (sleep (/ (random 10) 100)) (produce 1))) + (thread (λ () (sleep (/ (random 10) 100)) (produce 2)))) + (list (consume) (consume)) + ] + +It is possible to build up more complex synchronization patterns. Here is +a silly example where we extend the producer consumer with an operation +to wait until at least a certain number of items have been produced. + +@examples[ + #:eval concurrency-eval + #:label #f + + (eval:no-prompt + (define/contract (produce x) + (-> any/c void?) + (channel-put producer-chan x)) + + (define/contract (consume) + (-> any/c) + (channel-get consumer-chan)) + + (define/contract (wait-at-least n) + (-> natural? void?) + (define c (make-channel)) + (code:comment "we send a new channel over to the") + (code:comment "main loop so that we can wait here") + (channel-put wait-at-least-chan (cons n c)) + (channel-get c))) + + (eval:no-prompt + (define producer-chan (make-channel)) + (define consumer-chan (make-channel)) + (define wait-at-least-chan (make-channel)) + (void + (thread + (λ () + (let loop ([items '()] + [total-items-seen 0] + [waiters '()]) + (code:comment "instead of waiting on just production/") + (code:comment "consumption now we wait to learn about") + (code:comment "threads that want to wait for a certain") + (code:comment "number of elements to be reached") + (apply + sync + (handle-evt + producer-chan + (λ (i) (loop (cons i items) + (+ total-items-seen 1) + waiters))) + (handle-evt + (if (null? items) + never-evt + (channel-put-evt consumer-chan (car items))) + (λ (_) (loop (cdr items) total-items-seen waiters))) + + (code:comment "wait for threads that are interested") + (code:comment "the number of items produced") + (handle-evt + wait-at-least-chan + (λ (waiter) (loop items total-items-seen (cons waiter waiters)))) + + (code:comment "for each thread that wants to wait,") + (for/list ([waiter (in-list waiters)]) + (code:comment "we check to see if there has been enough") + (code:comment "production") + (cond + [(>= (car waiter) total-items-seen) + (code:comment "if so, we send a mesage back on the channel") + (code:comment "and continue the loop without that item") + (handle-evt + (channel-put-evt + (cdr waiter) + (void)) + (λ (_) (loop items total-items-seen (remove waiter waiters))))] + [else + (code:comment "otherwise, we just ignore that one") + never-evt])))))))) + + (code:comment "an example (non-deterministic) interaction") + (define thds + (for/list ([i (in-range 10)]) + (thread (λ () + (produce i) + (wait-at-least 10) + (display (format "~a -> ~a\n" i (consume))))))) + (for ([thd (in-list thds)]) + (thread-wait thd)) + ] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/simple-function.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/simple-function.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/simple-function.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/simple-function.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -119,11 +119,13 @@ @racket[deposit]: @itemlist[#:style 'ordered - @item{Since the contract will always be checked on calls to @racket[deposit], - even inside the module in which it is defined, this may increase - the number of times the contract is checked. This could lead to + @item{The contract will be checked on any call to @racket[deposit] + that is outside of the definition of @racket[deposit] -- + even those inside the module in which it is defined. Because + there may be many calls inside the module, this checking may cause + the contract to be checked too often, which could lead to a performance degradation. This is especially true if the function - is called repeatedly in loops or using recursion.} + is called repeatedly from a loop.} @item{In some situations, a function may be written to accept a more lax set of inputs when called by other code in the same module. For such use cases, the contract boundary established by diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/distributed.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/distributed.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/distributed.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/distributed.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -41,7 +41,7 @@ assigned to the @racket[remote-node] variable. Localhost is used so that the example can be run using only a single machine. However localhost can be replaced by any host with ssh publickey access and racket. The -@racket[supervise-named-dynamic-place-at] creates a new place on the +@racket[supervise-place-at] creates a new place on the @racket[remote-node]. The new place will be identified in the future by its name symbol @racket['tuple-server]. A place descriptor is expected to be returned by invoking @racket[dynamic-place] with the @@ -51,7 +51,7 @@ The code for the tuple-server place exists in the file @filepath{tuple.rkt}. The @filepath{tuple.rkt} file contains the use of @racket[define-named-remote-server] form, which defines a RPC server -suitiable for invocation by @racket[supervise-named-dynamic-place-at]. +suitiable for invocation by @racket[supervise-place-at]. diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/macro-module.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/macro-module.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/macro-module.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/macro-module.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,447 @@ +#lang scribble/manual +@(require scribble/manual + scribble/examples + "guide-utils.rkt") + +@(define visit-eval (make-base-eval)) + +@examples[ +#:hidden +#:eval visit-eval +(current-pseudo-random-generator (make-pseudo-random-generator)) +;; Make the output deterministic: +(random-seed 11) +] + +@title[#:tag "macro-module"]{Module Instantiations and Visits} + +Modules often contain just function and structure-type definitions, in +which case the module itself behaves in a purely functional way, and +the time when the functions are created is not observable. If a +module's top-level expressions include side effects, however, then the +timing of the effects can matter. The distinction between module +declaration and @tech{instantiation} provides some control over that +timing. The concept of module @tech{visits} further explains the +interaction of effects with macro implementations. + +@; ---------------------------------------- +@section{Declaration versus Instantiation} + +Declaring a module does not immediately evaluate expressions in the +module's body. For example, evaluating + +@examples[ +#:label #f +#:eval visit-eval +(module number-n racket/base + (provide n) + (define n (random 10)) + (printf "picked ~a\n" n)) +] + +declares the module @racket[number-n], but it doesn't immediately pick a +random number for @racket[n] or display the number. A @racket[require] +of @racket[number-n] causes the module to be @deftech{instantiated} +(i.e., it triggers an @deftech{instantiation}), which implies that the +expressions in the body of the module are evaluated: + +@examples[ +#:label #f +#:eval visit-eval +(require 'number-n) +n +] + +After a module is instantiated in a particular @tech{namespace}, +further @racket[require]s of the module use the same instance, as +opposed to instantiating the module again: + +@examples[ +#:label #f +#:eval visit-eval +(require 'number-n) +n +(module use-n racket/base + (require 'number-n) + (printf "still ~a\n" n)) +(require 'use-n) +] + +The @racket[dynamic-require] function, like @racket[require], triggers +instantion of a module if it is not already instantiated, so +@racket[dynamic-require] with @racket[#f] as a second argument is +useful to just trigger the instantion effects of a module: + +@examples[ +#:label #f +#:eval visit-eval +(module use-n-again racket/base + (require 'number-n) + (printf "also still ~a\n" n)) +(dynamic-require ''use-n-again #f) +] + +Instantiation of modules by @racket[require] is transitive. That is, +if @racket[require] of a module instantiates it, then any module +@racket[require]d by that one is also instantiated (if it's not +instantiated already): + +@examples[ +#:label #f +#:eval visit-eval +(module number-m racket/base + (provide m) + (define m (random 10)) + (printf "picked ~a\n" m)) +(module use-m racket/base + (require 'number-m) + (printf "still ~a\n" m)) +(require 'use-m) +] + +@; ---------------------------------------- +@section[#:tag "compile-time-instantiation"]{Compile-Time Instantiation} + +In the same way that declaring a module does not by itself instantiate +a module, declaring a module that @racket[require]s another module +does not by itself instantiate the @racket[require]d module, as +illustrated in the preceding example. However, declaring a module +@emph{does} expand and compile the module. If a module imports another +with @racket[(require (for-syntax ....))], then module that is +imported @racket[for-syntax] must be instantiated during expansion: + +@examples[ +#:label #f +#:eval visit-eval +#:escape UNSYNTAX +(module number-p racket/base + (provide p) + (define p (random 10)) + (printf "picked ~a\n" p)) +(module use-p-at-compile-time racket/base + (require (for-syntax racket/base + 'number-p)) + (define-syntax (pm stx) + #`#,p) + (printf "was ~a at compile time\n" (pm))) +] + +Unlike run-time instantiation in a namespace, when a module is used +@racket[for-syntax] for another module expansion in the same +namespace, the @racket[for-syntax]ed module is instantiated separately +for each expansion. Continuing the previous example, if +@racket[number-p] is used a second time @racket[for-syntax], then a +second random number is selected for a new @racket[p]: + +@examples[ +#:label #f +#:eval visit-eval +#:escape UNSYNTAX +(module use-p-again-at-compile-time racket/base + (require (for-syntax racket/base + 'number-p)) + (define-syntax (pm stx) + #`#,p) + (printf "was ~a at second compile time\n" (pm))) +] + +Separate compile-time instantiations of @racket[number-p] helps +prevent accidental propagation of effects from one module's +compilation to another module's compilation. Preventing those effects +make compilation reliably separate and more deterministic. + +The expanded forms of @racket[use-p-at-compile-time] and +@racket[use-p-again-at-compile-time] record the number that was +selected each time, so those two different numbers are printed when the +modules are instantiated: + +@examples[ +#:label #f +#:eval visit-eval +(dynamic-require ''use-p-at-compile-time #f) +(dynamic-require ''use-p-again-at-compile-time #f) +] + +A namespace's top level behaves like a separate module, where multiple +interactions in the top level conceptually extend a single expansion +of the module. So, when using @racket[(require (for-syntax ....))] +twice in the top level, the second use does not trigger a new +compile-time instance: + +@examples[ +#:label #f +#:eval visit-eval +(begin (require (for-syntax 'number-p)) 'done) +(begin (require (for-syntax 'number-p)) 'done-again) +] + +However, a run-time instance of a module is kept separate from all +compile-time instances, including at the top level, so a +non-@racket[for-syntax] use of @racket[number-p] will pick another +random number: + +@examples[ +#:label #f +#:eval visit-eval +(require 'number-p) +] + +@; ---------------------------------------- +@section{Visiting Modules} + +When a module @racket[provide]s a macro for use by other modules, the +other modules use the macro by directly @racket[require]ing the macro +provider---i.e., without @racket[for-syntax]. That's because the macro +is being imported for use in a run-time position (even though the +macro's implementation lives at compile time), while +@racket[for-syntax] would import a binding for use in compile-time +position. + +The module implementing a macro, meanwhile, might @racket[require] +another module @racket[for-syntax] to implement the macro. The +@racket[for-syntax] module needs a compile-time instantiation during +any module expansion that might use the macro. That requirement sets +up a kind of transitivity through @racket[require] that is similar to +instantiation transitivity, but ``off by one'' at the point where the +@racket[for-syntax] shift occurs in the chain. + +Here's an example to make that scenario concrete: + +@examples[ +#:label #f +#:eval visit-eval +#:escape UNSYNTAX +(module number-q racket/base + (provide q) + (define q (random 10)) + (printf "picked ~a\n" q)) +(module use-q-at-compile-time racket/base + (require (for-syntax racket/base + 'number-q)) + (provide qm) + (define-syntax (qm stx) + #`#,q) + (printf "was ~a at compile time\n" (qm))) +(module use-qm racket/base + (require 'use-q-at-compile-time) + (printf "was ~a at second compile time\n" (qm))) +(dynamic-require ''use-qm #f) +] + +In this example, when @racket[use-q-at-compile-time] is expanded and +compiled, @racket[number-q] is instantiated once. In this case, that +instantion is needed to expand the @racket[(qm)] macro, but the module +system would proactively create a compile-time instantiation of +@racket[number-q] even if the @racket[qm] macro turned out not to be +used. + +Then, as @racket[use-qm] is expanded and compiled, a second +compile-time instantiation of @racket[number-q] is created. That +compile-time instantion is needed to expand the @racket[(qm)] form +within @racket[use-qm]. + +Instantiating @racket[use-qm] correctly reports the number that was +picked during that second module's compilation. First, though, the +@racket[require] of @racket[use-q-at-compile-time] in @racket[use-qm] +triggers a transitive instantiation of @racket[use-q-at-compile-time], +which correctly reports the number that was picked in its compilation. + +Overall, the example illustrates a transitive effect of +@racket[require] that we had already seen: + +@itemlist[ + + @item{When a module is @tech{instantiated}, the run-time expressions + in its body are evaluated.} + + @item{When a module is @tech{instantiated}, then any module that it @racket[require]s + (without @racket[for-syntax]) is also @tech{instantiated}.} + +] + +This rule does not explain the compile-time instantiations of +@racket[number-q], however. To explain that, we need a new word, +@deftech{visit}, for the concept that we saw in +@secref["compile-time-instantiation"]: + +@itemlist[ + +@item{When a module is @tech{visit}ed, the compile-time expressions + (such as macro definition) in its body are evaluated.} + +@item{As a module is expanded, it is @tech{visit}ed.} + +@item{When a module is @tech{visit}ed, then any module that it @racket[require]s + (without @racket[for-syntax]) is also @tech{visit}ed.} + +@item{When a module is @tech{visit}ed, then any module that it @racket[require]s + @racket[for-syntax] is @tech{instantiated} at compile time.} + +] + +Note that when visiting one module causes a compile-time instantion of +another module, the transitiveness of @tech{instantiated} through +regular @racket[require]s can trigger more compile-time instantiations. +Instantiation itself won't trigger further visits, however, because +any instantiated module has already been expanded and compiled. + +The compile-time expressions of a module that are evaluated by +@tech{visit}ing include both the right-hand sides of +@racket[define-syntax] forms and the body of @racket[begin-for-syntax] +forms. That's why a randomly selected number is printed immediately in +the following example: + +@examples[ +#:label #f +#:eval visit-eval +(module compile-time-number racket/base + (require (for-syntax racket/base)) + (begin-for-syntax + (printf "picked ~a\n" (random))) + (printf "running\n")) +] + +Instantiating the module evaluates only the run-time expressions, +which prints ``running'' but not a new random number: + +@examples[ +#:label #f +#:eval visit-eval +(dynamic-require ''compile-time-number #f) +] + +The description of @tech{instantiates} and @tech{visit} above is +phrased in terms of normal @racket[require]s and @racket[for-syntax] +@racket[require]s, but a more precise specification is in terms of +module phases. For example, if module @racket[_A] has @racket[(require +(for-syntax _B))] and module @racket[_B] has @racket[(require +(for-template _C))], then module @racket[_C] is @tech{instantiated} +when module @racket[_A] is instantiated, because the +@racket[for-syntax] and @racket[for-template] shifts cancel. We have +not yet specified what happens with @racket[for-meta 2] for when +@racket[for-syntax]es combine; we leave that to the next section, +@secref["stx-available-module"]. + +If you think of the top-level as a kind of module that is continuously +expanded, the above rules imply that @racket[require] of another +module at the top level both instantiates and visits the other module +(if it is not already instantiated and visited). That's roughly true, +but the visit is made lazy in a way that is also explained in the next +section, @secref["stx-available-module"]. + +Meanwhile, @racket[dynamic-require] only instantiates a module; it +does not visit the module. That simplification is why some of the +preceding examples use @racket[dynamic-require] instead of +@racket[require]. The extra visits of a top-level @racket[require] +would make the earlier examples less clear. + +@; ---------------------------------------- +@section[#:tag "stx-available-module"]{Lazy Visits via Available Modules} + +A top-level @racket[require] of a module does not actually +@tech{visit} the module. Instead, it makes the module +@deftech{available}. An @tech{available} module will be @tech{visit}ed +when a future expression needs to be expanded in the same context. The +next expression may or may not involve some imported macro that needs +its compile-time helpers evaluated by @tech{visit}ing, but the module +system proactively @tech{visit}s the module, just in case. + +In the following example, a random number is picked as a result of +visiting a module's own body while that module is being expanded. A +@racket[require] of the module instantiates it, printing ``running'', +and also makes the module @tech{available}. Evaluating any other +expression implies expanding the expression, and that expansion +triggers a @tech{visit} of the @tech{available} module---which picks +another random number: + +@examples[ +#:label #f +#:eval visit-eval +(module another-compile-time-number racket/base + (require (for-syntax racket/base)) + (begin-for-syntax + (printf "picked ~a\n" (random))) + (printf "running\n")) +(require 'another-compile-time-number) +'next +'another +] + +@margin-note{Beware that the expander flattens the content of a +top-level @racket[begin] into the top level as soon as the +@racket[begin] is discovered. So, @racket[(begin (require +'another-compile-time-number) 'next)] would still have printed +``picked'' before ``next``.} + +The final evaluation of @racket['another] also visits any available +modules, but no modules were made newly available by simply evaluating +@racket['next]. + +When a module @racket[require]s another module using @racket[for-meta +_n] for some @racket[_n] greater than 1, the @racket[require]d module +is made @tech{available} at phase @racket[_n]. A module that is +@tech{available} at phase @racket[_n] is @tech{visit}ed when some +expression at phase @math{@racket[_n]-1} is expanded. + +To help illustrate, the following examples use +@racket[(variable-reference->module-base-phase +(#%variable-reference))], which returns a number for the phase at +which the enclosing module is instantiated: + + +@examples[ +#:label #f +#:eval visit-eval +(module show-phase racket/base + (printf "running at ~a\n" + (variable-reference->module-base-phase (#%variable-reference)))) +(require 'show-phase) +(module use-at-phase-1 racket/base + (require (for-syntax 'show-phase))) +(module unused-at-phase-2 racket/base + (require (for-meta 2 'show-phase))) +] + +For the last module above, @racket[show-phase] is made +@tech{available} at phase 2, but no expressions within the module are +ever expanded at phase 1, so there's no phase-2 printout. The +following module includes a phase-1 expression after the phase-2 +@racket[require], so there's a printout: + +@examples[ +#:label #f +#:eval visit-eval +(module use-at-phase-2 racket/base + (require (for-meta 2 'show-phase) + (for-syntax racket/base)) + (define-syntax x 'ok)) +] + +If we @racket[require] the module @racket[use-at-phase-1] at the top +level, then @racket[show-phase] is made @tech{available} at phase 1. +Evaluating another expression causes @racket[use-at-phase-1] to be +@tech{visit}ed, which in turn instantitates @racket[show-phase]: + +@examples[ +#:label #f +#:eval visit-eval +(require 'use-at-phase-1) +'next +] + +A @racket[require] of @racket[use-at-phase-2] is similar, except that +@racket[show-phase] is made @tech{available} at phase 2, so it is not +instantiated until some expression is expanded at phase 1: + +@examples[ +#:label #f +#:eval visit-eval +(require 'use-at-phase-2) +'next +(require (for-syntax racket/base)) +(begin-for-syntax 'compile-time-next) +] + +@; ---------------------------------------------------------------------- + +@close-eval[visit-eval] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/macros.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/macros.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/macros.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/macros.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -15,11 +15,15 @@ use. Racket also supports arbitrary macro transformers that are implemented in Racket---or in a macro-extended variant of Racket. -(For a bottom-up introduction of Racket macro, you may refer to: @(hyperlink "http://www.greghendershott.com/fear-of-macros/" "Fear of Macros")) +This chapter provides an introduction to Racket macros, but see +@hyperlink["http://www.greghendershott.com/fear-of-macros/"]{@italic{Fear of +Macros}} for an introduction from a different perspective. @local-table-of-contents[] @;------------------------------------------------------------------------ @include-section["pattern-macros.scrbl"] @include-section["proc-macros.scrbl"] +@include-section["macro-module.scrbl"] + diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/module-macro.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/module-macro.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/module-macro.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/module-macro.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,78 @@ +#lang scribble/doc +@(require scribble/manual + scribble/example + "guide-utils.rkt") + +@(define noisy-eval (make-base-eval)) + +@title[#:tag "module-macro"]{Modules and Macros} + +Racket's module system cooperates closely with Racket's @tech{macro} +system for adding new syntactic forms to Racket. For example, in the +same way that importing @racketmodname[racket/base] introduces syntax +for @racket[require] and @racket[lambda], importing other modules can +introduce new syntactic forms (in addition to more traditional kinds +of imports, such as functions or constants). + +We introduce macros in more detail later, in @secref["macros"], but +here's a simple example of a module that defines a pattern-based +macro: + +@examples[ +#:eval noisy-eval +#:no-result +(module noisy racket + (provide define-noisy) + + (define-syntax-rule (define-noisy (id arg ...) body) + (define (id arg ...) + (show-arguments (quote id) (list arg ...)) + body)) + + (define (show-arguments name args) + (printf "calling ~s with arguments ~e" name args))) +] + +The @racket[define-noisy] binding provided by this module is a +@tech{macro} that acts like @racket[define] for a function, but it +causes each call to the function to print the arguments that are +provided to the function: + +@examples[ +#:label #f +#:eval noisy-eval +(require 'noisy) +(define-noisy (f x y) + (+ x y)) +(f 1 2) +] + +Roughly, the @racket[define-noisy] form works by replacing + +@racketblock[(define-noisy (f x y) + (+ x y))] + +with + +@racketblock[(define (f x y) + (show-arguments 'f (list x y)) + (+ x y))] + +Since @racket[show-arguments] isn't provided by the @racket[noisy] +module, however, this literal textual replacement is not quite right. +The actual replacement correctly tracks the origin of identifiers like +@racket[show-arguments], so they can refer to other definitions in the +place where the macro is defined---even if those identifiers are not +available at the place where the macro is used. + +There's more to the macro and module interaction than identifier +binding. The @racket[define-syntax-rule] form is itself a macro, and +it expands to compile-time code that implements the transformation +from @racket[define-noisy] into @racket[define]. The module system +keeps track of which code needs to run at compile and which needs to +run normally, as explained more in @secref["stx-phases"] and +@secref["macro-module"]. + +@; ---------------------------------------------------------------------- + +@close-eval[noisy-eval] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/modules.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/modules.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/modules.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/modules.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -15,3 +15,4 @@ @include-section["module-require.scrbl"] @include-section["module-provide.scrbl"] @include-section["module-set.scrbl"] +@include-section["module-macro.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/namespaces.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/namespaces.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/namespaces.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/namespaces.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -228,7 +228,8 @@ every identifier to an uninitialized top-level variable.} @item{A mapping from module names to module declarations and - instances.} + instances. (The distinction between declaration and instance is + discussed in @secref["macro-module"].)} ] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/other-editors.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/other-editors.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/other-editors.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/other-editors.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -60,7 +60,7 @@ does not provide support for Racket-specific forms.} @item{No Racket program is complete without documentation. Scribble - support for emacs is available with Neil Van Dyke's + support for Emacs is available with Neil Van Dyke's @hyperlink["http://www.neilvandyke.org/scribble-emacs/"]{Scribble Mode}. @@ -96,7 +96,7 @@ documentation in the minibuffer. While this mode was designed for @seclink["r5rs"]{@|r5rs|}, it - can still be useful for Racket development. That the tool is + can still be useful for Racket development. The tool is unaware of large portions of the Racket standard library, and there may be some discrepancies in the live documentation in cases where Scheme and Racket have diverged.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -419,13 +419,13 @@ @section[#:tag "gc-perf"]{Memory Management} -The Racket implementation is available in two variants: @deftech{3m} and -@deftech{CGC}. The @tech{3m} variant uses a modern, +The Racket implementation is available in three variants: @deftech{3m}, +@deftech{CGC}, and @deftech{CS}. The @tech{3m} and @tech{CS} variants use a modern, @deftech{generational garbage collector} that makes allocation relatively cheap for short-lived objects. The @tech{CGC} variant uses a @deftech{conservative garbage collector} which facilitates interaction with C code at the expense of both precision and speed for -Racket memory management. The 3m variant is the standard one. +Racket memory management. The @tech{3m} variant is currently the standard one. Although memory allocation is reasonably cheap, avoiding allocation altogether is normally faster. One particular place where allocation @@ -618,7 +618,7 @@ @racket[(collect-garbage 'incremental)] to initiate incremental mode from an optimal state. -To check whether incremental mode is use and how it affects pause +To check whether incremental mode is in use and how it affects pause times, enable @tt{debug}-level logging output for the @racketidfont{GC} topic. For example, diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/simple-syntax.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/simple-syntax.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/guide/simple-syntax.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/guide/simple-syntax.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -107,7 +107,7 @@ @defexamples[ #:eval ex-eval (define (bake flavor) - (printf "pre-heating oven...\n") + (printf "preheating oven...\n") (string-append flavor " pie")) (bake "apple") ] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/decompile.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/decompile.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/decompile.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/decompile.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -4,7 +4,7 @@ "common.rkt" (for-label racket/base compiler/decompile - (only-in compiler/zo-parse compilation-top? req) + (only-in compiler/zo-parse linkl-directory? linkl-bundle? linkl?) compiler/zo-marshal)) @title[#:tag "decompile"]{@exec{raco decompile}: Decompiling Bytecode} @@ -133,7 +133,7 @@ @defmodule[compiler/decompile] -@defproc[(decompile [top compilation-top?]) any/c]{ +@defproc[(decompile [top (or/c linkl-directory? linkl-bundle? linkl?)]) any/c]{ Consumes the result of parsing bytecode and returns an S-expression (as described above) that represents the compiled code.} @@ -148,11 +148,11 @@ @defmodule[compiler/zo-marshal] -@defproc[(zo-marshal-to [top compilation-top?] [out output-port?]) void?]{ +@defproc[(zo-marshal-to [top (or/c linkl-directory? linkl-bundle?)] [out output-port?]) void?]{ Consumes a representation of bytecode and writes it to @racket[out].} -@defproc[(zo-marshal [top compilation-top?]) bytes?]{ +@defproc[(zo-marshal [top (or/c linkl-directory? linkl-bundle?)]) bytes?]{ Consumes a representation of bytecode and generates a byte string for the marshaled bytecode.} @@ -160,4 +160,3 @@ @; ------------------------------------------------------------ @include-section["zo-struct.scrbl"] - diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/exe-api.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/exe-api.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/exe-api.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/exe-api.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -71,7 +71,7 @@ null] [#:gracket? gracket? any/c #f] [#:mred? mred? any/c #f] - [#:variant variant (or/c 'cgc '3m) + [#:variant variant (or/c 'cgc '3m 'cs) (system-type 'gc)] [#:aux aux (listof (cons/c symbol? any/c)) null] [#:collects-path collects-path @@ -251,6 +251,13 @@ original executable's path to DLLs is converted to an absolute path if it was relative.} + @item{@racket['embed-dlls?] (Windows) : A boolean indicating whether + to copy DLLs into the executable, where the default value is + @racket[#f]. Embedded DLLs are instantiated by an internal + linking step that bypasses some operating system facilities, + so it will not work for all Windows DLLs, but typical DLLs + will work as embedded.} + @item{@racket['subsystem] (Windows) : A symbol, either @racket['console] for a console application or @racket['windows] for a consoleless application; the default @@ -368,7 +375,10 @@ source, as long as the reader is referenced through an absolute module path. Each path given to @racket[extras-proc] corresponds to the actual file name (e.g., @filepath{.ss}/@filepath{.rkt} conversions -have been applied as needed to refer to the existing file).} +have been applied as needed to refer to the existing file). + +@history[#:changed "6.90.0.23" @elem{Added @racket[embed-dlls?] as an + @racket[#:aux] key.}]} @defproc[(make-embedding-executable [dest path-string?] @@ -384,7 +394,7 @@ [cmdline (listof string?)] [aux (listof (cons/c symbol? any/c)) null] [launcher? any/c #f] - [variant (one-of/c 'cgc '3m) (system-type 'gc)] + [variant (one-of/c 'cgc '3m'cs) (system-type 'gc)] [collects-path (or/c #f path-string? (listof path-string?)) @@ -477,9 +487,9 @@ @defproc[(find-exe [#:cross? cross? any/c #f] [#:untetherd? untethered? any/c #f] [gracket? any/c #f] - [variant (or/c 'cgc '3m) (if cross? - (cross-system-type 'gc) - (system-type 'gc))]) + [variant (or/c 'cgc '3m 'cs) (if cross? + (cross-system-type 'gc) + (system-type 'gc))]) path?]{ Finds the path to the @exec{racket} or @exec{gracket} (when diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/exe.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/exe.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/exe.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/exe.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -68,7 +68,7 @@ A stand-alone executable is ``stand-alone'' in the sense that you can run it without starting @exec{racket}, @exec{gracket}, or -DrRacket. However, the executable depends on Racket shared libraries, +DrRacket. However, the executable may depend on Racket shared libraries and possibly other run-time files declared via @racket[define-runtime-path]. The executable can be packaged with support libraries to create a distribution using @exec{raco @@ -95,6 +95,14 @@ are installed in user scope; use @exec{--exf -U} to enable access to user-scope packages from the launcher.} + @item{@DFlag{embed-dlls} --- On Windows, for a stand-alone executable, + copies any needed DLLs into the executable. Embedding DLLs makes + the resulting executable truly stand-alone if it does not depend on + other external files. Not all DLLs work with embedding, and + limitations are mostly related to thread-local storage and + resources, but all DLLs within the main Racket distribution work + with @DFlag{embed-dlls}.} + @item{@DFlag{config-path} @nonterm{path} --- set @nonterm{path} within the executable as the path to the @tech{configuration directory}; if the path is relative, it will be treated as relative @@ -146,6 +154,10 @@ variant of Racket, which is the default only when running a @exec{raco exe} that is based on the @gtech{CGC} variant.} + @item{@DFlag{cs} --- generate an executable based on the @gtech{cs} + variant of Racket, which is the default unless running a @exec{raco + exe} that is based on the @gtech{CS} variant.} + @item{@DPFlag{aux} @nonterm{file} --- attach information to the executable based on @nonterm{file}'s suffix; see @racket[extract-aux-from-path] for a list of recognized suffixes @@ -180,7 +192,8 @@ ] @history[#:changed "6.3.0.11" @elem{Added support for - @racketidfont{declare-preserve-for-embedding}.}] + @racketidfont{declare-preserve-for-embedding}.} + #:changed "6.90.0.23" @elem{Added @DFlag{embed-dlls}.}] @; ---------------------------------------------------------------------- diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/launcher.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/launcher.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/launcher.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/launcher.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -55,9 +55,9 @@ Racket or GRacket binary, like @exec{raco.exe}. No other @racket[aux] associations are used for an old-style launcher.} - @item{@racket['exe-name] (Mac OS, @racket['script-3m] or - @racket['script-cgc] variant) --- provides the base name for a - @racket['3m]-/@racket['cgc]-variant launcher, which the script + @item{@racket['exe-name] (Mac OS, @racket['script-3m], + @racket['script-cgc] or @racket['script-cs] variant) --- provides the base name for a + @racket['3m]-/@racket['cgc]-/@racket['cs]-variant launcher, which the script will call ignoring @racket[args]. If this name is not provided, the script will go through the GRacket executable as usual.} @@ -527,24 +527,24 @@ A parameter that indicates a variant of Racket or GRacket to use for launcher creation and for generating launcher names. The default is the result of @racket[(system-type 'gc)]. On Unix and Windows, the -possibilities are @racket['cgc] and @racket['3m]. On Mac OS, the -@racket['script-3m] and @racket['script-cgc] variants are also +possibilities are @racket['cgc], @racket['3m], and @racket['cs]. On Mac OS, the +@racket['script-cgc], @racket['script-3m], and @racket['script-cs] variants are also available for GRacket launchers.} @defproc[(available-gracket-variants) (listof symbol?)]{ Returns a list of symbols corresponding to available variants of GRacket in the current Racket installation. The list normally includes at -least one of @racket['3m] or @racket['cgc]--- whichever is the result -of @racket[(system-type 'gc)]---and may include the other, as well as -@racket['script-3m] and/or @racket['script-cgc] on Mac OS.} +least one of @racket['3m], @racket['cgc], or @racket['cs]--- whichever is the result +of @racket[(system-type 'gc)]---and may include the others, as well as +@racket['script-3m], @racket['script-cgc], and/or @racket['script-cs] on Mac OS.} @defproc[(available-racket-variants) (listof symbol?)]{ Returns a list of symbols corresponding to available variants of Racket in the current Racket installation. The list normally -includes at least one of @racket['3m] or @racket['cgc]---whichever is -the result of @racket[(system-type 'gc)]---and may include the other.} +includes at least one of @racket['3m], @racket['cgc], or @racket['cs]---whichever is +the result of @racket[(system-type 'gc)]---and may include the others.} @deftogether[( @defproc[(mred-launcher-up-to-date? [dest path-string?] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/make.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/make.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/make.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/make.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -301,7 +301,7 @@ @racketblock[ (struct compile-event (timestamp path type) #:prefab) ] -The @racket[timestamp] field is the time at which the event occured in +The @racket[timestamp] field is the time at which the event occurred in milliseconds since the epoch. The @racket[path] field is the path of a file being compiled for which the event is about. The @racket[type] field is a symbol which describes the action the event corresponds to. The currently logged values @@ -547,9 +547,9 @@ compilations of the same Racket source files in multiple places. } -@defproc[(install-module-hashes! [bstr btyes?] - [start exact-nonnegatve-integer? 0] - [end exact-nonnegatve-integer? (bytes-length bstr)]) +@defproc[(install-module-hashes! [bstr bytes?] + [start exact-nonnegative-integer? 0] + [end exact-nonnegative-integer? (bytes-length bstr)]) void?]{ Adjusts the bytecode representation in @racket[bstr] (from bytes @@ -600,7 +600,7 @@ @racket['done] as the @racket[_handler-type] argument for each successfully compiled file, @racket['output] when a successful compilation produces stdout/stderr output, @racket['error] when a -compilation error has occured, or @racket['fatal-error] when a unrecoverable +compilation error has occurred, or @racket['fatal-error] when a unrecoverable error occurs. The other arguments give more information for each status update. The return value is @racket[(void)] if it was successful, or @racket[#f] if there was an error. @@ -830,4 +830,23 @@ @(close-eval cm-eval) @; ---------------------------------------------------------------------- + @include-section["api.scrbl"] + +@; ---------------------------------------------------------------------- + +@section{API for Reading Compilation Dependencies} + +@defmodule[compiler/depend]{The @racketmodname[compiler/depend] module +provides a function to inspect and traverse the dependency information +generated by @exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm].} + +@history[#:added "6.90.0.13"] + +@defproc[(module-recorded-dependencies [module-file path?]) + (listof (and path? (complete-path? path?)))]{ + +Given a @racket[module-file] for a file that has been compiled with +@exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm], +returns a list of dependencies for @racket[module-file] by reading and +traversing dependency-information files left behind by compilation.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -286,6 +286,28 @@ location.} ]} +@item{Bootstrapping: +@itemize[ + + @item{@DFlag{boot} @nonterm{module-file} @nonterm{build-dir} --- For + use by directly running @racketmodname[setup] instead of + through @exec{raco setup}, loads @nonterm{module-file} in the + same way that @exec{raco setup} normally loads itself, + auto-detecting the need to start from sources and rebuild the + compiled files---even for the compilation manager itself. The + @nonterm{build-dir} path is installed as the only path in + @racket[current-compiled-file-roots], so all compiled files + go there.} + + @item{@DFlag{chain} @nonterm{module-file} @nonterm{build-dir} --- + Like @DFlag{boot}, but adds @nonterm{build-dir} to the start of + @racket[current-compiled-file-roots] instead of replacing the + current value, which means that libraries already built in the + normal location (including the compilation manager itself) will + be used instead of rebuilt. This mode makes sense for + cross-compilation.} + +]} ] @@ -1174,6 +1196,19 @@ } +@; ---------------------------------------- + +@subsection{Setup Start Module} + +@defmodule[setup]{The @racketmodname[setup] library implements +@exec{raco setup}, including the part that bootstraps @exec{raco setup} +if its own implementation needs to be compiled.} + +When running @racketmodname[setup] via @exec{racket}, supply the +@exec{@Flag{N} raco} to ensure that command-line arguments are parsed +the same way as for @exec{raco setup}, as opposed to a legacy +command-line mode. + @; ------------------------------------------------------------------------ @section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives} @@ -2019,7 +2054,7 @@ @history[#:added "6.3"] -@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'link 'machine +@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'vm 'link 'machine 'so-suffix 'so-mode 'fs-change) 'os]) (or/c symbol? string? bytes? exact-positive-integer? vector?)]{ @@ -2032,7 +2067,7 @@ See also @racket['cross] mode for @racket[system-type].} -@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m #f) +@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m 'cs #f) (system-type 'gc)]) path-for-some-system?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -16,19 +16,17 @@ @racketmodname[compiler/zo-structs] in addition to @racket[zo-parse]. -@defproc[(zo-parse [in input-port? (current-input-port)]) compilation-top?]{ +@defproc[(zo-parse [in input-port? (current-input-port)]) (or/c linkl-directory? linkl-bundle?)]{ Parses a port (typically the result of opening a @filepath{.zo} file) containing bytecode. Beware that the structure types used to represent the bytecode are subject to frequent changes across Racket versons. - The parsed bytecode is returned in a @racket[compilation-top] - structure. For a compiled module, the @racket[compilation-top] - structure will contain a @racket[mod] structure. For a top-level - sequence, it will normally contain a @racket[seq] or @racket[splice] - structure with a list of top-level declarations and expressions. + The parsed bytecode is returned in a @racket[linkl-directory] or + @racket[linkl-bundle] structure---the latter only for the compilation + of a module that contains no submodules. - The bytecode representation of an expression is closer to an + Within a linklet, the bytecode representation of an expression is closer to an S-expression than a traditional, flat control string. For example, an @racket[if] form is represented by a @racket[branch] structure that has three fields: a test expression, a ``then'' expression, and an @@ -67,20 +65,5 @@ bucket array in the same way that it captured and restores a local variable. Mutable local variables are boxed similarly to global variables, but individual boxes are referenced from the stack and - closures. + closures.} - Quoted syntax (in the sense of @racket[quote-syntax]) is treated like - a global variable, because it must be instantiated for an appropriate - phase. A @racket[prefix] structure within a @racket[compilation-top] - or @racket[mod] structure indicates the list of global variables and - quoted syntax that need to be instantiated (and put into an array on - the stack) before evaluating expressions that might use them.} - - -@defproc[(decode-module-binding [binding module-binding?] - [name symbol?]) - decoded-module-binding?]{ - -Given a compact-form representation of a module binding and the name -from which the binding is mapped, returns a normalized form of the -binding.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -34,96 +34,99 @@ @; -------------------------------------------------- @section{Prefix} -@defstruct+[(compilation-top zo) - ([max-let-depth exact-nonnegative-integer?] - [binding-namess (hash/c exact-nonnegative-integer? - (hash/c symbol? stx?))] - [prefix prefix?] - [code (or/c form? any/c)])]{ +@deftogether[( +@defstruct+[(linkl-directory zo) + ([table (hash/c (listof symbol?) linkl-bundle?)])] +@defstruct+[(linkl-bundle zo) + ([table (hash/c (or/c symbol? fixnum?) (or linkl? any/c))])] +)]{ Wraps compiled code. - The @racket[max-let-depth] field indicates the - maximum stack depth that @racket[code] creates (not counting the - @racket[prefix] array). - - The @racket[binding-namess] field provides a per-phase mapping from - symbols that appear in @racket[prefix] for top-level - @racket[def-values] forms and in top-level @racket[def-syntaxes] - forms. Each symbol is mapped to an identifier that will be bound - (after introduction into the namespace) by the definition. - - The @racket[prefix] field describes top-level variables, - module-level variables, and quoted syntax-objects accessed by - @racket[code]. - - The @racket[code] field contains executable code; it is normally a - @racket[form], but a literal value is represented as itself.} - -@defstruct+[(prefix zo) - ([num-lifts exact-nonnegative-integer?] - [toplevels (listof (or/c #f symbol? global-bucket? - module-variable?))] - [stxs (listof (or stx? #f))] - [src-inspector-desc symbol?])]{ - Represents a ``prefix'' that is pushed onto the stack to initiate - evaluation. The prefix is an array, where buckets holding the - values for @racket[toplevels] are first, then the buckets for the - @racket[stxs], then a bucket for another array if @racket[stxs] is - non-empty, then @racket[num-lifts] extra buckets for lifted local - procedures. - - In @racket[toplevels], each element is one of the following: - @itemize[ - @item{a @racket[#f], which indicates a dummy variable that is used - to access the enclosing module/namespace at run time;} - @item{a symbol, which is a reference to a variable defined in the - enclosing module;} - @item{a @racket[global-bucket], which is a top-level variable (appears - only outside of modules); or} - @item{a @racket[module-variable], which indicates a variable imported - from another module.} - ] - - The variable buckets and syntax objects that are recorded in a prefix - are accessed by @racket[toplevel] and @racket[topsyntax] expression - forms. - - When an element of @racket[stxs] is @racket[#f], it coresponds to a - syntax object that was optimized away at the last minute. The slot - must not be referenced by a @racket[topsyntax] form. - - The @racket[src-inspector-desc] field provides an inspector name that - is used within syntax-object bindings. At run time, the prefix gets - an inspector, and bindings that reference the same inspector name are - granted access capabilities through that inspector.} - -@defstruct+[(global-bucket zo) ([name symbol?])]{ - Represents a top-level variable, and used only in a - @racket[prefix]. Because modules cannot require top-level - variables, these will only appear in the top level - @racket[prefix]. Additionally, symbols in the top-level - prefix are an alias for @racket[global-bucket] structs, - making them redundant.} - -@defstruct+[(module-variable zo) - ([modidx module-path-index?] - [sym symbol?] - [pos exact-integer?] - [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed - function-shape? struct-shape?)])]{ - Represents a top-level variable, and used only in a @racket[prefix]. - The @racket[pos] may record the variable's offset within its module, - or it can be @racket[-1] if the variable is always located by name. - The @racket[phase] indicates the phase level of the definition within - its module. The @racket[constantness] field is either @racket['constant], - a @racket[function-shape] value, or a @racket[struct-shape] value - to indicate that - variable's value is always the same for every instantiation of its module; - @racket['fixed] to indicate - that it doesn't change within a particular instantiation of the module; - or @racket[#f] to indicate that the variable's value - can change even for one particular instantiation of its module.} + Module and top-level compilation produce one or more linklets that + represent independent evaluation in a specific phase. Even a single + top-level expression or a module with only run-time code will + generate multiple linklets to implement metadata and syntax data. A + module with no submodules is represented directly by a + @racket[linkl-bundle], while any other compiled form is represented + by a @racket[linkl-directory]. + + A linklet bundle maps an integer to a linklet representing forms to + evaluate at the integer-indicated phase. Symbols are mapped to + metadata, such as a module's name as compiled or a linklet + implementing literal syntax objects. A linklet directory normally + maps @racket['()] to the main linklet bundle for a module or a single + top-level form; for a linklet directory that corresponds to a + sequence of top-level forms, however, there is no ``main'' linklet + bundle, and symbol forms of integers are used to order the linkets. + + For a module with submodules, the linklet directory maps submodule + paths (as lists of symbols) to linklet bundles for the corresponding + submodules.} + +@defstruct+[(linkl zo) + ([name symbol?] + [importss (listof (listof symbol?))] + [import-shapess (listof (listof (or/c #f 'constant 'fixed + function-shape? + struct-shape?)))] + [exports (listof symbol?)] + [internals (listof (or/c symbol? #f))] + [lifts (listof symbol?)] + [source-names (hash/c symbol? symbol?)] + [body (listof (or/c form? any/c))] + [max-let-depth exact-nonnegative-integer?] + [need-instance-access? boolean?])]{ + + Represents a linklet, which corresponds to a module body or a + top-level sequence at a single phase. + + The @racket[name] of a linklet is for debugging purposes, similar to + the inferred name of a @racket[lambda] form. + + The @racket[importss] list of lists describes the linklet's imports. + Each of the elements of the out list corresponds to an import + source, and each element of an inner list is the symbolic name of an + export from that source. The @racket[import-shapess] list is in + parallel to @racket[imports]; it reflects optimization assumptions + by the compiler that are used by the bytecode validator and checked + when the linklet is instantiated. + + The @racket[exports] list describes the linklet's defined names that + are exported. The @racket[internals] list describes additional + definitions within the linket, but they are not accessible from the + outside of a linklet or one of its instances; a @racket[#f] can appear + in place of an unreferenced internal definition that has been removed. + The @racket[lifts] list + is an extension of @racket[internals] for procedures that are lifted + by the compiler; these procedures have certain properties that can be + checked by the bytecode validator. + + Each symbol in @racket[exports], + @racket[internals], and @racket[lifts] must be distinct from any + other symbol in those lists. The @racket[source-names] table maps + symbols in @racket[exports], @racket[internals], and @racket[lifts] + to other symbols, potentially not distinct, that correspond to + original source names for the definition. The @racket[source-names] + table is used only for debugging. + + When a linklet is instantiated, variables correponding to the + flattening of the lists @racket[importss], @racket[exports], + @racket[internals], and @racket[lifts] are placed in an array (in + that order) for access via @racket[toplevel] references. The initial + slot is reserved for a variable-like reference that strongly retains + a connection to an instance of its enclosing linklet. + + The @racket[bodys] list is the executable content of the linklet. The + value of the last element in @racket[bodys] may be returned when the + linklet is instantiated, depending on the way that it's instantiated. + + The @racket[max-let-depth] field indicates the maximum size of the + stack that will be created by any @racket[body]. + + The @racket[need-instance-access?] boolean indicates whether the + linklet contains a @racket[toplevel] for position 0. A @racket[#t] is + allowed (but suboptimal) if not such reference is present in the + linklet body.} @defstruct+[function-shape ([arity procedure-arity?] @@ -137,11 +140,11 @@ @deftogether[( @defstruct+[struct-shape ()] -@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] @defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])] -@defstruct+[(predicate-shape struct-shape) ()] -@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])] -@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(predicate-shape struct-shape) ([authentic? boolean?])] +@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] +@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] @defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])] @defstruct+[(property-predicate-shape struct-shape) ()] @defstruct+[(property-accessor-shape struct-shape) ()] @@ -151,15 +154,12 @@ Represents the shape of an expected import as a structure-type binding, constructor, etc.} -@defstruct+[(stx zo) ([content stx-obj?])]{ - Wraps a syntax object as it appears in a @racket[prefix].} - @; -------------------------------------------------- -@section{Forms} +@section{Forms and Inline Variants} @defstruct+[(form zo) ()]{ - A supertype for all forms that can appear in compiled code (including + A supertype for all forms that can appear in a linklet body (including @racket[expr]s), except for literals that are represented as themselves.} @@ -167,170 +167,24 @@ ([ids (listof toplevel?)] [rhs (or/c expr? seq? inline-variant? any/c)])]{ Represents a @racket[define-values] form. Each element of - @racket[ids] will reference via the prefix either a top-level variable - or a local module variable. + @racket[ids] references a defined variable in the enclosing linklet. After @racket[rhs] is evaluated, the stack is restored to its depth from before evaluating @racket[rhs].} -@deftogether[( -@defstruct+[(def-syntaxes form) ([ids (listof symbol?)] - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])] -@defstruct+[(seq-for-syntax form) - ([forms (listof (or/c form? any/c))] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])] -)]{ - Represents a @racket[define-syntaxes] or - @racket[begin-for-syntax] form. The @racket[rhs] expression or set of - @racket[forms] forms has its own @racket[prefix], which is pushed before evaluating - @racket[rhs] or the @racket[forms]; the stack is restored after obtaining the result values. - The @racket[max-let-depth] field indicates the maximum size of the - stack that will be created by @racket[rhs] (not counting - @racket[prefix]). The @racket[dummy] variable is used to access the enclosing - namespace.} - -@defstruct+[(req form) ([reqs stx?] - [dummy toplevel?])]{ - Represents a top-level @racket[#%require] form (but not one in a - @racket[module] form) with a sequence of specifications @racket[reqs]. - The @racket[dummy] variable is used to access the top-level - namespace.} - -@defstruct+[(seq form) ([forms (listof (or/c form? any/c))])]{ - Represents a @racket[begin] form, either as an expression or at the - top level (though the latter is more commonly a @racket[splice] form). - When a @racket[seq] appears in an expression position, its - @racket[forms] are expressions. - - After each form in @racket[forms] is evaluated, the stack is restored - to its depth from before evaluating the form.} - -@defstruct+[(splice form) ([forms (listof (or/c form? any/c))])]{ - Represents a top-level @racket[begin] form where each evaluation is - wrapped with a continuation prompt. - - After each form in @racket[forms] is evaluated, the stack is restored - to its depth from before evaluating the form.} - -@defstruct+[(inline-variant form) ([direct expr?] - [inline expr?])]{ +@defstruct+[(inline-variant zo) ([direct expr?] + [inline expr?])]{ Represents a function that is bound by @racket[define-values], where the function has two variants. The first variant is used for normal calls to the function. The second may be used for cross-module inlining of the function.} -@defstruct+[(mod form) - ([name (or/c symbol? (listof symbol?))] - [srcname symbol?] - [self-modidx module-path-index?] - [prefix prefix?] - [provides (listof (list/c (or/c exact-integer? #f) - (listof provided?) - (listof provided?)))] - [requires (listof (cons/c (or/c exact-integer? #f) - (listof module-path-index?)))] - [body (listof (or/c form? any/c))] - [syntax-bodies (listof (cons/c exact-positive-integer? - (listof (or/c def-syntaxes? - seq-for-syntax?))))] - [unexported (listof (list/c exact-nonnegative-integer? - (listof symbol?) - (listof symbol?)))] - [max-let-depth exact-nonnegative-integer?] - [dummy toplevel?] - [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx? (vectorof stx?))] - [binding-names (hash/c exact-integer? - (hash/c symbol? (or/c #t stx?)))] - [flags (listof (or/c 'cross-phase))] - [pre-submodules (listof mod?)] - [post-submodules (listof mod?)])]{ - Represents a @racket[module] declaration. - - The @racket[provides] and @racket[requires] lists are each an - association list from phases to exports or imports. In the case of - @racket[provides], each phase maps to two lists: one for exported - variables, and another for exported syntax. In the case of - @racket[requires], each phase maps to a list of imported module paths. - - The @racket[body] field contains the module's run-time (i.e., phase - 0) code. The @racket[syntax-bodies] list has a list of forms for - each higher phase in the module body; the phases are in order - starting with phase 1. The @racket[body] forms use @racket[prefix], - rather than any prefix in place for the module declaration itself, - while members of lists in @racket[syntax-bodies] have their own - prefixes. After each form in @racket[body] or @racket[syntax-bodies] - is evaluated, the stack is restored to its depth from before - evaluating the form. - - The @racket[unexported] list contains lists of symbols for - unexported definitions that can be accessed through macro expansion - and that are implemented through the forms in @racket[body] and - @racket[syntax-bodies]. Each list in @racket[unexported] starts - with a phase level. - - The @racket[max-let-depth] field indicates the maximum stack depth - created by @racket[body] forms (not counting the @racket[prefix] - array). - - The @racket[dummy] variable is used to access the top-level - namespace. - - The @racket[lang-info] value specifies an optional module path that - provides information about the module's implementation language. - - The @racket[internal-context] value describes the lexical context of - the body of the module. This value is used by - @racket[module->namespace]. A @racket[#f] value means that the - context is unavailable or empty. A @racket[#t] value means that the - context is computed by re-importing all required modules. A - syntax-object value embeds lexical information; the syntax object - should contain a vector of two elements, where the first element of - the vector is a syntax object for the module's body, which includes - the outside-edge and inside-edge scopes, and the second element of - the vector is a syntax object that has just the module's inside-edge - scope. - - The @racket[binding-names] value provides additional information to - @racket[module->namespace] to correlate symbol names for variables - and syntax definitions to identifiers that map to those variables. A - separate table of names exists for each phase, and a @racket[#t] - mapping for a name indicates that it is mapped but inaccessible - (because the relevant scopes are inaccessible). - - The @racket[flags] field records certain properties of the module. - The @racket['cross-phase] flag indicates that the module body is - evaluated once and the results shared across instances for all phases; such a - module contains only definitions of functions, structure types, and - structure type properties. - - The @racket[pre-submodules] field records @racket[module]-declared - submodules, while the @racket[post-submodules] field records - @racket[module*]-declared submodules.} - -@defstruct+[(provided zo) - ([name symbol?] - [src (or/c module-path-index? #f)] - [src-name symbol?] - [nom-src (or/c module-path-index? #f)] - [src-phase exact-nonnegative-integer?] - [protected? boolean?])]{ - Describes an individual provided identifier within a @racket[mod] - instance.} - @; -------------------------------------------------- @section{Expressions} @defstruct+[(expr form) ()]{ A supertype for all expression forms that can appear in compiled code, - except for literals that are represented as themselves and some - @racket[seq] structures (which can appear as an expression as long as - it contains only other things that can be expressions).} + except for literals that are represented as themselves.} @defstruct+[(lam expr) ([name (or/c symbol? vector?)] @@ -367,7 +221,7 @@ refers to a syntax-object constant, the variables and constants are represented in the closure by capturing a prefix (in the sense of @racket[prefix]). The @racket[toplevel-map] field indicates - which top-level and lifted variables are actually used by the + which top-level variables (i.e., linklet imports and definitions) are actually used by the closure (so that variables in a prefix can be pruned by the run-time system if they become unused) and whether any syntax objects are used (so that the syntax objects as a group can be similarly @@ -497,8 +351,8 @@ [pos exact-nonnegative-integer?] [const? boolean?] [ready? boolean?])]{ - Represents a reference to a top-level or imported variable via the - @racket[prefix] array. The @racket[depth] field indicates the number + Represents a reference to an imported or defined variable within + a linklet. The @racket[depth] field indicates the number of stack slots to skip to reach the prefix array, and @racket[pos] is the offset into the array. @@ -513,21 +367,11 @@ @racket[#f], then a check is needed to determine whether the variable is defined. - When the @racket[toplevel] is the right-hand side for - @racket[def-values], then @racket[const?] is @racket[#f]. If + When the @racket[toplevel] is the left-hand side for + @racket[def-values], then @racket[const?] is @racket[#f]. If @racket[ready?] is @racket[#t], the variable is marked as immutable after it is defined.} -@defstruct+[(topsyntax expr) - ([depth exact-nonnegative-integer?] - [pos exact-nonnegative-integer?] - [midpt exact-nonnegative-integer?])]{ - Represents a reference to a quoted syntax object via the - @racket[prefix] array. The @racket[depth] field indicates the number - of stack slots to skip to reach the prefix array, and @racket[pos] is - the offset into the array. The @racket[midpt] value is used - internally for lazy calculation of syntax information.} - @defstruct+[(application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])]{ @@ -556,6 +400,12 @@ restored to its depth from before evaluating @racket[key] or @racket[val].} +@defstruct+[(seq expr) ([forms (listof (or/c expr? any/c))])]{ + Represents a @racket[begin] form. + + After each form in @racket[forms] is evaluated, the stack is restored + to its depth from before evaluating the form.} + @defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? any/c))])]{ Represents a @racket[begin0] expression. @@ -566,14 +416,24 @@ @racket[seq] is never in tail position, even if it is the only expression in the list.} -@defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)] - [dummy (or/c toplevel? #f)])]{ - Represents a @racket[#%variable-reference] form. The @racket[toplevel] - field is @racket[#t] if the original reference was to a constant local - binding. The @racket[dummy] field +@defstruct+[(varref expr) ([toplevel (or/c toplevel? #t #f symbol?)] + [dummy (or/c toplevel? #f)] + [constant? boolean?] + [from-unsafe? boolean?])]{ + Represents a @racket[#%variable-reference] form. The + @racket[toplevel] field is @racket[#t] if the original reference was + to a constant local binding, @racket[#f] if the variable reference + is for @racket[(#%variable-reference)] and does not refer to a + specific variable, or a symbol if the variable reference refers to a + primitive variable. The @racket[dummy] field accesses a variable bucket that strongly references its namespace (as opposed to a normal variable bucket, which only weakly references its - namespace); it can be @racket[#f].} + namespace); it can be @racket[#f]. + + The value of @racket[constant?] is true when the @racket[toplevel] + field is not @racket[#t] but the referenced variable is known to be + constant. The value of @racket[from-unsafe?] is true when the module + that created the reference was compiled in unsafe mode.} @defstruct+[(assign expr) ([id toplevel?] @@ -616,210 +476,3 @@ Represents a direct reference to a variable imported from the run-time kernel.} -@; -------------------------------------------------- -@section{Syntax Objects} - -@defstruct+[(stx-obj zo) - ([datum any/c] - [wrap wrap?] - [srcloc (or/c #f srcloc?)] - [props (hash/c symbol? any/c)] - [tamper-status (or/c 'clean 'armed 'tainted)])]{ - Represents a syntax object, where @racket[wrap] contains lexical - information, @racket[srcloc] is the source location, - @racket[props] contains preserved properties, - and @racket[tamper-status] is taint information. When the - @racket[datum] part is itself compound, its pieces are wrapped - as @racket[stx-obj]s, too. - - The content of @racket[wrap] is typically cyclic, since it includes - scopes that contain bindings that refer to scopes.} - -@defstruct+[(wrap zo) ([shifts (listof module-shift?)] - [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])]{ - Lexical information for a syntax object. The @racket[shifts] field - allows binding information to be relative to the enclosing module's - run-time path. The @racket[simple-scopes] field records scopes that - are attached to the syntax object at all phases, and @racket[multi-scopes] - records phase-specific scopes (which are always attached as a group) - along with a phase shift for every scope within the group.} - -@defstruct+[(module-shift zo) ([from (or/c #f module-path-index?)] - [to (or/c #f module-path-index?)] - [from-inspector-desc (or/c #f symbol?)] - [to-inspector-desc (or/c #f symbol?)])]{ - -Records a history of module path index replacements. These replacements -are applied in reverse order, and a module instantiation typically adds -one more shift to replace the current ``self'' module path index -with a run-time module path. The @racket[from] and @racket[to] -fields should be both @racket[#f] or both non-@racket[#f]. - -The @racket[from-inspector-desc] and @racket[to-inspector-desc] fields -similarly should be both @racket[#f] or both non-@racket[#f]. They -record a history of code-inspector replacements.} - - -@defstruct+[(scope zo) ([name (or/c 'root exact-nonnegative-integer?)] - [kind symbol?] - [bindings (listof (list/c symbol? (listof scope?) binding?)) #;#:mutable] - [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #;#:mutable] - [multi-owner (or/c #f multi-scope?) #;#:mutable])]{ - -Represents a scope. When @racket[name] is @racket['root] then the -scope represents the unique all-phases scope that is shared among -non-module namespaces. Otherwise, @racket[name] is intended to be -distinct for each @racket[scope] instance within a module or top-level -compilation, but the @racket[eq?]-identity of the @racket[scope] -instance ultimately determines its identity. The @racket[kind] symbol -similarly acts as a debugging hint in the same way as for -@racket[syntax-debug-info]. - -The @racket[bindings] list indicates some bindings that are associated -with the scope. Each element of the list includes a symbolic name, a -list of scopes (including the enclosing one), and the binding for the -combination of name and scope set. A given symbol can appear in -multiple elements of @racket[bindings], but the combination of the -symbol and scope set are unique within @racket[bindings] and across -all scopes. The mapping of a symbol and scope set to a binding is -recorded with an arbitrary member of the scope set. - -The @racket[bulk-bindings] field lists bindings of all exports from a -given module, which is an optimization over including each export in -@racket[bindings]. Elements of @racket[bindings] take precedence over -elements of @racket[bulk-bindings], and earlier elements of -@racket[bulk-bindings] take precedence over later elements. - -If the @racket[scope] represents a scope at a particular phase for a -group of phase-specific scopes, @racket[mark-owner] refers to the -group.} - - -@defstruct+[(multi-scope zo) ([name exact-nonnegative-integer?] - [src-name any/c] - [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #;#:mutable])]{ - -Represents a set of phase-specific scopes that are added or removed -from lexical information as a group. As for @racket[scope], the -@racket[name] field is intended to be distinct for different groups, -but the @racket[eq?] identity of the @racket[multi-scope] record -ultimately determines its identity. The @racket[src-name] field -similarly acts as a debugging hint in the same way as for -@racket[syntax-debug-info]. - -Scopes within the group are instantiated at different phases on -demand. The @racket[scopes] field lists all of the scopes instantiated -for the group, and the phase at which it is instantiated. Each element -of @racket[scopes] must have a @racketidfont{multi-owner} field -value that refers back to the @racket[multi-scope].} - - -@defstruct+[(binding zo) ()]{ - -A supertype for all binding representations.} - - -@defstruct+[(module-binding binding) ([encoded any/c])]{ - -Represents a binding to a module or top-level definition. The -@racket[encoded] field can be unpacked using -@racket[decode-module-binding], providing the symbol name for which -the binding is the target (since @racket[encoded] can be relative to -that name).} - - -@defstruct+[(decoded-module-binding binding) ([path (or/c #f module-path-index?)] - [name symbol?] - [phase exact-integer?] - [nominal-path (or/c #f module-path-index?)] - [nominal-export-name symbol?] - [nominal-phase (or/c #f exact-integer?)] - [import-phase (or/c #f exact-integer?)] - [inspector-desc (or/c #f symbol?)])]{ - -Represents a binding to a module or top-level definition---like -@racket[module-binding], but in normalized form: - -@itemlist[ - - @item{@racket[path]: the referenced module.} - - @item{@racket[name]: the referenced definition within its module.} - - @item{@racket[phase]: the phase of the referenced definition within - its module.} - - @item{@racket[nominal-path]: the module that was explicitly imported - into the binding context; this path can be different from - @racket[path] when a definition is re-exported.} - - @item{@racket[nominal-export-name]: the name of the binding as - exported from @racket[nominal-path], which can be different from - @racket[name] due to renaming on export.} - - @item{@racket[nominal-phase]: the phase of the export from - @racket[nominal-path], which can be different from @racket[phase] - due to re-export from a module that imports at a phase level other - than @racket[0].} - - @item{@racket[import-phase]: the phase of the import of - @racket[nominal-path], which shifted (if non-@racket[0]) the - binding phase relative to the export phase from - @racket[nominal-path].} - - @item{@racket[inspector-desc]: a name for an inspector (mapped to a - specific inspector at run time) that determines access to the - definition.} - -]} - -@defstruct+[(local-binding binding) ([name symbol?])]{ - -Represents a local binding (i.e., not at the top level or module level). -Such bindings rarely appear in bytecode, since @racket[quote-syntax] -prunes them.} - - -@defstruct+[(free-id=?-binding binding) ([base (and/c binding? - (not/c free-id=?-binding?))] - [id stx-obj?] - [phase (or/c #f exact-integer?)])]{ - -Represents a binding that includes a @racket[free-identifier=?] alias -(to an identifier with a particular phase shift) as well as a base binding.} - - -@defstruct+[(all-from-module zo) ([path module-path-index?] - [phase (or/c exact-integer? #f)] - [src-phase (or/c exact-integer? #f)] - [inspector-desc symbol?] - [exceptions (listof symbol?)] - [prefix (or/c symbol? #f)])]{ - -Describes a bulk import as an optimization over individual imports of -a module's exports: - -@itemlist[ - - @item{@racket[path]: the imported module.} - - @item{@racket[phase]: the phase of the import module's exports.} - - @item{@racket[src-phase]: the phase at which @racket[path] was - imported; @racket[src-phase] combined with @racket[phase] - determines the phase of the bindings.} - - @item{@racket[inspector-desc]: a name for an inspector (mapped to a - specific inspector at run time) that determines access to the - definition.} - - @item{@racket[exceptions]: exports of @racket[path] that are omitted - from the bulk import.} - - @item{@racket[prefix]: a prefix, if any, applied (after - @racket[exceptions]) to each of the imported names.} - -]} - - diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/chaperones.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/chaperones.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/chaperones.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/chaperones.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -921,10 +921,15 @@ result of @racket[struct-type-make-constructor] on the chaperoned structure type. -The @racket[guard-proc] must accept as many argument as a constructor -for @racket[struct-type]; it must return the same number of arguments, -each the same or a chaperone of the corresponding argument. The -@racket[guard-proc] is added as a constructor guard when a subtype is +The @racket[guard-proc] is like a @racket[guard] argument to +@racket[make-struct-type]: it must accept one more argument +than a constructor for @racket[struct-type], where the last argument +is the name the name of the instantiated structure type. +It must return the number of values needed by the constructor +(i.e. one value for each argument but the last), +and each returned value must be the same as +or a chaperone of the corresponding argument. +The @racket[guard-proc] is added as a constructor guard when a subtype is created of the chaperoned structure type. Pairs of @racket[prop] and @racket[prop-val] (the number of arguments diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/code-inspectors.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/code-inspectors.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/code-inspectors.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/code-inspectors.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -57,5 +57,9 @@ @defparam[current-code-inspector insp inspector?]{ -A @tech{parameter} that determines an inspector to control access to module -bindings and redefinitions.} +A @tech{parameter} that determines an inspector to control access to +module bindings and redefinitions. + +If the code inspector is changed from its original value, then +bytecode loaded by the default @tech{compiled-load handler} is marked +as non-runnable.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -259,7 +259,7 @@ (first-or/c (-> number? number?) (-> string? string? string?))] accepts the function @racket[(λ args 0)], - applying the @racket[(->number? number?)] contract to the function + applying the @racket[(-> number? number?)] contract to the function because it comes first, even though @racket[(-> string? string? string?)] also applies. @@ -1990,13 +1990,16 @@ contract-expr pos-blame-party source-loc - name-for-blame) + name-for-blame + no-context) #:grammar ([pos-blame-party (code:line) (code:line #:pos-source pos-source-expr)] [source-loc (code:line) (code:line #:srcloc srcloc-expr)] [name-for-blame (code:line) - (code:line #:name-for-blame blame-id)])]{ + (code:line #:name-for-blame blame-id)] + [name-for-blame (code:line) + (code:line #:context-limit limit-expr)])]{ Defines @racket[id] to be @racket[orig-id], but with the contract @racket[contract-expr]. @@ -2019,7 +2022,10 @@ The name used in the error messages will be @racket[orig-id], unless @racket[#:name-for-blame] is supplied, in which case the identifier following it is used as the name in the error messages. - + + If @racket[#:context-limit] is supplied, it behaves the same as + it does when supplied to @racket[contract]. + @examples[#:eval (contract-eval) #:once (module server racket/base (require racket/contract/base) @@ -2035,7 +2041,8 @@ (eval:error (clients-fault)) (eval:error (servers-fault))] - @history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.}] + @history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.} + #:changed "6.90.0.29" @elem{Added the @racket[#:context-limit] argument.}] } @@ -2043,6 +2050,9 @@ positive-blame-expr negative-blame-expr) (contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr + #:context-limit limit-expr) + (contract contract-expr to-protect-expr + positive-blame-expr negative-blame-expr value-name-expr source-location-expr)]]{ The primitive mechanism for attaching a contract to a value. The @@ -2076,6 +2086,14 @@ structure, @tech{syntax object}, @racket[#f], or a list or vector in the format accepted by the third argument to @racket[datum->syntax]. + If @racket[#:context-limit] is supplied, the following expression + must evaluate to either @racket[#f] or a natural number. If + the expression evaluates to an natural number, the number of + layers of context information is limited to at most that + many. For example, if the number is @racket[0], no context + information is recorded and the error messages do not contain + the section that starts with @litchar{in:}. + } @; ------------------------------------------------------------------------ @@ -2110,6 +2128,9 @@ [#:stronger stronger (or/c #f (-> contract? contract? boolean?)) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:list-contract? is-list-contract? boolean? #f]) contract?] @defproc[(make-chaperone-contract @@ -2135,6 +2156,9 @@ [#:stronger stronger (or/c #f (-> contract? contract? boolean?)) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:list-contract? is-list-contract? boolean? #f]) chaperone-contract?] @defproc[(make-flat-contract @@ -2160,6 +2184,9 @@ [#:stronger stronger (or/c #f (-> contract? contract? boolean?)) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:list-contract? is-list-contract? boolean? #f]) flat-contract?] )]{ @@ -2206,7 +2233,7 @@ an extra layer of currying. At least one of the @racket[late-neg-proj], @racket[proj], - @racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. + @racket[val-first-proj], or @racket[test] must be non-@racket[#f]. The projection arguments (@racket[late-neg-proj], @racket[proj], and @racket[val-first-proj]) must be in sync with the @racket[test] argument. @@ -2235,6 +2262,9 @@ For @tech{impersonator contracts} constructed with @racket[make-contract] that do not supply the @racket[stronger] argument, @racket[contract-stronger?] returns @racket[#f]. +Similarly, the @racket[equivalent] argument is used to implement @racket[contract-equivalent?]. +If it isn't supplied or @racket[#false] is supplied, then @racket[equal?] is used +for chaperone and flat contracts, and @racket[(λ (x y) #f)] is used otherwise. The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate to determine if this is a contract that accepts only @racket[list?] values. @@ -2270,7 +2300,8 @@ (eval:error (halve 1)) ] -@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}] +@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.} + #:changed "6.90.0.30" @list{Added the @racket[#:equivalent] argument.}] } @defproc[(build-compound-type-name [c/s any/c] ...) any]{ @@ -2374,6 +2405,43 @@ @history[#:added "6.4.0.4"] } +@defform[(contract-pos/neg-doubling e1 e2)]{ + + Some contract combinators need to build projections for + subcontracts with both regular and @racket[blame-swap]ed + versions of the blame that they are given in order to check + both access and mutations (e.g., @racket[vector/c] and + @racket[vectorof]). In the case that such combinators are + nested deeply inside each other, there is a potential for an + exponential explosion of nested projections being built. + + To avoid that explosion, wrap each of the calls to the + blame-accepting portion of the combinator in + @racket[contract-pos/neg-doubling]. It returns three values. + The first is a boolean, indicating how to interpret the + other two results. If the boolean is @racket[#t], then the + other two results are the values of @racket[e1] and + @racket[e2] and we are not too deep in the nesting. If the + boolean is @racket[#f], then we have passed a threshold and + it is not safe to evaluate @racket[e1] and @racket[e2] yet, + as we are in danger of running into the exponential + slowdown. In that case, the last two results are thunks + that, when invoked, compute the values of @racket[e1] and + @racket[e2]. + + As an example, @racket[vectorof] uses + @racket[contract-pos/neg-doubling] wrapping its two calls to + the blame-accepting part of the projection for its + subcontract. When it receives a @racket[#f] as that first + boolean, it does not invoke the thunks right away, but waits + until the interposition procedure that it attaches to the + chaperoned vector is called. Then it invokes them (and caches + the result). This delays the construction of the projections + until they are actually needed, avoiding the exponential blowup. + + @history[#:added "6.90.0.27"] +} + @subsection{Blame Objects} This section describes @deftech{blame objects} and operations on them. @@ -2415,7 +2483,7 @@ the @racket[b] argument has been swapped or not (see @racket[blame-swap]). If @racket[fmt] contains the symbols @racket['given:] or @racket['expected:], -they are replaced like @racket['given:] and @racket['expected:] are, but +they are replaced like @racket['given] and @racket['expected] are, but the replacements are prefixed with the string @racket["\n "] to conform to the error message guidelines in @secref["err-msg-conventions"]. @@ -2459,15 +2527,21 @@ while adding the layer of context, but without creating an extra @|blame-object|. -The context information recorded in blame structs keeps track of -combinators that do not add information, and add the string @racket["..."] -for them, so programmers at least see that there was some context -they are missing in the error messages. Accordingly, since there are -combinators that should not add any context (e.g., @racket[recursive-contract]), -passing @racket[#f] as the context string argument avoids adding the -@racket["..."] string. + +Passing @racket[#f] as the context string argument is no longer relevant. +For backwards compatibility, @racket[blame-add-context] returns @racket[b] +when @racket[context] is @racket[#f]. + +@history[#:changed "6.90.0.29" @elem{The @racket[context] argument being + @racket[#f] is no longer relevant.}] } +@defproc[(blame-context [blame blame?]) (listof string?)]{ + Returns the context information that would be supplied in + an error message, if @racket[blame] is passed to @racket[raise-blame-error]. +} + + @deftogether[( @defproc[(blame-positive [b blame?]) any/c] @defproc[(blame-negative [b blame?]) any/c] @@ -2665,6 +2739,9 @@ stronger (or/c (-> contract? contract? boolean?) #f) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:generate generate (->i ([c contract?]) @@ -2708,6 +2785,9 @@ stronger (or/c (-> contract? contract? boolean?) #f) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:generate generate (->i ([c contract?]) @@ -2761,6 +2841,9 @@ stronger (or/c (-> contract? contract? boolean?) #f) #f] + [#:equivalent equivalent + (or/c #f (-> contract? contract? boolean?)) + #f] [#:generate generate (->i ([c contract?]) @@ -2782,7 +2865,7 @@ (λ (c) (λ (fuel) (values void '())))] [#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)]) contract-property?])]{ - + These functions build the arguments for @racket[prop:contract], @racket[prop:chaperone-contract], and @racket[prop:flat-contract], respectively. @@ -2793,14 +2876,19 @@ of a contract violation;} @item{@racket[get-first-order], which produces a first-order predicate to be used by @racket[contract-first-order-passes?];} - @item{@racket[get-late-neg-projection], which produces a blame-tracking projection + @item{@racket[late-neg-proj], which produces a blame-tracking projection defining the behavior of the contract (The @racket[get-projection] - and @racket[get-val-first-projection] arguments also specify the projection, + and @racket[val-first-proj] arguments also specify the projection, but using a different signature. They are here for backwards compatibility.);} @item{@racket[stronger], a predicate that determines whether this contract (passed in the first argument) is stronger than some other contract (passed in the second argument) and whose default always returns @racket[#f];} + @item{@racket[equivalent], a predicate that determines whether this + contract (passed in the first argument) is equivalent to some other + contract (passed in the second argument); the default for flat + and chaperone contracts is @racket[equal?] and for impersonator contracts + returns @racket[#f];} @item{@racket[generate], which returns a thunk that generates random values matching the contract (using @racket[contract-random-generate-fail]) to indicate failure) or @racket[#f] to indicate that random @@ -2813,8 +2901,8 @@ to determine if this contract accepts only @racket[list?]s.} ] -At least one of the @racket[late-neg-proj], @racket[proj], -@racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. +At least one of the @racket[late-neg-proj], @racket[get-projection], +@racket[val-first-proj], or @racket[get-first-order] must be non-@racket[#f]. These accessors are passed as (optional) keyword arguments to @racket[build-contract-property], and are applied to instances of the @@ -2841,7 +2929,9 @@ @history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.} #:changed "6.1.1.4" - @list{Allow @racket[generate] to return @racket[contract-random-generate-fail].}] + @list{Allow @racket[generate] to return @racket[contract-random-generate-fail].} + #:changed "6.90.0.30" + @list{Added the @racket[#:equivalent] argument.}] } @deftogether[( @@ -2958,7 +3048,7 @@ @defproc[(contract-stronger? [c1 contract?] [c2 contract?]) boolean?]{ Returns @racket[#t] if the contract @racket[c1] accepts either fewer - or the same number of values as @racket[c2] does. + or the same set of values that @racket[c2] does. @tech{Chaperone contracts} and @tech{flat contracts} that are the same (i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are @@ -2979,6 +3069,29 @@ } +@defproc[(contract-equivalent? [c1 contract?] [c2 contract?]) boolean?]{ + Returns @racket[#t] if the contract @racket[c1] accepts the same + set of values that @racket[c2] does. + + @tech{Chaperone contracts} and @tech{flat contracts} that are the same + (i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are + considered to always be equivalent to each other. + + This function is conservative, so it may return @racket[#f] when + @racket[c1] does, in fact, accept the same set of values that @racket[c2] does. + +@examples[#:eval (contract-eval) #:once + (contract-equivalent? integer? integer?) + (contract-equivalent? (non-empty-listof integer?) + (cons/c integer? (listof integer?))) + + (contract-equivalent? (λ (x) (and (real? x) (and (number? x) (>= (sqr x) 0)))) + (λ (x) (and (real? x) (real? x))))] + + + @history[#:added "6.90.0.30"] +} + @defproc[(contract-first-order-passes? [contract contract?] [v any/c]) boolean?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/data.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/data.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/data.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/data.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -119,6 +119,18 @@ Sets the content of @racket[box] to @racket[v].} +@deftogether[( +@defproc[(unbox* [box (and box? (not/c impersonator?))]) any/c] +@defproc[(set-box*! [box (and/c box? (not/c immutable?) (not/c impersonator?))] + [v any/c]) void?] +)]{ + +Like @racket[unbox] and @racket[set-box!], but constrained to work on +boxes that are not @tech{impersonators}. + +@history[#:added "6.90.0.15"]} + + @defproc[(box-cas! [box (and/c box? (not/c immutable?) (not/c impersonator?))] [old any/c] [new any/c]) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -205,7 +205,12 @@ handler}.} -@defparam[current-load-extension proc (path? (or/c symbol? #f) . -> . any)]{ +@defparam[current-load-extension proc (path? (or/c #f + symbol? + (cons/c (or/c #f symbol?) + (non-empty-listof symbol?))) + . -> . + any)]{ A @tech{parameter} that determines a @deftech{extension-load handler}, which is called by @racket[load-extension] and the default @tech{compiled-load diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/evts.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/evts.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/evts.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/evts.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -31,10 +31,18 @@ event's state. Racket values that act as @tech{synchronizable events} include -@tech{semaphores}, @tech{channels}, @tech{asynchronous channels}, -@tech{ports}, @tech{TCP listeners}, @tech{log receiver}s, @tech{threads}, -@tech{subprocess}es, @tech{will executors}, and @tech{custodian -box}es. Libraries can define new synchronizable events, especially +@tech{asynchronous channels}, +@tech{channels}, +@tech{custodian box}es, +@tech{log receivers}, +@tech{place channels}, +@tech{ports}, +@tech{semaphores}, +@tech{subprocess}es, +@tech{TCP listeners}, +@tech{threads}, and +@tech{will executors}. +Libraries can define new synchronizable events, especially though @racket[prop:evt]. @;------------------------------------------------------------------------ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -309,13 +309,39 @@ arguments, which are shown in the error message (using the error value conversion handler; see @racket[error-value->string-handler]); also, the number of supplied @racket[arg-v]s is explicitly mentioned in the -message.} +message. + +@examples[ +(eval:error (raise-arity-error 'unite (arity-at-least 13) "Virginia" "Maryland")) +]} + + +@defproc[(raise-result-arity-error [name (or/c symbol? #f)] + [arity-v exact-nonnegative-integer?] + [detail-str (or/c string? #f)] + [result-v any/c] ...) + any]{ + +Like @racket[raise-arity-error], but reports a ``result'' mismatch +instead of an ``argument'' mismatch. The @racket[name] argument can be +@racket[#f] to omit an initial source for the error. The +@racket[detail-str] argument, if non-@racket[#f], should be a string +that starts with a newline, since it is added near the end of the +generated error message. + +@examples[ +(eval:error (raise-result-arity-error 'let-values 2 "\n in: example" 'a 2.0 "three")) +] + +@history[#:added "6.90.0.26"]} + @defproc[(raise-syntax-error [name (or/c symbol? #f)] [message string?] [expr any/c #f] [sub-expr any/c #f] - [extra-sources (listof syntax?) null]) + [extra-sources (listof syntax?) null] + [message-suffix string? ""]) any]{ Creates an @racket[exn:fail:syntax] value and @racket[raise]s it as an @@ -366,7 +392,15 @@ @item{When @racket[name] is a symbol, then the symbol is used as the form name in the generated error message.} -]} +] + +The @racket[message-suffix] string is appended to the end of the error +message. If not @racket[""], it should normally start with a newline +and two spaces to add extra fields to the message (see +@secref["err-msg-conventions"]). + +@history[#:changed "6.90.0.18" @elem{Added the @racket[message-suffix] optional argument.}]} + @deftogether[( @defproc[(unquoted-printing-string? [v any/c]) boolean?] @@ -954,7 +988,10 @@ @item{@racket[span] --- The number of covered positions (counts from 0) or @racket[#f] (unknown).} -]} +] + +See @secref["print-compiled"] for information about the treatment of +@racket[srcloc] values that are embedded in compiled code.} @defproc[(srcloc->string [srcloc srcloc?]) (or/c string? #f)]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/extflonums.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/extflonums.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/extflonums.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/extflonums.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -22,9 +22,9 @@ A literal extflonum is written like an @tech{inexact number}, but using an explicit @litchar{t} or @litchar{T} exponent marker (see @secref["parse-extflonum"]). For example, @racket[3.5t0] is an -extflonum. The extflonum infinities and non-a-number values are -@as-index{@racket[+inf.t]}, @as-index{@racket[-inf.t]}, -and @as-index{@racket[+nan.t]}. +extflonum. The extflonum values for infinity are +@as-index{@racket[+inf.t]} and @as-index{@racket[-inf.t]}. The +extflonum value for not-a-number is @as-index{@racket[+nan.t]}. If @racket[(extflonum-available?)] produces @racket[#f], then all operations exported by @racketmodname[racket/extflonum] raise diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/fasl.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/fasl.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/fasl.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/fasl.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -9,33 +9,65 @@ @note-lib-only[racket/fasl] @deftogether[( -@defproc[(s-exp->fasl [v any/c] [out (or/c output-port? #f) #f]) (or/c (void) bytes?)] -@defproc[(fasl->s-exp [in (or/c input-port? bytes?)]) any/c] +@defproc[(s-exp->fasl [v any/c] + [out (or/c output-port? #f) #f] + [#:keep-mutable? keep-mutable? any/c #f]) + (or/c (void) bytes?)] +@defproc[(fasl->s-exp [in (or/c input-port? bytes?)] + [#:datum-intern? datum-intern? any/c #t]) + any/c] )]{ The @racket[s-exp->fasl] function serializes @racket[v] to a byte string, printing it directly to @racket[out] if @racket[out] is an -output port or return the byte string otherwise. The +output port or returning the byte string otherwise. The @racket[fasl->s-exp] function decodes a value from a byte string (supplied either directly or as an input port) that was encoded with @racket[s-exp->fasl]. The @racket[v] argument must be a value that could be @racket[quote]d -as a literal, because @racket[s-exp->fasl] essentially uses -@racket[(compile `(quote ,v))] to encode the value using Racket's -built-in fast-load format for bytecode. - -The byte-string encoding produced by @racket[s-exp->fasl] is specific -to a version of Racket. That is, the resulting byte string can be -decoded back to @racket[v] only using the same version with which it -was encoded. +as a literal---that is, a value without syntax objects for which +@racket[(compile `(quote ,v))] +would work and be @racket[read]able after @racket[write]. The +byte string produced by @racket[s-exp->fasl] does not use the same +format as compiled code, however. + +Like @racket[(compile `(quote ,v))], @racket[s-exp->fasl] does not +preserve graph structure, support cycles, or handle non-@tech{prefab} +structures. Compose @racket[s-exp->fasl] with @racket[serialize] to +preserve graph structure, handle cyclic data, and encode serializable +structures. The @racket[s-exp->fasl] and @racket[fasl->s-exp] +functions consult @racket[current-write-relative-directory] and +@racket[current-load-relative-directory], respectively, in the same +way as bytecode saving and loading to store paths in relative form, +and they similarly allow and convert constrained @racket[srcloc] +values (see @secref["print-compiled"]). + +Unless @racket[keep-mutable?] is provided as true to +@racket[s-exp->fasl], then mutable values in @racket[v] are replaced +by immutable values when the result is decoded by +@racket[fasl->s-exp]. Unless @racket[datum-intern?] is provided as +@racket[#f], then any immutable value produced by @racket[fasl->s-exp] +is filtered by @racket[datum-intern-literal]. The defaults make the +composition of @racket[s-exp->fasl] and @racket[fasl->s-exp] behave +like the composition of @racket[write] and @racket[read]. + +The byte-string encoding produced by @racket[s-exp->fasl] is +independent of the Racket version, except as future Racket versions +introduce extensions that are not currently recognized. In particular, +the result of @racket[s-exp->fasl] will be valid as input to any +future version of @racket[s-exp->fasl]. @mz-examples[ #:eval fasl-eval (define fasl (s-exp->fasl (list #("speed") 'racer #\!))) fasl (fasl->s-exp fasl) -]} +] + +@history[#:changed "6.90.0.21" @elem{Made @racket[s-exp->fasl] format version-independent + and added the @racket[#:keep-mutable?] + and @racket[#:datum-intern?] arguments.}]} @; ---------------------------------------------------------------------- diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/filesystem.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/filesystem.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/filesystem.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/filesystem.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -303,6 +303,16 @@ On Windows, @racket[delete-file] can delete a symbolic link, but not a junction. Use @racket[delete-directory] to delete a junction. +On Windows, beware that if a file is deleted while it remains in use +by some process (e.g., a background search indexer), then the file's +content will eventually go away, but the file's name remains occupied +until the file is no longer used. As long as the name remains +occupied, attempts to open, delete, or replace the file will trigger a +permission error (as opposed to a file-exists error). A common +technique to avoid this pitfall is to move the file to a generated +temporary name before deleting it. See also +@racket[delete-directory/files]. + @history[#:changed "6.1.1.7" @elem{Changed Windows behavior to use @racket[current-force-delete-permissions].}]} @@ -332,7 +342,16 @@ If @racket[old] is a link, the link is renamed rather than the destination of the link, and it counts as a file for replacing any -existing @racket[new].} +existing @racket[new]. + +On Windows, beware that a directory cannot be renamed if any file +within the directory is open. That constraint is particularly +problematic if a search indexer is running in the background (as in +the default Windows configuration). A possible workaround is to +combine @racket[copy-directory/files] and +@racket[delete-directory/files], since the latter can deal with open +files, although that sequence is obviously not atomic and temporarily +duplicates files.} @defproc*[([(file-or-directory-modify-seconds [path path-string?] @@ -638,7 +657,7 @@ void?]{ Causes @racket[evt] to become immediately @tech{ready for -synchronization}, whether it was ready or before not, and releases and +synchronization}, whether it was ready or not before, and releases the resources (at the operating-system level) for tracking filesystem changes.} @@ -1001,7 +1020,17 @@ false, then @racket[delete-directory/files] succeeds if @racket[path] does not exist (but a failure is possible if @racket[path] initially exists and is removed by another thread or process before -@racket[delete-directory/files] deletes it).} +@racket[delete-directory/files] deletes it). + +On Windows, @racket[delete-directory/files] attempts to move a file +into the temporary-file directory before deleting it, which avoids +problems caused by deleting a file that is currently open (e.g., by a +search indexer running as a background process). If the move attempt +fails (e.g., because the temporary directory is on a different drive +than the file), then the file is deleted directly with +@racket[delete-file]. + +@history[#:changed "7.0" @elem{Added Windows-specific file deletion.}]} @defproc[(find-files [predicate (path? . -> . any/c)] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/for.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/for.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/for.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/for.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -349,7 +349,7 @@ [else (values (cons x acc) (hash-set seen x #t))])) ] -@history[#:changed "6.11.0.1" @elem{Added the @racket[#:result] form.}]} +@history[#:changed "6.11.0.1" @elem{Added the @racket[#:result] form.}] } @defform[(for* (for-clause ...) body-or-break ... body)]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,468 @@ +#lang scribble/doc +@(require "mz.rkt" + (for-label racket/linklet + racket/unsafe/ops)) + +@title[#:tag "linklets"]{Linklets and the Core Compiler} + +@defmodule[racket/linklet] + +A @deftech{linklet} is a primitive element of compilation, bytecode +marshaling, and evaluation. Racket's implementations of modules, +macros, and top-level evaluation are all built on linklets. Racket +programmers generally do not encounter linklets directly, but the +@racketmodname[racket/linklet] library provides access to linklet +facilities. + +A single Racket module (or collection of top-level forms) is typically +implemented by multiple linklets. For example, each phase of +evaluation that exists in a module is implemented in a separate +linklet. A linklet is also used for metadata such as the @tech{module +path index}es for a module's @racket[require]s. These linklets, plus +some other metadata, are combined to form a @deftech{linklet bundle}. +Information in a @tech{linklet bundle} is keyed by either a symbol or +a @tech{fixnum}. A @tech{linklet directory} containing +@tech{linklet}s can be marshaled to and from a byte stream by +@racket[write] and (with @racket[read-accept-compiled] is enabled) +@racket[read]. + +When a Racket module has submodules, the @tech{linklet bundles} for +the module and the submodules are grouped together in a +@deftech{linklet directory}. A @tech{linklet directory} can have +nested linklet directories. Information in a linklet directory is +keyed by @racket[#f] or a symbol, where @racket[#f] must be mapped to +a @tech{linklet bundle} (if anything) and each symbol must be mapped +to a @tech{linklet directory}. A @tech{linklet directory} can be +equivalently viewed as a mapping from a lists of symbols to a +@tech{linklet bundle}. Like @tech{linklet bundles}, a @tech{linklet +directory} can be marshaled to and from a byte stream by +@racket[write] and @racket[read]; the marshaled form allows individual +@tech{linklet bundles} to be loaded independently. + +A linklet consists of a set of variable definitions and expressions, +an exported subset of the defined variable names, a set of variables to export +from the linklet despite having no corresponding definition, and a set +of imports that provide other variables for the linklet to use. To run +a linklet, it is instantiated as as @deftech{linklet instance} (or +just @defterm{instance}, for short). When a linklet is instantiated, +it receives other @tech{linklet instances} for its imports, and it +extracts a specified set of variables that are exported from each of +the given instances. The newly created @tech{linklet instance} +provides its exported variables for use by other linklets or for +direct access via @racket[instance-variable-value]. A @tech{linklet +instance} can be synthesized directly with @racket[make-instance]. + +A linklet is created by compiling an enriched S-expression +representation of its source. Since linklets exist below the layer of +macros and syntax objects, linklet compilation does not use +@tech{syntax objects}. Instead, linklet compilation uses +@deftech{correlated objects}, which are like @tech{syntax objects} +without lexical-context information and without the constraint that +content is coerced to correlated objects. Using an S-expression or +@tech{correlated object}, the grammar of a linklet as recognized by +@racket[compile-linklet] is + +@specform[(linklet [[imported-id/renamed ...] ...] + [exported-id/renamed ...] + defn-or-expr ...) + #:grammar + ([imported-id/renamed imported-id + (external-imported-id internal-imported-id)] + [exported-id/renamed exported-id + (internal-exported-id external-exported-id)])] + +Each import set @racket[[_imported-id/renamed ...]] refers to a single +imported instance, and each @racket[_import-id/renamed] corresponds to +a variable from that instance. If separate +@racket[_external-imported-id] and @racket[_internal-imported-id] are +specified, then @racket[_external-imported-id] is the name of the +variable as exported by the instance, and +@racket[_internal-imported-id] is the name used to refer to the +variable in the @racket[_defn-or-expr]s. For exports, separate +@racket[_internal-exported-id] and @racket[_external-exported-id] +names corresponds to the variable name as exported as referenced +in the @racket[_defn-or-expr]s, respectively. + +The grammar of an @racket[_defn-or-expr] is similar to the expander's +grammar of fully expanded expressions (see @secref["fully-expanded"]) +with some exceptions: @racket[quote-syntax] and @racket[#%top] are not allowed; +@racket[#%plain-lambda] is spelled @racket[lambda]; +@racket[#%plain-app] is omitted (i.e., application is implicit); +@racket[lambda], @racket[case-lambda], @racket[let-values], and +@racket[letrec-values] can have only a single body expression; and +numbers, booleans, strings, and byte strings are self-quoting. +Primitives are accessed directly by name, and shadowing is not allowed +within a @racketidfont{linklet} form for primitive names, imported +variables, defined variables, or local variables. + +When a @racket[_exported-id/renamed] has no corresponding definition +among the @racket[_defn-or-expr]s, then the variable is effectively +defined as uninitialized; referencing the variable will trigger +@racket[exn:fail:contract:variable], the same as referencing a +variable before it is defined. When a target instance is provided to +@racket[instantiate-linklet], any existing variable with the same name +will be left as-is, instead of set to undefined. This treatment of +uninitialized variables provides core support for top-level evaluation +where variables may be referenced and then defined in a separate +element of compilation. + +@history[#:added "6.6.1"] + +@; -------------------------------------------------- + +@defproc[(linklet? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet}, @racket[#f] +otherwise.} + + +@defproc*[([(compile-linklet [form (or/c correlated? any/c)] + [name any/c #f] + [import-keys #f #f] + [get-import #f #f] + [options (listof (or/c 'serializable 'unsafe 'static)) '(serializable)]) + linklet?] + [(compile-linklet [form (or/c correlated? any/c)] + [name any/c] + [import-keys vector?] + [get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f) + (or/c vector? #f)))) + #f] + [options (listof (or/c 'serializable 'unsafe 'static)) '(serializable)]) + (values linklet? vector?)])]{ + +Takes an S-expression or @tech{correlated object} for a +@schemeidfont{linklet} form and produces a @tech{linklet}. +As long as @racket['serializable] included in @racket[options], the +resulting linklet can be marshaled to and from a byte stream when it is +part of a @tech{linklet bundle}. + +The optional @racket[name] is associated to the linklet for debugging +purposes and as the default name of the linklet's instance. + +The optional @racket[import-keys] and @racket[get-import] arguments +support cross-linklet optimization. If @racket[import-keys] is a +vector, it must have as many elements as sets of imports in +@racket[form]. If the compiler becomes interested in optimizing a +reference to an imported variable, it passes back to +@racket[get-import] (if non-@racket[#f]) the element of @racket[import-keys] that +corresponds to the variable's import set. The @racket[get-import] +function can then return a linklet or instance that represents an instance to be +provided to the compiled linklet when it is eventually instantiated; +ensuring consistency between reported linklet or instance and the eventual +instance is up to the caller of @racket[compile-linklet]. If +@racket[get-import] returns @racket[#f] as its first value, the +compiler will be prevented from make any assumptions about the +imported instance. The second result from @racket[get-import] is an +optional vector of keys to provide transitive information on a +returned linklet's imports (and is not allowed for a returned instance); +the returned vector must have the same +number of elements as the linklet has imports. When vector elements +are @racket[eq?] and non-@racket[#f], the compiler can assume that +they correspond to the same run-time instance. A @racket[#f] +value for @racket[get-import] is equivalent to a function that +always returns two @racket[#f] results. + +When @racket[import-keys] is not @racket[#f], then the compiler is +allowed to grow or shrink the set of imported instances for the +linklet. The result vector specifies the keys of the imports for the +returned linklet. Any key that is @racket[#f] or a @tech{linklet instance} +must be preserved intact, however. + +If @racket['unsafe] is included in @racket[options], then the linklet +is compiled in @deftech{unsafe mode}: uses of safe operations within +the linklet can be converted to unsafe operations on the assumption +that the relevant contracts are satisfied. For example, @racket[car] +is converted to @racket[unsafe-car]. Some substituted unsafe +operations may not have directly accessible names, such as the unsafe +variant of @racket[in-list] that can be substituted in @tech{unsafe +mode}. An unsafe operation is substituted only if its (unchecked) +contract is subsumed by the safe operation's contract. The fact that +the linklet is compiled in @tech{unsafe mode} can be exposed through +@racket[variable-reference-from-unsafe?] using a variable reference +produced by a @racket[#%variable-reference] form within the module +body. + +If @racket['static] is included in @racket[options] then the linklet +must be instantiated only once; in the linklet is serialized, then any +individual instance read from the serialized form must be instantiated +at most once. Compilation with @racket['static] is intended to improve +the performance of references within the linklet to defined and +imported variables. + +The symbols in @racket[options] must be distinct, otherwise +@exnraise[exn:fail:contract].} + + +@defproc*[([(recompile-linklet [linklet linklet?] + [name any/c #f] + [import-keys #f #f] + [get-import (any/c . -> . (values (or/c linklet? #f) + (or/c vector? #f))) + (lambda (import-key) (values #f #f))]) + linklet?] + [(recompile-linklet [linklet linklet?] + [name any/c] + [import-keys vector?] + [get-import (any/c . -> . (values (or/c linklet? #f) + (or/c vector? #f))) + (lambda (import-key) (values #f #f))]) + (values linklet? vector?)])]{ + +Like @racket[compile-linklet], but takes an already-compiled linklet +and potentially optimizes it further.} + + +@defproc[(eval-linklet [linklet linklet?]) linklet?]{ + +Returns a variant of a @racket[linklet] that is prepared for JIT +compilation such that every later use of the result linklet with +@racket[instantiate-linklet] shares the JIT-generated code. However, +the result of @racket[eval-linklet] cannot be marshaled to a byte +stream as part of a @tech{linklet bundle}, and it cannot be used with +@racket[recompile-linklet].} + + + +@defproc*[([(instantiate-linklet [linklet linklet?] + [import-instances (listof instance?)] + [target-instance? #f #f] + [use-prompt? any/c #t]) + instance?] + [(instantiate-linklet [linklet linklet?] + [import-instances (listof instance?)] + [target-instance instance?] + [use-prompt? any/c #t]) + any])]{ + +Instantiates @racket[linklet] by running its definitions and +expressions, using the given @racket[import-instances] for its +imports. The number of instances in @racket[import-instances] must +match the number of import sets in @racket[linklet]. + +If @racket[target-instance] is @racket[#f] or not provided, the result +is a fresh instance for the linklet. If @racket[target-instance] is an +instance, then the instance is used and modified for the linklet +definitions and expressions, and the result is the value of the last +expression in the linklet. + +The linklet's exported variables are accessible in the result instance +or in @racket[target-instance] using the linklet's external name for +each export. If @racket[target-instance] is provided as +non-@racket[#f], its existing variables remain intact if they are not +modified by a linklet definition. + +If @racket[use-prompt?] is true, then the evaluation each definition +and expression in the linklet is wrapped in a @tech{prompt} in the +same ways as an expression in a module body.} + + +@defproc[(linklet-import-variables [linklet linklet?]) + (listof (listof symbol?))]{ + +Returns a description of a linklet's imports. Each element of the +result list corresponds to an import set as satisfied by a single +instance on instantiation, and each member of the set is a variable +name that is used from the corresponding imported instance.} + +@defproc[(linklet-export-variables [linklet linklet?]) + (listof symbol?)]{ + +Returns a description of a linklet's exports. Each element of the list +corresponds to a variable that is made available by the linklet in its +instance.} + + +@defproc[(linklet-directory? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet directory}, +@racket[#f] otherwise.} + + +@defproc[(hash->linklet-directory [content (and/c hash? hash-eq? immutable? (not/c impersonator?))]) + linklet-directory?]{ + +Constructs a @tech{linklet directory} given mappings in the form of a +@tech{hash table}. Each key of @racket[content] must be either a +symbol or @racket[#f], each symbol must be mapped to a @tech{linklet +directory}, and @racket[#f] must be mapped to a @tech{linklet bundle} +or not mapped.} + + +@defproc[(linklet-directory->hash [linklet-directory linklet-directory?]) + (and/c hash? hash-eq? immutable? (not/c impersonator?))]{ + +Extracts the content of a @tech{linklet directory} into a @tech{hash +table}.} + + +@defproc[(linklet-bundle? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet bundle}, +@racket[#f] otherwise.} + + +@defproc[(hash->linklet-bundle [content (and/c hash? hash-eq? immutable? (not/c impersonator?))]) + linklet-bundle?]{ + +Constructs a @tech{linklet bundle} given mappings in the form of a +@tech{hash table}. Each key of @racket[content] must be either a +symbol or a @tech{fixnum}. Values in the hash table are unconstrained, +but the intent is that they are all @tech{linklets} or values that can +be recovered from @racket[write] output by @racket[read].} + + +@defproc[(linklet-bundle->hash [linklet-bundle linklet-bundle?]) + (and/c hash? hash-eq? immutable? (not/c impersonator?))]{ + +Extracts the content of a @tech{linklet bundle} into a @tech{hash +table}.} + + +@defproc[(instance? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet instance}, +@racket[#f] otherwise.} + + +@defproc[(make-instance [name any/c] + [data any/c #f] + [mode (or/c #f 'constant 'consistent) #f] + [variable-name symbol?] + [variable-value any/c] ... ...) + instance?]{ + +Constructs a @tech{linklet instance} directly. Besides associating an +arbitrary @racket[name] and @racket[data] value to the instance, the +instance is populated with variables as specified by +@racket[variable-name] and @racket[variable-value]. + +The optional @racket[data] and @racket[mode] arguments must be +provided if any @racket[variable-name] and @racket[variable-value] +arguments are provided. The @racket[mode] argument is used as in +@racket[instance-set-variable-value!] for every +@racket[variable-name].} + + +@defproc[(instance-name [instance instance?]) any/c]{ + +Returns the value associated to @racket[instance] as its name---either +the first value provided to @racket[make-instance] or the name of a +linklet that was instantiated to create the instance.} + + +@defproc[(instance-data [instance instance?]) any/c]{ + +Returns the value associated to @racket[instance] as its data---either +the second value provided to @racket[make-instance] or the default +@racket[#f].} + + +@defproc[(instance-variable-names [instance instance?]) (list symbol?)]{ + +Returns a list of all names for all variables accessible from +@racket[instance].} + + +@defproc[(instance-variable-value [instance instance?] + [name symbol?] + [fail-k any/c (lambda () (error ....))]) + any]{ + +Returns the value of the variable exported as @racket[name] from +@racket[instance]. If no such variable is exported, then +@racket[fail-k] is used in the same way as by @racket[hash-ref].} + + +@defproc[(instance-set-variable-value! [instance instance?] + [name symbol?] + [v any/c] + [mode (or/c #f 'constant 'consistent) #f]) + void?]{ + +Sets or creates the variable exported as @racket[name] in +@racket[instance] so that its value is @racket[v], as long as the +variable does not exist already as constant. If a variable for +@racket[name] exists as constant, the @exnraise[exn:fail:contract]. + +If @racket[mode] is a single, then the variable is created or changed +to be constant. If @racket[mode] is @racket['consistent], then +the optimizer can assume that the value has the same shape in all +instances that are used to satisfy a linklet's imports.} + + +@defproc[(instance-unset-variable! [instance instance?] + [name symbol?]) + void?]{ + +Changes @racket[instance] so taht it does not export a variable as +@racket[name], as long as @racket[name] does not exist as a constant +variable. If a variable for @racket[name] exists as constant, the +@exnraise[exn:fail:contract].} + + +@defproc[(variable-reference->instance [varref variable-reference?] + [ref-site? any/c #f]) + (if ref-site? (or/c instance? #f symbol?) instance?)]{ + +Extracts the instance where the variable of @racket[varref] is defined +if @var[ref-site?] is @racket[#f], and returns the instance where +@racket[varref] itself resides if @racket[ref-site?] is true. This +notion of @tech{variable reference} is the same as at the module level +and can reflect the linklet instance that implements a particular +phase of a module instance. + +When @var[ref-site?] is @racket[#f], the result is @racket[#f] when +@racket[varref] is from @racket[(#%variable-reference)] with no +identifier. The result is a symbol if @racket[varref] refers to a +primitive.} + +@deftogether[( +@defproc[(correlated? [v any/c]) boolean?] +@defproc[(correlated-source [stx correlated?]) any] +@defproc[(correlated-line [stx correlated?]) + (or/c exact-positive-integer? #f)] +@defproc[(correlated-column [stx correlated?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(correlated-position [stx correlated?]) + (or/c exact-positive-integer? #f)] +@defproc[(correlated-span [stx correlated?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(correlated-e [stx correlated?]) any] +@defproc[(correlated->datum [stx (or/c correlated? any/c)]) any] +@defproc[(datum->correlated [v any/c] + [srcloc (or/c correlated? #f + (list/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f)) + (vector/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f))) + #f]) + correlated?] +@defproc*[([(correlated-property [stx correlated?] + [key any/c] + [val any/c]) + correlated?] + [(correlated-property [stx correlated?] [key any/c]) any/c])] +@defproc[(correlated-property-symbol-keys [stx correlated?]) list?] +)]{ + +Like @racket[syntax?], @racket[syntax-source], @racket[syntax-line], +@racket[syntax-column], @racket[syntax-position], +@racket[syntax-span], @racket[syntax-e], @racket[syntax->datum], +@racket[datum->syntax], @racket[syntax-property], and +@racket[syntax-property-symbol-keys], but for @tech{correlated +objects}. + +Unlike @racket[datum->syntax], @racket[datum->correlated] does not +recur through the given S-expression and convert pieces to +@tech{correlated objects}. Instead, a @tech{correlated object} is +simply wrapped around the immediate value. In contrast, +@racket[correlated->datum] recurs through its argument (which is not +necessarily a @tech{correlated object}) to discover any +@tech{correlated objects} and convert them to plain S-expressions.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -55,6 +55,14 @@ The default is @racket["error"].} + @item{If the @indexed-envvar{PLTSTDOUT} environment variable is + defined and is not overridden by a command-line flag, it + determines the level of the @tech{log receiver} that propagates + events to the original output port. The possible values are the + same as for @envvar{PLTSTDERR}. + + The default is @racket["none"].} + @item{If the @indexed-envvar{PLTSYSLOG} environment variable is defined and is not overridden by a command-line flag, it determines the level of the @tech{log receiver} that propagates @@ -78,7 +86,8 @@ of @envvar{PLTSTDERR} and @envvar{PLTSYSLOG} was very strict. Leading and trailing whitespace was forbidden, and anything other than exactly one space character separating two specifications was - rejected.}] + rejected.} + #:changed "6.90.0.17" @elem{Added @envvar{PLTSTDOUT}.}] @; ---------------------------------------- @section{Creating Loggers} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -155,7 +155,13 @@ #:eval match-eval (match '(1 2 3) [(list-no-order 3 2 x) x]) - ]} + ] + + @margin-note{ + Unlike other patterns, @racketidfont{list-no-order} doesn't + allow duplicate identifiers between subpatterns. For example + the patterns @racket[(list-no-order x 1 x)] and + @racket[(list-no-order x 1 x ...)] both produce syntax errors.}} @item{@racket[(#,(racketidfont "list-no-order") _pat ... _lvp)] --- generalizes @racketidfont{list-no-order} to allow a pattern @@ -689,8 +695,9 @@ } @defproc[(syntax-local-match-introduce [stx syntax?]) syntax?]{ -Like @racket[syntax-local-introduce], but for match expanders. -} +For backward compatibility only; equivalent to @racket[syntax-local-introduce]. + +@history[#:changed "6.90.0.29" @elem{Made equivalent to @racket[syntax-local-introduce].}]} @defparam[match-equality-test comp-proc (any/c any/c . -> . any)]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -190,10 +190,13 @@ @racket[will-execute] blocks until one is ready.} -@defproc[(will-try-execute [executor any/c]) any]{ +@defproc[(will-try-execute [executor any/c] [v any/c #f]) + any]{ Like @racket[will-execute] if a will is ready for immediate -execution. Otherwise, @racket[#f] is returned.} +execution. Otherwise, @racket[v] is returned. + +@history[#:changed "6.90.0.4" @elem{Added the @racket[v] argument.}]} @;------------------------------------------------------------------------ @section[#:tag "garbagecollection"]{Garbage Collection} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/module-reflect.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/module-reflect.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/module-reflect.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/module-reflect.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -273,7 +273,8 @@ @racket[#f] otherwise.} -@defproc[(module-path-index-resolve [mpi module-path-index?]) +@defproc[(module-path-index-resolve [mpi module-path-index?] + [load? any/c #f]) resolved-module-path?]{ Returns a @tech{resolved module path} for the resolved module name, @@ -285,9 +286,12 @@ on the kind of module paths encapsulated by @racket[mpi], the computed resolved name can depend on the value of @racket[current-load-relative-directory] or -@racket[current-directory]. +@racket[current-directory]. The @racket[load?] argument is propagated as +the last argument to the @tech{module name resolver}. + +See @racket[resolve-module-path-index]. -See @racket[resolve-module-path-index].} +@history[#:changed "6.90.0.16" @elem{Added the @racket[load?] optional argument.}]} @defproc[(module-path-index-split [mpi module-path-index?]) @@ -476,6 +480,11 @@ [fail-thunk (-> any) (lambda () ....)]) (or/c void? any/c)]{ +@margin-note{Because @racket[dynamic-require] is a procedure, giving a plain S-expression for +@racket[mod] the same way as you would for a @racket[require] expression likely won't give you +expected results. What you need instead is something that evaluates to an S-expression; using +@racket[quote] is one way to do it.} + Dynamically @tech{instantiates} the module specified by @racket[mod] in the current namespace's registry at the namespace's @tech{base phase}, if it is not yet @tech{instantiate}d. The current @tech{module @@ -494,6 +503,11 @@ (dynamic-require ''a #f) ] +@margin-note{The double quoted @racket[''a] evaluates to the @racket[root-module-path] @racket['a] +(see the grammar for @racket[require]). Using @racket['a] or @racket[a] for @racket[mod] won't work +because the former evaluates to @racket[root-module-path] @racket[a] which fails since the example is +not a module installed in a collection, the latter is an undefined variable.} + When @racket[provided] is a symbol, the value of the module's export with the given name is returned, and still the module is not @tech{visit}ed or made @tech{available} in higher phases. @@ -535,6 +549,31 @@ @tech{visit}ed but not @tech{instantiate}d (see @secref["mod-parse"]), and the result is @|void-const|.} +More examples using different @racket[module-path] grammar expressions are given below: + +@examples[#:eval mod-eval + (dynamic-require 'racket/base #f) +] + +@examples[#:eval mod-eval + (dynamic-require (list 'lib "racket/base") #f) +] + +@examples[#:eval mod-eval + (module a racket/base + (module b racket/base + (provide inner-dessert) + (define inner-dessert "tiramisu"))) + (dynamic-require '(submod 'a b) 'inner-dessert) +] + +The last line in the above example could instead have been written as + +@examples[#:eval mod-eval + (dynamic-require ((lambda () (list 'submod ''a 'b))) 'inner-dessert) +] + +which is equivalent. @defproc[(dynamic-require-for-syntax [mod module-path?] [provided (or/c symbol? #f)] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/namespaces.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/namespaces.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/namespaces.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/namespaces.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -89,7 +89,8 @@ If the anchor is from a @racket[define-namespace-anchor] form in a module context, then the result is a namespace for the module's body in the anchor's phase. The result is the same as a namespace obtained -via @racket[module->namespace]. +via @racket[module->namespace], and the module is similarly made +@tech{available} if it is not available already. If the anchor is from a @racket[define-namespace-anchor] form in a top-level content, then the result is the namespace in which the @@ -170,7 +171,8 @@ @defproc[(namespace-set-variable-value! [sym symbol?] [v any/c] [map? any/c #f] - [namespace namespace? (current-namespace)]) + [namespace namespace? (current-namespace)] + [as-constant? any/c #f]) void?]{ Sets the value of @racket[sym] in the top-level environment of @@ -180,7 +182,13 @@ If @racket[map?] is supplied as true, then the namespace's @tech{identifier} mapping is also adjusted (see @secref["namespace-model"]) in the @tech{phase level} corresponding to -the @tech{base phase}, so that @racket[sym] maps to the variable.} +the @tech{base phase}, so that @racket[sym] maps to the variable. + +If @racket[as-constant?] is true, then the variable is made a constant +(so future assignments are rejected) after @racket[v] is installed as +the value. + +@history[#:changed "6.90.0.14" @elem{Added the @racket[as-constant?] argument.}]} @defproc[(namespace-undefine-variable! [sym symbol?] @@ -202,11 +210,12 @@ -@defproc[(namespace-require [quoted-raw-require-spec any/c]) +@defproc[(namespace-require [quoted-raw-require-spec any/c] + [namespace namespace? (current-namespace)]) void?]{ Performs the import corresponding to @racket[quoted-raw-require-spec] -in the top-level environment of the current namespace, like a +in the top-level environment of @racket[namespace], like a top-level @racket[#%require]. The @racket[quoted-raw-require-spec] argument must be either a datum that corresponds to a quoted @racket[_raw-require-spec] for @racket[#%require], which includes @@ -215,38 +224,49 @@ Module paths in @racket[quoted-raw-require-spec] are resolved with respect to @racket[current-load-relative-directory] or @racket[current-directory] (if the former is @racket[#f]), even if the -current namespace corresponds to a module body.} +current namespace corresponds to a module body. + +@history[#:changed "6.90.0.16" @elem{Added the @racket[namespace] optional argument.}]} -@defproc[(namespace-require/copy [quoted-raw-require-spec any/c]) +@defproc[(namespace-require/copy [quoted-raw-require-spec any/c] + [namespace namespace? (current-namespace)]) void?]{ Like @racket[namespace-require] for syntax exported from the module, but exported variables at the namespace's @tech{base phase} are treated differently: the export's current value is copied to a -top-level variable in the current namespace.} +top-level variable in @racket[namespace]. +@history[#:changed "6.90.0.16" @elem{Added the @racket[namespace] optional argument.}]} -@defproc[(namespace-require/constant [quoted-raw-require-spec any/c]) + +@defproc[(namespace-require/constant [quoted-raw-require-spec any/c] + [namespace namespace? (current-namespace)]) void?]{ Like @racket[namespace-require], but for each exported variable at the @tech{namespace}'s @tech{base phase}, the export's value is copied to a corresponding top-level variable that is made immutable. Despite setting the top-level variable, the corresponding identifier is bound -as imported.} +as imported. +@history[#:changed "6.90.0.16" @elem{Added the @racket[namespace] optional argument.}]} -@defproc[(namespace-require/expansion-time [quoted-raw-require-spec any/c]) + +@defproc[(namespace-require/expansion-time [quoted-raw-require-spec any/c] + [namespace namespace? (current-namespace)]) void?]{ Like @racket[namespace-require], but only the transformer part of the -module is executed relative to the @tech{namespace}'s @tech{base +module is executed relative to @racket[namespace]'s @tech{base phase}; that is, the module is merely @tech{visit}ed, and not @tech{instantiate}d (see @secref["mod-parse"]). If the required module has not been instantiated before, the module's variables remain -undefined.} +undefined. + +@history[#:changed "6.90.0.16" @elem{Added the @racket[namespace] optional argument.}]} @defproc[(namespace-attach-module [src-namespace namespace?] @@ -348,16 +368,17 @@ @defproc[(module->namespace [mod (or/c module-path? resolved-module-path? - module-path-index?)]) + module-path-index?)] + [src-namespace namespace? (current-namespace)]) namespace?]{ Returns a namespace that corresponds to the body of an instantiated -module in the current namespace's @tech{module registry} and in the -current namespace's @tech{base phase}, making the module -@tech{available} for on-demand @tech{visits} at the namespace's +module in @racket[src-namespace]'s @tech{module registry} and in the +@racket[src-namespace]'s @tech{base phase}, making the module +@tech{available} for on-demand @tech{visits} at @racket[src-namespace]'s @tech{base phase}. The returned namespace has the same @tech{module -registry} as the current namespace. Modifying a binding in the -namespace changes the binding seen in modules that require the +registry} as @racket[src-namespace]. Modifying a binding in the +resulting namespace changes the binding seen in modules that require the namespace's module. Module paths in a top-level @racket[require] expression are resolved @@ -365,24 +386,30 @@ declarations are not allowed. If the current code inspector does not control the invocation of the -module in the current namespace's @tech{module registry}, the +module in @racket[src-namespace]'s @tech{module registry}, the @exnraise[exn:fail:contract]; see also @secref["modprotect"]. -Bindings in the namespace cannot be modified if the +Bindings in the result namespace cannot be modified if the @racket[compile-enforce-module-constants] parameter was true when the module was declared, unless the module declaration itself included -assignments to the binding via @racket[set!].} +assignments to the binding via @racket[set!]. +@history[#:changed "6.90.0.16" @elem{Added the @racket[src-namespace] optional argument.}]} -@defproc[(namespace-syntax-introduce [stx syntax?]) syntax?]{ -Returns a syntax object like @racket[stx], except that the current -namespace's bindings are included in the @tech{syntax object}'s +@defproc[(namespace-syntax-introduce [stx syntax?] + [namespace namespace? (current-namespace)]) + syntax?]{ + +Returns a syntax object like @racket[stx], except that +@racket[namespace]'s bindings are included in the @tech{syntax object}'s @tech{lexical information} (see @secref["stxobj-model"]). The additional context is overridden by any existing @tech{top-level bindings} in the @tech{syntax object}'s @tech{lexical information}, or by any existing or future @tech{module bindings} in the @tech{lexical -information}.} +information}. + +@history[#:changed "6.90.0.16" @elem{Added the @racket[namespace] optional argument.}]} @defproc[(module-provide-protected? [module-path-index (or/c symbol? module-path-index?)] @@ -432,7 +459,8 @@ If @racket[varref] refers to a @tech{module-level variable}, then the result is a namespace for the module's body in the referenced variable's @tech{phase}; the result is the same as a namespace -obtained via @racket[module->namespace]. +obtained via @racket[module->namespace], and the module is similarly made +@tech{available} if it is not available already. If @racket[varref] refers to a @tech{top-level variable}, then the result is the namespace in which the referenced variable is defined.} @@ -496,3 +524,27 @@ for the module of @racket[varref], where @racket[varref] must refer to an anonymous module variable as produced by @racket[(#%variable-reference)].} + + +@defproc[(variable-reference-from-unsafe? [varref variable-reference?]) boolean?]{ + +Returns @racket[#t] if the module of the variable reference itself +(not necessarily a referenced variable) is compiled in unsafe mode, +@racket[#f] otherwise. + +The @racket[variable-reference-from-unsafe?] procedure is intended for +use as + +@racketblock[ +(variable-reference-from-unsafe? (#%variable-reference)) +] + +which the compiler can optimize to a literal @racket[#t] or +@racket[#f] (since the enclosing module is being compiled in +@tech{unsafe mode} or not). + +Currently @tech{unsafe mode} can be controlled only through the +@tech{linklet} interface, but future changes may make @tech{unsafe +mode} more accessible at the module level. + +@history[#:added "6.12.0.4"]} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -103,7 +103,7 @@ @defproc[(number? [v any/c]) boolean?]{Returns @racket[#t] if @racket[v] is a number, @racket[#f] otherwise. -@mz-examples[(number? 1) (number? 2+3i) (number? "hello")]} +@mz-examples[(number? 1) (number? 2+3i) (number? "hello") (number? +nan.0)]} @defproc[(complex? [v any/c]) boolean?]{ Returns @racket[(number? v)], @@ -1304,13 +1304,11 @@ @history[#:added "6.8.0.2"]} @defproc[(negative-integer? [x any/c]) boolean?]{ - Like @racket[exact-negative-integer?], but also returns - @racket[#t] for negative @racket[inexact?] integers. + The same as @racket[(and (integer? x) (negative? x))]. @history[#:added "6.8.0.2"]} @defproc[(nonpositive-integer? [x any/c]) boolean?]{ - Like @racket[exact-nonpositive-integer?], but also returns - @racket[#t] for non-positive @racket[inexact?] integers. + The same as @racket[(and (integer? x) (not (positive? x)))]. @history[#:added "6.8.0.2"]} @defproc[(nonnegative-integer? [x any/c]) boolean?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/pairs.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/pairs.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/pairs.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/pairs.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1352,9 +1352,10 @@ @defproc[(permutations [lst list?]) list?]{ -Returns a list of all permutations of the input list. Note that this +@index["rearrangements"]{Returns} a list of all permutations of the input list. Note that this function works without inspecting the elements, and therefore it ignores repeated elements (which will result in repeated permutations). +Raises an error if the input list contains more than 256 elements. @mz-examples[#:eval list-eval (permutations '(1 2 3)) @@ -1364,9 +1365,10 @@ @defproc[(in-permutations [lst list?]) sequence?]{ -Returns a sequence of all permutations of the input list. It is +@index["in-rearrangements"]{Returns} a sequence of all permutations of the input list. It is equivalent to @racket[(in-list (permutations l))] but much faster since -it builds the permutations one-by-one on each iteration} +it builds the permutations one-by-one on each iteration +Raises an error if the input list contains more than 256 elements.} @defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/paths.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/paths.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/paths.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/paths.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -705,21 +705,25 @@ @defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)] [path (or/c path-string? path-for-some-system?)] [#:more-than-root? more-than-root? any/c #f] + [#:more-than-same? more-than-same? any/c #t] [#:normalize-case? normalize-case? any/c #t]) (or/c path-for-some-system? path-string?)]{ Finds a relative pathname with respect to @racket[base] that names the same file or directory as @racket[path]. Both @racket[base] and @racket[path] must be simplified in the sense of -@racket[simple-form-path]. If @racket[path] shares no subpath in +@racket[simple-form-path]. If @racket[path] shares no subpath in common with @racket[base], @racket[path] is returned. If @racket[more-than-root?] is true, if @racket[base] and @racket[path] share only a Unix root in common, and if neither @racket[base] nor @racket[path] is just a root path, then -@racket[path] is returned. The case when @racket[path] is returned -and is a string is the only case when @racket[find-relative-path] -returns a string result. +@racket[path] is returned. + +If @racket[path] is the same as @racket[base], then +@racket[(build-path 'same)] is returned only if +@racket[more-than-same?] is true. Otherwise, @racket[path] is +returned when @racket[path] is the same as @racket[base]. If @racket[normalize-case?] is true (the default), then pairs of path elements to be compared are first converted via @@ -728,10 +732,17 @@ @racket[#f], then path elements and the path roots match only if they have the same case. +The result is normally a @tech{path} in the sense of @racket[path?]. +The result is a string only if @racket[path] is provided a string and +also returned as the result. + @history[#:changed "6.8.0.3" @elem{Made path elements case-normalized for comparison by default, and added the @racket[#:normalize-case?] - argument.}]} + argument.} + #:changed "6.90.0.21" @elem{Added the @racket[#:more-than-same?] + argument.}]} + @defproc[(normalize-path [path path-string?] [wrt (and/c path-string? complete-path?) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/places.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/places.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/places.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/places.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -151,7 +151,7 @@ the place. The module indicated by @racket[module-path] must export a function - with the name @racket[start-proc]. The function must accept a single + with the name @racket[start-name]. The function must accept a single argument, which is a @tech{place channel} that corresponds to the other end of communication for the @tech{place descriptor} returned by @racket[place]. @@ -168,7 +168,7 @@ is converted to @racket[0]. If the function indicated by @racket[module-path] and - @racket[start-proc] returns, then the place terminates with the + @racket[start-name] returns, then the place terminates with the @tech{completion value} @racket[0]. In the created place, the @racket[current-input-port] parameter is @@ -372,10 +372,12 @@ @item{@tech{pairs}, @tech{lists}, @tech{vectors}, and immutable @tech{prefab} structures containing message-allowed values, where a mutable vector is automatically replaced by an - immutable vector;} + immutable vector and where @tech{impersonators} of vectors and + @tech{prefab} structures are copied;} @item{@tech{hash tables} where mutable hash tables are automatically - replaced by immutable variants;} + replaced by immutable variants, and where a + hash table @tech{impersonator} is copied;} @item{@tech{place channels}, where a @tech{place descriptor} is automatically replaced by a plain place channel;} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/port-lib.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/port-lib.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/port-lib.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/port-lib.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -157,7 +157,10 @@ @section{Creating Ports} -@defproc[(input-port-append [close-at-eof? any/c] [in input-port?] ...) input-port?]{ +@defproc[(input-port-append [close-at-eof? any/c] + [in input-port?] ... + [#:name name any/c (map object-name in)]) + input-port?]{ Takes any number of input ports and returns an input port. Reading from the input port draws bytes (and special non-byte values) from the @@ -167,8 +170,13 @@ the returned input port remains available for reading in its original input port. +The @racket[name] argument determines the name as reported by +@racket[object-name] for the returned input port. + See also @racket[merge-input], which interleaves data from multiple -input ports as it becomes available.} +input ports as it becomes available. + +@history[#:changed "6.90.0.19" @elem{Added the @racket[name] argument.}]} @defproc[(make-input-port/read-to-peek @@ -824,7 +832,7 @@ This function is often called from a ``background'' thread to continuously pump data from one stream to another. -If multiple @racket[out]s are provided, case data from @racket[in] is +If multiple @racket[out]s are provided, data from @racket[in] is written to every @racket[out]. The different @racket[out]s block output to each other, because each block of data read from @racket[in] is written completely to one @racket[out] before moving to the next diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/printer.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/printer.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/printer.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/printer.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -40,7 +40,7 @@ the printer first scans an object to detect cycles. The scan traverses the components of pairs, mutable pairs, vectors, boxes (when @racket[print-box] is @racket[#t]), hash tables (when -@racket[print-hash-table] is @racket[#t]), fields of structures +@racket[print-hash-table] is @racket[#t] and when key are held strongly), fields of structures exposed by @racket[struct->vector] (when @racket[print-struct] is @racket[#t]), and fields of structures exposed by printing when the structure's type has the @racket[prop:custom-write] property. If @@ -424,7 +424,8 @@ @racket[write] and @racket[display] modes, a @tech{hash table} prints starting with @litchar{#hash(}, @litchar{#hasheqv(}, or @litchar{#hasheq(} for a table using @racket[equal?], @racket[eqv?], -or @racket[eq?] key comparisons, respectively. After the prefix, each +or @racket[eq?] key comparisons, respectively, as long as the hash table +retains keys strongly. After the prefix, each key--value mapping is shown as @litchar{(}, the printed form of a key, a space, @litchar{.}, a space, the printed form the corresponding value, and @litchar{)}, with an additional space if the key--value @@ -444,7 +445,8 @@ is @tech{quotable} when all of its keys and values are @tech{quotable}. -When the @racket[print-hash-table] parameter is set to @racket[#f], a +When the @racket[print-hash-table] parameter is set to @racket[#f] +or when a hash table retains its keys weakly, a hash table prints as @litchar{#} and counts as @tech{quotable}. @@ -553,17 +555,16 @@ form when the @racket[read-accept-compiled] parameter is set to @racket[#t]. -When a compiled form contains syntax object constants, they must not -be @tech{tainted} or @tech{armed}; the @litchar{#~}-marshaled form -drops source-location information and properties (see -@secref["stxprops"]) for the @tech{syntax objects}. - -Compiled code parsed from @litchar{#~} may contain references to -unexported or protected bindings from a module. At read time, such -references are associated with the current code inspector (see -@racket[current-code-inspector]), and the code will only execute if -that inspector controls the relevant module invocation (see -@secref["modprotect"]). +Compiled code parsed from @litchar{#~} is marked as non-runnable if +the current code inspector (see @racket[current-code-inspector]) is +not the original code inspector; on attempting to evaluate or reoptimize +non-runnable bytecode, @exnraise[exn:fail]. Otherwise, compiled +code parsed from @litchar{#~} may contain references to unexported or +protected bindings from a module. Conceptually, the references in +bytecode are associated with the current code inspector, where the +code will only execute if that inspector controls the relevant module +invocation (see @secref["modprotect"])---but the original code +inspector controls all other inspectors, anyway. A compiled-form object may contain @tech{uninterned} symbols (see @secref["symbols"]) that were created by @racket[gensym] or @@ -585,19 +586,9 @@ the result of @racket[make-syntax-introducer] to an existing identifier; those functions lead to top-level and module variables with @tech{unreadable symbol}ic names, and the names are deterministic -as long as expansion is otherwise deterministic. +as long as expansion is otherwise deterministic. -Despite the problems inherent with @tech{uninterned} symbols as -variable names, they are partially supported even across multiple -@litchar{#~}s: When compiled code contains a reference to a module-defined -variable whose name is an @tech{uninterned} symbol, the relative -position of the variable among the module's definitions is recorded, -and the reference can be linked back to the definition based on its -position and the characters in its name. This accommodation works only -for variable references in compiled code; it does not work for -@racket[syntax]-quoted identifiers, for example. - -Finally, a compiled form may contain path literals. Although paths are +A compiled form may contain path literals. Although paths are not normally printed in a way that can be read back in, path literals can be written and read as part of compiled code. The @racket[current-write-relative-directory] parameter is used to convert @@ -613,3 +604,33 @@ coerced to a string that preserves only part of the path (an in effort to make it less tied to the build-time filesystem, which can be different than the run-time filesystem). + +Finally, a compiled form may contain @racket[srcloc] structures if the +source field of the structure is a path for some system, a string, a +byte string, a symbol, or @racket[#f]. For a path value (matching the +current platform's convention), if the path cannot be recorded as a +relative path based on @racket[current-write-relative-directory], then +it is converted to a string with at most two path elements; if the +path contains more than two elements, then the string contains +@litchar{.../}, the next-to-last element, @litchar{/} and the last +element. The intent of the constraints on @racket[srcloc] values and +the conversion of the source field is to preserve some source +information but not expose or record a path that makes no sense on +a different filesystem or platform. + +For internal testing purposes, when the +@as-index{@envvar{PLT_VALIDATE_LOAD}} environment variable is set, the +reader runs a validator on bytecode parsed from @litchar{#~}. The +validator may catch miscompilations or bytecode-file corruption. The +validtor may run lazily, such as checking a procedure only when the +procedure is called. + +@history[#:changed "6.90.0.21" @elem{Adjusted the effect of changing + the code inspector on parsed + bytecode, causing the reader to + mark the loaded code as generally + unrunnable instead of rejecting at + read time references to unsafe + operations.} + #:changed "7.0" @elem{Allowed some @racket[srcloc] values + embedded in compiled code.}] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/reader.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/reader.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/reader.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/reader.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -956,16 +956,17 @@ then a variety of changes occur in the reader. First, symbols can no longer include the character @litchar{.}, unless -the entire symbol is quoted with @litchar{|}. +the @litchar{.} is quoted with @litchar{|} or @litchar{\}. Second, numbers can no longer include the character @litchar{.}, -unless the number is prefixed with @litchar{#e} or @litchar{#i}, or an +unless the number is prefixed with @litchar{#e}, @litchar{#i}, +@litchar{#b}, @litchar{#o}, @litchar{#d}, @litchar{#x}, or an equivalent prefix as discussed in @secref["parse-number"]. If these numbers are followed by a @litchar{.} intended to be read as a C-style -infix dot, then there must be separating whitespace. +infix dot, then a delimiter must precede the @litchar{.}. Finally, after reading any datum @racket[_x], the reader will seek -through whitespace and look for zero or more sequences of a +through whitespace and comments and look for zero or more sequences of a @litchar{.} followed by another datum @racket[_y]. It will then group @racket[_x] and @racket[_y] together in a @racket[#%dot] form so that @racket[_x.y] reads equal to @racket[(#%dot _x _y)]. diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/read.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/read.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/read.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/read.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -62,17 +62,9 @@ the read datum are local to the datum. When called within the dynamic extent of @racket[read], the -@racket[read/recursive] procedure produces either an opaque -placeholder value, a special-comment value, or an end-of-file. The -result is a special-comment value (see @secref["special-comments"]) -when the input stream's first non-whitespace content parses as a -comment. The result is end-of-file when @racket[read/recursive] -encounters an end-of-file. Otherwise, the result is a placeholder that -protects graph references that are not yet resolved. When this -placeholder is returned within an S-expression that is produced by any -reader-extension procedure (see @secref["reader-procs"]) for the -same outermost @racket[read], it will be replaced with the actual read -value before the outermost @racket[read] returns. +@racket[read/recursive] procedure can produce a special-comment value +(see @secref["special-comments"]) when the input stream's first +non-whitespace content parses as a comment. See @secref["readtables"] for an extended example that uses @racket[read/recursive]. @@ -302,7 +294,7 @@ @defboolparam[read-accept-lang on?]{ -A @tech{parameter} that (along with @racket[read-accept-reader] controls +A @tech{parameter} that (along with @racket[read-accept-reader]) controls whether @litchar{#lang} and @litchar{#!} are allowed for selecting a parser. See @secref["parse-reader"] for more information.} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -150,7 +150,7 @@ @racket[#f]. When the reader macro is triggered by @racket[read] (or @racket[read/recursive]), the procedure is passed only two arguments if it accepts two arguments, otherwise it is passed six arguments -where the last four are all @racket[#f]. See @secref["reader-procs"] +where the third is always @racket[#f]. See @secref["reader-procs"] for information on the procedure's results. A reader macro normally reads characters from the given input port to @@ -264,7 +264,7 @@ ((if (eof-object? v) raise-read-eof-error raise-read-error) - "expected `,' or `>'" src l c p 1)]))])) + "expected `,` or `>`" src l c p 1)]))])) (define (make-delims-table) ;; Table to use for recursive reads to disallow delimiters @@ -274,7 +274,7 @@ [(ch port) (misplaced-delimiter ch port #f #f #f #f)] [(ch port src line col pos) (raise-read-error - (format "misplaced `~a' in tuple" ch) + (format "misplaced `~a` in tuple" ch) src line col pos 1)])]) (make-readtable (current-readtable) #\, 'terminating-macro misplaced-delimiter @@ -286,14 +286,14 @@ (define parse-open-tuple (case-lambda [(ch port) - ;; `read' mode + ;; `read` mode (wrap (parse port (lambda () (read/recursive port #f (make-delims-table))) (object-name port)))] [(ch port src line col pos) - ;; `read-syntax' mode + ;; `read-syntax` mode (datum->syntax #f (wrap (parse port diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/repl.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/repl.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/repl.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/repl.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang scribble/doc +@(require "mz.rkt") + +@title[#:tag "repl-module"]{The @racketmodname[racket/repl] Library} + +@defmodule[racket/repl] + +The @racketmodname[racket/repl] provides the same +@racket[read-eval-print-loop] binding as @racketmodname[racket/base], but +with even fewer internal dependencies than @racketmodname[racket/base]. It is +loaded in some situations on startup, as described in +@secref["init-actions"]. diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -27,18 +27,20 @@ or 64-bit program. In @indexed-racket['vm] mode, -the only possible symbol result is: +the possible symbol results are: @itemize[ @item{@indexed-racket['racket]} +@item{@indexed-racket['chez-scheme]} ] In @indexed-racket['gc] mode, the possible symbol results are: @itemize[ -@item{@indexed-racket['cgc]} -@item{@indexed-racket['3m]} +@item{@indexed-racket['cgc] --- when @racket[(system-type 'vm)] is @racket['racket]} +@item{@indexed-racket['3m] --- when @racket[(system-type 'vm)] is @racket['racket]} +@item{@indexed-racket['cs] --- when @racket[(system-type 'vm)] is @racket['chez-scheme]} ] In @indexed-racket['link] mode, the possible symbol results are: @@ -162,8 +164,8 @@ @defparam*[current-command-line-arguments argv - (vectorof (and/c string? immutable?)) - (vectorof string?)]{ + (vectorof string?) + (vectorof (and/c string? immutable?))]{ A @tech{parameter} that is initialized with command-line arguments when Racket starts (not including any command-line arguments that were diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/security.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/security.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/security.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/security.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -18,3 +18,5 @@ @include-section["code-inspectors.scrbl"] @include-section["plumbers.scrbl"] @include-section["sandbox.scrbl"] +@include-section["repl.scrbl"] +@include-section["linklet.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/splicing.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/splicing.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/splicing.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/splicing.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -21,14 +21,16 @@ @defidform[splicing-letrec-syntaxes] @defidform[splicing-letrec-syntaxes+values] @defidform[splicing-local] +@defidform[splicing-parameterize] )]{ Like @racket[let], @racket[letrec], @racket[let-values], @racket[letrec-values], @racket[let-syntax], @racket[letrec-syntax], @racket[let-syntaxes], @racket[letrec-syntaxes], -@racket[letrec-syntaxes+values], and @racket[local], except that in a -definition context, the body forms are spliced into the enclosing -definition context (in the same way as for @racket[begin]). +@racket[letrec-syntaxes+values], @racket[local], and +@racket[parameterize], except that in a definition context, the body +forms are spliced into the enclosing definition context (in the same +way as for @racket[begin]). @examples[ #:eval splice-eval @@ -57,7 +59,10 @@ example, @racket[splicing-let] itself adds the property to locally-bound identifiers as it expands to a sequence of definitions, so that nesting @racket[splicing-let] within a splicing form works as -expected (without any ambiguous bindings).} +expected (without any ambiguous bindings). + +@history[ + #:changed "6.12.0.2" @elem{Added @racket[splicing-parameterize].}]} @defidform[splicing-syntax-parameterize]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/startup.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/startup.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/startup.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/startup.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -80,20 +80,26 @@ language is used before the module is instantiated; see @secref["configure-runtime"]. -After running all command-line expressions, files, and modules, -Racket or GRacket then starts a read-eval-print loop for interactive +After running all command-line expressions, files, and modules, Racket +or GRacket then starts a read-eval-print loop for interactive evaluation if no command line flags are provided other than -@tech{configuration options}. If any command-line argument is +@tech{configuration options}. For Racket, the read-eval-print loop is +run by calling @racket[read-eval-print-loop] from +@racketmodname[racket/repl]. For GRacket, the read-eval-print loop is +run by calling @racket[graphical-read-eval-print-loop] from +@racketmodname[racket/gui/base]. If any command-line argument is provided that is not a @tech{configuration option}, then the read-eval-print-loop is not started, unless the @Flag{i}/@DFlag{repl} flag is provided on the command line to -specifically re-enable it. In addition, just before the command line +specifically re-enable it. + +In addition, just before the read-eval-print loop is started, Racket runs @racketmodname[racket/interactive] and GRacket runs @racketmodname[racket/gui/interactive], unless a different interactive file is specified in the the installation's @filepath{config.rktd} file found in @racket[(find-config-dir)], or the file @filepath{interactive.rkt} is found in @racket[(find-system-path 'addon-dir)]. If the -@Flag{q}/@DFlag{no-init-file} flag is specified on the command line +@Flag{q}/@DFlag{no-init-file} flag is specified on the command line, then no interactive file is run. Finally, before Racket or GRacket exits, it calls the procedure that @@ -103,7 +109,10 @@ @racket[(racket 'yield)]. @history[#:changed "6.7" @elem{Run @racketmodname[racket/interactive] file - rather than directly running @racket[(find-system-path 'init-file)].}] + rather than directly running @racket[(find-system-path 'init-file)].} + #:changed "6.90.0.30" @elem{Run a read-eval-print loop by + using @racketmodname[racket/repl] or @racketmodname[racket/gui/base] + instead of @racketmodname[racket/base] or @racketmodname[racket/gui/init].}] @; ---------------------------------------------------------------------- @@ -347,6 +356,12 @@ are the same as for the @envvar{PLTSTDERR} environment variable. See @secref["logging"] for more information.} + @item{@FlagFirst{O} @nonterm{levels} or @DFlagFirst{stdout} + @nonterm{levels} : Sets the logging level for writing events to + the original output port. The possible @nonterm{level} values + are the same as for the @envvar{PLTSTDOUT} environment + variable. See @secref["logging"] for more information.} + @item{@FlagFirst{L} @nonterm{levels} or @DFlagFirst{syslog} @nonterm{levels} : Sets the logging level for writing events to the system log. The possible @nonterm{level} values @@ -439,6 +454,8 @@ Extra arguments following the last option are available from the @indexed-racket[current-command-line-arguments] parameter. +@history[#:changed "6.90.0.17" @elem{Added @Flag{O}/@DFlag{stdout}.}] + @; ---------------------------------------------------------------------- @section[#:tag "configure-runtime"]{Language Run-Time Configuration} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/string-input.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/string-input.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/string-input.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/string-input.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -410,20 +410,39 @@ @defproc[(peek-char-or-special [in input-port? (current-input-port)] [skip-bytes-amt exact-nonnegative-integer? 0] - [special-wrap (or/c (any/c -> any/c) #f) #f] + [special-wrap (or/c (any/c -> any/c) #f 'special) #f] [source-name any/c #f]) (or/c char? eof-object? any/c)]{ Like @racket[peek-char], but if the input port returns a non-byte -value after @racket[skip-bytes-amt] byte positions, then it is returned. +value after @racket[skip-bytes-amt] byte positions, then the result +depends on @racket[special-wrap]: + +@itemlist[ + + @item{If @racket[special-wrap] is @racket[#f], then the special value + is returned (as for @racket[read-char-or-special]).} + +@item{If @racket[special-wrap] is a procedure, then it is applied the + special value to produce the result (as for + @racket[read-char-or-special]).} + + @item{If @racket[special-wrap] is @racket['special], then + @racket['special] is returned in place of the special + value---without calling the special-value procedure that is + returned by the input-port implementation.} + +] @history[#:changed "6.8.0.2" @elem{Added the @racket[special-wrap] and - @racket[source-name] arguments.}]} + @racket[source-name] arguments.} + #:changed "6.90.0.16" @elem{Added @racket['special] as an option + for @racket[special-wrap].}]} @defproc[(peek-byte-or-special [in input-port? (current-input-port)] [skip-bytes-amt exact-nonnegative-integer? 0] [progress (or/c progress-evt? #f) #f] - [special-wrap (or/c (any/c -> any/c) #f) #f] + [special-wrap (or/c (any/c -> any/c) #f 'special) #f] [source-name any/c #f]) (or/c byte? eof-object? any/c)]{ @@ -432,7 +451,9 @@ like @racket[peek-bytes-avail!]. @history[#:changed "6.8.0.2" @elem{Added the @racket[special-wrap] and - @racket[source-name] arguments.}]} + @racket[source-name] arguments.} + #:changed "6.90.0.16" @elem{Added @racket['special] as an option + for @racket[special-wrap].}]} @defproc[(port-progress-evt [in (and/c input-port? port-provides-progress-evts?) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -354,14 +354,21 @@ identifier?]{ Returns an identifier with the same binding as @racket[id-stx], but -without lexical information from @racket[id-stx] that does not apply +without possibly lexical information from @racket[id-stx] that does not apply to the symbols in @racket[syms], where even further extension of the lexical information drops information for other symbols. In particular, transferring the lexical context via @racket[datum->syntax] from the result of this function to a symbol -other than one in @racket[syms] produces an identifier with no binding. +other than one in @racket[syms] may produce an identifier with no binding. -See also @racket[quote-syntax/prune].} +Currently, the result is always @racket[id-stx] exactly. Pruning was +intended primarily as a kind of optimization in a previous version of +Racket, but it is less useful and difficult to implement efficiently +in the current macro expander. + +See also @racket[quote-syntax/prune]. + +@history[#:changed "6.5" @elem{Always return @racket[id-stx].}]} @defproc[(identifier-prune-to-source-module [id-stx identifier?]) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-patterns.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1,5 +1,5 @@ #lang scribble/doc -@(require "mz.rkt") +@(require "mz.rkt" (for-label syntax/parse)) @(define lit-ellipsis (racket ...)) @@ -11,23 +11,24 @@ @title[#:tag "stx-patterns"]{Pattern-Based Syntax Matching} -@defform/subs[(syntax-case stx-expr (literal-id ...) +@defform/subs[#:literals (_) + (syntax-case stx-expr (literal-id ...) clause ...) ([clause [pattern result-expr] [pattern fender-expr result-expr]] - [pattern _ - id + [pattern np-pattern (pattern ...) - (pattern ...+ . pattern) - (pattern ... pattern ellipsis pattern ...) - (pattern ... pattern ellipsis pattern ... . pattern) - (code:line #,(tt "#")(pattern ...)) - (code:line #,(tt "#")(pattern ... pattern ellipsis pattern ...)) - (code:line #,(tt "#&")pattern) - (code:line #,(tt "#s")(key-datum pattern ...)) - (code:line #,(tt "#s")(key-datum pattern ... pattern ellipsis pattern ...)) - (ellipsis stat-pattern) - const] + (pattern ...+ . np-pattern) + (pattern ... pattern ellipsis pattern ... . np-pattern)] + [np-pattern _ + id + (code:line #,(tt "#")(pattern ...)) + (code:line #,(tt "#")(pattern ... pattern ellipsis pattern ...)) + (code:line #,(tt "#&")pattern) + (code:line #,(tt "#s")(key-datum pattern ...)) + (code:line #,(tt "#s")(key-datum pattern ... pattern ellipsis pattern ...)) + (ellipsis stat-pattern) + const] [stat-pattern id (stat-pattern ...) (stat-pattern ...+ . stat-pattern) @@ -79,18 +80,13 @@ Any @tech{pattern variables} bound by the sub-@racket[pattern]s are bound by the complete pattern; the bindings must all be distinct.} - @specsubform[(pattern ...+ . pattern)]{ - - The last @racket[pattern] must not be a @racket/form[(pattern ...)], - @racket/form[(pattern ...+ . pattern)], @racket/form[(pattern ... pattern - ellipsis pattern ...)], or @racket/form[(pattern ... pattern ellipsis - pattern ... . pattern)] form. + @specsubform[(pattern ...+ . np-pattern)]{ Like the previous kind of pattern, but matches syntax objects that are not necessarily lists; for @math{n} sub-@racket[pattern]s before - the last sub-@racket[pattern], the syntax object's datum must be a - pair such that @math{n-1} @racket[cdr]s produce pairs. The last - sub-@racket[pattern] is matched against the syntax object + the final @racket[np-pattern], the syntax object's datum must be a + pair such that @math{n-1} @racket[cdr]s produce pairs. The final + @racket[np-pattern] is matched against the syntax object corresponding to the @math{n}th @racket[cdr] (or the @racket[datum->syntax] coercion of the datum using the nearest enclosing syntax object's lexical context and source location).} @@ -111,11 +107,11 @@ lists of syntax objects with a @tech{depth marker} of @math{2}, and so on.)} - @specsubform[(pattern ... pattern ellipsis pattern ... . pattern)]{ + @specsubform[(pattern ... pattern ellipsis pattern ... . np-pattern)]{ Like the previous kind of pattern, but with a final - sub-@racket[pattern] as for @racket[(pattern ...+ . pattern)]. The - final @racket[pattern] never matches a syntax object whose datum is a + @racket[np-pattern] as for @racket[(pattern ...+ . np-pattern)]. The + final @racket[np-pattern] never matches a syntax object whose datum is a pair.} @specsubform[(code:line #,(tt "#")(pattern ...))]{ @@ -270,30 +266,37 @@ (math 3 1 4 1 5 9) ]} -@defform/subs[(syntax template) - ([template id - (template-elem ...) - (template-elem ...+ . template) - (code:line #,(tt "#")(template-elem ...)) - (code:line #,(tt "#&")template) - (code:line #,(tt "#s")(key-datum template-elem ...)) - (ellipsis stat-template) - const] - [template-elem (code:line template ellipsis ...)] - [stat-template id - (stat-template ...) - (stat-template ... . stat-template) - (code:line #,(tt "#")(stat-template ...)) - (code:line #,(tt "#&")stat-template) - (code:line #,(tt "#s")(key-datum stat-template ...)) - const] - [ellipsis #,lit-ellipsis])]{ +@defform[#:literals (~? ~@) (syntax template) + #:grammar + ([template id + (head-template ...) + (head-template ...+ . template) + (code:line #,(tt "#")(head-template ...)) + (code:line #,(tt "#&")template) + (code:line #,(tt "#s")(key-datum head-template ...)) + (~? template template) + (ellipsis stat-template) + const] + [head-template template + (code:line head-template ellipsis ...+) + (~@ . template) + (~? head-template head-template) + (~? head-template)] + [stat-template @#,elem{like @svar{template}, but without @|lit-ellipsis|, + @racket[~?], and @racket[~@]}] + [ellipsis #,lit-ellipsis])]{ Constructs a syntax object based on a @racket[template], which can include @tech{pattern variables} bound by @racket[syntax-case] or @racket[with-syntax]. -Template forms produce a syntax object as follows: +A @svar[template] produces a single syntax object. A +@svar[head-template] produces a sequence of zero or more syntax +objects. A @svar[stat-template] is like a @svar[template], except that +@|lit-ellipsis|, @racket[~?], and @racket[~@] are interpreted as +constants instead of template forms. + +A @svar[template] produces a syntax object as follows: @specsubform[id]{ @@ -314,54 +317,21 @@ If @racket[id] is not bound as a pattern variable, then @racket[id] as a template produces @racket[(quote-syntax id)].} - @specsubform[(template-elem ...)]{ + @specsubform[(head-template ...)]{ Produces a syntax object whose datum is a list, and where the elements of the list correspond to syntax objects produced by the - @racket[template-elem]s. - - A @racket[template-elem] is a sub-@racket[template] replicated by any - number of @racket[ellipsis]es: + @racket[head-template]s.} - @itemize[ - - @item{If the sub-@racket[template] is replicated by no - @racket[ellipsis]es, then it generates a single syntax object to - incorporate into the result syntax object.} - - @item{If the sub-@racket[template] is replicated by one - @racket[ellipsis], then it generates a sequence of syntax objects - that is ``inlined'' into the resulting syntax object. - - The number of generated elements depends on the values of - @tech{pattern variables} referenced within the - sub-@racket[template]. There must be at least one @tech{pattern - variable} whose value has a @tech{depth marker} less than the - number of @racket[ellipsis]es after the pattern variable within the - sub-@racket[template]. - - If a @tech{pattern variable} is replicated by more - @racket[ellipsis]es in a @racket[template] than the @tech{depth - marker} of its binding, then the @tech{pattern variable}'s result - is determined normally for inner @racket[ellipsis]es (up to the - binding's @tech{depth marker}), and then the result is replicated - as necessary to satisfy outer @racket[ellipsis]es.} - - @item{For each @racket[ellipsis] after the first one, the preceding - element (with earlier replicating @racket[ellipsis]es) is - conceptually wrapped with parentheses for generating output, and - then the wrapping parentheses are removed in the resulting syntax - object.}]} - - @specsubform[(template-elem ... . template)]{ + @specsubform[(head-template ... . template)]{ Like the previous form, but the result is not necessarily a list; instead, the place of the empty list in the resulting syntax object's datum is taken by the syntax object produced by @racket[template].} - @specsubform[(code:line #,(tt "#")(template-elem ...))]{ + @specsubform[(code:line #,(tt "#")(head-template ...))]{ - Like the @racket[(template-elem ...)] form, but producing a syntax + Like the @racket[(head-template ...)] form, but producing a syntax object whose datum is a vector instead of a list.} @specsubform[(code:line #,(tt "#&")template)]{ @@ -369,18 +339,37 @@ Produces a syntax object whose datum is a box holding the syntax object produced by @racket[template].} - @specsubform[(code:line #,(tt "#s")(key-datum template-elem ...))]{ + @specsubform[(code:line #,(tt "#s")(key-datum head-template ...))]{ - Like the @racket[(template-elem ...)] form, but producing a syntax + Like the @racket[(head-template ...)] form, but producing a syntax object whose datum is a @tech{prefab} structure instead of a list. The @racket[key-datum] must correspond to a valid first argument of @racket[make-prefab-struct].} + @specsubform[#:literals (~?) (~? template1 template2)]{ + + Produces the result of @racket[template1] if @racket[template1] has no + pattern variables with ``missing values''; otherwise, produces the result of + @racket[template2]. + + A pattern variable bound by @racket[syntax-case] never has a missing value, but + pattern variables bound by @racket[syntax-parse] (for example, @racket[~or] or + @racket[~optional] patterns) can. + + @examples[#:eval (let ([ev (syntax-eval)]) (ev '(require syntax/parse/pre)) ev) + (syntax-parse #'(m 1 2 3) + [(_ (~optional (~seq #:op op:expr)) arg:expr ...) + #'((~? op +) arg ...)]) + (syntax-parse #'(m #:op max 1 2 3) + [(_ (~optional (~seq #:op op:expr)) arg:expr ...) + #'((~? op +) arg ...)]) + ]} + @specsubform[(ellipsis stat-template)]{ Produces the same result as @racket[stat-template], which is like a - @racket[template], but @racket[...] is treated like an @racket[id] - (with no pattern binding).} + @racket[template], but @racket[...], @racket[~?], and @racket[~@] + are treated like an @racket[id] (with no pattern binding).} @specsubform[const]{ @@ -388,11 +377,74 @@ preceding cases, and it produces the result @racket[(quote-syntax const)].} +A @racket[head-template] produces a sequence of syntax objects; that sequence is +``inlined'' into the result of the enclosing @racket[template]. The result of a +@racket[head-template] is defined as follows: + + @specsubform[template]{ + + Produces one syntax object, according to the rules for @svar[template] + above.} + + @specsubform[(code:line head-template ellipsis ...+)]{ + + Generates a sequence of syntax objects by ``@racket[map]ping'' the + @racket[head-template] over the values of its pattern variables. The number of + iterations depends on the values of the @tech{pattern variables} referenced + within the sub-template. + + To be more precise: Let @racket[_outer] be @racket[_inner] followed by one + ellipsis. A @tech{pattern variable} is an @deftech{iteration pattern variable} + for @racket[_outer] if occurs at a depth equal to its @tech{depth + marker}. There must be at least one; otherwise, an error is raised. If there + are multiple iteration variables, then all of their values must be lists of + the same length. The result for @racket[_outer] is produced by + @racket[map]ping the @racket[_inner] template over the @tech{iteration pattern + variable} values and decreasing their effective @tech{depth markers} by 1 + within @racket[_inner]. The @racket[_outer] result is formed by appending the + @racket[_inner] results. + + Consequently, if a @tech{pattern variable} occurs at a depth greater than its + @tech{depth marker}, it is used as an @tech{iteration pattern variable} for + the innermost ellipses but not the outermost. A @tech{pattern variable} must + not occur at a depth less than its @tech{depth marker}; otherwise, an error is + raised.} + + @specsubform[#:literals (~@) (~@ . template)]{ + + Produces the sequence of elements in the syntax list produced by + @racket[template]. If @racket[template] does not produce a proper syntax list, + an exception is raised. + + @examples[#:eval (syntax-eval) + (with-syntax ([(key ...) #'('a 'b 'c)] + [(val ...) #'(1 2 3)]) + #'(hash (~@ key val) ...)) + (with-syntax ([xs #'(2 3 4)]) + #'(list 1 (~@ . xs) 5)) + ]} + + @specsubform[#:literals (~?) (~? head-template1 head-template2)]{ + + Produces the result of @racket[head-template1] if none of its pattern + variables have ``missing values''; otherwise produces the result of + @racket[head-template2]. } + + @specsubform[#:literals (~?) (~? head-template)]{ + + Produces the result of @racket[head-template] if none of its pattern + variables have ``missing values''; otherwise produces nothing. + + Equivalent to @racket[(~? head-template (~@))]. } + A @racket[(#,(racketkeywordfont "syntax") template)] form is normally abbreviated as @racket[#'template]; see also @secref["parse-quote"]. If @racket[template] contains no pattern variables, then @racket[#'template] is equivalent to -@racket[(quote-syntax template)].} +@racket[(quote-syntax template)]. + +@history[#:changed "6.90.0.25" @elem{Added @racket[~@] and @racket[~?].}] +} @defform[(quasisyntax template)]{ @@ -430,16 +482,28 @@ for use only with a @racket[quasisyntax] template.} -@defform[(syntax/loc stx-expr template)]{ +@defform[(syntax/loc stx-expr template) + #:contracts ([stx-expr syntax?])]{ Like @racket[syntax], except that the immediate resulting syntax object takes its source-location information from the result of -@racket[stx-expr] (which must produce a syntax object), unless the -@racket[template] is just a pattern variable, or both the source and -position of @racket[stx-expr] are @racket[#f].} +@racket[stx-expr] (which must produce a syntax object). +Only the source location of the immediate result---the ``outermost'' +syntax object---is adjusted. The source location is @emph{not} +adjusted if both the source and position of @racket[stx-expr] are +@racket[#f]. The source location is adjusted only if the resulting +syntax object comes from the template itself rather than the value of +a syntax pattern variable. For example, if @racket[_x] is a syntax +pattern variable, then @racket[(syntax/loc stx-expr _x)] does not use +the location of @racket[stx-expr]. + +@history[#:changed "6.90.0.25" @elem{Previously, @racket[syntax/loc] +did not enforce the contract on @racket[stx-expr] if @racket[template] +was just a pattern variable.}]} -@defform[(quasisyntax/loc stx-expr template)]{ +@defform[(quasisyntax/loc stx-expr template) + #:contracts ([stx-expr syntax?])]{ Like @racket[quasisyntax], but with source-location assignment like @racket[syntax/loc].} @@ -512,6 +576,16 @@ where it indicates a pattern that matches any syntax object. See @racket[syntax-case].} +@deftogether[[ +@defidform[~?] +@defidform[~@] +]]{ + +The @racket[~?] and @racket[~@] transformer bindings prohibit these forms from +being used as an expression. The bindings are useful only in syntax templates. +See @racket[syntax]. + +@history[#:added "6.90.0.25"]} @defproc[(syntax-pattern-variable? [v any/c]) boolean?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-props.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-props.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-props.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-props.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -157,6 +157,16 @@ @history[#:changed "6.4.0.14" @elem{Added the @racket[preserved?] argument.}]} +@defproc[(syntax-property-remove [stx syntax?] + [key any/c]) + syntax?]{ + +Returns a syntax object like @racket[stx], but without a property (if +any) for @racket[key]. + +@history[#:added "6.90.0.20"]} + + @defproc[(syntax-property-preserved? [stx syntax?] [key (and/c symbol? symbol-interned?)]) boolean?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -14,7 +14,7 @@ @(define (transform-time) @t{This procedure must be called during the dynamic extent of a @tech{syntax transformer} application by the -expander or while a module is @tech{visit}ed (see +expander or while a module is @tech{visit}ed (see @racket[syntax-transforming?]), otherwise the @exnraise[exn:fail:contract].}) @@ -233,11 +233,10 @@ @defproc[(local-expand [stx any/c] [context-v (or/c 'expression 'top-level 'module 'module-begin list?)] [stop-ids (or/c (listof identifier?) empty #f)] - [intdef-ctx (or/c internal-definition-context? - (and/c pair? - (listof internal-definition-context?)) + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) #f) - #f]) + '()]) syntax?]{ Expands @racket[stx] in the lexical context of the expression @@ -248,41 +247,48 @@ already a @tech{syntax object}, it is coerced with @racket[(datum->syntax #f stx)] before expansion. -When an identifier in @racket[stop-ids] is encountered by the expander -in a sub-expression, expansions stops for the sub-expression. If -@racket[stop-ids] is a non-empty list and does not contain just @racket[module*], then -@racket[begin], @racket[quote], @racket[set!], @racket[lambda], -@racket[case-lambda], @racket[let-values], @racket[letrec-values], -@racket[if], @racket[begin0], @racket[with-continuation-mark], -@racket[letrec-syntaxes+values], @racket[#%app], -@racket[#%expression], @racket[#%top], and -@racket[#%variable-reference] are added to @racket[stop-ids]. If -@racket[#%app] or @racket[#%datum] appears in -@racket[stop-ids], then application and -literal data expressions without the respective explicit form are not -wrapped with the explicit form, and @racket[#%top] wrappers are -never added (even with an empty @racket[stop-ids] list). - -If @racket[stop-ids] is an empty list, then @racket[stx] is expanded -recursively (i.e., expansion proceeds to sub-expressions). - -If @racket[stop-ids] is @racket[#f] -instead of a list, then @racket[stx] is expanded only as long as the -outermost form of @racket[stx] is a macro (i.e., expansion does not -proceed to sub-expressions). - -A fully expanded form can include the -bindings listed in @secref["fully-expanded"] plus the -@racket[letrec-syntaxes+values] form and @racket[#%expression] -in any expression position. - -When @racket[#%plain-module-begin] is not itself in @racket[stop-ids] -and @racket[module*] is in @racket[stop-ids], then the -@racket[#%plain-module-begin] transformer refrains from expanding -@racket[module*] sub-forms. Otherwise, the -@racket[#%plain-module-begin] transformer detects and expands sub-forms -(such as @racket[define-values]) independent of the corresponding -identifier's presence in @racket[stop-ids]. +The @racket[stop-ids] argument controls how far @racket[local-expand] expands @racket[stx]: + +@itemlist[ + @item{If @racket[stop-ids] is an empty list, then @racket[stx] is recursively expanded (i.e. + expansion proceeds to sub-expressions). The result is guaranteed to be a fully-expanded form, + which can include the bindings listed in @secref["fully-expanded"], plus @racket[#%expression] + in any expression position.} + + @item{If @racket[stop-ids] is a list containing just @racket[module*], then expansion proceeds as if + @racket[stop-ids] were an empty list, except that expansion does not recur to @tech{submodules} + defined with @racket[module*] (which are left unexpanded in the result).} + + @item{If @racket[stop-ids] is any other list, then @racket[begin], @racket[quote], @racket[set!], + @racket[#%plain-lambda], @racket[case-lambda], @racket[let-values], @racket[letrec-values], + @racket[if], @racket[begin0], @racket[with-continuation-mark], @racket[letrec-syntaxes+values], + @racket[#%plain-app], @racket[#%expression], @racket[#%top], and @racket[#%variable-reference] + are implicitly added to @racket[stop-ids]. Expansion stops when the expander encounters any of + the forms in @racket[stop-ids], and the result is the partially-expanded form. + + When the expander would normally implicitly introduce a @racketid[#%app], @racketid[#%datum], + or @racketid[#%top] identifier as described in @secref["expand-steps"], it checks to see if an + identifier with the same @tech{binding} as the one to be introduced appears in + @racket[stop-ids]. If so, the identifier is @emph{not} introduced; the result of expansion is + the bare application, literal data expression, or unbound identifier rather than one wrapped in + the respective explicit form. + + When @racket[#%plain-module-begin] is not in @racket[stop-ids], the + @racket[#%plain-module-begin] transformer detects and expands sub-forms (such as + @racket[define-values]) regardless of the identifiers presence in @racket[stop-ids]. + + Expansion does not replace the scopes in a local-variable + reference to match the binding identifier.} + + @item{If @racket[stop-ids] is @racket[#f] instead of a list, then @racket[stx] is expanded only as + long as the outermost form of @racket[stx] is a macro (i.e. expansion does @emph{not} proceed + to sub-expressions, and it does not replace the scopes in a local-variable reference to match the + binding identifier). The @racketid[#%app], @racketid[#%datum], and @racketid[#%top] identifiers are + never introduced.}] + +Independent of @racket[stop-ids], when @racket[local-expand] encounters an identifier that has a local +binding but no binding in the current expansion context, the variable is left as-is (as opposed to +triggering an ``out of context'' syntax error). When @racket[context-v] is @racket['module-begin], and the result of expansion is a @racket[#%plain-module-begin] form, then a @@ -290,13 +296,19 @@ @racket[module] form (but not @racket[module*] forms) in the same way as by @racket[module] expansion. -The optional @racket[intdef-ctx] argument must be either @racket[#f], -the result of @racket[syntax-local-make-definition-context], or a list -of such results. In the latter two cases, lexical information for -internal definitions is added to @racket[stx] before it is expanded -(in reverse order relative to the list). The lexical information is -also added to the expansion result (because the expansion might -introduce bindings or references to internal-definition bindings). +If the @racket[intdef-ctx] argument is an internal-definition context, its @tech{bindings} and +@tech{bindings} from all @tech{parent internal-definition contexts} are added to the +@tech{local binding context} during the dynamic extent of the call to @racket[local-expand]. +Additionally, unless @racket[#f] was provided for the @racket[_add-scope?] argument to +@racket[syntax-local-make-definition-context] when the internal-definition context was created, +its @tech{scope} (but @emph{not} the scopes of any @tech{parent internal-definition contexts}) is +added to the @tech{lexical information} for both @racket[stx] prior to its expansion and the expansion +result (because the expansion might introduce bindings or references to internal-definition bindings). +If @racket[intdef-ctx] is a list, all @tech{bindings} from all of the provided internal-definition +contexts and their parents are added to the @tech{local binding context}, and the @tech{scope} from +each context for which @racket[_add-scope?] was not @racket[#f] is added in the same way. For +backwards compatibility, providing @racket[#f] for @racket[intdef-ctx] is treated the same as +providing an empty list. For a particular @tech{internal-definition context}, generate a unique value and put it into a list for @racket[context-v]. To allow @@ -343,32 +355,54 @@ @history[#:changed "6.0.1.3" @elem{Changed treatment of @racket[#%top] so that it is never introduced as - an explicit wrapper.}]} + an explicit wrapper.} + #:changed "6.0.90.27" @elem{Loosened the contract on the @racket[intdef-ctx] argument to + allow an empty list, which is treated the same way as + @racket[#f].}]} -@defproc[(syntax-local-expand-expression [stx any/c]) - (values syntax? syntax?)]{ +@defproc[(syntax-local-expand-expression [stx any/c] [opaque-only? any/c #f]) + (values (if opaque-only? #f syntax?) syntax?)]{ Like @racket[local-expand] given @racket['expression] and an empty stop list, but with two results: a syntax object for the fully -expanded expression, and a syntax object whose content is opaque. The -latter can be used in place of the former (perhaps in a larger +expanded expression, and a syntax object whose content is opaque. + +The latter can be used in place of the former (perhaps in a larger expression produced by a macro transformer), and when the macro expander encounters the opaque object, it substitutes the fully expanded expression without re-expanding it; the @exnraise[exn:fail:syntax] if the expansion context includes -@tech{scopes} that were not present for the original expansion, in which -case re-expansion might produce different results. Consistent use of -@racket[syntax-local-expand-expression] and the opaque object thus -avoids quadratic expansion times when local expansions are nested. +@tech{scopes} that were not present for the original expansion, in +which case re-expansion might produce different results. Consistent +use of @racket[syntax-local-expand-expression] and the opaque object +thus avoids quadratic expansion times when local expansions are +nested. + +If @racket[opaque-only?] is true, then the first result is @racket[#f] +instead of the expanded expression. Obtaining only the second, opaque +result can be more efficient in some expansion contexts. + +Unlike @racket[local-expand], @racket[syntax-local-expand-expression] +normally produces an expanded expression that contains no +@racket[#%expression] forms. However, if +@racket[syntax-local-expand-expression] is used within an expansion +that is triggered by an enclosing @racket[local-expand] call, then the +result of @racket[syntax-local-expand-expression] can include +@racket[#%expression] forms. -@transform-time[]} +@transform-time[] + +@history[#:changed "6.90.0.13" @elem{Added the @racket[opaque-only?] argument.}]} @defproc[(local-transformer-expand [stx any/c] - [context-v (or/c 'expression 'top-level list?)] - [stop-ids (or/c (listof identifier?) #f)] - [intdef-ctx (or/c internal-definition-context? #f) #f]) + [context-v (or/c 'expression 'top-level list?)] + [stop-ids (or/c (listof identifier?) #f)] + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) + #f) + '()]) syntax?]{ Like @racket[local-expand], but @racket[stx] is expanded as a @@ -386,11 +420,15 @@ @racket['top-level] context.}]} -@defproc[(local-expand/capture-lifts [stx any/c] - [context-v (or/c 'expression 'top-level 'module 'module-begin list?)] - [stop-ids (or/c (listof identifier?) #f)] - [intdef-ctx (or/c internal-definition-context? #f) #f] - [lift-ctx any/c (gensym 'lifts)]) +@defproc[(local-expand/capture-lifts + [stx any/c] + [context-v (or/c 'expression 'top-level 'module 'module-begin list?)] + [stop-ids (or/c (listof identifier?) #f)] + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) + #f) + '()] + [lift-ctx any/c (gensym 'lifts)]) syntax?]{ Like @racket[local-expand], but the result is a syntax object that @@ -409,11 +447,15 @@ @racket['module], then @racket[module*] forms can appear, too.} -@defproc[(local-transformer-expand/capture-lifts [stx any/c] - [context-v (or/c 'expression 'top-level list?)] - [stop-ids (or/c (listof identifier?) #f)] - [intdef-ctx (or/c internal-definition-context? #f) #f] - [lift-ctx any/c (gensym 'lifts)]) +@defproc[(local-transformer-expand/capture-lifts + [stx any/c] + [context-v (or/c 'expression 'top-level list?)] + [stop-ids (or/c (listof identifier?) #f)] + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) + #f) + '()] + [lift-ctx any/c (gensym 'lifts)]) syntax?]{ Like @racket[local-expand/capture-lifts], but @racket[stx] is expanded @@ -429,29 +471,42 @@ @defproc[(syntax-local-make-definition-context - [intdef-ctx (or/c internal-definition-context? #f) #f] - [add-scope? any/c #f]) + [parent-ctx (or/c internal-definition-context? #f) #f] + [add-scope? any/c #t]) internal-definition-context?]{ -Creates an opaque @tech{internal-definition context} value to be used -with @racket[local-expand] and other functions. A transformer should -create one context for each set of internal definitions to be -expanded, and use it when expanding any form whose lexical context -should include the definitions. After discovering an internal -@racket[define-values] or @racket[define-syntaxes] form, use -@racket[syntax-local-bind-syntaxes] to add bindings to the context. - -An @tech{internal-definition context} internally creates a -@tech{scope} to represent the context. Unless @racket[add-scope?] is -@racket[#f], the @tech{scope} is added to any form that is expanded -within the context or that appears as the result of a (partial) -expansion within the context. - -If @racket[intdef-ctx] is not @racket[#f], then the new -internal-definition context extends the given one. An extending -definition context adds all @tech{scopes} that are added by -@racket[intdef-ctx], and expanding in the new internal-definition context -can use bindings previously introduced into @racket[intdef-ctx]. +Creates an opaque @tech{internal-definition context} value to be used with @racket[local-expand] and +other functions. A transformer should create one context for each set of internal definitions to be +expanded, and use it when expanding any form whose lexical context should include the definitions. +After discovering an internal @racket[define-values] or @racket[define-syntaxes] form, use +@racket[syntax-local-bind-syntaxes] to add @tech{bindings} to the context. + +An @tech{internal-definition context} internally creates a @tech{scope} to represent the context. +Unless @racket[add-scope?] is @racket[#f], the @tech{scope} is added to any form that is expanded +within the context or that appears as the result of a (partial) expansion within the context. + +If @racket[parent-ctx] is not @racket[#f], then @racket[parent-ctx] is made the @deftech{parent +internal-definition context} for the new internal-definition context. Whenever the new context’s +@tech{bindings} are added to the @tech{local binding context} (e.g. by providing the context to +@racket[local-expand], @racket[syntax-local-bind-syntaxes], or @racket[syntax-local-value]), then the +bindings from @racket[parent-ctx] are also added as well. If @racket[parent-ctx] was also created with a +@tech{parent internal-definition context}, @tech{bindings} from its parent are also added, and so on +recursively. Note that the @tech{scopes} of parent contexts are @emph{not} added implicitly, only the +@tech{bindings}, even when the @tech{scope} of the child context would be implicitly added. If the +@tech{scopes} of parent definition contexts should be added, the parent contexts must be provided +explicitly. + +Additionally, if the created definition context is intended to be spliced into a surrounding +definition context, the surrounding context should always be provided for the @racket[parent-ctx] +argument to ensure the necessary @tech{use-site scopes} are added to macros expanded in the context. +Otherwise, expansion of nested definitions can be inconsistent with the expansion of definitions in +the surrounding context. + +The scope associated with a new definition context is pruned from +@racket[quote-syntax] forms only when it is created during the dynamic +extent of a @tech{syntax transformer} application or in a +@racket[begin-for-syntax] form (potentially nested) within a module +being expanded. @transform-time[] @@ -463,7 +518,10 @@ @defproc[(syntax-local-bind-syntaxes [id-list (listof identifier?)] [expr (or/c syntax? #f)] - [intdef-ctx internal-definition-context?]) + [intdef-ctx internal-definition-context?] + [extra-intdef-ctxs (or/c internal-definition-context? + (listof internal-definition-context?)) + '()]) void?]{ Binds each identifier in @racket[id-list] within the @@ -477,7 +535,16 @@ match the number of identifiers, otherwise the @exnraise[exn:fail:contract:arity]. -@transform-time[]} +When @racket[expr] is not @racket[#f], it is expanded in an @tech{expression context} and evaluated in +the current @tech{transformer environment}. In this case, the @tech{bindings} and @tech{lexical +information} from both @racket[intdef-ctx] and @racket[extra-intdef-ctxs] are used to enrich +@racket[expr]’s @tech{lexical information} and extend the @tech{local binding context} in the same way +as the fourth argument to @racket[local-expand]. If @racket[expr] is @racket[#f], the value provided +for @racket[extra-intdef-ctxs] is ignored. + +@transform-time[] + +@history[#:changed "6.90.0.27" @elem{Added the @racket[extra-intdef-ctxs] argument.}]} @defproc[(internal-definition-context-binding-identifiers @@ -573,16 +640,16 @@ [failure-thunk (or/c (-> any) #f) #f] [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) #f) - #f]) + '()]) any]{ -Returns the @tech{transformer} binding value of the identifier -@racket[id-stx] in either the context associated with -@racket[intdef-ctx] (if not @racket[#f]) or the context of the -expression being expanded (if @racket[intdef-ctx] is @racket[#f]). If -@racket[intdef-ctx] is provided, it must be an extension of the -context of the expression being expanded. +Returns the @tech{transformer} binding value of the identifier @racket[id-stx] in the context of the +current expansion. If @racket[intdef-ctx] is not @racket[#f], bindings from all provided definition +contexts are also considered. @emph{Unlike} the fourth argument to @racket[local-expand], the +@tech{scopes} associated with the provided definition contexts are @emph{not} used to enrich +@racket[id-stx]’s @tech{lexical information}. If @racket[id-stx] is bound to a @tech{rename transformer} created with @racket[make-rename-transformer], @racket[syntax-local-value] @@ -616,15 +683,21 @@ (define-syntax (transformer-3 stx) (syntax-local-value #'chips)) (transformer-3) -]} +] + +@history[ + #:changed "6.90.0.27" @elem{Changed @racket[intdef-ctx] to accept a list of internal-definition + contexts in addition to a single internal-definition context or + @racket[#f].}]} @defproc[(syntax-local-value/immediate [id-stx syntax?] [failure-thunk (or/c (-> any) #f) #f] [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) #f) - #f]) + '()]) any]{ Like @racket[syntax-local-value], but the result is normally two @@ -660,7 +733,7 @@ lifted to a @racket[let] wrapper around the corresponding right-hand side of the binding. A compile-time expression within @racket[begin-for-syntax] is lifted to a @racket[define] -declaration just before the requesting expression within the +declaration just before the requesting expression within the @racket[begin-for-syntax]. Other syntactic forms can capture lifts by using @@ -731,7 +804,7 @@ enclosing @racket[begin-for-syntax]. @transform-time[] If the current expression being transformed is not -within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), +within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), then the @exnraise[exn:fail:contract].} @@ -759,7 +832,12 @@ @racket[syntax-local-lift-require]. Otherwise, marks added by the macro expander can prevent access to the new imports. -@transform-time[]} +@transform-time[] + +@history[#:changed "6.90.0.27" @elem{Changed the @tech{scope} added to inputs from a + macro-introduction scope to one that does not affect whether or + not the resulting syntax is considered original as reported by + @racket[syntax-original?].}]} @defproc[(syntax-local-lift-provide [raw-provide-spec-stx syntax?]) void?]{ @@ -875,14 +953,14 @@ @defproc[(syntax-local-make-delta-introducer [id-stx identifier?]) procedure?]{ -For (limited) backward compatibility only; raises @racket[exn:fail:supported]. +For (limited) backward compatibility only; raises @racket[exn:fail:unsupported]. @history[#:changed "6.3" @elem{changed to raise @racket[exn:fail:supported].}]} @defproc[(syntax-local-certifier [active? boolean? #f]) - ((syntax?) (any/c (or/c procedure? #f)) + ((syntax?) (any/c (or/c procedure? #f)) . ->* . syntax?)]{ For backward compatibility only; returns a procedure that returns its @@ -968,7 +1046,28 @@ added the optional operation argument in the result procedure.}]} -@defproc[(make-syntax-delta-introducer [ext-stx identifier?] +@defproc[(make-interned-syntax-introducer [key symbol?]) + ((syntax?) ((or/c 'flip 'add 'remove)) . ->* . syntax?)]{ + +Like @racket[make-syntax-introducer], but the encapsulated @tech{scope} is interned. Multiple calls to +@racket[make-interned-syntax-introducer] with the same @racket[key] will produce procedures that flip, +add, or remove the same scope, even across @tech{phases} and module @tech{instantiations}. +Furthermore, the scope remains consistent even when embedded in @tech{compiled} code, so a scope +created with @racket[make-interned-syntax-introducer] will retain its identity in syntax objects +loaded from compiled code. (In this sense, the relationship between @racket[make-syntax-introducer] +and @racket[make-interned-syntax-introducer] is analogous to the relationship between +@racket[gensym] and @racket[quote].) + +This function is intended for the implementation of separate binding environments within a single +phase, for which the scope associated with each environment must be the same across modules. + +Unlike @racket[make-syntax-introducer], the scope added by a procedure created with +@racket[make-interned-syntax-introducer] is always treated like a use-site scope, not a +macro-introduction scope, so it does not affect originalness as reported by @racket[syntax-original?]. + +@history[#:added "6.90.0.28"]} + +@defproc[(make-syntax-delta-introducer [ext-stx identifier?] [base-stx (or/c syntax? #f)] [phase-level (or/c #f exact-integer?) (syntax-local-phase-level)]) @@ -1161,9 +1260,9 @@ @defstruct[import ([local-id identifier?] [src-sym symbol?] - [src-mod-path (or/c module-path? + [src-mod-path (or/c module-path? (and/c syntax? - (lambda (stx) + (lambda (stx) (module-path? (syntax->datum stx)))))] [mode (or/c exact-integer? #f)] [req-mode (or/c exact-integer? #f)] @@ -1256,7 +1355,7 @@ @defproc[(syntax-local-require-certifier) - ((syntax?) (or/c #f (syntax? . -> . syntax?)) + ((syntax?) (or/c #f (syntax? . -> . syntax?)) . ->* . syntax?)]{ For backward compatibility only; returns a procedure that returns its @@ -1433,7 +1532,7 @@ @defproc[(syntax-local-provide-certifier) - ((syntax?) (or/c #f (syntax? . -> . syntax?)) + ((syntax?) (or/c #f (syntax? . -> . syntax?)) . ->* . syntax?)]{ For backward compatibility only; returns a procedure that returns its @@ -1447,13 +1546,13 @@ @deftogether[( @defproc[(syntax-procedure-alias-property [stx syntax?]) - (or/c #f + (or/c #f (letrec ([val? (recursive-contract (or/c (cons/c identifier? identifier?) (cons/c val? val?)))]) val?))] @defproc[(syntax-procedure-converted-arguments-property [stx syntax?]) - (or/c #f + (or/c #f (letrec ([val? (recursive-contract (or/c (cons/c identifier? identifier?) (cons/c val? val?)))]) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/surrogate.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/surrogate.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/surrogate.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/surrogate.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -16,7 +16,7 @@ @defform/subs[#:literals (augment override override-final) (surrogate use-wrapper-proc method-spec ...) ([use-wrapper-proc #:use-wrapper-proc (code:line)] - [method-spec (augment method-id arg-spec ...) + [method-spec (augment default-expr method-id arg-spec ...) (override method-id arg-spec ...) (override-final method-id (lambda () default-expr) arg-spec ...)] @@ -52,7 +52,7 @@ skipping the surrogate. The other one invokes the surrogate. @racketblock[(λ (fallback-thunk surrogate-thunk) (surrogate-thunk))] -which means that it simply defers to the method being invoked on the surrogate. +This means that it simply defers to the method being invoked on the surrogate. The @racket[_surrogate-wrapper-proc] capability is part of the surrogate so that the dynamic extent of the calls to the surrogate can be adjusted (by, for example, changing the values of parameters). The @@ -62,7 +62,7 @@ The host mixin has a single overriding method for each @racket[method-id] in the @racket[surrogate] form (even the ones -specified with @racket[augment]. Each of these +specified with @racket[augment]). Each of these methods is defined with a @racket[case-lambda] with one arm for each @racket[arg-spec]. Each arm has the variables as arguments in the @racket[arg-spec]. The body of each method tests the diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -155,15 +155,12 @@ @;------------------------------------------------------------------------ @section[#:tag "stxobj-model"]{Syntax Objects} -A @deftech{syntax object} combines a simpler Racket value, such as a -symbol or pair, with a @tech{scope set} at each @tech{phase level}, -source-location information, @tech{syntax properties}, and -@tech{tamper status}. In particular, an @tech{identifier} is -represented as a syntax object that combines a @tech{symbol} with scope sets -and other information. The @deftech{lexical information} of a -@tech{syntax object} is its @tech{scope set} combined with the portion -of the global table of bindings that is relevant to the syntax -object's set of scopes. +A @deftech{syntax object} combines a simpler Racket value, such as a symbol or pair, with +@tech{lexical information}, source-location information, @tech{syntax properties}, and @tech{tamper +status}. The @deftech{lexical information} of a @tech{syntax object} comprises a set of @tech{scope +sets}, one for each @tech{phase level}. In particular, an @tech{identifier} is represented as a syntax +object containing a @tech{symbol}, and its @tech{lexical information} can be combined with the global +table of bindings to determine its @tech{binding} (if any) at each @tech{phase level}. For example, a @racketidfont{car} @tech{identifier} might have @tech{lexical information} that designates it as the @racket[car] from @@ -581,8 +578,8 @@ @secref["expand-steps"]. Before the expander passes a @tech{syntax object} to a transformer, -the @tech{syntax object} is extended with a fresh @tech{scope} (that -applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects} +the @tech{syntax object} is extended with a fresh @deftech{macro-introduction scope} +(that applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects} at the macro's use site from @tech{syntax objects} that are introduced by the macro; in the result of the transformer the presence of the @tech{scope} is flipped, so that introduced @tech{syntax objects} retain the @tech{scope}, @@ -718,6 +715,81 @@ @tech{transformer} binding at @tech{phase level} 0). @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +@subsection[#:tag "local-binding-context"]{Local Binding Context} + +Although the @tech{binding} of an @tech{identifier} can be uniquely determined from the combination of +its @tech{lexical information} and the global binding table, the expander also maintains a +@deftech{local binding context} that records additional information about @tech{local bindings} to +ensure they are not used outside of the lexical region in which they are bound. + +Due to the way local binding forms like @racket[let] add a fresh @tech{scope} to both bound +@tech{identifiers} and body forms, it isn’t ordinarily possible for an @tech{identifier} to reference +a @tech{local binding} without appearing in the body of the @racket[let]. However, if macros use +compile-time state to stash bound @tech{identifiers}, or use @racket[local-expand] to extract +@tech{identifiers} from an expanded binding form, they can violate this constraint. For example, the +following @racket[stash-id] and @racket[unstash-id] macros cooperate to move a reference to a +locally-bound @racket[x] @tech{identifier} outside of the lexical region in which it is bound: + +@(examples + #:label #f + #:eval racket-eval + (begin-for-syntax + (define stashed-id #f)) + (define-syntax (stash-id stx) + (syntax-case stx () + [(_ id) + (begin + (set! stashed-id #'id) + #'(void))])) + (define-syntax (unstash-id stx) + stashed-id) + (let ([x 42]) + (stash-id x) + (unstash-id)) + (eval:error (unstash-id))) + +In general, an @tech{identifier}’s @tech{lexical information} is not sufficient to know whether or not +its @tech{binding} is available in the enclosing context, since the @tech{scope set} for the +@tech{identifier} stored in @racket[stashed-id] unambiguously refers to a binding in the global +binding table. This can be observed by the fact that @racket[identifier-binding] produces +@racket['lexical], not @racket[#f]: + +@(examples + #:label #f + #:eval racket-eval + #:escape UNSYNTAX + (define-syntax (stashed-id-binding stx) + #`(quote #,(identifier-binding stashed-id))) + (eval:check (stashed-id-binding) 'lexical)) + +However, the reference produced by @racket[(unstash-id)] in the above program is still illegal, even +if it isn’t technically unbound. To record the fact that @racket[x]’s @tech{binding} is in scope only +within the body of its corresponding @racket[let] form, the expander adds @racket[x]’s @tech{binding} +to the @tech{local binding context} while expanding the @racket[let] body. More generally, the +expander adds all @tech{local variable} @tech{bindings} to the @tech{local binding context} while +expanding expressions in which a reference to the @tech{variable} would be legal. When the expander +encounters an @tech{identifier} bound to a @tech{local variable}, and the associated @tech{binding} is +not in the current @tech{local binding context}, it raises a syntax error. + +The @tech{local binding context} also tracks local @tech{transformer} @tech{bindings} (i.e. bindings +bound by forms like @racket[let-syntax]) in a similar way, except that the context also stores the +compile-time value associated with the @tech{transformer}. When an @tech{identifier} that is locally +bound as a @tech{transformer} is used in application position as a @tech{syntax transformer}, or its +compile-time value is looked up using @racket[syntax-local-value], the @tech{local binding context} is +consulted to retrieve the value. If the @tech{binding} is in scope, its associated compile-time value +is used; otherwise, the expander raises a syntax error. + +@(examples + #:eval racket-eval + #:escape UNSYNTAX + (define-syntax (stashed-id-local-value stx) + #`(quote #,(syntax-local-value stashed-id))) + (let-syntax ([y 42]) + (stash-id y) + (stashed-id-local-value)) + (eval:error (stashed-id-local-value))) + +@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @subsection[#:tag "partial-expansion"]{Partial Expansion} In certain contexts, such as an @tech{internal-definition context} or @@ -1170,7 +1242,8 @@ boolean identifier string - bytes] + bytes + ()] ] This grammar applies after @tech{expansion}, but because a @tech{cross-phase persistent} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -2583,20 +2583,17 @@ This form expands to @racket[define-syntax] with a use of @racket[make-require-transformer] (see @secref["require-trans"] for -more information), and the @tech{syntax object} passed to and from the -macro transformer is adjusted via @racket[syntax-local-require-introduce]. +more information). The second form is a shorthand the same as for @racket[define-syntax]; it expands to a definition of the first form where the @racket[proc-expr] is a @racket[lambda] form.} -@defproc[(syntax-local-require-introduce [stx syntax?]) - syntax?]{ +@defproc[(syntax-local-require-introduce [stx syntax?]) syntax?]{ -Provided @racket[for-syntax] for use only during the application of a -@racket[require] sub-form macro transformer: like -@racket[syntax-local-introduce], but for @racket[require] sub-form -expansion.} +For backward compatibility only; equivalent to @racket[syntax-local-introduce]. + +@history[#:changed "6.90.0.29" @elem{Made equivalent to @racket[syntax-local-introduce].}]} @; ---------------------------------------------------------------------- @@ -2614,20 +2611,17 @@ This form expands to @racket[define-syntax] with a use of @racket[make-provide-transformer] (see @secref["provide-trans"] for -more information), and the @tech{syntax object} passed to and from the -macro transformer is adjusted via @racket[syntax-local-provide-introduce]. +more information). The second form is a shorthand the same as for @racket[define-syntax]; it expands to a definition of the first form where the @racket[expr] is a @racket[lambda] form.} -@defproc[(syntax-local-provide-introduce [stx syntax?]) - syntax?]{ +@defproc[(syntax-local-provide-introduce [stx syntax?]) syntax?]{ + +For backward compatibility only; equivalent to @racket[syntax-local-introduce]. -Provided @racket[for-syntax] for use only during the application of a -@racket[provide] sub-form macro transformer: like -@racket[syntax-local-introduce], but for @racket[provide] sub-form -expansion.} +@history[#:changed "6.90.0.29" @elem{Made equivalent to @racket[syntax-local-introduce].}]} @;------------------------------------------------------------------------ @section[#:tag "begin"]{Sequencing: @racket[begin], @racket[begin0], and @racket[begin-for-syntax]} @@ -2866,7 +2860,7 @@ (eval:alts (#,(racket quasiquote) (0 1 2)) `(0 1 2)) (eval:alts (#,(racket quasiquote) (0 (#,unquote-id (+ 1 2)) 4)) `(0 ,(+ 1 2) 4)) (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id (list 1 2)) 4)) `(0 ,@(list 1 2) 4)) -(eval:error (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1) 4)) `(0 ,@1 4))) +(eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1) 4)) (eval:error `(0 ,@1 4))) (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1))) `(0 ,@1)) ] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -195,16 +195,22 @@ [stx syntax?]) syntax?]{ -Applies the renamings of @racket[intdef-ctx] to @racket[stx]. +Equivalent to @racket[(internal-definition-context-introduce intdef-ctx stx 'add)]. The +@racket[internal-definition-context-apply] function is provided for backwards compatibility; the more +general @racket[internal-definition-context-introduce] function is preferred. } @defproc[(syntax-local-eval [stx syntax?] - [intdef-ctx (or/c internal-definition-context? #f) #f]) + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?) + #f) + '()]) any]{ -Evaluates @racket[stx] as an expression in the current transformer -environment (that is, at phase level 1), optionally extended with -@racket[intdef-ctx]. +Evaluates @racket[stx] as an expression in the current @tech{transformer environment} (that is, at +@tech{phase level} 1). If @racket[intdef-ctx] is not @racket[#f], the value provided for +@racket[intdef-ctx] is used to enrich @racket[stx]’s @tech{lexical information} and extend the +@tech{local binding context} in the same way as the fourth argument to @racket[local-expand]. @examples[#:eval the-eval (define-syntax (show-me stx) @@ -220,6 +226,11 @@ (define fruit 'pear) (show-me fruit) ] + +@history[ + #:changed "6.90.0.27" @elem{Changed @racket[intdef-ctx] to accept a list of internal-definition + contexts in addition to a single internal-definition context or + @racket[#f].}] } @defform[(with-syntax* ([pattern stx-expr] ...) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/trace.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/trace.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/trace.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/trace.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -5,6 +5,10 @@ (ev '(require racket/trace)) (ev '(require (for-syntax racket/base)))) +@(begin (define ev1 (make-base-eval)) + (ev1 '(require racket/trace)) + (ev1 '(require (for-syntax racket/base)))) + @title{Tracing} @note-lib-only[racket/trace] @@ -47,6 +51,26 @@ (f 10) ] +@racket[trace] can also be used to debug @tech{syntax transformers}. +This is verbose to do directly with @racket[trace]; refer to @racket[trace-define-syntax] for a +simpler way to do this. + +@examples[#:eval ev +(require (for-syntax racket/trace)) +(begin-for-syntax + (define _let + (syntax-rules () + [(_ ([x v]) e) ((lambda (x) e) v)])) + (trace _let)) +(define-syntax let _let) + +(let ([x 120]) x) +] + +When tracing syntax transformers, it may be helpful to modify @racket[current-trace-print-args] and +@racket[current-trace-print-results] to make the trace output more readable; see +@racket[current-trace-print-args] for an extended example. + } @defform*[((trace-define id expr) @@ -69,7 +93,7 @@ (trace-define-syntax (head args) body ...+))]{ The @racket[trace-define-syntax] form is short-hand for first defining a -macro then tracing it. This form supports all @racket[define-syntax] forms. +syntax transformer then tracing it. This form supports all @racket[define-syntax] forms. For example: @@ -81,25 +105,11 @@ ] By default, @racket[trace] prints out syntax objects when tracing a -macro. This can result in too much output if you do not need to see, -e.g., source information. To get more readable output, try this: - -@examples[#:eval ev - (require (for-syntax racket/trace)) - (begin-for-syntax - (current-trace-print-args - (let ([ctpa (current-trace-print-args)]) - (lambda (s l kw l2 n) - (ctpa s (map syntax->datum l) kw l2 n)))) - (current-trace-print-results - (let ([ctpr (current-trace-print-results)]) - (lambda (s l n) - (ctpr s (map syntax->datum l) n))))) - - (trace-define-syntax fact - (syntax-rules () - [(_ x) #'120])) - (fact 5)]} +syntax transformer. This can result in too much output if you do not need to see, +e.g., source information. +To get more readable output by printing syntax objects as datums, we can modify the +@racket[current-trace-print-args] and @racket[current-trace-print-results]. +See @racket[current-trace-print-args] for an example. @defform[(trace-lambda [#:name id] args expr)]{ @@ -165,6 +175,77 @@ ordinary arguments, its keywords, the values of the keywords, and a number indicating the depth of the call. +Modifying this and @racket[current-trace-print-results] is useful to to get more +readable or additional output when tracing syntax transformers. +For example, we can use @racketmodname[debug-scopes #:indirect] to add scopes information +to the trace, (see @racketmodname[debug-scopes #:indirect] for an example), +or remove source location information to just display the shape of the syntax +object + +In this example, we update the printers @racket[current-trace-print-args] and +@racket[current-trace-print-results] +by storing the current printers (@racket[ctpa] and +@racket[ctpr]) to cast syntax objects to datum using @racket[syntax->datum] and then +pass the transformed arguments and results to the previous printer. +When tracing, syntax arguments will be displayed without source location +information, shortening the output. + +@examples[#:eval ev + (require (for-syntax racket/trace)) + (begin-for-syntax + (current-trace-print-args + (let ([ctpa (current-trace-print-args)]) + (lambda (s l kw l2 n) + (ctpa s (map syntax->datum l) kw l2 n)))) + (current-trace-print-results + (let ([ctpr (current-trace-print-results)]) + (lambda (s r n) + (ctpr s (map syntax->datum r) n))))) + + (trace-define-syntax fact + (syntax-rules () + [(_ x) 120])) + (fact 5)] + + +We must take care when modifying these parameters, especially when the +transformation makes assumptions about or changes the type of the +argument/result of the traced identifier. +This modification of @racket[current-trace-print-args] and +@racket[current-trace-print-results] is an imperative update, and will affect all traced identifiers. +This example assumes all arguments and results to @emph{all traced functions} will be syntax objects, +which is the case only if you are only tracing syntax transformers. +If used as-is, the above code could result in type errors when tracing both functions and syntax transformers. +It would be better to use @racket[syntax->datum] only when the argument or result is actually a syntax +object, for example, by defining @racket[maybe-syntax->datum] as follows. + +@examples[#:eval ev1 + (require (for-syntax racket/trace)) + (begin-for-syntax + (define (maybe-syntax->datum syn?) + (if (syntax? syn?) + (syntax->datum syn?) + syn?)) + (current-trace-print-args + (let ([ctpa (current-trace-print-args)]) + (lambda (s l kw l2 n) + (ctpa s (map maybe-syntax->datum l) kw l2 n)))) + (current-trace-print-results + (let ([ctpr (current-trace-print-results)]) + (lambda (s l n) + (ctpr s (map maybe-syntax->datum l) n)))) + + (trace-define (precompute-fact syn n) (datum->syntax syn (apply * (build-list n add1))))) + (trace-define (run-time-fact n) (apply * (build-list n add1))) + + (require (for-syntax syntax/parse)) + (trace-define-syntax (fact syn) + (syntax-parse syn + [(_ x:nat) (precompute-fact syn (syntax->datum #'x))] + [(_ x) #'(run-time-fact x)])) + (fact 5) + (fact (+ 2 3))]} + } @defparam[current-trace-print-results trace-print-results diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -77,7 +77,7 @@ @racket[arithmetic-shift], but require non-negative arguments; @racket[unsafe-fxlshift] is a positive (i.e., left) shift, and @racket[unsafe-fxrshift] is a negative (i.e., right) shift, where the -number of bits to shift must be less than the number of bits used to +number of bits to shift must be no more than the number of bits used to represent a @tech{fixnum}. In the case of @racket[unsafe-fxlshift], bits in the result beyond the number of bits used to represent a @tech{fixnum} are effectively replaced with a copy of the high bit.} @@ -655,6 +655,7 @@ @history[#:added "6.9.0.2"] } + @; ------------------------------------------------------------------------ @include-section["unsafe-undefined.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -9,20 +9,27 @@ The constant @racket[unsafe-undefined] is used internally as a placeholder value. For example, it is used by @racket[letrec] as a value for a variable that has not yet been assigned a value. Unlike -the @racket[undefined] value exported by @racket[racket/undefined], +the @racket[undefined] value exported by @racketmodname[racket/undefined], however, the @racket[unsafe-undefined] value should not leak as the -result of a safe expression. Expression results that potentially +result of a safe expression, and it should not be passed as an optional +argument to a procedure (because it may count as ``no value provided''). +Expression results that potentially produce @racket[unsafe-undefined] can be guarded by @racket[check-not-unsafe-undefined], so that an exception can be raised instead of producing an @racket[undefined] value. The @racket[unsafe-undefined] value is always @racket[eq?] to itself. -@history[#:added "6.0.1.2"] +@history[#:added "6.0.1.2" + #:changed "6.90.0.29" @elem{Procedures with optional arguments + sometimes use the @racket[unsafe-undefined] + value internally to mean ``no argument supplied.''}] @defthing[unsafe-undefined any/c]{ -The unsafe ``undefined'' constant.} +The unsafe ``undefined'' constant. + +See above for important constraints on the use of @racket[unsafe-undefined].} @defproc[(check-not-unsafe-undefined [v any/c] [sym symbol?]) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/vectors.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/vectors.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/vectors.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/vectors.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -72,6 +72,23 @@ Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].} + +@deftogether[( +@defproc[(vector*-length [vec (and/c vector? (not/c impersonator?))]) exact-nonnegative-integer?] +@defproc[(vector*-ref [vec (and/c vector? (not/c impersonator?))] [pos exact-nonnegative-integer?]) any/c] +@defproc[(vector*-set! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))] + [pos exact-nonnegative-integer?] + [v any/c]) + void?] +)]{ + +Like @racket[vector-length], @racket[vector-ref], and +@racket[vector-set!], but constrained to work on vectors that are not +@tech{impersonators}. + +@history[#:added "6.90.0.15"]} + + @defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))] [pos exact-nonnegative-integer?] [old-v any/c] diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/write.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/write.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/reference/write.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/reference/write.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -239,7 +239,7 @@ @defboolparam[print-hash-table on?]{ A @tech{parameter} that controls printing hash tables; defaults to -@racket[#f]. See @secref["print-hashtable"] for more information.} +@racket[#t]. See @secref["print-hashtable"] for more information.} @defboolparam[print-boolean-long-form on?]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -30,7 +30,7 @@ parts: @tt{success} and @tt{failure}. The former is for tests that should succeed now, and the latter is for tests that are currently expected to fail. See the - @hyperlink["https://github.com/racket/racket/tree/master/collects/tests/typed-scheme"]{Typed + @hyperlink["https://github.com/racket/typed-racket/tree/master/typed-racket-test"]{Typed Racket testing arrangement} for an example. When you create such @tt{failure} tests, you may wish to disable DrDr's checking like this: @verbatim[#:indent 2]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/apply-transformer.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/apply-transformer.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/apply-transformer.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/apply-transformer.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,27 @@ +#lang scribble/doc +@(require "common.rkt" (for-label syntax/apply-transformer)) + +@title[#:tag "syntax/apply-transformer"]{Applying Macro Transformers} + +@defmodule[syntax/apply-transformer] + +@defproc[(local-apply-transformer [transformer (or/c (-> syntax? syntax?) set!-transformer?)] + [stx syntax?] + [context (or/c 'expression 'top-level 'module 'module-begin list?)] + [intdef-ctxs (listof internal-definition-context?) '()]) + syntax?]{ + +Applies @racket[transformer] as a @tech[#:doc refman]{syntax transformer} to @racket[stx] in the +current expansion context. The result is similar to expanding @racket[(m stx)] with +@racket[local-expand], where @racket[m] is bound to @racket[transformer], except that expansion is +guaranteed to stop after applying a single macro transformation (assuming @racket[transformer] does +not explicitly force further recursive expansion). + +Unlike simply applying @racket[transformer] to @racket[stx] directly, using +@racket[local-apply-transformer] introduces the appropriate @tech[#:doc refman]{use-site scope} and +@tech[#:doc refman]{macro-introduction scope} that would be added by the expander. + +The @racket[context] and @racket[intdef-ctxs] arguments are treated the same way as the corresponding +arguments to @racket[local-expand]. + +@history[#:added "6.90.0.29"]} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/for-body.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/for-body.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/for-body.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/for-body.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang scribble/manual @(require (for-label racket/base - syntax/quote)) + syntax/quote + syntax/for-body)) @title{Parsing @racket[for] Bodies} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/kerncase.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/kerncase.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/kerncase.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/kerncase.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -66,4 +66,7 @@ "scribblings/reference/reference.scrbl") "fully-expanded"], the list includes @racket[letrec-syntaxes+values], which is the core form for local expand-time binding and can appear in the result of -@racket[local-expand].} +@racket[local-expand]. + +@history[#:changed "6.90.0.27" @elem{Added @racket[quote-syntax] and @racket[#%plain-module-begin] to + the list, which had previously been unintentionally missing.}]} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/modcode.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/modcode.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/modcode.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/modcode.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -7,7 +7,7 @@ @defproc[(get-module-code [path path-string?] [#:submodule-path submodule-path (listof symbol?) '()] - [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] + [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:compile compile-proc0 (any/c . -> . any) compile] @@ -31,7 +31,7 @@ @racket[submodule-path] is empty for a root module or a list for a submodule. -The @racket[compiled-subdir] argument defaults to @racket["compiled"]; +The @racket[compiled-subdir] argument defaults to @racket[(get-default-compiled-sub-path)]; it specifies the sub-directory to search for a compiled version of the module. The @racket[roots] list specifies a compiled-file search path in the same way as the @racket[current-compiled-file-roots] parameter. @@ -77,11 +77,14 @@ (source, @filepath{.zo} or extension) that is chosen. If @racket[read-syntax-proc] is provided, it is used to read the -module from a source file (but not from a bytecode file).} +module from a source file (but not from a bytecode file). + +@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)] + for the default value of @racket[compiled-subdir].}]} @defproc[(get-module-path [path path-string?] [#:submodule? submodule? boolean?] - [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] + [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:choose choose-proc @@ -107,7 +110,18 @@ submodule of the one specified by @racket[path]. When @racket[submodule?] is true, the result is never a @racket['so] path, as native libraries cannot provide submodules. -} + +@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)] + for the default value of @racket[compiled-subdir].}]} + + +@defproc[(get-default-compiled-sub-path) path-string?]{ + +If @racket[(use-compiled-file-paths)] is not @racket['()], returns the +first element of the list. Otherwise, results @racket["compiled"]. + +@history[#:added "6.90.0.7"]} + @defproc[(get-metadata-path [path path-string?] [#:roots roots (listof (or/c path-string? 'same)) @@ -131,7 +145,6 @@ A parameter whose value is used like @racket[open-input-file] to read a module source or @filepath{.zo} file.} - @defstruct[(exn:get-module-code exn:fail) ([path path?])]{ An exception structure type for exceptions raised by diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/moddep.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/moddep.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/moddep.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/moddep.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -9,7 +9,20 @@ @racketmodname[syntax/modcode], @racketmodname[syntax/modcollapse], and @racketmodname[syntax/modresolve], in addition to the following: -@defproc[(show-import-tree [module-path-v module-path?]) void?]{ +@defproc[(show-import-tree [module-path-v module-path?] + [#:dag? dag? any/c #f] + [#:path-to path-to-module-path-v (or/c #f module-path?) #f]) + void?]{ A debugging aid that prints the import hierarchy starting from a given -module path.} +module path. + +If @racket[dag?] is true, then a module is printed only the first time +is encountered in the hierarchy. + +If @racket[path-to-module-path-v] is a module path, then only the +spines of the tree that reach @racket[path-to-module-path-v] are +shown. + +@history[#:changed "6.12.0.4" @elem{Added the @racket[#:dag?] and + @racket[#:path-to] arguments.}]} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/define.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -20,7 +20,8 @@ @racketblock[ (define-syntax (macro-id stx) (syntax-parse stx - [(macro-id . pattern) pattern-directive ... (syntax template)])) + #:track-literals + [((~var macro-id id) . pattern) pattern-directive ... (syntax template)])) ] @(the-eval '(require syntax/parse/define)) @@ -38,6 +39,12 @@ (fn2 a #:b 'c) ] +@history[#:changed "6.12.0.3" @elem{Changed pattern head to @racket[(~var macro-id id)] from + @racket[macro-id], allowing tilde-prefixed identifiers or + identifiers containing colons to be used as @racket[macro-id] + without producing a syntax error.} + #:changed "6.90.0.29" @elem{Changed to always use the @racket[#:track-literals] + @racket[syntax-parse] option.}] } @defform[(define-syntax-parser macro-id parse-option ... clause ...+)]{ diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-kw-args.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-kw-args.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-kw-args.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-kw-args.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -27,7 +27,8 @@ @interaction[#:eval the-eval (define-syntax (mycond stx) (syntax-parse stx - [(mycond (~or* (~seq #:error-on-fallthrough who:expr) (~seq)) + [(mycond (~or* (~seq #:error-on-fallthrough who:expr) + (~seq)) clause ...) (with-syntax ([error? (if (attribute who) #'#t #'#f)] [who (or (attribute who) #'#f)]) @@ -43,11 +44,11 @@ (void)])) ] -We cannot write @racket[#'who] in the macro's right-hand side, because -the @racket[who] attribute does not receive a value if the keyword -argument is omitted. Instead we must write @racket[(attribute who)], -which produces @racket[#f] if matching did not assign a value to the -attribute. +We cannot simply write @racket[#'who] in the macro's right-hand side, +because the @racket[who] attribute does not receive a value if the +keyword argument is omitted. Instead we must first check the attribute +using @racket[(attribute who)], which produces @racket[#f] if matching +did not assign a value to the attribute. @interaction[#:eval the-eval (mycond [(even? 13) 'blue] @@ -62,8 +63,48 @@ (~optional (~seq #:error-on-fallthrough who:expr)) ] + +@section{Optional Arguments with @racket[~?]} + +The @racket[~?] template form provides a compact alternative to +explicitly testing attribute values. Here's one way to do it: + +@interaction[#:eval the-eval +(define-syntax (mycond stx) + (syntax-parse stx + [(mycond (~optional (~seq #:error-on-fallthrough who:expr)) + clause ...) + #'(mycond* (~? (~@ #t who) (~@ #f #f)) clause ...)])) +] + +If @racket[who] matched, then the @racket[~?] subtemplate splices in +the two terms @racket[#t who] into the enclosing template (@racket[~@] +is the template splicing form). Otherwise, it splices in @racket[#f #f]. + +Here's an alternative definition that re-uses Racket's @racket[cond] macro: + +@interaction[#:eval the-eval +(define-syntax (mycond stx) + (syntax-parse stx + [(mycond (~optional (~seq #:error-on-fallthrough who:expr)) + clause ...) + #'(cond clause ... (~? [else (error 'who "no clause matched")] (~@)))])) +] + +In this version, we optionally insert an @racket[else] clause at the +end to signal the error; otherwise we use @racket[cond]'s fall-through +behavior (that is, returning @racket[(void)]). + +If the second subtemplate of a @racket[~?] template is +@racket[(~@)]---that is, it produces no terms at all---the second +subtemplate can be omitted. + + +@section{Optional Arguments with @racket[define-splicing-syntax-class]} + Yet another way is to introduce a @tech{splicing syntax class}, which is like an ordinary syntax class but for head patterns. + @interaction[#:eval the-eval (define-syntax (mycond stx) @@ -82,9 +123,9 @@ Defining a splicing syntax class also makes it easy to eliminate the case analysis we did before using @racket[attribute] by defining @racket[error?] and @racket[who] as attributes within both of the -syntax class's variants. (This is possible to do in the inline pattern -version too, using @racket[~and] and @racket[~parse], just less -convenient.) Splicing syntax classes also closely parallel the style -of grammars in macro documentation. +syntax class's variants. This is possible to do in the inline pattern +version too, using @racket[~and] and @racket[~parse], but it is less +convenient. Splicing syntax classes also closely parallel the style of +grammars in macro documentation. @(close-eval the-eval) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -162,7 +162,8 @@ @defmodule[syntax/parse/experimental/splicing] @defform[(define-primitive-splicing-syntax-class (name-id param-id ...) - maybe-description maybe-attrs + #:description description-expr + #:attributes (attr-arity-decl ...) parser-expr) #:contracts ([parser (-> syntax? (->* () ((or/c string? #f) -> any)) @@ -277,127 +278,20 @@ @defmodule[syntax/parse/experimental/template] -@(define literal-ellipsis (racket ...)) - -@defform[#:literals (?? ?@) - (template tmpl) - #:grammar - ([tmpl pattern-variable-id - (head-tmpl . tmpl) - (head-tmpl ellipsis ...+ . tmpl) - (metafunction-id . tmpl) - (?? tmpl tmpl) - #(@#,svar[head-tmpl] ...) - #s(prefab-struct-key @#,svar[head-tmpl] ...) - #&@#,svar[tmpl] - constant-term] - [head-templ tmpl - (?? head-tmpl) - (?? head-tmpl head-tmpl) - (?@ . tmpl)] - [ellipsis @#,literal-ellipsis])]{ - -Constructs a syntax object from a syntax template, like -@racket[syntax], but provides additional templating forms for dealing -with optional terms and splicing sequences of terms. Only the -additional forms are described here; see @racket[syntax] for -descriptions of pattern variables, etc. - -As in @racket[syntax], a template can be ``escaped'' with ellipses, -like @racket[(... _escaped-tmpl)]. Within the escaped template, -ellipses (@racket[...]), the @racket[??] and @racket[?@] forms, and -metafunctions are treated as constants rather than interpreted as -template forms. - -@specsubform[#:literals (??) - (?? tmpl alt-tmpl)]{ - -Produces @racket[tmpl] unless any attribute used in @racket[tmpl] has -an absent value; in that case, @racket[alt-tmpl] is used instead. - -@examples[#:eval the-eval -(syntax-parse #'(m 1 2 3) - [(_ (~optional (~seq #:op op:expr)) arg:expr ...) - (template ((?? op +) arg ...))]) -(syntax-parse #'(m #:op max 1 2 3) - [(_ (~optional (~seq #:op op:expr)) arg:expr ...) - (template ((?? op +) arg ...))]) -] - -If @racket[??] is used as a head-template, then its sub-templates may -also be head-templates. - -@examples[#:eval the-eval -(syntax-parse #'(m 1) - [(_ x:expr (~optional y:expr)) - (template (m2 x (?? (?@ #:y y) (?@ #:z 0))))]) -(syntax-parse #'(m 1 2) - [(_ x:expr (~optional y:expr)) - (template (m2 x (?? (?@ #:y y) (?@ #:z 0))))]) -] -} - -@specsubform[#:literals (??) - (?? head-tmpl)]{ - -Produces @racket[head-tmpl] unless any attribute used in -@racket[head-tmpl] has an absent value; in that case, the term is -omitted. Can only occur in head position in a template. - -Equivalent to @racket[(?? head-tmpl (?@))]. - -@examples[#:eval the-eval -(syntax-parse #'(m 1) - [(_ x:expr (~optional y:expr)) - (template (m2 x (?? y)))]) -(syntax-parse #'(m 1 2) - [(_ x:expr (~optional y:expr)) - (template (m2 x (?? y)))]) -(syntax-parse #'(m 1 2) - [(_ x:expr (~optional y:expr)) - (template (m2 x (?? (?@ #:y y))))]) -] -} - -@specsubform[#:literals (?@) - (?@ . tmpl)]{ - -Similar to @racket[unquote-splicing], splices the result of -@racket[tmpl] (which must produce a syntax list) into the surrounding -template. Can only occur in head position in a template. - -@examples[#:eval the-eval -(syntax-parse #'(m #:a 1 #:b 2 3 4 #:e 5) - [(_ (~alt pos:expr (~seq kw:keyword kwarg:expr)) ...) - (template (m2 (?@ kw kwarg) ... pos ...))]) -] - -The @racket[tmpl] must produce a proper syntax list, but it does not -need to be expressed as a proper list. For example, to unpack pattern -variables that contain syntax lists, use a ``dotted'' template: - -@examples[#:eval the-eval -(with-syntax ([x #'(a b c)]) - (template ((?@ . x) d))) -(with-syntax ([(x ...) #'((1 2 3) (4 5))]) - (template ((?@ . x) ...))) -] -} - -@specsubform[(metafunction-id . tmpl)]{ +@deftogether[[ +@defform[(template tmpl)] +@defform[(template/loc loc-expr tmpl)] +@defform[(quasitemplate tmpl)] +@defform[(quasitemplate/loc loc-expr tmpl)] +]]{ -Applies the template metafunction named @racket[metafunction-id] to -the result of the template (including @racket[metafunction-id] -itself). See @racket[define-template-metafunction] for examples. +Equivalent to @racket[syntax], @racket[syntax/loc], +@racket[quasisyntax], and @racket[quasisyntax/loc], respectively. } -The @racket[??] and @racket[?@] forms and metafunction applications -are disabled in an ``escaped template'' (see @racket[_stat-template] -under @racket[syntax]). +@defform[(datum-template tmpl)]{ -@examples[#:eval the-eval -(template (... ((?@ a b c) d))) -] +Equivalent to @racket[datum]. } @deftogether[[ @@ -405,16 +299,15 @@ @defidform[?@] ]]{ -Auxiliary forms used by @racket[template]. They may not be used as -expressions. +Equivalent to @racket[~?] and @racket[~@], respectively. } @defform*[[(define-template-metafunction metafunction-id expr) (define-template-metafunction (metafunction-id . formals) body ...+)]]{ Defines @racket[metafunction-id] as a @deftech{template -metafunction}. A metafunction application in a @racket[template] -expression (but not a @racket[syntax] expression) is evaluated by +metafunction}. A metafunction application in a @racket[syntax] +or @racket[template] expression is evaluated by applying the metafunction to the result of processing the ``argument'' part of the template. @@ -453,23 +346,4 @@ invalid binding list. } -@deftogether[[ -@defform[(template/loc loc-expr tmpl)] -@defform[(quasitemplate tmpl)] -@defform[(quasitemplate/loc loc-expr tmpl)] -]]{ - -Like @racket[syntax/loc], @racket[quasisyntax], and -@racket[quasisyntax/loc], respectively, but with the additional -features of @racket[template]. -} - -@defform[(datum-template tmpl)]{ - -Like @racket[datum] but with some of the additional features of -@racket[template]: @racket[?@] and @racket[??] are supported (although -@racket[??] is useless, since @racket[datum-case] cannot bind -``absent'' variables), but template metafunctions are not allowed. -} - @(close-eval the-eval) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -73,7 +73,15 @@ @racket[syntax-transforming?]), matching fails. The attribute @var[value] contains the value the name is bound to. -} + +If matching succeeds, @racket[static] additionally adds the matched identifier +to the current @racket[syntax-parse] state under the key @racket['literals] +using @racket[syntax-parse-state-cons!], in the same way as identifiers matched +using @racket[#:literals] or @racket[~literal]. + +@history[#:changed "6.90.0.29" + @elem{Changed to add matched identifiers to the @racket[syntax-parse] + state under the key @racket['literals].}]} @defstxclass[(expr/c [contract-expr syntax?] [#:positive pos-blame diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -3,6 +3,7 @@ scribble/struct scribble/decode scribble/eval + "../common.rkt" "parse-common.rkt" (for-label racket/syntax)) @@ -28,6 +29,7 @@ (code:line #:literals (literal ...)) (code:line #:datum-literals (datum-literal ...)) (code:line #:literal-sets (literal-set ...)) + #:track-literals (code:line #:conventions (convention-id ...)) (code:line #:local-conventions (convention-rule ...)) (code:line #:disable-colon-notation)] @@ -157,6 +159,24 @@ macros that generate @racket[syntax-parse] expressions. } +@specsubform[(code:line #:track-literals)]{ + +If specified, each final @racket[body] expression is further constrained to +produce a single value, which must be a @tech[#:doc refman]{syntax object}, and +its @racket['disappeared-use] @tech[#:doc refman]{syntax property} is +automatically extended to include literals matched as part of pattern-matching. +Literals are automatically tracked from uses of @racket[#:literals], +@racket[#:literal-sets], or @racket[~literal], but they can also be manually +tracked using @racket[syntax-parse-state-cons!]. The property is added or +extended in the same way as a property added by +@racket[syntax-parse-track-literals]. + +Due to the way the @racket[body] forms are wrapped, specifying this option means +the final @racket[body] form will no longer be in tail position with respect to +the enclosing @racket[syntax-parse] form. + +@history[#:added "6.90.0.29"]} + @specsubform[(code:line #:conventions (conventions-id ...))]{ Imports @tech{convention}s that give default syntax classes to pattern diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1181,7 +1181,8 @@ @defproc[(syntax-local-syntax-parse-pattern-introduce [stx syntax?]) syntax?]{ -Like @racket[syntax-local-introduce], but for @tech{pattern expanders}. -} +For backward compatibility only; equivalent to @racket[syntax-local-introduce]. + +@history[#:changed "6.90.0.29" @elem{Made equivalent to @racket[syntax-local-introduce].}]} @(close-eval the-eval) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -3,6 +3,7 @@ scribble/struct scribble/decode scribble/eval + "../common.rkt" "parse-common.rkt") @(define the-eval (make-sp-eval)) @@ -50,4 +51,45 @@ @history[#:added "6.11.0.4"] } +@defproc[(syntax-parse-track-literals [stx syntax?] [#:introduce? introduce? any/c #t]) syntax?]{ + +Add a @racket['disappeared-use] @tech[#:doc refman]{syntax property} to +@racket[stx] containing the information stored in the current +@racket[syntax-parse] state under the key @racket['literals]. If +@racket[stx] already has a @racket['disappeared-use] property, the +added information is @racket[cons]ed onto the property’s current value. + +Due to the way @racket[syntax-parse] automatically adds identifiers that match +literals to the state under the key @racket['literals], as described in the +documentation for @racket[syntax-parse-state-ref], +@racket[syntax-parse-track-literals] can be used to automatically add any +identifiers used as literals to the @racket['disappeared-use] property. + +If @racket[syntax-parse-track-literals] is called within the dynamic +extent of a @tech[#:doc refman]{syntax transformer} (see +@racket[syntax-transforming?]), @racket[introduce?] is not @racket[#f], and the +value in the current @racket[syntax-parse] state under the key +@racket['literals] is a list, then @racket[syntax-local-introduce] is applied to +any identifiers in the list before they are added to @racket[stx]’s +@racket['disappeared-use] property. + +Most of the time, it is unnecessary to call this function directly. Instead, the +@racket[#:track-literals] option should be provided to @racket[syntax-parse], +which will automatically call @racket[syntax-parse-track-literals] on +syntax-valued results. + +@examples[#:eval the-eval +(define-syntax-class cond-clause + #:literals (=> else) + (pattern [test:expr => ~! answer:expr ...]) + (pattern [else answer:expr ...]) + (pattern [test:expr answer:expr ...])) +(syntax-property + (syntax-parse #'(cond [A => B] [else C]) + [(_ c:cond-clause ...) (syntax-parse-track-literals #'#f)]) + 'disappeared-use) +] + +@history[#:added "6.90.0.29"]} + @(close-eval the-eval) diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -350,6 +350,14 @@ Equivalent to @racket[#:and (~undo defn-or-expr ...)]. } +@specsubform[(code:line #:cut)]{ + +Eliminates backtracking choice points and commits parsing to the +current branch at the current point. + +Equivalent to @racket[#:and ~!]. +} + @;{----------} diff -Nru racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer-helpers.scrbl racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer-helpers.scrbl --- racket-6.12+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer-helpers.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer-helpers.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -11,3 +11,4 @@ @include-section["path-spec.scrbl"] @include-section["template.scrbl"] @include-section["transformer.scrbl"] +@include-section["apply-transformer.scrbl"] diff -Nru racket-6.12+ppa1/share/pkgs/racket-index/info.rkt racket-7.0+ppa1/share/pkgs/racket-index/info.rkt --- racket-6.12+ppa1/share/pkgs/racket-index/info.rkt 2018-01-26 21:09:28.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-index/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib"))) (define build-deps (quote ("scheme-lib" "at-exp-lib"))) (define pkg-desc "Racket Documentation driver") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))) (define version "1.2") (define binary-keep-files (quote ("scribblings" "scribblings/main/compiled/acks_scrbl.zo" "scribblings/main/compiled/license_scrbl.zo" "scribblings/main/compiled/local-redirect_scrbl.zo" "scribblings/main/compiled/release_scrbl.zo" "scribblings/main/compiled/search_scrbl.zo" "scribblings/main/compiled/start_scrbl.zo" "scribblings/main/user/compiled/local-redirect_scrbl.zo" "scribblings/main/user/compiled/release_scrbl.zo" "scribblings/main/user/compiled/search_scrbl.zo" "scribblings/main/user/compiled/start_scrbl.zo"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib"))) (define build-deps (quote ("scheme-lib" "at-exp-lib"))) (define pkg-desc "Racket Documentation driver") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))) (define version "1.2") (define binary-keep-files (quote ("scribblings" "scribblings/main/compiled/acks_scrbl.zo" "scribblings/main/compiled/license_scrbl.zo" "scribblings/main/compiled/local-redirect_scrbl.zo" "scribblings/main/compiled/release_scrbl.zo" "scribblings/main/compiled/search_scrbl.zo" "scribblings/main/compiled/start_scrbl.zo" "scribblings/main/user/compiled/local-redirect_scrbl.zo" "scribblings/main/user/compiled/release_scrbl.zo" "scribblings/main/user/compiled/search_scrbl.zo" "scribblings/main/user/compiled/start_scrbl.zo"))))) diff -Nru racket-6.12+ppa1/share/pkgs/racket-index/scribblings/main/license.scrbl racket-7.0+ppa1/share/pkgs/racket-index/scribblings/main/license.scrbl --- racket-6.12+ppa1/share/pkgs/racket-index/scribblings/main/license.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-index/scribblings/main/license.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -69,5 +69,11 @@ Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. } +@copyright{ + MemoryModule + Copyright (c) 2004-2015 by Joachim Bauch / mail@"@"joachim-bauch.de + http://www.joachim-bauch.de +} + See also other @filepath{LICENSE.txt} files in your distribution or packages. diff -Nru racket-6.12+ppa1/share/pkgs/racket-index/scribblings/main/local-redirect.scrbl racket-7.0+ppa1/share/pkgs/racket-index/scribblings/main/local-redirect.scrbl --- racket-6.12+ppa1/share/pkgs/racket-index/scribblings/main/local-redirect.scrbl 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-index/scribblings/main/local-redirect.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -9,7 +9,7 @@ @title{Redirections} -This page that is intended to redirect to the result of a search +This page is intended to redirect to the result of a search request. Since you're reading this, it seems that the redirection did not work. diff -Nru racket-6.12+ppa1/share/pkgs/racket-lib/info.rkt racket-7.0+ppa1/share/pkgs/racket-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/racket-lib/info.rkt 2018-01-26 21:09:28.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racket-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("racket-win32-i386-2" #:platform "win32\\i386") ("racket-win32-x86_64-2" #:platform "win32\\x86_64") ("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg") ("racket-x86_64-macosx-2" #:platform "x86_64-macosx") ("racket-i386-macosx-2" #:platform "i386-macosx") ("racket-ppc-macosx-2" #:platform "ppc-macosx") ("db-ppc-macosx" #:platform "ppc-macosx") ("db-win32-i386" #:platform "win32\\i386") ("db-win32-x86_64" #:platform "win32\\x86_64") ("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("com-win32-i386" #:platform "win32\\i386") ("com-win32-x86_64" #:platform "win32\\x86_64")))) (define pkg-desc "Combines platform-specific native libraries that are useful for base Racket") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("racket-win32-i386-3" #:platform "win32\\i386") ("racket-win32-x86_64-3" #:platform "win32\\x86_64") ("racket-x86_64-linux-natipkg-3" #:platform "x86_64-linux-natipkg") ("racket-x86_64-macosx-3" #:platform "x86_64-macosx") ("racket-i386-macosx-3" #:platform "i386-macosx") ("racket-ppc-macosx-3" #:platform "ppc-macosx") ("db-ppc-macosx" #:platform "ppc-macosx") ("db-win32-i386" #:platform "win32\\i386") ("db-win32-x86_64" #:platform "win32\\x86_64") ("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("com-win32-i386" #:platform "win32\\i386") ("com-win32-x86_64" #:platform "win32\\x86_64")))) (define pkg-desc "Combines platform-specific native libraries that are useful for base Racket") (define pkg-authors (quote (eli jay matthias mflatt robby ryanc samth))))) diff -Nru racket-6.12+ppa1/share/pkgs/racklog/info.rkt racket-7.0+ppa1/share/pkgs/racklog/info.rkt --- racket-6.12+ppa1/share/pkgs/racklog/info.rkt 2018-01-26 21:09:40.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racklog/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "racklog") (define scribblings (quote (("racklog.scrbl" (multi-page) (tool))))) (define deps (quote ("base" "datalog"))) (define build-deps (quote ("eli-tester" "rackunit-lib" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Racklog (embedded Prolog) language") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "racklog") (define scribblings (quote (("racklog.scrbl" (multi-page) (tool))))) (define deps (quote ("base" "datalog"))) (define build-deps (quote ("eli-tester" "rackunit-lib" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Racklog (embedded Prolog) language") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/racklog/racklog.rkt racket-7.0+ppa1/share/pkgs/racklog/racklog.rkt --- racket-6.12+ppa1/share/pkgs/racklog/racklog.rkt 2018-01-26 20:36:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racklog/racklog.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -22,8 +22,8 @@ (syntax-rules () ((%or g ...) (lambda (__fk) - (let/racklog-cc __sk - (let/racklog-cc __fk + (let/racklog-sk __sk + (let/racklog-fk __fk (__sk ((logic-var-val* g) __fk))) ... (__fk 'fail)))))) @@ -43,7 +43,9 @@ (syntax-rules () ((%cut-delimiter g) (lambda (__fk) - (let ((this-! (lambda (__fk2) __fk))) + (let ((this-! (lambda (__fk2) + (__fk2 'unwind-trail) + __fk))) (syntax-parameterize ([! (make-rename-transformer #'this-!)]) ((logic-var-val* g) __fk))))))) @@ -53,10 +55,10 @@ ((%rel (v ...) ((a ...) subgoal ...) ...) (lambda __fmls (lambda (fail-relation) - (let/racklog-cc + (let/racklog-sk __sk (%let (v ...) - (let/racklog-cc + (let/racklog-fk fail-case (define-values (unify-cleanup fail-unify) @@ -65,6 +67,7 @@ (define this-! (lambda (fk1) (λ (fk2) + ;; XXX could be (fail-unify 'unwind-trail) (unify-cleanup) (fail-relation 'fail)))) (syntax-parameterize @@ -175,8 +178,8 @@ (define ((make-negation p) . args) ;basically inlined cut-fail (lambda (fk) - (if (let/racklog-cc k - ((apply p args) (lambda (d) (k #f)))) + (if (let/racklog-sk k + ((apply p args) (make-racklog-fk (lambda (d) (k #f))))) (fk 'fail) fk))) @@ -206,10 +209,7 @@ ((%= (copy s) c) fk))) (define (%not g) - (lambda (fk) - (if (let/racklog-cc k - ((logic-var-val* g) (lambda (d) (k #f)))) - (fk 'fail) fk))) + (%if-then-else g %fail %true)) (define (%empty-rel . args) %fail) @@ -255,7 +255,7 @@ (define (make-bag-of-aux kons fvv lv goal bag) (lambda (fk) - (let/racklog-cc sk + (let/racklog-sk sk (let ((lv2 (cons fvv lv))) (let* ((acc '()) (fk-final @@ -304,9 +304,10 @@ (%let (v ...) (set-box! *more-fk* ((logic-var-val* g) - (lambda (d) - (set-box! *more-fk* #f) - (abort-to-racklog-prompt #f)))) + (make-racklog-fk + (lambda (d) + (set-box! *more-fk* #f) + (abort-to-racklog-prompt #f))))) (abort-to-racklog-prompt (list (cons 'v (logic-var-val* v)) ...))))) @@ -338,6 +339,15 @@ (call-with-continuation-prompt (λ () e ...) racklog-prompt-tag)) (define-syntax-rule (let/racklog-cc k e ...) (call-with-current-continuation (λ (k) e ...) racklog-prompt-tag)) +(define-syntax-rule (let/racklog-sk k e ...) + (let/racklog-cc k e ...)) +(define (make-racklog-fk fk) + (λ (msg) + (if (not (eq? msg 'unwind-trail)) + (fk 'fail) + #f))) +(define-syntax-rule (let/racklog-fk k e ...) + (let/racklog-cc fk (let ([k (make-racklog-fk fk)]) e ...))) (define (%member x y) (%let (xs z zs) diff -Nru racket-6.12+ppa1/share/pkgs/racklog/tests/pr/pr4.rkt racket-7.0+ppa1/share/pkgs/racklog/tests/pr/pr4.rkt --- racket-6.12+ppa1/share/pkgs/racklog/tests/pr/pr4.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racklog/tests/pr/pr4.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require racklog + tests/eli-tester) + +(module+ test + (test + (%which (x) %true) + => '((x . _)) + + (%which (x) (%or (%not (%= x 1)) %true)) + => '((x . _)) + + (%which (x) (%or (%if-then-else (%= x 1) %fail %true) %true)) + => '((x . _)) + + (%which (x) (%or (%cut-delimiter (%or (%and (%= x 1) ! %fail) %true)) %true)) + => '((x . _)) + + (%which (x) (%or (%cut-delimiter (%or (%and ! (%= x 1) %fail) %true)) %true)) + => '((x . _)))) diff -Nru racket-6.12+ppa1/share/pkgs/racklog/unify.rkt racket-7.0+ppa1/share/pkgs/racklog/unify.rkt --- racket-6.12+ppa1/share/pkgs/racklog/unify.rkt 2018-01-26 20:36:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/racklog/unify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -440,6 +440,9 @@ (define (cleanup-n-fail s) (cleanup s) (fk 'fail)) + (define (unwind-trail s) + (cleanup s) + (fk 'unwind-trail)) (define (unify1 t1 t2 s) (cond [(eqv? t1 t2) s] [(logic-var? t1) @@ -502,7 +505,8 @@ (values (λ () (cleanup s)) (lambda (d) - (cleanup-n-fail s))))) + ((if (eq? d 'unwind-trail) unwind-trail cleanup-n-fail) + s))))) (define-syntax-rule (or* x f ...) (or (f x) ...)) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit/info.rkt racket-7.0+ppa1/share/pkgs/rackunit/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit/info.rkt 2018-01-26 21:09:40.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("rackunit-lib" "rackunit-doc" "rackunit-gui" "rackunit-plugin-lib"))) (define implies (quote ("rackunit-lib" "rackunit-doc" "rackunit-gui" "rackunit-plugin-lib"))) (define pkg-desc "RackUnit testing framework") (define pkg-authors (quote (ryanc noel))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("rackunit-lib" "rackunit-doc" "rackunit-gui" "rackunit-plugin-lib"))) (define implies (quote ("rackunit-lib" "rackunit-doc" "rackunit-gui" "rackunit-plugin-lib"))) (define pkg-desc "RackUnit testing framework") (define pkg-authors (quote (ryanc noel))))) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-doc/info.rkt racket-7.0+ppa1/share/pkgs/rackunit-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-doc/info.rkt 2018-01-26 21:09:40.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "RackUnit documentation") (define pkg-authors (quote (noel ryanc))) (define build-deps (quote ("racket-index" "racket-doc" "rackunit-gui" "rackunit-lib" "scribble-lib"))) (define update-implies (quote ("rackunit-lib"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "RackUnit documentation") (define pkg-authors (quote (noel ryanc))) (define build-deps (quote ("racket-index" "racket-doc" "rackunit-gui" "rackunit-lib" "scribble-lib"))) (define update-implies (quote ("rackunit-lib"))))) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-gui/info.rkt racket-7.0+ppa1/share/pkgs/rackunit-gui/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-gui/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-gui/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("rackunit-lib" "class-iop-lib" "data-lib" "gui-lib" "base"))) (define pkg-desc "RackUnit test runner GUI") (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("rackunit-lib" "class-iop-lib" "data-lib" "gui-lib" "base"))) (define pkg-desc "RackUnit test runner GUI") (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-lib/info.rkt racket-7.0+ppa1/share/pkgs/rackunit-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-lib/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "testing-util-lib"))) (define implies (quote ("testing-util-lib"))) (define pkg-desc "RackUnit testing framework") (define pkg-authors (quote (ryanc noel))) (define version "1.8"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "testing-util-lib"))) (define implies (quote ("testing-util-lib"))) (define pkg-desc "RackUnit testing framework") (define pkg-authors (quote (ryanc noel))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/check-info.rkt racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/check-info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/check-info.rkt 2018-01-26 20:34:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/check-info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -21,12 +21,18 @@ [struct dynamic-info ([proc (-> any/c)])] [info-value->string (-> any/c string?)] [current-check-info (parameter/c (listof check-info?))] + [check-info-contains-key? (check-info-> symbol? boolean?)] + [check-info-ref (check-info-> symbol? (or/c check-info? #f))] [with-check-info* ((listof check-info?) (-> any) . -> . any)]) with-check-info) (module+ for-test (provide trim-current-directory)) +(define (check-info-> dom cod) + (case-> (-> dom cod) + (-> (listof check-info?) dom cod))) + ;; Structures -------------------------------------------------- (struct check-info (name value) @@ -96,3 +102,17 @@ (define-check-type message any/c) (define-check-type actual any/c #:wrapper pretty-info) (define-check-type expected any/c #:wrapper pretty-info) + +(define check-info-ref + (case-lambda + [(k) + (check-info-ref (current-check-info) k)] + [(info k) + (findf (λ (i) (eq? k (check-info-name i))) info)])) + +(define check-info-contains-key? + (case-lambda + [(k) + (check-info-contains-key? (current-check-info) k)] + [(info k) + (and (check-info-ref info k) #t)])) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/check.rkt racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/check.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/check.rkt 2018-01-26 20:34:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -164,14 +164,17 @@ [exn:fail? (lambda (exn) (with-check-info* - (list - (make-check-message "Wrong exception raised") + (list/if + (and (not (check-info-contains-key? 'message)) + (make-check-message "Wrong exception raised")) (make-check-info 'exn-message (exn-message exn)) (make-check-info 'exn exn)) (lambda () (fail-check))))]) (thunk)) (with-check-info* - (list (make-check-message "No exception raised")) + (list/if + (and (not (check-info-contains-key? 'message)) + (make-check-message "No exception raised"))) (lambda () (fail-check)))))) (define-check (check-not-exn thunk) @@ -181,8 +184,9 @@ [exn? (lambda (exn) (with-check-info* - (list - (make-check-message "Exception raised") + (list/if + (and (not (check-info-contains-key? 'message)) + (make-check-message "Exception raised")) (make-check-info 'exception-message (exn-message exn)) (make-check-info 'exception exn)) (lambda () (fail-check))))]) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/format.rkt racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/format.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-lib/rackunit/private/format.rkt 2018-01-26 20:34:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-lib/rackunit/private/format.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,6 +2,7 @@ (require racket/list racket/match racket/string + racket/pretty "base.rkt" "check-info.rkt") @@ -17,6 +18,7 @@ (define minimum-name-width 9) (define nested-indent-amount 2) +(define multi-line-indent-amount 2) (define (display-test-result res #:verbose? [verbose? #f] @@ -71,7 +73,16 @@ (format "~a:\n~a" name nested-str)] [else (define pad (string-padding name name-width)) - (format "~a:~a ~a" name pad (info-value->string value))])) + (define one-line-candidate + (parameterize ([pretty-print-columns 'infinity]) + (format "~a:~a ~a" name pad (info-value->string value)))) + (if (<= (string-length one-line-candidate) (pretty-print-columns)) + one-line-candidate + (format "~a:\n~a" + name + (string-indent + (info-value->string value) + multi-line-indent-amount)))])) (define (nested-info->string nested verbose? name-width) (define infos (nested-info-values nested)) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt racket-7.0+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "rackunit-lib" "rackunit-gui" "gui-lib" "drracket-plugin-lib"))) (define pkg-desc "RackUnit testing framework DrRacket plugin") (define pkg-authors (quote (ryanc noel))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "rackunit-lib" "rackunit-gui" "gui-lib" "drracket-plugin-lib"))) (define pkg-desc "RackUnit testing framework DrRacket plugin") (define pkg-authors (quote (ryanc noel))))) diff -Nru racket-6.12+ppa1/share/pkgs/rackunit-typed/info.rkt racket-7.0+ppa1/share/pkgs/rackunit-typed/info.rkt --- racket-6.12+ppa1/share/pkgs/rackunit-typed/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/rackunit-typed/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "typed") (define test-responsibles (quote ((all jay)))) (define deps (quote ("racket-index" "rackunit-gui" "rackunit-lib" "typed-racket-lib" "base" "testing-util-lib"))) (define pkg-desc "Typed Racket types for RackUnit") (define pkg-authors (quote (samth stamourv))) (define version "1.0"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "typed") (define test-responsibles (quote ((all jay)))) (define deps (quote ("racket-index" "rackunit-gui" "rackunit-lib" "typed-racket-lib" "base" "testing-util-lib"))) (define pkg-desc "Typed Racket types for RackUnit") (define pkg-authors (quote (samth stamourv))) (define version "1.0"))) diff -Nru racket-6.12+ppa1/share/pkgs/readline/info.rkt racket-7.0+ppa1/share/pkgs/readline/info.rkt --- racket-6.12+ppa1/share/pkgs/readline/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/readline/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("readline-lib" "readline-doc"))) (define implies (quote ("readline-lib" "readline-doc"))) (define pkg-desc "GNU Readline access from Racket") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("readline-lib" "readline-doc"))) (define implies (quote ("readline-lib" "readline-doc"))) (define pkg-desc "GNU Readline access from Racket") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/readline-doc/info.rkt racket-7.0+ppa1/share/pkgs/readline-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/readline-doc/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/readline-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("scribble-lib" "readline-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("readline-lib"))) (define pkg-desc "documentation part of \"readline\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("scribble-lib" "readline-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("readline-lib"))) (define pkg-desc "documentation part of \"readline\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/readline-lib/info.rkt racket-7.0+ppa1/share/pkgs/readline-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/readline-lib/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/readline-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"readline\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation (no documentation) part of \"readline\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/readline-lib/readline/pread.rkt racket-7.0+ppa1/share/pkgs/readline-lib/readline/pread.rkt --- racket-6.12+ppa1/share/pkgs/readline-lib/readline/pread.rkt 2018-01-26 20:36:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/readline-lib/readline/pread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -101,7 +101,7 @@ (when (eq? readline-output-port (current-output-port)) (define-values [line col pos] (port-next-location readline-output-port)) (when (and col (positive? col)) (newline readline-output-port))) - (let ([s (readline-bytes p)]) (add-to-history s force-keep?) s)) + (let ([s (readline-bytes (bytes-append p #"\0"))]) (add-to-history s force-keep?) s)) (exit-handler (let ([old (exit-handler)]) diff -Nru racket-6.12+ppa1/share/pkgs/readline-lib/readline/rktrl.rkt racket-7.0+ppa1/share/pkgs/readline-lib/readline/rktrl.rkt --- racket-6.12+ppa1/share/pkgs/readline-lib/readline/rktrl.rkt 2018-01-26 20:36:54.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/readline-lib/readline/rktrl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -43,26 +43,25 @@ lib) (ffi-lib "libedit" '("3" "2" "0.0.43" "0.0.53" "0" "")))) -(define make-byte-string ; helper for the two types below - (get-ffi-obj "scheme_make_byte_string" #f (_fun _pointer -> _scheme))) - -(define _bytes/eof/free ; register a finalizer on the resulting bytes +(define _bytes/eof/free ; copies bytes and frees result pointer (make-ctype _pointer (lambda (x) (and (not (eof-object? x)) x)) (lambda (x) (if x - (let ([b (make-byte-string x)]) - (register-finalizer b (lambda (_) (free x))) - b) - eof)))) + (begin0 + (bytes-copy (cast x _pointer _bytes)) + (free x)) + eof)))) (define _string/eof/free ; make a Scheme str from C str & free immediately (make-ctype _pointer (lambda (x) (and (not (eof-object? x)) (string->bytes/utf-8 x))) (lambda (x) (if x - (let ([s (bytes->string/utf-8 (make-byte-string x))]) (free x) s) - eof)))) + (begin0 + (cast x _pointer _string) + (free x)) + eof)))) (define readline (get-ffi-obj "readline" libreadline (_fun _string -> _string/eof/free))) diff -Nru racket-6.12+ppa1/share/pkgs/realm/info.rkt racket-7.0+ppa1/share/pkgs/realm/info.rkt --- racket-6.12+ppa1/share/pkgs/realm/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/realm/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "realm") (define name "Realm of Racket Source Code") (define compile-omit-paths (quote ("chapter5/ufo-source.rkt"))) (define deps (quote ("base" "htdp-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "Sample code for _Realm of Racket_") (define pkg-authors (quote (matthias))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "realm") (define name "Realm of Racket Source Code") (define compile-omit-paths (quote ("chapter5/ufo-source.rkt"))) (define deps (quote ("base" "htdp-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "Sample code for _Realm of Racket_") (define pkg-authors (quote (matthias))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex/info.rkt racket-7.0+ppa1/share/pkgs/redex/info.rkt --- racket-6.12+ppa1/share/pkgs/redex/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("redex-doc" "redex-examples" "redex-lib" "redex-gui-lib"))) (define implies (quote ("redex-doc" "redex-examples" "redex-lib" "redex-gui-lib"))) (define pkg-desc "PLT Redex libraries for practical semantics engineering") (define pkg-authors (quote (robby bfetscher))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("redex-doc" "redex-examples" "redex-lib" "redex-gui-lib"))) (define implies (quote ("redex-doc" "redex-examples" "redex-lib" "redex-gui-lib"))) (define pkg-desc "PLT Redex libraries for practical semantics engineering") (define pkg-authors (quote (robby bfetscher))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-benchmark/info.rkt racket-7.0+ppa1/share/pkgs/redex-benchmark/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-benchmark/info.rkt 2018-01-26 21:09:42.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-benchmark/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "rackunit-lib" "redex-lib" "redex-examples" "math-lib" "plot-lib"))) (define build-deps (quote ())) (define pkg-desc "PLT Redex Benchmark") (define pkg-authors (quote (robby bfetscher))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "rackunit-lib" "redex-lib" "redex-examples" "math-lib" "plot-lib"))) (define build-deps (quote ())) (define pkg-desc "PLT Redex Benchmark") (define pkg-authors (quote (robby bfetscher))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/info.rkt racket-7.0+ppa1/share/pkgs/redex-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-doc/info.rkt 2018-01-26 21:09:46.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "racket-doc"))) (define build-deps (quote ("draw-doc" "gui-doc" "htdp-doc" "pict-doc" "slideshow-doc" "at-exp-lib" "data-doc" "data-enumerate-lib" ("scribble-lib" #:version "1.16") "gui-lib" "htdp-lib" "pict-lib" "redex-gui-lib" "redex-benchmark" "rackunit-lib" "sandbox-lib"))) (define pkg-desc "documentation part of \"redex\"") (define pkg-authors (quote (robby bfetscher))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "racket-doc"))) (define build-deps (quote ("draw-doc" "gui-doc" "htdp-doc" "pict-doc" "slideshow-doc" "at-exp-lib" "data-doc" "data-enumerate-lib" ("scribble-lib" #:version "1.16") "gui-lib" "htdp-lib" "pict-lib" "redex-gui-lib" "redex-benchmark" "rackunit-lib" "sandbox-lib"))) (define pkg-desc "documentation part of \"redex\"") (define pkg-authors (quote (robby bfetscher))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/languages.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/languages.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/languages.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/languages.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -33,7 +33,7 @@ (code:line binding-pattern #:...bind (id beta beta))] [beta nothing symbol - (shadow beta-seqence ...)] + (shadow beta-sequence ...)] [beta-sequence beta (code:line ... (code:comment "literal ellipsis"))])]{ @@ -46,7 +46,8 @@ A @racket[non-terminal-def] comprises one or more non-terminal names (considered aliases) followed by one or more productions. -For example, the following defines @deftech{@racket[_lc-lang]} as the +@; this language is copied to other-relations.scrbl to be used in examples there, too + For example, the following defines @deftech{@racket[_lc-lang]} as the grammar of the λ-calculus: @examples[#:label #f #:eval redex-eval #:no-prompt #:no-result (define-language lc-lang @@ -64,7 +65,8 @@ @racket[E] for the evaluation contexts. Non-terminals used in @racket[define-language] are not bound in -@pattech[side-condition] patterns and duplicates are not constrained +@pattech[side-condition] patterns. Duplicate non-terminals +that appear outside of the binding-forms section are not constrained to be the same unless they have underscores in them. @mini-heading{Binding Forms} @@ -427,12 +429,12 @@ language's non-terminal, as well as any new ones. If a non-terminal occurs in both the base language and the extension, the extension's non-terminal replaces the -originals. If a non-terminal only occurs in either the base +originals. If a non-terminal only occurs in the base language, then it is carried forward into the -extension. And, of course, extend-language lets you add new +extension. And, of course, @racket[define-extended-language] lets you add new non-terminals to the language. -If a language is has a group of multiple non-terminals +If a language has a group of multiple non-terminals defined together, extending any one of those non-terminals extends all of them. } diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -11,7 +11,17 @@ vc-append hbl-append vl-append) redex)) -@(define redex-eval (make-base-eval '(require redex/reduction-semantics))) +@(define redex-eval (make-base-eval '(require redex/reduction-semantics redex/pict))) +@; this definition is copied from languages.scrbl +@(redex-eval + '(define-language lc-lang + (e ::= (e e ...) + x + (λ (x ...) e)) + (v ::= (λ (x ...) e)) + (E ::= (v ... E e ...) + hole) + (x y ::= variable-not-otherwise-mentioned))) @title{Other Relations} @@ -99,8 +109,8 @@ The @racket[clause-name] is used only when typesetting. See @racket[metafunction-cases]. -The @racket[or] clause is used to define a form of conditional -right-hand side of a metafunction. In particular, if any of the +The @racket[or] clause is used to define piecewise conditional +metafunctions. In particular, if any of the @racket[where] or @racket[side-condition] clauses fail, then evaluation continues after an @racket[or] clause, treating the term that follows as the result (subject to any subsequent @@ -110,6 +120,29 @@ the typesetting library to use a large left curly brace to group the conditions in the @racket[or]. + For example, here are two equivalent definitions of a @racket[biggest] + metafunction that typeset differently: + + @examples[#:eval redex-eval + (define-metafunction lc-lang + biggest : natural natural -> natural + [(biggest natural_1 natural_2) + natural_2 + (side-condition (< (term natural_1) (term natural_2)))] + [(biggest natural_1 natural_2) + natural_1]) + (render-metafunction biggest) + (define-metafunction lc-lang + biggest : natural natural -> natural + [(biggest natural_1 natural_2) + natural_2 + (side-condition (< (term natural_1) (term natural_2))) + + or + + natural_1]) + (render-metafunction biggest)] + Note that metafunctions are assumed to always return the same results for the same inputs, and their results are cached, unless @racket[caching-enabled?] is set to @racket[#f]. Accordingly, if a @@ -333,8 +366,10 @@ A rule's @racket[side-condition] and @racket[side-condition/hidden] premises are similar to those in @racket[reduction-relation] and @racket[define-metafunction], except that they do not implicitly unquote their right-hand sides. In other words, a premise -of the form @racket[(side-condition term)] is equivalent to the premise -@racket[(where #t term)], except it does not typeset with the ``#t = '', as that would. +of the form @racket[(side-condition term)] is close to the premise +@racket[(where #t term)], except it does not typeset with the ``#t = '', as that would +and it holds whenever the expression evaluates to any non @racket[#f] value +(not just @racket[#t]). Judgments with exclusively @racket[I] mode positions may also be used in @|tttterm|s in a manner similar to metafunctions, and evaluate to a boolean. diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/patterns.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/patterns.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/patterns.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/patterns.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -394,7 +394,7 @@ } @defproc[(set-cache-size! [size positive-integer?]) void?]{ -Changes the size of the per-pattern and per-metafunction caches. +Changes the size of the per-pattern, per-metafunction and per-judgment-form caches. The default size is @racket[63]. } diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/reduction-relations.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/reduction-relations.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/reduction-relations.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/reduction-relations.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -34,6 +34,7 @@ (bind @#,ttpattern @#,tttterm) (bind/hidden @#,ttpattern @#,tttterm) (judgment-holds (judgment-form-id pat/term ...)) + (judgment-holds (relation-id @#,tttterm ...)) (side-condition/hidden racket-expression)] [shortcuts (code:line) (code:line with shortcut ...)] diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/terms.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/terms.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/terms.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/terms.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -29,8 +29,7 @@ (in-hole term term) hole (mf-apply identifier term ...) - #t #f - string] + datum] [term-sequence term ,@expr @@ -64,8 +63,18 @@ @item{A term written @racket[(mf-apply f arg ...)] asserts that @racket[f] is a @tech{metafunction} and produces the term @racket[(f arg ...)].} -@item{A term written as a literal boolean or a string -produces the boolean or the string.} + @item{A term written as any other @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{datum} + not listed above produces that @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{datum}. + For example, @racket[(term (1 x #t))] is the same as @racket['(1 x #t)]. + + Term substitution and metafunction application do not occur + within compound @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{datums}. For example, + + @racketblock[ + (term-let ([a 1]) (term #hash((x . a)))) + ] + + is the same as @racket['#hash((x . a))], not @racket['#hash((x . 1))].} ] @defform*[[(term @#,tttterm) (term @#,tttterm #:lang lang-id)]]{ diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/testing.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/testing.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/testing.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/testing.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -59,7 +59,7 @@ (code:line #:equiv pred-expr) (code:line #:pred pred-expr)]) #:contracts ([rel-expr reduction-relation?] - [pred-expr (--> any/c any)] + [pred-expr (-> any/c any)] [e1-expr any/c] [e2-expr any/c])]{ @@ -92,7 +92,7 @@ @defform/subs[(test--> rel-expr option ... e1-expr e2-expr ...) ([option (code:line #:equiv pred-expr)]) #:contracts ([rel-expr reduction-relation?] - [pred-expr (--> any/c any/c any/c)] + [pred-expr (-> any/c any/c any/c)] [e1-expr any/c] [e2-expr any/c])]{ diff -Nru racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl --- racket-6.12+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -138,23 +138,27 @@ @ex[(term->pict nums (+ 1 (+ 3 4)))] } -@defproc[(render-term/pretty-write [lang compiled-lang?] - [term any/c] - [filename path-string?] - [#:width width #f]) - void?]{ +@defproc[(render-term/pretty-write + [lang compiled-lang?] + [term any/c] + [filename (or/c path-string? #f) #f] + [#:width width (or/c exact-positive-integer? 'infinity) (pretty-print-columns)]) + (or/c void? pict?)]{ Like @racket[render-term], except that the @racket[term] argument is evaluated, and expected to return a term. Then, @racket[pretty-write] is used to determine where the line breaks go, using the @racket[width] argument as a maximum width (via @racket[pretty-print-columns]). + If @racket[filename] is provided, the pict is saved as a pdf to that file. + @ex[(render-term/pretty-write nums '(+ (1 1 1) (1 0 1)))] } -@defproc[(term->pict/pretty-write [lang compiled-lang?] - [term any/c] - [#:width width #f]) +@defproc[(term->pict/pretty-write + [lang compiled-lang?] + [term any/c] + [#:width width (or/c exact-positive-integer? 'infinity) (pretty-print-columns)]) pict?]{ Like @racket[term->pict], but with the same change that @racket[render-term/pretty-write] has from @racket[render-term]. @@ -257,9 +261,8 @@ } @deftogether[[ -@defform[(render-metafunction metafunction-name maybe-contract)]{} -@defform/none[#:literals (render-metafunction) - (render-metafunction metafunction-name filename maybe-contract)]{} +@defform*[[(render-metafunction metafunction-name maybe-contract) + (render-metafunction metafunction-name filename maybe-contract)]]{} @defform[(render-metafunctions metafunction-name ... maybe-filename maybe-contract) #:grammar ([maybe-filename (code:line) @@ -427,8 +430,8 @@ A parameter that controls the rendering of extended languages. If the parameter value is @racket[#t], then a language constructed with -extend-language is shown as if the language had been -constructed directly with @racket[language]. If it is @racket[#f], then only +@racket[define-extended-language] is shown as if the language had been +constructed directly with @racket[define-language]. If it is @racket[#f], then only the last extension to the language is shown (with four-period ellipses, just like in the concrete syntax). @@ -1068,6 +1071,11 @@ ] } +@defform[(with-atomic-rewriters ([name-symbol string-or-thunk-returning-pict] ...) + expression)]{ +Shorthand for nested @racket[with-atomic-rewriter] expressions. +@history[#:added "1.4"]} + @defform[(with-compound-rewriter name-symbol proc expression)]{ diff -Nru racket-6.12+ppa1/share/pkgs/redex-examples/info.rkt racket-7.0+ppa1/share/pkgs/redex-examples/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-examples/info.rkt 2018-01-26 21:09:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-examples/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "rackunit-lib" "redex-gui-lib" "slideshow-lib" "math-lib" "plot-lib"))) (define build-deps (quote ())) (define pkg-desc "PLT Redex examples") (define pkg-authors (quote (robby bfetscher))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compiler-lib" "rackunit-lib" "redex-gui-lib" "slideshow-lib" "math-lib" "plot-lib"))) (define build-deps (quote ())) (define pkg-desc "PLT Redex examples") (define pkg-authors (quote (robby bfetscher))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/meta.rkt racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/meta.rkt --- racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/meta.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/meta.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,49 +7,50 @@ ;; Substitution: (define-metafunction grammar - [(subst x_1 x_1 e_1) ; shortcut - e_1] - [(subst x_1 e_1 (λ (x_2 ... x_1 x_3 ...) e_2)) - (λ (x_2 ... x_1 x_3 ...) e_2)] - [(subst x_1 x_2 (λ (x_3 ...) e_1)) ; shortcut; x_1 != any x_3 - (λ (x_3 ...) (subst x_1 x_2 e_1))] - [(subst x_1 e_1 (λ (x_2 ...) e_2)) ; x_1 != any x_2 - ,(term-let ([(x_new ...) (variables-not-in (term (x_1 e_1 e_2)) (term (x_2 ...)))]) - (term (λ (x_new ...) - (subst x_1 e_1 (subst* (x_2 ...) (x_new ...) e_2)))))] - [(subst x_1 e_1 x_1) e_1] - [(subst x_1 e x_2) x_2] ; x_1 != x_2, since previous didn't match - [(subst x_1 e_1 v_1) v_1] ; all other values are atomic - [(subst x_1 e_1 (list v_1 ...)) (list (subst x_1 e_1 v_1) ...)] - [(subst x_1 e_1 (e_2 ...)) - ((subst x_1 e_1 e_2) ...)] - [(subst x_1 e_1 (if e_2 e_3 e_4)) - (if (subst x_1 e_1 e_2) - (subst x_1 e_1 e_3) - (subst x_1 e_1 e_4))] - [(subst x_1 e_1 (begin e_2 e_3)) - (begin (subst x_1 e_1 e_2) - (subst x_1 e_1 e_3))] - [(subst x_1 e_1 (set! x_2 e_2)) - (set! x_2 (subst x_1 e_1 e_2))] - [(subst x_1 e_1 (% e_2 e_3 e_4)) - (% (subst x_1 e_1 e_2) - (subst x_1 e_1 e_3) - (subst x_1 e_1 e_4))] - [(subst x_1 e_1 (wcm ((v_1 v_2) ...) e_2)) - (wcm (((subst x_1 e_1 v_1) - (subst x_1 e_1 v_2)) ...) - (subst x_1 e_1 e_2))] - [(subst x_1 e_1 (dw x_2 e_2 e_3 e_4)) + [(subst x e_1 e_2) (subst* ((x e_1)) e_2)]) + +(define-metafunction grammar + [(subst* () e) e] ;; shortcut + [(subst* ((x_0 e_0) ... (x_1 e_1) (x_4 e_4) ...) (λ (x_2 ... x_1 x_3 ...) e_2)) + (subst* ((x_0 e_0) ... (x_4 e_4) ...) (λ (x_2 ... x_1 x_3 ...) e_2))] + [(subst* ((x_1 e_1) ...) (λ (x_2 ...) e_2)) ; x_1 != any x_2 + ,(term-let ([(x_new ...) (variables-not-in (term (((x_1 e_1) ...) e_2)) (term (x_2 ...)))]) + (term (λ (x_new ...) + (subst* ((x_1 e_1) ...) (replace* ((x_2 x_new) ...) e_2)))))] + [(subst* ((x_0 e_0) ... (x_1 e_1) (x_2 e_2) ...) x_1) e_1] + [(subst* ((x_1 e) ...) x_2) x_2] ; x_1 != x_2, since previous didn't match + [(subst* ((x_1 e_1) ...) (list v_1 ...)) (list (subst* ((x_1 e_1) ...) v_1) ...)] + [(subst* ((x_1 e_1) ...) (cont v E)) (cont (subst* ((x_1 e_1) ...) v) E)] + [(subst* ((x_1 e_1) ...) v_1) v_1] ; all other values are atomic + [(subst* ((x_1 e_1) ...) (e_2 ...)) + ((subst* ((x_1 e_1) ...) e_2) ...)] + [(subst* ((x_1 e_1) ...) (if e_2 e_3 e_4)) + (if (subst* ((x_1 e_1) ...) e_2) + (subst* ((x_1 e_1) ...) e_3) + (subst* ((x_1 e_1) ...) e_4))] + [(subst* ((x_1 e_1) ...) (begin e_2 e_3)) + (begin (subst* ((x_1 e_1) ...) e_2) + (subst* ((x_1 e_1) ...) e_3))] + [(subst* ((x_1 e_1) ...) (set! x_2 e_2)) + (set! x_2 (subst* ((x_1 e_1) ...) e_2))] + [(subst* ((x_1 e_1) ...) (% e_2 e_3 e_4)) + (% (subst* ((x_1 e_1) ...) e_2) + (subst* ((x_1 e_1) ...) e_3) + (subst* ((x_1 e_1) ...) e_4))] + [(subst* ((x_1 e_1) ...) (wcm ((v_1 v_2) ...) e_2)) + (wcm (((subst* ((x_1 e_1) ...) v_1) + (subst* ((x_1 e_1) ...) v_2)) ...) + (subst* ((x_1 e_1) ...) e_2))] + [(subst* ((x_1 e_1) ...) (dw x_2 e_2 e_3 e_4)) (dw x_2 - (subst x_1 e_1 e_2) - (subst x_1 e_1 e_3) - (subst x_1 e_1 e_4))]) + (subst* ((x_1 e_1) ...) e_2) + (subst* ((x_1 e_1) ...) e_3) + (subst* ((x_1 e_1) ...) e_4))]) (define-metafunction grammar - [(subst* () () e_1) e_1] - [(subst* (x_1 x_2 ...) (e_1 e_2 ...) e_3) - (subst* (x_2 ...) (e_2 ...) (subst x_1 e_1 e_3))]) + [(replace* ((x_1 x_2) ... (x_3 x_4) (x_5 x_6) ...) x_3) x_4] + [(replace* ((x_1 x_2) ...) (any ...)) ((replace* ((x_1 x_2) ...) any) ...)] + [(replace* ((x_1 x_2) ...) any) any]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Other meta-functions: diff -Nru racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/reduce.rkt racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/reduce.rkt --- racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/reduce.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/reduce.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,7 +13,7 @@ ;; beta (~~> ((λ (x_1 ..._1) e_1) v_1 ..._1) - (subst* (x_1 ...) (v_1 ...) e_1) + (subst* ((x_1 v_1) ...) e_1) "beta") ;; arithmetic diff -Nru racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/test.rkt racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/test.rkt --- racket-6.12+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/test.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-examples/redex/examples/delim-cont/test.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -30,8 +30,40 @@ (printf "=> ~s\n\n" r) (error 'test "expected ~s" result))) (set! tests-passed (add1 tests-passed))) + +(define-syntax (test-subst stx) + (syntax-case stx () + [(_ in out) + #`(test-subst/proc #,(syntax-line stx) (term in) (term out))])) +(define (test-subst/proc line in out) + (unless (equal? in out) + (error 'test-subst "test on line ~a failed:\n ~s\n ~s" + line in out)) + (set! tests-passed (+ tests-passed 1))) + (define tests-passed 0) +;; Subst ---------------------------------------- + +(define (substitution-tests) + (test-subst (subst x x 1) 1) + (test-subst (subst x y 1) 1) + (test-subst (subst x y (x x)) (y y)) + (test-subst (subst x y (λ (x) x)) (λ (x) x)) + (test-subst (subst x y (λ (z x p) x)) (λ (z x p) x)) + (test-subst (subst x y (λ (y) x)) (λ (y1) y)) + (test-subst (subst x y (if x x x)) (if y y y)) + (test-subst (subst* ((a 1) (b 2) (c 3)) (if a b c)) (if 1 2 3)) + (test-subst (subst* ((a 1) (b 2) (c 3)) (dw q a b c)) (dw q 1 2 3)) + (test-subst (subst* ((a 1) (b 2) (c 3)) (list (λ (p) a) (λ (q) b) (λ (r) c))) + (list (λ (p) 1) (λ (q) 2) (λ (r) 3))) + (test-subst (subst* ((a 1) (b 2) (c 3)) (begin a (set! z (% a b c)))) + (begin 1 (set! z (% 1 2 3)))) + (test-subst (subst* ((a 1) (b 2) (c 3)) (wcm (((λ (x) a) (λ (x) b))) c)) + (wcm (((λ (x) 1) (λ (x) 2))) 3)) + (test-subst (subst* ((a 1) (b 2)) (cont (λ (x) b) hole)) + (cont (λ (x) 2) hole))) + ;; Basic ---------------------------------------- (define (basic-tests) @@ -1222,12 +1254,21 @@ `(<> (,@chain-defns) [,@chain-output 1 3 4 2] - 0))) + 0)) + (test "substitution" + `(<> + ((S #t)) + () + (((λ (o S) o) + (λ () S) + #f))) + `(<> ((S #t)) () #t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Run (begin + (substitution-tests) (basic-tests) (r6rs-dw-tests) (cont-tests) diff -Nru racket-6.12+ppa1/share/pkgs/redex-gui-lib/info.rkt racket-7.0+ppa1/share/pkgs/redex-gui-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-gui-lib/info.rkt 2018-01-26 21:09:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-gui-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "draw-lib" "gui-lib" "data-lib" "profile-lib" "redex-lib" "redex-pict-lib" "pict-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("redex-lib" "redex-pict-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\" gui") (define pkg-authors (quote (robby bfetscher))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "draw-lib" "gui-lib" "data-lib" "profile-lib" "redex-lib" "redex-pict-lib" "pict-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("redex-lib" "redex-pict-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\" gui") (define pkg-authors (quote (robby bfetscher))))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-gui-lib/redex/private/stepper.rkt racket-7.0+ppa1/share/pkgs/redex-gui-lib/redex/private/stepper.rkt --- racket-6.12+ppa1/share/pkgs/redex-gui-lib/redex/private/stepper.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-gui-lib/redex/private/stepper.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -25,6 +25,7 @@ "sexp-diffs.rkt" "size-snip.rkt" redex/private/reduction-semantics + redex/private/judgment-form redex/private/lang-struct redex/private/binding-forms redex/private/struct @@ -66,9 +67,13 @@ ;; all-nodes-ht : hash[sexp -o> (is-a/c node%)] (define all-nodes-ht - (let* ([lang (reduction-relation-lang red)] - [term-equal? (lambda (x y) (α-equal? (compiled-lang-binding-table lang) match-pattern x y))] - [term-hash (lambda (x) (α-equal-hash-code (compiled-lang-binding-table lang) match-pattern x))]) + (let* ([lang (reduction-relation/IO-jf-lang red)] + [term-equal? (lambda (x y) (α-equal? (compiled-lang-binding-table lang) + (compiled-lang-literals lang) + match-pattern x y))] + [term-hash (lambda (x) (α-equal-hash-code (compiled-lang-binding-table lang) + (compiled-lang-literals lang) + match-pattern x))]) (make-custom-hash term-equal? term-hash))) (define root (new node% @@ -123,7 +128,9 @@ [editor zoom-out-pb])) (define choice-vp (new vertical-panel% [alignment '(center center)] [parent lower-hp] [stretchable-width #f])) - (define reduction-names (reduction-relation->rule-names red)) + (define reduction-names (if (IO-judgment-form? red) + '() + (reduction-relation->rule-names red))) (define reds-choice (and (not (null? reduction-names)) (new choice% @@ -135,7 +142,7 @@ (map (λ (x) (format "Reduce until ~a" x)) reduction-names))]))) (define red-name-message - (and (not (null? (reduction-relation->rule-names red))) + (and (not (null? reduction-names)) (new message% [parent choice-vp] [stretchable-width #t] diff -Nru racket-6.12+ppa1/share/pkgs/redex-gui-lib/redex/private/traces.rkt racket-7.0+ppa1/share/pkgs/redex-gui-lib/redex/private/traces.rkt --- racket-6.12+ppa1/share/pkgs/redex-gui-lib/redex/private/traces.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-gui-lib/redex/private/traces.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -348,13 +348,15 @@ [label "Top to Bottom"])) (define reductions-lang - (cond - [(reduction-relation? reductions) (reduction-relation-lang reductions)] - [(IO-judgment-form? reductions) (runtime-judgment-form-lang reductions)])) + (reduction-relation/IO-jf-lang reductions)) (define snip-cache - (let* ([term-equal? (lambda (x y) (α-equal? (compiled-lang-binding-table reductions-lang) match-pattern x y))] - [term-hash (lambda (x) (α-equal-hash-code (compiled-lang-binding-table reductions-lang) match-pattern x))]) + (let* ([term-equal? (lambda (x y) (α-equal? (compiled-lang-binding-table reductions-lang) + (compiled-lang-literals reductions-lang) + match-pattern x y))] + [term-hash (lambda (x) (α-equal-hash-code (compiled-lang-binding-table reductions-lang) + (compiled-lang-literals reductions-lang) + match-pattern x))]) (make-custom-hash term-equal? term-hash))) ;; call-on-eventspace-main-thread : (-> any) -> any diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/info.rkt racket-7.0+ppa1/share/pkgs/redex-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/info.rkt 2018-01-26 21:09:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("data-enumerate-lib" #:version "1.3") "scheme-lib" ("base" #:version "6.2.900.6") "data-lib" "math-lib" "tex-table" "profile-lib" "typed-racket-lib" "testing-util-lib" "2d-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\"") (define pkg-authors (quote (robby bfetscher))) (define version "1.13"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("data-enumerate-lib" #:version "1.3") "scheme-lib" ("base" #:version "6.2.900.6") "data-lib" "math-lib" "tex-table" "profile-lib" "typed-racket-lib" "testing-util-lib" "2d-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\"") (define pkg-authors (quote (robby bfetscher))) (define version "1.13"))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt racket-7.0+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,3 +1,7 @@ +v7.0 + + * various bug fixes + v6.12 * typeset prime characters better, e.g. when writing e_′, diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/binding-forms-compiler.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/binding-forms-compiler.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/binding-forms-compiler.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/binding-forms-compiler.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -31,7 +31,9 @@ [_ (raise-syntax-error (syntax-e form-name) "internal error")])) (define-values (pat bspec betas+ellipses) - (surface-bspec->pat&bspec #`(bf-name+bf-body #:exports #,exports) form-name)) + (surface-bspec->pat&bspec + (quasisyntax/loc #'bf-name+bf-body (bf-name+bf-body #:exports #,exports)) + form-name)) (with-syntax ([(syncheck-expr rewritten-pat-with-betas _ _) (rewrite-side-conditions/check-errs all-nts (syntax-e form-name) #t diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/binding-forms.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/binding-forms.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/binding-forms.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/binding-forms.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -101,6 +101,8 @@ (define pattern-matcher (make-parameter "pattern matcher not defined")) ;; Sometimes we want fresh names, sometimes we want canonical names (define name-generator (make-parameter "name generator not defined")) +;; These tell us which symbols are not renamable (when set, should be (listof symbol?)) +(define literals-in-language (make-parameter "literals-in-language not defined")) ;; For α-equivalence testing, we walk the whole term at once. (define all-the-way-down? (make-parameter "all-the-way-downness not defined")) @@ -117,36 +119,37 @@ ;; freshen : (listof (list compiled-pattern bspec)) ;; (compiled-pattern redex-val -> (union #f mtch)) redex-val -> redex-val bool -(define (freshen language-bf-table match-pattern redex-val) +(define (freshen language-bf-table language-literals match-pattern redex-val) (parameterize ([current-bf-table language-bf-table] [pattern-matcher match-pattern] [name-generator generate-readable-fresh-name] + [literals-in-language language-literals] [all-the-way-down? #f]) (first (rec-freshen redex-val #f #t #f)))) ;; α-equal-hash-code : (listof (list compiled-pattern bspec)) ;; (compiled-pattern redex-val -> (union #f mtch)) redex-val -> exact-integer -(define (α-equal-hash-code language-bf-table match-pattern redex-val) - (equal-hash-code (canonicalize language-bf-table match-pattern redex-val))) +(define (α-equal-hash-code language-bf-table language-literals match-pattern redex-val) + (equal-hash-code (canonicalize language-bf-table language-literals match-pattern redex-val))) -(define (α-equal-secondary-hash-code language-bf-table match-pattern redex-val) - (equal-secondary-hash-code (canonicalize language-bf-table match-pattern redex-val))) +(define (α-equal-secondary-hash-code language-bf-table language-literals match-pattern redex-val) + (equal-secondary-hash-code (canonicalize language-bf-table language-literals match-pattern redex-val))) -(define (make-α-hash language-bf-table match-pattern) - (make-custom-hash (λ (x y) (α-equal? language-bf-table match-pattern x y)) - (λ (x) (α-equal-hash-code language-bf-table match-pattern x)) - (λ (x) (α-equal-secondary-hash-code language-bf-table match-pattern x)))) +(define (make-α-hash language-bf-table language-literals match-pattern) + (make-custom-hash (λ (x y) (α-equal? language-bf-table language-literals match-pattern x y)) + (λ (x) (α-equal-hash-code language-bf-table language-literals match-pattern x)) + (λ (x) (α-equal-secondary-hash-code language-bf-table language-literals match-pattern x)))) -(define (make-immutable-α-hash language-bf-table match-pattern) +(define (make-immutable-α-hash language-bf-table language-literals match-pattern) (make-immutable-custom-hash - (λ (x y) (α-equal? language-bf-table match-pattern x y)) - (λ (x) (α-equal-hash-code language-bf-table match-pattern x)) - (λ (x) (α-equal-secondary-hash-code language-bf-table match-pattern x)))) + (λ (x y) (α-equal? language-bf-table language-literals match-pattern x y)) + (λ (x) (α-equal-hash-code language-bf-table language-literals match-pattern x)) + (λ (x) (α-equal-secondary-hash-code language-bf-table language-literals match-pattern x)))) ;; α-equal? : (listof (list compiled-pattern bspec)) ;; (compiled-pattern redex-val -> (union #f mtch)) redex-val -> boolean -(define (α-equal? language-bf-table match-pattern redex-val-lhs redex-val-rhs) +(define (α-equal? language-bf-table language-literals match-pattern redex-val-lhs redex-val-rhs) (cond ;; short-circuit on some easy cases: [(eq? redex-val-lhs redex-val-rhs) #t] @@ -157,15 +160,16 @@ (list? redex-val-rhs))) #f] [(not (list? redex-val-lhs)) (equal? redex-val-lhs redex-val-rhs)] [else - (equal? (canonicalize language-bf-table match-pattern redex-val-lhs) - (canonicalize language-bf-table match-pattern redex-val-rhs))])) + (equal? (canonicalize language-bf-table language-literals match-pattern redex-val-lhs) + (canonicalize language-bf-table language-literals match-pattern redex-val-rhs))])) ;; Perform a capture-avoiding substitution -(define (safe-subst language-bf-table match-pattern redex-val redex-val-old-var redex-val-new-val) +(define (safe-subst language-bf-table language-literals match-pattern redex-val redex-val-old-var redex-val-new-val) (parameterize ([current-bf-table language-bf-table] [pattern-matcher match-pattern] [name-generator generate-readable-fresh-name] + [literals-in-language language-literals] [all-the-way-down? #t]) (let loop [(v (first (rec-freshen redex-val #f #t #f)))] @@ -177,7 +181,7 @@ (define canonical-name-marker (gensym)) ;; not exported, but useful here: -(define (canonicalize language-bf-table match-pattern redex-val) +(define (canonicalize language-bf-table language-literals match-pattern redex-val) (define current-name-id 0) (parameterize @@ -186,7 +190,8 @@ [all-the-way-down? #t] [name-generator (λ (orig) (set! current-name-id (add1 current-name-id)) - `(,canonical-name-marker ,current-name-id))]) + `(,canonical-name-marker ,current-name-id))] + [literals-in-language language-literals]) (first (rec-freshen redex-val #f #t #f)))) @@ -546,7 +551,8 @@ ;; subterms have no binding structure this way: (parameterize ([current-bf-table `()] - [pattern-matcher #f]) + [pattern-matcher #f] + [literals-in-language '()]) (check-equal? @@ -583,7 +589,9 @@ ;; `noop?` is true because unused exports are treated as free (map (λ (elt) (car (rec-freshen elt #f #t #f))) redex-val) redex-val) ())] - [(and (symbol? redex-val) assume-binder?) + [(and (symbol? redex-val) + assume-binder? + (not (member redex-val (literals-in-language)))) (if (or noop? (and top-level? (all-the-way-down?))) `(,redex-val ((,redex-val ,redex-val))) (redex-error @@ -626,7 +634,8 @@ nt-name (let handle-... ([...-depth (second trscr-depth)] [exp (bind-exp b)]) (if (= ...-depth 0) - (if (symbol? exp) + (if (and (symbol? exp) + (not (member exp (literals-in-language)))) (let ([new-name ;; Is it a binder, and should we freshen it? (if (and sub-ported? (not sub-noop?)) @@ -750,6 +759,7 @@ (parameterize ([current-bf-table `()] [pattern-matcher #f] [name-generator gensym] + [literals-in-language '()] [all-the-way-down? #f]) (check-equal? diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/cycle-check.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/cycle-check.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/cycle-check.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/cycle-check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,15 +1,50 @@ #lang racket/base -(require racket/match) +(require racket/match + (for-template "lang-struct.rkt")) -(provide check-for-cycles) +(provide build-graph-and-check-for-cycles + check-for-cycles + build-union-language-nt-neighbors/nt-hole-at-top) -(define (check-for-cycles stx ntss/stx prodss/stx nt-identifiers) +(define (build-graph-and-check-for-cycles stx ntss/stx prodss/stx nt-identifiers + aliases + parent-language-nt-hole-at-top + parent-language-nt-neighbors) (define ntss (syntax->datum ntss/stx)) (define prodss (syntax->datum prodss/stx)) - + ;; hash[sym[nt] -o> #t] - (define produces-hole (make-hash)) + ;; maps all nt aliases to #t + (define nt-hole-at-top (make-hash)) + + ;; hash[sym[nt] -o> (listof sym[nt]) + ;; contains no nt aliases -- at least, it isn't supposed to + ;; (if you have a possibly-aliased nt, look it up in the + ;; alias table before you consult this hash) + (define nt-neighbors (make-hash)) + + (when parent-language-nt-hole-at-top + (for ([(nt ans) (in-hash parent-language-nt-hole-at-top)]) + (define in-ntss? + (for/or ([nts (in-list ntss)]) + (for/or ([nt2 (in-list nts)]) + (equal? nt nt2)))) + (unless in-ntss? + (hash-set! nt-hole-at-top nt ans) + (hash-set! nt-neighbors nt (hash-ref parent-language-nt-neighbors nt))))) + + (when parent-language-nt-neighbors + (for ([(nt _) (in-hash parent-language-nt-neighbors)]) + (hash-set! nt-neighbors (hash-ref aliases nt nt) '()))) + + (define (add-neighbors-link from/aliased to/aliased) + (define from (hash-ref aliases from/aliased from/aliased)) + (define to (hash-ref aliases to/aliased to/aliased)) + (hash-set! nt-neighbors from + (cons to + (hash-ref nt-neighbors from)))) + (let loop () (define any-change? #f) (for ([nts (in-list ntss)] @@ -17,80 +52,156 @@ (for ([prod (in-list prods)]) (define (set-these) (for ([nt (in-list nts)]) - (unless (hash-ref produces-hole nt #f) - (hash-set! produces-hole nt #t) + (unless (hash-ref nt-hole-at-top nt #f) + (hash-set! nt-hole-at-top nt #t) (set! any-change? #t)))) (match prod [`hole (set-these)] - [`(nt ,name) - (when (hash-ref produces-hole name #f) + [`(nt ,name) + (when (hash-ref nt-hole-at-top name #f) + (set-these))] + [(? (λ (x) (member x extend-nt-ellipses))) + (define parent-language-nt-has-hole? + (and parent-language-nt-hole-at-top + (for/or ([nt (in-list nts)]) + (hash-ref parent-language-nt-hole-at-top nt #f)))) + (when parent-language-nt-has-hole? (set-these))] [_ (void)]))) (when any-change? (loop))) - - ;; hash[sym[nt] -o> (listof sym[nt]) - (define neighbors-table (make-hash)) - + ;; build the graph (for ([nts (in-list ntss)] [prods (in-list prodss)]) (define base-nt (car nts)) - (for ([nt (in-list (cdr nts))]) - (hash-set! neighbors-table nt (list base-nt))) - (hash-set! neighbors-table base-nt '()) + (hash-set! nt-neighbors base-nt '()) (for ([prod (in-list prods)]) - (define (add-link name) - (hash-set! neighbors-table base-nt (cons name (hash-ref neighbors-table base-nt)))) (match prod - [`(nt ,name) (add-link name)] - [`(in-hole hole (nt ,name)) (add-link name)] + [`(nt ,name) (add-neighbors-link base-nt name)] + [`(in-hole hole (nt ,name)) (add-neighbors-link base-nt name)] [`(in-hole (nt ,name1) (nt ,name2)) - (when (hash-ref produces-hole name1 #f) - (add-link name2))] + (when (hash-ref nt-hole-at-top name1 #f) + (add-neighbors-link base-nt name2))] + [(? (λ (x) (member x extend-nt-ellipses))) + (when parent-language-nt-hole-at-top + (when parent-language-nt-neighbors + (define nt (hash-ref aliases (car nts) (car nts))) + (for/or ([neighbor (hash-ref parent-language-nt-neighbors nt)]) + (add-neighbors-link base-nt neighbor))))] [_ (void)]))) - - ;; traverse the graph looking for cycles + + (check-for-cycles stx nt-identifiers nt-neighbors) + + (values nt-hole-at-top nt-neighbors)) + +(define (build-union-language-nt-neighbors/nt-hole-at-top + aliases + prefixes + parent-language-nt-hole-at-tops + parent-language-nt-neighborss) + + (define nt-hole-at-top (make-hash)) + + (define nt-neighbors (make-hash)) + + (define (add-prefix prefix parent-nt) + (if prefix + (string->symbol (format "~a~a" prefix parent-nt)) + parent-nt)) + + (for ([prefix (in-list prefixes)] + [parent-language-nt-hole-at-top (in-list parent-language-nt-hole-at-tops)]) + (for ([(parent-nt has-hole?) (in-hash parent-language-nt-hole-at-top)]) + (when has-hole? + (hash-set! nt-hole-at-top + (add-prefix prefix parent-nt) + #t)))) + + (for ([prefix (in-list prefixes)] + [parent-language-nt-neighbors (in-list parent-language-nt-neighborss)]) + (for ([(parent-nt neighbors) (in-hash parent-language-nt-neighbors)]) + (define nt/prefix (add-prefix prefix parent-nt)) + (define nt (hash-ref aliases nt/prefix nt/prefix)) + (hash-set! nt-neighbors + nt + (append (hash-ref nt-neighbors nt '()) + (for/list ([neighbor (in-list neighbors)]) + (define nt (add-prefix prefix neighbor)) + (hash-ref aliases nt nt)))))) + (values nt-hole-at-top nt-neighbors)) + +(define (check-for-cycles stx nt-identifiers nt-neighbors) + (define cycle - (for/or ([(nt neighbors) (in-hash neighbors-table)]) + (for/or ([(nt neighbors) (in-hash nt-neighbors)]) (define visited (make-hash)) - (for/or ([neighbor (in-list neighbors)]) + (for/or ([neighbor (in-list neighbors)]) (let loop ([current-node neighbor]) (cond [(eq? current-node nt) nt] [(hash-ref visited current-node #f) #f] [else (hash-set! visited current-node #t) - (for/or ([neighbor (in-list (hash-ref neighbors-table current-node))]) + (for/or ([neighbor (in-list (hash-ref nt-neighbors current-node))]) (loop neighbor))]))))) - + (when cycle (define bad-path - (for/or ([neighbor (in-list (hash-ref neighbors-table cycle))]) + (for/or ([neighbor (in-list (hash-ref nt-neighbors cycle))]) (let loop ([node neighbor]) (cond [(equal? node cycle) (list node)] [else - (for/or ([neighbor (in-list (hash-ref neighbors-table node))]) + (for/or ([neighbor (in-list (hash-ref nt-neighbors node))]) (define path (loop neighbor)) (and path (cons node path)))])))) - (define full-path (cons cycle bad-path)) - (define all/backwards (for/list ([nt (in-list (reverse bad-path))]) - (define stx (hash-ref nt-identifiers nt)) - (datum->syntax stx nt stx))) + (define bad-path/stx-objects + (for/list ([nt (in-list bad-path)]) + (define stx-lst (hash-ref nt-identifiers nt #f)) + (cond + [stx-lst + (define lst (if (syntax? stx-lst) (syntax->list stx-lst) stx-lst)) + (define stx (car lst)) + (datum->syntax stx nt stx)] + [else nt]))) + + (define bad-path-starting-point + (for/fold ([smallest (car bad-path/stx-objects)]) + ([point (in-list (cdr bad-path/stx-objects))]) + (define smaller? + (< (or (and (syntax? smallest) (syntax-position smallest)) +inf.0) + (or (and (syntax? smallest) (syntax-position point)) +inf.0))) + (if smaller? + smallest + point))) + (define bad-path-in-canonical-order + (let loop ([bad-path bad-path/stx-objects]) + (cond + [(equal? bad-path-starting-point (car bad-path)) + bad-path] + [else + (loop (append (cdr bad-path) (list (car bad-path))))]))) + (define bad-path-in-canonical-order/stx-only + (filter syntax? bad-path-in-canonical-order)) (raise-syntax-error 'define-language - (if (= 1 (length bad-path)) + (if (= 1 (length bad-path-in-canonical-order)) (format "the non-terminal ~a is defined in terms of itself" - (car bad-path)) + (if (syntax? (car bad-path-in-canonical-order)) + (syntax-e (car bad-path-in-canonical-order)) + (car bad-path-in-canonical-order))) (format "found a cycle of non-terminals that doesn't consume input:~a" (apply string-append - (for/list ([node (in-list full-path)]) - (format " ~a" node))))) + (for/list ([node (in-list bad-path-in-canonical-order)]) + (format " ~a" (if (syntax? node) (syntax-e node) node)))))) stx - (car all/backwards) - (cdr all/backwards)))) + (and (pair? bad-path-in-canonical-order/stx-only) + (car bad-path-in-canonical-order/stx-only)) + (if (pair? bad-path-in-canonical-order/stx-only) + (cdr bad-path-in-canonical-order/stx-only) + '())))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -50,14 +50,66 @@ (define-struct metafunc-extra-where (lhs rhs)) (define-struct metafunc-extra-fresh (vars)) -(define-struct runtime-judgment-form (name proc mode cache lang) +(define-struct runtime-judgment-form (name proc mode cache lang + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat + input-contract-pat + output-contract-pat) #:methods gen:custom-write [(define (write-proc rjf port _mode) (if (runtime-judgment-form-mode rjf) - (display "#" port))]) +(define (build-runtime-judgment-form parent-judgment-form + name proc mode lang + original-contract-expression ;; (or/c #f (listof s-exp)) + input-contract-pat + output-contract-pat) + (define cache (cons (box (make-hash)) (box (make-hash)))) + (make-runtime-judgment-form + name proc mode cache lang + (cond + [original-contract-expression + original-contract-expression] + [parent-judgment-form + (runtime-judgment-form-original-contract-expression + parent-judgment-form)] + [else #f]) + (cond + [original-contract-expression + (compile-pattern lang input-contract-pat #f)] + [(and parent-judgment-form + (runtime-judgment-form-input-contract-pat parent-judgment-form)) + => + (λ (pat) (compile-pattern lang pat #f))] + [else #f]) + (cond + [original-contract-expression + (compile-pattern lang output-contract-pat #f)] + [(and parent-judgment-form + (runtime-judgment-form-output-contract-pat parent-judgment-form)) + => + (λ (pat) (compile-pattern lang pat #f))] + [else #f]) + (or input-contract-pat + (and parent-judgment-form + (runtime-judgment-form-input-contract-pat parent-judgment-form))) + (or output-contract-pat + (and parent-judgment-form + (runtime-judgment-form-output-contract-pat parent-judgment-form))))) (begin-for-syntax ;; pre: (judgment-form-id? stx) holds @@ -166,7 +218,9 @@ "compiled-lang?" 0 lang lhs rhs)) - (α-equal? (compiled-lang-binding-table lang) match-pattern lhs rhs)] + (α-equal? (compiled-lang-binding-table lang) + (compiled-lang-literals lang) + match-pattern lhs rhs)] [(lhs rhs) (define l (default-language)) (unless l @@ -290,7 +344,7 @@ (define judgment-form (lookup-judgment-form-id #'form-name)) (check-judgment-arity stx premise) (define mode (judgment-form-mode judgment-form)) - (define judgment-proc (judgment-form-proc judgment-form)) + (define runtime-judgment-form-id (judgment-form-runtime-judgment-form-id judgment-form)) (define-values (input-template output-pre-pattern) (let-values ([(in out) (split-by-mode (syntax->list #'(pats ...)) mode)]) (if under-ellipsis? @@ -317,10 +371,18 @@ (forward-errortrace-prop premise (quasisyntax/loc premise - (call-judgment-form 'form-name #,judgment-proc '#,mode #,input + (call-judgment-form 'form-name + #,(judgment-form-proc judgment-form) + '#,mode #,input #,(if jf-results-id #''() #f) #,(judgment-form-cache judgment-form) - #,ct-lang)))) + #,ct-lang + #,(judgment-form-original-contract-expression-id + judgment-form) + #,(judgment-form-compiled-input-contract-pat-id + judgment-form) + #,(judgment-form-compiled-output-contract-pat-id + judgment-form))))) (if under-ellipsis? #`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x))) (make-traced input)))) @@ -334,7 +396,7 @@ (set! compiled-pattern-identifiers (cons #'pat-id compiled-pattern-identifiers)) #`(begin #,syncheck-exp - (void #,(defined-check judgment-proc "judgment form" #:external #'form-name)) + (void #,(defined-check runtime-judgment-form-id "judgment form" #:external #'form-name)) (judgment-form-bind-withs/proc #,rt-lang pat-id @@ -382,10 +444,15 @@ (define (combine-where/error-results pat term who lang result) (define mtchs (match-pattern pat term)) (unless mtchs (error who "where/error did not match")) - (define fst (result (mtch-bindings (car mtchs)))) - (for ([m (in-list (cdr mtchs))]) - (define nxt (result (mtch-bindings m))) - (unless (alpha-equivalent? lang fst nxt) + (define all-results + (for/list ([mtch (in-list mtchs)]) + (result (mtch-bindings mtch)))) + (define fst + (for/first ([a-result (in-list all-results)] + #:when a-result) + a-result)) + (for ([nxt (in-list all-results)]) + (unless (or (not nxt) (alpha-equivalent? lang fst nxt)) (error who "where/error matched multiple ways, but did not return alpha-equivalent? results"))) fst) @@ -412,8 +479,24 @@ (equal? (runtime-judgment-form-mode jf) '(O I))))) (define not-in-cache (gensym)) +(define (call-runtime-judgment-form a-runtime-judgment-form inputs derivation-init) + (call-judgment-form (runtime-judgment-form-name a-runtime-judgment-form) + (runtime-judgment-form-proc a-runtime-judgment-form) + (runtime-judgment-form-mode a-runtime-judgment-form) + inputs + #f + (runtime-judgment-form-cache a-runtime-judgment-form) + (runtime-judgment-form-lang a-runtime-judgment-form) + (runtime-judgment-form-original-contract-expression a-runtime-judgment-form) + (runtime-judgment-form-compiled-input-contract-pat a-runtime-judgment-form) + (runtime-judgment-form-compiled-output-contract-pat a-runtime-judgment-form))) + (define (call-judgment-form form-name form-proc mode input derivation-init - pair-of-boxed-caches ct-lang) + pair-of-boxed-caches ct-lang + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat) + (define boxed-cache (if (include-entire-derivation) (car pair-of-boxed-caches) (cdr pair-of-boxed-caches))) @@ -426,22 +509,59 @@ (let ([cache-value (hash-ref cache input not-in-cache)]) (not (eq? cache-value not-in-cache))))) (define p-a-e (print-as-expression)) - (define (form-proc/cache recur input derivation-init pair-of-boxed-caches) + (define (form-proc/cache recur input derivation-init pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract) + + (define (check-input-contract input) + (when compiled-input-contract-pat + (check-judgment-form-contract form-name input #f + compiled-input-contract-pat + original-contract-expression + 'I + mode))) + + (define (check-output-contract input outputs) + (when compiled-output-contract-pat + (for ([output (in-list outputs)]) + (check-judgment-form-contract form-name input output + compiled-output-contract-pat + original-contract-expression + 'O + mode)))) + (parameterize ([default-language ct-lang] [print-as-expression p-a-e] [binding-forms-opened? (if (caching-enabled?) (box #f) #f)]) + (check-input-contract input) (cond [(caching-enabled?) (define candidate (hash-ref cache input not-in-cache)) (cond [(equal? candidate not-in-cache) - (define computed-ans (form-proc recur input derivation-init pair-of-boxed-caches)) + (define output (form-proc recur input derivation-init pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract)) + (check-output-contract input output) (unless (unbox (binding-forms-opened?)) - (hash-set! cache input computed-ans)) - computed-ans] + (hash-set! cache input output)) + output] [else candidate])] - [else (form-proc recur input derivation-init pair-of-boxed-caches)]))) + [(not compiled-output-contract-pat) + (form-proc recur input derivation-init pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract)] + [else + (define output (form-proc recur input derivation-init pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract)) + (check-output-contract input output) + output]))) (define dwoos (if (or (eq? 'all traced) (memq form-name traced)) (let ([outputs #f]) @@ -453,7 +573,13 @@ [else '()])) (define (wrapped . _) - (set! outputs (form-proc/cache form-proc/cache input derivation-init pair-of-boxed-caches)) + (set! outputs (form-proc/cache form-proc/cache + input + derivation-init + pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat)) (for/list ([output (in-list outputs)]) (cons form-name (assemble mode input (derivation-with-output-only-output output))))) (define otr (current-trace-print-results)) @@ -473,10 +599,18 @@ result-tracer)]) (apply trace-call form-name wrapped (assemble mode input spacers))) outputs) - (form-proc/cache form-proc/cache input derivation-init pair-of-boxed-caches))) + (form-proc/cache form-proc/cache + input + derivation-init + pair-of-boxed-caches + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat))) (define without-exact-duplicates-vec (apply vector (remove-duplicates dwoos))) - (define ht (make-α-hash (compiled-lang-binding-table ct-lang) match-pattern)) + (define ht (make-α-hash (compiled-lang-binding-table ct-lang) + (compiled-lang-literals ct-lang) + match-pattern)) (for ([d (in-vector without-exact-duplicates-vec)] [i (in-naturals)]) (define t (derivation-with-output-only-output d)) @@ -784,21 +918,38 @@ (judgment-form '#,judgment-form-name '#,(and mode (cdr mode)) #'judgment-form-runtime-proc #'mk-judgment-form-proc #'#,lang #'jf-lws '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses #'jf-term-proc #,is-relation? - #'jf-cache (λ (stx) (expand-to-id #'the-runtime-judgment-form stx)))) - (define-values (mk-judgment-form-proc mk-judgment-gen-clauses) + #'jf-cache #'the-runtime-judgment-form + #'original-contract-expression-id + #'compiled-input-contract-pat-id + #'compiled-output-contract-pat-id + (λ (stx) (expand-to-id #'the-runtime-judgment-form stx)))) + (define-values (mk-judgment-form-proc + mk-judgment-gen-clauses + original-contract-expression + judgment-form-input-contract + judgment-form-output-contract) (compile-judgment-form #,judgment-form-name #,mode-stx #,lang #,clauses #,rule-names #,position-contracts #,invariant #,orig #,stx #,syn-err-name judgment-runtime-gen-clauses)) (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) (define jf-lws (compiled-judgment-form-lws #,clauses #,judgment-form-name #,stx)) (define judgment-runtime-gen-clauses (mk-judgment-gen-clauses #,lang (λ () (judgment-runtime-gen-clauses)))) (define jf-term-proc (make-jf-term-proc #,judgment-form-name #,syn-err-name #,lang #,nts #,mode-stx)) - (define jf-cache (cons (box (make-hash)) (box (make-hash)))) (define the-runtime-judgment-form - (runtime-judgment-form '#,judgment-form-name - judgment-form-runtime-proc - '#,(and mode (cdr mode)) - jf-cache - #,lang))))) + (build-runtime-judgment-form #,orig + '#,judgment-form-name + judgment-form-runtime-proc + '#,(and mode (cdr mode)) + #,lang + original-contract-expression + judgment-form-input-contract + judgment-form-output-contract)) + (define jf-cache (runtime-judgment-form-cache the-runtime-judgment-form)) + (define original-contract-expression-id + (runtime-judgment-form-original-contract-expression the-runtime-judgment-form)) + (define compiled-input-contract-pat-id + (runtime-judgment-form-compiled-input-contract-pat the-runtime-judgment-form)) + (define compiled-output-contract-pat-id + (runtime-judgment-form-compiled-output-contract-pat the-runtime-judgment-form))))) (syntax-property (values ;prune-syntax (if (eq? 'top-level (syntax-local-context)) @@ -807,7 +958,11 @@ #`(begin (define-syntaxes (judgment-form-runtime-proc judgment-runtime-gen-clauses - jf-term-proc jf-lws jf-cache) + jf-term-proc jf-lws jf-cache + original-contract-expression-id + compiled-input-contract-pat-id + compiled-output-contract-pat-id + the-runtime-judgment-form) (values)) #,definitions) definitions)) @@ -1064,13 +1219,11 @@ [(_ jf-expr) #'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) -(define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses rule-names contracts orig-ctcs nts orig lang stx syn-error-name) +(define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses rule-names + orig-ctcs nts orig lang stx syn-error-name) (define is-relation? (jf-is-relation? name)) (with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))]) (define mode (let ([m (syntax->datum mode-stx)]) (and m (cdr m)))) - (define-values (input-contracts output-contracts) - (values (first contracts) - (second contracts))) (define (compile-clause clause clause-name) (syntax-case clause () [((_ . conc-pats) . prems) @@ -1083,7 +1236,13 @@ (cons name (struct-copy judgment-form (lookup-judgment-form-id name) [proc #'recur] - [cache #'recur-cache]))]) + [cache #'recur-cache] + [original-contract-expression-id + #'original-contract-expression] + [compiled-input-contract-pat-id + #'compiled-input-contract-pat] + [compiled-output-contract-pat-id + #'compiled-output-contract-pat]))]) (bind-withs syn-error-name '() lang nts lang (syntax->list #'prems) 'flatten #`(list (derivation-with-output-only (term (#,@output-pats) #:lang #,lang) @@ -1093,30 +1252,17 @@ (syntax->list #'(names/ellipses ...)) #f #'jf-derivation-id))) - (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) - (generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))] + (with-syntax ([(compiled-lhs) (generate-temporaries '(compiled-lhs))] [(compiled-pattern-identifier ...) compiled-pattern-identifiers] [(pattern-to-compile ...) patterns-to-compile]) #`(;; pieces of a 'let' expression to be combined: first some bindings ([compiled-pattern-identifier (compile-pattern lang pattern-to-compile #t)] ... - [compiled-lhs (compile-pattern lang `lhs #t)] - #,@(if input-contracts - (list #`[compiled-input-ctcs (compile-pattern lang `#,input-contracts #f)]) - (list)) - #,@(if output-contracts - (list #`[compiled-output-ctcs (compile-pattern lang `#,output-contracts #f)]) - (list))) + [compiled-lhs (compile-pattern lang `lhs #t)]) ;; and then the body of the let, but expected to be behind a (λ (input) ...). (let ([jf-derivation-id init-jf-derivation-id]) (begin lhs-syncheck-exp - #,@(if input-contracts - (list #`(check-judgment-form-contract '#,name input #f - compiled-input-ctcs - '#,orig-ctcs 'I '#,mode - '#,is-relation?)) - (list)) (combine-judgment-rhses compiled-lhs input @@ -1124,14 +1270,7 @@ #,(bind-pattern-names 'judgment-form #'(names/ellipses ...) #'((lookup-binding bnds 'names) ...) - body)) - #,(if output-contracts - #`(λ (output) - (check-judgment-form-contract '#,name input output - compiled-output-ctcs - '#,orig-ctcs 'O '#,mode - '#,is-relation?)) - #`void))))))))])) + body)))))))))])) (when (identifier? orig) (define orig-mode (judgment-form-mode (lookup-judgment-form-id orig))) @@ -1166,15 +1305,24 @@ #`(λ (lang) (let (clause-proc-binding ... ...) (let ([prev (orig-mk lang)]) - (λ (recur input init-jf-derivation-id recur-cache) - (append (prev recur input init-jf-derivation-id recur-cache) + (λ (recur input init-jf-derivation-id recur-cache + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat) + (append (prev recur input init-jf-derivation-id recur-cache + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat) clause-proc-body-backwards ...)))))) #`(λ (lang) (let (clause-proc-binding ... ...) - (λ (recur input init-jf-derivation-id recur-cache) + (λ (recur input init-jf-derivation-id recur-cache + original-contract-expression + compiled-input-contract-pat + compiled-output-contract-pat) (append clause-proc-body-backwards ...))))))))) -(define (combine-judgment-rhses compiled-lhs input rhs check-output) +(define (combine-judgment-rhses compiled-lhs input rhs) (define mtchs (match-pattern compiled-lhs input)) (cond [mtchs @@ -1184,10 +1332,7 @@ (when os (for ([x (in-list os)]) (hash-set! output-table x #t)))) - (define outputs (hash-map output-table (λ (k v) k))) - (for ([output (in-list outputs)]) - (check-output output)) - outputs] + (hash-map output-table (λ (k v) k))] [else '()])) (define-for-syntax (do-compile-judgment-form-lws clauses jf-name-stx full-def) @@ -1233,39 +1378,43 @@ (reverse sc/wheres)))) (define (check-judgment-form-contract form-name input-term output-term+trees - contracts orig-ctcs mode modes is-relation?) - (define o-term (and (equal? mode 'O) + contracts orig-ctcs input-or-output-contract modes) + (define o-term (and (equal? input-or-output-contract 'O) (derivation-with-output-only-output output-term+trees))) (define description - (case mode + (case input-or-output-contract [(I) "input"] [(O) "output"])) (when contracts - (case mode + (case input-or-output-contract [(I) (cond - [is-relation? + [modes (unless (match-pattern contracts input-term) (redex-error form-name - (string-append "relation values do not match the contract;\n" + (string-append "judgment input values do not match its contract;\n" + " (unknown output values indicated by _)\n" " contract: ~s\n" - " values: ~s") + " values: ~s") (cons form-name orig-ctcs) - (cons form-name input-term)))] + (cons form-name (assemble modes input-term (build-list (length modes) + (λ (_) '_))))))] [else (unless (match-pattern contracts input-term) (redex-error form-name - (string-append "judgment input values do not match its contract;\n" - " (unknown output values indicated by _)\n" + (string-append "relation values do not match the contract;\n" " contract: ~s\n" - " values: ~s") + " values: ~s") (cons form-name orig-ctcs) - (cons form-name (assemble modes input-term (build-list (length modes) - (λ (_) '_))))))])] + (cons form-name input-term)))])] [(O) (define io-term (assemble modes input-term o-term)) (unless (match-pattern contracts io-term) - (redex-error form-name "judgment values do not match its contract;\n contract: ~s\n values: ~s" + (redex-error form-name + (string-append + "judgment values do not match its contract;\n" + " contract: ~s\n" + " values: ~s") (cons form-name orig-ctcs) (cons form-name io-term)))]))) (define-for-syntax (mode-check mode clauses nts syn-err-name orig-stx) @@ -1454,15 +1603,17 @@ (λ (ctc-stx) #`(side-condition #,ctc-stx (term invt))) values)) - (define-values (i-ctc-syncheck-expr i-ctc) + (define-values (i-ctc-syncheck-expr i-ctc contract-original-expr) (syntax-case #'ctcs () - [#f (values #'(void) #f)] + [#f (values #'(void) #f #f)] [(p ...) (let-values ([(i-ctcs o-ctcs) (split-by-mode (syntax->list #'(p ...)) mode)]) (with-syntax* ([(i-ctcs ...) i-ctcs] [(syncheck i-ctc-pat (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs #'lang syn-err-name #f #'(i-ctcs ...))]) - (values #'syncheck #'i-ctc-pat)))])) + (values #'syncheck + #'i-ctc-pat + #'(p ...))))])) (define-values (ctc-syncheck-expr ctc) (cond [(not (or (syntax-e #'ctcs) @@ -1479,11 +1630,12 @@ (with-syntax ([(syncheck ctc-pat (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs #'lang syn-err-name #f ctc-stx)]) (values #'syncheck #'ctc-pat))])) + (define-values (input-contract-id output-contract-id) + (apply values (generate-temporaries '(jf-input-contract-id jf-output-contract-id)))) (define proc-stx (do-compile-judgment-form-proc #'judgment-form-name #'mode-arg clauses rule-names - (list i-ctc ctc) #'ctcs nts #'orig @@ -1507,8 +1659,14 @@ (λ () #,(check-pats #'(list comp-clauses ...))))))) - #`(begin #,i-ctc-syncheck-expr #,ctc-syncheck-expr - (values #,proc-stx #,gen-stx)))])) + #`(begin #,i-ctc-syncheck-expr #,ctc-syncheck-expr + (values #,proc-stx + #,gen-stx + #,(if i-ctc + #``#,contract-original-expr + #`#f) + #,(and i-ctc #``#,i-ctc) + #,(and ctc #``#,ctc))))])) (define-for-syntax (fix-relation-clauses name raw-clauses) (map (λ (clause-stx) @@ -1820,7 +1978,7 @@ build-derivations generate-lws IO-judgment-form? - call-judgment-form + call-runtime-judgment-form include-jf-rulename alpha-equivalent? (struct-out derivation-subs-acc) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/lang-struct.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/lang-struct.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/lang-struct.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/lang-struct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,5 +1,5 @@ #lang racket/base -(require racket/promise) +(require racket/promise (for-syntax racket/base)) (provide (struct-out nt) make-multi-name-nt (struct-out rhs) (struct-out bind) @@ -18,11 +18,20 @@ the-not-hole the-hole hole? + term/pretty-write-doing-the-printing (struct-out compiled-lang) compiled-lang-across-ht compiled-lang-across-list-ht compiled-lang-cclang - default-language) + default-language + + extend-nt-ellipses + (for-syntax extend-nt-ellipses)) + + +(begin-for-syntax + (define extend-nt-ellipses '(....))) +(define extend-nt-ellipses '(....)) ;; lang = (listof nt) ;; nt = (make-nt sym (listof rhs)) @@ -30,6 +39,7 @@ ;; single-pattern = sexp (define-struct nt (name rhs) #:transparent) (define-struct rhs (pattern) #:transparent) +(define term/pretty-write-doing-the-printing (make-parameter #f)) (define-values (the-hole the-not-hole hole?) (let () (struct hole (which) @@ -42,7 +52,7 @@ "hole" "not-hole")) (cond - [(or (equal? mode 0) (equal? mode 1)) + [(or (equal? mode 0) (equal? mode 1) (term/pretty-write-doing-the-printing)) (write-string str port)] [else (write-string "#<" port) @@ -114,7 +124,14 @@ has-hole-or-hide-hole-ht cache binding-forms-absent-cache bind-names-cache pict-builder literals aliases collapsible-nts - ambiguity-cache binding-table enum-table)) + ambiguity-cache binding-table enum-table + language-name) + #:methods gen:custom-write + [(define (write-proc clang port mode) + (define lang-name (compiled-lang-language-name clang)) + (display "#" port))]) (define (compiled-lang-cclang x) (force (compiled-lang-delayed-cclang x))) (define (compiled-lang-across-ht x) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/matcher.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/matcher.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/matcher.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/matcher.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -90,7 +90,7 @@ ;; compile-language : language-pict-info[see pict.rkt] (listof nt) (listof (uf-set/c symbol?)) ;; (listof (list rewritten-pattern bspec)) -> compiled-lang -(define (compile-language pict-info lang binding-info aliases) +(define (compile-language pict-info lang binding-info aliases language-name) (let* ([clang-ht (make-hasheq)] [clang-list-ht (make-hasheq)] [clang-all-ht (make-hasheq)] @@ -113,7 +113,8 @@ collapsible-nts 'uninitialized-ambiguity-info `() ;; internal patterns don't need freshening - #f)] + #f + language-name)] [binders (map (match-lambda [`(,rewritten-pattern ,bspec) (bf-table-entry (compile-pattern clang rewritten-pattern #t) @@ -691,7 +692,9 @@ names (if (empty? (compiled-lang-binding-table clang)) equal? - (λ (lhs rhs) (α-equal? (compiled-lang-binding-table clang) match-pattern lhs rhs)))))) + (λ (lhs rhs) (α-equal? (compiled-lang-binding-table clang) + (compiled-lang-literals clang) + match-pattern lhs rhs)))))) (define (build-compiled-pattern proc names lang-α-equal?) (make-compiled-pattern @@ -737,9 +740,10 @@ (define clang-list-ht (compiled-lang-list-ht clang)) (define has-hole-or-hide-hole-ht (compiled-lang-has-hole-or-hide-hole-ht clang)) (define binding-forms (compiled-lang-binding-table clang)) + (define literals (compiled-lang-literals clang)) (define lang-α-equal? - (λ (lhs rhs) (α-equal? binding-forms match-pattern lhs rhs))) + (λ (lhs rhs) (α-equal? binding-forms literals match-pattern lhs rhs))) ;; Note that `bind-names?` means that identical names must match identical values, and ;; binding forms specify alpha-equivalence behavior in the user-defined language. @@ -774,7 +778,7 @@ [(equal? (procedure-arity compiled-pattern-without-freshening) 3) (lambda (exp hole-info nesting-depth) (compiled-pattern-without-freshening - (freshen binding-forms match-pattern exp) + (freshen binding-forms literals match-pattern exp) hole-info nesting-depth))] ;; only returns a boolean, no need to freshen [else compiled-pattern-without-freshening])) @@ -1834,7 +1838,7 @@ ;; remove-bindings/filter : (union #f (listof mtch)) (exp exp -> boolean) -> (union #f (listof mtch)) (define (remove-bindings/filter matches lang-α-equal?) (and matches - (let ([filtered (filter-multiples matches equal?)]) + (let ([filtered (filter-multiples matches lang-α-equal?)]) ;(printf ">> ~s\n=> ~s\n\n" matches filtered) (and (not (null? filtered)) (map (λ (match) @@ -2060,6 +2064,7 @@ (compile-language (-> any/c (listof nt?) (listof (list/c (not/c compiled-pattern?) bspec?)) (listof symbol?) + symbol? compiled-lang?))) (provide compiled-pattern? print-stats) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/pat-unify.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/pat-unify.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/pat-unify.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/pat-unify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -953,7 +953,8 @@ (error 'pat-unify.rkt "this shouldn't be called, but it was ~s" args))]) (compiled-lang #f #f #f #f #f #f #f #f #f #f #f #f '() '() (hash) (make-hash) '() - (lang-enumerators '() (make-hash) (delay '()) pat-unify.rkt::die)))) + (lang-enumerators '() (make-hash) (delay '()) pat-unify.rkt::die) + 'pat-unify.rkt::empty-lang))) (define unique-name-nums (make-parameter 0)) diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/reduction-semantics.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/reduction-semantics.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/reduction-semantics.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/reduction-semantics.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,10 +9,9 @@ "error.rkt" "judgment-form.rkt" "search.rkt" - "lang-struct.rkt" "enum.rkt" (only-in "binding-forms.rkt" - α-equal? safe-subst binding-forms-opened? make-immutable-α-hash) + safe-subst binding-forms-opened? make-immutable-α-hash) (only-in "binding-forms-definitions.rkt" shadow nothing bf-table-entry-pat bf-table-entry-bspec) racket/trace @@ -272,18 +271,15 @@ [(runtime-judgment-form? p) (define jf-res (parameterize ([include-jf-rulename tag-with-names?]) - (call-judgment-form (runtime-judgment-form-name p) - (runtime-judgment-form-proc p) - (runtime-judgment-form-mode p) - - ;; this list is because we expect one argument - ;; judgment forms, but the general API puts the - ;; arguments into a list. - (list v) - - #f - (runtime-judgment-form-cache p) - (runtime-judgment-form-lang p)))) + (call-runtime-judgment-form + p + + ;; this list is because we expect one argument + ;; judgment forms, but the general API puts the + ;; arguments into a list. + (list v) + + #f))) (apply append (for/list ([d-sub (in-list jf-res)]) @@ -2101,7 +2097,10 @@ (append (loop (car stx)) (loop (cdr stx)))] [else '()]))]) - (check-for-cycles stx #'(name ...) #'((r-rhs ...) ...) nt-identifiers) + (define-values (nt-hole-at-top nt-neighbors) + (build-graph-and-check-for-cycles stx #'(name ...) #'((r-rhs ...) ...) + nt-identifiers + aliases #f #f)) (define nt->hole (make-hash)) (for ([name (in-list all-names-stx-list)]) (hash-set! nt->hole (syntax-e name) 'unknown)) @@ -2141,7 +2140,8 @@ (list (list 'name rhs/lw ...) ...) (list (make-nt 'first-names (list (make-rhs `r-rhs) ...)) ...) binding-table - '(alias-names ...))))))))) + '(alias-names ...) + 'lang-id)))))))) ;; this keeps things from breaking at the top level if `errortrace` is on (define errortrace-safe-language-def @@ -2177,7 +2177,9 @@ (hash #,@(apply append (for/list ([(k v) (in-hash nt-identifiers)]) (with-syntax ([k k] [v v]) (list #''k #'#'v))))) - '#,nt->hole))) + '#,nt->hole + '#,nt-hole-at-top + '#,nt-neighbors))) #,errortrace-safe-language-def))))))))])) (define-for-syntax (nt-hole-lub l r) @@ -2206,7 +2208,13 @@ (unless (equal? (hash-ref nt->hole name) nt-hole-count) (hash-set! nt->hole name nt-hole-count) (set! changed? #t)))) - (when changed? (loop)))) + (when changed? (loop))) + ;; at the end of this process, any unknown + ;; non-terminals cannot produce a hole, + ;; so update the nt map to reflect that + (for ([nt (in-list (hash-keys nt->hole))]) + (when (equal? (hash-ref nt->hole nt) 'unknown) + (hash-set! nt->hole nt 0)))) (define-for-syntax (record-nts-disappeared-bindings lang nt-ids [prop `disappeared-binding]) (let loop ([nt-ids nt-ids] @@ -2323,7 +2331,7 @@ (unless (member the-name old-names) (raise-syntax-error #f - (format "cannot extend the `~a' non-terminal because `~s' does not define it" + (format "cannot extend the `~a` non-terminal because the language ~s does not define it" the-name (syntax->datum #'orig-lang)) stx rhs)) @@ -2360,7 +2368,7 @@ (unless (hash-ref nt->hole name #f) (hash-set! nt->hole name 'unknown)))) - (define extended-language-stx + (define-values (extended-language-stx nt-hole-at-top nt-neighbors) (with-syntax ([(((r-syncheck-expr r-rhs r-names r-names/ellipses) ...) ...) (for/list ([rhss (in-list rhsss)]) (for/list ([rhs (in-list rhss)]) @@ -2378,20 +2386,31 @@ (map syntax->list (syntax->list #'((r-rhs ...) ...))) rhsss nt->hole) + + (define-values (nt-hole-at-top nt-neighbors) + (build-graph-and-check-for-cycles + stx #'(names ...) #'((r-rhs ...) ...) nt-identifiers + aliases + (language-id-nt-hole-at-top #'orig-lang 'define-extended-language) + (language-id-nt-neighbors #'orig-lang 'define-extended-language))) - (with-syntax ([(primary-name ...) unaliased-new-names] - [((all-names ...) ...) namess] - [(alias-names ...) (hash-keys aliases)]) - (forward-errortrace-prop - stx - (syntax/loc stx - (do-extend-language - (begin r-syncheck-expr ... ... orig-lang) - (list (make-nt 'primary-name - (list (make-rhs `r-rhs) ...)) ...) - new-bindings-table - (list (list '(all-names ...) rhs/lw ...) ...) - '(alias-names ...))))))) + (values + (with-syntax ([(primary-name ...) unaliased-new-names] + [((all-names ...) ...) namess] + [(alias-names ...) (hash-keys aliases)]) + (forward-errortrace-prop + stx + (syntax/loc stx + (do-extend-language + (begin r-syncheck-expr ... ... orig-lang) + (list (make-nt 'primary-name + (list (make-rhs `r-rhs) ...)) ...) + new-bindings-table + (list (list '(all-names ...) rhs/lw ...) ...) + '(alias-names ...) + 'name)))) + nt-hole-at-top + nt-neighbors))) (forward-errortrace-prop stx (quasisyntax/loc stx @@ -2418,17 +2437,15 @@ (hash #,@(apply append (for/list ([(k v) (in-hash nt-identifiers)]) (with-syntax ([k k] [v v]) (list #''k #'#'v))))) - '#,nt->hole))))))))])) - -(begin-for-syntax - (define extend-nt-ellipses '(....))) -(define extend-nt-ellipses '(....)) + '#,nt->hole + '#,nt-hole-at-top + '#,nt-neighbors))))))))])) ;; do-extend-language : compiled-lang (listof (listof nt)) (listof (list compiled-pattern bspec)) ? ;; -> compiled-lang ;; note: the nts that come here are an abuse of the `nt' struct; they have ;; lists of symbols in the nt-name field. -(define (do-extend-language old-lang new-nts new-bindings-table new-pict-infos alias-names) +(define (do-extend-language old-lang new-nts new-bindings-table new-pict-infos alias-names lang-name) (unless (compiled-lang? old-lang) (error 'define-extended-language "expected a language as first argument, got ~e" old-lang)) @@ -2462,7 +2479,8 @@ (list (bf-table-entry-pat bf-table-entry) (bf-table-entry-bspec bf-table-entry))) new-bindings-table) - alias-names))) + alias-names + lang-name))) (define-syntax (define-union-language stx) (syntax-case stx () @@ -2594,9 +2612,22 @@ ;; make the hash be immutable (for/hash ([(k v) (in-hash aliases)]) (values k v)))) - + (define nt-identifiers (build-nt-identifiers-table #'name '())) - + + (define-values (nt-hole-at-top nt-neighbors) + (build-union-language-nt-neighbors/nt-hole-at-top + aliases + (for/list ([normalized-orig-lang (in-list normalized-orig-langs)]) + (list-ref normalized-orig-lang 0)) + (for/list ([normalized-orig-lang (in-list normalized-orig-langs)]) + (language-id-nt-hole-at-top (list-ref normalized-orig-lang 1) + 'define-union-language)) + (for/list ([normalized-orig-lang (in-list normalized-orig-langs)]) + (language-id-nt-neighbors (list-ref normalized-orig-lang 1) + 'define-union-language)))) + (check-for-cycles stx nt-identifiers nt-neighbors) + (with-syntax ([(all-names ...) (sort (hash-map names-table (λ (x y) x)) string<=? #:key symbol->string)] @@ -2605,7 +2636,8 @@ #`(begin (define define-language-name (union-language (list (list 'prefix old-lang) ...) - '#,aliases)) + '#,aliases + 'name)) (define-syntax name (make-set!-transformer (make-language-id @@ -2622,9 +2654,11 @@ (hash #,@(apply append (for/list ([(k v) (in-hash nt-identifiers)]) (with-syntax ([k k] [v v]) (list #''k #'#'v))))) - '#,nt->hole))))))])) + '#,nt->hole + '#,nt-hole-at-top + '#,nt-neighbors))))))])) -(define (union-language old-langs/prefixes aliases) +(define (union-language old-langs/prefixes aliases union-langs-name) (define (add-prefix prefix sym) (if prefix (string->symbol @@ -2671,8 +2705,8 @@ (compile-language #f (hash-map names-table (λ (name set) (make-nt name (set->list set)))) binding-table - (hash-keys aliases))) - + (hash-keys aliases) + union-langs-name)) (define (apply-reduction-relation* reductions exp #:all? [return-all? #f] @@ -2687,6 +2721,11 @@ (struct search-success ()) (struct search-failure (cutoff?)) +(define (reduction-relation/IO-jf-lang reductions) + (if (reduction-relation? reductions) + (reduction-relation-lang reductions) + (runtime-judgment-form-lang reductions))) + ;; traverse-reduction-graph : ;; reduction-relation term #:goal (-> any boolean?) #:steps number? ;; #:visit (-> any/c void?) -> (or/c search-success? search-failure?) @@ -2709,9 +2748,11 @@ ;; in commit ;; 152084d5ce6ef49df3ec25c18e40069950146041 ;; suggest that a hash works better than a trie. - [path (make-immutable-α-hash (compiled-lang-binding-table - (reduction-relation-lang reductions)) - match-pattern)] + [path + (let ([lang (reduction-relation/IO-jf-lang reductions)]) + (make-immutable-α-hash (compiled-lang-binding-table lang) + (compiled-lang-literals lang) + match-pattern))] [more-steps steps]) (if (and goal? (goal? term)) (return (search-success)) @@ -2759,13 +2800,23 @@ ;; nexts already has had the check that they are in the codomain (or domain ;; if there is one); here we remove the ones that are outside the codomain (define (remove-outside-domain reductions nexts) - (define dom-pat (reduction-relation-compiled-domain-pat reductions)) (cond - [dom-pat - (for/list ([next (in-list nexts)] - #:when (match-pattern? dom-pat next)) - next)] - [else nexts])) + [(reduction-relation? reductions) + (define dom-pat (reduction-relation-compiled-domain-pat reductions)) + (cond + [dom-pat + (for/list ([next (in-list nexts)] + #:when (match-pattern? dom-pat next)) + next)] + [else nexts])] + [else + (define input-pat + (runtime-judgment-form-compiled-input-contract-pat reductions)) + (if input-pat + (for/list ([next (in-list nexts)] + #:when (match-pattern? input-pat (list next))) + next) + nexts)])) ;; map/mt : (a -> b) (listof a) (listof b) -> (listof b) ;; map/mt is like map, except @@ -2781,9 +2832,14 @@ (cons this-one (loop (cdr l))) (loop (cdr l))))]))) -(define (reduction-relation->rule-names x) +(define (reduction-relation->rule-names x) (reverse (reduction-relation-rule-names x))) +(define (reduction-relation/IO-jf->rule-names x) + (cond + [(reduction-relation? x) (reduction-relation->rule-names x)] + [(IO-judgment-form? x) '(judgment-form->rule-names x)])) + ; ; @@ -3084,6 +3140,7 @@ (define lang (default-language)) (unless lang (error 'substitute "unable to determine the language to use")) (safe-subst (compiled-lang-binding-table lang) + (compiled-lang-literals lang) match-pattern (term any_body) (term variable) (term any_substitution)))]) @@ -3194,6 +3251,7 @@ (provide (rename-out [-reduction-relation reduction-relation]) ::= reduction-relation->rule-names + reduction-relation/IO-jf-lang extend-reduction-relation reduction-relation? union-reduction-relations diff -Nru racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt --- racket-6.12+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -18,6 +18,8 @@ language-id-nt-aliases language-id-nt-identifiers language-id-nt-hole-map + language-id-nt-hole-at-top + language-id-nt-neighbors pattern-symbols build-disappeared-uses @@ -41,7 +43,11 @@ ;; mode: (or/c #f (listof (or/c 'I 'O)) -- #f means the judgment form is actually a relation (define-struct judgment-form (name mode proc mk-proc lang lws rule-names gen-clauses mk-gen-clauses term-proc relation? - cache transformer) + cache runtime-judgment-form-id + original-contract-expression-id + compiled-input-contract-pat-id + compiled-output-contract-pat-id + transformer) #:property prop:procedure (struct-field-index transformer) #:transparent) @@ -59,9 +65,8 @@ (raise-syntax-error #f "not allowed in an expression context" stx))) (define-values (language-id make-language-id language-id? language-id-get language-id-set) - (make-struct-type 'language-id #f 5 0 #f '() #f 0)) + (make-struct-type 'language-id #f 7 0 #f '() #f 0)) -(define (language-id-nts stx id) (language-id-getter stx id 1)) (define (language-id-getter stx id n) (unless (identifier? stx) (raise-syntax-error id "expected an identifier defined by define-language" stx)) @@ -70,10 +75,19 @@ (language-id? (set!-transformer-procedure val))) (raise-syntax-error id "expected an identifier defined by define-language" stx)) (language-id-get (set!-transformer-procedure val) n))) +(define (language-id-nts stx id) (language-id-getter stx id 1)) (define (language-id-nt-aliases stx id) (language-id-getter stx id 2)) (define (language-id-nt-identifiers stx id) (language-id-getter stx id 3)) + +;; determine if an nt produces pluggable things (define (language-id-nt-hole-map stx id) (language-id-getter stx id 4)) +;; determine if an nt produces a hole without consuming any input +(define (language-id-nt-hole-at-top stx id) (language-id-getter stx id 5)) + +;; for cycle checking of extended languages +(define (language-id-nt-neighbors stx id) (language-id-getter stx id 6)) + (define pattern-symbols '(any number natural integer real string boolean variable variable-not-otherwise-mentioned hole symbol)) diff -Nru racket-6.12+ppa1/share/pkgs/redex-pict-lib/info.rkt racket-7.0+ppa1/share/pkgs/redex-pict-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/redex-pict-lib/info.rkt 2018-01-26 21:09:50.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-pict-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "draw-lib" "data-lib" "profile-lib" "redex-lib" "pict-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("redex-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\" using picts") (define pkg-authors (quote (robby bfetscher))) (define version "1.6"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "draw-lib" "data-lib" "profile-lib" "redex-lib" "pict-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("redex-lib"))) (define pkg-desc "implementation (no documentation) part of \"redex\" using picts") (define pkg-authors (quote (robby bfetscher))) (define version "1.6"))) diff -Nru racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/pict.rkt racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/pict.rkt --- racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/pict.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/pict.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -167,7 +167,8 @@ (provide with-unquote-rewriter with-compound-rewriter with-compound-rewriters - with-atomic-rewriter) + with-atomic-rewriter + with-atomic-rewriters) (provide/contract [set-arrow-pict! (-> symbol? (-> pict?) void?)] diff -Nru racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/private/core-layout.rkt racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/private/core-layout.rkt --- racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/private/core-layout.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/private/core-layout.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -53,6 +53,7 @@ with-compound-rewriter with-compound-rewriters with-atomic-rewriter + with-atomic-rewriters STIX? white-bracket-sizing apply-rewrites @@ -86,10 +87,13 @@ (basic-text "\u22ef" (default-style)) (basic-text "..." (default-style))))) (hole "[]")))) - - (define-syntax (with-atomic-rewriter stx) + + (define-syntax-rule + (with-atomic-rewriter name rewriter body) + (with-atomic-rewriters ([name rewriter]) body)) + (define-syntax (with-atomic-rewriters stx) (syntax-parse stx - [(_ name transformer e:expr) + [(_ ([name transformer] ...) e:expr) #:declare name (expr/c #'symbol? #:name "atomic-rewriter name") @@ -97,9 +101,8 @@ (expr/c #'(or/c (-> pict?) string?) #:name "atomic-rewriter rewrite") #`(parameterize ([atomic-rewrite-table - (cons (list name.c #,(wrap-expr/c #'(or/c string? (-> pict?)) - #'transformer.c)) - (atomic-rewrite-table))]) + (append (list (list name.c transformer.c) ...) + (atomic-rewrite-table))]) e)])) ;; compound-rewrite-table : (listof lw) -> (listof (union lw pict string)) diff -Nru racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/private/pict.rkt racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/private/pict.rkt --- racket-6.12+ppa1/share/pkgs/redex-pict-lib/redex/private/pict.rkt 2018-01-26 20:36:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/redex-pict-lib/redex/private/pict.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -225,8 +225,7 @@ (list lhs arrow (hbl-append rhs - (let ([sc (rule-pict-info->side-condition-pict rp max-w)]) - (inset sc (min 0 (- max-rhs (pict-width sc))) 0 0 0))) + (rule-pict-info->side-condition-pict rp max-w)) label)) (list (list lhs arrow rhs label) @@ -1102,7 +1101,7 @@ left-right/compact-side-conditions left-right*/compact-side-conditions))) - (define (handle-single-side-condition scs) + (define (handle-single-side-condition scs ignore-compact-side-conditions?) (define-values (fresh where/sc) (partition metafunc-extra-fresh? scs)) (define side-cond-picts (for/list ([thing (in-list where/sc)]) @@ -1124,7 +1123,7 @@ [vertical-side-conditions? ;; maximize line breaks: 0] - [compact-side-conditions? + [(and compact-side-conditions? (not ignore-compact-side-conditions?)) ;; maximize line break as needed: (apply max max-line-w/pre-sc (map pict-width side-cond-picts))] @@ -1149,7 +1148,8 @@ ((adjust 'side-condition-line) ((adjust 'side-condition) ((otherwise-make-pict))))) - (handle-single-side-condition (cdr cond-line)))) + (handle-single-side-condition (cdr cond-line) + #t))) (list rhs scs))) (define rhs (map car rhs+scs)) (define scs (map cadr rhs+scs)) @@ -1245,7 +1245,7 @@ (cond [(null? scs) #f] [(member 'or scs) #f] - [else (handle-single-side-condition scs)])])))) + [else (handle-single-side-condition scs #f)])])))) (define contractss (for/list ([lhs/contracts (in-list lhs/contractss)] [rhss (in-list rhsss)]) @@ -1688,7 +1688,8 @@ (define (term->pict/pretty-write lang term #:width [width (pretty-print-columns)]) (define-values (in out) (make-pipe)) (thread (λ () - (parameterize ([pretty-print-columns width]) + (parameterize ([pretty-print-columns width] + [term/pretty-write-doing-the-printing #t]) (pretty-write term out)) (close-output-port out))) (port-count-lines! in) diff -Nru racket-6.12+ppa1/share/pkgs/sandbox-lib/info.rkt racket-7.0+ppa1/share/pkgs/sandbox-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/sandbox-lib/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sandbox-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "errortrace-lib"))) (define pkg-desc "Library for sandboxing Racket programs") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "errortrace-lib"))) (define pkg-desc "Library for sandboxing Racket programs") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/sasl/info.rkt racket-7.0+ppa1/share/pkgs/sasl/info.rkt --- racket-6.12+ppa1/share/pkgs/sasl/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sasl/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.0") (define collection "sasl") (define deps (quote ("sasl-lib" "sasl-doc" "base"))) (define implies (quote ("sasl-lib" "sasl-doc"))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define version "1.0") (define collection "sasl") (define deps (quote ("sasl-lib" "sasl-doc" "base"))) (define implies (quote ("sasl-lib" "sasl-doc"))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/sasl-doc/info.rkt racket-7.0+ppa1/share/pkgs/sasl-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/sasl-doc/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sasl-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.0") (define collection "sasl") (define deps (quote ("base"))) (define build-deps (quote ("scribble-lib" "sasl-lib" "racket-doc"))) (define update-implies (quote ("sasl-lib"))) (define scribblings (quote (("sasl.scrbl" () (net-library))))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define version "1.0") (define collection "sasl") (define deps (quote ("base"))) (define build-deps (quote ("scribble-lib" "sasl-lib" "racket-doc"))) (define update-implies (quote ("sasl-lib"))) (define scribblings (quote (("sasl.scrbl" () (net-library))))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/sasl-lib/info.rkt racket-7.0+ppa1/share/pkgs/sasl-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/sasl-lib/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sasl-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define version "1.0") (define collection "sasl") (define deps (quote (("base" #:version "6.10")))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define version "1.0") (define collection "sasl") (define deps (quote (("base" #:version "6.10")))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/sasl-lib/private/crypto.rkt racket-7.0+ppa1/share/pkgs/sasl-lib/private/crypto.rkt --- racket-6.12+ppa1/share/pkgs/sasl-lib/private/crypto.rkt 2018-01-26 20:36:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sasl-lib/private/crypto.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,7 +5,8 @@ ffi/unsafe/define) (provide (protect-out (all-defined-out))) -(define-ffi-definer define-libcrypto libcrypto) +(define-ffi-definer define-libcrypto libcrypto + #:default-make-fail make-not-available) (define-cpointer-type _EVP_MD) (define-cpointer-type _EVP_MD_CTX) @@ -17,9 +18,14 @@ (define-libcrypto EVP_sha1 (_fun -> _EVP_MD)) (define-libcrypto EVP_sha256 (_fun -> _EVP_MD)) +;; In libcrypto 1.1, EVP_MD_CTX_{create,destroy} renamed to {new,free}. +(define-libcrypto EVP_MD_CTX_new (_fun -> _EVP_MD_CTX)) +(define-libcrypto EVP_MD_CTX_free (_fun _EVP_MD_CTX -> _void)) (define-libcrypto EVP_MD_CTX_destroy (_fun _EVP_MD_CTX -> _void) + #:fail (lambda () EVP_MD_CTX_free) #:wrap (deallocator)) (define-libcrypto EVP_MD_CTX_create (_fun -> _EVP_MD_CTX) + #:fail (lambda () EVP_MD_CTX_new) #:wrap (allocator EVP_MD_CTX_destroy)) (define-libcrypto EVP_MD_CTX_md (_fun _EVP_MD_CTX -> _EVP_MD)) @@ -48,8 +54,8 @@ (_int = (bytes-length data)) (md : _bytes = (make-bytes (EVP_MD_size alg))) (_pointer = #f) - -> (r : _int) - -> (and (positive? r) md))) + -> (r : _pointer) + -> (and r md))) (define-libcrypto PKCS5_PBKDF2_HMAC (_fun (digest password salt iters keylen) :: diff -Nru racket-6.12+ppa1/share/pkgs/scheme-lib/info.rkt racket-7.0+ppa1/share/pkgs/scheme-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/scheme-lib/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scheme-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Legacy (Scheme) libraries") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Legacy (Scheme) libraries") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/schemeunit/info.rkt racket-7.0+ppa1/share/pkgs/schemeunit/info.rkt --- racket-6.12+ppa1/share/pkgs/schemeunit/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/schemeunit/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "schemeunit") (define deps (quote ("base" "rackunit-lib" "rackunit-gui"))) (define pkg-desc "Legacy SchemeUnit testing framework") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "schemeunit") (define deps (quote ("base" "rackunit-lib" "rackunit-gui"))) (define pkg-desc "Legacy SchemeUnit testing framework") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble/info.rkt racket-7.0+ppa1/share/pkgs/scribble/info.rkt --- racket-6.12+ppa1/share/pkgs/scribble/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scribble-lib" "scribble-doc"))) (define implies (quote ("scribble-lib" "scribble-doc"))) (define pkg-desc "Racket documentatation and typesetting tool") (define pkg-authors (quote (mflatt eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scribble-lib" "scribble-doc"))) (define implies (quote ("scribble-lib" "scribble-doc"))) (define pkg-desc "Racket documentatation and typesetting tool") (define pkg-authors (quote (mflatt eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/info.rkt racket-7.0+ppa1/share/pkgs/scribble-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/scribble-doc/info.rkt 2018-01-26 21:09:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("racket-index" "mzscheme-doc" "net-doc" "scheme-lib" "draw-doc" "gui-doc" "slideshow-doc" "pict-doc" "typed-racket-doc" "at-exp-lib" "base" "compatibility-lib" "draw-lib" "pict-lib" "sandbox-lib" "slideshow-lib" "scribble-lib" "scribble-text-lib" "racket-doc"))) (define update-implies (quote ("scribble-lib"))) (define pkg-desc "documentation part of \"scribble\"") (define pkg-authors (quote (mflatt eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("racket-index" "mzscheme-doc" "net-doc" "scheme-lib" "draw-doc" "gui-doc" "slideshow-doc" "pict-doc" "typed-racket-doc" "at-exp-lib" "base" "compatibility-lib" "draw-lib" "pict-lib" "sandbox-lib" "slideshow-lib" "scribble-lib" "scribble-text-lib" "racket-doc"))) (define update-implies (quote ("scribble-lib"))) (define pkg-desc "documentation part of \"scribble\"") (define pkg-authors (quote (mflatt eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/acmart.scrbl racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/acmart.scrbl --- racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/acmart.scrbl 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/acmart.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -34,6 +34,9 @@ @defidform[sigplan] @defidform[sigchi] @defidform[sigchi-a] +@defidform[dtrap] +@defidform[tiot] +@defidform[tdsci] )]{ Enables the given document format. Use the format only on the same diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/base.scrbl racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/base.scrbl --- racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/base.scrbl 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/base.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -261,7 +261,8 @@ [#:sep sep (or/c block? content? #f) #f] [#:column-properties column-properties (listof any/c) '()] [#:row-properties row-properties (listof any/c) '()] - [#:cell-properties cell-properties (listof (listof any/c)) '()]) + [#:cell-properties cell-properties (listof (listof any/c)) '()] + [#:sep-properties sep-properties (or/c list? #f) #f]) table?]{ Creates a @tech{table} with the given @racket[cells] content, which is @@ -276,11 +277,11 @@ The @racket[style] argument is handled the same as @racket[para]. See @racket[table] for a list of recognized @tech{style names} and @tech{style properties}. -If @racket[sep] is not @racket[#f], it is inserted as a new column -between every column in the table; note that any -@racket[table-columns] or @racket[table-cells] property in -@racket[style] must take the added columns into account. Otherwise, -the default style places no space between table columns. When @racket[sep] +The default style places no space between table columns. If +@racket[sep] is not @racket[#f], it is inserted as a new column +between every column in the table; the new column's properties are the +same as the preceding column's, unless @racket[sep-properties] +provides a list of @tech{style properties} to use. When @racket[sep] would be placed before a @racket['cont], a @racket['cont] is inserted, instead. @@ -343,7 +344,10 @@ @racket[#:row-properties], and @racket[#:cell-properties] arguments.} #:changed "1.12" @elem{Changed @racket[sep] insertion before a - @racket['cont].}] + @racket['cont].} + #:changed "1.28" @elem{Added @racket[sep-properties] and made + the preceding column's properties used + consistently if not specified.}] Examples: @codeblock[#:keep-lang-line? #f]|{ diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/lp.scrbl racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/lp.scrbl --- racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/lp.scrbl 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/lp.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -69,6 +69,15 @@ effectively re-expanded). The @racketidfont{doc} submodule is declared with @racket[module*]. +To include a @racketmodname[scribble/lp2] document named + @filepath{file.scrbl} into another Scribble document, + import the @racketidfont{doc} submodule: + +@codeblock[#:keep-lang-line? #false]|{ + #lang scribble/manual + @include-section[(submod "file.scrbl" doc)] +}| + @history[#:added "1.8" #:changed "1.17" @elem{Declared the @racketidfont{doc} submodule with @racket[module*] instead of @racket[module].}] @@ -127,8 +136,8 @@ @defmodule[scribble/lp-include]{The @racketmodname[scribble/lp-include] library is normally used within a Scribble document---that is, a module that starts with something like -@racket[#, @hash-lang[] @racketmodname[scribble/base]] or @racket[#, @hash-lang[] -@racketmodname[scribble/manual]], instead of @racket[#, @hash-lang[] @racketmodname[racket]].} +@hash-lang[] @racketmodname[scribble/base] or @hash-lang[] @racketmodname[scribble/manual], +instead of @hash-lang[] @racketmodname[racket].} @defform[(lp-include filename)]{ Includes the source of @racket[filename] as the typeset version of the literate diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl --- racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -106,7 +106,7 @@ provided by @racket[context-expr]. The default @racket[context-expr] has the same lexical context as the first @racket[str-expr]. When @racket[line-number-expr] is true, line number is enabled starting -from @racket[line-number-expr], and @racket[line-number-sep] controls +from @racket[line-number-expr], and @racket[line-number-sep-expr] controls the separation (in spaces; defaults to 1) between the line numbers and code. diff -Nru racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/reader-internals.scrbl racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/reader-internals.scrbl --- racket-6.12+ppa1/share/pkgs/scribble-doc/scribblings/scribble/reader-internals.scrbl 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-doc/scribblings/scribble/reader-internals.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -163,7 +163,7 @@ In addition to configuring the reader for a module body, @racketmodname[at-exp] attaches a run-time configuration annotation to -the module, so that it if it used as the main module, the +the module, so that if it used as the main module, the @racket[current-read-interaction] parameter is adjusted to use the @seclink["reader"]{@"@"-reader} readtable extension. diff -Nru racket-6.12+ppa1/share/pkgs/scribble-html-lib/info.rkt racket-7.0+ppa1/share/pkgs/scribble-html-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/scribble-html-lib/info.rkt 2018-01-26 21:09:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-html-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "at-exp-lib" "scribble-text-lib"))) (define pkg-desc "Language for HTML with embedded Racket code") (define pkg-authors (quote (mflatt eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "at-exp-lib" "scribble-text-lib"))) (define pkg-desc "Language for HTML with embedded Racket code") (define pkg-authors (quote (mflatt eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/info.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/info.rkt 2018-01-26 21:09:56.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "scribble-text-lib" "scribble-html-lib" "planet-lib" "net-lib" "at-exp-lib" "draw-lib" "syntax-color-lib" "sandbox-lib" "typed-racket-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("scribble-html-lib"))) (define pkg-desc "implementation (no documentation) part of \"scribble\"") (define pkg-authors (quote (mflatt eli))) (define version "1.27"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "scribble-text-lib" "scribble-html-lib" "planet-lib" "net-lib" "at-exp-lib" "draw-lib" "syntax-color-lib" "sandbox-lib" "typed-racket-lib"))) (define build-deps (quote ("rackunit-lib"))) (define implies (quote ("scribble-html-lib"))) (define pkg-desc "implementation (no documentation) part of \"scribble\"") (define pkg-authors (quote (mflatt eli))) (define version "1.28"))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls 2018-07-27 22:12:02.000000000 +0000 @@ -37,7 +37,7 @@ %% Right brace \} Tilde \~} \NeedsTeXFormat{LaTeX2e} \ProvidesClass{acmart} -[2017/09/16 v1.48 Typesetting articles for the Association for +[2018/04/14 v1.53 Typesetting articles for the Association for Computing Machinery] \def\@classname{acmart} \InputIfFileExists{acmart-preload-hook.tex}{% @@ -199,22 +199,6 @@ \ClassInfo{\@classname}{Using fontsize \ACM@fontsize} \LoadClass[\ACM@fontsize, reqno]{amsart} \RequirePackage{microtype} -\ifcase\ACM@format@nr - \relax % manuscript - \or % acmsmall - \or % acmlarge - \or % acmtog - \RequirePackage{flushend} - \or % sigconf - \RequirePackage{flushend} - \or % siggraph - \RequirePackage{flushend} - \or % sigplan - \RequirePackage{flushend} - \or % sigchi - \RequirePackage{flushend} - \or % sigchi-a -\fi \RequirePackage{etoolbox} \RequirePackage{refcount} \RequirePackage{totpages} @@ -465,7 +449,6 @@ \let\citeANP\citeauthor \let\citeNN\citeyearpar \let\citeyearNP\citeyear - \let\citeyear\citeyearpar \let\citeNP\citealt \DeclareRobustCommand\citeA {\begingroup\NAT@swafalse @@ -477,7 +460,7 @@ \providecommand\citename[1]{#1}} \fi \newcommand\shortcite[2][]{% - \ifNAT@numbers\cite[#1]{#2}\else\citeyear[#1]{#2}\fi} + \ifNAT@numbers\cite[#1]{#2}\else\citeyearpar[#1]{#2}\fi} \def\bibliographystyle#1{% \ifx\@begindocumenthook\@undefined\else \expandafter\AtBeginDocument @@ -485,7 +468,8 @@ {\if@filesw \immediate\write\@auxout{\string\bibstyle{#1}}% \fi}} -\RequirePackage{graphicx, xcolor} +\RequirePackage{graphicx} +\RequirePackage[prologue]{xcolor} \definecolor[named]{ACMBlue}{cmyk}{1,0.1,0,0.1} \definecolor[named]{ACMYellow}{cmyk}{0,0.16,1,0} \definecolor[named]{ACMOrange}{cmyk}{0,0.42,1,0.01} @@ -499,8 +483,8 @@ \SetWatermarkFontSize{0.5in} \SetWatermarkColor[gray]{.9} \SetWatermarkText{\parbox{12em}{\centering - Unpublished working draft\\ - Not for distribution}} + Unpublished working draft.\\ + Not for distribution.}} \fi \RequirePackage{geometry} \ifcase\ACM@format@nr @@ -655,10 +639,16 @@ have the newtxmath package installed. Please upgrade your TeX}\@ACM@newfontsfalse} \if@ACM@newfonts -\RequirePackage[tt=false, type1=true]{libertine} +\ifxetex + \RequirePackage[tt=false]{libertine} +\else + \RequirePackage[tt=false, type1=true]{libertine} +\fi \RequirePackage[varqu]{zi4} \RequirePackage[libertine]{newtxmath} -\RequirePackage[T1]{fontenc} +\ifxetex\else + \RequirePackage[T1]{fontenc} +\fi \fi \let\liningnums\@undefined \AtEndPreamble{% @@ -793,6 +783,7 @@ \define@choicekey*+{ACM}{acmJournal}[\@journalCode\@journalCode@nr]{% CIE,% CSUR,% + DTRAP,% IMWUT,% JACM,% JDIQ,% @@ -800,6 +791,7 @@ JERIC,% JETC,% JOCCH,% + PACMCGIT,% PACMHCI,% PACMPL,% POMACS,% @@ -810,10 +802,12 @@ TALLIP,% TAP,% TCPS,% + TDSCI,% TEAC,% TECS,% THRI,% TIIS,% + TIOT,% TISSEC,% TIST,% TKDD,% @@ -853,6 +847,10 @@ \def\@journalName{ACM Computing Surveys}% \def\@journalNameShort{ACM Comput. Surv.}% \def\@permissionCodeOne{0360-0300}% +\or % DTRAP + \def\@journalName{Digital Threats: Research and Practice}% + \def\@journalNameShort{Digit. Threat. Res. Pract.}% + \def\@permissionCodeOne{2576-5337}% \or % IMWUT \def\@journalName{Proceedings of the ACM on Interactive, Mobile, Wearable and Ubiquitous Technologies}% @@ -883,6 +881,12 @@ \or % JOCCH \def\@journalName{ACM Journal on Computing and Cultural Heritage}% \def\@journalNameShort{ACM J. Comput. Cult. Herit.}% +\or % PACMCGIT + \def\@journalName{Proceedings of the ACM on Computer Graphics and Interactive Techniques}% + \def\@journalNameShort{Proc. ACM Comput. Graph. Interact. Tech.}% + \def\@permissionCodeOne{2577-6193}% + \@ACM@screentrue + \PackageInfo{\@classname}{Using screen mode due to \@journalCode}% \or % PACMHCI \def\@journalName{Proceedings of the ACM on Human-Computer Interaction}% \def\@journalNameShort{Proc. ACM Hum.-Comput. Interact.}% @@ -924,6 +928,10 @@ \def\@journalName{ACM Transactions on Applied Perception}% \or % TCPS \def\@journalName{ACM Transactions on Cyber-Physical Systems}% +\or % TDSCI + \def\@journalName{ACM Transactions on Data Science}% + \def\@journalNameShort{ACM Trans. Data Sci.}% + \def\@permissionCodeOne{2577-3224}% \or % TEAC \def\@journalName{ACM Transactions on Economics and Computation}% \or % TECS @@ -938,6 +946,10 @@ \def\@journalName{ACM Transactions on Interactive Intelligent Systems}% \def\@journalNameShort{ACM Trans. Interact. Intell. Syst.}% \def\@permissionCodeOne{2160-6455}% +\or % TIOT + \def\@journalName{ACM Transactions on Internet of Things}% + \def\@journalNameShort{ACM Trans. Internet Things}% + \def\@permissionCodeOne{2577-6207}% \or % TISSEC \def\@journalName{ACM Transactions on Information and System Security}% \def\@journalNameShort{ACM Trans. Info. Syst. Sec.}% @@ -1332,7 +1344,8 @@ \acm@copyrightinput\acm@copyrightmode]{none,% acmcopyright,acmlicensed,rightsretained,% usgov,usgovmixed,cagov,cagovmixed,licensedusgovmixed,% - licensedcagov,licensedcagovmixed,othergov,licensedothergov}{% + licensedcagov,licensedcagovmixed,othergov,licensedothergov,% + iw3c2w3,iw3c2w3g}{% \@printpermissiontrue \@printcopyrighttrue \@acmownedtrue @@ -1346,13 +1359,13 @@ \fi \ifnum\acm@copyrightmode=3\relax % rightsretained \@acmownedfalse - \acmPrice{}% + \AtBeginDocument{\acmPrice{}}% \fi \ifnum\acm@copyrightmode=4\relax % usgov \@printpermissiontrue \@printcopyrightfalse \@acmownedfalse - \acmPrice{}% + \AtBeginDocument{\acmPrice{}}% \fi \ifnum\acm@copyrightmode=6\relax % cagov \@acmownedfalse @@ -1371,6 +1384,14 @@ \fi \ifnum\acm@copyrightmode=12\relax % licensedothergov \@acmownedfalse + \fi + \ifnum\acm@copyrightmode=13\relax % iw3c2w3 + \@acmownedfalse + \AtBeginDocument{\acmPrice{}}% + \fi + \ifnum\acm@copyrightmode=14\relax % iw3c2w3g + \@acmownedfalse + \AtBeginDocument{\acmPrice{}}% \fi} \def\setcopyright#1{\setkeys{ACM@}{acmcopyrightmode=#1}} \setcopyright{acmcopyright} @@ -1380,7 +1401,7 @@ Association for Computing Machinery. \or % acmlicensed Copyright held by the owner/author(s). Publication rights licensed to - Association for Computing Machinery. + ACM\@. \or % rightsretained Copyright held by the owner/author(s). \or % usgov @@ -1392,18 +1413,24 @@ Association for Computing Machinery. \or %licensedusgovmixed Copyright held by the owner/author(s). Publication rights licensed to - Association for Computing Machinery. + ACM\@. \or % licensedcagov Crown in Right of Canada. Publication rights licensed to - Association for Computing Machinery. + ACM\@. \or %licensedcagovmixed Copyright held by the owner/author(s). Publication rights licensed to - Association for Computing Machinery. + ACM\@. \or % othergov Association for Computing Machinery. \or % licensedothergov Copyright held by the owner/author(s). Publication rights licensed to - Association for Computing Machinery. + ACM\@. + \or % ic2w3www + IW3C2 (International World Wide Web Conference Committee), published + under Creative Commons CC-BY~4.0 License. + \or % ic2w3wwwgoogle + IW3C2 (International World Wide Web Conference Committee), published + under Creative Commons CC-BY-NC-ND~4.0 License. \fi} \def\@formatdoi#1{\url{https://doi.org/#1}} \def\@copyrightpermission{% @@ -1517,7 +1544,18 @@ retains a nonexclusive, royalty-free right to publish or reproduce this article, or to allow others to do so, for Government purposes only. - \fi} + \or % iw3c2w3 + This paper is published under the Creative Commons Attribution~4.0 + International (CC-BY~4.0) license. Authors reserve their rights to + disseminate the work on their personal and corporate Web sites with + the appropriate attribution. + \or % iw3c2w3g + This paper is published under the Creative Commons + Attribution-NonCommercial-NoDerivs~4.0 International + (CC-BY-NC-ND~4.0) license. Authors reserve their rights to + disseminate the work on their personal and corporate Web sites with + the appropriate attribution. + \fi} \def\copyrightyear#1{\def\@copyrightyear{#1}} \copyrightyear{\@acmYear} \def\@teaserfigures{} @@ -1571,8 +1609,7 @@ \footnotetextcopyrightpermission{% \if@ACM@authordraft \raisebox{-2ex}[\z@][\z@]{\makebox[0pt][l]{\large\bfseries - Unpublished - working draft. Not for distribution}}% + Unpublished working draft. Not for distribution.}}% \color[gray]{0.9}% \fi \parindent\z@\parskip0.1\baselineskip @@ -1642,10 +1679,17 @@ \if@ACM@printacmref \@mkbibcitation \fi - \hypersetup{pdfauthor={\authors}, + \hypersetup{% + pdflang={English}, + pdfdisplaydoctitle, + pdfauthor={\authors}, pdftitle={\@title}, pdfsubject={\@concepts}, - pdfkeywords={\@keywords}}% + pdfkeywords={\@keywords}, + pdfcreator={LaTeX with acmart + \csname ver@acmart.cls\endcsname\space + and hyperref + \csname ver@hyperref.sty\endcsname}}% \@printendtopmatter \@afterindentfalse \@afterheading @@ -2119,7 +2163,7 @@ ACM, New York, NY, USA% \@article@string\unskip, \ref{TotPages}~\@pages@word. \fi - \@formatdoi{\@acmDOI} + \ifx\@acmDOI\@empty\else\@formatdoi{\@acmDOI}\fi \par\egroup} \def\@printendtopmatter{\par\bigskip} \def\@setthanks{\long\def\thanks##1{\par##1\@addpunct.}\thankses} @@ -2189,7 +2233,7 @@ \fancyhead[RO]{\@headfootfont\@acmArticle\if@ACM@printfolios:\thepage\fi}% \fancyhead[RE]{\@headfootfont\@shortauthors}% \fancyhead[LO]{\ACM@linecountL\@headfootfont\shorttitle}% - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \or % acmlarge \fancyhead[LE]{\ACM@linecountL\@headfootfont @@ -2197,7 +2241,7 @@ \fancyhead[LO]{\ACM@linecountL}% \fancyhead[RO]{\@headfootfont \shorttitle\quad\textbullet\quad\@acmArticle\if@ACM@printfolios:\thepage\fi}% - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \or % acmtog \fancyhead[LE]{\ACM@linecountL\@headfootfont @@ -2206,7 +2250,7 @@ \fancyhead[RE]{\ACM@linecountR}% \fancyhead[RO]{\@headfootfont \shorttitle\quad\textbullet\quad\@acmArticle\if@ACM@printfolios:\thepage\fi\ACM@linecountR}% - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \else % Proceedings \fancyfoot[C]{\if@ACM@printfolios\footnotesize\thepage\fi}% @@ -2275,7 +2319,7 @@ \fancyfoot[RO,LE]{\if@ACM@printfolios\small\thepage\fi}% \fancyfoot[RE,LO]{\footnotesize Manuscript submitted to ACM}% \or % acmsmall - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \fancyhead[LE]{\ACM@linecountL\@folioblob}% @@ -2283,7 +2327,7 @@ \fancyhead[RO]{\@folioblob}% \fancyheadoffset[RO,LE]{0.6\@folio@wd}% \or % acmlarge - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \fancyhead[RO]{\@folioblob}% @@ -2291,7 +2335,7 @@ \fancyhead[LO]{\ACM@linecountL}% \fancyheadoffset[RO,LE]{1.4\@folio@wd}% \or % acmtog - \fancyfoot[RO,LE]{\footnotesize \@journalName, Vol. \@acmVolume, No. + \fancyfoot[RO,LE]{\footnotesize \@journalNameShort, Vol. \@acmVolume, No. \@acmNumber, Article \@acmArticle. Publication date: \@acmPubDate.}% \fancyhead[L]{\ACM@linecountL}% @@ -2465,8 +2509,9 @@ \@ifundefined{proposition}{% \newtheorem{proposition}[theorem]{Proposition} }{} + \@ifundefined{lemma}{% \newtheorem{lemma}[theorem]{Lemma} - \@ifundefined{lemma}{}{} + }{} \@ifundefined{corollary}{% \newtheorem{corollary}[theorem]{Corollary} }{} diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.css racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.css --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.css 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.css 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,4 @@ -/* Support for styles in scribble/sigplan */ +/* Support for styles in scribble/acmart */ .SAuthorPlace, .SAuthorEmail, .SConferenceInfo, .SCopyrightYear, .SCopyrightData, diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart-load.tex racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart-load.tex --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart-load.tex 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart-load.tex 2018-07-27 22:12:02.000000000 +0000 @@ -3,6 +3,8 @@ % Avoid package option conflict \renewcommand\packageColor\relax \renewcommand\packageTocstyle\relax +\renewcommand\packageMathabx{\ifx\bigtimes\undefined \usepackage{mathabx} \else \relax \fi} +% Both 'mathabx' and 'newtxmath' (required by the 'acmart' class) define a '\bigtimes' command. \let\Footnote\undefined \let\captionwidth\undefined \renewcommand{\renewrmdefault}{} diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/lang.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/lang.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart/lang.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart/lang.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,7 +6,8 @@ scribble/latex-prefix racket/list "../private/defaults.rkt" - (for-syntax racket/base)) + (for-syntax racket/base + syntax/parse)) (provide (except-out (all-from-out scribble/doclang) #%module-begin) (all-from-out scribble/acmart) (all-from-out scribble/base) @@ -23,106 +24,98 @@ [authorversion? #f] [font-size #f]) (let loop ([stuff #'body]) - (syntax-case* stuff (manuscript acmsmall acmlarge acmtog sigconf siggraph sigplan sigchi sigchi-a - review screen natbib anonymous authorversion 9pt 10pt 11pt 12pt) - (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + (syntax-parse stuff + #:datum-literals (manuscript acmsmall acmlarge acmtog sigconf siggraph sigplan sigchi + sigchi-a dtrap pacmcgit tiot tdsci review screen natbib + anonymous authorversion 9pt 10pt 11pt 12pt) + + ;; Skip intraline whitespace to find options: [(ws . body) - ;; Skip intraline whitespace to find options: - (and (string? (syntax-e #'ws)) - (regexp-match? #rx"^ *$" (syntax-e #'ws))) + #:when (and (string? (syntax-e #'ws)) + (regexp-match? #rx"^ *$" (syntax-e #'ws))) (loop #'body)] - ; boolean options - [((review #t) . body) - (set! review? "review=true") - (loop #'body)] - [((review #f) . body) - (set! review? "review=false") - (loop #'body)] - [(review . body) - (set! review? "review=true") - (loop #'body)] - [((screen #t) . body) - (set! screen? "screen=true") - (loop #'body)] - [((screen #f) . body) - (set! screen? "screen=false") - (loop #'body)] - [(screen . body) - (set! screen? "screen=true") - (loop #'body)] - [((natbib #t) . body) - (set! natbib? "natbib=true") - (loop #'body)] - [((natbib #f) . body) - (set! natbib? "natbib=false") - (loop #'body)] - [(natbib . body) - (set! natbib? "natbib=true") - (loop #'body)] + ; boolean options + [((review #t) . body) + (set! review? "review=true") + (loop #'body)] + [((review #f) . body) + (set! review? "review=false") + (loop #'body)] + [(review . body) + (set! review? "review=true") + (loop #'body)] + [((screen #t) . body) + (set! screen? "screen=true") + (loop #'body)] + [((screen #f) . body) + (set! screen? "screen=false") + (loop #'body)] + [(screen . body) + (set! screen? "screen=true") + (loop #'body)] + [((natbib #t) . body) + (set! natbib? "natbib=true") + (loop #'body)] + [((natbib #f) . body) + (set! natbib? "natbib=false") + (loop #'body)] + [(natbib . body) + (set! natbib? "natbib=true") + (loop #'body)] - [((anonymous #t) . body) - (set! anonymous? "anonymous=true") - (loop #'body)] - [((anonymous #f) . body) - (set! anonymous? "anonymous=false") - (loop #'body)] - [(anonymous . body) - (set! anonymous? "anonymous=true") - (loop #'body)] - [((authorversion #t) . body) - (set! authorversion? "authorversion=true") - (loop #'body)] - [((authorversion #f) . body) - (set! authorversion? "authorversion=false") - (loop #'body)] - [(authorversion . body) - (set! authorversion? "authorversion=true") - (loop #'body)] - [(9pt . body) - (set! font-size "9pt") - (loop #'body)] - [(10pt . body) - (set! font-size "10pt") - (loop #'body)] - [(11pt . body) - (set! font-size "11pt") - (loop #'body)] - [(12pt . body) - (set! font-size "12pt") - (loop #'body)] - - - ; format options - [(manuscript . body) - (set! format? "manuscript") + [((anonymous #t) . body) + (set! anonymous? "anonymous=true") + (loop #'body)] + [((anonymous #f) . body) + (set! anonymous? "anonymous=false") (loop #'body)] - [(acmsmall . body) - (set! format? "acmsmall") + [(anonymous . body) + (set! anonymous? "anonymous=true") (loop #'body)] - [(acmlarge . body) - (set! format? "acmlarge") + [((authorversion #t) . body) + (set! authorversion? "authorversion=true") (loop #'body)] - [(acmtog . body) - (set! format? "acmtog") + [((authorversion #f) . body) + (set! authorversion? "authorversion=false") (loop #'body)] - [(sigconf . body) - (set! format? "sigconf") + [(authorversion . body) + (set! authorversion? "authorversion=true") (loop #'body)] - [(sigconf . body) - (set! format? "siggraph") + [(9pt . body) + (set! font-size "9pt") (loop #'body)] - [(sigplan . body) - (set! format? "sigplan") + [(10pt . body) + (set! font-size "10pt") (loop #'body)] - [(sigchi . body) - (set! format? "sigchi") + [(11pt . body) + (set! font-size "11pt") (loop #'body)] - [(sigchi-a . body) - (set! format? "sigchi-a") + [(12pt . body) + (set! font-size "12pt") + (loop #'body)] + + + ; format options + [((~and fmt + (~or manuscript + acmsmall + acmlarge + acmtog + sigconf + siggraph + sigplan + sigchi + sigchi-a + dtrap + pacmcgit + tiot + tdsci)) + . body) + (set! format? (symbol->string (syntax->datum #'fmt))) (loop #'body)] - - [body + + [body #`(#%module-begin id (post-process #,review? #,screen? #,natbib? #,anonymous? #,authorversion? #,font-size #,format?) () . body)])))])) (define ((post-process . opts) doc) @@ -139,7 +132,7 @@ (scribble-file "acmart/style.tex") (list (scribble-file "acmart/acmart.cls")) #f - #:replacements (hash "scribble-load-replace.tex" (scribble-file "acmart/acmart-load.tex")))))) + #:replacements (hash "scribble-load-replace.tex" (scribble-file "acmart/acmart-load.tex")))))) (define (add-acmart-styles doc) (struct-copy part doc diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/acmart.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/acmart.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,6 +9,7 @@ scribble/html-properties scribble/latex-properties scribble/private/tag + scribble/private/lang-parameters (for-syntax racket/base)) (struct affiliation (position institution street-address city state postcode country) @@ -86,7 +87,8 @@ (->* () () #:rest (listof pre-content?) any/c)]) (provide - invisible-element-to-collect-for-acmart-extras) + invisible-element-to-collect-for-acmart-extras + include-abstract) (define-syntax-rule (defopts name ...) (begin (define-syntax (name stx) @@ -131,7 +133,8 @@ ...)) ; format options -(defopts manuscript acmsmall acmlarge acmtog sigconf siggraph sigplan sigchi sigchi-a) +(defopts manuscript acmsmall acmlarge acmtog sigconf siggraph sigplan sigchi sigchi-a + dtrap pacmcgit tiot tdsci) ; boolean options (defopts review screen natbib anonymous authorversion 9pt 10pt 11pt 12pt) @@ -159,6 +162,20 @@ abstract-style (decode-flow strs))) +(define (extract-abstract p) + (unless (part? p) + (error 'include-abstract "doc binding is not a part: ~e" p)) + (unless (null? (part-parts p)) + (error 'include-abstract "abstract part has sub-parts: ~e" (part-parts p))) + (when (part-title-content p) + (error 'include-abstract "abstract part has title content: ~e" (part-title-content p))) + (part-blocks p)) + +(define-syntax-rule (include-abstract mp) + (begin + (require (only-in mp [doc abstract-doc])) + (make-nested-flow abstract-style (extract-abstract abstract-doc)))) + (define (acmConference name date venue) (make-paragraph (make-style 'pretitle '()) (make-multiarg-element (make-style "acmConference" multicommand-props) @@ -392,3 +409,7 @@ ; FIXME: theorem styles +(default-figure-label-text (make-element 'sf "Fig.")) +(default-figure-label-sep ". ") +(default-figure-caption-style 'sf) +(default-figure-counter-style 'sf) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/base.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/base.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/base.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/base.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -329,7 +329,8 @@ #:sep (or/c content? block? #f) #:column-properties (listof any/c) #:row-properties (listof any/c) - #:cell-properties (listof (listof any/c))) + #:cell-properties (listof (listof any/c)) + #:sep-properties (or/c list? #f)) table?)]) (define (convert-block-style style) @@ -352,6 +353,7 @@ (define (tabular #:style [style #f] #:sep [sep #f] + #:sep-properties [sep-props #f] #:column-properties [column-properties null] #:row-properties [row-properties null] #:cell-properties [cell-properties null] @@ -426,7 +428,7 @@ [(null? column-properties) (if (or (zero? n) (not sep)) (cons prev (loop null (add1 n) prev)) - (list* prev prev (loop null (+ n 2) prev)))] + (list* (or sep-props prev) prev (loop null (+ n 2) prev)))] [else (define (to-list v) (if (list? v) v (list v))) (define props (to-list (car column-properties))) @@ -437,7 +439,7 @@ props)) (if (or (zero? n) (not sep)) (cons props rest) - (list* null props rest))]))) + (list* (or sep-props prev) props rest))]))) (define full-column-properties (make-full-column-properties column-properties)) (define (make-full-cell-properties cell-properties) @@ -560,7 +562,7 @@ #:rest (listof pre-content?) element?)] [secref (->* (string?) - (#:doc module-path? + (#:doc (or/c #f module-path?) #:tag-prefixes (or/c #f (listof string?)) #:underline? any/c #:link-render-style (or/c #f link-render-style?)) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1317,17 +1317,11 @@ (if (path? p) (url->string* (path->url (path->complete-path p))) p))]) - `((,(if svg? 'object 'img) - ([,(if svg? 'data 'src) ,srcref] + `((img + ([src ,srcref] [alt ,(content->string (element-content e))] - ,@(if svg? - `([type "image/svg+xml"]) - null) ,@sz - ,@(attribs)) - ,@(if svg? - `((param ([name "src"] [value ,srcref]))) - null)))))] + ,@(attribs))))))] [(element-style-property-matching e script-property?) => (lambda (v) @@ -1496,8 +1490,8 @@ (list (add-padding cvt - `(object - ([data ,(install-file "pict.svg" bstr)] + `(img + ([src ,(install-file "pict.svg" bstr)] [type "image/svg+xml"]))))))] [else #f]))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1112,6 +1112,16 @@ [(#\u039B) "$\\Lambda$"] [(#\u03BC) "$\\mu$"] [(#\u03C0) "$\\pi$"] + [(#\₀) "$_0$"] + [(#\₁) "$_1$"] + [(#\₂) "$_2$"] + [(#\₃) "$_3$"] + [(#\₄) "$_4$"] + [(#\₅) "$_5$"] + [(#\₆) "$_6$"] + [(#\₇) "$_7$"] + [(#\₈) "$_8$"] + [(#\₉) "$_9$"] [(#\‘) "{`}"] [(#\’) "{'}"] [(#\“) "{``}"] diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/lncs/lang.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/lncs/lang.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/lncs/lang.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/lncs/lang.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -63,8 +63,8 @@ (unless (or (not (path? cls-file)) (file-exists? cls-file)) (log-error (format "File not found: ~a" cls-file)) - (define site "ftp.springer.de") - (define path "pub/tex/latex/llncs/latex2e") + (define site "ftp.springernature.com") + (define path "cs-proceeding/llncs") (define file "llncs2e.zip") (unless (directory-exists? (find-system-path 'addon-dir)) (make-directory (find-system-path 'addon-dir))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/lncs/lncs.css racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/lncs/lncs.css --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/lncs/lncs.css 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/lncs/lncs.css 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +/* Support for styles in scribble/lncs */ + +.SAuthorPlace, .SAuthorEmail, +.SConferenceInfo, .SCopyrightYear, .SCopyrightData, +.Sdoi, .SPexclusivelicense, +.SCategory, .SCategoryPlus, .STerms, .SKeywords { + display: none; +} + +.SSubtitle { + display: block; + font-size: smaller; +} diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/lang-parameters.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/lang-parameters.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/lang-parameters.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/lang-parameters.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,19 @@ +#lang racket/base + +(provide (all-defined-out)) + +;; Some latex formats have different requirements on how +;; figures, citations, etc. are displayed. This allows different +;; scribble langs to handle them. + +;; `Figure` string that appears in front of a figure caption +(define default-figure-label-text (make-parameter "Figure")) + +;; Seperator string between figure counter and caption +(define default-figure-label-sep (make-parameter ": ")) + +;; Style for the figure caption +(define default-figure-caption-style (make-parameter #f)) + +;; Style for the number in the figure counter +(define default-figure-counter-style (make-parameter #f)) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/manual-proc.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/manual-proc.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/manual-proc.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/manual-proc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1039,12 +1039,13 @@ #'(with-togetherable-racket-variables () () - (*defthing kind.kind - lt.expr - (list (or id-expr (quote-syntax/loc id))) (list 'id) #f - (list (racketblock0 result)) - (lambda () (list desc ...)) - (list (result-value value.value))))])) + (let ([id-val id-expr]) + (*defthing kind.kind + lt.expr + (list (or id-val (quote-syntax/loc id))) (list (if (identifier? id-val) (syntax-e id-val) 'id)) #f + (list (racketblock0 result)) + (lambda () (list desc ...)) + (list (result-value value.value)))))])) (define-syntax (defthing* stx) (syntax-parse stx diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/manual-scheme.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/manual-scheme.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/private/manual-scheme.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/private/manual-scheme.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -247,12 +247,16 @@ (define-for-syntax (strip-ellipsis-context a) (define a-ellipsis (datum->syntax a '...)) + (define a-ellipsis+ (datum->syntax a '...+)) (let loop ([a a]) (cond [(identifier? a) - (if (free-identifier=? a a-ellipsis #f) - (datum->syntax #f '... a a) - a)] + (cond + [(free-identifier=? a a-ellipsis #f) + (datum->syntax #f '... a a)] + [(free-identifier=? a a-ellipsis+ #f) + (datum->syntax #f '...+ a a)] + [else a])] [(syntax? a) (datum->syntax a (loop (syntax-e a)) a a)] [(pair? a) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex --- racket-6.12+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex 2018-07-27 22:12:02.000000000 +0000 @@ -340,10 +340,10 @@ \newcommand{\Ssubsubsubsubsectionstar}[1]{\Ssubsubsubsectionstar{#1}} % "starx" means unnumbered but in ToC: -\newcommand{\Spartstarx}[2]{\Spartstar{#2}\addcontentsline{toc}{part}{#1}} -\newcommand{\Ssectionstarx}[2]{\Ssectionstar{#2}\addcontentsline{toc}{section}{#1}} -\newcommand{\Ssubsectionstarx}[2]{\Ssubsectionstar{#2}\addcontentsline{toc}{subsection}{#1}} -\newcommand{\Ssubsubsectionstarx}[2]{\Ssubsubsectionstar{#2}\addcontentsline{toc}{subsubsection}{#1}} +\newcommand{\Spartstarx}[2]{\Spartstar{#2}\phantomsection\addcontentsline{toc}{part}{#1}} +\newcommand{\Ssectionstarx}[2]{\Ssectionstar{#2}\phantomsection\addcontentsline{toc}{section}{#1}} +\newcommand{\Ssubsectionstarx}[2]{\Ssubsectionstar{#2}\phantomsection\addcontentsline{toc}{subsection}{#1}} +\newcommand{\Ssubsubsectionstarx}[2]{\Ssubsubsectionstar{#2}\phantomsection\addcontentsline{toc}{subsubsection}{#1}} \newcommand{\Ssubsubsubsectionstarx}[2]{\Ssubsubsubsectionstar{#2}} \newcommand{\Ssubsubsubsubsectionstarx}[2]{\Ssubsubsubsubsectionstar{#2}} diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/figure.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/figure.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/figure.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/figure.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,7 +6,8 @@ scribble/html-properties scribble/latex-properties setup/main-collects - "private/counter.rkt") + "private/counter.rkt" + scribble/private/lang-parameters) (provide figure figure* @@ -75,11 +76,9 @@ figure-style-extras)) c)) -(define default-label-sep ": ") - (define (figure tag caption #:style [style center-figure-style] - #:label-sep [label-sep default-label-sep] + #:label-sep [label-sep (default-figure-label-sep)] #:label-style [label-style #f] #:continue? [continue? #f] . content) @@ -87,7 +86,7 @@ (define (figure-here tag caption #:style [style center-figure-style] - #:label-sep [label-sep default-label-sep] + #:label-sep [label-sep (default-figure-label-sep)] #:label-style [label-style #f] #:continue? [continue? #f] . content) @@ -95,14 +94,14 @@ (define (figure* tag caption #:style [style center-figure-style] - #:label-sep [label-sep default-label-sep] + #:label-sep [label-sep (default-figure-label-sep)] #:label-style [label-style #f] #:continue? [continue? #f] . content) (figure-helper figuremulti-style style label-sep label-style tag caption content continue?)) (define (figure** tag caption #:style [style center-figure-style] - #:label-sep [label-sep default-label-sep] + #:label-sep [label-sep (default-figure-label-sep)] #:label-style [label-style #f] #:continue? [continue? #f] . content) @@ -124,7 +123,7 @@ #:label-sep label-sep #:label-style label-style #:continue? continue?) - caption))))))) + (make-element (default-figure-caption-style) caption)))))))) (define figures (new-counter "figure" #:target-wrap make-figure-target @@ -134,7 +133,7 @@ #:label-sep [label-sep ": "] #:label-style [label-style #f]) (counter-target figures tag - "Figure" + (default-figure-label-text) #:label-suffix (list (if continue? " (continued)" "") label-sep) #:label-style label-style #:target-style figure-target-style diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/footnote.css racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/footnote.css --- racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/footnote.css 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/footnote.css 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,8 @@ position: relative; float: right; left: 2em; - height: 0em; + height: auto; + clear: right; width: 13em; margin: 0em -13em 0em 0em; } diff -Nru racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/private/counter.rkt racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/private/counter.rkt --- racket-6.12+ppa1/share/pkgs/scribble-lib/scriblib/private/counter.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-lib/scriblib/private/counter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require scribble/core - scribble/decode) + scribble/decode + scribble/private/lang-parameters) (provide new-counter counter-target @@ -38,7 +39,8 @@ (let ([n (resolve-get part ri (tag->counter-tag counter tag "value"))]) (cons (make-element label-style - (let ([l (cons (format "~a" n) (decode-content (list label-suffix)))]) + (let ([l (cons (make-element (default-figure-counter-style) (format "~a" n)) + (decode-content (list label-suffix)))]) (if label (list* label 'nbsp l) l))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-text-lib/info.rkt racket-7.0+ppa1/share/pkgs/scribble-text-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/scribble-text-lib/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-text-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "at-exp-lib"))) (define pkg-desc "Language for text with embedded Racket code") (define pkg-authors (quote (mflatt eli))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "at-exp-lib"))) (define pkg-desc "Language for text with embedded Racket code") (define pkg-authors (quote (mflatt eli))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/scribble-text-lib/scribble/text/output.rkt racket-7.0+ppa1/share/pkgs/scribble-text-lib/scribble/text/output.rkt --- racket-6.12+ppa1/share/pkgs/scribble-text-lib/scribble/text/output.rkt 2018-01-26 20:34:48.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/scribble-text-lib/scribble/text/output.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,6 +3,7 @@ racket/contract/base) (provide + special? outputable/c (contract-out [output (->* (outputable/c) (output-port?) void?)])) diff -Nru racket-6.12+ppa1/share/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt racket-7.0+ppa1/share/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt --- racket-6.12+ppa1/share/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt 2018-01-26 20:36:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -95,14 +95,14 @@ [make-ID/mode (format-id #'_ID "make-~a/mode" id)] - [serialize-inplace (and (attribute serialize-inplace-kw) #t)] - [deserialize-inplace (and (attribute deserialize-inplace-kw) #t)]) + [serialize-inplace (and (attribute serialize-inplace-kw) (not (eq? 'cs (system-type 'gc))))] + [deserialize-inplace (and (attribute deserialize-inplace-kw) (not (eq? 'cs (system-type 'gc))))]) (quasisyntax/loc stx (begin #,@(if (eq? 'top-level (syntax-local-context)) ;; Forward reference: - `((define-syntaxes (all-serializable) (values))) + `((define-syntaxes (copy-any-non-pointers-for-ID? all-serializable) (values))) null) ;; the wrapped cstruct @@ -114,13 +114,13 @@ (lambda (s) (force all-serializable) (hash-set! cpointer-mapping s s) - (define inplace-bs (make-sized-byte-string s (ctype-sizeof _ID))) (define bs (if serialize-inplace - inplace-bs - (let ([mem (malloc _ID 'atomic)]) - (memcpy mem inplace-bs 1 _ID) - (make-sized-byte-string mem (ctype-sizeof _ID))))) + (make-sized-byte-string s (ctype-sizeof _ID)) + (let ([mem (make-bytes (ctype-sizeof _ID))]) + (when (force copy-any-non-pointers-for-ID?) + (memcpy mem s 1 _ID)) + mem))) (vector bs (serialize-cstruct-pointers s))) (quote-syntax deser-ID) #t @@ -134,13 +134,17 @@ (malloc-mode (ctype-sizeof _ID)) (malloc _ID malloc-mode))) + ;; must be delayed to handle cyclic structs + (define copy-any-non-pointers-for-ID? + (delay (copy-any-non-pointers? _ID))) + ;; deserialization proc #,@(if (eq? (syntax-local-context) 'module) #`((runtime-require (submod "." deserialize-info)) (module+ deserialize-info (provide deser-ID other-vers-deser-ID ...))) null) - (define deser-chain-ID (id->deserialize-chain-info _ID _ID-pointer deserialize-inplace malloc-ID)) + (define deser-chain-ID (id->deserialize-chain-info _ID _ID-pointer deserialize-inplace malloc-ID copy-any-non-pointers-for-ID?)) (define deser-ID (deserialize-chain-info->deserialize-info deser-chain-ID)) (define other-vers-deser-ID (chain+converters->deserialize-info other-vers-deser-chain other-vers-convert @@ -184,7 +188,6 @@ (array-base-type (array-type ((ctype-c->scheme ct) #f))) ct)) - (define (ctype-layout-base-type v) (if (vector? v) (ctype-layout-base-type (vector-ref v 0)) @@ -192,14 +195,15 @@ (struct chain-deserialize-info (make cycle-make)) -(define (id->deserialize-chain-info _ID _ID-pointer deserialize-inplace malloc-ID) +(define (id->deserialize-chain-info _ID _ID-pointer deserialize-inplace malloc-ID copy-any-non-pointers-for-ID?) (chain-deserialize-info (lambda (bs ptrs) (define s (if deserialize-inplace (cast bs _bytes _ID-pointer) (let ([mem (malloc-ID)]) - (memcpy mem bs 1 _ID) + (when (force copy-any-non-pointers-for-ID?) + (memcpy mem bs 1 _ID)) (cast mem _pointer _ID-pointer)))) (deserialize-cstruct-pointers s ptrs) s) @@ -232,6 +236,14 @@ (define ptr-types '(bytes string/ucs-4 string/utf-16 pointer gcpointer)) +(define (copy-any-non-pointers? _ID) + (for/or ([t (in-list (ctype->layout _ID))]) + (let ([base (ctype-layout-base-type t)]) + (let loop ([base base]) + (cond + [(list? base) (ormap loop base)] + [(vector? base) (loop (vector-ref base 0))] + [else (not (memq base ptr-types))]))))) (define (serialize-cstruct-pointers o) (define who 'serialize-cstruct-pointers) diff -Nru racket-6.12+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt racket-7.0+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "serialization support for C structs") (define pkg-authors (quote ("tobias.hammer@dlr.de"))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "serialization support for C structs") (define pkg-authors (quote ("tobias.hammer@dlr.de"))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/sgl/info.rkt racket-7.0+ppa1/share/pkgs/sgl/info.rkt --- racket-6.12+ppa1/share/pkgs/sgl/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/sgl/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "sgl") (define compile-omit-paths (quote ("examples"))) (define test-omit-paths (quote ("examples"))) (define scribblings (quote (("scribblings/sgl.scrbl" (multi-page) (gui-library))))) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "gui-lib"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "Legacy OpenGL library") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "sgl") (define compile-omit-paths (quote ("examples"))) (define test-omit-paths (quote ("examples"))) (define scribblings (quote (("scribblings/sgl.scrbl" (multi-page) (gui-library))))) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "gui-lib"))) (define build-deps (quote ("draw-doc" "gui-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "Legacy OpenGL library") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/shell-completion/info.rkt racket-7.0+ppa1/share/pkgs/shell-completion/info.rkt --- racket-6.12+ppa1/share/pkgs/shell-completion/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/shell-completion/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "shell-completion") (define deps (quote ("base"))) (define pkg-desc "Completion scribpts for bash and zsh") (define pkg-authors (quote (samth sstrickl stamourv))) (define test-responsibles (quote (("racket-completion.zsh" eli)))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "shell-completion") (define deps (quote ("base"))) (define pkg-desc "Completion scribpts for bash and zsh") (define pkg-authors (quote (samth sstrickl stamourv))) (define test-responsibles (quote (("racket-completion.zsh" eli)))))) diff -Nru racket-6.12+ppa1/share/pkgs/slatex/info.rkt racket-7.0+ppa1/share/pkgs/slatex/info.rkt --- racket-6.12+ppa1/share/pkgs/slatex/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slatex/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "slatex") (define scribblings (quote (("slatex-wrap.scrbl" () (tool-library))))) (define mzscheme-launcher-names (quote ("SLaTeX" "PDF SLaTeX"))) (define mzscheme-launcher-libraries (quote ("slatex-launcher.rkt" "pdf-slatex-launcher.rkt"))) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("racket-index" "eli-tester" "racket-doc" "scribble-lib"))) (define copy-shared-files (quote ("slatex.sty" "slatex.py"))) (define pkg-desc "SLaTeX (Scheme in LaTeX)") (define pkg-authors (quote (sstrickl))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "slatex") (define scribblings (quote (("slatex-wrap.scrbl" () (tool-library))))) (define mzscheme-launcher-names (quote ("SLaTeX" "PDF SLaTeX"))) (define mzscheme-launcher-libraries (quote ("slatex-launcher.rkt" "pdf-slatex-launcher.rkt"))) (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("racket-index" "eli-tester" "racket-doc" "scribble-lib"))) (define copy-shared-files (quote ("slatex.sty" "slatex.py"))) (define pkg-desc "SLaTeX (Scheme in LaTeX)") (define pkg-authors (quote (sstrickl))))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow/info.rkt racket-7.0+ppa1/share/pkgs/slideshow/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("slideshow-lib" "slideshow-exe" "slideshow-plugin" "slideshow-doc"))) (define implies (quote ("slideshow-lib" "slideshow-exe" "slideshow-plugin" "slideshow-doc"))) (define pkg-desc "Slide-presentation tool") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("slideshow-lib" "slideshow-exe" "slideshow-plugin" "slideshow-doc"))) (define implies (quote ("slideshow-lib" "slideshow-exe" "slideshow-plugin" "slideshow-doc"))) (define pkg-desc "Slide-presentation tool") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow-doc/info.rkt racket-7.0+ppa1/share/pkgs/slideshow-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow-doc/info.rkt 2018-01-26 21:09:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("scheme-lib" "draw-doc" "gui-doc" "pict-doc" "scribble-doc" "web-server-doc" "base" "gui-lib" "pict-lib" "scribble-lib" "slideshow-lib" "racket-doc"))) (define update-implies (quote ("slideshow-lib"))) (define pkg-desc "documentation part of \"slideshow\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("scheme-lib" "draw-doc" "gui-doc" "pict-doc" "scribble-doc" "web-server-doc" "base" "gui-lib" "pict-lib" "scribble-lib" "slideshow-lib" "racket-doc"))) (define update-implies (quote ("slideshow-lib"))) (define pkg-desc "documentation part of \"slideshow\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow-exe/info.rkt racket-7.0+ppa1/share/pkgs/slideshow-exe/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow-exe/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow-exe/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "gui-lib" "pict-lib" "slideshow-lib"))) (define implies (quote ("slideshow-lib"))) (define pkg-desc "executables for \"slideshow\"") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "compatibility-lib" "gui-lib" "pict-lib" "slideshow-lib"))) (define implies (quote ("slideshow-lib"))) (define pkg-desc "executables for \"slideshow\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow-exe/slideshow/info.rkt racket-7.0+ppa1/share/pkgs/slideshow-exe/slideshow/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow-exe/slideshow/info.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow-exe/slideshow/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,3 +8,8 @@ (define binary-keep-files '("tutorial-show.rkt" "initial-ones.rkt" "examples")) + +(define raco-commands '(("slideshow" + slideshow/start + "render a Slideshow document" + #f))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow-lib/info.rkt racket-7.0+ppa1/share/pkgs/slideshow-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow-lib/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "draw-lib" "pict-lib" "gui-lib"))) (define pkg-desc "implementation (no documentation) part of \"slideshow\"") (define pkg-authors (quote (mflatt robby))) (define version "1.4"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "draw-lib" "pict-lib" "gui-lib"))) (define pkg-desc "implementation (no documentation) part of \"slideshow\"") (define pkg-authors (quote (mflatt robby))) (define version "1.4"))) diff -Nru racket-6.12+ppa1/share/pkgs/slideshow-plugin/info.rkt racket-7.0+ppa1/share/pkgs/slideshow-plugin/info.rkt --- racket-6.12+ppa1/share/pkgs/slideshow-plugin/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/slideshow-plugin/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "slideshow-lib" "pict-lib" "string-constants-lib" "compatibility-lib" "drracket-plugin-lib" "gui-lib"))) (define pkg-desc "Slideshow's DrRacket plugin") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "slideshow-lib" "pict-lib" "string-constants-lib" "compatibility-lib" "drracket-plugin-lib" "gui-lib"))) (define pkg-desc "Slideshow's DrRacket plugin") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/snip/info.rkt racket-7.0+ppa1/share/pkgs/snip/info.rkt --- racket-6.12+ppa1/share/pkgs/snip/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/snip/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("snip-lib" "gui-doc"))) (define pkg-desc "Text and graphics editor extension protocol") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("snip-lib" "gui-doc"))) (define pkg-desc "Text and graphics editor extension protocol") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/snip-lib/info.rkt racket-7.0+ppa1/share/pkgs/snip-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/snip-lib/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/snip-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib"))) (define pkg-desc "implementation (no documentation) part of \"snip\"") (define pkg-authors (quote (mflatt))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "draw-lib"))) (define pkg-desc "implementation (no documentation) part of \"snip\"") (define pkg-authors (quote (mflatt))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/source-syntax/info.rkt racket-7.0+ppa1/share/pkgs/source-syntax/info.rkt --- racket-6.12+ppa1/share/pkgs/source-syntax/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/source-syntax/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "syntax") (define deps (quote ("base"))) (define pkg-desc "find mappings from expanded to source syntax") (define pkg-authors (quote (samth stamourv eli))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "syntax") (define deps (quote ("base"))) (define pkg-desc "find mappings from expanded to source syntax") (define pkg-authors (quote (samth stamourv eli))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/srfi/info.rkt racket-7.0+ppa1/share/pkgs/srfi/info.rkt --- racket-6.12+ppa1/share/pkgs/srfi/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lib" "srfi-doc"))) (define implies (quote ("srfi-lib" "srfi-doc"))) (define pkg-desc "Legacy SRFI (Scheme) libraries") (define pkg-authors (quote (mflatt noel chongkai jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lib" "srfi-lib-nonfree" "srfi-doc" "srfi-doc-nonfree"))) (define implies (quote ("srfi-lib" "srfi-lib-nonfree" "srfi-doc" "srfi-doc-nonfree"))) (define pkg-desc "Legacy SRFI (Scheme) libraries") (define pkg-authors (quote (mflatt noel chongkai jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/srfi-doc/info.rkt racket-7.0+ppa1/share/pkgs/srfi-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/srfi-doc/info.rkt 2018-01-26 21:10:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "base" "scribble-lib" "srfi-lib" "racket-doc" "r5rs-doc" "r6rs-doc" "compatibility-lib"))) (define update-implies (quote ("srfi-lib"))) (define pkg-desc "documentation part of \"srfi\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("mzscheme-doc" "scheme-lib" "base" "scribble-lib" "srfi-lib" "racket-doc" "r5rs-doc" "r6rs-doc" "compatibility-lib"))) (define deps (quote ("scheme-lib" "base" "scribble-lib" "compatibility-lib"))) (define update-implies (quote ("srfi-lib"))) (define pkg-desc "documentation part of \"srfi\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi.scrbl racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi.scrbl --- racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi.scrbl 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -1,5 +1,6 @@ #lang scribble/doc -@(require scribble/manual +@(require srfi/scribblings/util + scribble/manual scribble/eval scriblib/render-cond scribble/core @@ -8,54 +9,6 @@ (for-label scheme/base racket/stream)) -@(define-syntax (srfi stx) - (syntax-case stx () - [(_ num #:subdir subdir? . title) - (with-syntax ([srfi/n (string->symbol (format "srfi/~a" (syntax-e #'num)))]) - #'(begin - (section #:tag (format "srfi-~a" num) - #:style 'unnumbered - (format "SRFI ~a: " num) - . title) - (defmodule srfi/n) - "Original specification: " - (let* ([label (format "SRFI ~a" num)] - [sub (if subdir? (format "srfi-~a/" num) "")] - [url (λ (b) (format "~a/srfi-std/~asrfi-~a.html" b sub num))]) - (cond-element - [(or latex text) @link[(url "http://docs.racket-lang.org") label]] - [else @link[(url ".") label]]))))] - [(_ num . title) #'(srfi num #:subdir #f . title)])) - -@;{ The `lst' argument is a list of - (list sym syntactic-form? html-anchor) } -@(define (redirect n lst #:subdir [subdir? #f]) - (let ([file (if subdir? - (format "srfi-~a/srfi-~a.html" n n) - (format "srfi-~a.html" n))] - [mod-path (string->symbol (format "srfi/~a" n))]) - (make-binding-redirect-elements mod-path - (map (lambda (b) - (list (car b) (cadr b) - (build-path "srfi-std" file) - (caddr b))) - lst)))) - -@(define in-core - (case-lambda - [() (in-core ".")] - [(k) @elem{This SRFI's bindings are also available in - @racketmodname[racket/base]@|k|}])) - -@(begin - (define-syntax-rule (def-mz mz-if) - (begin - (require (for-label mzscheme)) - (define mz-if (racket if)))) - (def-mz mz-if)) - -@(define srfi-std (style #f (list (install-resource "srfi-std")))) - @; ---------------------------------------------------------------------- @title{SRFIs: Libraries} @@ -245,14 +198,6 @@ @; ---------------------------------------- -@srfi[5]{A compatible let form with signatures and rest arguments} - -@redirect[5 '( - (let #t "unnamed") -)] - -@; ---------------------------------------- - @srfi[6]{Basic String Ports} @redirect[6 '( @@ -671,20 +616,6 @@ @; ---------------------------------------- -@srfi[29]{Localization} - -@redirect[29 '( - (current-language #f "current-language") - (current-country #f "current-country") - (current-locale-details #f "current-locale-details") - (declare-bundle! #f "declare-bundle!") - (store-bundle #f "store-bundle") - (load-bundle! #f "load-bundle!") - (localized-template #f "localized-template") -)] - -@; ---------------------------------------- - @srfi[30]{Nested Multi-line Comments} This SRFI's syntax is part of Racket's default reader. diff -Nru racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-29.html racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-29.html --- racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-29.html 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-29.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,507 +0,0 @@ - - - - - SRFI 29: Localization - - - - -

Title

- - SRFI 29: Localization - -

Author

- - Scott G. Miller - -

Abstract

- - This document specifies an interface to retrieving and - displaying locale sensitive messages. A Scheme program can - register one or more translations of templated messages, and - then write Scheme code that can transparently retrieve the - appropriate message for the locale under which the Scheme - system is running.
- - -

Rationale

- -

As any programmer that has ever had to deal with making his - or her code readable in more than one locale, the process of - sufficiently abstracting program messages from their - presentation to the user is non-trivial without help from the - programming language. Most modern programming language - libraries do provide some mechanism for performing this - separation.

- -

A portable API that allows a piece of code to run without - modification in different countries and under different - languages is a must for any non-trivial software project. -  The interface should separate the logic of a program from - the myriad of translations that may be necessary.

- -

The interface described in this document provides such - functionality. The underlying implementation is also allowed to - use whatever datastructures it likes to provide access to the - translations in the most efficient manner possible.  In - addition, the implementation is provided with standardized - functions that programs will use for accessing an external, - unspecified repository of translations.

- -

This interface does not cover all aspects of - localization, including support for non-latin characters, - number and date formatting, etc. Such functionality is the - scope of a future SRFI that may extend this one.

- -

Dependencies

- - An SRFI-29 conformant implementation must also implement - SRFI-28, Basic Format Strings. Message templates are strings - that must be processed by the format function - specified in that SRFI. - -

Specification

- -

Message Bundles

- -

A Message Bundle is a set of message templates and their - identifying keys. Each bundle contains one or more such - key/value pairs. The bundle itself is associated with a - bundle specifier which uniquely identifies the - bundle.

- -

Bundle Specifiers

- -

A Bundle Specifier is a Scheme list that describes, in order - of importance, the package and locale of a message bundle. -  In most cases, a locale specifier will have between one - and three elements. The first element is a symbol denoting the - package for which this bundle applies. The second and third - elements denote a locale. The second element (first - element of the locale) if present, is the two letter, ISO 639-1 - language code for the bundle. The third element, if present, is - a two letter ISO 3166-1 country code.  In some cases, a - fourth element may be present, specifying the encoding used for - the bundle.  All bundle specifier elements are Scheme - symbols.

- -

If only one translation is provided, it should be designated - only by a package name, for example (mathlib). This - translation is called the default translation.

- -

Bundle Searching

- -

When a message template is retrieved from a bundle, the - Scheme implementation will provide the locale under which the - system is currently running. When the template is retrieved, - the package name will be specified. The Scheme system should - construct a Bundle Specifier from the provided package name and - the active locale. For example, when retrieving a message - template for French Canadian, in the mathlib package, - the bundle specifier '(mathlib fr ca)' is used. A - program may also retrieve the elements of the current locale - using the no-argument procedures:

- -

current-language -> - symbol
- current-language symbol -> - undefined
-

- -
- When given no arguments, returns the current ISO 639-1 - language code as a symbol.  If provided with an - argument, the current language is set to that named by the - symbol for the currently executing Scheme thread (or for the - entire Scheme system if such a distinction is not possible). -   -
- -

current-country -> - symbol
- current-country symbol -> - undefined
-

- -
- returns the current ISO 3166-1 country code as a symbol. -  If provided with an argument, the current country is - set to that named by the symbol for the currently executing - Scheme thread (or for the entire Scheme system if such a - distinction is not possible).    -
- -

current-locale-details -> list of - symbols
- current-locale-details list-of-symbols -> - undefined
-

- -
- Returns a list of additional locale details as a list of - symbols.  This list may contain information about - encodings or other more specific information.  If - provided with an argument, the current locale details are set - to those given in the currently executing Scheme thread (or - for the entire Scheme system if such a distinction is not - possible).  -
- -

The Scheme System should first check for a bundle with the - exact name provided. If no such bundle is found, the last - element from the list is removed and a search is tried for a - bundle with that name. If no bundle is then found, the list is - shortened by removing the last element again. If no message is - found and the bundle specifier is now the empty list, an error - should be raised.

- -

The reason for this search order is to provide the most - locale sensitive template possible, but to fall back on more - general templates if a translation has not yet been provided - for the given locale.

- -

Message Templates

- -

A message template is a localized message that may or may - not contain one of a number of formatting codes. A message - template is a Scheme string. The string is of a form that can - be processed by the format procedure found in many - Scheme systems and formally specified in SRFI-28 (Basic Format - Strings).

- -

This SRFI also extends SRFI-28 to provide an additional - format escape code:

- -
- ~[n]@* - Causes a value-requiring escape code that - follows this code immediately to reference the [N]'th - optional value absolutely, rather than the next unconsumed - value. The referenced value is not consumed. -
- This extension allows optional values to be positionally - referenced, so that message templates can be constructed that - can produce the proper word ordering for a language. - -

Preparing Bundles

- Before a bundle may be used by the Scheme system to retrieve - localized template messages, they must be made available to the - Scheme system.  This SRFI specifies a way to portably - define the bundles, as well as store them in and retrieve them - from an unspecified system which may be provided by resources - outside the Scheme system.
- - -

declare-bundle! bundle-specifier - association-list -> undefined
-

- -
- Declares a new bundle named by the given bundle-specifier. -  The contents of the bundle are defined by the provided - association list.  The list contains associations - between Scheme symbols and the message templates (Scheme - strings) they name.  If a bundle already exists with the - given name, it is overwritten with the newly declared - bundle.
-
- store-bundle bundle-specifier -> - boolean
- - -
- Attempts to store a bundle named by the given bundle - specifier, and previously made available using - declare-bundle! or load-bundle!, in an - unspecified mechanism that may be persistent across Scheme - system restarts.  If successful, a non-false value is - returned.  If unsuccessful, #f is returned.
-
- load-bundle! bundle-specifier -> - boolean
- - -
- Attempts to retrieve a bundle from an unspecified mechanism - which stores bundles outside the Scheme system.  If the - bundle was retrieved successfully, the function returns a - non-false value, and the bundle is immediately available to - the Scheme system. If the bundle could not be found or loaded - successfully, the function returns #f, and the - Scheme system's bundle registry remains unaffected.
-
- A compliant Scheme system may choose not to provide any - external mechanism to store localized bundles.  If it does - not, it must still provide implementations for - store-bundle and load-bundle!. In such a - case, both functions must return #f regardless of the - arguments given. Users of this SRFI should recognize that the - inability to load or store a localized bundle in an external - repository is not a fatal error.
- - -

Retrieving Localized Message Templates

- -

localized-template package-name - message-template-name -> string or #f
-

- -
- Retrieves a localized message template for the given package - name and the given message template name (both symbols). -  If no such message could be found, false (#f) is - returned.
-
-
- After retrieving a template, the calling program can use - format to produce a string that can be displayed to - the user.
- - -

Examples

- The below example makes use of SRFI-29 to display simple, - localized messages.  It also defines its bundles in such a - way that the Scheme system may store and retrieve the bundles - from a more efficient system catalog, if available.
- -
-(let ((translations
-       '(((en) . ((time . "Its ~a, ~a.")
-                (goodbye . "Goodbye, ~a.")))
-         ((fr) . ((time . "~1@*~a, c'est ~a.")
-                (goodbye . "Au revoir, ~a."))))))
-  (for-each (lambda (translation)
-              (let ((bundle-name (cons 'hello-program (car translation))))
-                (if (not (load-bundle! bundle-name))
-                    (begin
-                     (declare-bundle! bundle-name (cdr translation))
-                     (store-bundle! bundle-name)))))
-             translations))
-
-(define localized-message
-  (lambda (message-name . args)
-    (apply format (cons (localized-template 'hello-program
-                                            message-name)
-                        args))))
-
-(let ((myname "Fred"))
-  (display (localized-message 'time "12:00" myname))
-  (display #\newline)
-
-  (display (localized-message 'goodbye myname))
-  (display #\newline))
-
-;; Displays (English):
-;; Its 12:00, Fred.
-;; Goodbye, Fred.
-;;
-;; French:
-;; Fred, c'est 12:00.
-;; Au revoir, Fred.
-
- -

Implementation

- -

The implementation requires that the Scheme system provide a - definition for current-language and - current-country capable of distinguishing the correct - locale present during a Scheme session. The definitions of - those functions in the reference implementation are not capable - of that distinction. Their implementation is provided only so - that the following code can run in any R4RS scheme system. -  
-

- -

In addition, the below implementation of a compliant - format requires SRFI-6 (Basic String Ports) and - SRFI-23 (Error reporting)

-
-;; The association list in which bundles will be stored
-(define *localization-bundles* '())
-
-;; The current-language and current-country functions provided
-;; here must be rewritten for each Scheme system to default to the
-;; actual locale of the session
-(define current-language
-  (let ((current-language-value 'en))
-    (lambda args
-      (if (null? args)
-          current-language-value
-          (set! current-language-value (car args))))))
-
-(define current-country
-  (let ((current-country-value 'us))
-    (lambda args
-      (if (null? args)
-          current-country-value
-          (set! current-country-value (car args))))))
-
-;; The load-bundle! and store-bundle! both return #f in this
-;; reference implementation.  A compliant implementation need
-;; not rewrite these procedures.
-(define load-bundle!
-  (lambda (bundle-specifier)
-    #f))
-
-(define store-bundle!
-  (lambda (bundle-specifier)
-    #f))
-
-;; Declare a bundle of templates with a given bundle specifier
-(define declare-bundle!
-  (letrec ((remove-old-bundle
-            (lambda (specifier bundle)
-              (cond ((null? bundle) '())
-                    ((equal? (caar bundle) specifier)
-                     (cdr bundle))
-                    (else (cons (car bundle)
-                                (remove-old-bundle specifier
-                                                   (cdr bundle))))))))
-    (lambda (bundle-specifier bundle-assoc-list)
-      (set! *localization-bundles*
-            (cons (cons bundle-specifier bundle-assoc-list)
-                  (remove-old-bundle bundle-specifier
-                                     *localization-bundles*))))))
-
-;;Retrieve a localized template given its package name and a template name
-(define localized-template
-  (letrec ((rdc
-            (lambda (ls)
-              (if (null? (cdr ls))
-                  '()
-                  (cons (car ls) (rdc (cdr ls))))))
-           (find-bundle
-            (lambda (specifier template-name)
-              (cond ((assoc specifier *localization-bundles*) =>
-                     (lambda (bundle) bundle))
-                    ((null? specifier) #f)
-                    (else (find-bundle (rdc specifier)
-                                       template-name))))))
-    (lambda (package-name template-name)
-      (let loop ((specifier (cons package-name
-                                  (list (current-language)
-                                        (current-country)))))
-        (and (not (null? specifier))
-             (let ((bundle (find-bundle specifier template-name)))
-               (and bundle
-                    (cond ((assq template-name bundle) => cdr)
-                          ((null? (cdr specifier)) #f)
-                          (else (loop (rdc specifier)))))))))))
-
-;;An SRFI-28 and SRFI-29 compliant version of format.  It requires
-;;SRFI-23 for error reporting.
-(define format
-  (lambda (format-string . objects)
-    (let ((buffer (open-output-string)))
-      (let loop ((format-list (string->list format-string))
-                 (objects objects)
-                 (object-override #f))
-        (cond ((null? format-list) (get-output-string buffer))
-              ((char=? (car format-list) #\~)
-               (cond ((null? (cdr format-list))
-                      (error 'format "Incomplete escape sequence"))
-                     ((char-numeric? (cadr format-list))
-                      (let posloop ((fl (cddr format-list))
-                                    (pos (string->number
-                                          (string (cadr format-list)))))
-                        (cond ((null? fl)
-                               (error 'format "Incomplete escape sequence"))
-                              ((and (eq? (car fl) '#\@)
-                                    (null? (cdr fl)))
-                                    (error 'format "Incomplete escape sequence"))
-                              ((and (eq? (car fl) '#\@)
-                                    (eq? (cadr fl) '#\*))
-                               (loop (cddr fl) objects (list-ref objects pos)))
-                              (else
-                                (posloop (cdr fl)
-                                         (+ (* 10 pos)
-                                            (string->number
-                                             (string (car fl)))))))))
-                     (else
-                       (case (cadr format-list)
-                         ((#\a)
-                          (cond (object-override
-                                 (begin
-                                   (display object-override buffer)
-                                   (loop (cddr format-list) objects #f)))
-                                ((null? objects)
-                                 (error 'format "No value for escape sequence"))
-                                (else
-                                  (begin
-                                    (display (car objects) buffer)
-                                    (loop (cddr format-list)
-                                          (cdr objects) #f)))))
-                         ((#\s)
-                          (cond (object-override
-                                 (begin
-                                   (display object-override buffer)
-                                   (loop (cddr format-list) objects #f)))
-                                ((null? objects)
-                                 (error 'format "No value for escape sequence"))
-                                (else
-                                  (begin
-                                    (write (car objects) buffer)
-                                    (loop (cddr format-list)
-                                          (cdr objects) #f)))))
-                         ((#\%)
-                          (if object-override
-                              (error 'format "Escape sequence following positional override does not require a value"))
-                          (display #\newline buffer)
-                          (loop (cddr format-list) objects #f))
-                        ((#\~)
-                          (if object-override
-                              (error 'format "Escape sequence following positional override does not require a value"))
-                          (display #\~ buffer)
-                          (loop (cddr format-list) objects #f))
-                         (else
-                           (error 'format "Unrecognized escape sequence"))))))
-              (else (display (car format-list) buffer)
-                    (loop (cdr format-list) objects #f)))))))
-
-
- -

Copyright

- - Copyright (C) Scott G. Miller (2002). All Rights Reserved. - -

This document and translations of it may be copied and - furnished to others, and derivative works that comment on or - otherwise explain it or assist in its implementation may be - prepared, copied, published and distributed, in whole or in - part, without restriction of any kind, provided that the above - copyright notice and this paragraph are included on all such - copies and derivative works. However, this document itself may - not be modified in any way, such as by removing the copyright - notice or references to the Scheme Request For Implementation - process or editors, except as needed for the purpose of - developing SRFIs in which case the procedures for copyrights - defined in the SRFI process must be followed, or as required to - translate it into languages other than English.

- -

The limited permissions granted above are perpetual and will - not be revoked by the authors or their successors or - assigns.

- -

This document and the information contained herein is - provided on an "AS IS" basis and THE AUTHOR AND THE SRFI - EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING - BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION - HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES - OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.

-
- -
- Editor: David - Rush -
- -
- Author: Scott G. - Miller -
- - Last modified: Mon Jun 17 12:00:08 Pacific - Daylight Time 2002
- - - diff -Nru racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-5.html racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-5.html --- racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-5.html 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/srfi-std/srfi-5.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,345 +0,0 @@ - - - - SRFI 5: A compatible let form with signatures and rest arguments - - - -

Title

- -SRFI-5: A compatible let form with signatures and rest arguments - -

Author

- -Andy Gaynor - -

Status

- -This SRFI is currently in ``final'' status. To see an explanation of each status that a SRFI can hold, see here. -You can access the discussion on this SRFI via the archive of the mailing list. -

    -
  • Received: 1999/2/2 -
  • Draft: 1999/2/10-1999/04/12 -
  • Final: 1999/4/26 -
  • Revised reference implementation: 2003/01/27 -
- -

Abstract

- -The named-let incarnation of the let form has two slight -inconsistencies with the define form. As defined, the let -form makes no accommodation for rest arguments, an issue of functionality -and consistency. As defined, the let form does not accommodate -signature-style syntax, an issue of aesthetics and consistency. Both -issues are addressed here in a manner which is compatible with the traditional -let form but for minor extensions. - -

Rationale

- -

Signature-style Syntax

- -Consider the following two equivalent definitions: - -

-(define fibonacci
-  (lambda (n i f0 f1)
-    (if (= i n)
-      f0
-      (fibonacci n (+ i 1) f1 (+ f0 f1)))))
-
-(define (fibonacci n i f0 f1)
-  (if (= i n)
-    f0
-    (fibonacci n (+ i 1) f1 (+ f0 f1))))
-
- -Although there is a named-let analog for the former form, there is none -for the latter. To wit, suppose one wished to compute the 10th element -of the Fibonacci sequence using a named let: - -

-

-(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
-  (if (= i n)
-    f0
-    (fibonacci n (+ i 1) f1 (+ f0 f1))))
-Values: 55
-
- -As it stands, one cannot equivalently write - -

-

-(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
-  (if (= i n)
-    f0
-    (fibonacci n (+ i 1) f1 (+ f0 f1))))
-
- -which is consistent with define's signature-style form. -

Those that favor the signature style may prefer this extension. -In any case, it may be more appropriate to include all bound names within -the binding section. As presented, this straightforward extension -introduces no ambiguity or incompatibility with the existing definition -of let. - -

Rest Arguments

- -As it stands, one cannot write a named let with rest arguments, as in - -

-

-(let (blast (port (current-output-port)) . (x (+ 1 2) 4 5))
-  (if (null? x)
-    'just-a-silly-contrived-example
-    (begin
-      (write (car x) port)
-      (apply blast port (cdr x)))))
-
- -otherwise equivalent to - -

-

-(letrec ((blast (lambda (port . x)
-		  (if (null? x)
-		      'just-a-silly-contrived-example
-		      (begin
-			(write (car x) port)
-			(apply blast port (cdr x)))))))
-  (blast (current-output-port) (+ 1 2) 4 5))
-
- -While this example is rather contrived, the functionality is not. -There are several times when the author has used this construct in practice. -Regardless, there is little reason to deny the let form access to -all the features of lambda functionality. - -

Symbols in Binding Sections

- -Both the features above rely upon the placement of symbols in let -binding lists (this statement is intentially simplistic). The only -other apparent use of such symbol placement is to tersely bind variables -to unspecified values. For example, one might desire to use -(let (foo bar baz) ...) -to bind foo, bar, and baz to -unspecified values. - -

This usage is considered less important in light of the rationales -presented above, and an alternate syntax is immediately apparent, as -in (let ((foo) (bar) (baz)) ...) This may even -be preferable, consistently parenthesizing normal binding clauses. - -

Specification

- -

Syntax

- -

-A formal specification of the syntax follows. Below, body, expression, -and identifier are free. Each instantiation of binding-name must be -unique. -

- -

-

-            let = "(" "let" let-bindings body ")"
-    expressions = nothing | expression expressions
-   let-bindings = let-name bindings
-                | "(" let-name "." bindings ")"
-       let-name = identifier
-       bindings = "(" ")"
-                | rest-binding
-                | "(" normal-bindings ["." rest-binding] ")"
-normal-bindings = nothing
-                | normal-binding normal-bindings
- normal-binding = "(" binding-name expression ")"
-   binding-name = identifier
-   rest-binding = "(" binding-name expressions ")"
-
- -

-For clarity and convenience, an informal specification follows. -

- -
    -
  1. Unnamed - -

    -(let ((<parameter> <argument>)...) 
-  <body>...)
-
    -
    2. - -
  2. -Named, non-signature-style, no rest argument - -

    -(let <name> ((<parameter> <argument>)...)
-  <body>...)
-
    -
    3. - -
  3. Named, signature-style, no rest argument - -

    -(let (<name> (<parameter> <argument>)...)
-  <body>...)
-
    -
    4. - -
  4. Named, non-signature-style, rest argument - -

    -(let <name> ((<parameter> <argument>)...
-    
-. (<rest-parameter> <rest-argument>...))
-  <body>...)
-
    - -
  5. Named, signature-style, rest argument - -

    -(let (<name> (<parameter> <argument>)...
-   
-. (<rest-parameter> <rest-argument>...))
-  <body>...)
-
    -
    6. -
- -

Semantics

- -Let $lambda and $letrec be hygienic bindings for the lambda -and letrec forms, respectively. - -
    -
  • For informal syntax 1: - -

    -(($lambda (<parameter>...) <body>...) <argument>...)
-
    -
    • - -
  • For informal syntaxes 2 and 3: - -

    -

    -($letrec ((<name> ($lambda (<parameter>...) <body>...)))
-  (<name> <argument>...))
-
    -
    • - -
  • For informal syntaxes 4 and 5: - -

    -

    -($letrec ((<name> ($lambda (<parameter>...
-   
-. <rest-parameter>) <body>...))) 
-  (<name> <argument>... <rest-argument>...))
-
    -
    • -
- -

Implementation

- -Here is an implementation using SYNTAX-RULES. - -

-

-;; Use your own standard let.
-;; Or call a lambda.
-;; (define-syntax standard-let
-;;
-;;   (syntax-rules ()
-;;
-;;     ((let ((var val) ...) body ...)
-;;      ((lambda (var ...) body ...) val ...))))
-
-(define-syntax let
-
-  (syntax-rules ()
-
-    ;; No bindings: use standard-let.
-    ((let () body ...)
-     (standard-let () body ...))
-    ;; Or call a lambda.
-    ;; ((lambda () body ...))
-
-    ;; All standard bindings: use standard-let.
-    ((let ((var val) ...) body ...)
-     (standard-let ((var val) ...) body ...))
-    ;; Or call a lambda.
-    ;; ((lambda (var ...) body ...) val ...)
-
-    ;; One standard binding: loop.
-    ;; The all-standard-bindings clause didn't match,
-    ;; so there must be a rest binding.
-    ((let ((var val) . bindings) body ...)
-     (let-loop #f bindings (var) (val) (body ...)))
-
-    ;; Signature-style name: loop.
-    ((let (name binding ...) body ...)
-     (let-loop name (binding ...) () () (body ...)))
-
-    ;; defun-style name: loop.
-    ((let name bindings body ...)
-     (let-loop name bindings () () (body ...)))))
-
-(define-syntax let-loop
-
-  (syntax-rules ()
-
-    ;; Standard binding: destructure and loop.
-    ((let-loop name ((var0 val0) binding ...) (var ...     ) (val ...     ) body)
-     (let-loop name (            binding ...) (var ... var0) (val ... val0) body))
-
-    ;; Rest binding, no name: use standard-let, listing the rest values.
-    ;; Because of let's first clause, there is no "no bindings, no name" clause.
-    ((let-loop #f (rest-var rest-val ...) (var ...) (val ...) body)
-     (standard-let ((var val) ... (rest-var (list rest-val ...))) . body))
-    ;; Or call a lambda with a rest parameter on all values.
-    ;; ((lambda (var ... . rest-var) . body) val ... rest-val ...))
-    ;; Or use one of several other reasonable alternatives.
-
-    ;; No bindings, name: call a letrec'ed lambda.
-    ((let-loop name () (var ...) (val ...) body)
-     ((letrec ((name (lambda (var ...) . body)))
-        name)
-      val ...))
-
-    ;; Rest binding, name: call a letrec'ed lambda.
-    ((let-loop name (rest-var rest-val ...) (var ...) (val ...) body)
-     ((letrec ((name (lambda (var ... . rest-var) . body)))
-        name)
-      val ... rest-val ...))))
-
- - -

Copyright

- -Copyright (C) Andy Gaynor (1999). All Rights Reserved. -

This document and translations of it may be copied and furnished to -others, and derivative works that comment on or otherwise explain it or -assist in its implementation may be prepared, copied, published and distributed, -in whole or in part, without restriction of any kind, provided that the -above copyright notice and this paragraph are included on all such copies -and derivative works. However, this document itself may not be modified -in any way, such as by removing the copyright notice or references to the -Scheme Request For Implementation process or editors, except as needed -for the purpose of developing SRFIs in which case the procedures for copyrights -defined in the SRFI process must be followed, or as required to translate -it into languages other than English. -

The limited permissions granted above are perpetual and will not be -revoked by the authors or their successors or assigns. -

This document and the information contained herein is provided on an -"AS IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE -USE OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED -WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. - -

-
Editor: Mike Sperber
- - - diff -Nru racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/util.rkt racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/util.rkt --- racket-6.12+ppa1/share/pkgs/srfi-doc/srfi/scribblings/util.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-doc/srfi/scribblings/util.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,61 @@ +#lang scribble/doc + +@(require scribble/manual + scribble/eval + scriblib/render-cond + scribble/core + scribble/html-properties + (for-syntax scheme/base) + (for-label scheme/base + racket/stream)) + +@(provide (all-defined-out)) + +@(define-syntax (srfi stx) + (syntax-case stx () + [(_ num #:subdir subdir? . title) + (with-syntax ([srfi/n (string->symbol (format "srfi/~a" (syntax-e #'num)))]) + #'(begin + (section #:tag (format "srfi-~a" num) + #:style 'unnumbered + (format "SRFI ~a: " num) + . title) + (defmodule srfi/n) + "Original specification: " + (let* ([label (format "SRFI ~a" num)] + [sub (if subdir? (format "srfi-~a/" num) "")] + [url (λ (b) (format "~a/srfi-std/~asrfi-~a.html" b sub num))]) + (cond-element + [(or latex text) @link[(url "http://docs.racket-lang.org") label]] + [else @link[(url ".") label]]))))] + [(_ num . title) #'(srfi num #:subdir #f . title)])) + +@;{ The `lst' argument is a list of + (list sym syntactic-form? html-anchor) } +@(define (redirect n lst #:subdir [subdir? #f]) + (let ([file (if subdir? + (format "srfi-~a/srfi-~a.html" n n) + (format "srfi-~a.html" n))] + [mod-path (string->symbol (format "srfi/~a" n))]) + (make-binding-redirect-elements mod-path + (map (lambda (b) + (list (car b) (cadr b) + (build-path "srfi-std" file) + (caddr b))) + lst)))) + +@(define in-core + (case-lambda + [() (in-core ".")] + [(k) @elem{This SRFI's bindings are also available in + @racketmodname[racket/base]@|k|}])) + +@(begin + (define-syntax-rule (def-mz mz-if) + (begin + (require (for-label mzscheme)) + (define mz-if (racket if)))) + (def-mz mz-if)) + +@(define srfi-std (style #f (list (install-resource "srfi-std")))) + diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/info.rkt racket-7.0+ppa1/share/pkgs/srfi-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lib/info.rkt 2018-01-26 21:10:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "srfi-lite-lib" "r6rs-lib" "compatibility-lib"))) (define implies (quote ("srfi-lite-lib"))) (define pkg-desc "implementation (no documentation) part of \"srfi\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "srfi-lite-lib" "r6rs-lib" "compatibility-lib"))) (define implies (quote ("srfi-lite-lib"))) (define pkg-desc "implementation (no documentation) part of \"srfi\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/32/sort.txt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/32/sort.txt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/32/sort.txt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/32/sort.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,1069 +0,0 @@ -The SRFI-32 sort libraries -*- outline -*- -Olin Shivers -First draft: 1998/10/19 -Last update: 2002/7/21 - -[Todo: del-list-neighbor-dups! - vector-copy -> subvector - use srfi-23 for reporting errors - use srfi-16 for n-aries? - -Emacs should display this document in outline mode. Say c-h m for -instructions on how to move through it by sections (e.g., c-c c-n, c-c c-p). - -* Table of contents -------------------- -Abstract -Procedure index -Introduction -What's wrong with the current state of affairs? -Design rules - What vs. how - Consistency across function signatures - Data parameter first, less-than parameter after - Ordering, comparison functions & stability - All vector operations accept optional subrange parameters - Required vs. allowed side-effects -Procedure specification - Procedure naming and functionality - Types of parameters and return values - sort-lib - general sorting package - Algorithm-specific sorting packages -Algorithmic properties -Topics to be resolved during discussion phase -Porting and optimisation -References & Links -Acknowledgements -Copyright - - -* Abstract ----------- -Current Scheme sorting packages are, every one of them, surprisingly bad. I've -designed the API for a full-featured sort toolkit, which I propose as a SRFI. - -The spec comes with 1200 lines of high-quality reference code: tightly -written, highly commented, portable code, available for free. Implementors -want this code. It's better than what you have. - -------------------------------------------------------------------------------- -* Procedure index ------------------ -list-sorted? vector-sorted? - -list-merge vector-merge -list-sort vector-sort -list-stable-sort vector-stable-sort -list-delete-neighbor-dups vector-delete-neighbor-dups - -list-merge! vector-merge! -list-sort! vector-sort! -list-stable-sort! vector-stable-sort! -list-delete-neighbor-dups! vector-delete-neighbor-dups! - -quick-sort heap-sort insert-sort list-merge-sort vector-merge-sort -quick-sort! heap-sort! insert-sort! list-merge-sort! vector-merge-sort! -quick-sort3! - -vector-binary-search -vector-binary-search3 - -------------------------------------------------------------------------------- -* Introduction --------------- -As I'll detail below, I wasn't very happy with the state of the Scheme -world for sorting and merging lists and vectors. So I have designed and -written a fairly comprehensive sorting & merging toolkit. It is - - - very portable, - - - much better code than what is currently in Elk, Gambit, Bigloo, - Scheme->C, MzScheme, RScheme, Scheme48, MIT Scheme, or slib, and - - - priced to move: free code. - -The package includes - - Vector insert sort (stable) - - Vector heap sort - - Vector quick sort (with median-of-3 pivot picking) - - Vector merge sort (stable) - - Pure and destructive list merge sort (stable) - - Stable vector and list merge - - Miscellaneous sort-related procedures: Vector and list merging, - sorted? predicates, vector binary search, vector and list - delete-equal-neighbor procedures. - - A general, non-algorithmic set of procedure names for general sorting - and merging. - -Scheme programmers may want to adopt this package. I'd like Scheme -implementors to adopt this code and its API -- in fact, the code is a bribe to -make it easy for implementors to converge on the suggested API. I mean, you'd -really have to be a boor to take this free code I wrote and mutate its -interface over to your incompatible, unportable API, wouldn't you? But you -could, of course -- it's freely available. More in the spirit of the offering, -you could make this API available, and then also write a little module -providing your old interface that is defined in terms of this API. "Scheme -implementors," in this context, includes slib, which is not a standalone -implementation of Scheme, but rather an influential collection of API's and -code. - -The code is tightly bummed. It is clearly written, and commented in my usual -voluminous style. This includes notes on porting and implementation-specific -optimisations. - - -------------------------------------------------------------------------------- -* What's wrong with the current state of affairs? -------------------------------------------------- - -It's just amazing to me that in 2002, sorting and merging hasn't been -completely put to bed. These are well-understood algorithms, each of them well -under a page of code. The straightforward algorithms are basic, core stuff -- -sophomore-level. But if you tour the major Scheme implementations out there on -the Net, you find badly written code that provides extremely spotty coverage -of the algorithm space. One implementation even has a buggy implementation -that has been in use for about 20 years. Another has an O(n^2) algorithm... -implemented in C for speed. - -Open source-code is a wonderful thing. In a couple of hours, I was able to -download and check the sources of 9 Scheme systems. Here are my notes from the -systems I checked. You can skip to the next section if you aren't morbidly -curious. - -slib - sorted? vector-or-list < - merge list1 list2 < - merge! list1 list2 < - sort vector-or-list < - sort! vector-or-list < - - Richard O'Keefe's stable list merge sort is right idea, but implemented - using gratuitous variable side effects. It also does redundant SET-CDR!s. - The vector sort converts to list, merge sorts, then reconverts - to vector. This is a bad idea -- non-local pointer chasing bad; vector - shuffling good. If you must allocate temp storage, might as well allocate - a temp vector and use vector merge sort. - -MIT Scheme - sort! vector < - merge-sort! vector < - quick-sort! vector < - - sort vector-or-list < - merge-sort vector-or-list < - quick-sort vector-or-list < - - Naive vector quicksort: loser, for worst-case performance reasons. - List sort by "list->vector; quicksort; vector->list," hence also loser. - A clever stable vector merge sort, albeit not very bummed. - -Scheme 48 & T - sort-list list < - sort-list! list < - list-merge! list1 list2 < - - Bob Nix's implementation of online merge-sort, written in the early 80's. - Conses unnecessary bookkeeping structure, which isn't necessary with a - proper recursive formulation. Also, does redundant SET-CDR!s. No vector - sort. Also, has a bug -- is claimed to be a stable sort, but isn't! To see - this, get the S48 code, and try - (define (my< x y) (< (abs x) (abs y))) - (list-merge! (list 0 2) (list -2) my<) ; -> (0 2 -2) - (list-merge! (list 2) (list 0 -2) my<) ; -> (0 -2 2) - This could be fixed very easily, but it isn't worth it given the - other problems with the algorithm. - -RScheme - vector-sort! vector < - sort collection < - - Good basic implementation of vector heapsort, which has O(n lg n) - worst-case time. Code ugly, needs tuning. List sort by "list->vector; - sort; vector->list." Nothing for stable sorting. - -MzScheme - quicksort lis < - mergesort alox < - - Sorts lists with (list->vector; quicksort; vector->list) -- but the core - quicksort is not available for vector sorting. Nothing for stable sorting. - Quicksort picks pivot naively, inducing O(n^2) worse-case behaviour on a - fairly common case: an already-sorted list. - -Bigloo, STK - sort vector-or-list < - Uses an O(n^2) algorithm... implemented in C for speed. Hmm. - (See runtime/Ieee/vector.scm and runtime/Clib/cvector.c) - -Gambit - sort-list list < - Nothing for vectors. Simple, slow, unstable merge sort for lists. - -Elk - Another naive quicksort. Lists handled by converting to vector. - sort vector-or-list < - sort! vector-or-list < - -Chez Scheme - merge < list1 list2 - merge! < list1 list2 - sort < list - sort! < list - - These are stable. I have not seen the source code. - -Common Lisp - sort sequence < [key] - stable-sort sequence < [key] - merge result-type sequence1 sequence2 < [key] - - The sort procedures are allowed, but not required, to be destructive. - -SML/NJ - sort: ('a*'a -> bool) -> 'a list -> 'a list - "Smooth applicative merge sort," which is stable. - There is also a highly bummed quicksort for vectors. - -The right solution: Implement a full toolbox of carefully written standard sort -routines. - -Having the source of all these above-cited Schemes available for study made -life a lot easier writing this code. I appreciate the authors making their -source available under such open terms. - - -------------------------------------------------------------------------------- -* Design rules --------------- - -** What vs. how -=============== -There are two different interfaces: "what" (simple) & "how" (detailed). - - - Simple: you specify semantics: datatype (list or vector), - mutability, and stability. - - - Detailed: you specify the actual algorithm (quick, heap, - insert, merge). Different algorithms have different properties, - both semantic & pragmatic, so these exports are necessary. - - It is necessarily the case that the specifications of these procedures - make statements about execution "pragmatics." For example, the sole - distinction between heap sort and quick sort -- both of which are - provided by this library -- is one of execution time, which is not a - "semantic" distinction. Similar resource-use statements are made about - "iterative" procedures, meaning that they can execute on input of - arbitrary size in a constant number of stack frames. - -** Consistency across function signatures -========================================= -The two interfaces share common function signatures wherever -possible, to facilitate switching a given call from one procedure -to another. - -** Less-than parameter first, data parameter after -================================================== -These procedures uniformly observe the following parameter order: -the data to be sorted comes after the comparison function. -That is, we write - (sort < lis) -not - (sort lis <). - -With the sole exception of Chez Scheme, this is the exact opposite of -every sort function out there in current use in the Scheme world. (See -the summary of related APIs above.) However, it is consistent with common -practice across Scheme libraries in general to put the ordering function -first -- the "operation currying" convention. (E.g., consider FOR-EACH or -MAP or FIND.) - -The original draft of this SRFI used the data-first/comparison-last convention -for backwards compatibility -- a decision I made with internal misgivings. -Happily, however, the overwhelming response from the discussion phase -supported "cleaning up" this issue and re-converging the parameter order with -the general Scheme "op currying" convention. So the original decision was -inverted in favor of the comparison-first/data-last convention. - -** Ordering, comparison functions & stability -============================================= -These routines take a < comparison function, not a <= comparison -function, and they sort into increasing order. The difference between -a < spec and a <= spec comes up in three places: - - the definition of an ordered or sorted data set, - - the definition of a stable sorting algorithm, and - - correctness of quicksort. - -+ We say that a data set (a list or vector) is *sorted* or *ordered* - if it contains no adjacent pair of values ... X Y ... such that Y < X. - - In other words, scanning across the data never takes a "downwards" step. - - If you use a <= procedure where these algorithms expect a < - procedure, you may not get the answers you expect. For example, - the LIST-SORTED? function will return false if you pass it a <= comparison - function and an ordered list containing adjacent equal elements. - -+ A "stable" sort is one that preserves the pre-existing order of equal - elements. Suppose, for example, that we sort a list of numbers by - comparing their absolute values, i.e., using comparison function - (lambda (x y) (< (abs x) (abs y))) - If we sort a list that contains both 3 and -3: - ... 3 ... -3 ... - then a stable sort is an algorithm that will not swap the order - of these two elements, that is, the answer is guaranteed to to look like - ... 3 -3 ... - not - ... -3 3 ... - - Choosing < for the comparison function instead of <= affects how stability - is coded. Given an adjacent pair X Y, (< y x) means "Y should be moved in - front of X" -- otherwise, leave things as they are. So using a <= function - where a < function is expected will *invert* stability. - - This is due to the definition of equality, given a < comparator: - (and (not (< x y)) - (not (< y x))) - The definition is rather different, given a <= comparator: - (and (<= x y) - (<= y x)) - -+ A "stable" merge is one that reliably favors one of its data sets - when equal items appear in both data sets. *All merge operations in - this library are stable*, breaking ties between data sets in favor - of the first data set -- elements of the first list come before equal - elements in the second list. - - So, if we are merging two lists of numbers ordered by absolute value, - the stable merge operation LIST-MERGE - (list-merge (lambda (x y) (< (abs x) (abs y))) - '(0 -2 4 8 -10) '(-1 3 -4 7)) - reliably places the 4 of the first list before the equal-comparing -4 - of the second list: - (0 -1 -2 4 -4 7 8 -10) - -+ Some sort algorithms will *not work correctly* if given a <= when they - expect a < comparison (or vice-versa). For example, violating quicksort's - spec may cause it to produce wrong answers, diverge, raise an error, or do - some fourth thing. To see why, consider the left-scan part of the standard - quicksort partition step: - (let ((i (let scan ((i i)) (if (elt< (vector-ref v i) pivot) - (scan (+ i 1)) - i)))) - ...) - Consider applying this loop to a vector of all zeroes (hence, PIVOT, as - well, is zero), but erroneously using <= for the ELT< function. The loop - will scan right off the end of the vector, producing a vector-index error. - The guarantee that the scan loop will terminate before running off the end - of the vector depends critically upon ELT< performing as a true, irreflexive - < relation. Running off the end of the vector is only one of a variety of - possibly ways to lose -- other, variant implementations of quicksort can, - instead, loop forever on some data sets if ELT< is a <= predicate. - -In short, if your comparison function F answers true to (F x x), then - - using a stable sorting or merging algorithm will not give you a - stable sort or merge, - - LIST-SORTED? may surprise you, and - - quicksort may fail in a variety of possible ways. -Note that you can synthesize a < function from a <= function with - (lambda (x y) (not (<= y x))) -if need be. - -Precise definitions give sharp edges to tools, but require care in use. -"Measure twice, cut once." - -I have adopted the choice of < from Common Lisp. One would assume the definers -of Common Lisp had a good reason for adopting < instead of <=, but canvassing -several of the principal actors in the definition process has turned up no -better reason than "an arbitrary but consistent choice." At minimum, then, -this SRFI extends the coverage of that consistent choice. - -** All vector operations accept optional subrange parameters -============================================================ -The vector operations specified below all take optional START/END arguments -indicating a selected subrange of a vector's elements. If a START parameter or -START/END parameter pair is given to such a procedure, they must be exact, -non-negative integers, such that - 0 <= START <= END <= (VECTOR-LENGTH V) -where V is the related vector parameter. If not specified, they default to 0 -and the length of the vector, respectively. They are interpreted to select the -range [START,END), that is, all elements from index START (inclusive) up to, -but not including, index END. - -** Required vs. allowed side-effects -==================================== -LIST-SORT! and LIST-STABLE-SORT! are allowed, but not required, -to alter their arguments' cons cells to construct the result list. This is -consistent with the what-not-how character of the group of procedures -to which they belong (the "sort-lib" package). - -The LIST-DELETE-NEIGHBOR-DUPS!, LIST-MERGE! and LIST-MERGE-SORT! procedures, -on the other hand, provide specific algorithms, and, as such, explicitly -commit to the use of side-effects on their input lists in order to guarantee -their key algorithmic properties (e.g., linear-time operation, constant-space -stack use). - -------------------------------------------------------------------------------- -* Procedure specification -------------------------- -The procedures are split into several packages. In a Scheme system that has a -module or package system, these procedures should be contained in modules -named as follows: - Package name Functionality - ------------ ------------- - sort-lib General sorting for lists & vectors - sorted?-lib Sorted predicates for lists & vectors - list-merge-sort-lib List merge sort - vector-merge-sort-lib Vector merge sort - vector-heap-sort-lib Vector heap sort - vector-quick-sort-lib Vector quick sort - vector-insert-sort-lib Vector insertion sort - delndup-lib List and vector delete neighbor duplicates - binsearch-lib Vector binary search - -A Scheme system without a module system should provide all of the bindings -defined in all of these modules as components of the "SRFI-32" package. - -Note that there is no "list insert sort" package, as you might as well always -use list merge sort. The reference implementation's destructive list merge -sort will do fewer SET-CDR!s than a destructive insert sort. - -** Procedure naming and functionality -===================================== -Almost all of the procedures described below are variants of two basic -operations: sorting and merging. These procedures are consistently named -by composing a set of basic lexemes to indicate what they do. - -Lexeme Meaning ------- ------- -"sort" The procedure sorts its input data set by some < comparison function. - -"merge" The procedure merges two ordered data sets into a single ordered - result. - -"stable" This lexeme indicates that the sort is a stable one. - -"vector" The procedure operates upon vectors. - -"list" The procedure operates upon lists. - -"!" Procedures that end in "!" are allowed, and sometimes required, - to reuse their input storage to construct their answer. - -** Types of parameters and return values -======================================== -In the procedures specified below, - - A LIS parameter is a list; - - - A V parameter is a vector; - - - A < or = parameter is a procedure accepting two arguments taken from the - specified procedure's data set(s), and returning a boolean; - - - START and END parameters are exact, non-negative integers that - serve as vector indices selecting a subrange of some associated vector. - When specified, they must satisfy the relation - 0 <= start <= end <= (vector-length v) - where V is the associated vector. - -Passing values to procedures with these parameters that do not satisfy these -types is an error. - -If a procedure is said to return "unspecified," this means that nothing at all -is said about what the procedure returns, not even the number of return -values. Such a procedure is not even required to be consistent from call to -call in the nature or number of its return values. It is simply required to -return a value (or values) that may be passed to a command continuation, e.g. -as the value of an expression appearing as a non-terminal subform of a BEGIN -expression. Note that in R5RS, this restricts such a procedure to returning a -single value; non-R5RS systems may not even provide this restriction. - -** sort-lib - general sorting package -===================================== -This library provides basic sorting and merging functionality suitable for -general programming. The procedures are named by their semantic properties, -i.e., what they do to the data (sort, stable sort, merge, and so forth). - - Procedure Suggested algorithm - ------------------------------------------------------------------------- - list-sorted? < lis -> boolean - list-merge < lis1 lis2 -> list - list-merge! < lis1 lis2 -> list - list-sort < lis -> list (vector heap or quick) - list-sort! < lis -> list (list merge sort) - list-stable-sort < lis -> list (vector merge sort) - list-stable-sort! < lis -> list (list merge sort) - list-delete-neighbor-dups = lis -> list - list-delete-neighbor-dups! = lis -> list - - vector-sorted? < v [start end] -> boolean - vector-merge < v1 v2 [start1 end1 start2 end2] -> vector - vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecified - vector-sort < v [start end] -> vector (heap or quick sort) - vector-sort! < v [start end] -> unspecified (heap or quick sort) - vector-stable-sort < v [start end] -> vector (vector merge sort) - vector-stable-sort! < v [start end] -> unspecified (vector merge sort) - vector-delete-neighbor-dups = v [start end] -> vector - vector-delete-neighbor-dups! = target source [t-start s-start s-end] -> t-end - - LIST-SORTED? and VECTOR-SORTED? return true if their input list or vector - is in sorted order, as determined by their < comparison parameter. - - All four merge operations are stable: an element of the initial list LIS1 - or vector V1 will come before an equal-comparing element in the second - list LIS2 or vector V2 in the result. - - The procedures - LIST-MERGE - LIST-SORT - LIST-STABLE-SORT - LIST-DELETE-NEIGHBOR-DUPS - do not alter their inputs and are allowed to return a value that shares - a common tail with a list argument. - - The procedures - LIST-SORT! - LIST-STABLE-SORT! - are "linear update" operators -- they are allowed, but not required, to - alter the cons cells of their arguments to produce their results. - - On the other hand, the procedures - LIST-DELETE-NEIGHBOR-DUPS! - LIST-MERGE! - make only a single, iterative, linear-time pass over their argument lists, - using SET-CDR!s to rearrange the cells of the lists into the final result - -- they work "in place." Hence, any cons cell appearing in the result must - have originally appeared in an input. The intent of this - iterative-algorithm commitment is to allow the programmer to be sure that - if, for example, LIST-MERGE! is asked to merge two ten-million-element - lists, the operation will complete without performing some extremely - (possibly twenty-million) deep recursion. - - The vector procedures - VECTOR-SORT - VECTOR-STABLE-SORT - VECTOR-DELETE-NEIGHBOR-DUPS - do not alter their inputs, but allocate a fresh vector for their result, - of length END - START. - - The vector procedures - VECTOR-SORT! - VECTOR-STABLE-SORT! - sort their data in-place. (But note that VECTOR-STABLE-SORT! may - allocate temporary storage proportional to the size of the input -- - I am not aware of O(n lg n) stable vector-sorting algorithms that - run in constant space.) - - VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). - - VECTOR-MERGE! writes its result into vector V, beginning at index START, - for indices less than END = START + (END1-START1) + (END2-START2). The - target subvector - V[start,end) - may not overlap either source subvector - V1[start1,end1) - V2[start2,end2). - - The ...-DELETE-NEIGHBOR-DUPS-... procedures: - These procedures delete adjacent duplicate elements from a list or a - vector, using a given element-equality procedure. The first/leftmost - element of a run of equal elements is the one that survives. The list or - vector is not otherwise disordered. - - These procedures are linear time -- much faster than the O(n^2) general - duplicate-element deletors that do not assume any "bunching" of elements - (such as the ones provided by SRFI-1). If you want to delete duplicate - elements from a large list or vector, you can sort the elements to bring - equal items together, then use one of these procedures, for a total time - of O(n lg n). - - The comparison function = passed to these procedures is always applied - (= x y) - where X comes before Y in the containing list or vector. - - - LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer - may share storage with the input list. - - - VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but - rather allocates a fresh vector to hold the result. - - - LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to - mutate its input list in order to construct its answer. - - - VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the - answer, packing its answer into the index range [start,end'), where - END' is the non-negative exact integer returned as its value. It - returns END' as its result. The vector is not altered outside the range - [start,end'). - - - VECTOR-DELETE-NEIGHBOR-DUPS! scans vector SOURCE in range - [S-START,S-END), writing its result to vector TARGET beginning at index - T-START. It returns exact, non-negative integer T-END, which indicates - that the results of the operation are found in index range - [T-START,T-END) of TARGET; elements of TARGET outside this range - are unaltered. - - It is an error for memory cell TARGET[T-START] to be a memory cell in - the region SOURCE[1 + S-START, S-END). In a Scheme implementation - that does not allow distinct vectors to share storage, this means - that one of the following must be true: - 1. (not (eq? source target)) - 2. t-start not-in [s-start + 1, s-end) - - - Examples: - (list-delete-neighbor-dups = '(1 1 2 7 7 7 0 -2 -2)) - => (1 2 7 0 -2) - - (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2)) - => #(1 2 7 0 -2) - - (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2) 3 7) - => #(7 0 -2) - - ;; Result left in v[3,9): - (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) - (cons (vector-delete-neighbor-dups! = v 3) - v)) - => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) - - -** Algorithm-specific sorting packages -====================================== -These packages provide more specific sorting functionality, that is, -specific commitment to particular algorithms that have particular -pragmatic consequences (such as memory locality, asymptotic running time) -beyond their semantic behaviour (sorting, stable sorting, merging, etc.). -Programmers that need a particular algorithm can use one of these packages. - -sorted?-lib - sorted predicates - list-sorted? < lis -> boolean - vector-sorted? < v [start end] -> boolean - - Return #f iff there is an adjacent pair ... X Y ... in the input - list or vector such that Y < X. The optional START/END range - arguments restrict VECTOR-SORTED? to the indicated subvector. - -list-merge-sort-lib - list merge sort - list-merge-sort < lis -> list - list-merge-sort! < lis -> list - list-merge lis1 < lis2 -> list - list-merge! lis1 < lis2 -> list - - The sort procedures sort their data using a list merge sort, which is - stable. (The reference implementation is, additionally, a "natural" sort. - See below for the properties of this algorithm.) - - The ! procedures are destructive -- they use SET-CDR!s to rearrange the - cells of the lists into the proper order. As such, they do not allocate - any extra cons cells -- they are "in place" sorts. Additionally, - LIST-MERGE! is iterative -- it can operate on arguments of arbitrary size - with a constant number of stack frames. - - The merge operations are stable: an element of LIS1 will come before an - equal-comparing element in LIS2 in the result list. - -vector-merge-sort-lib - vector merge sort - vector-merge-sort < v [start end temp] -> vector - vector-merge-sort! < v [start end temp] -> unspecified - vector-merge < v1 v2 [start1 end1 start2 end2] -> vector - vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecified - - The sort procedures sort their data using vector merge sort, which is - stable. (The reference implementation is, additionally, a "natural" sort. - See below for the properties of this algorithm.) - - The optional START/END arguments provide for sorting of subranges, and - default to 0 and the length of the corresponding vector. - - Merge-sorting a vector requires the allocation of a temporary "scratch" - work vector for the duration of the sort. This scratch vector can be - passed in by the client as the optional TEMP argument; if so, the supplied - vector must be of size >= END, and will not be altered outside the range - [start,end). If not supplied, the sort routines allocate one themselves. - - The merge operations are stable: an element of V1 will come before an - equal-comparing element in V2 in the result vector. - - VECTOR-MERGE-SORT! leaves its result in V[start,end). - - VECTOR-MERGE-SORT returns a vector of length END-START. - - VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). - - VECTOR-MERGE! writes its result into vector V, beginning at index START, - for indices less than END = START + (END1-START1) + (END2-START2). The - target subvector - V[start,end) - may not overlap either source subvector - V1[start1,end1) - V2[start2,end2). - -vector-heap-sort-lib - vector heap sort - heap-sort < v [start end] -> vector - heap-sort! < v [start end] -> unspecified - - These procedures sort their data using heap sort, - which is not a stable sorting algorithm. - - HEAP-SORT returns a vector of length END-START. - HEAP-SORT! is in-place, leaving its result in V[start,end). - -vector-quick-sort-lib - vector quick sort - quick-sort < v [start end] -> vector - quick-sort! < v [start end] -> unspecified - quick-sort3! c v [start end] -> unspecified - - These procedures sort their data using quick sort, - which is not a stable sorting algorithm. - - QUICK-SORT returns a vector of length END-START. - QUICK-SORT! is in-place, leaving its result in V[start,end). - - QUICK-SORT3! is a variant of quick-sort that takes a three-way - comparison function C. C compares a pair of elements and returns - an exact integer whose sign indicates their relationship: - (c x y) < 0 => x x=y - (c x y) > 0 => x>y - To help remember the relationship between the sign of the result and - the relation, use the function - as the model for C: (- x y) < 0 - means that x < y; (- x y) > 0 means that x > y. - - The extra discrimination provided by the three-way comparison can - provide significant speedups when sorting data sets with many duplicates, - especially when the comparison function is relatively expensive (e.g., - comparing long strings). - - WARNING: Some sort algorithms, such as insertion sort or heap sort, - can tolerate being passed a <= comparison function when they expect a < - function -- insertion and merge sort may simply invert stability; and - heap sort will run a bit slower, but otherwise produce a correct answer. - - Quicksort, however, is much more critically sensitive to the distinction - between a < and a <= comparison. If QUICK-SORT or QUICK-SORT! expect a < - comparison function, and are erroneously given a <= function, they may, - depending on implementation, produce an unsorted result, go into an - infinite loop, cause a run-time error, occasionally produce a correct - result, or do some fifth thing. - - Implementors may wish to write QUICKSORT3! so that it (a) tests the - comparison function (by checking that (c v[start] v[start]) produces - false), or (b) is tolerant of an erroneous <= function, or (c) both. - Clients of this function, however, should not count on this. - -vector-insert-sort-lib - vector insertion sort - insert-sort < v [start end] -> vector - insert-sort! < v [start end] -> unspecified - - These procedures stably sort their data using insertion sort. - - INSERT-SORT returns a vector of length END-START. - INSERT-SORT! is in-place, leaving its result in V[start,end). - -delndup-lib - list and vector delete neighbor duplicates - list-delete-neighbor-dups = lis -> list - list-delete-neighbor-dups! = lis -> list - - vector-delete-neighbor-dups = v [start end] -> vector - vector-delete-neighbor-dups! = v [start end] -> end' - - These procedures delete adjacent duplicate elements from a list or - a vector, using a given element-equality procedure =. The first/leftmost - element of a run of equal elements is the one that survives. The list - or vector is not otherwise disordered. - - These procedures are linear time -- much faster than the O(n^2) general - duplicate-element deletors that do not assume any "bunching" of elements - (such as the ones provided by SRFI-1). If you want to delete duplicate - elements from a large list or vector, you can sort the elements to bring - equal items together, then use one of these procedures, for a total time - of O(n lg n). - - The comparison function = passed to these procedures is always applied - (= x y) - where X comes before Y in the containing list or vector. - - LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer - may share storage with the input list. - - VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but - rather allocates a fresh vector to hold the result. - - LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to - mutate its input list in order to construct its answer. - - VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the - answer, packing its answer into the index range [start,end'), where - END' is the non-negative exact integer returned as its value. It - returns END' as its result. The vector is not altered outside the range - [start,end'). - - Examples: - (list-delete-neighbor-dups = '(1 1 2 7 7 7 0 -2 -2)) - => (1 2 7 0 -2) - - (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2)) - => #(1 2 7 0 -2) - - (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2) 3 7) - => #(7 0 -2) - - ;; Result left in v[3,9): - (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) - (cons (vector-delete-neighbor-dups! = v 3) - v)) - => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) - -binsearch-lib - vector binary search lib - vector-binary-search elt< elt->key key v [start end] -> integer-or-false - vector-binary-search3 c v [start end] -> integer-or-false - - VECTOR-BINARY-SEARCH searches vector V in range [START,END) (which - default to 0 and the length of V, respectively) for an element whose - associated key is equal to KEY. The procedure ELT->KEY is used to map - an element to its associated key. The elements of the vector are assumed - to be ordered by the ELT< relation on these keys. That is, - (vector-sorted? (lambda (x y) (elt< (elt->key x) (elt->key y))) - v start end) => true - An element E of V is a match for KEY if it's neither less nor greater - than the key: - (and (not (elt< (elt->key e) key)) - (not (elt< key (elt->key e)))) - If there is such an element, the procedure returns its index in the - vector as an exact integer. If there is no such element in the searched - range, the procedure returns false. - - (vector-binary-search < car 4 '#((1 . one) (3 . three) - (4 . four) (25 . twenty-five))) - => 2 - - (vector-binary-search < car 7 '#((1 . one) (3 . three) - (4 . four) (25 . twenty-five))) - => #f - - VECTOR-BINARY-SEARCH3 is a variant that uses a three-way comparison - function C. C compares its parameter to the search key, and returns an - exact integer whose sign indicates its relationship to the search key. - (c x) < 0 => x < search-key - (c x) = 0 => x = search-key - (c x) > 0 => x > search-key - - (vector-binary-search3 (lambda (elt) (- (car elt) 4)) - '#((1 . one) (3 . three) - (4 . four) (25 . twenty-five))) - => 2 - - Rationale: - - Why isn't VECTOR-BINARY-SEARCH's ELT->KEY computation simply absorbed - into the < function? It is separated out because the < function is - applied twice inside the binary-search inner loop, once with the search - key for the first argument and the element key for the second argument, - and once, with the reverse argument order. This is not necessary for - VECTOR-BINARY-SEARCH3. - - - When a comparison operation is able to produce a three-way - discrimination, the inner loop of the binary search can trim the number - of per-iteration comparisons from an average of 1.5 to a guaranteed - single comparison per iteration. This can be a significant savings when - searching with an expensive comparison operation (e.g., one that - uses string compare, sends email, references a database, or queries - a network service such as a web server). - - - Failure is signaled by false (rather than, say, -1) so that searches - can be used in conditional forms such as - (or (vector-binary-search ...) ...) - or - (cond ((vector-binary-search ...) => index-consumer) - ...) - -------------------------------------------------------------------------------- -* Algorithmic properties ------------------------- -Different sort and merge algorithms have different properties. -Choose the algorithm that matches your needs: - -Vector insert sort - Stable, but only suitable for small vectors -- O(n^2). - -Vector quick sort - Not stable. Is fast on average -- O(n lg n) -- but has bad worst-case - behaviour. Has good memory locality for big vectors (unlike heap sort). - A clever pivot-picking trick (median of three samples) helps avoid - worst-case behaviour, but pathological cases can still blow up. - -Vector heap sort - Not stable. Guaranteed fast -- O(n lg n) *worst* case. Poor locality - on large vectors. A very reliable workhorse. - -Vector merge sort - Stable. Not in-place -- requires a temporary buffer of equal size. - Fast -- O(n lg n) -- and has good memory locality for large vectors. - - The implementation of vector merge sort provided by this SRFI's reference - implementation is, additionally, a "natural" sort, meaning that it - exploits existing order in the input data, providing O(n) best case. - -Destructive list merge sort - Stable, fast and in-place (i.e., allocates no new cons cells). "Fast" - means O(n lg n) worse-case, and substantially better if the data - is already mostly ordered, all the way down to linear time for - a completely-ordered input list (i.e., it is a "natural" sort). - - Note that sorting lists involves chasing pointers through memory, which - can be a loser on modern machine architectures because of poor cache & - page locality. Pointer *writing*, which is what the SET-CDR!s of a - destructive list-sort algorithm do, is even worse, especially if your - Scheme has a generational GC -- the writes will thrash the write-barrier. - Sorting vectors has inherently better locality. - - This SRFI's destructive list merge and merge sort implementations are - opportunistic -- they avoid redundant SET-CDR!s, and try to take long - already-ordered runs of list structure as-is when doing the merges. - -Pure list merge sort - Stable and fast -- O(n lg n) worst-case, and possibly O(n), depending - upon the input list (see discussion above). - - -Algorithm Stable? Worst case Average case In-place ------------------------------------------------------- -Vector insert Yes O(n^2) O(n^2) Yes -Vector quick No O(n^2) O(n lg n) Yes -Vector heap No O(n lg n) O(n lg n) Yes -Vector merge Yes O(n lg n) O(n lg n) No -List merge Yes O(n lg n) O(n lg n) Either - - -------------------------------------------------------------------------------- -* Porting and optimisation --------------------------- -This package should be trivial to port. There are only four non-R4RS bits -in the code: -- Use of multiple-value return, with the R5RS VALUES procedure, and the - simple (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro - of SRFI-8. - -- A VECTOR-COPY procedure. This is a tiny little procedure: - (vector-copy v [start end]) - -- Use of the LET-OPTIONALS macro from scsh to parse and default optional - arguments to three routines. Again, easy to port the macro or rewrite - the code to parse, default, and error check the args by hand. - -- Calls to an ERROR function for complaining about bad arguments. - -This code is tightly bummed, as far as I can go in portable Scheme. - -You could speed up the vector code a lot by error-checking the procedure -parameters and then shifting over to fixnum-specific arithmetic and dangerous -vector-indexing and vector-setting primitives. The comments in the code -indicate where the initial error checks would have to be added. There are -several (QUOTIENT N 2)'s that could be changed to a fixnum right-shift, as -well, in both the list and vector code (SRFI 33 provides such an operator). -The code is designed to enable this -- each file usually exports one or two -"safe" procedures that end up calling an internal "dangerous" primitive. The -little exported cover procedures are where you move the error checks. - -This should provide *big* speedups. In fact, all the code bumming I've done -pretty much disappears in the noise unless you have a good compiler and also -can dump the vector-index checks and generic arithmetic -- so I've really just -set things up for you to exploit. - -The optional-arg parsing, defaulting, and error checking is done with a -portable R4RS macro. But if your Scheme has a faster mechanism (e.g., Chez), -you should definitely port over to it. Note that argument defaulting and -error-checking are interleaved -- you don't have to error-check defaulted -START/END args to see if they are fixnums that are legal vector indices for -the corresponding vector, etc. - - -------------------------------------------------------------------------------- -* References & Links --------------------- - -This document, in HTML: - http://srfi.schemers.org/srfi-32/srfi-32.html - [This link may not be valid while the SRFI is in draft form.] - -This document, in simple text format: - http://srfi.schemers.org/srfi-32/srfi-32.txt - -Archive of SRFI-32 discussion-list email: - http://srfi.schemers.org/srfi-32/mail-archive/maillist.html - -SRFI web site: - http://srfi.schemers.org/ - -[CommonLisp] - Common Lisp: the Language - Guy L. Steele Jr. (editor). - Digital Press, Maynard, Mass., second edition 1990. - Available at http://www.elwood.com/alu/table/references.htm#cltl2 - - The Common Lisp "HyperSpec," produced by Kent Pitman, is essentially - the ANSI spec for Common Lisp: - http://www.xanalys.com/software_tools/reference/HyperSpec/ - -[R5RS] - Revised^5 Report on the Algorithmic Language Scheme, - R. Kelsey, W. Clinger, J. Rees (editors). - Higher-Order and Symbolic Computation, Vol. 11, No. 1, September, 1998. - and ACM SIGPLAN Notices, Vol. 33, No. 9, October, 1998. - - Available at http://www.schemers.org/Documents/Standards/ - - -------------------------------------------------------------------------------- -* Acknowledgements ------------------- - -I thank the authors of the open source I consulted when designing this -library, particularly Richard O'Keefe, Donovan Kolby and the MIT Scheme Team. - - -------------------------------------------------------------------------------- -* Copyright ------------ - -** SRFI text -============ -This document is copyright (C) Olin Shivers (1998, 1999). -All Rights Reserved. - -This document and translations of it may be copied and furnished to others, -and derivative works that comment on or otherwise explain it or assist in its -implementation may be prepared, copied, published and distributed, in whole or -in part, without restriction of any kind, provided that the above copyright -notice and this paragraph are included on all such copies and derivative -works. However, this document itself may not be modified in any way, such as -by removing the copyright notice or references to the Scheme Request For -Implementation process or editors, except as needed for the purpose of -developing SRFIs in which case the procedures for copyrights defined in the -SRFI process must be followed, or as required to translate it into languages -other than English. - -The limited permissions granted above are perpetual and will not be revoked by -the authors or their successors or assigns. - -This document and the information contained herein is provided on an "AS IS" -basis and THE AUTHORS AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE -INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF -MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. - -** Reference implementation -=========================== -Short summary: no restrictions. - -While I wrote all of this code myself, I read a lot of code before I began -writing. However, all such code is, itself, either open source or public -domain, rendering irrelevant any issue of "copyright taint." - -The natural merge sorts (pure list, destructive list, and vector) are not only -my own code, but are implementations of an algorithm of my own devising. They -run in O(n lg n) worst case, O(n) best case, and require only a logarithmic -number of stack frames. And they are stable. And the destructive-list variant -allocates zero cons cells; it simply rearranges the cells of the input list. - -Hence the reference implementation is - Copyright (c) 1998 by Olin Shivers. -and made available under the same copyright as the SRFI text (see above). diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/32/srfi-32.txt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/32/srfi-32.txt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/32/srfi-32.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/32/srfi-32.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,938 @@ +The SRFI-32 sort libraries -*- outline -*- +Olin Shivers +First draft: 1998/10/19 +Last update: 2002/7/21 + +Emacs should display this document in outline mode. Say c-h m for +instructions on how to move through it by sections (e.g., c-c c-n, c-c c-p). + +* Table of contents +------------------- +Abstract +Procedure index +Introduction +What's wrong with the current state of affairs? +Design rules + What vs. how + Consistency across function signatures + Data parameter first, less-than parameter after + Ordering, comparison functions & stability + All vector operations accept optional subrange parameters + Required vs. allowed side-effects +Procedure specification + Procedure naming and functionality + Types of parameters and return values + sort-lib - general sorting package + Algorithm-specific sorting packages +Algorithmic properties +Topics to be resolved during discussion phase +Porting and optimisation +References & Links +Acknowledgements +Copyright + + +* Abstract +---------- +Current Scheme sorting packages are, every one of them, surprisingly bad. I've +designed the API for a full-featured sort toolkit, which I propose as an SRFI. +The spec comes with 1200 lines of high-quality reference code: tightly +written, highly commented, portable code, available for free. Implementors +want this code. It's better than what you have. + +------------------------------------------------------------------------------- +* Procedure index +----------------- +list-sorted? vector-sorted? + +list-merge vector-merge +list-sort vector-sort +list-stable-sort vector-stable-sort +list-delete-neighbor-dups vector-delete-neighbor-dups + +list-merge! vector-merge! +list-sort! vector-sort! +list-stable-sort! vector-stable-sort! +list-delete-neighbor-dups! vector-delete-neighbor-dups! + +heap-sort quick-sort insert-sort list-merge-sort vector-merge-sort +heap-sort! quick-sort! insert-sort! list-merge-sort! vector-merge-sort! + +------------------------------------------------------------------------------- +* Introduction +-------------- +As I'll detail bewlow, I wasn't very happy with the state of the Scheme +world for sorting and merging lists and vectors. So I have designed and +written a fairly comprehensive sorting & merging toolkit. It is + + - very portable, + + - much better code than what is currently in Elk, Gambit, Bigloo, + Scheme->C, MzScheme, RScheme, Scheme48, MIT Scheme, or slib, and + + - priced to move: free code. + +The package includes + - Vector insert sort (stable) + - Vector heap sort + - Vector quick sort (with median-of-3 pivot picking) + - Vector merge sort (stable) + - Pure and destructive list merge sort (stable) + - Stable vector and list merge + - Miscellaneous sort-related procedures: Vector and list merging, + sorted? predicates, vector binary search, vector and list + delete-equal-neighbor procedures. + - A general, non-algorithmic set of procedure names for general sorting + and merging. + +Scheme programmers may want to adopt this package. I'd like Scheme +implementors to adopt this code and its API -- in fact, the code is a bribe to +make it easy for implementors to converge on the suggested API. I mean, you'd +really have to be a boor to take this free code I wrote and mutate its +interface over to your incompatible, unportable API, wouldn't you? But you +could, of course -- it's freely available. More in the spirit of the offering, +you could make this API available, and then also write a little module +providing your old interface that is defined in terms of this API. "Scheme +implementors," in this context, includes slib, which isn't really a standalone +implementation of Scheme, but is an influential collection of API's and code. + +The code is tightly bummed. It is clearly written, and commented in my usual +voluminous style. This includes notes on porting and implementation-specific +optimisations. + + +------------------------------------------------------------------------------- +* What's wrong with the current state of affairs? +------------------------------------------------- + +It's just amazing to me that in 2002, sorting and merging hasn't been +completely put to bed. These are well-understood algorithms, each of them well +under a page of code. The straightforward algorithms are basic, core stuff -- +sophomore-level. But if you tour the major Scheme implementations out there on +the Net, you find badly written code that provides extremely spotty coverage +of the algorithm space. One implementation even has a buggy implementation +that has been in use for about 20 years! + +Open source-code is a wonderful thing. In a couple of hours, I was able to +download and check the sources of 9 Scheme systems. Here are my notes from the +systems I checked. You can skip to the next section if you aren't morbidly +curious. + +slib + sorted? vector-or-list < + merge list1 list2 < + merge! list1 list2 < + sort vector-or-list < + sort! vector-or-list < + + Richard O'Keefe's stable list merge sort is right idea, but implemented + using gratuitous variable side effects. It also does redundant SET-CDR!s. + The vector sort converts to list, merge sorts, then reconverts + to vector. This is a bad idea -- non-local pointer chasing bad; vector + shuffling good. + +MIT Scheme + sort! vector < + merge-sort! vector < + quick-sort! vector < + + sort vector-or-list < + merge-sort vector-or-list < + quick-sort vector-or-list < + + Naive vector quicksort: loser, for worst-case performance reasons. + List sort by "list->vector; quicksort; vector->list," hence also loser. + A clever stable vector merge sort, albeit not very bummed. + +Scheme 48 & T + sort-list list < + sort-list! list < + list-merge! list1 list2 < + + Bob Nix's implementation of online merge-sort, written in the early 80's. + Conses unnecessary bookkeeping structure, which isn't necessary with a + proper recursive formulation. Also, does redundant SET-CDR!s. No vector + sort. Also, has a bug -- is claimed to be a stable sort, but isn't! To see + this, get the S48 code, and try + (define (my< x y) (< (quotient x 2) (quotient y 2))) + (list-merge! (list 0 2) (list 3) my<) ; -> (0 2 3) + (list-merge! (list 2) (list 0 3) my<) ; -> (0 3 2) + This could be fixed very easily, but it isn't worth it given the + other problems with the algorithm. + +RScheme + vector-sort! vector < + sort collection < + + Good basic implementation of vector heapsort, which has O(n lg n) + worst-case time. Code ugly, needs tuning. List sort by "list->vector; + sort; vector->list", which allocates unneeded temp storage. Nothing + for stable sorting. + +MzScheme + Naive quicksort -- but not available for vector sorting, even + though it internally uses a vector. Nothing for stable sorting, + and naive quicksort has bad worst-case behaviour. + +Bigloo, Scheme->C + Couldn't find anything -- but maybe I didn't search for the right + thing, since the Bigloo names are French. (I invite correction from + the Bigloo implementors.) + +Gambit + sort-list list < + Nothing for vectors. Simple, slow, unstable merge sort for lists. + +Elk + Another naive quicksort. Lists handled by converting to vector. + sort vector-or-list < + sort! vector-or-list < + +Chez Scheme + merge < list1 list2 + merge! < list1 list2 + sort < list + sort! < list + + These are stable. I have not seen the source code. + +Common Lisp + sort sequence < [key] + stable-sort sequence < [key] + merge result-type sequence1 sequence2 < [key] + + The sort procedures are allowed, but not required, to be destructive. + +SML/NJ + sort: ('a*'a -> bool) -> 'a list -> 'a list + "Smooth applicative merge sort," which is stable. + There is also a highly bummed quicksort for vectors. + +The right solution: Implement a full toolbox of carefully written standard sort +routines. + +Having the source available for all of these above-cited Schemes made +life a lot easier writing this code. I appreciate the authors making their +source available under such open terms. + + +------------------------------------------------------------------------------- +* Design rules +-------------- + +** What vs. how +=============== +There are two different interfaces: "what" (simple) & "how" (detailed). + + - Simple: you specify semantics: datatype (list or vector), + mutability, and stability. + + - Detailed: you specify the actual algorithm (quick, heap, + insert, merge). Different algorithms have different properties, + both semantic & pragmatic, so these exports are necessary. + + It is necessarily the case that the specifications of these procedures + make statements about execution "pragmatics." For example, the sole + distinction between heap sort and quick sort -- both of which are + provided by this library -- is one of execution time, which is not a + "semantic" distinction. Similar resource-use statements are made about + "iterative" procedures, meaning that they can execute on input of + arbitrary size without needing to allocate an unbounded number of stack + frames. + +** Consistency across function signatures +========================================= +The two interfaces share common function signatures wherever +possible, to facilitate switching a given call from one procedure +to another. + +** Data parameter first, less-than parameter after +================================================== +These procedures uniformly observe the following parameter order: +the data to be sorted come before the the comparison function. +That is, we write + (sort lis <) +not + (sort < lis). +This is consistent with every single implementation out there, with +the sole exception of Chez Scheme. + +In my opinion, it would be more consistent with other Scheme libraries +to put the ordering function first -- the "operation currying" convention. +(E.g., consider FOR-EACH or MAP or FIND.) I decided to leave things as they +are in favor of near-total backwards compatibility with existing practice. + +[Perhaps this should be discussed.] + +** Ordering, comparison functions & stability +============================================= +These routines take a < comparison function, not a <= comparison +function, and they sort into increasing order. The difference between +a < spec and a <= spec comes up in two places: + - the definition of an ordered or sorted data set, and + - the definition of a stable sorting algorithm. + ++ We say that a data set (a list or vector) is *sorted* or *ordered* + if it contains no adjacent pair of values ... X Y ... such that Y < X. + + In other words, scanning across the data never takes a "downwards" step. + + If you use a <= procedure where these algorithms expect a < + procedure, you may not get the answers you expect. For example, + the LIST-SORTED? function will return false if you pass it a <= comparison + function and an ordered list containing adjacent equal elements. + ++ A "stable" sort is one that preserves the pre-existing order of equal + elements. Suppose, for example, that we sort a list of numbers by + comparing their absolute values, i.e., using comparison function + (lambda (x y) (< (abs x) (abs y))) + If we sort a list that contains both 3 and -3: + ... 3 ... -3 ... + then a stable sort is an algorithm that will not swap the order + of these two elements, that is, the answer will look like + ... 3 -3 ... + not + ... -3 3 ... + + Choosing < for the comparison function instead of <= affects how stability + is coded. Given an adjacent pair X Y, (< y x) means "Y should be moved in + front of X" -- otherwise, leave things as they are. So using a <= function + where a < function is expected will *invert* stability. + + This is due to the definition of equality, given a < comparator: + (and (not (< x y)) + (not (< y x))) + The definition is rather different, given a <= comparator: + (and (<= x y) + (<= x y)) + ++ A "stable" merge is one that reliably favors one of its data sets + when equal items appear in both data sets. *All merge operations in + this library are stable*, breaking ties between data sets in favor + of the first data set -- elements of the first list come before equal + elements in the second list. + + So, if we are merging two lists of numbers ordered by absolute value + using the stable merge operation LIST-MERGE + (list-merge '(0 -2 4 8 -10) '(-1 3 -4 7) + (lambda (x y) (< (abs x) (abs y)))) + reliably places the 4 of the first list before the equal-comparing -4 + of the second list: + (0 -1 -2 4 -4 7 8 -10) + +In short, if your comparison function F answers true to (F x x), then +using a stable sorting or merging algorithm will not give you a stable sort +or merge, and LIST-SORTED? may surprise you. Note that you can synthesize a < +function from a <= function with + (lambda (x y) (not (<= y x))) +if need be. + +Precise definitions give sharp edges to tools, but require care +in use. "Measure twice, cut once." + +I have adopted the choice of < from Common Lisp. I assume they +had a good reason for adopting < instead of <=. I'd love to know +what this reason is; send me email if you can explain it, please. + +** All vector operations accept optional subrange parameters +============================================================ +The vector operations specified below all take optional START/END arguments +indicating a selected subrange of a vector's elements. If a START parameter or +START/END parameter pair is given to such a procedure, they must be exact, +non-negative integers, such that + 0 <= START <= END <= (VECTOR-LENGTH V) +where V is the related vector parameter. If not specified, they default to 0 +and the length of the vector, respectively. They are interpreted to select the +range [START,END), that is, all elements from index START (inclusive) up to, +but not including, index END. + +** Required vs. allowed side-effects +==================================== +LIST-SORT! and LIST-STABLE-SORT! are allowed, but not required, +to alter their arguments' cons cells to construct the result list. This is +consistent with the what-not-how character of the group of procedures +to which they belong (the "sort-lib" package). + +The LIST-DELETE-NEIGHBOR-DUPS!, LIST-MERGE! and LIST-MERGE-SORT! procedures, +on the other hand, provide specific algorithms, and, as such, explicitly +commit to the use of side-effects on their input lists in order to guarantee +their key algorithmic properties (e.g., linear-time operation, constant-space +stack use). + +------------------------------------------------------------------------------- +* Procedure specification +------------------------- +The procedures are split into several packages. In a Scheme system that has a +module or package system, these procedures should be contained in modules +named as follows: + Package name Functionality + ------------ ------------- + sort-lib General sorting for lists & vectors + sorted?-lib Sorted predicates for lists & vectors + list-merge-sort-lib List merge sort + vector-merge-sort-lib Vector merge sort + vector-heap-sort-lib Vector heap sort + vector-quick-sort-lib Vector quick sort + vector-insert-sort-lib Vector insertion sort + delndup-lib List and vector delete neighbor duplicates + +A Scheme system without a module system should provide all of the bindings +defined in all of these modules as components of the "SRFI-32" package. + +Note that there is no list insert sort package, as you might as well always +use list merge sort. The reference implementation's destructive list merge +sort will do fewer SET-CDR!s than a destructive insert sort. + +** Procedure naming and functionality +===================================== +Almost all of the procedures described below are variants of two basic +operations: sorting and merging. These procedures are consistently named +by composing a set of basic lexemes to indicate what they do. + +Lexeme Meaning +------ ------- +"sort" The procedure sorts its input data set by some < comparison function. + +"merge" The procedure merges two ordered data sets into a single ordered + result. + +"stable" This lexeme indicates that the sort is a stable one. + +"vector" The procedure operates upon vectors. + +"list" The procedure operates upon lists. + +"!" Procedures that end in "!" are allowed, and sometimes required, + to reuse their input storage to construct their answer. + +** Types of parameters and return values +======================================== +In the procedures specified below, + - A LIS parameter is a list; + + - A V parameter is a vector; + + - A < or = parameter is a procedure accepting two arguments taken from the + specified procedure's data set(s), and returning a boolean; + + - START and END parameters are exact, non-negative integers that + serve as vector indices selecting a subrange of some associated vector. + When specified, they must satisfy the relation + 0 <= start <= end <= (vector-length v) + where V is the associated vector. + +Passing values to procedures with these parameters that do not satisfy these +types is an error. + +If a procedure is said to return "unspecified," this means that nothing at all +is said about what the procedure returns, not even the number of return +values. Such a procedure is not even required to be consistent from call to +call in the nature or number of its return values. It is simply required to +return a value (or values) that may be passed to a command continuation, e.g. +as the value of an expression appearing as a non-terminal subform of a BEGIN +expression. Note that in R5RS, this restricts such a procedure to returning a +single value; non-R5RS systems may not even provide this restriction. + +** sort-lib - general sorting package +===================================== +This library provides basic sorting and merging functionality suitable for +general programming. The procedures are named by their semantic properties, +i.e., what they do to the data (sort, stable sort, merge, and so forth). + + Procedure Suggested algorithm + ------------------------------------------------------------------------- + list-sorted? lis < -> boolean + list-merge lis1 lis2 < -> list + list-merge! lis1 lis2 < -> list + list-sort lis < -> list (vector heap or quick) + list-sort! lis < -> list (list merge sort) + list-stable-sort lis < -> list (vector merge sort) + list-stable-sort! lis < -> list (list merge sort) + list-delete-neighbor-dups lis = -> list + list-delete-neighbor-dups! lis = -> list + + vector-sorted? v < [start end] -> boolean + vector-merge v1 v2 < [start1 end1 start2 end2] -> vector + vector-merge! v v1 v2 < [start start1 end1 start2 end2] -> unspecific + vector-sort v < [start end] -> vector (heap or quick sort) + vector-sort! v < [start end] -> unspecific (heap or quick sort) + vector-stable-sort v < [start end] -> vector (vector merge sort) + vector-stable-sort! v < [start end] -> unspecific (vector merge sort) + vector-delete-neighbor-dups v = [start end] -> vector + vector-delete-neighbor-dups! v = [start end] -> end' + + LIST-SORTED? and VECTOR-SORTED? return true if their input list or vector + is in sorted order, as determined by their < comparison parameter. + + All four merge operations are stable: an element of the initial list LIS1 + or vector V1 will come before an equal-comparing element in the second + list LIS2 or vector V2 in the result. + + The procedures + LIST-MERGE + LIST-SORT + LIST-STABLE-SORT + LIST-DELETE-NEIGHBOR-DUPS + do not alter their inputs and are allowed to return a value that shares + a common tail with a list argument. + + The procedures + LIST-SORT! + LIST-STABLE-SORT! + are "linear update" operators -- they are allowed, but not required, to + alter the cons cells of their arguments to produce their results. + + On the other hand, the procedures + LIST-DELETE-NEIGHBOR-DUPS! + LIST-MERGE! + make only a single, iterative, linear-time pass over their argument lists, + using SET-CDR!s to rearrange the cells of the lists into the final result + -- they work "in place." Hence, any cons cell appearing in the result must + have originally appeared in an input. The intent of this + iterative-algorithm commitment is to allow the programmer to be sure that + if, for example, LIST-MERGE! is asked to merge two ten-million-element + lists, the operation will complete without performing some extremely + (possibly twenty-million) deep recursion. + + The vector procedures + VECTOR-SORT + VECTOR-STABLE-SORT + VECTOR-DELETE-NEIGHBOR-DUPS + do not alter their inputs, but allocate a fresh vector for their result, + of length END-START. + + The vector procedures + VECTOR-SORT! + VECTOR-STABLE-SORT! + sort their data in-place. (But note that VECTOR-STABLE-SORT! may + allocate temporary storage proportional to the size of the input -- + I am not aware of O(n lg n) stable vector sorting algorithms that + run in constant space.) + + VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). + + VECTOR-MERGE! writes its result into vector V, beginning at index START0, + for indices less than END0 = START0 + (END1-START1) + (END2-START2). The + target subvector + V[start0,end0) + may not overlap either source subvector + V1[start1,end1) + V2[start2,end2). + + The DELETE-NEIGHBOR-DUP-... procedures: + These procedures delete adjacent duplicate elements from a list or a + vector, using a given element-equality procedure. The first/leftmost + element of a run of equal elements is the one that survives. The list or + vector is not otherwise disordered. + + These procedures are linear time -- much faster than the O(n^2) general + duplicate-element deletors that do not assume any "bunching" of elements + (such as the ones provided by SRFI-1). If you want to delete duplicate + elements from a large list or vector, sort the elements to bring equal + items together, then use one of these procedures, for a total time of + O(n lg n). + + The comparison function = passed to these procedures is always applied + (= x y) + where X comes before Y in the containing list or vector. + + - LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer + may share storage with the input list. + + - VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but + rather allocates a fresh vector to hold the result. + + - LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to + mutate its input list in order to construct its answer. + + - VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the + answer, packing its answer into the index range [start,end'), where + END' is the non-negative exact integer returned as its value. It + returns END' as its result. The vector is not altered outside the range + [start,end'). + + [Maybe this procedure should take a "target" vector to write?] + + - Examples: + (list-delete-neighbor-dups '(1 1 2 7 7 7 0 -2 -2) =) + => (1 2 7 0 -2) + + (vector-delete-neighbor-dups '#(1 1 2 7 7 7 0 -2 -2) =) + => #(1 2 7 0 -2) + + (vector-delete-neighbor-dups '#(1 1 2 7 7 7 0 -2 -2) = 3 7) + => #(7 0 -2) + + ;; Result left in v[3,9): + (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) + (cons (vector-delete-neighbor-dups! v = 3) + v)) + => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) + + +** Algorithm-specific sorting packages +====================================== +These packages provide more specific sorting functionality, that is, +specific committment to particular algorithms that have particular +pragmatic consequences (such as memory locality, asymptotic running time) +beyond their semantic behaviour (sorting, stable sorting, merging, etc.). +Programmers that need a particular algorithm can use one of these packages. + +sorted?-lib - sorted predicates + list-sorted? lis < -> boolean + vector-sorted? v < [start end] -> boolean + + Return #f iff there is an adjacent pair ... X Y ... in the input + list or vector such that Y < X. The optional START/END range + arguments restrict VECTOR-SORTED? to the indicated subvector. + +list-merge-sort-lib - list merge sort + list-merge-sort lis < -> list + list-merge-sort! lis < -> list + list-merge lis1 lis2 < -> list + list-merge! lis1 lis2 < -> list + + The sort procedures sort their data using a list merge sort, which is + stable. (The reference implementation is, additionally, a "natural" sort. + See below for the properties of this algorithm.) + + The ! procedures are destructive -- they use SET-CDR!s to rearrange the + cells of the lists into the proper order. As such, they do not allocate + any extra cons cells -- they are "in place" sorts. Additionally, + LIST-MERGE! is iterative, not recursive -- it can operate on arguments of + arbitrary size without requiring an unbounded amount of stack space. + + The merge operations are stable: an element of LIS1 will come before an + equal-comparing element in LIS2 in the result list. + +vector-merge-sort-lib - vector merge sort + vector-merge-sort v < [start end temp] -> vector + vector-merge-sort! v < [start end temp] -> unspecific + vector-merge v1 v2 < [start1 end1 start2 end2] -> vector + vector-merge! v v1 v2 < [start0 start1 end1 start2 end2] -> unspecific + + The sort procedures sort their data using vector merge sort, which is + stable. (The reference implementation is, additionally, a "natural" sort. + See below for the properties of this algorithm.) + + The optional START/END arguments provide for sorting of subranges, and + default to 0 and the length of the corresponding vector. + + Merge-sorting a vector requires the allocation of a temporary "scratch" + work vector for the duration of the sort. This scratch vector can be + passed in by the client as the optional TEMP argument; if so, the supplied + vector must be of size >= END, and will not be altered outside the range + [start,end). If not supplied, the sort routines allocate one themselves. + + The merge operations are stable: an element of V1 will come before an + equal-comparing element in V2 in the result vector. + + VECTOR-MERGE-SORT! leaves its result in V[start,end). + + VECTOR-MERGE-SORT returns a vector of length END-START. + + VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). + + VECTOR-MERGE! writes its result into vector V, beginning at index START0, + for indices less than END0 = START0 + (END1-START1) + (END2-START2). The + target subvector + V[start0,end0) + may not overlap either source subvector + V1[start1,end1) + V2[start2,end2). + +vector-heap-sort-lib - vector heap sort + heap-sort v < [start end] -> vector + heap-sort! v < [start end] -> unspecific + + These procedures sort their data using heap sort, + which is not a stable sorting algorithm. + + HEAP-SORT returns a vector of length END-START. + HEAP-SORT! is in-place, leaving its result in V[start,end). + +vector-quick-sort-lib - vector quick sort + quick-sort v < [start end] -> vector + quick-sort! v < [start end] -> unspecific + + These procedures sort their data using quick sort, + which is not a stable sorting algorithm. + + QUICK-SORT returns a vector of length END-START. + QUICK-SORT! is in-place, leaving its result in V[start,end). + +vector-insert-sort-lib - vector insertion sort + insert-sort v < [start end] -> vector + insert-sort! v < [start end] -> unspecific + + These procedures stably sort their data using insertion sort. + + INSERT-SORT returns a vector of length END-START. + INSERT-SORT! is in-place, leaving its result in V[start,end). + +delndup-lib - list and vector delete neighbor duplicates + list-delete-neighbor-dups lis = -> list + list-delete-neighbor-dups! lis = -> list + + vector-delete-neighbor-dups v = [start end] -> vector + vector-delete-neighbor-dups! v = [start end] -> end' + + These procedures delete adjacent duplicate elements from a list or + a vector, using a given element-equality procedure =. The first/leftmost + element of a run of equal elements is the one that survives. The list + or vector is not otherwise disordered. + + These procedures are linear time -- much faster than the O(n^2) general + duplicate-element deletors that do not assume any "bunching" of elements + (such as the ones provided by SRFI-1). If you want to delete duplicate + elements from a large list or vector, sort the elements to bring equal + items together, then use one of these procedures, for a total time of + O(n lg n). + + The comparison function = passed to these procedures is always applied + (= x y) + where X comes before Y in the containing list or vector. + + LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer + may share storage with the input list. + + VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but + rather allocates a fresh vector to hold the result. + + LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to + mutate its input list in order to construct its answer. + + VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the + answer, packing its answer into the index range [start,end'), where + END' is the non-negative exact integer returned as its value. It + returns END' as its result. The vector is not altered outside the range + [start,end'). + + Examples: + (list-delete-neighbor-dups '(1 1 2 7 7 7 0 -2 -2) =) + => (1 2 7 0 -2) + + (vector-delete-neighbor-dups '#(1 1 2 7 7 7 0 -2 -2) =) + => #(1 2 7 0 -2) + + (vector-delete-neighbor-dups '#(1 1 2 7 7 7 0 -2 -2) = 3 7) + => #(7 0 -2) + + ;; Result left in v[3,9): + (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) + (cons (vector-delete-neighbor-dups! v = 3) + v)) + => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) + + +------------------------------------------------------------------------------- +* Algorithmic properties +------------------------ +Different sort and merge algorithms have different properties. +Choose the algorithm that matches your needs: + +Vector insert sort + Stable, but only suitable for small vectors -- O(n^2). + +Vector quick sort + Not stable. Is fast on average -- O(n lg n) -- but has bad worst-case + behaviour. Has good memory locality for big vectors (unlike heap sort). + A clever pivot-picking trick (median of three samples) helps avoid + worst-case behaviour, but pathological cases can still blow up. + +Vector heap sort + Not stable. Guaranteed fast -- O(n lg n) *worst* case. Poor locality + on large vectors. A very reliable workhorse. + +Vector merge sort + Stable. Not in-place -- requires a temporary buffer of equal size. + Fast -- O(n lg n) -- and has good memory locality for large vectors. + + The implementation of vector merge sort provided by this SRFI's reference + implementation is, additionally, a "natural" sort, meaning that it + exploits existing order in the input data, providing O(n) best case. + +Destructive list merge sort + Stable, fast and in-place (i.e., allocates no new cons cells). "Fast" + means O(n lg n) worse-case, and substantially better if the data + is already mostly ordered, all the way down to linear time for + a completely-ordered input list (i.e., it is a "natural" sort). + + Note that sorting lists involves chasing pointers through memory, which + can be a loser on modern machine architectures because of poor cache & + page locality. Pointer *writing*, which is what the SET-CDR!s of a + destructive list-sort algorithm do, is even worse, especially if your + Scheme has a generational GC -- the writes will thrash the write-barrier. + Sorting vectors has inherently better locality. + + This SRFIs destructive list merge and merge sort implementations are + opportunistic -- they avoid redundant SET-CDR!s, and try to take long + already-ordered runs of list structure as-is when doing the merges. + +Pure list merge sort + Stable and fast -- O(n lg n) worst-case, and possibly better, depending + upon the input list (see above). + + +Algorithm Stable? Worst case Average case In-place +------------------------------------------------------ +V insert Yes O(n^2) O(n^2) Yes +V quick No O(n^2) O(n lg n) Yes +V heap No O(n lg n) O(n lg n) Yes +V merge Yes O(n lg n) O(n lg n) No +L merge Yes O(n lg n) O(n lg n) Either + + +------------------------------------------------------------------------------- +* Topics to be resolved during discussion phase +----------------------------------------------- +I particularly solicit comments about the following topics. + +- Include VECTOR-BINARY-SEARCH ? + Should we include + (VECTOR-BINARY-SEARCH v key< elt->key key [start end]) + in the SRFI? It sort of goes with sorting; it's exactly ten lines of code. + +- Comparison function before or after the list/vector argument? + Should it be + (list-sort < lis) + or + (list-sort lis <) + There is overwhelming consistency among the implementations: data first, + < after. Only Chez does it differently. + + I have done it in the backwards-compatible way. But I prefer the < first, + data after way. + + +------------------------------------------------------------------------------- +* Porting and optimisation +-------------------------- +This package should be trivial to port. There are only four non-R4RS bits +in the code: +- Use of multiple-value return, with the R5RS VALUES procedure, and the + simple (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro. + +- A VECTOR-COPY procedure. This is a tiny little procedure: + (vector-copy v [start end]) + +- Use of the LET-OPTIONALS macro from scsh to parse and default optional + arguments to three routines. Again, easy to port the macro or rewrite + the code to parse, default, and error check the args by hand. + +- Calls to an ERROR function for complaining about bad arguments. + +This code is tightly bummed, as far as I can go in portable Scheme. + +You could speed up the vector code a lot by error-checking the procedure +parameters and then shifting over to fixnum-specific arithmetic and +dangerous vector-indexing and vector-setting primitives. The comments +in the code indicate where the initial error checks would have to be +added. There are several (QUOTIENT N 2)'s that could be changed to a +fixnum right-shift, as well, in both the list and vector code. The code +is designed to enable this -- each file usually exports one or two "safe" +procedures that end up calling an internal "dangerous" primitive. The +little exported cover procedures are where you move the error checks. + +This should provide *big* speedups. In fact, all the code bumming I've done +pretty much disappears in the noise unless you have a good compiler and also +can dump the vector-index checks and generic arithmetic -- so I've really just +set things up for you to exploit. + +The optional-arg parsing, defaulting, and error checking is done with a +portable R4RS macro. But if your Scheme has a faster mechanism (e.g., Chez), +you should definitely port over to it. Note that argument defaulting and +error-checking are interleaved -- you don't have to error-check defaulted +START/END args to see if they are fixnums that are legal vector indices for +the corresponding vector, etc. + + +------------------------------------------------------------------------------- +* References & Links +-------------------- + +This document, in HTML: + http://srfi.schemers.org/srfi-32/srfi-32.html + [This link may not be valid while the SRFI is in draft form.] + +This document, in simple text format: + http://srfi.schemers.org/srfi-32/srfi-32.txt + +Archive of SRFI-32 discussion-list email: + http://srfi.schemers.org/srfi-32/mail-archive/maillist.html + +SRFI web site: + http://srfi.schemers.org/ + +[CommonLisp] + Common Lisp: the Language + Guy L. Steele Jr. (editor). + Digital Press, Maynard, Mass., second edition 1990. + Available at http://www.elwood.com/alu/table/references.htm#cltl2 + + The Common Lisp "HyperSpec," produced by Kent Pitman, is essentially + the ANSI spec for Common Lisp: + http://www.xanalys.com/software_tools/reference/HyperSpec/ + +[R5RS] + Revised^5 Report on the Algorithmic Language Scheme, + R. Kelsey, W. Clinger, J. Rees (editors). + Higher-Order and Symbolic Computation, Vol. 11, No. 1, September, 1998. + and ACM SIGPLAN Notices, Vol. 33, No. 9, October, 1998. + + Available at http://www.schemers.org/Documents/Standards/ + + +------------------------------------------------------------------------------- +* Acknowledgements +------------------ + +I thank the authors of the open source I consulted when designing this +library, particularly Richard O'Keefe, Donovan Kolby and the MIT Scheme Team. + + +------------------------------------------------------------------------------- +* Copyright +----------- + +** SRFI text +============ +This document is copyright (C) Olin Shivers (1998, 1999). +All Rights Reserved. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +** Reference implementation +=========================== +Short summary: no restrictions. + +While I wrote all of this code myself, I read a lot of code before I began +writing. However, all such code is, itself, either open source or public +domain, rendering irrelevant any issue of "copyright taint." + +The natural merge sorts (pure list, destructive list, and vector) are not only +my own code, but are implementations of an algorithm of my own devising. They +run in O(n lg n) worst case, O(n) best case, and require only a logarithmic +number of stack frames. And they are stable. And the destructive-list variant +allocates zero cons cells; it simply rearranges the cells of the input list. + +Hence the reference implementation is + Copyright (c) 1998 by Olin Shivers. +and made available under the same copyright as the SRFI text (see above). diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/%3a5/let.rkt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/%3a5/let.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/%3a5/let.rkt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/%3a5/let.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -#lang s-exp srfi/provider srfi/%3a5 diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/%3a5.rkt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/%3a5.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/%3a5.rkt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/%3a5.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -#lang s-exp srfi/provider srfi/5 - -;; FIXME: "rest arguments" need to generate mutable lists diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/5/let.rkt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/5/let.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/5/let.rkt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/5/let.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -;;; -;;; ---- SRFI 5 A compatible let form with signatures and rest arguments -;;; Time-stamp: <03/04/08 09:56:06 solsona> -;;; -;;; Usually, I would add a copyright notice, and the announce that -;;; this code is under the LGPL licence. Nevertheless, I only did the -;;; port to PLT Scheme v200, and here is the copyright notice, -;;; comments, and licence from the original source: -;;; -;;; Copyright (C) Andy Gaynor (1999-2003) -;;; -;;; The version of my-let here was cleaned up by: Paul Schlie . -;;; Renamed to s:let by Eli Barzilay - -#lang scheme/base -(provide s:let) - -(define-syntax s:let - (syntax-rules () - ;; standard - ((s:let () body ...) - (let () body ...)) - ((s:let ((var val) ...) body ...) - (let ((var val) ...) body ...)) - - ;; rest style - ((s:let ((var val) . bindings) body ...) - (let-loop #f bindings (var) (val) (body ...))) - - ;; signature style - ((s:let (name bindings ...) body ...) - (let-loop name (bindings ...) () () (body ...))) - - ;; standard named style - ((s:let name (bindings ...) body ...) - (let-loop name (bindings ...) () () (body ...))) - - )) - -;; A loop to walk down the list of bindings. - -(define-syntax let-loop - (syntax-rules () - - ;; No more bindings - make a LETREC. - ((let-loop name () (vars ...) (vals ...) body) - ((letrec ((name (lambda (vars ...) . body))) - name) - vals ...)) - - ;; Rest binding, no name - ((let-loop #f (rest-var rest-val ...) (var ...) (val ...) body) - (let ((var val) ... (rest-var (list rest-val ...))) . body)) - - ;; Process a (var val) pair. - ((let-loop name ((var val) more ...) (vars ...) (vals ...) body) - (let-loop name (more ...) (vars ... var) (vals ... val) body)) - - ;; End with a rest variable - make a LETREC. - ((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body) - ((letrec ((name (lambda (vars ... . rest-var) . body))) - name) - vals ... rest-vals ...)))) - -;; Four loops - normal and `signature-style', each with and without a rest -;; binding. -;; -;;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1)) -;; (if (= i n) -;; f0 -;; (fibonacci n (+ i 1) f1 (+ f0 f1)))) -;; -;;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1)) -;; (if (= i n) -;; f0 -;; (fibonacci n (+ i 1) f1 (+ f0 f1)))) -;; -;;(let fibonacci ((n 10) (i 0) . (f 0 1)) -;; (if (= i n) -;; (car f) -;; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f))))) -;; -;;(let (fibonacci (n 10) (i 0) . (f 0 1)) -;; (if (= i n) -;; (car f) -;; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f))))) diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/5.rkt racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/5.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lib/srfi/5.rkt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lib/srfi/5.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -;; module loader for SRFI-5 -#lang s-exp srfi/provider srfi/5/let #:unprefix s: diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lite-lib/info.rkt racket-7.0+ppa1/share/pkgs/srfi-lite-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lite-lib/info.rkt 2018-01-26 21:10:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lite-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation of the most widely used \"srfi\" libraries") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation of the most widely used \"srfi\" libraries") (define pkg-authors (quote (mflatt))))) Binary files /tmp/tmppggmQ3/KHtDR92Cf5/racket-6.12+ppa1/share/pkgs/srfi-lite-lib/.info.rkt.swp and /tmp/tmppggmQ3/HoxxPvf5Qz/racket-7.0+ppa1/share/pkgs/srfi-lite-lib/.info.rkt.swp differ diff -Nru racket-6.12+ppa1/share/pkgs/srfi-lite-lib/srfi/29/localization.rkt racket-7.0+ppa1/share/pkgs/srfi-lite-lib/srfi/29/localization.rkt --- racket-6.12+ppa1/share/pkgs/srfi-lite-lib/srfi/29/localization.rkt 2018-01-26 20:34:52.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/srfi-lite-lib/srfi/29/localization.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,6 +2,7 @@ (require racket/contract/base racket/file + racket/list (only-in racket/runtime-path define-runtime-path) racket/string racket/format syntax/modread @@ -113,10 +114,6 @@ (lambda () (with-input-from-file path read)))) #t)))) - (define (rdc ls) - (if (null? (cdr ls)) - '() - (cons (car ls) (rdc (cdr ls))))) ;;Retrieve a localized template given its package name and a template name (define (localized-template package-name template-name) @@ -127,5 +124,5 @@ (let ((bundle (hash-ref *localization-bundles* specifier #f))) (cond ((and bundle (assq template-name bundle)) => cdr) ((null? (cdr specifier)) #f) - (else (loop (rdc specifier)))))))) + (else (loop (drop-right specifier 1)))))))) ) diff -Nru racket-6.12+ppa1/share/pkgs/string-constants/info.rkt racket-7.0+ppa1/share/pkgs/string-constants/info.rkt --- racket-6.12+ppa1/share/pkgs/string-constants/info.rkt 2018-01-26 21:10:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("string-constants-lib" "string-constants-doc"))) (define implies (quote ("string-constants-lib" "string-constants-doc"))) (define pkg-desc "String constants to support internationalization, especially in DrRacket") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("string-constants-lib" "string-constants-doc"))) (define implies (quote ("string-constants-lib" "string-constants-doc"))) (define pkg-desc "String constants to support internationalization, especially in DrRacket") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-doc/info.rkt racket-7.0+ppa1/share/pkgs/string-constants-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-doc/info.rkt 2018-01-26 21:10:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("string-constants-lib" "base"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "String constants documentation") (define update-implies (quote ("string-constants-lib"))) (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("string-constants-lib" "base"))) (define build-deps (quote ("racket-doc" "scribble-lib"))) (define pkg-desc "String constants documentation") (define update-implies (quote ("string-constants-lib"))) (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/info.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/info.rkt 2018-01-26 21:10:04.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "String constants to support internationalization, especially in DrRacket") (define pkg-authors (quote (robby))) (define version "1.17"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "String constants to support internationalization, especially in DrRacket") (define pkg-authors (quote (robby))) (define version "1.19"))) diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,4 @@ -;; Bulgarian translation of Racket string constants file, version: 1.18 +;; Bulgarian translation of Racket string constants file, version: 1.19 ;; This file is distributed under the same terms as Racket ;; Copyright on translation: Alexander Shopov , 2015, 2016, 2017, 2018. @@ -1025,6 +1025,7 @@ (stand-alone-explanatory-label "Компилат (работи само на тази машина, използва компилиран вариант)") (distribution "Дистрибуция") (distribution-explanatory-label "Дистрибуция (за инсталация на други машини)") + (embed-dlls? "Да се вградят ли библиотеките DLL в изпълнимия файл?") ;; appears in the GUI only under windows (executable-type "Вид") (executable-base "Основа") (filename "Име на файл: ") diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -495,7 +495,11 @@ ;;; save file in particular format prompting. (save-as-plain-text "Save this file as plain text?") - (save-in-drs-format "Save this file in drscheme-specific non-text format?") + (save-as-binary-format "Convert this file to a DrRacket specific format to keep non-text elements?") + (save-in-drs-format "Save this file in DrRacket-specific non-text format?") + (keep-format "Keep (may lose data)") + (convert-format "Convert (recommended)") + (dont-save "Don't Save") (yes "Yes") (no "No") @@ -1108,6 +1112,7 @@ (stand-alone-explanatory-label "Stand-alone (for this machine only, run compiled copy)") (distribution "Distribution") (distribution-explanatory-label "Distribution (to install on other machines)") + (embed-dlls? "Embed DLLs in the executable?") ;; appears in the GUI only under windows (executable-type "Type") (executable-base "Base") (filename "Filename: ") diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -495,7 +495,11 @@ ;;; save file in particular format prompting. (save-as-plain-text "Sauvegarder ce fichier au format texte ?") - (save-in-drs-format "Sauvegarder ce fichier au format DrRacket (non-texte) ?") + (save-as-binary-format "Convertir ce fichier au format DrRacket pour préserver les éléments non-textuels ?") + (save-in-drs-format "Sauvegarder ce fichier au format DrRacket non-textuel ?") + (keep-format "Ne pas convertir (des données peuvent être perdues)") + (convert-format "Convertir (recommendé)") + (dont-save "Ne pas Sauvegarder") (yes "Oui") (no "Non") @@ -986,7 +990,15 @@ "erreur durant le chargement du fichier info.rkt pour ~s") (tool-error-phase1 "Erreur durant la phase 1 pour l'outil ~s; ~s") (tool-error-phase2 "Erreur durant la phase 2 oour l'outil ~s; ~s") - + ;; tool preferences panel + (tool-config-changes "Les changements dans la configuration d'outil prendront effet au prochain démarrage de DrRacket.") + (installed-tools "Outils installés") + (tool-prefs-panel-tool:-label "Outil: ") + (load-tool-when-drracket-starts? "Charger l'outil quand DrRacket démarre ?") + (unnamed-tool "outil anonyme ~a") + (note-that-tool-loaded " (chargé)") + (note-that-tool-was-skipped " (sauté)") + (note-that-tool-failed-to-load " (chargement a échoué)") ;;; define popup menu (end-of-buffer-define "« fin du tampon »") diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -990,6 +990,7 @@ (stand-alone-explanatory-label "Stand-alone (nur für diese Maschine, startet compilierte Kopie)") (distribution "Distribution") (distribution-explanatory-label "Distribution (für die Installation auf anderen Maschinen)") + (embed-dlls? "DLLs in Programmdatei einbetten?") ;; appears in the GUI only under windows (executable-type "Typ") (executable-base "Hauptteil") (filename "Dateiname: ") @@ -1262,7 +1263,7 @@ (test-coverage-ask? "Frage nach dem Löschen der Testabdeckungs-Information") (test-coverage-on "Durch Tests abgedeckt") (test-coverage-off "Durch Tests nicht abgedeckt") - (test-coverage-entirely-covered "Alle Ausdrücke are sind abgedeckt") + (test-coverage-entirely-covered "Alle Ausdrücke sind abgedeckt") (test-coverage-next-time-check-box "Nächstes Mal anzeigen?") (test-coverage-summary "Zusammenfassung der Abdeckungs-Ergebnisse anzeigen") diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -22,7 +22,7 @@ (are-you-sure-you-want-to-switch-languages "为了改变界面语言，现在需要重新启动DrRacket。你确定吗？") - (interact-with-drscheme-in-language "使用简体中文作DrRacket界面语言") + (interact-with-drscheme-in-language "使用简体中文作为DrRacket界面语言") ;; these two should probably be the same in all languages excepet English. ;; they are the button labels (under macos and windows, respectively) @@ -146,7 +146,7 @@ (cs-lexical-variable "词法变量") (cs-set!d-variable "set!过的变量") (cs-imported-variable "导入的变量") - (cs-unused-require "无用的require") + (cs-unused-require "无效的require") (cs-free-variable "自由变量") (cs-binder-count "~a次绑定出现") @@ -198,7 +198,7 @@ (online-expansion-show-variable-errors-as "显示未绑定变量") (online-expansion-show-other-errors-as "显示其他错误") ; locations the errors can be shown - (online-expansion-error-gold-highlight "使用高亮突出") + (online-expansion-error-gold-highlight "使用高亮显示错误") (online-expansion-error-margin "在一侧显示") ; the label of a preference in the (string-constant online-expansion) section (show-arrows-on-mouseover "鼠标悬停时显示绑定及尾位置箭头") diff -Nru racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt --- racket-6.12+ppa1/share/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt 2018-01-26 20:37:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -980,7 +980,7 @@ (stepper-previous "Paso") (stepper-next "Paso") (stepper-next-application "Aplicación") - (stepper-jump-to-beginning "Hogar") + (stepper-jump-to-beginning "al inicio") (dialog-back "Atrás") diff -Nru racket-6.12+ppa1/share/pkgs/swindle/info.rkt racket-7.0+ppa1/share/pkgs/swindle/info.rkt --- racket-6.12+ppa1/share/pkgs/swindle/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/swindle/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "swindle") (define mzscheme-launcher-names (quote ("swindle"))) (define mzscheme-launcher-flags (quote (("-li" "swindle")))) (define scribblings (quote (("swindle.scrbl" ())))) (define tools (quote (("tool.rkt")))) (define tool-names (quote ("Swindle"))) (define tool-icons (quote (("swindle-icon.png" "swindle")))) (define tool-urls (quote ("http://www.barzilay.org/Swindle/"))) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "drracket-plugin-lib" "gui-lib" "net-lib" "string-constants-lib"))) (define build-deps (quote ("compatibility-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Swindle language") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "swindle") (define mzscheme-launcher-names (quote ("swindle"))) (define mzscheme-launcher-flags (quote (("-li" "swindle")))) (define scribblings (quote (("swindle.scrbl" ())))) (define tools (quote (("tool.rkt")))) (define tool-names (quote ("Swindle"))) (define tool-icons (quote (("swindle-icon.png" "swindle")))) (define tool-urls (quote ("http://www.barzilay.org/Swindle/"))) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "drracket-plugin-lib" "gui-lib" "net-lib" "string-constants-lib"))) (define build-deps (quote ("compatibility-doc" "racket-doc" "scribble-lib"))) (define pkg-desc "The implementation of the Swindle language") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/syntax-color/info.rkt racket-7.0+ppa1/share/pkgs/syntax-color/info.rkt --- racket-6.12+ppa1/share/pkgs/syntax-color/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/syntax-color/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("syntax-color-lib" "syntax-color-doc"))) (define implies (quote ("syntax-color-lib" "syntax-color-doc"))) (define pkg-desc "Program syntax coloring for editors and typesetting") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("syntax-color-lib" "syntax-color-doc"))) (define implies (quote ("syntax-color-lib" "syntax-color-doc"))) (define pkg-desc "Program syntax coloring for editors and typesetting") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/syntax-color-doc/info.rkt racket-7.0+ppa1/share/pkgs/syntax-color-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/syntax-color-doc/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/syntax-color-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("gui-doc" "scribble-doc" "gui-lib" "scribble-lib" "racket-doc" "syntax-color-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("syntax-color-lib"))) (define pkg-desc "documentation part of \"syntax-color\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("gui-doc" "scribble-doc" "gui-lib" "scribble-lib" "racket-doc" "syntax-color-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("syntax-color-lib"))) (define pkg-desc "documentation part of \"syntax-color\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/syntax-color-lib/info.rkt racket-7.0+ppa1/share/pkgs/syntax-color-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/syntax-color-lib/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/syntax-color-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "parser-tools-lib" "option-contract-lib"))) (define pkg-desc "implementation (no documentation) part of \"syntax-color\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "parser-tools-lib" "option-contract-lib"))) (define pkg-desc "implementation (no documentation) part of \"syntax-color\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) diff -Nru racket-6.12+ppa1/share/pkgs/syntax-color-lib/syntax-color/lexer-contract.rkt racket-7.0+ppa1/share/pkgs/syntax-color-lib/syntax-color/lexer-contract.rkt --- racket-6.12+ppa1/share/pkgs/syntax-color-lib/syntax-color/lexer-contract.rkt 2018-01-26 20:37:02.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/syntax-color-lib/syntax-color/lexer-contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -35,6 +35,7 @@ [else lexer])) (define initial-state (pseudo-random-generator->vector (current-pseudo-random-generator))) + (define latest-input-string #f) (with-handlers ([exn:fail? (lambda (exn) (raise @@ -43,9 +44,11 @@ " random testing of lexer failed\n" " lexer: ~e\n" " pseudo-random state: ~s\n" + " latest input string: ~s\n" " error message: ~s") lexer initial-state + latest-input-string (exn-message exn)) (exn-continuation-marks exn))))]) (for ([x (in-range 10)]) @@ -65,6 +68,7 @@ (string-ref s (random (string-length s)))] [(1 2) (integer->char (random 255))]))))) + (set! latest-input-string s) (define in (open-input-string s)) (port-count-lines! in) (let loop ([mode #f][offset 0]) diff -Nru racket-6.12+ppa1/share/pkgs/testing-util-lib/info.rkt racket-7.0+ppa1/share/pkgs/testing-util-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/testing-util-lib/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/testing-util-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Utilities for interoperating between testing frameworks") (define version "1.1") (define pkg-authors (quote (florence))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Utilities for interoperating between testing frameworks") (define version "1.1") (define pkg-authors (quote (florence))))) diff -Nru racket-6.12+ppa1/share/pkgs/tex-table/info.rkt racket-7.0+ppa1/share/pkgs/tex-table/info.rkt --- racket-6.12+ppa1/share/pkgs/tex-table/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/tex-table/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define deps (quote ("base"))) (define collection "mrlib") (define pkg-desc "Table of TeX-style abbreviations") (define pkg-authors (quote (robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define deps (quote ("base"))) (define collection "mrlib") (define pkg-desc "Table of TeX-style abbreviations") (define pkg-authors (quote (robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/tex-table/tex-table.rkt racket-7.0+ppa1/share/pkgs/tex-table/tex-table.rkt --- racket-6.12+ppa1/share/pkgs/tex-table/tex-table.rkt 2018-01-26 20:36:30.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/tex-table/tex-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -73,7 +73,7 @@ ("delta" "δ") ("kappa" "κ") ("rho" "ρ") - ("varphi" "ϕ") + ("varphi" "φ") ("epsilon" "ϵ") ("lambda" "λ") ("varrho" "ϱ") @@ -192,6 +192,7 @@ ("ddots" "⋱") ("cdots" "⋯") ("hdots" "⋯") + ("ldots" "…") ("langle" "⟨") ("rangle" "⟩"))) diff -Nru racket-6.12+ppa1/share/pkgs/trace/info.rkt racket-7.0+ppa1/share/pkgs/trace/info.rkt --- racket-6.12+ppa1/share/pkgs/trace/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/trace/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection "trace") (define name "Calltrace") (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-desc "Instrumentation to show function calls") (define pkg-authors (quote (mflatt robby))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection "trace") (define name "Calltrace") (define deps (quote ("scheme-lib" "base" "compatibility-lib"))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-desc "Instrumentation to show function calls") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket/info.rkt racket-7.0+ppa1/share/pkgs/typed-racket/info.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("typed-racket-lib" "typed-racket-doc"))) (define implies (quote ("typed-racket-lib" "typed-racket-doc"))) (define pkg-desc "The implementation of the Typed Racket language") (define pkg-authors (quote (samth stamourv))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("typed-racket-lib" "typed-racket-doc"))) (define implies (quote ("typed-racket-lib" "typed-racket-doc"))) (define pkg-desc "The implementation of the Typed Racket language") (define pkg-authors (quote (samth stamourv))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-compatibility/info.rkt racket-7.0+ppa1/share/pkgs/typed-racket-compatibility/info.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-compatibility/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-compatibility/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "typed-racket-lib" "base"))) (define pkg-desc "compatibility library for older Typed Racket-based languages") (define pkg-authors (quote (samth stamourv))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "typed-racket-lib" "base"))) (define pkg-desc "compatibility library for older Typed Racket-based languages") (define pkg-authors (quote (samth stamourv))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-doc/info.rkt racket-7.0+ppa1/share/pkgs/typed-racket-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-doc/info.rkt 2018-01-26 21:10:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("net-doc" "scheme-lib" "srfi-lite-lib" "r6rs-doc" "srfi-doc" "r6rs-lib" "sandbox-lib" "at-exp-lib" ("scribble-lib" #:version "1.16") "pict-lib" ("typed-racket-lib" #:version "1.6") "typed-racket-compatibility" "typed-racket-more" "racket-doc" "draw-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("typed-racket-lib"))) (define pkg-desc "documentation part of \"typed-racket\"") (define pkg-authors (quote (samth stamourv))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("net-doc" "scheme-lib" "srfi-lite-lib" "r6rs-doc" "srfi-doc" "r6rs-lib" "sandbox-lib" "at-exp-lib" ("scribble-lib" #:version "1.16") "pict-lib" ("typed-racket-lib" #:version "1.6") "typed-racket-compatibility" "typed-racket-more" "racket-doc" "draw-lib"))) (define deps (quote ("base"))) (define update-implies (quote ("typed-racket-lib"))) (define pkg-desc "documentation part of \"typed-racket\"") (define pkg-authors (quote (samth stamourv))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/guide/optimization.scrbl racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/guide/optimization.scrbl --- racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/guide/optimization.scrbl 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/guide/optimization.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -36,6 +36,11 @@ @other-doc['(lib "optimization-coach/scribblings/optimization-coach.scrbl") #:indirect "Optimization Coach"]{}. +The Typed Racket optimizer logs events with the topic +@indexed-racket['TR-optimizer]. +See @Secref["logging" #:doc '(lib "scribblings/reference/reference.scrbl")] +to learn how to receive these log events. + @subsection{Numeric types} Being type-driven, the optimizer makes most of its decisions based on diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/types.scrbl racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/types.scrbl --- racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/types.scrbl 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/types.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -84,9 +84,18 @@ Exact-Number Float-Complex Single-Flonum-Complex -Inexact-Complex)] +Inexact-Complex +Imaginary +Exact-Complex +Exact-Imaginary +Inexact-Imaginary)] These types correspond to Racket's complex numbers. +@history[#:changed "1.7"]{@elem{Added @racket[Imaginary], + @racket[Inexact-Complex], + @racket[Exact-Complex], + @racket[Exact-Imaginary], + @racket[Inexact-Imaginary].}} The above types can be subdivided into more precise types if you want to enforce tighter constraints. Typed Racket provides types for the positive, @@ -715,7 +724,8 @@ [optional-dom type (code:line keyword type)] [rest (code:line) - (code:line #:rest type)])]{ + (code:line #:rest type) + (code:line #:rest-star (type ...))])]{ Constructs the type of functions with optional or rest arguments. The first list of @racket[mandatory-dom]s correspond to mandatory argument types. The list @racket[optional-doms], if provided, specifies the optional argument types. @@ -724,7 +734,7 @@ (define (append-bar str [how-many 1]) (apply string-append str (make-list how-many "bar")))] - If provided, the @racket[rest] expression specifies the type of + If provided, the @racket[#:rest type] specifies the type of elements in the rest argument list. @ex[(: +all (->* (Integer) #:rest Integer (Listof Integer))) @@ -732,6 +742,22 @@ (map (λ ([x : Integer]) (+ x inc)) rst)) (+all 20 1 2 3)] + A @racket[#:rest-star (type ...)] specifies the rest list is a sequence + of types which occurs 0 or more times (i.e. the Kleene closure of the + sequence). + + @ex[(: print-name+ages (->* () #:rest-star (String Natural) Void)) + (define (print-name+ages . names+ages) + (let loop ([names+ages : (Rec x (U Null (List* String Natural x))) names+ages]) + (when (pair? names+ages) + (printf "~a is ~a years old!\n" + (first names+ages) + (second names+ages)) + (loop (cddr names+ages)))) + (printf "done printing ~a ages" (/ (length names+ages) 2))) + (print-name+ages) + (print-name+ages "Charlotte" 8 "Harrison" 5 "Sydney" 3)] + Both the mandatory and optional argument lists may contain keywords paired with types. @@ -774,8 +800,9 @@ @ex[((λ #:forall (A) ([x : (∩ Symbol A)]) x) 'foo)]} @defform[(case-> fun-ty ...)]{is a function that behaves like all of - the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function - types constructed with @racket[->]. + the @racket[fun-ty]s, considered in order from first to last. + The @racket[fun-ty]s must all be non-dependent function types (i.e. no + preconditions or dependencies between arguments are currently allowed). @ex[(: add-map : (case-> [(Listof Integer) -> (Listof Integer)] [(Listof Integer) (Listof Integer) -> (Listof Integer)]))] @@ -833,20 +860,79 @@ @ex[(struct-info (arity-at-least 0))] } -@defform[(Prefab key type ...)]{ - Represents a @rtech{prefab} structure type with the given prefab structure - key (such as one returned by @racket[prefab-struct-key] or accepted by - @racket[make-prefab-struct]) and with the given types for each field. - - In the case of prefab structure types with supertypes, the field types of the - supertypes come before the field types of the child structure type. The order - of types matches the order of arguments to a prefab struct constructor. - - @ex[#s(salad "potato" "mayo") - (: q-salad (Prefab (salad food 1) String String Symbol)) - (define q-salad - #s((salad food 1) "quinoa" "EVOO" salad))] -} +@defform[(Prefab key type ...)]{Describes a @rtech{prefab} + structure with the given (implicitly quoted) @emph{prefab + key} @racket[key] and specified field types. + + Prefabs are more-or-less tagged polymorphic tuples which + can be directly serialized and whose fields can be accessed + by anyone. Subtyping is covariant for immutable fields and + invariant for mutable fields. + + When a prefab struct is defined with @racket[struct] the + struct name is bound at the type-level to the + @racket[Prefab] type with the corresponding key and field + types and the constructor expects types corresponding to + those declared for each field. The defined predicate, + however, only tests whether a value is a prefab structure + with the same key and number of fields, but does not inspect + the fields' values. + + @ex[(struct person ([name : String]) #:prefab) + person + person? + person-name + (person "Jim") + (ann '#s(person "Dwight") person) + (ann '#s(person "Pam") (Prefab person String)) + (ann '#s(person "Michael") (Prefab person Any)) + (eval:error (person 'Toby)) + (eval:error (ann #s(person Toby) (Prefab person String))) + (ann '#s(person Toby) (Prefab person Symbol)) + (person? '#s(person "Michael")) + (person? '#s(person Toby)) + (struct employee person ([schrute-bucks : Natural]) #:prefab) + (employee "Oscar" 10000) + (ann '#s((employee person 1) "Oscar" 10000) employee) + (ann '#s((employee person 1) "Oscar" 10000) + (Prefab (employee person 1) String Natural)) + (person? '#s((employee person 1) "Oscar" 10000)) + (employee? '#s((employee person 1) "Oscar" 10000)) + (eval:error (employee 'Toby -1)) + (ann '#s((employee person 1) Toby -1) + (Prefab (employee person 1) Symbol Integer)) + (person? '#s((employee person 1) Toby -1)) + (employee? '#s((employee person 1) Toby -1))] +} + +@defform[(PrefabTop key field-count)]{Describes all +prefab types with the (implicitly quoted) prefab-key + @racket[key] and @racket[field-count] many fields. + + For immutable prefabs this is equivalent to + @racket[(Prefab key Any ...)] with @racket[field-count] many + occurrences of @racket[Any]. For mutable prefabs, this + describes a prefab that can be read from but not written to + (since we do not know at what type other code may have the + fields typed at). + +@ex[(struct point ([x : Number] [y : Number]) + #:prefab + #:mutable) + point + point-x + point-y + point? + (define (maybe-read-x p) + (if (point? p) + (ann (point-x p) Any) + 'not-a-point)) + (eval:error (define (read-some-x-num p) + (if (point? p) + (ann (point-x p) Number) + -1)))] + +@history[#:added "1.7"]} @defalias[Union U] @defalias[Intersection ∩] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl --- racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/unsafe.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -41,7 +41,9 @@ Unlike @racket[provide], this form is unsafe and Typed Racket will not generate any contracts that correspond to the specified types. This means that uses of the - exports in other modules may circumvent the type system's invariants. + exports in other modules may circumvent the type system's invariants. In + particular, one typed module may unsafely provide identifiers imported from + another typed module. Additionally, importing an identififer that is exported with @racket[unsafe-provide] into another typed module, and then @@ -70,7 +72,8 @@ (eval:error (require 'u)) ] - @history[#:added "1.3"] + @history[#:added "1.3" + #:changed "1.8" "Added support for re-provided typed variables"] } @defform[(unsafe-require/typed/provide m rt-clause ...)]{ diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl --- racket-6.12+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -73,6 +73,32 @@ } +@defform*[[(assert-typecheck-fail body-expr) + (assert-typecheck-fail body-expr #:result result-expr)]]{ +Explicitly produce a type error if @racket[body-expr] does not produce a type error. +If @racket[result-expr] is provided, it will be the result of evaluating the + expression, otherwise @racket[(void)] will be returned. If there is an expected type, + that type is propagated as the expected type when checking @racket[body-expr]. +@history[#:added "1.7"]} + +@section{Ignoring type information} + +In some contexts, it is useful to have the typechecker forget type +information on particular expressions. Any expression with the shape +@racket[(#%expression sub)] that has a true value for the syntax property +@racket['typed-racket:ignore-type-information] will have the type @racket[Any], and +the type checker won't learn anything about the expression for use in +refining other types. +@history[#:added "1.7"] + +The expression @racket[sub] must still type check, but can have any +single-valued type. + +This is similar to @racket[(ann sub Any)], but differs in whether the +typechecker can use this to refine other types, and can be used in +context that do not depend on Typed Racket. + + @section{Untyped Utilities} @defmodule[typed/untyped-utils] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/info.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/info.rkt 2018-01-26 21:10:08.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.7.0.4") "source-syntax" "compatibility-lib" "string-constants-lib"))) (define pkg-desc "implementation (no documentation) part of \"typed-racket\"") (define pkg-authors (quote (samth stamourv))) (define version "1.7"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.90.0.30") "source-syntax" "compatibility-lib" "string-constants-lib"))) (define pkg-desc "implementation (no documentation) part of \"typed-racket\"") (define pkg-authors (quote (samth stamourv))) (define version "1.8"))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed/racket/unsafe.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed/racket/unsafe.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed/racket/unsafe.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed/racket/unsafe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,6 +8,7 @@ (require (for-syntax racket/base syntax/parse + typed-racket/typecheck/renamer (prefix-in internal: typed-racket/private/syntax-properties) (prefix-in internal: (submod typed-racket/base-env/prims-contract unsafe)))) @@ -15,8 +16,16 @@ (internal:unsafe-require/typed stx)) (define-syntax (unsafe-provide stx) - (quasisyntax/loc stx - #,(internal:unsafe-provide #`(provide . #,stx)))) + (syntax-case stx () + [(_ nm* ...) + (with-syntax ([(orig-nm* ...) + (for/list ((nm (in-list (syntax-e #'(nm* ...))))) + ;; un-rename any rename transformers + (if (identifier? nm) + (un-rename nm) + nm))]) + (internal:unsafe-provide + (syntax/loc stx (provide orig-nm* ...))))])) (define-syntax (unsafe-require/typed/provide stx) (unless (memq (syntax-local-context) '(module module-begin)) @@ -45,4 +54,4 @@ other-clause ...) #'(begin (unsafe-require/typed lib clause) (provide t pred) - (unsafe-require/typed/provide lib other-clause ...))])) \ No newline at end of file + (unsafe-require/typed/provide lib other-clause ...))])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require syntax/parse/pre + racket/private/immediate-default "../private/parse-classes.rkt" "../private/syntax-properties.rkt" (for-label "colon.rkt")) @@ -10,8 +11,8 @@ ;; ---------------- ;; ;; A LambdaKeywords is a -;; (lambda-kws (Listof Keyword) (Listof Keyword)) -(struct lambda-kws (mand opt)) +;; (lambda-kws (Listof Keyword) (Listof Keyword) (Listof Keyword) Integer (listof Boolean)) +(struct lambda-kws (mand opt opt-supplied pos-mand-count pos-opt-supplied?)) ;; interp. ;; - the first list contains the mandatory keywords @@ -194,13 +195,20 @@ #:attr default #f #:attr type #f) (pattern (~seq kw:keyword [id:id default:expr]) - #:with form #'(kw [id default]) + #:with i-id (if (immediate-default? #'default) + (optional-immediate-arg-property #'id #true) + (optional-non-immediate-arg-property #'id #true)) + #:with form #`(kw [i-id default]) #:attr type #f) (pattern (~seq kw:keyword [id:id : type:expr]) #:with form #`(kw #,(type-label-property #'id #'type)) #:attr default #f) (pattern (~seq kw:keyword [id:id : type:expr default:expr]) - #:with form #`(kw [#,(type-label-property #'id #'type) default]))) + #:with t-id (type-label-property #'id #'type) + #:with i-id (if (immediate-default? #'default) + (optional-immediate-arg-property #'t-id #true) + (optional-non-immediate-arg-property #'t-id #true)) + #:with form #`(kw [i-id default]))) (define-splicing-syntax-class mand-formal #:description "lambda argument" @@ -222,11 +230,18 @@ #:attributes (form id default type kw) #:literal-sets (colon) (pattern [id:id default:expr] - #:with form #'([id default]) + #:with form #`([#,(if (immediate-default? #'default) + (optional-immediate-arg-property #'id #t) + (optional-non-immediate-arg-property #'id #t)) + default]) #:attr type #f #:attr kw #f) (pattern [id:id : type:expr default:expr] - #:with form #`([#,(type-label-property #'id #'type) default]) + #:with form #`([#,(let ([t-id (type-label-property #'id #'type)]) + (if (immediate-default? #'default) + (optional-immediate-arg-property t-id #t) + (optional-non-immediate-arg-property t-id #t))) + default]) #:attr kw #f) (pattern :kw-formal)) @@ -257,22 +272,44 @@ ;; put them in a struct for later use by tc-expr (let ([kws (append (attribute mand.kw) (attribute opt.kw))] - [opt?s (append (attribute mand.default) - (attribute opt.default))]) - (define-values (mand-kws opt-kws) + [defaults (append (attribute mand.default) + (attribute opt.default))]) + (define-values (mand-kws opt-kws opt-kws-supplied) (for/fold ([mand-kws '()] - [opt-kws '()]) + [opt-kws '()] + [opt-kws-supplied '()]) ([kw (in-list kws)] - [opt? (in-list opt?s)] + [default (in-list defaults)] #:when kw) - (if opt? - (values mand-kws (cons (syntax-e kw) opt-kws)) - (values (cons (syntax-e kw) mand-kws) opt-kws)))) + (if default + (values mand-kws + (cons (syntax-e kw) opt-kws) + (if (immediate-default? default) + (cons (syntax-e kw) opt-kws-supplied) + opt-kws-supplied)) + (values (cons (syntax-e kw) mand-kws) + opt-kws + opt-kws-supplied)))) + (define pos-mand-count + (for/sum ([kw (in-list kws)] + [default (in-list defaults)] + #:unless default + #:unless kw) + 1)) + (define pos-opt-supplied?s + (for/list ([kw (in-list kws)] + [default (in-list defaults)] + #:when default + #:unless kw) + (immediate-default? default))) (and (or (not (null? mand-kws)) (not (null? opt-kws))) - (lambda-kws mand-kws opt-kws))) + (lambda-kws mand-kws opt-kws opt-kws-supplied pos-mand-count pos-opt-supplied?s))) #:attr opt-property - (list (length (attribute mand)) (length (attribute opt))) + (list (length (attribute mand)) + (length (attribute opt)) + (for/list ([default (in-list (attribute opt.default))]) + (and default (immediate-default? default)))) #:attr erased (with-syntax ([((mand-form ...) ...) #'(mand.form ...)] [((opt-form ...) ...) #'(opt.form ...)]) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -923,21 +923,9 @@ [hash-eqv? (-> -HashTableTop B)] [hash-equal? (-> -HashTableTop B)] [hash-weak? (asym-pred -HashTableTop B (-PS (-is-type 0 -Weak-HashTableTop) (-not-type 0 -Weak-HashTableTop)))] -[hash (-poly (a b) (cl->* (-> (-Immutable-HT a b)) - (a b . -> . (-Immutable-HT a b)) - (a b a b . -> . (-Immutable-HT a b)) - (a b a b a b . -> . (-Immutable-HT a b)) - (a b a b a b a b . -> . (-Immutable-HT a b))))] -[hasheqv (-poly (a b) (cl->* (-> (-Immutable-HT a b)) - (a b . -> . (-Immutable-HT a b)) - (a b a b . -> . (-Immutable-HT a b)) - (a b a b a b . -> . (-Immutable-HT a b)) - (a b a b a b a b . -> . (-Immutable-HT a b))))] -[hasheq (-poly (a b) (cl->* (-> (-Immutable-HT a b)) - (a b . -> . (-Immutable-HT a b)) - (a b a b . -> . (-Immutable-HT a b)) - (a b a b a b . -> . (-Immutable-HT a b)) - (a b a b a b a b . -> . (-Immutable-HT a b))))] +[hash (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))] +[hasheqv (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))] +[hasheq (-poly (a b) (->* (list) (make-Rest (list a b)) (-Immutable-HT a b)))] [make-hash (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))] [make-hasheq (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))] [make-hasheqv (-poly (a b) (->opt [(-lst (-pair a b))] (-Mutable-HT a b)))] @@ -949,7 +937,9 @@ [make-immutable-hasheqv (-poly (a b) (->opt [(-lst (-pair a b))] (-Immutable-HT a b)))] [hash-set (-poly (a b) ((-HT a b) a b . -> . (-Immutable-HT a b)))] +[hash-set* (-poly (a b) (->* (list (-HT a b)) (make-Rest (list a b)) (-Immutable-HT a b)))] [hash-set! (-poly (a b) ((-HT a b) a b . -> . -Void))] +[hash-set*! (-poly (a b) (->* (list (-HT a b)) (make-Rest (list a b)) -Void))] [hash-ref (-poly (a b c) (cl-> [((-HT a b) a) b] [((-HT a b) a (-val #f)) (-opt b)] @@ -1208,6 +1198,8 @@ [void (->* '() Univ -Void)] [void? (make-pred-ty -Void)] +[unsafe-undefined -Unsafe-Undefined] + ;; Section 5.2 (Structure Types) [make-struct-type (->opt -Symbol @@ -2347,6 +2339,7 @@ [variable-reference->module-source (-> -Variable-Reference (Un Sym (-val #f) -Path))] [variable-reference->phase (-> -Variable-Reference -Nat)] [variable-reference-constant? (-> -Variable-Reference -Boolean)] +[variable-reference-from-unsafe? (-> -Variable-Reference -Boolean)] ;; Section 14.2 (Evaluation and Compilation) [current-eval (-Param (-> Univ ManyUniv) (-> Univ ManyUniv))] @@ -3081,15 +3074,25 @@ ;; Section 15.9 (racket/cmdline) [parse-command-line - (let ([mode-sym (one-of/c 'once-each 'once-any 'multi 'final 'help-labels)]) - (-polydots (b a) - (cl->* (-Pathlike - (Un (-lst -String) (-vec -String)) - (-lst (Un (-pair mode-sym (-lst (-lst Univ))) - (-pair (-val 'ps) (-lst -String)))) - ((list Univ) [a a] . ->... . b) - (-lst -String) - . -> . b))))] + (let ([mode-sym (one-of/c 'once-each 'once-any 'multi 'final)] + [label-sym (one-of/c 'ps 'help-labels 'usage-help)]) + (-polydots + (b a) + (cl->* (->opt -Pathlike + (Un (-lst -String) (-vec -String)) + (-lst (Un (-pair mode-sym + ;; With the `command-line` macro, the typechecker + ;; can't figure out that a type specifying the shape of + ;; the flag specification list would be satisfied. + (-lst Univ)) + (-pair label-sym + (-lst -String)))) + (->... (list (-lst Univ)) [-String a] b) + (-lst -String) + [(-> -String Univ) + ;; Still permits unknown-proc args that accept rest arguments + (-> -String Univ)] + b))))] ;; Section 16.1 (Weak Boxes) [make-weak-box (-poly (a) (-> a (-weak-box a)))] @@ -3319,8 +3322,8 @@ (-poly (a b) (cl->* - (->key (-lst a) (-> a a -Boolean) #:key (-> a a) #f #:cache-keys? -Boolean #f (-lst a)) - (->key (-lst a) (-> b b -Boolean) #:key (-> a b) #f #:cache-keys? -Boolean #f (-lst a))))) + (->key (-lst a) (-> a a -Boolean) #:key (-opt (-> a a)) #f #:cache-keys? -Boolean #f (-lst a)) + (->key (-lst a) (-> b b -Boolean) #:key (-opt (-> a b)) #f #:cache-keys? -Boolean #f (-lst a))))) (check-duplicates (-poly (a b c) @@ -3343,8 +3346,8 @@ (-poly (a b) (cl->* - (->optkey (-lst a) ((-> a a Univ)) #:key (-> a a) #f (-lst a)) - (->optkey (-lst a) ((-> b b Univ)) #:key (-> a b) #f (-lst a))))) + (->optkey (-lst a) ((-> a a Univ)) #:key (-opt (-> a a)) #f (-lst a)) + (->optkey (-lst a) ((-> b b Univ)) #:key (-opt (-> a b)) #f (-lst a))))) (open-input-file (->key -Pathlike #:mode (one-of/c 'binary 'text) #f #:for-module? Univ #f @@ -3426,6 +3429,7 @@ (find-relative-path (->key -SomeSystemPathlike -SomeSystemPathlike #:more-than-root? Univ #f + #:more-than-same? Univ #f #:normalize-case? Univ #f -SomeSystemPath)) (regexp-match* diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -121,9 +121,6 @@ ;; check-vector [(make-template-identifier 'check-vector 'racket/private/for) (-> Univ -Void)] - ;; check-in-hash - [(make-template-identifier 'check-in-hash 'racket/private/for) - (-> Univ -Void)] ;; in-range [(make-template-identifier 'in-range 'racket/private/for) (cl->* (-> -Byte (-seq -Byte)) @@ -214,6 +211,39 @@ (-> Univ -Boolean)] [(make-template-identifier 'not-weak? 'racket/private/for) (-> -HashTableTop -Boolean)] + ;; check-in-hash and friends + [(make-template-identifier 'check-in-hash 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-hash-keys 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-hash-values 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-hash-pairs 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-mutable-hash 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-mutable-hash-keys 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-mutable-hash-values 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-mutable-hash-pairs 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-immutable-hash 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-immutable-hash-keys 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-immutable-hash-values 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-immutable-hash-pairs 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-weak-hash 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-weak-hash-keys 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-weak-hash-values 'racket/private/for) + (-> Univ -Void)] + [(make-template-identifier 'check-in-weak-hash-pairs 'racket/private/for) + (-> Univ -Void)] ;; in-port [(make-template-identifier 'in-port 'racket/private/for) (-poly (a) @@ -260,12 +290,39 @@ ;; check-in-port [(make-template-identifier 'check-in-port 'racket/private/for) (-> Univ Univ Univ)] - ;; from the expansion of `with-syntax' + ;; from the expansion of `with-syntax' or `quasisyntax' [(make-template-identifier 'apply-pattern-substitute 'racket/private/stxcase) (->* (list (-Syntax Univ) Univ) Univ (-Syntax Univ))] ;; same [(make-template-identifier 'with-syntax-fail 'racket/private/with-stx) (-> (-Syntax Univ) (Un))] + ; from `quasisyntax' + [(make-template-identifier 'check-splicing-list 'racket/private/qqstx) + (-> Univ (-Syntax Univ) (-Syntax Univ))] + ;; more from with-syntax, a Guide is ... + [(make-template-identifier 't-append 'racket/private/template) + (-> (-lst (-Syntax Univ)) -Stxish -Stxish)] + ;; ... or a Guide is ... + [(make-template-identifier 't-resyntax 'racket/private/template) + (-> (Un (-val #f) (-Syntax Univ)) (-Syntax Univ) Univ (-Syntax Univ))] + ;; ... or a Guide is ... + [(make-template-identifier 't-relocate 'racket/private/template) + (-> (-Syntax Univ) (Un (-val #f) (-Syntax Univ)) (-Syntax Univ))] + ;; ... or a Guide is ... + [(make-template-identifier 't-orelse* 'racket/private/template) + (-> (-> -Stxish) (-> -Stxish) -Stxish)] + ;; ... or a Guide is ... + [(make-template-identifier 't-struct 'racket/private/template) + (-> Univ (-lst (-Syntax Univ)) (-Syntax Univ))] + ;; ... or a Guide is ... + [(make-template-identifier 'h-splice 'racket/private/template) + (-> Univ Univ Univ (-lst (-Syntax Univ)))] + ;; ... or a Guide is ... + [(make-template-identifier 't-subst 'racket/private/template) + (->* (list (Un (-val #f) (-Syntax Univ)) (-Syntax Univ) Univ) Univ (-Syntax Univ))] + ;; ... or a Guide is ... + [(make-template-identifier 'check-same-length 'racket/private/template) + (-> (Un (-val #f) (-Syntax Univ)) (Un (-val #f) (-Syntax Univ)) (-lst Univ) -Void)] ;; from the expansion of `make-temp-file` [(make-template-identifier 'make-temporary-file/proc 'racket/file) (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -82,7 +82,7 @@ (define-hierarchy exn:fail:contract:divide-by-zero (#:kernel-maker k:exn:fail:contract:divide-by-zero) ()) (define-hierarchy exn:fail:contract:non-fixnum-result (#:kernel-maker k:exn:fail:contract:non-fixnum-result) ()) (define-hierarchy exn:fail:contract:continuation (#:kernel-maker k:exn:fail:contract:continuation) ()) - (define-hierarchy exn:fail:contract:variable (#:kernel-maker k:exn:fail:contract:variable) ())) + (define-hierarchy exn:fail:contract:variable (#:kernel-maker k:exn:fail:contract:variable) ([id : -Symbol]))) (define-hierarchy exn:fail:syntax (#:kernel-maker k:exn:fail:syntax) ([exprs : (-lst Any-Syntax)]) (define-hierarchy exn:fail:syntax:unbound (#:kernel-maker k:exn:fail:syntax:unbound) ()) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -21,7 +21,7 @@ (define-other-types -> ->* case-> U Union ∩ Intersection Rec All Opaque Vector Parameterof List List* Class Object Row Unit Values AnyValues Instance Refinement - pred Struct Struct-Type Prefab Distinction Sequenceof Refine) + pred Struct Struct-Type Prefab PrefabTop Distinction Sequenceof Refine) (define-other-props Top Bot !) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,6 +9,10 @@ [Inexact-Complex -InexactComplex] [Single-Flonum-Complex -SingleFlonumComplex] [Float-Complex -FloatComplex] +[Exact-Complex -ExactComplex] +[Exact-Imaginary -ExactImaginary] +[Inexact-Imaginary -InexactImaginary] +[Imaginary -Imaginary] [Exact-Number -ExactNumber] [Real -Real] [Nonpositive-Real -NonPosReal] @@ -89,6 +93,7 @@ [Void -Void] [Undefined -Undefined] ; initial value of letrec bindings +;; [Unsafe-Undefined -Unsafe-Undefined] ; not clear that it makes sense to export this [Boolean -Boolean] [Symbol -Symbol] [String -String] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -786,6 +786,18 @@ [(_ orig) #'(quote-syntax (typecheck-fail-internal orig "Incomplete case coverage" #f) #:local)])) +(define-syntax (assert-typecheck-fail stx) + (syntax-parse stx + [(_ orig) #'(assert-typecheck-fail orig #:result (void))] + [(_ orig #:result res) + #`(if #,(syntax-property #'(#%expression #f) + 'typed-racket:ignore-type-information + #t) + (quote-syntax (assert-typecheck-fail-internal + #,(local-expand #'orig 'expression '())) + #:local) + res)])) + (define-syntax (base-for/vector stx) (syntax-case stx () [(name for ann T K #:length n-expr #:fill fill-expr (clauses ...) body-expr) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,9 +16,9 @@ (for-syntax syntax/parse racket/base) (types abbrev struct-table utils) data/queue - racket/dict racket/list racket/promise + racket/private/dict racket/list racket/promise racket/match - syntax/id-table) + syntax/private/id-table) (provide ;; convenience form for defining an initial environment ;; used by "base-special-env.rkt" and "base-contracted.rkt" @@ -257,6 +257,7 @@ [(Prefab: key flds) `(make-Prefab (quote ,key) (list ,@(map type->sexp flds)))] + [(PrefabTop: key) `(make-PrefabTop (quote ,key))] [(App: rator rands) `(make-App ,(type->sexp rator) (list ,@(map type->sexp rands)))] @@ -264,7 +265,9 @@ `(make-Opaque (quote-syntax ,pred))] [(Refinement: parent pred) `(make-Refinement ,(type->sexp parent) (quote-syntax ,pred))] - [(Mu-name: n b) + [(Mu-maybe-name: n (? Type? b)) + `(make-Mu (quote ,n) ,(type->sexp b))] + [(Mu: n b) `(make-Mu (quote ,n) ,(type->sexp b))] [(Poly-names: ns b) `(make-Poly (list ,@(for/list ([n (in-list ns)]) @@ -324,6 +327,8 @@ ,(and rest (type->sexp rest)) (list ,@(map type->sexp kws)) ,(type->sexp rng))] + [(Rest: tys ) + `(make-Rest (list ,@(map type->sexp tys)))] [(RestDots: ty db) `(make-RestDots ,(type->sexp ty) (quote ,db))] @@ -386,7 +391,9 @@ [(In-Predefined-Table: id) id] ;; CarPE, CdrPE, SyntaxPE, ForcePE, FieldPE are in the table [(StructPE: ty idx) - `(make-StructPE ,(type->sexp ty) ,idx)])) + `(make-StructPE ,(type->sexp ty) ,idx)] + [(PrefabPE: key idx) + `(make-PrefabPE (quote ,key) ,idx)])) (define (bound-in-this-module id) (let ([binding (identifier-binding id)]) @@ -456,10 +463,19 @@ (make-init-code struct-fn-table-map (λ (id v) - (match-define (list pe mut?) v) - #`(add-struct-fn! (quote-syntax #,id) - #,(path-elem->sexp pe) - #,mut?)))) + (match-define (struct-field-entry type idx mutator? mutable?) v) + (cond + [mutator? + #`(add-struct-mutator-fn! + (quote-syntax #,id) + #,(type->sexp type) + #,idx)] + [else + #`(add-struct-accessor-fn! + (quote-syntax #,id) + #,(type->sexp type) + #,idx + #,mutable?)])))) ;; -> (Listof Syntax) ;; Construct syntax that does type environment serialization diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,3 +1,10 @@ +7.0 +- Revamp prefab struct handling. +- Improve contract generation for unions. +- Handle NaN correctly in comparisons. +- Improve `unsafe-provide` on imported bindings. +- Add `#:rest-star` in function types. +- Add `typed-racket:ignore-type-information` syntax property. 6.12 - Fixes for contract generation (merged before 6.11 but not released). - Change `inst` to handle missing arguments (uses `Any`). diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,11 +10,11 @@ (require "../utils/utils.rkt" (except-in (combine-in - (utils tc-utils) + (utils tc-utils prefab identifier) (rep free-variance type-rep prop-rep object-rep values-rep rep-utils type-mask) (types utils abbrev numeric-tower subtype resolve - substitute generalize prefab) + substitute generalize) (env lexical-env index-env tvar-env) (logic proves)) make-env -> ->* one-of/c) @@ -22,6 +22,7 @@ "signatures.rkt" "fail.rkt" "promote-demote.rkt" racket/match + ;racket/trace (contract-req) (for-syntax racket/base @@ -175,20 +176,25 @@ ;; of them. (struct seq (types end) #:transparent) (struct null-end () #:transparent) -(struct uniform-end (type) #:transparent) +(define -null-end (null-end)) +;; ts is the pattern of the rest of the seq that can +;; occur 0 or more times +;; e.g. a rest argument of Num would just be (list Num) +;; a rest arg of (Num Str) would be (list Num Str) +(struct star-end (ts) #:transparent) (struct dotted-end (type bound) #:transparent) (define (Values->seq v) (match v - [(Values: ts) (seq ts (null-end))] + [(Values: ts) (seq ts -null-end)] [(ValuesDots: ts dty dbound) (seq ts (dotted-end (-result dty) dbound))] [_ #f])) (define (List->end v) (match v - [(== -Null) (null-end)] - [(Listof: t) (uniform-end t)] + [(== -Null) -null-end] + [(Listof: t) (star-end (list t))] [(ListDots: t dbound) (dotted-end t dbound)] [_ #f])) @@ -256,19 +262,27 @@ [((seq ss (null-end)) (seq ts (null-end))) (cgen/list context ss ts)] - ;; One is null-end the other is uniform-end + ;; One is null-end the other is star-end [((seq ss (null-end)) - (seq ts (uniform-end t-rest))) - (cgen/list context ss (list-extend ss ts t-rest))] - [((seq ss (uniform-end s-rest)) + (seq ts (star-end t-rest))) + (define ss-len (length ss)) + (define ts-len (length ts)) + #:return-unless (<= ts-len ss-len) #f + (define fewer-args (- ss-len ts-len)) + (define cycle-len (length t-rest)) + #:return-unless (zero? (remainder fewer-args cycle-len)) #f + (define repetitions (quotient fewer-args cycle-len)) + (define new-ts (append ts (repeat-list t-rest repetitions))) + (cgen/list context ss new-ts)] + [((seq ss (star-end _)) (seq ts (null-end))) #f] - ;; Both are uniform-end - [((seq ss (uniform-end s-rest)) - (seq ts (uniform-end t-rest))) - (cgen/list context - (cons s-rest ss) - (cons t-rest (list-extend ss ts t-rest)))] + ;; Both are star-end + [((seq ss (star-end s-rest)) + (seq ts (and t-end (star-end t-rest)))) + (cgen/seq context + (seq (append s-rest ss) -null-end) + (seq (append t-rest ts) t-end))] ;; dotted below, nothing above [((seq ss (dotted-end dty dbound)) (seq ts (null-end))) @@ -326,27 +340,37 @@ (% move-dotted-rest-to-dmap (cgen (context-add-var context dbound*) s-dty t-dty) dbound* dbound)))] ;; * <: ... - [((seq ss (uniform-end s-rest)) + [((seq ss (star-end (list s-rest-ty))) (seq ts (dotted-end t-dty dbound))) #:return-unless (inferable-index? context dbound) #f #:return-unless (<= (length ts) (length ss)) #f (define new-bound (gensym dbound)) - (define-values (vars new-tys) (generate-dbound-prefix dbound t-dty (- (length ss) (length ts)) - new-bound)) + (define-values (vars new-tys) + (generate-dbound-prefix dbound t-dty (- (length ss) (length ts)) + new-bound)) (define-values (ss-front ss-back) (split-at ss (length ts))) (% cset-meet (cgen/list context ss-front ts) (% move-vars+rest-to-dmap (% cset-meet - (cgen/list (context-add context #:bounds (list new-bound) #:vars vars #:indices (list new-bound)) - ss-back new-tys) - (cgen (context-add-var context dbound) s-rest t-dty)) + (cgen/list (context-add context + #:bounds (list new-bound) + #:vars vars + #:indices (list new-bound)) + ss-back + new-tys) + (cgen (context-add-var context dbound) s-rest-ty t-dty)) vars dbound #:exact #t))] + ;; TODO figure out how above code could be modified to support + ;; star-end w/ a cycle of len > 1 + [((seq ss (star-end _)) + (seq ts (dotted-end _ _))) + #f] [((seq ss (dotted-end s-dty dbound)) - (seq ts (uniform-end t-rest))) + (seq ts (star-end (list t-rest-ty)))) (cond [(inferable-index? context dbound) (define new-bound (gensym dbound)) @@ -356,16 +380,21 @@ (% cset-meet (cgen/list context ss (if (positive? length-delta) (drop-right ts length-delta) - (list-extend ss ts t-rest))) + (list-extend ss ts t-rest-ty))) (% move-vars+rest-to-dmap (% cset-meet (cgen/list (context-add context #:bounds (list new-bound) #:vars vars #:indices (list new-bound)) new-tys (take-right ts (max 0 length-delta))) - (cgen (context-add-var context dbound) s-dty t-rest)) + (cgen (context-add-var context dbound) s-dty t-rest-ty)) vars dbound))] [else (extend-tvars (list dbound) - (cgen/seq (context-add context #:bounds (list dbound)) (seq ss (uniform-end s-dty)) t-seq))])])) + (cgen/seq (context-add context #:bounds (list dbound)) + (seq ss (star-end (list s-dty))) + t-seq))])] + [((seq ts (dotted-end _ _)) + (seq ss (star-end _))) + #f])) (define/cond-contract (cgen/arrow context s-arr t-arr) (context? Arrow? Arrow? . -> . (or/c #f cset?)) @@ -374,10 +403,10 @@ (Arrow: ts t-rest t-kws t)) (define (rest->end rest) (match rest - [(? Type?) (uniform-end rest)] + [(Rest: rst-ts) (star-end rst-ts)] [(RestDots: ty dbound) (dotted-end ty dbound)] - [_ (null-end)])) + [_ -null-end])) (define s-seq (seq ss (rest->end s-rest))) (define t-seq (seq ts (rest->end t-rest))) @@ -947,9 +976,16 @@ ;; like infer, but T-var is the vararg type: (define (infer/vararg X Y S T T-var R [expected #f] #:objs [objs '()]) - (define new-T (if T-var (list-extend S T T-var) T)) (and ((length S) . >= . (length T)) - (infer X Y S new-T R expected #:objs objs))) + (let* ([fewer-ts (- (length S) (length T))] + [new-T (match T-var + [(? Type? var-t) (list-extend S T var-t)] + [(Rest: rst-ts) + #:when (zero? (remainder fewer-ts (length rst-ts))) + (append T (repeat-list rst-ts + (quotient fewer-ts (length rst-ts))))] + [_ T])]) + (infer X Y S new-T R expected #:objs objs)))) ;; like infer, but dotted-var is the bound on the ... ;; and T-dotted is the repeated type @@ -988,6 +1024,6 @@ ;(trace substs-gen) ;(trace cgen) ;(trace cgen/list) -;(trace cgen/arr) +;(trace cgen/arrow) ;(trace cgen/seq) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/intersect.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/intersect.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/intersect.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/intersect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,8 @@ #lang racket/unit (require "../utils/utils.rkt" - (rep type-rep type-mask rep-utils) + (utils prefab) + (rep type-rep object-rep type-mask rep-utils) (types abbrev subtype resolve overlap) "signatures.rkt" racket/match @@ -54,6 +55,23 @@ ;; contain not only *if* they are polymorphic, but *which* fields are too ;;[((Struct: _ _ _ _ _ _) ;; (Struct: _ _ _ _ _ _))] + [((Prefab: key1 flds1) (Prefab: key2 flds2)) + #:when (and (or (prefab-key-subtype? key1 key2) + (prefab-key-subtype? key2 key1)) + (not (prefab-key/mutable-fields? key1)) + (not (prefab-key/mutable-fields? key2))) + (define-values (resulting-key extra-fields) + (if (prefab-key-subtype? key1 key2) + (values key1 (list-tail flds1 (length flds2))) + (values key2 (list-tail flds2 (length flds1))))) + (define flds* (for/list ([fty1 (in-list flds1)] + [fty2 (in-list flds2)] + [n (in-naturals)]) + (rec fty1 fty2 (-prefab-idx-of resulting-key n obj)))) + (cond + [(ormap Bottom? flds*) -Bottom] + [else (make-Prefab resulting-key + (append flds* extra-fields))])] [((Syntax: t1*) (Syntax: t2*)) (rebuild -Syntax (rec t1* t2*))] [((Promise: t1*) (Promise: t2*)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -36,21 +36,21 @@ ;; Returns the changed arr or #f if there is no arr above it (define (arr-change arr) (match arr - [(Arrow: dom rest kws rng) + [(Arrow: dom rst kws rng) (cond [(apply V-in? V (get-propsets rng)) #f] - [(and (RestDots? rest) - (memq (RestDots-nm rest) V)) + [(and (RestDots? rst) + (memq (RestDots-nm rst) V)) (make-Arrow (map contra dom) - (contra (RestDots-ty rest)) + (contra (RestDots-ty rst)) (map contra kws) (co rng))] [else (make-Arrow (map contra dom) - (and rest (contra rest)) + (and rst (contra rst)) (map contra kws) (co rng))])])) (match cur diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/signatures.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -50,7 +50,7 @@ ;; domain (listof Type?) ;; rest - (or/c #f Type?) + (or/c #f Type? Rest?) ;; range (or/c #f Values/c ValuesDots?)) ;; [optional] expected type diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,12 +16,12 @@ (pattern op:id #:when (struct-accessor? #'op) #:attr message "struct ref" - #:with idx #`'#,(struct-fn-idx #'op) + #:with idx #`'#,(struct-accessor? #'op) #:with opt #'unsafe-struct-ref) (pattern op:id #:when (struct-mutator? #'op) #:attr message "struct set" - #:with idx #`'#,(struct-fn-idx #'op) + #:with idx #`'#,(struct-mutator? #'op) #:with opt #'unsafe-struct-set!)) (define-syntax-class struct-opt-expr diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,10 +5,11 @@ (require (rename-in "../utils/utils.rkt" [infer infer-in]) (rep core-rep type-rep object-rep values-rep free-ids rep-utils) (types abbrev utils prop-ops resolve - classes prefab signatures + classes signatures subtype path-type numeric-tower) (only-in (infer-in infer) intersect) - (utils tc-utils stxclass-util literal-syntax-class) + (utils tc-utils prefab stxclass-util literal-syntax-class + identifier) syntax/stx (prefix-in c: (contract-req)) syntax/parse racket/sequence (env tvar-env type-alias-env mvar-env @@ -136,6 +137,7 @@ (define-literal-syntax-class #:for-label Struct) (define-literal-syntax-class #:for-label Struct-Type) (define-literal-syntax-class #:for-label Prefab) +(define-literal-syntax-class #:for-label PrefabTop) (define-literal-syntax-class #:for-label Values) (define-literal-syntax-class #:for-label values) (define-literal-syntax-class #:for-label AnyValues) @@ -254,7 +256,7 @@ ;; that looks the same as the original and which meets the above ;; conditions. (define (id->local-id id) - (gen-pretty-id (syntax->datum id))) + (symbol->fresh-pretty-normal-id (syntax->datum id))) (define-syntax-class dependent-fun-arg #:description "dependent function argument" @@ -296,7 +298,7 @@ ;; does not need to be delayed since there's no parsing done #:attr result #'t)) -(define-splicing-syntax-class ->*-rest +(define-splicing-syntax-class optional->*-rest #:description "rest argument type for ->*" #:attributes (type) (pattern (~optional (~seq #:rest type:non-keyword-ty)))) @@ -609,6 +611,18 @@ "key" (prefab-key->field-count new-key) "fields" num-fields)) (make-Prefab new-key (parse-types #'(ts ...)))] + [(:PrefabTop^ key count) + #:fail-unless (prefab-key? (syntax->datum #'key)) + "expected a prefab key" + #:fail-unless (exact-nonnegative-integer? (syntax->datum #'count)) + "expected a field count (i.e. an exact nonnegative integer)" + (define num-fields (syntax->datum #'count)) + (define new-key (normalize-prefab-key (syntax->datum #'key) num-fields)) + (unless (= (prefab-key->field-count new-key) num-fields) + (parse-error "the number of fields in the prefab key and type disagree" + "key" (prefab-key->field-count new-key) + "fields" num-fields)) + (make-PrefabTop new-key)] [(:Refine^ [x:id :colon^ type:expr] prop:expr) ;; x is not in scope for the type (define t (parse-type #'type)) @@ -683,16 +697,27 @@ (-pair (parse-type #'fst) (parse-type #'rst))] [(:pred^ t) (make-pred-ty (parse-type #'t))] - [(:case->^ tys ...) + [((~and :case->^ operator) tys ...) + (when (eq? (syntax-e #'operator) 'case-lambda) + (log-message + (current-logger) + 'warning + (format "~a~a" + "The case-lambda type constructor is deprecated!" + " Please use case-> instead.") + stx)) (make-Fun - (for/list ([ty (in-syntax #'(tys ...))]) - (let ([t (parse-type ty)]) - (match t - [(Fun: (list arr)) arr] - [_ (parse-error - #:stx ty - "expected a function type for component of case-> type" - "given" t)]))))] + (remove-duplicates + (apply + append + (for/list ([ty (in-syntax #'(tys ...))]) + (let ([t (parse-type ty)]) + (match t + [(Fun: arrows) arrows] + [_ (parse-error + #:stx ty + "expected a function type for component of case-> type" + "given" t)]))))))] [(:Rec^ x:id t) (let* ([var (syntax-e #'x)] [tvar (make-F var)]) @@ -811,6 +836,7 @@ ;; let's keep going! (define arg-order (arg-deps->idx-order (attribute args.deps))) (define arg-type-dict (make-hasheq)) + ;; parse argument type syntax in the (dependency based) order (for ([idx (in-list arg-order)]) (define dep-ids (cdr (list-ref (attribute args.deps) idx))) (define-values (dep-local-ids dep-local-types) @@ -825,21 +851,40 @@ #:types dep-local-types] (with-local-term-names (map cons dep-ids dep-local-ids) (parse-type (list-ref (attribute args.type-stx) idx))))) - (hash-set! arg-type-dict idx idx-type)) + (define (abstract rep) (abstract-obj rep (attribute args.local-name))) (define dom (for/list ([idx (in-range (length arg-order))]) (hash-ref arg-type-dict idx))) (define abstracted-dom (map abstract dom)) + (define arg-idents (attribute args.name)) + (define arg-local-idents (attribute args.local-name)) + ;; type check the pre-condition with the specified args in scope + (define abstracted-pre-prop + (let-values ([(in-scope-arg-names + in-scope-arg-local-names + in-scope-arg-types) + (for/lists (_1 _2 _3) + ([arg-id (in-list arg-idents)] + [arg-local-id (in-list arg-local-idents)] + [arg-ty (in-list dom)] + #:when (member arg-id pre-deps free-identifier=?)) + (values arg-id arg-local-id arg-ty))]) + (with-extended-lexical-env + [#:identifiers in-scope-arg-local-names + #:types in-scope-arg-types] + (with-local-term-names (map cons + in-scope-arg-names + in-scope-arg-local-names) + (abstract (parse-prop #'pre-stx)))))) + ;; now type check the range (with-extended-lexical-env - [#:identifiers (attribute args.local-name) + [#:identifiers arg-local-idents #:types dom] (with-local-term-names (map cons - (attribute args.name) - (attribute args.local-name)) - (define pre-prop (parse-prop #'pre-stx)) - (define abstracted-pre-prop (abstract pre-prop)) + arg-idents + arg-local-idents) (match (parse-values-type #'rng-type) ;; single value'd return type, propositions/objects allowed [(Values: (list (Result: rng-t _ _))) @@ -968,19 +1013,37 @@ (parse-type #'rng) : (-PS (attribute latent.positive) (attribute latent.negative)) : (attribute latent.object)))] + ;; like ->* below but w/ a #:rest-pat present + [(:->*^ (~var mand (->*-args #t)) + (~optional (~var opt (->*-args #f)) + #:defaults ([opt.doms null] [opt.kws null])) + #:rest-star (rest-types-stx:non-keyword-ty ...) + rng) + (with-arity (length (attribute mand.doms)) + (define doms (map parse-type (attribute mand.doms))) + (define opt-doms (map parse-type (attribute opt.doms))) + (define rest-tys (stx-map parse-type #'(rest-types-stx ...))) + (cond + [(< (length rest-tys) 1) + (opt-fn doms opt-doms (parse-values-type #'rng) + #:kws (map force (append (attribute mand.kws) + (attribute opt.kws))))] + [else + (opt-fn doms opt-doms (parse-values-type #'rng) + #:rest (make-Rest rest-tys) + #:kws (map force (append (attribute mand.kws) + (attribute opt.kws))))]))] [(:->*^ (~var mand (->*-args #t)) (~optional (~var opt (->*-args #f)) #:defaults ([opt.doms null] [opt.kws null])) - rest:->*-rest + rest:optional->*-rest rng) (with-arity (length (attribute mand.doms)) - (define doms (for/list ([d (attribute mand.doms)]) - (parse-type d))) - (define opt-doms (for/list ([d (attribute opt.doms)]) - (parse-type d))) + (define doms (map parse-type (attribute mand.doms))) + (define opt-doms (map parse-type (attribute opt.doms))) (opt-fn doms opt-doms (parse-values-type #'rng) #:rest (and (attribute rest.type) - (parse-type (attribute rest.type))) + (make-Rest (list (parse-type (attribute rest.type))))) #:kws (map force (append (attribute mand.kws) (attribute opt.kws)))))] [:->^ diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -59,6 +59,8 @@ (type-inst type-inst) (row-inst row-inst) (type-label type-label) + (optional-non-immediate-arg optional-non-immediate-arg) + (optional-immediate-arg optional-immediate-arg) (type-dotted type-dotted) (exn-predicate typechecker:exn-predicate) (exn-handler typechecker:exn-handler) @@ -82,4 +84,5 @@ (tr:unit:invoke:expr tr:unit:invoke:expr) (tr:unit:compound tr:unit:compound) (tr:unit:from-context tr:unit:from-context #:mark) - (unsafe-provide unsafe-provide #:mark)) + (unsafe-provide unsafe-provide #:mark) + (typed-racket:ignore-type-information typed-racket:ignore-type-information)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,7 +6,7 @@ "../utils/utils.rkt" syntax/parse (rep type-rep prop-rep object-rep fme-utils) - (utils tc-utils) + (utils tc-utils prefab identifier) (env type-name-env row-constraint-env) (rep core-rep rep-utils free-ids type-mask values-rep base-types numeric-base-types) @@ -177,6 +177,7 @@ typed-racket/utils/utils (for-syntax typed-racket/utils/utils) typed-racket/utils/any-wrap typed-racket/utils/struct-type-c + typed-racket/utils/prefab-c typed-racket/utils/opaque-object typed-racket/utils/evt-contract typed-racket/utils/hash-contract @@ -471,7 +472,7 @@ ;; - because `HashTableTop` is a union containing `(Immutable-HashTable Any Any)` ;; - and `Any` makes a chaperone contract hash?/sc] - [(Union-all: elems) + [(Union-all-flat: elems) (define-values [hash-elems other-elems] (partition hash/kv? elems)) (define maybe-hash/sc (hash-types->sc hash-elems)) (if maybe-hash/sc @@ -492,7 +493,7 @@ (define prop (cond [(TrueProp? raw-prop) #f] - [else (define x (gen-pretty-id)) + [else (define x (genid)) (define prop (Intersection-prop (-id-path x) type)) (define name (format "~a" `(λ (,(syntax->datum x)) ,prop))) (flat-named-lambda/sc name @@ -705,7 +706,7 @@ [poly? (define nm* (generate-temporary #'n*)) (define fields - (for/list ([fty flds] [mut? mut?]) + (for/list ([fty (in-list flds)]) (t->sc fty #:recursive-values (hash-set recursive-values nm (recursive-sc-use nm*))))) @@ -717,6 +718,11 @@ (fail #:reason (~a "cannot import structure types from" "untyped code")) (struct-type/sc null))] + [(Prefab: key (list (app t->sc fld/scs) ...)) (prefab/sc key fld/scs)] + [(PrefabTop: key) + (flat/sc #`(struct-type-make-predicate + (prefab-key->struct-type (quote #,(abbreviate-prefab-key key)) + #,(prefab-key->field-count key))))] [(Syntax: (? Base:Symbol?)) identifier?/sc] [(Syntax: t) (syntax/sc (t->sc t))] @@ -736,6 +742,8 @@ (channel/sc (t->sc t))] [(Evt: t) (evt/sc (t->sc t))] + [(Rest: (list rst-t)) (listof/sc (t->sc rst-t))] + [(? Rest? rst) (t->sc (Rest->Type rst))] [(? Prop? rep) (prop->sc rep)] [_ (fail #:reason "contract generation not supported for this type")])))) @@ -812,7 +820,7 @@ (values (map conv mand-kws) (map conv opt-kws)))) (define range (map t->sc rngs)) - (define rest (and rst (listof/sc (t->sc/neg rst)))) + (define rest (and rst (t->sc/neg rst))) (function/sc (from-typed? typed-side) (process-dom mand-args) opt-args mand-kws opt-kws rest range)) (handle-arrow-range first-arrow convert-arrow)] [else @@ -827,7 +835,7 @@ " with optional keyword arguments"))) (if case-> (arr/sc (process-dom (map t->sc/neg dom)) - (and rst (listof/sc (t->sc/neg rst))) + (and rst (t->sc/neg rst)) (map t->sc rngs)) (function/sc (from-typed? typed-side) @@ -836,7 +844,7 @@ (map conv mand-kws) (map conv opt-kws) (match rst - [(? Type?) (listof/sc (t->sc/neg rst))] + [(? Rest?) (t->sc/neg rst)] [(RestDots: dty dbound) (listof/sc (t->sc/neg dty diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/base-types.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/base-types.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/base-types.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/base-types.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,6 +6,7 @@ (require "../utils/utils.rkt" (rep rep-utils base-type-rep type-mask core-rep) racket/undefined + racket/unsafe/undefined (types numeric-predicates) racket/extflonum ;; for base type contracts and predicates @@ -14,6 +15,7 @@ racket/base racket/contract/base racket/undefined + racket/unsafe/undefined racket/extflonum (only-in racket/pretty pretty-print-style-table?) (only-in racket/udp udp?) @@ -192,6 +194,10 @@ Undefined #'(λ (x) (eq? x undefined)) (λ (x) (eq? x undefined))] + [-Unsafe-Undefined + Unsafe-Undefined + #'(λ (x) (eq? x unsafe-undefined)) + (λ (x) (eq? x unsafe-undefined))] [-ExtFlVector ExtFlVector #'extflvector? extflvector?] ;; 80-bit floating-point numbers ;; +nan.t is included in all 80-bit floating-point types diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/object-rep.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/object-rep.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/object-rep.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/object-rep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,6 +9,7 @@ "fme-utils.rkt" racket/match "rep-utils.rkt" + (utils identifier) "core-rep.rkt" "free-variance.rkt" (env mvar-env) @@ -49,6 +50,9 @@ [#:frees (f) (f t)] [#:fmap (f) (make-StructPE (f t) idx)] [#:for-each (f) (f t)]) +;; NOTE: key must be the verbose/expanded key! (see utils/prefab.rkt) +(def-path-elem PrefabPE ([key prefab-key?] [idx natural-number/c]) + #:base) (def-path-elem VecLenPE () [#:singleton -vec-len]) @@ -69,6 +73,10 @@ (if (Empty? o) ;; lets not make the pe if we don't need to o (-path-elem-of (make-StructPE t idx) o))) +(define/provide (-prefab-idx-of key idx o) + (if (Empty? o) ;; lets not make the pe if we don't need to + o + (-path-elem-of (make-PrefabPE key idx) o))) ;; e.g. (car (cdr x)) == (make-Path (list -car -cdr) x) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/rep-utils.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/rep-utils.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/rep-utils.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/rep-utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ #lang racket/base (require "../utils/utils.rkt" - (utils tc-utils) + (utils tc-utils identifier) racket/match (contract-req) @@ -248,7 +248,6 @@ #:with free-idxs (fixed-rep-transform #'self #'f #'free-idxs* struct-fields #'body))) (define-syntax-class (constructor-spec constructor-name constructor-contract - internal-constructor-name raw-constructor-name raw-constructor-contract struct-fields) @@ -257,7 +256,6 @@ #:with def (with-syntax ([constructor-name constructor-name] [constructor-contract constructor-contract] - [internal-constructor-name internal-constructor-name] [raw-constructor-name raw-constructor-name] [raw-constructor-contract raw-constructor-contract] [(struct-fields ...) struct-fields]) @@ -331,7 +329,6 @@ . (~var constr-def (constructor-spec #'var.constructor #'(-> flds.contracts ... any) - #'var.internal-constructor #'var.raw-constructor #'(-> flds.contracts ... any) #'(flds.ids ...)))] @@ -340,7 +337,6 @@ . (~var constr-def (constructor-spec #'var.constructor #'custom-constructor-contract - #'var.internal-constructor #'var.raw-constructor #'(-> flds.contracts ... any) #'(flds.ids ...)))])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,7 +7,7 @@ (for-syntax "../utils/utils.rkt")) ;; TODO use contract-req -(require (utils tc-utils) +(require (utils tc-utils prefab identifier) "rep-utils.rkt" "core-rep.rkt" "object-rep.rkt" @@ -23,6 +23,7 @@ syntax/id-table racket/contract racket/lazy-require + racket/unsafe/undefined (for-syntax racket/base racket/syntax syntax/parse)) @@ -32,7 +33,7 @@ "base-union.rkt") Type Prop Object PathElem SomeValues) Type? - Mu-name: + Mu-maybe-name: Poly-names: Poly-fresh: PolyDots-names: PolyRow-names: PolyRow-fresh: @@ -58,7 +59,6 @@ -refine Refine: Refine-obj: - Refine-name: save-term-var-names! instantiate-type abstract-type @@ -66,7 +66,6 @@ abstract-obj substitute-names DepFun/ids: - DepFun/pretty-ids: (rename-out [Union:* Union:] [Intersection:* Intersection:] [make-Intersection* make-Intersection] @@ -78,6 +77,7 @@ [PolyDots:* PolyDots:] [PolyRow:* PolyRow:] [Mu* make-Mu] + [make-Mu unsafe-make-Mu] [Poly* make-Poly] [PolyDots* make-PolyDots] [PolyRow* make-PolyRow] @@ -508,6 +508,19 @@ (= (length kws) 1) (equal? kws (sort kws Keyword dom-len arity) + (error 'Arrow-domain-at-arity + "invalid arity! ~a @ ~a" a arity)] + [(= arity dom-len) (Arrow-dom a)] + [(Arrow-rst a) + => (match-lambda + [(Rest: rst-ts) + (define extra-args (- arity dom-len)) + (define-values (reps extra) + (quotient/remainder extra-args (length rst-ts))) + (unless (zero? extra) + (error 'Arrow-domain-at-arity + "invalid arity! ~a @ ~a" a arity)) + (append (Arrow-dom a) (repeat-list rst-ts reps))] + [_ #f])] + [else + (error 'Arrow-domain-at-arity + "invalid arity! ~a @ ~a" a arity)])) + ;; a standard function ;; + all functions are case-> under the hood (i.e. see 'arrows') ;; + each Arrow in 'arrows' may have a dependent range @@ -580,14 +635,14 @@ [#:for-each (f) (for-each f dom) (f pre) (f rng)]) -(define-for-syntax (DepFun-id-matcher id-fun) +(define-match-expander DepFun/ids: (λ (stx) (syntax-case stx () [(_ ids dom pre rng) (quasisyntax/loc stx (app (match-lambda [(DepFun: raw-dom raw-pre raw-rng) - (define fresh-ids (for/list ([_ (in-list raw-dom)]) (#,id-fun))) + (define fresh-ids (for/list ([_ (in-list raw-dom)]) (genid))) (define (instantiate rep) (instantiate-obj rep fresh-ids)) (list fresh-ids (map instantiate raw-dom) @@ -596,11 +651,6 @@ [_ #f]) (list ids dom pre rng)))]))) -(define-match-expander DepFun/ids: - (DepFun-id-matcher #'genid)) - -(define-match-expander DepFun/pretty-ids: - (DepFun-id-matcher #'gen-pretty-id)) ;;************************************************************ ;; Structs @@ -643,6 +693,13 @@ [pred-id (normalize-id pred-id)]) (make-Struct name parent flds proc poly? pred-id))]) + +(def-type StructTop ([name Struct?]) + [#:frees (f) (f name)] + [#:fmap (f) (make-StructTop (f name))] + [#:for-each (f) (f name)] + [#:mask (mask-union mask:struct mask:procedure)]) + ;; Represents prefab structs ;; key : prefab key encoding mutability, auto-fields, etc. ;; flds : the types of all of the prefab fields @@ -653,6 +710,17 @@ [#:for-each (f) (for-each f flds)] [#:mask mask:prefab]) +(def-type PrefabTop ([key prefab-key?]) + #:base + [#:mask mask:prefab] + [#:custom-constructor + (cond + [(prefab-key/mutable-fields? key) + (make-PrefabTop key)] + [else + (make-Prefab key (build-list (prefab-key->field-count key) + (λ (_) Univ)))])]) + (def-type StructTypeTop () [#:mask mask:struct-type] [#:singleton -StructTypeTop]) @@ -664,12 +732,6 @@ [#:for-each (f) (f s)] [#:mask mask:struct-type]) -(def-type StructTop ([name Struct?]) - [#:frees (f) (f name)] - [#:fmap (f) (make-StructTop (f name))] - [#:for-each (f) (f name)] - [#:mask (mask-union mask:struct mask:procedure)]) - ;;************************************************************ ;; Singleton Values (see also Base) @@ -695,6 +757,7 @@ [(? void?) -Void] [0 -Zero] [1 -One] + [(? (lambda (x) (eq? x unsafe-undefined))) -Unsafe-Undefined] [_ (make-Value val)])]) @@ -976,20 +1039,9 @@ (cons x (Intersection-prop* (-id-path x) i))) (cons x prop))))]))) -(define-match-expander Refine-name: - (lambda (stx) - (syntax-case stx () - [(_ x t prop) - (syntax/loc stx - (and (Intersection _ (not (TrueProp:)) _) - (app Intersection-w/o-prop t) - (app (λ (i) - (match-define (list x) (hash-ref term-var-name-table i (list (gen-pretty-id)))) - (cons x (Intersection-prop* (-id-path x) i))) - (cons x prop))))]))) - (define (save-term-var-names! t xs) - (hash-set! term-var-name-table t (map (λ (id) (gen-pretty-id (syntax->datum id))) xs))) + (hash-set! term-var-name-table t + (map (λ (id) (symbol->fresh-pretty-normal-id (syntax->datum id))) xs))) (define-match-expander Refine-obj: (λ (stx) (syntax-case stx () @@ -1527,13 +1579,15 @@ (list sym (Mu-body* sym t)))) (list np bp)))]))) -(define-match-expander Mu-name: +(define-match-expander Mu-maybe-name: (lambda (stx) (syntax-case stx () [(_ np bp) #'(? Mu? - (app (lambda (t) (let ([sym (hash-ref type-var-name-table t (lambda _ (gensym)))]) - (list sym (Mu-body* sym t)))) + (app (lambda (t) (let ([sym (hash-ref type-var-name-table t #f)]) + (if sym + (list sym (Mu-body* sym t)) + (list #f #f)))) (list np bp)))]))) ;; These match expanders correspond to opening up a type in diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,62 @@ +#lang racket/base + +;; Static contract for prefab/c. + +(require "../../utils/utils.rkt" + "../structures.rkt" + "../constraints.rkt" + (utils prefab) + racket/match + (contract-req) + (for-template racket/base "../../utils/prefab-c.rkt") + (for-syntax racket/base syntax/parse)) + + + +(provide prefab/sc:) + +(provide/cond-contract + [prefab/sc (prefab-key? (listof static-contract?) . -> . static-contract?)]) + +(struct prefab-combinator combinator (key field-mutability) + #:transparent + #:property prop:combinator-name "prefab/sc" + #:methods gen:sc + [(define (sc-map v f) + (match v + [(prefab-combinator args key field-mutability) + (prefab-combinator (map (λ (a mut?) (f a (if mut? 'invariant 'covariant))) + args + field-mutability) + key + field-mutability)])) + (define (sc-traverse v f) + (match v + [(prefab-combinator args key field-mutability) + (for-each (λ (a mut?) (f a (if mut? 'invariant 'covariant))) + args + field-mutability) + (void)])) + (define (sc->contract v f) + (match v + [(prefab-combinator args key _) + #`(prefab/c (quote #,(abbreviate-prefab-key key)) #,@(map f args))])) + (define (sc->constraints v f) + (match v + [(prefab-combinator args _ field-mutability) + (merge-restricts* + (if (ormap values field-mutability) 'chaperone 'flat) + (map (λ (a mut?) + (if (not mut?) (add-constraint (f a) 'chaperone) (f a))) + args + field-mutability))]))]) + +(define (prefab/sc key fields) + (prefab-combinator fields key (prefab-key->field-mutability key))) + + +(define-match-expander prefab/sc: + (syntax-parser + [(_ name fields) + #'(prefab-combinator fields name _)])) + diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,18 +2,27 @@ ;; Reprovides everything from all the files in the combinators directory. -(require (for-syntax racket/base racket/runtime-path)) +(define-syntax-rule (require/provide . args) + (begin + (require . args) + (provide (all-from-out . args)))) -(begin-for-syntax - (define-runtime-path combinator-dir "combinators") - (define base-file-names - (filter (lambda (v) (regexp-match? #rx".rkt$" v)) (directory-list combinator-dir))) - (define file-names (map (lambda (v) (string-append "combinators/" (path->string v))) - base-file-names))) - -(define-syntax (gen-provides stx) - #`(begin - (require #,@file-names) - (provide (all-from-out #,@file-names)))) - -(gen-provides) +(require/provide + "combinators/any.rkt" + "combinators/case-lambda.rkt" + "combinators/control.rkt" + "combinators/dep-function.rkt" + "combinators/derived.rkt" + "combinators/function.rkt" + "combinators/lengths.rkt" + "combinators/name.rkt" + "combinators/none.rkt" + "combinators/object.rkt" + "combinators/parametric.rkt" + "combinators/prefab.rkt" + "combinators/proposition.rkt" + "combinators/simple.rkt" + "combinators/struct.rkt" + "combinators/structural.rkt" + "combinators/symbolic-object.rkt" + "combinators/unit.rkt") diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -21,7 +21,7 @@ . ->* . static-contract?)]) ;; Reduce a static contract to a smaller simpler one that protects in the same way -(define (reduce sc) +(define (reduce sc flat-sc?) (match sc ;; none/sc cases [(listof/sc: (none/sc:)) empty-list/sc] @@ -60,6 +60,11 @@ [(? (λ (l) (member any/sc l))) any/sc] [(? (λ (l) (member none/sc l))) (apply or/sc (remove* (list none/sc) scs))] + [(? (λ (l) (ormap (match-lambda [(or/sc: _ ...) #true] [_ #false]) l))) + (define new-scs (flatten-or/sc scs flat-sc?)) + (if new-scs + (apply or/sc new-scs) + sc)] [else sc])] ;; and/sc cases @@ -108,18 +113,67 @@ [else sc])) +;; flatten-or/sc : (listof static-contract?) -> (listof static-contract?) +;; Basically, flatten a list `(list pre-scs ... (or/sc mid-scs ...) post-scs ...)` +;; to `(list pre-scs ... mid-scs ... post-scs ...)`, but: +;; - flatten all `or/sc` contracts in the given list +;; - remove duplicate contracts from the result +;; Uses `flat-sc?` to check that the `mid-scs ...` are either (1) all flat +;; or (2) all non-flat. Without this check, the flattened contract might +;; accept a value that the original contract failed for. Example: +;; consider `(or/c (or/c procedure? (-> boolean?)) (-> integer?))` +;; and `(or/c procedure? (-> boolean?) (-> integer?))` +;; and any thunk. The first contract fails and the second passes. +(define (flatten-or/sc scs flat-sc?) + (define flattened-any? (box #false)) + (define new-scs + (for/fold ([acc '()]) + ([sc (in-list scs)]) + (match sc + [(or/sc: inner-scs ...) + #:when (eq?*/f inner-scs flat-sc?) + (set-box! flattened-any? #true) + (set-union acc inner-scs)] + [_ + (set-add acc sc)]))) + (and (unbox flattened-any?) new-scs)) + +;; eq?*/f : (-> (listof a) (-> a b) boolean?) +;; Returns #true if (f x) is `eq?` to `(f y)` for all `x`, `y` in the given list. +(define (eq?*/f x* f) + (define undef 'undef) + (let loop ((x* x*) + (prev undef)) + (cond + [(null? x*) + #true] + [(eq? prev undef) + (loop (cdr x*) (f (car x*)))] + [(eq? prev (f (car x*))) + (loop (cdr x*) prev)] + [else + #false]))) ;; Reduce a static contract assuming that we trusted the current side -(define ((make-trusted-side-reduce flat-sc?) sc) +;; If `is-weak-side?` is true, then preserve the "head constructor" of the +;; result --- if `((make-trusted-side-reduce ...) sc #true) = sc+`, then +;; both `sc` and `sc+` must give the same answer to `contract-first-order` +;; after instantiation. +(define ((make-trusted-side-reduce flat-sc?) sc is-weak-side?) (match sc [(->/sc: mand-args opt-args mand-kw-args opt-kw-args rest-arg (list (any/sc:) ...)) (function/sc #t mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)] [(arr/sc: args rest (list (any/sc:) ...)) (arr/sc args rest #f)] [(none/sc:) any/sc] - [(or/sc: (? flat-sc?) ...) any/sc] - [(? flat-sc?) any/sc] + [(or/sc: (? flat-sc?) ...) + #:when (not is-weak-side?) + any/sc] + [(? flat-sc?) + #:when (not is-weak-side?) + any/sc] [(syntax/sc: (? recursive-sc?)) + #:when (not is-weak-side?) ;;bg; _temporary_ case to allow contracts from the `Syntax` type. ;; This is temporary until TR has types for immutable-vector ;; and box-immutable & changes the definition of the `Syntax` type. @@ -134,11 +188,20 @@ (define (side? v) (memq v '(positive negative both))) -;; A _weak side_ is a side that is currently unsafe to optimize +;; A _weak side_ is a side that may be optimized with caution --- optimization +;; cannot change the value of `contract-first-order` on the result. ;; Example: ;; when optimizing an `(or/sc scs ...)` on the 'positive side, ;; each of the `scs` should be optimized on the '(weak positive) side, ;; and their sub-contracts --- if any --- may be optimized on the 'positive side +;; +;; - `(or/sc integer? (-> boolean? boolean?))` +;; ==> `(or/sc integer? (-> boolean? any))` +;; is OK +;; - `(or/sc integer? (-> boolean? boolean?))` +;; ==> `(or/sc any/c (-> boolean? boolean?))` +;; is NOT ok, because the second contract accepts any value and will +;; let typed functions cross without protection into untyped code. (define (weak-side? x) (match x [(list 'weak (? side?)) @@ -196,6 +259,7 @@ (arr/sc: _ _ _) (async-channel/sc: _) (box/sc: _) + (case->/sc: _) (channel/sc: _) (cons/sc: _ _) (continuation-mark-key/sc: _) @@ -211,12 +275,14 @@ (sequence/sc: _ ...) (set/sc: _) (struct/sc: _ _) + (prefab/sc: _ _) (syntax/sc: _) (vector/sc: _ ...) (vectorof/sc: _) (weak-hash/sc: _ _)) #true] [_ + ;; class/sc object/sc rec/sc ... #false])) (define (remove-unused-recursive-contracts sc) @@ -314,17 +380,16 @@ ;; single-step: reduce and trusted-side-reduce if appropriate (define (single-step sc maybe-weak-side) (define trusted - (if (weak-side? maybe-weak-side) - #false - (case maybe-weak-side - [(positive) trusted-positive] - [(negative) trusted-negative] - [(both) (and trusted-positive trusted-negative)]))) + (case (strengthen-side maybe-weak-side) + [(positive) trusted-positive] + [(negative) trusted-negative] + [(both) (and trusted-positive trusted-negative)])) (reduce (if trusted - (trusted-side-reduce sc) - sc))) + (trusted-side-reduce sc (weak-side? maybe-weak-side)) + sc) + flat-sc?)) ;; full-pass: single-step at every static contract subpart (define (full-pass sc) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -10,9 +10,11 @@ (typecheck error-message tc-envops)) (provide/cond-contract - [check-below (-->i ([s (-or/c Type? full-tc-results/c)] - [t (s) (if (Type? s) Type? tc-results/c)]) - [_ (s) (if (Type? s) Type? full-tc-results/c)])] + [check-below (-->i ([s (t) (if (Type? t) + (-or/c full-tc-results/c Type?) + full-tc-results/c)] + [t (-or/c Type? tc-results/c)]) + [_ (t) (if (Type? t) Type? full-tc-results/c)])] [cond-check-below (-->i ([s (-or/c Type? full-tc-results/c)] [t (s) (-or/c #f (if (Type? s) Type? tc-results/c))]) [_ (s) (-or/c #f (if (Type? s) Type? full-tc-results/c))])]) @@ -49,7 +51,6 @@ ;; check-below : (/\ (Results Type -> Result) ;; (Results Results -> Result) -;; (Type Results -> Type) ;; (Type Type -> Type)) (define (check-below tr1 expected) (define (prop-set-better? p1 p2) @@ -83,6 +84,18 @@ [(_ _) #f])) (match* (tr1 expected) + + [((tc-result1: t1 p1 o1) (? Type? t2)) + (cond + [(with-refinements?) + (with-naively-extended-lexical-env + [#:props (list (-is-type o1 t1) + (-or (PropSet-thn p1) (PropSet-els p1)))] + (unless (subtype t1 t2 o1) + (expected-but-got t2 t1)))] + [else (unless (subtype t1 t2 o1) + (expected-but-got t2 t1))]) + t2] ;; This case has to be first so that bottom (exceptions, etc.) can be allowed in cases ;; where multiple values are expected. ;; We can ignore the props and objects in the actual value because they would never be about a value @@ -105,7 +118,6 @@ (type-mismatch p2 merged-prop "mismatch in proposition")) (-tc-any-results (fix-props p2 merged-prop))] - [((tc-result1: t1 p1 o1) (tc-result1: t2 p2 o2)) (define (perform-check!) (cond diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,6 +13,7 @@ "signatures.rkt" (private parse-type syntax-properties) (env lexical-env tvar-env global-env type-alias-helper mvar-env) + (base-env annotate-classes) (types utils abbrev subtype resolve generalize) (typecheck check-below internal-forms) (utils tc-utils mutated-vars) @@ -233,7 +234,11 @@ kw:kw-lambda^) #:do [(register/method #'meth-name)] #:with props-core - (kw-lambda-property #'kw-core (attribute kw.value)) + (let ([kw-val (attribute kw.value)]) + (kw-lambda-property + #'kw-core + (struct-copy lambda-kws kw-val + [pos-mand-count (add1 (lambda-kws-pos-mand-count kw-val))]))) #:with plam-core (cond [(plambda-property this-syntax) => (λ (plam) (plambda-property #'props-core plam))] @@ -249,8 +254,9 @@ #:with props-core (let* ([prop-val (attribute opt.value)] [mand (add1 (car prop-val))] - [opt (cadr prop-val)]) - (opt-lambda-property #'opt-core (list mand opt))) + [opt (cadr prop-val)] + [opt-supplied? (caddr prop-val)]) + (opt-lambda-property #'opt-core (list mand opt opt-supplied?))) #:with plam-core (cond [(plambda-property this-syntax) => (λ (plam) (plambda-property #'props-core plam))] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -56,12 +56,12 @@ (tc/funapp #'here #'(here) t (list (ret arg1)) #f)] [(Fun: (list _ ... (Arrow: (list) - (? Type? rst) + (Rest: (list rst-t)) (list (Keyword: _ _ #f) ...) _ ) _ ...)) - #:when (subtype prop-type rst) - (tc/funapp #'here #'(here) t (list (ret rst)) #f)] + #:when (subtype prop-type rst-t) + (tc/funapp #'here #'(here) t (list (ret rst-t)) #f)] [(? resolvable? t) (loop (resolve t))] [(or (Poly: ns _) (PolyDots: (list ns ... _) _)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,228 @@ +#lang racket/base + +(require "../utils/utils.rkt" + (prefix-in c: (contract-req)) + (types abbrev subtype numeric-tower prop-ops) + (types tc-result type-table) + racket/match + syntax/private/id-table + syntax/parse + (for-syntax racket/base)) + +(provide/cond-contract + [has-linear-integer-refinements? (c:-> identifier? boolean?)] + [maybe-add-linear-integer-refinements (c:-> identifier? syntax? full-tc-results/c + full-tc-results/c)]) + +(define (has-linear-integer-refinements? id) + (and (free-id-table-ref linear-integer-function-table id #f) #t)) + +(define (maybe-add-linear-integer-refinements id args-stx result) + (cond + [(free-id-table-ref linear-integer-function-table id #f) + => (λ (f) (f args-stx result))] + [else result])) + +;; takes a result and adds p to the then proposition +;; and (not p) to the else proposition +(define (add-p/not-p result p) + (match result + [(tc-result1: t (PropSet: p+ p-) o) + (ret t + (-PS (-and p p+) (-and (negate-prop p) p-)) + o)] + [_ result])) + +(define (add-to-pos-side result p) + (match result + [(tc-result1: t (PropSet: p+ p-) o) + (ret t + (-PS (-and p p+) p-) + o)] + [_ result])) + +;; class to recognize expressions that typecheck at a subtype of `type` +(define-syntax-class (w/obj+type type) + #:attributes (obj) + (pattern e:expr + #:do [(define o + (match (type-of #'e) + [(tc-result1: t _ (? Object? o)) + #:when (subtype t type) + o] + [_ #f]))] + #:fail-unless o (format "not a ~a expr with a non-empty object" type) + #:attr obj o)) + +(define-syntax-class (w/type type) + #:attributes (obj) + (pattern e:expr + #:do [(define o + (match (type-of #'e) + [(tc-result1: t _ o) + #:when (subtype t type) + o] + [_ #f]))] + #:fail-unless o (format "not a ~a expr with a non-empty object" type) + #:attr obj (if (Object? o) o -empty-obj))) + +;; < <= >= = +(define (numeric-comparison-function prop-constructor) + (λ (args-stx result) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) + (define p (prop-constructor (attribute e1.obj) (attribute e2.obj))) + (add-p/not-p result p)] + [((~var e1 (w/type -Int)) (~var e2 (w/type -Int)) (~var e3 (w/type -Int))) + #:when (or (and (Object? (attribute e1.obj)) (Object? (attribute e2.obj))) + (and (Object? (attribute e2.obj)) (Object? (attribute e3.obj)))) + (define p (-and (prop-constructor (attribute e1.obj) (attribute e2.obj)) + (prop-constructor (attribute e2.obj) (attribute e3.obj)))) + (add-p/not-p result p)] + [_ result]))) + +;; +/- +(define (plus/minus plus?) + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + ;; +/- (2 args) + [((~var e1 (w/obj+type -Int)) + (~var e2 (w/obj+type -Int))) + (define (sign o) (if plus? o (scale-obj -1 o))) + (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) + ps + l)] + ;; +/- (3 args) + [((~var e1 (w/obj+type -Int)) + (~var e2 (w/obj+type -Int)) + (~var e3 (w/obj+type -Int))) + (define (sign o) (if plus? o (scale-obj -1 o))) + (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)) (sign (attribute e3.obj)))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) + ps + l)] + [_ result])] + [_ result]))) + +;; equal?/eqv?/eq? +;; if only one side is a supported type, we can learn integer equality for +;; a result of `#t`, whereas if both sides are of the supported type, +;; we learn on both `#t` and `#f` answers +(define (equality-function supported-type) + (λ (args-stx result) + (syntax-parse args-stx + [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type supported-type))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-p/not-p result p)] + [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type Univ))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-to-pos-side result p)] + [((~var e1 (w/obj+type Univ)) (~var e2 (w/obj+type supported-type))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-to-pos-side result p)] + [_ result]))) + +;; * +(define product-function + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) + (define product-obj (-obj* (attribute e1.obj) (attribute e2.obj))) + (cond + [(Object? product-obj) + (ret (-refine/fresh x ret-t (-eq (-lexp x) product-obj)) + ps + product-obj)] + [else result])] + [_ result])] + [_ result]))) + +;; make-vector +(define make-vector-function + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var size (w/obj+type -Int)) . _) + (ret (-refine/fresh v ret-t (-eq (-lexp (-vec-len-of (-id-path v))) + (attribute size.obj))) + ps + orig-obj)] + [_ result])] + [_ result]))) + +;; modulo +(define modulo-function + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/type -Int)) (~var e2 (w/obj+type -Nat))) + (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e2.obj))) + ps + orig-obj)] + [_ result])] + [_ result]))) + +;; random +(define random-function + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + ;; random (1 arg) + [((~var e1 (w/obj+type -Nat))) + (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e1.obj))) + ps + orig-obj)] + ;; random (2 arg) + [((~var e1 (w/type -Int)) (~var e2 (w/type -Int))) + #:when (or (Object? (attribute e1.obj)) + (Object? (attribute e2.obj))) + (ret (-refine/fresh x ret-t (-and (-leq (attribute e1.obj) (-lexp x)) + (-lt (-lexp x) (attribute e2.obj)))) + ps + orig-obj)] + [_ result])] + [_ result]))) + +;; add1 / sub1 +(define (add/sub-1-function add?) + (λ (args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int))) + (define l ((if add? -lexp-add1 -lexp-sub1) (attribute e1.obj))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) + ps + l)] + [_ result])] + [_ result]))) + +(define linear-integer-function-table + (make-immutable-free-id-table + (list + (cons #'< (numeric-comparison-function -lt)) + (cons #'<= (numeric-comparison-function -leq)) + (cons #'> (numeric-comparison-function -gt)) + (cons #'>= (numeric-comparison-function -geq)) + (cons #'= (numeric-comparison-function -eq)) + (cons #'eqv? (equality-function -Int)) + (cons #'equal? (equality-function -Int)) + (cons #'eq? (equality-function -Fixnum)) + (cons #'+ (plus/minus #t)) + (cons #'- (plus/minus #f)) + (cons #'* product-function) + (cons #'make-vector make-vector-function) + (cons #'modulo modulo-function) + (cons #'random random-function) + (cons #'add1 (add/sub-1-function #t)) + (cons #'sub1 (add/sub-1-function #f))) + #:phase -1)) + diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -31,6 +31,7 @@ type-declaration typed-define-signature typed-define-values/invoke-unit + assert-typecheck-failure typecheck-failure type-alias? @@ -63,6 +64,7 @@ assert-predicate-internal declare-refinement-internal :-internal + assert-typecheck-fail-internal typecheck-fail-internal define-signature-internal define-values/invoke-unit-internal)) @@ -182,6 +184,11 @@ #:literal-sets (kernel-literals internal-literals) (pattern (quote-syntax (typecheck-fail-internal stx message:str var) #:local))) +(define-syntax-class assert-typecheck-failure + #:literal-sets (kernel-literals internal-literals) + (pattern (quote-syntax (assert-typecheck-fail-internal body:expr) #:local))) + + ;;; Internal form creation (define (internal stx) (quasisyntax/loc stx diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -71,18 +71,16 @@ (define orig (map list doms rngs rests)) - (define cases - (map (compose make-Fun list make-Arrow) - doms - rests - (make-list (length doms) null) - (map (match-lambda ; strip props - [(AnyValues: f) (-AnyValues -tt)] - [(Values: (list (Result: t _ _) ...)) - (-values t)] - [(ValuesDots: (list (Result: t _ _) ...) _ _) - (-values t)]) - rngs))) + (define cases (for/list ([d (in-list doms)] + [rst (in-list rests)] + [rng (in-list rngs)]) + (make-Fun (list (make-Arrow d rst null + (match rng ; strip props from range + [(AnyValues: f) (-AnyValues -tt)] + [(Values: (list (Result: t _ _) ...)) + (-values t)] + [(ValuesDots: (list (Result: t _ _) ...) _ _) + (-values t)])))))) ;; iterate in lock step over the function types we analyze and the parts ;; that we will need to print the error message, to make sure we throw @@ -113,9 +111,9 @@ ;; function types with a return type of any then test for subtyping (define fun-tys-ret-any (map (match-lambda - [(Fun: (list (Arrow: dom rest _ _))) + [(Fun: (list (Arrow: dom rst _ _))) (make-Fun (list (make-Arrow dom - rest + rst null (-values (list Univ)))))]) candidates)) @@ -163,10 +161,9 @@ ;; the original, which may confuse `:print-type''s pruning detection) t ;; pruning helped, return pruned type - (make-Fun (map make-Arrow - pdoms - rests - (make-list (length pdoms) null) - rngs))))] + (make-Fun (for/list ([pdom (in-list pdoms)] + [rst (in-list rests)] + [rng (in-list rngs)]) + (make-Arrow pdom rst null rng)))))] ;; not a function type. keep as is. [_ t])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -33,7 +33,15 @@ ([cond-contracted tc/if-twoarm ((syntax? syntax? syntax?) ((or/c tc-results/c #f)) . ->* . full-tc-results/c)])) (define-signature tc-literal^ - ([cond-contracted tc-literal (->* (syntax?) ((or/c Type? #f)) Type?)])) + ([cond-contracted tc-literal (->* (syntax?) ((or/c Type? #f)) Type?)] + [cond-contracted tc-hash (-> (-> any/c (or/c Type? #f) Type?) + hash? + (or/c Type? #f) + Type?)] + [cond-contracted tc-prefab (-> (-> any/c (or/c Type? #f) Type?) + prefab-struct-key ;; i.e. a prefab struct instance + (or/c Type? #f) + Type?)])) (define-signature tc-send^ ([cond-contracted tc/send ((syntax? syntax? diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ (require "../../utils/utils.rkt" "signatures.rkt" "utils.rkt" - syntax/parse syntax/stx racket/match + syntax/parse syntax/stx racket/match racket/unsafe/undefined (typecheck signatures tc-funapp) (types abbrev prop-ops utils match-expanders) (rep type-rep object-rep) @@ -38,7 +38,7 @@ ;; typecheck eq? applications ;; identifier expr expr -> tc-results (define (tc/eq comparator v1 v2) - (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e))) + (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e) (eq? e unsafe-undefined))) (define (eqv?-able e) (or (eq?-able e) (number? e) (char? e))) (define (equal?-able e) #t) (define (id=? a b) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,6 +4,7 @@ syntax/parse syntax/stx racket/match racket/sequence "signatures.rkt" "utils.rkt" + (utils prefab) (types utils abbrev numeric-tower resolve type-table generalize match-expanders) (typecheck signatures check-below) @@ -93,6 +94,12 @@ (tc/hetero-ref #'index flds struct-t "struct" #'op)] [(tc-result1: (and struct-t (app resolve (Prefab: _ (list flds ...))))) (tc/hetero-ref #'index flds struct-t "prefab struct" #'op)] + [(tc-result1: (and struct-t (app resolve (PrefabTop: key)))) + (tc/hetero-ref #'index + (build-list (prefab-key->field-count key) (λ (_) Univ)) + struct-t + "prefab struct" + #'op)] [s-ty (tc/app-regular #'form expected)])) ;; vector-ref on het vectors (pattern (~and form ((~and op (~or vector-ref unsafe-vector-ref unsafe-vector*-ref)) vec:expr index:expr)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ syntax/parse racket/match syntax/parse/experimental/reflect "../signatures.rkt" "../tc-funapp.rkt" + "../integer-refinements.rkt" (types abbrev utils prop-ops) (env lexical-env) (typecheck tc-subst tc-envops check-below) @@ -47,8 +48,6 @@ [(#%plain-app . (~var v (tc/app-special-cases expected))) ((attribute v.check))])) - - ;; TODO: handle drest, and props/objects (define (arrow-matches? arr args) (match arr @@ -59,10 +58,7 @@ (PropSet: (TrueProp:) (TrueProp:)) (Empty:)) ...))) - (cond - [(< (length domain) (length args)) rst] - [(= (length domain) (length args)) #t] - [else #f])] + (Arrow-includes-arity? domain rst args)] [_ #f])) (define (has-props? arr) @@ -102,22 +98,28 @@ (tc/funapp #'f #'args f-ty (map tc-dep-fun-arg args*) expected))] [(Fun: (app matching-arities (list (Arrow: doms rsts _ _) ..1))) + (define check-arg (if (and (identifier? #'f) + (with-refinements?) + (has-linear-integer-refinements? #'f)) + tc-dep-fun-arg + single-value)) ;; if for a particular argument, all of the domain types ;; agree for each arrow type in the case->, then we use ;; that type to check the argument expression against (define arg-types (for/list ([arg-stx (in-list args*)] [arg-idx (in-naturals)]) - (define dom-ty (list-ref/default (car doms) - arg-idx - (car rsts))) + (define dom-ty (dom+rst-ref (car doms) (car rsts) arg-idx)) (cond - [(for/and ([dom (in-list doms)] - [rst (in-list rsts)]) - (equal? dom-ty - (list-ref/default dom arg-idx rst))) - (single-value arg-stx (ret dom-ty))] - [else (single-value arg-stx)]))) + [(for/and ([dom (in-list (cdr doms))] + [rst (in-list (cdr rsts))]) + (equal? dom-ty (dom+rst-ref dom rst arg-idx))) + (check-arg arg-stx (ret dom-ty))] + [else (check-arg arg-stx)]))) (tc/funapp #'f #'args f-ty arg-types expected)] + [_ #:when (and (identifier? #'f) + (with-refinements?) + (has-linear-integer-refinements? #'f)) + (tc/funapp #'f #'args f-ty (map tc-dep-fun-arg args*) expected)] [_ (tc/funapp #'f #'args f-ty (map single-value args*) expected)]))])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require "../utils/utils.rkt" + (utils identifier) racket/match racket/sequence racket/set racket/list (contract-req) (typecheck check-below tc-subst tc-metafunctions possible-domains) @@ -16,32 +17,56 @@ ((syntax? stx-list? Arrow? (listof tc-results/c) (or/c #f tc-results/c)) (#:check boolean?) . ->* . full-tc-results/c)]) -(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) +(define (tc/funapp1 f-stx args-stx ftype0 arg-ress expected #:check [check? #t]) ;; update tooltip-table with inferred function type (add-typeof-expr f-stx (ret (make-Fun (list ftype0)))) - (match* (ftype0 argtys) + (match* (ftype0 arg-ress) ;; we check that all kw args are optional - [((Arrow: dom rest (list (Keyword: _ _ #f) ...) rng) + [((Arrow: dom rst (list (Keyword: _ _ #f) ...) rng) (list (tc-result1: t-a _ o-a) ...)) - #:when (not (RestDots? rest)) + #:when (not (RestDots? rst)) (when check? - (cond [(and (not rest) (not (= (length dom) (length t-a)))) + (define extra-arg-count (- (length t-a) (length dom))) + (cond [(and (not rst) (not (eqv? 0 extra-arg-count))) (tc-error/fields "could not apply function" #:more "wrong number of arguments provided" "expected" (length dom) "given" (length t-a) #:delayed? #t)] - [(and rest (< (length t-a) (length dom))) + [(and rst (negative? extra-arg-count)) (tc-error/fields "could not apply function" #:more "wrong number of arguments provided" "expected at least" (length dom) "given" (length t-a) - #:delayed? #t)]) - (for ([dom-t (if rest (in-list/rest dom rest) (in-list dom))] - [a (in-syntax args-stx)] - [arg-t (in-list t-a)]) - (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) + #:delayed? #t)] + [(and (Rest? rst) + (positive? extra-arg-count) + (not (zero? (remainder extra-arg-count (length (Rest-tys rst)))))) + (cond + [(eqv? 2 (length (Rest-tys rst))) + (tc-error/fields "could not apply function" + #:more "wrong number of rest arguments provided" + "expected an even number, given" extra-arg-count + #:delayed? #t)] + [else (tc-error/fields "could not apply function" + #:more "wrong number of rest arguments provided" + "expected a multiple of " (length (Rest-tys rst)) + "given" extra-arg-count + #:delayed? #t)])]) + (match rst + [(Rest: rst-ts) + (for ([a (in-syntax args-stx)] + [arg-res (in-list arg-ress)] + [idx (in-naturals)]) + (parameterize ([current-orig-stx a]) + (check-below arg-res (dom+rst-ref dom rst idx))))] + [_ + (for ([dom-t (in-list dom)] + [a (in-syntax args-stx)] + [arg-res (in-list arg-ress)]) + (parameterize ([current-orig-stx a]) + (check-below arg-res dom-t)))])) (let ([dom-count (length dom)]) ;; Currently do nothing with rest args and keyword args ;; as there are no support for them in objects yet. @@ -64,7 +89,7 @@ "missing keyword" (car (filter Keyword-required? kws))))] [((Arrow: _ (? RestDots? drest) '() _) _) - (int-err "funapp with drest args ~a ~a NYI" drest argtys)] + (int-err "funapp with drest args ~a ~a NYI" drest arg-ress)] [((Arrow: _ _ kws _) _) (int-err "funapp with keyword args ~a NYI" kws)])) @@ -85,7 +110,7 @@ ;; but arguments were String (define/cond-contract (stringify-domain dom rst [rng #f]) (->* ((listof (or/c Type? tc-results/c)) - (or/c #f Type? RestDots?)) + (or/c #f Type? Rest? RestDots?)) ((or/c Type? SomeValues? tc-results/c)) string?) (let ([doms-string (if (null? dom) "" (stringify (map make-printable dom)))] @@ -96,7 +121,10 @@ [rst (format "~a~a~a" doms-string - (if rst (format "~a *" rst) "") + (match rst + [(Rest: rst-ts) (format "(~a)*" rst)] + [(? Type?) (format "~a *" rst)] + [_ ""]) rng-string)]))) ;; creates a "pretty-printed" version of the arguments @@ -119,7 +147,7 @@ ;; Generates error messages when operand types don't match operator domains. (provide/cond-contract [domain-mismatches - ((syntax? syntax? Type? (listof (listof Type?)) (listof (or/c #f Type? RestDots?)) + ((syntax? syntax? Type? (listof (listof Type?)) (listof (or/c #f Rest? RestDots?)) (listof SomeValues?) (listof tc-results?) (or/c #f Type?) any/c) (#:expected (or/c #f tc-results/c) #:return tc-results? @@ -290,24 +318,28 @@ ""))))))] [(Poly-names: msg-vars - (DepFun/pretty-ids: ids domain _ rng)) - (let ([fcn-string (name->function-str name)]) - (if (and (null? domain) - (null? argtypes)) - (tc-error/expr (string-append - "Could not infer types for applying polymorphic " - fcn-string - "\n")) - (domain-mismatches f-stx args-stx t (list domain) (list #f) - (list rng) argtypes #f #f #:expected expected - #:msg-thunk (lambda (dom) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:\n" - dom - (if (not (subset? (fv/list domain) (list->seteq msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - ""))) - #:arg-names ids)))] + (DepFun: raw-domain _ raw-rng)) + (with-printable-names (length raw-domain) names + (define domain (for/list ([d (in-list raw-domain)]) + (instantiate-obj d names))) + (define rng (instantiate-obj rng names)) + (let ([fcn-string (name->function-str name)]) + (if (and (null? domain) + (null? argtypes)) + (tc-error/expr (string-append + "Could not infer types for applying polymorphic " + fcn-string + "\n")) + (domain-mismatches f-stx args-stx t (list domain) (list #f) + (list rng) argtypes #f #f #:expected expected + #:msg-thunk (lambda (dom) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:\n" + dom + (if (not (subset? (fv/list domain) (list->seteq msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + ""))) + #:arg-names names))))] [(or (Poly-names: msg-vars (Fun: (list (Arrow: msg-doms msg-rests kws msg-rngs) ...))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -46,7 +46,7 @@ (match f-ty [(tc-result1: (and t (AnyPoly-names: _ _ - (Fun: (list (Arrow: doms rests (list (Keyword: _ _ #f) ...) rngs) ..1))))) + (Fun: (list (Arrow: doms rests (list (Keyword: _ _ #f) ...) rngs) ..1))))) (domain-mismatches f args t doms rests rngs arg-tres full-tail-ty #f #:msg-thunk (lambda (dom) (string-append @@ -64,7 +64,7 @@ (for/or ([arrow (in-list arrows)]) (match arrow [(Arrow: domain rst _ rng) - ;; Takes a possible substitution and comuptes + ;; Takes a possible substitution and computes ;; the substituted range type if it is not #f (define (finish substitution) (begin0 @@ -73,16 +73,7 @@ (finish (infer vars dotted-vars (list (-Tuple* arg-tys full-tail-ty)) - (list (-Tuple* domain - (match rst - ;; the actual work, when we have a * function - [(? Type?) (make-Listof rst)] - ;; ... function - [(RestDots: dty dbound) - (make-ListDots dty dbound)] - ;; the function has no rest argument, - ;; but provides all the necessary fixed arguments - [_ -Null]))) + (list (-Tuple* domain (Rest->Type rst))) rng))])) (failure))] [(tc-result1: (AnyPoly: _ _ (Fun: '()))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,7 +7,7 @@ (rep type-rep prop-rep object-rep rep-utils) (utils tc-utils) racket/set - (types tc-result resolve update prop-ops subtract) + (types tc-result resolve update prop-ops subtract path-type) (env type-env-structs lexical-env mvar-env) (only-in (infer infer) intersect) (rename-in (types abbrev) @@ -32,11 +32,12 @@ (define-values (props atoms) (combine-props ps (env-props env))) (cond [props - (let loop ([ps atoms] + (let loop ([todo atoms] + [atoms '()] [negs '()] [new '()] [Γ (env-replace-props env props)]) - (match ps + (match todo [(cons p ps) ;; update-obj-pos-type : (listof Prop?) env? Object? Type? -> env or #f ;; sometimes we need to update the object's type directly -- this helper @@ -46,12 +47,16 @@ (define new-t (intersect t pt obj)) (cond [(Bottom? new-t) #f] - [(equal? t new-t) (loop ps negs new Γ)] + [(equal? t new-t) (loop ps (cons p atoms) negs new Γ)] [else ;; it's a new type! check if there are any logical propositions that can ;; be extracted from new-t (define-values (new-t* new-props) (extract-props obj new-t)) - (loop ps negs (append new-props new) (env-set-obj-type Γ obj new-t*))]))) + (loop ps + (cons (-is-type obj new-t*) atoms) + negs + (append new-props new) + (env-set-obj-type Γ obj new-t*))]))) (match p [(TypeProp: (and obj (Path: pes (? identifier? x))) pt) (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))]) @@ -62,7 +67,7 @@ (cond [(ormap uninterpreted-PE? pes) (update-obj-pos-type new Γ obj pt)] - [else (loop ps negs new Γ)])] + [else (loop ps (cons p atoms) negs new Γ)])] [else ;; it's a new type! check if there are any logical propositions that can ;; be extracted from new-t @@ -77,7 +82,11 @@ obj pt)] [else - (loop ps negs (append new-props new) (env-set-id-type Γ x new-t*))])]))] + (loop ps + (cons (-is-type obj (path-type pes new-t*)) atoms) + negs + (append new-props new) + (env-set-id-type Γ x new-t*))])]))] [(TypeProp: obj pt) (update-obj-pos-type new Γ obj pt)] ;; process negative info _after_ positive info so we don't miss anything! @@ -85,9 +94,10 @@ ;; with x ∉ String and then x ∈ String just produces a Γ with x ∈ String, ;; but updating with x ∈ String _and then_ x ∉ String derives a contradiction) [(? NotTypeProp?) - (loop ps (cons p negs) new Γ)] - [_ (loop ps negs new Γ)])] + (loop ps atoms (cons p negs) new Γ)] + [_ (loop ps atoms negs new Γ)])] [_ (let loop ([negs negs] + [atoms atoms] [new new] [Γ Γ]) (match negs @@ -100,12 +110,15 @@ (define new-t (subtract t pt)) (cond [(Bottom? new-t) #f] - [(equal? t new-t) (loop negs new Γ)] + [(equal? t new-t) (loop negs (cons p atoms) new Γ)] [else ;; it's a new type! check if there are any logical propositions that can ;; be extracted from new-t (define-values (new-t* new-props) (extract-props obj new-t)) - (loop negs (append new-props new) (env-set-obj-type Γ obj new-t*))]))) + (loop negs + (cons (-is-type obj new-t*) atoms) + (append new-props new) + (env-set-obj-type Γ obj new-t*))]))) (match p [(NotTypeProp: (and obj (Path: pes (? identifier? x))) pt) (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))]) @@ -116,7 +129,7 @@ (cond [(ormap uninterpreted-PE? pes) (update-obj-neg-type new Γ obj pt)] - [else (loop negs new Γ)])] + [else (loop negs (cons p atoms) new Γ)])] [else ;; it's a new type! check if there are any logical propositions that can ;; be extracted from new-t @@ -131,7 +144,10 @@ obj pt)] [else - (loop negs (append new-props new) (env-set-id-type Γ x new-t*))])]))] + (loop negs + (cons p atoms) + (append new-props new) + (env-set-id-type Γ x new-t*))])]))] [(NotTypeProp: obj pt) (update-obj-neg-type new Γ obj pt)])] [_ @@ -200,4 +216,4 @@ (with-lexical-env new-env (let () . b))] - [else absurd])))])) + [else absurd])))])) \ No newline at end of file diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,13 +5,14 @@ racket/match (prefix-in - (contract-req)) "signatures.rkt" "check-below.rkt" "../types/kw-types.rkt" + "integer-refinements.rkt" (types utils abbrev subtype type-table path-type prop-ops overlap resolve generalize tc-result numeric-tower) (private-in syntax-properties parse-type) (rep type-rep prop-rep object-rep) (only-in (infer infer) intersect) - (utils tc-utils) + (utils tc-utils identifier) (env lexical-env scoped-tvar-env) racket/list racket/private/class-internal @@ -75,6 +76,13 @@ (--> syntax? Type? tc-results/c) (tc-expr/check form (ret expected))) +;; form : what expression are we typechecking? +;; expected : what is the expected tc-result (can be #f) +;; existential? : do we want to create an existential +;; identifier for this expression if it does not +;; have a non-trivual object? This is useful when +;; the type of other expressions can depend on +;; the specific type of this term. (define (tc-expr/check form expected [existential? #f]) (parameterize ([current-orig-stx form]) ;; the argument must be syntax @@ -151,9 +159,17 @@ [stx:exn-handlers^ (register-ignored! form) (check-subforms/with-handlers form expected) ] + [(~and stx:typed-racket:ignore-type-information^ (#%expression inner)) + (tc-expr/check/internal #'inner Univ) + (ret Univ -tt-propset -empty-obj)] ;; explicit failure [t:typecheck-failure (explicit-fail #'t.stx #'t.message #'t.var)] + [t:assert-typecheck-failure + (cond + [(tc-expr/check? #'t.body expected) + (tc-error/expr #:stx #'t.body (format "Expected a type check error!"))] + [else expected])] ;; data [(quote #f) (ret (-val #f) -false-propset)] [(quote #t) (ret (-val #t) -true-propset)] @@ -210,11 +226,12 @@ ;(tc-expr/check #'e3 expected) (tc-error/expr "with-continuation-mark requires a continuation-mark-key, but got ~a" key-t)])] ;; application - [(#%plain-app . _) + [(#%plain-app fun . args-stx) (define result (tc/app form expected)) (cond - [(with-refinements?) - (add-applicable-linear-info form result)] + [(and (identifier? #'fun) + (with-refinements?)) + (maybe-add-linear-integer-refinements #'fun #'args-stx result)] [else result])] ;; #%expression [(#%expression e) (tc/#%expression form expected)] @@ -269,9 +286,9 @@ (define conv-type (match expected [(tc-result1: fun-type) - (match-define (list required-pos optional-pos) + (match-define (list required-pos optional-pos optional-supplied?) (attribute opt.value)) - (opt-convert fun-type required-pos optional-pos)] + (opt-convert fun-type required-pos optional-pos optional-supplied?)] [_ #f])) (if conv-type (begin (tc-expr/check/type #'fun conv-type) expected) @@ -392,21 +409,21 @@ ;; find-stx-type : Any [(or/c Type? #f)] -> Type? ;; recursively find the type of either a syntax object or the result of syntax-e -(define (find-stx-type datum-stx [expected #f]) - (match datum-stx +(define (find-stx-type datum-stx-or-datum [expected-type #f]) + (match datum-stx-or-datum [(? syntax? (app syntax-e stx-e)) - (match (and expected (resolve (intersect expected (-Syntax Univ)))) + (match (and expected-type (resolve (intersect expected-type (-Syntax Univ)))) [(Syntax: t) (-Syntax (find-stx-type stx-e t))] [_ (-Syntax (find-stx-type stx-e))])] [(or (? symbol?) (? null?) (? number?) (? extflonum?) (? boolean?) (? string?) (? char?) (? bytes?) (? regexp?) (? byte-regexp?) (? keyword?)) - (tc-literal #`#,datum-stx expected)] + (tc-literal #`#,datum-stx-or-datum expected-type)] [(cons car cdr) - (match (and expected (resolve (intersect expected (-pair Univ Univ)))) + (match (and expected-type (resolve (intersect expected-type (-pair Univ Univ)))) [(Pair: car-t cdr-t) (-pair (find-stx-type car car-t) (find-stx-type cdr cdr-t))] [_ (-pair (find-stx-type car) (find-stx-type cdr))])] [(vector xs ...) - (match (and expected (resolve (intersect expected -VectorTop))) + (match (and expected-type (resolve (intersect expected-type -VectorTop))) [(Vector: t) (make-Vector (check-below @@ -422,166 +439,11 @@ [_ (make-HeterogeneousVector (for/list ([x (in-list xs)]) (generalize (find-stx-type x #f))))])] [(box x) - (match (and expected (resolve (intersect expected -BoxTop))) + (match (and expected-type (resolve (intersect expected-type -BoxTop))) [(Box: t) (-box (check-below (find-stx-type x t) t))] [_ (-box (generalize (find-stx-type x)))])] - [(? hash? h) - (cond - [(immutable? h) - (match (and expected (resolve (intersect expected (-Immutable-HT Univ Univ)))) - [(Immutable-HashTable: k v) - (value->HT/find-stx-type h -Immutable-HT k v)] - [_ - (value->HT/find-stx-type h -Immutable-HT)])] - [(hash-weak? h) - (match (and expected (resolve (intersect expected (-Weak-HT Univ Univ)))) - [(Weak-HashTable: k v) - (value->HT/find-stx-type h -Weak-HT k v)] - [_ - (value->HT/find-stx-type h -Weak-HT)])] - [else - (match (and expected (resolve (intersect expected (-Mutable-HT Univ Univ)))) - [(Mutable-HashTable: k v) - (value->HT/find-stx-type h -Mutable-HT k v)] - [_ - (value->HT/find-stx-type h -HT)])])] - [(? prefab-struct-key) - ;; FIXME is there a type for prefab structs? - Univ] + [(? hash? hash-val) (tc-hash find-stx-type hash-val expected-type)] + [(? prefab-struct-key prefab-val) (tc-prefab find-stx-type prefab-val expected-type)] [_ Univ])) -;; value->HT/find-stx-type : hash? (-> type? type? type?) -> type? -;; : hash? (-> type? type? type?) type? type? -> type? -;; Build a HashTable type from a value, type constructor, and (optionally) -;; upper bounds on the key and value types. -(define value->HT/find-stx-type - (case-lambda - [(h tycon expected-kt expected-vt) - (let* ([kts (hash-map h (lambda (x y) (find-stx-type x expected-kt)))] - [vts (hash-map h (lambda (x y) (find-stx-type y expected-vt)))] - [kt (apply Un kts)] - [vt (apply Un vts)]) - (tycon (check-below kt expected-kt) (check-below vt expected-vt)))] - [(h tycon) - (let ([kt (generalize (apply Un (map find-stx-type (hash-keys h))))] - [vt (generalize (apply Un (map find-stx-type (hash-values h))))]) - (tycon kt vt))])) - - -;; adds linear info for the following operations: -;; + - * < <= = >= > make-vector -;; when the arguments are integers w/ objects. -;; These are the 'axiomatized' arithmetic operators. -;; NOTE: We should keep these axiomatizations so that they -;; only add info that we could later reasonably encode in a -;; standard function type for TR, so we're not bound to always -;; doing this. -(define (add-applicable-linear-info form result) - ;; class to recognize expressions that typecheck at a subtype of -Int - ;; and whose object is non-empty - (define-syntax-class (t/obj type) - #:attributes (obj) - (pattern e:expr - #:do [(define o - (match (type-of #'e) - [(tc-result1: t _ (? Object? o)) - #:when (subtype t type) - o] - [_ #f]))] - #:fail-unless o (format "not a ~a expr with a non-empty object" type) - #:attr obj o)) - (define-syntax (obj stx) - (syntax-case stx () - [(_ e) - (with-syntax ([e* (format-id #'e "~a.obj" (syntax->datum #'e))]) - (syntax/loc #'e (attribute e*)))])) - ;; class to recognize int comparisons and associate their - ;; internal TR prop constructors - (define-syntax-class int-comparison - #:attributes (constructor) - (pattern (~literal <) #:attr constructor -lt) - (pattern (~literal <=) #:attr constructor -leq) - (pattern (~literal >=) #:attr constructor -geq) - (pattern (~literal >) #:attr constructor -gt) - (pattern (~literal =) #:attr constructor -eq)) - - ;; takes a result and adds p to the then proposition - ;; and (not p) to the else proposition - (define (add-p/not-p result p) - (match result - [(tc-result1: t (PropSet: p+ p-) o) - (ret t - (-PS (-and p p+) (-and (negate-prop p) p-)) - o)] - [_ result])) - - ;; inspect the function appplication to see if it is a linear - ;; integer compatible form we want to enrich with info when - ;; #:with-logical-refinements is specified by the user - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse form - ;; * - [(#%plain-app (~literal *) (~var e1 (t/obj -Int)) (~var e2 (t/obj -Int))) - (define product-obj (-obj* (obj e1) (obj e2))) - (cond - [(Object? product-obj) - (ret (-refine/fresh x ret-t (-eq (-lexp x) product-obj)) - ps - product-obj)] - [else result])] - ;; +/- (2 args) - [(#%plain-app (~and op (~or (~literal +) (~literal -))) - (~var e1 (t/obj -Int)) - (~var e2 (t/obj -Int))) - (define (sign o) (if (eq? '+ (syntax->datum #'op)) - o - (scale-obj -1 o))) - (define l (-lexp (obj e1) (sign (obj e2)))) - (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) - ps - l)] - ;; +/- (3 args) - [(#%plain-app (~and op (~or (~literal +) (~literal -))) - (~var e1 (t/obj -Int)) - (~var e2 (t/obj -Int)) - (~var e3 (t/obj -Int))) - (define (sign o) (if (eq? '+ (syntax->datum #'op)) - o - (scale-obj -1 o))) - (define l (-lexp (obj e1) (sign (obj e2)) (sign (obj e3)))) - (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) - ps - l)] - ;; integer comparisons, 2 args - [(#%plain-app comp:int-comparison - (~var e1 (t/obj -Int)) - (~var e2 (t/obj -Int))) - (define p ((attribute comp.constructor) - (obj e1) - (obj e2))) - (add-p/not-p result p)] - ;; integer comparisons, 3 args - [(#%plain-app comp:int-comparison - (~var e1 (t/obj -Int)) - (~var e2 (t/obj -Int)) - (~var e3 (t/obj -Int))) - (define p (-and ((attribute comp.constructor) - (obj e1) - (obj e2)) - ((attribute comp.constructor) - (obj e2) - (obj e3)))) - (add-p/not-p result p)] - ;; make-vector include length in result - [(#%plain-app (~literal make-vector) - (~var size (t/obj -Int)) - . _) - #:when (Object? (obj size)) - (ret (-refine/fresh v ret-t (-eq (-lexp (-vec-len-of (-id-path v))) - (obj size))) - ps - orig-obj)] - [_ result])] - [_ result])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer]) racket/match racket/list racket/sequence (prefix-in c: (contract-req)) - (utils tc-utils) + (utils tc-utils identifier) (env tvar-env lexical-env) (for-syntax syntax/parse racket/base) (types utils subtype resolve abbrev @@ -151,10 +151,9 @@ #:infer-when ;; only try inference if the argument lengths are appropriate (match rst - [(? Type?) (<= (length dom) (length argtys))] [(RestDots: _ dbound) (and (<= (length dom) (length argtys)) (eq? dotted-var dbound))] - [_ (= (length dom) (length argtys))]) + [_ (Arrow-includes-arity? dom rst argtys)]) ;; Only try to infer the free vars of the rng (which includes the vars ;; in props/objects). #:maybe-inferred-substitution @@ -162,7 +161,7 @@ (extend-tvars fixed-vars (match rst - [(? Type?) + [(? Rest?) (infer/vararg fixed-vars (list dotted-var) argtys dom rst rng (and expected (tc-results->values expected)) @@ -197,7 +196,7 @@ ;; and there's no mandatory kw #:infer-when (and (not (ormap Keyword-required? kws)) - ((if rst <= =) (length dom) (length argtys))) + (Arrow-includes-arity? dom rst argtys)) ;; Only try to infer the free vars of the rng (which includes the vars ;; in props/objects). #:maybe-inferred-substitution @@ -307,7 +306,8 @@ [(? resolvable?) (tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)] ;; a union of functions can be applied if we can apply all of the elements - [(Union: (? Bottom?) ts) #:when (andmap Fun? ts) + [(Union: (? Bottom?) ts) #:when (for/and ([t (in-list ts)]) + (subtype t top-func)) (merge-tc-results (for/list ([fty (in-list ts)]) (tc/funapp f-stx args-stx fty args-res expected)))] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -26,20 +26,16 @@ #:literal-sets (kernel-literals) #:attributes (i cond) [pattern i:id #:attr cond #f] - [pattern (if cond:id i:id e:expr)]) + [pattern (if cond:expr e:expr i:id)]) (define-syntax-class rebuild-let* #:literal-sets (kernel-literals) - #:attributes (mapping flag-mapping) + #:attributes (mapping) (pattern (#%expression :rebuild-let*)) (pattern (let-values ([(new-id) e:cl-rhs]) body:rebuild-let*) - #:attr mapping (free-id-table-set (attribute body.mapping) #'e.i #'new-id) - #:attr flag-mapping (if (attribute e.cond) - (free-id-table-set (attribute body.flag-mapping) #'e.i #'e.cond) - (attribute body.flag-mapping))) + #:attr mapping (free-id-table-set (attribute body.mapping) #'e.i #'new-id)) (pattern body:expr - #:attr mapping (make-immutable-free-id-table) - #:attr flag-mapping (make-immutable-free-id-table))) + #:attr mapping (make-immutable-free-id-table))) ;; positional: (listof identifier?) ;; rest: id or #f @@ -83,23 +79,18 @@ ;; expected: The expected type of the body forms. ;; body: The body of the lambda to typecheck. (define/cond-contract - (tc-lambda-body arg-names arg-types #:rest-arg+type [rest-arg+type #f] #:expected [expected #f] body) + (tc-lambda-body arg-names arg-types + #:rest-id+type+body-type [rest-id+type+body-type #f] + #:expected [expected #f] body) (->* ((listof identifier?) (listof Type?) syntax?) - (#:rest-arg+type (or/c #f (cons/c identifier? (or/c Type? RestDots?))) + (#:rest-id+type+body-type (or/c #f (list/c identifier? (or/c Rest? RestDots?) Type?)) #:expected (or/c #f tc-results/c)) Arrow?) (define-values (rst-id rst-type names types) - (match rest-arg+type - [(cons id rst) - (values id rst - (cons id arg-names) - (cons (match rst - [(? Bottom?) -Null] - [(? Type?) (-lst rst)] - [(RestDots: dty dbound) - (make-ListDots dty dbound)]) - arg-types))] + (match rest-id+type+body-type + [(list id rst body-type) + (values id rst (cons id arg-names) (cons body-type arg-types))] [_ (values #f #f arg-names arg-types)])) (-Arrow @@ -117,28 +108,33 @@ ;; rest-id: The identifier of the rest arg, or #f for no rest arg ;; body: The body of the lambda to typecheck. ;; arg-tys: The expected positional argument types. -;; rst: #f, expected rest arg Type, or expected RestDots +;; rst: #f, expected rest arg Rest, or expected RestDots ;; ret-ty: The expected type of the body of the lambda. (define/cond-contract (check-clause arg-list rest-id body arg-tys rst ret-ty) ((listof identifier?) - (or/c #f identifier?) syntax? (listof Type?) (or/c #f Type? RestDots?) + (or/c #f identifier?) syntax? (listof Type?) (or/c #f Rest? RestDots?) tc-results/c . -> . Arrow?) (let* ([arg-len (length arg-list)] - [tys-len (length arg-tys)] + [arg-tys-len (length arg-tys)] + [extra-arg-count (- arg-len arg-tys-len)] [arg-types - (if (andmap type-annotation arg-list) - (get-types arg-list #:default Univ) - (cond - [(= arg-len tys-len) arg-tys] - [(< arg-len tys-len) (take arg-tys arg-len)] - [(> arg-len tys-len) - (append arg-tys - (map (if (Type? rst) - (λ _ rst) - (λ _ -Bottom)) - (drop arg-list tys-len)))]))]) + (cond + [(andmap type-annotation arg-list) + (get-types arg-list #:default Univ)] + [(zero? extra-arg-count) arg-tys] + [(negative? extra-arg-count) (take arg-tys arg-len)] + [else + (define tail-tys (match rst + [(Rest: rst-tys) + (define rst-len (length rst-tys)) + (for/list ([_ (in-range extra-arg-count)] + [rst-t (in-list-cycle rst-tys)]) + rst-t)] + [_ (for/list ([_ (in-range extra-arg-count)]) + -Bottom)])) + (append arg-tys tail-tys)])]) ;; Check that the number of formal arguments is valid for the expected type. ;; Thus it must be able to accept the number of arguments that the expected @@ -146,72 +142,116 @@ ;; enough arguments, or if it requires too many arguments. ;; This allows a form like (lambda args body) to have the type (-> Symbol ;; Number) with out a rest arg. - (when (or (and (< arg-len tys-len) (not rest-id)) - (and (> arg-len tys-len) (not rst))) - (tc-error/delayed (expected-str tys-len rst arg-len rest-id))) - (define rest-type + (when (or (and (< arg-len arg-tys-len) (not rest-id)) + (and (> arg-len arg-tys-len) (not rst))) + (tc-error/delayed (expected-str arg-tys-len rst arg-len rest-id))) + + ;; rst-type - the type of the rest argument in the Arrow type + ;; rest-body-type - the type the rest argument id has in the body + ;; of the function + ;; e.g. for + ;; (: foo (->* () () #:rest String Number)) + ;; (define (foo . rest-strings) ...) + ;; the caller can provide 0 or more Strings, so the Arrow's + ;; rest spec would be (make-Rest (list -String)) + ;; and in the body of the function, the rest argument + ;; identifier (rest-strings) have type (Listof String) + (define-values (rst-type rest-body-type) (cond - [(not rest-id) #f] - [(RestDots? rst) rst] + ;; there's not a rest ident... easy + [(not rest-id) (values #f #f)] + ;; a dotted rest spec, so the body has a ListDots + [(RestDots? rst) + (match-define (RestDots: dty dbound) rst) + (values rst (make-ListDots dty dbound))] + ;; the rest-id is dotted?, lets go get its type [(dotted? rest-id) - => (λ (b) (make-RestDots (extend-tvars (list b) (get-type rest-id #:default Univ)) - b))] + => (λ (dbound) + (define ty (extend-tvars (list dbound) (get-type rest-id #:default Univ))) + (values (make-RestDots ty dbound) + (make-ListDots ty dbound)))] [else - (define base-rest-type + ;; otherwise let's get the sequence of types the rest argument would have + ;; and call it 'rest-types' (i.e. in our above example 'foo', this would + ;; be (list -String) + (define rest-types (cond - [(type-annotation rest-id) (get-type rest-id #:default Univ)] - [(Type? rst) rst] - [(not rst) -Bottom] - [else Univ])) - (define extra-types - (if (<= arg-len tys-len) - (drop arg-tys arg-len) - null)) - (apply Un base-rest-type extra-types)])) - (tc-lambda-body arg-list arg-types - #:rest-arg+type (and rest-type (cons rest-id rest-type)) - #:expected ret-ty - body))) + [(type-annotation rest-id) (list (get-type rest-id #:default Univ))] + [else + (match rst + [#f (list -Bottom)] + [(? Type? t) (list t)] + [(Rest: rst-ts) rst-ts] + [_ (list Univ)])])) + ;; now that we have the list of types, we need to calculate, based on how many + ;; positional argument identifiers there are, how the rest should look + ;; i.e. if our rest was (Num Str)* (i.e. an even length rest arg of numbers + ;; followed by strings) and there was 1 more positional argument that positional + ;; domain types, then that extra positional arg would be type Num (i.e. the type + ;; it gets since its type is coming from the rest type) and the rest id's type + ;; in the body of the function would (Pair Str (Num Str)*) (i.e. the rest arg + ;; would _have_ to have a Str in it, and then would have 0 or more Num+Strs + (cond + [(= arg-len arg-tys-len) + (values (make-Rest rest-types) + (make-CyclicListof rest-types))] + ;; some of the args are _in_ the rst arg (i.e. they + ;; do not have argument names) ... + [(<= arg-len arg-tys-len) + (define extra-types (drop arg-tys arg-len)) + (define rst-type (apply Un (append extra-types rest-types))) + (values (make-Rest (list rst-type)) + (make-Listof rst-type))] + ;; there are named args whose type came from the rst argument + ;; i.e. we need to pull there types out of the rst arg + [else + (define rest-remainder (drop rest-types (remainder extra-arg-count + (length rest-types)))) + (values (make-Rest rest-types) + (-Tuple* rest-remainder + (make-CyclicListof rest-types)))])])) + + (tc-lambda-body + arg-list + arg-types + #:rest-id+type+body-type (and rst-type (list rest-id rst-type rest-body-type)) + #:expected ret-ty + body))) ;; typecheck a single lambda, with argument list and body ;; drest-ty and drest-bound are both false or not false (define/cond-contract (tc/lambda-clause/check f body arg-tys ret-ty rst) - (-> formals? syntax? (listof Type?) (or/c tc-results/c #f) (or/c #f Type? RestDots?) + (-> formals? + syntax? + (listof Type?) + (or/c tc-results/c #f) + (or/c #f Rest? RestDots?) Arrow?) - (check-clause (formals-positional f) (formals-rest f) body arg-tys rst ret-ty)) + (check-clause (formals-positional f) + (formals-rest f) + body + arg-tys + rst + ret-ty)) ;; typecheck a single opt-lambda clause with argument list and body -(define/cond-contract (tc/opt-lambda-clause arg-list body aux-table flag-table) - (-> (listof identifier?) syntax? free-id-table? free-id-table? +(define/cond-contract (tc/opt-lambda-clause arg-list body aux-table) + (-> (listof identifier?) syntax? free-id-table? (listof Arrow?)) ;; arg-types: Listof[Type?] (define arg-types (for/list ([a (in-list arg-list)]) (get-type a #:default (lambda () (define id (free-id-table-ref aux-table a #f)) - (if id - (get-type id #:default Univ) - Univ))))) - - ;; new-arg-types: Listof[Listof[Type?]] - (define new-arg-types - (if (= 0 (free-id-table-count flag-table)) - (list arg-types) - (apply append - (for/list ([(k v) (in-free-id-table flag-table)]) - (list - (for/list ([i (in-list arg-list)] - [t (in-list arg-types)]) - (cond [(free-identifier=? i k) t] - [(free-identifier=? i v) (-val #t)] - [else t])) - (for/list ([i (in-list arg-list)] - [t (in-list arg-types)]) - (cond [(free-identifier=? i k) (-val #f)] - [(free-identifier=? i v) (-val #f)] - [else t]))))))) - (for/list ([arg-types (in-list new-arg-types)]) - (tc-lambda-body arg-list arg-types body))) + (cond + [id + (define ty (get-type id #:default Univ)) + (if (optional-non-immediate-arg-property id) + (Un -Unsafe-Undefined ty) + ty)] + [else Univ]))))) + + (list (tc-lambda-body arg-list arg-types body))) ;; restrict-to-arity : Arrow? nat -> (or/c #f Arrow?) ;; either produces a new arrow which is a subtype of arr with arity n, @@ -226,11 +266,10 @@ (define/cond-contract (tc/lambda-clause f body) (-> formals? syntax? (listof Arrow?)) - (define-values (aux-table flag-table) + (define aux-table (syntax-parse body - [(b:rebuild-let*) (values (attribute b.mapping) (attribute b.flag-mapping))] - [_ (values (make-immutable-free-id-table) - (make-immutable-free-id-table))])) + [(b:rebuild-let*) (values (attribute b.mapping))] + [_ (make-immutable-free-id-table)])) (define arg-list (formals-positional f)) (define rest-id (formals-rest f)) @@ -246,7 +285,7 @@ (cond [(and (> (free-id-table-count aux-table) 0) (not rest-id)) - (tc/opt-lambda-clause arg-list body aux-table flag-table)] + (tc/opt-lambda-clause arg-list body aux-table)] [else (define arg-types (get-types arg-list #:default (lambda () #f))) (define rest-type @@ -262,8 +301,10 @@ (make-RestDots (extend-tvars (list bound) (get-type rest-id #:default Univ)) bound))] ;; Lambda with regular rest argument - [rest-id - (get-type rest-id #:default Univ)] + [rest-id (match (get-type rest-id #:default Univ) + [(? Type? t) (make-Rest (list t))] + [(? Rest? rst) rst] + [(? RestDots? rst) rst])] ;; Lambda with no rest argument [else #f])) (cond @@ -290,10 +331,17 @@ (register-ignored! (car (syntax-e body))) x)] [else + (define rest-body-type + (match rest-type + [#f #f] + [(Rest: ts) (make-CyclicListof ts)] + [(RestDots: dty dbound) (make-ListDots dty dbound)])) (list - (tc-lambda-body arg-list (map (lambda (v) (or v Univ)) arg-types) - #:rest-arg+type (and rest-type (cons rest-id rest-type)) - body))])])) + (tc-lambda-body + arg-list + (map (λ (v) (or v Univ)) arg-types) + #:rest-id+type+body-type (and rest-type (list rest-id rest-type rest-body-type)) + body))])])) @@ -379,7 +427,7 @@ #:unless (in-arities? seen arrow) #:when (cond [formals-rest? - (or (Type? rst) (>= (length dom) pos-count))] + (or (Rest? rst) (>= (length dom) pos-count))] [rst (<= (length dom) pos-count)] [else (= (length dom) pos-count)])) arrow)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,11 +3,10 @@ (require "../utils/utils.rkt" racket/match (typecheck signatures check-below) - (types abbrev numeric-tower resolve subtype generalize - prefab) + (types abbrev numeric-tower resolve subtype generalize) (rep type-rep) (only-in (infer infer) intersect) - (utils stxclass-util) + (utils stxclass-util prefab) syntax/parse racket/extflonum) @@ -27,8 +26,10 @@ ;; return the type of a literal value ;; tc-literal: racket-value-syntax [type] -> type (define (tc-literal v-stx [expected #f]) + (define-syntax-class regexp-cls #:attributes () (pattern x #:when (regexp? (syntax-e #'x)))) + (define-syntax-class byte-regexp-cls #:attributes () (pattern x #:when (byte-regexp? (syntax-e #'x)))) (define-syntax-class exp - (pattern (~and i (~or :number :str :bytes :char)) + (pattern (~and i (~or :number :str :bytes :char :regexp-cls :byte-regexp-cls)) #:fail-unless expected #f #:fail-unless (let ([n (syntax-e #'i)]) (subtype (-val n) expected (if (exact-integer? n) (-lexp n) -empty-obj))) #f)) @@ -134,35 +135,48 @@ (-vec-len-of (-id-path v)))) vec-ty)] [(~var i (3d hash?)) - (let ([h (syntax-e #'i)]) - (match (and expected (resolve (intersect expected (-Immutable-HT Univ Univ)))) - [(Immutable-HashTable: k v) - (let* ([kts (hash-map h (lambda (x y) (tc-literal x k)))] - [vts (hash-map h (lambda (x y) (tc-literal y v)))] - [kt (apply Un kts)] - [vt (apply Un vts)]) - (-Immutable-HT (check-below kt k) (check-below vt v)))] - [_ - (let* ([kts (hash-map h (lambda (x y) (tc-literal x)))] - [vts (hash-map h (lambda (x y) (tc-literal y)))] - [kt (generalize (apply Un kts))] - [vt (generalize (apply Un vts))]) - (-Immutable-HT kt vt))]))] + (tc-hash tc-literal (syntax-e #'i) expected)] [(~var i (3d prefab-struct-key)) - (tc-prefab (syntax-e #'i) expected)] + (tc-prefab tc-literal (syntax-e #'i) expected)] [_ Univ])) -;; Typecheck a prefab struct literal -(define (tc-prefab struct-inst expected) - (define expected-ts - (match (and expected (resolve expected)) - [(Prefab: _ ts) (in-list/rest ts #f)] - [_ (in-cycle (in-value #f))])) + +;; Typecheck a hash literal (or result of syntax-e) +;; `check-element` allows hash tables in syntax to be checked by passing +;; a function that unwraps their syntax for recursive checks (see +;; `find-stx-type` in tc-expr-unit) +(define (tc-hash check-element hash-inst expected-type) + (match (and expected-type (resolve (intersect expected-type (-Immutable-HT Univ Univ)))) + [(Immutable-HashTable: k v) + (let* ([kts (hash-map hash-inst (lambda (x y) (check-element x k)))] + [vts (hash-map hash-inst (lambda (x y) (check-element y v)))] + [kt (apply Un kts)] + [vt (apply Un vts)]) + (-Immutable-HT (check-below kt k) (check-below vt v)))] + [_ #:when (immutable? hash-inst) + (let* ([kts (hash-map hash-inst (lambda (x y) (check-element x #f)))] + [vts (hash-map hash-inst (lambda (x y) (check-element y #f)))] + [kt (generalize (apply Un kts))] + [vt (generalize (apply Un vts))]) + (-Immutable-HT kt vt))] + [_ (Un -Mutable-HashTableTop + -Weak-HashTableTop)])) + + +;; Typecheck a prefab struct literal (or result of syntax-e) +;; `check-field` allows prefabs in syntax to be checked by passing +;; a function that unwraps their syntax for recursive checks (see +;; `find-stx-type` in tc-expr-unit) +(define (tc-prefab check-field struct-inst expected-type) + (define maybe-expected-field-ts + (match (and expected-type (resolve expected-type)) + [(Prefab: _ ts) ts] + [_ '()])) (define key (prefab-struct-key struct-inst)) (define struct-vec (struct->vector struct-inst)) (define fields (for/list ([elem (in-vector struct-vec 1)] - [expected-t expected-ts]) - (tc-literal elem expected-t))) + [expected-t (in-list/rest maybe-expected-field-ts #f)]) + (check-field elem expected-t))) (make-Prefab (normalize-prefab-key key (length fields)) fields)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require "../utils/utils.rkt" + (utils identifier) racket/match racket/list (except-in (types abbrev utils prop-ops) -> ->* one-of/c) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,9 +6,9 @@ (prefix-in c: (contract-req)) (rep type-rep object-rep free-variance) (private parse-type syntax-properties) - (types abbrev subtype utils resolve substitute struct-table prefab) + (types abbrev subtype utils resolve substitute struct-table) (env global-env type-name-env type-alias-env tvar-env) - (utils tc-utils) + (utils tc-utils prefab identifier) (typecheck def-binding internal-forms error-message) (for-syntax syntax/parse racket/base)) @@ -125,7 +125,7 @@ (struct-names-predicate names)))) -;; construct all the various types for structs, and then register the approriate names +;; construct all the various types for structs, and then register the appropriate names ;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> ;; (values Type listof[Type] listof[Type]) (define/cond-contract (register-sty! sty names desc) @@ -140,14 +140,121 @@ (register-type-name type-name (make-Poly (struct-desc-tvars desc) sty))) - - - ;; Register the approriate types to the struct bindings. (define/cond-contract (register-struct-bindings! sty names desc si) (c:-> (c:or/c Struct? Prefab?) struct-names? struct-desc? (c:or/c #f struct-info?) (c:listof binding?)) + (match sty + [(? Struct?) (register-non-prefab-bindings! sty names desc si)] + [(? Prefab?) (register-prefab-bindings! sty names desc si)])) + +(define/cond-contract (register-prefab-bindings! pty names desc si) + (c:-> Prefab? struct-names? struct-desc? (c:or/c #f struct-info?) (c:listof binding?)) + (define key (Prefab-key pty)) + (match-define + (struct-desc parent-fields self-fields + constructor-tvars + self-mutable parent-mutable _) + desc) + (define any-mutable (or self-mutable parent-mutable)) + (define all-fields (append parent-fields self-fields)) + (define self-count (length self-fields)) + (define parent-count (length parent-fields)) + (define field-count (+ self-count parent-count)) + (define field-univs (build-list field-count (λ (_) Univ))) + (define field-tvar-syms + (build-list field-count (λ (_) (gen-pretty-sym)))) + (define field-tvar-Fs (map make-F field-tvar-syms)) + (define raw-poly-prefab ;; since all prefabs are polymorphic by nature + (make-Prefab key field-tvar-Fs)) + (define prefab-top-type (make-PrefabTop key)) + + (define bindings + (list* + ;; the list of names w/ types + (make-def-binding (struct-names-struct-type names) (make-StructType pty)) + (make-def-binding (struct-names-predicate names) + (make-pred-ty prefab-top-type)) + (append + (for/list ([acc-id (in-list (struct-names-getters names))] + [t (in-list self-fields)] + [idx (in-naturals parent-count)]) + (let* ([path (make-PrefabPE key idx)] + [fld-sym (list-ref field-tvar-syms idx)] + [fld-t (list-ref field-tvar-Fs idx)] + [func-t (cond + [(or self-mutable parent-mutable) + ;; NOTE - if we ever track mutable fields more ganularly + ;; than "all of the fields are mutable or not" then this + ;; could be more precise (i.e. include the path elem + ;; for any immutable field). + (make-Poly + field-tvar-syms + (cl-> [(raw-poly-prefab) fld-t] + [(prefab-top-type) Univ]))] + [else + (make-Poly + (list fld-sym) + (cl->* + (->acc (list (make-Prefab key (list-set field-univs idx fld-t))) + fld-t + (list path)) + (-> prefab-top-type Univ)))])]) + (add-struct-accessor-fn! acc-id prefab-top-type idx self-mutable) + (make-def-binding acc-id func-t))) + (if self-mutable + (for/list ([s (in-list (struct-names-setters names))] + [t (in-list self-fields)] + [idx (in-naturals parent-count)]) + (let ([fld-t (list-ref field-tvar-Fs idx)]) + (add-struct-mutator-fn! s prefab-top-type idx) + (make-def-binding s (make-Poly + field-tvar-syms + (->* (list raw-poly-prefab fld-t) -Void))))) + null)))) + ;; the base-type, with free type variables + ;; NOTE: This type is only used for the constructor + ;; of a prefab---other operators are entirely polymorphic + (define name-type + (make-Name (struct-names-type-name names) + (length constructor-tvars) + #t)) + (define poly-base + (if (null? constructor-tvars) + name-type + (make-App name-type (map make-F constructor-tvars)))) + (define extra-constructor (struct-names-extra-constructor names)) + + (define constructor-binding + (make-def-binding (struct-names-constructor names) + (make-Poly constructor-tvars + (->* all-fields poly-base)))) + (define constructor-bindings + (cons constructor-binding + (if extra-constructor + (list (make-def-binding + extra-constructor + (make-Poly constructor-tvars + (->* all-fields poly-base)))) + null))) + + (for ([b (in-list (append constructor-bindings bindings))]) + (register-type (binding-name b) (def-binding-ty b))) + + (append + (if (free-identifier=? (struct-names-type-name names) + (struct-names-constructor names)) + null + (list constructor-binding)) + (cons + (make-def-struct-stx-binding (struct-names-type-name names) + si + (def-binding-ty constructor-binding)) + bindings))) + +(define/cond-contract (register-non-prefab-bindings! sty names desc si) + (c:-> Struct? struct-names? struct-desc? (c:or/c #f struct-info?) (c:listof binding?)) (define tvars (struct-desc-tvars desc)) (define all-fields (struct-desc-all-fields desc)) (define parent-fields (struct-desc-parent-fields desc)) @@ -183,7 +290,6 @@ (make-def-binding (struct-names-struct-type names) (make-StructType sty)) (make-def-binding (struct-names-predicate names) (make-pred-ty (if (not covariant?) - ;; FIXME: does this make sense with prefabs? (make-StructTop sty) (subst-all (make-simple-substitution tvars (map (const Univ) tvars)) poly-base)))) @@ -196,13 +302,13 @@ (if mutable (->* (list poly-base) t) (->acc (list poly-base) t (list path))))]) - (add-struct-fn! g path #f) + (add-struct-accessor-fn! g poly-base i mutable) (make-def-binding g func))) (if mutable (for/list ([s (in-list (struct-names-setters names))] [t (in-list self-fields)] [i (in-naturals parent-count)]) - (add-struct-fn! s (make-StructPE poly-base i) #t) + (add-struct-mutator-fn! s poly-base i) (make-def-binding s (poly-wrapper (->* (list poly-base t) -Void)))) null)))) @@ -218,7 +324,7 @@ (poly-wrapper (->* all-fields poly-base)))) null))) - (for ([b (append constructor-bindings bindings)]) + (for ([b (in-list (append constructor-bindings bindings))]) (register-type (binding-name b) (def-binding-ty b))) (append @@ -230,6 +336,8 @@ (make-def-struct-stx-binding (struct-names-type-name names) si (def-binding-ty constructor-binding)) bindings))) + + (define (register-parsed-struct-sty! ps) (match ps ((parsed-struct sty names desc si type-only) @@ -308,8 +416,7 @@ (match parent-key [(list-rest _ num-fields _ mutable _) (= num-fields (vector-length mutable))] - ;; no parent, so trivially true - ['() #t])) + ['() #f])) (define desc (struct-desc parent-fields types tvars mutable parent-mutable #f)) (parsed-struct (make-Prefab key (append parent-fields types)) @@ -383,4 +490,3 @@ (list #'fld ...) (list ty ...) opts.kernel-maker)])) - diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,11 +5,12 @@ ;; within Typed Racket implementation code. (require "../utils/utils.rkt" + (utils prefab identifier) racket/list racket/match (prefix-in c: (contract-req)) (rep rep-utils type-rep prop-rep object-rep values-rep) - (types numeric-tower prefab) + (types numeric-tower) ;; Using this form so all-from-out works "base-abbrev.rkt" "match-expanders.rkt" @@ -43,6 +44,8 @@ (define -inst make-Instance) (define (-prefab key . types) (make-Prefab (normalize-prefab-key key (length types)) types)) +(define (-prefab-top key field-count) + (make-PrefabTop (normalize-prefab-key key field-count))) (define -unit make-Unit) (define -signature make-Signature) @@ -97,6 +100,7 @@ (make-Listof (-Syntax e)) (-pair (-Syntax e) (-Syntax e))))) (define/decl Any-Syntax (-Syntax In-Syntax)) +(define/decl -Stxish (-mu S (Un -Null (-Syntax Univ) (-pair (-Syntax Univ) S)))) (define (-Sexpof t) (-mu sexp (Un -Null diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,6 +6,7 @@ ;; extends it with more types and type abbreviations. (require "../utils/utils.rkt" + "../utils/identifier.rkt" "../rep/type-rep.rkt" "../rep/prop-rep.rkt" "../rep/object-rep.rkt" @@ -44,8 +45,12 @@ (define/decl -Null (-val null)) ;; Char type and List type (needed because of how sequences are checked in subtype) -(define (make-Listof elem) (-mu list-rec (Un -Null (make-Pair elem list-rec)))) -(define (make-MListof elem) (-mu list-rec (Un -Null (make-MPair elem list-rec)))) +(define (make-Listof elem) (unsafe-make-Mu (Un -Null (make-Pair elem (make-B 0))))) +(define (make-MListof elem) (unsafe-make-Mu (Un -Null (make-MPair elem (make-B 0))))) +(define (make-CyclicListof cycle) + (cond + [(ormap Bottom? cycle) -Null] + [else (unsafe-make-Mu (Un -Null (-Tuple* cycle (make-B 0))))])) ;; -Tuple Type is needed by substitute for ListDots (define -pair make-Pair) @@ -128,13 +133,13 @@ #:props [props -tt-propset] #:object [obj -empty-obj]) (c:->* ((c:listof Type?) (c:or/c SomeValues? Type?)) - (#:rest (c:or/c #f Type? RestDots?) + (#:rest (c:or/c #f Type? RestDots? Rest?) #:kws (c:listof Keyword?) #:props PropSet? #:object OptObject?) Arrow?) (make-Arrow dom - rst + (if (Type? rst) (make-Rest (list rst)) rst) (sort kws Keyword* . args) - (define (funty-arities f) - (match f - [(Fun: as) as])) - (make-Fun (apply append (map funty-arities args)))) + (make-Fun (apply append (map Fun-arrows args)))) (define-syntax (cl-> stx) (syntax-parse stx diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/generalize.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/generalize.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/generalize.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/generalize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,6 +28,10 @@ [(? (lambda (t) (subtype t -FloatComplex))) -FloatComplex] [(? (lambda (t) (subtype t -SingleFlonumComplex))) -SingleFlonumComplex] [(? (lambda (t) (subtype t -Number))) -Number] + [(? (lambda (t) (subtype t -Base-Regexp))) -Regexp] + [(? (lambda (t) (subtype t -PRegexp))) -PRegexp] + [(? (lambda (t) (subtype t -Byte-Base-Regexp))) -Byte-Regexp] + [(? (lambda (t) (subtype t -Byte-PRegexp))) -Byte-PRegexp] [(? (lambda (t) (subtype t -Char))) -Char] [(? (lambda (t) (subtype t -ExtFlonum))) -ExtFlonum] [(Listof: _) t*] diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -2,7 +2,7 @@ (require "../utils/utils.rkt" (utils tc-utils) - (types abbrev tc-result) + (types abbrev tc-result utils) (rep core-rep type-rep values-rep) (base-env annotate-classes) racket/list racket/set racket/match @@ -11,14 +11,17 @@ (define (convert keywords ; (listof Keyword?) + kw-opts-supplied ; (listof Keyword?) mandatory-arg-types ; (listof Type?) optional-arg-types ; (listof Type?) + pos-opts-supplied? ; (or/c (listof Boolean?) #f) rng ; SomeValues? maybe-rst ; (or/c #f Type? RestDots?) split?) ; boolean? - (when (RestDots? maybe-rst) (int-err "RestDots passed to kw-convert")) - ;; the kw function protocol passes rest args as an explicit list - (define rst-type (if maybe-rst (list (-lst maybe-rst)) empty)) + (define rst-type (match maybe-rst + [#f '()] + [(? Rest?) (list (Rest->Type maybe-rst))] + [_ (int-err "Invalid rest kind passed to kw-convert")])) ;; the kw protocol puts the arguments in keyword-sorted order in the ;; function header, so we need to sort the types to match @@ -26,6 +29,16 @@ (sort keywords (λ (kw1 kw2) (keywordlist to retain determinism (remove-duplicates - (for/list ([(arrow mand-arg-count) (in-assoc mand-arg-table)]) + (for/list ([(arrow arrow-mand-arg-count) (in-assoc mand-arg-table)]) (match arrow [(Arrow: dom rst kws rng) (define kws* (if actual-kws (handle-extra-or-missing-kws kws actual-kws) kws)) + (define kw-opts-supplied (if actual-kws + (lambda-kws-opt-supplied actual-kws) + '())) + (define mand-arg-count (if actual-kws + (lambda-kws-pos-mand-count actual-kws) + arrow-mand-arg-count)) + (define opt-arg-count (- (length dom) mand-arg-count)) + (define extra-opt-arg-count + ;; In case `dom` has too many arguments that we try to treat + ;; as optional: + (if actual-kws + (max 0 (- opt-arg-count (length (lambda-kws-pos-opt-supplied? actual-kws)))) + 0)) (convert kws* + kw-opts-supplied (take dom mand-arg-count) (drop dom mand-arg-count) + (if actual-kws + (append (lambda-kws-pos-opt-supplied? actual-kws) + (make-list extra-opt-arg-count #f)) + (make-list opt-arg-count #f)) rng rst split?)])))) @@ -203,32 +236,13 @@ ;; if min and max both have rest args, then there cannot ;; have been any optional arguments [(_ _ non-kw:id ... . rst:id) 0])) - ;; counted twice since optionals expand to two arguments - (define non-kw-argc (+ raw-non-kw-argc opt-non-kw-argc)) - (define mand-non-kw-argc (- non-kw-argc (* 2 opt-non-kw-argc))) + (define non-kw-argc raw-non-kw-argc) + (define mand-non-kw-argc (- non-kw-argc opt-non-kw-argc)) (match ft [(Fun: arrs) - (cond [(= (length arrs) 1) ; no optional args (either kw or not) - (match-define (Arrow: doms _ _ rng) (car arrs)) - (define kw-length - (- (length doms) (+ non-kw-argc (if rest? 1 0)))) - (define-values (kw-args other-args) (split-at doms kw-length)) - (define actual-kws - (for/list ([kw (in-list keywords)] - [kw-type (in-list kw-args)]) - (make-Keyword kw kw-type #t))) - (define rest-type - (and rest? (last other-args))) - (make-Fun - (list (-Arrow (take other-args non-kw-argc) - (erase-props/Values rng) - #:kws actual-kws - #:rest rest-type)))] - [(and (even? (length arrs)) ; had optional args - (>= (length arrs) 2)) + (cond [(positive? (length arrs)) ;; assumption: only one arr is needed, since the types for - ;; the actual domain are the same (the difference is in the - ;; second type for the optional keyword protocol) + ;; the actual domain are the same (match-define (Arrow: doms _ _ rng) (car arrs)) (define kw-length (- (length doms) (+ non-kw-argc (if rest? 1 0)))) @@ -243,7 +257,8 @@ (define opt-types-count (length opt-types)) (make-Fun (for/list ([to-take (in-range (add1 opt-types-count))]) - (-Arrow (append mand-args (take opt-types to-take)) + (-Arrow (append mand-args + (take opt-types to-take)) (erase-props/Values rng) #:kws actual-kws #:rest (if (= to-take opt-types-count) rest-type #f))))] @@ -256,7 +271,9 @@ ;; the type that we've given. Allows for better error messages than just ;; relying on tc-expr. Return #f if the function shouldn't be checked. (define (check-kw-arity kw-prop f-type) - (match-define (lambda-kws actual-mands actual-opts) kw-prop) + (match-define (lambda-kws actual-mands actual-opts actual-opts-supplied + actual-pos-mand-count actual-pos-opts-supplied?) + kw-prop) (define arrs (match f-type [(AnyPoly-names: _ _ (Fun: arrs)) arrs])) @@ -306,36 +323,51 @@ (loop (cdr kw-args) (cdr keywords) (cons (make-Keyword (car keywords) (car kw-args) #t) kw-types))] - [else ; optional, so there are two arg types - (loop (cddr kw-args) (cdr keywords) + [else ; optional + (loop (cdr kw-args) (cdr keywords) (cons (make-Keyword (car keywords) (car kw-args) #f) kw-types))]))) -(define ((opt-convert-arr required-pos optional-pos) arr) +(define (opt-convert-arr required-pos optional-pos optional-supplied? arr) (match arr [(Arrow: args #f '() result) (define num-args (length args)) (and (>= num-args required-pos) (<= num-args (+ required-pos optional-pos)) (let* ([required-args (take args required-pos)] - [opt-args (drop args required-pos)] - [missing-opt-args (- (+ required-pos optional-pos) num-args)] - [present-flags (map (λ (t) (-val #t)) opt-args)] - [missing-args (make-list missing-opt-args (-val #f))]) + [opt-args (for/list ([arg (in-list (drop args required-pos))] + [supplied? (in-list optional-supplied?)]) + (if supplied? + arg + (Un -Unsafe-Undefined arg)))]) (-Arrow (append required-args opt-args - missing-args - present-flags - missing-args) + (make-missing-opt-args (- (+ required-pos optional-pos) num-args) + (list-tail optional-supplied? (- num-args required-pos)))) result)))] [_ #f])) -(define (opt-convert ft required-pos optional-pos) +(define (make-missing-opt-args num-missing-opt-args supplied?s) + (for/list ([i (in-range num-missing-opt-args)] + [supplied? (in-list supplied?s)]) + (if supplied? + ;; body will get the right type from other `if` branch: + (Un) + ;; body can deal with an unsafe-undefined argument: + -Unsafe-Undefined))) + +(define (opt-convert ft required-pos optional-pos optional-supplied?) (let loop ([ft ft]) (match ft [(Fun: arrs) - (let ([arrs (map (opt-convert-arr required-pos optional-pos) arrs)]) - (and (andmap values arrs) + ;; We expect only one of `arrs` to have all optional arguments, but + ;; accomodate multiple of them + (let ([arrs (for*/list ([arr (in-list arrs)] + [new-arr (in-value + (opt-convert-arr required-pos optional-pos optional-supplied? arr))] + #:when new-arr) + new-arr)]) + (and (pair? arrs) (make-Fun arrs)))] [(Poly-names: names f) (match (loop f) @@ -369,12 +401,10 @@ ;; if min and max both have rest args, then there cannot ;; have been any optional arguments [(arg:id ... . rst:id) 0])) - ;; counted twice since optionals expand to two arguments - (define argc (+ raw-argc opt-argc)) - (define mand-argc (- argc (* 2 opt-argc))) + (define mand-argc (- raw-argc opt-argc)) (match ft [(Fun: arrs) - (cond [(and (even? (length arrs)) (>= (length arrs) 2)) + (cond [(= 1 (length arrs)) (match-define (Arrow: doms _ _ rng) (car arrs)) (define-values (mand-args opt-and-rest-args) (split-at doms mand-argc)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,6 +5,7 @@ racket/match syntax/parse/define racket/set + racket/unsafe/undefined (types resolve base-abbrev) (for-syntax racket/base syntax/parse)) @@ -44,6 +45,7 @@ [(== -False) (box-immutable #f)] [(== -Zero) (box-immutable 0)] [(== -One) (box-immutable 1)] + [(== -Unsafe-Undefined) (box-immutable unsafe-undefined)] [_ #f])) ;; matches types that correspond to singleton values diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -225,6 +225,11 @@ (set! props (cons (-eq (-vec-len-of obj) (-lexp (length ts))) props)) rep] + [_ #:when (and (with-refinements?) + (eqv? mask:vector (mask rep))) + (set! props (cons (-leq (-lexp 0) (-vec-len-of obj)) + props)) + rep] [(Intersection: ts _) (apply -unsafe-intersect (for/list ([t (in-list ts)]) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/overlap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require "../utils/utils.rkt" + (utils prefab) (rep type-rep rep-utils type-mask) (prefix-in c: (contract-req)) (types abbrev subtype resolve utils) @@ -50,6 +51,7 @@ [((or (B: _) (F: _)) _) #:no-order #t] [((Opaque: _) _) #:no-order #t] [((Name/simple: n) (Name/simple: n*)) #:when (free-identifier=? n n*) #t] + [((Distinction: _ _ t1) t2) #:no-order (overlap? t1 t2)] [(t1 (or (? Name? t2) (? App? t2))) #:no-order @@ -164,6 +166,17 @@ (and t2 (Struct: _ _ _ _ _ _))) (or (subtype t1 t2) (subtype t2 t1) (parent-of? t1 t2) (parent-of? t2 t1))] + [((PrefabTop: key1) (or (PrefabTop: key2) + (Prefab: key2 _))) + #:no-order + (or (prefab-key-subtype? key1 key2) + (prefab-key-subtype? key2 key1))] + [((Prefab: key1 flds1) (Prefab: key2 flds2)) + (and (or (prefab-key-subtype? key1 key2) + (prefab-key-subtype? key2 key1)) + (for/and ([fty1 (in-list flds1)] + [fty2 (in-list flds2)]) + (overlap? fty1 fty2)))] [(_ _) #t])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/path-type.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/path-type.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/path-type.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/path-type.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,7 +4,7 @@ racket/match racket/set (contract-req) (rep object-rep type-rep values-rep) - (utils tc-utils) + (utils tc-utils prefab) (typecheck renamer) (types subtype resolve numeric-tower) (except-in (types utils abbrev kw-types) -> ->* one-of/c)) @@ -48,12 +48,17 @@ [((Promise: t) (cons (ForcePE:) rst)) (path-type rst t (hash))] - ;; struct ops - [((Struct: nm par flds proc poly pred) (cons (StructPE: struct-ty idx) rst)) + ;; struct ops (non-prefab) + [((Struct: _ _ flds _ _ _) (cons (StructPE: struct-ty idx) rst)) #:when (subtype t struct-ty) (match-let ([(fld: ft _ _) (list-ref flds idx)]) (path-type rst ft (hash)))] + ;; prefab ops + [((Prefab: key flds) (cons (PrefabPE: path-key idx) rst)) + #:when (prefab-key-subtype? key path-key) + (path-type rst (list-ref flds idx) (hash))] + ;; vector length [(vec-t (list (VecLenPE:))) #:when (subtype vec-t -VectorTop) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prefab.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prefab.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prefab.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prefab.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -#lang racket/base - -;; Utilities for dealing with prefab struct types - -(require "../utils/utils.rkt" - (contract-req) - racket/list - racket/match) - -(provide/cond-contract [normalize-prefab-key - (-> prefab-key? integer? prefab-key?)] - [prefab-key->field-count - (-> prefab-key? integer?)] - [abbreviate-prefab-key - (-> prefab-key? prefab-key?)] - [prefab-key-subtype? - (-> prefab-key? prefab-key? any)] - [prefab-key->field-mutability - (-> prefab-key? (listof boolean?))]) - -;; Convert a prefab key to its expanded version -(define (normalize-prefab-key key field-length) - (cond [(symbol? key) `(,key ,field-length (0 #f) #())] - [(list? key) - (define base-sym (car key)) - (define-values (base-clauses rst) - (splitf-at (cdr key) (λ (x) (not (symbol? x))))) - (define parent-fragments - (let loop ([key rst] [fragments null]) - (cond [(null? key) fragments] - [else - (define-values (clauses rst) - (splitf-at (cdr key) (λ (x) (not (symbol? x))))) - (loop rst (cons (cons (car key) clauses) - fragments))]))) - (define-values (processed-parents remaining-length) - (for/fold ([processed null] - [field-length field-length]) - ([parent (in-list parent-fragments)]) - (match parent - [(list _ n (and auto (list auto-n _)) _) - (values (cons parent processed) - (- field-length n auto-n))] - [(list sym (? number? n) (and auto (list auto-n _))) - (values (cons `(,sym ,n ,auto #()) processed) - (- field-length n auto-n))] - [(list sym (? number? n) (? vector? mut)) - (values (cons `(,sym ,n (0 #f) ,mut) processed) - (- field-length n))] - [(list sym n) - (values (cons `(,sym ,n (0 #f) #()) processed) - (- field-length n))]))) - (define processed-base - (match base-clauses - [(list n _ _) (cons base-sym base-clauses)] - [(list (? number? n) (and auto (list auto-n _))) - `(,base-sym ,n ,auto #())] - [(list (? number? n) (? vector? mut)) - `(,base-sym ,n (0 #f) ,mut)] - [(list (and auto (list auto-n _)) (? vector? mut)) - `(,base-sym ,(- remaining-length auto-n) ,auto ,mut)] - [(list (? number? n)) - `(,base-sym ,n (0 #f) #())] - [(list (and auto (list auto-n _))) - `(,base-sym ,(- remaining-length auto-n) ,auto #())] - [(list (? vector? mut)) - `(,base-sym ,remaining-length (0 #f) ,mut)] - [(list) - `(,base-sym ,remaining-length (0 #f) #())])) - (append processed-base (apply append processed-parents))])) - -;; Accepts a normalized prefab key and returns the number of fields -;; a struct with this key should have -(define (prefab-key->field-count key) - (let loop ([key key] [count 0]) - (cond [(null? key) count] - [else - (match-define (list _ len (list auto-len _) _ rst ...) key) - (loop rst (+ len auto-len count))]))) - -;; Convert a prefab key to a shortened version -(define (abbreviate-prefab-key key) - (let loop ([key key] [first? #t]) - (cond [(null? key) null] - [(symbol? key) key] - [(list? key) - (define sym (car key)) - (define-values (other-clauses rst) - (splitf-at (cdr key) (λ (x) (not (symbol? x))))) - (define simplified-clauses - (for/list ([elem (in-list other-clauses)] - #:unless (and first? (number? elem)) - #:unless (and (list? elem) - (= (car elem) 0)) - #:unless (and (vector? elem) - (= (vector-length elem) 0))) - elem)) - (if (and (null? simplified-clauses) - (null? rst)) - sym - (cons sym (append simplified-clauses - (loop rst #f))))]))) - -;; Determine if the first prefab key can be a subtype of the second -;; Invariant: the keys are fully expanded (normalized) -(define (prefab-key-subtype? key1 key2) - (or (equal? key1 key2) - (suffix? key2 key1))) - -(define (suffix? l1 l2) - (for/or ([n (in-range (add1 (length l2)))]) - (equal? (drop l2 n) l1))) - -;; Returns a list of flags indicating the mutability of prefab struct types -;; in order from parent to the children (#t is mutable, #f is not) -;; Precondition: the key is fully expanded -(define (prefab-key->field-mutability key) - (let loop ([key key]) - (cond [(null? key) null] - [else - (match-define (list sym len auto mut parents ...) key) - (define mut-list (vector->list mut)) - (append (loop parents) - (for/list ([idx (in-range len)]) - (and (member idx mut-list) #t)))]))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/printer.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/printer.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/printer.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/printer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -16,9 +16,10 @@ "types/utils.rkt" "types/abbrev.rkt" "types/union.rkt" "types/numeric-tower.rkt" "types/resolve.rkt" - "types/prefab.rkt" + "utils/prefab.rkt" "utils/identifier.rkt" "utils/utils.rkt" - "utils/tc-utils.rkt") + "utils/tc-utils.rkt" + "types/struct-table.rkt") (for-syntax racket/base syntax/parse)) ;; printer-type: (one-of/c 'custom 'debug) @@ -87,9 +88,6 @@ (define (print-type type port write? [ignored-names '()]) (display (type->sexp type ignored-names) port)) -(define (print-pathelem pe port write?) - (display (pathelem->sexp pe) port)) - (define (print-prop prop port write?) (display (prop->sexp prop) port)) @@ -101,6 +99,9 @@ (define (print-object obj port write?) (display (object->sexp obj) port)) +(define (print-pathelem pe port write?) + (display (cons 'PathElem (vector->list (struct->vector pe))) port)) + (define (print-result res port write?) (display (result->sexp res) port)) @@ -171,73 +172,110 @@ [(LeqProp: lhs rhs) `(<= ,(object->sexp lhs) ,(object->sexp rhs))] [else `(Unknown Prop: ,(struct->vector prop))])) -;; pathelem->sexp : PathElem -> S-expression -;; Print a PathElem (see object-rep.rkt) to the given port -(define (pathelem->sexp pathelem) - (match pathelem - [(CarPE:) 'car] - [(CdrPE:) 'cdr] - [(ForcePE:) 'force] - [(StructPE: t i) `(,(type->sexp t)-,i)] - [(VecLenPE:) 'vector-length] - [(SyntaxPE:) 'syntax] - [else `(Invalid Path-Element: ,(struct->vector pathelem))])) + +;; c is the constant (exact-integer) +;; terms is the mapping of objects to coefficients +(define (linear-expression->sexp c terms) + (cond + [(terms-empty? terms) c] + [else + (define (positive-term? t) + (match t + [(? number? n) (exact-positive-integer? n)] + [(list '* (? number? n) var) (exact-positive-integer? n)] + [(or (? symbol?) (? list?)) ;; obj w/ coeff 1 + #t])) + (define term-list + (let ([terms (for/list ([(obj coeff) (in-terms terms)]) + (if (= 1 coeff) + (object->sexp obj) + `(* ,coeff ,(object->sexp obj))))]) + (if (zero? c) terms (cons c terms)))) + (cond + [(null? (cdr term-list)) (car term-list)] + [else + (define-values (pos-terms neg-terms) (partition positive-term? term-list)) + (define (flip-sign term) + (match term + [(? number? n) (* -1 n)] + [(list '* (? number? n) obj) + (if (= -1 n) + obj + `(* ,(* -1 n) ,obj))] + [(or (? symbol? obj) (? list? obj)) ;; obj w/ coeff 1 + (list '* -1 obj)])) + (cond + [(null? neg-terms) (cons '+ pos-terms)] + ;; if we have zero or one positive term t1, + ;; and the rest (-t2 -t3 etc) are negative, + ;; turn it into (- t1 t2 t3 ...) (where t1 may be omitted) + [(<= (length pos-terms) 1) + (append '(-) + pos-terms + (map flip-sign neg-terms))] + ;; otherwise we have some negative terms (-t1 -t2 ...) + ;; and two or more positive terms (t3 t4 ...), + ;; convert it into (- (+ t3 t4 ...) t1 t2 ...) + [else + (append '(-) + (cons '+ pos-terms) + (map flip-sign neg-terms))])])])) ;; object->sexp : Object -> S-expression ;; Print an Object (see object-rep.rkt) to the given port (define (object->sexp object) + ;; take a `adaa` (or similar) turn it into `cadaar` + (define (pair-seq->sym seq) + (string->symbol (apply string-append (append (cons "c" seq) (list "r"))))) (match object [(Empty:) '-] [(Path: pes n) - (let ([pes (map pathelem->sexp pes)]) - (cond - [(null? pes) (name-ref->sexp n)] - [else (append pes (list (name-ref->sexp n)))]))] - [(LExp: c terms) - (cond - [(terms-empty? terms) c] - [else - (define (positive-term? t) - (match t - [(? number? n) (exact-positive-integer? n)] - [(list '* (? number? n) var) (exact-positive-integer? n)] - [(or (? symbol?) (? list?)) ;; obj w/ coeff 1 - #t])) - (define term-list - (let ([terms (for/list ([(obj coeff) (in-terms terms)]) - (if (= 1 coeff) - (object->sexp obj) - `(* ,coeff ,(object->sexp obj))))]) - (if (zero? c) terms (cons c terms)))) - (cond - [(null? (cdr term-list)) (car term-list)] - [else - (define-values (pos-terms neg-terms) (partition positive-term? term-list)) - (define (flip-sign term) - (match term - [(? number? n) (* -1 n)] - [(list '* (? number? n) obj) - (if (= -1 n) - obj - `(* ,(* -1 n) ,obj))] - [(or (? symbol? obj) (? list? obj)) ;; obj w/ coeff 1 - (list '* -1 obj)])) - (cond - [(null? neg-terms) (cons '+ pos-terms)] - ;; if we have zero or one positive term t1, - ;; and the rest (-t2 -t3 etc) are negative, - ;; turn it into (- t1 t2 t3 ...) (where t1 may be omitted) - [(<= (length pos-terms) 1) - (append '(-) - pos-terms - (map flip-sign neg-terms))] - ;; otherwise we have some negative terms (-t1 -t2 ...) - ;; and two or more positive terms (t3 t4 ...), - ;; convert it into (- (+ t3 t4 ...) t1 t2 ...) - [else - (append '(-) - (cons '+ pos-terms) - (map flip-sign neg-terms))])])])] + (for/fold ([sexp (name-ref->sexp n)] + [pair-seq '()] + [depth 0] + #:result (cond + [(not (null? pair-seq)) + (list (pair-seq->sym pair-seq) sexp)] + [else sexp])) + ([pe (in-list (reverse pes))]) + (let ([sexp (if (= 4 (length pair-seq)) + (list (pair-seq->sym pair-seq) sexp) + sexp)]) + (match pe + [(CarPE:) (values sexp (cons "a" pair-seq) (add1 depth))] + [(CdrPE:) (values sexp (cons "d" pair-seq) (add1 depth))] + [_ + (let ([sexp (if (not (null? pair-seq)) + (list (pair-seq->sym pair-seq) sexp) + sexp)]) + (values + (match pe + [(ForcePE:) (list 'force sexp)] + [(StructPE: t idx) + (define maybe-accessor-id + (id-for-struct-pe + (λ (t* idx*) (and (subtype t t*) + (= idx idx*))))) + (cond + [maybe-accessor-id + (list (syntax-e maybe-accessor-id) sexp)] + [else (list 'struct-ref sexp idx)])] + [(PrefabPE: key idx) + (define maybe-accessor-id + (id-for-struct-pe + (λ (t* idx*) (and (Prefab? t*) + (prefab-key-subtype? (Prefab-key t*) key) + (= idx idx*))))) + (cond + [maybe-accessor-id + (list (syntax-e maybe-accessor-id) sexp)] + [else (list 'prefab-ref sexp idx)])] + [(VecLenPE:) (list 'vector-length sexp)] + [(SyntaxPE:) (list 'syntax-e sexp)] + [_ `((Invalid Path-Element: ,(struct->vector pe)) ,sexp)]) + '() + (add1 depth)))])))] + [(LExp: c terms) (linear-expression->sexp c terms)] [else `(Unknown Object: ,(struct->vector object))])) ;; cover-union : Type LSet -> Listof Listof @@ -300,10 +338,13 @@ ;; Convert an arr (see type-rep.rkt) to its printable form (define (arr->sexp arr) (match arr - [(Arrow: dom rest kws rng) + [(Arrow: dom rst kws rng) + (define arrow-star? (and (Rest? rst) (> (length (Rest-tys rst)) 1))) + (define dom-sexps (map type->sexp dom)) (append - (list '->) - (map type->sexp dom) + (if arrow-star? + (list '->* dom-sexps) + (cons '-> dom-sexps)) ;; Format keyword types as strings because the square ;; brackets are significant for printing. Note that ;; as long as the resulting s-expressions are `display`ed @@ -314,8 +355,9 @@ (if req? (format "~a ~a" k (type->sexp t)) (format "[~a ~a]" k (type->sexp t)))])) - (match rest - [(? Type?) `(,(type->sexp rest) *)] + (match rst + [(Rest: (list rst-t)) `(,(type->sexp rst-t) *)] + [(Rest: rst-ts) `(#:rest-star ,(map type->sexp rst-ts))] [(RestDots: dty dbound) `(,(type->sexp dty) ... ,dbound)] [_ null]) @@ -330,7 +372,7 @@ (list (type->sexp t))] [(Values: (list (Result: t (PropSet: - (TypeProp: (Path: pth1 (cons 0 0)) ft1) + (TypeProp: (and o (Path: pth1 (cons 0 0))) ft1) (NotTypeProp: (Path: pth2 (cons 0 0)) ft2)) (? Empty?)))) ;; Only print a simple prop for single argument functions, @@ -342,7 +384,7 @@ (if (null? pth1) `(,(type->sexp t) : ,(type->sexp ft1)) `(,(type->sexp t) : ,(type->sexp ft1) @ - ,@(map pathelem->sexp pth1)))] + ,(object->sexp o)))] ;; Print asymmetric props with only a positive prop as a ;; special case (even when complex printing is off) because it's ;; useful to users who use functions like `prop`. @@ -385,7 +427,10 @@ (for/list ([opt-kw (in-list opt-kws)]) (match-define (Keyword: k t _) opt-kw) (list k (type->sexp t)))) - ,@(if rst (list '#:rest (type->sexp rst)) null) + ,@(match rst + [#f null] + [(Rest: (list rst-t)) `(#:rest ,(type->sexp rst-t))] + [(Rest: rst-ts) `(#:rest-star ,(map type->sexp rst-ts))]) ,(values->sexp rng))])) ;; cover-case-lambda : (Listof arr) -> (Listof s-expression) @@ -522,10 +567,20 @@ [(Pair: a (? tuple?)) #t] [(== -Null) #t] [_ #f])) + (define (improper-tuple? t) + (let loop ([t t] + [depth 0]) + (match t + [(Pair: a rst) (loop rst (add1 depth))] + [_ (>= depth 2)]))) (define (tuple-elems t) (match t [(Pair: a e) (cons a (tuple-elems e))] [(== -Null) null])) + (define (improper-tuple-elems t) + (match t + [(Pair: a e) (cons a (improper-tuple-elems e))] + [end (list end)])) (match type [(Univ:) 'Any] [(Bottom:) 'Nothing] @@ -559,6 +614,9 @@ [(Prefab: key field-types) `(Prefab ,(abbreviate-prefab-key key) ,@(map t->s field-types))] + [(PrefabTop: key) + `(PrefabTop ,(abbreviate-prefab-key key) + ,(prefab-key->field-count key))] [(BoxTop:) 'BoxTop] [(Weak-BoxTop:) 'Weak-BoxTop] [(ChannelTop:) 'ChannelTop] @@ -580,6 +638,8 @@ `(MListof ,(t->s elem-ty))] [(? tuple? t) `(List ,@(map type->sexp (tuple-elems t)))] + [(? improper-tuple? t) + `(List* ,@(map type->sexp (improper-tuple-elems t)))] [(Opaque: pred) `(Opaque ,(syntax->datum pred))] [(Struct: nm par (list (fld: t _ _) ...) proc _ _) `#(,(string->symbol (format "struct:~a" (syntax-e nm))) @@ -612,8 +672,11 @@ [(BaseUnion-bases: bs) (define-values (covered remaining) (cover-union type bs ignored-names)) (cons 'U (sort (append covered (map t->s remaining)) primitive<=?))] - [(Refine-name: x ty prop) - `(Refine [,(name-ref->sexp x) : ,ty] ,(prop->sexp prop))] + [(Refine: raw-ty raw-prop) + (with-printable-names 1 names + (define ty (instantiate-obj raw-ty names)) + (define prop (instantiate-obj raw-prop names)) + `(Refine [,(name-ref->sexp (car names)) : ,ty] ,(prop->sexp prop)))] [(Intersection: elems _) (cons '∩ (sort (map t->s elems) primitive<=?))] ;; format as a string to preserve reader abbreviations and primitive @@ -667,8 +730,14 @@ #t] [_ #f]))) 'Syntax] - [(Mu-name: name body) + [(Mu-maybe-name: name (? Type? body)) `(Rec ,name ,(t->s body))] + [(Mu-unsafe: raw-body) + (with-printable-names 1 name-ids + (let ([names (for/list ([id (in-list name-ids)]) + (make-F (syntax-e id)))]) + `(Rec ,(first names) + ,(t->s (instantiate-type raw-body names)))))] [(B: idx) `(B ,idx)] [(Syntax: t) `(Syntaxof ,(t->s t))] [(Instance: (and (? has-name?) cls)) `(Instance ,(t->s cls))] @@ -692,25 +761,30 @@ ;[(fld: t a m) `(fld ,(type->sexp t))] [(Distinction: name sym ty) ; from define-new-subtype name] - [(DepFun/pretty-ids: ids dom pre rng) - (define (arg-id? id) (member id ids free-identifier=?)) - (define pre-deps (map name-ref->sexp - (filter arg-id? (free-ids pre)))) - `(-> ,(for/list ([id (in-list ids)] - [d (in-list dom)]) - (define deps (map name-ref->sexp - (filter arg-id? (free-ids d)))) - `(,(syntax-e id) - : - ,@(if (null? deps) - '() - (list deps)) - ,(t->s d))) - ,@(cond - [(TrueProp? pre) '()] - [(null? pre-deps) `(#:pre ,(prop->sexp pre))] - [else `(#:pre ,pre-deps ,(prop->sexp pre))]) - ,(values->sexp rng))] + [(DepFun: raw-dom raw-pre raw-rng) + (with-printable-names (length raw-dom) ids + (define dom (for/list ([d (in-list raw-dom)]) + (instantiate-obj d ids))) + (define pre (instantiate-obj raw-pre ids)) + (define rng (instantiate-obj raw-rng ids)) + (define (arg-id? id) (member id ids free-identifier=?)) + (define pre-deps (map name-ref->sexp + (filter arg-id? (free-ids pre)))) + `(-> ,(for/list ([id (in-list ids)] + [d (in-list dom)]) + (define deps (map name-ref->sexp + (filter arg-id? (free-ids d)))) + `(,(syntax-e id) + : + ,@(if (null? deps) + '() + (list deps)) + ,(t->s d))) + ,@(cond + [(TrueProp? pre) '()] + [(null? pre-deps) `(#:pre ,(prop->sexp pre))] + [else `(#:pre ,pre-deps ,(prop->sexp pre))]) + ,(values->sexp rng)))] [else `(Unknown Type: ,(struct->vector type))])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prop-ops.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prop-ops.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prop-ops.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/prop-ops.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -409,14 +409,14 @@ ;; useful to express properties of the form: if this function returns at all, ;; we learn this about its arguments (like fx primitives, or car/cdr, etc.) (define/match (add-unconditional-prop-all-args arr type) - [((Fun: (list (Arrow: dom rest kws rng))) type) + [((Fun: (list (Arrow: dom rst kws rng))) type) (match rng [(Values: (list (Result: tp (PropSet: p+ p-) op))) (let ([new-props (apply -and (build-list (length dom) (lambda (i) (-is-type i type))))]) (make-Fun - (list (make-Arrow dom rest kws + (list (make-Arrow dom rst kws (make-Values (list (-result tp (-PS (-and p+ new-props) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/resolve.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/resolve.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/resolve.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/resolve.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -146,9 +146,10 @@ (define (resolve-app rator rands [stx #f]) - (parameterize ([current-orig-stx (or stx (current-orig-stx))] + (define orig-stx (or stx (current-orig-stx))) + (parameterize ([current-orig-stx orig-stx] [already-resolving? #t]) - (resolve-app-check-error rator rands stx) + (resolve-app-check-error rator rands orig-stx) (match rator [(? Name?) (let ([r (resolve-name rator)]) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -9,32 +9,59 @@ (env env-utils) (types abbrev)) + +;; struct-type : what type is this an accessor for? +;; field-index : what is the (absolute) field-index for this field? +;; (i.e. the `i` where `(unsafe-struct-ref s i)` would return +;; this field) +;; mutator? : #t if this is a mutator, #f if it is an accessor +;; mutable? : #t if this field is mutable, #f if it is immutable +(struct struct-field-entry (struct-type field-index mutator? mutable?) #:prefab) + (define struct-fn-table (make-free-id-table)) -(define (add-struct-fn! id pe mut?) - (free-id-table-set! struct-fn-table id (list pe mut?))) -(define-values (struct-accessor? struct-mutator?) - (let () - (define ((mk mut?) id) - (cond [(free-id-table-ref struct-fn-table id #f) - => (match-lambda [(list pe m) (and (eq? m mut?) pe)] [_ #f])] - [else #f])) - (values (mk #f) (mk #t)))) +(define (add-struct-accessor-fn! fn-id type idx mutable-field?) + (free-id-table-set! struct-fn-table fn-id (struct-field-entry type idx #f mutable-field?))) + +(define (add-struct-mutator-fn! fn-id type idx) + (free-id-table-set! struct-fn-table fn-id (struct-field-entry type idx #t #t))) + +(define (struct-accessor? id) + (match (free-id-table-ref struct-fn-table id #f) + [(struct-field-entry _ idx #f _) idx] + [_ #f])) + +(define (struct-mutator? id) + (match (free-id-table-ref struct-fn-table id #f) + [(struct-field-entry _ idx #t _) idx] + [_ #f])) -(define (struct-fn-idx id) +(define (immutable-struct-field-accessor? id) (match (free-id-table-ref struct-fn-table id #f) - [(list (StructPE: _ idx) _) idx] - [_ (int-err (format "no struct fn table entry for ~a" (syntax->datum id)))])) + [(struct-field-entry _ idx #t #t) idx] + [_ #f])) (define (struct-fn-table-map f) (for/list ([(k v) (in-sorted-dict struct-fn-table id<)]) (f k v))) +(define (id-for-struct-pe type/idx=?) + (for*/or ([(id entry) (in-free-id-table struct-fn-table)] + [type (in-value (struct-field-entry-struct-type entry))] + [idx (in-value (struct-field-entry-field-index entry))] + #:when (type/idx=? type idx)) + id)) + + +(provide struct-field-entry) + (provide/cond-contract - [add-struct-fn! (identifier? StructPE? boolean? . c:-> . c:any/c)] - [struct-accessor? (identifier? . c:-> . (c:or/c #f StructPE?))] - [struct-mutator? (identifier? . c:-> . (c:or/c #f StructPE?))] - [struct-fn-idx (identifier? . c:-> . exact-integer?)] - [struct-fn-table-map (c:-> (c:-> identifier? (c:list/c StructPE? boolean?) c:any/c) - (c:listof c:any/c))]) + [add-struct-accessor-fn! (identifier? Type? exact-nonnegative-integer? boolean? . c:-> . c:any/c)] + [add-struct-mutator-fn! (identifier? Type? exact-nonnegative-integer? . c:-> . c:any/c)] + [struct-accessor? (identifier? . c:-> . (c:or/c #f exact-nonnegative-integer?))] + [struct-mutator? (identifier? . c:-> . (c:or/c #f exact-nonnegative-integer?))] + [immutable-struct-field-accessor? (identifier? . c:-> . exact-nonnegative-integer?)] + [id-for-struct-pe (c:-> (c:-> Type? exact-nonnegative-integer? boolean?) (c:or/c identifier? #f))] + [struct-fn-table-map (c:-> (c:-> identifier? struct-field-entry? c:any/c) + (c:listof c:any/c))]) \ No newline at end of file diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/substitute.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/substitute.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/substitute.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/substitute.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -100,7 +100,7 @@ (let ([expanded (sub dty)]) (map (λ (img) (substitute img name expanded)) images))) - rimage + (if (Type? rimage) (make-Rest (list rimage)) rimage) (map sub kws) (sub rng))] [_ (Rep-fmap target sub)]))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/subtype.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/subtype.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/subtype.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/subtype.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -6,14 +6,15 @@ (rep type-rep prop-rep object-rep core-rep type-mask values-rep rep-utils free-variance rep-switch) - (utils tc-utils) + (utils tc-utils prefab identifier) (only-in (env type-env-structs) with-lexical-env with-naively-extended-lexical-env lexical-env) (types utils resolve match-expanders current-seen - numeric-tower substitute prefab signatures) + numeric-tower substitute signatures) (for-syntax racket/base syntax/parse racket/sequence) + "../infer/fail.rkt" (except-in (rename-in "abbrev.rkt" [-> t->] [->* t->*]) @@ -34,7 +35,10 @@ [subval (-> SomeValues? SomeValues? boolean?)] [type-equiv? (-> Type? Type? boolean?)] [subtypes (-> (listof Type?) (listof Type?) boolean?)] - [subtypes/varargs (-> (listof Type?) (listof Type?) (or/c Type? #f) boolean?)] + [subtypes/varargs (-> (listof Type?) + (listof Type?) + (or/c Type? Rest? #f) + boolean?)] [unrelated-structs (-> Struct? Struct? boolean?)]) @@ -80,15 +84,16 @@ ;;************************************************************ -;; check subtyping for two lists of types +;; check subtyping for two lists of types, possibly terminated with a `Rest` or `RestDots` ;; List[(cons Number Number)] listof[type] listof[type] -> Opt[List[(cons Number Number)]] -(define (subtypes* A t1s t2s) - (cond [(and (null? t1s) (null? t2s) A)] - [(or (null? t1s) (null? t2s)) #f] - [(subtype* A (car t1s) (car t2s)) - => - (λ (A*) (subtypes* A* (cdr t1s) (cdr t2s)))] - [else #f])) +(define/cond-contract (subtypes* A t1s t2s) + (-> list? (listof Type?) (listof Type?) (or/c #f list?)) + (match* (t1s t2s) + [((cons t1 rst1) (cons t2 rst2)) + (subtype-seq A + (subtype* t1 t2) + (subtypes* rst1 rst2))] + [(_ _) (and (equal? t1s t2s) A)])) (define (subresults* A rs1 rs2) (cond [(and (null? rs1) (null? rs2) A)] @@ -176,18 +181,28 @@ [(_ _) #f])))) -;; used when checking if (Arrow ... rst1 ...) -;; is a subtype of (Arrow2 ... rst2 ...) -(define (rest-arg-subtype* A rst1 rst2) - (match* (rst1 rst2) - [(_ #f) A] - [(t t) A] - [((? Type? t1) (? Type? t2)) (subtype* A t2 t1)] - [((RestDots: t1 dbound) - (RestDots: t2 dbound)) - (subtype* A t2 t1)] - [(_ _) #f])) - +;; Based soley on the domain, is one arrow (i.e. dom1 + rst1) +;; a subtype of another arrow (i.e. dom1 + rst1)? +;; NOTE: This function takes into account that domains are +;; contravariant w.r.t. subtyping, i.e. callers should NOT +;; flip argument order. +(define/cond-contract (Arrow-domain-subtypes* A dom1 rst1 dom2 rst2 [objs #f]) + (->* (list? + (listof Type?) + (or/c #f Rest? RestDots?) + (listof Type?) + (or/c #f Rest? RestDots?)) + ((listof Object?)) + (or/c #f list?)) + (match* (dom1 dom2) + [((cons t1 ts1) (cons t2 ts2)) + (subtype-seq A + (subtype* t2 t1 (and objs (car objs))) + (Arrow-domain-subtypes* ts1 rst1 ts2 rst2 (and objs (cdr objs))))] + [(_ _) + (subtype* A + (-Tuple* dom2 (Rest->Type rst2)) + (-Tuple* dom1 (Rest->Type rst1)))])) (define-syntax-rule (with-fresh-ids len ids . body) (let-values ([(ids seq) (for/fold ([ids '()] @@ -199,23 +214,22 @@ . body))) ;; simple co/contra-variance for -> -(define (arrow-subtype* A arr1 arr2) +(define/cond-contract (arrow-subtype* A arr1 arr2) + (-> list? Arrow? Arrow? (or/c #f list?)) (match* (arr1 arr2) [((Arrow: dom1 rst1 kws1 raw-rng1) (Arrow: dom2 rst2 kws2 raw-rng2)) (define A* (subtype-seq A - (rest-arg-subtype* rst1 rst2) - (subtypes*/varargs dom2 dom1 rst1 #f) + (Arrow-domain-subtypes* dom1 rst1 dom2 rst2) (kw-subtypes* kws1 kws2))) (cond [(not A*) #f] [else - (define arity (max (length dom1) (length dom2))) - (with-fresh-ids arity ids + (with-fresh-ids (length dom2) ids (define mapping - (for/list ([idx (in-range arity)] + (for/list ([idx (in-naturals)] [id (in-list ids)] - [t (in-list/rest dom2 (or rst2 Univ))]) + [t (in-list dom2)]) (list* idx id t))) (subval* A* (instantiate-obj+simplify raw-rng1 mapping) @@ -228,22 +242,23 @@ ;; x : T3 ⊢ T2 <: T4 ;; ----------------------- ;; ⊢ (T1 → T2) <: (x:T3)→T4 -(define (arrow-subtype-dfun* A arrow dfun) +(define/cond-contract (arrow-subtype-dfun* A arrow dfun) + (-> list? Arrow? DepFun? (or/c #f list?)) (match* (arrow dfun) - [((Arrow: dom1 rst1 kws1 raw-rng1) + [((Arrow: dom1 rst1 kws1 raw-rng1) (DepFun: raw-dom2 raw-pre2 raw-rng2)) - (define arity (max (length dom1) (length raw-dom2))) + #:when (Arrow-includes-arity? arrow (length raw-dom2)) + (define arity (length raw-dom2)) (with-fresh-ids arity ids (define dom2 (for/list ([d (in-list raw-dom2)]) (instantiate-obj d ids))) - (define pre2 (instantiate-obj raw-pre2 ids)) (define A* (subtype-seq A - (rest-arg-subtype* rst1 #f) - (subtypes*/varargs dom2 dom1 rst1 (map -id-path ids)) - (kw-subtypes* kws1 '()))) + (kw-subtypes* kws1 '()) + (Arrow-domain-subtypes* dom1 rst1 dom2 #f (map -id-path ids)))) (cond [(not A*) #f] [else + (define pre2 (instantiate-obj raw-pre2 ids)) (define-values (mapping t2s) (for/lists (_1 _2) ([idx (in-range arity)] @@ -256,7 +271,8 @@ #:props (list pre2)] (subval* A* (instantiate-obj+simplify raw-rng1 mapping) - (instantiate-obj raw-rng2 ids)))]))])) + (instantiate-obj raw-rng2 ids)))]))] + [(_ _) #f])) ;;************************************************************ ;; Prop 'Subtyping' @@ -279,45 +295,22 @@ [(_ _) #f])) (define (subtypes/varargs args dom rst) - (and (subtypes*/varargs null args dom rst #f) #t)) + (and (subtypes*/varargs null args dom rst) #t)) ; subtypes*/varargs : list? ; (listof Type) ; (listof Type) -; (or/c #f Type) +; (or/c #f Type Rest) ; (or/c #f (listof Object)) ; -> ; list? or #f -(define (subtypes*/varargs A argtys dom rst argobjs) - (let loop-varargs ([dom dom] - [argtys argtys] - [argobjs argobjs] - [A A]) - (cond - [(not A) #f] - [(and (null? dom) (null? argtys)) A] - [(null? argtys) #f] - [(and (null? dom) rst) - (cond - [(subtype* A - (car argtys) - rst - (and argobjs (car argobjs))) - => (λ (A) (loop-varargs dom - (cdr argtys) - (and argobjs (cdr argobjs)) - A))] - [else #f])] - [(null? dom) #f] - [(subtype* A - (car argtys) - (car dom) - (and argobjs (car argobjs))) - => (λ (A) (loop-varargs (cdr dom) - (cdr argtys) - (and argobjs (cdr argobjs)) - A))] - [else #f]))) +(define/cond-contract (subtypes*/varargs A argtys dom raw-rst) + (-> list? (listof Type?) (listof Type?) (or/c #f Type? Rest? RestDots?) + (or/c #f list?)) + (define rst (match raw-rst + [(? Type?) (make-Rest (list raw-rst))] + [_ raw-rst])) + (Arrow-domain-subtypes* A dom rst argtys #f)) ;;************************************************************ @@ -459,11 +452,13 @@ (subtype* A t1 t2 obj))]) (and A (or (TrueProp? raw-prop) - (let* ([obj (if (Object? obj) obj (-id-path (genid)))] - [prop (instantiate-obj raw-prop obj)]) - (implies-in-env? (lexical-env) - (-is-type obj t1) - prop))) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let* ([obj (if (Object? obj) obj (-id-path (genid)))] + [prop (instantiate-obj raw-prop obj)]) + (implies-in-env? (lexical-env) + (-is-type obj t1) + prop))))) A))] [(_ (? resolvable?)) (let ([A (remember t1 t2 A)]) @@ -475,7 +470,9 @@ (cons lower-bound upper-bound))) #:when (and (with-refinements?) (subtype* A t1 -Int obj) - (provable-int-subtype? A t1 lower-bound upper-bound obj)) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (provable-int-subtype? A t1 t2 lower-bound upper-bound obj)))) A] [(_ _) ;; otherwise we case on t1 (subtype-cases A t1 t2 obj)])])) @@ -483,7 +480,7 @@ ;; if obj ∈ t1, can we prove 'lower-bound <= obj' and 'obj <= upper-bound'? -(define (provable-int-subtype? A t1 lower-bound upper-bound obj) +(define (provable-int-subtype? A t1 t2 lower-bound upper-bound obj) (define lower-ineq (cond [lower-bound (-leq (-lexp lower-bound) @@ -500,19 +497,20 @@ ;; both inequalities were trivially true, succeed! [(and (TrueProp? lower-ineq) (TrueProp? upper-ineq)) A] [else - ;; otherwise we have at least one inequality that must - ;; be provable for subtyping to hold - (define-values (t1* extracted-props) (extract-props obj t1)) - (define assumptions (apply -and (cons (-is-type obj t1*) extracted-props))) - - (define goal - (match* (lower-ineq upper-ineq) - [((? TrueProp?) p) p] - [(p (? TrueProp?)) p] - [(_ _) (make-AndProp (list lower-ineq upper-ineq))])) - (implies-in-env? (lexical-env) - assumptions - goal)])) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + ;; be provable for subtyping to hold + (define-values (t1* extracted-props) (extract-props obj t1)) + (define assumptions (apply -and (cons (-is-type obj t1*) extracted-props))) + + (define goal + (match* (lower-ineq upper-ineq) + [((? TrueProp?) p) p] + [(p (? TrueProp?)) p] + [(_ _) (make-AndProp (list lower-ineq upper-ineq))])) + (implies-in-env? (lexical-env) + assumptions + goal)))])) (define (continue<: A t1 t2 obj) @@ -740,11 +738,12 @@ [#:identifiers ids #:types dom2 #:props (list pre2)] - (define A* - (subtype-seq A - (subtypes*/varargs dom2 dom1 #f (map -id-path ids)) - (subval* rng1 rng2))) - + (define A* (for/fold ([A (subval* A rng1 rng2)]) + ([d1 (in-list dom1)] + [d2 (in-list dom2)] + [id (in-list ids)] + #:break (not A)) + (subtype* A d2 d1 (-id-path id)))) (and (implies-in-env? (lexical-env) pre2 pre1) A*)))])] [(Fun: arrows2) @@ -761,7 +760,7 @@ (match a2 [(Arrow: dom2 rst2 kws2 raw-rng2) (define A* (subtype-seq A - (subtypes*/varargs dom2 dom1 #f #f) + (subtypes* dom2 dom1) (kw-subtypes* '() kws2))) (cond [(not A*) #f] @@ -770,8 +769,8 @@ (define-values (mapping t2s) (for/lists (_1 _2) ([idx (in-range arity)] - [id (in-list ids)] - [t (in-list/rest dom2 (or rst2 Univ))]) + [id (in-list ids)]) + (define t (dom+rst-ref dom2 rst2 idx Univ)) (values (list* idx id t) t))) (with-naively-extended-lexical-env [#:identifiers ids @@ -1050,6 +1049,20 @@ (subtype* t s) (subtype* s t)) (subtype* A s t))))))))] + [(PrefabTop: k2) (and (prefab-key-subtype? k1 k2) A)] + [_ (continue<: A t1 t2 obj)])] + [(case: PrefabTop (PrefabTop: k1)) + (match t2 + [(Prefab: k2 flds) + (and (prefab-key-subtype? k1 k2) + (not (prefab-key/mutable-fields? k2)) + (for/fold ([A A]) + ([fld-t (in-list flds)] + ;; only check the fields both have in common + [_ (in-range (prefab-key->field-count k2))] + #:break (not A)) + (subtype* A Univ fld-t)))] + [(PrefabTop: k2) (and (prefab-key-subtype? k1 k2) A)] [_ (continue<: A t1 t2 obj)])] [(case: Promise (Promise: elem1)) (match t2 @@ -1217,4 +1230,4 @@ (Immutable-HashTable: _ _)) #false] [_ (continue<: A t1 t2 obj)])] - [else: (continue<: A t1 t2 obj)]) + [else: (continue<: A t1 t2 obj)]) \ No newline at end of file diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/type-table.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/type-table.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/type-table.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/type-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -79,7 +79,7 @@ (define (type-of e) (hash-ref type-table e - (lambda () (int-err (format "no type for ~a at: ~a line ~a col ~a" + (lambda () (int-err (format "no type for ~s at: ~a line ~a col ~a" (syntax->datum e) (syntax-source e) (syntax-line e) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/update.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/update.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/update.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/update.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -5,7 +5,7 @@ (contract-req) (infer-in infer) (rep core-rep type-rep prop-rep object-rep values-rep rep-utils) - (utils tc-utils) + (utils tc-utils prefab) (types resolve subtype subtract) (rename-in (types abbrev) [-> -->] @@ -45,6 +45,8 @@ (rebuild -Promise (update t rst))] ;; struct ops + ;; (NOTE: we assume path elements to mutable fields + ;; are never created) [((Struct: nm par flds proc poly pred) (StructPE: s idx)) #:when (subtype t s) @@ -57,6 +59,16 @@ [(Bottom:) -Bottom] [ty (let ([flds (append lhs (cons (make-fld ty acc-id #f) rhs))]) (make-Struct nm par flds proc poly pred))])] + + ;; prefab struct ops + ;; (NOTE: we assume path elements to mutable fields + ;; are never created) + [((Prefab: key flds) (PrefabPE: path-key idx)) + #:when (prefab-key-subtype? key path-key) + (match-define-values (lhs (cons fld-ty rhs)) (split-at flds idx)) + (match (update fld-ty rst) + [(Bottom:) -Bottom] + [fld-ty (make-Prefab key (append lhs (cons fld-ty rhs)))])] ;; class field ops ;; @@ -88,6 +100,15 @@ [(CdrPE:) (intersect t (-pair Univ (update Univ rst)))] [(SyntaxPE:) (intersect t (-syntax-e (update Univ rst)))] [(ForcePE:) (intersect t (-force (update Univ rst)))] + [(PrefabPE: key idx) + #:when (not (prefab-key/mutable-fields? key)) + (define field-count (prefab-key->field-count key)) + (define updated-field (update Univ rst)) + (define fields (for/list ([fld-idx (in-range field-count)]) + (if (eqv? idx fld-idx) + updated-field + Univ))) + (intersect t (make-Prefab key fields))] [_ t])])] ;; path is empty (base case) [_ (cond diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/utils.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/utils.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/utils.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/types/utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,6 +4,7 @@ (rep type-rep rep-utils) (utils tc-utils) "substitute.rkt" "tc-result.rkt" "tc-error.rkt" + (except-in "base-abbrev.rkt" -> ->*) (rep free-variance) racket/match racket/set @@ -14,6 +15,33 @@ (provide (all-from-out "tc-result.rkt" "tc-error.rkt")) +(define dom+rst-ref-failure (λ () (int-err "invalid index for domain and rest args"))) + +;; given the list of domain types (dom) +;; and the functions rest spec (rst), +;; get the type for an argument at position idx, +;; else return default if no such type exists +;; where default is a procedure (i.e. a thunk +;; to be called in tail position) +;; or some other value (to be returned) +(define (dom+rst-ref dom rst idx [default dom+rst-ref-failure]) + (match dom + [(cons t ts) + (cond + [(zero? idx) t] + [else (dom+rst-ref ts rst (sub1 idx) default)])] + [_ (match rst + [(Rest: rst-ts) (list-ref rst-ts (remainder idx (length rst-ts)))] + [_ (if (procedure? default) (default) default)])])) + +(define (Rest->Type r) + (match r + [#f -Null] + [(Rest: (list t)) (-lst t)] + [(Rest: (list)) -Null] + [(Rest: ts) (make-CyclicListof ts)] + [(RestDots: dty dbound) (make-ListDots dty dbound)])) + (define (instantiate-poly t types) (match t [(Poly: ns body) @@ -120,5 +148,9 @@ [fv/list ((listof Rep?) . -> . (set/c symbol?))] [current-poly-struct (parameter/c (or/c #f poly?))] [has-optional-args? (-> (listof Arrow?) any)] + [Rest->Type (-> (or/c #f Rest? RestDots?) Type?)] + [dom+rst-ref (->* ((listof Type?) (or/c #f Rest? RestDots?) exact-nonnegative-integer?) + (any/c) + any/c)] ) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/evt-contract.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/evt-contract.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/evt-contract.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/evt-contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -49,9 +49,20 @@ ;; evt/c-stronger? : Contract Contract -> Boolean (define (evt/c-stronger? this that) - (define this-ctcs (tr-evt/c-ctc this)) - (define that-ctcs (tr-evt/c-ctc that)) - (contract-stronger? this that)) + (cond + [(tr-evt/c? that) + (define this-ctcs (tr-evt/c-ctc this)) + (define that-ctcs (tr-evt/c-ctc that)) + (contract-stronger? this-ctcs that-ctcs)] + [else #f])) + +(define (evt/c-equivalent? this that) + (cond + [(tr-evt/c? that) + (define this-ctcs (tr-evt/c-ctc this)) + (define that-ctcs (tr-evt/c-ctc that)) + (contract-equivalent? this-ctcs that-ctcs)] + [else #f])) (define-struct tr-evt/c (ctc) #:property prop:chaperone-contract @@ -59,4 +70,5 @@ #:late-neg-projection evt/c-late-neg-proj #:first-order evt/c-first-order #:stronger evt/c-stronger? + #:equivalent evt/c-equivalent? #:name evt/c-name)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/identifier.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/identifier.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/identifier.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/identifier.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,83 @@ +#lang racket/base + +(require (for-syntax racket/base)) + +(provide local-tr-identifier? + genid + gen-pretty-sym + gen-pretty-id + symbol->fresh-pretty-normal-id + gen-existential-id + mark-id-as-normalized + normalized-id? + existential-id? + with-printable-names) +;; we use this syntax location to recognized gensymed identifiers +(define-for-syntax loc #'x) +(define dummy-id (datum->syntax #'loc (gensym 'x))) +;; tools for marking identifiers as normalized and recognizing normalized +;; identifiers (we normalize ids so free-identifier=? ids are represented +;; with the same syntax object and are thus equal?) +(define-values (mark-id-as-normalized + normalized-id?) + (let ([normalized-identifier-sym (gensym 'normal-id)]) + (values (λ (id) (syntax-property id normalized-identifier-sym #t)) + (λ (id) (syntax-property id normalized-identifier-sym))))) +(define-values (mark-id-as-existential + existential-id?) + (let ([existential-identifier-sym (gensym 'existential-id)]) + (values (λ (id) (syntax-property id existential-identifier-sym #t)) + (λ (id) (syntax-property id existential-identifier-sym))))) +;; generates fresh identifiers for use while typechecking +(define (genid [sym (gensym 'local)]) + (mark-id-as-normalized (datum->syntax #'loc sym))) +(define letters (vector-immutable "x" "y" "z" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" + "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w")) +(define subscripts (vector-immutable "₀" "₁" "₂" "₃" "₄" "₅" "₆" "₇" "₈" "₉")) +;; this is just a silly helper function that gives us a letter from +;; the latin alphabet in a cyclic manner +(define gen-pretty-sym + (let ([i 0]) + (λ () + (define letter (string->uninterned-symbol (vector-ref letters i))) + (set! i (modulo (add1 i) (vector-length letters))) + letter))) +;; generates a fresh identifier w/ a "pretty" printable representation +(define (gen-pretty-id [sym (gen-pretty-sym)]) + (mark-id-as-normalized (datum->syntax #'loc sym))) +;; generates a fresh identifier w/ a "pretty" printable representation +;; (i.e. looks like the given sym) +(define (symbol->fresh-pretty-normal-id sym) + (mark-id-as-normalized (datum->syntax #'loc (string->uninterned-symbol (symbol->string sym))))) +(define (gen-existential-id [sym (gen-pretty-sym)]) + (mark-id-as-existential (genid sym))) +;; allows us to recognize and distinguish gensym'd identifiers +;; from ones that came from the program we're typechecking +(define (local-tr-identifier? id) + (and (identifier? id) + (eq? (syntax-source-module dummy-id) + (syntax-source-module id)))) +(define (nat->id n) + (define-values (subscript letter-idx) + (quotient/remainder n (vector-length letters))) + (define letter (vector-ref letters letter-idx)) + (let loop ([sub ""] + [left subscript]) + (define next-digit (vector-ref subscripts (remainder left 10))) + (cond + [(< left 10) + (mark-id-as-normalized + (datum->syntax + #'loc (string->uninterned-symbol (string-append letter next-digit sub))))] + [else + (loop (string-append next-digit sub) + (quotient left 10))]))) + +(define pretty-fresh-name-counter (make-parameter 0)) +(define-syntax-rule (with-printable-names count-expr ids . body) + (let ([offset (pretty-fresh-name-counter)] + [count count-expr]) + (parameterize ([pretty-fresh-name-counter (+ count offset)]) + (let ([ids (for/list ([n (in-range offset (+ offset count))]) + (nat->id n))]) + . body)))) \ No newline at end of file diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/opaque-object.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/opaque-object.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/opaque-object.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/opaque-object.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -39,14 +39,20 @@ (provide object/c-opaque) +(module+ for-testing + (provide restrict-typed->/c + restrict-typed-field/c)) + ;; projection for base-object/c-opaque (define ((object/c-opaque-late-neg-proj ctc) blame) + (match-define (base-object/c-opaque + base-ctc + methods method-ctcs + fields field-ctcs) + ctc) + (define guard/c (dynamic-object/c methods method-ctcs fields field-ctcs)) + (define guard/c-proj ((contract-late-neg-projection guard/c) blame)) (λ (obj neg-party) - (match-define (base-object/c-opaque - base-ctc - methods method-ctcs - fields field-ctcs) - ctc) (when (not (object? obj)) (raise-blame-error blame #:missing-party neg-party obj "expected an object got ~a" obj)) (define actual-fields (field-names obj)) @@ -56,19 +62,23 @@ (remove* fields actual-fields)) (define remaining-methods (remove* methods actual-methods)) - (define guard/c - (dynamic-object/c (append methods remaining-methods) - (append method-ctcs - (for/list ([m remaining-methods]) - (restrict-typed->/c m))) - (append fields remaining-fields) - (append field-ctcs - (for/list ([m remaining-fields]) - (restrict-typed-field/c m))))) - ;; FIXME: this is a bit sketchy because we have to construct - ;; a contract that depends on the actual object that we got - ;; since we don't know its methods beforehand - (((contract-late-neg-projection guard/c) blame) obj neg-party))) + (cond + [(and (null? remaining-methods) (null? remaining-fields)) + (guard/c-proj obj neg-party)] + [else + (define restrict-guard/c + (dynamic-object/c remaining-methods + (for/list ([m (in-list remaining-methods)]) + (restrict-typed->/c m)) + remaining-fields + (for/list ([m (in-list remaining-fields)]) + (restrict-typed-field/c m)))) + ;; FIXME: this is a bit sketchy because we have to construct + ;; a contract that depends on the actual object that we got + ;; since we don't know its methods beforehand + (((contract-late-neg-projection restrict-guard/c) blame) + (guard/c-proj obj neg-party) + neg-party)]))) (define (object/c-opaque-name ctc) (build-object/c-type-name 'object/c-opaque @@ -85,7 +95,7 @@ ;; and `this` has stronger contracts on all members ;; - `that` is an object/c contract ;; and `this` has stronger contracts on their common members -(define (object/c-opaque-stronger this that) +(define (object/c-opaque-stronger? this that) (define that-opaque? (base-object/c-opaque? that)) (cond [(or that-opaque? @@ -102,12 +112,20 @@ #t)] [else #f])) +;; An `object/c-opaque` contract is equivalent to another `object/c-opaque` +;; contract that has the same fields+methods and the same contracts on them. +(define (object/c-opaque-equivalent? this that) + (and (base-object/c-opaque? that) + (contract-equivalent? (base-object/c-opaque-obj/c this) + (base-object/c-opaque-obj/c that)))) + (struct base-object/c-opaque (obj/c ; keep a copy of the normal object/c for first-order and stronger checks method-names method-ctcs field-names field-ctcs) #:property prop:contract (build-contract-property - #:stronger object/c-opaque-stronger + #:stronger object/c-opaque-stronger? + #:equivalent object/c-opaque-equivalent? #:name object/c-opaque-name #:first-order (λ (ctc) (define obj/c (base-object/c-opaque-obj/c ctc)) @@ -145,34 +163,34 @@ ;; method is typed (assuming that the caller is untyped or the receiving ;; object went through untyped code) (define (((restrict-typed->-late-neg-projection ctc) blame) val neg-party) - (define blame+neg-party (cons blame neg-party)) - (chaperone-procedure val - (make-keyword-procedure - (λ (_ kw-args . rst) - (with-contract-continuation-mark - blame+neg-party - (when (typed-method? val) + (cond + [(typed-method? val) + (chaperone-procedure val + (make-keyword-procedure + (λ (_ kw-args . rst) (raise-blame-error (blame-swap blame) val #:missing-party neg-party "cannot call uncontracted typed method")) - (apply values kw-args rst))) - (λ args - (with-contract-continuation-mark - blame+neg-party - (when (typed-method? val) + (λ args (raise-blame-error (blame-swap blame) val #:missing-party neg-party - "cannot call uncontracted typed method")) - (apply values args)))))) + "cannot call uncontracted typed method"))))] + [else val])) ;; Returns original method name (define (restrict-typed->-name ctc) (define name (restrict-typed->/c-name ctc)) (build-compound-type-name 'restrict-typed->/c name)) +(define (restrict-typed->/c-equivalent? this that) + (and (restrict-typed->/c? that) + (eq? (restrict-typed->/c-name this) + (restrict-typed->/c-name that)))) + (struct restrict-typed->/c (name) #:property prop:chaperone-contract (build-chaperone-contract-property #:name restrict-typed->-name - #:stronger equal? + #:stronger restrict-typed->/c-equivalent? + #:equivalent restrict-typed->/c-equivalent? #:late-neg-projection restrict-typed->-late-neg-projection)) (define (restrict-typed-field-late-neg-proj ctc) @@ -194,9 +212,15 @@ (define name (restrict-typed-field/c-name ctc)) (build-compound-type-name 'restrict-typed-field/c name)) +(define (restrict-typed-field-equivalent? this that) + (and (restrict-typed-field/c? that) + (equal? (restrict-typed-field/c-name this) + (restrict-typed-field/c-name that)))) + (struct restrict-typed-field/c (name) #:property prop:flat-contract (build-flat-contract-property #:name restrict-typed-field-name - #:stronger equal? + #:stronger restrict-typed-field-equivalent? + #:equivalent restrict-typed-field-equivalent? #:late-neg-projection restrict-typed-field-late-neg-proj)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab-c.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab-c.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab-c.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab-c.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,282 @@ +#lang racket/base + +(require racket/contract) + +(provide (rename-out [-prefab/c prefab/c])) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +;; prefab contract property functions +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +;; name +(define (prefab/c-name ctc) + (define key (base-prefab/c-key ctc)) + (define field-contracts (base-prefab/c-field-contracts ctc)) + `(prefab/c ,key ,@(map contract-name field-contracts))) + +;; flat-first-order +(define (prefab/c-flat-first-order ctc) + (define field-contracts (base-prefab/c-field-contracts ctc)) + (define prefab-struct-type (prefab-key->struct-type (base-prefab/c-key ctc) + (length field-contracts))) + (define pred? (struct-type-make-predicate prefab-struct-type)) + (define accessor-proc + (let-values ([(name + init-field-cnt + auto-field-cnt + accessor-proc + mutator-proc + immutable-k-list + super-type + skipped?) + (struct-type-info prefab-struct-type)]) + accessor-proc)) + (cond + [(flat-prefab/c? ctc) + ;; It's flat, so each field and contract must be immutable and + ;; flat respectively. + (λ (val) + (and (pred? val) + (for/and ([field-contract (in-list field-contracts)] + [idx (in-naturals)]) + ((flat-contract-predicate field-contract) (accessor-proc val idx)))))] + [else + ;; flat-field-indices+contracts : (listof (cons natural contract)) + ;; i.e. which fields have flat contracts? + (define flat-field-indices+contracts + (for/list ([field-contract (in-list field-contracts)] + [idx (in-naturals)] + #:when (flat-contract? field-contract)) + (cons idx field-contract))) + (λ (val) + (and (pred? val) + (for*/and ([idx/contract (in-list flat-field-indices+contracts)] + [idx (in-value (car idx/contract))] + [field-contract (in-value (cdr idx/contract))] + [field-val (in-value (accessor-proc val idx))]) + ((flat-contract-predicate field-contract) field-val))))])) + +(define (ending n) + (case (remainder n 100) + [(11 12 13) "th"] + [else (case (remainder n 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [else "th"])])) + +;; late-neg-projection +(define (prefab/c-late-neg-projection ctc) + (define field-contracts (base-prefab/c-field-contracts ctc)) + (define field-count (length field-contracts)) + (define mutability-bits (base-prefab/c-mutability-bits ctc)) + (define prefab-struct-type (prefab-key->struct-type (base-prefab/c-key ctc) + field-count)) + (define pred? (struct-type-make-predicate prefab-struct-type)) + (define-values (accessor-proc mutator-proc) + (let-values ([(_1 _2 _3 accessor-proc mutator-proc _6 _7 _8) + (struct-type-info prefab-struct-type)]) + (values accessor-proc mutator-proc))) + (define chaperone? (andmap chaperone-contract? field-contracts)) + (define (generate-field-functions/contracts first-projs + late-acc-projs + late-mut-projs + val + b-) + (for/fold ([ctcs '()]) + ([first-proj (in-list first-projs)] + [late-acc-proj (in-list late-acc-projs)] + [late-mut-proj (in-list late-mut-projs)] + [idx (in-naturals)]) + ;; first order check on value + ((first-proj (accessor-proc val idx)) b-) + (let ([ctcs/accessor (if (flat-contract? ctc) + ctcs + (list* (make-struct-field-accessor accessor-proc idx) + (λ (self val) (late-acc-proj val b-)) + ctcs))]) + (if (bitwise-bit-set? mutability-bits idx) + (list* (make-struct-field-mutator mutator-proc idx) + (λ (self val) (late-mut-proj val b-)) + ctcs/accessor) + ctcs/accessor)))) + (λ (b+) + (define-values (first-projs late-acc-projs late-mut-projs) + (for/lists (_1 _2 _3) + ([field-ctc (in-list field-contracts)] + [idx (in-naturals)]) + (define field-context + (format "the ~a~a field of" + (add1 idx) (ending (add1 idx)))) + (values ((get/build-val-first-projection field-ctc) + (blame-add-context b+ field-context)) + ((get/build-late-neg-projection field-ctc) + (blame-add-context b+ field-context)) + ((get/build-late-neg-projection field-ctc) + (blame-add-context b+ field-context #:swap? #t))))) + (λ (val b-) + (unless (pred? val) + (raise-blame-error b+ #:missing-party b- + val '(expected: "~a" given: "~e") + (contract-name ctc) + val)) + (apply + (if chaperone? chaperone-struct impersonate-struct) + val + prefab-struct-type + (generate-field-functions/contracts first-projs + late-acc-projs + late-mut-projs + val + b-))))) + +(define (prefab-sub-key? this-key this-field-count that-key that-field-count) + ;; TODO this could easily be more complete + (and (equal? this-key that-key) + (= this-field-count that-field-count))) + +;; stronger +(define (prefab/c-stronger this that) + (cond + [(not (base-prefab/c? that)) #f] + [else + (define this-key (base-prefab/c-key this)) + (define these-field-contracts (base-prefab/c-field-contracts this)) + (define this-mutability-bits (base-prefab/c-mutability-bits this)) + (define this-field-count (length these-field-contracts)) + (define that-key (base-prefab/c-key that)) + (define those-field-contracts (base-prefab/c-field-contracts that)) + (define that-field-count (length those-field-contracts)) + (cond + [(not (prefab-sub-key? this-key this-field-count that-key that-field-count)) + #f] + [else + (for/and ([this-field-contract (in-list these-field-contracts)] + [that-field-contract (in-list those-field-contracts)] + [idx (in-naturals)]) + (cond + [(bitwise-bit-set? this-mutability-bits idx) + (contract-equivalent? this-field-contract that-field-contract)] + [else + (contract-stronger? this-field-contract that-field-contract)]))])])) + +;; equivalent +(define (prefab/c-equivalent this that) + (cond + [(not (and (base-prefab/c? that) + (equal? (base-prefab/c-key this) (base-prefab/c-key that)))) + #f] + [else + (define these-field-contracts (base-prefab/c-field-contracts this)) + (define those-field-contracts (base-prefab/c-field-contracts that)) + (and (eqv? (length these-field-contracts) + (length those-field-contracts)) + (andmap contract-equivalent? these-field-contracts those-field-contracts))])) + +;; generate +(define ((prefab/c-generate ctc) fuel) + (define field-contracts (base-prefab/c-field-contracts ctc)) + (define total-field-count (length field-contracts)) + (define prefab-struct-type (prefab-key->struct-type (base-prefab/c-key ctc) + total-field-count)) + (define constructor (struct-type-make-constructor prefab-struct-type)) + (let loop ([to-gen field-contracts] + [gens '()]) + (cond + [(null? to-gen) + (λ () + (let loop ([gens gens] + [args '()]) + (cond + [(null? gens) (apply constructor args)] + [else (loop (cdr gens) + (cons ((car gens)) args))])))] + [else + (define field-contract (car to-gen)) + (define field-gen (contract-random-generate/choose field-contract fuel)) + (cond + [field-gen (loop (cdr to-gen) (cons field-gen gens))] + [else #f])]))) + + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +;; prefab contract structs +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +;; NOTE: these are meant to more-or-less mirror struct/c +;; in how they work. One notable difference: we don't +;; necessarily have identifiers corresponding to accessor +;; functions for prefabs. + + + +(struct base-prefab/c (key field-contracts mutability-bits)) + +(struct flat-prefab/c base-prefab/c () + #:property prop:flat-contract + (build-flat-contract-property + #:name prefab/c-name + #:first-order prefab/c-flat-first-order + #:late-neg-projection #f + #:stronger prefab/c-stronger + #:equivalent prefab/c-equivalent + #:generate prefab/c-generate)) + +(struct prefab/c base-prefab/c () + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:name prefab/c-name + #:first-order prefab/c-flat-first-order + #:late-neg-projection prefab/c-late-neg-projection + #:stronger prefab/c-stronger + #:equivalent prefab/c-equivalent + #:generate prefab/c-generate + #:exercise #f)) + +(struct impersonator-prefab/c base-prefab/c () + #:property prop:contract + (build-contract-property + #:name prefab/c-name + #:first-order prefab/c-flat-first-order + #:late-neg-projection prefab/c-late-neg-projection + #:stronger prefab/c-stronger + #:equivalent prefab/c-equivalent + #:generate prefab/c-generate + #:exercise #f)) + + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +;; prefab contract constructor +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +;; +;; creates a contract for a prefab with key `key` +;; and with `(length args)` fields +(define (-prefab/c key . args) + (unless (prefab-key? key) + (raise-argument-error 'prefab/c "prefab-key?" key)) + (define field-contracts (for/list ([arg (in-list args)]) + (coerce-contract 'prefab/c arg))) + ;; construct struct type and other struct information so we can + ;; reject nonsensical prefabs early and determine if this will + ;; be a flat contract or not + (define field-count (length field-contracts)) + (define prefab-struct-type (prefab-key->struct-type key field-count)) + (define immutable-k-list + (let-values ([(_1 _2 _3 _4 _5 immutable-k-list _7 _8) + (struct-type-info prefab-struct-type)]) + immutable-k-list)) + (define mutability-bits (for/fold ([bits #b0]) + ([idx (in-range field-count)] + #:when (not (memv idx immutable-k-list))) + (bitwise-ior bits (arithmetic-shift 1 idx)))) + (define max-kind (for/fold ([kind 0]) + ([ctc (in-list field-contracts)]) + (max kind (cond + [(flat-contract? ctc) 0] + [(chaperone-contract? ctc) 1] + [else 2])))) + (case max-kind + [(0) (if (= (length immutable-k-list) field-count) + (flat-prefab/c key field-contracts mutability-bits) + (prefab/c key field-contracts mutability-bits))] + [(1) (prefab/c key field-contracts mutability-bits)] + [else (impersonator-prefab/c key field-contracts mutability-bits)])) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/prefab.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,137 @@ +#lang racket/base + +;; Utilities for dealing with prefab struct types + +(require "../utils/utils.rkt" + (contract-req) + racket/list + racket/match) + +(provide/cond-contract [normalize-prefab-key + (-> prefab-key? integer? prefab-key?)] + [prefab-key->field-count + (-> prefab-key? integer?)] + [abbreviate-prefab-key + (-> prefab-key? prefab-key?)] + [prefab-key-subtype? + (-> prefab-key? prefab-key? any)] + [prefab-key->field-mutability + (-> prefab-key? (listof boolean?))] + [prefab-key/mutable-fields? + (-> prefab-key? boolean?)]) + +;; Convert a prefab key to its expanded version +(define (normalize-prefab-key key field-length) + (cond [(symbol? key) `(,key ,field-length (0 #f) #())] + [(list? key) + (define base-sym (car key)) + (define-values (base-clauses rst) + (splitf-at (cdr key) (λ (x) (not (symbol? x))))) + (define parent-fragments + (let loop ([key rst] [fragments null]) + (cond [(null? key) fragments] + [else + (define-values (clauses rst) + (splitf-at (cdr key) (λ (x) (not (symbol? x))))) + (loop rst (cons (cons (car key) clauses) + fragments))]))) + (define-values (processed-parents remaining-length) + (for/fold ([processed null] + [field-length field-length]) + ([parent (in-list parent-fragments)]) + (match parent + [(list _ n (and auto (list auto-n _)) _) + (values (cons parent processed) + (- field-length n auto-n))] + [(list sym (? number? n) (and auto (list auto-n _))) + (values (cons `(,sym ,n ,auto #()) processed) + (- field-length n auto-n))] + [(list sym (? number? n) (? vector? mut)) + (values (cons `(,sym ,n (0 #f) ,mut) processed) + (- field-length n))] + [(list sym n) + (values (cons `(,sym ,n (0 #f) #()) processed) + (- field-length n))]))) + (define processed-base + (match base-clauses + [(list n _ _) (cons base-sym base-clauses)] + [(list (? number? n) (and auto (list auto-n _))) + `(,base-sym ,n ,auto #())] + [(list (? number? n) (? vector? mut)) + `(,base-sym ,n (0 #f) ,mut)] + [(list (and auto (list auto-n _)) (? vector? mut)) + `(,base-sym ,(- remaining-length auto-n) ,auto ,mut)] + [(list (? number? n)) + `(,base-sym ,n (0 #f) #())] + [(list (and auto (list auto-n _))) + `(,base-sym ,(- remaining-length auto-n) ,auto #())] + [(list (? vector? mut)) + `(,base-sym ,remaining-length (0 #f) ,mut)] + [(list) + `(,base-sym ,remaining-length (0 #f) #())])) + (append processed-base (apply append processed-parents))])) + +;; Accepts a normalized prefab key and returns the number of fields +;; a struct with this key should have +(define (prefab-key->field-count key) + (let loop ([key key] [count 0]) + (cond [(null? key) count] + [else + (match-define (list _ len (list auto-len _) _ rst ...) key) + (loop rst (+ len auto-len count))]))) + +;; Convert a prefab key to a shortened version +(define (abbreviate-prefab-key key) + (let loop ([key key] [first? #t]) + (cond [(null? key) null] + [(symbol? key) key] + [(list? key) + (define sym (car key)) + (define-values (other-clauses rst) + (splitf-at (cdr key) (λ (x) (not (symbol? x))))) + (define simplified-clauses + (for/list ([elem (in-list other-clauses)] + #:unless (and first? (number? elem)) + #:unless (and (list? elem) + (= (car elem) 0)) + #:unless (and (vector? elem) + (= (vector-length elem) 0))) + elem)) + (if (and (null? simplified-clauses) + (null? rst)) + sym + (cons sym (append simplified-clauses + (loop rst #f))))]))) + +;; Determine if the first prefab key can be a subtype of the second +;; Invariant: the keys are fully expanded (normalized) +(define (prefab-key-subtype? key1 key2) + (or (equal? key1 key2) + (suffix? key2 key1))) + +(define (suffix? l1 l2) + (for/or ([n (in-range (add1 (length l2)))]) + (equal? (drop l2 n) l1))) + +;; Returns a list of flags indicating the mutability of prefab struct types +;; in order from parent to the children (#t is mutable, #f is not) +;; Precondition: the key is fully expanded +(define (prefab-key->field-mutability key) + (let loop ([key key]) + (cond [(null? key) null] + [else + (match-define (list sym len auto mut parents ...) key) + (define mut-list (vector->list mut)) + (append (loop parents) + (for/list ([idx (in-range len)]) + (and (member idx mut-list) #t)))]))) + + +;; does `key` have mutable fields? (don't allocate) +(define (prefab-key/mutable-fields? key) + (let loop ([key key]) + (cond [(null? key) #f] + [else + (match-define (list sym len auto mut parents ...) key) + (or (not (eqv? 0 (vector-length mut))) + (loop parents))]))) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,7 @@ #lang racket/base (require syntax/private/modcollapse-noctc - syntax/id-table + syntax/private/id-table (for-template racket/base)) (provide make-make-redirect-to-contract) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/sealing-contract.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/sealing-contract.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/sealing-contract.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/sealing-contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -19,6 +19,43 @@ (quote ((?i ...) (?f ...) (?m ...))) (λ (?var) ?c))])) +(define ((make-sealing-contract-<=? ctc-<=? member-name-<=?) this that) + (cond + [(sealing-contract? that) + (define this-unsealed (sealing-contract-unsealed this)) + (define that-unsealed (sealing-contract-unsealed that)) + (match-define (list this-inits this-fields this-methods) this-unsealed) + (match-define (list that-inits that-fields that-methods) that-unsealed) + (define that-<=-this? + (and (member-name-<=? this-inits that-inits) + (member-name-<=? this-fields that-fields) + (member-name-<=? this-methods that-methods))) + (cond [that-<=-this? + (define sealer/unsealer + (seal/unseal (gensym) #t that-unsealed)) + ;; see if the instantiated contract is stronger + (ctc-<=? ((sealing-contract-proc this) + sealer/unsealer) + ((sealing-contract-proc that) + sealer/unsealer))] + [else #f])] + [else #f])) + +(define (superset? this-sym* that-sym*) + (for/and ([that-sym (in-list that-sym*)]) + (memq that-sym this-sym*))) + +(define (set=? this-sym* that-sym*) + (and (= (length this-sym*) (length that-sym*)) + (for/and ([this-sym (in-list this-sym*)]) + (memq this-sym that-sym*)))) + +(define sealing-contract-stronger? + (make-sealing-contract-<=? contract-stronger? superset?)) + +(define sealing-contract-equivalent? + (make-sealing-contract-<=? contract-equivalent? set=?)) + ;; represents a sealing function contract ;; name - a datum for the printed form of the contract ;; unsealed - init/field/method names left unsealed by sealers/unsealers @@ -27,30 +64,8 @@ #:property prop:contract (build-contract-property #:name (λ (ctc) (sealing-contract-name ctc)) - #:stronger - (λ (this that) - (cond - [(sealing-contract? that) - (define this-unsealed (sealing-contract-unsealed this)) - (define that-unsealed (sealing-contract-unsealed that)) - (match-define (list this-inits this-fields this-methods) this-unsealed) - (match-define (list that-inits that-fields that-methods) that-unsealed) - (define (that-subset-of-this? this that) - (for/and ([that-member (in-list that)]) - (member that-member this))) - (that-subset-of-this? this-inits that-inits) - (that-subset-of-this? this-fields that-fields) - (that-subset-of-this? this-methods that-methods) - (cond [that-subset-of-this? - (define sealer/unsealer - (seal/unseal (gensym) #t that-unsealed)) - ;; see if the instantiated contract is stronger - (contract-stronger? ((sealing-contract-proc this) - sealer/unsealer) - ((sealing-contract-proc that) - sealer/unsealer))] - [else #f])] - [else #f])) + #:stronger sealing-contract-stronger? + #:equivalent sealing-contract-equivalent? #:late-neg-projection (λ (ctc) (define unsealed (sealing-contract-unsealed ctc)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/stxclass-util.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/stxclass-util.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/stxclass-util.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/stxclass-util.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,7 +23,7 @@ [#,i #:declare #,i pat #'#,get-i])))])) (define (atom? v) - (or (number? v) (string? v) (boolean? v) (symbol? v) (char? v) (bytes? v) (regexp? v))) + (or (number? v) (string? v) (boolean? v) (symbol? v) (char? v) (bytes? v) (regexp? v) (byte-regexp? v))) (define-syntax-class (3d pred) (pattern s diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -272,7 +272,7 @@ (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " - (apply format msg args) + (if (null? args) msg (apply format msg args)) (let ([stx (current-orig-stx)]) (format "\nwhile typechecking:\n~a\noriginally:\n~a" (and stx (syntax->datum stx)) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt 2018-01-26 20:34:58.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,21 +23,16 @@ rep utils typecheck infer env private types static-contracts ;; misc list-extend + repeat-list ends-with? filter-multiple syntax-length in-pair in-list/rest + in-list-cycle list-ref/default match*/no-order bind - genid - gen-pretty-id - gen-existential-id - existential-id? - local-tr-identifier? - mark-id-as-normalized - normalized-id? assoc-ref assoc-set assoc-remove @@ -252,6 +247,12 @@ [(<= s-len t-len) t] [else (append t (build-list (- s-len t-len) (λ _ extra)))])) +;; repeat l n times +(define (repeat-list l n) + (for/fold ([acc '()]) + ([_ (in-range n)]) + (append l acc))) + ;; does l1 end with l2? ;; e.g. (list 1 2 3) ends with (list 2 3) (define (ends-with? l1 l2) @@ -348,7 +349,41 @@ #'xs)] [blah (raise-syntax-error 'in-list/rest "invalid usage" #'blah)]))) -;; quick in-list/rest sanity checks +(define-sequence-syntax in-list-cycle + (λ () #'in-cycle) + (λ (stx) + (syntax-case stx () + [[(val) (_ list-exp)] + #'[(val) + (:do-in + ;; ([(outer-id ...) outer-expr] ...) + ([(l) list-exp]) + ;; outer-check + (unless (not (null? l)) + (error 'in-list-cycle "must be given a non-empty list")) + ;; ([loop-id loop-expr] ...) + ([pos l]) + ;; pos-guard + #t + ;; ([(inner-id ...) inner-expr] ...) + ([(val pos) (if (pair? pos) + (values (car pos) (cdr pos)) + (values (car l) (cdr l)))]) + ;; pre-guard + #t + ;; post-guard + #t + ;; (loop-arg ...) + (pos))]] + [[xs (_ dd-exp)] + (list? (syntax->datum #'xs)) + (raise-syntax-error 'in-list-cycle + (format "expected an identifier, given ~a" + (syntax->list #'xs)) + #'xs)] + [blah (raise-syntax-error 'in-list-cycle "invalid usage" #'blah)]))) + +;; quick in-list/rest and in-list-cycle sanity checks (module+ test (unless (equal? (for/list ([_ (in-range 0)] [val (in-list/rest (list 1 2) #f)]) @@ -364,7 +399,34 @@ [val (in-list/rest (list 1 2) #f)]) val) (list 1 2 #f #f)) - (error 'in-list/rest "broken!"))) + (error 'in-list/rest "broken!")) + + (unless (with-handlers ([exn:fail? + (λ (e) #t)]) + (for/list ([n (in-range 10)] + [m (in-list-cycle '())]) + m) + #f) + (error 'in-list-cycle "broken!")) + + (unless (equal? (for/list ([n (in-range 1)] + [m (in-list-cycle '(1))]) + m) + '(1)) + (error 'in-list-cycle "broken!")) + + (unless (equal? (for/list ([n (in-range 5)] + [m (in-list-cycle '(1))]) + m) + '(1 1 1 1 1)) + (error 'in-list-cycle "broken!")) + + (unless (equal? (for/list ([n (in-range 5)] + [m (in-list-cycle '(1 2))]) + m) + '(1 2 1 2 1)) + (error 'in-list-cycle "broken!"))) + (define (list-ref/default xs idx default) @@ -411,7 +473,7 @@ (in-parallel (map car l) (map cdr l))) (define-sequence-syntax in-assoc - (λ () #'in-list/rest-proc) + (λ () #'in-assoc-proc) (λ (stx) (syntax-case stx () [[(key val) (_ assoc-exp)] @@ -437,54 +499,3 @@ (pos))]] [blah (raise-syntax-error 'in-assoc "invalid usage" #'blah)]))) - -(module local-ids racket - (provide local-tr-identifier? - genid - gen-pretty-id - gen-existential-id - mark-id-as-normalized - normalized-id? - existential-id?) - ;; we use this syntax location to recognized gensymed identifiers - (define-for-syntax loc #'x) - (define dummy-id (datum->syntax #'loc (gensym 'x))) - ;; tools for marking identifiers as normalized and recognizing normalized - ;; identifiers (we normalize ids so free-identifier=? ids are represented - ;; with the same syntax object and are thus equal?) - (define-values (mark-id-as-normalized - normalized-id?) - (let ([normalized-identifier-sym (gensym 'normal-id)]) - (values (λ (id) (syntax-property id normalized-identifier-sym #t)) - (λ (id) (syntax-property id normalized-identifier-sym))))) - (define-values (mark-id-as-existential - existential-id?) - (let ([existential-identifier-sym (gensym 'existential-id)]) - (values (λ (id) (syntax-property id existential-identifier-sym #t)) - (λ (id) (syntax-property id existential-identifier-sym))))) - ;; generates fresh identifiers for use while typechecking - (define (genid [sym (gensym 'local)]) - (mark-id-as-normalized (datum->syntax #'loc sym))) - (define letters (vector-immutable "x" "y" "z" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" - "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w")) - ;; this is just a silly helper function that gives us a letter from - ;; the latin alphabet in a cyclic manner - (define next-letter - (let ([i 0]) - (λ () - (define letter (string->uninterned-symbol (vector-ref letters i))) - (set! i (modulo (add1 i) (vector-length letters))) - letter))) - ;; generates a fresh identifier w/ a "pretty" printable representation - (define (gen-pretty-id [sym (next-letter)]) - (mark-id-as-normalized (datum->syntax #'loc sym))) - (define (gen-existential-id [sym (next-letter)]) - (mark-id-as-existential (genid sym))) - ;; allows us to recognize and distinguish gensym'd identifiers - ;; from ones that came from the program we're typechecking - (define (local-tr-identifier? id) - (and (identifier? id) - (eq? (syntax-source-module dummy-id) - (syntax-source-module id))))) - -(require 'local-ids) diff -Nru racket-6.12+ppa1/share/pkgs/typed-racket-more/info.rkt racket-7.0+ppa1/share/pkgs/typed-racket-more/info.rkt --- racket-6.12+ppa1/share/pkgs/typed-racket-more/info.rkt 2018-01-26 21:10:12.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/typed-racket-more/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "base" "net-lib" "web-server-lib" "db-lib" "draw-lib" "rackunit-lib" "rackunit-gui" "rackunit-typed" "snip-lib" "typed-racket-lib" "gui-lib" "pict-lib" "images-lib" "racket-index" "sandbox-lib"))) (define implies (quote ("rackunit-typed"))) (define pkg-desc "Types for various libraries") (define pkg-authors (quote (samth stamourv))) (define version "1.9"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "base" "net-lib" "web-server-lib" "db-lib" "draw-lib" "rackunit-lib" "rackunit-gui" "rackunit-typed" "snip-lib" "typed-racket-lib" "gui-lib" "pict-lib" "images-lib" "racket-index" "sandbox-lib"))) (define implies (quote ("rackunit-typed"))) (define pkg-desc "Types for various libraries") (define pkg-authors (quote (samth stamourv))) (define version "1.9"))) diff -Nru racket-6.12+ppa1/share/pkgs/unix-socket/info.rkt racket-7.0+ppa1/share/pkgs/unix-socket/info.rkt --- racket-6.12+ppa1/share/pkgs/unix-socket/info.rkt 2018-01-26 21:10:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/unix-socket/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.2") (define deps (quote ("unix-socket-lib" "unix-socket-doc"))) (define implies (quote ("unix-socket-lib"))) (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.2") (define deps (quote ("unix-socket-lib" "unix-socket-doc"))) (define implies (quote ("unix-socket-lib"))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/unix-socket-doc/info.rkt racket-7.0+ppa1/share/pkgs/unix-socket-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/unix-socket-doc/info.rkt 2018-01-26 21:10:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/unix-socket-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.1") (define deps (quote ("base" ("unix-socket-lib" #:version "1.2")))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.1") (define deps (quote ("base" ("unix-socket-lib" #:version "1.2")))) (define build-deps (quote ("scribble-lib" "racket-doc"))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/unix-socket-lib/info.rkt racket-7.0+ppa1/share/pkgs/unix-socket-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/unix-socket-lib/info.rkt 2018-01-26 21:10:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/unix-socket-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define version "1.2") (define deps (quote (("base" #:version "6.11.0.5")))) (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define version "1.2") (define deps (quote (("base" #:version "6.11.0.5")))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-6.12+ppa1/share/pkgs/web-server/info.rkt racket-7.0+ppa1/share/pkgs/web-server/info.rkt --- racket-6.12+ppa1/share/pkgs/web-server/info.rkt 2018-01-26 21:10:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("web-server-lib" "web-server-doc"))) (define implies (quote ("web-server-lib" "web-server-doc"))) (define pkg-desc "An HTTP server") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("web-server-lib" "web-server-doc"))) (define implies (quote ("web-server-lib" "web-server-doc"))) (define pkg-desc "An HTTP server") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/info.rkt racket-7.0+ppa1/share/pkgs/web-server-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/web-server-doc/info.rkt 2018-01-26 21:10:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("net-doc" "net-cookies-doc" "rackunit-doc" "compatibility-doc" "db-doc" "scribble-doc" "compatibility-lib" "db-lib" "net-lib" "net-cookies-lib" "rackunit-lib" "sandbox-lib" "scribble-lib" "web-server-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("web-server-lib"))) (define pkg-desc "documentation part of \"web-server\"") (define pkg-authors (quote (jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("net-doc" "net-cookies-doc" "rackunit-doc" "compatibility-doc" "db-doc" "scribble-doc" "compatibility-lib" "db-lib" "net-lib" "net-cookies-lib" "rackunit-lib" "sandbox-lib" "scribble-lib" "web-server-lib" "racket-doc"))) (define deps (quote ("base"))) (define update-implies (quote ("web-server-lib"))) (define pkg-desc "documentation part of \"web-server\"") (define pkg-authors (quote (jay))))) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl --- racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -23,12 +23,15 @@ } @defproc[(cache-table-clear! [ct cache-table?] - [entry-ids (or/c false/c (listof symbol?)) #f]) + [entry-ids (or/c false/c (listof symbol?)) #f] + [finalize (-> any/c void?) void]) void?]{ If @racket[entry-ids] is @racket[#f], clears all entries in @racket[ct]. Otherwise, clears only the entries with keys in @racket[entry-ids]. + The procedure @racket[finalize] is invoked on each entry before it is cleared. - @history[#:changed "6.9.0.1" "Added optional argument."] + @history[#:changed "6.9.0.1" "Added optional argument for list of entry keys." + #:changed "6.11.0.3" "Added optional argument for finalizer procedure."] } @defproc[(cache-table? [v any/c]) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl --- racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -239,9 +239,10 @@ } @defproc[(make [#:format format format-req/c paren-format] - [#:log-path log-path path-string? "log"]) + [#:log-path log-path (or/c path-string? output-port?) "log"]) dispatcher/c]{ - Logs requests to @racket[log-path] by using @racket[format] to format the requests. + Logs requests to @racket[log-path], which can be either a filepath or an @racket[output-port?], + using @racket[format] to format the requests. Then invokes @racket[next-dispatcher]. }} diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl --- racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -18,17 +18,22 @@ @defproc[(make-cached-url->servlet [url->path url->path/c] [path->serlvet path->servlet/c]) - (values (->* () ((or/c false/c (listof url?))) void?) + (values (->* () ((or/c false/c (listof url?)) (-> servlet? void?)) void?) url->servlet/c)]{ - The first return value flushes the cache. If its optional argument is - @racket[#f] (the default), all servlet caches are flushed. Otherwise, - only those servlet caches to which @racket[url->path] maps the given - URLs are flushed. The second return value is a procedure that uses + The first return value is a procedure that flushes the cache. If its first + optional argument is @racket[#f] (the default), all servlet caches are + flushed. Otherwise, only those servlet caches to which @racket[url->path] + maps the given URLs are flushed. The second optional argument is a procedure + which is invoked on each cached value before it is flushed, which can be used + to finalize servlet resources. It defaults to @racket[void]. + + The second return value is a procedure that uses @racket[url->path] to resolve the URL to a path, then uses @racket[path->servlet] to resolve that path to a servlet, caching the results in an internal table. - @history[#:changed "6.9.0.1" "Added optional argument to first return value."] + @history[#:changed "6.9.0.1" "Added optional argument to first return value for list of URLs." + #:changed "6.11.0.3" "Added optional argument to first return value for servlet finalizer procedure."] } @defproc[(make [url->servlet url->servlet/c] diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl --- racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -176,7 +176,7 @@ [#:ssl-cert ssl-cert (or/c false/c path-string?) (and ssl? (build-path server-root-path "server-cert.pem"))] [#:ssl-key ssl-key (or/c false/c path-string?) (and ssl? (build-path server-root-path "private-key.pem"))] - [#:log-file log-file (or/c false/c path-string?) #f] + [#:log-file log-file (or/c false/c path-string? output-port?) #f] [#:log-format log-format (or/c log-format/c format-req/c) 'apache-default]) void]{ This sets up and starts a fairly default server instance. @@ -235,6 +235,8 @@ If @racket[log-file] is given, then it used to log requests using @racket[log-format] as the format. Allowable formats are those allowed by @racket[log-format->format]. If @racket[log-format] is a function, it is used directly to render the log entry. + If @racket[log-file] is a filepath, the given file is opened and written in a different thread. If @racket[log-file] is an @racket[output-port?], + logs are written directly to the port. If @racket[connection-close?] is @racket[#t], then every connection is closed after one request. Otherwise, the client decides based on what HTTP version it uses. diff -Nru racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/stateless-usage.scrbl racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/stateless-usage.scrbl --- racket-6.12+ppa1/share/pkgs/web-server-doc/web-server/scribblings/stateless-usage.scrbl 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-doc/web-server/scribblings/stateless-usage.scrbl 2018-07-27 22:12:02.000000000 +0000 @@ -12,7 +12,7 @@ @itemize[ @item{All uses of @racket[letrec] are removed and replaced with equivalent uses of @racket[let] and imperative features.} - @item{The program is converted into @link["http://en.wikipedia.org/wiki/Administrative_normal_form"]{ANF} (Administrative Normal Form), + @item{The program is converted into @link["http://en.wikipedia.org/wiki/A-normal_form"]{ANF} (A-Normal Form), making all continuations explicit.} @item{All continuations and continuations marks are recorded in the continuation marks of the expression diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/info.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/info.rkt 2018-01-26 21:10:18.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.2.900.15") "net-lib" "net-cookies-lib" "compatibility-lib" "scribble-text-lib" "parser-tools-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"web-server\"") (define pkg-authors (quote (jay))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" ("base" #:version "6.2.900.15") "net-lib" "net-cookies-lib" "compatibility-lib" "scribble-text-lib" "parser-tools-lib"))) (define build-deps (quote ("rackunit-lib"))) (define pkg-desc "implementation (no documentation) part of \"web-server\"") (define pkg-authors (quote (jay))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-log.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-log.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-log.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-log.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -20,7 +20,7 @@ [interface-version dispatcher-interface-version/c] [make (->* () (#:format format-req/c - #:log-path path-string?) + #:log-path (or/c path-string? output-port?)) dispatcher/c)]) (define interface-version 'v1) @@ -71,7 +71,7 @@ (uri ,(url->string (request-uri req))) (time ,(current-seconds))))) -(define (make-log-message log-path format-req) +(define (make-log-message log-path-or-port format-req) (define log-ch (make-async-channel)) (define log-thread (thread/suspend-to-kill @@ -89,14 +89,16 @@ (close-output-port log-p)) #f)]) (define the-log-p - (if (not (and log-p (file-exists? log-path))) - (begin - (unless (eq? log-p #f) - (close-output-port log-p)) - (let ([new-log-p (open-output-file log-path #:exists 'append)]) - (file-stream-buffer-mode new-log-p 'line) - new-log-p)) - log-p)) + (if (path-string? log-path-or-port) + (if (not (and log-p (file-exists? log-path-or-port))) + (begin + (unless (eq? log-p #f) + (close-output-port log-p)) + (let ([new-log-p (open-output-file log-path-or-port #:exists 'append)]) + (file-stream-buffer-mode new-log-p 'line) + new-log-p)) + log-p) + log-path-or-port)) (display (format-req req) the-log-p) the-log-p))]))))))) (lambda args diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-servlets.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-servlets.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-servlets.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/dispatchers/dispatch-servlets.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -23,21 +23,21 @@ [make-cached-url->servlet (-> url->path/c path->servlet/c - (values (() ((or/c false/c (listof url?))) . ->* . void?) + (values (() ((or/c false/c (listof url?)) (-> servlet? void?)) . ->* . void?) url->servlet/c))]) (define (make-cached-url->servlet url->path path->servlet) (define config:scripts (make-cache-table)) - (values (lambda ([uris #f]) - ;; This is broken - only out of date or specifically mentioned scripts should be flushed. This destroys persistent state! + (values (lambda ([uris #f] [finalize void]) (cache-table-clear! config:scripts (and uris (for/list ([uri (in-list uris)]) (let-values ([(servlet-path _) (url->path uri)]) - (string->symbol (path->string servlet-path))))))) + (string->symbol (path->string servlet-path))))) + finalize)) (lambda (uri) (define-values (servlet-path _) (with-handlers diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/lib.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/lib.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/lib.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/lib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,7 @@ racket/function racket/serialize syntax/location + setup/collects (for-syntax racket/base syntax/parse)) @@ -70,7 +71,7 @@ #:range-contracts (map (curry coerce-contract 'formlet/c) contracts)))])) (define quote-this-module-path - (quote-module-path)) + (path->collects-relative (quote-module-path))) (define-syntax formlet/c (syntax-parser [(_ range ...) @@ -83,7 +84,7 @@ (-> contract? (... ...) contract?) dynamic-formlet/c quote-this-module-path - (quote-module-path) + (path->collects-relative (quote-module-path)) "formlet/c" #'name)])) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/input.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/input.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/input.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/input.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -310,7 +310,7 @@ ,(display e)))))))) (define (serial-car pr) - (car pr)) + (if (pair? pr) (car pr) #f)) (define (select-input l #:attributes [attrs null] diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/lib.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/lib.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/lib.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/formlets/unsafe/lib.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -77,10 +77,3 @@ (define (formlet-process f r) (let-values ([(x p i) (f 0)]) (p (request-bindings/raw r)))) - - - - - - - diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/private/cache-table.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/private/cache-table.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/private/cache-table.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/private/cache-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -8,15 +8,20 @@ (make-cache-table (make-hasheq) (make-semaphore 1))) -(define (cache-table-clear! ct [entry-ids #f]) +(define (cache-table-clear! ct [entry-ids #f] [finalize void]) (call-with-semaphore (cache-table-semaphore ct) (lambda () - (if entry-ids - (let ([cache-hash (cache-table-hash ct)]) + (let ([cache-hash (cache-table-hash ct)]) + (if entry-ids (for ([entry-id (in-list entry-ids)]) - (hash-remove! cache-hash entry-id))) - (set-cache-table-hash! ct (make-hasheq)))))) + (when (hash-has-key? cache-hash entry-id) + (finalize (hash-ref cache-hash entry-id)) + (hash-remove! cache-hash entry-id))) + (begin + (for ([entry (in-hash-values cache-hash)]) + (finalize entry)) + (set-cache-table-hash! ct (make-hasheq)))))))) (define (cache-table-lookup! ct entry-id entry-thunk) (define ht (cache-table-hash ct)) @@ -35,5 +40,5 @@ [rename new-cache-table make-cache-table (-> cache-table?)] [cache-table-lookup! (cache-table? symbol? (-> any/c) . -> . any/c)] - [cache-table-clear! ((cache-table?) ((or/c false/c (listof symbol?))) . ->* . void?)] + [cache-table-clear! ((cache-table?) ((or/c false/c (listof symbol?)) (-> any/c void?)) . ->* . void?)] [cache-table? (any/c . -> . boolean?)]) diff -Nru racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/servlet-env.rkt racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/servlet-env.rkt --- racket-6.12+ppa1/share/pkgs/web-server-lib/web-server/servlet-env.rkt 2018-01-26 20:34:44.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/web-server-lib/web-server/servlet-env.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -66,7 +66,7 @@ #:mime-types-path path-string? #:servlet-path string? #:servlet-regexp regexp? - #:log-file (or/c false/c path-string?) + #:log-file (or/c false/c path-string? output-port?) #:log-format (or/c log:log-format/c log:format-req/c)) . ->* . void)]) diff -Nru racket-6.12+ppa1/share/pkgs/wxme/info.rkt racket-7.0+ppa1/share/pkgs/wxme/info.rkt --- racket-6.12+ppa1/share/pkgs/wxme/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/wxme/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("wxme-lib" "gui-doc"))) (define implies (quote ("wxme-lib"))) (define pkg-desc "Decoding the WXME graphical file format in a text-only environment") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("wxme-lib" "gui-doc"))) (define implies (quote ("wxme-lib"))) (define pkg-desc "Decoding the WXME graphical file format in a text-only environment") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/wxme-lib/info.rkt racket-7.0+ppa1/share/pkgs/wxme-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/wxme-lib/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/wxme-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "snip-lib"))) (define pkg-desc "implementation (no documentation) part of \"wxme\"") (define pkg-authors (quote (mflatt))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "compatibility-lib" "snip-lib"))) (define pkg-desc "implementation (no documentation) part of \"wxme\"") (define pkg-authors (quote (mflatt))))) diff -Nru racket-6.12+ppa1/share/pkgs/xrepl/info.rkt racket-7.0+ppa1/share/pkgs/xrepl/info.rkt --- racket-6.12+ppa1/share/pkgs/xrepl/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/xrepl/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("xrepl-lib" "xrepl-doc"))) (define implies (quote ("xrepl-lib" "xrepl-doc"))) (define pkg-desc "Console-oriented extended REPL for Racket") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("xrepl-lib" "xrepl-doc"))) (define implies (quote ("xrepl-lib" "xrepl-doc"))) (define pkg-desc "Console-oriented extended REPL for Racket") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/xrepl-doc/info.rkt racket-7.0+ppa1/share/pkgs/xrepl-doc/info.rkt --- racket-6.12+ppa1/share/pkgs/xrepl-doc/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/xrepl-doc/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define build-deps (quote ("errortrace-doc" "macro-debugger" "profile-doc" "readline-doc" "macro-debugger-text-lib" "profile-lib" "readline-lib" "xrepl-lib" "racket-doc"))) (define deps (quote ("base" "sandbox-lib" "scribble-lib"))) (define update-implies (quote ("xrepl-lib"))) (define pkg-desc "documentation part of \"xrepl\"") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define build-deps (quote ("errortrace-doc" "macro-debugger" "profile-doc" "readline-doc" "macro-debugger-text-lib" "profile-lib" "readline-lib" "xrepl-lib" "racket-doc"))) (define deps (quote ("base" "sandbox-lib" "scribble-lib"))) (define update-implies (quote ("xrepl-lib"))) (define pkg-desc "documentation part of \"xrepl\"") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/xrepl-doc/xrepl/doc-utils.rkt racket-7.0+ppa1/share/pkgs/xrepl-doc/xrepl/doc-utils.rkt --- racket-6.12+ppa1/share/pkgs/xrepl-doc/xrepl/doc-utils.rkt 2018-01-26 20:37:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/xrepl-doc/xrepl/doc-utils.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -18,7 +18,8 @@ (λ () (make-evaluator 'racket/base)))) (e '(require xrepl/xrepl)) (e '(current-namespace (module->namespace 'xrepl/xrepl))) - (set! c (e '(for/list ([c (in-list commands-list)]) + (set! c (e '(for*/list ([cs (in-list (reverse commands-dict))] + [c (in-list (reverse (cdr cs)))]) (list (car (command-names c)) (cdr (command-names c)) (command-argline c) diff -Nru racket-6.12+ppa1/share/pkgs/xrepl-lib/info.rkt racket-7.0+ppa1/share/pkgs/xrepl-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/xrepl-lib/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/xrepl-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base" "readline-lib" "scribble-text-lib"))) (define pkg-desc "implementation (no documentation) part of \"xrepl\"") (define pkg-authors (quote (eli))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base" "readline-lib" "scribble-text-lib"))) (define pkg-desc "implementation (no documentation) part of \"xrepl\"") (define pkg-authors (quote (eli))))) diff -Nru racket-6.12+ppa1/share/pkgs/xrepl-lib/xrepl/xrepl.rkt racket-7.0+ppa1/share/pkgs/xrepl-lib/xrepl/xrepl.rkt --- racket-6.12+ppa1/share/pkgs/xrepl-lib/xrepl/xrepl.rkt 2018-01-26 20:37:06.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/xrepl-lib/xrepl/xrepl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -14,7 +14,7 @@ ;; ---------------------------------------------------------------------------- -(require racket/list racket/match scribble/text/wrap) +(require racket/dict racket/list racket/match scribble/text/wrap) ;; ---------------------------------------------------------------------------- ;; utilities @@ -114,8 +114,8 @@ ;; "~/..." path. (if (not (complete-path? x)) ; shouldn't happen x - (let* ([r (path->string (find-relative-path (current-directory) x))] - [h (path->string (let ([p (find-relative-path home-dir x)]) + (let* ([r (path->string (find-relative-path (current-directory) (string->path x)))] + [h (path->string (let ([p (find-relative-path home-dir (string->path x))]) ;; On Windows, HOME might be on a different ;; volume, so make sure we get a relative ;; path back: @@ -235,8 +235,13 @@ (struct command (names argline blurb desc handler)) (define commands (make-hasheq)) -(define commands-list '()) ; for help displays, in definition order +;; For help displays: commands organized into sections, where sections are +;; subdicts. Sections and items within each section are added in reverse +;; definition order. Nested sections are printed correctly by ",help", but +;; `defcommand-section' does not currently support defining nested sections. +(define commands-dict null) (define current-command (make-parameter #f)) +(define current-commands-section (make-parameter commands-dict)) (define (register-command! names blurb argline desc handler) (let* ([names (if (list? names) names (list names))] [cmd (command names blurb argline desc handler)]) @@ -244,11 +249,18 @@ (if (hash-ref commands n #f) (error 'defcommand "duplicate command name: ~s" n) (hash-set! commands n cmd))) - (set! commands-list (cons cmd commands-list)))) + (set! commands-dict (dict-update commands-dict + (current-commands-section) + (λ (sec-cmd-list) (cons cmd sec-cmd-list)))))) (define-syntax-rule (defcommand cmd+aliases argline blurb [desc ...] body0 body ...) (register-command! `cmd+aliases `argline `blurb `(desc ...) (λ () body0 body ...))) +(define (defcommand-section name) + (when (dict-has-key? commands-dict name) + (error 'defcommand-section "duplicate command section name: ~s" name)) + (set! commands-dict (cons (cons name null) commands-dict)) + (current-commands-section name)) (define (cmderror fmt #:default-who [dwho #f] . args) (let ([cmd (current-command)]) @@ -351,6 +363,11 @@ ((command-handler (or (hash-ref commands cmd #f) (error "Unknown command:" cmd))))))) +;; ---------------------------------------------------------------------------- +;; generic commands + +(defcommand-section "General commands") + (defcommand (help h ?) "[]" "display available commands" ["Lists known commands and their help; use with a command name to get" @@ -359,24 +376,30 @@ (define cmd (and arg (hash-ref commands arg (λ () (printf "*** Unknown command: `~s'\n" arg) #f)))) - (define (show-cmd cmd indent) + (define (indentation-string indent-level) + (string-append "; " (make-string (* 2 indent-level) #\space))) + (define (show-cmd cmd indent-level) (define names (command-names cmd)) - (printf "~a~s" indent (car names)) + (printf "~a~s" (indentation-string indent-level) (car names)) (when (pair? (cdr names)) (printf " ~s" (cdr names))) (printf ": ~a\n" (command-blurb cmd))) + (define (show-cmd-sec sec [indent-level 0]) + (for ([(name commands-or-sections) (in-dict (reverse sec))]) + (unless (null? commands-or-sections) + (printf "~a~a:\n" (indentation-string indent-level) name) + (for-each (λ (c) (if (dict? c) + (show-cmd-sec c (add1 indent-level)) + (show-cmd c (add1 indent-level)))) + (reverse commands-or-sections))))) (with-wrapped-output - (if cmd - (begin (show-cmd cmd "; ") - (printf "; usage: ,~a" arg) - (let ([a (command-argline cmd)]) (when a (printf " ~a" a))) - (printf "\n") - (for ([d (in-list (command-desc cmd))]) - (printf "; ~a\n" d))) - (begin (printf "; Available commands:\n") - (for-each (λ (c) (show-cmd c "; ")) (reverse commands-list)))))) - -;; ---------------------------------------------------------------------------- -;; generic commands + (if cmd + (begin (show-cmd cmd "; ") + (printf "; usage: ,~a" arg) + (let ([a (command-argline cmd)]) (when a (printf " ~a" a))) + (printf "\n") + (for ([d (in-list (command-desc cmd))]) + (printf "; ~a\n" d))) + (show-cmd-sec commands-dict)))) (defcommand (exit quit ex) "[]" "exit racket" @@ -587,6 +610,8 @@ ;; ---------------------------------------------------------------------------- ;; binding related commands +(defcommand-section "Binding information") + (defcommand (apropos ap) " ..." "look for a binding" ["Additional arguments restrict the shown matches. The search specs can" @@ -750,6 +775,8 @@ ;; ---------------------------------------------------------------------------- ;; require/load commands +(defcommand-section "Requiring and loading") + (defcommand (require req r) " ...+" "require a module" ["The arguments are usually passed to `require', unless an argument" @@ -816,6 +843,8 @@ ;; ---------------------------------------------------------------------------- ;; debugging commands +(defcommand-section "Debugging") + ;; not useful: catches only escape continuations ;; (define last-break-exn (make-parameter #f)) ;; (defcommand (continue cont) #f @@ -1033,6 +1062,8 @@ ;; ---------------------------------------------------------------------------- ;; namespace switching +(defcommand-section "Miscellaneous") + (define default-namespace-name '*) (define current-namespace-name (make-parameter default-namespace-name)) (define namespaces diff -Nru racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt --- racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -11,11 +11,12 @@ racket/pretty racket/path racket/set - racket/extflonum) + racket/extflonum + racket/private/truncate-path) (provide/contract - [zo-marshal (compilation-top? . -> . bytes?)] - [zo-marshal-to (compilation-top? output-port? . -> . void?)]) + [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)] + [zo-marshal-to ((or/c linkl-directory? linkl-bundle?) output-port? . -> . void?)]) (struct not-ready ()) @@ -27,15 +28,17 @@ (get-output-bytes bs)) (define (zo-marshal-to top outp) - (if (and (mod? (compilation-top-code top)) - (or (pair? (mod-pre-submodules (compilation-top-code top))) - (pair? (mod-post-submodules (compilation-top-code top))))) - ;; module directory and submodules: - (zo-marshal-modules-to top outp) - ;; single module or other: - (zo-marshal-top-to top outp))) + (match top + [(linkl-directory table) + ;; linklet directory: + (zo-marshal-directory-to table outp)] + [(linkl-bundle table) + ;; single linklet bundle: + (zo-marshal-bundle-to table outp)] + [else + (error 'zo-marshal-top "not a linklet bundle or directory:" top)])) -(define (zo-marshal-modules-to top outp) +(define (zo-marshal-directory-to top outp) ;; Write the compiled form header (write-bytes #"#~" outp) ;; Write the version: @@ -45,80 +48,78 @@ (write-byte (char->integer #\D) outp) - (struct mod-bytes (code-bstr name-bstr offset)) - ;; bytestring encodings of the modules and module names - ;; --- in the order that they must be written: - (define pre-mod-bytess - (reverse - (let loop ([m (compilation-top-code top)] [pre-accum null]) - (define (encode-module-name name) - (if (symbol? name) - #"" - (apply bytes-append - (for/list ([sym (in-list (cdr name))]) - (define b (string->bytes/utf-8 (symbol->string sym))) - (define len (bytes-length b)) - (bytes-append (if (len . < . 255) - (bytes len) - (bytes-append - (bytes 255) - (integer->integer-bytes len 4 #f #f))) - b))))) - (define accum - (let iloop ([accum pre-accum] [subm (mod-pre-submodules m)]) - (if (null? subm) - accum - (iloop (loop (car subm) accum) (cdr subm))))) - (define o (open-output-bytes)) - (zo-marshal-top-to (struct-copy compilation-top top - [code (struct-copy mod m - [pre-submodules null] - [post-submodules null])]) - o) - (define new-accum - (cons (mod-bytes (get-output-bytes o) - (encode-module-name (mod-name m)) - 0) - accum)) - (let iloop ([accum new-accum] [subm (mod-post-submodules m)]) - (if (null? subm) - accum - (iloop (loop (car subm) accum) (cdr subm))))))) - (write-bytes (int->bytes (length pre-mod-bytess)) outp) + (struct bundle-bytes (code-bstr name-list name-bstr offset)) + ;; bytestring encodings of the bundles and bundle names + (define unsorted-pre-bundle-bytess + (for/list ([(name bundle) (in-hash top)]) + (define name-bstr + (if (null? name) + #"" + (apply bytes-append + (for/list ([sym (in-list name)]) + (define b (string->bytes/utf-8 (symbol->string sym))) + (define len (bytes-length b)) + (bytes-append (if (len . < . 255) + (bytes len) + (bytes-append + (bytes 255) + (integer->integer-bytes len 4 #f #f))) + b))))) + (define o (open-output-bytes)) + (zo-marshal-bundle-to (linkl-bundle-table bundle) o) + (bundle-bytes (get-output-bytes o) + name + name-bstr + 0))) + ;; Write order must correspond to a post-order traversal + ;; of the tree, so write + (define pre-bundle-bytess + (sort unsorted-pre-bundle-bytess + (lambda (a b) + (let loop ([a (bundle-bytes-name-list a)] [b (bundle-bytes-name-list b)]) + (cond + [(null? a) #f] + [(null? b) #t] + [(eq? (car a) (car b)) (loop (cdr a) (cdr b))] + [(symbolbytes (length pre-bundle-bytess)) outp) ;; Size of btree: (define header-size (+ 8 (string-length (version)))) (define btree-size (+ header-size - (apply + (for/list ([mb (in-list pre-mod-bytess)]) - (+ (bytes-length (mod-bytes-name-bstr mb)) + (apply + (for/list ([mb (in-list pre-bundle-bytess)]) + (+ (bytes-length (bundle-bytes-name-bstr mb)) 20))))) - ;; Add offsets to mod-bytess: - (define mod-bytess (let loop ([offset btree-size] [mod-bytess pre-mod-bytess]) - (if (null? mod-bytess) + ;; Add offsets to bundle-bytess: + (define bundle-bytess (let loop ([offset btree-size] [bundle-bytess pre-bundle-bytess]) + (if (null? bundle-bytess) null - (let ([mb (car mod-bytess)]) - (cons (mod-bytes (mod-bytes-code-bstr mb) - (mod-bytes-name-bstr mb) - offset) + (let ([mb (car bundle-bytess)]) + (cons (bundle-bytes (bundle-bytes-code-bstr mb) + (bundle-bytes-name-list mb) + (bundle-bytes-name-bstr mb) + offset) (loop (+ offset - (bytes-length (mod-bytes-code-bstr mb))) - (cdr mod-bytess))))))) + (bytes-length (bundle-bytes-code-bstr mb))) + (cdr bundle-bytess))))))) ;; Sort by name for btree order: - (define sorted-mod-bytess - (list->vector (sort mod-bytess bytesvector (sort bundle-bytess bytesbytes name-len) outp) - (write-bytes (mod-bytes-name-bstr mb) outp) - (write-bytes (int->bytes (mod-bytes-offset mb)) outp) - (write-bytes (int->bytes (bytes-length (mod-bytes-code-bstr mb))) outp) + (write-bytes (bundle-bytes-name-bstr mb) outp) + (write-bytes (int->bytes (bundle-bytes-offset mb)) outp) + (write-bytes (int->bytes (bytes-length (bundle-bytes-code-bstr mb))) outp) (define left-pos (+ pos name-len 20)) (write-bytes (int->bytes (if (= lo mid) 0 @@ -137,31 +138,16 @@ (loop (add1 mid) hi right-pos)))) (write-btree void) ; to fill `right-offsets' (write-btree write-bytes) ; to actually write the btree - ;; write modules: - (for ([mb (in-list mod-bytess)]) - (write-bytes (mod-bytes-code-bstr mb) outp))) + ;; Write bundles: + (for ([mb (in-list bundle-bytess)]) + (write-bytes (bundle-bytes-code-bstr mb) outp))) -(define (zo-marshal-top-to top outp) - - ; For detecting sharing in wraps: - (define stx-objs (make-hasheq)) - (define wraps (make-hasheq)) - (define hash-consed (make-hash)) - (define hash-consed-results (make-hasheq)) - +(define (zo-marshal-bundle-to top outp) ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) - (define ct - (match top - [(compilation-top max-let-depth binding-namess prefix form) - (list* max-let-depth - (binding-namess-hash->list binding-namess) - prefix - (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? - stx-objs wraps hash-consed hash-consed-results)) + (out-anything top (make-out outp shared-obj-pos shared-obj-pos-any counting?)) (file-position outp)) ; -> vector @@ -231,8 +217,7 @@ [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f - stx-objs wraps hash-consed hash-consed-results)))) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f)))) (file-position outp))) ; Calculate file positions @@ -248,7 +233,8 @@ (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) - (write-byte (char->integer #\T) outp) + ;; "B" is for linklet "bundle" (as opposed to a linklet directory) + (write-byte (char->integer #\B) outp) ; Write empty hash code (write-bytes (make-bytes 20 0) outp) @@ -260,7 +246,7 @@ (write-bytes (bytes (if all-short? 1 0)) outp) (for ([o (in-list offsets)]) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - ; Post-shared is where the ctop actually starts + ; Post-shared is where the top actually starts (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) @@ -272,29 +258,22 @@ ;; ---------------------------------------- (define toplevel-type-num 0) -(define sequence-type-num 6) -(define unclosed-procedure-type-num 8) -(define let-value-type-num 9) -(define let-void-type-num 10) -(define letrec-type-num 11) -(define wcm-type-num 13) -(define quote-syntax-type-num 14) +(define sequence-type-num 7) +(define unclosed-procedure-type-num 9) +(define let-value-type-num 10) +(define let-void-type-num 11) +(define letrec-type-num 12) +(define wcm-type-num 14) (define define-values-type-num 15) -(define define-syntaxes-type-num 16) -(define begin-for-syntax-type-num 17) -(define set-bang-type-num 18) -(define boxenv-type-num 19) -(define begin0-sequence-type-num 20) -(define splice-sequence-type-num 21) -(define require-form-type-num 22) -(define varref-form-type-num 23) -(define apply-values-type-num 24) -(define with-immed-mark-type-num 25) -(define case-lambda-sequence-type-num 26) -(define module-type-num 27) -(define inline-variants-type-num 28) -(define variable-type-num 37) -(define prefix-type-num 122) +(define set-bang-type-num 16) +(define boxenv-type-num 17) +(define begin0-sequence-type-num 18) +(define varref-form-type-num 19) +(define apply-values-type-num 20) +(define with-immed-mark-type-num 21) +(define case-lambda-sequence-type-num 22) +(define inline-variants-type-num 23) +(define linklet-type-num 25) (define-syntax define-enum (syntax-rules () @@ -324,9 +303,8 @@ CPT_LIST CPT_VECTOR CPT_HASH_TABLE - CPT_STX CPT_LET_ONE_TYPED - CPT_MARSHALLED + CPT_LINKLET CPT_QUOTE CPT_REFERENCE CPT_LOCAL @@ -335,25 +313,31 @@ CPT_APPLICATION CPT_LET_ONE CPT_BRANCH - CPT_MODULE_INDEX - CPT_MODULE_VAR CPT_PATH CPT_CLOSURE - CPT_DELAY_REF ; XXX should be used to delay loading of syntax objects and lambda bodies + CPT_DELAY_REF ; used to delay loading of syntax objects and lambda bodies CPT_PREFAB CPT_LET_ONE_UNUSED - CPT_SCOPE - CPT_ROOT_SCOPE - CPT_SHARED) + CPT_SHARED + CPT_TOPLEVEL + CPT_BEGIN + CPT_BEGIN0 + CPT_LET_VALUE + CPT_LET_VOID + CPT_LETREC + CPT_WCM + CPT_DEFINE_VALUES + CPT_SET_BANG + CPT_VARREF + CPT_APPLY_VALUES + CPT_OTHER_FORM + CPT_SRCLOC) -(define CPT_SMALL_NUMBER_START 39) -(define CPT_SMALL_NUMBER_END 62) +(define CPT_SMALL_NUMBER_START 47) +(define CPT_SMALL_NUMBER_END 74) -(define CPT_SMALL_SYMBOL_START 62) -(define CPT_SMALL_SYMBOL_END 80) - -(define CPT_SMALL_MARSHALLED_START 80) -(define CPT_SMALL_MARSHALLED_END 92) +(define CPT_SMALL_SYMBOL_START 74) +(define CPT_SMALL_SYMBOL_END 92) (define CPT_SMALL_LIST_MAX 50) (define CPT_SMALL_PROPER_LIST_START 92) @@ -391,90 +375,6 @@ (define-struct protected-symref (val)) -(define (encode-stx-obj w out) - (match w - [(struct stx-obj (datum wraps srcloc props tamper-status)) - (let* ([enc-datum - (match datum - [(cons a b) - (let ([p (cons (encode-stx-obj a out) - (let bloop ([b b]) - (match b - ['() null] - [(cons b1 b2) - (cons (encode-stx-obj b1 out) - (bloop b2))] - [else - (encode-stx-obj b out)])))] - [len (let loop ([datum datum][len 0]) - (cond - [(null? datum) #f] - [(pair? datum) (loop (cdr datum) (add1 len))] - [else len]))]) - ;; for improper lists, we need to include the length so the - ;; parser knows where the end of the improper list is - (if len - (cons len p) - p))] - [(box x) - (box (encode-stx-obj x out))] - [(? vector? v) - (vector-map (lambda (e) (encode-stx-obj e out)) v)] - [(? prefab-struct-key) - (define l (vector->list (struct->vector datum))) - (apply - make-prefab-struct - (car l) - (map (lambda (e) (encode-stx-obj e out)) (cdr l)))] - [_ datum])] - [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)] - [esrcloc (let () - (define (avail? n) (n . >= . 0)) - (define (xvector a b c d e) - ;; Add paren-shape info, if any: - (case (hash-ref props 'paren-shape #f) - [(#\[) (yvector a b c d e #\[)] - [(#\{) (yvector a b c d e #\{)] - [else (if (or a (avail? b) (avail? c) (avail? d)) - (yvector a b c d e #f) - #f)])) - (define (yvector a b c d e f) - ;; Add properties, if any: - (if (positive? (- (hash-count props) (if f 1 0))) - (vector a b c d e f - (sort (for/list ([(k v) (in-hash props)] - #:unless (and f - (eq? k 'paren-shape))) - (cons k v)) - symbolbytes n) out)])) -(define (out-marshaled type-num val out) - (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) - (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) - (begin - (out-byte CPT_MARSHALLED out) - (out-number type-num out))) - (out-anything val out)) - (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) @@ -561,9 +433,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? - ;; For root scope: - scope?)) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -624,135 +494,40 @@ (out-byte CPT_FALSE out)] [(? void?) (out-byte CPT_VOID out)] - [(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root)))) - (out-byte CPT_ROOT_SCOPE out)] - [(struct module-variable (modidx sym pos phase constantness)) - (define (to-sym #:prefix [prefix "struct"] n) - (string->symbol (format "~a~a" prefix n))) - (out-byte CPT_MODULE_VAR out) - (out-anything modidx out) - (out-anything sym out) - (out-anything (cond - [(function-shape? constantness) - (let ([a (function-shape-arity constantness)]) - (cond - [(arity-at-least? a) - (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) - (if (function-shape-preserves-marks? constantness) 1 0))] - [(list? a) - (string->symbol (apply - string-append - (add-between - (for/list ([a (in-list a)]) - (define n (if (arity-at-least? a) - (- (add1 (arity-at-least-value a))) - a)) - (number->string n)) - ":")))] - [else - (bitwise-ior (arithmetic-shift a 1) - (if (function-shape-preserves-marks? constantness) 1 0))]))] - [(struct-type-shape? constantness) - (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) - 3))] - [(constructor-shape? constantness) - (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) - 3)))] - [(predicate-shape? constantness) (to-sym 2)] - [(accessor-shape? constantness) - (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) - 3)))] - [(mutator-shape? constantness) - (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) - 3)))] - [(struct-type-property-shape? constantness) - (to-sym #:prefix "prop" - (if (struct-type-property-shape-has-guard? constantness) - 1 - 0))] - [(property-predicate-shape? constantness) - (to-sym #:prefix "prop" 2)] - [(property-accessor-shape? constantness) - (to-sym #:prefix "prop" 3)] - [(struct-other-shape? constantness) - (to-sym 5)] - [else #f]) - out) - (case constantness - [(#f) (void)] - [(fixed) (out-number -5 out)] - [else (out-number -4 out)]) - (unless (zero? phase) - (out-number -2 out) - (out-number phase out)) - (out-number pos out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) (let ([pos ((out-shared-index out) v #:error? #t)]) (out-number pos out) (out-anything lam out))] - [(struct prefix (num-lifts toplevels stxs src-insp-desc)) - (out-marshaled - prefix-type-num - (list* src-insp-desc - num-lifts - (list->vector toplevels) - (list->vector stxs)) - out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(? mod?) - (out-module v out)] + [(? linkl?) + (out-linklet v out)] [(struct def-values (ids rhs)) - (out-marshaled define-values-type-num - (list->vector (cons (protect-quote rhs) ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - (out-marshaled define-syntaxes-type-num - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - dummy - ids)) - out)] - [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) - (out-marshaled begin-for-syntax-type-num - (vector (map protect-quote rhs) - prefix - max-let-depth - dummy) - out)] + (out-byte CPT_DEFINE_VALUES out) + (out-anything (list->vector (cons (protect-quote rhs) ids)) out)] [(struct beg0 (forms)) - (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + (out-byte CPT_BEGIN0 out) + (out-number (length forms) out) + (for ([form (in-list forms)]) (out-anything (protect-quote form) out))] [(struct seq (forms)) - (out-marshaled sequence-type-num (map protect-quote forms) out)] - [(struct splice (forms)) - (out-marshaled splice-sequence-type-num forms out)] - [(struct req (reqs dummy)) - (out-marshaled require-form-type-num (cons dummy reqs) out)] + (out-byte CPT_BEGIN out) + (out-number (length forms) out) + (for ([form (in-list forms)]) (out-anything (protect-quote form) out))] [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (cons - depth - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x2 0) - (if ready? #x1 0))) - pos)) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] + (out-byte CPT_TOPLEVEL out) + (out-number (bitwise-ior + (if const? #x2 0) + (if ready? #x1 0)) + out) + (out-number pos out) + (out-number depth out)] [(struct primval (id)) (out-byte CPT_REFERENCE out) (out-number id out)] [(struct assign (id rhs undef-ok?)) - (out-marshaled set-bang-type-num - (cons undef-ok? (cons id (protect-quote rhs))) - out)] + (out-byte CPT_SET_BANG out) + (out-number (if undef-ok? 1 0) out) + (out-anything id out) + (out-anything (protect-quote rhs) out)] [(struct localref (unbox? offset clear? other-clears? type)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) @@ -775,10 +550,11 @@ [(? lam?) (out-lam v out)] [(struct case-lam (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number case-lambda-sequence-type-num out) + (out-number (length lams) out) + (out-anything name out) + (for ([lam (in-list lams)]) (out-anything lam out))] [(struct let-one (rhs body type unused?)) (out-byte (cond [type CPT_LET_ONE_TYPED] @@ -790,34 +566,27 @@ (when type (out-number (type->index type) out))] [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] + (out-byte CPT_LET_VOID out) + (out-number count out) + (out-number (if boxes? 1 0) out) + (out-anything (protect-quote body) out)] [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] + (out-byte CPT_LETREC out) + (out-number (length procs) out) + (for ([proc (in-list procs)]) (out-anything proc out)) + (out-anything (protect-quote body) out)] [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] + (out-byte CPT_LET_VALUE out) + (out-number count out) + (out-number pos out) + (out-number (if boxes? 1 0) out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out)] [(struct boxenv (pos body)) - (out-marshaled boxenv-type-num - (cons - pos - (protect-quote body)) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number boxenv-type-num out) + (out-anything pos out) + (out-anything (protect-quote body) out)] [(struct branch (test then else)) (out-byte CPT_BRANCH out) (out-anything (protect-quote test) out) @@ -834,28 +603,32 @@ (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) - (out-marshaled apply-values-type-num - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] + (out-byte CPT_APPLY_VALUES out) + (out-anything (protect-quote proc) out) + (out-anything (protect-quote args-expr) out)] [(struct with-immed-mark (key val body)) - (out-marshaled with-immed-mark-type-num - (vector - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number with-immed-mark-type-num out) + (out-anything (protect-quote key) out) + (out-anything (protect-quote val) out) + (out-anything (protect-quote body) out)] [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct varref (expr dummy)) - (out-marshaled varref-form-type-num - (cons expr dummy) - out)] + (out-byte CPT_WCM out) + (out-anything (protect-quote key) out) + (out-anything (protect-quote val) out) + (out-anything (protect-quote body) out)] + [(struct varref (expr dummy constant? from-unsafe?)) + (out-byte CPT_VARREF out) + (out-number (bitwise-ior (if constant? 1 0) + (if from-unsafe? 2 0)) + out) + (out-anything expr out) + (out-anything dummy out)] + [(struct inline-variant (direct inline)) + (out-byte CPT_OTHER_FORM out) + (out-number inline-variants-type-num out) + (out-anything (protect-quote direct) out) + (out-anything (protect-quote inline) out)] [(protected-symref v) (out-anything ((out-shared-index out) v #:error? #t) out)] [(and (? symbol?) (not (? symbol-interned?))) @@ -963,27 +736,6 @@ (out-number len out))) (for ([n (in-range (sub1 len) -1 -1)]) (out-number (vector-ref vec n) out)))] - [(? module-path-index?) - ;; XXX should add interning of module path indices - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split v)]) - (out-anything name out) - (out-anything base out) - (unless (or name base) - (out-anything (module-path-index-submodule v) out)))] - [(stx content) - (out-byte CPT_STX out) - (out-anything content out)] - [(encoded-scope relative-id content) - (out-byte CPT_SCOPE out) - ;; The `out-shared` wrapper already called `((out-shared-index out) v)` - ;; once, so `pos` will defintely be a number: - (let ([pos ((out-shared-index out) v)]) - (out-number pos out)) - (out-number relative-id out) - (out-anything (share-everywhere content out) out)] - [(? stx-obj?) - (out-anything (lookup-encoded-stx-obj v out) out)] [(? prefab-struct-key) (define pre-v (struct->vector v)) (vector-set! pre-v 0 (prefab-struct-key v)) @@ -995,26 +747,8 @@ (out-anything qv out))] [(? path?) (out-byte CPT_PATH out) - (define (within? p) - (and (relative-path? p) - (let loop ([p p]) - (define-values (base name dir?) (split-path p)) - (and (not (eq? name 'up)) - (not (eq? name 'same)) - (or (not (path? base)) - (loop base)))))) (define maybe-rel - (and (current-write-relative-directory) - (let ([dir (current-write-relative-directory)]) - (and (or (not dir) - (within? (find-relative-path v - (if (pair? dir) - (cdr dir) - dir)))) - (find-relative-path v - (if (pair? dir) - (car dir) - dir)))))) + (path->relative-path v)) (cond [(not maybe-rel) (define bstr (path->bytes v)) @@ -1027,6 +761,19 @@ (path-element->bytes e) e)) out)])] + [(? srcloc?) + (out-byte CPT_SRCLOC out) + (define src (srcloc-source v)) + (define new-src + (cond + [(and (path? src) (not (path->relative-path src))) + (truncate-path src)] + [else src])) + (out-anything new-src out) + (out-anything (srcloc-line v) out) + (out-anything (srcloc-column v) out) + (out-anything (srcloc-position v) out) + (out-anything (srcloc-span v) out)] [(or (? regexp?) (? byte-regexp?) (? number?) @@ -1052,202 +799,99 @@ (out-bytes bstr out)] [else (error 'out-anything "~s" (current-type-trace))]))))) -(define (out-module mod-form out) - (out-marshaled module-type-num - (convert-module mod-form) - out)) - -(define (convert-module mod-form) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (let* ([lookup-req (lambda (phase) - (let ([a (assq phase requires)]) - (if a - (cdr a) - null)))] - [other-requires (filter (lambda (l) - (not (memq (car l) '(#f -1 0 1)))) - requires)] - [extract-protects - (lambda (phase) - (let ([a (assq phase provides)]) - (and a - (let ([p (map provided-protected? (append (cadr a) - (caddr a)))]) - (if (ormap values p) - (list->vector p) - #f)))))] - [extract-unexported - (lambda (phase) - (let ([a (assq phase unexported)]) - (and a - (cdr a))))] - [list->vector/#f (lambda (default l) - (if (andmap (lambda (x) (equal? x default)) l) - #f - (list->vector l)))] - [l - (let loop ([l other-requires]) - (match l - [(list) - empty] - [(list-rest (cons phase reqs) rst) - (list* phase reqs (loop rst))]))] - [l (cons (length other-requires) l)] - [l (cons (lookup-req #f) l)] ; dt-requires - [l (cons (lookup-req -1) l)] ; tt-requires - [l (cons (lookup-req 1) l)] ; et-requires - [l (cons (lookup-req 0) l)] ; requires - [l (cons (list->vector body) l)] - [l (append (reverse - (for/list ([b (in-list syntax-bodies)]) - (for/vector ([i (in-list (cdr b))]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) - (vector #f rhs max-let-depth prefix #t)])))) - l)] - [l (append (apply - append - (map (lambda (l) - (let* ([phase (car l)] - [all (append (cadr l) (caddr l))] - [protects (extract-protects phase)] - [unexported (extract-unexported phase)]) - (append - (list phase) - (if (and (not protects) - (not unexported)) - (list (void)) - (let ([unexported (or unexported - '(() ()))]) - (list (list->vector (cadr unexported)) - (length (cadr unexported)) - (list->vector (car unexported)) - (length (car unexported)) - protects))) - (list (list->vector/#f 0 (map provided-src-phase all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all))))) - provides)) - l)] - [l (cons (length provides) l)] ; number of provide sets - [l (cons (add1 (length syntax-bodies)) l)] - [l (cons prefix l)] - [l (cons dummy l)] - [l (cons max-let-depth l)] - [l (cons internal-context l)] ; module->namespace syntax - [l (list* #f #f l)] ; obsolete `functional?' info - [l (cons (protect-quote lang-info) l)] ; lang-info - [l (cons (map convert-module post-submodules) l)] - [l (cons (map convert-module pre-submodules) l)] - [l (cons (if (memq 'cross-phase flags) #t #f) l)] - [l (append (pack-binding-names binding-names) l)] - [l (cons self-modidx l)] - [l (cons srcname l)] - [l (cons (if (pair? name) (car name) name) l)] - [l (cons (if (pair? name) (cdr name) null) l)]) - l)])) - -(define (lookup-encoded-stx-obj w out) - (hash-ref! (out-stx-objs out) w - (λ () - (encode-stx-obj w out)))) - -(define (pack-binding-names binding-names) - (define (ht-to-vector ht) - (and ht (list->vector (apply append (hash-map ht list))))) - (list (ht-to-vector (hash-ref binding-names 0 #f)) - (ht-to-vector (hash-ref binding-names 1 #f)) - (list->vector - (apply append - (for/list ([(phase ht) (in-hash binding-names)] - #:unless (or (= phase 0) (= phase 1))) - (list phase (ht-to-vector ht))))))) +(define (out-linklet linklet-form out) + (out-byte CPT_LINKLET out) + (out-number 0 out) ; no static prefix + (out-anything (convert-linklet linklet-form) out)) + +(define (convert-linklet linklet-form) + (match linklet-form + [(struct linkl (name importss import-shapess exports internals lifts + source-names body max-let-depth need-instance-access?)) + (define names-count (* 2 (hash-count source-names))) + (list name + need-instance-access? + max-let-depth + (length lifts) + (length exports) + (list->vector body) + (for*/vector #:length names-count ([(k v) (in-hash source-names)] + [(n) (in-list (list k v))]) + n) + (list->vector (append exports internals lifts)) + (list->vector (map list->vector importss)) + (if (not (for*/or ([import-shapes (in-list import-shapess)] + [import-shape (in-list import-shapes)]) + import-shape)) + #f + (for*/vector ([import-shapes (in-list import-shapess)] + [import-shape (in-list import-shapes)]) + (encode-shape import-shape))))])) (define (out-lam expr out) (match expr [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) - (let* ([l (protect-quote body)] - [any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) + (let* ([any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) (not (andmap (lambda (t) (eq? t 'val/ref)) closure-types)))] [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) (add1 num-params) num-params)] - [l (cons (make-svector (if any-refs? - (list->vector - (append - (vector->list closure-map) - (let* ([v (make-vector (ceiling - (/ (* BITS_PER_ARG (+ num-all-params (vector-length closure-map))) - BITS_PER_MZSHORT)))] - [set-bit! (lambda (i bit) - (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) - (vector-set! v pos - (bitwise-ior (vector-ref v pos) - (arithmetic-shift - bit - (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) - (for ([t (in-list param-types)] - [i (in-naturals)]) - (case t - [(val) (void)] - [(ref) (set-bit! i 1)] - [else (set-bit! i (+ 1 (type->index t)))])) - (for ([t (in-list closure-types)] - [i (in-naturals num-all-params)]) - (case t - [(val/ref) (void)] - [else (set-bit! i (+ 1 (type->index t)))])) - (vector->list v)))) - closure-map)) - l)] - [l (if any-refs? - (cons (vector-length closure-map) l) - l)] + [cl-map (make-svector (if any-refs? + (list->vector + (append + (vector->list closure-map) + (let* ([v (make-vector (ceiling + (/ (* BITS_PER_ARG (+ num-all-params (vector-length closure-map))) + BITS_PER_MZSHORT)))] + [set-bit! (lambda (i bit) + (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift + bit + (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) + (for ([t (in-list param-types)] + [i (in-naturals)]) + (case t + [(val) (void)] + [(ref) (set-bit! i 1)] + [else (set-bit! i (+ 1 (type->index t)))])) + (for ([t (in-list closure-types)] + [i (in-naturals num-all-params)]) + (case t + [(val/ref) (void)] + [else (set-bit! i (+ 1 (type->index t)))])) + (vector->list v)))) + closure-map))] [tl-map (and toplevel-map (for/fold ([v 0]) ([i (in-set toplevel-map)]) (bitwise-ior v (arithmetic-shift 1 i))))]) - (out-marshaled unclosed-procedure-type-num - (list* - (+ (if rest? CLOS_HAS_REST 0) - (if any-refs? CLOS_HAS_REF_ARGS 0) - (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) - (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) - (if (memq 'is-method flags) CLOS_IS_METHOD 0) - (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - num-all-params - max-let-depth - (and tl-map - (if (tl-map . <= . #xFFFFFFF) - ;; Encode as a fixnum: - tl-map - ;; Encode as an even-sized vector of 16-bit integers: - (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) - (for/vector ([i (in-range len)]) - (let ([s (* i 16)]) - (bitwise-bit-field tl-map s (+ s 16))))))) - name - l) - out))])) + (out-byte CPT_OTHER_FORM out) + (out-number unclosed-procedure-type-num out) + (out-number (+ (if rest? CLOS_HAS_REST 0) + (if any-refs? CLOS_HAS_REF_ARGS 0) + (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) + (if (memq 'is-method flags) CLOS_IS_METHOD 0) + (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) + out) + (when any-refs? + (out-number (vector-length closure-map) out)) + (out-number num-all-params out) + (out-number max-let-depth out) + (out-anything name out) + (out-anything (protect-quote body) out) + (out-anything cl-map out) + (out-anything (and tl-map + (if (tl-map . <= . #xFFFFFFF) + ;; Encode as a fixnum: + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16))))))) + out))])) (define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) (define s (->bytes expr)) @@ -1273,260 +917,77 @@ (find-relative-path r v) v))) -(define (binding-namess-hash->list binding-namess) - (for/list ([(phase t) (in-hash binding-namess)]) - (cons phase - (list->vector - (apply append (for/list ([(id sym) (in-hash t)]) - (list id sym))))))) - -;; ---------------------------------------- - -;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based -;; table would equate different "self" modidxes that we need to keep -;; separate. So, roll a `simple-equal?` that inspects wraps. We don't -;; have to deal with cycles, since cycles would always go through a scope, -;; and we recur into scopes. - -(struct modidx-must-be-eq (content) - #:property prop:equal+hash - (list (lambda (a b eql?) - (simple-equal? (modidx-must-be-eq-content a) - (modidx-must-be-eq-content b))) - (lambda (a h) (h (modidx-must-be-eq-content a))) - (lambda (a h) (h (modidx-must-be-eq-content a))))) - -(define (simple-equal? a b) +(define (encode-shape constantness) + (define (to-sym #:prefix [prefix "struct"] n) + (string->symbol (format "~a~a" prefix n))) + (define (struct-count-shift n) (arithmetic-shift n 5)) + (define (add-authentic n authentic?) (bitwise-ior n (if authentic? #x10 0))) (cond - [(eqv? a b) #t] - [(pair? a) - (and (pair? b) - (simple-equal? (car a) (car b)) - (simple-equal? (cdr a) (cdr b)))] - [(vector? a) - (and (vector? b) - (= (vector-length a) (vector-length b)) - (for/and ([ae (in-vector a)] - [be (in-vector b)]) - (simple-equal? ae be)))] - [(box? a) - (and (box? b) - (simple-equal? (unbox a) (unbox b)))] - [(module-path-index? a) - (and (module-path-index? b) - (let-values ([(a-name a-base) (module-path-index-split a)] - [(b-name b-base) (module-path-index-split b)]) - (and a-name - a-base - (simple-equal? a-name b-name) - (simple-equal? a-base b-base))))] + [(eq? constantness 'constant) #t] + [(eq? constantness 'fixed) (void)] + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (add-authentic (struct-count-shift (struct-type-shape-field-count constantness)) + (struct-type-shape-authentic? constantness)))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (struct-count-shift (constructor-shape-arity constantness))))] + [(predicate-shape? constantness) (to-sym (add-authentic 2 (predicate-shape-authentic? constantness)))] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (add-authentic + (struct-count-shift (accessor-shape-field-count constantness)) + (accessor-shape-authentic? constantness))))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (add-authentic + (struct-count-shift (mutator-shape-field-count constantness)) + (mutator-shape-authentic? constantness))))] + [(struct-type-property-shape? constantness) + (to-sym #:prefix "prop" + (if (struct-type-property-shape-has-guard? constantness) + 1 + 0))] + [(property-predicate-shape? constantness) + (to-sym #:prefix "prop" 2)] + [(property-accessor-shape? constantness) + (to-sym #:prefix "prop" 3)] + [(struct-other-shape? constantness) + (to-sym 5)] [else #f])) -(define (share-everywhere v out) - (define (register r) - (hash-set! (out-hash-consed-results out) r #t) - r) - (hash-ref! (out-hash-consed out) - (modidx-must-be-eq v) - (lambda () - (cond - [(pair? v) - (register - (cons (share-everywhere (car v) out) - (share-everywhere (cdr v) out)))] - [(vector? v) - (register - (for/vector #:length (vector-length v) ([e (in-vector v)]) - (share-everywhere e out)))] - [(box? v) - (register - (box (share-everywhere (unbox v) out)))] - [else v])))) - -;; ---------------------------------------- - -(define (encode-wrap w ht) - (hash-ref! ht w - (lambda () - (vector (map-encode encode-shift (wrap-shifts w) ht) - (encode-scope-list (wrap-simple-scopes w) ht) - (map-encode encode-multi-scope (wrap-multi-scopes w) ht))))) - -(define (map-encode encode l ht) - (cond - [(null? l) l] - [else - (hash-ref! ht l - (lambda () - (cons (encode (car l) ht) - (map-encode encode (cdr l) ht))))])) - -(define (encode-shift s ht) - (hash-ref! ht s - (lambda () - (if (module-shift-from-inspector-desc s) - (vector (module-shift-to s) - (module-shift-from s) - (module-shift-from-inspector-desc s) - (module-shift-to-inspector-desc s)) - (vector (module-shift-to s) - (module-shift-from s)))))) - -(define (encode-scope s ht) - (if (eq? 'root (scope-name s)) - s - (hash-ref ht s - (lambda () - (define es (encoded-scope (scope-name s) #f)) - (hash-set! ht s es) - (define kind - (case (scope-kind s) - [(module) (if (scope-multi-owner s) - 1 - 0)] - [(macro) 2] - [(local) 3] - [(intdef) 4] - [else 5])) - (cond - [(and (null? (scope-bindings s)) - (null? (scope-bulk-bindings s))) - (set-encoded-scope-content! es kind)] - [else - (define binding-table - (for/fold ([bt (hasheq)]) ([b (in-list (scope-bindings s))]) - (hash-set bt - (car b) - (cons (cons (encode-scope-list (cadr b) ht) - (encode-binding (caddr b) (car b) ht)) - (hash-ref bt (car b) null))))) - (define bindings - (list->vector - (apply - append - (sort (hash-map binding-table list) - symbol #:key (lambda (s) - (if (eq? 'root (scope-name s)) - -1 - (scope-name s)))) - ht)) - -(define (encode-multi-scope ms+phase ht) - (define ms (car ms+phase)) - (cons (hash-ref ht ms - (lambda () - (define v (make-vector (add1 (* 2 (length (multi-scope-scopes ms)))))) - (hash-set! ht ms v) - (vector-copy! - v - 0 - (list->vector - (append (apply - append - (for/list ([e (in-list (multi-scope-scopes ms))]) - (list (car e) - (encode-scope (cadr e) ht)))) - (list (multi-scope-src-name ms))))) - v)) - (cadr ms+phase))) - -(define (encode-binding b name ht) - (match b - [(free-id=?-binding base id phase) - (hash-ref ht b - (lambda () - (match b - [(free-id=?-binding base id phase) - (define bx (box #f)) - (hash-set! ht b bx) - (set-box! bx - (cons - (cons (encode-binding base name ht) - (cons (stx-obj-datum id) - (stx-obj-wrap id))) - phase))])))] - [_ - (hash-ref! ht b - (lambda () - (match b - [(local-binding name) - name] - [(module-binding encoded) - encoded] - [(? decoded-module-binding?) - (encode-module-binding b name ht)])))])) - - -(define (encode-module-binding b name ht) - (hash-ref! ht (cons name b) - (lambda () - (match b - [(decoded-module-binding path export-name phase - nominal-path nominal-export-name nominal-phase - import-phase inspector-desc) - (define l - (cond - [(and (eq? path nominal-path) - (eq? export-name nominal-export-name) - (eqv? phase 0) - (eqv? import-phase 0) - (eqv? nominal-phase phase)) - (if (eq? name export-name) - path - (cons path export-name))] - [(and (eq? export-name nominal-export-name) - (eq? name export-name) - (eqv? 0 phase) - (eqv? import-phase 0) - (eqv? nominal-phase phase)) - (cons path nominal-path)] - [else - (define nom-mod+phase - (if (eqv? nominal-phase phase) - (if (eqv? 0 import-phase) - nominal-path - (cons nominal-path import-phase)) - (cons nominal-path (cons import-phase nominal-phase)))) - (define l (list* export-name nom-mod+phase nominal-export-name)) - (if (zero? phase) - l - (cons phase l))])) - (if inspector-desc - (cons inspector-desc l) - l)])))) - -(define (encode-bulk-binding p ht) - (cons (encode-scope-list (car p) ht) - (encode-all-from-module (cadr p) ht))) - -(define (encode-all-from-module b ht) - (hash-ref! ht b - (lambda () - (match b - [(all-from-module path phase src-phase inspector-desc exceptions prefix) - (vector path src-phase - (cond - [(and (not prefix) (null? exceptions)) - phase] - [(not prefix) - (cons phase (list->vector exceptions))] - [(null? exceptions) - (cons phase prefix)] - [else - (cons phase (cons (list->vector exceptions) prefix))]) - inspector-desc)])))) - +(define (path->relative-path v) + (define (within? p) + (and (relative-path? p) + (let loop ([p p]) + (define-values (base name dir?) (split-path p)) + (and (not (eq? name 'up)) + (not (eq? name 'same)) + (or (not (path? base)) + (loop base)))))) + (and (current-write-relative-directory) + (let ([dir (current-write-relative-directory)]) + (and (or (not dir) + (within? (find-relative-path v + (if (pair? dir) + (cdr dir) + dir)))) + (find-relative-path v + (if (pair? dir) + (car dir) + dir)))))) diff -Nru racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt --- racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -7,65 +7,24 @@ racket/dict racket/set) -(provide zo-parse - decode-module-binding) +(provide zo-parse) (provide (all-from-out compiler/zo-structs)) ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms -(define (read-toplevel v) +(define (read-toplevel flags pos depth) (define SCHEME_TOPLEVEL_CONST #x02) (define SCHEME_TOPLEVEL_READY #x01) - (match v - [(cons depth (cons pos flags)) - ;; In the VM, the two flag bits are actually interpreted - ;; as a number when the toplevel is a reference, but we - ;; interpret the bits as flags here for backward compatibility. - (make-toplevel depth pos - (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) - (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] - [(cons depth pos) - (make-toplevel depth pos #f #f)])) - -(define (read-topsyntax v) - (match v - [`(,depth ,pos . ,midpt) - (make-topsyntax depth pos midpt)])) - -(define (read-variable v) - (if (symbol? v) - (make-global-bucket v) - (error "expected a symbol"))) - -(define (do-not-read-variable v) - (error "should not get here")) - -(define (read-compilation-top v) - (match v - [`(,ld ,binding-namess ,prefix . ,code) - (unless (prefix? prefix) - (error 'bad "not prefix ~a" prefix)) - (make-compilation-top ld - (binding-namess-list->hash binding-namess) - prefix - code)])) - -(define (binding-namess-list->hash binding-namess) - (for/hash ([e (in-list binding-namess)]) - (values (car e) - (let ([vec (cdr e)]) - (for/hash ([i (in-range 0 (vector-length vec) 2)]) - (values (vector-ref vec i) - (vector-ref vec (add1 i)))))))) + ;; In the VM, the two flag bits are actually interpreted + ;; as a number when the toplevel is a reference, but we + ;; interpret the bits as flags here for backward compatibility. + (make-toplevel depth pos + (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) + (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))) -(define (read-resolve-prefix v) - (match v - [`(,src-insp-desc ,i ,tv . ,sv) - ;; XXX Why not leave them as vectors and change the contract? - (make-prefix i (vector->list tv) (vector->list sv) src-insp-desc)])) - -(define (read-unclosed-procedure v) +(define (read-unclosed-procedure flags maybe-closure-size num-params max-let-depth + name body closed-over tl-map) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) (define CLOS_PRESERVES_MARKS 4) @@ -74,140 +33,78 @@ (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) (define BITS_PER_ARG 4) - (match v - [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) - (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) - (let*-values ([(closure-size closed-over body) - (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (values (vector-length v) v rest) - (values v (car rest) (cdr rest)))] - [(get-flags) (lambda (i) - (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - 0 - (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) - (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) - (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] - [(num->type) (lambda (n) - (case n - [(2) 'flonum] - [(3) 'fixnum] - [(4) 'extflonum] - [else (error "invaid type flag")]))] - [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) - (for/list ([i (in-range num-params)]) - (define v (get-flags i)) - (case v - [(0) 'val] - [(1) 'ref] - [else (num->type v)])))] - [(closure-types) (for/list ([i (in-range closure-size)] - [j (in-naturals num-params)]) - (define v (get-flags j)) - (case v - [(0) 'val/ref] - [(1) (error "invalid 'ref closure variable")] - [else (num->type v)]))]) - (make-lam name - (append - (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) - (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) - (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) - (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) - (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) - (if (and rest? (num-params . > . 0)) - (sub1 num-params) - num-params) - arg-types - rest? - (if (= closure-size (vector-length closed-over)) - closed-over - (let ([v2 (make-vector closure-size)]) - (vector-copy! v2 0 closed-over 0 closure-size) - v2)) - closure-types - (and tl-map - (let* ([bits (if (exact-integer? tl-map) - tl-map - (for/fold ([i 0]) ([v (in-vector tl-map)] - [s (in-naturals)]) - (bitwise-ior i (arithmetic-shift v (* s 16)))))] - [len (integer-length bits)]) - (list->set - (let loop ([bit 0]) - (cond - [(bit . >= . len) null] - [(bitwise-bit-set? bits bit) - (cons bit (loop (add1 bit)))] - [else (loop (add1 bit))]))))) - max-let-depth - body)))])) - -(define (read-let-value v) - (match v - [`(,count ,pos ,boxes? ,rhs . ,body) - (make-install-value count pos boxes? rhs body)])) - -(define (read-let-void v) - (match v - [`(,count ,boxes? . ,body) - (make-let-void count boxes? body)])) + (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) + (let*-values ([(closure-size) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (vector-length closed-over) + maybe-closure-size)] + [(get-flags) (lambda (i) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + 0 + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [(4) 'extflonum] + [else (error "invaid type flag")]))] + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (for/list ([i (in-range num-params)]) + (define v (get-flags i)) + (case v + [(0) 'val] + [(1) 'ref] + [else (num->type v)])))] + [(closure-types) (for/list ([i (in-range closure-size)] + [j (in-naturals num-params)]) + (define v (get-flags j)) + (case v + [(0) 'val/ref] + [(1) (error "invalid 'ref closure variable")] + [else (num->type v)]))]) + (make-lam name + (append + (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) + (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) + (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) + (if (and rest? (num-params . > . 0)) + (sub1 num-params) + num-params) + arg-types + rest? + (if (= closure-size (vector-length closed-over)) + closed-over + (let ([v2 (make-vector closure-size)]) + (vector-copy! v2 0 closed-over 0 closure-size) + v2)) + closure-types + (and tl-map + (let* ([bits (if (exact-integer? tl-map) + tl-map + (for/fold ([i 0]) ([v (in-vector tl-map)] + [s (in-naturals)]) + (bitwise-ior i (arithmetic-shift v (* s 16)))))] + [len (integer-length bits)]) + (list->set + (let loop ([bit 0]) + (cond + [(bit . >= . len) null] + [(bitwise-bit-set? bits bit) + (cons bit (loop (add1 bit)))] + [else (loop (add1 bit))]))))) + max-let-depth + body)))) -(define (read-letrec v) - (match v - [`(,count ,body . ,procs) - (make-let-rec procs body)])) - -(define (read-with-cont-mark v) - (match v - [`(,key ,val . ,body) - (make-with-cont-mark key val body)])) - -(define (read-sequence v) - (make-seq v)) - -; XXX Allocates unnessary list (define (read-define-values v) (make-def-values (cdr (vector->list v)) (vector-ref v 0))) -(define (read-define-syntax v) - (make-def-syntaxes (list-tail (vector->list v) 4) - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3))) - -(define (read-begin-for-syntax v) - (make-seq-for-syntax - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3))) - -(define (read-set! v) - (make-assign (cadr v) (cddr v) (car v))) - -(define (read-case-lambda v) - (make-case-lam (car v) (cdr v))) - -(define (read-begin0 v) - (make-beg0 v)) - -(define (read-boxenv v) - (make-boxenv (car v) (cdr v))) -(define (read-require v) - (make-req (cdr v) (car v))) -(define (read-#%variable-ref v) - (make-varref (car v) (cdr v))) -(define (read-apply-values v) - (make-apply-values (car v) (cdr v))) -(define (read-with-immed-mark v) - (make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) -(define (read-splice v) - (make-splice v)) - (define (in-list* l n) (make-do-sequence (lambda () @@ -217,149 +114,74 @@ (lambda (l) (>= (length l) n)) (lambda _ #t) (lambda _ #t))))) - -(define (split-phase-data rest n) - (let loop ([n n] [rest rest] [phase-accum null]) - (cond - [(zero? n) - (values (reverse phase-accum) rest)] - [else - (let ([maybe-indirect (list-ref rest 1)]) - (if (void? maybe-indirect) - ;; no indirect or protect info: - (loop (sub1 n) - (list-tail rest 9) - (cons (take rest 9) phase-accum)) - ;; has indirect or protect info: - (loop (sub1 n) - (list-tail rest (+ 5 8)) - (cons (take rest (+ 5 8)) phase-accum))))]))) -(define (read-module v) +(define (read-linklet v) (match v - [`(,submod-path - ,name ,srcname ,self-modidx - ,rt-binding-names ,et-binding-names ,other-binding-names - ,cross-phase? - ,pre-submods ,post-submods - ,lang-info ,functional? ,et-functional? - ,rename ,max-let-depth ,dummy - ,prefix ,num-phases - ,provide-phase-count . ,rest) - (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] - [(bodies rest-module) (values (take rest-module num-phases) - (drop rest-module num-phases))]) - (match rest-module - [`(,requires ,syntax-requires ,template-requires ,label-requires - ,more-requires-count . ,more-requires) - (make-mod (if (null? submod-path) - name - (if (symbol? name) - (cons name submod-path) - (cons (car name) submod-path))) - srcname self-modidx - prefix - ;; provides: - (for/list ([l (in-list phase-data)]) - (let* ([phase (list-ref l 0)] - [has-info? (not (void? (list-ref l 1)))] - [delta (if has-info? 5 1)] - [num-vars (list-ref l (+ delta 6))] - [num-all (list-ref l (+ delta 7))] - [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] - [src (in-vector (list-ref l (+ delta 4)))] - [src-name (in-vector (list-ref l (+ delta 3)))] - [nom-src (or (list-ref l (+ delta 2)) - (in-cycle (in-value #f)))] - [src-phase (or (list-ref l (+ delta 1)) - (in-cycle (in-value 0)))] - [protected? (cond - [(or (not has-info?) - (not (list-ref l 5))) - (in-cycle (in-value #f))] - [else (list-ref l 5)])]) - (make-provided name src src-name - (or nom-src src) - src-phase - protected?))]) - (list - phase - (take ps num-vars) - (drop ps num-vars)))) - ;; requires: - (list* - (cons 0 requires) - (cons 1 syntax-requires) - (cons -1 template-requires) - (cons #f label-requires) - (for/list ([(phase reqs) (in-list* more-requires 2)]) - (cons phase reqs))) - ;; body: - (vector->list (last bodies)) - ;; syntax-bodies: add phase to each list, break apart - (for/list ([b (cdr (reverse bodies))] - [i (in-naturals 1)]) - (cons i - (for/list ([sb (in-vector b)]) - (match sb - [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) - (if for-stx? - (make-seq-for-syntax (list expr) prefix max-let-depth #f) - (make-def-syntaxes - (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] - [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) - ;; unexported: - (for/list ([l (in-list phase-data)] - #:unless (void? (list-ref l 1))) - (let* ([phase (list-ref l 0)] - [indirect-syntax - ;; could check: (list-ref l 2) should be size of vector: - (list-ref l 1)] - [indirect - ;; could check: (list-ref l 4) should be size of vector: - (list-ref l 3)]) - (list - phase - (vector->list indirect) - (vector->list indirect-syntax)))) - max-let-depth - dummy - lang-info - rename - (assemble-binding-names rt-binding-names - et-binding-names - other-binding-names) - (if cross-phase? '(cross-phase) '()) - (map read-module pre-submods) - (map read-module post-submods))]))])) -(define (read-module-wrap v) - v) - + [`(,name ,need-instance-access? ,max-let-depth ,num-lifts ,num-exports + ,body + ,source-names ,defns-vec ,imports-vec ,shapes-vec) + (define defns (vector->list defns-vec)) + (linkl name + (map vector->list (vector->list imports-vec)) + (if (not shapes-vec) + (for/list ([imports (in-vector imports-vec)]) + (for/list ([i (in-vector imports)]) + #f)) + (let ([pos 0]) + (for/list ([imports (in-vector imports-vec)]) + (for/list ([i (in-vector imports)]) + (begin0 + (parse-shape (vector-ref shapes-vec pos)) + (set! pos (add1 pos))))))) + (take defns num-exports) + (take (list-tail defns num-exports) (- (length defns) num-exports num-lifts)) + (drop defns (- (length defns) num-lifts)) + (for/hasheq ([i (in-range 0 (vector-length source-names) 2)]) + (values (vector-ref source-names i) + (vector-ref source-names (add1 i)))) + (vector->list body) + max-let-depth + need-instance-access?)])) -(define (read-inline-variant v) - (make-inline-variant (car v) (cdr v))) - -(define (assemble-binding-names rt-binding-names - et-binding-names - other-binding-names) - (define (vector-to-ht vec) - (define sz (vector-length vec)) - (let loop ([i 0] [ht #hasheq()]) - (cond - [(= i sz) ht] - [else (loop (+ i 2) - (hash-set ht (vector-ref vec i) (vector-ref vec (add1 i))))]))) - (for/hash ([(phase vec) (let* ([ht (if other-binding-names - (vector-to-ht other-binding-names) - #hash())] - [ht (if rt-binding-names - (hash-set ht 0 rt-binding-names) - ht)] - [ht (if et-binding-names - (hash-set ht 0 et-binding-names) - ht)]) - ht)]) - (values phase (vector-to-ht vec)))) +(define (parse-shape shape) + (cond + [(not shape) #f] + [(eq? shape #t) 'constant] + [(eq? shape (void)) 'fixed] + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (define (authentic-shape? n) (bitwise-bit-set? n 4)) + (define (shape-count-shift n) (arithmetic-shift n -5)) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (shape-count-shift n) (authentic-shape? n))] + [(1) (make-constructor-shape (shape-count-shift n))] + [(2) (make-predicate-shape (authentic-shape? n))] + [(3) (make-accessor-shape (shape-count-shift n) (authentic-shape? n))] + [(4) (make-mutator-shape (shape-count-shift n) (authentic-shape? n))] + [else (make-struct-other-shape)])] + [(and (symbol? shape) + (regexp-match? #rx"^prop" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 4))) + (case n + [(0 1) (make-struct-type-property-shape (= n 1))] + [(2) (make-property-predicate-shape)] + [else (make-property-accessor-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])) ;; ---------------------------------------- ;; Unmarshal dispatch for various types @@ -368,67 +190,26 @@ (define (int->type i) (case i [(0) 'toplevel-type] - [(6) 'sequence-type] - [(8) 'unclosed-procedure-type] - [(9) 'let-value-type] - [(10) 'let-void-type] - [(11) 'letrec-type] - [(13) 'with-cont-mark-type] - [(14) 'quote-syntax-type] + [(1) 'static-toplevel-type] + [(7) 'sequence-type] + [(9) 'unclosed-procedure-type] + [(10) 'let-value-type] + [(11) 'let-void-type] + [(12) 'letrec-type] + [(14) 'with-cont-mark-type] [(15) 'define-values-type] - [(16) 'define-syntaxes-type] - [(17) 'begin-for-syntax-type] - [(18) 'set-bang-type] - [(19) 'boxenv-type] - [(20) 'begin0-sequence-type] - [(21) 'splice-sequence-type] - [(22) 'require-form-type] - [(23) 'varref-form-type] - [(24) 'apply-values-type] - [(25) 'with-immed-mark-type] - [(26) 'case-lambda-sequence-type] - [(27) 'module-type] - [(28) 'inline-variant-type] - [(37) 'variable-type] - [(38) 'module-variable-type] - [(122) 'resolve-prefix-type] + [(16) 'set-bang-type] + [(17) 'boxenv-type] + [(18) 'begin0-sequence-type] + [(19) 'varref-form-type] + [(20) 'apply-values-type] + [(21) 'with-immed-mark-type] + [(22) 'case-lambda-sequence-type] + [(23) 'inline-variant-type] + [(25) 'linklet-type] + [(89) 'prefix-type] [else (error 'int->type "unknown type: ~e" i)])) -(define type-readers - (make-immutable-hash - (list - (cons 'toplevel-type read-toplevel) - (cons 'sequence-type read-sequence) - (cons 'unclosed-procedure-type read-unclosed-procedure) - (cons 'let-value-type read-let-value) - (cons 'let-void-type read-let-void) - (cons 'letrec-type read-letrec) - (cons 'with-cont-mark-type read-with-cont-mark) - (cons 'quote-syntax-type read-topsyntax) - (cons 'variable-type read-variable) - (cons 'module-variable-type do-not-read-variable) - (cons 'compilation-top-type read-compilation-top) - (cons 'case-lambda-sequence-type read-case-lambda) - (cons 'begin0-sequence-type read-begin0) - (cons 'module-type read-module) - (cons 'inline-variant-type read-inline-variant) - (cons 'resolve-prefix-type read-resolve-prefix) - (cons 'define-values-type read-define-values) - (cons 'define-syntaxes-type read-define-syntax) - (cons 'begin-for-syntax-type read-begin-for-syntax) - (cons 'set-bang-type read-set!) - (cons 'boxenv-type read-boxenv) - (cons 'require-form-type read-require) - (cons 'varref-form-type read-#%variable-ref) - (cons 'apply-values-type read-apply-values) - (cons 'with-immed-mark-type read-with-immed-mark) - (cons 'splice-sequence-type read-splice)))) - -(define (get-reader type) - (hash-ref type-readers type - (λ () - (error 'read-marshalled "reader for ~a not implemented" type)))) - ;; ---------------------------------------- ;; Lowest layer of bytecode parsing @@ -443,7 +224,7 @@ (define (read-simple-number p) (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis)) +(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets)) (define (cport-get-bytes cp len) (define port (cport-orig-port cp)) (define pos (cport-pos cp)) @@ -485,30 +266,37 @@ [15 list] [16 vector] [17 hash-table] - [18 stx] - [19 let-one-typed] - [20 marshalled] - [21 quote] - [22 reference] - [23 local] - [24 local-unbox] - [25 svector] - [26 application] - [27 let-one] - [28 branch] - [29 module-index] - [30 module-var] - [31 path] - [32 closure] - [33 delayed] - [34 prefab] - [35 let-one-unused] - [36 scope] - [37 root-scope] - [38 shared] - [39 62 small-number] - [62 80 small-symbol] - [80 92 small-marshalled] + [18 let-one-typed] + [19 linklet] + [20 quote] + [21 reference] + [22 local] + [23 local-unbox] + [24 svector] + [25 application] + [26 let-one] + [27 branch] + [28 path] + [29 closure] + [30 delayed] + [31 prefab] + [32 let-one-unused] + [33 shared] + [34 toplevel] + [35 begin] + [36 begin0] + [37 let-value] + [38 let-void] + [39 letrec] + [40 wcm] + [41 define-values] + [42 set-bang] + [43 varref] + [44 apply-values] + [45 other-form] + [46 srcloc] + [47 74 small-number] + [74 92 small-symbol] [92 ,(+ 92 small-list-max) small-proper-list] [,(+ 92 small-list-max) 192 small-list] [192 207 small-local] @@ -518,8 +306,6 @@ [249 small-application3] [247 255 small-application])) -(define root-scope (scope 'root 'module null null #f)) - ;; To accelerate cpt-table lookup, we flatten out the above ;; list into a vector: (define cpt-table (make-vector 256 #f)) @@ -568,12 +354,6 @@ (vector-set! v (sub1 (- n i)) (read-compact-number port))) v) -(define (read-marshalled type port) - (let* ([type (if (number? type) (int->type type) type)] - [l (read-compact port)] - [reader (get-reader type)]) - (reader l))) - (define SCHEME_LOCAL_TYPE_FLONUM 1) (define SCHEME_LOCAL_TYPE_FIXNUM 2) (define SCHEME_LOCAL_TYPE_EXTFLONUM 3) @@ -599,95 +379,6 @@ (define-struct in-progress ()) ;; ---------------------------------------- -;; Syntax unmarshaling -(define (make-memo) (make-weak-hash)) -(define (with-memo* mt arg thnk) - (hash-ref! mt arg thnk)) -(define-syntax-rule (with-memo mt arg body ...) - (with-memo* mt arg (λ () body ...))) - -;; placeholder for a `scope` decoded in a second pass: -(struct encoded-scope (relative-id content) #:prefab) - -(define (decode-wrapped cp v) - (let loop ([v v]) - (let-values ([(tamper-status v encoded-wraps esrcloc) - (match v - [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)] - [`#(,datum ,wraps 2) (values 'armed datum wraps #f)] - [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)] - [`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)] - [`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)] - [`(,datum . ,wraps) (values 'clean datum wraps #f)] - [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let iloop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) - (cond - [(null? v) null] - [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] - [else (iloop v)]))] - [(box? v) (add-wrap (box (iloop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map iloop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (iloop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map iloop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) - (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (loop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)]))))) - -(define (in-vector* v n) - (make-do-sequence - (λ () - (values (λ (i) (vector->values v i (+ i n))) - (λ (i) (+ i n)) - 0 - (λ (i) (>= (vector-length v) (+ i n))) - (λ _ #t) - (λ _ #t))))) - -(define (parse-module-path-index cp s) - s) - -;; ---------------------------------------- ;; Main parsing loop (define (read-compact cp) @@ -755,66 +446,6 @@ (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] - [(module-index) - (define name (read-compact cp)) - (define base (read-compact cp)) - (if (or name base) - (module-path-index-join name base) - (module-path-index-join #f #f (read-compact cp)))] - [(module-var) - (let ([mod (read-compact cp)] - [var (read-compact cp)] - [shape (read-compact cp)] - [pos (read-compact-number cp)]) - (let-values ([(flags mod-phase pos) - (let loop ([pos pos]) - (cond - [(pos . < . -3) - (let ([real-pos (read-compact-number cp)]) - (define-values (_ m p) (loop real-pos)) - (values (- (+ pos 3)) m p))] - [(= pos -2) - (values 0 (read-compact-number cp) (read-compact-number cp))] - [else (values 0 0 pos)]))]) - (make-module-variable mod var pos mod-phase - (cond - [shape - (cond - [(number? shape) - (define n (arithmetic-shift shape -1)) - (make-function-shape (if (negative? n) - (make-arity-at-least (sub1 (- n))) - n) - (odd? shape))] - [(and (symbol? shape) - (regexp-match? #rx"^struct" (symbol->string shape))) - (define n (string->number (substring (symbol->string shape) 6))) - (case (bitwise-and n #x7) - [(0) (make-struct-type-shape (arithmetic-shift n -3))] - [(1) (make-constructor-shape (arithmetic-shift n -3))] - [(2) (make-predicate-shape)] - [(3) (make-accessor-shape (arithmetic-shift n -3))] - [(4) (make-mutator-shape (arithmetic-shift n -3))] - [else (make-struct-other-shape)])] - [(and (symbol? shape) - (regexp-match? #rx"^prop" (symbol->string shape))) - (define n (string->number (substring (symbol->string shape) 4))) - (case n - [(0 1) (make-struct-type-property-shape (= n 1))] - [(2) (make-property-predicate-shape)] - [else (make-property-accessor-shape)])] - [else - ;; parse symbol as ":"-separated sequence of arities - (make-function-shape - (for/list ([s (regexp-split #rx":" (symbol->string shape))]) - (define i (string->number s)) - (if (negative? i) - (make-arity-at-least (sub1 (- i))) - i)) - #f)])] - [(not (zero? (bitwise-and #x1 flags))) 'constant] - [(not (zero? (bitwise-and #x2 flags))) 'fixed] - [else #f]))))] [(local-unbox) (let* ([p* (read-compact-number cp)] [p (if (< p* 0) (- (add1 p*)) p*)] @@ -830,6 +461,12 @@ (build-path p (if (bytes? e) (bytes->path-element e) e)))) ;; Read a path: (bytes->path (read-compact-bytes cp len))))] + [(srcloc) + (srcloc (read-compact cp) + (read-compact cp) + (read-compact cp) + (read-compact cp) + (read-compact cp))] [(small-number) (let ([l (- ch cpt-start)]) l)] @@ -849,8 +486,8 @@ (vector->immutable-vector (list->vector lst)))] [(pair) (let* ([a (read-compact cp)] - [d (read-compact cp)]) - (cons a d))] + [d (read-compact cp)]) + (cons a d))] [(list) (let ([len (read-compact-number cp)]) (let loop ([i len]) @@ -874,10 +511,11 @@ (for/list ([i (in-range len)]) (cons (read-compact cp) (read-compact cp)))))] - [(marshalled) (read-marshalled (read-compact-number cp) cp)] - [(stx) - (let ([v (read-compact cp)]) - (make-stx (decode-wrapped cp v)))] + [(linklet) + (unless (zero? (read-compact-number cp)) + ;; read and ignore the static-prefix placeholder + (read-compact cp)) + (read-linklet (read-compact cp))] [(local local-unbox) (let ([c (read-compact-number cp)] [unbox? (eq? cpt-tag 'local-unbox)]) @@ -931,8 +569,6 @@ (string->uninterned-symbol str) ; unreadable is equivalent to parallel in the C implementation (string->unreadable-symbol str)))] - [(small-marshalled) - (read-marshalled (- ch cpt-start) cp)] [(small-application2) (make-application (read-compact cp) (list (read-compact cp)))] @@ -970,19 +606,88 @@ (read-compact-svector cp (read-compact-number cp))] [(small-svector) (read-compact-svector cp (- ch cpt-start))] - [(scope) - (let ([pos (read-compact-number cp)] - [relative-id (read-compact-number cp)]) - (if (zero? pos) - (encoded-scope relative-id (read-compact cp)) - (read-cyclic cp pos 'scope (lambda (v) - (encoded-scope relative-id - v)))))] - [(root-scope) - root-scope] [(shared) (let ([pos (read-compact-number cp)]) (read-cyclic cp pos 'shared))] + [(toplevel) + (read-toplevel (read-compact-number cp) (read-compact-number cp) (read-compact-number cp))] + [(begin begin0) + (define len (read-compact-number cp)) + (define l (for/list ([i (in-range len)]) (read-compact cp))) + (if (eq? cpt-tag 'begin) + (make-seq l) + (make-beg0 l))] + [(let-value) + (define count (read-compact-number cp)) + (define pos (read-compact-number cp)) + (define boxes? (not (zero? (read-compact-number cp)))) + (define rhs (read-compact cp)) + (define body (read-compact cp)) + (make-install-value count pos boxes? rhs body)] + [(let-void) + (define count (read-compact-number cp)) + (define boxes? (not (zero? (read-compact-number cp)))) + (define body (read-compact cp)) + (make-let-void count boxes? body)] + [(letrec) + (define len (read-compact-number cp)) + (define procs (for/list ([i (in-range len)]) (read-compact cp))) + (define body (read-compact cp)) + (make-let-rec procs body)] + [(wcm) + (make-with-cont-mark (read-compact cp) (read-compact cp) (read-compact cp))] + [(define-values) + (define v (read-compact cp)) + (make-def-values + (cdr (vector->list v)) + (vector-ref v 0))] + [(set-bang) + (define undef-ok? (not (zero? (read-compact-number cp)))) + (make-assign (read-compact cp) (read-compact cp) undef-ok?)] + [(varref) + (define flags (read-compact-number cp)) + (make-varref (read-compact cp) (read-compact cp) + (bitwise-bit-set? flags 1) + (bitwise-bit-set? flags 2))] + [(apply-values) + (make-apply-values (read-compact cp) (read-compact cp))] + [(other-form) + (define type (read-compact-number cp)) + (case (int->type type) + [(static-toplevel-type) + (begin0 + (read-toplevel (read-compact-number cp) (read-compact-number cp) 0) + ;; read and discard the prefix identity: + (read-compact cp))] + [(prefix-type) + (read-compact-number cp)] + [(boxenv-type) + (make-boxenv (read-compact cp) (read-compact cp))] + [(with-immed-mark-type) + (make-with-immed-mark (read-compact cp) (read-compact cp) (read-compact cp))] + [(inline-variant-type) + (make-inline-variant (read-compact cp) (read-compact cp))] + [(case-lambda-sequence-type) + (define count (read-compact-number cp)) + (define name (read-compact cp)) + (define l (for/list ([i (in-range count)]) (read-compact cp))) + (make-case-lam name l)] + [(unclosed-procedure-type) + (define flags (read-compact-number cp)) + (define CLOS_HAS_TYPED_ARGS 2) + (define maybe-closure-size (if (positive? (bitwise-and flags CLOS_HAS_TYPED_ARGS)) + (read-compact-number cp) + -1)) + (define num-params (read-compact-number cp)) + (define max-let-depth (read-compact-number cp)) + (define name (read-compact cp)) + (define body (read-compact cp)) + (define closure-map (read-compact cp)) + (define tl-map (read-compact cp)) + (read-unclosed-procedure flags maybe-closure-size num-params max-let-depth + name body closure-map tl-map)] + [else + (error 'read-compact "unknown other-form type ~a" type)])] [else (error 'read-compact "unknown tag ~a" cpt-tag)])) (cond [(zero? need-car) v] @@ -1021,27 +726,31 @@ (error who "unexpected cycle in input")] [else v])) -(define (read-prefix port) +(define (read-prefix port can-be-false?) ;; skip the "#~" - (unless (equal? #"#~" (read-bytes 2 port)) + (define tag (read-bytes 2 port)) + (unless (or (equal? #"#~" tag) + (and can-be-false? (equal? #"#f" tag))) (error 'zo-parse "not a bytecode stream")) - (define version (read-bytes (min 63 (read-byte port)) port)) - - (read-char port)) + (cond + [(equal? #"#f" tag) #f] + [else + (define version (read-bytes (min 63 (read-byte port)) port)) + (read-char port)])) ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse [port (current-input-port)]) (define init-pos (file-position port)) - (define mode (read-prefix port)) + (define mode (read-prefix port #f)) (case mode - [(#\T) (zo-parse-top port)] + [(#\B) (linkl-bundle (zo-parse-top port))] [(#\D) - (struct mod-info (name start len)) - (define mod-infos + (struct sub-info (name start len)) + (define sub-infos (sort (for/list ([i (in-range (read-simple-number port))]) (define size (read-simple-number port)) @@ -1051,7 +760,7 @@ (define left (read-simple-number port)) (define right (read-simple-number port)) (define name-p (open-input-bytes name)) - (mod-info (let loop () + (sub-info (let loop () (define c (read-byte name-p)) (if (eof-object? c) null @@ -1064,53 +773,32 @@ start len)) < - #:key mod-info-start)) - (define tops - (for/list ([mod-info (in-list mod-infos)]) + #:key sub-info-start)) + (define (remove-empty-root ht) + ;; A linklet for top-level forms will have '() mapped to #f + (if (hash-ref ht '() #f) + ht + (hash-remove ht '()))) + (linkl-directory + (remove-empty-root + (for/hash ([sub-info (in-list sub-infos)]) (define pos (file-position port)) - (unless (= (- pos init-pos) (mod-info-start mod-info)) + (unless (= (- pos init-pos) (sub-info-start sub-info)) (error 'zo-parse - "next module expected at ~a, currently at ~a" - (+ init-pos (mod-info-start mod-info)) pos)) - (unless (eq? (read-prefix port) #\T) - (error 'zo-parse "expected a module")) - (define top (zo-parse-top port #f)) - (define m (compilation-top-code top)) - (unless (mod? m) - (error 'zo-parse "expected a module")) - (unless (equal? (mod-info-name mod-info) - (if (symbol? (mod-name m)) - '() - (cdr (mod-name m)))) - (error 'zo-parse "module name mismatch")) - top)) - (define avail (for/hash ([mod-info (in-list mod-infos)] - [top (in-list tops)]) - (values (mod-info-name mod-info) top))) - (unless (hash-ref avail '() #f) - (error 'zo-parse "no root module in directory")) - (define-values (pre-subs post-subs seen) - (for/fold ([pre-subs (hash)] [post-subs (hash)] [seen (hash)]) ([mod-info (in-list mod-infos)]) - (if (null? (mod-info-name mod-info)) - (values pre-subs post-subs (hash-set seen '() #t)) - (let () - (define name (mod-info-name mod-info)) - (define prefix (take name (sub1 (length name)))) - (unless (hash-ref avail prefix #f) - (error 'zo-parse "no parent module for ~s" name)) - (define (add subs) - (hash-set subs prefix (cons name (hash-ref subs prefix '())))) - (define new-seen (hash-set seen name #t)) - (if (hash-ref seen prefix #f) - (values pre-subs (add post-subs) new-seen) - (values (add pre-subs) post-subs new-seen)))))) - (define (get-all prefix) - (struct-copy mod - (compilation-top-code (hash-ref avail prefix)) - [pre-submodules (map get-all (reverse (hash-ref pre-subs prefix '())))] - [post-submodules (map get-all (reverse (hash-ref post-subs prefix '())))])) - (struct-copy compilation-top (hash-ref avail '()) - [code (get-all '())])] + "next bundle expected at ~a, currently at ~a" + (+ init-pos (sub-info-start sub-info)) pos)) + (define tag (read-prefix port #t)) + (define sub + (cond + [(not tag) #f] + [else + (unless (eq? tag #\B) + (error 'zo-parse "expected a bundle")) + (define sub (and tag (zo-parse-top port #f))) + (unless (hash? sub) + (error 'zo-parse "expected a bundle hash")) + (linkl-bundle sub)])) + (values (sub-info-name sub-info) sub))))] [else (error 'zo-parse "bad file format specifier")])) @@ -1147,8 +835,7 @@ (define symtab (make-vector symtabsize (not-ready))) (define cp - (make-cport 0 shared-size port size* rst-start symtab so* - (make-vector symtabsize (not-ready)) (make-hash) (make-hash))) + (make-cport 0 shared-size port size* rst-start symtab so*)) (for ([i (in-range 1 symtabsize)]) (read-symref cp i #f 'table)) @@ -1158,338 +845,7 @@ (printf "~a = ~a\n" i (placeholder-get v))) (set-cport-pos! cp shared-size) - (define decoded-except-for-stx - (make-reader-graph (read-marshalled 'compilation-top-type cp))) - - (decode-stxes decoded-except-for-stx)) - -;; ---------------------------------------- - -(define (decode-stxes v) - ;; Walk `v` to find `stx-obj` instances and decode the `wrap` field. - ;; We do this after building a graph from the input, and `decode-wrap` - ;; preserves graph structure. - (define decode-ht (make-hasheq)) - (define srcloc-ht (make-hasheq)) - (let walk ([p v]) - (match p - [(compilation-top _ binding-namess pfx c) - (struct-copy compilation-top p - [binding-namess (walk binding-namess)] - [prefix (walk pfx)] - [code (walk c)])] - [(prefix _ _ s _) - (struct-copy prefix p [stxs (map walk s)])] - [(req rs _) - (struct-copy req p - [reqs (walk rs)])] - [(? mod?) - (struct-copy mod p - [prefix (walk (mod-prefix p))] - [syntax-bodies - (for/list ([e (in-list (mod-syntax-bodies p))]) - (cons (car e) - (map walk (cdr e))))] - [internal-context - (walk (mod-internal-context p))] - [binding-names - (for/hash ([(p ht) (in-hash (mod-binding-names p))]) - (values p - (for/hash ([(k v) (in-hash ht)]) - (values k (walk v)))))] - [pre-submodules - (map walk (mod-pre-submodules p))] - [post-submodules - (map walk (mod-post-submodules p))])] - [(stx c) - (struct-copy stx p [content (walk c)])] - [(def-syntaxes _ _ pfx _ _) - (struct-copy def-syntaxes p - [prefix (walk pfx)])] - [(seq-for-syntax _ pfx _ _) - (struct-copy seq-for-syntax p - [prefix (walk pfx)])] - [(stx-obj d w esrcloc _ _) - (define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht)) - (struct-copy stx-obj p - [datum (walk d)] - [wrap (decode-wrap w decode-ht)] - [srcloc srcloc] - [props props])] - [(? zo?) p] - ;; Generic constructors happen inside the `datum` of `stx-obj`, - ;; for example (with no cycles): - [(cons a d) - (cons (walk a) (walk d))] - [(? vector?) - (vector->immutable-vector - (for/vector #:length (vector-length p) ([e (in-vector p)]) - (walk e)))] - [(box v) - (box-immutable (walk v))] - [(? prefab-struct-key) - (apply make-prefab-struct - (prefab-struct-key p) - (cdr (for/list ([e (in-vector (struct->vector p))]) - (walk e))))] - [(? hash?) - (cond - [(hash-eq? p) - (for/hasheq ([(k v) (in-hash p)]) - (values k (walk v)))] - [(hash-eqv? p) - (for/hasheqv ([(k v) (in-hash p)]) - (values k (walk v)))] - [else - (for/hash ([(k v) (in-hash p)]) - (values k (walk v)))])] - [_ p]))) - -;; ---------------------------------------- - -(define (decode-srcloc+props esrcloc ht) - (define (norm v) (if (v . < . 0) #f v)) - (define p - (hash-ref! ht - esrcloc - (lambda () - (cons (and esrcloc - ;; We could reduce this srcloc to #f if - ;; there's no source, line, column, or position - ;; information, but we want to expose the actual - ;; content of a bytecode stream: - (srcloc (vector-ref esrcloc 0) - (norm (vector-ref esrcloc 1)) - (norm (vector-ref esrcloc 2)) - (norm (vector-ref esrcloc 3)) - (norm (vector-ref esrcloc 4)))) - (let ([props - (if (and esrcloc ((vector-length esrcloc) . > . 5)) - (case (vector-ref esrcloc 5) - [(#\[) #hasheq((paren-shape . #\[))] - [(#\{) #hasheq((paren-shape . #\{))] - [else #hasheq()]) - #hasheq())]) - (if (and esrcloc ((vector-length esrcloc) . > . 6)) - (for/fold ([props props]) ([p (in-list (vector-ref esrcloc 6))]) - (hash-set props (car p) (cdr p))) - props)))))) - (values (car p) (cdr p))) - -;; ---------------------------------------- - -(define (decode-wrap encoded-wrap ht) - (hash-ref! ht - encoded-wrap - (lambda () - (match encoded-wrap - [(vector shifts simple-scopes multi-scopes) - (make-wrap (decode-map decode-shift shifts ht) - (decode-map decode-scope simple-scopes ht) - (decode-map decode-shifted-multi-scope multi-scopes ht))] - [_ (error 'decode-wrap "bad wrap")])))) - -(define (decode-map decode-one l ht) - (cond - [(null? l) l] - [(not (pair? l)) - (error 'decode-wrap "bad list")] - [else (hash-ref! ht l - (lambda () - (cons (decode-one (car l) ht) - (decode-map decode-one (cdr l) ht))))])) - -(define (decode-shift s ht) - (hash-ref! ht s - (lambda () - (match s - [(vector to from) - (module-shift to from #f #f)] - [(vector to from i-to i-from) - (module-shift to from i-to i-from)] - [_ (error 'decode-wrap "bad shift")])))) - -(define (decode-scope s ht) - (or - (and (eq? s root-scope) - s) - (hash-ref ht s - (lambda () - (unless (encoded-scope? s) - (error 'decode-wrap "bad scope: ~e" s)) - (define v (encoded-scope-content s)) - (define kind - (match v - [(? number?) v] - [(cons (? number?) _) - (car v)] - [else (error 'decode-wrap "bad scope")])) - (define sc (scope (encoded-scope-relative-id s) - (case kind - [(0 1) 'module] - [(2) 'macro] - [(3) 'local] - [(4) 'intdef] - [else 'use-site]) - null - null - #f)) - (hash-set! ht s sc) - (unless (number? v) - (define-values (bulk-bindings end) - (let loop ([l (cdr v)] [bulk-bindings null]) - (cond - [(pair? l) - (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) - (decode-bulk-import (cdar l) ht)) - bulk-bindings))] - [else (values (reverse bulk-bindings) l)]))) - (set-scope-bulk-bindings! sc bulk-bindings) - (unless (and (vector? end) - (even? (vector-length end))) - (error 'decode-wrap "bad scope")) - (define bindings - (let loop ([i 0]) - (cond - [(= i (vector-length end)) null] - [else - (append (for/list ([p (in-list (vector-ref end (add1 i)))]) - (list (vector-ref end i) - (decode-scope-set (car p) ht) - (decode-binding (cdr p) ht))) - (loop (+ i 2)))]))) - (set-scope-bindings! sc bindings)) - sc)))) - -(define (decode-scope-set l ht) - (decode-map decode-scope l ht)) - -(define (decode-binding b ht) - (hash-ref! ht b - (lambda () - (match b - [(box (cons base-b (cons (cons sym wraps) phase))) - (free-id=?-binding - (decode-binding base-b ht) - (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean) - phase)] - [(? symbol?) - (local-binding b)] - [else - ;; Leave it encoded, so that the compactness (or not) - ;; of the encoding is visible; clients decode further - ;; with `decode-module-binding` - (module-binding b)])))) - -(define (decode-module-binding b name) - (define-values (insp-desc rest-b) - (match b - [(cons (? symbol?) _) - (values (car b) (cdr b))] - [else - (values #f b)])) - (define (decode-nominal-modidx-plus-phase n mod-phase) - (match n - [(? module-path-index?) - (values n mod-phase 0)] - [(cons nom-modix (cons import-phase nom-phase)) - (values nom-modix nom-phase import-phase)] - [(cons nom-modix import-phase) - (values nom-modix mod-phase import-phase)] - [_ - (error 'decode-module-binding "bad encoding")])) - (match rest-b - [(and modidx (? module-path-index?)) - (decoded-module-binding modidx name 0 - modidx name 0 - 0 insp-desc)] - [(cons (and modidx (? module-path-index?)) - (and name (? symbol?))) - (decoded-module-binding modidx name 0 - modidx name 0 - 0 insp-desc)] - [(cons (and modidx (? module-path-index?)) - (and nom-modidx (? module-path-index?))) - (decoded-module-binding modidx name 0 - nom-modidx name 0 - 0 insp-desc)] - [(list* modidx (and name (? symbol?)) - nominal-modidx-plus-phase nom-name) - (define-values (nom-modidx nom-phase import-phase) - (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase 0)) - (decoded-module-binding modidx name 0 - nom-modidx nom-name nom-phase - import-phase insp-desc)] - [(list* modidx mod-phase (and name (? symbol?)) - nominal-modidx-plus-phase nom-name) - (define-values (nom-modidx nom-phase import-phase) - (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase mod-phase)) - (decoded-module-binding modidx name mod-phase - nom-modidx nom-name nom-phase - import-phase insp-desc)] - [_ (error 'decode-module-binding "bad encoding")])) - -(define (decode-bulk-import l ht) - (hash-ref! ht l - (lambda () - (match l - [(vector (and modidx (? module-path-index?)) - src-phase - info - (and insp-desc (or #f (? symbol?)))) - (define-values (phase prefix excepts) - (match info - [(or #f (? exact-integer?)) - (values info #f '#())] - [(cons phase (and prefix (? symbol?))) - (values phase prefix '#())] - [(cons phase (cons excepts prefix)) - (values phase prefix excepts)] - [(cons phase excepts) - (values phase #f excepts)] - [_ (error 'decode-wrap "bad bulk import info")])) - (all-from-module modidx - phase - src-phase - insp-desc - (if excepts - (vector->list excepts) - null) - prefix)] - [_ (error 'decode-wrap "bad bulk import")])))) - -(define (decode-shifted-multi-scope sms ht) - (unless (pair? sms) - (error 'decode-wrap "bad multi-scope pair")) - (list (decode-multi-scope (car sms) ht) - (cdr sms))) - -(define (decode-multi-scope ms ht) - (unless (and (vector? ms) - (odd? (vector-length ms))) - (error 'decode-wrap "bad multi scope")) - (hash-ref ht ms - (lambda () - (define multi (multi-scope (hash-count ht) - (vector-ref ms (sub1 (vector-length ms))) - null)) - (hash-set! ht ms multi) - (define scopes - (let loop ([i 0]) - (cond - [(= (add1 i) (vector-length ms)) null] - [else - (define s (decode-scope (vector-ref ms (add1 i)) ht)) - (when (scope-multi-owner s) - (error 'decode-wrap "bad scope owner: ~e while reading ~e" - (scope-multi-owner s) - multi)) - (set-scope-multi-owner! s multi) - (cons (list (vector-ref ms i) - s) - (loop (+ i 2)))]))) - (set-multi-scope-scopes! multi scopes) - multi))) + (make-reader-graph (read-compact cp))) ;; ---------------------------------------- diff -Nru racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-structs.rkt racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-structs.rkt --- racket-6.12+ppa1/share/pkgs/zo-lib/compiler/zo-structs.rkt 2018-01-26 20:34:16.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/zo-lib/compiler/zo-structs.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -4,19 +4,6 @@ racket/list racket/set) -#| Unresolved issues - - what are the booleans in lexical-rename? - - contracts that are probably too generous: - prefix-stxs - provided-nom-src - lam-num-params - lexical-rename-alist - all-from-module - -|# - ;; ---------------------------------------- ;; Structures to represent bytecode @@ -42,94 +29,51 @@ (define-form-struct struct-shape ()) (define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) -(define-form-struct (predicate-shape struct-shape) ()) -(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) -(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) -(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ([authentic? boolean?])) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) (define-form-struct (struct-type-property-shape struct-shape) ([has-guard? boolean?])) (define-form-struct (property-predicate-shape struct-shape) ()) (define-form-struct (property-accessor-shape struct-shape) ()) (define-form-struct (struct-other-shape struct-shape) ()) -;; In toplevels of resove prefix: -(define-form-struct global-bucket ([name symbol?])) ; top-level binding -(define-form-struct module-variable ([modidx module-path-index?] - [sym symbol?] - [pos exact-integer?] - [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed - function-shape? - struct-shape?)])) - -(define-form-struct prefix ([num-lifts exact-nonnegative-integer?] - [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] - [stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment - [src-inspector-desc symbol?])) - (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] - [binding-namess (hash/c exact-nonnegative-integer? - (hash/c symbol? stx?))] - [prefix prefix?] - [code (or/c form? any/c)])) ; compiled code always wrapped with this - -;; A provided identifier -(define-form-struct provided ([name symbol?] - [src (or/c module-path-index? #f)] - [src-name symbol?] - [nom-src any/c] ; should be (or/c module-path-index? #f) - [src-phase exact-nonnegative-integer?] - [protected? boolean?])) - (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [const? boolean?] [ready? boolean?])) ; access binding via prefix array (which is on stack) -(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' -(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])) +(define-form-struct (seq expr) ([forms (listof (or/c expr? any/c))])) ; `begin' -(define-form-struct (inline-variant form) ([direct expr?] - [inline expr?])) +(define-form-struct (inline-variant zo) ([direct expr?] + [inline expr?])) ;; Definitions (top level or within module): (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] - [rhs (or/c expr? seq? inline-variant? any/c)])) -(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])) - -(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] - [srcname symbol?] - [self-modidx module-path-index?] - [prefix prefix?] - [provides (listof (list/c (or/c exact-integer? #f) - (listof provided?) - (listof provided?)))] - [requires (listof (cons/c (or/c exact-integer? #f) - (listof module-path-index?)))] + [rhs (or/c expr? seq? inline-variant? any/c)])) + +(define-form-struct (linkl zo) ([name symbol?] + [importss (listof (listof symbol?))] + [import-shapess (listof (listof (or/c #f 'constant 'fixed + function-shape? + struct-shape?)))] + [exports (listof symbol?)] + [internals (listof (or/c symbol? #f))] + [lifts (listof symbol?)] + [source-names (hash/c symbol? symbol?)] [body (listof (or/c form? any/c))] - [syntax-bodies (listof (cons/c exact-positive-integer? - (listof (or/c def-syntaxes? seq-for-syntax?))))] - [unexported (listof (list/c exact-nonnegative-integer? - (listof symbol?) - (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] - [dummy toplevel?] - [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx? (vectorof stx?))] - [binding-names (hash/c exact-integer? - (hash/c symbol? (or/c #t stx?)))] - [flags (listof (or/c 'cross-phase))] - [pre-submodules (listof mod?)] - [post-submodules (listof mod?)])) + [need-instance-access? boolean?])) + +(define-form-struct (linkl-directory zo) ([table (hash/c (listof symbol?) linkl-bundle?)])) +(define-form-struct (linkl-bundle zo) ([table (hash/c (or/c symbol? fixnum?) + any/c)])) ; can be anythingv, but especially a linklet (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] [flags (listof (or/c 'preserves-marks 'is-method 'single-result @@ -165,16 +109,16 @@ [type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack -(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) - (define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call (define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' (define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] [val (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' -(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' -(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' +(define-form-struct (varref expr) ([toplevel (or/c toplevel? #f #t symbol?)] + [dummy (or/c toplevel? #f)] + [constant? boolean?] + [from-unsafe? boolean?])) (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] @@ -182,58 +126,37 @@ [body (or/c expr? seq? any/c)])) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive -;; Top-level `require' -(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) - - -;; Syntax objects - -(define-form-struct stx ([content stx-obj?])) - -(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components - [wrap any/c] ; should be `wrap?`, but encoded form appears initially - [srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially - [props (hash/c symbol? any/c)] - [tamper-status (or/c 'clean 'armed 'tainted)])) - -(define-form-struct wrap ([shifts (listof module-shift?)] - [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) - -(define-form-struct module-shift ([from (or/c #f module-path-index?)] - [to (or/c #f module-path-index?)] - [from-inspector-desc (or/c #f symbol?)] - [to-inspector-desc (or/c #f symbol?)])) - -(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing - [kind symbol?] - [bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable] - [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable] - [multi-owner (or/c #f multi-scope?) #:mutable])) -(define-form-struct multi-scope ([name exact-nonnegative-integer?] - [src-name any/c] ; debugging info, such as module name - [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable])) - -(define-form-struct binding ()) -(define-form-struct (free-id=?-binding binding) ([base (and/c binding? - (not/c free-id=?-binding?))] - [id stx-obj?] - [phase (or/c #f exact-integer?)])) -(define-form-struct (local-binding binding) ([name symbol?])) -(define-form-struct (module-binding binding) ([encoded any/c])) -;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`: -(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)] - [name symbol?] - [phase exact-integer?] - [nominal-path (or/c #f module-path-index?)] - [nominal-export-name symbol?] - [nominal-phase (or/c #f exact-integer?)] - [import-phase (or/c #f exact-integer?)] - [inspector-desc (or/c #f symbol?)])) - -(define-form-struct all-from-module ([path module-path-index?] - [phase (or/c exact-integer? #f)] - [src-phase (or/c exact-integer? #f)] - [inspector-desc symbol?] - [exceptions (listof symbol?)] - [prefix (or/c symbol? #f)])) +;; For backward compatibility, provide limited matching support as `compilation-top`: +(provide compilation-top) +(require (for-syntax racket/base)) +(define-match-expander compilation-top + (lambda (stx) + (syntax-case stx () + [(_ max-let-depth binding-namess prefix code) + #'(linkl-directory (hash-table ('() (linkl-bundle + (hash-table (0 (linkl _ ; name + _ ; imports + _ ; import shapes + _ ; exports + _ ; internals + _ ; lifts + _ ; source-names + (list code) ; body + max-let-depth + _)) + _ (... ...)))) + _ (... ...)))])) + (lambda (stx) + (syntax-case stx () + [(_ max-let-depth binding-namess prefix code) + #'(linkl-directory (hash '() (linkl-bundle + (hasheq 0 (linkl 'top + '() + '() + '() + '() + '() + #hasheq() + (list code) + (add1 max-let-depth) + #f)))))]))) diff -Nru racket-6.12+ppa1/share/pkgs/zo-lib/info.rkt racket-7.0+ppa1/share/pkgs/zo-lib/info.rkt --- racket-6.12+ppa1/share/pkgs/zo-lib/info.rkt 2018-01-26 21:10:24.000000000 +0000 +++ racket-7.0+ppa1/share/pkgs/zo-lib/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "6.12"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Libraries for handling zo files") (define pkg-authors (quote (mflatt))) (define version "1.2"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.0"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Libraries for handling zo files") (define pkg-authors (quote (mflatt))) (define version "1.2"))) diff -Nru racket-6.12+ppa1/src/cify/arg.rkt racket-7.0+ppa1/src/cify/arg.rkt --- racket-6.12+ppa1/src/cify/arg.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/arg.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,79 @@ +#lang racket/base +(require "match.rkt") + +(provide add-args + extract-rest-arg + lambda-arity + lambda-no-rest-args? + args-length + compatible-args?) + +(define (add-args env ids) + (cond + [(null? ids) env] + [(symbol? ids) (hash-set env ids #t)] + [else (add-args (hash-set env (car ids) #t) + (cdr ids))])) + +(define (extract-rest-arg ids) + (if (pair? ids) + (extract-rest-arg (cdr ids)) + ids)) + +(define (lambda-arity e #:precise-cases? [precise-cases? #f]) + (match e + [`(lambda ,ids . ,_) + (define min-a (args-length ids)) + (if (list? ids) + (values min-a min-a) + (values min-a -1))] + [`(case-lambda) + (if precise-cases? + (values -1 "\"\"") + (values 0 0))] + [`(case-lambda [,unsorted-idss . ,_] ...) + (cond + [precise-cases? + ;; Get full arity to record for arity reporting + (define idss unsorted-idss) + (values (- (+ (length idss) 1)) + (substring + (format "~s" + (apply bytes-append + ;; Encode individual arities as pairs of little-endian `int`s: + (for/list ([ids (in-list idss)]) + (define-values (min-a max-a) (lambda-arity `(lambda ,ids))) + (bytes-append (integer->integer-bytes min-a 4 #t #f) + (integer->integer-bytes max-a 4 #t #f))))) + 1))] + [else + ;; Get approximate arity for predictions about calls + (define idss (sort unsorted-idss < #:key args-length)) + (define-values (min-a max-a) (lambda-arity `(lambda ,(car idss)))) + (let loop ([min-a min-a] [max-a max-a] [idss (cdr idss)]) + (cond + [(null? idss) (values min-a max-a)] + [else + (define-values (new-min-a new-max-a) (lambda-arity `(lambda ,(car idss)))) + (loop (min min-a new-min-a) + (if (or (= max-a -1) (= new-max-a -1)) + -1 + (max max-a new-max-a)) + (cdr idss))]))])])) + +(define (lambda-no-rest-args? e) + (match e + [`(lambda ,ids . ,_) (list? ids)] + [`(case-lambda [,idss . ,_] ...) + (for/and ([ids (in-list idss)]) + (list? ids))])) + +(define (args-length ids) + (if (pair? ids) (add1 (args-length (cdr ids))) 0)) + +(define (compatible-args? n e) + (match e + [`(lambda ,ids . ,_) (= n (args-length ids))] + [`(case-lambda [,idss . ,_] ...) + (for/or ([ids (in-list idss)]) + (= n (args-length ids)))])) diff -Nru racket-6.12+ppa1/src/cify/debug.rkt racket-7.0+ppa1/src/cify/debug.rkt --- racket-6.12+ppa1/src/cify/debug.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/debug.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide current-debug) + +;; Insert debugging checks? +(define current-debug (make-parameter #f)) + diff -Nru racket-6.12+ppa1/src/cify/free-var.rkt racket-7.0+ppa1/src/cify/free-var.rkt --- racket-6.12+ppa1/src/cify/free-var.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/free-var.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,90 @@ +#lang racket/base +(require "match.rkt" + "vehicle.rkt" + "function.rkt" + "ref.rkt" + "sort.rkt" + "arg.rkt") + +(provide get-free-vars) + +(define (get-free-vars e env lambdas knowns top-names state) + (define lam (hash-ref lambdas e)) + (or (lam-free-var-refs lam) + (let ([vars (extract-lambda-free-vars #hasheq() e env lambdas knowns top-names state)]) + (define free-vars (for/list ([var (in-sorted-hash-keys vars symbol~a" (cify (vehicle-id vehicle)))) + (vehicle-max-runstack-depth vehicle)) + (out-close!) + (out-open "if (c_argv == c_orig_runstack)") + (out "c_runbase = c_argv + c_argc;") + (out-close+open "else") + (out "c_runbase = c_orig_runstack;") + (out-close!)) + (cond + [multi? + (out-open "switch(SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(c_self)[0])) {") + (out "default:") + (for ([lam (in-list lams)] + [i (in-naturals)]) + (out-open "case ~a:" i) + (when (lam-no-rest-args? lam) + (ensure-lambda-args-in-place leaf? lam)) + (out "goto c_entry_~a;" (cify (lam-id lam))) + (out-close!)) + (out-close "}")] + [else + (when (lam-no-rest-args? (car lams)) + (ensure-lambda-args-in-place leaf? (car lams)))]) + (for ([lam (in-list lams)]) + (when (or multi? (lam-need-entry? lam)) + (out-margin "c_entry_~a:" (cify (lam-id lam)))) + (generate-lambda lam multi? leaf? (or multi? overflow-check?))) + (out-close "}")) + + (define (generate-lambda lam multi? leaf? bracket?) + (define e (lam-e lam)) + (define id (lam-id lam)) + (define free-var-refs (lam-free-var-refs lam)) + (define closure-offset (if multi? 1 0)) + (when bracket? (out-open "{")) + (match e + [`(lambda . ,_) (generate-lambda-case lam leaf? e free-var-refs closure-offset)] + [`(case-lambda [,idss . ,bodys] ...) + (for ([ids (in-list idss)] + [body (in-list bodys)] + [i (in-naturals)]) + (out-open "~aif (c_argc ~a ~a) {" (if (zero? i) "" "else ") (if (list? ids) "==" ">=") (args-length ids)) + (generate-lambda-case lam leaf? `(lambda ,ids . ,body) free-var-refs closure-offset) + (out-close "}")) + (out "~areturn c_wrong_arity(~s, c_argc, c_argv);" + (if (null? idss) "" "else ") + (format "~a" id))]) + (when bracket? (out-close "}"))) + + ;; Returns a boolean indicating whether the functon can be a leaf + (define (generate-lambda-case lam leaf? e free-var-refs closure-offset) + (define name (lam-id lam)) + (match e + [`(lambda ,ids . ,body) + (define n (args-length ids)) + (when (not (lam-no-rest-args? lam)) + (define rest-arg? (not (list? ids))) + (ensure-args-in-place leaf? n free-var-refs + #:rest-arg? rest-arg? + #:rest-arg-used? (and rest-arg? (referenced? (hash-ref state (extract-rest-arg ids) #f))))) + (unless (null? ids) (out-open "{")) + (when (and leaf? (for/or ([id (in-list ids)]) + (referenced? (hash-ref state id #f)))) + (out "Scheme_Object **c_runbase = c_argv + ~a;" n)) + ;; At this point, for a non-leaf, runstack == runbase - argument-count (including rest) + (define runstack (make-runstack state)) + (define pushed-arg-count + (let loop ([ids ids]) + (cond + [(null? ids) 0] + [(symbol? ids) (loop (list ids))] + [else + ;; Push last first: + (define count (add1 (loop (cdr ids)))) + (runstack-push! runstack (car ids) #:referenced? (referenced? (hash-ref state (car ids) #f))) + count]))) + (runstack-synced! runstack) ; since runstack = start of arguments + ;; Unpack closure + (for ([ref (in-list free-var-refs)]) + (runstack-push! runstack (ref-id ref) #:local? leaf?)) + (for ([ref (in-list free-var-refs)] + [i (in-naturals)]) + (define id (ref-id ref)) + (out "~a = SCHEME_PRIM_CLOSURE_ELS(c_self)[~a];" (runstack-assign runstack id) (+ closure-offset i))) + (when (hash-ref (lam-loop-targets lam) n #f) + (out-margin "c_recur_~a_~a:" (cify name) n)) + (clear-unused-ids ids runstack state) + (box-mutable-ids ids runstack lam state top-names) + (generate (tail-return name lam ids leaf?) `(begin . ,body) lam (add-args (lam-env lam) ids) runstack + knowns top-names state lambdas prim-names prim-knowns) + (runstack-pop! runstack pushed-arg-count) + (unless (null? ids) (out-close "}")) + (let ([vehicle (lam-vehicle lam)]) + (set-vehicle-max-runstack-depth! vehicle (max (runstack-max-depth runstack) + (vehicle-max-runstack-depth vehicle)))) + (set-lam-can-leaf?! lam (not (runstack-ever-synced? runstack)))])) + + (for ([vehicle (in-list vehicles)]) + (generate-vehicle vehicle))) + +(define (lam-constant-args-count? lam) + (match (lam-e lam) + [`(lambda (,_ ...) . ,_) #t] + [`,_ #f])) + +(define (lam-no-rest-args? lam) + (match (lam-e lam) + [`(lambda (,_ ...) . ,_) #t] + [`(case-lambda [(,_ ...) . ,_] ...) #t] + [`,_ #f])) + +;; Only used when no rest args: +(define (ensure-lambda-args-in-place leaf? lam) + (match (lam-e lam) + [`(lambda ,ids . ,_) + (ensure-args-in-place leaf? (length ids) #:rest-arg? #f (lam-free-var-refs lam))] + [`,_ + (ensure-args-in-place leaf? "c_argc" #:rest-arg? #f (lam-free-var-refs lam))])) + +(define (ensure-args-in-place leaf? expected-n free-var-refs + #:rest-arg? rest-arg? + #:rest-arg-used? [rest-arg-used? #t]) + ;; Generate code to make sure that `c_runbase` minus the number of + ;; argument variables (including a "rest" args) holds arguments, + ;; converting "rest" args to a list as needed. We don't need to + ;; perform this check (or set `c_argv` and `c_argc`) for a call + ;; within a vehicle for a non-`case-lambda`, because it will + ;; definitely hold then. + (unless leaf? + (cond + [rest-arg? + (out "~ac_ensure_args_in_place_rest(c_argc, c_argv, c_runbase, ~a, 1, ~a, ~a);" + (if (null? free-var-refs) "(void)" "c_self = ") + expected-n + (if rest-arg-used? "c_rest_arg_used" "c_rest_arg_unused") + (if (null? free-var-refs) "NULL" "c_self"))] + [(eqv? 0 expected-n) + ;; No args; we can always assume that 0 arguments are at `_runbase` + (void)] + [else + ;; No rest arg + (out "c_ensure_args_in_place(~a, c_argv, c_runbase);" expected-n)]))) + +(define (box-mutable-ids ids runstack in-lam state top-names) + (let loop ([ids ids]) + (unless (null? ids) + (cond + [(symbol? ids) (loop (list ids))] + [else + (when (and (mutated? (hash-ref state (car ids) #f)) + (not (hash-ref top-names (car ids) #f))) + (define s (let ([id (car ids)]) + (if (hash-ref top-names id #f) + (format "~a =" (top-ref in-lam id)) + (runstack-assign runstack id)))) + (runstack-sync! runstack) + (out "~a = scheme_box_variable(~a);" s s)) + (loop (cdr ids))])))) + +(define (clear-unused-ids ids runstack state) + (let loop ([ids ids]) + (unless (null? ids) + (cond + [(symbol? ids) (loop (list ids))] + [else + (define id (car ids)) + (when (and (not (referenced? (hash-ref state id #f))) + (not (state-implicitly-referenced? state id))) + (runstack-stage-clear! runstack id state)) + (loop (cdr ids))])))) + +;; ---------------------------------------- + +(define (generate ret e in-lam env runstack knowns top-names state lambdas prim-names prim-knowns) + (define (generate ret e env) + (match e + [`(quote ,v) + (generate-quote ret v)] + [`(lambda . ,_) + (generate-closure ret e env)] + [`(case-lambda . ,_) + (generate-closure ret e env)] + [`(begin ,e) + (generate ret e env)] + [`(begin ,e . ,r) + (generate (multiple-return "") e env) + (generate ret `(begin . ,r) env)] + [`(begin0 ,e . ,r) + (define vals-id (genid 'c_vals)) + (out-open "{") + (runstack-push! runstack vals-id) + (out "int ~a_count;" vals-id) + (generate (multiple-return (lambda (s) + (out "~a = ~a;" (runstack-assign runstack vals-id) s) + (out-open "if (~a == SCHEME_MULTIPLE_VALUES) {" (runstack-ref runstack vals-id #:values-ok? #t)) + (out "Scheme_Object **~a_vals;" vals-id) + (out "~a_vals = c_current_thread->ku.multiple.array;" vals-id) + (out "~a_count = c_current_thread->ku.multiple.count;" vals-id) + (out "if (SAME_OBJ(~a_vals, c_current_thread->values_buffer))" vals-id) + (out " c_current_thread->values_buffer = NULL;") + (out "~a = (Scheme_Object *)~a_vals;" (runstack-assign runstack vals-id) vals-id) + (out-close+open "} else") + (out "~a_count = 1;" vals-id) + (out-close!))) + e env) + (generate (multiple-return "") `(begin . ,r) env) + (out-open "if (~a_count != 1)" vals-id) + (return ret runstack #:can-omit? #t + (format "scheme_values(~a_count, (Scheme_Object **)~a)" vals-id (runstack-ref runstack vals-id))) + (out-close+open "else") + (return ret runstack #:can-omit? #t #:can-pre-pop? #t + (runstack-ref runstack vals-id)) + (out-close!) + (runstack-pop! runstack) + (out-close "}")] + [`(if ,orig-tst ,thn ,els) + (define-values (tsts sync-for-gc? wrapper) (extract-inline-predicate orig-tst in-lam knowns #:compose? #t)) + (define tst-ids (for/list ([tst (in-list tsts)]) + (if (simple? tst in-lam state knowns) + #f + (genid 'c_if)))) + (define all-simple? (for/and ([tst-id (in-list tst-ids)]) + (not tst-id))) + ;; The last `tst-id` doesn't need to be on the runstack + (define immediate-tst-id (for/fold ([id #f]) ([tst-id (in-list tst-ids)]) + (or tst-id id))) + (unless all-simple? (out-open "{")) + (define tst-id-count + (for/sum ([tst-id (in-list tst-ids)] + #:when (and tst-id (not (eq? tst-id immediate-tst-id)))) + (runstack-push! runstack tst-id) + 1)) + (when immediate-tst-id + (out "Scheme_Object *~a;" (cify immediate-tst-id))) + (for ([tst-id (in-list tst-ids)] + [tst (in-list tsts)] + #:when tst-id) + (generate (if (eq? tst-id immediate-tst-id) + (format "~a =" (cify tst-id)) + (make-runstack-assign runstack tst-id)) + tst env)) + (when sync-for-gc? + (runstack-sync! runstack)) + (call-with-simple-shared + (cons 'begin (for/list ([tst-id (in-list tst-ids)] + [tst (in-list tsts)] + #:when (not tst-id)) + tst)) + runstack state + (lambda (shared) + (out-open "if (~a) {" + (wrapper (apply string-append + (add-between + (for/list ([tst-id (in-list tst-ids)] + [tst (in-list tsts)]) + (format "~a" + (cond + [(not tst-id) (generate-simple tst shared env runstack in-lam state top-names knowns prim-names)] + [(eq? tst-id immediate-tst-id) (cify tst-id)] + [tst-id (runstack-ref runstack tst-id)]))) + ", ")))) + (define-values (thn-refs els-refs) (let ([p (hash-ref state e '(#hasheq() . #hasheq()))]) + (values (car p) (cdr p)))) + (define pre-branch (runstack-branch-before! runstack)) + (define pre-ref-use (ref-use-branch-before! state)) + (runstack-stage-clear-unused! runstack thn-refs els-refs state) + (generate ret thn env) + (out-close+open "} else {") + (runstack-stage-clear-unused! runstack els-refs thn-refs state) + (define post-branch (runstack-branch-other! runstack pre-branch)) + (define post-ref-use (ref-use-branch-other! state pre-ref-use)) + (generate ret els env) + (when (state-first-pass? state) + (define-values (thn-refs els-refs) (runstack-branch-refs runstack pre-branch post-branch)) + (hash-set! state e (cons thn-refs els-refs))) + (runstack-branch-merge! runstack pre-branch post-branch) + (ref-use-branch-merge! state pre-ref-use post-ref-use) + (out-close "}") + (runstack-pop! runstack tst-id-count))) + (unless all-simple? (out-close "}"))] + [`(with-continuation-mark ,key ,val ,body) + (define wcm-id (genid 'c_wcm)) + (define wcm-key-id (genid 'c_wcm_key)) + (define wcm-val-id (genid 'c_wcm_val)) + (out-open "{") + (define simple-key? (simple? key in-lam state knowns)) + (define simple-val? (simple? val in-lam state knowns)) + (define simple-either? (or simple-key? simple-val?)) + (runstack-push! runstack wcm-key-id #:local? simple-either?) + (runstack-push! runstack wcm-val-id #:local? simple-either?) + (unless (tail-return? ret) + (out "c_saved_mark_stack_t ~a_frame = c_push_mark_stack();" wcm-id)) + (cond + [(and simple-key? (not simple-val?)) + ;; Value first + (generate (make-runstack-assign runstack wcm-val-id) val env) + (generate (make-runstack-assign runstack wcm-key-id) key env)] + [else + ;; Key first + (generate (make-runstack-assign runstack wcm-key-id) key env) + (generate (make-runstack-assign runstack wcm-val-id) val env)]) + (define set-cont-mark (format "scheme_set_cont_mark(~a, ~a);" + (runstack-ref runstack wcm-key-id) + (runstack-ref runstack wcm-val-id))) + (runstack-pop! runstack 2) + (runstack-sync! runstack) + (out set-cont-mark) + (generate ret body env) + (unless (tail-return? ret) + (out "c_pop_mark_stack(~a_frame);" wcm-id)) + (out-close "}")] + [`(let () . ,body) (generate ret `(begin . ,body) env)] + [`(let (,_) . ,_) (generate-let ret e env)] + [`(let ([,id ,rhs] . ,rest) . ,body) + ;; One at a time, so runstack slot can be allocated after RHS: + (generate ret `(let ([,id ,rhs]) (let ,rest . ,body)) env)] + [`(letrec . ,_) (generate-let ret e env)] + [`(letrec* . ,_) (generate-let ret e env)] + [`(call-with-values (lambda () . ,body1) (lambda (,ids ...) . ,body2)) + (define values-ret (if (for/or ([id (in-list ids)]) + (or (referenced? (hash-ref state id #f)) + (hash-ref top-names id #f))) + "/*needed*/" + "")) + (generate (multiple-return values-ret) `(begin . ,body1) env) + (out-open "{") + (define bind-count + (for/sum ([id (in-list ids)] + #:unless (or (hash-ref top-names id #f) + (not (referenced? (hash-ref state id #f))))) + (runstack-push! runstack id) + 1)) + (generate-multiple-value-binds ids runstack in-lam state top-names) + (box-mutable-ids ids runstack in-lam state top-names) + (generate ret `(begin . ,body2) (add-args env ids)) + (runstack-pop! runstack bind-count) + (out-close "}")] + [`(set! ,ref ,rhs) + (define top? (hash-ref top-names ref #f)) + (define target + (cond + [top? (top-ref in-lam ref)] + [else (genid 'c_set)])) + (unless top? + (out-open "{") + (out "Scheme_Object *~a;" target)) + (generate (format "~a =" target) rhs env) + (unless top? + (when (ref? ref) (ref-use! ref state)) + (out "SCHEME_UNBOX_VARIABLE_LHS(~a) = ~a;" + (runstack-ref runstack (unref ref) #:ref (and (ref? ref) ref)) + target) + (out-close "}")) + (generate ret '(void) env)] + [`(void) (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_void")] + [`(void . ,r) + (generate ret `(begin ,@r (void)) env)] + [`(values ,r) + (generate ret r env)] + [`null (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_null")] + [`eof-object (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_eof")] + [`unsafe-undefined (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_undefined")] + [`(,rator ,rands ...) + (generate-app ret rator rands env)] + [`,_ + (cond + [(symbol-ref? e) + (when (ref? e) (ref-use! e state)) + (define can-omit? (not (and (ref? e) (ref-last-use? e)))) + (define id (unref e)) + (return ret runstack #:can-omit? can-omit? #:can-pre-pop? #t + (cond + [(hash-ref env id #f) + (cond + [(mutated? (hash-ref state id #f)) + (format "SCHEME_UNBOX_VARIABLE(~a)" + (runstack-ref runstack id #:ref e))] + [else + (when (and (return-can-omit? ret) + can-omit? + (state-first-pass? state)) + (adjust-state! state id -1)) + (runstack-ref runstack id #:ref e)])] + [(hash-ref top-names id #f) (top-ref in-lam id)] + [else (format "c_prims.~a" (cify id))]))] + [else (generate-quote ret e)])])) + + (define (generate-let ret e env) + (match e + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define body-env (for/fold ([env env]) ([id (in-list ids)] + ;; Leave out of the environment if flattened + ;; into the top sequence: + #:unless (hash-ref top-names id #f)) + (when (eq? let-id 'letrec) + (unless (function? (hash-ref knowns id #f)) + (log-error "`letrec` binding should have been treated as closed: ~e" id))) + (hash-set env id #t))) + (define rhs-env (if (eq? let-id 'let) env body-env)) + (out-open "{") + (define (push-binds) + (for/sum ([id (in-list ids)] + #:unless (or (not (referenced? (hash-ref state id #f))) + ;; flattened into top? + (hash-ref top-names id #f))) + (runstack-push! runstack id #:track-local? (eq? let-id 'let)) + 1)) + (define let-one? (and (eq? let-id 'let) + (= 1 (length ids)) + (referenced? (hash-ref state (car ids) #f)) + (not (hash-ref top-names (car ids) #f)))) + (define pre-bind-count (if let-one? 0 (push-binds))) + (define let-one-id (and let-one? (genid 'c_let))) + (when let-one? + (out "Scheme_Object *~a;" (cify let-one-id))) + (when (eq? let-id 'letrec*) + (box-mutable-ids ids runstack in-lam state top-names)) + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (cond + [(eq? let-id 'letrec*) + (generate "" `(set! ,id ,rhs) rhs-env)] + [(not (referenced? (hash-ref state id #f))) + (generate "" rhs rhs-env)] + [else + (define ret (cond + [let-one? (format "~a =" (cify let-one-id))] + [(hash-ref top-names id #f) (format "~a =" (top-ref in-lam id))] + [else + (make-runstack-assign runstack id)])) + (generate ret rhs rhs-env)])) + (when let-one? + (runstack-push! runstack (car ids) #:track-local? #t) + (out "~a = ~a;" (runstack-assign runstack (car ids)) (cify let-one-id))) + (when (eq? let-id 'let) + (box-mutable-ids ids runstack in-lam state top-names)) + (generate ret `(begin . ,body) body-env) + (runstack-pop! runstack (if let-one? 1 pre-bind-count) + #:track-local? (eq? let-id 'let)) + (out-close "}") + (when (state-first-pass? state) + ;; For any variable that has become unused, mark a + ;; right-hand side function as unused + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (unless (referenced? (hash-ref state id #f)) + (define lam-e (match rhs + [`(lambda . ,_) rhs] + [`(case-lambda . ,_) rhs] + [`,_ #f])) + (when lam-e + (define lam (hash-ref lambdas lam-e #f)) + (set-lam-unused?! lam #t)))))])) + + (define (generate-app ret rator rands env) + (define n (length rands)) + (cond + [(and (symbol? rator) + (inline-function rator n rands in-lam knowns)) + (generate-inline-app ret rator rands n env)] + [(and (symbol? rator) + (let ([k (hash-ref knowns rator #f)]) + (and (struct-constructor? k) + (struct-info-pure-constructor? (struct-constructor-si k)) + k))) + => (lambda (k) + (generate-inline-construct ret k rands n env))] + [else + (generate-general-app ret rator rands n env)])) + + (define (generate-inline-app ret rator rands n env) + (define need-sync? (not (inline-function rator n rands in-lam knowns #:can-gc? #f))) + (define tmp-ids (for/list ([rand (in-list rands)] + [i (in-naturals)]) + (and (not (simple? rand in-lam state knowns)) + (genid (format "c_arg_~a_" i))))) + (define all-simple? (for/and ([tmp-id (in-list tmp-ids)]) + (not tmp-id))) + (unless all-simple? (out-open "{")) + (define tmp-count + (for/sum ([tmp-id (in-list tmp-ids)] + #:when tmp-id) + (runstack-push! runstack tmp-id) + 1)) + (for ([tmp-id (in-list tmp-ids)] + [rand (in-list rands)]) + (when tmp-id + (generate (make-runstack-assign runstack tmp-id) + rand env))) + (when need-sync? + (runstack-sync! runstack)) + (define inline-app (cons rator (for/list ([tmp-id (in-list tmp-ids)] + [rand (in-list rands)]) + (or tmp-id rand)))) + (call-with-simple-shared + inline-app + runstack state + (lambda (shared) + (define s (generate-simple inline-app shared env runstack in-lam state top-names knowns prim-names)) + (return ret runstack #:can-pre-pop? #t s) + (runstack-pop! runstack tmp-count))) + (unless all-simple? (out-close "}"))) + + (define (generate-inline-construct ret k rands n env) + (define si (struct-constructor-si k)) + (out-open "{") + (define struct-tmp-id (genid 'c_structtmp)) + (out "Scheme_Object *~a;" (cify struct-tmp-id)) + (runstack-sync! runstack) + (out "~a = c_malloc_struct(~a);" (cify struct-tmp-id) (struct-info-field-count si)) + (out "c_struct_set_type(~a, ~a);" (cify struct-tmp-id) (top-ref in-lam (struct-info-struct-id si))) + (define all-simple? (for/and ([rand (in-list rands)]) + (simple? rand in-lam state knowns))) + (define struct-id (and (not all-simple?) (genid 'c_struct))) + (unless all-simple? + (out-open "{") + (runstack-push! runstack struct-id #:track-local? #t) + (out "~a = ~a;" (runstack-assign runstack struct-id) (cify struct-tmp-id))) + (for ([rand (in-list rands)] + [i (in-naturals)]) + (define to-struct-s (format "c_STRUCT_ELS(~a)[~a] =" + (if all-simple? + (cify struct-tmp-id) + (runstack-ref runstack struct-id)) + i)) + (generate (if all-simple? + to-struct-s + (format "~a =" (cify struct-tmp-id))) + rand env) + (unless all-simple? + (out "~a ~a;" to-struct-s (cify struct-tmp-id)))) + (return ret runstack (if all-simple? + (cify struct-tmp-id) + (runstack-ref runstack struct-id))) + (unless all-simple? + (runstack-pop! runstack 1 #:track-local? #t) + (out-close "}")) + (out-close "}")) + + (define (generate-general-app ret rator rands n env) + (define known-target-lam (let ([f (hash-ref knowns rator #f)]) + (and (function? f) (hash-ref lambdas (function-e f))))) + ;; If the target is known for a tail call, put this lambda and + ;; that one in the same vehicle, so the tail call can be a jump: + (when (and (tail-return? ret) + known-target-lam + (state-first-pass? state)) + (union! state (tail-return-lam ret) known-target-lam)) + ;; If it's known, we can jump as long as the target is in the same + ;; vehicle (which we just ensured, at least for a second pass) + (define direct? (and known-target-lam + (or (not (tail-return? ret)) + (eq? (find! state known-target-lam) + (find! state (tail-return-lam ret)))) + (compatible-args? n (lam-e known-target-lam)))) + (define direct-tail? (and direct? (tail-return? ret))) + ;; Do we need to evaluate the rator expression? If so, `rator-id` + ;; will be non-#f: + (define rator-id (cond + [direct? #f] + [(simple? rator in-lam state knowns) #f] + [else (genid 'c_rator)])) + ;; For a non-tail call, make a runstack id for every argument; + ;; that part of the runstack will be argv. + ;; For a tail call, we only need an arg-id for a non-simple + ;; expression, and we don't need one for the last non-simple. + (define arg-ids (for/list ([rand (in-list rands)] + [i (in-naturals)]) + (if (and direct-tail? + (simple? rand in-lam state knowns)) + #f + (genid (format "c_arg_~a_" i))))) + (define last-non-simple-arg-id + (and direct-tail? (for/last ([arg-id (in-list arg-ids)]) + arg-id))) + (define open? (not (and (zero? n) (not rator-id)))) + (when open? (out-open "{")) + ;; We can perform less runstack work by evaluating the first + ;; argument before making room on the runstack: + (define-values (first-non-simple-id first-non-simple-e) + (if rator-id + (values rator-id rator) + (let loop ([arg-ids arg-ids] [rands rands]) + (cond + [(null? arg-ids) (values #f #f)] + [(simple? (car rands) in-lam state knowns) (loop (cdr arg-ids) (cdr rands))] + [else (values (car arg-ids) (car rands))])))) + (define first-tmp-id (and first-non-simple-id + (genid 'c_argtmp))) + (when first-non-simple-id + (out "Scheme_Object *~a;" (cify first-tmp-id)) + (generate (format "~a =" (cify first-tmp-id)) + first-non-simple-e env)) + (when last-non-simple-arg-id ; could be the same as `first-non-simple-id` + (out "Scheme_Object *~a;" (cify last-non-simple-arg-id))) + (define declared-tmp? (or first-non-simple-id last-non-simple-arg-id)) + (when declared-tmp? (out-open "{")) + ;; Allocate the runstack room; put space for the rator, + ;; if needed, at the end, so it's after the runstack as argv + (when rator-id + (runstack-push! runstack rator-id)) + (define arg-push-count + (for/sum ([arg-id (reverse arg-ids)] + #:when (and arg-id + (not (eq? arg-id last-non-simple-arg-id)))) + (runstack-push! runstack arg-id) + 1)) + (define (generate-assign id e) + ;; Generate or use an already-generated non-simple in tmp + (cond + [(eq? id first-non-simple-id) + (out "~a = ~a;" + (if (eq? id last-non-simple-arg-id) + (cify id) + (runstack-assign runstack id)) + (cify first-tmp-id))] + [(eq? id last-non-simple-arg-id) + (generate (format "~a =" (cify id)) + e env)] + [else + (generate (make-runstack-assign runstack id) + e env)])) + (define (generate-args #:simple? gen-simple?) + (for ([arg-id (in-list arg-ids)] + [rand (in-list rands)] + #:when (and arg-id + (eq? (and gen-simple? #t) + (simple? rand in-lam state knowns)))) + (generate-assign arg-id rand))) + ;; For a non-tail call, generate simple arguments first, so + ;; that the allocated runstacks are filled: + (unless direct-tail? + (generate-args #:simple? #t)) + (when rator-id + (generate-assign rator-id rator)) + (generate-args #:simple? #f) + ;; Now that the arguments are ready (except simple arguments + ;; for a direct tail call), we finish in various ways: + (cond + ;; Special case for `values`: + [(eq? rator 'values) + (runstack-sync! runstack) ; now argv == runstack + (return ret runstack #:can-omit? #t + (if (zero? n) + "c_zero_values()" + (format "scheme_values(~a, c_current_runstack)" n)))] + ;; Call to a non-inlined primitive or to an unknown target + [(not direct?) + (call-with-simple-shared + (if rator-id #f rator) + runstack state + (lambda (shared) + (define rator-s (if rator-id + (runstack-ref runstack rator-id) + (generate-simple rator shared env runstack in-lam state top-names knowns prim-names))) + (define direct-prim? (and (symbol? rator) + (direct-call-primitive? rator prim-knowns))) + (define use-tail-apply? (and (tail-return? ret) + (or (not (symbol? rator)) + (hash-ref env rator #f) + (hash-ref top-names rator #f) + (not direct-prim?)))) + (define template (cond + [use-tail-apply? "_scheme_tail_apply(~a, ~a, ~a)"] + [direct-prim? "c_extract_prim(~a)(~a, ~a)"] + [(or (multiple-return? ret) (tail-return? ret)) "_scheme_apply_multi(~a, ~a, ~a)"] + [else "_scheme_apply(~a, ~a, ~a)"])) + (unless (or use-tail-apply? + (and direct-prim? (immediate-primitive? rator prim-knowns))) + (lam-calls-non-immediate! in-lam)) + (when use-tail-apply? + (set-lam-can-tail-apply?! in-lam #t)) + (runstack-sync! runstack) ; now argv == runstack + (return ret runstack (format template rator-s n (if (zero? n) "NULL" (runstack-stack-ref runstack))))))] + ;; Tail call to a known target: + [(tail-return? ret) + ;; Put simple arguments in temporaries: + (define any-simple? (for/or ([arg-id (in-list arg-ids)]) (not arg-id))) + (define arg-tmp-ids (for/list ([arg-id (in-list arg-ids)] + [rand (in-list rands)] + [i (in-naturals)]) + (cond + [arg-id #f] + [(and (symbol-ref? rand) + (eqv? (runstack-ref-pos runstack (unref rand)) (- n i)) + ((- n i) . <= . (args-length (tail-return-self-args ret))) + (not (mutated? (hash-ref state (unref rand) #f)))) + ;; No need to copy an argument to itself, which is + ;; common for lifted loops: + (when (state-first-pass? state) + (adjust-state! state (unref rand) -1)) + #f] + [else + (genid 'c_argtmp)]))) + (when any-simple? + (out-open "{") + (for ([arg-tmp-id (in-list arg-tmp-ids)] + #:when arg-tmp-id) + (out "Scheme_Object *~a;" (cify arg-tmp-id))) + (for ([arg-tmp-id (in-list arg-tmp-ids)] + [rand (in-list rands)] + #:when arg-tmp-id) + (generate (format "~a =" (cify arg-tmp-id)) + rand env))) + ;; Non-simple args are on the runstack. We need to move from + ;; last to first, since the runstack staging area and the + ;; and target argument area may overlap. + (for ([i (in-range n 0 -1)] + [arg-id (in-list (reverse arg-ids))]) + (when arg-id + (out "c_runbase[~a] = ~a;" + (- i (add1 n)) + (if (eq? arg-id last-non-simple-arg-id) + (cify arg-id) + (runstack-ref runstack arg-id))))) + ;; Move the simple arguments into place: + (for ([i (in-range n)] + [arg-tmp-id (in-list arg-tmp-ids)]) + (when arg-tmp-id + (out "c_runbase[~a] = ~a;" (- i n) (cify arg-tmp-id)))) + ;; For any argument that was skipped because it's already in + ;; place, record that we need it live to here: + (for ([arg-id (in-list arg-ids)] + [arg-tmp-id (in-list arg-tmp-ids)] + [rand (in-list rands)]) + (unless (or arg-id arg-tmp-id) + (out "/* in place: ~a */" (cify (ref-id rand))) + (runstack-ref-use! runstack rand) + (ref-use! rand state) + (state-implicit-reference! state (ref-id rand)))) + (when any-simple? + (out-close "}")) + ;; Set the runstack pointer to the argument start, then jump + (out "c_current_runstack = c_runbase - ~a;" n) + (when (if (eq? in-lam known-target-lam) + (n . <= . (args-length (tail-return-self-args ret))) + (symbolstring e))] + [(string? e) + (define s (string->bytes/utf-8 e)) + (format "scheme_make_sized_utf8_string(~s, ~a)" + (bytes->string/latin-1 s) + (bytes-length s))] + [(bytes? e) + (format "scheme_make_sized_byte_string(~s, ~a, 0)" + (bytes->string/latin-1 e) + (bytes-length e))] + [(number? e) + (cond + [(always-fixnum? e) + (format "scheme_make_integer(~a)" e)] + [(eqv? e +inf.0) "scheme_inf_object"] + [(eqv? e -inf.0) "scheme_minus_inf_object"] + [(eqv? e +nan.0) "scheme_nan_object"] + [(eqv? e +inf.f) "scheme_single_inf_object"] + [(eqv? e -inf.f) "scheme_single_minus_inf_object"] + [(eqv? e +nan.f) "scheme_single_nan_object"] + [else + (format "scheme_make_double(~a)" e)])] + [(boolean? e) (if e "scheme_true" "scheme_false")] + [(null? e) "scheme_null"] + [(void? e) "scheme_void"] + [(eq? unsafe-undefined e) "scheme_undefined"] + [(char? e) (format "scheme_make_character(~a)" (char->integer e))] + [else + (error 'generate-quote "not handled: ~e" e)])) + + (generate ret e env)) + +;; ---------------------------------------- + +(define (generate-tops e max-runstack-depth exports knowns top-names state lambdas prim-names prim-knowns) + (define runstack (make-runstack state)) + + (define (generate-tops e) + (generate-init-prims) + (out-next) + (out-open "void scheme_init_startup_instance(Scheme_Instance *c_instance) {") + (out "c_LINK_THREAD_LOCAL") + (out "Scheme_Object **c_runbase = c_current_runstack;") + (out "MZ_GC_DECL_REG(1);") + (out "MZ_GC_VAR_IN_REG(0, c_instance);") + (out "MZ_GC_REG();") + + (out "REGISTER_SO(c_top);") + (out "c_top = scheme_malloc(sizeof(struct startup_instance_top_t));") + + (out "c_check_top_runstack_depth(~a);" max-runstack-depth) + (generate-moved-to-top lambdas) + (generate-top e) + ;; Expects `([ ] ...)` for `exports` + (for ([ex (in-list exports)]) + (out "scheme_instance_add(c_instance, ~s, ~a);" + (format "~a" (cadr ex)) + (top-ref #f (no-c-prefix (car ex))))) + + (out "MZ_GC_UNREG();") + (out-close "}") + (runstack-max-depth runstack)) + + (define (generate-moved-to-top lambdas) + (for ([lam (in-sorted-hash-values lambdas (compare symbolku.multiple.array[~a];" s i))) + +;; ---------------------------------------- + +;; Recognize the patterns that the linklet flattener uses to record a +;; function's name within an S-expression, taking into account that lifting +;; may have pushed the pattern under a `let`: +(define (extract-lambda-name e) + (define (extract body) + (match body + [`(,e ,e2 . ,_) + (extract-one e)] + [`((begin . ,body)) + (extract body)] + [`((let ,binds . ,body)) (extract body)] + [`((letrec ,binds . ,body)) (extract body)] + [`((letrec* ,binds . ,body)) (extract body)] + [`,_ #f])) + (define (extract-one e) + (match e + [`(quote ,id) (and (symbol? id) id)] + [`(begin ,e . ,_) (extract-one e)] + [`,_ #f])) + (match e + [`(lambda ,_ . ,body) + (extract body)] + [`(case-lambda [,_ . ,body] . ,_) + (extract body)] + [`,_ #f])) + diff -Nru racket-6.12+ppa1/src/cify/id.rkt racket-7.0+ppa1/src/cify/id.rkt --- racket-6.12+ppa1/src/cify/id.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/id.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,78 @@ +#lang racket/base + +(provide no-c-prefix + cify + genid + reset-genid-counters!) + +;; The "c_" prefix is reserved for names that are provided +;; by the Racket glue or that we make up, where we choose +;; a prefix for any made-up name that won't conflict with +;; the Racket-glue names. +(define (no-c-prefix s) + (if (regexp-match? #rx"c_" (symbol->string s)) + (string->symbol (format "o_~a" s)) + s)) + +(define c-names (make-hasheq)) +(define used-names (make-hasheq)) + +;; Count reserved names as used, as well as anything +;; that doesn't fit the "c_..." or "scheme_..." pattern. +(for ([n (in-list '(void int long double short + if else return const goto switch case + SAME_OBJ))]) + (hash-set! used-names n #t)) + +(define replacements + '((#rx"!" "_B_") + (#rx"-" "_") + (#rx"[.]" "_T_") + (#rx"[?]" "_Q_") + (#rx"[+]" "_P_") + (#rx":" "_C_") + (#rx"/" "_S_") + (#rx"<" "_L_") + (#rx">" "_G_") + (#rx"#%" "_HP_") + (#rx"[*]" "_R_") + (#rx"[=]" "_E_") + (#rx"[$]" "_M_") + (#rx"#" "_H_") + (#rx"~" "_I") + (#rx"@" "_A_"))) + +(define (cify name) + (or (hash-ref c-names name #f) + (let* ([c-name + (string->symbol + (regexp-replace* + #rx"^(?=[0-9]|_[_A-Z]|scheme|SCHEME|Scheme|MZ_)" ; c_ prefix is avoided via `no-c-prefix` + (for/fold ([s (symbol->string name)]) ([r (in-list replacements)]) + (regexp-replace* (car r) s (cadr r))) + "o_"))] + [c-name (if (not (hash-ref used-names c-name #f)) + c-name + ;; collisions should be very rare + (let loop ([i 2]) + (define new-c-name (string->symbol (format "~a_~a" c-name i))) + (if (hash-ref used-names new-c-name #f) + (loop (add1 i)) + new-c-name)))]) + (hash-set! c-names name c-name) + (hash-set! used-names c-name #t) + c-name))) + +;; ---------------------------------------- + +(define compiler-ids (make-hasheq)) + +(define (genid in-s) + (define s (if (string? in-s) (string->symbol in-s) in-s)) + (define c (hash-ref compiler-ids s 0)) + (hash-set! compiler-ids s (add1 c)) + (string->symbol (format "~a~a" s c))) + +(define (reset-genid-counters! l) + (for ([c (in-list l)]) + (hash-set! compiler-ids c 0))) diff -Nru racket-6.12+ppa1/src/cify/inline.rkt racket-7.0+ppa1/src/cify/inline.rkt --- racket-6.12+ppa1/src/cify/inline.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/inline.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,152 @@ +#lang racket/base +(require "match.rkt" + "id.rkt" + "vehicle.rkt" + "struct.rkt") + +(provide inline-function + extract-inline-predicate) + +(define (inline-function rator n rands in-lam knowns #:can-gc? [can-gc? #t]) + (case rator + [(car unsafe-car) (and (= n 1) 'c_pair_car)] + [(cdr unsafe-cdr) (and (= n 1) 'c_pair_cdr)] + [(cadr) (and (= n 1) 'c_pair_cadr)] + [(cdar) (and (= n 1) 'c_pair_cdar)] + [(cddr) (and (= n 1) 'c_pair_cddr)] + [(caar) (and (= n 1) 'c_pair_caar)] + [(cons) (and (= n 2) can-gc? 'scheme_make_pair)] + [(list*) (and (= n 2) can-gc? 'scheme_make_pair)] + [(list) (and (or (= n 1) (= n 2)) can-gc? (if (= n 1) 'c_make_list1 'c_make_list2))] + [(unbox unsafe-unbox unbox* unsafe-unbox*) (and (= n 1) 'c_box_ref)] + [(weak-box-value) (and (or (= n 1) (= n 2)) 'c_weak_box_value)] + [(set-box! set-box*! unsafe-set-box! unsafe-set-box*!) (and (= n 2) 'c_box_set)] + [(vector-ref unsafe-vector-ref) (and (= n 2) 'c_vector_ref)] + [(vector*-ref unsafe-vector*-ref) (and (= n 2) 'c_authentic_vector_ref)] + [(vector-set! unsafe-vector-set! vector*-set! unsafe-vector*-set!) (and (= n 3) 'c_vector_set)] + [(vector-length unsafe-vector-length vector*-length unsafe-vector*-length) (and (= n 1) 'c_vector_length)] + [(string-ref unsafe-string-ref) (and (= n 2) can-gc? 'c_string_ref)] + [(bytes-ref unsafe-bytes-ref) (and (= n 2) 'c_bytes_ref)] + [(fx+ unsafe-fx+) (and (= n 2) 'c_int_add)] + [(fx- unsafe-fx-) (and (= n 2) 'c_int_sub)] + [(fx* unsafe-fx*) (and (= n 2) 'c_int_mult)] + [(fxrshift unsafe-fxrshift) (and (= n 2) 'c_int_rshift)] + [(fxand unsafe-fxand) (and (= n 2) 'c_int_and)] + [(add1) (and (= n 1) can-gc? 'c_number_add1)] + [(sub1) (and (= n 1) can-gc? 'c_number_sub1)] + [(hash-ref) (cond + [(= n 3) (and can-gc? (known-non-procedure? (caddr rands) knowns) 'c_hash_ref)] + [(= n 2) (and can-gc? 'c_hash_ref2)] + [else #f])] + [(hash-set) (and (= n 3) can-gc? 'c_hash_set)] + [(hash-count) (and (= n 1) can-gc? 'c_hash_count)] + [(hash-iterate-first) (and (= n 1) can-gc? 'c_hash_iterate_first)] + [(unsafe-immutable-hash-iterate-first) (and (= n 1) can-gc? 'c_unsafe_immutable_hash_iterate_first)] + [(unsafe-immutable-hash-iterate-next) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_next)] + [(unsafe-immutable-hash-iterate-key) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_key)] + [(unsafe-immutable-hash-iterate-key+value) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_key_value)] + [(prefab-struct-key) (and (= n 1) 'c_prefab_struct_key)] + [else + (define-values (pred-exprs pred-gc? pred-inliner) + (extract-inline-predicate (cons rator (for/list ([i (in-range n)]) 'c_unknown)) in-lam knowns)) + (cond + [(and pred-inliner + (or (not pred-gc?) can-gc?)) + (lambda (s) (format "(~a ? scheme_true : scheme_false)" (pred-inliner s)))] + [else + (define k (hash-ref knowns rator #f)) + (cond + [(and (struct-accessor? k) (= n 1)) + (lambda (s) + (if (struct-info-authentic? (struct-accessor-si k)) + (format "c_authentic_struct_ref(~a, ~a)" s (struct-accessor-pos k)) + (and can-gc? (format "c_struct_ref(~a, ~a)" s (struct-accessor-pos k)))))] + [(and (struct-mutator? k) (= n 2)) + (lambda (s) + (if (struct-info-authentic? (struct-mutator-si k)) + (format "c_authentic_struct_set(~a, ~a)" s (struct-mutator-pos k)) + (and can-gc? (format "c_struct_set(~a, ~a)" s (struct-mutator-pos k)))))] + [(and (struct-property-accessor? k) (= n 1)) + (and can-gc? + (lambda (s top-ref) + (format "c_struct_property_ref(~a, ~a)" s (top-ref (struct-property-accessor-property-id k)))))] + [else #f])])])) + +(define (extract-inline-predicate e in-lam knowns #:compose? [compose? #f]) + (define (compose e gc? wrapper) + (define-values (new-es new-gc? new-wrapper) (extract-inline-predicate e in-lam knowns #:compose? compose?)) + (values new-es (or gc? new-gc?) (lambda (s) (wrapper (new-wrapper s))))) + (define (generic e) + (if compose? + (values (list e) #f (lambda (s) (format "c_scheme_truep(~a)" s))) + (values #f #f #f))) + ;; simple => no GC + (define (simple template #:can-gc? [can-gc? #f] . args) + (values args can-gc? (lambda (s) (format template s)))) + (match e + [`(not ,e) + (if compose? + (compose e #f (lambda (s) (format "!~a" s))) + (values (list e) #f (lambda (s) (format "c_scheme_falsep(~a)" s))))] + [`(null? ,e) (simple "c_scheme_nullp(~a)" e)] + [`(eof-object? ,e) (simple "c_scheme_eof_objectp(~a)" e)] + [`(void? ,e) (simple "c_scheme_voidp(~a)" e)] + [`(boolean? ,e) (simple "c_scheme_boolp(~a)" e)] + [`(number? ,e) (simple "c_scheme_numberp(~a)" e)] + [`(pair? ,e) (simple "c_scheme_pairp(~a)" e)] + [`(list? ,e) (simple "c_scheme_listp(~a)" e)] + [`(vector? ,e) (simple "c_scheme_chaperone_vectorp(~a)" e)] + [`(box? ,e) (simple "c_scheme_chaperone_boxp(~a)" e)] + [`(symbol? ,e) (simple "c_scheme_symbolp(~a)" e)] + [`(keyword? ,e) (simple "c_scheme_keywordp(~a)" e)] + [`(string? ,e) (simple "c_scheme_char_stringp(~a)" e)] + [`(bytes? ,e) (simple "c_scheme_byte_stringp(~a)" e)] + [`(path? ,e) (simple "c_scheme_pathp(~a)" e)] + [`(char? ,e) (simple "c_scheme_charp(~a)" e)] + [`(hash? ,e) (simple "c_scheme_hashp(~a)" e)] + [`(eq? ,e1 ,e2) (simple "c_same_obj(~a)" e1 e2)] + [`(eqv? ,e1 ,e2) (simple "scheme_eqv(~a)" e1 e2)] + [`(equal? ,e1 ,e2) (simple #:can-gc? #t "scheme_equal(~a)"e1 e2)] + [`(char=? ,e1 ,e2) (simple "c_scheme_char_eq(~a)" e1 e2)] + [`(char-whitespace? ,e) (simple "c_scheme_char_whitespacep(~a)" e)] + [`(unsafe-fx< ,e1 ,e2) (simple "c_int_lt(~a)" e1 e2)] + [`(fx< ,e1 ,e2) (simple "c_int_lt(~a)" e1 e2)] + [`(unsafe-fx> ,e1 ,e2) (simple "c_int_gt(~a)" e1 e2)] + [`(fx> ,e1 ,e2) (simple "c_int_gt(~a)" e1 e2)] + [`(unsafe-fx>= ,e1 ,e2) (simple "!c_int_lt(~a)" e1 e2)] + [`(fx>= ,e1 ,e2) (simple "!c_int_lt(~a)" e1 e2)] + [`(unsafe-fx<= ,e1 ,e2) (simple "!c_int_gt(~a)" e1 e2)] + [`(fx<= ,e1 ,e2) (simple "!c_int_gt(~a)" e1 e2)] + [`(unsafe-fx= ,e1 ,e2) (simple "c_same_obj(~a)" e1 e2)] + [`(fx= ,e1 ,e2) (simple "c_same_obj(~a)" e1 e2)] + [`(= ,e1 ,e2) (simple #:can-gc? #t "c_number_eq(~a)" e1 e2)] + [`(< ,e1 ,e2) (simple #:can-gc? #t "c_number_lt(~a)" e1 e2)] + [`(> ,e1 ,e2) (simple #:can-gc? #t "c_number_gt(~a)" e1 e2)] + [`(<= ,e1 ,e2) (simple #:can-gc? #t "c_number_lt_eq(~a)" e1 e2)] + [`(>= ,e1 ,e2) (simple #:can-gc? #t "c_number_gt_eq(~a)" e1 e2)] + [`(zero? ,e) (simple "c_number_zerop(~a)" e)] + [`(,rator ,rand) + (define k (and (symbol? rator) + (hash-ref knowns rator #f))) + (cond + [(struct-predicate? k) + (define si (struct-predicate-si k)) + (define s-id (struct-info-struct-id si)) + (values (list rand) + #f + (cond + [(struct-info-authentic? si) + (lambda (s) (format "c_is_authentic_struct_instance(~a, ~a)" s (top-ref in-lam s-id)))] + [else + (lambda (s) (format "c_is_struct_instance(~a, ~a)" s (top-ref in-lam s-id)))]))] + [else (generic e)])] + [`,_ (generic e)])) + +(define (known-non-procedure? e knowns) + (or (boolean? e) + (number? e) + (eq? e 'null) + (and (symbol? e) + (let ([k (hash-ref knowns e #f)]) + (or (symbol? k) + (eq? k '#:non-procedure)))))) diff -Nru racket-6.12+ppa1/src/cify/lambda.rkt racket-7.0+ppa1/src/cify/lambda.rkt --- racket-6.12+ppa1/src/cify/lambda.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/lambda.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,58 @@ +#lang racket/base +(require "match.rkt" + "vehicle.rkt" + "id.rkt") + +;; See also "vehicle.rkt" for the `lam` structure type. + +(provide extract-lambdas!) + +(define (extract-lambdas! lambdas e) + (match e + [`(define ,id ,rhs) + (extract-lambdas! lambdas rhs)] + [`(define-values ,_ ,rhs) + (extract-lambdas! lambdas rhs)] + [`(begin ,es ...) + (for ([e (in-list es)]) + (extract-lambdas! lambdas e))] + [`(begin0 ,es ...) + (extract-lambdas! lambdas `(begin . ,es))] + [`(lambda ,ids . ,body) + (hash-set! lambdas e (make-lam (genid 'c_lambda) e)) + (extract-lambdas! lambdas `(begin . ,body))] + [`(case-lambda [,idss . ,bodys] ...) + (hash-set! lambdas e (make-lam (genid 'c_case_lambda) e)) + (for ([ids (in-list idss)] + [body (in-list bodys)]) + (extract-lambdas! lambdas `(begin . ,body)))] + [`(quote ,_) lambdas] + [`(if ,tst ,thn ,els) + (extract-lambdas! lambdas tst) + (extract-lambdas! lambdas thn) + (extract-lambdas! lambdas els)] + [`(with-continuation-mark ,key ,val ,body) + (extract-lambdas! lambdas key) + (extract-lambdas! lambdas val) + (extract-lambdas! lambdas body)] + [`(let . ,_) + (extract-let-lambdas! lambdas e)] + [`(letrec . ,_) + (extract-let-lambdas! lambdas e)] + [`(letrec* . ,_) + (extract-let-lambdas! lambdas e)] + [`(set! ,id ,rhs) + (extract-lambdas! lambdas rhs)] + [`(call-with-values (lambda () . ,body1) (lambda (,ids ...) . ,body2)) + (extract-lambdas! lambdas `(begin . ,body1)) + (extract-lambdas! lambdas `(begin . ,body2))] + [`(,rator ,rands ...) + (extract-lambdas! lambdas `(begin ,rator . ,rands))] + [`,_ (void)])) + +(define (extract-let-lambdas! lambdas e) + (match e + [`(,let-id ([,ids ,rhss] ...) . ,body) + (for ([rhs (in-list rhss)]) + (extract-lambdas! lambdas rhs)) + (extract-lambdas! lambdas `(begin . ,body))])) diff -Nru racket-6.12+ppa1/src/cify/main.rkt racket-7.0+ppa1/src/cify/main.rkt --- racket-6.12+ppa1/src/cify/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,129 @@ +#lang racket/base +(require racket/list + racket/port + "match.rkt" + "out.rkt" + "prune.rkt" + "unique.rkt" + "sort.rkt" + "id.rkt" + "vehicle.rkt" + "top-name.rkt" + "prim-name.rkt" + "ref.rkt" + "function.rkt" + "state.rkt" + "generate.rkt" + "lambda.rkt" + "struct.rkt" + "union.rkt" + "debug.rkt") + +(provide (rename-out [main-cify cify])) + +(define (main-cify out-file exports in-e prim-knowns + #:debug? [debug? #f] + #:preamble [preamble '()] + #:postamble [postamble '()]) + (current-debug debug?) + (call-with-output-file* + out-file + #:exists 'truncate/replace + (lambda (out) + (parameterize ([current-c-output-port out]) + (for-each out-exact preamble) + (to-c exports in-e prim-knowns) + (for-each out-exact postamble))))) + +;; ---------------------------------------- + +(define (to-c exports in-e prim-knowns) + (generate-header) + + ;; Inlining may have made some definitions useless: + (define pruned-e (prune-unused in-e exports)) + + ;; Make sure all names are unique: + (define unique-e (re-unique pruned-e)) + + ;; Find all `define`d names and `let[rec[*]]` names that are + ;; flattend into the top sequence: + (define top-names (extract-top-names #hasheq() unique-e)) + + ;; Find all the primitives that we'll need to call: + (define prim-names (extract-prim-names unique-e top-names)) + + ;; Find mutable variables, which will need to be boxed: + (define state (make-state)) + (extract-state! state unique-e) + + ;; Wrap `ref` around every local-variable reference. Also, + ;; perform copy propagation: + (define e (wrap-ref unique-e top-names prim-names state)) + + ;; Find all `lambda`s and `case-lambda`s, mapping each to + ;; a newly synthesized name: + (define lambdas (make-hasheq)) + (extract-lambdas! lambdas e) + + (define struct-knowns (extract-structs e)) + + ;; Find all functions that do not need to be kept in a closure. + ;; Top-level functions and functions bound with `letrec` are in this + ;; category: + (define functions (extract-functions #hasheq() e lambdas)) + (for ([(id f) (in-sorted-hash functions symbol 'local or distance from stack start + need-inits ; set of pushed vars that are not yet initialized + unsynced ; pushed vars that haven't yet lived through a GC boundary + unsynced-refs ; per-var refs that haven't yet lived through a GC boundary + all-refs ; per-var, all references encountered + staged-clears ; clears staged by branching + ever-synced?) ; whether the runstack is ever synced + #:mutable) + +(define (make-runstack state) + (define rs-state (or (hash-ref state '#:runstack #f) + (let ([ht (make-hasheq)]) + (hash-set! state '#:runstack ht) + ht))) + (runstack rs-state + 0 ; depth + 0 ; max-depth + #f ; sync-depth + '() ; vars + (make-hasheq) ; var-depths + (make-hasheq) ; need-inits + (make-hasheq) ; unsyned + (make-hasheq) ; unsynced-refs + #hasheq() ; all-refs + #hasheq() ; staged-clears + #f)) ; ever-synced? + +(define (runstack-push! rs id + #:referenced? [referenced? #t] + #:local? [local? #f] + #:track-local? [track-local? #f]) + (set-runstack-vars! rs (cons id (runstack-vars rs))) + (cond + [(or local? + (and track-local? + referenced? + (eq? 'local (hash-ref (runstack-rs-state rs) id #f)))) + ;; A previous pass determined that this variable will not + ;; live across a GC boundary, so it can be stored in a C local. + ;; Note that we're sharing a global table, even though an id + ;; can have different extents due to closures; but only `let` + ;; bindings are "tracked", and each of those is unique. + (hash-set! (runstack-var-depths rs) id 'local) + (out "Scheme_Object *~a;" (cify id))] + [else + (define depth (add1 (runstack-depth rs))) + (set-runstack-depth! rs depth) + (set-runstack-max-depth! rs (max depth (runstack-max-depth rs))) + (hash-set! (runstack-var-depths rs) id depth) + (hash-set! (runstack-need-inits rs) id #t) + (hash-set! (runstack-unsynced rs) id #t) + (out "~aconst int ~a = -~a;~a" + (if referenced? "" "/* ") + (cify id) depth + (if referenced? "" " */"))])) + +(define (runstack-pop! rs [n 1] + #:track-local? [track-local? #f]) + (define var-depths (runstack-var-depths rs)) + (let loop ([n n]) + (unless (zero? n) + (define var (car (runstack-vars rs))) + (unless (eq? 'local (hash-ref var-depths var #f)) + (set-runstack-depth! rs (- (runstack-depth rs) 1)) + (hash-remove! (runstack-need-inits rs) var) + (when (hash-ref (runstack-unsynced rs) var #f) + (when track-local? + (hash-set! (runstack-rs-state rs) var 'local)) + (hash-remove! (runstack-unsynced rs) var)) + (let ([refs (hash-ref (runstack-unsynced-refs rs) var '())]) + (hash-remove! (runstack-unsynced-refs rs) var) + (for ([ref (in-list refs)]) + (set-ref-last-use?! ref #f)))) + (set-runstack-vars! rs (cdr (runstack-vars rs))) + (set-runstack-all-refs! rs (hash-remove (runstack-all-refs rs) var)) + (hash-remove! var-depths var) + (set-runstack-staged-clears! rs (hash-remove (runstack-staged-clears rs) var)) + (loop (sub1 n))))) + +(define (runstack-ref rs id #:assign? [assign? #f] #:ref [ref #f] #:values-ok? [values-ok? #f]) + (when ref + (runstack-ref-use! rs ref) + ;; Remember the ref, so we can clear its `last-use?` if no sync + ;; happens before the variable is popped + (hash-set! (runstack-unsynced-refs rs) id + (cons ref (hash-ref (runstack-unsynced-refs rs) id '())))) + (define s + (cond + [(eq? 'local (hash-ref (runstack-var-depths rs) id #f)) + (format "~a" (cify id))] + [(and ref (ref-last-use? ref)) + (format "c_last_use(c_runbase, ~a)" (cify id))] + [else + (format "c_runbase[~a]" (cify id))])) + (if (and (current-debug) (not values-ok?) (not assign?)) + (format "c_validate(~a)" s) + s)) + +(define (runstack-ref-use! rs ref) + (set-runstack-all-refs! rs (hash-set2 (runstack-all-refs rs) (ref-id ref) ref #t))) + +(define (runstack-assign rs id) + (hash-remove! (runstack-need-inits rs) id) + (runstack-ref rs id #:assign? #t)) + +(define (make-runstack-assign rs id) + (lambda (s) (out "~a = ~a;" (runstack-assign rs id) s))) + +(define (runstack-stack-ref rs) + (format "(c_runbase-~a)" (runstack-depth rs))) + +(define (runstack-ref-pos rs id) + (hash-ref (runstack-var-depths rs) id #f)) + +(define (runstack-sync! rs) + (set-runstack-ever-synced?! rs #t) + (hash-clear! (runstack-unsynced rs)) + (hash-clear! (runstack-unsynced-refs rs)) + (runstack-generate-staged-clears! rs) + (define vars (sort (hash-keys (runstack-need-inits rs)) symbol . (hash-count a)) + (union-unsynced-refs! b a c)] + [((hash-count c) . > . (hash-count b)) + (union-unsynced-refs! a c b)] + [else + (union-unsynced-refs! a b) + (union-unsynced-refs! a c)])] + [(a b) + (for ([(id l) (in-hash b)]) + (hash-set! a id (append l (hash-ref a id '())))) + a])) + +(define union-all-refs + (case-lambda + [(a b c) + (cond + [((hash-count b) . > . (hash-count a)) + (union-all-refs b a c)] + [((hash-count c) . > . (hash-count b)) + (union-all-refs a c b)] + [else + (union-all-refs (union-all-refs a b) c)])] + [(a b) + (for/fold ([a a]) ([(id b-refs) (in-hash b)]) + (define a-refs (hash-ref a id #hasheq())) + (hash-set a id (hash-union a-refs b-refs)))])) + +(define (hash-set2 ht key key2 val) + (hash-set ht key + (hash-set (hash-ref ht key #hasheq()) + key2 + val))) + +;; ---------------------------------------- + +;; If `other-refs` includes a last use of a variable that +;; is not referenced in `my-refs`, then stage a clear +;; operation for space safety. The clear operation is emitted +;; only if the variable is still live by the time the runstack +;; is synced. +(define (runstack-stage-clear-unused! rs my-refs other-refs state) + (for* ([refs (in-hash-values other-refs)] + [ref (in-hash-keys refs)]) + (define id (ref-id ref)) + (when (and (ref-last-use? ref) + (not (hash-ref my-refs id #f))) + (runstack-stage-clear! rs id state)))) + +;; A danger of lazy clearing is that we might push the same +;; clearing operation to two different branches. It would be +;; better to clear eagerly at the start of a branch if there +;; will definitely by a sync point later, but we don't currently +;; have the "sync point later?" information. +(define (runstack-stage-clear! rs id state) + (set-runstack-staged-clears! + rs + (hash-set (runstack-staged-clears rs) + id + ;; the `get-pos` thunk: + (lambda () + (cond + [(not (referenced? (hash-ref state id #f))) + ;; This can happen in we need to clear a variable that is + ;; otherwise only implicitly passed in a tail call: + (format "-~a /* ~a */" (runstack-ref-pos rs id) (cify id))] + [else + (cify id)]))))) + +(define (runstack-generate-staged-clears! rs) + (for ([(id get-pos) (in-sorted-hash (runstack-staged-clears rs) symbol (lambda (new-id) (format "~a" (cify new-id)))] + [else + (ref-use! e state) + (runstack-ref runstack id #:ref e)])] + [(or (hash-ref top-names e #f) + (hash-ref knowns e #f)) + (format "~a" (top-ref in-lam e))] + [(hash-ref prim-names e #f) + (cond + [(eq? e 'null) "scheme_null"] + [(eq? e 'eof-object) "scheme_eof"] + [(eq? e 'unsafe-undefined) "scheme_undefined"] + [else (format "c_prims.~a" (cify e))])] + [else (runstack-ref runstack e)])] + [else + (define inliner (inline-function (car e) (length (cdr e)) (cdr e) in-lam knowns)) + (define args (apply string-append + (append + (add-between + (for/list ([e (in-list (cdr e))]) + (format "~a" (generate-simple e))) + ", ")))) + (cond + [(procedure? inliner) (if (procedure-arity-includes? inliner 2) + (inliner args (lambda (id) (top-ref in-lam id))) + (inliner args))] + [else + (format "~a(~a)" inliner args)])])) + (generate-simple e)) + +;; ---------------------------------------- + +(define (simple-quote? e) + (or (always-fixnum? e) + (boolean? e) + (null? e) + (void? e) + (and (char? e) + (<= 0 (char->integer e) 255)))) + +(define (always-fixnum? e) + (and (integer? e) + (exact? e) + (<= (- (expt 2 30)) e (sub1 (expt 2 30))))) diff -Nru racket-6.12+ppa1/src/cify/sort.rkt racket-7.0+ppa1/src/cify/sort.rkt --- racket-6.12+ppa1/src/cify/sort.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cify/sort.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base + +(provide in-sorted-hash + in-sorted-hash-keys + in-sorted-hash-values + + compare) + +(define (in-sorted-hash ht GC-independent leaf + +(struct vehicle ([id #:mutable] + [lams #:mutable] + [closure? #:mutable] + [uses-top? #:mutable] + [min-argc #:mutable] + [max-jump-argc #:mutable] + [max-runstack-depth #:mutable] + [called-direct? #:mutable] ; if the vehicle can be called directly + [calls-non-immediate? #:mutable])) + +(define (make-lam id e) + (define-values (min-argc max-argc) (lambda-arity e)) + (define a-vehicle (vehicle id '() #f #f min-argc 0 0 #f #f)) + (define a-lam (lam id e #f #f (make-hasheqv) 0 #f a-vehicle 0 #f #f #f #f #hasheq() #f)) + (set-vehicle-lams! a-vehicle (list a-lam)) + a-lam) + +(define (top-ref in-lam id) + (when in-lam + (set-vehicle-uses-top?! (lam-vehicle in-lam) #t)) + (format "c_top->~a" (cify id))) + +(define (lam-calls-non-immediate! in-lam) + (when in-lam + (set-vehicle-calls-non-immediate?! (lam-vehicle in-lam) #t))) + +(define (lam-called-direct! in-lam) + (when in-lam + (set-vehicle-called-direct?! (lam-vehicle in-lam) #t))) + +(define (lam-add-transitive-tail-apply! lam target-lam) + (set-lam-transitive-tail-applies! + lam + (hash-set (lam-transitive-tail-applies lam) target-lam #t))) + +(define (merge-vehicles! lambdas state) + (define vehicles + (for/fold ([vehicles #hash()]) ([lam (in-sorted-hash-values lambdas (compare symbol&5 @@ -5011,6 +5049,9 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $set_strip_lib" >&5 $as_echo "$set_strip_lib" >&6; } + if test "${strip_needs_dash_s}" = "yes" ; then + STRIP_DEBUG="${STRIP_LIB_DEBUG}" + fi fi fi @@ -6597,11 +6638,13 @@ RUN_RACKET_MMM='$(RUN_THIS_RACKET_MMM)' RUN_RACKET_MAIN_VARIANT='$(RUN_THIS_RACKET_MAIN_VARIANT)' CGC_IF_NEEDED_FOR_MMM="cgc" + BOOT_MODE="--boot" else RUN_RACKET_CGC="${enable_racket}" RUN_RACKET_MMM="${enable_racket}" RUN_RACKET_MAIN_VARIANT="${enable_racket}" CGC_IF_NEEDED_FOR_MMM="no-cgc-needed" + BOOT_MODE="--chain" fi ############## libtool ################ @@ -6688,6 +6731,11 @@ + + + + + diff -Nru racket-6.12+ppa1/src/cs/absify.rkt racket-7.0+ppa1/src/cs/absify.rkt --- racket-6.12+ppa1/src/cs/absify.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/absify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base +(require racket/cmdline + racket/path) + +(define same-up? #f) +(define exec? #f) + +(define-values (orig-p extras) + (command-line + #:once-each + [("--same-up") "Leave path alone if it starts \"..\"" + (set! same-up? #t)] + [("--exec") "Find executable path" + (set! exec? #t)] + #:args + (path . extra) + (values path extra))) + +(cond + [(and same-up? + (eq? (car (explode-path orig-p)) 'up)) + (display orig-p)] + [else + (define p + (if exec? + (let ([p orig-p]) + (if (path-element? (string->path p)) + (or (find-executable-path p) + p) + p)) + orig-p)) + + (display (simplify-path (path->complete-path p)))]) + +;; In case there are extra arguments to an executable, preserve them +(for ([e (in-list extras)]) + (display " ") + (display e)) + +(newline) diff -Nru racket-6.12+ppa1/src/cs/c/boot.c racket-7.0+ppa1/src/cs/c/boot.c --- racket-6.12+ppa1/src/cs/c/boot.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/boot.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,146 @@ +#ifndef _MSC_VER +# include +#endif +#include +#include +#include +#include +#include "scheme.h" +#include "rktio.h" +#include "boot.h" + +#if defined(_MSC_VER) || defined(__MINGW32__) +# define BOOT_O_BINARY O_BINARY +#endif + +#ifndef BOOT_O_BINARY +# define BOOT_O_BINARY 0 +#endif + +#if defined(OS_X) && !defined(RACKET_XONX) + +# include +# define RACKET_USE_FRAMEWORK + +const char *get_framework_path() { + int i, c, len; + const char *s; + + c = _dyld_image_count(); + for (i = 0; i < c; i++) { + s = _dyld_get_image_name(i); + len = strlen(s); + if ((len > 9) && !strcmp("CS/Racket", s + len - 9)) { + char *s2; + s2 = strdup(s); + strcpy(s2 + len - 6, "boot"); + return s2; + } + } + + return "???"; +} + +char *path_append(const char *p1, char *p2) { + int l1, l2; + char *s; + l1 = strlen(p1); + l2 = strlen(p2); + s = malloc(l1 + l2 + 2); + memcpy(s, p1, l1); + s[l1] = '/'; + memcpy(s + l1 + 1, p2, l2); + s[l1+l2+1] = 0; + return s; +} + +#endif + +static ptr Sbytevector(char *s) +{ + iptr len = strlen(s); + ptr bv; + bv = Smake_bytevector(len, 0); + memcpy(Sbytevector_data(bv), s, len); + return bv; +} + +static void racket_exit(int v) +{ + exit(v); +} + +void racket_boot(int argc, char **argv, char *self, long segment_offset, + char *coldir, char *configdir, + int pos1, int pos2, int pos3, + int is_gui) +/* exe argument already stripped from argv */ +{ + int fd; +#ifdef RACKET_USE_FRAMEWORK + const char *fw_path; +#endif + + Sscheme_init(NULL); + +#ifdef RACKET_USE_FRAMEWORK + fw_path = get_framework_path(); + Sregister_boot_file(path_append(fw_path, "petite.boot")); + Sregister_boot_file(path_append(fw_path, "scheme.boot")); +#else + fd = open(self, O_RDONLY | BOOT_O_BINARY); + + { + int fd1, fd2; + + fd1 = dup(fd); + lseek(fd1, pos1, SEEK_SET); + Sregister_boot_file_fd("petite", fd1); + + fd2 = open(self, O_RDONLY | BOOT_O_BINARY); + lseek(fd2, pos2, SEEK_SET); + Sregister_boot_file_fd("scheme", fd2); + } +#endif + + Sbuild_heap(NULL, NULL); + +# include "rktio.inc" + Sforeign_symbol("racket_exit", (void *)racket_exit); + + { + ptr l = Snil; + int i; + char segment_offset_s[32]; + + for (i = argc; i--; ) { + l = Scons(Sbytevector(argv[i]), l); + } + l = Scons(Sbytevector(is_gui ? "true" : "false"), l); + sprintf(segment_offset_s, "%ld", segment_offset); + l = Scons(Sbytevector(segment_offset_s), l); + l = Scons(Sbytevector(configdir), l); + l = Scons(Sbytevector(coldir), l); + l = Scons(Sbytevector(self), l); + Sset_top_level_value(Sstring_to_symbol("bytes-command-line-arguments"), l); + } + +#ifdef RACKET_USE_FRAMEWORK + fd = open(path_append(fw_path, "racket.so"), O_RDONLY); + pos3 = 0; +#endif + + { + ptr c, p; + + if (pos3) lseek(fd, pos3, SEEK_SET); + c = Stop_level_value(Sstring_to_symbol("open-fd-input-port")); + p = Scall1(c, Sfixnum(fd)); + Slock_object(p); + c = Stop_level_value(Sstring_to_symbol("port-file-compressed!")); + Scall1(c, p); + Sunlock_object(p); + c = Stop_level_value(Sstring_to_symbol("load-compiled-from-port")); + Scall1(c, p); + } +} diff -Nru racket-6.12+ppa1/src/cs/c/boot.h racket-7.0+ppa1/src/cs/c/boot.h --- racket-6.12+ppa1/src/cs/c/boot.h 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/boot.h 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +void racket_boot(int argc, char **argv, char *self, long segment_offset, + char *coldir, char *configdir, + int pos1, int pos2, int pos3, + int is_gui); diff -Nru racket-6.12+ppa1/src/cs/c/configure racket-7.0+ppa1/src/cs/c/configure --- racket-6.12+ppa1/src/cs/c/configure 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/configure 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5202 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +ac_unique_file="embed-boot.rkt" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef STDC_HEADERS +# include +# include +#else +# ifdef HAVE_STDLIB_H +# include +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include +# endif +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='LTLIBOBJS +LIBOBJS +FRAMEWORK_PREFIX +FRAMEWORK_INSTALL_DIR +SCHEME_CONFIG_ARGS +SCHEME_SRC +CONFIGURE_RACKET_SO_COMPILE +NOT_OSX +OSX +MACH +SCHEME_DIR +RACKET +INCLUDEDEP +RKTLINKER +ICP +STATIC_AR +RANLIB +ARFLAGS +AR +EGREP +GREP +CPP +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +target_os +target_vendor +target_cpu +target +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_shared +enable_standalone +enable_pthread +enable_iconv +enable_xonx +enable_racket +enable_scheme +enable_mach +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] + --target=TARGET configure for building compilers for TARGET [HOST] +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-shared create shared libraries (ok, but not recommended) + --enable-standalone create a standalone shared library + --enable-pthread link with pthreads (usually auto-enabled if needed) + --enable-iconv use iconv (usually auto-enabled) + --enable-xonx use Unix style (e.g., use Gtk) for Mac OS + --enable-racket= use as Racket to build; or "auto" to create + --enable-scheme= Chez Scheme build directory at + --enable-mach= Use Chez Scheme machine type + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +ac_config_headers="$ac_config_headers cs_config.h" + + +ac_aux_dir= +for ac_dir in ../../lt "$srcdir"/../../lt; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in ../../lt \"$srcdir\"/../../lt" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +$as_echo_n "checking build system type... " >&6; } +if ${ac_cv_build+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +$as_echo "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +$as_echo_n "checking host system type... " >&6; } +if ${ac_cv_host+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +$as_echo "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 +$as_echo_n "checking target system type... " >&6; } +if ${ac_cv_target+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$target_alias" = x; then + ac_cv_target=$ac_cv_host +else + ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 +$as_echo "$ac_cv_target" >&6; } +case $ac_cv_target in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; +esac +target=$ac_cv_target +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_target +shift +target_cpu=$1 +target_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +target_os=$* +IFS=$ac_save_IFS +case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac + + +# The aliases save the names the user supplied, while $host etc. +# will get canonicalized. +test -n "$target_alias" && + test "$program_prefix$program_suffix$program_transform_name" = \ + NONENONEs,x,x, && + program_prefix=${target_alias}- + + +# Check whether --enable-shared was given. +if test "${enable_shared+set}" = set; then : + enableval=$enable_shared; +fi + +# Check whether --enable-standalone was given. +if test "${enable_standalone+set}" = set; then : + enableval=$enable_standalone; +fi + +# Check whether --enable-pthread was given. +if test "${enable_pthread+set}" = set; then : + enableval=$enable_pthread; +fi + +# Check whether --enable-iconv was given. +if test "${enable_iconv+set}" = set; then : + enableval=$enable_iconv; +fi + +# Check whether --enable-xonx was given. +if test "${enable_xonx+set}" = set; then : + enableval=$enable_xonx; +fi + +# Check whether --enable-racket was given. +if test "${enable_racket+set}" = set; then : + enableval=$enable_racket; +fi + +# Check whether --enable-scheme was given. +if test "${enable_scheme+set}" = set; then : + enableval=$enable_scheme; +fi + +# Check whether --enable-mach was given. +if test "${enable_mach+set}" = set; then : + enableval=$enable_mach; +fi + + +show_explicitly_disabled() +{ + if test "$1" = "no" ; then + echo "=== $2 disabled" + fi +} + +show_explicitly_enabled() +{ + if test "$1" = "yes" ; then + echo "=== $2 enabled" + if test "$3" != "" ; then + echo " $3" + fi + fi +} + +show_explicitly_set() +{ + if test "$1" != "" ; then + echo "=== $2 set to $1" + fi +} + +show_explicitly_enabled "${enable_pthread}" "pthreads" +show_explicitly_disabled "${enable_pthread}" "pthreads" +show_explicitly_enabled "${enable_xonx}" "Unix style" +show_explicitly_set "${enable_racket}" "Racket" +show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" +show_explicitly_set "${enable_mach}" "machine type" + +if test "${enable_iconv}" = "" ; then + enable_iconv=yes +fi + +if test "${enable_xonx}" == "" ; then + enable_xonx=no +fi + +skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no + +INCLUDEDEP="#" +OSX="not_osx" +NOT_OSX="" +CONFIGURE_RACKET_SO_COMPILE="" + +FRAMEWORK_INSTALL_DIR='$(srcdir)/../../../lib/' +FRAMEWORK_PREFIX='@executable_path/../lib/' + +RACKET='$(DEFAULT_RACKET)' + +enable_pthread_by_default=yes + +###### Autoconfigure ####### + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +# If using gcc, we want all warnings: +if test "$CC" = "gcc" ; then + CFLAGS="$CFLAGS -Wall" +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fmod in -lm" >&5 +$as_echo_n "checking for fmod in -lm... " >&6; } +if ${ac_cv_lib_m_fmod+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char fmod (); +int +main () +{ +return fmod (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_m_fmod=yes +else + ac_cv_lib_m_fmod=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_fmod" >&5 +$as_echo "$ac_cv_lib_m_fmod" >&6; } +if test "x$ac_cv_lib_m_fmod" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBM 1 +_ACEOF + + LIBS="-lm $LIBS" + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +$as_echo_n "checking for dlopen in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int +main () +{ +return dlopen (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlopen=yes +else + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +$as_echo "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBDL 1 +_ACEOF + + LIBS="-ldl $LIBS" + +fi + + +############## platform tests ################ + +case "$host_os" in + solaris2*) + MACH_OS=s2 + ;; + aix*) + ;; + *freebsd*) + MACH_OS=fb + ;; + openbsd*) + MACH_OS=ob + ;; + bitrig*) + ;; + dragonfly*) + ;; + netbsd*) + MACH_OS=nb + ;; + irix*) + ;; + linux*) + MACH_OS=le + LIBS="${LIBS} -lncurses" + ;; + osf1*) + ;; + hpux*) + ;; + *mingw*) + skip_iconv_check=yes + ;; + cygwin*) + ;; + darwin*) + PREFLAGS="$PREFLAGS -DOS_X" + MACH_OS=osx + LIBS="${LIBS} -lncurses -framework CoreFoundation" + if test "${enable_xonx}" == "no" ; then + INCLUDEDEP="-include" + OSX="" + NOT_OSX="osx" + else + CONFIGURE_RACKET_SO_COMPILE="env PLT_CS_MAKE_UNIX_STYLE_MACOS=y" + CPPFLAGS="${CPPFLAGS} -DRACKET_XONX" + fi + + # -pthread is not needed and triggers a warning + use_flag_pthread=no + ;; + nto-qnx*) + MACH_OS=qnx + use_flag_pthread=no + ;; + *) + ;; +esac + +case "$host_cpu" in + arm*) + enable_pthread_by_default=no + ;; +esac + +if test "${enable_pthread}" = "" ; then + if test "${enable_pthread_by_default}" = "yes" ; then + enable_pthread=yes + fi +fi + +thread_prefix="" +thread_config_arg="" +if test "${enable_pthread}" = "yes" ; then + thread_prefix="t" + thread_config_arg="--threads" +fi + +case "$host_cpu" in + x86_64) + MACH="${thread_prefix}a6${MACH_OS}" + ;; + x86|i*86) + MACH="${thread_prefix}i3${MACH_OS}" + ;; + arm*) + MACH="${thread_prefix}arm32${MACH_OS}" + ;; + power*) + MACH="${thread_prefix}ppc32${MACH_OS}" + ;; +esac + +SCHEME_SRC=../ChezScheme + +if test "${enable_scheme}" != "" ; then + SCHEME_SRC="${enable_scheme}" +fi + +if test "${enable_racket}" != "" ; then + RACKET="${enable_racket}" +fi + +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg}" + +############## C flags ################ + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +iconv_lib_flag="" +if test "${skip_iconv_check}" = "no" ; then + if test "${enable_iconv}" = "yes" ; then + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +$as_echo_n "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +$as_echo "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +$as_echo_n "checking for grep that handles long lines and -e... " >&6; } +if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +$as_echo "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +$as_echo_n "checking for egrep... " >&6; } +if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +$as_echo "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 +$as_echo_n "checking for ANSI C header files... " >&6; } +if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_stdc=yes +else + ac_cv_header_stdc=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then : + : +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +else + ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 +$as_echo "$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +$as_echo "#define STDC_HEADERS 1" >>confdefs.h + +fi + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +ac_fn_c_check_header_mongrel "$LINENO" "iconv.h" "ac_cv_header_iconv_h" "$ac_includes_default" +if test "x$ac_cv_header_iconv_h" = xyes; then : + enable_iconv=yes +else + enable_iconv=no +fi + + + if test "${enable_iconv}" = "yes" ; then + # Does it all work, now? + if test "$cross_compiling" = yes; then : + enable_iconv=yes +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + #include + #include + int main() { + iconv_open("UTF-8", "UTF-8"); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + enable_iconv=yes +else + enable_iconv=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "${enable_iconv}" = "no" ; then + # Try adding -liconv ? + # We did not use AC_CHECK_LIB because iconv is sometimes macro-renamed + ORIG_LIBS="$LIBS" + LIBS="$LIBS -liconv" + if test "$cross_compiling" = yes; then : + enable_iconv=yes +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + #include + #include + int main() { + iconv_open("UTF-8", "UTF-8"); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + enable_iconv=yes +else + enable_iconv=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "${enable_iconv}" = "no" ; then + LIBS="$ORIG_LIBS" + else + iconv_lib_flag=" -liconv" + fi + fi + fi + fi + msg="iconv is usable" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking $msg" >&5 +$as_echo_n "checking $msg... " >&6; } + iconv_usage_result="$enable_iconv$iconv_lib_flag" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $iconv_usage_result" >&5 +$as_echo "$iconv_usage_result" >&6; } +fi +if test "${enable_iconv}" = "no" ; then + +$as_echo "#define RKTIO_NO_ICONV 1" >>confdefs.h + +fi + +if test "${enable_iconv}" = "yes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for nl_langinfo (CODESET)" >&5 +$as_echo_n "checking for nl_langinfo (CODESET)... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +char *codeset = nl_langinfo (CODESET); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + +$as_echo "#define RKTIO_HAVE_CODESET 1" >>confdefs.h + + have_codeset=yes +else + have_codeset=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_codeset" >&5 +$as_echo "$have_codeset" >&6; } +fi + +############### pthread ################### + +if test "${enable_pthread}" = "yes" ; then + if test "${use_flag_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + fi + if test "${use_flag_posix_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -D_POSIX_PTHREAD_SEMANTICS -D_REENTRANT" + fi + +$as_echo "#define RKTIO_USE_PTHREADS 1" >>confdefs.h + +fi + +############## libtool ################ + +if test "${enable_shared}" = "yes" ; then + echo "Configuring libtool" + + # Assuming an absolute "${libdir}": + abslibdir="${libdir}" + + if test ! -d "../../lt" ; then + mkdir "../../lt" + fi + abssrcdir=`(cd ${srcdir}; pwd)` + + if test "${LIBTOOLPROG}" = "" ; then + (cd ../lt; sh ${abssrcdir}/../lt/configure --enable-shared --disable-static) + LIBTOOLPROG=`pwd`/../lt/libtool + fi + + if test "${need_gcc_static_libgcc}" = "yes" ; then + need_gcc_static_libgcc="" + if test "$CC" = "gcc" ; then + gcc_vers_three=`${CC} -v 2>&1 | grep "version 3."` + if test "$gcc_vers_three" = "" ; then + need_gcc_static_libgcc="" + else + need_gcc_static_libgcc=" -XCClinker -static-libgcc" + fi + fi + fi + + # Use only for standalone builds: + AR="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}${ar_libtool_no_undefined} -release ${rktio_version} -rpath ${abslibdir} \$(ARLIBFLAGS) -o" + # Used for a librktio convenience library: + STATIC_AR="${LIBTOOLPROG} --mode=link --tag=CC $CC -o" + ARFLAGS="" + RANLIB=":" + + RKTLINKER="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}" + CC="${LIBTOOLPROG} --mode=compile --tag=CC $CC" + LTO="lo" + LTA="la" + STRIP_LIB_DEBUG=":" + LIBSFX=la + ICP_LIB="${LIBTOOLPROG} --mode=install install -s" +else + ICP=cp + LTO="o" + LTA="a" + RKTLINKER='$(CC)' + STATIC_AR="$AR" + LIBSFX=so + ICP_LIB=cp + if test "${make_darwin_dylib}" = "yes" ; then + LIBSFX="dylib" + AR='$(RKTLINKER) --shared -o' + ARFLAGS="" + LIBS="${LIBS} -framework CoreFoundation" + ICP_LIB=cp + fi +fi + +############## final output ################ + +CPPFLAGS="$CPPFLAGS $PREFLAGS" + + + + + + + + + + + + + + + + + + + + + + + + +makefiles="Makefile" + +ac_config_files="$ac_config_files $makefiles" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "cs_config.h") CONFIG_HEADERS="$CONFIG_HEADERS cs_config.h" ;; + "$makefiles") CONFIG_FILES="$CONFIG_FILES $makefiles" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +$as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + +mkdir -p rktio +abssrcdir=`(cd ${srcdir}; pwd)` +echo "=== configuring in rktio (${abssrcdir}/../../rktio)" +cd rktio; ${abssrcdir}/../../rktio/configure diff -Nru racket-6.12+ppa1/src/cs/c/configure.ac racket-7.0+ppa1/src/cs/c/configure.ac --- racket-6.12+ppa1/src/cs/c/configure.ac 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/configure.ac 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,363 @@ + +################################################################# +# This is the source for the `configure` script, to be compiled # +# by autoconf (use `make-configure` in "../../racket"). # +################################################################# + +AC_INIT([embed-boot.rkt]) +AC_CONFIG_HEADERS([cs_config.h]) + +AC_CONFIG_AUX_DIR(../../lt) +AC_CANONICAL_SYSTEM + +AC_ARG_ENABLE(shared, [ --enable-shared create shared libraries (ok, but not recommended)]) +AC_ARG_ENABLE(standalone, [ --enable-standalone create a standalone shared library]) +AC_ARG_ENABLE(pthread, [ --enable-pthread link with pthreads (usually auto-enabled if needed)]) +AC_ARG_ENABLE(iconv, [ --enable-iconv use iconv (usually auto-enabled)]) +AC_ARG_ENABLE(xonx, [ --enable-xonx use Unix style (e.g., use Gtk) for Mac OS]) +AC_ARG_ENABLE(racket, [ --enable-racket= use as Racket to build; or "auto" to create]) +AC_ARG_ENABLE(scheme, [ --enable-scheme= Chez Scheme build directory at ]) +AC_ARG_ENABLE(mach, [ --enable-mach= Use Chez Scheme machine type ]) + +show_explicitly_disabled() +{ + if test "$1" = "no" ; then + echo "=== $2 disabled" + fi +} + +show_explicitly_enabled() +{ + if test "$1" = "yes" ; then + echo "=== $2 enabled" + if test "$3" != "" ; then + echo " $3" + fi + fi +} + +show_explicitly_set() +{ + if test "$1" != "" ; then + echo "=== $2 set to $1" + fi +} + +show_explicitly_enabled "${enable_pthread}" "pthreads" +show_explicitly_disabled "${enable_pthread}" "pthreads" +show_explicitly_enabled "${enable_xonx}" "Unix style" +show_explicitly_set "${enable_racket}" "Racket" +show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" +show_explicitly_set "${enable_mach}" "machine type" + +if test "${enable_iconv}" = "" ; then + enable_iconv=yes +fi + +if test "${enable_xonx}" == "" ; then + enable_xonx=no +fi + +skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no + +INCLUDEDEP="#" +OSX="not_osx" +NOT_OSX="" +CONFIGURE_RACKET_SO_COMPILE="" + +FRAMEWORK_INSTALL_DIR='$(srcdir)/../../../lib/' +FRAMEWORK_PREFIX='@executable_path/../lib/' + +RACKET='$(DEFAULT_RACKET)' + +enable_pthread_by_default=yes + +###### Autoconfigure ####### + +AC_PROG_CC + +# If using gcc, we want all warnings: +if test "$CC" = "gcc" ; then + CFLAGS="$CFLAGS -Wall" +fi + +AC_CHECK_LIB(m, fmod) +AC_CHECK_LIB(dl, dlopen) + +############## platform tests ################ + +case "$host_os" in + solaris2*) + MACH_OS=s2 + ;; + aix*) + ;; + *freebsd*) + MACH_OS=fb + ;; + openbsd*) + MACH_OS=ob + ;; + bitrig*) + ;; + dragonfly*) + ;; + netbsd*) + MACH_OS=nb + ;; + irix*) + ;; + linux*) + MACH_OS=le + LIBS="${LIBS} -lncurses" + ;; + osf1*) + ;; + hpux*) + ;; + *mingw*) + skip_iconv_check=yes + ;; + cygwin*) + ;; + darwin*) + PREFLAGS="$PREFLAGS -DOS_X" + MACH_OS=osx + LIBS="${LIBS} -lncurses -framework CoreFoundation" + if test "${enable_xonx}" == "no" ; then + INCLUDEDEP="-include" + OSX="" + NOT_OSX="osx" + else + CONFIGURE_RACKET_SO_COMPILE="env PLT_CS_MAKE_UNIX_STYLE_MACOS=y" + CPPFLAGS="${CPPFLAGS} -DRACKET_XONX" + fi + + # -pthread is not needed and triggers a warning + use_flag_pthread=no + ;; + nto-qnx*) + MACH_OS=qnx + use_flag_pthread=no + ;; + *) + ;; +esac + +case "$host_cpu" in + arm*) + enable_pthread_by_default=no + ;; +esac + +if test "${enable_pthread}" = "" ; then + if test "${enable_pthread_by_default}" = "yes" ; then + enable_pthread=yes + fi +fi + +thread_prefix="" +thread_config_arg="" +if test "${enable_pthread}" = "yes" ; then + thread_prefix="t" + thread_config_arg="--threads" +fi + +case "$host_cpu" in + x86_64) + MACH="${thread_prefix}a6${MACH_OS}" + ;; + x86|i*86) + MACH="${thread_prefix}i3${MACH_OS}" + ;; + arm*) + MACH="${thread_prefix}arm32${MACH_OS}" + ;; + power*) + MACH="${thread_prefix}ppc32${MACH_OS}" + ;; +esac + +SCHEME_SRC=../ChezScheme + +if test "${enable_scheme}" != "" ; then + SCHEME_SRC="${enable_scheme}" +fi + +if test "${enable_racket}" != "" ; then + RACKET="${enable_racket}" +fi + +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg}" + +############## C flags ################ + +AC_LANG_C + +iconv_lib_flag="" +if test "${skip_iconv_check}" = "no" ; then + if test "${enable_iconv}" = "yes" ; then + AC_CHECK_HEADER(iconv.h, enable_iconv=yes, enable_iconv=no) + if test "${enable_iconv}" = "yes" ; then + # Does it all work, now? + AC_TRY_RUN( +[ #include ] +[ #include ] + int main() { +[ iconv_open("UTF-8", "UTF-8");] + return 0; + }, enable_iconv=yes, enable_iconv=no, enable_iconv=yes) + if test "${enable_iconv}" = "no" ; then + # Try adding -liconv ? + # We did not use AC_CHECK_LIB because iconv is sometimes macro-renamed + ORIG_LIBS="$LIBS" + LIBS="$LIBS -liconv" + AC_TRY_RUN( +[ #include ] +[ #include ] + int main() { +[ iconv_open("UTF-8", "UTF-8");] + return 0; + }, enable_iconv=yes, enable_iconv=no, enable_iconv=yes) + if test "${enable_iconv}" = "no" ; then + LIBS="$ORIG_LIBS" + else + iconv_lib_flag=" -liconv" + fi + fi + fi + fi + [ msg="iconv is usable" ] + AC_MSG_CHECKING($msg) + iconv_usage_result="$enable_iconv$iconv_lib_flag" + AC_MSG_RESULT($iconv_usage_result) +fi +if test "${enable_iconv}" = "no" ; then + AC_DEFINE(RKTIO_NO_ICONV,1,[Do not use iconv]) +fi + +if test "${enable_iconv}" = "yes" ; then + AC_MSG_CHECKING([for nl_langinfo (CODESET)]) + AC_TRY_LINK([#include ], + [char *codeset = nl_langinfo (CODESET);], + AC_DEFINE(RKTIO_HAVE_CODESET,1,[Have nl_langinfo (CODESET)]) + have_codeset=yes, + have_codeset=no) + AC_MSG_RESULT($have_codeset) +fi + +############### pthread ################### + +if test "${enable_pthread}" = "yes" ; then + if test "${use_flag_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + fi + if test "${use_flag_posix_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -D_POSIX_PTHREAD_SEMANTICS -D_REENTRANT" + fi + AC_DEFINE(RKTIO_USE_PTHREADS, 1, [Pthread enabled]) +fi + +############## libtool ################ + +if test "${enable_shared}" = "yes" ; then + echo "Configuring libtool" + + # Assuming an absolute "${libdir}": + abslibdir="${libdir}" + + if test ! -d "../../lt" ; then + mkdir "../../lt" + fi + abssrcdir=`(cd ${srcdir}; pwd)` + + if test "${LIBTOOLPROG}" = "" ; then + (cd ../lt; sh ${abssrcdir}/../lt/configure --enable-shared --disable-static) + LIBTOOLPROG=`pwd`/../lt/libtool + fi + + if test "${need_gcc_static_libgcc}" = "yes" ; then + need_gcc_static_libgcc="" + if test "$CC" = "gcc" ; then + gcc_vers_three=`${CC} -v 2>&1 | grep "version 3[.]"` + if test "$gcc_vers_three" = "" ; then + need_gcc_static_libgcc="" + else + need_gcc_static_libgcc=" -XCClinker -static-libgcc" + fi + fi + fi + + # Use only for standalone builds: + AR="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}${ar_libtool_no_undefined} -release ${rktio_version} -rpath ${abslibdir} \$(ARLIBFLAGS) -o" + # Used for a librktio convenience library: + STATIC_AR="${LIBTOOLPROG} --mode=link --tag=CC $CC -o" + ARFLAGS="" + RANLIB=":" + + RKTLINKER="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}" + CC="${LIBTOOLPROG} --mode=compile --tag=CC $CC" + LTO="lo" + LTA="la" + STRIP_LIB_DEBUG=":" + LIBSFX=la + ICP_LIB="${LIBTOOLPROG} --mode=install install -s" +else + ICP=cp + LTO="o" + LTA="a" + RKTLINKER='$(CC)' + STATIC_AR="$AR" + LIBSFX=so + ICP_LIB=cp + if test "${make_darwin_dylib}" = "yes" ; then + LIBSFX="dylib" + AR='$(RKTLINKER) --shared -o' + ARFLAGS="" + LIBS="${LIBS} -framework CoreFoundation" + ICP_LIB=cp + fi +fi + +############## final output ################ + +CPPFLAGS="$CPPFLAGS $PREFLAGS" + +AC_SUBST(CC) +AC_SUBST(CFLAGS) +AC_SUBST(CPPFLAGS) +AC_SUBST(LDFLAGS) +AC_SUBST(LIBS) +AC_SUBST(AR) +AC_SUBST(ARFLAGS) +AC_SUBST(RANLIB) +AC_SUBST(STATIC_AR) +AC_SUBST(ICP) +AC_SUBST(RKTLINKER) +AC_SUBST(INCLUDEDEP) +AC_SUBST(RACKET) +AC_SUBST(SCHEME_DIR) +AC_SUBST(MACH) +AC_SUBST(OSX) +AC_SUBST(NOT_OSX) +AC_SUBST(CONFIGURE_RACKET_SO_COMPILE) +AC_SUBST(SCHEME_SRC) +AC_SUBST(SCHEME_CONFIG_ARGS) +AC_SUBST(FRAMEWORK_INSTALL_DIR) +AC_SUBST(FRAMEWORK_PREFIX) + +makefiles="Makefile" + +AC_OUTPUT($makefiles) + +mkdir -p rktio +abssrcdir=`(cd ${srcdir}; pwd)` +echo "=== configuring in rktio (${abssrcdir}/../../rktio)" +cd rktio; ${abssrcdir}/../../rktio/configure diff -Nru racket-6.12+ppa1/src/cs/c/cs_config.h.in racket-7.0+ppa1/src/cs/c/cs_config.h.in --- racket-6.12+ppa1/src/cs/c/cs_config.h.in 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/cs_config.h.in 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1 @@ + diff -Nru racket-6.12+ppa1/src/cs/c/embed-boot.rkt racket-7.0+ppa1/src/cs/c/embed-boot.rkt --- racket-6.12+ppa1/src/cs/c/embed-boot.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/embed-boot.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,66 @@ +#lang racket/base +(require racket/cmdline + racket/file + compiler/private/mach-o + compiler/private/elf) + +(command-line + #:args (src-file dest-file boot-dir racket.so) + + (define bstr1 (file->bytes (build-path boot-dir "petite.boot"))) + (define bstr2 (file->bytes (build-path boot-dir "scheme.boot"))) + (define bstr3 (file->bytes racket.so)) + + (with-handlers ([exn? (lambda (x) + (when (file-exists? dest-file) + (delete-file dest-file)) + (raise x))]) + (define data + (bytes-append bstr1 #"\0" + bstr2 #"\0" + bstr3 #"\0")) + (define pos + (case (path->string (system-library-subpath #f)) + [("x86_64-darwin" "i386-darwin" "x86_64-macosx" "i386-macosx") + ;; Mach-O + (copy-file src-file dest-file #t) + (add-plt-segment dest-file data #:name #"__RKTBOOT")] + [else + ;; ELF? + (define-values (start-pos end-pos any1 any2) + (add-racket-section src-file dest-file #".rackboot" + (lambda (pos) + (values data 'any1 'any2)))) + (define (ensure-executable dest-file) + (let* ([perms1 (file-or-directory-permissions dest-file 'bits)] + [perms2 (bitwise-ior user-read-bit user-write-bit user-execute-bit + perms1)]) + (unless (equal? perms1 perms2) + (file-or-directory-permissions dest-file perms2)))) + (cond + [start-pos + ;; Success as ELF + (ensure-executable dest-file) + start-pos] + [else + ;; Not ELF; just append to the end + (copy-file src-file dest-file #t) + (ensure-executable dest-file) + (define pos (file-size dest-file)) + (call-with-output-file* + dest-file + #:exists 'update + (lambda (o) + (file-position o pos) + (write-bytes data o))) + pos])])) + + (define-values (i o) (open-input-output-file dest-file #:exists 'update)) + (define m (regexp-match-positions #rx"BooT FilE OffsetS:" i)) + (unless m + (error 'embed-boot "cannot file boot-file offset tag")) + + (file-position o (cdar m)) + (void (write-bytes (integer->integer-bytes pos 4 #t #f) o)) + (void (write-bytes (integer->integer-bytes (+ pos (bytes-length bstr1) 1) 4 #t #f) o)) + (void (write-bytes (integer->integer-bytes (+ pos (bytes-length bstr1) (bytes-length bstr2) 2) 4 #t #f) o)))) diff -Nru racket-6.12+ppa1/src/cs/c/grmain.c racket-7.0+ppa1/src/cs/c/grmain.c --- racket-6.12+ppa1/src/cs/c/grmain.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/grmain.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,19 @@ +#define do_pre_filter_cmdline_arguments(argc, argv) pre_filter_cmdline_arguments(argc, argv) +static void pre_filter_cmdline_arguments(int *argc, char ***argv); + +#define INITIAL_BIN_TYPE "ri" +#define RACKET_IS_GUI 1 + +#include "main.c" + +#ifdef OS_X +# define wx_mac +#else +# define wx_xt +#endif + +static void scheme_register_process_global(const char *key, void *v) +{ +} + +#include "../../start/gui_filter.inc" diff -Nru racket-6.12+ppa1/src/cs/c/main.c racket-7.0+ppa1/src/cs/c/main.c --- racket-6.12+ppa1/src/cs/c/main.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/main.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,132 @@ +#ifndef _MSC_VER +# include +#endif +#include +#include +#include +#ifdef _MSC_VER +# include +# define DOS_FILE_SYSTEM +static int scheme_utf8_encode(unsigned int *path, int zero_offset, int len, + char *dest, int dest_len, int get_utf16); +#endif +#include "boot.h" + +#define MZ_CHEZ_SCHEME +#ifndef INITIAL_BIN_TYPE +# define INITIAL_BIN_TYPE "zi" +#endif +#ifndef RACKET_IS_GUI +# define RACKET_IS_GUI 0 +#endif + +#include "../../start/config.inc" + +char *boot_file_data = "BooT FilE OffsetS:xxxxyyyyyzzzz"; +static int boot_file_offset = 18; + +#ifdef OS_X +# include +static char *get_self_path() +{ + char buf[1024], *s; + uint32_t size = sizeof(buf); + int r; + + r = _NSGetExecutablePath(buf, &size); + if (!r) + return strdup(buf); + else { + s = malloc(size); + r = _NSGetExecutablePath(s, &size); + if (!r) + return s; + fprintf(stderr, "failed to get self\n"); + exit(1); + } +} +#endif + +#if defined(__linux__) +# include +static char *get_self_path() +{ + char buf[256], *s = buf; + ssize_t len, blen = sizeof(buf); + + while (1) { + len = readlink("/proc/self/exe", s, blen-1); + if (len == (blen-1)) { + if (s != buf) free(s); + blen *= 2; + s = malloc(blen); + } else if (len < 0) { + fprintf(stderr, "failed to get self (%d)\n", errno); + exit(1); + } else + break; + } + buf[len] = 0; + return strdup(buf); +} +#endif + +#ifdef _MSC_VER +static char *get_self_path() +{ + wchar_t *p = get_self_executable_path(); + char *r; + int len; + + len = WideCharToMultiByte(CP_UTF8, 0, p, -1, NULL, 0, NULL, NULL); + r = malloc(len); + len = WideCharToMultiByte(CP_UTF8, 0, p, -1, r, len, NULL, NULL); + + return r; +} + +static int scheme_utf8_encode(unsigned int *path, int zero_offset, int len, + char *dest, int dest_len, int get_utf16) +{ + return WideCharToMultiByte(CP_UTF8, 0, (wchar_t *)path, len, dest, dest_len, NULL, NULL); +} +#endif + +#ifdef NO_GET_SEGMENT_OFFSET +static long get_segment_offset() +{ + return 0; +} +#endif + +#ifndef do_pre_filter_cmdline_arguments +# define do_pre_filter_cmdline_arguments(argc, argv) /* empty */ +#endif + +int main(int argc, char **argv) +{ + char *self, *prog = argv[0], *sprog = NULL; + int pos1, pos2, pos3; + long segment_offset; + + do_pre_filter_cmdline_arguments(&argc, &argv); + + argc--; + argv++; + + extract_built_in_arguments(&prog, &sprog, &argc, &argv); + segment_offset = get_segment_offset(); + + self = get_self_path(); + + memcpy(&pos1, boot_file_data + boot_file_offset, sizeof(pos1)); + memcpy(&pos2, boot_file_data + boot_file_offset + 4, sizeof(pos2)); + memcpy(&pos3, boot_file_data + boot_file_offset + 8, sizeof(pos2)); + + racket_boot(argc, argv, self, segment_offset, + extract_coldir(), extract_configdir(), + pos1, pos2, pos3, + RACKET_IS_GUI); + + return 0; +} diff -Nru racket-6.12+ppa1/src/cs/c/Makefile.in racket-7.0+ppa1/src/cs/c/Makefile.in --- racket-6.12+ppa1/src/cs/c/Makefile.in 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,226 @@ +srcdir = @srcdir@ +builddir = @builddir@ + +SCHEME_SRC = @SCHEME_SRC@ +MACH = @MACH@ +SCHEME_BIN = $(SCHEME_SRC)/$(MACH)/bin/$(MACH)/scheme +SCHEME_INC = $(SCHEME_SRC)/$(MACH)/boot/$(MACH) +SCHEME = $(SCHEME_BIN) -b $(SCHEME_INC)/petite.boot -b $(SCHEME_INC)/scheme.boot + +CC = @CC@ +CFLAGS = @CFLAGS@ @CPPFLAGS@ -I$(SCHEME_INC) -I$(srcdir)/../../rktio -Irktio -I. +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +DEFAULT_RACKET = $(srcdir)/../../../bin/racket +RACKET = @RACKET@ +RACO = $(RACKET) -N raco -l- raco + +CS_INSTALLED = cs +CS_GR_INSTALLED = CS +bindir = $(srcdir)/../../../bin +libpltdir = $(srcdir)/../../../lib +docdir = $(srcdir)/../../../doc +sharepltdir = $(srcdir)/../../../share +configdir = $(srcdir)/../../../etc + +ALLDIRINFO = "$(DESTDIR)$(bindir)" \ + "$(DESTDIR)$(docdir)" \ + "$(DESTDIR)$(libpltdir)" \ + "$(DESTDIR)$(sharepltdir)" \ + "$(DESTDIR)$(configdir)" + +# Defines FWVERSION: +mainsrcdir = @srcdir@/../.. +@INCLUDEDEP@ @srcdir@/../../racket/version.mak + +cs: + $(MAKE) scheme + $(MAKE) racket-so + cd rktio; $(MAKE) + $(MAKE) racketcs + $(MAKE) gracketcs + $(MAKE) starter + +ABS_RACKET = "`$(RACKET) $(srcdir)/../absify.rkt --exec $(RACKET)`" +ABS_SCHEME_SRC = "`$(RACKET) $(srcdir)/../absify.rkt $(SCHEME_SRC)`" +ABS_SRCDIR = "`$(RACKET) $(srcdir)/../absify.rkt $(srcdir)`" +ABS_BUILDDIR = "`$(RACKET) $(srcdir)/../absify.rkt $(builddir)`" + +SETUP_BOOT = -W 'info@compiler/cm error' -l- setup --chain $(srcdir)/../../setup-go.rkt $(builddir)/compiled + +# We don't try to track dependencies through makefiles for things +# build with the expander extrator, hence "ignored" +BOOTSTRAP_RACKET = $(RACKET) $(SETUP_BOOT) ignored $(builddir)/ignored.d + +RKTIO_RACKET = $(RACKET) $(SETUP_BOOT) '(GENERATED_RKTIO_RKTL)' $(builddir)/rktio.d +CONVERT_RACKET = $(RACKET) $(SETUP_BOOT) + +racket-so: + $(MAKE) bounce TARGET=build-racket-so + +RACKET_SO_ENV = @CONFIGURE_RACKET_SO_COMPILE@ env COMPILED_SCM_DIR="$(builddir)/compiled/" + +build-racket-so: + $(MAKE) expander + $(MAKE) thread + $(MAKE) io + $(MAKE) regexp + $(MAKE) schemify + $(MAKE) known + cd $(srcdir)/.. && $(RACKET_SO_ENV) $(MAKE) "$(builddir)/racket.so" RACKET="$(RACKET)" SCHEME="$(SCHEME)" BUILDDIR="$(builddir)/" CONVERT_RACKET="$(CONVERT_RACKET)" + +bounce: + $(MAKE) RACKET="$(ABS_RACKET)" SCHEME_SRC="$(ABS_SCHEME_SRC)" srcdir="$(ABS_SRCDIR)" builddir="$(ABS_BUILDDIR)" $(TARGET) + +# You can't make `expander`, `thread`, etc., directly, because +# `builddir` and `srcdir` are not necessarily absolute. But you can +# `make bounce TARGET=expander`, etc. + +# This sequence essentially duplicates the handling of layers that is +# in "../Makefile", but it does so to swap in `BOOTSTRAP_RACKET` in +# place of `raco make` (to avoid a dependency on a package for `raco +# make`). + +expander: + cd $(srcdir)/../../expander && $(MAKE) expander-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +thread: + cd $(srcdir)/../../thread && $(MAKE) thread-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +io: + cd $(srcdir)/../../io && $(MAKE) io-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +regexp: + cd $(srcdir)/../../regexp && $(MAKE) regexp-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +schemify: + cd $(srcdir)/../../schemify && $(MAKE) schemify-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +known: + cd $(srcdir)/../../schemify && $(MAKE) known-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +scheme: + $(MAKE) $(SCHEME_BIN) + +$(SCHEME_BIN): + cd @SCHEME_SRC@ && ./configure @SCHEME_CONFIG_ARGS@ + cd @SCHEME_SRC@ && make + +# ---------------------------------------- +# Unix + +EMBED_DEPS = $(srcdir)/embed-boot.rkt + +racketcs@NOT_OSX@: raw_racketcs racket.so $(EMBED_DEPS) + $(RACKET) $(srcdir)/embed-boot.rkt raw_racketcs racketcs $(SCHEME_INC) racket.so + +gracketcs@NOT_OSX@: raw_gracketcs racket.so $(EMBED_DEPS) + $(RACKET) $(srcdir)/embed-boot.rkt raw_gracketcs gracketcs $(SCHEME_INC) racket.so + +BOOT_OBJS = boot.o $(SCHEME_INC)/kernel.o rktio/librktio.a + +raw_racketcs: main.o boot.o $(BOOT_OBJS) + $(CC) $(CFLAGS) -o raw_racketcs main.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + +raw_gracketcs: grmain.o boot.o $(BOOT_OBJS) + $(CC) $(CFLAGS) -o raw_gracketcs grmain.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + +# ---------------------------------------- +# Mac OS + +RKTFWDIR = Racket.framework/Versions/$(FWVERSION)_CS +RKTFW = $(RKTFWDIR)/Racket +GRAPPSKEL = GRacketCS.app/Contents/Info.plist + +racketcs@OSX@: main.o $(RKTFW) + $(CC) $(CFLAGS) -o racketcs main.o -F. -framework Racket + /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@executable_path/Racket.framework/Versions/$(FWVERSION)_CS/Racket" racketcs + +GRACKET_BIN = GRacketCS.app/Contents/MacOS/GracketCS + +gracketcs@OSX@: + $(MAKE) $(GRACKET_BIN) + +$(GRACKET_BIN): grmain.o $(RKTFW) $(GRAPPSKEL) + $(CC) $(CFLAGS) -o $(GRACKET_BIN) grmain.o -F. -framework Racket + /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@executable_path/../../../Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(GRACKET_BIN) + +$(GRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../racket/src/schvers.h $(srcdir)/../../mac/icon/GRacket.icns + env $(RACKET) $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "CS" + +BOOT_FILES = $(SCHEME_INC)/petite.boot $(SCHEME_INC)/scheme.boot racket.so + +$(RKTFW): $(BOOT_OBJS) $(BOOT_FILES) + mkdir -p Racket.framework/Versions/$(FWVERSION)_CS + @RKTLINKER@ -o $(RKTFW) @LDFLAGS@ -dynamiclib -all_load $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + rm -f Racket.framework/Racket + ln -s Versions/$(FWVERSION)_CS/Racket Racket.framework/Racket + mkdir -p Racket.framework/Versions/$(FWVERSION)_CS/boot + cp $(SCHEME_INC)/petite.boot $(SCHEME_INC)/scheme.boot Racket.framework/Versions/$(FWVERSION)_CS/boot + cp racket.so Racket.framework/Versions/$(FWVERSION)_CS/boot + +# ---------------------------------------- +# Common + +DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"' +DEF_CONFIG_DIR = -DINITIAL_CONFIG_DIRECTORY='"'"`cd $(srcdir)/../../..; pwd`/etc"'"' +DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) + +MAIN_DEPS = $(srcdir)/main.c $(srcdir)/boot.h $(srcdir)/../../start/config.inc + +main.o: $(MAIN_DEPS) + $(CC) $(CFLAGS) $(DEF_C_DIRS) -c -o main.o $(srcdir)/main.c + +grmain.o: $(srcdir)/grmain.c $(MAIN_DEPS) $(srcdir)/../../start/gui_filter.inc + $(CC) $(CFLAGS) $(DEF_C_DIRS) -c -o grmain.o $(srcdir)/grmain.c + +boot.o: $(srcdir)/boot.c $(srcdir)/../../rktio/rktio.inc $(srcdir)/boot.h + $(CC) $(CFLAGS) -c -o boot.o $(srcdir)/boot.c + +starter: $(srcdir)/../../start/ustart.c + $(CC) $(CFLAGS) -o starter $(srcdir)/../../start/ustart.c + +# ---------------------------------------- +# Install + +ICP=@ICP@ + +install: + $(MAKE) plain-install + $(srcdir)/../../../bin/racketcs $(SELF_RACKET_FLAGS) -N raco -l- raco setup $(PLT_SETUP_OPTIONS) + +plain-install@NOT_OSX@: + $(MAKE) unix-install + +plain-install@OSX@: + $(MAKE) macos-install + +common-install: + mkdir -p $(ALLDIRINFO) + $(ICP) racketcs "$(DESTDIR)$(bindir)/racket$(CS_INSTALLED)" + $(ICP) starter "$(DESTDIR)$(libpltdir)/starter" + $(ICP) $(srcdir)/../../start/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" + +unix-install: + $(MAKE) common-install + $(ICP) gracketcs "$(DESTDIR)$(libpltdir)/gracket$(CS_INSTALLED)" + +RKTFWDEST = @FRAMEWORK_INSTALL_DIR@/Racket.framework + +macos-install: + $(MAKE) common-install + rm -f $(DESTDIR)$(RKTFWDEST)/Racket + rm -rf $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS + mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS" + cp $(RKTFW) $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/ + mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot" + cp $(RKTFWDIR)/boot/petite.boot $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + cp $(RKTFWDIR)/boot/scheme.boot $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + cp $(RKTFWDIR)/boot/racket.so $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + /usr/bin/install_name_tool -change "@executable_path/Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(DESTDIR)"$(bindir)/racket$(CS_GR_INSTALLED)" + rm -rf $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" + $(ICP) -r "GRacketCS.app" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" + $(RACKET) "$(srcdir)/../../mac/rename-app.rkt" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" "GRacketCS" "GRacket$(CS_GR_INSTALLED)" no-up + /usr/bin/install_name_tool -change "@executable_path/../../../../racket/Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" + $(RACKET) "$(srcdir)/../../racket/collects-path.rkt" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" ../../../../collects ../../../../etc diff -Nru racket-6.12+ppa1/src/cs/c/README.txt racket-7.0+ppa1/src/cs/c/README.txt --- racket-6.12+ppa1/src/cs/c/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/c/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,73 @@ +This directory contains a `configure` script and a makefile (template) +for building the variant of Racket that runs on Chez Scheme. The +result of the build is a `racketcs` executable that embeds both Chez +Scheme and the Racket startup code to behave the same as the +traditional `racket` executable. + +If you have a checkout of the main Racket repo, you can just use `make +cs` in the top-level directory of the repo to build Racket-on-Chez. +See "INSTALL.txt" in the top-level directory for more information. + +If you want to know more about how Racket-on-Chez is put together, see +"../README.txt". + +======================================================================== + Requirements +======================================================================== + +Building Racket-on-Chez requires both an existing Racket build and +Chez Scheme build: + + * By default, the build uses Racket as built and installed in-place + in the same way as described in "../../README", so that the Racket + executable is "../../../bin/racket". + + You can select a different Racket excutable by supplying + `--enable-racket=...` to `configure`. + + * By default, the build uses Chez Scheme as built in a "ChezScheme" + sibling directory of the build directory. The Racket-on-Chez build + needs a Chez Scheme build directory, and not an end-user Chez + Scheme installation, because it needs "kernel.o" as created in a + Chez Scheme build; it may also need makefiles or other scripts in + the Chez Scheme build directory. + + See "../README.txt" for information on the required Chez Scheme + version. + + You can select a different Chez Scheme build path by supplying + `--enable-scheme=...` to `configure`. + +======================================================================== + Compiling for supported Unix variants (including Linux and Mac OS) +======================================================================== + +From two directories up, run the following commands: + + mkdir build + cd build + ../cs/c/configure + make + make install + +Those commands will create an in-place installation of Racket and +store the results of various compilation steps in a separate "build" +subdirectory, which is useful if you need to update your sources, +delete the build, and start from scratch. + +You can also run the typical `./configure && make && make install` if +you don't anticipate updating/rebuilding, but it will be harder to +restart from scratch should you need to. + +======================================================================== + Compiling for Windows +======================================================================== + +Compilation for Windows on Windows requires building the traditional +Racket implementation. Then, from the directory "..\..\worksp", run + + ..\..\racket csbuild.rkt + +Many intermediate files will be put in "../../build", including a Chez +Scheme checkout if it's not already present (in whcih case `git` must +be available). diff -Nru racket-6.12+ppa1/src/cs/chezpart.sls racket-7.0+ppa1/src/cs/chezpart.sls --- racket-6.12+ppa1/src/cs/chezpart.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/chezpart.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,82 @@ +;; Reexports from `chezscheme` bindings that won't be replaced +;; by Racket-specific implementations. + +(library (chezpart) + (export) + (import (chezscheme)) + (export (import + (rename (except (chezscheme) + remq remove + sort + force delay identifier? + output-port-buffer-mode + peek-char char-ready? + make-input-port make-output-port + close-input-port close-output-port + list? input-port? output-port? + open-input-file open-output-file abort + current-output-port current-input-port current-directory + open-input-string open-output-string get-output-string + open-input-output-file + with-input-from-file with-output-to-file + call-with-output-file + file-position + write display newline port-name port-closed? write-char + print-graph print-vector-length + date? make-date + dynamic-wind + call-with-current-continuation + make-engine engine-block engine-return + current-eval load + sleep thread? buffer-mode? + equal? + vector? mutable-vector? vector-length vector-ref vector-set! + vector-copy vector-fill! vector->immutable-vector vector->list + random random-seed + box? unbox set-box! + get-thread-id + threaded? + map for-each andmap ormap + char-general-category) + [make-parameter chez:make-parameter] + [void chez:void] + [date-second chez:date-second] + [date-minute chez:date-minute] + [date-hour chez:date-hour] + [date-day chez:date-day] + [date-month chez:date-month] + [date-year chez:date-year] + [date-week-day chez:date-week-day] + [date-year-day chez:date-year-day] + [date-dst? chez:date-dst?] + [string-copy! chez:string-copy!] + [apply chez:apply] + [procedure? chez:procedure?] + [procedure-arity-mask chez:procedure-arith-mask] + [substring chez:substring] + [gensym chez:gensym] + [symbol->string chez:symbol->string] + [fprintf chez:fprintf] + [printf chez:printf] + [format chez:format] + [current-error-port chez:current-error-port] + [string->number chez:string->number] + [number->string chez:number->string] + [file-exists? chez:file-exists?] + [directory-list chez:directory-list] + [delete-file chez:delete-file] + [delete-directory chez:delete-directory] + [filter chez:filter] + [member chez:member] + [memv chez:memv] + [memq chez:memq] + [error chez:error] + [raise chez:raise] + [exit-handler chez:exit-handler] + [exit chez:exit] + [vector-sort! chez:vector-sort!] + [vector-sort chez:vector-sort] + [call-with-input-file chez:call-with-input-file] + [read-char chez:read-char] + [gcd chez:gcd] + [lcm chez:lcm])))) diff -Nru racket-6.12+ppa1/src/cs/compile-file.ss racket-7.0+ppa1/src/cs/compile-file.ss --- racket-6.12+ppa1/src/cs/compile-file.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/compile-file.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,102 @@ + +;; Check to make we're using a build of Chez Scheme +;; that has all the features we need. + +(define (check-defined expr) + (unless (guard (x [else #f]) (eval expr)) + (error 'compile-file + (format + "failed trying `~a`; probably you need a newer Chez Scheme" + expr)))) + +(check-defined 'box-cas!) +(check-defined 'make-arity-wrapper-procedure) +(check-defined 'generate-procedure-source-information) +(check-defined 'object-backreferences) +(check-defined 'current-generate-id) +(check-defined 'load-compiled-from-port) +(check-defined 'collect-rendezvous) +(check-defined '(define-ftype T (function __thread () void))) + +;; ---------------------------------------- + +(current-make-source-object + (lambda (sfd bfp efp) + (call-with-values (lambda () (locate-source sfd bfp #t)) + (case-lambda + [() (error 'compile-config "cannot get line and column")] + [(name line col) + (make-source-object sfd bfp efp line col)])))) + +(generate-wpo-files #t) + +(define (get-opt args flag arg-count) + (cond + [(null? args) #f] + [(equal? (car args) flag) + (unless (> (length args) arg-count) + (error 'compile-file "missing argument for ~a" flag)) + (cdr args)] + [else #f])) + +(define whole-program? #f) +(generate-inspector-information #f) +(generate-procedure-source-information #t) +(define build-dir "") + +(define-values (src deps) + (let loop ([args (command-line-arguments)]) + (cond + [(get-opt args "--debug" 0) + => (lambda (args) + (generate-inspector-information #t) + (loop args))] + [(get-opt args "--unsafe" 0) + => (lambda (args) + (optimize-level 3) + (loop args))] + [(get-opt args "--whole-program" 0) + => (lambda (args) + (set! whole-program? #t) + (loop args))] + [(get-opt args "--dest" 1) + => (lambda (args) + (set! build-dir (car args)) + (loop (cdr args)))] + [(null? args) + (error 'compile-file "missing source file")] + [else + (values (car args) (cdr args))]))) + +(define src-so + (letrec ([find-dot (lambda (pos) + (let ([pos (sub1 pos)]) + (cond + [(zero? pos) (error 'compile-file "can't find extension in ~s" src)] + [(char=? (string-ref src pos) #\.) pos] + [else (find-dot pos)])))]) + (string-append (substring src 0 (find-dot (string-length src))) ".so"))) + +(define dest + (if (equal? build-dir "") + src-so + (string-append build-dir src-so))) + +(cond + [whole-program? + (unless (= 1 (length deps)) + (error 'compile-file "expected a single dependency for whole-program compilation")) + (unless (equal? build-dir "") + (library-directories (list (cons "." build-dir)))) + (compile-whole-program (car deps) src #t)] + [else + (for-each load deps) + (parameterize ([current-generate-id + (let ([counter-ht (make-eq-hashtable)]) + (lambda (sym) + (let* ([n (eq-hashtable-ref counter-ht sym 0)] + [s ((if (gensym? sym) gensym->unique-string symbol->string) sym)] + [g (gensym (symbol->string sym) (format "rkt-~a-~a-~a" src s n))]) + (eq-hashtable-set! counter-ht sym (+ n 1)) + g)))]) + (compile-file src dest))]) diff -Nru racket-6.12+ppa1/src/cs/convert.rkt racket-7.0+ppa1/src/cs/convert.rkt --- racket-6.12+ppa1/src/cs/convert.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/convert.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,254 @@ +#lang racket/base +(require racket/cmdline + racket/pretty + racket/match + racket/file + racket/extflonum + racket/include + "../schemify/schemify.rkt" + "../schemify/serialize.rkt" + "../schemify/known.rkt" + "../schemify/lift.rkt") + +(define skip-export? #f) +(define for-cify? #f) +(define unsafe-mode? #f) + +(define-values (in-file out-file) + (command-line + #:once-each + [("--skip-export") "Don't generate an `export` form" + (set! skip-export? #t)] + [("--for-cify") "Keep `make-struct-type` as-is, etc." + (set! for-cify? #t)] + [("--unsafe") "Compile for unsafe mode" + (set! unsafe-mode? #t)] + #:args + (in-file out-file) + (values in-file out-file))) + +(define content (call-with-input-file* in-file read)) +(define l (cdddr content)) + +(let loop ([l l]) + (cond + [(eq? l 'make-optional-keyword-procedure) + (error "keyword residual `make-optional-keyword-procedure` appears in .rktl")] + [(pair? l) + (loop (car l)) + (loop (cdr l))])) + +(define lifts (make-hash)) +(define ordered-lifts null) + +(define (lift-set! k v) + (unless (hash-ref lifts k #f) + (hash-set! lifts k v) + (set! ordered-lifts (cons k ordered-lifts)))) + +;; Ad hoc patterns to deal with a special case in "expander.rktl": +(define (quote? v) + (and (pair? v) + (eq? (car v) 'quote) + (pair? (cdr v)) + (null? (cddr v)))) +(define (nested-hash? v) + (and (pair? v) + (eq? #f (car v)) + (hash? (cdr v)))) +(define (list-of-keywords? v) + (and (pair? v) + (list? v) + (andmap keyword? v))) + +;; Gather all literal regexps and hash tables +(define (lift v) + (cond + [(or (regexp? v) (byte-regexp? v)) + (define s (gensym 'rx)) + (lift-set! v s)] + [(or (pregexp? v) (byte-pregexp? v)) + (define s (gensym 'px)) + (lift-set! v s)] + [(hash? v) + (define s (gensym 'hash)) + (lift-set! v s)] + [(and (quote? v) + (nested-hash? (cadr v))) + (define s (gensym 'nhash)) + (lift-set! (cadr v) s)] + [(keyword? v) + (define s (gensym 'kw)) + (lift-set! v s)] + [(and (quote? v) + (list-of-keywords? (cadr v))) + (define s (gensym 'kws)) + (lift-set! (cadr v) s)] + [(and (quote? v) + (extflonum? (cadr v))) + (define s (gensym 'extfl)) + (lift-set! (cadr v) s)] + [(pair? v) + (lift (car v)) + (lift (cdr v))])) + +(unless for-cify? + (lift l)) + +(define prim-knowns + (let ([knowns (hasheq)]) + (define-syntax-rule (define-primitive-table id [prim known] ...) + (begin (set! knowns (hash-set knowns 'prim known)) ...)) + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (include "primitive/internal.ss") + knowns)) + +;; Convert: +(define schemified-body + (let () + (define-values (bodys/constants-lifted lifted-constants) + (if for-cify? + (begin + (printf "Serializable...\n") + (time (convert-for-serialize l for-cify?))) + (values l null))) + (printf "Schemify...\n") + (define body + (time + (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode?))) + (printf "Lift...\n") + ;; Lift functions to aviod closure creation: + (define lifted-body + (time + (lift-in-schemified-body body (lambda (old new) new)))) + (append (for/list ([p (in-list lifted-constants)]) + (cons 'define p)) + lifted-body))) + +;; ---------------------------------------- + +(unless for-cify? + + ;; Set a hook to redirect literal regexps and + ;; hash tables to lifted bindings + (pretty-print-size-hook + (lambda (v display? out) + (cond + [(and (pair? v) + (pair? (cdr v)) + (eq? 'quote (car v)) + (or (regexp? (cadr v)) + (byte-regexp? (cadr v)) + (pregexp? (cadr v)) + (byte-pregexp? (cadr v)) + (hash? (cadr v)) + (nested-hash? (cadr v)) + (keyword? (cadr v)) + (list-of-keywords? (cadr v)) + (extflonum? (cadr v)))) + 10] + [(bytes? v) (* 3 (bytes-length v))] + [(and (symbol? v) (regexp-match? #rx"#" (symbol->string v))) + (+ 2 (string-length (symbol->string v)))] + [(char? v) 5] + [(single-flonum? v) 5] + [(or (keyword? v) + (regexp? v) + (pregexp? v) + (hash? v)) + (error 'lift "value that needs lifting is in an unrecognized context: ~v" v)] + [else #f]))) + + ;; This hook goes with `pretty-print-size-hook` + (pretty-print-print-hook + (lambda (v display? out) + (cond + [(and (pair? v) + (eq? 'quote (car v)) + (or (regexp? (cadr v)) + (byte-regexp? (cadr v)) + (pregexp? (cadr v)) + (byte-pregexp? (cadr v)) + (hash? (cadr v)) + (nested-hash? (cadr v)) + (keyword? (cadr v)) + (list-of-keywords? (cadr v)) + (extflonum? (cadr v)))) + (write (hash-ref lifts (cadr v)) out)] + [(bytes? v) + (display "#vu8") + (write (bytes->list v) out)] + [(symbol? v) + (write-string (format "|~a|" v) out)] + [(char? v) + (write-string (format "#\\x~x" (char->integer v)) out)] + [(single-flonum? v) + (write (real->double-flonum v) out)] + [else #f])))) + +;; ---------------------------------------- + +(make-parent-directory* out-file) + +(with-handlers ([void (lambda (exn) + (when (file-exists? out-file) + (with-handlers ([void (lambda (exn) + (log-error "delete failed: ~s" exn))]) + (delete-file out-file))) + (raise exn))]) + (with-output-to-file + out-file + #:exists 'truncate + (lambda () + (unless skip-export? + ;; Write out exports + (pretty-write + `(export (rename ,@(caddr content))))) + ;; Write out lifted regexp and hash-table literals + (for ([k (in-list (reverse ordered-lifts))]) + (define v (hash-ref lifts k)) + (pretty-write + `(define ,v + ,(let loop ([k k]) + (cond + [(or (regexp? k) + (byte-regexp? k)) + `(,(cond [(byte-regexp? k) 'byte-regexp] + [(byte-pregexp? k) 'byte-pregexp] + [(pregexp? k) 'pregexp] + [else 'regexp]) + ,(object-name k))] + [(hash? k) + `(,(cond + [(hash-equal? k) 'hash] + [(hash-eqv? k) 'hasheqv] + [else 'hasheq]) + ,@(for*/list ([(k v) (in-hash k)] + [e (in-list (list k v))]) + `(quote ,e)))] + [(pair? k) + `(cons ,(loop (car k)) ,(loop (cdr k)))] + [(keyword? k) + `(string->keyword ,(keyword->string k))] + [(null? k) ''()] + [(extflonum? k) `(string->number ,(format "~a" k) 10 'read)] + [else k]))))) + + ;; Write out converted forms + (for ([v (in-list schemified-body)]) + (unless (equal? v '(void)) + (let loop ([v v]) + (match v + [`(begin ,vs ...) + (for-each loop vs)] + [else + (pretty-write v)]))))))) diff -Nru racket-6.12+ppa1/src/cs/demo/chaperone.ss racket-7.0+ppa1/src/cs/demo/chaperone.ss --- racket-6.12+ppa1/src/cs/demo/chaperone.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/chaperone.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,458 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ got expect) + (let ([v got] + [expect-v expect]) + (unless (equal? v expect-v) + (error 'check (format "failed: ~s => ~s" 'got v))))])) + +(define-syntax check-error + (syntax-rules () + [(_ expr) + (check (call-with-current-continuation + (lambda (esc) + (with-continuation-mark + exception-handler-key + (lambda (exn) (|#%app| esc 'expected-error)) + expr))) + 'expected-error)])) + +;; ---------------------------------------- + +(define v1 (vector 1 2 3)) +(define v2 (vector 1 2 3)) + +(check (impersonator-of? v1 v2) + #t) +(check (impersonator-of? v2 v1) + #t) + +(define v1i (impersonate-vector v1 + (lambda (v i e) (- e)) + (lambda (v i e) (* 2 e)))) + +(check (vector? v1) #t) +(check (vector? v2) #t) +(check (vector? v1i) #t) + +(check (vector-ref v1i 1) -2) +(check (vector-ref v1 1) 2) +(check (vector-set! v1 1 5) (void)) +(check (vector-ref v1i 1) -5) +(check (vector-ref v1 1) 5) +(check (vector-set! v1i 1 6) (void)) +(check (vector-ref v1i 1) -12) +(check (vector-ref v1 1) 12) + +(check (vector-set! v2 1 12) (void)) + +(check (impersonator-of? v1i v2) + #f) +(check (impersonator-of? v2 v1i) + #f) +(check (impersonator-of? v1i v1) + #t) +(check (impersonator-of? v1 v1i) + #f) + +(define v1j (impersonate-vector v1 + #f + #f)) + +(check (vector? v1j) #t) + +(check (impersonator-of? v1j v1) + #t) +(check (impersonator-of? v1 v1j) + #t) + +(define v1c (chaperone-vector v1 + (lambda (v i e) e) + (lambda (v i e) e))) + +(check (chaperone-of? v1c v1) + #t) +(check (chaperone-of? v1i v1) + #f) +(check (impersonator-of? v1c v1) + #t) + +(define vv (vector (vector 1 2 3) + (vector 4 5 6))) +(define vvc (chaperone-vector vv + (lambda (v i e) + (chaperone-vector + e + (lambda (v i e) e) + (lambda (v i e) e))) + (lambda (v i e) e))) +(check (chaperone-of? vvc vv) + #t) +(check (chaperone-of? (vector-ref vvc 0) (vector-ref vv 0)) + #t) + +;; ---------------------------------------- + +(define b1 (box 1)) +(define b1c (chaperone-box b1 (lambda (b v) v) (lambda (b v) v))) +(define b1i (impersonate-box b1 (lambda (b v) (add1 v)) (lambda (b v) (sub1 v)))) + +(check (unbox b1) 1) +(check (set-box! b1 0) (void)) +(check (unbox b1) 0) + +(check (unbox b1c) 0) +(check (unbox b1i) 1) + +;; ---------------------------------------- + +(define (f x y) + (list x y)) + +(define fi (impersonate-procedure f (lambda (x y) + (values (- x) (- y))))) +(define fc (chaperone-procedure f (lambda (x y) + (values x y)))) + +(check (f 1 2) '(1 2)) +(check (|#%app| fc 1 2) '(1 2)) +(check (|#%app| fi 1 2) '(-1 -2)) + +(check (impersonator-of? fc f) #t) +(check (impersonator-of? fi f) #t) +(check (impersonator-of? fi fc) #f) +(check (impersonator-of? fc fi) #f) + +(check (chaperone-of? fc f) #t) +(check (chaperone-of? fi f) #f) +(check (chaperone-of? fi fc) #f) +(check (chaperone-of? fc fi) #t) + +(define fc2 (chaperone-procedure f + (lambda (x y) + (values (chaperone-vector + x + (lambda (v i e) e) + (lambda (v i e) e)) + y)))) + +(check (|#%app| fc2 v1 0) (list v1 0)) +(check (chaperone-of? (|#%app| fc2 v1 0) (list v1 0)) + #t) + +(define fc* (chaperone-procedure* f (lambda (orig x y) + (check orig fc*) + (values x y)))) +(check (|#%app| fc* 'a 'b) '(a b)) + +(define fiu (unsafe-chaperone-procedure f (lambda (x y) 'unsafe))) +(check (chaperone-of? fiu f) #t) +(check (|#%app| fiu 'a 'b) 'unsafe) +(check (|#%app| (chaperone-procedure fiu (lambda (x y) (values x y))) 'a 'b) + 'unsafe) + +;; ---------------------------------------- + +(define-values (iprop:flavor flavor? flavor-ref) + (make-impersonator-property 'flavor)) + +(check (|#%app| flavor? 1) #f) +(check (|#%app| flavor? f) #f) + +(define fcp (chaperone-procedure f + (lambda (x y) + (values x y)) + iprop:flavor 'spicy)) + +(check (|#%app| flavor? fcp) #t) +(check (|#%app| flavor-ref fcp) 'spicy) + +(check (|#%app| fcp 3 4) '(3 4)) + +;; ---------------------------------------- + +(define (g x y) + (list x y (continuation-mark-set->list + (current-continuation-marks) + 'calling))) + +(check (g 1 2) '(1 2 ())) + +(define gcam (chaperone-procedure g + (lambda (x y) + (values x y)) + impersonator-prop:application-mark + (cons 'calling 'london))) + +(check (|#%app| gcam 1 2) '(1 2 (london))) + +(check (with-continuation-mark 'calling 'madrid + (|#%app| gcam 1 2)) + '(1 2 (london))) + + +(define giam (impersonate-procedure g + (lambda (x y) + ;; Has a result wrapper, so call of `g` + ;; will not be in tail positions + (values (lambda (r) r) + x + (continuation-mark-set->list + (current-continuation-marks) + 'calling))) + impersonator-prop:application-mark + (cons 'calling 'paris))) + +(check (|#%app| giam 1 2) '(1 () (paris))) + +(check (with-continuation-mark 'calling 'madrid + (|#%app| giam 1 2)) + '(1 (madrid madrid) (paris madrid))) + +(check (|#%app| + (chaperone-procedure (lambda (x) (list + (continuation-mark-set->list + (current-continuation-marks) + 'a) + x)) + (lambda (x) (values 'mark 'a 'b x))) + 1) + '((b) 1)) + +;; ---------------------------------------- + +(let () + (define-values (prop:x x? x-ref) (make-struct-type-property 'x)) + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons prop:x 5)))) + (define-values (struct:s-b make-s-b s-b? s-b-ref s-b-set!) + (make-struct-type 's-b #f 2 0 #f '() #f 0)) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define s-b-y (make-struct-field-accessor s-b-ref 1 'y)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define counter 0) + (define last-flavor #f) + + (define s1 (make-s-a 1 2)) + (define s1c (chaperone-struct s1 + s-a-x (lambda (s v) (set! counter (add1 counter)) v) + x-ref (lambda (s v) (set! counter (add1 counter)) v))) + (define s1i (impersonate-struct s1 + s-a-x (lambda (s v) (list v)) + set-s-a-x! (lambda (s v) (box v)))) + + (define ps1 (make-s-b (lambda (c) (list c c)) 2)) + (define ps1i (impersonate-struct ps1 s-b-y (lambda (s v) (box v)))) + (define ps1ic (chaperone-procedure* ps1i (lambda (p v) + (set! last-flavor (and (|#%app| flavor? p) + (|#%app| flavor-ref p))) + (set! counter (add1 counter)) + v))) + (define ps1icp (impersonate-struct ps1ic struct:s-b iprop:flavor 'chocolate)) + + (check (chaperone-struct 7) 7) + (check (impersonate-struct 7) 7) + + (check (impersonator-of? s1c s1) #t) + + (check (s-a-x s1) 1) + (check (s-a-y s1) 2) + + (check counter 0) + (check (s-a-x s1c) 1) + (check counter 1) + (check (s-a-y s1c) 2) + (check counter 1) + + (check (s-a-x s1i) '(1)) + (check (s-a-y s1i) 2) + (check (set-s-a-x! s1i 0) (void)) + (check (s-a-x s1i) '(#&0)) + + (check counter 1) + (check (|#%app| s-a-ref s1c 1) 2) + (check counter 1) + (check (|#%app| s-a-ref s1c 0) '#&0) + (check counter 2) + + (check (|#%app| x-ref s1) 5) + (check counter 2) + (check (|#%app| x-ref s1c) 5) + (check counter 3) + + (check (|#%app| ps1 3) '(3 3)) + (check (|#%app| ps1i 3) '(3 3)) + (check (s-b-y ps1) 2) + (check (s-b-y ps1i) '#&2) + + (check counter 3) + (check (|#%app| ps1ic 3) '(3 3)) + (check counter 4) + (check last-flavor #f) + (check (|#%app| ps1icp 3) '(3 3)) + (check counter 5) + (check last-flavor 'chocolate) + + (void)) + +;; ---------------------------------------- + +(let () + (define ops null) + (define (push! v) (set! ops (cons v ops))) + (define (ops!) (begin0 (reverse ops) (set! ops '()))) + (define (ch ht) + (chaperone-hash ht + (lambda (ht k) + (push! 'get) + (values k (lambda (ht k v) + (push! 'got) + v))) + (lambda (ht k v) (push! 'set) (values k v)) + (lambda (ht k) (push! 'remove) k) + (lambda (ht k) (push! 'key) k) + (lambda (ht) (push! 'clear)) + (lambda (ht k) (push! 'equal-key) k))) + (define ht1 (hash 1 'a 2 'b)) + (define ht1c (ch ht1)) + (define ht2 (make-hash)) + (define ht2c (ch ht2)) + + (hash-set! ht2 1 'a) + (hash-set! ht2 2 'b) + + (check (ops!) '()) + + (check (hash-ref ht1c 1) 'a) + (check (ops!) '(get equal-key got)) + (check (hash-ref ht2c 1) 'a) + (check (ops!) '(get equal-key got)) + + (check (hash-ref ht1c 2) 'b) + (check (ops!) '(get equal-key got)) + (check (hash-ref ht2c 2) 'b) + (check (ops!) '(get equal-key got)) + + (check (hash-ref (hash-set ht1c 3 'c) 3) 'c) + (check (ops!) '(set equal-key get equal-key got)) + (check (begin (hash-set! ht2c 3 'c) + (hash-ref ht2c 3)) + 'c) + (check (ops!) '(set equal-key get equal-key got)) + (check (begin (hash-set! ht2c 4 'd) + (hash-ref ht2 4)) + 'd) + (check (ops!) '(set equal-key)) + + (check (hash-ref (hash-remove ht1c 1) 1 'none) 'none) + (check (ops!) '(remove equal-key get equal-key)) + (check (begin + (hash-remove! ht2c 1) + (hash-ref ht2c 1 'none)) + 'none) + (check (ops!) '(remove equal-key get equal-key)) + + (check (hash-clear! ht2c) (void)) + (check (ops!) '(clear)) + (check (hash-set! ht2c 1 'a) (void)) + (check (ops!) '(set equal-key)) + + (check (hash-map ht2c cons) '((1 . a))) + (check (ops!) '(key get equal-key got)) + + (let ([i (hash-iterate-first ht2c)]) + (check (ops!) '()) + (check (hash-iterate-key ht2c i) 1) + (check (ops!) '(key)) + (check (hash-iterate-value ht2c i) 'a) + (check (ops!) '(key get equal-key got))) + + (check (equal? (hash-remove ht1c 5) ht1c) #t) + + ;; Check that hash table updates maintain chaperone identity + (check (chaperone-of? (hash-remove ht1c 5) ht1c) #t) + (check (chaperone-of? (hash-set (hash-remove ht1c 1) 1 'a) ht1c) #t) + (check (chaperone-of? (hash-set (hash-remove ht1c 1) 1 'aa) ht1c) #f) + (check (chaperone-of? ht1 (hash-remove ht1c 5)) #f) + + (void)) + +;; ---------------------------------------- +;; `prop:impersonator-of` + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons prop:equal+hash + ;; Equality compares only the first field + (list + (lambda (a b eql?) + (eql? (|#%app| s-a-ref a 0) + (|#%app| s-a-ref b 0))) + (lambda (a hc) + (hc (|#%app| s-a-ref a 0))) + (lambda (a hc) + (hc (|#%app| s-a-ref a 0))))) + (cons prop:impersonator-of + ;; Second field contains impersonated record + (lambda (a) + (|#%app| s-a-ref a 1)))))) + + (define a1 (make-s-a 1 #f)) + (define a1i (make-s-a #f a1)) + + (check (equal? a1 (make-s-a 1 #f)) #t) + (check (equal? a1 (make-s-a 3 #f)) #f) + + (check (equal? a1 a1i) #t) + (check (equal? a1i a1) #t) + (check (impersonator-of? a1i a1) #t) + (check (impersonator-of? a1 a1i) #f) + + (check (chaperone-of? a1i a1) #f) + (check (chaperone-of? a1 a1i) #f) + + (void)) + +;; ---------------------------------------- +;; `chaperone-struct-unsafe-undefined` + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f)) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define set-s-a-y! (make-struct-field-mutator s-a-set! 1 'y)) + + (define a1 (make-s-a 1 unsafe-undefined)) + (define a1c (chaperone-struct-unsafe-undefined a1)) + + (check unsafe-undefined (|#%app| s-a-ref a1 1)) + (check 1 (|#%app| s-a-ref a1c 0)) + (check 1 (s-a-x a1c)) + (check-error (|#%app| s-a-ref a1c 1)) + (check-error (s-a-y a1c)) + + (void)) + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons + prop:chaperone-unsafe-undefined + '(y x))))) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define set-s-a-y! (make-struct-field-mutator s-a-set! 1 'y)) + + (define a1 (|#%app| make-s-a 1 unsafe-undefined)) + + (check 1 (|#%app| s-a-ref a1 0)) + (check 1 (s-a-x a1)) + (check-error (|#%app| s-a-ref a1 1)) + (check-error (s-a-y a1)) + + (void)) diff -Nru racket-6.12+ppa1/src/cs/demo/control.ss racket-7.0+ppa1/src/cs/demo/control.ss --- racket-6.12+ppa1/src/cs/demo/control.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/control.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,639 @@ +(import (rumble) + (rename (only (chezscheme) dynamic-wind) + (dynamic-wind chez:dynamic-wind))) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v a]) + (unless (equal? v b) + (error 'check (format "failed ~s => ~s" 'a v))))])) + +(define check-abort-tag (make-continuation-prompt-tag 'check-abort)) + +(define-syntax check-error + (syntax-rules () + [(_ a s) + (let ([v (call-with-continuation-prompt + (lambda () + (with-continuation-mark + exception-handler-key + (lambda (exn) + (if (exn? exn) + (abort-current-continuation + check-abort-tag + (lambda () (exn-message exn))) + exn)) + a)) + check-abort-tag)] + [es s]) + (unless (and (string? v) + (>= (string-length v) (string-length es)) + (string=? es (substring v 0 (string-length es)))) + (error 'check (format "failed ~s != ~s" v es))))])) + +(define tag1 (make-continuation-prompt-tag 'tag1)) +(define tag2 (make-continuation-prompt-tag 'tag2)) + +(check (eq? (make-continuation-prompt-tag) + (make-continuation-prompt-tag)) + #f) + +(check (call-with-continuation-prompt + (lambda () 10)) + 10) + +(check (call-with-continuation-prompt + (lambda () 10) + tag1) + 10) + +(check (let ([saved #f]) + (let ([a (call-with-continuation-prompt + (lambda () + (+ 10 + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + tag1)]) + (list a + (|#%app| saved -12)))) + (list 22 -2)) + +(check (let ([saved #f]) + (let ([a (call-with-continuation-prompt + (lambda () + (+ 10 + (call-with-continuation-prompt + (lambda () + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1)) + tag2))) + tag1)]) + (list a + (|#%app| saved -12)))) + (list 22 -2)) + +;; Shouldn't take long or use much memory: +(check (call-with-continuation-prompt + (lambda () + (let loop ([n 1000000]) + (call-with-composable-continuation + (lambda (k) + (if (zero? n) + 'ok + ;; In tail position: + (loop (sub1 n)))) + tag1))) + tag1) + 'ok) + +;; Also shouldn't take long or use much memory: +(check (let ([old-k (lambda (p) (p))] + [n 100000]) + (call-with-continuation-prompt + (lambda () + (let loop () + ((call-with-composable-continuation + (lambda (k) + (let ([prev-k old-k]) + (set! old-k k) + (|#%app| prev-k (lambda () + (call-with-composable-continuation + (lambda (k) + (cond + [(zero? n) + (lambda () 'also-ok)] + [else + (set! n (sub1 n)) + loop]))))))) + tag1)))) + tag1)) + 'also-ok) + +(check (let ([t (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (abort-current-continuation + t + 17)) + (make-continuation-prompt-tag))) + t + values)) + 17) + +(check (let ([syms null]) + (let ([v (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () 'ok) + (lambda () (set! syms (cons 'out syms))))]) + (cons v syms))) + '(ok out in)) + +(check (let ([syms null]) + (let ([v (call-with-current-continuation + (lambda (esc) + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () (|#%app| esc 'esc)) + (lambda () (set! syms (cons 'out syms))))))]) + (cons v syms))) + '(esc out in)) + +(check (let ([syms null]) + (let ([v (call-with-current-continuation + (lambda (esc) + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (call-with-continuation-prompt + (lambda () + 'in-prompt))) + (lambda () (set! syms (cons 'out syms))))))]) + (cons v syms))) + '(in-prompt out in)) + +(check (let ([saved #f] + [syms null]) + (let ([a (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (+ 10 + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + (lambda () (set! syms (cons 'out syms))))) + tag1)]) + (let ([b (|#%app| saved -10)]) + (list a + b + syms)))) + (list 22 0 '(out in out in))) + +(check (let ([saved #f]) + (with-continuation-mark + 'x 0 + (let ([a (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x 1 + (begin + (call-with-composable-continuation + (lambda (k) + (set! saved k))) + (continuation-mark-set->list + (current-continuation-marks) + 'x)))))]) + (list a + (|#%app| saved #f))))) + '((1) (1 0))) + +(check (call-with-current-continuation + (lambda (k) + (|#%app| k 0))) + 0) + +(check (call-with-current-continuation + (lambda (k) + (call-with-continuation-prompt + (lambda () + (|#%app| k 100)) + tag1))) + 100) + +(check (let ([syms null]) + (let ([saved #f]) + (let ([v + (call-with-continuation-prompt + (lambda () + ;; This metacontinuation frame will be shared between the + ;; capture and invocation: + (dynamic-wind + (lambda () (set! syms (cons 'in0 syms))) + (lambda () + (let ([a (call-with-continuation-prompt + (lambda () + ;; This metacontinuation frame will not + ;; be shared: + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (+ 10 + (call-with-current-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + (lambda () (set! syms (cons 'out syms))))) + tag1)]) + (let ([b (call-with-continuation-prompt + (lambda () + (|#%app| saved -8)) + tag1)]) + (list a b)))) + (lambda () (set! syms (cons 'out0 syms))))))]) + (list v syms)))) + (list (list 22 2) '(out0 out in out in in0))) + +;; ---------------------------------------- +;; Escape continuations + +(check (call-with-escape-continuation + (lambda (k) + (+ 1 (|#%app| k 'esc)))) + 'esc) + +(check (let-values ([(k ek) + (call-with-continuation-prompt + (lambda () + (call-with-escape-continuation + (lambda (ek) + (let-values ([(k0 ek0) + ((call-with-composable-continuation + (lambda (k) + (lambda () (values k ek)))))]) + (values k0 (box ek0)))))))]) + (let-values ([(k2 ek2) + (|#%app| k (lambda () (|#%app| (unbox ek) 'none 'skip)))]) + ek2)) + 'skip) + +(check-error (|#%app| (call-with-escape-continuation + (lambda (k) k))) + "continuation application: attempt to jump into an escape continuation") + +(check (with-continuation-mark + 'x 1 + (call-with-escape-continuation + (lambda (k) + (with-continuation-mark + 'x 2 + (continuation-mark-set->list (rumble:continuation-marks k) 'x))))) + '(1)) + +(check-error (rumble:continuation-marks (call-with-escape-continuation + (lambda (k) k))) + "continuation application: escape continuation not in the current continuation") + +;; ---------------------------------------- +;; Barriers + +(check (call-with-continuation-barrier + (lambda () + 'ok)) + 'ok) + +(check-error (call-with-continuation-prompt + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-composable-continuation + (lambda (k) + k) + (make-continuation-prompt-tag)))))) + "call-with-composable-continuation: continuation includes no prompt with the given tag") + +(check-error (call-with-continuation-prompt + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-composable-continuation + (lambda (k) + k)))))) + "call-with-composable-continuation: cannot capture past continuation barrier") + +(check-error (let ([k (call-with-continuation-barrier + (lambda () + (call-with-current-continuation + (lambda (k) + k))))]) + (|#%app| k void)) + "continuation application: attempt to cross a continuation barrier") + +;; ---------------------------------------- +;; Continuation marks + +(printf "Constant-time `continuation-mark-set-first` makes these tests fast enough...\n") + +;; Caching within a metacontinuation frame +(let ([N 100000]) + (check (let loop ([n N]) + (cond + [(zero? n) + (check (length (continuation-mark-set->list + (current-continuation-marks) + 'there)) + N) + n] + [else + (if (continuation-mark-set-first #f 'not-there #f) + 'oops + (with-continuation-mark + 'there n + (- (loop (sub1 n)) 1)))])) + (- N))) + +;; Caching across metacontinuation frames +(let ([N 10000]) + (check (let loop ([n N]) + (cond + [(zero? n) + (check (length (continuation-mark-set->list + (current-continuation-marks) + 'there)) + N) + n] + [else + (if (continuation-mark-set-first #f 'not-there #f) + 'oops + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'there n + (- (loop (sub1 n)) 1))) + tag1))])) + (- N))) + +(printf "Done.\n") + +(check (call-with-immediate-continuation-mark + 'not-there + (lambda (v) v)) + #f) +(check (call-with-immediate-continuation-mark + 'not-there + (lambda (v) v) + 'no) + 'no) +(check (with-continuation-mark + 'there 1 + (call-with-immediate-continuation-mark + 'there + (lambda (v) v))) + 1) +(check (with-continuation-mark + 'there 1 + (list + (call-with-immediate-continuation-mark + 'there + (lambda (v) v)))) + '(#f)) + +(define (non-tail v) (values v)) + +(check (with-continuation-mark + 'x1 1 + (with-continuation-mark + 'x2 1 + (non-tail + (with-continuation-mark + 'x1 2 + (non-tail + (with-continuation-mark + 'x2 3 + (values + (continuation-mark-set->list* + (current-continuation-marks) + '(x1 x2) + (default-continuation-prompt-tag) + 'nope)))))))) + '(#(nope 3) #(2 nope) #(1 1))) + +;; Make sure caching doesn't ignore the prompt tag +;; for a continuation-mark lookup +(check (with-continuation-mark + 'x 1 + (non-tail + (with-continuation-mark + 'y 2 + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (let ([a (continuation-mark-set-first #f 'x)]) + (list a + (continuation-mark-set-first #f 'x #f tag1)))) + tag2)) + tag1)))) + '(1 #f)) + +;; ---------------------------------------- +;; Engines + +(define e (make-engine (lambda () 'done) #f #f)) +(check (cdr (e 20 void list vector)) + '(done)) + +(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) +(check (vector? (e-forever 10 void list vector)) + #t) + +(define e-10 (make-engine (lambda () + (let loop ([n 10]) + (cond + [(zero? n) + (engine-return 1 2 3) + (loop 0)] + [else + (engine-block) + (loop (sub1 n))]))) + #f #f)) +(check (let ([started 0]) + (let loop ([e e-10] [n 0]) + (e 100 + (lambda () (set! started (add1 started))) + (lambda (remain a b c) (list a b c n started)) + (lambda (e) + (loop e (add1 n)))))) + '(1 2 3 10 11)) + +;; Check that winders are not run on engine swaps: +(let ([pre 0] + [post 0]) + (let ([e-10/dw (make-engine (lambda () + (let loop ([n 10]) + (cond + [(zero? n) + (values 1 2 3 pre post)] + [else + (engine-block) + (dynamic-wind + (lambda () (set! pre (add1 pre))) + (lambda () (loop (sub1 n))) + (lambda () (set! post (add1 post))))]))) + #f #f)]) + (check (let loop ([e e-10/dw] [n 0]) + (e 200 + void + (lambda (remain a b c pre t-post) (list a b c pre t-post post n)) + (lambda (e) + (loop e (add1 n))))) + '(1 2 3 10 0 10 10)))) + +;; ---------------------------------------- +;; Thread cells (which are really engine cells): + +(let ([ut (make-thread-cell 1)] + [pt (make-thread-cell 100 #t)]) + (define (gen) + (define u-old (thread-cell-ref ut)) + (define p-old (thread-cell-ref pt)) + (thread-cell-set! ut (add1 u-old)) + (thread-cell-set! pt (add1 p-old)) + (list u-old + p-old + (make-engine gen #f #f) + (thread-cell-ref ut) + (thread-cell-ref pt))) + (define l1 ((make-engine gen #f #f) + 100 + void + (lambda (remain l) l) + (lambda (e) (error 'engine "oops")))) + (define l2 ((list-ref l1 2) + 100 + void + (lambda (remain l) l) + (lambda (e) (error 'engine "oops")))) + (check (list-ref l1 0) 1) + (check (list-ref l1 1) 100) + (check (list-ref l1 3) 2) + (check (list-ref l1 4) 101) + (check (list-ref l2 0) 1) + (check (list-ref l2 1) 101) + (check (list-ref l2 3) 2) + (check (list-ref l2 4) 102)) + +;; ---------------------------------------- +;; Parameters: + +(define my-param (make-parameter 'init)) +(check (procedure? my-param) #t) +(let ([e (with-continuation-mark parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set) + (make-engine (lambda () (|#%app| my-param)) #f #f))]) + (check (|#%app| my-param) 'init) + (check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set)) + +(let ([also-my-param (make-derived-parameter my-param + (lambda (v) (list v)) + (lambda (v) (box v)))]) + (check (procedure? also-my-param) #t) + (check (|#%app| my-param) 'init) + (with-continuation-mark parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) also-my-param 'set) + (begin + (check (|#%app| my-param) '(set)) + (check (|#%app| also-my-param) '#&(set))))) + +;; ---------------------------------------- +;; Prompt-tag impersonators + +(let ([tag1i (impersonate-prompt-tag tag1 + ;; handle + (lambda (args) (list 'handle args)) + ;; abort: + (lambda (args) (list 'abort args)) + ;; cc-guard: + (lambda (result) (list 'cc-guard result)) + ;; call-triggered guard impersonator: + (lambda (proc) (lambda (result) + (list 'cc-use (proc result)))))]) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1 'bye)) + tag1 + (lambda (arg) + (list 'aborted arg))) + (list 'aborted 'bye)) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1 'bye)) + tag1i + (lambda (arg) + (list 'aborted arg))) + (list 'aborted (list 'handle 'bye))) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1i 'bye)) + tag1 + (lambda (arg) + (list 'aborted arg))) + (list 'aborted (list 'abort 'bye))) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1)) + tag1i + (lambda (arg) 'oops)) + (list 'cc-guard 'jump)) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1i)) + tag1 + (lambda (arg) 'oops)) + (list 'cc-use 'jump)) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1i)) + tag1i + (lambda (arg) 'oops)) + (list 'cc-use (list 'cc-guard 'jump))) + (void)) + +;; ---------------------------------------- +;; call-with-system-wind + +(define e-sw (make-engine (let ([pre 0] + [post 0]) + (lambda () + (call-with-system-wind + (lambda () + (chez:dynamic-wind + (lambda () + (set! pre (add1 pre))) + (lambda () + (let loop ([n 1000]) + (if (zero? n) + (list pre post) + (loop (sub1 n))))) + (lambda () + (set! post (add1 post)))))))) + #f #f)) + +(check (let ([prefixes 0]) + (let loop ([e e-sw] [i 0]) + (e 100 + (lambda () (set! prefixes (add1 prefixes))) + (lambda (remain v) (list (> i 2) + (= prefixes (add1 i)) + (- (car v) i) + (- (cadr v) i))) + (lambda (e) (loop e (add1 i)))))) + '(#t #t 1 0)) + +;; ---------------------------------------- + +(call-with-continuation-prompt + (lambda () + (error 'demo "this is an intended error")) + tag1) diff -Nru racket-6.12+ppa1/src/cs/demo/expander.ss racket-7.0+ppa1/src/cs/demo/expander.ss --- racket-6.12+ppa1/src/cs/demo/expander.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/expander.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,72 @@ +(import (rumble) + (expander) + (io)) + +(define time-compiler-passes? (getenv "PLT_COMPILER_TIMES")) + +(define (show v) (write v) (newline)) + +(call-in-main-thread + (lambda () + (boot) + + (set-exec-file! (path->complete-path (string->path "../../bin/racket"))) + + (namespace-require ''|#%kernel|) + + (expand '1) + (eval '((lambda (x) x) 1)) + + (eval '(module m '|#%kernel| + (|#%require| (for-syntax '|#%kernel|)) + (define-syntaxes (m) + (lambda (stx) + (quote-syntax 'ex))) + (define-values (x) (m)) + (|#%provide| x))) + (eval '(|#%require| 'm)) + (eval 'x) + + (let () + (define (run s) + (show (eval (read (open-input-string s))))) + ;; (run "'x") + (void)) + + (|#%app| use-compiled-file-paths '()) ; => expand from source + (|#%app| current-library-collection-links + (find-library-collection-links)) + (|#%app| current-library-collection-paths + (find-library-collection-paths)) + + (when time-compiler-passes? + (#%$enable-pass-timing #t)) + + (time (eval '(|#%require| racket/base))) + + ;;(time (eval `(|#%require| "../regexp/demo.rkt"))) + ;;(time (eval `(|#%require| "../../../pkgs/expander/main.rkt"))) + + (when time-compiler-passes? + (let ([l (sort + (lambda (a b) (< (cdr a) (cdr b))) + (map (lambda (r) (cons (car r) + (let ([t (caddr r)]) + (+ (* 1000. (time-second t)) + (/ (time-nanosecond t) 1000000.))))) + (#%$pass-stats)))] + [pad (lambda (s len) + (let ([s (format "~a" s)]) + (string-append (make-string (max 0 (- len (string-length s))) #\space) + s)))] + [dec (lambda (s) (let ([s (format "~a" (/ (round (* s 100)) 100))]) + (if (char=? #\. (string-ref s (- (string-length s) 2))) + (string-append s "0") + s)))]) + (for-each (lambda (p) (printf "~a: ~a\n" + (pad (car p) 30) + (pad (dec (cdr p)) 8))) + (append l + (list (cons 'total (apply + (map cdr l)))))))) + + (void))) diff -Nru racket-6.12+ppa1/src/cs/demo/foreign.ss racket-7.0+ppa1/src/cs/demo/foreign.ss --- racket-6.12+ppa1/src/cs/demo/foreign.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/foreign.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,73 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ got expect) + (let ([v got] + [expect-v expect]) + (unless (equal? v expect-v) + (error 'check (format "failed: ~s => ~s" 'got v))))])) + +;; ---------------------------------------- + +(define m1 (malloc 24)) + +(check (ptr-set! m1 _int32 99) (void)) +(check (ptr-ref m1 _int32) 99) + +(define _idi (make-cstruct-type (list _int32 _double _int32))) + +(check (ctype-alignof _idi) 8) +(check (ctype-sizeof _idi) 24) ; due to alignment + +(define an-idi (malloc _idi)) +(ptr-set! an-idi _int32 99) +(ptr-set! an-idi _double 1 99.9) + +(check (ptr-ref an-idi _double 'abs 8) 99.9) + +(define double-of-an-idi (ptr-add an-idi 8)) +(check (ptr-ref double-of-an-idi _double) 99.9) + +(define icell (malloc-immobile-cell cons)) +(check (ptr-ref icell _scheme) cons) +(ptr-set! icell _scheme car) +(check (ptr-ref icell _scheme) car) +(free-immobile-cell icell) + +;; ---------------------------------------- + +(define sym1 (gensym)) +(define s/done? #f) +(define done 0) + +(define wb (make-weak-box sym1)) + +(define we/s (rumble:make-stubborn-will-executor void)) +(rumble:will-register we/s sym1 (lambda (s) + (unless (eq? s (weak-box-value wb)) + (error 'stubborn-executor-test "box context wrong")) + (set! s/done? (symbol? s)))) + +(define we (rumble:make-will-executor void)) +(rumble:will-register we sym1 (letrec ([will (lambda (s) + (when s/done? + (error 'stubborn-executor-test "done too early")) + (set! done (add1 done)) + (unless (= done 10) + (rumble:will-register we s will)))]) + will)) + +(set! sym1 #f) + +(define (run p) (when p ((car p) (cdr p)))) + +(let loop () + (unless s/done? + (collect (collect-maximum-generation)) + (run (rumble:will-try-execute we/s)) + (run (rumble:will-try-execute we)) + (loop))) +(collect (collect-maximum-generation)) +(unless (not (weak-box-value wb)) + (error 'stubborn-executor-test "weak box still has a value")) diff -Nru racket-6.12+ppa1/src/cs/demo/hash.ss racket-7.0+ppa1/src/cs/demo/hash.ss --- racket-6.12+ppa1/src/cs/demo/hash.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/hash.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,425 @@ +(import (rumble)) + +(define-syntax time + (syntax-rules () + [(_ expr1 expr ...) + (let ([pre-mem (current-memory-use 'cumulative)]) + (let-values ([(v cpu user gc) (time-apply (lambda () expr1 expr ...) null)]) + (printf "cpu time: ~s real time: ~s gc time: ~s MB: ~s\n" cpu user gc + (quotient (- (current-memory-use 'cumulative) pre-mem) (* 1024 1024))) + (apply values v)))])) + +(define-values (struct:top top top? top-ref top-set!) + (make-struct-type 'top #f 2 0 #f + (list (cons prop:equal+hash + (list + (lambda (a b eql?) + (eql? (top-1 a) + (top-1 b))) + (lambda (a hc) + (hc (top-1 a))) + (lambda (a hc) + (hc (top-1 a)))))))) +(define top-1 (make-struct-field-accessor top-ref 0)) + +(define-values (struct:trans trans trans? trans-ref trans-set!) + (make-struct-type 'top #f 2 0 #f '() #f)) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([av a] + [bv b]) + (unless (equal? av bv) + (error 'check (format "failed ~s = ~s [expected ~s]" 'a av bv))))])) + +(check (equal? (top 1 2) (top 1 3)) #t) +(check (equal? (top 1 2) (top 2 2)) #f) +(check (hash-ref (hash-set (hash) (top 1 2) 'ok) (top 1 3) #f) 'ok) + +(check (equal? (trans 1 2) (trans 1 2)) #t) +(check (equal? (trans 1 2) (trans 1 3)) #f) +(check (hash-ref (hash-set (hash) (trans 1 2) 'ok) (trans 1 2) #f) 'ok) +(check (hash-ref (hash-set (hash) (trans 1 2) 'ok) (trans 1 3) #f) #f) + +(check (equal? (hash 1 'x 2 'y) (hash 2 'y 1 'x)) #t) +(check (hash-ref (hash (hash 1 'x 2 'y) 7) (hash 2 'y 1 'x) #f) 7) + +;; Check `equal?`-based weak hash tables +(let ([ht (make-weak-hash)] + [apple (string #\a #\p #\p #\l #\e)] + [banana (list "banana")]) + (check (hash-ref ht "apple" 'no) 'no) + (check (hash-set! ht apple 'yes) (void)) + (check (hash-ref ht "apple" 'no) 'yes) + (check (hash-ref ht apple 'no) 'yes) + (check (hash-set! ht apple banana) (void)) + (let ([bp (weak-cons banana #f)]) + (set! apple #f) + (set! banana #f) + (collect (collect-maximum-generation)) + (collect (collect-maximum-generation)) + (check (car bp) #!bwp) + ;; Ensure that `ht` stays live until here + (check (hash? ht) #t))) + +(define (shuffle l) + (define a (make-vector (length l))) + (let loop ([l l] [i 0]) + (unless (null? l) + (let ([x (car l)]) + (let ([j (random (add1 i))]) + (unless (= j i) (vector-set! a i (vector-ref a j))) + (vector-set! a j x))) + (loop (cdr l) (add1 i)))) + (vector->list a)) + +(define l (values #;shuffle (let loop ([i 1000]) + (if (zero? i) + '() + (cons i (loop (sub1 i))))))) + +(printf "large tables\n") +(time + (let loop ([j 1000]) + (define numbers + (let loop ([ht (hasheqv)] [l l]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hash-ref numbers i (lambda () (error 'oops "bad"))) (sub1 i)))) + (loop (sub1 j))))) +(time + (let loop ([j 1000]) + (define numbers + (let loop ([ht (hasheq)] [l l]) + (if (null? l) + ht + (loop (hash-set ht l #t) (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [l l]) + (if (null? l) + v + (loop (hash-ref numbers l (lambda () (error 'oops "bad"))) (cdr l)))) + (loop (sub1 j))))) + +(printf "small tables\n") +(time + (let loop ([j 100000]) + (define numbers + (let loop ([ht (hasheqv)] [i 10]) + (if (zero? i) + ht + (loop (hash-set ht i #t) (sub1 i))))) + (define numbers2 + (let loop ([ht (hasheqv)] [i 10]) + (if (zero? i) + ht + (loop (hash-set ht i #t) (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (and (hash-keys-subset? numbers numbers2) + (loop (hash-ref numbers i (lambda () (error 'oops "bad"))) (sub1 i))))) + (loop (sub1 j))))) + +(define numbers + (let loop ([ht (hasheqv)] [l l]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + +(printf "safe iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first numbers)] [c (hash-count numbers)]) + (if i + (loop (hash-iterate-value numbers i) + (hash-iterate-next numbers i) + (fx1- c)) + (if (zero? c) + v + (error 'safe-iterate "not enough")))) + (loop (sub1 j))))) + +(printf "unsafe iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (unsafe-immutable-hash-iterate-first numbers)] [c (hash-count numbers)]) + (if i + (loop (unsafe-immutable-hash-iterate-value numbers i) + (unsafe-immutable-hash-iterate-next numbers i) + (fx1- c)) + (if (zero? c) + v + (error 'unsafe-iterate "not enough")))) + (loop (sub1 j))))) + +(printf "safe vs. unsafe on small table\n") +(let ([ht (let loop ([ht (hasheq)] [i 8]) + (if (zero? i) + ht + (loop (hash-set ht (gensym) #t) (sub1 i))))] + [N 1000000]) + (time + (let loop ([j N]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first ht)]) + (if i + (loop (hash-iterate-value ht i) + (hash-iterate-next ht i)) + v)) + (loop (sub1 j))))) + (time + (let loop ([j N]) + (unless (zero? j) + (let loop ([v #f] [i (unsafe-immutable-hash-iterate-first ht)]) + (if i + (loop (unsafe-immutable-hash-iterate-value ht i) + (unsafe-immutable-hash-iterate-next ht i)) + v)) + (loop (sub1 j)))))) + +;; ---------------------------------------- + +(printf "mutable large tables\n") +(time + (let loop ([j 1000]) + (define numbers (make-hash)) + (let loop ([l l]) + (if (null? l) + (void) + (begin + (hash-set! numbers (car l) #t) + (loop (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hash-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(printf "mutable small tables\n") +(time + (let loop ([j 100000]) + (define numbers (make-hash)) + (let loop ([i 10]) + (if (zero? i) + (void) + (begin + (hash-set! numbers i #t) + (loop (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (loop (hash-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(define mut-numbers (make-hasheqv)) +(let loop ([l l]) + (unless (null? l) + (hash-set! mut-numbers (car l) #t) + (loop (cdr l)))) + +(printf "mutable iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first mut-numbers)]) + (if i + (loop (hash-iterate-value mut-numbers i) + (hash-iterate-next mut-numbers i)) + v)) + (loop (sub1 j))))) + +(printf "mutable for-each\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let ([a #f]) + (hash-for-each mut-numbers (lambda (k v) (set! a v)))) + (loop (sub1 j))))) + +(printf "mutable destructive for-each\n") +(time + (let loop ([j 1000]) + (define ht (hash-copy mut-numbers)) + (unless (zero? j) + (let ([count 0]) + (hash-for-each ht + (lambda (k v) + (set! count (add1 count)) + (hash-remove! ht k))) + (unless (= count (hash-count mut-numbers)) + (error 'mutable-for-each-remove! "bad count"))) + (loop (sub1 j))))) + +;; ---------------------------------------- + +(printf "primitive mutable large tables\n") +(time + (let loop ([j 1000]) + (define numbers (make-hashtable equal-hash-code equal?)) + (let loop ([l l]) + (if (null? l) + (void) + (begin + (hashtable-set! numbers (car l) #t) + (loop (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hashtable-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(printf "primitive mutable small tables\n") +(time + (let loop ([j 100000]) + (define numbers (make-hashtable equal-hash-code equal?)) + (let loop ([i 10]) + (if (zero? i) + (void) + (begin + (hashtable-set! numbers i #t) + (loop (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (loop (hashtable-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +;; ---------------------------------------- + +(printf "weak equal table\n") +(let ([ht (make-weak-hash)]) + (define evens + (let loop ([i 1000]) + (define s (format "~a" i)) + (hash-set! ht s i) + (cond + [(zero? i) '()] + [(even? i) + (cons s (loop (sub1 i)))] + [else (loop (sub1 i))]))) + (collect) + (printf "~s\n" (hash-count ht)) + (hash-set! ht "300" 'three-hundred) + (hash-remove! ht "302") + (for-each (lambda (e) + (define v (hash-ref ht (number->string (string->number e)) #f)) + (cond + [(equal? e "302") + (when v (error 'weak "present"))] + [else + (unless v + (error 'weak "missing ~s" e)) + (unless (equal? v (if (equal? e "300") + 'three-hundred + (string->number e))) + (error 'weak "wrong value"))])) + evens) + (let loop ([i (hash-iterate-first ht)] [c 0]) + (if i + (begin + (check (string? (hash-iterate-key ht i)) #t) + (loop (hash-iterate-next ht i) (add1 c))) + (check (hash-count ht) c))) + (check (positive? (length evens)) #t)) + +(check (hash-iterate-first (make-weak-hash)) #f) + +;; ---------------------------------------- + +(let loop ([i 1000]) + (unless (zero? i) + (let ([l2 (list-tail (shuffle l) (quotient (length l) 2))]) + (define half-numbers + (let loop ([ht (hasheqv)] [l l2]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + (unless (hash-keys-subset? half-numbers numbers) + (error 'subset? "failed")) + (loop (sub1 i))))) + +;; ---------------------------------------- + +(printf "many tables\n") +(collect-garbage) +(define m1 (current-memory-use)) +(define hts + (time + (let loop ([i 0]) + (if (< i 100) + (cons + (let loop2 ([i 0]) + (if (< i 10000) + (hash-set + (loop2 (+ i 1)) + (gensym) + (cons (random 100) (random 100))) + (hasheq))) + (loop (+ 1 i))) + null)))) +(collect-garbage) +(printf "~a\n" (- (current-memory-use) m1)) + +;; ---------------------------------------- + +(printf "test hashing function, counting collisions\n") +(let* ([convert (lambda (l) + (case (random 4) + [(0) l] + [(1) (list->vector l)] + [(2) (box l)] + [(3) (map exact->inexact l)]))] + [l (let loop ([i 1000]) + (if (zero? i) + '() + (cons (convert + (let loop ([j (add1 (random 3))]) + (if (zero? j) + '() + (cons (random 10000) (loop (sub1 j)))))) + (loop (sub1 i)))))]) + (define len (length l)) + (define c-vec (make-vector len)) + (define r-vec (make-vector len)) + (define c-coll (make-hash)) + (define r-coll (make-hash)) + (for-each (lambda (i) + (define c-k (modulo (equal-hash i) len)) + (define r-k (modulo (equal-hash-code i) len)) + (vector-set! c-vec c-k (add1 (vector-ref c-vec c-k))) + (vector-set! r-vec r-k (add1 (vector-ref r-vec r-k)))) + l) + (let loop ([i 0]) + (unless (= i len) + (let () + (define (count coll vec) + (define n (vector-ref vec i)) + (hash-set! coll n (+ 1 (hash-ref coll n 0)))) + (count c-coll c-vec) + (count r-coll r-vec) + (loop (add1 i))))) + (let () + (define (report which coll) + (printf " ~a:\n" which) + (let ([keys (sort < (hash-map coll (lambda (k v) k)))]) + (for-each (lambda (k) + (printf " ~a: ~a\n" k (hash-ref coll k))) + keys))) + (report "equal-hash" c-coll) + (report "equal-hash-code" r-coll)) + (time (for-each (lambda (i) (for-each equal-hash l)) l)) + (time (for-each (lambda (i) (for-each equal-hash-code l)) l))) diff -Nru racket-6.12+ppa1/src/cs/demo/io-impl.rkt racket-7.0+ppa1/src/cs/demo/io-impl.rkt --- racket-6.12+ppa1/src/cs/demo/io-impl.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/io-impl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,101 @@ +#lang racket/base +(require racket/include + racket/unsafe/ops + racket/flonum + racket/fixnum + '#%foreign + (only-in '#%kernel open-input-file) + (only-in '#%paramz + parameterization-key + extend-parameterization + break-enabled-key + check-for-break) + (only-in '#%linklet + primitive-table)) + +(provide (rename-out + (1/build-path/convention-type build-path/convention-type) + (1/peek-bytes! peek-bytes!) + (1/explode-path explode-path) + (1/peek-byte peek-byte) + (1/write write) + (1/fprintf fprintf) + (1/write-bytes-avail write-bytes-avail) + (1/open-output-bytes open-output-bytes) + (1/open-input-file open-input-file) + (1/write-bytes-avail* write-bytes-avail*) + (1/path-element->string path-element->string) + (1/simplify-path simplify-path) + (1/bytes->string/locale bytes->string/locale) + (1/error error) + (1/current-input-port current-input-port) + (1/path->directory-path path->directory-path) + (1/read-bytes-avail!* read-bytes-avail!*) + (1/make-pipe make-pipe) + (1/write-string write-string) + (1/bytes->path bytes->path) + (1/pathbytes/latin-1 string->bytes/latin-1) + (is-path? path?) + (1/bytes->string/utf-8 bytes->string/utf-8) + (1/path->bytes path->bytes) + (1/format format) + (1/newline newline) + (1/string->bytes/utf-8 string->bytes/utf-8) + (1/string->bytes/locale string->bytes/locale) + (1/read-bytes read-bytes) + (pipe-input-port? pipe-input-port?) + (1/string->path-element string->path-element) + (1/peek-char peek-char) + (1/absolute-path? absolute-path?) + (1/path-convention-type path-convention-type) + (1/path->complete-path path->complete-path) + (1/bytes-utf-8-length bytes-utf-8-length) + (1/cleanse-path cleanse-path) + (1/peek-string peek-string) + (1/write-bytes-avail/enable-break write-bytes-avail/enable-break) + (1/display display) + (1/read-char read-char) + (1/make-output-port make-output-port) + (1/bytes->path-element bytes->path-element) + (1/complete-path? complete-path?) + (1/build-path build-path) + (1/relative-path? relative-path?) + (1/path-for-some-system? path-for-some-system?) + (1/open-input-string open-input-string) + (1/string->path string->path) + (1/close-input-port close-input-port) + (1/current-error-port current-error-port) + (1/write-bytes write-bytes) + (1/prop:custom-write prop:custom-write) + (1/read-bytes-avail! read-bytes-avail!) + (1/peek-string! peek-string!) + (1/string-utf-8-length string-utf-8-length) + (pipe-output-port? pipe-output-port?) + (1/print print) + (1/read-byte read-byte) + (1/make-input-port make-input-port) + (1/port-next-location port-next-location) + (1/path-element->bytes path-element->bytes) + (1/split-path split-path) + (1/printf printf) + (1/read-string read-string) + (1/bytes->string/latin-1 bytes->string/latin-1) + (1/port-count-lines! port-count-lines!) + (1/path->string path->string) + (1/current-output-port current-output-port) + (1/peek-bytes-avail! peek-bytes-avail!) + (1/pipe-content-length pipe-content-length) + (1/peek-bytes-avail!* peek-bytes-avail!*) + (1/read-bytes! read-bytes!) + (1/peek-bytes peek-bytes) + (1/close-output-port close-output-port) + (1/open-output-string open-output-string))) + +(define-syntax-rule (linklet () (ex ...) body ...) + (begin body ...)) + +(include "../../io/compiled/io.rktl") diff -Nru racket-6.12+ppa1/src/cs/demo/io.rkt racket-7.0+ppa1/src/cs/demo/io.rkt --- racket-6.12+ppa1/src/cs/demo/io.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/io.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,64 @@ +#lang racket/base +(require "io-impl.rkt" + (only-in racket/base + [open-input-file c:open-input-file] + [port-count-lines! c:port-count-lines!] + [read-string c:read-string] + [close-input-port c:close-input-port] + [bytes->string/utf-8 c:bytes->string/utf-8] + [string->bytes/utf-8 c:string->bytes/utf-8])) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +'|Same, but in C....| +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (c:open-input-file "compiled/io.scm")) + (c:port-count-lines! p) + (let loop () + (define s (c:read-string 100 p)) + (unless (eof-object? s) + (loop))) + (c:close-input-port p) + (loop (sub1 j)))))) + + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (bytes->string/utf-8 (string->bytes/utf-8 "ap\x3BB;ple")))))) + +'|Same, but in C...| +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (c:bytes->string/utf-8 (c:string->bytes/utf-8 "ap\x3BB;ple")))))) diff -Nru racket-6.12+ppa1/src/cs/demo/io.ss racket-7.0+ppa1/src/cs/demo/io.ss --- racket-6.12+ppa1/src/cs/demo/io.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/io.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,120 @@ +(import (rumble) + (io) + (thread)) + +(define-syntax test + (syntax-rules () + [(_ expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))])) + +;; ---------------------------------------- + +(test #t (directory-exists? "demo")) +(test #f (directory-exists? "no-such-demo")) + +;; ---------------------------------------- + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop ([total 0]) + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop (+ total (string-length s))))) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (bytes->string/utf-8 (string->bytes/utf-8 "ap\x3BB;ple")))))) + + +;; ---------------------------------------- + +(let ([c (make-custodian)]) + (with-continuation-mark + parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) current-custodian c) + (let () + (define p (open-input-file "compiled/io.scm")) + (define wb (make-weak-box p)) + (define we (make-will-executor)) + (will-register we p values) + (set! p #f) + (collect (collect-maximum-generation)) + (test #t (input-port? (will-try-execute we))) + (collect (collect-maximum-generation)) + (test #f (weak-box-value wb)) + (custodian-shutdown-all c)))) + +;; ---------------------------------------- + +(call-in-main-thread + (lambda () + (define root-logger (make-logger)) + + (test 'none (log-max-level root-logger)) + (add-stderr-log-receiver! root-logger 'warning) + + (test 'warning (log-max-level root-logger)) + + (log-message root-logger 'error "this should print to stderr" 5) + + (let () + (define demo1-logger (make-logger 'demo1 root-logger)) + (define demo2-logger (make-logger 'demo2 root-logger 'fatal)) + + (log-message demo1-logger 'error "this should print to stderr, too" 5) + (log-message demo2-logger 'error "this should not print to stderr" 5) + + (test 'warning (log-max-level demo1-logger)) + (test 'fatal (log-max-level demo2-logger)) + + (let () + (define lr1 (make-log-receiver root-logger 'info 'cats)) + + (test 'info (log-max-level demo1-logger)) + (test 'fatal (log-max-level demo2-logger)) + + (test 'info (log-max-level demo1-logger 'cats)) + (test 'fatal (log-max-level demo2-logger 'cats)) + + (test 'warning (log-max-level demo1-logger 'dogs)) + (test 'fatal (log-max-level demo2-logger 'dogs)) + + (test #t (log-level? demo1-logger 'info 'cats)) + (test #f (log-level? demo1-logger 'debug 'cats)) + (test #f (log-level? demo1-logger 'info 'dogs)) + + (let () + (define msg1 #f) + (define th1 (thread (lambda () (set! msg1 (sync lr1))))) + (sync (system-idle-evt)) + (test #f msg1) + + (log-message demo1-logger 'info 'cats "hello" 7) + (sync (system-idle-evt)) + (test '#(info "cats: hello" 7 cats) msg1) + + (log-message demo1-logger 'info 'cats "goodbye" 9) + (test '#(info "cats: goodbye" 9 cats) (sync lr1))))))) diff -Nru racket-6.12+ppa1/src/cs/demo/linklet.rkt racket-7.0+ppa1/src/cs/demo/linklet.rkt --- racket-6.12+ppa1/src/cs/demo/linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base +(require racket/pretty + "chezify.rkt") + +(pretty-print + (chezify-linklet '(linklet + (import (a b c)) + (export f g x) + (define-values (f) (lambda () (g))) + (define-values (g) (lambda () (a (f)))) + (define-values (x) 5)) + #hasheq())) + diff -Nru racket-6.12+ppa1/src/cs/demo/linklet.ss racket-7.0+ppa1/src/cs/demo/linklet.ss --- racket-6.12+ppa1/src/cs/demo/linklet.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/linklet.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +(import (rumble) + (linklet)) + +(define l1 (compile-linklet + '(linklet + () ; imports + (f x) ; exports + (define-values (f) (lambda (y) (add1 y))) + (define-values (x) 5) + 'done) + 'l1)) + +(define l2 (compile-linklet + '(linklet + ((f x)) ; imports + () ; exports + (display (f x)) + (newline)))) + +(instantiate-linklet l2 (list (instantiate-linklet l1 '()))) diff -Nru racket-6.12+ppa1/src/cs/demo/regexp.rkt racket-7.0+ppa1/src/cs/demo/regexp.rkt --- racket-6.12+ppa1/src/cs/demo/regexp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/regexp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,21 @@ +#lang racket/base +(require racket/include + racket/unsafe/ops) + +;; Run using the built-in C implementation: +'|C -----------------| +(include "regexp.rktl") + +;; Run the Racket implementation: +'|Racket -----------------| +(let () + (define-syntax-rule (linklet () ([int-id ext-id] ...) body ...) + (begin + (define ext-id #f) ... + (let () + body ... + (set! ext-id int-id) ...))) + (include "../../regexp/compiled/regexp.rktl") + + ;; Run using the Racket implementation: + (include "regexp.rktl")) diff -Nru racket-6.12+ppa1/src/cs/demo/regexp.rktl racket-7.0+ppa1/src/cs/demo/regexp.rktl --- racket-6.12+ppa1/src/cs/demo/regexp.rktl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/regexp.rktl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,51 @@ +(define (check pat str) + (write + (time + (let ([rx (byte-regexp (string->bytes/utf-8 pat))] + [in (string->bytes/utf-8 str)]) + (let loop ([v #f] [n 100000]) + (if (zero? n) + v + (loop (regexp-match rx in) + (sub1 n))))))) + (newline)) + +;; A smallish backtracking test, more or less: +(check "ab(?:a*c)*d" "abaacacaaacacaaacd") + +;; Relatively realitic workload: +(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*") +(define url-s + (string-append + "^" + "(?:" ; / scheme-colon-opt + "([^:/?#]*)" ; | #1 = scheme-opt + ":)?" ; \ + "(?://" ; / slash-slash-authority-opt + "(?:" ; | / user-at-opt + "([^/?#@]*)" ; | | #2 = user-opt + "@)?" ; | \ + "(?:" ; + "(?:\\[" ; | / #3 = ipv6-host-opt + "(" ipv6-hex ")" ; | | hex-addresses + "\\])|" ; | \ + "([^/?#:]*)" ; | #4 = host-opt + ")?" ; + "(?::" ; | / colon-port-opt + "([0-9]*)" ; | | #5 = port-opt + ")?" ; | \ + ")?" ; \ + "([^?#]*)" ; #6 = path + "(?:\\?" ; / question-query-opt + "([^#]*)" ; | #7 = query-opt + ")?" ; \ + "(?:#" ; / hash-fragment-opt + "(.*)" ; | #8 = fragment-opt + ")?" ; \ + "$")) +(define rlo "https://racket-lang.org:80x/people.html?check=ok#end") +(check url-s rlo) + +;; A test of scanning a byte string to look for the letter "b" +;; (where a tight loop in C is likely to win): +(check "a*b" (make-string 1024 #\a)) diff -Nru racket-6.12+ppa1/src/cs/demo/regexp.ss racket-7.0+ppa1/src/cs/demo/regexp.ss --- racket-6.12+ppa1/src/cs/demo/regexp.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/regexp.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5 @@ +(import (rumble) + (regexp) + (io)) + +(include "demo/regexp.rktl") diff -Nru racket-6.12+ppa1/src/cs/demo/struct.ss racket-7.0+ppa1/src/cs/demo/struct.ss --- racket-6.12+ppa1/src/cs/demo/struct.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/struct.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,275 @@ +(import (rumble)) + +(define (show v) (printf "~s\n" v) v) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v a]) + (unless (equal? v b) + (error 'check (format "failed ~s => ~s" 'a v))))])) + +;; ---------------------------------------- + +(define-values (prop:x x? x-ref) (make-struct-type-property 'x)) + +(define-values (struct:a make-a a? a-ref a-set!) + (make-struct-type 'a #f 2 0 #f (list (cons prop:x 5)))) +(define a-x (make-struct-field-accessor a-ref 0 'x)) +(define a-y (make-struct-field-accessor a-ref 1 'y)) +(define-values (struct:b make-b b? b-ref b-set!) + (make-struct-type 'b #f 2 0 #f (list + (cons prop:equal+hash + (list (lambda (o t eql?) + (eql? (b-x o) (b-x t))) + (lambda (o hc) 0) + (lambda (o hc) 0)))))) +(define b-x (make-struct-field-accessor b-ref 0 'x)) +(define b-y (make-struct-field-accessor b-ref 1 'y)) + +(define an-a (make-a 1 2)) +(define b1 (make-b 3 4)) +(define b2 (make-b 3 4)) + +(check (a-x an-a) 1) +(check (|#%app| a-ref an-a 0) 1) +(check (|#%app| a-ref an-a 1) 2) + +(time (let loop ([i 10000000] [v1 (make-b 3 4)] [v2 (make-b 3 4)]) + (cond + [(= i 0) (list b1 b2)] + [else (loop (sub1 i) (if (equal? v1 v2) v2 v1) v1)]))) + + +(define-values (struct:p make-p p? p-ref p-set!) + (make-struct-type 'p #f 2 0 #f (list (cons prop:procedure 0)) (|#%app| current-inspector) #f '(0 1))) + +(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10)) + +(check (procedure-arity (make-p add1 'x)) 1) +(check (procedure-arity (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x)) + (list 1 (|#%app| arity-at-least 3))) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 0) + #f) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 1) + #t) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 2) + #f) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3) + #t) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3000) + #t) + +(define-values (struct:p0 make-p0 p0? p0-ref p0-set!) + (make-struct-type 'p0 #f 2 0 #f)) +(define-values (struct:p1 make-p1 p1? p1-ref p1-set!) + (make-struct-type 'p1 struct:p0 2 0 #f '() (|#%app| current-inspector) 0)) + +(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10)) +(check (|#%app| (make-p1 'no 'nope (lambda (x) (list x x)) 'whatever) 11) '(11 11)) + +(define-values (struct:p2 make-p2 p2? p2-ref p2-set!) + (make-struct-type 'p2 struct:p0 2 0 #f + (list (cons prop:procedure + (lambda (p2 x) + (list (|#%app| p2-ref p2 0) x)))))) + +(check (|#%app| (make-p2 0 1 'a 'b) 'c) '(a c)) +(check (procedure-arity (make-p2 0 1 'a 'b)) 1) +(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 1) #t) +(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 2) #f) + +;; ---------------------------------------- +;; Inspectors and `struct->vector` + +(check (struct->vector an-a) '#(struct:a ...)) + +(check (call-with-values (lambda () (struct-info an-a)) list) '(#f #t)) +(check (call-with-values (lambda () (struct-info 7)) list) '(#f #t)) + +(define sub-i (make-inspector (|#%app| current-inspector))) +(define-values (struct:q make-q q? q-ref q-set!) + (make-struct-type 'q #f 2 0 #f '() sub-i)) + +(define a-q (make-q 9 10)) +(check (struct->vector a-q) '#(struct:q 9 10)) +(check (call-with-values (lambda () (struct-info a-q)) list) (list struct:q #f)) +(check ((struct-type-make-constructor struct:q) 9 10) a-q) +(check ((struct-type-make-predicate struct:q) a-q) #t) + +(check (andmap (lambda (a b) + (or (equal? a b) + (and (struct-accessor-procedure? a) + (struct-accessor-procedure? b)) + (and (struct-mutator-procedure? a) + (struct-mutator-procedure? b)))) + (call-with-values (lambda () (struct-type-info struct:q)) list) + (list 'q 2 0 q-ref q-set! '() #f #f)) + #t) + +(define-values (struct:q+3 make-q+3 q+3? q+3-ref q+3-set!) + (make-struct-type 'q+3 struct:q 3 0)) + +(define a-q+3 (make-q+3 9 10 'a 'b 'c)) +(check (|#%app| q+3-ref a-q+3 0) 'a) +(check (|#%app| q+3-ref a-q+3 1) 'b) +(check ((make-struct-field-accessor q+3-ref 1 'second) a-q+3) 'b) +(check (struct->vector a-q+3) '#(struct:q+3 9 10 ...)) + +(define-values (struct:q+3+2 make-q+3+2 q+3+2? q+3+2-ref q+3+2-set!) + (make-struct-type 'q+3+2 struct:q+3 2 0 #f '() sub-i)) + +(check (struct->vector (make-q+3+2 9 10 'a 'b 'c "x" "y")) '#(struct:q+3+2 9 10 ... "x" "y")) + +;; ---------------------------------------- +;; Prefabs + +(check (prefab-key? 'a) #t) +(check (prefab-key? '(a)) #t) +(check (prefab-key? '(a 5)) #t) +(check (prefab-key? '(a 5 (0 #f))) #t) +(check (prefab-key? '(a 5 (3 #f))) #t) +(check (prefab-key? '(a (0 #f))) #t) +(check (prefab-key? '(a 3 (0 #f) #())) #t) +(check (prefab-key? '(a 3 #())) #t) +(check (prefab-key? '(a #())) #t) +(check (prefab-key? '(a 3 (0 #f) #(1 2))) #t) +(check (prefab-key? '(a 3 (10 #f) #(11 12))) #t) +(check (prefab-key? '(a #(100 101 99))) #t) +(check (prefab-key? '(a 3 (0 #f) #(2) b 1)) #t) +(check (prefab-key? '(a 3 b 1)) #t) +(check (prefab-key? '(a b 1)) #t) + +(check (prefab-key? "a") #f) +(check (prefab-key? '(a a)) #f) +(check (prefab-key? '(a . 5)) #f) +(check (prefab-key? '(a 5 (x #f))) #f) +(check (prefab-key? '(a 5 (2))) #f) +(check (prefab-key? '(a 5 (3 #f 5))) #f) +(check (prefab-key? '(a (x #f))) #f) +(check (prefab-key? '(a 3 (0 #f) #(x))) #f) +(check (prefab-key? '(a 3 (0 #f) #(-2))) #f) +(check (prefab-key? '(a 3 (0 #f) #(3))) #f) +(check (prefab-key? '(a 3 #(11 12))) #f) +(check (prefab-key? '(a #(100 101 100))) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) b)) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) "b" 1)) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) b -1)) #f) + +(check (prefab-struct-key (make-prefab-struct 'a 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct 'a 1 2)) 'a) +(check (equal? (make-prefab-struct 'a 1 2) + (make-prefab-struct 'a 1 2)) + #t) +(check (equal? (make-prefab-struct 'a 1) + (make-prefab-struct 'a 1 2)) + #f) + +(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f) #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f)) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1 #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #(0)) 1)) '(a #(0))) + +(let () + (define-values (struct:f make-f f? f-ref f-set!) + (make-struct-type 'f #f 1 0 #f '() 'prefab #f '(0))) + (define-values (struct:g make-g g? g-ref g-set!) + (make-struct-type 'g struct:f 2 0 #f '() 'prefab #f '(0 1))) + (define-values (struct:h make-h h? h-ref h-set!) + (make-struct-type 'h struct:g 3 0 #f '() 'prefab #f '(0 1 2))) + + (check (prefab-struct-key (make-f 1)) 'f) + (check (prefab-struct-key (make-g 1 2 3)) '(g f 1)) + (check (prefab-struct-key (make-h 1 2 3 4 5 6)) '(h g 2 f 1)) + + (void)) + +;; ---------------------------------------- +;; Guards + +(define checked-names '()) + +(define-values (struct:ga make-ga ga? ga-ref ga-set!) + (make-struct-type 'ga #f 2 0 #f null (|#%app| current-inspector) #f '(0 1) + (lambda (a b name) + (set! checked-names (cons name checked-names)) + (values a (box b))))) + +(check (|#%app| ga-ref (|#%app| make-ga 1 2) 1) (box 2)) +(check checked-names '(ga)) + +(define-values (struct:gb make-gb gb? gb-ref gb-set!) + (make-struct-type 'gb struct:ga 1 0 #f null (|#%app| current-inspector) #f '(0) + (lambda (a b c name) + (values a (list b) c)))) + +(check (|#%app| ga-ref (|#%app| make-gb 1 2 3) 1) (box (list 2))) +(check checked-names '(gb ga)) + +;; ---------------------------------------- +;; Graphs + +(let* ([p (make-placeholder #f)] + [c (cons 1 p)]) + (placeholder-set! p c) + (check (make-reader-graph p) + '#0=(1 . #0#))) + +(let* ([p (make-placeholder #f)] + [v (vector-immutable p 2 3)] + [b (box-immutable v)]) + (placeholder-set! p b) + (check (make-reader-graph v) + '#0=#(#�# 2 3))) + +(let* ([p (make-placeholder #f)] + [hp (make-hash-placeholder (list (cons 1 'a) (cons 2 p)))]) + (placeholder-set! p hp) + (let ([ht (make-reader-graph p)]) + (check (hash-ref ht 1) 'a) + (check (hash-ref (hash-ref ht 2) 1) 'a))) + +(let* ([p (make-placeholder #f)] + [a (make-prefab-struct 'a 1 2 p)]) + (define-values (struct:a make-a a? a-ref a-set!) + (make-struct-type 'a #f 3 0 #f '() 'prefab #f '(0 1 2))) + (placeholder-set! p a) + (check (|#%app| a-ref (|#%app| a-ref (|#%app| a-ref (make-reader-graph a) 2) 2) 0) + 1)) + +;; ---------------------------------------- + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 'x #f 2 0 #f (list (cons prop:x 5)))) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (let ([an-a (make-s-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (s-a-x an-a)))))))) + +(let () + (define struct:s-a (make-record-type-descriptor 's #f #f #f #f '#((mutable x) (mutable y)))) + (define make-s-a (record-constructor + (make-record-constructor-descriptor struct:s-a #f #f))) + (define s-a-x (record-accessor struct:s-a 0)) + (let ([an-a (make-s-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (s-a-x an-a)))))))) + +(let () + (define-record r-a (x y)) + + (let ([an-a (make-r-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (r-a-x an-a)))))))) diff -Nru racket-6.12+ppa1/src/cs/demo/thread.ss racket-7.0+ppa1/src/cs/demo/thread.ss --- racket-6.12+ppa1/src/cs/demo/thread.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/thread.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,221 @@ +(import (rumble) + (thread)) + +(define-syntax declare + (syntax-rules () + [(_ id ...) + (begin (define id #f) ...)])) + +(define done? #f) + +(call-in-main-thread + (lambda () + (define-syntax check + (syntax-rules () + [(_ a b) + (unless (equal? a b) + (printf "~s: ~s vs. ~s\n" 'b a b) + (error 'check "failed"))])) + + (declare s t0 t1 t2 + ch ct1 ct2 + cpt1 cpt2 + s2 + pc + ok-evt + sp + nack + now1 now2 now3 + t tinf tdelay + tdw dw-s dw-pre? dw-body? dw-post?) + + (define-syntax define + (syntax-rules () + [(_ id rhs) (set! id rhs)])) + + (check #t (thread? (current-thread))) + (check #t (evt? (current-thread))) + (define s (make-semaphore)) + (define t0 (thread (lambda () (semaphore-wait s) (printf "__\n") (semaphore-post s)))) + (define t1 (thread (lambda () (semaphore-wait s) (printf "hi\n") (semaphore-post s)))) + (define t2 (thread (lambda () (printf "HI\n") (semaphore-post s)))) + (thread-wait t0) + (thread-wait t1) + (thread-wait t2) + + (define ch (make-channel)) + (define ct1 (thread (lambda () (printf "1 ~a\n" (channel-get ch))))) + (define ct2 (thread (lambda () (printf "2 ~a\n" (channel-get ch))))) + (channel-put ch 'a) + (channel-put ch 'b) + + (define cpt1 (thread (lambda () (channel-put ch 'c)))) + (define cpt2 (thread (lambda () (channel-put ch 'd)))) + (printf "3 ~a\n" (channel-get ch)) + (printf "4 ~a\n" (channel-get ch)) + + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 s)) + + (define s2 (make-semaphore 3)) + (check s2 (sync/timeout 0 s s2)) + (check s2 (sync/timeout 0 s2 s)) + (check 'got-s2 (sync s (wrap-evt s2 (lambda (v) (check v s2) 'got-s2)))) + (check #f (sync/timeout 0 s2 s)) + + (void (thread (lambda () (channel-put ch 'c2)))) + (check 'c2 (sync ch)) + + (void (thread (lambda () (check 'c3 (channel-get ch))))) + (define pc (channel-put-evt ch 'c3)) + (check pc (sync pc)) + + (define ok-evt (guard-evt + (lambda () + (define ch (make-channel)) + (thread (lambda () (channel-put ch 'ok))) + ch))) + (check 'ok (sync ok-evt)) + + (semaphore-post s) + (define sp (semaphore-peek-evt s)) + (check sp (sync/timeout 0 sp)) + (check sp (sync/timeout 0 sp)) + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 sp)) + + (define nack #f) + (check #t (semaphore? (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore 1)))))) + (check #f (sync/timeout 0 nack)) + (set! nack #f) + (let loop () + (check 'ok (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore))) ok-evt)) + (unless nack (loop))) + (check (void) (sync/timeout 0 nack)) + + (semaphore-post s) + (check #f (sync/timeout 0 ch (channel-put-evt ch 'oops))) + (check sp (sync/timeout #f ch (channel-put-evt ch 'oops) sp)) + + (define now1 (current-inexact-milliseconds)) + (sleep 0.1) + (check #t (>= (current-inexact-milliseconds) (+ now1 0.1))) + + (define now2 (current-inexact-milliseconds)) + (define ts (thread (lambda () (sleep 0.1)))) + (check ts (sync ts)) + (check #t (>= (current-inexact-milliseconds) (+ now2 0.1))) + + (define v 0) + (thread (lambda () (set! v (add1 v)))) + (sync (system-idle-evt)) + (check 1 v) + + (define tinf (thread (lambda () (let loop () (loop))))) + (break-thread tinf) + (check tinf (sync tinf)) + (printf "[That break was from a thread, and it's expected]\n") + + (define now3 (current-inexact-milliseconds)) + (define tdelay (with-continuation-mark + break-enabled-key + (make-thread-cell #f #t) + (thread (lambda () + (sleep 0.1) + (with-continuation-mark + break-enabled-key + (make-thread-cell #t #t) + (begin + ;(check-for-break) + (let loop () (loop)))))))) + (break-thread tdelay) + (check tdelay (sync tdelay)) + (printf "[That break was from a thread, and it's expected]\n") + (check #t (>= (current-inexact-milliseconds) (+ now3 0.1))) + + ;; Make sure breaks are disabled in a `dynamic-wind` post thunk + (define dw-s (make-semaphore)) + (define dw-pre? #f) + (define dw-body? #f) + (define dw-post? #f) + (define tdw (thread + (lambda () + (dynamic-wind + (lambda () (semaphore-wait dw-s) (set! dw-pre? #t)) + (lambda () (set! dw-body? #f)) + (lambda () (set! dw-post? #t)))))) + (sync (system-idle-evt)) + (check #f dw-pre?) + (break-thread tdw) + (check #f dw-pre?) + (semaphore-post dw-s) + (sync tdw) + (check #t dw-pre?) + (check #f dw-body?) + (check #t dw-post?) + + ;; Make sure `equal?`-based hash tables are thread-safe + (let* ([ht (make-hash)] + [s (make-semaphore)] + [compare-ok (semaphore-peek-evt s)] + [trying 0] + [result #f]) + (define-values (struct:posn make-posn posn? posn-ref posn-set!) + (make-struct-type 'posn #f 2 0 #f (list (cons prop:equal+hash + (list + (lambda (a b eql?) + (set! trying (add1 trying)) + (sync compare-ok) + #t) + (lambda (a hc) 0) + (lambda (a hc) 0)))))) + (hash-set! ht (make-posn 1 2) 11) + (thread (lambda () + (set! result (hash-ref ht (make-posn 1 2) #f)))) + (sync (system-idle-evt)) + (check #f result) + (check 1 trying) + (thread (lambda () + ;; Should get stuck before calling the `posn` equality function: + (set! result (hash-ref ht (make-posn 1 2) #f)))) + (check #f result) + (check 1 trying) ; since the second thread is waiting for the table + (semaphore-post s) + (sync (system-idle-evt)) + (check 11 result) + (sync (system-idle-evt)) + (check 2 trying)) ; second thread should have completed + + ;; Measure thread quantum: + #; + (let ([t1 (thread (lambda () (let loop () (loop))))] + [t2 (thread (lambda () (let loop () + (define n (current-inexact-milliseconds)) + (sleep) + (fprintf (current-error-port) "~a\n" (- (current-inexact-milliseconds) n)) + (loop))))]) + (sleep 0.5) + (break-thread t1) + (break-thread t2)) + + (time + (let ([s1 (make-semaphore)] + [s2 (make-semaphore)]) + (let ([ping + (lambda (s1 s2) + (let loop ([n 1000000]) + (if (zero? n) + 'done + (begin + (semaphore-post s1) + (semaphore-wait s2) + (loop (sub1 n))))))]) + (let ([t1 (thread (lambda () (ping s1 s2)))] + [t2 (thread (lambda () (ping s2 s1)))]) + (thread-wait t1) + (thread-wait t2))))) + + (set! done? #t))) + +(unless done? + (error 'thread-demo "something went wrong; deadlock?")) diff -Nru racket-6.12+ppa1/src/cs/demo/will.ss racket-7.0+ppa1/src/cs/demo/will.ss --- racket-6.12+ppa1/src/cs/demo/will.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/demo/will.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,46 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v b]) + (unless (equal? a v) + (error 'check (format "failed ~s = ~s" 'b v))))])) + +(define we (make-will-executor void)) +(define we2 (make-will-executor void)) +(define we3 (make-will-executor void)) +(check #t (will-executor? we)) + +(define s1 (gensym)) +(define s2 (gensym)) +(will-register we s1 (let ([s2 s2]) (lambda (s) s2))) +(will-register we2 s1 (lambda (s) 'second)) +(will-register we s1 (lambda (s) 'first)) +(will-register we3 s2 (lambda (s) 'other)) + +(set! s1 #f) +(set! s2 #f) + +(define (gc) + (collect (collect-maximum-generation))) + +(define (will-try-execute* we) + (let ([p (will-try-execute we)]) + (and p + ((car p) (cdr p))))) + +(gc) +(check 'first (will-try-execute* we)) +(gc) +(check 'second (will-try-execute* we2)) +(gc) +(check #f (will-try-execute* we3)) +(gc) +(check #t (gensym? (will-try-execute* we))) +(gc) +(check 'other (will-try-execute* we3)) +(gc) +(check #f (will-try-execute* we)) +(gc) +(check #f (will-try-execute* we2)) diff -Nru racket-6.12+ppa1/src/cs/expander.rkt racket-7.0+ppa1/src/cs/expander.rkt --- racket-6.12+ppa1/src/cs/expander.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/expander.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,15 @@ +#lang racket/base +(require '#%paramz + (only-in '#%kernel prop:method-arity-error) + '#%linklet + racket/unsafe/ops + racket/fixnum + racket/flonum + racket/include) + +(define-syntax-rule (linklet () ([int-id ext-id] ...) body ...) + (begin + (provide (rename-out [int-id ext-id] ...)) + body ...)) + +(include "expander.rktl") diff -Nru racket-6.12+ppa1/src/cs/expander.sls racket-7.0+ppa1/src/cs/expander.sls --- racket-6.12+ppa1/src/cs/expander.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/expander.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,184 @@ +(library (expander) + (export current-command-line-arguments + executable-yield-handler + load-on-demand-enabled + call-in-main-thread + version + exit) + (import (except (chezpart) + syntax->datum + datum->syntax) + (rename (rumble) + [correlated? syntax?] + [correlated-source syntax-source] + [correlated-line syntax-line] + [correlated-column syntax-column] + [correlated-position syntax-position] + [correlated-span syntax-span] + [correlated-e syntax-e] + [correlated->datum syntax->datum] + [datum->correlated datum->syntax] + [correlated-property syntax-property] + [correlated-property-symbol-keys syntax-property-symbol-keys]) + (thread) + (regexp) + (io) + (linklet)) + + ;; Set to `#t` to make compiled code reliably compatible with + ;; changes to primitive libraries. Changing ths setting makes + ;; the build incompatible with previously generated ".zo" files. + (define compile-as-independent? #f) + + ;; The expander needs various tables to set up primitive modules, and + ;; the `primitive-table` function is the bridge between worlds + + (define (primitive-table key) + (case key + [(|#%linklet|) linklet-table] + [(|#%kernel|) kernel-table] + [(|#%read|) (make-hasheq)] + [(|#%paramz|) paramz-table] + [(|#%unsafe|) unsafe-table] + [(|#%foreign|) foreign-table] + [(|#%futures|) futures-table] + [(|#%place|) place-table] + [(|#%flfxnum|) flfxnum-table] + [(|#%extfl|) extfl-table] + [(|#%network|) network-table] + [else #f])) + + (define-syntax define-primitive-table + (syntax-rules () + [(_ id [prim known] ...) + (define id + (let ([ht (make-hasheq)]) + (hash-set! ht 'prim prim) + ... + ht))])) + + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (include "primitive/internal.ss") + + ;; ---------------------------------------- + + (include "include.ss") + (include-generated "expander.scm") + + ;; ---------------------------------------- + + ;; The environment is used to evaluate linklets, so all primitives + ;; need to be there imported (prefered) or defined (less efficient, + ;; but less tied to library implementations) + (unless compile-as-independent? + (parameterize ([expand-omit-library-invocations #f]) + (eval `(import (rename (rumble) + [correlated? syntax?] + [correlated-source syntax-source] + [correlated-line syntax-line] + [correlated-column syntax-column] + [correlated-position syntax-position] + [correlated-span syntax-span] + [correlated-e syntax-e] + [correlated->datum syntax->datum] + [datum->correlated datum->syntax] + [correlated-property syntax-property] + [correlated-property-symbol-keys syntax-property-symbol-keys]) + (thread) + (io) + (regexp) + (linklet))) + ;; Ensure that the library is visited, especially for a wpo build: + (eval 'variable-set!))) + + (eval `(define primitive-table ',primitive-table)) + + (let ([install-table + (lambda (table) + (hash-for-each table + (lambda (k v) + ;; Avoid redefining some primitives that we + ;; don't have to replace: + (unless (memq k '(vector + list cons car cdr + eq? + values call-with-values)) + (eval `(define ,k ',v))))))]) + (when compile-as-independent? + (install-table kernel-table) + (install-table unsafe-table) + (install-table flfxnum-table) + (install-table paramz-table) + (install-table extfl-table) + (install-table network-table) + (install-table futures-table) + (install-table place-table) + (install-table foreign-table) + (install-table linklet-table) + (install-table internal-table) + (install-table schemify-table))) + + (when compile-as-independent? + ;; Copies of macros provided by `rumble`, plus + ;; other bindings assumed by schemify: + (eval '(define-syntax with-continuation-mark + (syntax-rules () + [(_ key val body) + (call/cm key val (lambda () body))]))) + (eval '(define-syntax begin0 + (syntax-rules () + [(_ expr0 expr ...) + (call-with-values (lambda () + (call-with-values (lambda () expr0) + (case-lambda + [(x) (values x #f)] + [args (values args #t)]))) + (lambda (l apply?) + expr ... + (if apply? + (#%apply values l) + l)))]))) + (eval '(define-syntax (|#%app| stx) + (syntax-case stx () + [(_ rator rand ...) + (with-syntax ([n-args (length #'(rand ...))]) + #'((extract-procedure rator n-args) rand ...))]))) + (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error))) + + ;; For interpretation of the outer shell of a linklet: + (install-linklet-primitive-tables! kernel-table + unsafe-table + flfxnum-table + paramz-table + extfl-table + network-table + futures-table + place-table + foreign-table + linklet-table + internal-table + schemify-table) + + ;; ---------------------------------------- + + ;; `install-reader!` is from the `io` library, where the + ;; given functions are used by the default port read handler + (install-reader! 1/read 1/read-syntax 1/read-accept-reader 1/read-accept-lang) + + ;; `set-string->number?!` is also from the `io` library, where + ;; the printer needs to check whether a string parses as a number + ;; for deciding wheter to quote the string + (set-string->number?! (lambda (str) + (not (not (1/string->number str 10 'read))))) + + ;; `set-maybe-raise-missing-module!` is also from the `io` library + (set-maybe-raise-missing-module! maybe-raise-missing-module)) diff -Nru racket-6.12+ppa1/src/cs/.gitignore racket-7.0+ppa1/src/cs/.gitignore --- racket-6.12+ppa1/src/cs/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/.gitignore 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,2 @@ +*.so +*.wpo diff -Nru racket-6.12+ppa1/src/cs/include.ss racket-7.0+ppa1/src/cs/include.ss --- racket-6.12+ppa1/src/cs/include.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/include.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ + +(define-syntax (include-generated stx) + (syntax-case stx () + [(inc file) + (let* ([dir (or (getenv "COMPILED_SCM_DIR") + "compiled/")] + [file (#%datum->syntax #'inc (string-append dir (#%syntax->datum #'file)))]) + (#%datum->syntax #'inc `(include ,file)))])) diff -Nru racket-6.12+ppa1/src/cs/io.sls racket-7.0+ppa1/src/cs/io.sls --- racket-6.12+ppa1/src/cs/io.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/io.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,395 @@ +(library (io) + (export) + (import (except (chezpart) + close-port) + (rename (only (chezscheme) + read-char peek-char + current-directory + error + input-port? output-port? + file-position flush-output-port + file-symbolic-link?) + [input-port? chez:input-port?] + [output-port? chez:output-port?] + [flush-output-port flush-output]) + (rumble) + (thread)) + ;; ---------------------------------------- + ;; Tie knots: + + (define (path? v) (is-path? v)) + (define (path->string v) (1/path->string v)) + (define path->complete-path + (case-lambda + [(v) (1/path->complete-path v)] + [(v wrt) (1/path->complete-path v wrt)])) + (define (absolute-path? v) (1/absolute-path? v)) + (define (relative-path? v) (1/relative-path? v)) + + ;; ---------------------------------------- + + (module (|#%rktio-instance| ptr->address) + (meta define (convert-type t) + (syntax-case t (ref *ref rktio_bool_t rktio_const_string_t) + [(ref . _) #'uptr] + [(*ref rktio_const_string_t) #'uptr] + [(*ref . _) #'u8*] + [rktio_bool_t #'boolean] + [rktio_const_string_t #'u8*] + [else t])) + + (define-ftype intptr_t iptr) + (define-ftype uintptr_t uptr) + (define-ftype rktio_int64_t integer-64) + (define _uintptr _uint64) + (define NULL 0) + + (define (<< a b) (bitwise-arithmetic-shift-left a b)) + + (define-syntax define-constant + (syntax-rules () + [(_ id expr) (define id expr)])) + + (define-syntax (define-type stx) + (syntax-case stx (rktio_const_string_t rktio_ok_t rktio_bool_t) + [(_ rktio_const_string_t old_type) + ;; skip + #'(begin)] + [(_ rktio_ok_t old_type) + (with-syntax ([(_ type _) stx]) + #'(define-ftype type boolean))] + [(_ rktio_bool_t old_type) + (with-syntax ([(_ type _) stx]) + #'(define-ftype type boolean))] + [(_ type old-type) + (with-syntax ([old-type (convert-type #'old-type)]) + #'(define-ftype type old-type))])) + + (define-syntax (define-struct-type stx) + (syntax-case stx () + [(_ type ([old-type field] ...)) + (with-syntax ([(old-type ...) (map convert-type #'(old-type ...))]) + #'(define-ftype type (struct [field old-type] ...)))])) + + ;; Wrap foreign-pointer addressed in a record so that + ;; the value can be finalized + (define-record ptr (address)) + (define (ptr->address v) (if (eqv? v NULL) v (ptr-address v))) + (define (address->ptr v) (if (eqv? v NULL) v (make-ptr v))) + + (define-syntax (let-unwrappers stx) + ;; Unpack plain pointers; when an argument has type + ;; `rktio_const_string_t`, add an explicit NUL terminator byte; + ;; when an argument has a `nullable` wrapper, then add a #f -> 0 + ;; conversion + (syntax-case stx (rktio_const_string_t ref nullable) + [(_ () body) #'body] + [(_ ([rktio_const_string_t arg-name] . args) body) + #'(let ([arg-name (add-nul-terminator arg-name)]) + (let-unwrappers args body))] + [(_ ([(ref (nullable type)) arg-name] . args) body) + #'(let ([arg-name (ptr->address (or arg-name NULL))]) + (let-unwrappers args body))] + [(_ ([(ref type) arg-name] . args) body) + #'(let ([arg-name (ptr->address arg-name)]) + (let-unwrappers args body))] + [(_ ([(*ref rktio_const_string_t) arg-name] . args) body) + #'(let ([arg-name (ptr->address arg-name)]) + (let-unwrappers args body))] + [(_ (_ . args) body) + #'(let-unwrappers args body)])) + + (define (add-nul-terminator bstr) + (and bstr (bytes-append bstr '#vu8(0)))) + + (define-syntax (wrap-result stx) + (syntax-case stx (ref) + [(_ (ref _) v) #'(address->ptr v)] + [(_ _ v) #'v])) + + (meta define (convert-function stx) + (syntax-case stx () + [(_ (flag ...) orig-ret-type name ([orig-arg-type arg-name] ...)) + (with-syntax ([ret-type (convert-type #'orig-ret-type)] + [(arg-type ...) (map convert-type #'(orig-arg-type ...))] + [(conv ...) (if (#%memq 'blocking (map syntax->datum #'(flag ...))) + #'(__thread) + #'())]) + #'(let ([proc (foreign-procedure conv ... (rktio-lookup 'name) + (arg-type ...) + ret-type)]) + (lambda (arg-name ...) + (let-unwrappers + ([orig-arg-type arg-name] ...) + (wrap-result orig-ret-type (proc arg-name ...))))))])) + + (define-syntax (define-function stx) + (syntax-case stx () + [(_ _ _ name . _) + (with-syntax ([rhs (convert-function stx)]) + #'(define name rhs))])) + + (define-syntax (define-function*/errno stx) + (syntax-case stx () + [(_ err-val err-expr flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (with-syntax ([rhs (convert-function + #'(define-function flags ret-type name ([rktio-type rktio] [arg-type arg] ...)))]) + #'(define name + (let ([proc rhs]) + (lambda (rktio arg ...) + (let ([v (proc rktio arg ...)]) + (if (eqv? v err-val) + err-expr + v))))))])) + + (define-syntax define-function/errno + (syntax-rules () + [(_ err-val flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (define-function*/errno err-val + (vector (rktio_get_last_error_kind rktio) + (rktio_get_last_error rktio)) + flags ret-type name ([rktio-type rktio] [arg-type arg] ...))])) + + (define-syntax define-function/errno+step + (syntax-rules () + [(_ err-val flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (define-function*/errno err-val + (vector (rktio_get_last_error_kind rktio) + (rktio_get_last_error rktio) + (rktio_get_last_error_step rktio)) + flags ret-type name ([rktio-type rktio] [arg-type arg] ...))])) + + (define loaded-librktio + (or (foreign-entry? "rktio_init") + (load-shared-object (string-append (string-append (current-directory) "/../../lib/librktio") + (utf8->string (system-type 'so-suffix)))))) + + (define (rktio-lookup name) + (foreign-entry (symbol->string name))) + + (include "../rktio/rktio.rktl") + + (define (rktio_filesize_ref fs) + (ftype-ref rktio_filesize_t () (make-ftype-pointer rktio_filesize_t (ptr->address fs)))) + (define (rktio_timestamp_ref fs) + (ftype-ref rktio_timestamp_t () (make-ftype-pointer rktio_timestamp_t (ptr->address fs)))) + (define (rktio_is_timestamp v) + (let ([radix (arithmetic-shift 1 (sub1 (* 8 (ftype-sizeof rktio_timestamp_t))))]) + (<= (- radix) v (sub1 radix)))) + + (define (rktio_recv_length_ref fs) + (ftype-ref rktio_length_and_addrinfo_t (len) (make-ftype-pointer rktio_length_and_addrinfo_t (ptr->address fs)) 0)) + + (define (rktio_recv_address_ref fs) + (ftype-ref rktio_length_and_addrinfo_t (address) (make-ftype-pointer rktio_length_and_addrinfo_t (ptr->address fs)) 0)) + + (define (rktio_identity_to_vector p) + (let ([p (make-ftype-pointer rktio_identity_t (ptr->address p))]) + (vector + (ftype-ref rktio_identity_t (a) p) + (ftype-ref rktio_identity_t (b) p) + (ftype-ref rktio_identity_t (c) p) + (ftype-ref rktio_identity_t (a_bits) p) + (ftype-ref rktio_identity_t (b_bits) p) + (ftype-ref rktio_identity_t (c_bits) p)))) + + (define (rktio_convert_result_to_vector p) + (let ([p (make-ftype-pointer rktio_convert_result_t (ptr->address p))]) + (vector + (ftype-ref rktio_convert_result_t (in_consumed) p) + (ftype-ref rktio_convert_result_t (out_produced) p) + (ftype-ref rktio_convert_result_t (converted) p)))) + (define (cast v from to) + (let ([p (malloc from)]) + (ptr-set! p from v) + (ptr-ref p to))) + + (define (rktio_to_bytes fs) + (cast (ptr->address fs) _uintptr _bytes)) + + (define (rktio_to_shorts fs) + (cast (ptr->address fs) _uintptr _short_bytes)) + + ;; Unlike `rktio_to_bytes`, frees the array and strings + (define rktio_to_bytes_list + (case-lambda + [(lls) (rktio_to_bytes_list lls #f)] + [(lls len) + (begin0 + (let loop ([i 0]) + (cond + [(and len (fx= i len)) + '()] + [else + (let ([bs (foreign-ref 'uptr (ptr->address lls) (* i (foreign-sizeof 'uptr)))]) + (if (not (eqv? NULL bs)) + (cons (begin0 + (cast bs _uintptr _bytes) + (rktio_free (make-ptr bs))) + (loop (add1 i))) + '()))])) + (rktio_free lls))])) + + ;; Allocates pointers that must be released via `rktio_free_bytes_list`: + (define (rktio_from_bytes_list bstrs) + (let ([p (foreign-alloc (fx* (length bstrs) (foreign-sizeof 'uptr)))]) + (let loop ([bstrs bstrs] [i 0]) + (cond + [(null? bstrs) p] + [else + (let* ([bstr (car bstrs)] + [len (bytes-length bstr)] + [s (foreign-alloc (fx+ len 1))]) + (let loop ([j 0]) + (cond + [(= j len) + (foreign-set! 'unsigned-8 s j 0)] + [else + (foreign-set! 'unsigned-8 s j (bytes-ref bstr j)) + (loop (fx+ 1 j))])) + (foreign-set! 'uptr p (fx* i (foreign-sizeof 'uptr)) s) + (loop (cdr bstrs) (fx+ 1 i)))])) + (address->ptr p))) + + (define (rktio_free_bytes_list lls len) + (rktio_to_bytes_list lls len) + (void)) + + (define (null-to-false v) (if (eqv? v NULL) #f v)) + + (define (rktio_process_result_stdin_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stdin_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_stdout_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stdout_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_stderr_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stderr_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_process r) + (address->ptr (ftype-ref rktio_process_result_t (process) (make-ftype-pointer rktio_process_result_t (ptr->address r))))) + + (define (rktio_status_running r) + (ftype-ref rktio_status_t (running) (make-ftype-pointer rktio_status_t (ptr->address r)))) + (define (rktio_status_result r) + (ftype-ref rktio_status_t (result) (make-ftype-pointer rktio_status_t (ptr->address r)))) + + (define (rktio_do_install_os_signal_handler rktio) + (rktio_install_os_signal_handler rktio)) + + (define (rktio_get_ctl_c_handler) + (get-ctl-c-handler)) + + (define |#%rktio-instance| + (let () + (define-syntax extract-functions + (syntax-rules (define-constant + define-type + define-struct-type + define-function + define-function/errno + define-function/errno+step) + [(_ accum) (hasheq . accum)] + [(_ accum (define-constant . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-struct-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-function _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno+step _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)])) + (define-syntax begin + (syntax-rules () + [(begin form ...) + (extract-functions ['rktio_NULL + NULL + 'rktio_filesize_ref rktio_filesize_ref + 'rktio_timestamp_ref rktio_timestamp_ref + 'rktio_is_timestamp rktio_is_timestamp + 'rktio_recv_length_ref rktio_recv_length_ref + 'rktio_recv_address_ref rktio_recv_address_ref + 'rktio_identity_to_vector rktio_identity_to_vector + 'rktio_convert_result_to_vector rktio_convert_result_to_vector + 'rktio_to_bytes rktio_to_bytes + 'rktio_to_bytes_list rktio_to_bytes_list + 'rktio_to_shorts rktio_to_shorts + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd + 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd + 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd + 'rktio_process_result_process rktio_process_result_process + 'rktio_status_running rktio_status_running + 'rktio_status_result rktio_status_result + 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler + 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] + form ...)])) + (include "../rktio/rktio.rktl")))) + + ;; ---------------------------------------- + + (define format + (case-lambda + [(fmt arg) + (unless (equal? fmt "~s") + (raise-arguments-error 'format "should only be used as a fallback" + "format string" fmt + "argument" arg)) + (cond + [(and (record? arg) + (or (not (impersonator? arg)) + (record? (unsafe-struct*-ref arg 0)))) + (let ([arg (if (impersonator? arg) + (unsafe-struct*-ref arg 0) + arg)]) + (chez:format "#<~a>" (record-type-name (record-rtd arg))))] + [else + (chez:format "~s" arg)])] + [(fmt . args) + (raise-arguments-error 'format "should only be used as a fallback" + "format string" fmt + "arguments" args)])) + + ;; ---------------------------------------- + + (export system-library-subpath) + (define system-library-subpath + (case-lambda + [() (system-library-subpath (system-type 'gc))] + [(mode) + (1/string->path + (string-append + system-library-subpath-string + (cond + [(eq? mode '3m) (if (eq? 'windows (system-path-convention-type)) + "\\3m" + "/3m")] + [(eq? mode 'cs) (if (eq? 'windows (system-path-convention-type)) + "\\cs" + "/cs")] + [(or (eq? mode 'cgc) (not mode)) ""] + [else (raise-argument-error 'system-library-subpath + "(or/c '3m 'cgc 'cs #f)" + mode)])))])) + + (define (primitive-table key) + (case key + [(|#%thread|) |#%thread-instance|] + [(|#%rktio|) |#%rktio-instance|] + [else #f])) + + (include "include.ss") + (include-generated "io.scm") + + ;; Initialize: + (|#%app| 1/current-directory (current-directory)) + (|#%app| 1/current-directory-for-user (current-directory)) + (set-log-system-message! (lambda (level str) + (1/log-message (|#%app| 1/current-logger) level str #f))) + (set-error-display-eprintf! (lambda (fmt . args) + (apply 1/fprintf (|#%app| 1/current-error-port) fmt args))) + (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ptr->address) + (set-async-callback-poll-wakeup! 1/unsafe-signal-received)) diff -Nru racket-6.12+ppa1/src/cs/linklet.sls racket-7.0+ppa1/src/cs/linklet.sls --- racket-6.12+ppa1/src/cs/linklet.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/linklet.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1247 @@ +(library (linklet) + (export linklet? + compile-linklet + recompile-linklet + eval-linklet + read-compiled-linklet + instantiate-linklet + + read-on-demand-source + + linklet-import-variables + linklet-export-variables + + instance? + make-instance + instance-name + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + linklet-directory? + hash->linklet-directory + linklet-directory->hash + + linklet-bundle? + hash->linklet-bundle + linklet-bundle->hash + + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe? + + compile-enforce-module-constants + compile-context-preservation-enabled + compile-allow-set!-undefined + eval-jit-enabled + load-on-demand-enabled + + primitive->compiled-position + compiled-position->primitive + primitive-in-category? + + platform-independent-zo-mode? ; not exported to racket + linklet-performance-init! ; not exported to racket + linklet-performance-report! ; not exported to racket + + install-linklet-primitive-tables! ; not exported to racket + + ;; schemify glue: + variable-set! + variable-set!/check-undefined + variable-ref + variable-ref/no-check + make-instance-variable-reference + jitified-extract-closed + jitified-extract + schemify-table) + (import (chezpart) + (only (chezscheme) printf) + (rumble) + (only (io) + path? + complete-path? + path->string + string->bytes/utf-8 + bytes->string/utf-8 + prop:custom-write + write-bytes + read-byte + read-bytes + open-output-bytes + get-output-bytes + file-position + current-logger + log-message) + (regexp) + (schemify)) + + (define linklet-compilation-mode + (cond + [(getenv "PLT_CS_JIT") 'jit] + [(getenv "PLT_CS_MACH") 'mach] + [else 'mach])) + + (define linklet-compilation-limit + (and (eq? linklet-compilation-mode 'mach) + (or (let ([s (getenv "PLT_CS_COMPILE_LIMIT")]) + (and s + (let ([n (string->number s)]) + (and (real? n) + n)))) + 10000))) + + ;; For "main.sps" to select the default ".zo" directory name: + (define platform-independent-zo-mode? (eq? linklet-compilation-mode 'jit)) + + (define (primitive->compiled-position prim) #f) + (define (compiled-position->primitive pos) #f) + (define (primitive-in-category? sym cat) #f) + + (define root-logger (|#%app| current-logger)) + + (define omit-debugging? (not (getenv "PLT_CS_DEBUG"))) + (define measure-performance? (getenv "PLT_LINKLET_TIMES")) + + (define gensym-on? (getenv "PLT_LINKLET_SHOW_GENSYM")) + (define pre-lift-on? (getenv "PLT_LINKLET_SHOW_PRE_LIFT")) + (define pre-jit-on? (getenv "PLT_LINKLET_SHOW_PRE_JIT")) + (define lambda-on? (getenv "PLT_LINKLET_SHOW_LAMBDA")) + (define post-lambda-on? (getenv "PLT_LINKLET_SHOW_POST_LAMBDA")) + (define post-interp-on? (getenv "PLT_LINKLET_SHOW_POST_INTERP")) + (define jit-demand-on? (getenv "PLT_LINKLET_SHOW_JIT_DEMAND")) + (define known-on? (getenv "PLT_LINKLET_SHOW_KNOWN")) + (define show-on? (or gensym-on? + pre-jit-on? + pre-lift-on? + post-lambda-on? + post-interp-on? + jit-demand-on? + known-on? + (getenv "PLT_LINKLET_SHOW"))) + (define show + (case-lambda + [(what v) (show show-on? what v)] + [(on? what v) + (when on? + (printf ";; ~a ---------------------\n" what) + (call-with-system-wind + (lambda () + (parameterize ([print-gensym gensym-on?] + [print-extended-identifiers #t]) + (pretty-print (strip-jit-wrapper + (strip-nested-annotations + (correlated->annotation v)))))))) + v])) + + (define region-times (make-eq-hashtable)) + (define region-counts (make-eq-hashtable)) + (define region-memories (make-eq-hashtable)) + (define current-start-time 0) + (define-syntax performance-region + (syntax-rules () + [(_ label e ...) (measure-performance-region label (lambda () e ...))])) + (define (measure-performance-region label thunk) + (cond + [measure-performance? + (let ([old-start current-start-time]) + (set! current-start-time (current-inexact-milliseconds)) + (begin0 + (thunk) + (let ([delta (- (current-inexact-milliseconds) current-start-time)]) + (hashtable-update! region-times label (lambda (v) (+ v delta)) 0) + (hashtable-update! region-counts label add1 0) + (set! current-start-time (+ old-start delta)))))] + [else (thunk)])) + (define (add-performance-memory! label delta) + (when measure-performance? + (hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))) + (define (linklet-performance-init!) + (hashtable-set! region-times 'boot + (let ([t (sstats-cpu (statistics))]) + (+ (* 1000.0 (time-second t)) + (/ (time-nanosecond t) 1000000.0))))) + (define (linklet-performance-report!) + (when measure-performance? + (let ([total 0]) + (define (report label n units extra) + (define (pad v w) + (let ([s (chez:format "~a" v)]) + (string-append (make-string (max 0 (- w (string-length s))) #\space) + s))) + (chez:printf ";; ~a: ~a ~a~a\n" + (pad label 15) + (pad (round (inexact->exact n)) 5) + units + extra)) + (define (ht->sorted-list ht) + (list-sort (lambda (a b) (< (cdr a) (cdr b))) + (hash-table-map ht cons))) + (for-each (lambda (p) + (let ([label (car p)] + [n (cdr p)]) + (set! total (+ total n)) + (report label n 'ms (let ([c (hashtable-ref region-counts label 0)]) + (if (zero? c) + "" + (chez:format " ; ~a times" c)))))) + (ht->sorted-list region-times)) + (report 'total total 'ms "") + (chez:printf ";;\n") + (for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) 'MB "")) + (ht->sorted-list region-memories))))) + + ;; `compile`, `interpret`, etc. have `dynamic-wind`-based state + ;; that need to be managed correctly when swapping Racket + ;; engines/threads. + (define (compile* e) + (call-with-system-wind (lambda () (compile e)))) + (define (interpret* e) + (call-with-system-wind (lambda () (interpret e)))) + (define (fasl-write* s o) + (call-with-system-wind (lambda () (fasl-write s o)))) + (define (compile-to-port* s o) + (call-with-system-wind (lambda () (compile-to-port s o)))) + + (define primitives (make-hasheq)) + (define (install-linklet-primitive-tables! . tables) + (for-each + (lambda (table) + (hash-for-each table (lambda (k v) (hash-set! primitives k v)))) + tables)) + + (define (outer-eval s format) + (if (eq? format 'interpret) + (interpret-linklet s primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (compile* s))) + + (define (compile*-to-bytevector s) + (let-values ([(o get) (open-bytevector-output-port)]) + (compile-to-port* (list `(lambda () ,s)) o) + (get))) + + (define (compile-to-bytevector s format) + (bytevector-compress + (cond + [(eq? format 'interpret) + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* s o) + (get))] + [else (compile*-to-bytevector s)]))) + + (define (eval-from-bytevector c-bv format) + (add-performance-memory! 'uncompress (bytevector-length c-bv)) + (let* ([bv (performance-region + 'uncompress + (bytevector-uncompress c-bv))]) + (add-performance-memory! 'faslin (bytevector-length bv)) + (cond + [(eq? format 'interpret) + (let ([r (performance-region + 'faslin + (fasl-read (open-bytevector-input-port bv)))]) + (performance-region + 'outer + (outer-eval r format)))] + [else + (performance-region + 'faslin + (code-from-bytevector bv))]))) + + (define (code-from-bytevector bv) + (let ([i (open-bytevector-input-port bv)]) + (performance-region + 'outer + ((load-compiled-from-port i))))) + + (define-record-type wrapped-code + (fields (mutable content) ; bytevector for 'lambda mode; annotation for 'jit mode + arity-mask + name) + (nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-0})) + + (define (force-wrapped-code wc) + (let ([f (wrapped-code-content wc)]) + (if (procedure? f) + f + (performance-region + 'on-demand + (cond + [(bytevector? f) + (let* ([f (code-from-bytevector f)]) + (wrapped-code-content-set! wc f) + f)] + [else + (let* ([f (compile* (wrapped-code-content wc))]) + (when jit-demand-on? + (show "JIT demand" (strip-nested-annotations (wrapped-code-content wc)))) + (wrapped-code-content-set! wc f) + f)]))))) + + (define (jitified-extract-closed wc) + (let ([f (wrapped-code-content wc)]) + (if (#2%procedure? f) + ;; previously forced, so no need for a wrapper + f + ;; make a wrapper that has the right arity and name + ;; and that compiles/extracts when called: + (make-jit-procedure (lambda () (force-wrapped-code wc)) + (wrapped-code-arity-mask wc) + (wrapped-code-name wc))))) + + (define (jitified-extract wc) + (let ([f (wrapped-code-content wc)]) + (if (#2%procedure? f) + ;; previously forced, so no need for a wrapper + f + ;; make a wrapper that has the right arity and name + ;; and that compiles/extracts when called: + (lambda free-vars + (make-jit-procedure (lambda () + (apply (force-wrapped-code wc) + free-vars)) + (wrapped-code-arity-mask wc) + (wrapped-code-name wc)))))) + + (define (strip-jit-wrapper p) + (cond + [(wrapped-code? p) + (vector (strip-jit-wrapper (strip-nested-annotations (wrapped-code-content p))) + (wrapped-code-arity-mask p) + (wrapped-code-name p))] + [(pair? p) + (cons (strip-jit-wrapper (car p)) (strip-jit-wrapper (cdr p)))] + [else p])) + + ;; A linklet is implemented as a procedure that takes an argument + ;; for each import plus an `variable` for each export, and calling + ;; the procedure runs the linklet body. + + ;; A source linklet has a list of list of imports; those are all + ;; flattened into a sequence of arguments for the linklet procedure, + ;; followed by the arguments to receive the export `variable`s. Each + ;; import is either a `variable` or the variable's value as + ;; indicated by the "ABI" (which is based on information about which + ;; exports of an imported linklet are constants). + + ;; A linklet also has a table of information about its + + (define-record-type linklet + (fields (mutable code) ; the procedure + format ; 'compile or 'interpret (where the latter may have compiled internal parts) + (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, or 'lazy + importss-abi ; ABI for each import, in parallel to `importss` + exports-info ; hash(sym -> known) for info about each export; see "known.rkt" + name ; name of the linklet (for debugging purposes) + importss ; list of list of import symbols + exports) ; list of export symbols + (nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-0})) + + (define (set-linklet-code linklet code preparation) + (make-linklet code + (linklet-format linklet) + preparation + (linklet-importss-abi linklet) + (linklet-exports-info linklet) + (linklet-name linklet) + (linklet-importss linklet) + (linklet-exports linklet))) + + (define compile-linklet + (case-lambda + [(c) (compile-linklet c #f #f (lambda (key) (values #f #f)) '(serializable))] + [(c name) (compile-linklet c name #f (lambda (key) (values #f #f)) '(serializable))] + [(c name import-keys) (compile-linklet c name import-keys (lambda (key) (values #f #f)) '(serializable))] + [(c name import-keys get-import) (compile-linklet c name import-keys get-import '(serializable))] + [(c name import-keys get-import options) + (define serializable? (#%memq 'serializable options)) + (performance-region + 'schemify + (define jitify-mode? + (or (eq? linklet-compilation-mode 'jit) + (and (linklet-bigger-than? c linklet-compilation-limit serializable?) + (log-message root-logger 'info 'linklet "compiling only interior functions for large linklet" #f) + #t))) + (define format (if jitify-mode? 'interpret 'compile)) + ;; Convert the linklet S-expression to a `lambda` S-expression: + (define-values (impl-lam importss exports new-import-keys importss-abi exports-info) + (schemify-linklet (show "linklet" c) + serializable? + jitify-mode? + (|#%app| compile-allow-set!-undefined) + #f ;; safe mode + recorrelate + prim-knowns + ;; Callback to get a specific linklet for a + ;; given import: + (lambda (key) + (lookup-linklet-or-instance get-import key)) + import-keys)) + (define impl-lam/lifts + (lift-in-schemified-linklet (show pre-lift-on? "pre-lift" impl-lam) + recorrelate)) + (define impl-lam/jitified + (cond + [(not jitify-mode?) impl-lam/lifts] + [else + (jitify-schemified-linklet (case linklet-compilation-mode + [(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)] + [else (show "schemified" impl-lam/lifts)]) + ;; don't need extract for non-serializable 'lambda mode + (or serializable? (eq? linklet-compilation-mode 'jit)) + ;; compilation threshold for ahead-of-time mode: + (and (eq? linklet-compilation-mode 'mach) + linklet-compilation-limit) + ;; correlation -> lambda + (case linklet-compilation-mode + [(jit) + ;; Preserve annotated `lambda` source for on-demand compilation: + (lambda (expr arity-mask name) + (make-wrapped-code (correlated->annotation expr) arity-mask name))] + [else + ;; Compile an individual `lambda`: + (lambda (expr arity-mask name) + (performance-region + 'compile + (let ([code ((if serializable? compile*-to-bytevector compile*) + (show lambda-on? "lambda" (correlated->annotation expr)))]) + (if serializable? + (make-wrapped-code code arity-mask name) + code))))]) + recorrelate)])) + (define impl-lam/interpable + (let ([impl-lam (case (and jitify-mode? + linklet-compilation-mode) + [(mach) (show post-lambda-on? "post-lambda" impl-lam/jitified)] + [else (show "schemified" impl-lam/jitified)])]) + (if jitify-mode? + (interpretable-jitified-linklet impl-lam correlated->datum) + (correlated->annotation impl-lam)))) + (when known-on? + (show "known" (hash-map exports-info (lambda (k v) (list k v))))) + (performance-region + 'compile + ;; Create the linklet: + (let ([lk (make-linklet (call-with-system-wind + (lambda () + ((if serializable? compile-to-bytevector outer-eval) + (show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable) + format))) + format + (if serializable? 'faslable 'callable) + importss-abi + exports-info + name + importss + exports)]) + (show "compiled" 'done) + ;; In general, `compile-linklet` is allowed to extend the set + ;; of linklet imports if `import-keys` is provided (e.g., for + ;; cross-linklet optimization where inlining needs a new + ;; direct import) + (if import-keys + (values lk new-import-keys) + lk))))])) + + (define (lookup-linklet-or-instance get-import key) + ;; Use the provided callback to get an linklet for the + ;; import at `index` + (cond + [key + (let-values ([(lnk/inst more-import-keys) (get-import key)]) + (cond + [(linklet? lnk/inst) + (values (linklet-exports-info lnk/inst) + ;; No conversion needed: + #f + more-import-keys)] + [(instance? lnk/inst) + (values (instance-hash lnk/inst) + variable->known + more-import-keys)] + [else (values #f #f #f)]))] + [else (values #f #f #f)])) + + (define (recompile-linklet lnk . args) lnk) + + ;; Intended to speed up reuse of a linklet in exchange for not being + ;; able to serialize anymore + (define (eval-linklet linklet) + (case (linklet-preparation linklet) + [(faslable) + (set-linklet-code linklet (linklet-code linklet) 'lazy)] + [(faslable-strict) + (set-linklet-code linklet (eval-from-bytevector (linklet-code linklet) (linklet-format linklet)) 'callable)] + [else + linklet])) + + (define instantiate-linklet + (case-lambda + [(linklet import-instances) + (instantiate-linklet linklet import-instances #f #f)] + [(linklet import-instances target-instance) + (instantiate-linklet linklet import-instances target-instance #f)] + [(linklet import-instances target-instance use-prompt?) + (cond + [target-instance + ;; Instantiate into the given instance and return the + ;; result of the linklet body: + (call/cc + (lambda (k) + (register-linklet-instantiate-continuation! k (instance-name target-instance)) + (when (eq? 'lazy (linklet-preparation linklet)) + ;; Trigger lazy conversion of code from bytevector + (let ([code (eval-from-bytevector (linklet-code linklet) (linklet-format linklet))]) + (with-interrupts-disabled + (when (eq? 'lazy (linklet-preparation linklet)) + (linklet-code-set! linklet code) + (linklet-preparation-set! linklet 'callable))))) + ;; Call the linklet: + (performance-region + 'instantiate + (apply + (if (eq? 'callable (linklet-preparation linklet)) + (linklet-code linklet) + (eval-from-bytevector (linklet-code linklet) (linklet-format linklet))) + (make-variable-reference target-instance #f) + (append (apply append + (map extract-variables + import-instances + (linklet-importss linklet) + (linklet-importss-abi linklet))) + (create-variables target-instance + (linklet-exports linklet)))))))] + [else + ;; Make a fresh instance, recur, and return the instance + (let ([i (make-instance (linklet-name linklet))]) + (instantiate-linklet linklet import-instances i use-prompt?) + i)])])) + + (define (linklet-import-variables linklet) + (linklet-importss linklet)) + + (define (linklet-export-variables linklet) + (linklet-exports linklet)) + + ;; ---------------------------------------- + + ;; A potentially mutable import or definition is accessed through + ;; the indirection of a `variable`; accessing a variable may include + ;; a check for undefined, since going through a `variable` + ;; sacrifices the undefined check of the host Scheme + + (define-record variable (val + name + constance ; #f (mutable), 'constant, or 'consistent (always the same shape) + inst-box)) ; weak pair with instance in `car` + + (define (variable-set! var val constance) + (cond + [(variable-constance var) + (raise + (|#%app| + exn:fail:contract:variable + (string-append (symbol->string (variable-name var)) + ": cannot modify constant") + (current-continuation-marks) + (variable-name var)))] + [else + (set-variable-val! var val) + (when constance + (set-variable-constance! var constance))])) + + (define (variable-set!/check-undefined var val constance) + (when (eq? (variable-val var) unsafe-undefined) + (raise-undefined var #t)) + (variable-set! var val constance)) + + (define (variable-ref var) + (let ([v (variable-val var)]) + (if (eq? v unsafe-undefined) + (raise-undefined var #f) + v))) + + (define (variable-ref/no-check var) + (variable-val var)) + + ;; Find variables or values needed from an instance for a linklet's + ;; imports + (define (extract-variables inst syms imports-abi) + (let ([ht (instance-hash inst)]) + (map (lambda (sym import-abi) + (let ([var (or (hash-ref ht sym #f) + (raise-arguments-error 'instantiate-linklet + "variable not found in imported instance" + "instance" inst + "name" sym))]) + (if import-abi + (variable-val var) + var))) + syms + imports-abi))) + + (define (identify-module var) + (let ([i (car (variable-inst-box var))]) + (cond + [(eq? i #!bwp) + ""] + [(instance-name i) + => (lambda (name) + (#%format "\n module: ~a" name))] + [else ""]))) + + (define (raise-undefined var set?) + (raise + (|#%app| + exn:fail:contract:variable + (cond + [set? + (string-append "set!: assignment disallowed;\n" + " cannot set variable before its definition\n" + " variable: " (symbol->string (variable-name var)) + (identify-module var))] + [else + (string-append (symbol->string (variable-name var)) + ": undefined;\n cannot reference undefined identifier" + (identify-module var))]) + (current-continuation-marks) + (variable-name var)))) + + ;; Create the variables needed for a linklet's exports + (define (create-variables inst syms) + (let ([ht (instance-hash inst)] + [inst-box (weak-cons inst #f)]) + (map (lambda (sym) + (or (hash-ref ht sym #f) + (let ([var (make-variable unsafe-undefined sym #f inst-box)]) + (hash-set! ht sym var) + var))) + syms))) + + (define (variable->known var) + (let ([constance (variable-constance var)]) + (cond + [(not constance) #f] + [(and (eq? constance 'consistent) + (#%procedure? (variable-val var))) + (known-procedure (#%procedure-arity-mask (variable-val var)))] + [else a-known-constant]))) + + ;; ---------------------------------------- + + ;; An instance represents the instantiation of a linklet + (define-record-type (instance new-instance instance?) + (fields name + data + hash)) ; symbol -> variable + + (define make-instance + (case-lambda + [(name) (make-instance name #f)] + [(name data) (make-instance name data #f)] + [(name data constance . content) + (let* ([ht (make-hasheq)] + [inst (new-instance name data ht)] + [inst-box (weak-cons inst #f)]) + (check-constance 'make-instance constance) + (let loop ([content content]) + (cond + [(null? content) (void)] + [else + (hash-set! ht (car content) (make-variable (cadr content) (car content) constance inst-box)) + (loop (cddr content))])) + inst)])) + + (define (instance-variable-names i) + (hash-map (instance-hash i) (lambda (k v) k))) + + (define instance-variable-value + (case-lambda + [(i sym fail-k) + (let* ([var (hash-ref (instance-hash i) sym unsafe-undefined)] + [v (if (eq? var unsafe-undefined) + unsafe-undefined + (variable-val var))]) + (if (eq? v unsafe-undefined) + (fail-k) + v))] + [(i sym) + (instance-variable-value i + sym + (lambda () + (raise-argument-error + 'instance-variable-value + "instance variable not found" + "name" sym)))])) + + (define instance-set-variable-value! + (case-lambda + [(i k v) (instance-set-variable-value! i k v #f)] + [(i k v mode) + (unless (instance? i) + (raise-argument-error 'instance-set-variable-value! "instance?" i)) + (unless (symbol? k) + (raise-argument-error 'instance-set-variable-value! "symbol?" i)) + (check-constance 'instance-set-variable-value! mode) + (let ([var (or (hash-ref (instance-hash i) k #f) + (let ([var (make-variable unsafe-undefined k #f (weak-cons i #f))]) + (hash-set! (instance-hash i) k var) + var))]) + (variable-set! var v mode))])) + + (define (instance-unset-variable! i k) + (unless (instance? i) + (raise-argument-error 'instance-unset-variable! "instance?" i)) + (unless (symbol? k) + (raise-argument-error 'instance-unset-variable! "symbol?" i)) + (let ([var (hash-ref (instance-hash i) k #f)]) + (when var + (set-variable-val! var unsafe-undefined)))) + + (define (check-constance who mode) + (unless (or (not mode) (eq? mode 'constant) (eq? mode 'consistent)) + (raise-argument-error who "(or/c #f 'constant 'consistant)" mode))) + + ;; -------------------------------------------------- + + (define-record-type linklet-directory + (fields hash) + (nongenerative #{linklet-directory cvqw30w53xy6hsjsc5ipep-0})) + + (define (hash->linklet-directory ht) + (make-linklet-directory ht)) + + (define (linklet-directory->hash ld) + (linklet-directory-hash ld)) + + (define-record-type (linklet-bundle make-linklet-bundle linklet-bundle?) + (fields (immutable hash)) + (nongenerative #{linklet-bundle chqh4u4pk0me3osmzzx8pq-0})) + + (define (install-linklet-bundle-write!) + (struct-property-set! prop:custom-write (record-type-descriptor linklet-bundle) write-linklet-bundle) + (struct-property-set! prop:custom-write (record-type-descriptor linklet-directory) write-linklet-directory)) + + (define (hash->linklet-bundle ht) + (make-linklet-bundle ht)) + + (define (linklet-bundle->hash b) + (linklet-bundle-hash b)) + + (define-record variable-reference (instance ; the use-site instance + var-or-info)) ; the referenced variable + + (define variable-reference->instance + (case-lambda + [(vr ref?) + (if ref? + (variable-reference-instance vr) + (variable-reference->instance vr))] + [(vr) + (let ([v (variable-reference-var-or-info vr)]) + (cond + [(not v) ;; anonymous + #f] + [(variable? v) + (let ([i (car (variable-inst-box v))]) + (if (eq? i #!bwp) + (variable-reference->instance vr #t) + i))] + [else + ;; Local variable, so same as use-site + (variable-reference->instance vr #t)]))])) + + (define (variable-reference-constant? vr) + (eq? (variable-reference-var-or-info vr) 'constant)) + + (define (variable-reference-from-unsafe? vr) + #f) + + (define (make-instance-variable-reference vr v) + (make-variable-reference (variable-reference-instance vr) v)) + + ;; ---------------------------------------- + + (define (write-linklet-bundle b port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "B" + ;; 20 bytes of SHA-1 hash + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port)) + (write-bytes '#vu8(66) port) + (write-bytes (make-bytes 20 0) port) + ;; The rest is whatever we want. We'll simply fasl the bundle. + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* b o) + (let ([bstr (get)]) + (write-int (bytes-length bstr) port) + (write-bytes bstr port)))) + + (define (linklet-bundle->bytes b) + (let ([o (open-output-bytes)]) + (write-linklet-bundle b o #t) + (get-output-bytes o))) + + (define (write-linklet-directory ld port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "D" + ;; bundle count as 4-byte integer + ;; binary tree: + ;; bundle-name length as 4-byte integer + ;; bundle name [encoding decribed below] + ;; bundle offset as 4-byte integer + ;; bundle size as 4-byte integer + ;; left-branch offset as 4-byte integer + ;; right-branch offset as 4-byte integer + ;; A bundle name corresponds to a list of symbols. Each symbol in the list is + ;; prefixed with either: its length as a byte if less than 255; 255 followed by + ;; a 4-byte integer for the length. + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port) + (write-bytes '#vu8(68) port) + ;; Flatten a directory of bundles into a vector of pairs, where + ;; each pair has the encoded bundle name and the bundle bytes + (let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))] + [len (vector-length bundles)] + [initial-offset (+ 2 ; "#~" + 1 ; version length + (bytes-length vers) + 1 ; D + 4)]) ; bundle count + (write-int len port) ; bundle count + (chez:vector-sort! (lambda (a b) (bytesbytes value)) + accum) + #t)] + [else + (loop (hash-iterate-next ht i) + (flatten-linklet-directory value (cons key rev-name-prefix) accum) + saw-bundle?)]))])))) + + ;; Encode a bundle name (as a reversed list of symbols) as a single + ;; byte string + (define (encode-name rev-name) + (define (encode-symbol s) + (let* ([bstr (string->bytes/utf-8 (symbol->string s))] + [len (bytes-length bstr)]) + (if (< len 255) + (list (bytes len) bstr) + (list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr)))) + (let loop ([rev-name rev-name] [accum '()]) + (cond + [(null? rev-name) (apply bytes-append accum)] + [else + (loop (cdr rev-name) (append (encode-symbol (car rev-name)) + accum))]))) + + ;; Figure out how big the binary tree will be, which depends + ;; on the size of bundle-name byte strings + (define (compute-btree-size bundles len) + (let loop ([i 0] [size 0]) + (if (= i len) + size + (let ([nlen (bytes-length (car (vector-ref bundles i)))]) + ;; 5 numbers: name length, bundle offset, bundles size, lef, and right + (loop (fx1+ i) (+ size nlen (* 5 4))))))) + + ;; Compute the offset where each node in the binary tree will reside + ;; relative to the start of the bundle directory's "#~" + (define (compute-btree-node-offsets bundles len initial-offset) + (let ([node-offsets (make-vector len)]) + (let loop ([lo 0] [hi len] [offset initial-offset]) + (cond + [(= lo hi) offset] + [else + (let* ([mid (quotient (+ lo hi) 2)]) + (vector-set! node-offsets mid offset) + (let* ([nlen (bytes-length (car (vector-ref bundles mid)))] + [offset (+ offset 4 nlen 4 4 4 4)]) + (let ([offset (loop lo mid offset)]) + (loop (add1 mid) hi offset))))])) + node-offsets)) + + ;; Compute the offset where each bundle will reside relative + ;; to the start of the bundle directory's "#~" + (define (compute-bundle-offsets bundles len offset) + (let ([bundle-offsets (make-vector len)]) + (let loop ([i 0] [offset offset]) + (unless (= i len) + (vector-set! bundle-offsets i offset) + (loop (fx1+ i) (+ offset (bytes-length (cdr (vector-ref bundles i))))))) + bundle-offsets)) + + ;; Write the binary tree for the directory: + (define (write-directory-btree bundles node-offsets bundle-offsets len port) + (let loop ([lo 0] [hi len]) + (cond + [(= lo hi) (void)] + [else + (let* ([mid (quotient (+ lo hi) 2)] + [p (vector-ref bundles mid)] + [nlen (bytes-length (car p))]) + (write-int nlen port) + (write-bytes (car p) port) + (write-int (vector-ref bundle-offsets mid) port) + (write-int (bytes-length (cdr p)) port) + (cond + [(> mid lo) + (let ([left (quotient (+ lo mid) 2)]) + (write-int (vector-ref node-offsets left) port))] + [else + (write-int 0 port)]) + (cond + [(< (fx1+ mid) hi) + (let ([right (quotient (+ (fx1+ mid) hi) 2)]) + (write-int (vector-ref node-offsets right) port))] + [else + (write-int 0 port)]) + (loop lo mid) + (loop (fx1+ mid) hi))]))) + + (define (write-int n port) + (write-bytes (integer->integer-bytes n 4 #f #f) port)) + + ;; -------------------------------------------------- + + (define (read-compiled-linklet in) + (read-compiled-linklet-or-directory in #t)) + + (define (read-compiled-linklet-or-directory in initial?) + ;; `#~` has already been read + (let* ([start-pos (- (file-position in) 2)] + [vers-len (min 63 (read-byte in))] + [vers (read-bytes vers-len in)]) + (unless (equal? vers (string->bytes/utf-8 (version))) + (raise-arguments-error 'read-compiled-linklet + "version mismatch" + "expected" (version) + "found" (bytes->string/utf-8 vers #\?))) + (let ([tag (read-byte in)]) + (cond + [(equal? tag (char->integer #\B)) + (let ([sha-1 (read-bytes 20 in)]) + (let ([len (read-int in)]) + (let ([bstr (read-bytes len in)]) + (let ([b (fasl-read (open-bytevector-input-port bstr))]) + (add-hash-code (adjust-linklet-bundle-laziness + (if initial? + (strip-submodule-references b) + b)) + sha-1)))))] + [(equal? tag (char->integer #\D)) + (unless initial? + (raise-argument-error 'read-compiled-linklet + "expected a linklet bundle")) + (read-bundle-directory in start-pos)] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `B` or `D`")])))) + + (define (read-int in) + (integer-bytes->integer (read-bytes 4 in) #f #f)) + + (define (read-bundle-directory in pos) + (let ([count (read-int in)]) + (let ([position-to-name + (let loop ([count count] [accum (hasheqv)]) + (cond + [(zero? count) accum] + [else + (let ([bstr (read-bytes (read-int in) in)]) + (let* ([offset (read-int in)] + [len (read-int in)]) + (read-int in) ; left + (read-int in) ; right + (loop (fx1- count) + (hash-set accum offset bstr))))]))]) + (let loop ([count count] [accum '()]) + (cond + [(zero? count) + (list->bundle-directory accum)] + [else + (let ([name (hash-ref position-to-name (- (file-position in) pos) #f)]) + (unless name + (raise-arguments-error 'read-compiled-linklet + "bundle not at an expected file position")) + (let ([bstr (read-bytes 2 in)]) + (let ([bundle + (cond + [(equal? '#vu8(35 126) bstr) + (read-compiled-linklet in)] + [(equal? '#vu8(35 102) bstr) + #f] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `#~` or `#f` for a bundle")])]) + (loop (fx1- count) + (cons (cons (decode-name name 0) bundle) accum)))))]))))) + + (define (decode-name bstr pos) + (let ([blen (bytes-length bstr)] + [bad-bundle (lambda () + (raise-arguments-error 'read-compiled-linklet + "malformed bundle"))]) + (cond + [(= pos blen) + '()] + [(> pos blen) (bad-bundle)] + [else + (let ([len (bytes-ref bstr pos)]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (if (= len 255) + (let ([len (integer-bytes->integer bstr #f #f (fx1+ pos) (fx+ pos 5))]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx+ pos 5) (+ pos 5 len)) #\?)) + (decode-name bstr (+ pos 5 len)))) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx1+ pos) (+ pos 1 len)) #\?)) + (decode-name bstr (+ pos 1 len)))))]))) + + ;; Convert a post-order list into a tree + (define (list->bundle-directory l) + ;; The bundles list is in post-order, so we can build directories + ;; bottom-up + (let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)]) + (when (null? l) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let* ([p (car l)] + [path (car p)] + [v (cdr p)] + [len (length path)]) + (when (< len prev-len) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let sloop ([prev-len prev-len] [stack stack] [accum accum]) + (cond + [(> len (fx1+ prev-len)) + (sloop (fx1+ prev-len) + (cons accum stack) + (hasheq))] + [else + (let ([path (list-tail path (fxmax 0 (fx1- prev-len)))]) + (cond + [(= len prev-len) + (let ([accum (if v + (hash-set accum #f v) + accum)]) + (if (zero? len) + (make-linklet-directory accum) + (loop (cdr l) + (fx1- prev-len) + (cdr stack) + (hash-set (car stack) (car path) (make-linklet-directory accum)))))] + [else + (let ([path (if (positive? prev-len) + (cdr path) + path)]) + (loop (cdr l) + prev-len + stack + (hash-set accum + (car path) + (make-linklet-directory (if v + (hasheq #f v) + (hasheq))))))]))]))))) + + ;; When a bundle is loaded by itself, remove any 'pre and 'post + ;; submodule descriptions: + (define (strip-submodule-references b) + (make-linklet-bundle (hash-remove (hash-remove (linklet-bundle-hash b) 'pre) 'post))) + + ;; If the bundle has a non-zero hash code, record it with the + ;; 'hash-code key to enable module caching + (define (add-hash-code b sha-1) + (if (bytevector=? sha-1 '#vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + b + (make-linklet-bundle (hash-set (linklet-bundle-hash b) 'hash-code sha-1)))) + + (define read-on-demand-source + (make-parameter #f + (lambda (v) + (unless (or (eq? v #t) (eq? v #f) (and (path? v) + (complete-path? v))) + (raise-argument-error 'read-on-demand-source + "(or/c #f #t (and/c path? complete-path?))" + v)) + v))) + + (define (adjust-linklet-bundle-laziness b) + (make-linklet-bundle + (let ([ht (linklet-bundle-hash b)]) + (let loop ([i (hash-iterate-first ht)]) + (cond + [(not i) (hasheq)] + [else + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (hash-set (loop (hash-iterate-next ht i)) + key + (if (linklet? val) + (adjust-linklet-laziness val) + val)))]))))) + + (define (adjust-linklet-laziness linklet) + (set-linklet-code linklet + (linklet-code linklet) + (if (|#%app| read-on-demand-source) + 'faslable + 'faslable-strict))) + + ;; -------------------------------------------------- + + (define (recorrelate old-term new-term) + (if (correlated? old-term) + (datum->correlated #f new-term old-term) + new-term)) + + ;; -------------------------------------------------- + + (define (correlated->annotation v) + (let-values ([(e stripped-e) (correlated->annotation* v)]) + e)) + + (define (correlated->annotation* v) + (cond + [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))] + [(d stripped-d) (correlated->annotation* (cdr v))]) + (if (and (eq? a (car v)) + (eq? d (cdr v))) + (values v v) + (values (cons a d) + (cons stripped-a stripped-d))))] + [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) + (values (transfer-srcloc v e stripped-e) + stripped-e))] + ;; correlated will be nested only in pairs with current expander + [else (values v v)])) + + (define (transfer-srcloc v e stripped-e) + (let ([src (correlated-source v)] + [pos (correlated-position v)] + [line (correlated-line v)] + [column (correlated-column v)] + [span (correlated-span v)]) + (if (and pos span (or (path? src) (string? src))) + (let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based + (make-annotation e + (if (and line column) + ;; Racket columns are 0-based; host-Scheme columns are 1-based + (make-source-object (source->sfd src) pos (+ pos span) line (add1 column)) + (make-source-object (source->sfd src) pos (+ pos span))) + stripped-e)) + e))) + + (define sfd-cache (make-weak-hash)) + + (define (source->sfd src) + (or (hash-ref sfd-cache src #f) + (let ([str (if (path? src) + (path->string src) + src)]) + ;; We'll use a file-position object in source objects, so + ;; the sfd checksum doesn't matter + (let ([sfd (source-file-descriptor str 0)]) + (hash-set! sfd-cache src sfd) + sfd)))) + + ;; -------------------------------------------------- + + (define (strip-nested-annotations s) + (cond + [(annotation? s) (annotation-stripped s)] + [(pair? s) + (let ([a (strip-nested-annotations (car s))] + [d (strip-nested-annotations (cdr s))]) + (if (and (eq? a (car s)) (eq? d (cdr s))) + s + (cons a d)))] + [else s])) + + ;; -------------------------------------------------- + + (define compile-enforce-module-constants + (make-parameter #t (lambda (v) (and v #t)))) + + (define compile-context-preservation-enabled + (make-parameter #f (lambda (v) (and v #t)))) + + (define compile-allow-set!-undefined + (make-parameter #f (lambda (v) (and v #t)))) + + (define eval-jit-enabled + (make-parameter #t (lambda (v) (and v #t)))) + + (define load-on-demand-enabled + (make-parameter #t (lambda (v) (and v #t)))) + + ;; -------------------------------------------------- + + (define-syntax primitive-table + (syntax-rules () + [(_ id ...) + (let ([ht (make-hasheq)]) + (hash-set! ht 'id id) ... + ht)])) + + (define schemify-table + (primitive-table + variable-set! + variable-set!/check-undefined + variable-ref + variable-ref/no-check + make-instance-variable-reference + unbox/check-undefined + set-box!/check-undefined + jitified-extract + jitified-extract-closed)) + + ;; -------------------------------------------------- + + (when omit-debugging? + (generate-inspector-information (not omit-debugging?)) + (generate-procedure-source-information #t)) + + (expand-omit-library-invocations #t) + + (install-linklet-bundle-write!)) diff -Nru racket-6.12+ppa1/src/cs/main.sps racket-7.0+ppa1/src/cs/main.sps --- racket-6.12+ppa1/src/cs/main.sps 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/main.sps 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,499 @@ +(top-level-program + (import (except (chezpart) + eval + read) + (rumble) + (only (expander) + boot + current-command-line-arguments + use-compiled-file-paths + current-library-collection-links + find-library-collection-links + current-library-collection-paths + find-library-collection-paths + use-collection-link-paths + find-main-config + executable-yield-handler + load-on-demand-enabled + use-user-specific-search-paths + eval + read + load + dynamic-require + namespace-require + module-declared? + module->language-info + module-path-index-join + version + exit) + (regexp) + (io) + (thread) + (only (linklet) + platform-independent-zo-mode? + linklet-performance-init! + linklet-performance-report!)) + + (linklet-performance-init!) + + (define the-command-line-arguments + (or (and (top-level-bound? 'bytes-command-line-arguments) + (map (lambda (s) (bytes->string/locale s #\?)) + (top-level-value 'bytes-command-line-arguments))) + (command-line-arguments))) + + (unless (>= (length the-command-line-arguments) 5) + (error 'racket "expected `self`, `collects`, and `libs` paths plus `segment-offset` and `is-gui?` to start")) + (set-exec-file! (path->complete-path (car the-command-line-arguments))) + (define init-collects-dir (let ([s (cadr the-command-line-arguments)]) + (if (equal? s "") 'disable (string->path s)))) + (define init-config-dir (string->path (or (getenv "PLTCONFIGDIR") + (caddr the-command-line-arguments)))) + (define segment-offset (#%string->number (list-ref the-command-line-arguments 3))) + (define gracket? (string=? "true" (list-ref the-command-line-arguments 4))) + + (when (foreign-entry? "racket_exit") + (#%exit-handler (foreign-procedure "racket_exit" (int) void))) + + (|#%app| use-compiled-file-paths + (list (string->path (string-append "compiled/" + (cond + [(getenv "PLT_ZO_PATH") + => (lambda (s) + (unless (and (not (equal? s "")) + (relative-path? s)) + (error 'racket "PLT_ZO_PATH environment variable is not a valid path")) + s)] + [platform-independent-zo-mode? "cs"] + [else (symbol->string (machine-type))]))))) + + (define (see saw . args) + (let loop ([saw saw] [args args]) + (if (null? args) + saw + (loop (hash-set saw (car args) #t) (cdr args))))) + (define (saw? saw tag) + (hash-ref saw tag #f)) + + (define rx:logging-spec (pregexp "^[\\s]*(none|fatal|error|warning|info|debug)(?:@([^\\s @]+))?(.*)$")) + (define rx:all-whitespace (pregexp "^[\\s]*$")) + (define (parse-logging-spec which str where exit-on-fail?) + (define (fail) + (let ([msg (string-append + which " " where " must be one of the following\n" + " s:\n" + " none fatal error warning info debug\n" + "or up to one such in whitespace-separated sequence of\n" + " @\n" + "given: " str)]) + (cond + [exit-on-fail? + (raise-user-error 'racket msg)] + [else + (eprintf "~a\n" msg)]))) + (let loop ([str str] [default #f]) + (let ([m (regexp-match rx:logging-spec str)]) + (cond + [m + (let ([level (string->symbol (cadr m))] + [topic (caddr m)]) + (cond + [topic + (cons level (cons (string->symbol topic) (loop (cadddr m) default)))] + [default (fail)] + [else (loop (cadddr m) level)]))] + [(regexp-match? rx:all-whitespace str) + (if default (list default) null)] + [else (fail)])))) + + (define (configure-runtime m) + ;; New-style configuration through a `configure-runtime` submodule: + (let ([config-m (module-path-index-join '(submod "." configure-runtime) m)]) + (when (module-declared? config-m #t) + (dynamic-require config-m #f))) + ;; Old-style configuration with module language info: + (let ([info (module->language-info m #t)]) + (when (and (vector? info) (= 3 (vector-length info))) + (let* ([info-load (lambda (info) + ((dynamic-require (vector-ref info 0) (vector-ref info 1)) (vector-ref info 2)))] + [get (info-load info)] + [infos (get 'configure-runtime '())]) + (unless (and (list? infos) + (andmap (lambda (info) (and (vector? info) (= 3 (vector-length info)))) + infos)) + (raise-argument-error 'runtime-configure "(listof (vector any any any))" infos)) + (for-each info-load infos))))) + + (define need-runtime-configure? #t) + (define (namespace-require+ mod) + (let ([m (module-path-index-join mod #f)]) + (when need-runtime-configure? + (configure-runtime m) + (set! need-runtime-configure? #f)) + (namespace-require m) + ;; Run `main` submodule, if any: + (let ([main-m (module-path-index-join '(submod "." main) m)]) + (when (module-declared? main-m #t) + (dynamic-require main-m #f))))) + + (define (get-repl-init-filename) + (call-with-continuation-prompt + (lambda () + (or (let ([p (build-path (find-system-path 'addon-dir) + (if gracket? + "gui-interactive.rkt" + "interactive.rkt"))]) + (and (file-exists? p) p)) + (hash-ref (call-with-input-file + (build-path (find-main-config) "config.rktd") + read) + (if gracket? 'gui-interactive-file 'interactive-file) + #f) + (if gracket? 'racket/interactive 'racket/gui/interactive))) + (default-continuation-prompt-tag) + (lambda args #f))) + + (define init-library (if gracket? + '(lib "racket/gui/init") + '(lib "racket/init"))) + (define loads '()) + (define repl? #f) + (define repl-init? #t) + (define version? #f) + (define stderr-logging-arg #f) + (define stdout-logging-arg #f) + (define runtime-for-init? #t) + (define exit-value 0) + (define host-collects-dir init-collects-dir) + (define host-config-dir init-config-dir) + + (define (no-init! saw) + (unless (saw? saw 'top) + (set! init-library #f))) + + (define (next-arg what flag within-flag args) + (let loop ([args (cdr args)] [accum '()]) + (cond + [(null? args) + (error 'racket "missing ~a after ~a switch" what (or within-flag flag))] + [(pair? (car args)) + (loop (cdr args) (cons (car args) accum))] + [else + (values (car args) (append (reverse accum) (cdr args)))]))) + + (define (check-path-arg what flag within-flag) + (when (equal? what "") + (error 'racket "empty ~a after ~a switch" what (or within-flag flag)))) + + (define-syntax string-case + ;; Assumes that `arg` is a variable + (syntax-rules () + [(_ arg [else body ...]) + (let () body ...)] + [(_ arg [(str ...) body ...] rest ...) + (if (or (string=? arg str) ...) + (let () body ...) + (string-case arg rest ...))])) + + (let flags-loop ([args (list-tail the-command-line-arguments 5)] + [saw (hasheq)]) + ;; An element of `args` can become `(cons _arg _within-arg)` + ;; due to splitting multiple flags with a single "-" + (define (loop args) (flags-loop args saw)) + ;; Called to handle remaining non-switch arguments: + (define (finish args saw) + (cond + [(and (pair? args) + (not (saw? saw 'non-config))) + (loop (cons "-u" args))] + [else + (|#%app| current-command-line-arguments (list->vector args)) + (when (and (null? args) (not (saw? saw 'non-config))) + (set! repl? #t) + (unless gracket? + (set! version? #t)))])) + ;; Dispatch on first argument: + (if (null? args) + (finish args saw) + (let* ([arg (car args)] + [within-arg (and (pair? arg) (cdr arg))] + [arg (if (pair? arg) (car arg) arg)]) + (string-case + arg + [("-l" "--lib") + (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(lib ,lib-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-t" "--require") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(file ,file-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-u" "--script") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(file ,file-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-f" "--load") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (load file-name)) + loads)) + (flags-loop rest-args (see saw 'non-config)))] + [("-e" "--eval") + (let-values ([(expr rest-args) (next-arg "expression" arg within-arg args)]) + (set! loads + (cons + (lambda () + (eval (read (open-input-string expr)))) + loads)) + (flags-loop rest-args (see saw 'non-config)))] + [("-i" "--repl") + (set! repl? #t) + (set! version? #t) + (flags-loop (cdr args) (see saw 'non-config 'top))] + [("-n" "--no-lib") + (set! init-library #f) + (flags-loop (cdr args) (see saw 'non-config))] + [("-v" "--version") + (set! version? #t) + (flags-loop (cddr args) (see saw 'non-config))] + [("-c" "--no-compiled") + (|#%app| use-compiled-file-paths '()) + (loop (cdr args))] + [("-I") + (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) + (when init-library + (set! init-library `(lib ,lib-name))) + (loop rest-args))] + [("-X" "--collects") + (let-values ([(collects-path rest-args) (next-arg "collects path" arg within-arg args)]) + (cond + [(equal? collects-path "") + (set! init-collects-dir 'disable)] + [else + (check-path-arg "collects path" arg within-arg) + (set! init-collects-dir (path->complete-path (string->path collects-path)))]) + (loop rest-args))] + [("-G" "--config") + (let-values ([(config-path rest-args) (next-arg "config path" arg within-arg args)]) + (check-path-arg "config path" arg within-arg) + (set! init-config-dir (path->complete-path (string->path config-path))) + (loop rest-args))] + [("-C" "--cross") + (set! host-config-dir init-config-dir) + (set! host-collects-dir init-collects-dir) + (loop (cdr args))] + [("-U" "--no-user-path") + (|#%app| use-user-specific-search-paths #f) + (loop (cdr args))] + [("-d") + (|#%app| load-on-demand-enabled #f) + (loop (cdr args))] + [("-q" "--no-init-file") + (set! repl-init? #f) + (loop (cdr args))] + [("-W" "--stderr") + (let-values ([(spec rest-args) (next-arg "stderr level" arg within-arg args)]) + (set! stderr-logging-arg (parse-logging-spec "stderr" spec (format "after ~a switch" (or within-arg arg)) #t)) + (loop rest-args))] + [("-O" "--stdout") + (let-values ([(spec rest-args) (next-arg "stdout level" arg within-arg args)]) + (set! stdout-logging-arg (parse-logging-spec "stdout" spec (format "after ~a switch" (or within-arg arg)) #t)) + (loop rest-args))] + [("-N" "--name") + (let-values ([(name rest-args) (next-arg "name" arg within-arg args)]) + (set-run-file! (string->path name)) + (loop rest-args))] + [("--") + (cond + [(or (null? (cdr args)) (not (pair? (cadr args)))) + (finish (cdr args) saw)] + [else + ;; Need to handle more switches from a combined flag + (loop (cons (cadr args) (cons (car args) (cddr args))))])] + [else + (cond + [(eqv? (string-ref arg 0) #\-) + (cond + [(and (> (string-length arg) 2) + (not (eqv? (string-ref arg 1) #\-))) + ;; Split flags + (loop (append (map (lambda (c) (cons (string #\- c) arg)) + (cdr (string->list arg))) + (cdr args)))] + [else + (raise-user-error 'racket "bad switch: ~a~a" + arg + (if within-arg + (format " within: ~a" within-arg) + ""))])] + [else + ;; Non-flag argument + (finish args saw)])])))) + + ;; Set up GC logging + (define-values (struct:gc-info make-gc-info gc-info? gc-info-ref gc-info-set!) + (make-struct-type 'gc-info #f 10 0 #f null 'prefab #f '(0 1 2 3 4 5 6 7 8 9))) + (define (K plus n) + (let* ([s (number->string (quotient (abs n) 1000))] + [len (string-length s)] + [len2 (+ len + (quotient (sub1 len) 3) + (if (or (< n 0) + (not (eq? "" plus))) + 1 + 0) + 1)] + [s2 (make-string len2)]) + (string-set! s2 (sub1 len2) #\K) + (let loop ([i len] + [j (sub1 len2)] + [digits 0]) + (cond + [(zero? i) + (cond + [(< n 0) (string-set! s2 0 #\-)] + [(not (eq? plus "")) (string-set! s2 0 (string-ref plus 0))]) + s2] + [(= 3 digits) + (let ([j (sub1 j)]) + (string-set! s2 j #\,) + (loop i j 0))] + [else + (let ([i (sub1 i)] + [j (sub1 j)]) + (string-set! s2 j (string-ref s i)) + (loop i j (add1 digits)))])))) + (define minor-gcs 0) + (define major-gcs 0) + (define auto-gcs 0) + (define peak-mem 0) + (set-garbage-collect-notify! + (let ([root-logger (|#%app| current-logger)]) + ;; This function can be called in any Chez Scheme thread + (lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time + post-allocated post-allocated+overhead post-time post-cpu-time) + (let ([minor? (< gen (collect-maximum-generation))]) + (if minor? + (set! minor-gcs (add1 minor-gcs)) + (set! major-gcs (add1 major-gcs))) + (set! peak-mem (max peak-mem pre-allocated)) + (let ([debug-GC? (log-level? root-logger 'debug 'GC)]) + (when (or debug-GC? + (and (not minor?) + (log-level? root-logger 'debug 'GC:major))) + (let ([delta (- pre-allocated post-allocated)]) + (log-message root-logger 'debug (if debug-GC? 'GC 'GC:major) + (chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams @ ~a" + (if minor? "min" "MAJ") gen + (K "" pre-allocated) (K "+" (- pre-allocated+overhead pre-allocated)) + (K "" delta) (K "+" (- (- pre-allocated+overhead post-allocated+overhead) + delta)) + (- post-cpu-time pre-cpu-time) pre-cpu-time) + (make-gc-info (if minor? 'minor 'major) pre-allocated pre-allocated+overhead 0 + post-allocated post-allocated+overhead + pre-cpu-time post-cpu-time + pre-time post-time) + #f)))))))) + (|#%app| exit-handler + (let ([orig (|#%app| exit-handler)] + [root-logger (|#%app| current-logger)]) + (lambda (v) + (when (log-level? root-logger 'info 'GC) + (log-message root-logger 'info 'GC + (chez:format "0:atexit peak ~a; alloc ~a; major ~a; minor ~a; ~ams" + (K "" peak-mem) + (K "" (- (+ (bytes-deallocated) (bytes-allocated)) (initial-bytes-allocated))) + major-gcs + minor-gcs + (let ([t (sstats-gc-cpu (statistics))]) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + #f)) + (linklet-performance-report!) + (|#%app| orig v)))) + + (define stderr-logging + (or stderr-logging-arg + (let ([spec (getenv "PLTSTDERR")]) + (if spec + (parse-logging-spec "stderr" spec "in PLTSTDERR environment variable" #f) + '(error))))) + + (define stdout-logging + (or stdout-logging-arg + (let ([spec (getenv "PLTSTDOUT")]) + (if spec + (parse-logging-spec "stdout" spec "in PLTSTDOUT environment variable" #f) + '())))) + + (when (getenv "PLT_STATS_ON_BREAK") + (keyboard-interrupt-handler + (let ([orig (keyboard-interrupt-handler)]) + (lambda args + (dump-memory-stats) + (apply orig args))))) + + (when version? + (printf "Welcome to Racket v~a [cs]\n" (version))) + (call-in-main-thread + (lambda () + (boot) + (when (and stderr-logging + (not (null? stderr-logging))) + (apply add-stderr-log-receiver! (|#%app| current-logger) stderr-logging)) + (when (and stdout-logging + (not (null? stdout-logging))) + (apply add-stdout-log-receiver! (|#%app| current-logger) stdout-logging)) + (cond + [(eq? init-collects-dir 'disable) + (|#%app| use-collection-link-paths #f) + (set-collects-dir! (build-path 'same))] + [else + (set-collects-dir! init-collects-dir)]) + (set-config-dir! init-config-dir) + (unless (eq? init-collects-dir 'disable) + (|#%app| current-library-collection-links + (find-library-collection-links)) + (|#%app| current-library-collection-paths + (find-library-collection-paths))) + + (when init-library + (namespace-require+ init-library)) + + (for-each (lambda (ld) (ld)) + (reverse loads)) + + (when repl? + (when repl-init? + (let ([m (get-repl-init-filename)]) + (when m + (call-with-continuation-prompt + (lambda () (dynamic-require m 0)) + (default-continuation-prompt-tag) + (lambda args (set! exit-value 1)))))) + (|#%app| (if gracket? + (dynamic-require 'racket/gui/init 'graphical-read-eval-print-loop) + (dynamic-require 'racket/base 'read-eval-print-loop))) + (unless gracket? + (newline))) + + (|#%app| (|#%app| executable-yield-handler) 0) + + (exit exit-value)))) diff -Nru racket-6.12+ppa1/src/cs/Makefile racket-7.0+ppa1/src/cs/Makefile --- racket-6.12+ppa1/src/cs/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,310 @@ +# This makefile is used to a limited degree with nmake, but it mostly +# intended for use as a GNU makefile. + +RACKET = ../../bin/racket +SCHEME = scheme + +# Controls whether Racket layers are built as unsafe: +UNSAFE_COMP = --unsafe + +# Controls whether Racket layers are built with expression-level debugging: +DEBUG_COMP = # --debug + +# Controls whether Rumble is built as unsafe: +RUMBLE_UNSAFE_COMP = --unsafe + +COMPILE_FILE = $(SCHEME) --script compile-file.ss $(UNSAFE_COMP) $(DEBUG_COMP) --dest "$(BUILDDIR)" +COMPILE_FILE_DEPS = compile-file.ss include.ss + +RACKET_SETUP_ARGS = ../../bin/racket ../collects ../etc 0 false + +PRIMITIVES_TABLES = primitive/kernel.ss primitive/unsafe.ss primitive/flfxnum.ss \ + primitive/paramz.ss primitive/extfl.ss primitive/network.ss \ + primitive/futures.ss primitive/foreign.ss primitive/place.ss \ + primitive/linklet.ss primitive/internal.ss + +# Set by the makefile in the "c" directory when driving this one +BUILDDIR = + +# List all targets ".scm" that use "convert.rkt" so we can generate a +# dependency rule for all of them: +CONVERTED = $(BUILDDIR)compiled/thread.scm $(BUILDDIR)compiled/io.scm \ + $(BUILDDIR)compiled/regexp.scm $(BUILDDIR)compiled/expander.scm \ + $(BUILDDIR)compiled/schemify.scm $(BUILDDIR)compiled/known.scm + +# Additional dependencies for those ".scm" files generated by "convert.rkt": +CONVERT_DEPS = $(PRIMITIVES_TABLES) + +CONVERT_RACKET = $(RACKET) -l- setup --chain ../setup-go.rkt $(BUILDDIR)compiled +CONVERT = $(CONVERT_RACKET) '(CONVERTED)' $(BUILDDIR)compiled/convert.d convert.rkt $(UNSAFE_COMP) + +# Depenency chain for ".so" files: +RUMBLE_DEPS = $(BUILDDIR)chezpart.so +THREAD_DEPS = $(RUMBLE_DEPS) $(BUILDDIR)rumble.so +IO_DEPS = $(THREAD_DEPS) $(BUILDDIR)thread.so +REGEXP_DEPS = $(IO_DEPS) $(BUILDDIR)io.so +SCHEMIFY_DEPS = $(REGEXP_DEPS) $(BUILDDIR)regexp.so +LINKLET_DEPS = $(SCHEMIFY_DEPS) $(BUILDDIR)schemify.so +EXPANDER_DEPS = $(LINKLET_DEPS) $(BUILDDIR)linklet.so +MAIN_DEPS = $(EXPANDER_DEPS) $(BUILDDIR)expander.so + +all: + $(MAKE) rktio + $(MAKE) rktl + $(MAKE) $(BUILDDIR)racket.so + +expander-demo: $(BUILDDIR)expander.so demo/expander.ss + $(SCHEME) $(EXPANDER_DEPS) $(BUILDDIR)expander.so demo/expander.ss + +run: $(BUILDDIR)main.so ../../bin/racket + $(SCHEME) --script $(BUILDDIR)main.so $(RACKET_SETUP_ARGS) $(ARGS) + +setup: + $(MAKE) run ARGS="-l- setup $(ARGS)" + +setup-v: + $(MAKE) run ARGS="-W 'info@compiler/cm info@linklet debug@GC:major error' -l- setup $(ARGS)" + +run-wpo: $(BUILDDIR)racket.so ../../bin/racket + $(SCHEME) --script $(BUILDDIR)racket.so $(RACKET_SETUP_ARGS) $(ARGS) + +$(BUILDDIR)racket.so: $(BUILDDIR)main.so $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) --whole-program $(BUILDDIR)racket.so $(BUILDDIR)main.wpo + +$(BUILDDIR)main.so: $(MAIN_DEPS) main.sps $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) main.sps $(MAIN_DEPS) + +strip: + $(SCHEME) --script strip.ss $(MAIN_DEPS) $(BUILDDIR)racket.so + +rktl: + $(MAKE) thread-rktl + $(MAKE) io-rktl + $(MAKE) regexp-rktl + $(MAKE) schemify-rktl + $(MAKE) known-rktl + $(MAKE) expander-rktl + +# For running without an enclosing build of the traditional Racket VM: +../../bin/racket: + mkdir -p ../../bin + touch ../../bin/racket + +$(BUILDDIR)expander.so: expander.sls $(BUILDDIR)compiled/expander.scm $(PRIMITIVES_TABLES) $(EXPANDER_DEPS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) expander.sls $(EXPANDER_DEPS) + +$(BUILDDIR)compiled/expander.scm: $(BUILDDIR)compiled/expander.rktl $(CONVERT_DEPS) + $(CONVERT) $(BUILDDIR)compiled/expander.rktl $(BUILDDIR)compiled/expander.scm + +$(BUILDDIR)compiled/expander.rktl: + $(MAKE) expander-rktl + +expander-rktl: + $(MAKE) bounce BOUNCE_DIR=../expander BOUNCE_TARGET=expander-src BUILDDIR="../cs/" + +linklet-demo: $(BUILDDIR)linklet.so + $(SCHEME) $(LINKLET_DEPS) $(BUILDDIR)linklet.so demo/linklet.ss + +$(BUILDDIR)linklet.so: linklet.sls $(LINKLET_DEPS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) linklet.sls $(LINKLET_DEPS) + + +$(BUILDDIR)schemify.so: schemify.sls $(BUILDDIR)compiled/schemify.scm $(BUILDDIR)compiled/known.scm $(SCHEMIFY_DEPS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) schemify.sls $(SCHEMIFY_DEPS) + +$(BUILDDIR)compiled/schemify.scm: $(BUILDDIR)compiled/schemify.rktl $(CONVERT_DEPS) + $(CONVERT) --skip-export $(BUILDDIR)compiled/schemify.rktl $(BUILDDIR)compiled/schemify.scm + +$(BUILDDIR)compiled/schemify.rktl: + $(MAKE) schemify-rktl + +schemify-rktl: + $(MAKE) bounce BOUNCE_DIR=../schemify BOUNCE_TARGET=schemify-src BUILDDIR="../cs/" + + +# Used by schemify.sls at compile time +$(BUILDDIR)compiled/known.scm: $(BUILDDIR)compiled/known.rktl $(CONVERT_DEPS) + $(CONVERT) --skip-export $(BUILDDIR)compiled/known.rktl $(BUILDDIR)compiled/known.scm + +$(BUILDDIR)compiled/known.rktl: + $(MAKE) known-rktl + +known-rktl: + $(MAKE) bounce BOUNCE_DIR=../schemify BOUNCE_TARGET=known-src BUILDDIR="../cs/" + + +regexp-demo: $(BUILDDIR)regexp.so + $(SCHEME) $(REGEXP_DEPS) $(BUILDDIR)regexp.so demo/regexp.ss + +$(BUILDDIR)regexp.so: $(BUILDDIR)compiled/regexp.scm regexp.sls $(REGEXP_DEPS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) regexp.sls $(REGEXP_DEPS) + +$(BUILDDIR)compiled/regexp.scm: $(BUILDDIR)compiled/regexp.rktl $(CONVERT_DEPS) + $(CONVERT) $(BUILDDIR)compiled/regexp.rktl $(BUILDDIR)compiled/regexp.scm + +$(BUILDDIR)compiled/regexp.rktl: + $(MAKE) regexp-rktl + +regexp-rktl: + $(MAKE) bounce BOUNCE_DIR=../regexp BOUNCE_TARGET=regexp-src BUILDDIR="../cs/" + + +io-demo: $(BUILDDIR)io.so + $(SCHEME) $(IO_DEPS) $(BUILDDIR)io.so demo/io.ss + +$(BUILDDIR)io.so: $(BUILDDIR)compiled/io.scm io.sls $(IO_DEPS) ../rktio/rktio.rktl $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) io.sls $(IO_DEPS) + +$(BUILDDIR)compiled/io.scm: $(BUILDDIR)compiled/io.rktl $(CONVERT_DEPS) + $(CONVERT) $(BUILDDIR)compiled/io.rktl $(BUILDDIR)compiled/io.scm + +$(BUILDDIR)compiled/io.rktl: + $(MAKE) io-rktl + +io-rktl: + $(MAKE) bounce BOUNCE_DIR=../io BOUNCE_TARGET=io-src BUILDDIR="../cs/" + +rktio: + $(MAKE) bounce BOUNCE_DIR=../io BOUNCE_TARGET=rktio + + +thread-demo: $(BUILDDIR)thread.so + $(SCHEME) $(THREAD_DEPS) $(BUILDDIR)thread.so demo/thread.ss + +$(BUILDDIR)thread.so: $(BUILDDIR)compiled/thread.scm thread.sls $(THREAD_DEPS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) thread.sls $(THREAD_DEPS) + +$(BUILDDIR)compiled/thread.scm: $(BUILDDIR)compiled/thread.rktl $(CONVERT_DEPS) + $(CONVERT) $(BUILDDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.scm + +$(BUILDDIR)compiled/thread.rktl: + $(MAKE) thread-rktl + +thread-rktl: + $(MAKE) bounce BOUNCE_DIR=../thread BOUNCE_TARGET=thread-src BUILDDIR="../cs/" + + +bounce: + $(MAKE) bounce-go RACKET="`$(RACKET) absify.rkt --exec $(RACKET)`" + +bounce-go: + cd $(BOUNCE_DIR); $(MAKE) RACO="$(RACKET) -N raco -l- raco" $(BOUNCE_TARGET) + + +chaperone-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/chaperone.ss + +hash-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/hash.ss + +struct-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/struct.ss + +control-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/control.ss + +foreign-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/foreign.ss + +will-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/will.ss + +future-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/future.ss + +future2-demo: $(BUILDDIR)rumble.so + $(SCHEME) $(BUILDDIR)chezpart.so $(BUILDDIR)rumble.so demo/future2.ss + +RUMBLE_SRCS = rumble/define.ss \ + rumble/virtual-register.ss \ + rumble/check.ss \ + rumble/syntax-rule.ss \ + rumble/constant.ss \ + rumble/hash-code.ss \ + rumble/struct.ss \ + rumble/prefab.ss \ + rumble/procedure.ss \ + rumble/impersonator.ss \ + rumble/equal.ss \ + rumble/object-name.ss \ + rumble/arity.ss \ + rumble/intmap.ss \ + rumble/hash.ss \ + rumble/datum.ss \ + rumble/lock.ss \ + rumble/thread-cell.ss \ + rumble/parameter.ss \ + rumble/begin0.ss \ + rumble/pthread.ss \ + rumble/control.ss \ + rumble/interrupt.ss \ + rumble/engine.ss \ + rumble/error.ss \ + rumble/srcloc.ss \ + rumble/boolean.ss \ + rumble/bytes.ss \ + rumble/string.ss \ + rumble/char.ss \ + rumble/symbol.ss \ + rumble/list.ss \ + rumble/vector.ss \ + rumble/box.ss \ + rumble/immutable.ss \ + rumble/keyword.ss \ + rumble/mpair.ss \ + rumble/number.ss \ + rumble/random.ss \ + rumble/flvector.ss \ + rumble/correlated.ss \ + rumble/graph.ss \ + rumble/time.ss \ + rumble/memory.ss \ + rumble/ephemeron.ss \ + rumble/will-executor.ss \ + rumble/system.ss \ + rumble/unsafe.ss \ + rumble/extfl.ss \ + rumble/place.ss \ + rumble/foreign.ss \ + rumble/future.ss \ + rumble/version.ss \ + rumble/inline.ss \ + ../racket/src/schvers.h + +$(BUILDDIR)rumble.so: $(RUMBLE_DEPS) rumble.sls $(RUMBLE_SRCS) $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) $(RUMBLE_UNSAFE_COMP) rumble.sls $(RUMBLE_DEPS) + +$(BUILDDIR)chezpart.so: chezpart.sls $(COMPILE_FILE_DEPS) + $(COMPILE_FILE) chezpart.sls + +clean: + rm -f chezpart.so rumble.so regexp.so io.so linklet.so expander.so schemify.so + rm -f chezpart.wpo rumble.wpo regexp.wpo io.wpo linklet.wpo expander.wpo schemify.wpo + rm -f thread.so thread.wpo main.wpo main.so + rm -rf compiled + + +# The following included dependency files are generated by when +# creating compiler/expander.rktl, etc. The `-inclide` statements are +# wrapped in a pattern that causes them to be ignored by `nmake`, +# while the `nmake` directives are ignored by GNU `make`. + +# \ +!if 0 + +# These dependencies are used only for direct use of the makefile +-include compiled/expander.d +-include compiled/thread.d +-include compiled/io.d +-include compiled/regexp.d +-include compiled/schemify.d +-include compiled/known.d + +# These dependencies are needed when "cs/c" drives the makefile +-include $(BUILDDIR)compiled/convert.d + +#\ +!endif + +# \ +!include $(BUILDDIR)compiled/convert.d diff -Nru racket-6.12+ppa1/src/cs/primitive/extfl.ss racket-7.0+ppa1/src/cs/primitive/extfl.ss --- racket-6.12+ppa1/src/cs/primitive/extfl.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/extfl.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,47 @@ + +(define-primitive-table extfl-table + [->extfl (known-procedure 2)] + [extfl* (known-procedure 4)] + [extfl+ (known-procedure 4)] + [extfl- (known-procedure 4)] + [extfl->exact (known-procedure 2)] + [extfl->exact-integer (known-procedure 2)] + [extfl->floating-point-bytes (known-procedure 30)] + [extfl->fx (known-procedure 2)] + [extfl->inexact (known-procedure 2)] + [extfl/ (known-procedure 4)] + [extfl< (known-procedure 4)] + [extfl<= (known-procedure 4)] + [extfl= (known-procedure 4)] + [extfl> (known-procedure 4)] + [extfl>= (known-procedure 4)] + [extflabs (known-procedure 2)] + [extflacos (known-procedure 2)] + [extflasin (known-procedure 2)] + [extflatan (known-procedure 2)] + [extflceiling (known-procedure 2)] + [extflcos (known-procedure 2)] + [extflexp (known-procedure 2)] + [extflexpt (known-procedure 4)] + [extflfloor (known-procedure 2)] + [extfllog (known-procedure 2)] + [extflmax (known-procedure 4)] + [extflmin (known-procedure 4)] + [extflonum-available? (known-procedure 1)] + [extflonum? (known-procedure 2)] + [extflround (known-procedure 2)] + [extflsin (known-procedure 2)] + [extflsqrt (known-procedure 2)] + [extfltan (known-procedure 2)] + [extfltruncate (known-procedure 2)] + [extflvector (known-procedure -1)] + [extflvector-length (known-procedure 2)] + [extflvector-ref (known-procedure 4)] + [extflvector-set! (known-procedure 8)] + [extflvector? (known-procedure 2)] + [floating-point-bytes->extfl (known-procedure 30)] + [fx->extfl (known-procedure 2)] + [make-extflvector (known-procedure 6)] + [make-shared-extflvector (known-procedure 6)] + [real->extfl (known-procedure 2)] + [shared-extflvector (known-procedure -1)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/flfxnum.ss racket-7.0+ppa1/src/cs/primitive/flfxnum.ss --- racket-6.12+ppa1/src/cs/primitive/flfxnum.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/flfxnum.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,73 @@ + +(define-primitive-table flfxnum-table + [->fl (known-procedure 2)] + [fl* (known-procedure 4)] + [fl+ (known-procedure 4)] + [fl- (known-procedure 4)] + [fl->exact-integer (known-procedure 2)] + [fl->fx (known-procedure 2)] + [fl/ (known-procedure 4)] + [fl< (known-procedure 4)] + [fl<= (known-procedure 4)] + [fl= (known-procedure 4)] + [fl> (known-procedure 4)] + [fl>= (known-procedure 4)] + [flabs (known-procedure 2)] + [flacos (known-procedure 2)] + [flasin (known-procedure 2)] + [flatan (known-procedure 2)] + [flceiling (known-procedure 2)] + [flcos (known-procedure 2)] + [flexp (known-procedure 2)] + [flexpt (known-procedure 4)] + [flfloor (known-procedure 2)] + [flimag-part (known-procedure 2)] + [fllog (known-procedure 2)] + [flmax (known-procedure 4)] + [flmin (known-procedure 4)] + [flreal-part (known-procedure 2)] + [flround (known-procedure 2)] + [flsin (known-procedure 2)] + [flsqrt (known-procedure 2)] + [fltan (known-procedure 2)] + [fltruncate (known-procedure 2)] + [flvector (known-procedure -1)] + [flvector-copy (known-procedure 14)] + [flvector-length (known-procedure 2)] + [flvector-ref (known-procedure 4)] + [flvector-set! (known-procedure 8)] + [flvector? (known-procedure 2)] + [fx* (known-procedure 4)] + [fx+ (known-procedure 4)] + [fx- (known-procedure 4)] + [fx->fl (known-procedure 2)] + [fx< (known-procedure 4)] + [fx<= (known-procedure 4)] + [fx= (known-procedure 4)] + [fx> (known-procedure 4)] + [fx>= (known-procedure 4)] + [fxabs (known-procedure 2)] + [fxand (known-procedure 4)] + [fxior (known-procedure 4)] + [fxlshift (known-procedure 4)] + [fxmax (known-procedure 4)] + [fxmin (known-procedure 4)] + [fxmodulo (known-procedure 4)] + [fxnot (known-procedure 2)] + [fxquotient (known-procedure 4)] + [fxremainder (known-procedure 4)] + [fxrshift (known-procedure 4)] + [fxvector (known-procedure -1)] + [fxvector-copy (known-procedure 14)] + [fxvector-length (known-procedure 2)] + [fxvector-ref (known-procedure 4)] + [fxvector-set! (known-procedure 8)] + [fxvector? (known-procedure 2)] + [fxxor (known-procedure 4)] + [make-flrectangular (known-procedure 4)] + [make-flvector (known-procedure 6)] + [make-fxvector (known-procedure 6)] + [make-shared-flvector (known-procedure 6)] + [make-shared-fxvector (known-procedure 6)] + [shared-flvector (known-procedure -1)] + [shared-fxvector (known-procedure -1)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/foreign.ss racket-7.0+ppa1/src/cs/primitive/foreign.ss --- racket-6.12+ppa1/src/cs/primitive/foreign.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/foreign.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,83 @@ + +(define-primitive-table foreign-table + [_bool (known-constant)] + [_bytes (known-constant)] + [_double (known-constant)] + [_double* (known-constant)] + [_fixint (known-constant)] + [_fixnum (known-constant)] + [_float (known-constant)] + [_fpointer (known-constant)] + [_gcpointer (known-constant)] + [_int16 (known-constant)] + [_int32 (known-constant)] + [_int64 (known-constant)] + [_int8 (known-constant)] + [_longdouble (known-constant)] + [_path (known-constant)] + [_pointer (known-constant)] + [_scheme (known-constant)] + [_stdbool (known-constant)] + [_string/ucs-4 (known-constant)] + [_string/utf-16 (known-constant)] + [_symbol (known-constant)] + [_ufixint (known-constant)] + [_ufixnum (known-constant)] + [_uint16 (known-constant)] + [_uint32 (known-constant)] + [_uint64 (known-constant)] + [_uint8 (known-constant)] + [_void (known-constant)] + [compiler-sizeof (known-procedure 2)] + [cpointer-gcable? (known-procedure 2)] + [cpointer-tag (known-procedure 2)] + [cpointer? (known-procedure 2)] + [ctype-alignof (known-procedure 2)] + [ctype-basetype (known-procedure 2)] + [ctype-c->scheme (known-procedure 2)] + [ctype-scheme->c (known-procedure 2)] + [ctype-sizeof (known-procedure 2)] + [ctype? (known-procedure 2)] + [end-stubborn-change (known-procedure 2)] + [extflvector->cpointer (known-procedure 2)] + [ffi-call (known-procedure 504)] + [ffi-call-maker (known-procedure 252)] + [ffi-callback (known-procedure 120)] + [ffi-callback? (known-procedure 2)] + [ffi-callback-maker (known-procedure 60)] + [ffi-lib (known-procedure 14)] + [ffi-lib-name (known-procedure 2)] + [ffi-lib? (known-procedure 2)] + [ffi-obj (known-procedure 4)] + [ffi-obj-lib (known-procedure 2)] + [ffi-obj-name (known-procedure 2)] + [ffi-obj? (known-procedure 2)] + [flvector->cpointer (known-procedure 2)] + [free (known-procedure 2)] + [free-immobile-cell (known-procedure 2)] + [lookup-errno (known-procedure 2)] + [make-array-type (known-procedure 4)] + [make-cstruct-type (known-procedure 14)] + [make-ctype (known-procedure 8)] + [make-late-weak-box (known-procedure 2)] + [make-late-weak-hasheq (known-procedure 1)] + [make-sized-byte-string (known-procedure 4)] + [make-stubborn-will-executor (known-procedure 1)] + [make-union-type (known-procedure -2)] + [malloc (known-procedure 62)] + [malloc-immobile-cell (known-procedure 2)] + [memcpy (known-procedure 120)] + [memmove (known-procedure 120)] + [memset (known-procedure 56)] + [offset-ptr? (known-procedure 2)] + [prop:cpointer (known-constant)] + [ptr-add (known-procedure 12)] + [ptr-add! (known-procedure 12)] + [ptr-equal? (known-procedure 4)] + [ptr-offset (known-procedure 2)] + [ptr-ref (known-procedure 28)] + [ptr-set! (known-procedure 56)] + [saved-errno (known-procedure 3)] + [set-cpointer-tag! (known-procedure 4)] + [set-ptr-offset! (known-procedure 12)] + [vector->cpointer (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/futures.ss racket-7.0+ppa1/src/cs/primitive/futures.ss --- racket-6.12+ppa1/src/cs/primitive/futures.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/futures.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ + +(define-primitive-table futures-table + [current-future (known-procedure 1)] + [fsemaphore-count (known-procedure 2)] + [fsemaphore-post (known-procedure 2)] + [fsemaphore-try-wait? (known-procedure 2)] + [fsemaphore-wait (known-procedure 2)] + [fsemaphore? (known-procedure 2)] + [future (known-procedure 2)] + [future? (known-procedure 2)] + [futures-enabled? (known-procedure 1)] + [make-fsemaphore (known-procedure 2)] + [mark-future-trace-end! (known-procedure 1)] + [processor-count (known-procedure 1)] + [reset-future-logs-for-tracing! (known-procedure 1)] + [touch (known-procedure 2)] + [would-be-future (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/internal.ss racket-7.0+ppa1/src/cs/primitive/internal.ss --- racket-6.12+ppa1/src/cs/primitive/internal.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/internal.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,32 @@ + +;; Exports that are not exposed to Racket, but +;; can be used in a linklet: + +(define-primitive-table internal-table + [call/cm (known-constant)] + [extract-procedure (known-constant)] + [set-ctl-c-handler! (known-constant)] + [register-linklet-instantiate-continuation! (known-constant)] + [impersonator-val (known-constant)] + [impersonate-ref (known-constant)] + [impersonate-set! (known-constant)] + [struct-type-install-properties! (known-constant)] + [structure-type-lookup-prefab-uid (known-constant)] + [struct-type-constructor-add-guards (known-constant)] + [register-struct-constructor! (known-constant)] + [register-struct-predicate! (known-constant)] + [register-struct-field-accessor! (known-constant)] + [register-struct-field-mutator! (known-constant)] + [struct-property-set! (known-constant)] + [|#%call-with-values| (known-constant)] + [unbox/check-undefined (known-constant)] + [set-box!/check-undefined (known-constant)] + + [make-record-type-descriptor (known-constant)] + [make-record-constructor-descriptor (known-constant)] + [record-constructor (known-constant)] + [record-predicate (known-constant)] + [record-accessor (known-constant)] + [record-mutator (known-constant)] + + [make-pthread-parameter (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/kernel.ss racket-7.0+ppa1/src/cs/primitive/kernel.ss --- racket-6.12+ppa1/src/cs/primitive/kernel.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/kernel.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,979 @@ + +;; This table omits anything that the expander implements itself, +;; since the expander will export its own variant instead of the +;; `kernel-table` variant. + +(define-primitive-table kernel-table + [* (known-procedure -1)] + [+ (known-procedure -1)] + [- (known-procedure -2)] + [/ (known-procedure -2)] + [< (known-procedure -4)] + [<= (known-procedure -4)] + [= (known-procedure -4)] + [> (known-procedure -4)] + [>= (known-procedure -4)] + [abort-current-continuation (known-procedure -2)] + [abs (known-procedure 2)] + [absolute-path? (known-procedure 2)] + [acos (known-procedure 2)] + [add1 (known-procedure 2)] + [alarm-evt (known-procedure 2)] + [always-evt (known-constant)] + [andmap (known-procedure -4)] + [angle (known-procedure 2)] + [append (known-procedure -1)] + [apply (known-procedure -4)] + [arithmetic-shift (known-procedure 4)] + [arity-at-least (known-constant)] + [arity-at-least-value (known-procedure 2)] + [arity-at-least? (known-procedure/succeeds 2)] + [asin (known-procedure 2)] + [assoc (known-procedure 4)] + [assq (known-procedure 4)] + [assv (known-procedure 4)] + [atan (known-procedure 6)] + [banner (known-procedure 1)] + [bitwise-and (known-procedure -1)] + [bitwise-bit-field (known-procedure 8)] + [bitwise-bit-set? (known-procedure 4)] + [bitwise-ior (known-procedure -1)] + [bitwise-not (known-procedure 2)] + [bitwise-xor (known-procedure -1)] + [boolean? (known-procedure/succeeds 2)] + [bound-identifier=? (known-procedure 28)] + [box (known-procedure/succeeds 2)] + [box-cas! (known-procedure 8)] + [box-immutable (known-procedure 2)] + [box? (known-procedure/succeeds 2)] + [break-enabled (known-procedure 3)] + [break-thread (known-procedure 6)] + [build-path (known-procedure -2)] + [build-path/convention-type (known-procedure -4)] + [byte-pregexp (known-procedure 6)] + [byte-pregexp? (known-procedure 2)] + [byte-ready? (known-procedure 3)] + [byte-regexp (known-procedure 6)] + [byte-regexp? (known-procedure 2)] + [byte? (known-procedure/succeeds 2)] + [bytes (known-procedure -1)] + [bytes->immutable-bytes (known-procedure 2)] + [bytes->list (known-procedure 2)] + [bytes->path (known-procedure 6)] + [bytes->path-element (known-procedure 6)] + [bytes->string/latin-1 (known-procedure 30)] + [bytes->string/locale (known-procedure 30)] + [bytes->string/utf-8 (known-procedure 30)] + [bytes-append (known-procedure -1)] + [bytes-close-converter (known-procedure 2)] + [bytes-convert (known-procedure 254)] + [bytes-convert-end (known-procedure 15)] + [bytes-converter? (known-procedure 2)] + [bytes-copy (known-procedure 2)] + [bytes-copy! (known-procedure 56)] + [bytes-fill! (known-procedure 4)] + [bytes-length (known-procedure 2)] + [bytes-open-converter (known-procedure 4)] + [bytes-ref (known-procedure 4)] + [bytes-set! (known-procedure 8)] + [bytes-utf-8-index (known-procedure 28)] + [bytes-utf-8-length (known-procedure 30)] + [bytes-utf-8-ref (known-procedure 28)] + [bytes? (known-procedure -4)] + [bytes? (known-procedure/succeeds 2)] + [caaaar (known-procedure 2)] + [caaadr (known-procedure 2)] + [caaar (known-procedure 2)] + [caadar (known-procedure 2)] + [caaddr (known-procedure 2)] + [caadr (known-procedure 2)] + [caadr (known-procedure 2)] + [caar (known-procedure 2)] + [cadaar (known-procedure 2)] + [cadadr (known-procedure 2)] + [cadar (known-procedure 2)] + [caddar (known-procedure 2)] + [cadddr (known-procedure 2)] + [caddr (known-procedure 2)] + [cadr (known-procedure 2)] + [call-in-nested-thread (known-procedure 6)] + [call-with-composable-continuation (known-procedure 6)] + [call-with-continuation-barrier (known-procedure 2)] + [call-with-continuation-prompt (known-procedure -2)] + [call-with-current-continuation (known-procedure 6)] + [call-with-escape-continuation (known-procedure 2)] + [call-with-immediate-continuation-mark (known-procedure 12)] + [call-with-input-file (known-procedure 12)] + [call-with-output-file (known-procedure 28)] + [call-with-semaphore (known-procedure -4)] + [call-with-semaphore/enable-break (known-procedure -4)] + [call-with-values (known-procedure 4)] + [car (known-procedure 2)] + [cdaaar (known-procedure 2)] + [cdaadr (known-procedure 2)] + [cdaar (known-procedure 2)] + [cdadar (known-procedure 2)] + [cdaddr (known-procedure 2)] + [cdadr (known-procedure 2)] + [cdar (known-procedure 2)] + [cddaar (known-procedure 2)] + [cddadr (known-procedure 2)] + [cddar (known-procedure 2)] + [cdddar (known-procedure 2)] + [cddddr (known-procedure 2)] + [cdddr (known-procedure 2)] + [cddr (known-procedure 2)] + [cdr (known-procedure 2)] + [ceiling (known-procedure 2)] + [channel-put-evt (known-procedure 4)] + [channel-put-evt? (known-procedure 2)] + [channel? (known-procedure 2)] + [chaperone-box (known-procedure -8)] + [chaperone-channel (known-procedure -8)] + [chaperone-continuation-mark-key (known-procedure -8)] + [chaperone-evt (known-procedure -4)] + [chaperone-hash (known-procedure -32)] + [chaperone-of? (known-procedure 4)] + [chaperone-procedure (known-procedure -4)] + [chaperone-procedure* (known-procedure -4)] + [chaperone-prompt-tag (known-procedure -8)] + [chaperone-struct (known-procedure -2)] + [chaperone-struct-type (known-procedure -16)] + [chaperone-vector (known-procedure -8)] + [chaperone-vector* (known-procedure -8)] + [chaperone? (known-procedure/succeeds 2)] + [char->integer (known-procedure 2)] + [char-alphabetic? (known-procedure 2)] + [char-blank? (known-procedure 2)] + [char-ci<=? (known-procedure -4)] + [char-ci=? (known-procedure -4)] + [char-ci>? (known-procedure -4)] + [char-downcase (known-procedure 2)] + [char-foldcase (known-procedure 2)] + [char-general-category (known-procedure 2)] + [char-graphic? (known-procedure 2)] + [char-iso-control? (known-procedure 2)] + [char-lower-case? (known-procedure 2)] + [char-numeric? (known-procedure 2)] + [char-punctuation? (known-procedure 2)] + [char-ready? (known-procedure 3)] + [char-symbolic? (known-procedure 2)] + [char-title-case? (known-procedure 2)] + [char-titlecase (known-procedure 2)] + [char-upcase (known-procedure 2)] + [char-upper-case? (known-procedure 2)] + [char-utf-8-length (known-procedure 2)] + [char-whitespace? (known-procedure 2)] + [char<=? (known-procedure -4)] + [char=? (known-procedure -4)] + [char>? (known-procedure -4)] + [char? (known-procedure/succeeds 2)] + [checked-procedure-check-and-extract (known-procedure 32)] + [choice-evt (known-procedure -1)] + [cleanse-path (known-procedure 2)] + [close-input-port (known-procedure 2)] + [close-output-port (known-procedure 2)] + [collect-garbage (known-procedure 3)] + [compile (known-procedure 2)] + [compile-allow-set!-undefined (known-constant)] + [compile-context-preservation-enabled (known-constant)] + [compile-enforce-module-constants (known-constant)] + [complete-path? (known-procedure 2)] + [complex? (known-procedure/succeeds 2)] + [cons (known-procedure/succeeds 4)] + [continuation-mark-key? (known-procedure 2)] + [continuation-mark-set->context (known-procedure 2)] + [continuation-mark-set->list (known-procedure 12)] + [continuation-mark-set->list* (known-procedure 28)] + [continuation-mark-set-first (known-procedure 28)] + [continuation-mark-set? (known-procedure 2)] + [continuation-marks (known-procedure 6)] + [continuation-prompt-available? (known-procedure 6)] + [continuation-prompt-tag? (known-procedure 2)] + [continuation? (known-procedure 2)] + [copy-file (known-procedure 12)] + [cos (known-procedure 2)] + [current-code-inspector (known-constant)] + [current-command-line-arguments (known-constant)] + [current-continuation-marks (known-procedure 3)] + [current-custodian (known-constant)] + [current-directory (known-constant)] + [current-directory-for-user (known-constant)] + [current-drive (known-procedure 1)] + [current-environment-variables (known-constant)] + [current-error-port (known-constant)] + [current-evt-pseudo-random-generator (known-constant)] + [current-force-delete-permissions (known-constant)] + [current-gc-milliseconds (known-procedure 1)] + [current-get-interaction-input-port (known-constant)] + [current-inexact-milliseconds (known-procedure 1)] + [current-input-port (known-constant)] + [current-inspector (known-constant)] + [current-load-extension (known-constant)] + [current-load-relative-directory (known-constant)] + [current-locale (known-constant)] + [current-logger (known-constant)] + [current-memory-use (known-procedure 3)] + [current-milliseconds (known-procedure 1)] + [current-output-port (known-constant)] + [current-plumber (known-constant)] + [current-preserved-thread-cell-values (known-procedure 3)] + [current-print (known-constant)] + [current-process-milliseconds (known-procedure 3)] + [current-prompt-read (known-constant)] + [current-pseudo-random-generator (known-constant)] + [current-read-interaction (known-constant)] + [current-seconds (known-procedure 1)] + [current-security-guard (known-constant)] + [current-subprocess-custodian-mode (known-constant)] + [current-thread (known-procedure 1)] + [current-thread-group (known-constant)] + [current-thread-initial-stack-size (known-constant)] + [current-write-relative-directory (known-constant)] + [custodian-box-value (known-procedure 2)] + [custodian-box? (known-procedure 2)] + [custodian-limit-memory (known-procedure 12)] + [custodian-managed-list (known-procedure 4)] + [custodian-memory-accounting-available? (known-procedure 1)] + [custodian-require-memory (known-procedure 8)] + [custodian-shut-down? (known-procedure 2)] + [custodian-shutdown-all (known-procedure 2)] + [custodian? (known-procedure 2)] + [custom-print-quotable-accessor (known-procedure 2)] + [custom-print-quotable? (known-procedure 2)] + [custom-write-accessor (known-procedure 2)] + [custom-write? (known-procedure 2)] + [date (known-constant)] + [date* (known-constant)] + [date*-nanosecond (known-procedure 2)] + [date*-time-zone-name (known-procedure 2)] + [date*? (known-procedure 2)] + [date-day (known-procedure 2)] + [date-dst? (known-procedure 2)] + [date-hour (known-procedure 2)] + [date-minute (known-procedure 2)] + [date-month (known-procedure 2)] + [date-second (known-procedure 2)] + [date-time-zone-offset (known-procedure 2)] + [date-week-day (known-procedure 2)] + [date-year (known-procedure 2)] + [date-year-day (known-procedure 2)] + [date? (known-procedure/succeeds 2)] + [datum->syntax (known-procedure 60)] + [datum-intern-literal (known-procedure 2)] + [default-continuation-prompt-tag (known-procedure 1)] + [delete-directory (known-procedure 2)] + [delete-file (known-procedure 2)] + [denominator (known-procedure 2)] + [directory-exists? (known-procedure 2)] + [directory-list (known-procedure 3)] + [display (known-procedure 6)] + [double-flonum? (known-procedure 2)] + [dump-memory-stats (known-procedure -1)] + [dynamic-wind (known-procedure 8)] + [environment-variables-copy (known-procedure 2)] + [environment-variables-names (known-procedure 2)] + [environment-variables-ref (known-procedure 4)] + [environment-variables-set! (known-procedure 24)] + [environment-variables? (known-procedure 2)] + [eof (known-constant)] + [eof-object? (known-procedure/succeeds 2)] + [ephemeron-value (known-procedure 6)] + [ephemeron? (known-procedure/succeeds 2)] + [eprintf (known-procedure -2)] + [eq-hash-code (known-procedure 2)] + [eq? (known-procedure/succeeds 4)] + [equal-hash-code (known-procedure 2)] + [equal-secondary-hash-code (known-procedure 2)] + [equal? (known-procedure 4)] + [equal?/recur (known-procedure 8)] + [eqv-hash-code (known-procedure 2)] + [eqv? (known-procedure/succeeds 4)] + [error (known-procedure -2)] + [error-display-handler (known-constant)] + [error-escape-handler (known-constant)] + [error-print-context-length (known-constant)] + [error-print-source-location (known-constant)] + [error-print-width (known-constant)] + [error-value->string-handler (known-constant)] + [eval-jit-enabled (known-constant)] + [even? (known-procedure 2)] + [evt? (known-procedure 2)] + [exact->inexact (known-procedure 2)] + [exact-integer? (known-procedure/succeeds 2)] + [exact-nonnegative-integer? (known-procedure 2)] + [exact-positive-integer? (known-procedure/succeeds 2)] + [exact? (known-procedure 2)] + [executable-yield-handler (known-constant)] + [exit (known-procedure 3)] + [exit-handler (known-constant)] + [exn (known-constant)] + [exn-continuation-marks (known-procedure 2)] + [exn-continuation-marks (known-procedure 2)] + [exn-message (known-procedure 2)] + [exn-message (known-procedure 2)] + [exn:break (known-constant)] + [exn:break-continuation (known-procedure 2)] + [exn:break:hang-up (known-constant)] + [exn:break:hang-up? (known-procedure 2)] + [exn:break:terminate (known-constant)] + [exn:break:terminate? (known-procedure 2)] + [exn:break? (known-procedure 2)] + [exn:fail (known-constant)] + [exn:fail:contract (known-constant)] + [exn:fail:contract:arity (known-constant)] + [exn:fail:contract:arity? (known-procedure 2)] + [exn:fail:contract:continuation (known-constant)] + [exn:fail:contract:continuation? (known-procedure 2)] + [exn:fail:contract:divide-by-zero (known-constant)] + [exn:fail:contract:divide-by-zero? (known-procedure 2)] + [exn:fail:contract:non-fixnum-result (known-constant)] + [exn:fail:contract:non-fixnum-result? (known-procedure 2)] + [exn:fail:contract:variable (known-constant)] + [exn:fail:contract:variable-id (known-procedure 2)] + [exn:fail:contract:variable? (known-procedure 2)] + [exn:fail:contract? (known-procedure 2)] + [exn:fail:filesystem (known-constant)] + [exn:fail:filesystem:errno (known-constant)] + [exn:fail:filesystem:errno-errno (known-procedure 2)] + [exn:fail:filesystem:errno? (known-procedure 2)] + [exn:fail:filesystem:exists (known-constant)] + [exn:fail:filesystem:exists? (known-procedure 2)] + [exn:fail:filesystem:version (known-constant)] + [exn:fail:filesystem:version? (known-procedure 2)] + [exn:fail:filesystem? (known-procedure 2)] + [exn:fail:network (known-constant)] + [exn:fail:network:errno (known-constant)] + [exn:fail:network:errno-errno (known-procedure 2)] + [exn:fail:network:errno? (known-procedure 2)] + [exn:fail:network? (known-procedure 2)] + [exn:fail:out-of-memory (known-constant)] + [exn:fail:out-of-memory? (known-procedure 2)] + [exn:fail:read (known-constant)] + [exn:fail:read-srclocs (known-procedure 2)] + [exn:fail:read:eof (known-constant)] + [exn:fail:read:eof? (known-procedure 2)] + [exn:fail:read:non-char (known-constant)] + [exn:fail:read:non-char? (known-procedure 2)] + [exn:fail:read? (known-procedure 2)] + [exn:fail:unsupported (known-constant)] + [exn:fail:unsupported? (known-procedure 2)] + [exn:fail:user (known-constant)] + [exn:fail:user? (known-procedure 2)] + [exn:fail? (known-procedure 2)] + [exn:srclocs-accessor (known-procedure 2)] + [exn:srclocs? (known-procedure 2)] + [exn? (known-procedure 2)] + [exn? (known-procedure 2)] + [exp (known-procedure 2)] + [expand-user-path (known-procedure 2)] + [explode-path (known-procedure 2)] + [expt (known-procedure 4)] + [file-exists? (known-procedure 2)] + [file-or-directory-identity (known-procedure 6)] + [file-or-directory-modify-seconds (known-procedure 14)] + [file-or-directory-permissions (known-procedure 6)] + [file-position (known-procedure 6)] + [file-position* (known-procedure 2)] + [file-size (known-procedure 2)] + [file-stream-buffer-mode (known-procedure 6)] + [file-stream-port? (known-procedure 2)] + [file-truncate (known-procedure 4)] + [filesystem-change-evt (known-procedure 6)] + [filesystem-change-evt-cancel (known-procedure 2)] + [filesystem-change-evt? (known-procedure 2)] + [filesystem-root-list (known-procedure 1)] + [find-system-path (known-procedure 2)] + [fixnum? (known-procedure/succeeds 2)] + [floating-point-bytes->real (known-procedure 30)] + [flonum? (known-procedure/succeeds 2)] + [floor (known-procedure 2)] + [flush-output (known-procedure 3)] + [for-each (known-procedure -4)] + [format (known-procedure -2)] + [fprintf (known-procedure -4)] + [gcd (known-procedure -1)] + [gensym (known-procedure 3)] + [get-output-bytes (known-procedure 30)] + [get-output-string (known-procedure 2)] + [global-port-print-handler (known-constant)] + [handle-evt (known-procedure 4)] + [handle-evt? (known-procedure 2)] + [hash (known-procedure -1)] + [hash-clear (known-procedure 2)] + [hash-clear! (known-procedure 2)] + [hash-copy (known-procedure 2)] + [hash-count (known-procedure 2)] + [hash-eq? (known-procedure 2)] + [hash-equal? (known-procedure 2)] + [hash-eqv? (known-procedure 2)] + [hash-for-each (known-procedure 12)] + [hash-iterate-first (known-procedure 2)] + [hash-iterate-key (known-procedure 4)] + [hash-iterate-key+value (known-procedure 4)] + [hash-iterate-next (known-procedure 4)] + [hash-iterate-pair (known-procedure 4)] + [hash-iterate-value (known-procedure 4)] + [hash-keys-subset? (known-procedure 4)] + [hash-map (known-procedure 12)] + [hash-placeholder? (known-procedure 2)] + [hash-ref (known-procedure 12)] + [hash-remove (known-procedure 4)] + [hash-remove! (known-procedure 4)] + [hash-set (known-procedure 8)] + [hash-set! (known-procedure 8)] + [hash-weak? (known-procedure 2)] + [hash? (known-procedure/succeeds 2)] + [hasheq (known-procedure -1)] + [hasheqv (known-procedure -1)] + [imag-part (known-procedure 2)] + [immutable? (known-procedure/succeeds 2)] + [impersonate-box (known-procedure -8)] + [impersonate-channel (known-procedure -8)] + [impersonate-continuation-mark-key (known-procedure -8)] + [impersonate-hash (known-procedure -32)] + [impersonate-procedure (known-procedure -4)] + [impersonate-procedure* (known-procedure -4)] + [impersonate-prompt-tag (known-procedure -8)] + [impersonate-struct (known-procedure -2)] + [impersonate-vector (known-procedure -8)] + [impersonate-vector* (known-procedure -8)] + [impersonator-ephemeron (known-procedure 2)] + [impersonator-of? (known-procedure 4)] + [impersonator-prop:application-mark (known-constant)] + [impersonator-property-accessor-procedure? (known-procedure 2)] + [impersonator-property? (known-procedure 2)] + [impersonator? (known-procedure/succeeds 2)] + [inexact->exact (known-procedure 2)] + [inexact-real? (known-procedure 2)] + [inexact? (known-procedure 2)] + [input-port? (known-procedure 2)] + [inspector-superior? (known-procedure 4)] + [inspector? (known-procedure 2)] + [integer->char (known-procedure 2)] + [integer->integer-bytes (known-procedure 120)] + [integer-bytes->integer (known-procedure 60)] + [integer-length (known-procedure 2)] + [integer-sqrt (known-procedure 2)] + [integer-sqrt/remainder (known-procedure 2)] + [integer? (known-procedure 2)] + [interned-char? (known-procedure 2)] + [keyword->string (known-procedure 2)] + [keywordbytes (known-procedure 2)] + [list->string (known-procedure 2)] + [list->vector (known-procedure 2)] + [list-pair? (known-procedure 2)] + [list-ref (known-procedure 4)] + [list-tail (known-procedure 4)] + [list? (known-procedure 2)] + [load-on-demand-enabled (known-constant)] + [locale-string-encoding (known-procedure 1)] + [log (known-procedure 6)] + [log-all-levels (known-procedure 2)] + [log-level-evt (known-procedure 2)] + [log-level? (known-procedure 12)] + [log-max-level (known-procedure 6)] + [log-message (known-procedure 112)] + [log-receiver? (known-procedure 2)] + [logger-name (known-procedure 2)] + [logger? (known-procedure 2)] + [magnitude (known-procedure 2)] + [make-bytes (known-procedure 6)] + [make-channel (known-procedure 1)] + [make-continuation-mark-key (known-procedure 3)] + [make-continuation-prompt-tag (known-procedure 3)] + [make-custodian (known-procedure 3)] + [make-custodian-box (known-procedure 4)] + [make-date (known-constant)] + [make-date* (known-constant)] + [make-derived-parameter (known-procedure 8)] + [make-directory (known-procedure 2)] + [make-environment-variables (known-procedure -1)] + [make-ephemeron (known-procedure 4)] + [make-file-or-directory-link (known-procedure 4)] + [make-hash (known-procedure 3)] + [make-hash-placeholder (known-procedure 2)] + [make-hasheq (known-procedure 3)] + [make-hasheq-placeholder (known-procedure 2)] + [make-hasheqv (known-procedure 3)] + [make-hasheqv-placeholder (known-procedure 2)] + [make-immutable-hash (known-procedure 3)] + [make-immutable-hasheq (known-procedure 3)] + [make-immutable-hasheqv (known-procedure 3)] + [make-impersonator-property (known-procedure 2)] + [make-input-port (known-procedure 2032)] + [make-inspector (known-procedure 3)] + [make-known-char-range-list (known-procedure 1)] + [make-log-receiver (known-procedure -4)] + [make-logger (known-procedure -1)] + [make-output-port (known-procedure 4080)] + [make-parameter (known-procedure 6)] + [make-phantom-bytes (known-procedure 2)] + [make-pipe (known-procedure 15)] + [make-placeholder (known-procedure 2)] + [make-plumber (known-procedure 1)] + [make-polar (known-procedure 4)] + [make-prefab-struct (known-procedure -2)] + [make-pseudo-random-generator (known-procedure 1)] + [make-reader-graph (known-procedure 2)] + [make-rectangular (known-procedure 4)] + [make-security-guard (known-procedure 24)] + [make-semaphore (known-procedure 3)] + [make-shared-bytes (known-procedure 6)] + [make-sibling-inspector (known-procedure 3)] + [make-string (known-procedure 6)] + [make-struct-field-accessor (known-procedure 12)] + [make-struct-field-mutator (known-procedure 12)] + [make-struct-type (known-procedure 4080)] + [make-struct-type-property (known-procedure 30)] + [make-thread-cell (known-procedure 6)] + [make-thread-group (known-procedure 3)] + [make-vector (known-procedure 6)] + [make-weak-box (known-procedure 2)] + [make-weak-hash (known-procedure 3)] + [make-weak-hasheq (known-procedure 3)] + [make-weak-hasheqv (known-procedure 3)] + [make-will-executor (known-procedure 1)] + [map (known-procedure -4)] + [max (known-procedure -2)] + [mcar (known-procedure 2)] + [mcdr (known-procedure 2)] + [mcons (known-procedure/succeeds 4)] + [min (known-procedure -2)] + [modulo (known-procedure 4)] + [mpair? (known-procedure/succeeds 2)] + [nack-guard-evt (known-procedure 2)] + [negative? (known-procedure 2)] + [never-evt (known-constant)] + [newline (known-procedure 3)] + [not (known-procedure 2)] + [null (known-literal '(quote ()))] + [null? (known-procedure/succeeds 2)] + [number->string (known-procedure 6)] + [number? (known-procedure/succeeds 2)] + [numerator (known-procedure 2)] + [object-name (known-procedure 2)] + [odd? (known-procedure 2)] + [open-input-bytes (known-procedure 6)] + [open-input-file (known-procedure 14)] + [open-input-output-file (known-procedure 14)] + [open-input-string (known-procedure 6)] + [open-output-bytes (known-procedure 3)] + [open-output-file (known-procedure 14)] + [open-output-string (known-procedure 3)] + [ormap (known-procedure -4)] + [output-port? (known-procedure 2)] + [pair? (known-procedure/succeeds 2)] + [parameter-procedure=? (known-procedure 4)] + [parameter? (known-procedure 2)] + [parameterization? (known-procedure 2)] + [path->bytes (known-procedure 2)] + [path->complete-path (known-procedure 6)] + [path->directory-path (known-procedure 2)] + [path->string (known-procedure 2)] + [path-convention-type (known-procedure 2)] + [path-element->bytes (known-procedure 2)] + [path-element->string (known-procedure 2)] + [path-for-some-system? (known-procedure 2)] + [pathstruct-type (known-procedure 4)] + [prefab-key? (known-procedure 2)] + [prefab-struct-key (known-procedure 2)] + [pregexp (known-procedure 6)] + [pregexp? (known-procedure 2)] + [primitive-closure? (known-procedure 2)] + [primitive-result-arity (known-procedure 2)] + [primitive? (known-procedure 2)] + [print (known-procedure 14)] + [print-as-expression (known-constant)] + [print-boolean-long-form (known-constant)] + [print-box (known-constant)] + [print-graph (known-constant)] + [print-hash-table (known-constant)] + [print-mpair-curly-braces (known-constant)] + [print-pair-curly-braces (known-constant)] + [print-reader-abbreviations (known-constant)] + [print-struct (known-constant)] + [print-syntax-width (known-constant)] + [print-unreadable (known-constant)] + [print-vector-length (known-constant)] + [printf (known-procedure -2)] + [procedure->method (known-procedure 2)] + [procedure-arity (known-procedure 2)] + [procedure-arity-includes? (known-procedure 12)] + [procedure-arity? (known-procedure 2)] + [procedure-closure-contents-eq? (known-procedure 4)] + [procedure-extract-target (known-procedure 2)] + [procedure-impersonator*? (known-procedure 2)] + [procedure-reduce-arity (known-procedure 4)] + [procedure-rename (known-procedure 4)] + [procedure-result-arity (known-procedure 2)] + [procedure-specialize (known-procedure 2)] + [procedure-struct-type? (known-procedure 2)] + [procedure? (known-procedure/succeeds 2)] + [progress-evt? (known-procedure 6)] + [prop:arity-string (known-constant)] + [prop:authentic (known-struct-type-property/immediate-guard)] + [prop:checked-procedure (known-constant)] + [prop:custom-print-quotable (known-constant)] + [prop:custom-write (known-struct-type-property/immediate-guard)] + [prop:equal+hash (known-struct-type-property/immediate-guard)] + [prop:evt (known-struct-type-property/immediate-guard)] + [prop:exn:srclocs (known-constant)] + [prop:impersonator-of (known-constant)] + [prop:incomplete-arity (known-constant)] + [prop:input-port (known-constant)] + [prop:method-arity-error (known-constant)] + [prop:object-name (known-constant)] + [prop:output-port (known-constant)] + [prop:procedure (known-struct-type-property/immediate-guard)] + [pseudo-random-generator->vector (known-procedure 2)] + [pseudo-random-generator-vector? (known-procedure 2)] + [pseudo-random-generator? (known-procedure 2)] + [quotient (known-procedure 4)] + [quotient/remainder (known-procedure 4)] + [raise (known-procedure 6)] + [raise-argument-error (known-procedure -8)] + [raise-arguments-error (known-procedure -4)] + [raise-arity-error (known-procedure -4)] + [raise-mismatch-error (known-procedure -8)] + [raise-range-error (known-procedure 384)] + [raise-result-error (known-procedure -8)] + [raise-result-arity-error (known-procedure -16)] + [raise-type-error (known-procedure -8)] + [raise-user-error (known-procedure -2)] + [random (known-procedure 7)] + [random-seed (known-procedure 2)] + [rational? (known-procedure 2)] + [read-accept-bar-quote (known-constant)] + [read-byte (known-procedure 3)] + [read-byte-or-special (known-procedure 15)] + [read-bytes (known-procedure 6)] + [read-bytes! (known-procedure 30)] + [read-bytes-avail! (known-procedure 30)] + [read-bytes-avail!* (known-procedure 30)] + [read-bytes-avail!/enable-break (known-procedure 30)] + [read-bytes-line (known-procedure 7)] + [read-case-sensitive (known-constant)] + [read-char (known-procedure 3)] + [read-char-or-special (known-procedure 15)] + [read-line (known-procedure 7)] + [read-on-demand-source (known-constant)] + [read-string (known-procedure 6)] + [read-string! (known-procedure 30)] + [real->double-flonum (known-procedure 2)] + [real->floating-point-bytes (known-procedure 60)] + [real->single-flonum (known-procedure 2)] + [real-part (known-procedure 2)] + [real? (known-procedure 2)] + [regexp (known-procedure 6)] + [regexp-match (known-procedure 124)] + [regexp-match-peek (known-procedure 124)] + [regexp-match-peek-immediate (known-procedure 124)] + [regexp-match-peek-positions (known-procedure 124)] + [regexp-match-peek-positions-immediate (known-procedure 124)] + [regexp-match-peek-positions-immediate/end (known-procedure 252)] + [regexp-match-peek-positions/end (known-procedure 252)] + [regexp-match-positions (known-procedure 124)] + [regexp-match-positions/end (known-procedure 252)] + [regexp-match/end (known-procedure 252)] + [regexp-match? (known-procedure 124)] + [regexp-max-lookbehind (known-procedure 2)] + [regexp-replace (known-procedure 24)] + [regexp-replace* (known-procedure 24)] + [regexp? (known-procedure 2)] + [relative-path? (known-procedure 2)] + [remainder (known-procedure 4)] + [rename-file-or-directory (known-procedure 12)] + [replace-evt (known-procedure 4)] + [resolve-path (known-procedure 2)] + [reverse (known-procedure 2)] + [round (known-procedure 2)] + [seconds->date (known-procedure 6)] + [security-guard? (known-procedure 2)] + [semaphore-peek-evt (known-procedure 2)] + [semaphore-peek-evt? (known-procedure 2)] + [semaphore-post (known-procedure 2)] + [semaphore-try-wait? (known-procedure 2)] + [semaphore-wait (known-procedure 2)] + [semaphore-wait/enable-break (known-procedure 2)] + [semaphore? (known-procedure 2)] + [set-box! (known-procedure 4)] + [set-box*! (known-procedure 4)] + [set-mcar! (known-procedure 4)] + [set-mcdr! (known-procedure 4)] + [set-phantom-bytes! (known-procedure 4)] + [set-port-next-location! (known-procedure 16)] + [shared-bytes (known-procedure -1)] + [shell-execute (known-procedure 32)] + [simplify-path (known-procedure 6)] + [sin (known-procedure 2)] + [single-flonum? (known-procedure 2)] + [sleep (known-procedure 3)] + [split-path (known-procedure 2)] + [sqrt (known-procedure 2)] + [srcloc (known-constant)] + [srcloc->string (known-procedure 2)] + [srcloc-column (known-procedure 2)] + [srcloc-line (known-procedure 2)] + [srcloc-position (known-procedure 2)] + [srcloc-source (known-procedure 2)] + [srcloc-span (known-procedure 2)] + [srcloc? (known-procedure 2)] + [string (known-procedure -1)] + [string->bytes/latin-1 (known-procedure 30)] + [string->bytes/locale (known-procedure 30)] + [string->bytes/utf-8 (known-procedure 30)] + [string->immutable-string (known-procedure 2)] + [string->keyword (known-procedure 2)] + [string->list (known-procedure 2)] + [string->number (known-procedure 30)] + [string->path (known-procedure 2)] + [string->path-element (known-procedure 2)] + [string->symbol (known-procedure 2)] + [string->uninterned-symbol (known-procedure 2)] + [string->unreadable-symbol (known-procedure 2)] + [string-append (known-procedure -1)] + [string-ci<=? (known-procedure -4)] + [string-ci=? (known-procedure -4)] + [string-ci>? (known-procedure -4)] + [string-copy (known-procedure 2)] + [string-copy! (known-procedure 56)] + [string-downcase (known-procedure 2)] + [string-fill! (known-procedure 4)] + [string-foldcase (known-procedure 2)] + [string-length (known-procedure 2)] + [string-locale-ci? (known-procedure -4)] + [string-locale-downcase (known-procedure 2)] + [string-locale-upcase (known-procedure 2)] + [string-locale? (known-procedure -4)] + [string-normalize-nfc (known-procedure 2)] + [string-normalize-nfd (known-procedure 2)] + [string-normalize-nfkc (known-procedure 2)] + [string-normalize-nfkd (known-procedure 2)] + [string-port? (known-procedure 2)] + [string-ref (known-procedure 4)] + [string-set! (known-procedure 8)] + [string-titlecase (known-procedure 2)] + [string-upcase (known-procedure 2)] + [string-utf-8-length (known-procedure 14)] + [string<=? (known-procedure -4)] + [string=? (known-procedure -4)] + [string>? (known-procedure -4)] + [string? (known-procedure/succeeds 2)] + [struct->vector (known-procedure 6)] + [struct-accessor-procedure? (known-procedure 2)] + [struct-constructor-procedure? (known-procedure 2)] + [struct-info (known-procedure 2)] + [struct-mutator-procedure? (known-procedure 2)] + [struct-predicate-procedure? (known-procedure 2)] + [struct-type-info (known-procedure 2)] + [struct-type-make-constructor (known-procedure 6)] + [struct-type-make-predicate (known-procedure 2)] + [struct-type-property-accessor-procedure? (known-procedure 2)] + [struct-type-property? (known-procedure 2)] + [struct-type? (known-procedure 2)] + [struct:arity-at-least (known-constant)] + [struct:date (known-constant)] + [struct:date* (known-constant)] + [struct:exn (known-constant)] + [struct:exn:break (known-constant)] + [struct:exn:break:hang-up (known-constant)] + [struct:exn:break:terminate (known-constant)] + [struct:exn:fail (known-constant)] + [struct:exn:fail:contract (known-constant)] + [struct:exn:fail:contract:arity (known-constant)] + [struct:exn:fail:contract:continuation (known-constant)] + [struct:exn:fail:contract:divide-by-zero (known-constant)] + [struct:exn:fail:contract:non-fixnum-result (known-constant)] + [struct:exn:fail:contract:variable (known-constant)] + [struct:exn:fail:filesystem (known-constant)] + [struct:exn:fail:filesystem:errno (known-constant)] + [struct:exn:fail:filesystem:exists (known-constant)] + [struct:exn:fail:filesystem:version (known-constant)] + [struct:exn:fail:network (known-constant)] + [struct:exn:fail:network:errno (known-constant)] + [struct:exn:fail:out-of-memory (known-constant)] + [struct:exn:fail:read (known-constant)] + [struct:exn:fail:read:eof (known-constant)] + [struct:exn:fail:read:non-char (known-constant)] + [struct:exn:fail:unsupported (known-constant)] + [struct:exn:fail:user (known-constant)] + [struct:srcloc (known-constant)] + [struct? (known-procedure 2)] + [sub1 (known-procedure 2)] + [subbytes (known-procedure 12)] + [subprocess (known-procedure -16)] + [subprocess-group-enabled (known-constant)] + [subprocess-kill (known-procedure 4)] + [subprocess-pid (known-procedure 2)] + [subprocess-status (known-procedure 2)] + [subprocess-wait (known-procedure 2)] + [subprocess? (known-procedure 2)] + [substring (known-procedure 12)] + [symbol->string (known-procedure 2)] + [symbol-interned? (known-procedure 2)] + [symbol-unreadable? (known-procedure 2)] + [symboldatum (known-procedure 2)] + [syntax-column (known-procedure 2)] + [syntax-e (known-procedure 2)] + [syntax-line (known-procedure 2)] + [syntax-position (known-procedure 2)] + [syntax-property (known-procedure 28)] + [syntax-property-symbol-keys (known-procedure 2)] + [syntax-source (known-procedure 2)] + [syntax-span (known-procedure 2)] + [syntax? (known-procedure 2)] + [system-big-endian? (known-procedure 1)] + [system-idle-evt (known-procedure 1)] + [system-language+country (known-procedure 1)] + [system-library-subpath (known-procedure 3)] + [system-path-convention-type (known-procedure 1)] + [system-type (known-procedure 3)] + [tan (known-procedure 2)] + [terminal-port? (known-procedure 2)] + [thread (known-procedure 2)] + [thread-cell-ref (known-procedure 2)] + [thread-cell-set! (known-procedure 4)] + [thread-cell-values? (known-procedure 2)] + [thread-cell? (known-procedure 2)] + [thread-dead-evt (known-procedure 2)] + [thread-dead? (known-procedure 2)] + [thread-group? (known-procedure 2)] + [thread-receive (known-procedure 1)] + [thread-receive (known-procedure 1)] + [thread-receive-evt (known-procedure 1)] + [thread-resume (known-procedure 6)] + [thread-resume-evt (known-procedure 2)] + [thread-rewind-receive (known-procedure 2)] + [thread-running? (known-procedure 2)] + [thread-send (known-procedure 12)] + [thread-suspend (known-procedure 2)] + [thread-suspend-evt (known-procedure 2)] + [thread-try-receive (known-procedure 1)] + [thread-wait (known-procedure 2)] + [thread/suspend-to-kill (known-procedure 2)] + [thread? (known-procedure 2)] + [time-apply (known-procedure 4)] + [true-object? (known-procedure/succeeds 2)] + [truncate (known-procedure 2)] + [unbox (known-procedure 2)] + [unbox* (known-procedure 2)] + [uncaught-exception-handler (known-constant)] + [unquoted-printing-string (known-procedure 2)] + [unquoted-printing-string-value (known-procedure 2)] + [unquoted-printing-string? (known-procedure 2)] + [values (known-procedure -1)] + [vector (known-procedure/succeeds -1)] + [vector->immutable-vector (known-procedure 2)] + [vector->list (known-procedure 2)] + [vector->pseudo-random-generator (known-procedure 2)] + [vector->pseudo-random-generator! (known-procedure 4)] + [vector->values (known-procedure 14)] + [vector-cas! (known-procedure 16)] + [vector-copy! (known-procedure 56)] + [vector-fill! (known-procedure 4)] + [vector-immutable (known-procedure -1)] + [vector-length (known-procedure 2)] + [vector-ref (known-procedure 4)] + [vector-set! (known-procedure 8)] + [vector-set-performance-stats! (known-procedure 6)] + [vector? (known-procedure/succeeds 2)] + [vector*-length (known-procedure 2)] + [vector*-ref (known-procedure 4)] + [vector*-set! (known-procedure 8)] + [version (known-procedure 1)] + [void (known-procedure/succeeds -1)] + [void? (known-procedure/succeeds 2)] + [weak-box-value (known-procedure 6)] + [weak-box? (known-procedure 2)] + [will-execute (known-procedure 2)] + [will-executor? (known-procedure 2)] + [will-register (known-procedure 8)] + [will-try-execute (known-procedure 2)] + [with-input-from-file (known-procedure 12)] + [with-output-to-file (known-procedure 28)] + [wrap-evt (known-procedure 4)] + [write (known-procedure 6)] + [write-byte (known-procedure 6)] + [write-bytes (known-procedure 30)] + [write-bytes-avail (known-procedure 30)] + [write-bytes-avail* (known-procedure 30)] + [write-bytes-avail-evt (known-procedure 30)] + [write-bytes-avail/enable-break (known-procedure 30)] + [write-char (known-procedure 6)] + [write-special (known-procedure 6)] + [write-special-avail* (known-procedure 6)] + [write-special-evt (known-procedure 4)] + [write-string (known-procedure 30)] + [zero? (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/linklet.ss racket-7.0+ppa1/src/cs/primitive/linklet.ss --- racket-6.12+ppa1/src/cs/primitive/linklet.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/linklet.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ + +(define-primitive-table linklet-table + [compile-linklet (known-procedure 62)] + [compiled-position->primitive (known-procedure 2)] + [eval-linklet (known-procedure 2)] + [hash->linklet-bundle (known-procedure 2)] + [hash->linklet-directory (known-procedure 2)] + [instance-data (known-procedure 2)] + [instance-name (known-procedure 2)] + [instance-set-variable-value! (known-procedure 24)] + [instance-unset-variable! (known-procedure 4)] + [instance-variable-names (known-procedure 2)] + [instance-variable-value (known-procedure 12)] + [instance? (known-procedure 2)] + [instantiate-linklet (known-procedure 28)] + [linklet-bundle->hash (known-procedure 2)] + [linklet-bundle? (known-procedure 2)] + [linklet-directory->hash (known-procedure 2)] + [linklet-directory? (known-procedure 2)] + [linklet-export-variables (known-procedure 2)] + [linklet-import-variables (known-procedure 2)] + [linklet? (known-procedure 2)] + [make-instance (known-procedure -2)] + [primitive->compiled-position (known-procedure 2)] + [primitive-table (known-procedure 6)] + [read-compiled-linklet (known-procedure 2)] + [recompile-linklet (known-procedure 30)] + [variable-reference->instance (known-procedure 6)] + [variable-reference-constant? (known-procedure 2)] + [variable-reference-from-unsafe? (known-procedure 2)] + [variable-reference? (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/network.ss racket-7.0+ppa1/src/cs/primitive/network.ss --- racket-6.12+ppa1/src/cs/primitive/network.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/network.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,43 @@ + +(define-primitive-table network-table + [tcp-abandon-port (known-procedure 2)] + [tcp-accept (known-procedure 2)] + [tcp-accept-evt (known-procedure 2)] + [tcp-accept-ready? (known-procedure 2)] + [tcp-accept/enable-break (known-procedure 2)] + [tcp-addresses (known-procedure 6)] + [tcp-close (known-procedure 2)] + [tcp-connect (known-procedure 28)] + [tcp-connect/enable-break (known-procedure 28)] + [tcp-listen (known-procedure 30)] + [tcp-listener? (known-procedure 2)] + [tcp-port? (known-procedure 2)] + [udp-bind! (known-procedure 24)] + [udp-bound? (known-procedure 2)] + [udp-close (known-procedure 2)] + [udp-connect! (known-procedure 8)] + [udp-connected? (known-procedure 2)] + [udp-multicast-interface (known-procedure 2)] + [udp-multicast-join-group! (known-procedure 8)] + [udp-multicast-leave-group! (known-procedure 8)] + [udp-multicast-loopback? (known-procedure 2)] + [udp-multicast-set-interface! (known-procedure 4)] + [udp-multicast-set-loopback! (known-procedure 4)] + [udp-multicast-set-ttl! (known-procedure 4)] + [udp-multicast-ttl (known-procedure 2)] + [udp-open-socket (known-procedure 7)] + [udp-receive! (known-procedure 28)] + [udp-receive!* (known-procedure 28)] + [udp-receive!-evt (known-procedure 28)] + [udp-receive!/enable-break (known-procedure 28)] + [udp-receive-ready-evt (known-procedure 2)] + [udp-send (known-procedure 28)] + [udp-send* (known-procedure 28)] + [udp-send-evt (known-procedure 28)] + [udp-send-ready-evt (known-procedure 2)] + [udp-send-to (known-procedure 112)] + [udp-send-to* (known-procedure 112)] + [udp-send-to-evt (known-procedure 112)] + [udp-send-to/enable-break (known-procedure 112)] + [udp-send/enable-break (known-procedure 28)] + [udp? (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/paramz.ss racket-7.0+ppa1/src/cs/primitive/paramz.ss --- racket-6.12+ppa1/src/cs/primitive/paramz.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/paramz.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ + +(define-primitive-table paramz-table + [break-enabled-key (known-constant)] + [cache-configuration (known-procedure 4)] + [check-for-break (known-procedure 1)] + [exception-handler-key (known-constant)] + [extend-parameterization (known-procedure -2)] + [parameterization-key (known-constant)] + [reparameterize (known-procedure 2)] + [security-guard-check-file (known-procedure 8)] + [security-guard-check-file-link (known-procedure 8)] + [security-guard-check-network (known-procedure 16)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/place.ss racket-7.0+ppa1/src/cs/primitive/place.ss --- racket-6.12+ppa1/src/cs/primitive/place.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/place.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ + +(define-primitive-table place-table + [dynamic-place (known-procedure 32)] + [place-break (known-procedure 6)] + [place-channel (known-procedure 1)] + [place-channel-get (known-procedure 2)] + [place-channel-put (known-procedure 4)] + [place-channel? (known-procedure 2)] + [place-dead-evt (known-procedure 2)] + [place-enabled? (known-procedure 1)] + [place-kill (known-procedure 2)] + [place-message-allowed? (known-procedure 2)] + [place-pumper-threads (known-procedure 6)] + [place-shared? (known-procedure 2)] + [place-sleep (known-procedure 2)] + [place-wait (known-procedure 2)] + [place? (known-procedure 2)]) diff -Nru racket-6.12+ppa1/src/cs/primitive/unsafe.ss racket-7.0+ppa1/src/cs/primitive/unsafe.ss --- racket-6.12+ppa1/src/cs/primitive/unsafe.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/primitive/unsafe.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,163 @@ + +(define-primitive-table unsafe-table + [chaperone-struct-unsafe-undefined (known-procedure 2)] + [check-not-unsafe-undefined (known-procedure 4)] + [check-not-unsafe-undefined/assign (known-procedure 4)] + [prop:chaperone-unsafe-undefined (known-constant)] + [unsafe-abort-current-continuation/no-wind (known-procedure 4)] + [unsafe-box*-cas! (known-procedure 8)] + [unsafe-bytes-length (known-procedure/succeeds 2)] + [unsafe-bytes-ref (known-procedure 4)] + [unsafe-bytes-set! (known-procedure 8)] + [unsafe-call-in-os-thread (known-procedure 2)] + [unsafe-call-with-composable-continuation/no-wind (known-procedure 4)] + [unsafe-car (known-procedure/succeeds 2)] + [unsafe-cdr (known-procedure/succeeds 2)] + [unsafe-chaperone-procedure (known-procedure -4)] + [unsafe-chaperone-vector (known-procedure -4)] + [unsafe-cons-list (known-procedure/succeeds 4)] + [unsafe-custodian-register (known-procedure 32)] + [unsafe-custodian-unregister (known-procedure 4)] + [unsafe-end-atomic (known-procedure 1)] + [unsafe-end-breakable-atomic (known-procedure 1)] + [unsafe-extfl* (known-procedure/succeeds 4)] + [unsafe-extfl+ (known-procedure/succeeds 4)] + [unsafe-extfl- (known-procedure/succeeds 4)] + [unsafe-extfl->fx (known-procedure/succeeds 2)] + [unsafe-extfl/ (known-procedure/succeeds 4)] + [unsafe-extfl< (known-procedure/succeeds 4)] + [unsafe-extfl<= (known-procedure/succeeds 4)] + [unsafe-extfl= (known-procedure/succeeds 4)] + [unsafe-extfl> (known-procedure/succeeds 4)] + [unsafe-extfl>= (known-procedure/succeeds 4)] + [unsafe-extflabs (known-procedure/succeeds 2)] + [unsafe-extflmax (known-procedure/succeeds 4)] + [unsafe-extflmin (known-procedure/succeeds 4)] + [unsafe-extflsqrt (known-procedure/succeeds 2)] + [unsafe-extflvector-length (known-procedure/succeeds 2)] + [unsafe-extflvector-ref (known-procedure 4)] + [unsafe-extflvector-set! (known-procedure 8)] + [unsafe-f64vector-ref (known-procedure 4)] + [unsafe-f64vector-set! (known-procedure 8)] + [unsafe-f80vector-ref (known-procedure 4)] + [unsafe-f80vector-set! (known-procedure 8)] + [unsafe-file-descriptor->port (known-procedure 8)] + [unsafe-file-descriptor->semaphore (known-procedure 4)] + [unsafe-fl* (known-procedure/succeeds 4)] + [unsafe-fl+ (known-procedure/succeeds 4)] + [unsafe-fl- (known-procedure/succeeds 4)] + [unsafe-fl->fx (known-procedure/succeeds 2)] + [unsafe-fl/ (known-procedure/succeeds 4)] + [unsafe-fl< (known-procedure/succeeds 4)] + [unsafe-fl<= (known-procedure/succeeds 4)] + [unsafe-fl= (known-procedure/succeeds 4)] + [unsafe-fl> (known-procedure/succeeds 4)] + [unsafe-fl>= (known-procedure/succeeds 4)] + [unsafe-flabs (known-procedure/succeeds 2)] + [unsafe-flimag-part (known-procedure/succeeds 2)] + [unsafe-flmax (known-procedure/succeeds 4)] + [unsafe-flmin (known-procedure/succeeds 4)] + [unsafe-flrandom (known-procedure/succeeds 2)] + [unsafe-flreal-part (known-procedure/succeeds 2)] + [unsafe-flsqrt (known-procedure/succeeds 2)] + [unsafe-flvector-length (known-procedure/succeeds 2)] + [unsafe-flvector-ref (known-procedure 4)] + [unsafe-flvector-set! (known-procedure 8)] + [unsafe-fx* (known-procedure/succeeds 4)] + [unsafe-fx+ (known-procedure/succeeds 4)] + [unsafe-fx- (known-procedure/succeeds 4)] + [unsafe-fx->extfl (known-procedure/succeeds 2)] + [unsafe-fx->fl (known-procedure/succeeds 2)] + [unsafe-fx< (known-procedure/succeeds 4)] + [unsafe-fx<= (known-procedure/succeeds 4)] + [unsafe-fx= (known-procedure/succeeds 4)] + [unsafe-fx> (known-procedure/succeeds 4)] + [unsafe-fx>= (known-procedure/succeeds 4)] + [unsafe-fxabs (known-procedure/succeeds 2)] + [unsafe-fxand (known-procedure/succeeds 4)] + [unsafe-fxior (known-procedure/succeeds 4)] + [unsafe-fxlshift (known-procedure/succeeds 4)] + [unsafe-fxmax (known-procedure/succeeds 4)] + [unsafe-fxmin (known-procedure/succeeds 4)] + [unsafe-fxmodulo (known-procedure/succeeds 4)] + [unsafe-fxnot (known-procedure/succeeds 2)] + [unsafe-fxquotient (known-procedure/succeeds 4)] + [unsafe-fxremainder (known-procedure/succeeds 4)] + [unsafe-fxrshift (known-procedure/succeeds 4)] + [unsafe-fxvector-length (known-procedure/succeeds 2)] + [unsafe-fxvector-ref (known-procedure 4)] + [unsafe-fxvector-set! (known-procedure 8)] + [unsafe-fxxor (known-procedure/succeeds 4)] + [unsafe-get-place-table (known-procedure 1)] + [unsafe-immutable-hash-iterate-first (known-procedure/succeeds 2)] + [unsafe-immutable-hash-iterate-key (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-key+value (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-next (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-pair (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-value (known-procedure/succeeds 4)] + [unsafe-impersonate-procedure (known-procedure -4)] + [unsafe-impersonate-vector (known-procedure -4)] + [unsafe-in-atomic? (known-procedure 1)] + [unsafe-list-ref (known-procedure/succeeds 4)] + [unsafe-list-tail (known-procedure/succeeds 4)] + [unsafe-make-custodian-at-root (known-procedure 1)] + [unsafe-make-flrectangular (known-procedure/succeeds 4)] + [unsafe-make-os-semaphore (known-procedure 1)] + [unsafe-make-security-guard-at-root (known-procedure 15)] + [unsafe-mcar (known-procedure 2)] + [unsafe-mcdr (known-procedure 2)] + [unsafe-mutable-hash-iterate-first (known-procedure 2)] + [unsafe-mutable-hash-iterate-key (known-procedure 4)] + [unsafe-mutable-hash-iterate-key+value (known-procedure 4)] + [unsafe-mutable-hash-iterate-next (known-procedure 4)] + [unsafe-mutable-hash-iterate-pair (known-procedure 4)] + [unsafe-mutable-hash-iterate-value (known-procedure 4)] + [unsafe-os-semaphore-post (known-procedure 2)] + [unsafe-os-semaphore-wait (known-procedure 2)] + [unsafe-os-thread-enabled? (known-procedure 1)] + [unsafe-poll-ctx-eventmask-wakeup (known-procedure 4)] + [unsafe-poll-ctx-fd-wakeup (known-procedure 8)] + [unsafe-poll-ctx-milliseconds-wakeup (known-procedure 4)] + [unsafe-poller (known-constant)] + [unsafe-port->file-descriptor (known-procedure 2)] + [unsafe-port->socket (known-procedure 2)] + [unsafe-register-process-global (known-procedure 4)] + [unsafe-s16vector-ref (known-procedure 4)] + [unsafe-s16vector-set! (known-procedure 8)] + [unsafe-set-box! (known-procedure 4)] + [unsafe-set-box*! (known-procedure 4)] + [unsafe-set-mcar! (known-procedure 4)] + [unsafe-set-mcdr! (known-procedure 4)] + [unsafe-set-on-atomic-timeout! (known-procedure 2)] + [unsafe-set-sleep-in-thread! (known-procedure 4)] + [unsafe-signal-received (known-procedure 1)] + [unsafe-socket->port (known-procedure 8)] + [unsafe-socket->semaphore (known-procedure 4)] + [unsafe-start-atomic (known-procedure 1)] + [unsafe-start-breakable-atomic (known-procedure 1)] + [unsafe-string-length (known-procedure/succeeds 2)] + [unsafe-string-ref (known-procedure/succeeds 4)] + [unsafe-string-set! (known-procedure/succeeds 8)] + [unsafe-struct*-ref (known-procedure/succeeds 4)] + [unsafe-struct*-set! (known-procedure/succeeds 8)] + [unsafe-struct-ref (known-procedure/succeeds 4)] + [unsafe-struct-set! (known-procedure/succeeds 8)] + [unsafe-thread-at-root (known-procedure 2)] + [unsafe-u16vector-ref (known-procedure 4)] + [unsafe-u16vector-set! (known-procedure 8)] + [unsafe-unbox (known-procedure 2)] + [unsafe-unbox* (known-procedure 2)] + [unsafe-undefined (known-constant)] + [unsafe-vector*-cas! (known-procedure 16)] + [unsafe-vector*-length (known-procedure/succeeds 2)] + [unsafe-vector*-ref (known-procedure 4)] + [unsafe-vector*-set! (known-procedure 8)] + [unsafe-vector-length (known-procedure/succeeds 2)] + [unsafe-vector-ref (known-procedure 4)] + [unsafe-vector-set! (known-procedure 8)] + [unsafe-weak-hash-iterate-first (known-procedure 2)] + [unsafe-weak-hash-iterate-key (known-procedure 4)] + [unsafe-weak-hash-iterate-key+value (known-procedure 4)] + [unsafe-weak-hash-iterate-next (known-procedure 4)] + [unsafe-weak-hash-iterate-pair (known-procedure 4)] + [unsafe-weak-hash-iterate-value (known-procedure 4)]) diff -Nru racket-6.12+ppa1/src/cs/README.txt racket-7.0+ppa1/src/cs/README.txt --- racket-6.12+ppa1/src/cs/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,391 @@ +If you just want to build the variant of Racket that runs on Chez +Scheme, then you probably meant to read "./c/README.txt" instead of +this file. + +If you're working on the implementation of Racket-on-Chez, then it's +more convenient to work in this directory, so keep reading here. + + +Requirements +------------ + + * Chez Scheme --- for now, use a fork at + + https://github.com/mflatt/ChezScheme + + but we will eventually return to the current development version + from + + https://github.com/cisco/ChezScheme + + If this build of Chez Scheme is not installed so that plain + `scheme` on the command line runs your installation, you can use + `make SCHEME=...` to set the command for `scheme`. + + * Racket --- a recent version + + By default, `make` will use the enclosing Racket build. Go back to + the root of this repository/distribution and build so that at least + the "compiler-lib" package is installed, either with just `make` + (for a full build) or with + + make PKGS="compiler-lib" + + Note that if you build as described in "./c/README.txt", then you + don't need the "compiler-lib" package. + + If you'd like to use an existing installation of Racket, instead, + you can use `make RACKET=...` to set the command for `racket`. + + +Building +-------- + +Running `make` will build the Racket-on-Chez implementation, although +not in stand-alone form. Use `make expander-demo` to run a demo that +loads `racket/base` from source. + +Use `make setup` (or `make setup-v` for a verbose version) to build +".zo" files for collection-based libraries. + +If you want to control the `raco setup` that `make setup` runs, supply +an `ARGS` variable to make, such as + + make setup ARGS="-l typed/racket" # only sets up TR + make setup ARGS="--clean -Dd" # clears ".zo" files + make setup ARGS="--fail-fast" # stop at the first error + + +Machine Code versus JIT +----------------------- + +Racket on Chez Scheme currently supports two modes: + + * Machine-code mode --- The compiled form of a module is machine code + generated by compiling either whole linklets (for small enough + linklets) or functions within linklets (with a "bytecode" + interpreter around the compiled parts). Compiled ".zo" files in + this format are written to a subdirectory of "compiled" using the + Chez Scheme platform name (e.g., "a6osx"). + + Select this mode by seting the `PLT_CS_MACH` environment variable, + but it's currently the default. + + * JIT mode --- The compiled form of a module is an S-expression where + individual `lambda`s are compiled on demand. Compiled ".zo" files + in this format are written to a "cs" subdirectory of "compiled". + + Select this mode by seting the `PLT_CS_JIT` environment variable. + +Set the `PLT_ZO_PATH` environment variable to override the path used +for ".zo" files. For example, you may want to preserve a normal build +while also building in machine-code mode with `PLT_CS_DEBUG` set, in +which case setting `PLT_ZO_PATH` to something like "a6osx-debug" could +be a good idea. + +In machine-code code, set `PLT_CS_COMPILE_LIMIT` to set the maximum +size of forms to compile. The default is 10000. + + +Running +------- + +Use `make run ARGS="..."` to run Racket on Chez Scheme analogous to +running plain `racket`, where command-line arguments are supplied in +`ARGS`. + + +Structure +--------- + +The reimplementation on Chez Scheme is meant to export the same +interface as the traditional Racket virtual machine in "../racket": +the macro expander and primitive modules such as `#%kernel` and +`#%network`. + +The implementation is in layers. The immediate layer over Chez Scheme +is called "Rumble", and it implements delimited continuations, +structures, chaperones and imperaontors, engines (for threads), and +similar base functionality. The Rumble layer is implemeneted in Chez +Scheme. + +The rest of the layers are implemented in Racket: + + thread + io + regexp + expander + schemify + +Each of those layers is implemented in a sibling directory of this +one. Each layer is expanded (using "expander", of course) and then +compiled to Chez Scheme (using "schemify") to implement Racket. + +The fully expanded form of each layer must not refer to any +functionality of previous layers. For example, the expander "thread" +must not refer to functionality implemented by "io", "regexp", or +"expander", while the expanded form of "io" must not refer to "regexp" +or "expander" functionality. Each layer can use `racket/base` +functionality, but beware that code from `racket/base` will be +duplicated in each layer. + +The "io" layer relies on a shared library, rktio, to provide a uniform +interface to OS resources. The rktio source is in a "rktio" sibling +directory to this one. + +Files in this directory: + + *.sls - Chez Scheme libraries that provide implementations of Racket + primitives, building up to the Racket expander. The + "rumble.sls" library is implemented directly in Chez Scheme. + For most other cases, a corresponding "compiled/*.scm" file + contains the implementation extracted from from expanded and + flattened Racket code. Each "*.sls" file is built to "*.so". + + rumble/*.ss - Parts of "rumble.sls" (via `include`) to implement data + structures, immutable hash tables, structs, delimited + continuations, engines, impersonators, etc. + + compiled/*.rktl (generated) - A Racket library (e.g., to implement + regexps) that has been fully macro expanded and flattened + into a linklet from its source in "../*". A linklet's only + free variables are primitives that will be implemented by + various ".sls" libraries in lower layers. + + For example, "../thread" contains the implementation (in + Racket) of the thread and event subsystem. + + compiled/*.scm (generated) - A conversion from a ".rktl" file to be + `included`d into an ".sls" library. + + ../build/so-rktio/rktio.rktl (generated) and + ../../lib/librktio.{so,dylib,dll} (generated) - Created when building + the "io" layer, the "rktio.rktl" file contains FFI descriptions + that are `included` by "io.sls" and "librktio.{so,dylib,dll}" + is the shared library that implements rktio. + + CAUTION: The makefile here doesn't track dependencies for + rktio, so use `make rktio` if you change its implementation. + + primitive/*.ss - for "expander.sls", tables of bindings for + primitive linklet instances; see "From primitives to modules" + below for more information. + + convert.rkt - A "schemify"-based linklet-to-library-body compiler, + which is used to convert a ".rktl" file to a ".scm" file to + inclusion in an ".sls" library. + + demo/*.ss - Chez Scheme scripts to check that a library basically + works. For example "demo/regexp.ss" runs the regexp matcher + on a few examples. To run "demo/*.ss", use `make *-demo`. + + other *.rkt - Racket scripts like "convert.rkt" or comparisions like + "demo/regexp.rkt". For example, you can run "demo/regexp.rkt" + and compare the reported timing to "demo/regexp.ss". + + +From Primitives to Modules +-------------------------- + +The "expander" layer, as turned into a Chez Scheme library by +"expander.sls", synthesizes primitive Racket modules such as +`'#%kernel` and `'#%network`. The content of those primitive _modules_ +at the expander layer is based on primitve _instances_ (which are just +hash tables) as populated by tables in the "primitive" directory. For +example, "primitive/network.scm" defines the content of the +`'#network` primitive instance, which is turned into the primitive +`'#%network` module by the expander layer, which is reexported by the +`racket/network` module that is implemented as plain Racket code. The +Racket implementation in "../racket" provides those same primitive +instances to the macro expander. + + +Running "demo/expander.ss" +-------------------------- + +A `make expander-demo` builds and tries the expander on simple +examples, including loading `racket/base` from source. + + +Dumping Linklets and Schemified Linklets +---------------------------------------- + +Set the `PLT_LINKLET_SHOW` environment variable to pretty print each +linklet generated by the expander and its schemified form that is +passed on to Chez Scheme. + +By default, `PLT_LINKLET_SHOW` does not distinguish gensyms that have +the same base name, so the schemified form is not really accurate. Set +`PLT_LINKLET_SHOW_GENSYM` instead (or in addition) to get more +accurate output. + +In JIT mode, the schemified form is shown after a conversion to +support JIT mode. Set `PLT_LINKLET_SHOW_PRE_JIT` to see the +pre-conversion form. Set `PLT_LINKLET_SHOW_JIT_DEMAND` to see forms as +they are compiled on demand. + +In machine-code mode, set `PLT_LINKLET_SHOW_LAMBDA` to see individual +compiled terms when a linklet is not compliled whole; set +`PLT_LINKLET_SHOW_POST_LAMBDA` to see the linlet reorganized around +those compiled parts; and/or set `PLT_LINKLET_SHOW_POST_INTERP` to see +the "bytecode" form. + + +Development Mode +---------------- + +If you make changes to files in "rumble", you should turn off +`[RUMBLE_]UNSAFE_COMP` in the makefile. + +You may want to turn on `DEBUG_COMP` in the makefile, so that +backtraces provide expression-specific source locations instead of +just procedure-specific source locations. Enabling `DEBUG_COMP` makes +the Racket-on-Chez implementation take up twice as much memory and +take twice as long to load. + +Turning on `DEBUG_COMP` affects only the Racket-on-Chez +implementation. To preserve per-expression locations on compiled +Racket code, set `PLT_CS_DEBUG`. See also "JIT versus Machine Code" +for a suggestion on setting `PLT_ZO_PATH`. + +When you change "rumble" or other layers, you can continue to use +Racket modules that were previously compiled to ".zo" form... usually, +but inlining optimizations and similar compiler choices can break +compatibility. Set `compile-as-independent?` to #t in "expander.sls" +to make compiled Racket modules reliably compatible with changes to +the layers here (at the expense of some performance). + + +FFI Differences +--------------- + + * The `make-sized-byte-string` function always raises an exception, + because a foreign address cannot be turned into a byte string whose + content is stored in the foreign address. The options are to copy + the foreign content to/from a byte string or use `ptr-ref` and + `ptr-set!` to read and write at the address. + + * When `_bytes` is used as an argument type, beware that a byte + string is not implicitly terminated with a NUL byte. When `_bytes` + is used as a result type, the C result is copied into a fresh byte + string. + + * The 'atomic-interior allocation mode returns memory that is allowed + to move after the cpointer returned by allocation becomes + unreachable. + + * A `_gcpointer` can only refer to the start of an allocated object, + and never the interior of an 'atomic-interior allocation. Like + traditional Racket, `_gcpointer` is equivalent to `_pointer` for + sending values to a foreign procedure, return values from a + callback that is called from foreign code, or for `ptr-set!`. For + the other direction (receiving a foreign result, `ptr-ref`, and + receiving values in a callback), the received pointer must + correspond to the content of a byte string or vector. + + * Calling a foreign function implicitly uses atomic mode and also + disables GC. If the foreign function calls back to Racket, the + callback runs in atomic mode with the GC still disabled. + + * An immobile cell must be modified only through its original pointer + or a reconstructed `_gcpointer`. If it is cast or reconstructed as + a `_pointer`, setting the cell will not cooperate correctly with + the garbage collector. + + * Memory allocated with 'nonatomic works only in limited ways. It + cannot be usefully passed to foreign functions, since the layout is + not actually an array of pointers. + + +Status and Thoughts on Various Racket Subsystems +------------------------------------------------ + + * Applicable structs work by adding an indirection to each function + call when the target is not obviously a plain procedure; with the + analysis in "../schemify/schemify.rkt", the indirection is not + needed often in a typical program, and the overhead appears to be + light when it is needed. + + * Racket's delimited continuations, continuation marks, threads, and + events are mostly in place (see "rumble/control.ss", + "rumble/engine.ss", and the source for "thread.rktl"). + + * The "rktio" library fills the gap between Racket and Chez Scheme's + native I/O. The "rktio" library provides a minimal, non-blocking, + non-GCed interface to OS-specific functionality. Its' compiled to a + shared library and loadied into Chez Scheme, and then Racket's I/O + API is implemented in Racket by calling rktio as a kind of foreign + library. + + * The Racket and Chez Scheme numeric systems likely differ in some + ways, and I don't know how much work that will be. + + * For futures, Chez Scheme exposes OS-level threads with limited + safety guarantees. An implementation of futures can probably take + advantage of threads with thread-unsafe primitives wrapped to + divert to a barrier when called in a future. + + * GC-based memory accounting similarly seems to require new support, + but that can wait a while. + + * Extflonums will probably exist only on the Racket VM for a long + while. + + * For now, `make setup` builds platform-specific ".zo" files in a + subdirectory of "compiled" named by the Chez Scheme platform name + (e.g., "a6osx"). Longer term, although bytecode as it currently + exists goes away, platform-independent ".zo" files might contain + fully expanded source (possibly also run through Chez Scheme's + source-to-source optimizer) with `raco setup` gaining a new step in + creating platform-specific compiled code. + + +Performance Notes +----------------- + +The best-case scenario for performance is current the default +configuration: + + * `UNSAFE_COMP` is enabled in "Makefile" --- currently on by default. + + Effectiveness: Matters the most for "rumble.so", which has its own + setting, but otherwise by itself affects a from-source + `racket/base` expansion by about 5%. See also the interaction with + `compile-as-independent?`. + + * `RUMBLE_UNSAFE_COMP` is enabled in "Makefile" --- applies to + "rumble.so" even if `UNSAFE_COMP` is disabled. + + Effectiveness: Can mean a 10-20% improvement in loading + `racket/base` from source. Since the Rumble implementation is in + pretty good shape, `RUMBLE_UNSAFE_COMP` is enabled by default. + + * `compile-as-independent?` is #f in "expander.sls" --- currently set + to #f by default. See "Development Mode" above for more + information. + + Effectiveness: Without also enabling `UNSAFE_COMP`, setting + `compile-as-independent?` to #f slows down tasks like loading + `racket/base` from source, but substantially improves programs + where the Chez Scheme optimizer needs to recognize uses of + primitives (e.g., microbenchmarks). Combining with `UNSAFE_COMP` + speeds up loading `racket/base` from source, too. + + The combination of `UNSAFE_COMP` and `compile-as-independent?` + enables inlining of unsafe function bodies. For example, + `variable-ref/no-check` inlines as lots of code in safe mode and + little code in unsafe mode; lots of code doesn't run more slowly, + but it compiles more slowly. + + * `DEBUG_COMP` not enabled --- or, if you enable it, run `make + strip`. + + Effectivess: Avoids increasing the load time for the Rumble and + other layers by 30-50%. + + * `PLT_CS_DEBUG` not set --- an environment variable similar to + `DEBUG_COMP`, but applies to code compiled by Racket-on-Chez. + + Effectivess: Avoids improvement to stack traces, but also avoids + increases load time and memory use of Racket programs by as much as + 50%. diff -Nru racket-6.12+ppa1/src/cs/regexp.sls racket-7.0+ppa1/src/cs/regexp.sls --- racket-6.12+ppa1/src/cs/regexp.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/regexp.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ +(library (regexp) + (export) + (import (chezpart) + (rumble) + (io)) + (include "include.ss") + (include-generated "regexp.scm") + (set-intern-regexp?! 1/regexp?)) diff -Nru racket-6.12+ppa1/src/cs/rumble/arity.ss racket-7.0+ppa1/src/cs/rumble/arity.ss --- racket-6.12+ppa1/src/cs/rumble/arity.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/arity.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,41 @@ + +(define (mask->arity mask) + (let loop ([mask mask] [pos 0]) + (cond + [(= mask 0) null] + [(= mask -1) (|#%app| arity-at-least pos)] + [(bitwise-bit-set? mask 0) + (let ([rest (loop (bitwise-arithmetic-shift-right mask 1) (add1 pos))]) + (cond + [(null? rest) pos] + [(pair? rest) (cons pos rest)] + [else (list pos rest)]))] + [else + (loop (bitwise-arithmetic-shift-right mask 1) (add1 pos))]))) + +(define (arity->mask a) + (cond + [(exact-nonnegative-integer? a) + (bitwise-arithmetic-shift-left 1 a)] + [(arity-at-least? a) + (bitwise-xor -1 (sub1 (bitwise-arithmetic-shift-left 1 (arity-at-least-value a))))] + [(list? a) + (let loop ([mask 0] [l a]) + (cond + [(null? l) mask] + [else + (let ([a (car l)]) + (cond + [(or (exact-nonnegative-integer? a) + (arity-at-least? a)) + (loop (bitwise-ior mask (arity->mask a)) (cdr l))] + [else #f]))]))] + [else #f])) + +(define (procedure-arity? a) + (and (arity->mask a) #t)) + +(define-struct arity-at-least (value) + :guard (lambda (value who) + (check who exact-nonnegative-integer? value) + value)) diff -Nru racket-6.12+ppa1/src/cs/rumble/begin0.ss racket-7.0+ppa1/src/cs/rumble/begin0.ss --- racket-6.12+ppa1/src/cs/rumble/begin0.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/begin0.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ + +;; See copy in "expander.sls" +(define-syntax begin0 + (syntax-rules () + [(_ expr0 expr ...) + (call-with-values (lambda () + (call-with-values (lambda () expr0) + (case-lambda + [(x) (values x #f)] + [args (values args #t)]))) + (lambda (l apply?) + expr ... + (if apply? + (#%apply values l) + l)))])) + diff -Nru racket-6.12+ppa1/src/cs/rumble/boolean.ss racket-7.0+ppa1/src/cs/rumble/boolean.ss --- racket-6.12+ppa1/src/cs/rumble/boolean.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/boolean.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1 @@ +(define (true-object? v) (eq? v #t)) diff -Nru racket-6.12+ppa1/src/cs/rumble/box.ss racket-7.0+ppa1/src/cs/rumble/box.ss --- racket-6.12+ppa1/src/cs/rumble/box.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/box.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,146 @@ + +(define (unsafe-box*-cas+! b delta) + (let ([v (unsafe-unbox* b)]) + (unless (unsafe-box*-cas! b v (+ v delta)) + (unsafe-box*-cas+! b delta)))) + +;; ---------------------------------------- + +(define-record box-chaperone chaperone (ref set)) +(define-record box-impersonator impersonator (ref set)) + +(define (box? v) + (or (#%box? v) + (and (impersonator? v) + (#%box? (impersonator-val v))))) + +(define (unbox b) + (if (#%box? b) + (#3%unbox b) + (pariah (impersonate-unbox b)))) + +(define (unsafe-unbox b) + ;; must handle impersonators + (unbox b)) + +(define (unbox* b) + (#2%unbox b)) + +(define (set-box! b v) + (if (#%box? b) + (#3%set-box! b v) + (pariah (impersonate-set-box! b v)))) + +(define (unsafe-set-box! b v) + ;; must handle impersonators + (set-box! b v)) + +(define (set-box*! b v) + (#2%set-box! b v)) + +;; in schemified: +(define (unbox/check-undefined b name) + (check-not-unsafe-undefined (#3%unbox b) name)) + +;; in schemified: +(define (set-box!/check-undefined b v name) + (check-not-unsafe-undefined/assign (unbox b) name) + (#3%set-box! b v)) + +(define/who (chaperone-box b ref set . props) + (check who box? b) + (do-impersonate-box 'chaperone-box make-box-chaperone b ref set + make-props-chaperone props)) + +(define/who (impersonate-box b ref set . props) + (check who mutable-box? :contract "(and/c box? (not/c immutable?))" b) + (do-impersonate-box 'impersonate-box make-box-impersonator b ref set + make-props-chaperone props)) + +(define (do-impersonate-box who make-box-impersonator b ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 2) ref) + (check who (procedure-arity-includes/c 2) set) + (let ([val (if (impersonator? b) + (impersonator-val b) + b)] + [props (add-impersonator-properties who + props + (if (impersonator? b) + (impersonator-props b) + empty-hasheq))]) + (make-box-impersonator val b props ref set))) + +(define (impersonate-unbox orig) + (if (and (impersonator? orig) + (#%box? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%box? o) (#%unbox o)] + [(box-chaperone? o) + (let* ([val (loop (impersonator-next o))] + [new-val ((box-chaperone-ref o) o val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'unbox + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(box-impersonator? o) + (let ([val (loop (impersonator-next o))]) + ((box-impersonator-ref o) o val))] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%unbox orig))) + +(define (impersonate-set-box! orig val) + (cond + [(not (and (impersonator? orig) + (mutable-box? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%set-box! orig val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%box? o) (#2%set-box! o val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(box-chaperone? o) + (let ([new-val ((box-chaperone-set o) next val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'set-box! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(box-impersonator? o) + (loop next ((box-impersonator-set o) next val))] + [else (loop next val)]))]))])) + +(define (set-box-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor box-chaperone) + (lambda (c hash-code) + (hash-code (box (unbox c))))) + (record-type-hash-procedure (record-type-descriptor box-impersonator) + (lambda (i hash-code) + (hash-code (box (unbox i)))))) + +;; ---------------------------------------- + +;; A wrapper to hide the pairness of weak pairs: +(define-record-type (weak-box create-weak-box weak-box?) + (fields p)) + +(define (make-weak-box v) + (create-weak-box (weak-cons v #t))) + +(define/who weak-box-value + (case-lambda + [(v no-value) + (check who weak-box? v) + (let ([c (car (weak-box-p v))]) + (if (eq? c #!bwp) + no-value + c))] + [(v) (weak-box-value v #f)])) diff -Nru racket-6.12+ppa1/src/cs/rumble/bytes.ss racket-7.0+ppa1/src/cs/rumble/bytes.ss --- racket-6.12+ppa1/src/cs/rumble/bytes.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/bytes.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,177 @@ +(define/who (bytes . args) + ;; `bytevector` allows negative numbers that fit in a byte, + ;; but `bytes` does not + (for-each (lambda (arg) + (check who byte? arg)) + args) + (apply #2%bytevector args)) + +(define/who (shared-bytes . args) + (for-each (lambda (arg) + (check who byte? arg)) + args) + (apply #2%bytevector args)) + +(define bytes? #2%bytevector?) + +(define bytes-length #2%bytevector-length) + +(define/who make-bytes + (case-lambda + [(n) (#2%make-bytevector n 0)] + [(n b) + (check who exact-nonnegative-integer? n) + (check who byte? b) + (#2%make-bytevector n b)])) + +(define/who make-shared-bytes + (case-lambda + [(n) (#2%make-bytevector n 0)] + [(n b) + (check who exact-nonnegative-integer? n) + (check who byte? b) + (#2%make-bytevector n b)])) + +(define/who (list->bytes lst) + (check who + :test (and (list? lst) (for-each byte? lst)) + :contract "(listof byte?)" + lst) + (u8-list->bytevector lst)) + +(define bytes->list #2%bytevector->u8-list) + +(define bytes-ref #2%bytevector-u8-ref) +(define bytes-set! #2%bytevector-u8-set!) +(define bytes->immutable-bytes #2%bytevector->immutable-bytevector) + +(define/who bytes-copy! + (case-lambda + [(dest d-start src) + (bytes-copy! dest d-start src 0 (bytes-length src))] + [(dest d-start src s-start) + (bytes-copy! dest d-start src s-start (bytes-length src))] + [(dest d-start src s-start s-end) + (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who bytes? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (bytevector-length dest)]) + (check-range who "byte string" dest d-start #f d-len) + (check-range who "byte string" src s-start s-end (bytevector-length src)) + (let ([s-len (fx- s-end s-start)]) + (check-space who "byte string" d-start d-len s-len) + (bytevector-copy! src s-start dest d-start s-len)))])) + +(define/who (bytes-fill! bstr b) + (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" bstr) + (check who byte? b) + (bytevector-fill! bstr b)) + +(define bytes-copy #2%bytevector-copy) + +(define-syntax-rule (define-bytes-compare name do-name) + (define/who name + (case-lambda + [(a b) + (check who bytes? a) + (check who bytes? b) + (do-name a b)] + [(a b . l) + (check who bytes? a) + (check who bytes? b) + (and (bytevector=? a b) + (let loop ([a b] [l l]) + (cond + [(null? l) #t] + [else (let ([b (car l)]) + (check who bytes? b) + (and (do-name a b) + (loop b (cdr l))))])))]))) + +(define-bytes-compare bytes=? bytevector=?) + +(define (do-bytes? a b) + (let ([alen (bytes-length a)] + [blen (bytes-length b)]) + (let loop ([i 0]) + (cond + [(= i alen) #f] + [(= i blen) #t] + [else + (let ([va (bytes-ref a i)] + [vb (bytes-ref b i)]) + (cond + [(fx> va vb) #t] + [(fx= va vb) (loop (fx1+ i))] + [else #f]))])))) + +(define (do-bytes>=? a b) (not (do-bytes? a b))) + +(define-bytes-compare bytes? do-bytes>?) +(define-bytes-compare bytes>=? do-bytes>=?) + +(define/who bytes-append + (case-lambda + [(a b) + (check who bytes? a) + (check who bytes? b) + (let ([alen (bytevector-length a)] + [blen (bytevector-length b)]) + (let ([c (make-bytevector (+ alen blen))]) + (bytevector-copy! a 0 c 0 alen) + (bytevector-copy! b 0 c alen blen) + c))] + [(a) + (check who bytes? a) + a] + [() #vu8()] + [args + (let* ([size (let loop ([args args]) + (cond + [(null? args) 0] + [else (+ (bytevector-length (car args)) + (loop (cdr args)))]))] + [c (make-bytevector size)]) + (let loop ([args args] [pos 0]) + (cond + [(null? args) c] + [else + (let ([len (bytevector-length (car args))]) + (bytevector-copy! (car args) 0 c pos len) + (loop (cdr args) (+ pos len)))])))])) + +(define/who subbytes + (case-lambda + [(bstr start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "byte string" bstr start end (bytevector-length bstr)) + (let* ([len (- end start)] + [c (make-bytevector len)]) + (bytevector-copy! bstr start c 0 len) + c)] + [(bstr start) + (subbytes bstr start (bytes-length bstr))])) diff -Nru racket-6.12+ppa1/src/cs/rumble/char.ss racket-7.0+ppa1/src/cs/rumble/char.ss --- racket-6.12+ppa1/src/cs/rumble/char.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/char.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,642 @@ + +(define/who (char-blank? x) + (check who char? x) + (or (char=? x #\tab) + (eq? (#%char-general-category x) 'Zs))) + +(define/who (char-iso-control? x) + (check who char? x) + (or (char<=? #\nul x #\x1F) + (char<=? #\delete x #\x9F))) + +(define/who (char-punctuation? x) + (check who char? x) + (and (#%memq (#%char-general-category x) '(Pc Pd Ps Pe Pi Pf Po)) #t)) + +(define/who (char-graphic? x) + (check who char? x) + (or (char-numeric? x) + (char-alphabetic? x) + (and (#%memq (#%char-general-category x) '(Ll Lm Lo Lt Lu Nd Nl No Mn Mc Me + ;; char-symbolic?: + Sm Sc Sk So + ;; char-punctuation?: + Pc Pd Ps Pe Pi Pf Po)) + #t))) + +(define/who (char-symbolic? x) + (check who char? x) + (and (#%memq (#%char-general-category x) '(Sm Sc Sk So)) #t)) + +(define (interned-char? v) + (and (char? v) (< (char->integer v) 256))) + +(define (char-general-category ch) + (or (getprop (#%char-general-category ch) 'downcase #f) + (let* ([s (#%char-general-category ch)] + [ds (string->symbol (string-downcase (symbol->string s)))]) + (putprop s 'downcase ds) + ds))) + +;; FIXME +(define (make-known-char-range-list) + '((0 887 #f) + (890 895 #f) + (900 906 #f) + (908 908 #t) + (910 929 #f) + (931 1327 #f) + (1329 1366 #t) + (1369 1375 #f) + (1377 1415 #f) + (1417 1418 #f) + (1421 1423 #f) + (1425 1479 #f) + (1488 1514 #t) + (1520 1524 #f) + (1536 1564 #f) + (1566 1805 #f) + (1807 1866 #f) + (1869 1969 #f) + (1984 2042 #f) + (2048 2093 #f) + (2096 2110 #t) + (2112 2139 #f) + (2142 2142 #t) + (2208 2226 #t) + (2276 2435 #f) + (2437 2444 #t) + (2447 2448 #t) + (2451 2472 #t) + (2474 2480 #t) + (2482 2482 #t) + (2486 2489 #t) + (2492 2500 #f) + (2503 2504 #t) + (2507 2510 #f) + (2519 2519 #t) + (2524 2525 #t) + (2527 2531 #f) + (2534 2555 #f) + (2561 2563 #f) + (2565 2570 #t) + (2575 2576 #t) + (2579 2600 #t) + (2602 2608 #t) + (2610 2611 #f) + (2613 2614 #f) + (2616 2617 #t) + (2620 2620 #t) + (2622 2626 #f) + (2631 2632 #t) + (2635 2637 #f) + (2641 2641 #t) + (2649 2652 #f) + (2654 2654 #t) + (2662 2677 #f) + (2689 2691 #f) + (2693 2701 #t) + (2703 2705 #t) + (2707 2728 #t) + (2730 2736 #t) + (2738 2739 #t) + (2741 2745 #t) + (2748 2757 #f) + (2759 2761 #f) + (2763 2765 #f) + (2768 2768 #t) + (2784 2787 #f) + (2790 2801 #f) + (2817 2819 #f) + (2821 2828 #t) + (2831 2832 #t) + (2835 2856 #t) + (2858 2864 #t) + (2866 2867 #t) + (2869 2873 #t) + (2876 2884 #f) + (2887 2888 #f) + (2891 2893 #f) + (2902 2903 #f) + (2908 2909 #t) + (2911 2915 #f) + (2918 2935 #f) + (2946 2947 #f) + (2949 2954 #t) + (2958 2960 #t) + (2962 2965 #f) + (2969 2970 #t) + (2972 2972 #t) + (2974 2975 #t) + (2979 2980 #t) + (2984 2986 #t) + (2990 3001 #t) + (3006 3010 #f) + (3014 3016 #t) + (3018 3021 #f) + (3024 3024 #t) + (3031 3031 #t) + (3046 3066 #f) + (3072 3075 #f) + (3077 3084 #t) + (3086 3088 #t) + (3090 3112 #t) + (3114 3129 #t) + (3133 3140 #f) + (3142 3144 #f) + (3146 3149 #f) + (3157 3158 #f) + (3160 3161 #t) + (3168 3171 #f) + (3174 3183 #t) + (3192 3199 #f) + (3201 3203 #f) + (3205 3212 #t) + (3214 3216 #t) + (3218 3240 #t) + (3242 3251 #t) + (3253 3257 #t) + (3260 3268 #f) + (3270 3272 #f) + (3274 3277 #f) + (3285 3286 #t) + (3294 3294 #t) + (3296 3299 #f) + (3302 3311 #t) + (3313 3314 #t) + (3329 3331 #f) + (3333 3340 #t) + (3342 3344 #t) + (3346 3386 #t) + (3389 3396 #f) + (3398 3400 #t) + (3402 3406 #f) + (3415 3415 #t) + (3424 3427 #f) + (3430 3445 #f) + (3449 3455 #f) + (3458 3459 #t) + (3461 3478 #t) + (3482 3505 #t) + (3507 3515 #t) + (3517 3517 #t) + (3520 3526 #t) + (3530 3530 #t) + (3535 3540 #f) + (3542 3542 #t) + (3544 3551 #f) + (3558 3567 #t) + (3570 3572 #f) + (3585 3642 #f) + (3647 3675 #f) + (3713 3714 #t) + (3716 3716 #t) + (3719 3720 #t) + (3722 3722 #t) + (3725 3725 #t) + (3732 3735 #t) + (3737 3743 #t) + (3745 3747 #t) + (3749 3749 #t) + (3751 3751 #t) + (3754 3755 #t) + (3757 3769 #f) + (3771 3773 #f) + (3776 3780 #t) + (3782 3782 #t) + (3784 3789 #f) + (3792 3801 #t) + (3804 3807 #f) + (3840 3911 #f) + (3913 3948 #f) + (3953 3991 #f) + (3993 4028 #f) + (4030 4044 #f) + (4046 4058 #f) + (4096 4293 #f) + (4295 4295 #t) + (4301 4301 #t) + (4304 4680 #f) + (4682 4685 #t) + (4688 4694 #t) + (4696 4696 #t) + (4698 4701 #t) + (4704 4744 #t) + (4746 4749 #t) + (4752 4784 #t) + (4786 4789 #t) + (4792 4798 #t) + (4800 4800 #t) + (4802 4805 #t) + (4808 4822 #t) + (4824 4880 #t) + (4882 4885 #t) + (4888 4954 #t) + (4957 4988 #f) + (4992 5017 #f) + (5024 5108 #t) + (5120 5788 #f) + (5792 5880 #f) + (5888 5900 #t) + (5902 5908 #f) + (5920 5942 #f) + (5952 5971 #f) + (5984 5996 #t) + (5998 6000 #t) + (6002 6003 #t) + (6016 6109 #f) + (6112 6121 #t) + (6128 6137 #t) + (6144 6158 #f) + (6160 6169 #t) + (6176 6263 #f) + (6272 6314 #f) + (6320 6389 #t) + (6400 6430 #t) + (6432 6443 #f) + (6448 6459 #f) + (6464 6464 #t) + (6468 6509 #f) + (6512 6516 #t) + (6528 6571 #t) + (6576 6601 #f) + (6608 6618 #f) + (6622 6683 #f) + (6686 6750 #f) + (6752 6780 #f) + (6783 6793 #f) + (6800 6809 #t) + (6816 6829 #f) + (6832 6846 #f) + (6912 6987 #f) + (6992 7036 #f) + (7040 7155 #f) + (7164 7223 #f) + (7227 7241 #f) + (7245 7295 #f) + (7360 7367 #t) + (7376 7414 #f) + (7416 7417 #t) + (7424 7669 #f) + (7676 7957 #f) + (7960 7965 #t) + (7968 8005 #f) + (8008 8013 #t) + (8016 8023 #f) + (8025 8025 #t) + (8027 8027 #t) + (8029 8029 #t) + (8031 8061 #f) + (8064 8116 #f) + (8118 8132 #f) + (8134 8147 #f) + (8150 8155 #f) + (8157 8175 #f) + (8178 8180 #f) + (8182 8190 #f) + (8192 8292 #f) + (8294 8305 #f) + (8308 8334 #f) + (8336 8348 #t) + (8352 8381 #f) + (8400 8432 #f) + (8448 8585 #f) + (8592 9210 #f) + (9216 9254 #t) + (9280 9290 #t) + (9312 11123 #f) + (11126 11157 #t) + (11160 11193 #t) + (11197 11208 #t) + (11210 11217 #t) + (11264 11310 #t) + (11312 11358 #t) + (11360 11507 #f) + (11513 11557 #f) + (11559 11559 #t) + (11565 11565 #t) + (11568 11623 #t) + (11631 11632 #f) + (11647 11670 #f) + (11680 11686 #t) + (11688 11694 #t) + (11696 11702 #t) + (11704 11710 #t) + (11712 11718 #t) + (11720 11726 #t) + (11728 11734 #t) + (11736 11742 #t) + (11744 11842 #f) + (11904 11929 #t) + (11931 12019 #f) + (12032 12245 #t) + (12272 12283 #t) + (12288 12351 #f) + (12353 12438 #f) + (12441 12543 #f) + (12549 12589 #t) + (12593 12686 #t) + (12688 12730 #f) + (12736 12771 #t) + (12784 12830 #f) + (12832 13054 #f) + (13056 19893 #f) + (19904 40908 #f) + (40960 42124 #f) + (42128 42182 #t) + (42192 42539 #f) + (42560 42653 #f) + (42655 42743 #f) + (42752 42894 #f) + (42896 42925 #f) + (42928 42929 #f) + (42999 43051 #f) + (43056 43065 #f) + (43072 43127 #f) + (43136 43204 #f) + (43214 43225 #f) + (43232 43259 #f) + (43264 43347 #f) + (43359 43388 #f) + (43392 43469 #f) + (43471 43481 #f) + (43486 43518 #f) + (43520 43574 #f) + (43584 43597 #f) + (43600 43609 #t) + (43612 43714 #f) + (43739 43766 #f) + (43777 43782 #t) + (43785 43790 #t) + (43793 43798 #t) + (43808 43814 #t) + (43816 43822 #t) + (43824 43871 #f) + (43876 43877 #t) + (43968 44013 #f) + (44016 44025 #t) + (44032 55203 #t) + (55216 55238 #t) + (55243 55291 #t) + (57344 64109 #f) + (64112 64217 #t) + (64256 64262 #t) + (64275 64279 #t) + (64285 64310 #f) + (64312 64316 #t) + (64318 64318 #t) + (64320 64321 #t) + (64323 64324 #t) + (64326 64449 #f) + (64467 64831 #f) + (64848 64911 #t) + (64914 64967 #t) + (65008 65021 #f) + (65024 65049 #f) + (65056 65069 #f) + (65072 65106 #f) + (65108 65126 #f) + (65128 65131 #f) + (65136 65140 #f) + (65142 65276 #t) + (65279 65279 #t) + (65281 65470 #f) + (65474 65479 #t) + (65482 65487 #t) + (65490 65495 #t) + (65498 65500 #t) + (65504 65510 #f) + (65512 65518 #f) + (65529 65533 #f) + (65536 65547 #t) + (65549 65574 #t) + (65576 65594 #t) + (65596 65597 #t) + (65599 65613 #t) + (65616 65629 #t) + (65664 65786 #t) + (65792 65794 #t) + (65799 65843 #t) + (65847 65932 #f) + (65936 65947 #t) + (65952 65952 #t) + (66000 66045 #f) + (66176 66204 #t) + (66208 66256 #t) + (66272 66299 #f) + (66304 66339 #f) + (66352 66378 #f) + (66384 66426 #f) + (66432 66461 #t) + (66463 66499 #f) + (66504 66517 #f) + (66560 66717 #f) + (66720 66729 #t) + (66816 66855 #t) + (66864 66915 #t) + (66927 66927 #t) + (67072 67382 #t) + (67392 67413 #t) + (67424 67431 #t) + (67584 67589 #t) + (67592 67592 #t) + (67594 67637 #t) + (67639 67640 #t) + (67644 67644 #t) + (67647 67669 #t) + (67671 67742 #f) + (67751 67759 #t) + (67840 67867 #f) + (67871 67897 #f) + (67903 67903 #t) + (67968 68023 #t) + (68030 68031 #t) + (68096 68099 #f) + (68101 68102 #t) + (68108 68115 #f) + (68117 68119 #t) + (68121 68147 #t) + (68152 68154 #f) + (68159 68167 #f) + (68176 68184 #t) + (68192 68255 #f) + (68288 68326 #f) + (68331 68342 #f) + (68352 68405 #t) + (68409 68437 #f) + (68440 68466 #f) + (68472 68497 #f) + (68505 68508 #t) + (68521 68527 #t) + (68608 68680 #t) + (69216 69246 #f) + (69632 69709 #f) + (69714 69743 #f) + (69759 69825 #f) + (69840 69864 #t) + (69872 69881 #t) + (69888 69940 #f) + (69942 69955 #f) + (69968 70006 #f) + (70016 70088 #f) + (70093 70093 #t) + (70096 70106 #f) + (70113 70132 #t) + (70144 70161 #t) + (70163 70205 #f) + (70320 70378 #f) + (70384 70393 #t) + (70401 70403 #f) + (70405 70412 #t) + (70415 70416 #t) + (70419 70440 #t) + (70442 70448 #t) + (70450 70451 #t) + (70453 70457 #t) + (70460 70468 #f) + (70471 70472 #t) + (70475 70477 #f) + (70487 70487 #t) + (70493 70499 #f) + (70502 70508 #t) + (70512 70516 #t) + (70784 70855 #f) + (70864 70873 #t) + (71040 71093 #f) + (71096 71113 #f) + (71168 71236 #f) + (71248 71257 #t) + (71296 71351 #f) + (71360 71369 #t) + (71840 71922 #f) + (71935 71935 #t) + (72384 72440 #t) + (73728 74648 #t) + (74752 74862 #t) + (74864 74868 #t) + (77824 78894 #t) + (92160 92728 #t) + (92736 92766 #t) + (92768 92777 #t) + (92782 92783 #t) + (92880 92909 #t) + (92912 92917 #f) + (92928 92997 #f) + (93008 93017 #t) + (93019 93025 #t) + (93027 93047 #t) + (93053 93071 #t) + (93952 94020 #t) + (94032 94078 #f) + (94095 94111 #f) + (110592 110593 #t) + (113664 113770 #t) + (113776 113788 #t) + (113792 113800 #t) + (113808 113817 #t) + (113820 113827 #f) + (118784 119029 #t) + (119040 119078 #t) + (119081 119261 #f) + (119296 119365 #f) + (119552 119638 #t) + (119648 119665 #t) + (119808 119892 #f) + (119894 119964 #f) + (119966 119967 #t) + (119970 119970 #t) + (119973 119974 #t) + (119977 119980 #t) + (119982 119993 #f) + (119995 119995 #t) + (119997 120003 #t) + (120005 120069 #f) + (120071 120074 #t) + (120077 120084 #t) + (120086 120092 #t) + (120094 120121 #f) + (120123 120126 #t) + (120128 120132 #t) + (120134 120134 #t) + (120138 120144 #t) + (120146 120485 #f) + (120488 120779 #f) + (120782 120831 #t) + (124928 125124 #t) + (125127 125142 #f) + (126464 126467 #t) + (126469 126495 #t) + (126497 126498 #t) + (126500 126500 #t) + (126503 126503 #t) + (126505 126514 #t) + (126516 126519 #t) + (126521 126521 #t) + (126523 126523 #t) + (126530 126530 #t) + (126535 126535 #t) + (126537 126537 #t) + (126539 126539 #t) + (126541 126543 #t) + (126545 126546 #t) + (126548 126548 #t) + (126551 126551 #t) + (126553 126553 #t) + (126555 126555 #t) + (126557 126557 #t) + (126559 126559 #t) + (126561 126562 #t) + (126564 126564 #t) + (126567 126570 #t) + (126572 126578 #t) + (126580 126583 #t) + (126585 126588 #t) + (126590 126590 #t) + (126592 126601 #t) + (126603 126619 #t) + (126625 126627 #t) + (126629 126633 #t) + (126635 126651 #t) + (126704 126705 #t) + (126976 127019 #t) + (127024 127123 #t) + (127136 127150 #t) + (127153 127167 #t) + (127169 127183 #t) + (127185 127221 #t) + (127232 127244 #f) + (127248 127278 #t) + (127280 127339 #f) + (127344 127386 #f) + (127462 127490 #f) + (127504 127546 #t) + (127552 127560 #t) + (127568 127569 #t) + (127744 127788 #t) + (127792 127869 #t) + (127872 127950 #t) + (127956 127991 #t) + (128000 128254 #t) + (128256 128330 #t) + (128336 128377 #t) + (128379 128419 #t) + (128421 128578 #t) + (128581 128719 #t) + (128736 128748 #t) + (128752 128755 #t) + (128768 128883 #t) + (128896 128980 #t) + (129024 129035 #t) + (129040 129095 #t) + (129104 129113 #t) + (129120 129159 #t) + (129168 129197 #t) + (131072 173782 #t) + (173824 177972 #t) + (177984 178205 #t) + (194560 195101 #t) + (917505 917505 #t) + (917536 917631 #t) + (917760 917999 #t) + (983040 1048573 #t) + (1048576 1114109 #t))) diff -Nru racket-6.12+ppa1/src/cs/rumble/check.ss racket-7.0+ppa1/src/cs/rumble/check.ss --- racket-6.12+ppa1/src/cs/rumble/check.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/check.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,77 @@ + +(define-syntax (who stx) + (syntax-error stx "not bound")) + +(define-syntax-rule (define-define/who define/who define) + (... + (define-syntax (define/who stx) + (syntax-case stx () + [(_ (id . args) body ...) + #'(define id + (fluid-let-syntax ([who (lambda (stx) + #''id)]) + (lambda args body ...)))] + [(_ id rhs) + #'(define id + (fluid-let-syntax ([who (lambda (stx) + #''id)]) + rhs))])))) + +(define-define/who define/who define) +(define-define/who define/lift/who define/lift) +(define-define/who define/no-lift/who define/no-lift) + +(define-syntax (check stx) + (syntax-case stx (:test :contract :or-false) + [(_ who pred :contract ctc v) + #`(unless (pred v) + (raise-argument-error who ctc v))] + [(_ who :test test-expr :contract ctc v) + #`(unless test-expr + (raise-argument-error who ctc v))] + [(_ who :or-false pred v) + #`(unless (or (not v) (pred v)) + (raise-argument-error who #,(format "(or/c #f ~a)" (syntax->datum #'pred)) v))] + [(_ who pred :or-false v) + #`(unless (or (not v) (pred v)) + (raise-argument-error who #,(format "(or/c ~a #f)" (syntax->datum #'pred)) v))] + [(_ who pred v) + #`(check who pred :contract #,(format "~a" (syntax->datum #'pred)) v)])) + +(define-syntax (procedure-arity-includes/c stx) + (syntax-case stx () + [(_ n) + (let ([n (syntax->datum #'n)]) + (and (integer? n) + (exact? n) + (not (negative? n)))) + #'(lambda (p) + (and (procedure? p) + (procedure-arity-includes? p n)))])) + +(define (check-space who what d-start d-len s-len) + (unless (fx<= (fx+ d-start s-len) d-len) + (raise-arguments-error who (string-append "not enough room in target " what) + "target length" d-len + "needed length" s-len))) + +(define (check-range who what in-value start end len) + (unless (<= start len) + (raise-range-error who what "starting " start in-value 0 len)) + (when end + (unless (<= start end len) + (raise-range-error who what "ending " end in-value start len 0)))) + +(define (check-errno who errno) + (check who + :test (and (pair? errno) + (exact-integer? (car errno)) + (chez:memq (cdr errno) '(posix windows gai))) + :contract "(cons/c exact-integer? (or/c 'posix 'windows 'gai))" + errno)) + +(define (check-integer who lo hi v) + (unless (and (integer? v) + (exact? v) + (<= lo v hi)) + (raise-argument-error who v (format "(integer-in ~a ~a)" lo hi)))) diff -Nru racket-6.12+ppa1/src/cs/rumble/constant.ss racket-7.0+ppa1/src/cs/rumble/constant.ss --- racket-6.12+ppa1/src/cs/rumble/constant.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/constant.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5 @@ +(define null '()) +(define eof #!eof) + +(define (void . args) (chez:void)) +(define (void? v) (eq? v (chez:void))) diff -Nru racket-6.12+ppa1/src/cs/rumble/control.ss racket-7.0+ppa1/src/cs/rumble/control.ss --- racket-6.12+ppa1/src/cs/rumble/control.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/control.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1845 @@ +;; The full continuation is a chain of metacontinuations. Each +;; metacontinuation contains a host Scheme continuation, and +;; every prompt is on a boundary between metacontinuations. When +;; a composable continuation is applied, the composition boundary +;; is also a metacontinuation boundary. + +;; "Continuation" as exported from Rumble is "metacontinuation" +;; here. So, `call-with-current-continuation` defined here and +;; exported captures the current metacontinuation (up to a prompt). +;; The `call/cc` function is the host's notion of continuation, which +;; corresponds to a single metacontinuation frame. + +;; A picture where the continuation grows down: + +;; [root empty continuation] +;; --- empty-k +;; metacontinuation | +;; frame | +;; |--- resume-k +;; |<-- tag represents this point +;; --- empty-k +;; metacontinuation | +;; frame | +;; | +;; |--- resume-k +;; |<-- tag represents this point +;; --- empty-k +;; current host | +;; continuation | +;; v + +;; Concretely, the metacontinuation is the current host continuation +;; plus the frames in the list `(current-metacontinuation)`, where the +;; shallowest (= lowest in the picture above) frame is first in the +;; list. The `empty-k` value of the current host continuation is +;; in `current-empty-k`. + +;; The shallowest metacontinuation frame's `empty-k` continuation is +;; used to detect when the current host continuation is empty (i.e., +;; when it matches the `current-empty-k` value). When it's empty, then +;; calling a composable continuation doesn't need to add a new +;; metacontinuation frame, and the application gets the right "tail" +;; behavior. + +;; The shallowest metacontinuation frame's `empty-k` continuation also +;; indicates which continuation's marks (if any) should be spliced +;; into a new context when captured in a composable continuation. See +;; also `current-mark-splice` below. + +;; A metacontinuation frame's `resume-k` is called when control +;; returns or aborts to the frame: +;; +;; * When returning normally to a metacontinuation frame, the +;; `resume-k` continuation receives a function for values returned +;; to the frame. +;; +;; * When aborting to a prompt tag, the `resume-k` continination +;; receives a special value that indicates an abort with arguments. +;; +;; Calling a non-composable continuation is similar to aborting, +;; except that the target prompt's abort handler is not called. In +;; fact, the metacontinuation-frame unwinding process stops before the +;; frame with the target prompt tag (since that prompt is meant to be +;; preserved). + +;; The `dynamic-wind` winders for the frame represented by the current +;; host continuation are kept in `current-winders`. Each winder has a +;; continuation for the point where the winder applies, and when +;; winding or unwinding, control is oved to that continuation, which +;; is needed especially for space-safe unwinding to avoid retaining +;; the continuation where the jump starts. + +;; The continuation marks for the frame represented by the current +;; host continuation are kept in `current-mark-stack`. When a +;; metacontinuation frame is created, it takes the current +;; `current-mark-stack` value and `current-mark-stack` is set back to +;; empty. To keep winders and the mark stack in sync, a `dynamic-wind` +;; pre or post thunk resets the mark stack on entry. + +;; When a composable continuation is applied in a continuation frame +;; that has marks, then the marks are moved into `current-mark-splice`, +;; which is conceptually merged into the tai of `current-mark-stack`. +;; Having a separate `current-mark-splice` enables `dynamic-wind` +;; pre and post thunks adapt correctly to the splicing while jumping +;; into or out of the continuation. + +;; A metacontinuation frame has an extra cache slot to contain a list +;; of mark-stack lists down to the root continuation. When a delimited +;; sequence of metacontinuation frames are copied out of or into the +;; metacontinuation, the slot is flushed and will be reset on demand. + +;; Continuations are used to implement engines, but it's important +;; that an engine doesn't get swapped out (or, more generally, +;; asynchronous signals are handled at the Racket level) while we're +;; manipulating the continuation representation. A bad time for a swap +;; is an "interrupted" region. The `begin-uninterrupted` and +;; `end-uninterrupted` functions bracket such regions dynamically. See +;; also "rumble/engine.ss" and "rumble/interrupt.ss" + +(define-virtual-register current-metacontinuation '()) + +(define-virtual-register current-empty-k #f) + +(define-record metacontinuation-frame (tag ; continuation prompt tag or #f + resume-k ; delivers values to the prompt + empty-k ; deepest end of this frame + winders ; `dynamic-wind` winders + mark-stack ; mark stack to restore + mark-splice ; extra part of mark stack to restore + mark-chain ; #f or a cached list of mark-chain-frame or elem+cache + traces ; #f or a cached list of traces + cc-guard)) ; for impersonated tag, initially #f + +;; Messages to `resume-k[/no-wind]`: +(define-record aborting (args)) + +(define-record-type (continuation-prompt-tag create-continuation-prompt-tag authentic-continuation-prompt-tag?) + (fields (mutable name))) ; mutable => constructor generates fresh instances + +(define the-default-continuation-prompt-tag (create-continuation-prompt-tag 'default)) + +;; Not actually set, but allows access to the full continuation: +(define the-root-continuation-prompt-tag (create-continuation-prompt-tag 'root)) + +;; Tag for a metacontinuation created for composing a continuation +(define the-compose-prompt-tag (create-continuation-prompt-tag 'compose)) + +;; Detected to prevent some jumps: +(define the-barrier-prompt-tag (create-continuation-prompt-tag 'barrier)) + +(define/who make-continuation-prompt-tag + (case-lambda + [() (create-continuation-prompt-tag #f)] + [(name) + (check who symbol? name) + (create-continuation-prompt-tag name)])) + +(define (default-continuation-prompt-tag) the-default-continuation-prompt-tag) +(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag) + +;; To support special treatment of break parameterizations, and also +;; to initialize disabled breaks for `dynamic-wind` pre and post +;; thunks: +(define break-enabled-key (gensym 'break-enabled)) + +;; FIXME: add caching to avoid full traversal +(define/who (continuation-prompt-available? tag) + (check who continuation-prompt-tag? tag) + (let ([tag (strip-impersonator tag)]) + (or (eq? tag the-default-continuation-prompt-tag) + (eq? tag the-root-continuation-prompt-tag) + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) + (eq? tag the-default-continuation-prompt-tag)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc)))) + #t] + [else (loop (cdr mc))]))))) + +(define/who (maybe-future-barricade tag) + (when (future? (current-future)) ;; running in a future + (check who continuation-prompt-tag? tag) + (let ([fp (strip-impersonator (current-future-prompt))] + [tag (strip-impersonator tag)]) + (cond + [(eq? tag the-root-continuation-prompt-tag) + (block)] + [else + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) + ;; Won't happen normally, since every thread starts with a explicit prompt + (block)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc)))) + (void)] + [(eq? (metacontinuation-frame-tag (car mc)) fp) + ;; tag must be above future prompt + (block)] + [else + (loop (cdr mc))]))])))) + +(define/who call-with-continuation-prompt + (case-lambda + [(proc) (call-with-continuation-prompt proc the-default-continuation-prompt-tag #f)] + [(proc tag) (call-with-continuation-prompt proc tag #f)] + [(proc tag handler . args) + (check who procedure? proc) + (check who continuation-prompt-tag? tag) + (check who :or-false procedure? handler) + (start-uninterrupted 'prompt) + (call-in-empty-metacontinuation-frame + tag + (wrap-handler-for-impersonator + tag + (or handler (make-default-abort-handler tag))) + #f ; not a tail call + (lambda () + (end-uninterrupted 'prompt) + ;; Make room for a slicing continuation-mark frame, in case this + ;; metacontinuation frame is capture and composed in a context + ;; that already has marks: + (call-with-splice-k + (lambda () + ;; Finally, apply the given function: + (apply proc args)))))])) + +(define (make-default-abort-handler tag) + (lambda (abort-thunk) + (check 'default-continuation-prompt-handler (procedure-arity-includes/c 0) abort-thunk) + (call-with-continuation-prompt abort-thunk tag #f))) + +(define (resume-metacontinuation results) + ;; pop a metacontinuation frame + (cond + [(null? (current-metacontinuation)) (engine-return)] + [else + (start-uninterrupted 'resume-mc) + (let ([mf (car (current-metacontinuation))]) + (pop-metacontinuation-frame) + ;; resume + ((metacontinuation-frame-resume-k mf) results))])) + +(define (pop-metacontinuation-frame) + (let ([mf (car (current-metacontinuation))]) + (current-metacontinuation (cdr (current-metacontinuation))) + (current-winders (metacontinuation-frame-winders mf)) + (current-mark-stack (metacontinuation-frame-mark-stack mf)) + (current-mark-splice (metacontinuation-frame-mark-splice mf)) + (current-empty-k (metacontinuation-frame-empty-k mf)))) + +(define (call-in-empty-metacontinuation-frame tag handler tail? proc) + ;; Call `proc` in an empty metacontinuation frame, reifying the + ;; current metacontinuation as needed (i.e., if non-empty) as a new + ;; frame on `*metacontinuations*`; if the tag is #f and the + ;; current metacontinuation frame is already empty, don't push more + (assert-in-uninterrupted) + (assert-not-in-system-wind) + (call/cc + (lambda (tail-k) + (cond + [(and (eq? tag the-compose-prompt-tag) + (eq? tail-k (current-empty-k))) + ;; empty continuation in the current frame; don't push a new + ;; metacontinuation frame; if the mark stack is non-empty, + ;; merge it into the mark splice + (current-mark-splice (merge-mark-splice (current-mark-stack) (current-mark-splice))) + (current-mark-stack '()) + (proc)] + [else + (let ([r ; a list of results, or a non-list for special handling + (call/cc + (lambda (k) + ;; Push another continuation frame so we can drop its `next` + (call-as-non-tail + (lambda () + ;; drop the rest of the current continuation from the + ;; new metacontinuation frame: + (#%$current-stack-link #%$null-continuation) + (let-values ([results + (call/cc + ;; remember the "empty" continuation frame + ;; that just continues the metacontinuation: + (lambda (empty-k) + (let ([mf (make-metacontinuation-frame tag + k + (current-empty-k) + (current-winders) + (if tail? + (prune-immediate-frame (current-mark-stack) tail-k) + (current-mark-stack)) + (current-mark-splice) + #f + #f + #f)]) + (current-winders '()) + (current-empty-k empty-k) + (current-mark-splice (and tail? + (keep-immediate-frame (current-mark-stack) tail-k empty-k))) + (current-mark-stack #f) + ;; push the metacontinuation: + (current-metacontinuation (cons mf (current-metacontinuation))) + ;; ready: + (proc))))]) + ;; Prepare to use cc-guard, if one was enabled: + (let ([cc-guard (or (metacontinuation-frame-cc-guard (car (current-metacontinuation))) + values)]) + ;; Continue normally; the metacontinuation could be different + ;; than when we captured this metafunction frame, though: + (resume-metacontinuation + ;; Apply the cc-guard, if any, outside of the prompt: + (lambda () (apply cc-guard results)))))))))]) + (cond + [(aborting? r) + ;; Remove the prompt as we call the handler: + (pop-metacontinuation-frame) + (end-uninterrupted 'handle) + (apply handler + (aborting-args r))] + [else + ;; We're returning normally; the metacontinuation frame has + ;; been popped already by `resume-metacontinuation` + (end-uninterrupted 'resume) + (r)]))])))) + +(define (call-as-non-tail proc) + (proc) + '(error 'call-as-non-tail "shouldn't get to frame that was meant to be discarded")) + +(define (metacontinuation-frame-update-mark-stack current-mf mark-stack mark-splice) + (make-metacontinuation-frame (metacontinuation-frame-tag current-mf) + (metacontinuation-frame-resume-k current-mf) + (metacontinuation-frame-empty-k current-mf) + (metacontinuation-frame-winders current-mf) + mark-stack + mark-splice + #f + #f + (metacontinuation-frame-cc-guard current-mf))) + +(define (metacontinuation-frame-update-cc-guard current-mf cc-guard) + ;; Ok to keep caches, since the cc-guard doesn't affect them + (make-metacontinuation-frame (metacontinuation-frame-tag current-mf) + (metacontinuation-frame-resume-k current-mf) + (metacontinuation-frame-empty-k current-mf) + (metacontinuation-frame-winders current-mf) + (metacontinuation-frame-mark-stack current-mf) + (metacontinuation-frame-mark-splice current-mf) + (metacontinuation-frame-mark-chain current-mf) + (metacontinuation-frame-traces current-mf) + cc-guard)) + +;; ---------------------------------------- + +(define/who (abort-current-continuation tag . args) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (check-prompt-tag-available who (strip-impersonator tag)) + (start-uninterrupted 'abort) + (let ([args (apply-impersonator-abort-wrapper tag args)] + [tag (strip-impersonator tag)]) + (do-abort-current-continuation who tag args #t))) + +(define/who (unsafe-abort-current-continuation/no-wind tag arg) + (start-uninterrupted 'abort) + (let ([args (apply-impersonator-abort-wrapper tag (list arg))] + [tag (strip-impersonator tag)]) + (do-abort-current-continuation who tag args #f))) + +(define (do-abort-current-continuation who tag args wind?) + (assert-in-uninterrupted) + (cond + [(null? (current-metacontinuation)) + ;; A reset handler must end the uninterrupted region: + ((reset-handler))] + [(or (not wind?) + (null? (current-winders))) + (let ([mf (car (current-metacontinuation))]) + (cond + [(eq? tag (strip-impersonator (metacontinuation-frame-tag mf))) + ((metacontinuation-frame-resume-k mf) + (make-aborting args))] + [else + ;; Aborting to an enclosing prompt, so keep going: + (pop-metacontinuation-frame) + (do-abort-current-continuation who tag args wind?)]))] + [else + (wind-to + '() + ;; No winders left: + (lambda () + (do-abort-current-continuation who tag args wind?)) + ;; If the metacontinuation changes, check target before retrying: + (lambda () + (check-prompt-still-available who tag) + (do-abort-current-continuation who tag args wind?)))])) + +(define (check-prompt-still-available who tag) + (unless (continuation-prompt-available? tag) + (end-uninterrupted 'escape-fail) + (raise-continuation-error who + (string-append + "lost target;\n" + (if (eq? who 'abort-current-continuation) + (string-append + " abort in progress, but the current continuation includes no prompt with\n" + " the given tag after a `dynamic-wind` post-thunk return") + (string-append + " jump to escape continuation in progress, and the target is not in the\n" + " current continuation after a `dynamic-wind` post-thunk return")))))) + +;; ---------------------------------------- + +(define/who (call-with-continuation-barrier p) + (check who (procedure-arity-includes/c 0) p) + (start-uninterrupted 'barrier) + (call-in-empty-metacontinuation-frame + the-barrier-prompt-tag ; <- recognized as a barrier by continuation capture or call + #f + #f ; not a tail call + (lambda () + (end-uninterrupted 'barrier) + (|#%app| p)))) + +;; ---------------------------------------- +;; Capturing and applying continuations + +(define-record continuation ()) +(define-record full-continuation continuation (k winders mark-stack mark-splice empty-k mc)) +(define-record composable-continuation full-continuation ()) +(define-record composable-continuation/no-wind composable-continuation ()) +(define-record non-composable-continuation full-continuation (tag)) +(define-record escape-continuation continuation (tag)) + +(define/who call-with-current-continuation + (case-lambda + [(proc) (call-with-current-continuation proc + the-default-continuation-prompt-tag)] + [(proc tag) + (check who (procedure-arity-includes/c 1) proc) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (|#%app| + proc + (make-non-composable-continuation + k + (current-winders) + (current-mark-stack) + (current-mark-splice) + (current-empty-k) + (extract-metacontinuation 'call-with-current-continuation (strip-impersonator tag) #t) + tag))))))])) + +(define/who call-with-composable-continuation + (case-lambda + [(p) (call-with-composable-continuation p the-default-continuation-prompt-tag)] + [(p tag) + (check who (procedure-arity-includes/c 1) p) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call-with-composable-continuation* p tag #t)])) + +(define (call-with-composable-continuation* p tag wind?) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (|#%app| + p + ((if wind? + make-composable-continuation + make-composable-continuation/no-wind) + k + (current-winders) + (current-mark-stack) + (current-mark-splice) + (current-empty-k) + (extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f)))))))) + +(define (unsafe-call-with-composable-continuation/no-wind p tag) + (call-with-composable-continuation* p tag #f)) + +(define/who (call-with-escape-continuation p) + (check who (procedure-arity-includes/c 1) p) + (let ([tag (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (|#%app| p (make-escape-continuation tag))) + tag + values))) + +;; Applying a continuation calls this internal function: +(define (apply-continuation c args) + (start-uninterrupted 'continue) + (cond + [(composable-continuation? c) + ;; To compose the metacontinuation, first make sure the current + ;; continuation is reified in `(current-metacontinuation)`: + (call-in-empty-metacontinuation-frame + the-compose-prompt-tag + fail-abort-to-delimit-continuation + #t ; a tail call + (lambda () + ;; The current metacontinuation frame has an + ;; empty continuation, so we can "replace" that + ;; with the composable one: + (if (composable-continuation/no-wind? c) + (apply-immediate-continuation/no-wind c args) + (apply-immediate-continuation c (reverse (full-continuation-mc c)) args))))] + [(non-composable-continuation? c) + (apply-non-composable-continuation c args)] + [(escape-continuation? c) + (let ([tag (escape-continuation-tag c)]) + (unless (continuation-prompt-available? tag) + (end-uninterrupted 'escape-fail) + (raise-continuation-error '|continuation application| + "attempt to jump into an escape continuation")) + (do-abort-current-continuation '|continuation application| tag args #t))])) + +(define (apply-non-composable-continuation c args) + (assert-in-uninterrupted) + (let* ([tag (non-composable-continuation-tag c)]) + (let-values ([(common-mc ; shared part of the current metacontinuation + rmc-append) ; non-shared part of the destination metacontinuation + ;; We check every time, just in case control operations + ;; change the current continuation out from under us. + (find-common-metacontinuation (full-continuation-mc c) + (current-metacontinuation) + (strip-impersonator tag))]) + (let loop () + (cond + [(eq? common-mc (current-metacontinuation)) + ;; Replace the current metacontinuation frame's continuation + ;; with the saved one; this replacement will take care of any + ;; shared winders within the frame. + (apply-immediate-continuation c rmc-append args)] + [else + ;; Unwind this metacontinuation frame: + (wind-to + '() + ;; If all winders complete simply: + (lambda () + (pop-metacontinuation-frame) + (loop)) + ;; If a winder changes the metacontinuation, then + ;; start again: + (lambda () + (apply-non-composable-continuation c args)))]))))) + +;; Apply a continuation within the current metacontinuation frame: +(define (apply-immediate-continuation c rmc args) + (assert-in-uninterrupted) + (call-with-appended-metacontinuation + rmc + c + args + (lambda () + (let ([mark-stack (full-continuation-mark-stack c)] + [empty-k (full-continuation-empty-k c)]) + (current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)]) + (if (composable-continuation? c) + (prune-mark-splice (merge-mark-splice mark-splice (current-mark-splice)) + mark-stack + empty-k) + mark-splice))) + (current-empty-k empty-k) + (wind-to + (full-continuation-winders c) + ;; When no winders are left: + (lambda () + (current-mark-stack mark-stack) + (when (non-composable-continuation? c) + ;; Activate/add cc-guards in target prompt; any user-level + ;; callbacks here are run with a continuation barrier, so + ;; the metacontinuation won't change (except by escaping): + (activate-and-wrap-cc-guard-for-impersonator! + (non-composable-continuation-tag c))) + (apply (full-continuation-k c) args)) + ;; If a winder changed the meta-continuation, try again for a + ;; non-composable continuation: + (and (non-composable-continuation? c) + (lambda () + (apply-non-composable-continuation c args)))))))) + +;; Like `apply-immediate-continuation`, but don't run winders +(define (apply-immediate-continuation/no-wind c args) + (current-metacontinuation (append + (map metacontinuation-frame-clear-cache (full-continuation-mc c)) + (current-metacontinuation))) + (current-winders (full-continuation-winders c)) + (current-mark-stack (full-continuation-mark-stack c)) + (current-mark-splice (full-continuation-mark-splice c)) + (current-empty-k (full-continuation-empty-k c)) + (apply (full-continuation-k c) args)) + +;; Used as a "handler" for a prompt without a tag, which is used for +;; composable continuations +(define (fail-abort-to-delimit-continuation . args) + (error 'abort "trying to abort to a delimiter continuation frame")) + +;; Find common metacontinuation to keep due to a combination of: +;; the metacontinuation is beyond the relevant prompt, or the +;; metacontinuation fragment before the prompt is also shared +;; with the composable continuation's metacontinuation (so we +;; should not unwind and rewind those metacontinuation frames) +(define (find-common-metacontinuation mc current-mc tag) + (let-values ([(rev-current ; (list (cons mf mc) ...) + base-current-mc) + ;; Get the reversed prefix of `current-mc` that is to be + ;; replaced by `mc`: + (let loop ([current-mc current-mc] [accum null]) + (cond + [(null? current-mc) + (unless (or (eq? tag the-default-continuation-prompt-tag) + (eq? tag the-root-continuation-prompt-tag)) + (do-raise-arguments-error '|continuation application| + "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag))) + (values accum null)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car current-mc)))) + (values accum current-mc)] + [else + (loop (cdr current-mc) + ;; Accumulate this frame plus the chain that + ;; we should keep if this frame is shared: + (cons (cons (car current-mc) current-mc) + accum))]))]) + (let ([rev-mc (reverse mc)]) + ;; Work from the tail backwards (which is forward in the reverse + ;; lists): If the continuations are the same for the two frames, + ;; then the metacontinuation frame should not be unwound + (let loop ([rev-current rev-current] + [rev-mc rev-mc] + [base-current-mc base-current-mc]) + (cond + [(null? rev-mc) (values base-current-mc '())] + [(null? rev-current) + (check-for-barriers rev-mc) + ;; Return the shared part plus the unshared-to-append part + (values base-current-mc rev-mc)] + [(eq? (metacontinuation-frame-resume-k (car rev-mc)) + (metacontinuation-frame-resume-k (caar rev-current))) + ;; Matches, so update base and look shallower + (loop (cdr rev-current) + (cdr rev-mc) + (cdar rev-current))] + [else + ;; Doesn't match, so we've found the shared part; + ;; check for barriers that we'd have to reintroduce + (check-for-barriers rev-mc) + ;; Return the shared part plus the unshared-to-append part + (values (cdr (cdar rev-current)) rev-mc)]))))) + +(define (check-for-barriers rev-mc) + (unless (null? rev-mc) + (when (eq? (metacontinuation-frame-tag (car rev-mc)) + the-barrier-prompt-tag) + (raise-barrier-error)) + (check-for-barriers (cdr rev-mc)))) + +(define (raise-barrier-error) + (end-uninterrupted 'hit-barrier) + (raise-continuation-error '|continuation application| + "attempt to cross a continuation barrier")) + +(define (call-with-end-uninterrupted thunk) + ;; Using `call/cm` with a key of `none` ensures that we have an + ;; `(end-uninterrupted)` in the immediate continuation, but + ;; keeping the illusion that `thunk` is called in tail position. + (call/cm none #f thunk)) + +;; Update `splice-k` to be the "inside" of a continuation prompt. +(define (call-with-splice-k thunk) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (current-empty-k k) + (thunk)))))) + +(define (set-continuation-applicables!) + (let ([add (lambda (rtd) + (struct-property-set! prop:procedure + rtd + (lambda (c . args) + (apply-continuation c args))))]) + (add (record-type-descriptor composable-continuation)) + (add (record-type-descriptor composable-continuation/no-wind)) + (add (record-type-descriptor non-composable-continuation)) + (add (record-type-descriptor escape-continuation)))) + +;; ---------------------------------------- +;; Metacontinuation operations for continutions + +;; Extract a prefix of `(current-metacontinuation)` up to `tag` +(define (extract-metacontinuation who tag barrier-ok?) + (let ([check-barrier-ok + (lambda (saw-barrier?) + (when (and saw-barrier? (not barrier-ok?)) + (raise-continuation-error who "cannot capture past continuation barrier")))]) + (let loop ([mc (current-metacontinuation)] [saw-barrier? #f]) + (cond + [(null? mc) + (unless (or (eq? tag the-root-continuation-prompt-tag) + (eq? tag the-default-continuation-prompt-tag)) + (do-raise-arguments-error who "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag))) + (check-barrier-ok saw-barrier?) + '()] + [else + (let ([a-tag (strip-impersonator (metacontinuation-frame-tag (car mc)))]) + (cond + [(eq? a-tag tag) + (check-barrier-ok saw-barrier?) + '()] + [else + (cons (metacontinuation-frame-clear-cache (car mc)) + (loop (cdr mc) (or saw-barrier? + (eq? a-tag the-barrier-prompt-tag))))]))])))) + +(define (check-prompt-tag-available who tag) + (unless (continuation-prompt-available? tag) + (do-raise-arguments-error who "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag)))) + +(define (call-with-appended-metacontinuation rmc dest-c dest-args proc) + ;; Assumes that the current metacontinuation frame is ready to be + ;; replaced with `mc` (reversed as `rmc`) plus `proc`. + ;; In the simple case of no winders and an empty frame immediate + ;; metacontinuation fame, we could just + ;; (current-metacontinuation (append mc (current-metacontinuation))) + ;; But, to run winders and replace anything in the current frame, + ;; we proceed frame-by-frame in `mc`. + (assert-in-uninterrupted) + (let loop ([rmc rmc]) + (cond + [(null? rmc) (proc)] + [else + (let ([mf (maybe-merge-splice (composable-continuation? dest-c) + (metacontinuation-frame-clear-cache (car rmc)))] + [rmc (cdr rmc)]) + ;; Set splice before jumping, so it can be used by winders + (current-mark-splice (metacontinuation-frame-mark-splice mf)) + ;; Run "in" winders for the metacontinuation + (wind-to + (metacontinuation-frame-winders mf) + ;; When all winders done for this frame: + (lambda () + (current-metacontinuation (cons mf (current-metacontinuation))) + (current-winders '()) + (loop rmc)) + ;; When a winder changes the metacontinuation, try again + ;; for a non-composable continuation: + (and (non-composable-continuation? dest-c) + (lambda () + (apply-non-composable-continuation dest-c dest-args)))))]))) + +(define (metacontinuation-frame-clear-cache mf) + (metacontinuation-frame-update-mark-stack mf + (metacontinuation-frame-mark-stack mf) + (metacontinuation-frame-mark-splice mf))) + +;; Get/cache a converted list of marks for a metacontinuation +(define (metacontinuation-marks mc) + (cond + [(null? mc) null] + [else (let ([mf (car mc)]) + (or (metacontinuation-frame-mark-chain mf) + (let* ([r (metacontinuation-marks (cdr mc))] + [m (let ([mark-splice (metacontinuation-frame-mark-splice mf)]) + (if mark-splice + (cons (make-mark-chain-frame + (strip-impersonator (metacontinuation-frame-tag mf)) + ;; maybe splicing: + (mark-stack-tail-matches? (metacontinuation-frame-mark-stack mf) + (mark-stack-frame-k mark-splice)) + (mark-stack-to-marks mark-splice)) + r) + r))] + [l (cons (make-mark-chain-frame + (strip-impersonator (metacontinuation-frame-tag mf)) + #t ; not splicing + (mark-stack-to-marks + (metacontinuation-frame-mark-stack mf))) + m)]) + (set-metacontinuation-frame-mark-chain! mf l) + l)))])) + +(define (maybe-merge-splice splice? mf) + (cond + [(and splice? (current-mark-splice)) + => (lambda (mark-splice) + (current-mark-splice #f) + (metacontinuation-frame-update-mark-stack mf + (metacontinuation-frame-mark-stack mf) + (merge-mark-splice (metacontinuation-frame-mark-splice mf) + mark-splice)))] + [else mf])) + +;; ---------------------------------------- +;; Continuation marks + +(define-record continuation-mark-set (mark-chain traces)) +(define-record mark-stack-frame (prev ; prev frame + k ; continuation for this frame + table ; intmap mapping keys to values + flat)) ; #f or cached list that contains only tables and elem+caches + +;; A mark stack is made of marks-stack frames: +(define-virtual-register current-mark-stack #f) + +;; An extra mark stack of size 0 or 1 that is conceptually appended to +;; the end of `current-mark-stack`, mainly to support composable +;; continuations and `dynamic-wind`. If the last frame of +;; `current-mark-stack` has the same `k` as a frame in +;; `current-mark-stack-splice`, then then frames are conceptually +;; merged, so no key should be inthe mark-splice frame if it's in the +;; mark-stack frame. +(define-virtual-register current-mark-splice #f) + +;; See copy in "expander.sls" +(define-syntax with-continuation-mark + (syntax-rules () + [(_ key val body) + (call/cm key val (lambda () body))])) + +;; Sets a continuation mark. +;; Using `none` as a key ensures that a +;; stack-restoring frame is pushed without +;; adding a key--value mapping. +(define (call/cm key val proc) + (call/cc + (lambda (k) + (when (eq? k (current-empty-k)) + ;; Need to merge the main stack and splice, if both are active + (when (current-mark-splice) + (merge-mark-splice!))) + (let ([mark-stack (current-mark-stack)]) + (cond + [(and mark-stack + (eq? k (mark-stack-frame-k mark-stack))) + (unless (eq? key none) + (current-mark-stack (make-mark-stack-frame (mark-stack-frame-prev mark-stack) + k + (intmap-set/cm-key (mark-stack-frame-table mark-stack) + key + val) + #f))) + (proc)] + [else + (begin0 + (call/cc + (lambda (new-k) + (current-mark-stack + (make-mark-stack-frame mark-stack + new-k + (if (eq? key none) + empty-hasheq + (intmap-set/cm-key empty-hasheq key val)) + #f)) + (proc))) + (current-mark-stack (mark-stack-frame-prev (current-mark-stack))) + ;; To support exiting an uninterrupted region on resumption of + ;; a continuation (see `call-with-end-uninterrupted`): + (when (current-in-uninterrupted) + (pariah (end-uninterrupted/call-hook 'cm))))]))))) + +;; For internal use, such as `dynamic-wind` pre thunks: +(define (call/cm/nontail key val proc) + (current-mark-stack + (make-mark-stack-frame (current-mark-stack) + #f + (intmap-set empty-hasheq key val) + #f)) + (proc) + ;; If we're in an escape process, then `(current-mark-stack)` might not + ;; match, and that's ok; it doesn't matter what we set the mark stack to + ;; in that case, so we do something that's right for the non-escape case + (when (current-mark-stack) + (current-mark-stack (mark-stack-frame-prev (current-mark-stack))))) + +(define (current-mark-chain) + (get-current-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation))) + +(define (mark-stack-to-marks mark-stack) + (let loop ([mark-stack mark-stack]) + (cond + [(not mark-stack) null] + [(mark-stack-frame-flat mark-stack) => (lambda (l) l)] + [else + (let ([l (cons (mark-stack-frame-table mark-stack) + (loop (mark-stack-frame-prev mark-stack)))]) + (set-mark-stack-frame-flat! mark-stack l) + l)]))) + +(define-record mark-chain-frame (tag splice? marks)) + +(define (get-current-mark-chain mark-stack mark-splice mc) + (let ([hd (make-mark-chain-frame + #f ; no tag + #f ; not a splice + (mark-stack-to-marks mark-stack))] + [mid (and mark-splice + (make-mark-chain-frame + #f ; no tag + (mark-stack-tail-matches? mark-stack (mark-stack-frame-k mark-splice)) ; maybe splicing + (mark-stack-to-marks mark-splice)))] + [tl (metacontinuation-marks mc)]) + (if mid + (cons hd (cons mid tl)) + (cons hd tl)))) + +(define (mark-stack-tail-matches? mark-stack k) + (and mark-stack + (let ([prev (mark-stack-frame-prev mark-stack)]) + (or (and (not prev) + (eq? (mark-stack-frame-k mark-stack) k)) + (mark-stack-tail-matches? prev k))))) + +(define (prune-mark-chain-prefix tag mark-chain) + (cond + [(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain)))) + mark-chain] + [else + (prune-mark-chain-prefix tag (cdr mark-chain))])) + +(define (prune-mark-chain-suffix tag mark-chain) + (cond + [(null? mark-chain) null] + [(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain)))) + null] + [else + (let ([rest-mark-chain (prune-mark-chain-suffix tag (cdr mark-chain))]) + (if (eq? rest-mark-chain (cdr mark-chain)) + mark-chain + (cons (car mark-chain) + rest-mark-chain)))])) + +;; Used by `continuation-mark-set->list*` to determine when to splice +(define (splice-next? mark-chain) + (and (pair? mark-chain) + (pair? (cdr mark-chain)) + (mark-chain-frame-splice? (elem+cache-strip (cadr mark-chain))))) + +;; Called when the curent continuation is `(current-empty-k)`, +;; merge anything in `(current-mark-splice)` into `(current-mark-stack)` +(define (merge-mark-splice!) + (let ([mark-splice (current-mark-splice)]) + (when mark-splice + (current-mark-stack (merge-mark-splice (current-mark-stack) + mark-splice)) + (current-mark-splice #f)))) + +;; Merge immediate frame of `mark-splice` into immediate frame of +;; `mark-stack`, where `mark-stack` takes precedence. We expect that +;; each argument is a stack of length 0 or 1, since that's when +;; merging makes sense. +(define (merge-mark-splice mark-stack mark-splice) + (cond + [(not mark-stack) mark-splice] + [(not mark-splice) mark-stack] + [else + (make-mark-stack-frame #f + (mark-stack-frame-k mark-stack) + (merge-mark-table (mark-stack-frame-table mark-stack) + (mark-stack-frame-table mark-splice)) + #f)])) + +(define (merge-mark-table a b) + (cond + [(eq? empty-hasheq a) b] + [(eq? empty-hasheq b) a] + [else + (let loop ([b b] [i (hash-iterate-first a)]) + (cond + [(not i) b] + [else (let-values ([(key val) (hash-iterate-key+value a i)]) + (loop (hash-set b key val) + (hash-iterate-next a i)))]))])) + +;; If `mark-stack` ends with a frame that is conceptually +;; merged with one in `mark-splice`, then discard any keys +;; in `mark-splice` that are in the `mark-stack` frame. +;; Also, update `mark-splice` to use `empty-k`. +(define (prune-mark-splice mark-splice mark-stack empty-k) + (cond + [(not mark-splice) #f] + [else + (let loop ([mark-stack mark-stack]) + (cond + [(not mark-stack) (make-mark-stack-frame #f + empty-k + (mark-stack-frame-table mark-splice) + #f)] + [else + (let ([prev (mark-stack-frame-prev mark-stack)]) + (cond + [(and (not prev) (eq? (mark-stack-frame-k mark-stack) empty-k)) + (make-mark-stack-frame #f + empty-k + (prune-mark-table (mark-stack-frame-table mark-stack) + (mark-stack-frame-table mark-splice)) + #f)] + [else (loop prev)]))]))])) + +(define (prune-mark-table a b) + (cond + [(eq? empty-hasheq a) b] + [(eq? empty-hasheq b) a] + [else + (let loop ([b b] [i (hash-iterate-first a)]) + (cond + [(not i) b] + [else (loop (hash-remove b (hash-iterate-key a i)) + (hash-iterate-next a i))]))])) + +(define (mark-stack-starts-with? mark-stack k) + (and mark-stack + (eq? k (mark-stack-frame-k mark-stack)))) + +;; Drop any marks on the immediate frame --- used when +;; moving a frame across a metacontinuation boundary +(define (prune-immediate-frame mark-stack k) + (cond + [(mark-stack-starts-with? mark-stack k) + (make-mark-stack-frame (mark-stack-frame-prev mark-stack) + (mark-stack-frame-k mark-stack) + empty-hasheq + #f)] + [else mark-stack])) + +(define (keep-immediate-frame mark-stack k empty-k) + (cond + [(mark-stack-starts-with? mark-stack k) + (make-mark-stack-frame #f + empty-k + (mark-stack-frame-table mark-stack) + #f)] + [else #f])) + +(define (mark-stack-append a b) + (cond + [(not a) b] + [(not b) a] + [else + (make-mark-stack-frame (mark-stack-append (mark-stack-frame-prev a) b) + (mark-stack-frame-k a) + (mark-stack-frame-table a) + #f)])) + +;; ---------------------------------------- +;; Continuation-mark caching + +;; A `elem+cache` can replace a plain table in a "flat" variant of the +;; mark stack within a metacontinuation frame, or in a mark-stack +;; chain for a metacontinuation. The cache is a table that records +;; results found later in the list, which allows +;; `continuation-mark-set-first` to take amortized constant time. +(define-record elem+cache (elem cache)) +(define (elem+cache-strip t) (if (elem+cache? t) (elem+cache-elem t) t)) + +(define/who call-with-immediate-continuation-mark + (case-lambda + [(key proc) (call-with-immediate-continuation-mark key proc #f)] + [(key proc default-v) + (check who (procedure-arity-includes/c 1) proc) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)]) + (cond + [(not (current-mark-stack)) (|#%app| proc default-v)] + [else + (call/cc (lambda (k) + (when (eq? k (current-empty-k)) (merge-mark-splice!)) + (if (eq? k (mark-stack-frame-k (current-mark-stack))) + (|#%app| proc (let ([v (intmap-ref (mark-stack-frame-table (current-mark-stack)) + key + none)]) + (if (eq? v none) + default-v + (wrapper v)))) + (|#%app| proc default-v))))]))])) + +(define/who continuation-mark-set-first + (case-lambda + [(marks key) (continuation-mark-set-first marks key #f)] + [(marks key none-v) + (continuation-mark-set-first marks key none-v + ;; Treat `break-enabled-key` and `parameterization-key`, specially + ;; so that things like `current-break-parameterization` work without + ;; referencing the root continuation prompt tag + (if (or (eq? key break-enabled-key) + (eq? key parameterization-key)) + the-root-continuation-prompt-tag + the-default-continuation-prompt-tag))] + [(marks key none-v prompt-tag) + (check who continuation-mark-set? :or-false marks) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set-first key)]) + (let ([v (marks-search (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain)) + key + #t ; at-outer? + prompt-tag)]) + (cond + [(eq? v none) + ;; More special treatment of built-in keys + (cond + [(eq? key parameterization-key) + empty-parameterization] + [(eq? key break-enabled-key) + (current-engine-init-break-enabled-cell none-v)] + [else + none-v])] + [else (wrapper v)]))))])) + +;; To make `continuation-mark-set-first` constant-time, if we traverse +;; N elements to get an answer, then cache the answer at N/2 elements. +(define (marks-search elems key at-outer? prompt-tag) + (let loop ([elems elems] [elems/cache-pos elems] [cache-step? #f] [depth 0]) + (cond + [(or (null? elems) + (and at-outer? + (eq? (mark-chain-frame-tag (elem+cache-strip (car elems))) prompt-tag))) + ;; Not found + (cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) + none] + [else + (let ([t (car elems)] + [check-elem + (lambda (t) + (let ([v (if at-outer? + ;; Search within the metacontinuation frame: + (let ([marks (mark-chain-frame-marks t)]) + (marks-search marks key #f #f)) + ;; We're looking at just one frame: + (intmap-ref t key none))]) + (cond + [(eq? v none) + ;; Not found at this point; keep looking + (loop (cdr elems) + (if cache-step? (cdr elems/cache-pos) elems/cache-pos) + (not cache-step?) + (fx+ 1 depth))] + [else + ;; Found it + (cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) + v])))]) + (cond + [(elem+cache? t) + (let ([v (intmap-ref (elem+cache-cache t) key none2)]) + (cond + [(eq? v none2) + ;; No mapping in cache, so try the element and continue: + (check-elem (elem+cache-elem t))] + [else + (let ([v (if at-outer? + ;; strip & combine --- cache results at the metacontinuation + ;; level should depend on the prompt tag, so make the cache + ;; value another table level mapping the prompt tag to the value: + (hash-ref v prompt-tag none2) + v)]) + (cond + [(eq? v none2) + ;; Strip filtered this cache entry away, so try the element: + (check-elem (elem+cache-elem t))] + [(eq? v none) + ;; The cache records that it's not in the rest: + (cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) + none] + [else + ;; The cache provides a value from the rest: + (cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) + v]))]))] + [else + ;; Try the element: + (check-elem t)]))]))) + +;; To make `continuation-mark-set-first` constant-time, cache +;; a key--value mapping at a point that's half-way in +(define (cache-result! marks marks/cache-pos depth key v at-outer? prompt-tag) + (unless (< depth 16) + (let* ([t (car marks/cache-pos)] + [new-t (if (elem+cache? t) + t + (make-elem+cache t empty-hasheq))]) + (unless (eq? t new-t) + (set-car! marks/cache-pos new-t)) + (set-elem+cache-cache! new-t (intmap-set (elem+cache-cache new-t) + key + (if at-outer? + ;; At the metacontinuation level, cache depends on the + ;; prompt tag: + (let ([old (intmap-ref (elem+cache-cache new-t) key none2)]) + (intmap-set (if (eq? old none2) empty-hasheq old) prompt-tag v)) + v)))))) + +(define/who continuation-mark-set->list + (case-lambda + [(marks key) (continuation-mark-set->list marks key the-default-continuation-prompt-tag)] + [(marks key prompt-tag) + (check who continuation-mark-set? :or-false marks) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list key)]) + (let chain-loop ([mark-chain (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain))]) + (cond + [(null? mark-chain) + null] + [else + (let* ([mcf (elem+cache-strip (car mark-chain))]) + (cond + [(eq? (mark-chain-frame-tag mcf) prompt-tag) + null] + [else + (let loop ([marks (mark-chain-frame-marks mcf)]) + (cond + [(null? marks) + (chain-loop (cdr mark-chain))] + [else + (let* ([v (intmap-ref (elem+cache-strip (car marks)) key none)]) + (if (eq? v none) + (loop (cdr marks)) + (cons (wrapper v) (loop (cdr marks)))))]))]))]))))])) + +(define/who continuation-mark-set->list* + (case-lambda + [(marks keys) (continuation-mark-set->list* marks keys the-default-continuation-prompt-tag #f)] + [(marks keys prompt-tag) (continuation-mark-set->list* marks keys prompt-tag #f)] + [(marks keys prompt-tag none-v) + (check who continuation-mark-set? :or-false marks) + (check who list? keys) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(all-keys all-wrappers) + (map/2-values (lambda (k) + (extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list* k)) + keys)]) + (let* ([n (length all-keys)] + [tmp (make-vector n)]) + (let chain-loop ([mark-chain (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain))]) + (cond + [(null? mark-chain) + null] + [else + (let* ([mcf (elem+cache-strip (car mark-chain))]) + (cond + [(eq? (mark-chain-frame-tag mcf) prompt-tag) + null] + [else + (let loop ([marks (let ([marks (mark-chain-frame-marks mcf)]) + (if (splice-next? mark-chain) + ;; handle splicing (created by applying a composable + ;; continuation to a context that had marks already) + (append marks + (mark-chain-frame-marks (elem+cache-strip (cadr mark-chain)))) + marks))]) + (cond + [(null? marks) + (chain-loop (if (splice-next? mark-chain) + (cddr mark-chain) + (cdr mark-chain)))] + [else + (let ([t (elem+cache-strip (car marks))]) + (let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f]) + (cond + [(null? keys) + (if found? + (let ([vec (vector-copy tmp)]) + (cons vec (loop (cdr marks)))) + (loop (cdr marks)))] + [else + (let ([v (intmap-ref t (car keys) none)]) + (cond + [(eq? v none) + (vector-set! tmp i none-v) + (key-loop (cdr keys) (cdr wrappers) (add1 i) found?)] + [else + (vector-set! tmp i ((car wrappers) v)) + (key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))])) + +(define/who (continuation-mark-set->context marks) + (check who continuation-mark-set? marks) + (traces->context (continuation-mark-set-traces marks))) + +(define/who current-continuation-marks + (case-lambda + [() (current-continuation-marks the-default-continuation-prompt-tag)] + [(tag) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call/cc + (lambda (k) + (make-continuation-mark-set (prune-mark-chain-suffix (strip-impersonator tag) (current-mark-chain)) + (cons (continuation->trace k) + (get-metacontinuation-traces (current-metacontinuation))))))])) + +;; Wrapped a threads layer to handle thread arguments: +(define/who continuation-marks + (case-lambda + [(k) (continuation-marks k (default-continuation-prompt-tag))] + [(k tag) + ;; If `k` is a procedure, we assume that it's an engine + (check who (lambda (p) (or (not p) + (continuation? p) + (and (#%procedure? p) (procedure-arity-includes? p 0)))) + :contract "(or/c continuation? engine-procedure? #f)" + k) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (let ([tag (strip-impersonator tag)]) + (cond + [(#%procedure? k) + (let ([mc (saved-metacontinuation-mc (k))]) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (get-current-mark-chain #f #f mc)) + (get-metacontinuation-traces mc)))] + [(full-continuation? k) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (get-current-mark-chain (full-continuation-mark-stack k) + (full-continuation-mark-splice k) + (full-continuation-mc k))) + (cons (continuation->trace (full-continuation-k k)) + (get-metacontinuation-traces (full-continuation-mc k))))] + [(escape-continuation? k) + (unless (continuation-prompt-available? (escape-continuation-tag k)) + (raise-continuation-error '|continuation application| + "escape continuation not in the current continuation")) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (prune-mark-chain-prefix (escape-continuation-tag k) (current-mark-chain))) + null)] + [else + (make-continuation-mark-set null null)]))])) + +(define (get-metacontinuation-traces mc) + (cond + [(null? mc) '()] + [(metacontinuation-frame-traces (car mc)) + => (lambda (traces) traces)] + [else + (let ([traces + (cons (continuation->trace (metacontinuation-frame-resume-k (car mc))) + (get-metacontinuation-traces (cdr mc)))]) + (set-metacontinuation-frame-traces! (car mc) traces) + traces)])) + +;; ---------------------------------------- +;; Continuation-mark keys: impersonators, and chaperones + +(define-record-type (continuation-mark-key create-continuation-mark-key authentic-continuation-mark-key?) + (fields (mutable name))) ; `mutable` ensures that `create-...` allocates + +(define-record continuation-mark-key-impersonator impersonator (get set)) +(define-record continuation-mark-key-chaperone chaperone (get set)) + +(define make-continuation-mark-key + (case-lambda + [() (make-continuation-mark-key (gensym))] + [(name) (create-continuation-mark-key name)])) + +(define (continuation-mark-key? v) + (or (authentic-continuation-mark-key? v) + (and (impersonator? v) + (authentic-continuation-mark-key? (impersonator-val v))))) + +;; Like `intmap-set`, but handles continuation-mark-key impersonators +(define (intmap-set/cm-key ht k v) + (cond + [(and (impersonator? k) + (authentic-continuation-mark-key? (impersonator-val k))) + (let loop ([k k] [v v]) + (cond + [(or (continuation-mark-key-impersonator? k) + (continuation-mark-key-chaperone? k)) + (let ([new-v (|#%app| + (if (continuation-mark-key-impersonator? k) + (continuation-mark-key-impersonator-set k) + (continuation-mark-key-chaperone-set k)) + v)]) + (unless (or (continuation-mark-key-impersonator? k) + (chaperone-of? new-v v)) + (raise-chaperone-error 'with-continuation-mark "value" v new-v)) + (loop (impersonator-next k) new-v))] + [(impersonator? k) + (loop (impersonator-next k) v)] + [else + (intmap-set ht k v)]))] + [else (intmap-set ht k v)])) + +;; Extracts the key and converts the wrapper functions into +;; a single function: +(define (extract-continuation-mark-key-and-wrapper who k) + (cond + [(and (impersonator? k) + (authentic-continuation-mark-key? (impersonator-val k))) + (values + (impersonator-val k) + (let loop ([k k]) + (cond + [(or (continuation-mark-key-impersonator? k) + (continuation-mark-key-chaperone? k)) + (let ([get (if (continuation-mark-key-impersonator? k) + (continuation-mark-key-impersonator-get k) + (continuation-mark-key-chaperone-get k))] + [get-rest (loop (impersonator-next k))]) + (lambda (v) + (let* ([v (get-rest v)] + [new-v (|#%app| get v)]) + (unless (or (continuation-mark-key-impersonator? k) + (chaperone-of? new-v v)) + (raise-chaperone-error who "value" v new-v)) + new-v)))] + [(impersonator? k) + (loop (impersonator-next k))] + [else + (lambda (v) v)])))] + [else + (values k (lambda (v) v))])) + +(define (map/2-values f l) + (cond + [(null? l) (values '() '())] + [else + (let-values ([(a b) (f (car l))]) + (let-values ([(a-r b-r) (map/2-values f (cdr l))]) + (values (cons a a-r) (cons b b-r))))])) + +(define (impersonate-continuation-mark-key key get set . props) + (do-impersonate-continuation-mark-key 'impersonate-continuation-mark-key + key get set props + make-continuation-mark-key-impersonator)) + +(define (chaperone-continuation-mark-key key get set . props) + (do-impersonate-continuation-mark-key 'chaperone-continuation-mark-key + key get set props + make-continuation-mark-key-chaperone)) + +(define (do-impersonate-continuation-mark-key who + key get set props + make-continuation-mark-key-impersonator) + (check who continuation-mark-key? key) + (check who (procedure-arity-includes/c 1) get) + (check who (procedure-arity-includes/c 1) set) + (make-continuation-mark-key-impersonator (strip-impersonator key) + key + (add-impersonator-properties who + props + (if (impersonator? key) + (impersonator-props key) + empty-hasheq)) + get + set)) + +;; ---------------------------------------- +;; Continuation prompt tags: impersonators, and chaperones + +(define (continuation-prompt-tag? v) + (or (authentic-continuation-prompt-tag? v) + (and (impersonator? v) + (authentic-continuation-prompt-tag? (impersonator-val v))))) + +(define-record continuation-prompt-tag-impersonator impersonator (procs)) +(define-record continuation-prompt-tag-chaperone chaperone (procs)) + +(define-record continuation-prompt-tag-procs (handler abort cc-guard cc-impersonate)) + +(define (continuation-prompt-tag-impersonator-or-chaperone? tag) + (or (continuation-prompt-tag-impersonator? tag) + (continuation-prompt-tag-chaperone? tag))) + +(define (continuation-prompt-tag-impersonator-or-chaperone-procs tag) + (if (continuation-prompt-tag-impersonator? tag) + (continuation-prompt-tag-impersonator-procs tag) + (continuation-prompt-tag-chaperone-procs tag))) + +(define (impersonate-prompt-tag tag handler abort . args) + (do-impersonate-prompt-tag 'impersonate-prompt-tag tag handler abort args + make-continuation-prompt-tag-impersonator)) + +(define (chaperone-prompt-tag tag handler abort . args) + (do-impersonate-prompt-tag 'chaperone-prompt-tag tag handler abort args + make-continuation-prompt-tag-chaperone)) + + +(define (do-impersonate-prompt-tag who tag handler abort args + make-continuation-prompt-tag-impersonator) + (check who continuation-prompt-tag? tag) + (check who procedure? handler) + (check who procedure? abort) + (let* ([cc-guard (and (pair? args) + (procedure? (car args)) + (car args))] + [args (if cc-guard (cdr args) args)] + [callcc-impersonate (and (pair? args) + (procedure? (car args)) + (car args))] + [args (if callcc-impersonate (cdr args) args)]) + (when callcc-impersonate + (check who (procedure-arity-includes/c 1) callcc-impersonate)) + (make-continuation-prompt-tag-impersonator + (strip-impersonator tag) + tag + (add-impersonator-properties who + args + (if (impersonator? tag) + (impersonator-props tag) + empty-hasheq)) + (make-continuation-prompt-tag-procs handler abort cc-guard (or callcc-impersonate values))))) + +(define (apply-prompt-tag-interposition who at-when what + wrapper args chaperone?) + (call-with-values (lambda () (apply wrapper args)) + (lambda new-args + (unless (= (length args) (length new-args)) + (raise-result-arity-error #f (length args) (string-append "\n at: " at-when) new-args)) + (when chaperone? + (for-each (lambda (arg new-arg) + (unless (chaperone-of? new-arg arg) + (raise-chaperone-error who what arg new-arg))) + args new-args)) + new-args))) + +(define (wrap-handler-for-impersonator tag handler) + (let loop ([tag tag]) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([handler (loop (impersonator-next tag))] + [h (continuation-prompt-tag-procs-handler + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (lambda args + (apply handler + (apply-prompt-tag-interposition 'call-with-continuation-prompt + "use of prompt-handler redirecting procedure" + "prompt-handler argument" + h args chaperone?))))] + [(impersonator? tag) + (loop (impersonator-next tag))] + [else handler]))) + +(define (apply-impersonator-abort-wrapper tag args) + (let loop ([tag tag] [args args]) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([a (continuation-prompt-tag-procs-abort + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (loop (impersonator-next tag) + (apply-prompt-tag-interposition 'abort-current-continuation + "use of prompt-abort redirecting procedure" + "prompt-abort argument" + a args chaperone?)))] + [(impersonator? tag) + (loop (impersonator-next tag) args)] + [else args]))) + +(define (activate-and-wrap-cc-guard-for-impersonator! tag) + (assert-in-uninterrupted) + (current-metacontinuation + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) mc] + [(eq? (strip-impersonator tag) + (strip-impersonator (metacontinuation-frame-tag (car mc)))) + (let* ([mf (car mc)] + [mf-tag (metacontinuation-frame-tag mf)] + [mf-cc-guard (metacontinuation-frame-cc-guard mf)]) + (cond + [(or (continuation-prompt-tag-impersonator-or-chaperone? tag) + (and (continuation-prompt-tag-impersonator-or-chaperone? mf-tag) + (not mf-cc-guard))) + (cons (metacontinuation-frame-update-cc-guard + mf + (wrap-cc-guard-for-impersonator tag + (or mf-cc-guard + (compose-cc-guard-for-impersonator mf-tag values)))) + (cdr mc))] + [else mc]))] + [else + (let ([r (loop (cdr mc))]) + (if (eq? r (cdr mc)) + mc + (cons (car mc) r)))])))) + +(define (compose-cc-guard-for-impersonator tag guard) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([cc-guard (continuation-prompt-tag-procs-cc-guard + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (let ([guard (compose-cc-guard-for-impersonator (impersonator-next tag) + guard)]) + (cond + [cc-guard + (lambda args + (apply guard + (apply-prompt-tag-interposition 'call-with-continuation-prompt + "use of `call/cc` result guard" + "prompt-result argument" + cc-guard args chaperone?)))] + [else guard])))] + [(impersonator? tag) + (compose-cc-guard-for-impersonator (impersonator-next tag) guard)] + [else guard])) + +(define (wrap-cc-guard-for-impersonator tag cc-guard) + (assert-in-uninterrupted) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([cc-impersonate (continuation-prompt-tag-procs-cc-impersonate + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (let ([cc-guard (wrap-cc-guard-for-impersonator (impersonator-next tag) cc-guard)]) + (let ([new-cc-guard (call-with-continuation-barrier + (lambda () + (end-uninterrupted 'cc-guard) + (begin0 + (|#%app| cc-impersonate cc-guard) + (start-uninterrupted 'cc-guard))))]) + (when chaperone? + (unless (chaperone-of? new-cc-guard cc-guard) + (raise-chaperone-error 'call-with-current-continuation + "continuation-result guard" + cc-guard + new-cc-guard))) + new-cc-guard)))] + [(impersonator? tag) + (wrap-cc-guard-for-impersonator (impersonator-next tag) cc-guard)] + [else cc-guard])) + +;; ---------------------------------------- + +(define-virtual-register current-winders '()) + +(define-record winder (depth k pre post mark-stack)) + +;; Jobs for `dynamic-wind`: + +;; 1. Set the mark stack on entry and exit to the saved mark stack. +;; The saved mark stack is confined to the current metacontinuation +;; frame, so it's ok to use it if the current continuation is later +;; applied to a different metacontinuation. + +;; 2. Start and end uninterrupted regions on the boundaries of +;; transitions between thunks. + +;; 3. Perform a built-in `(parameterize-break #f ...)` around the pre +;; and post thunks. This break parameterization needs to be built +;; in so that it's put in place before exiting the uninterrupted region, +;; but it assumes a particular implementation of break +;; parameterizations. + +(define (dynamic-wind pre thunk post) + ((call/cc + (lambda (k) + (let* ([winders (current-winders)] + [winder (make-winder (if (null? winders) + 0 + (fx+ 1 (winder-depth (car winders)))) + k + pre + post + (current-mark-stack))]) + (start-uninterrupted 'dw) + (begin + (call-winder-thunk 'dw-pre pre) + (current-winders (cons winder winders)) + (end-uninterrupted/call-hook 'dw-body) + (call-with-values thunk + (lambda args + (start-uninterrupted 'dw-body) + (current-winders winders) + (call-winder-thunk 'dw-post post) + (end-uninterrupted/call-hook 'dw) + (lambda () (apply values args)))))))))) + +(define (call-winder-thunk who thunk) + (call/cm/nontail + break-enabled-key (make-thread-cell #f #t) + (lambda () + (end-uninterrupted who) + (thunk) + (start-uninterrupted who)))) + +(define (wind-in winders k) + (do-wind 'dw-pre winders winder-pre k)) + +(define (wind-out k) + (do-wind 'dw-post (current-winders) winder-post k)) + +(define (do-wind who winders winder-thunk k) + (assert-in-uninterrupted) + (let ([winder (car winders)] + [winders (cdr winders)]) + (current-winders winders) + (current-mark-stack (winder-mark-stack winder)) + (let ([thunk (winder-thunk winder)]) + ((winder-k winder) + (lambda () + (call-winder-thunk who thunk) + (k)))))) + +(define (wind-to dest-winders done-k retry-k) + (let ([starting-metacontinuation (current-metacontinuation)]) + (let loop ([rev-dest-winders-head '()] + [dest-winders-tail dest-winders]) + (cond + [(and retry-k + (not (eq? starting-metacontinuation (current-metacontinuation)))) + (retry-k)] + [else + (let ([winders (current-winders)]) + (cond + [(same-winders? winders dest-winders-tail) + ;; No winders to leave + (cond + [(null? rev-dest-winders-head) + (done-k)] + [else + ;; Go in one winder + (let ([new-winders (cons (car rev-dest-winders-head) winders)] + [rev-dest-winders-head (cdr rev-dest-winders-head)]) + (wind-in new-winders + (lambda () + (current-winders new-winders) + (loop rev-dest-winders-head new-winders))))])] + [(or (null? dest-winders-tail) + (and (pair? winders) + (> (winder-depth (car winders)) (winder-depth (car dest-winders-tail))))) + ;; Go out by one winder + (wind-out (lambda () (loop rev-dest-winders-head dest-winders-tail)))] + [else + ;; Move a dest winder from tail to head: + (loop (cons (car dest-winders-tail) rev-dest-winders-head) + (cdr dest-winders-tail))]))])))) + +(define (same-winders? winders dest-winders-tail) + (or (and (null? winders) + (null? dest-winders-tail)) + (and (pair? winders) + (pair? dest-winders-tail) + (eq? (car winders) (car dest-winders-tail))))) + +;; ---------------------------------------- + +(define (raise-continuation-error who msg) + (raise + (|#%app| + exn:fail:contract:continuation + (string-append (symbol->string who) ": " msg) + (current-continuation-marks)))) + +;; ---------------------------------------- +;; Breaks + +(define (call-with-break-disabled thunk) + (call/cm + break-enabled-key (make-thread-cell #f #t) + thunk)) + +;; Some points where we jump out of uninterrupted mode are also points +;; where we might jump to a context where breaks are allowed. The +;; `continuation-mark-change-hook` function allows a thread scheduler to +;; inject a check at those points. +(define (end-uninterrupted/call-hook who) + (end-uninterrupted who) + (break-enabled-transition-hook)) + +(define break-enabled-transition-hook void) + +(define (set-break-enabled-transition-hook! proc) + (set! break-enabled-transition-hook proc)) + +;; ---------------------------------------- +;; Metacontinuation swapping for engines + +(define-record saved-metacontinuation (mc system-winders exn-state)) + +(define empty-metacontinuation (make-saved-metacontinuation '() '() (create-exception-state))) + +;; Similar to `call-with-current-continuation` plus +;; applying an old continuation, but does not run winders; +;; this operation makes sense for thread or engine context +;; switches +(define (swap-metacontinuation saved proc) + (cond + [(current-system-wind-start-k) + => (lambda (k) (swap-metacontinuation-with-system-wind saved proc k))] + [else + (call-in-empty-metacontinuation-frame + #f + fail-abort-to-delimit-continuation + #f ; don't try to shift continuation marks + (lambda () + (let ([now-saved (make-saved-metacontinuation + (current-metacontinuation) + (#%$current-winders) + (current-exception-state))]) + (current-metacontinuation (saved-metacontinuation-mc saved)) + (#%$current-winders (saved-metacontinuation-system-winders saved)) + (current-exception-state (saved-metacontinuation-exn-state saved)) + (current-empty-k #f) + (set! saved #f) ; break link for space safety + (proc now-saved))))])) + +;; ---------------------------------------- + +;; In "system-wind" mode for the current metacontinuation frame, run +;; the frame's winders when jumping out of the frame or back in, +;; because the frame uses host-Scheme parameters and/or `fluid-let`. +;; For example, jumping out/in the host compiler needs to save/restore +;; compiler state. +(define-virtual-register current-system-wind-start-k #f) + +;; During `call-with-system-wind`, the current metacontinuation frame +;; must remain as the most recent one, so that `swap-metacontinuation` +;; can capture the system-wind part +(define (call-with-system-wind proc) + ((call/cc + (lambda (k) + (current-system-wind-start-k k) + (#%dynamic-wind + void + (lambda () + (call-with-values + proc + (lambda args + (lambda () + (apply values args))))) + (lambda () (current-system-wind-start-k #f))))))) + +(define (swap-metacontinuation-with-system-wind saved proc start-k) + (current-system-wind-start-k #f) + (call/cc + (lambda (system-wind-k) ; continuation with system `dynamic-wind` behavior + ;; escape to starting point, running winders, before + ;; capturing the rest of the metacontinuation: + (start-k (lambda () + (let ([prefix (swap-metacontinuation saved proc)]) + (current-system-wind-start-k start-k) + (system-wind-k prefix))))))) + +(define (assert-not-in-system-wind) + (CHECK-uninterrupted + (when (current-system-wind-start-k) + (internal-error 'not-in-system-wind "assertion failed")))) diff -Nru racket-6.12+ppa1/src/cs/rumble/correlated.ss racket-7.0+ppa1/src/cs/rumble/correlated.ss --- racket-6.12+ppa1/src/cs/rumble/correlated.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/correlated.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,102 @@ + +;; This correlated-like layer is meant to be for just source locations +;; and properties that the compiler might inspect. It's exported as +;; `correlated?`, etc., from `racket/linklet`, but as `syntax?`, etc. +;; from '#%kernel. + +;; Unlike the real syntax-object layer, a correlated object is not +;; required to have correlated objects inside. + +(define-record correlated (e srcloc props)) + +(define/who (datum->correlated ignored datum src) + (check who + :test (or (not src) (correlated? src) (srcloc? src) (encoded-srcloc? src)) + :contract (string-append "(or #f syntax? srcloc?\n" + " (list/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f))\n" + " (vector/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)))") + src) + (if (correlated? datum) + datum + (make-correlated datum (extract-srcloc src) empty-hasheq))) + +(define (correlated->datum e) + (cond + [(correlated? e) (correlated->datum (correlated-e e))] + [(pair? e) (let ([a (correlated->datum (car e))] + [d (correlated->datum (cdr e))]) + (if (and (eq? a (car e)) + (eq? d (cdr e))) + e + (cons a d)))] + [else e])) + +(define/who (correlated-property-symbol-keys v) + (check who correlated? v) + (hash-map (correlated-props v) (lambda (k v) k))) + +(define/who correlated-property + (case-lambda + [(v k) + (check who correlated? v) + (hash-ref (correlated-props v) k #f)] + [(v k val) + (check who correlated? v) + (make-correlated (correlated-e v) + (correlated-srcloc v) + (hash-set (correlated-props v) k val))])) + +(define/who (correlated-srcloc-field who v srcloc-x) + (check who correlated? v) + (let ([s (correlated-srcloc v)]) + (and s (srcloc-x s)))) + +(define (correlated-source v) + (correlated-srcloc-field 'correlated-source v srcloc-source)) +(define (correlated-line v) + (correlated-srcloc-field 'correlated-line v srcloc-line)) +(define (correlated-column v) + (correlated-srcloc-field 'correlated-column v srcloc-column)) +(define (correlated-position v) + (correlated-srcloc-field 'correlated-position v srcloc-position)) +(define (correlated-span v) + (correlated-srcloc-field 'correlated-span v srcloc-span)) + +(define (encoded-srcloc? v) + (or (and (list? v) + (= (length v) 5) + (srcloc-vector? (list->vector v))) + (and (vector? v) + (= (vector-length v) 5) + (srcloc-vector? v)))) + +(define (srcloc-vector? v) + (and (or (not (vector-ref v 1)) + (exact-positive-integer? (vector-ref v 1))) + (or (not (vector-ref v 2)) + (exact-nonnegative-integer? (vector-ref v 2))) + (or (not (vector-ref v 3)) + (exact-positive-integer? (vector-ref v 3))) + (or (not (vector-ref v 4)) + (exact-nonnegative-integer? (vector-ref v 4))))) + +(define (extract-srcloc src) + (cond + [(not src) #f] + [(correlated? src) (correlated-srcloc src)] + [(vector? src) (|#%app| + srcloc + (vector-ref src 0) + (vector-ref src 1) + (vector-ref src 2) + (vector-ref src 3) + (vector-ref src 4))] + [else (apply srcloc src)])) diff -Nru racket-6.12+ppa1/src/cs/rumble/datum.ss racket-7.0+ppa1/src/cs/rumble/datum.ss --- racket-6.12+ppa1/src/cs/rumble/datum.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/datum.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +(define datums (make-weak-hash)) + +(define intern-regexp? #f) +(define (set-intern-regexp?! p) (set! intern-regexp? p)) + +(define (datum-intern-literal v) + (cond + [(or (and (number? v) + ;; `eq?` doesn't work on flonums + (not (flonum? v))) + (string? v) + (char? v) + (bytes? v) + (intern-regexp? v)) + (with-interrupts-disabled + (or (weak-hash-ref-key datums v) + (let ([v (cond + [(string? v) (string->immutable-string v)] + [(bytes? v) (bytes->immutable-bytes v)] + [else v])]) + (hash-set! datums v #t) + v)))] + [else v])) diff -Nru racket-6.12+ppa1/src/cs/rumble/define.ss racket-7.0+ppa1/src/cs/rumble/define.ss --- racket-6.12+ppa1/src/cs/rumble/define.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/define.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,480 @@ +;; Replace `define` to perform simple function lifting, which avoids +;; having to allocate closures for local loops (i.e., a more +;; Racket-like allocation model). Since it only has to work for +;; Rumble's implementation, the lifter doesn't have to be general or +;; scalable. The lifter transforms unexpanded source expressions, so +;; it needs to recognize all of the forms that are used inside +;; `define` forms. + +;; Only functions bound with named `let`, normal `let` with `lambda`, +;; and `let*` with `lamdba` are lifted, and the lifter assumes that a +;; named `let`'s identifier is used only in application position. +;; Local `define` is not allowed. + +;; To bind a `let`-bound function that is not used only in an +;; application position, wrap it with `escapes-ok`. + +;; If a function F includes a call to a function G, function G has a +;; free variable X, and function F has an argument X, then the lifter +;; doesn't work (and it reports an error). Help the lifter in that +;; case by picking a different name for one of the Xs. + +;; If a "loop" is a non-tail loop or if has many free variables, then +;; lifting may be counterproductive (by making a bad trade for less +;; allocation but slower GCs). Use `define/no-lift` in that case. + +;; Select `define/lift` as the default mode: +(define-syntax (define stx) + (syntax-case stx () + [(_ . r) #'(define/lift . r)])) + +(define-syntax (define/lift stx) + (letrec ([lift-local-functions + ;; Convert `e` to return + ;; (list new-list (list lifted-defn ...)) + ;; The `env` argument is a list of symbols (not identifiers), + ;; and the `binds` argument is a list of syntax bindings + ;; #`(bind-form ([id rhs] ...)) + ;; to be copied over to any lifted form. Also, the `rhs` + ;; of a `bind-form` can contain free-variable and + ;; called-variable information for a previously lifted + ;; function, so that its free variables can be added + ;; as needed to a newly lifted function that calls the + ;; lifted one. + ;; Earlier entries in `binds` shadow later ones, and + ;; entires in `env` shadow `binds` entries. + (lambda (e env binds mutated) + (syntax-case e (quote begin lambda case-lambda + let letrec let* let-values + fluid-let-syntax let-syntax + cond define set!) + [(define . _) + (syntax-error e "don't use nested `define`:")] + [(quote _) + (list e '())] + [(begin e) + (lift-local-functions #'e env binds mutated)] + [(seq e ...) + (and (symbol? (syntax->datum #'seq)) + (or (free-identifier=? #'seq #'begin) + (free-identifier=? #'seq #'begin0) + (free-identifier=? #'seq #'if))) + (with-syntax ([((new-e lifts) ...) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + #'(e ...))]) + (list #'(seq new-e ...) + (append-all #'(lifts ...))))] + [(lambda args e ...) + (with-syntax ([(body lifts) + (lift-local-functions #'(begin e ...) + (add-args env #'args) + binds + mutated)]) + #`((lambda args body) + lifts))] + [(case-lambda [args e ...] ...) + (with-syntax ([((body lifts) ...) + (map (lambda (args body) + (lift-local-functions body + (add-args env args) + binds + mutated)) + #'(args ...) + #'((begin e ...) ...))]) + (list #'(case-lambda [args body] ...) + (append-all #'(lifts ...))))] + [(let loop ([arg val] ...) e ...) + (symbol? (syntax->datum #'loop)) + (generate-lifted env binds mutated + #'loop ; name + #'(arg ...) ; argument names + #'(begin e ...) ; body + #t ; recursive + (lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted) + (with-syntax ([(free-var ...) free-vars] + [new-loop-name new-loop-name] + [defn-to-lift defn-to-lift]) + #`((new-loop-name val ... free-var ...) + (defn-to-lift)))))] + [(let* () e ...) + (lift-local-functions #`(begin e ...) env binds mutated)] + [(let* ([id rhs] . more-binds) e ...) + (lift-local-functions #`(let ([id rhs]) (let* more-binds e ...)) env binds mutated)] + [(let . _) + (lift-local-functions-in-let/lift-immediate e env binds mutated)] + [(letrec . _) + (lift-local-functions-in-let e env binds mutated #t)] + [(let-values ([(id ...) rhs] ...) e ...) + (with-syntax ([((new-rhs lifts) ...) + (map (lambda (rhs) + (lift-local-functions rhs env binds mutated)) + #'(rhs ...))]) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (add-args env (#%apply append #'((id ...) ...))) + binds + mutated)]) + (list #'(let-values ([(id ...) new-rhs] ...) new-body) + (append #'body-lifts (append-all #'(lifts ...))))))] + [(fluid-let-syntax ([id rhs] ...) e ...) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (remove-args env #'(id ...)) + (cons #'(fluid-let-syntax ([id rhs] ...)) + binds) + mutated)]) + #`((fluid-let-syntax ([id rhs] ...) new-body) + body-lifts))] + [(let-syntax ([id rhs] ...) e ...) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (remove-args env #'(id ...)) + (cons #'(let-syntax ([id rhs] ...)) + binds) + mutated)]) + #`((let-syntax ([id rhs] ...) new-body) + body-lifts))] + [(cond [e ...] ...) + (with-syntax ([(((new-e lifts) ...) ...) + (map (lambda (es) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + es)) + #'((e ...) ...))]) + (list #'(cond [new-e ...] ...) + (append-all (append-all #'((lifts ...) ...)))))] + [(set! id rhs) + (track-mutated! mutated #'id 'mutated) + (with-syntax ([(new-rhs lifts) (lift-local-functions #'rhs env binds mutated)]) + #'((set! id new-rhs) + lifts))] + [(rator rand ...) + (with-syntax ([((new-e lifts) ...) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + #'(rator rand ...))]) + (list #'(new-e ...) + (append-all #'(lifts ...))))] + [_ (list e '())]))] + + [lift-local-functions-in-let + (lambda (e env binds mutated rec?) + (syntax-case e () + [(form ([id rhs] ...) e ...) + (let ([body-env (add-args env #'(id ...))]) + (with-syntax ([((new-rhs lifts) ...) + (map (lambda (rhs) + (lift-local-functions rhs (if rec? body-env env) binds mutated)) + #'(rhs ...))]) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) body-env binds mutated)]) + (list #'(form ([id new-rhs] ...) new-body) + (append #'body-lifts (append-all #'(lifts ...)))))))]))] + + [lift-local-functions-in-let/lift-immediate + ;; Split `lambda` bindings for other bindings, then lift the `lambda`s + (lambda (e env binds mutated) + (syntax-case e () + [(form ([id rhs] ...) . body) + (let ([body-env (add-args env #'(id ...))]) + (let-values ([(proc-binds other-binds) + (split-proc-binds #'([id rhs] ...))]) + (cond + [(null? proc-binds) + (lift-local-functions-in-let e env binds mutated #f)] + [else + (let loop ([proc-binds proc-binds] + [e (with-syntax ([other-binds other-binds]) + #'(form other-binds . body))] + [lifts '()]) + (cond + [(null? proc-binds) + (with-syntax ([(new-e e-lifts) (lift-local-functions e env binds mutated)]) + (list #'new-e + (append lifts #'e-lifts)))] + [else + (with-syntax ([[id (_ rhs-args rhs-e ...)] (car proc-binds)]) + (generate-lifted + env binds mutated + #'id ; name + #'rhs-args ; argument names + #'(begin rhs-e ...) ; body + #f ; not recursive + (lambda (defn-to-lift new-id free-vars wrap-bind-of-lifted) + (loop (cdr proc-binds) + (wrap-bind-of-lifted e) + (cons defn-to-lift lifts)))))]))])))]))] + + [split-proc-binds + ;; Helper to split `lambda` from non-`lambda` + (lambda (form-binds) + (let loop ([binds form-binds] [proc-binds '()] [other-binds '()]) + (cond + [(null? binds) + (values (reverse proc-binds) + (reverse other-binds))] + [else + (syntax-case (car binds) (lambda) + [[_ (lambda (arg ...) . _)] + (loop (cdr binds) + (cons (car binds) proc-binds) + other-binds)] + [_ + (loop (cdr binds) + proc-binds + (cons (car binds) other-binds))])])))] + + [generate-lifted + ;; Takes pieces for a function to lift an generates the lifted version + (lambda (env binds mutated name args body rec? k) + (let* ([ids (if rec? (cons name args) args)] + [binds (filter-shadowed-binds binds (add-args env ids))] + [body-env (remove-args env ids)] + [direct-free-vars (extract-free-vars body body-env)] + [direct-called-vars (extract-free-vars body (binds-to-env binds))]) + (for-each (lambda (free-var) (track-mutated! mutated free-var 'must-not)) direct-free-vars) + (let-values ([(free-vars called-vars) (extract-bind-vars binds body-env direct-free-vars direct-called-vars)]) + (let ([free-vars (unique-ids free-vars)] + [called-vars (unique-ids called-vars)]) + (with-syntax ([(free-var ...) free-vars] + [(called-var ...) called-vars] + [new-name (datum->syntax + name + (chez:gensym (chez:symbol->string (syntax->datum name))))] + [body (let loop ([body body] + [binds binds]) + (cond + [(null? binds) body] + [else (with-syntax ([(form form-binds) (car binds)] + [body body]) + (loop #'(form form-binds body) + (cdr binds)))]))] + [name name] + [(arg ...) args]) + (let ([wrap-bind-of-lifted + (lambda (body) + (with-syntax ([body body]) + #'(let-syntax ([name (begin ; this pattern is recognized by `extract-bind-free-vars` + '(FREE-VARS free-var ...) + '(CALLED-VARS called-var ...) + (lambda (stx) + (syntax-case stx () + [(_ call-arg (... ...)) + #'(new-name call-arg (... ...) free-var ...)] + [_ (syntax-error stx "lifted procedure escapes:")])))]) + body)))]) + (with-syntax ([wrapped-body (if rec? + (wrap-bind-of-lifted #'body) + #'body)]) + (k #`(define/lift new-name + (lambda (arg ... free-var ...) + wrapped-body)) + #'new-name + free-vars + wrap-bind-of-lifted))))))))] + + [extract-free-vars + ;; For an expression that is going to be lifted, find all the free + ;; variables so they can be added to call sites of the enclosing + ;; lifted function. Only variables in `env` are candidate free + ;; variables. + (lambda (e env) + (syntax-case e (quote begin lambda case-lambda + let* let letrec let-values + fluid-let-syntax let-syntax + set!) + [id + (symbol? (syntax->datum #'id)) + (if (chez:memq (syntax->datum #'id) env) + (list #'id) + '())] + [(set! id rhs) + (if (chez:memq (syntax->datum #'id) env) + (syntax-error #'id "cannot mutate variable added to lifted procedure:") + (extract-free-vars #'rhs env))] + [(quote _) '()] + [(seq e ...) + (and (symbol? (syntax->datum #'seq)) + (or (free-identifier=? #'seq #'begin) + (free-identifier=? #'seq #'begin0) + (free-identifier=? #'seq #'if) + (free-identifier=? #'seq #'cond))) + (#%apply append (map (lambda (e) + (extract-free-vars e env)) + #'(e ...)))] + [(lambda args e ...) + (extract-free-vars #'(begin e ...) + (remove-args env #'args))] + [(case-lambda [args e ...] ...) + (#%apply + append + (map (lambda (args body) + (extract-free-vars body (remove-args env args))) + #'(args ...) + #'((begin e ...) ...)))] + [(let loop ([arg val] ...) e ...) + (symbol? (syntax->datum #'loop)) + (append + (extract-free-vars #'(begin val ...) env) + (extract-free-vars #'(begin e ...) + (remove-args env #'(loop arg ...))))] + [(let* () e ...) + (extract-free-vars #`(begin e ...) env)] + [(let* ([id rhs] . binds) e ...) + (extract-free-vars #`(let ([id rhs]) (let* binds e ...)) env)] + [(let ([id rhs] ...) e ...) + (append + (extract-free-vars #'(begin rhs ...) env) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...))))] + [(let-values ([(id ...) rhs] ...) e ...) + (append + (extract-free-vars #'(begin rhs ...) env) + (extract-free-vars #'(begin e ...) (remove-args env (#%apply append #'((id ...) ...)))))] + [(letrec ([id rhs] ...) e ...) + (extract-free-vars #'(begin rhs ... e ...) (remove-args env #'(id ...)))] + [(fluid-let-syntax ([id rhs] ...) e ...) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))] + [(let-syntax ([id rhs] ...) e ...) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))] + [(rator rand ...) + (extract-free-vars #'(begin rator rand ...) env)] + [_ '()]))] + + [filter-shadowed-binds + ;; Simplify `binds` to drop bindings that are shadowned by + ;; `env` or by earlier bindings + (lambda (binds env) + (let loop ([binds binds] + [env env]) + (cond + [(null? binds) '()] + [else (with-syntax ([(form ([id rhs] ...)) (car binds)]) + (with-syntax ([([id rhs] ...) + ;; Filter any `ids` that are shadowed + (let loop ([ids #'(id ...)] [rhss #'(rhs ...)]) + (cond + [(null? ids) '()] + [(chez:memq (syntax->datum (car ids)) env) + (loop (cdr ids) (cdr rhss))] + [else (cons (list (car ids) (car rhss)) + (loop (cdr ids) (cdr rhss)))]))]) + (cons #'(form ([id rhs] ...)) + (loop (cdr binds) + (add-args env #'(id ...))))))])))] + + [binds-to-env + ;; Extract the identifiers of `binds` into an environment + (lambda (binds) + (let loop ([binds binds] [env '()]) + (cond + [(null? binds) env] + [else + (loop (cdr binds) + (syntax-case (car binds) () + [(form ([id rhs] ...)) + (add-args env #'(id ...))]))])))] + + [extract-bind-vars + ;; Add new variables to `free-vars` and `called-vars` based on + ;; entries in `all-binds` that will be called (because they're + ;; referenced in `called-vars`). A fixpoint calculation is needed, + ;; since calling a lifted function may add new free variables and + ;; new called variables. + (lambda (all-binds env free-vars called-vars) + (let loop ([binds all-binds] [added? #f] [free-vars free-vars] [called-vars called-vars] [did-ids '()]) + (cond + [(null? binds) (if added? + ;; Loop to fixpoint + (loop all-binds #f free-vars called-vars did-ids) + ;; Found fixpoint + (values free-vars called-vars))] + [else (syntax-case (car binds) (FREE-VARS CALLED-VARS begin quote) + [(form ([id (begin + '(FREE-VARS free-var ...) + '(CALLED-VARS called-var ...) + _)])) + (and (id-member? #'id called-vars) + (not (chez:memq (syntax->datum #'id) did-ids))) + (loop (cdr binds) + #t + (append (#%map (lambda (free-var) + (if (chez:memq (syntax->datum free-var) env) + free-var + (syntax-error free-var "wrong variable at call site; lifter needs your help by renaming:"))) + #'(free-var ...)) + free-vars) + (append #'(called-var ...) + called-vars) + (cons (syntax->datum #'id) did-ids))] + [_ + ;; Not a lifted-function binding + (loop (cdr binds) added? free-vars called-vars did-ids)])])))] + + [add-args + ;; Add identifiers (accomdating rest args) to an environment + (lambda (env args) + (let add-args ([env env] [args (syntax->datum args)]) + (cond + [(null? args) env] + [(pair? args) (add-args (cons (car args) env) + (cdr args))] + [else (cons args env)])))] + + [remove-args + ;; Remove identifiers (accomdating rest args) from an environment + (lambda (env args) + (let remove-args ([env env] [args (syntax->datum args)]) + (cond + [(null? args) env] + [(pair? args) (remove-args (#%remq (car args) env) + (cdr args))] + [else (#%remq args env)])))] + + [track-mutated! + (lambda (mutated id state) + (let ([old-state (hashtable-ref mutated (syntax->datum id) #f)]) + (when (and old-state + (not (eq? old-state state))) + (syntax-error id "lift seems to need to close over mutated variable:")) + (hashtable-set! mutated (syntax->datum id) state)))] + + [unique-ids + (lambda (l) + (let loop ([l l]) + (cond + [(null? l) '()] + [(id-member? (car l) (cdr l)) + (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))])))] + + [id-member? + (lambda (id l) + (let loop ([l l]) + (cond + [(null? l) #f] + [else (or (free-identifier=? id (car l)) + (loop (cdr l)))])))] + + [append-all + (lambda (l) + (#%apply append l))]) + + ;; Traverse the right-hand side of a definition to extract lifts + (syntax-case stx () + [(_ (id . args) e ...) + #'(define/lift id (lambda args e ...))] + [(_ id rhs) + (with-syntax ([(new-rhs (lift ...)) (lift-local-functions + #'rhs + '() + '() + (make-eq-hashtable))]) + #'(define/no-lift id + (let () + lift ... + new-rhs)))]))) + +(define-syntax (escapes-ok stx) + (syntax-case stx () + [(_ e) #'e])) diff -Nru racket-6.12+ppa1/src/cs/rumble/engine.ss racket-7.0+ppa1/src/cs/rumble/engine.ss --- racket-6.12+ppa1/src/cs/rumble/engine.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/engine.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,151 @@ +;; Like Chez's engine API, but +;; - works with delimited-continuations extensions in "control.ss" +;; - doesn't run winders when suspending or resuming an engine +;; - accepts an extra "prefix" argument to run code within an engine +;; just before resuming the engine's continuation + +;; Don't mix Chez engines with this implementation, because we take +;; over the timer. + +(define-record engine-state (mc complete expire thread-cell-values init-break-enabled-cell reset-handler)) + +(define-virtual-register current-engine-state #f) + +(define (set-ctl-c-handler! proc) + (keyboard-interrupt-handler (case-lambda + [() (proc 'break)] + [(kind) (proc kind)]))) +(define (get-ctl-c-handler) + (keyboard-interrupt-handler)) + +(define (engine-exit v) + (chez:exit v)) + +(define (set-engine-exit-handler! proc) + (set! engine-exit proc)) + +(define (make-engine thunk init-break-enabled-cell empty-config?) + (let ([paramz (if empty-config? + empty-parameterization + (current-parameterization))]) + (create-engine empty-metacontinuation + (lambda (prefix) + (with-continuation-mark + parameterization-key paramz + (begin + (prefix) + (call-with-values (lambda () (|#%app| thunk)) engine-return)))) + (if empty-config? + (make-empty-thread-cell-values) + (new-engine-thread-cell-values)) + init-break-enabled-cell))) + +(define (create-engine to-saves proc thread-cell-values init-break-enabled-cell) + (case-lambda + ;; For `continuation-marks`: + [() to-saves] + ;; Normal engine case: + [(ticks prefix complete expire) + (start-implicit-uninterrupted 'create) + ((swap-metacontinuation + to-saves + (lambda (saves) + (current-engine-state (make-engine-state saves complete expire thread-cell-values + init-break-enabled-cell (reset-handler))) + (reset-handler (lambda () + (end-uninterrupted 'reset) + (if (current-engine-state) + (engine-return (void)) + (chez:exit)))) + (timer-interrupt-handler engine-block-via-timer) + (end-implicit-uninterrupted 'create) + (set-timer ticks) + (proc prefix))))])) + +(define (engine-block-via-timer) + (cond + [(current-in-uninterrupted) + (pending-interrupt-callback engine-block)] + [else + (engine-block)])) + +(define (engine-block) + (assert-not-in-uninterrupted) + (timer-interrupt-handler void) + (let ([es (current-engine-state)]) + (unless es + (error 'engine-block "not currently running an engine")) + (reset-handler (engine-state-reset-handler es)) + (start-implicit-uninterrupted 'block) + ;; Extra pair of parens around swap is to apply a prefix + ;; function on swapping back in: + ((swap-metacontinuation + (engine-state-mc es) + (lambda (saves) + (end-implicit-uninterrupted 'block) + (current-engine-state #f) + (lambda () ; returned to the `swap-continuation` in `create-engine` + ((engine-state-expire es) + (create-engine + saves + (lambda (prefix) prefix) ; returns `prefix` to the above "((" + (engine-state-thread-cell-values es) + (engine-state-init-break-enabled-cell es))))))))) + +(define (engine-return . args) + (assert-not-in-uninterrupted) + (timer-interrupt-handler void) + (let ([es (current-engine-state)]) + (unless es + (error 'engine-return "not currently running an engine")) + (reset-handler (engine-state-reset-handler es)) + (let ([remain-ticks (set-timer 0)]) + (start-implicit-uninterrupted 'return) + (swap-metacontinuation + (engine-state-mc es) + (lambda (saves) + (current-engine-state #f) + (end-implicit-uninterrupted 'return) + (lambda () ; returned to the `swap-continuation` in `create-engine` + (apply (engine-state-complete es) remain-ticks args))))))) + +(define (make-empty-thread-cell-values) + (make-ephemeron-eq-hashtable)) + +(define root-thread-cell-values (make-empty-thread-cell-values)) + +(define (current-engine-thread-cell-values) + (let ([es (current-engine-state)]) + (if es + (engine-state-thread-cell-values es) + root-thread-cell-values))) + +(define (set-current-engine-thread-cell-values! new-t) + (let ([current-t (current-engine-thread-cell-values)]) + (with-interrupts-disabled + (hash-table-for-each + current-t + (lambda (c v) + (when (thread-cell-preserved? c) + (hashtable-delete! current-t c)))) + (hash-table-for-each + new-t + (lambda (c v) + (hashtable-set! current-t c v)))))) + +(define (new-engine-thread-cell-values) + (let ([current-t (current-engine-thread-cell-values)] + [new-t (make-ephemeron-eq-hashtable)]) + (when current-t + (hash-table-for-each + current-t + (lambda (c v) + (when (thread-cell-preserved? c) + (hashtable-set! new-t c v))))) + new-t)) + +(define (current-engine-init-break-enabled-cell none-v) + (let ([es (current-engine-state)]) + (if es + (engine-state-init-break-enabled-cell es) + none-v))) diff -Nru racket-6.12+ppa1/src/cs/rumble/ephemeron.ss racket-7.0+ppa1/src/cs/rumble/ephemeron.ss --- racket-6.12+ppa1/src/cs/rumble/ephemeron.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/ephemeron.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ + +;; A wrapper to hide the pairness of ephemeron pairs: +(define-record-type (ephemeron create-ephemeron ephemeron?) + (fields p)) + +(define (make-ephemeron key val) + (create-ephemeron (ephemeron-cons key val))) + +(define/who ephemeron-value + (case-lambda + [(e) (ephemeron-value e #f)] + [(e gced-v) + (check who ephemeron? e) + (let ([v (cdr (ephemeron-p e))]) + (if (eq? v #!bwp) + gced-v + v))])) diff -Nru racket-6.12+ppa1/src/cs/rumble/equal.ss racket-7.0+ppa1/src/cs/rumble/equal.ss --- racket-6.12+ppa1/src/cs/rumble/equal.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/equal.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,225 @@ + +;; Re-implement `equal?` to support impersonators and chaperones + +(define (do-equal? orig-a orig-b mode eql?) + (let equal? ([orig-a orig-a] [orig-b orig-b] [ctx #f]) + (let loop ([a orig-a] [b orig-b]) + (or (eqv? a b) + (cond + [(and (hash-impersonator? a) + (hash-impersonator? b) + (not (eq? mode 'chaperone-of?))) + ;; For immutable hashes, it's ok for the two objects to not be eq, + ;; as long as the interpositions are the same and the underlying + ;; values are `{impersonator,chaperone}-of?`: + (and (eq? (hash-impersonator-procs a) + (hash-impersonator-procs b)) + (loop (impersonator-next a) + (impersonator-next b)))] + [(and (hash-chaperone? a) + (hash-chaperone? b)) + ;; Same as above + (and (eq? (hash-chaperone-procs a) + (hash-chaperone-procs b)) + (loop (impersonator-next a) + (impersonator-next b)))] + [(and (props-impersonator? b) + (not (eq? mode 'chaperone-of?))) + (loop a (impersonator-next b))] + [(props-chaperone? b) + (loop a (impersonator-next b))] + [(and (impersonator? a) + (or (not (eq? mode 'chaperone-of?)) + (chaperone? a))) + (loop (impersonator-next a) b)] + [(impersonator? b) + (cond + [(eq? mode 'impersonator-of?) + ;; stop here, unless `prop:impersonator-of` is relevant + (let ([a2 (extract-impersonator-of mode a)]) + (cond + [a2 (or (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (equal? a2 b ctx)))] + [else #f]))] + [(and (eq? mode 'chaperone-of?) + (chaperone? b)) + ;; `a` does not include `b`, so give up + #f] + [else + (loop a (impersonator-next b))])] + [(#%vector? a) + (and (#%vector? b) + (or (not (eq? mode 'chaperone-of?)) + (and (immutable-vector? a) + (immutable-vector? b))) + (let ([len (#%vector-length a)]) + (and (fx= len (#%vector-length b)) + (or + (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (let loop ([i 0]) + (or (fx= i len) + (and (if eql? + (eql? (vector-ref orig-a i) + (vector-ref orig-b i)) + (equal? (vector-ref orig-a i) + (vector-ref orig-b i) + ctx)) + (loop (fx1+ i))))))))))] + [(pair? a) + (and (pair? b) + (or (check-union-find ctx a b) + (if eql? + (and (eql? (car a) (car b)) + (eql? (cdr a) (cdr b))) + (let ([ctx (deeper-context ctx)]) + (and + (equal? (car a) (car b) ctx) + (equal? (cdr a) (cdr b) ctx))))))] + [(#%box? a) + (and (#%box? b) + (or (not (eq? mode 'chaperone-of?)) + (and (immutable-box? a) + (immutable-box? b))) + (or (check-union-find ctx a b) + (if eql? + (eql? (unbox orig-a) (unbox orig-b)) + (let ([ctx (deeper-context ctx)]) + (equal? (unbox orig-a) (unbox orig-b) ctx)))))] + [(record? a) + (and (record? b) + ;; Check for for `prop:impersonator-of` + (let ([a2 (and (not (eq? mode 'chaperone-of?)) + (extract-impersonator-of mode a))] + [b2 (and (eq? mode 'equal?) + (extract-impersonator-of mode b))]) + (cond + [(or a2 b2) + ;; `prop:impersonator-of` takes precedence over + ;; other forms of checking + (or (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (equal? (or a a2) (or b b2) ctx)))] + [else + ;; No `prop:impersonator-of`, so check for + ;; `prop:equal+hash` or transparency + (let ([rec-equal? (record-equal-procedure a b)]) + (and rec-equal? + (or (check-union-find ctx a b) + (if eql? + (rec-equal? orig-a orig-b eql?) + (let ([ctx (deeper-context ctx)]) + (rec-equal? orig-a orig-b + (lambda (a b) + (equal? a b ctx))))))))])))] + [(and (eq? mode 'chaperone-of?) + ;; Mutable strings and bytevectors must be `eq?` for `chaperone-of?` + (or (mutable-string? a) + (mutable-string? b) + (mutable-bytevector? a) + (mutable-bytevector? b))) + #f] + [else + (#%equal? a b)]))))) + +(define (equal? a b) (do-equal? a b 'equal? #f)) +(define (impersonator-of? a b) (do-equal? a b 'impersonator-of? #f)) +(define (chaperone-of? a b) (do-equal? a b 'chaperone-of? #f)) + +(define/who (equal?/recur a b eql?) + (check who (procedure-arity-includes/c 2) eql?) + (do-equal? a b 'equal?/recur eql?)) + +;; ---------------------------------------- + +;; Use a hash table to detect cycles and sharing, +;; but only start using it if a comparison goes +;; deep enough. + +(define (deeper-context ctx) + (cond + [ctx + (let ([v (#%unbox ctx)]) + (when (fixnum? v) + (if (fx= v 0) + (#%set-box! ctx (make-eq-hashtable)) + (#%set-box! ctx (fx1- v))))) + ctx] + [else (box 32)])) + +(define (check-union-find ctx a b) + (cond + [(and ctx + (hashtable? (#%unbox ctx))) + (let ([ht (#%unbox ctx)]) + (let ([av (union-find ht a)] + [bv (union-find ht b)]) + (or (eq? av bv) + (begin + (hashtable-set! ht av bv) + #f))))] + [else #f])) + +(define (union-find ht a) + (let ([av (let loop ([a a]) + (let ([next-a (hashtable-ref ht a #f)]) + (if next-a + (loop next-a) + a)))]) + (unless (eq? av a) + (let loop ([a a]) + (let ([next-a (hashtable-ref ht a #f)]) + (unless (eq? next-a av) + (hashtable-set! ht a next-a) + (loop next-a))))) + av)) + +;; ---------------------------------------- + +;; The `key-equal-hash-code` and `key-equal?` functions allow +;; interposition on key equality through a hash table impersonator. +;; They call `equal-hash-code` or `equal?` unless the current +;; continuation maps `key-equality-wrap-key` to a key-wrapping +;; function. + +(define key-equality-wrap-key (gensym)) + +;; Looking in the continaution is expensive relative to `equal?`, so +;; look in a box as a quick pre-test. Multiple threads may increment +;; the counter in the box, so that's why it's only a pre-test. +(define key-equality-maybe-redirect (box 0)) + +(define (key-equal-hash-code k) + (let ([get-k (and (fx> (unbox key-equality-maybe-redirect) 0) + (continuation-mark-set-first #f key-equality-wrap-key))]) + (if get-k + (with-continuation-mark key-equality-wrap-key #f + (equal-hash-code (get-k k))) + (equal-hash-code k)))) + +(define (key-equal? k1 k2) + (let ([get-k (and (fx> (unbox key-equality-maybe-redirect) 0) + (continuation-mark-set-first #f key-equality-wrap-key))]) + (if get-k + (with-continuation-mark key-equality-wrap-key #f + (equal? (get-k k1) (get-k k2))) + (equal? k1 k2)))) + +(define (call-with-equality-wrap get-k key thunk) + (unsafe-box*-cas+! key-equality-maybe-redirect 1) + (let ([get-k + (if (eq? key none) + get-k + ;; record `(get-k key)` so that we + ;; don't have to compute it multiple + ;; times: + (let ([got-k (get-k key)]) + (lambda (k2) + (if (eq? k2 key) + got-k + (get-k k2)))))]) + (let ([r (with-continuation-mark key-equality-wrap-key get-k + (thunk))]) + (unsafe-box*-cas+! key-equality-maybe-redirect -1) + r))) diff -Nru racket-6.12+ppa1/src/cs/rumble/error.ss racket-7.0+ppa1/src/cs/rumble/error.ss --- racket-6.12+ppa1/src/cs/rumble/error.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/error.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,748 @@ + +(define raise + (case-lambda + [(v) (raise v #t)] + [(v barrier?) + (if barrier? + (call-with-continuation-barrier + (lambda () + (chez:raise v))) + (chez:raise v))])) + +;; ---------------------------------------- + +(define/who error-print-width + (make-parameter 256 + (lambda (v) + (check who + :test (and (integer? v) + (exact? v) + (>= v 3)) + :contract "(and/c exact-integer? (>=/c 3))" + v) + v))) + +(define/who error-value->string-handler + (make-parameter (lambda (v len) + (cond + [(or (number? v) + (boolean? v) + (string? v) + (symbol? v)) + (chez:format "~s" v)] + [else + "[?error-value->string-handler not ready?]"])) + (lambda (v) + (check who (procedure-arity-includes/c 2) v) + v))) + +(define/who error-print-context-length + (make-parameter 16 + (lambda (v) + (check who exact-nonnegative-integer? v) + v))) + +;; ---------------------------------------- + +(struct exn (message continuation-marks) :guard (lambda (msg cm who) + (check who string? msg) + (check who continuation-mark-set? cm) + (values (string->immutable-string msg) + cm))) +(struct exn:break exn (continuation) :guard (lambda (msg cm k who) + (check who escape-continuation? k) + (values msg cm k))) +(struct exn:break:hang-up exn:break ()) +(struct exn:break:terminate exn:break ()) +(struct exn:fail exn ()) +(struct exn:fail:contract exn:fail ()) +(struct exn:fail:contract:arity exn:fail:contract ()) +(struct exn:fail:contract:divide-by-zero exn:fail:contract ()) +(struct exn:fail:contract:non-fixnum-result exn:fail:contract ()) +(struct exn:fail:contract:continuation exn:fail:contract ()) +(struct exn:fail:contract:variable exn:fail:contract (id) :guard (lambda (msg cm id who) + (check who symbol? id) + (values msg cm id))) +(struct exn:fail:read exn:fail (srclocs) :guard (lambda (msg cm srclocs who) + (check who + :test (and (list srclocs) + (andmap srcloc? srclocs)) + :contract "(listof srcloc?)" + srclocs) + (values msg cm srclocs))) +(struct exn:fail:read:non-char exn:fail:read ()) +(struct exn:fail:read:eof exn:fail:read ()) +(struct exn:fail:filesystem exn:fail ()) +(struct exn:fail:filesystem:exists exn:fail:filesystem ()) +(struct exn:fail:filesystem:version exn:fail:filesystem ()) +(struct exn:fail:filesystem:errno exn:fail:filesystem (errno) :guard (lambda (msg cm errno who) + (check-errno who errno) + (values msg cm errno))) +(struct exn:fail:network exn:fail ()) +(struct exn:fail:network:errno exn:fail:network (errno) :guard (lambda (msg cm errno who) + (check-errno who errno) + (values msg cm errno))) +(struct exn:fail:out-of-memory exn:fail ()) +(struct exn:fail:unsupported exn:fail ()) +(struct exn:fail:user exn:fail ()) + +;; ---------------------------------------- + +(define (raise-arguments-error who what . more) + (unless (symbol? who) + (raise-argument-error 'raise-arguments-error "symbol?" who)) + (unless (string? what) + (raise-argument-error 'raise-arguments-error "string?" what)) + (do-raise-arguments-error who what exn:fail:contract more)) + +(define (do-raise-arguments-error who what exn:fail:contract more) + (raise + (|#%app| + exn:fail:contract + (apply + string-append + (symbol->string who) + ": " + what + (let loop ([more more]) + (cond + [(null? more) '()] + [(string? (car more)) + (cond + [(null? more) + (raise-arguments-error 'raise-arguments-error + "missing value after field string" + "string" + (car more))] + [else + (cons (string-append "\n " + (car more) ": " + (let ([val (cadr more)]) + (if (unquoted-printing-string? val) + (unquoted-printing-string-value val) + (error-value->string val)))) + (loop (cddr more)))])] + [else + (raise-argument-error 'raise-arguments-error "string?" (car more))]))) + (current-continuation-marks)))) + +(define (do-raise-argument-error e-who tag who what pos arg args) + (unless (symbol? who) + (raise-argument-error e-who "symbol?" who)) + (unless (string? what) + (raise-argument-error e-who "string?" what)) + (when pos + (unless (and (integer? pos) + (exact? pos) + (not (negative? pos))) + (raise-argument-error e-who "exact-nonnegative-integer?" pos))) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string who) + ": contract violation\n expected: " + (reindent what (string-length " expected: ")) + "\n " tag ": " + (error-value->string + (if pos (list-ref (cons arg args) pos) arg)) + (if (and pos (pair? args)) + (apply + string-append + "\n other arguments:" + (let loop ([pos pos] [args (cons arg args)]) + (cond + [(null? args) '()] + [(zero? pos) (loop (sub1 pos) (cdr args))] + [else (cons (string-append "\n " (error-value->string (car args))) + (loop (sub1 pos) (cdr args)))]))) + "")) + (current-continuation-marks)))) + +(define (reindent s amt) + (let loop ([i (string-length s)] [s s] [end (string-length s)]) + (cond + [(zero? i) + (if (= end (string-length s)) + s + (substring s 0 end))] + [else + (let ([i (fx1- i)]) + (cond + [(eqv? #\newline (string-ref s i)) + (string-append + (loop i s (fx1+ i)) + (make-string amt #\space) + (substring s (fx1+ i) end))] + [else + (loop i s end)]))]))) + +(define (error-value->string v) + ((|#%app| error-value->string-handler) + v + (|#%app| error-print-width))) + +(define raise-argument-error + (case-lambda + [(who what arg) + (do-raise-argument-error 'raise-argument-error "given" who what #f arg #f)] + [(who what pos arg . args) + (do-raise-argument-error 'raise-argument-error "given" who what pos arg args)])) + +(define (raise-result-error who what arg) + (do-raise-argument-error 'raise-result-error "result" who what #f arg #f)) + +(define (do-raise-type-error e-who tag who what pos arg args) + (unless (symbol? who) + (raise-argument-error e-who "symbol?" who)) + (unless (string? what) + (raise-argument-error e-who "string?" what)) + (when pos + (unless (and (integer? pos) + (exact? pos) + (not (negative? pos))) + (raise-argument-error e-who "exact-nonnegative-integer?" pos))) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string who) + ": expected argument ot type <" what ">" + "; given: " + (error-value->string + (if pos (list-ref (cons arg args) pos) arg)) + (if (and pos (pair? args)) + (apply + string-append + "; other arguments:" + (let loop ([pos pos] [args (cons arg args)]) + (cond + [(null? args) '()] + [(zero? pos) (loop (sub1 pos) (cdr args))] + [else (cons (string-append " " (error-value->string (car args))) + (loop (sub1 pos) (cdr args)))]))) + "")) + (current-continuation-marks)))) + +(define raise-type-error + (case-lambda + [(who what arg) + (do-raise-type-error 'raise-argument-error "given" who what #f arg #f)] + [(who what pos arg . args) + (do-raise-type-error 'raise-argument-error "given" who what pos arg args)])) + +(define/who (raise-mismatch-error in-who what . more) + (check who symbol? in-who) + (check who string? what) + (raise + (|#%app| + exn:fail:contract + (apply + string-append + (symbol->string in-who) + ": " + what + (let loop ([more more]) + (cond + [(null? more) '()] + [else + (cons (error-value->string (car more)) + (loop (cdr more)))]))) + (current-continuation-marks)))) + +(define/who raise-range-error + (case-lambda + [(in-who + type-description + index-prefix + index + in-value + lower-bound + upper-bound + alt-lower-bound) + (check who symbol? in-who) + (check who string? type-description) + (check who string? index-prefix) + (check who exact-integer? index) + (check who exact-integer? lower-bound) + (check who exact-integer? upper-bound) + (check who :or-false exact-integer? alt-lower-bound) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string in-who) + ": " + index-prefix "index is " + (cond + [(< upper-bound lower-bound) + (string-append "out of range for empty " type-description "\n" + " index: " (number->string index))] + [else + (string-append + (cond + [(and alt-lower-bound + (>= index alt-lower-bound) + (< index upper-bound)) + (string-append "smaller than starting index\n" + " " index-prefix "index: " (number->string index) "\n" + " starting index: " (number->string lower-bound) "\n")] + [else + (string-append "out of range\n" + " " index-prefix "index: " (number->string index) "\n")]) + " valid range: [" + (number->string (or alt-lower-bound lower-bound)) ", " + (number->string upper-bound) "]" "\n" + " " type-description ": " (error-value->string in-value))])) + (current-continuation-marks)))] + [(who + type-description + index-prefix + index + in-value + lower-bound + upper-bound) + (raise-range-error who + type-description + index-prefix + index + in-value + lower-bound + upper-bound + #f)])) + +(define/who (raise-arity-error name arity . args) + (check who (lambda (p) (or (symbol? name) (procedure? name))) + :contract "(or/c symbol? procedure?)" + name) + (check who procedure-arity? arity) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (let ([name (if (procedure? name) + (object-name name) + name)]) + (if (symbol? name) + (string-append (symbol->string name) ": ") + "")) + "arity mismatch;\n" + " the expected number of arguments does not match the given number\n" + (expected-arity-string arity) + " given: " (number->string (length args))) + (current-continuation-marks)))) + +(define (expected-arity-string arity) + (let ([expected + (lambda (s) (string-append " expected: " s "\n"))]) + (cond + [(number? arity) (expected (number->string arity))] + [(arity-at-least? arity) (expected + (string-append "at least " + (number->string (arity-at-least-value arity))))] + [else ""]))) + +(define (raise-result-arity-error who num-expected-args where args) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (if who (string-append (symbol->string who) ": ") "") + "result arity mismatch;\n" + " expected number of values not received\n" + " received: " (number->string (length args)) "\n" + " expected: " (number->string num-expected-args) + where) + (current-continuation-marks)))) + +(define (raise-binding-result-arity-error expected-args args) + (raise-result-arity-error #f (length expected-args) "\n at: local-binding form" args)) + +(define raise-unsupported-error + (case-lambda + [(id msg) + (raise + (|#%app| + exn:fail:unsupported + (string-append (symbol->string id) ": " msg) + (current-continuation-marks)))] + [(id) (raise-unsupported-error id "unsupported")])) + +;; ---------------------------------------- + +(define-record-type (unquoted-printing-string new-unquoted-printing-string unquoted-printing-string?) + (fields value)) + +(define make-unquoted-printing-string + (let ([unquoted-printing-string + (escapes-ok + (lambda (s) + (check 'unquoted-printing-string string? s) + (new-unquoted-printing-string s)))]) + unquoted-printing-string)) + +;; ---------------------------------------- + +(define (nth-str n) + (string-append + (number->string n) + (case (modulo n 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [else "th"]))) + +;; ---------------------------------------- + +(define exception-handler-key (gensym "exception-handler-key")) + +(define (default-uncaught-exception-handler exn) + (let ([message (if (exn? exn) + (exn-message exn) + (string-append "uncaught exception: " + (error-value->string exn)))]) + (unless (exn:break:hang-up? exn) + (let ([display-handler (|#%app| error-display-handler)]) + (call-with-parameterization + error-display-handler + (if (eq? display-handler default-error-display-handler) + emergency-error-display-handler + default-error-display-handler) + (lambda () + (call-with-exception-handler + (make-nested-exception-handler "error display handler" exn) + (lambda () + (call-with-break-disabled + (lambda () + (|#%app| display-handler message exn))))))))) + (when (or (exn:break:hang-up? exn) + (exn:break:terminate? exn)) + (engine-exit 1)) + (let ([escape-handler (|#%app| error-escape-handler)]) + (call-with-parameterization + error-display-handler + default-error-display-handler + (lambda () + (call-with-parameterization + error-escape-handler + default-error-escape-handler + (lambda () + (call-with-exception-handler + (make-nested-exception-handler "error escape handler" exn) + (lambda () + (call-with-break-disabled + (lambda () + (|#%app| escape-handler)))))))))) + ;; In case the escape handler doesn't escape: + (default-error-escape-handler))) + +(define link-instantiate-continuations (make-ephemeron-eq-hashtable)) + +;; For `instantiate-linklet` to help report which linklet is being run: +(define (register-linklet-instantiate-continuation! k name) + (when name + (hashtable-set! link-instantiate-continuations k name))) + +;; Convert a contination to a list of function-name and +;; source information. Cache the result half-way up the +;; traversal, so that it's amortized constant time. +(define cached-traces (make-ephemeron-eq-hashtable)) +(define (continuation->trace k) + (let ([i (inspect/object k)]) + (call-with-values + (lambda () + (let loop ([i i] [slow-i i] [move? #f]) + (cond + [(not (eq? (i 'type) 'continuation)) + (values (slow-i 'value) '())] + [else + (let ([k (i 'value)]) + (cond + [(hashtable-ref cached-traces k #f) + => (lambda (l) + (values slow-i l))] + [else + (let* ([name (or (let ([n (hashtable-ref link-instantiate-continuations + k + #f)]) + (and n + (string->symbol (format "body of ~a" n)))) + (let* ([c (i 'code)] + [n (c 'name)]) + n))] + [desc + (let* ([src (or + ;; when per-expression inspector info is available: + (i 'source-object) + ;; when only per-function source location is available: + ((i 'code) 'source-object))]) + (and (or name src) + (cons name src)))]) + (call-with-values + (lambda () (loop (i 'link) (if move? (slow-i 'link) slow-i) (not move?))) + (lambda (slow-k l) + (let ([l (if desc + (cons desc l) + l)]) + (when (eq? k slow-k) + (hashtable-set! cached-traces (i 'value) l)) + (values slow-k l)))))]))]))) + (lambda (slow-k l) + l)))) + +(define (traces->context ls) + (let loop ([l '()] [ls ls]) + (cond + [(null? l) + (if (null? ls) + '() + (loop (car ls) (cdr ls)))] + [else + (let* ([p (car l)] + [name (car p)] + [loc (and (cdr p) + (call-with-values (lambda () + (let* ([src (cdr p)] + [path (source-file-descriptor-path (source-object-sfd src))]) + (if (source-object-line src) + (values path + (source-object-line src) + (source-object-column src)) + (values path + (source-object-bfp src))))) + (case-lambda + [() #f] + [(path line col) (|#%app| srcloc path line (sub1 col) #f #f)] + [(path pos) (|#%app| srcloc path #f #f (add1 pos) #f)])))]) + (if (or name loc) + (cons (cons name loc) (loop (cdr l) ls)) + (loop (cdr l) ls)))]))) + +(define (default-error-display-handler msg v) + (eprintf "~a" msg) + (when (or (continuation-condition? v) + (and (exn? v) + (not (exn:fail:user? v)))) + (eprintf "\n context...:") + (let loop ([l (traces->context + (if (exn? v) + (continuation-mark-set-traces (exn-continuation-marks v)) + (list (continuation->trace (condition-continuation v)))))] + [n (|#%app| error-print-context-length)]) + (unless (or (null? l) (zero? n)) + (let* ([p (car l)] + [s (cdr p)]) + (cond + [(and s + (srcloc-line s) + (srcloc-column s)) + (eprintf "\n ~a:~a:~a" (srcloc-source s) (srcloc-line s) (srcloc-column s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(and s (srcloc-position s)) + (eprintf "\n ~a::~a" (srcloc-source s) (srcloc-position s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(car p) + (eprintf "\n ~a" (car p))])) + (loop (cdr l) (sub1 n))))) + (eprintf "\n")) + +(define eprintf + (lambda (fmt . args) + (apply fprintf (current-error-port) fmt args))) + +(define (emergency-error-display-handler msg v) + (log-system-message 'error msg)) + +(define (set-error-display-eprintf! proc) + (set! eprintf proc)) + +(define (default-error-escape-handler) + (abort-current-continuation (default-continuation-prompt-tag) void)) + +(define (exn->string v) + (format "~a~a" + (if (who-condition? v) + (format "~a: " (condition-who v)) + "") + (cond + [(exn? v) + (exn-message v)] + [(format-condition? v) + (apply format + (condition-message v) + (condition-irritants v))] + [(syntax-violation? v) + (let ([show (lambda (s) + (cond + [(not s) ""] + [else (format " ~s" (syntax->datum s))]))]) + (format "~a~a~a" + (condition-message v) + (show (syntax-violation-form v)) + (show (syntax-violation-subform v))))] + [(message-condition? v) + (condition-message v)] + [else (format "~s" v)]))) + +(define (condition->exn v) + (if (condition? v) + (cond + [(and (format-condition? v) + (irritants-condition? v) + (string-prefix? "incorrect number of arguments" (condition-message v)) + (pair? (condition-irritants v)) + (procedure? (car (condition-irritants v)))) + (let* ([proc (car (condition-irritants v))] + [name (object-name proc)] + [arity (procedure-arity proc)]) + (|#%app| + exn:fail:contract:arity + (string-append + (if (symbol? name) (symbol->string name) "#") + ": arity mismatch;\n the expected number of arguments does not match the given number" + (cond + [(list? arity) + ""] + [else + (string-append + "\n expected: " + (cond + [(arity-at-least? arity) (string-append "at least " (number->string (arity-at-least-value arity)))] + [else (number->string arity)]))])) + (current-continuation-marks)))] + [else + (|#%app| + (cond + [(and (format-condition? v) + (or (string-prefix? "incorrect number of arguments" (condition-message v)) + (string-suffix? "values to single value return context" (condition-message v)) + (string-prefix? "incorrect number of values received in multiple value context" (condition-message v)))) + exn:fail:contract:arity] + [(and (format-condition? v) + (who-condition? v) + (eq? '/ (condition-who v)) + (string=? "undefined for ~s" (condition-message v))) + exn:fail:contract:divide-by-zero] + [(and (format-condition? v) + (string=? "attempt to reference undefined variable ~s" (condition-message v))) + (lambda (msg marks) + (|#%app| exn:fail:contract:variable msg marks (car (condition-irritants v))))] + [else + exn:fail:contract]) + (exn->string v) + (current-continuation-marks))]) + v)) + +(define (string-prefix? p str) + (and (>= (string-length str) (string-length p)) + (string=? (substring str 0 (string-length p)) p))) + +(define (string-suffix? p str) + (and (>= (string-length str) (string-length p)) + (string=? (substring str (- (string-length str) (string-length p)) (string-length str)) p))) + +(define/who uncaught-exception-handler + (make-parameter default-uncaught-exception-handler + (lambda (v) + (check who (procedure-arity-includes/c 1) v) + v))) + +(define/who error-display-handler + (make-parameter default-error-display-handler + (lambda (v) + (check who (procedure-arity-includes/c 2) v) + v))) + +(define/who error-escape-handler + (make-parameter default-error-escape-handler + (lambda (v) + (check who (procedure-arity-includes/c 0) v) + v))) + +(define (set-no-locate-source!) + ;; Disable searching through the filesystem to convert a source + + ;; position to line and column information. Instead, Racket + ;; constructs source objects that preserve the line and column if + ;; available. + (current-locate-source-object-source + (lambda (src start? cache?) + (cond + [(source-object-line src) + ;; Line and column are available without searching + (values (source-file-descriptor-path (source-object-sfd src)) + (source-object-column src) + (source-object-column src))] + [else + ;; Don't search + (values)])))) + +(define (set-base-exception-handler!) + (current-exception-state (create-exception-state)) + (base-exception-handler + (lambda (v) + (cond + [(and (warning? v) + (not (non-continuable-violation? v))) + (log-system-message 'warning (exn->string exn))] + [else + (let ([hs (continuation-mark-set->list (current-continuation-marks the-root-continuation-prompt-tag) + exception-handler-key + the-root-continuation-prompt-tag)] + [init-v (condition->exn v)]) + (let ([call-with-nested-handler + (lambda (thunk) + (call-with-exception-handler + (make-nested-exception-handler "exception handler" init-v) + (lambda () + (call-with-break-disabled thunk))))]) + (let loop ([hs hs] [v init-v]) + (cond + [(null? hs) + (call-with-nested-handler + (lambda () (|#%app| (|#%app| uncaught-exception-handler) v))) + ;; Use `nested-exception-handler` if the uncaught-exception + ;; handler doesn't escape: + ((make-nested-exception-handler #f v) #f)] + [else + (let ([h (car hs)] + [hs (cdr hs)]) + (let ([new-v (call-with-nested-handler + (lambda () (|#%app| h v)))]) + (loop hs new-v)))]))))])))) + +(define (make-nested-exception-handler what old-exn) + (lambda (exn) + (let ([msg + (string-append + (cond + [(not what) + "handler for uncaught exceptions: did not escape"] + [else + (string-append + (cond [(exn? exn) + (string-append "exception raised by " what)] + [else + (string-append "raise called (with non-exception value) by " what)]) + ": " + (if (exn? exn) + (exn-message exn) + (error-value->string exn)))]) + "; original " + (if (exn? old-exn) + "exception raised" + "raise called (with non-exception value)") + ": " + (if (exn? old-exn) + (exn-message old-exn) + (error-value->string old-exn)))]) + (default-uncaught-exception-handler + (|#%app| exn:fail msg (current-continuation-marks)))))) + +(define (call-with-exception-handler proc thunk) + (call/cm exception-handler-key proc thunk)) + +;; ---------------------------------------- + +(define log-system-message void) + +(define (set-log-system-message! proc) + (set! log-system-message proc)) diff -Nru racket-6.12+ppa1/src/cs/rumble/extfl.ss racket-7.0+ppa1/src/cs/rumble/extfl.ss --- racket-6.12+ppa1/src/cs/rumble/extfl.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/extfl.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,88 @@ + +(define-record-type extflonum + (fields str) + (nongenerative #{extflonum lb32cq34kbljz9rpowkzge-0})) + +;; used by `string->number` +(define (extflonum-string? s) + ;; It's an extflonum if there's any #\t + (let loop ([i (string-length s)]) + (and (fx> i 0) + (let ([i (sub1 i)]) + (let ([c (string-ref s i)]) + (or (char=? #\t c) (char=? #\T c) + (loop i))))))) + +(define (extflonum-available?) #f) +(define (extflvector? v) #f) + +(define-syntax (define-extfl-ids stx) + (syntax-case stx () + [(_ id ...) + #'(begin + (define (id v) + (raise-unsupported-error 'id)) + ...)])) + +(define-extfl-ids + extfl* + extfl+ + extfl- + ->extfl + extfl->exact + extfl->exact-integer + extfl->floating-point-bytes + extfl->fx + extfl->inexact + extfl/ + extfl< + extfl<= + extfl= + extfl> + extfl>= + extflabs + extflacos + extflasin + extflatan + extflceiling + extflcos + extflexp + extflexpt + floating-point-bytes->extfl + extflfloor + fx->extfl + extfllog + make-shared-extflvector + make-extflvector + extflmax + extflmin + real->extfl + extflround + shared-extflvector + extflsin + extflsqrt + extfltan + extfltruncate + extflvector + extflvector-length + extflvector-ref + extflvector-set! + + unsafe-extfl* + unsafe-extfl+ + unsafe-extfl- + unsafe-extfl/ + unsafe-extfl< + unsafe-extfl<= + unsafe-extfl= + unsafe-extfl> + unsafe-extfl>= + unsafe-extflabs + unsafe-extflmax + unsafe-extflmin + unsafe-extflsqrt + unsafe-extfl->fx + unsafe-fx->extfl + unsafe-extflvector-length + unsafe-extflvector-ref + unsafe-extflvector-set!) diff -Nru racket-6.12+ppa1/src/cs/rumble/flvector.ss racket-7.0+ppa1/src/cs/rumble/flvector.ss --- racket-6.12+ppa1/src/cs/rumble/flvector.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/flvector.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,119 @@ + +(define-record-type (flvector create-flvector flvector?) + (fields bstr)) + +(define (flvector=? a b eql?) + (bytevector=? (flvector-bstr a) (flvector-bstr b))) + +(define (flvector-hash-code a hc) + (hc (flvector-bstr a))) + +(define (do-flvector who xs) + (let ([bstr (make-bytevector (* 8 (length xs)))]) + (let loop ([xs xs] [i 0]) + (unless (null? xs) + (let ([x (car xs)]) + (check who flonum? x) + (bytevector-ieee-double-set! bstr i x (native-endianness)) + (loop (cdr xs) (fx+ i 8))))) + (create-flvector bstr))) + +(define new-flvector + (let ([flvector + (lambda xs + (do-flvector 'flvector xs))]) + flvector)) + +(define (do-make-flvector who size init) + (check who exact-nonnegative-integer? size) + (cond + [(eqv? init 0.0) + ;; 0-fill bytevector => 0.0-fill flvector + (create-flvector (make-bytevector (bitwise-arithmetic-shift-left size 3) 0))] + [else + (check who flonum? init) + (let* ([bsize (* 8 size)] + [bstr (make-bytevector bsize)]) + (let loop ([i 0]) + (unless (= i bsize) + (bytevector-ieee-double-set! bstr i init (native-endianness)) + (loop (fx+ i 8)))) + (create-flvector bstr))])) + +(define make-flvector + (case-lambda + [(size) (make-flvector size 0.0)] + [(size init) (do-make-flvector 'make-flvector size init)])) + +(define/who (flvector-length flvec) + (check who flvector? flvec) + (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)) + +(define (unsafe-flvector-length flvec) + (#3%fxsrl (#3%bytevector-length (flvector-bstr flvec)) 3)) + +(define/who (flvector-ref flvec pos) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? pos) + (unless (and (>= pos 0) + (< pos len)) + (raise-range-error who "flvector" "" pos flvec 0 len))) + (bytevector-ieee-double-ref (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3) + (native-endianness))) + +(define (unsafe-flvector-ref flvec pos) + (#3%bytevector-ieee-double-ref (flvector-bstr flvec) + (#3%fxsll pos 3) + (native-endianness))) + +(define/who (flvector-set! flvec pos val) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? pos) + (unless (and (>= pos 0) + (< pos len)) + (raise-range-error who "flvector" "" pos flvec 0 len))) + (check who flonum? val) + (bytevector-ieee-double-set! (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3) + val + (native-endianness))) + +(define (unsafe-flvector-set! flvec pos val) + (#3%bytevector-ieee-double-set! (flvector-bstr flvec) + (#3%fxsll pos 3) + val + (native-endianness))) + +(define/who flvector-copy + (case-lambda + [(flvec) (flvector-copy flvec 0 (flvector-length flvec))] + [(flvec start) (flvector-copy flvec start (flvector-length flvec))] + [(flvec start end) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "flvector" flvec start end len) + (let* ([new-len (bitwise-arithmetic-shift-left (- end start) 3)] + [bstr (make-bytevector new-len)]) + (bytes-copy! bstr 0 (flvector-bstr flvec) (bitwise-arithmetic-shift-left start 3) new-len) + (create-flvector bstr)))])) + +(define/who (shared-flvector . xs) + (do-flvector who xs)) + +(define make-shared-flvector + (case-lambda + [(size) (make-shared-flvector size 0.0)] + [(size init) (do-make-flvector 'make-shared-flvector size init)])) + +;; ---------------------------------------- + +(define (set-flvector-hash!) + (record-type-equal-procedure (record-type-descriptor flvector) + flvector=?) + (record-type-hash-procedure (record-type-descriptor flvector) + flvector-hash-code)) diff -Nru racket-6.12+ppa1/src/cs/rumble/foreign.ss racket-7.0+ppa1/src/cs/rumble/foreign.ss --- racket-6.12+ppa1/src/cs/rumble/foreign.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/foreign.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1718 @@ + +(define (cpointer? v) + (or (authentic-cpointer? v) + (not v) + (bytes? v) + (has-cpointer-property? v))) + +;; A cpointer's `memory` is either a raw foreign address (i.e., a +;; number), a vector, or a byte string. A bytevector is used +;; for GCable atomic memory, and a vector is used for GCable +;; non-atomic memory. +(define-record-type (cpointer make-cpointer authentic-cpointer?) + (fields memory (mutable tags))) +(define-record-type cpointer+offset + (parent cpointer) + (fields (mutable offset))) + +(define-values (prop:cpointer has-cpointer-property? cpointer-property-ref) + (make-struct-type-property 'cpointer + (lambda (v info) + (cond + [(exact-nonnegative-integer? v) + (unless (< v (list-ref info 1)) + (raise-arguments-error 'prop:cpointer + "index is out of range" + "index" v)) + (unless (chez:memv v (list-ref info 5)) + (raise-arguments-error 'prop:cpointer + "index does not refer to an immutable field" + "index" v)) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0)))] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [(cpointer? v) v] + [else + (raise-argument-error 'prop:cpointer + (string-append + "(or/c exact-nonnegative-integer?\n" + " (procedure-arity-includes/c 1)\n" + " cpointer?)") + v)])))) + +;; Gets a primitive cpointer type by following a `prop:evt` property +;; as needed. Call with function *before* disabling GC interrupts. +(define (unwrap-cpointer who p) + (cond + [(authentic-cpointer? p) p] + [(not p) p] + [(bytes? p) p] + [(ffi-callback? p) p] + [else (let ([v (cpointer-property-ref p)]) + (cond + [(exact-nonnegative-integer? v) + (let ([v (unsafe-struct-ref p v)]) + (if (cpointer? v) + (unwrap-cpointer who v) + #f))] + [(procedure? v) + (let ([p2 (v p)]) + (unless (cpointer? p2) + (raise-result-error 'prop:cpointer-accessor + "cpointer?" + p2)) + (unwrap-cpointer who p2))] + [else + (unwrap-cpointer who v)]))])) + +;; Like `unwrap-cpointer*`, but also allows an integer as a raw +;; foreign address: +(define (unwrap-cpointer* who p) + (if (integer? p) + p + (unwrap-cpointer who p))) + +(define (offset-ptr? p) + (unless (cpointer? p) + (raise-argument-error 'offset-ptr? "cpointer?" p)) + (cpointer+offset? p)) + +(define/who (set-cpointer-tag! p t) + (if (authentic-cpointer? p) + (cpointer-tags-set! p t) + (if (cpointer? p) + (let ([q (unwrap-cpointer who p)]) + (if (authentic-cpointer? q) + (set-cpointer-tag! q t) + (raise-arguments-error who + "cannot set tag on given cpointer" + "given" p + "tag" t))) + (raise-argument-error who "cpointer?" p)))) + +(define/who (cpointer-tag p) + (if (authentic-cpointer? p) + (cpointer-tags p) + (if (cpointer? p) + (let ([q (unwrap-cpointer who p)]) + (if (authentic-cpointer? q) + (cpointer-tag q) + #f)) + (raise-argument-error who "cpointer?" p)))) + +;; Convert a `memory` --- typically a raw foreign address, but possibly +;; a byte string or vector --- to a cpointer, using #f for a NULL +;; address: +(define (memory->cpointer x) + (cond + [(or (not x) (authentic-cpointer? x)) + ;; This happens when a pointer is converted without going through + ;; `cpointer-address` such as a `ptr-ref` on a struct or array type + x] + [(eqv? x 0) #f] + [else (make-cpointer x #f)])) + +;; Works on unwrapped cpointers: +(define (cpointer-nonatomic? p) + (and (authentic-cpointer? p) + (#%vector? (cpointer-memory p)))) + +;; ---------------------------------------- + +;; Hack: use `s_fxmul` as an identity function +;; to corece a bytevector's start to an address +(define bytevector->addr ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (u8* uptr) + uptr)) +(define object->addr ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (scheme-object uptr) + uptr)) +(define address->object ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (uptr uptr) + scheme-object)) + +(define vector-content-offset + ;; Hack: we rely on the implementation detail of bytevectors and vectors + ;; having the same offset from the address to the content. + (let ([s (make-bytevector 1)]) + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + (- (bytevector->addr s 1) + (object->addr s 1))))) + +;; Converts a primitive cpointer (normally the result of +;; `unwrap-cpointer`) to a raw foreign address. The +;; GC must be disabled while extracting an address, +;; which might be the address of a byte string that +;; could otherwise change due to a GC. +(define (cpointer-address p) ; call with GC disabled + (cond + [(not p) 0] + [(bytes? p) (memory-address p)] + [(cpointer+offset? p) + (let ([memory (cpointer-memory p)]) + (+ (memory-address memory) (cpointer+offset-offset p)))] + [(authentic-cpointer? p) + (memory-address (cpointer-memory p))] + [(ffi-callback? p) + (foreign-callable-entry-point (callback-code p))] + [else + (raise-arguments-error 'internal-error "bad case extracting a cpointer address" + "value" p)])) + +;; Like `cpointer-address`, but allows a raw foreign +;; address to pass through: +(define (cpointer*-address p) ; call with GC disabled + (if (number? p) + p + (cpointer-address p))) + +;; Convert a `memory` (as in a cpointer) to a raw foreign address. +(define (memory-address memory) ; call with GC disabled + (cond + [(integer? memory) memory] + [(bytes? memory) (bytevector->addr memory 1)] + [else + (+ (object->addr memory 1) + vector-content-offset)])) + +;; Convert a raw foreign address to a Scheme value on the +;; assumption that the address is the payload of a byte +;; string or vector: +(define (addr->gcpointer-memory v) ; call with GC disabled + (address->object (- v vector-content-offset) 1)) + +;; ---------------------------------------- + +(define (cpointer-strip p) + (cond + [(not p) 0] + [(bytes? p) p] + [(and (authentic-cpointer? p) + (or (not (cpointer+offset? p)) + (zero? (cpointer+offset-offset p)))) + (cpointer-memory p)] + [else none])) + +(define (stripped-cpointer? v) + (or (eqv? v 0) + (bytes? v) + (vector? v))) + +;; ---------------------------------------- + +(define/who (ptr-equal? p1 p2) + (let ([p1 (unwrap-cpointer who p1)] + [p2 (unwrap-cpointer who p2)]) + (with-interrupts-disabled ; disable GC while extracting addresses + (= (cpointer-address p1) (cpointer-address p2))))) + +(define/who (ptr-offset p) + (let ([p (unwrap-cpointer who p)]) + (ptr-offset* p))) + +(define (ptr-offset* p) + (if (cpointer+offset? p) + (cpointer+offset-offset p) + 0)) + +(define (set-ptr-offset! p n) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-offset "(and/c cpointer? ptr-offset?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-offset "exact-integer?" n)) + (cpointer+offset-offset-set! p n)) + +(define ptr-add + (case-lambda + [(p n type) + (unless (cpointer? p) + (raise-argument-error 'ptr-add "cpointer?" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add "exact-integer?" n)) + (unless (ctype? type) + (raise-argument-error 'ptr-add "ctype?" type)) + (do-ptr-add p (* n (ctype-sizeof type)) #t)] + [(p n) + (unless (cpointer? p) + (raise-argument-error 'ptr-add "cpointer?" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add "exact-integer?" n)) + (do-ptr-add p n #t)])) + +(define (do-ptr-add p n save-tags?) + (cond + [(authentic-cpointer? p) + (make-cpointer+offset (cpointer-memory p) + (and save-tags? (cpointer-tag p)) + (+ n (ptr-offset* p)))] + [(has-cpointer-property? p) + (do-ptr-add (unwrap-cpointer 'do-ptr-add p) n save-tags?)] + [else + (make-cpointer+offset (or p 0) #f n)])) + +(define ptr-add! + (case-lambda + [(p n type) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-add! "(and/c cpointer? offset-ptr?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add! "exact-integer?" n)) + (unless (ctype? type) + (raise-argument-error 'ptr-add! "ctype?" type)) + (do-ptr-add! p (* n (ctype-sizeof type)))] + [(p n) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-add! "(and/c cpointer? offset-ptr?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add! "exact-integer?" n)) + (do-ptr-add! p n)])) + +(define (do-ptr-add! p n) + (unless (cpointer+offset? p) + (raise-arguments-error 'ptr-add! + "given cpointer does not have an offset" + "given" p)) + (cpointer+offset-offset-set! p (+ n (cpointer+offset-offset p)))) + +;; ---------------------------------------- + +(define-record-type (ctype create-ctype ctype?) + (fields host-rep ; host-Scheme representation description, 'struct, 'union, or 'array + our-rep ; Racket representation description + basetype ; parent ctype or the same as `our-rep` + scheme->c ; converter of values to `basetype` + c->scheme)) ; converter of values from `basetype` + +;; A `compound-ctype` is used for structs, unions, and arrays +(define-record-type (compound-ctype create-compound-ctype compound-ctype?) + (parent ctype) + (fields get-decls + size + alignment)) + +(define/who (make-ctype type racket-to-c c-to-racket) + (check who ctype? type) + (check who (procedure-arity-includes/c 1) :or-false racket-to-c) + (check who (procedure-arity-includes/c 1) :or-false c-to-racket) + (cond + [(compound-ctype? type) + (create-compound-ctype (ctype-host-rep type) + (ctype-our-rep type) + type + racket-to-c + c-to-racket + (compound-ctype-get-decls type) + (compound-ctype-size type) + (compound-ctype-alignment type))] + [else + (create-ctype (ctype-host-rep type) + (ctype-our-rep type) + type + racket-to-c + c-to-racket)])) + +;; Apply all the conversion wrappers of `type` to the Scheme value `v` +(define (s->c type v) + (let* ([racket-to-c (ctype-scheme->c type)] + [v (if racket-to-c + (|#%app| racket-to-c v) + v)] + [next (ctype-basetype type)]) + (if (ctype? next) + (s->c next v) + v))) + +;; Apply all the conversion wrapper of `type` to the C value `v` +(define (c->s type v) + (let* ([next (ctype-basetype type)] + [v (if (ctype? next) + (c->s next v) + v)] + [c-to-racket (ctype-c->scheme type)]) + (if c-to-racket + (|#%app| c-to-racket v) + v))) + +;; ---------------------------------------- + +(define-syntax define-ctype + (syntax-rules () + [(_ id host-rep basetype) + (define/who id (create-ctype host-rep basetype basetype #f #f))] + [(_ id host-rep basetype s->c) + (define/who id (create-ctype host-rep basetype basetype s->c #f))] + [(_ id host-rep basetype s->c c->s) + (define/who id (create-ctype host-rep basetype basetype s->c c->s))])) + +;; We need `s->c` checks, even if they seem redundant, to make sure +;; that the checks happen early enough --- outside of atomic and +;; foreign-thread regions. Also, the integer checks built into Chez +;; Scheme are more permissive than Racket's. + +(define-syntax-rule (checker who ?) (lambda (x) (if (? x) x (bad-ctype-value who x)))) +(define-syntax integer-checker + (syntax-rules (signed unsigned) + [(_ who signed n int?) (checker who (lambda (x) (and (int? x) (<= (- (expt 2 (- n 1))) x (- (expt 2 (- n 1)) 1)))))] + [(_ who unsigned n int?) (checker who (lambda (x) (and (int? x) (<= 0 x (- (expt 2 n) 1)))))])) + +(define-ctype _bool 'boolean 'bool) +(define-ctype _double 'double 'double (checker who flonum?)) +(define-ctype _fixnum 'fixnum 'fixnum (checker who fixnum?)) +(define-ctype _float 'float 'float (checker who flonum?)) +(define-ctype _int8 'integer-8 'int8 (integer-checker who signed 8 fixnum?)) +(define-ctype _int16 'integer-16 'int16 (integer-checker who signed 16 fixnum?)) +(define-ctype _int32 'integer-32 'int32 (integer-checker who signed 32 exact-integer?)) +(define-ctype _int64 'integer-64 'int64 (integer-checker who signed 64 exact-integer?)) +(define-ctype _uint8 'unsigned-8 'uint8 (integer-checker who unsigned 8 fixnum?)) +(define-ctype _uint16 'unsigned-16 'uint16 (integer-checker who unsigned 16 fixnum?)) +(define-ctype _uint32 'unsigned-32 'uint32 (integer-checker who unsigned 32 exact-integer?)) +(define-ctype _uint64 'unsigned-64 'uint64 (integer-checker who unsigned 64 exact-integer?)) +(define-ctype _scheme 'scheme-object 'scheme) +(define-ctype _string/ucs-4 (if (system-big-endian?) 'utf-32be 'utf-32le) 'string/ucs-4 + (checker who (lambda (x) (or (not x) (string? x))))) +(define-ctype _string/utf-16 (if (system-big-endian?) 'utf-16be 'utf-16le) 'string/utf-16 + (checker who (lambda (x) (or (not x) (string? x))))) +(define-ctype _void 'void 'void (checker who void)) + +(define (bad-ctype-value type-name v) + (raise-arguments-error 'apply + "bad value for conversion" + "ctype" (make-unquoted-printing-string (symbol->string type-name)) + "value" v)) + +;; Unlike traditional Racket, copies when converting from C: +(define-ctype _bytes 'void* 'bytes + (checker who (lambda (x) (or (not x) (bytes? x)))) + (lambda (x) + (cond + [(not x) ; happens with non-atomic memory reference + x] + [(bytes? x) ; happens with non-atomic memory reference + ;; For consistency, truncate byte string at any NUL byte + (let ([len (bytes-length x)]) + (let loop ([i 0]) + (cond + [(fx= i len) x] + [(fx= 0 (bytes-ref x i)) + (subbytes x 0 i)] + [else (loop (fx+ i 1))])))] + [(eqv? x 0) #f] + [else + (let loop ([i 0]) + (if (fx= 0 (foreign-ref 'unsigned-8 x i)) + (let ([bstr (make-bytes i)]) + (memcpy* bstr 0 x 0 i #f) + bstr) + (loop (add1 i))))]))) + +(define-ctype _short_bytes 'void* 'bytes + (lambda (x) x) + (lambda (x) (let loop ([i 0]) + (if (fx= 0 (foreign-ref 'unsigned-16 x i)) + (let ([bstr (make-bytes i)]) + (memcpy* bstr 0 x 0 i #f) + bstr) + (loop (+ i 2)))))) + +(define-ctype _double* 'double 'double + (lambda (x) (if (real? x) + (exact->inexact x) + (bad-ctype-value who x)))) + +(define-ctype _ufixnum 'fixnum 'fixnum (checker who fixnum?)) ; historically, no sign check +(define-ctype _fixint 'integer-32 'fixint (checker who fixnum?)) +(define-ctype _ufixint 'unsigned-32 'ufixint (checker who fixnum?)) ; historically, no sign check + +(define-ctype _symbol 'string 'string + (lambda (x) (if (symbol? x) + (symbol->string x) + (bad-ctype-value who x))) + (lambda (s) (string->symbol s))) + +(define-ctype _longdouble 'double 'double + (lambda (x) (bad-ctype-value who x))) + +(define-ctype _pointer 'void* 'pointer + (lambda (v) (unwrap-cpointer who v)) ; resolved to an address later (with the GC disabled) + (lambda (x) (memory->cpointer x))) + +;; Treated specially by `ptr-ref` +(define-ctype _fpointer 'void* 'fpointer + (lambda (v) (unwrap-cpointer who v)) ; resolved to an address later (with the GC disabled) + (lambda (x) + (if (ffi-obj? x) ; check for `ptr-ref` special case on `ffi-obj`s + x + (memory->cpointer x)))) + +(define-ctype _gcpointer 'void* 'gcpointer + (lambda (v) (unwrap-cpointer who v)) ; like `_pointer`: resolved later + (lambda (x) + ;; `x` must have been converted to a bytevector or vector before + ;; the GC was re-enabled + (memory->cpointer x))) + +;; FIXME: +(define-ctype _stdbool 'integer-8 'stdbool + (lambda (x) (and x 0)) + (lambda (v) (not (zero? v)))) + +(define make-cstruct-type + (case-lambda + [(types) (make-cstruct-type types #f #f)] + [(types abi) (make-cstruct-type types abi #f)] + [(types abi alignment) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps types)]) + (append decls + `((define-ftype ,id + (struct ,@(map (lambda (rep) + `[,(gensym) ,rep]) + reps))))))))]) + (let-values ([(size alignment) (ctypes-sizeof+alignof types alignment)]) + (create-compound-ctype 'struct + 'struct + types + (lambda (s) (unwrap-cpointer '_struct s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment)))])) + +(define/who (make-union-type . types) + (for-each (lambda (type) (check who ctype? type)) + types) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps types)]) + (append decls + `((define-ftype ,id + (union ,@(map (lambda (rep) + `[,(gensym) ,rep]) + reps))))))))] + [size (apply max (map ctype-sizeof types))] + [alignment (apply max (map ctype-alignof types))]) + (create-compound-ctype 'union + 'union + types + (lambda (s) (unwrap-cpointer '_union s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment))) + +(define/who (make-array-type type count) + (check who ctype? type) + (check who exact-nonnegative-integer? count) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps (list type))]) + (append decls + `((define-ftype ,id + (array ,count ,(car reps))))))))] + [size (* count (ctype-sizeof type))] + [alignment (ctype-alignof type)]) + (create-compound-ctype 'array + 'array + (vector type count) + (lambda (s) (unwrap-cpointer '_array s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment))) + +(define (compiler-sizeof sl) + (let ([rest (lambda (sl) (if (pair? sl) (cdr sl) '()))]) + (unless (or (symbol? sl) + (list? sl)) + (raise-argument-error 'compiler-sizeof + "(or/c ctype-symbol? (listof ctype-symbol?))" + sl)) + (let loop ([sl sl] [base-type #f] [star? #f] [size #f]) + (cond + [(null? sl) + (cond + [(eq? base-type 'void) + (when size + (raise-arguments-error 'compiler-sizeof "cannot qualify 'void")) + (if star? + (foreign-sizeof 'void*) + (raise-arguments-error 'compiler-sizeof "cannot use 'void without a '*"))] + [(or (not base-type) + (eq? base-type 'int)) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof (or size 'int)))] + [(eq? base-type 'double) + (case size + [(long) + (if star? + (foreign-sizeof 'void*) + ;; FIXME: + (foreign-sizeof 'double))] + [(#f) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof 'double))] + [else + (raise-arguments-error 'compiler-sizeof "bad qualifiers for 'double")])] + [(eq? base-type 'float) + (case size + [(#f) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof 'float))] + [else + (raise-arguments-error 'compiler-sizeof "bad qualifiers for 'float")])] + [size + (raise-arguments-error 'compiler-sizeof (format "cannot qualify '~a" base-type))])] + [else + (let ([s (if (pair? sl) (car sl) sl)]) + (case s + [(int char float double void) + (cond + [base-type + (raise-arguments-error 'compiler-sizeof + (format "extraneous type: '~a" s))] + [else + (loop (rest sl) s star? size)])] + [(short) + (case size + [(short) + (raise-arguments-error 'compiler-sizeof + "cannot handle more than one 'short")] + [(long) + (raise-arguments-error 'compiler-sizeof + "cannot use both 'short and 'long")] + [(#f) (loop (rest sl) base-type star? 'short)])] + [(long) + (case size + [(short) + (raise-arguments-error 'compiler-sizeof + "cannot use both 'short and 'long")] + [(long-long) + (raise-arguments-error 'compiler-sizeof + "cannot handle more than two 'long")] + [(long) + (loop (rest sl) base-type star? 'long-long)] + [(#f) + (loop (rest sl) base-type star? 'long)])] + [(*) + (if star? + (raise-arguments-error 'compiler-sizeof + "cannot handle more than one '*") + (loop (rest sl) base-type #t size))] + [else + (raise-argument-error 'compiler-sizeof + "(or/c ctype-symbol? (listof ctype-symbol?))" + sl)]))])))) + +(define (ctype-malloc-mode c) + (let ([t (ctype-our-rep c)]) + (if (or (eq? t 'gcpointer) (eq? t 'scheme)) + 'nonatomic + 'atomic))) + +(define/who (ctype-sizeof c) + (check who ctype? c) + (case (ctype-host-rep c) + [(void) 0] + [(boolean int) 4] + [(double) 8] + [(float) 4] + [(integer-8 unsigned-8) 1] + [(integer-16 unsigned-16) 2] + [(integer-32 unsigned-32) 4] + [(integer-64 unsigned-64) 8] + [else + (if (compound-ctype? c) + (compound-ctype-size c) + ;; Everything else is pointer-sized: + (foreign-sizeof 'void*))])) + +(define (ctypes-sizeof+alignof base alignment) + (let ([align (lambda (size algn) + (let ([amt (modulo size (or alignment algn))]) + (if (zero? amt) + size + (+ size (- algn amt)))))]) + (let loop ([types base] [size 0] [max-align 1]) + (cond + [(null? types) (values (align size max-align) + max-align)] + [else (let ([sz (ctype-sizeof (car types))] + [algn (ctype-alignof (car types))]) + (loop (cdr types) + (+ (align size algn) + sz) + (max algn max-align)))])))) + +(define/who (ctype-alignof c) + (check who ctype? c) + (cond + [(compound-ctype? c) + (compound-ctype-alignment c)] + [else + (ctype-sizeof c)])) + +(define/who (cpointer-gcable? p) + (let ([p (unwrap-cpointer who p)]) + (or (bytes? p) + (and (authentic-cpointer? p) + (let ([memory (cpointer-memory p)]) + (or (bytes? memory) + (#%vector? memory))))))) + +;; ---------------------------------------- + +(define-record-type (ffi-lib make-ffi-lib ffi-lib?) + (fields handle name)) + +(define ffi-lib* + (case-lambda + [(name) (ffi-lib* name #f #f)] + [(name fail-as-false?) (ffi-lib* name fail-as-false? #f)] + [(name fail-as-false? as-global?) + (let ([name (if (string? name) + (string->immutable-string name) + name)]) + (ffi-get-lib 'ffi-lib + name + as-global? + fail-as-false? + (lambda (h) + (make-ffi-lib h name))))])) + +(define-record-type (cpointer/ffi-obj make-ffi-obj ffi-obj?) + (parent cpointer) + (fields lib name)) + +(define/who (ffi-obj name lib) + (check who bytes? name) + (check who ffi-lib? lib) + (let ([name (bytes->immutable-bytes name)]) + (ffi-get-obj who + (ffi-lib-handle lib) + (ffi-lib-name lib) + name + (lambda (ptr) + (make-ffi-obj (ffi-ptr->address ptr) #f lib name))))) + +(define (ffi-obj-name obj) + (cpointer/ffi-obj-name obj)) + +(define (ffi-obj-lib obj) + (cpointer/ffi-obj-lib obj)) + +(define ffi-get-lib + ;; Placeholder implementation that either fails + ;; or returns a dummy value: + (lambda (who name as-global? fail-as-false? success-k) + (if fail-as-false? + #f + (success-k #f)))) + +(define ffi-get-obj + ;; Placeholder implementation that always fails: + (lambda (who lib lib-name name success-k) + (raise + (|#%app| + exn:fail:filesystem + (format "~a: not yet ready\n name: ~a" who name) + (current-continuation-marks))))) + +(define ffi-ptr->address + ;; Placeholder implementation + (lambda (p) p)) + +(define (set-ffi-get-lib-and-obj! do-ffi-get-lib do-ffi-get-obj do-ffi-ptr->address) + (set! ffi-get-lib do-ffi-get-lib) + (set! ffi-get-obj do-ffi-get-obj) + (set! ffi-ptr->address do-ffi-ptr->address)) + +;; ---------------------------------------- + +(define/who ptr-ref + (case-lambda + [(p type) + (check who cpointer? p) + (check who ctype? type) + (c->s type (foreign-ref* type p 0))] + [(p type offset) + (check who cpointer? p) + (check who ctype? type) + (check who exact-integer? offset) + (c->s type (foreign-ref* type + p + (* (ctype-sizeof type) offset)))] + [(p type abs-tag offset) + (check who cpointer? p) + (check who ctype? type) + (check who (lambda (p) (eq? p 'abs)) :contract "'abs" abs-tag) + (check who exact-integer? offset) + (c->s type (foreign-ref* type p offset))])) + +(define (foreign-ref* type orig-p offset) + (cond + [(and (ffi-obj? orig-p) + (eq? 'fpointer (ctype-our-rep type))) + ;; Special case for `ptr-ref` on a function-type ffi-object: + ;; cancel a level of indirection and preserve `ffi-obj`ness + ;; to keep its name + orig-p] + [else + (cond + [(compound-ctype? type) + ;; Instead of copying, get a pointer within `p`: + (do-ptr-add orig-p offset #f)] + [else + (let ([p (unwrap-cpointer 'foreign-ref* orig-p)] + [host-rep (ctype-host-rep type)]) + (cond + [(cpointer-nonatomic? p) + (let ([offset (+ offset (ptr-offset* p))]) + (cond + [(and (word-aligned? offset) + (or (eq? 'void* host-rep) + (eq? 'scheme-object host-rep))) + (let* ([i (fxsrl offset log-ptr-size-in-bytes)] + [v (vector-ref (cpointer-memory p) i)]) + (cond + [(eq? 'scheme-object host-rep) v] + [(stripped-cpointer? v) v] + [else + (raise-arguments-error 'ptr-ref + "cannot convert value to a cpointer" + "extracted value" v + "source" orig-p)]))] + [else + (raise-arguments-error 'ptr-ref "unsupported access into non-atomic memory" + "offset" offset + "representation" host-rep + "source" orig-p)]))] + [else + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + ;; Special treatment is needed for 'scheme-object, since the + ;; host Scheme rejects the use of 'scheme-object with + ;; `foreign-ref` + (let ([v (foreign-ref (if (eq? host-rep 'scheme-object) + 'uptr + host-rep) + (cpointer-address p) + offset)]) + (case host-rep + [(scheme-object) (address->object v 1)] + [else + (case (ctype-our-rep type) + [(gcpointer) (addr->gcpointer-memory v)] + [else v])])))]))])])) + +(define/who ptr-set! + (case-lambda + [(p type v) + (check who cpointer? p) + (check who ctype? type) + (foreign-set!* type + p + 0 + v)] + [(p type offset v) + (check who cpointer? p) + (check who ctype? type) + (check who exact-integer? offset) + (foreign-set!* type + p + (* (ctype-sizeof type) offset) + v)] + [(p type abs-tag offset v) + (check who cpointer? p) + (check who ctype? type) + (check who (lambda (p) (eq? p 'abs)) :contract "'abs" abs-tag) + (check who exact-integer? offset) + (foreign-set!* type + p + offset + v)])) + +(define ptr-size-in-bytes (foreign-sizeof 'void*)) +(define log-ptr-size-in-bytes (- (integer-length ptr-size-in-bytes) 1)) + +(define (word-aligned? offset) + (zero? (fxand offset (fx- ptr-size-in-bytes 1)))) + +(define (foreign-set!* type orig-p offset orig-v) + (let ([p (unwrap-cpointer 'foreign-set!* orig-p)]) + (cond + [(compound-ctype? type) + ;; Corresponds to a copy, since `v` is represented by a pointer + (memcpy* p offset + (s->c type orig-v) 0 + (compound-ctype-size type) + #f)] + [else + (let ([host-rep (ctype-host-rep type)] + [v (s->c type orig-v)]) + (cond + [(cpointer-nonatomic? p) + (let ([offset (+ offset (ptr-offset* p))]) + (cond + [(and (word-aligned? offset) + (or (eq? 'void* host-rep) + (eq? 'scheme-object host-rep))) + (let ([i (fxsrl offset log-ptr-size-in-bytes)]) + (if (eq? host-rep 'scheme-object) + (vector-set! (cpointer-memory p) i v) + (let ([v (cpointer-strip v)]) + (if (eq? v none) + (raise-arguments-error 'ptr-set! + "cannot install value into non-atomic memory" + "value" orig-v + "destination" orig-p) + (vector-set! (cpointer-memory p) i v)))))] + [else + (raise-arguments-error 'ptr-set! "unsupported access into non-atomic memory" + "offset" offset + "representation" host-rep + "value" orig-v + "destination" orig-p)]))] + [(and (cpointer-nonatomic? v) + (not (cpointer/cell? v))) + (raise-arguments-error 'ptr-set! + "cannot install non-atomic pointer into atomic memory" + "non-atomic pointer" orig-v + "destination" orig-p)] + [else + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + ;; Special treatment is needed for 'scheme-object, since + ;; the host Scheme rejects the use of 'scheme-object with + ;; `foreign-set!` + (foreign-set! (if (eq? host-rep 'scheme-object) + 'uptr + host-rep) + (cpointer-address p) + offset + (case host-rep + [(scheme-object) (object->addr v 1)] + [(void*) (cpointer-address v)] + [else v])))]))]))) + +(define (memcpy* to to-offset from from-offset len move?) + (let ([to (unwrap-cpointer* 'memcpy to)] + [from (unwrap-cpointer* 'memcpy from)]) + (cond + [(or (cpointer-nonatomic? to) + (cpointer-nonatomic? from)) + (cond + [(and (cpointer-nonatomic? to) + (cpointer-nonatomic? from)) + (let ([to-offset (+ to-offset (ptr-offset* to))] + [from-offset (+ from-offset (ptr-offset* from))]) + (cond + [(and (word-aligned? to-offset) + (word-aligned? from-offset) + (word-aligned? len)) + (let ([to-i (fxsrl to-offset log-ptr-size-in-bytes)] + [from-i (fxsrl from-offset log-ptr-size-in-bytes)] + [n (fxsrl len log-ptr-size-in-bytes)]) + (vector-copy! (cpointer-memory to) to-i + (cpointer-memory from) from-i + (+ from-i n)))] + [else + (raise-arguments-error (if move? 'memmove 'memcpy) "unaligned non-atomic memory transfer" + "destination" to + "source" from + "destination offset" to-offset + "source offset" from-offset + "count" len)]))] + [else + (raise-arguments-error (if move? 'memmove 'memcpy) "cannot copy non-atomic to/from atomic" + "destination" to + "source" from)])] + [else + (with-interrupts-disabled + (let ([to (fx+ (cpointer*-address to) to-offset)] + [from (fx+ (cpointer*-address from) from-offset)]) + (cond + [(and move? + ;; overlap? + (or (<= to from (fx+ to len -1)) + (<= from to (fx+ from len -1))) + ;; shifting up? + (< from to)) + ;; Copy from high to low to move in overlapping region + (let loop ([to (+ to len)] [from (+ from len)] [len len]) + (unless (fx= len 0) + (cond + #; + [(fx>= len 8) + (let ([to (fx- to 8)] + [from (fx- from 8)]) + (foreign-set! 'integer-64 to 0 + (foreign-ref 'integer-64 from 0)) + (loop to from (fx- len 8)))] + [(and (meta-cond [(> (fixnum-width) 32) #t] [else #f]) + (fx>= len 4)) + (let ([to (fx- to 4)] + [from (fx- from 4)]) + (foreign-set! 'integer-32 to 0 + (foreign-ref 'integer-32 from 0)) + (loop to from (fx- len 4)))] + [(fx>= len 2) + (let ([to (fx- to 2)] + [from (fx- from 2)]) + (foreign-set! 'integer-16 to 0 + (foreign-ref 'integer-16 from 0)) + (loop to from (fx- len 2)))] + [else + (let ([to (fx- to 1)] + [from (fx- from 1)]) + (foreign-set! 'integer-8 to 0 + (foreign-ref 'integer-8 from 0)) + (loop to from (fx- len 1)))])))] + [else + (let loop ([to to] [from from] [len len]) + (unless (fx= len 0) + (cond + #; + [(fx>= len 8) + (foreign-set! 'integer-64 to 0 + (foreign-ref 'integer-64 from 0)) + (loop (fx+ to 8) (fx+ from 8) (fx- len 8))] + [(and (meta-cond [(> (fixnum-width) 32) #t] [else #f]) + (fx>= len 4)) + (foreign-set! 'integer-32 to 0 + (foreign-ref 'integer-32 from 0)) + (loop (fx+ to 4) (fx+ from 4) (fx- len 4))] + [(fx>= len 2) + (foreign-set! 'integer-16 to 0 + (foreign-ref 'integer-16 from 0)) + (loop (fx+ to 2) (fx+ from 2) (fx- len 2))] + [else + (foreign-set! 'integer-8 to 0 + (foreign-ref 'integer-8 from 0)) + (loop (fx+ to 1) (fx+ from 1) (fx- len 1))])))])))]))) + +(define memcpy/memmove + (case-lambda + [(who cptr src-cptr count) + (check who cpointer? cptr) + (check who cpointer? src-cptr) + (check who exact-nonnegative-integer? count) + (memcpy* cptr 0 src-cptr 0 count (eq? who 'memmove))] + [(who cptr offset/src-cptr/src-cptr src-cptr/offset/count count/count/type) + (check who cpointer? cptr) + (cond + [(cpointer? offset/src-cptr/src-cptr) + ;; use y or z of x/y/z + (cond + [(ctype? count/count/type) + ;; use z of x/y/z + (check who exact-nonnegative-integer? src-cptr/offset/count) + (memcpy* cptr 0 (unwrap-cpointer who offset/src-cptr/src-cptr) 0 (* src-cptr/offset/count (ctype-sizeof count/count/type)) (eq? who 'memmove))] + [else + ;; use y of x/y/z + (check who exact-integer? src-cptr/offset/count) + (check who exact-nonnegative-integer? count/count/type) + (memcpy* cptr 0 (unwrap-cpointer who offset/src-cptr/src-cptr) src-cptr/offset/count src-cptr/offset/count (eq? who 'memmove))])] + [else + ;; use x of x/y/z + (check who exact-integer? offset/src-cptr/src-cptr) + (check who cpointer? src-cptr/offset/count) + (check who exact-nonnegative-integer? count/count/type) + (memcpy* cptr offset/src-cptr/src-cptr src-cptr/offset/count 0 count/count/type (eq? who 'memmove))])] + [(who cptr offset src-cptr src-offset/count count/type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who cpointer? src-cptr) + (cond + [(ctype? count/type) + ;; use y of x/y + (check who exact-nonnegative-integer? src-offset/count) + (let ([sz (ctype-sizeof count/type)]) + (memcpy* cptr (* sz offset) src-cptr 0 (* src-offset/count sz) (eq? who 'memmove)))] + [else + ;; use x of x/y + (check who exact-integer? src-offset/count) + (check who exact-nonnegative-integer? count/type) + (memcpy* cptr offset src-cptr src-offset/count count/type (eq? who 'memmove))])] + [(who cptr offset src-cptr src-offset count type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who cpointer? src-cptr) + (check who exact-integer? src-offset) + (check who ctype? type) + (let ([sz (ctype-sizeof type)]) + (memcpy* cptr (* offset sz) src-cptr (* src-offset sz) (* count sz) (eq? who 'memmove)))])) + +(define/who memcpy + (case-lambda + [(cptr src-cptr count) + (memcpy/memmove who cptr src-cptr count)] + [(cptr offset/src-cptr src-cptr/count count/type) + (memcpy/memmove who cptr offset/src-cptr src-cptr/count count/type)] + [(cptr offset src-cptr src-offset/count count/type) + (memcpy/memmove who cptr offset src-cptr src-offset/count count/type)] + [(cptr offset src-cptr src-offset count type) + (memcpy/memmove who cptr offset src-cptr src-offset count type)])) + +(define/who memmove + (case-lambda + [(cptr src-cptr count) + (memcpy/memmove who cptr src-cptr count)] + [(cptr offset/src-cptr src-cptr/count count/type) + (memcpy/memmove who cptr offset/src-cptr src-cptr/count count/type)] + [(cptr offset src-cptr src-offset/count count/type) + (memcpy/memmove who cptr offset src-cptr src-offset/count count/type)] + [(cptr offset src-cptr src-offset count type) + (memcpy/memmove who cptr offset src-cptr src-offset count type)])) + +;; ---------------------------------------- + +(define (memset* to to-offset byte len) + (let ([to (unwrap-cpointer* 'memset to)]) + (cond + [(cpointer-nonatomic? to) + (raise-arguments-error 'memset "cannot set non-atomic" + "destination" to)] + [else + (with-interrupts-disabled + (let ([to (fx+ (cpointer*-address to) to-offset)]) + (let loop ([to to] [len len]) + (unless (fx= len 0) + (foreign-set! 'unsigned-8 to 0 byte) + (loop (fx+ to 1) (fx- len 1))))))]))) + +(define/who memset + (case-lambda + [(cptr byte count) + (check who cpointer? cptr) + (check who byte? byte) + (check who exact-nonnegative-integer? count) + (memset* cptr 0 byte count)] + [(cptr byte/offset count/byte type/count) + (check who cpointer? cptr) + (cond + [(ctype? type/count) + (check who byte? byte/offset) + (check who exact-nonnegative-integer? count/byte) + (memset* cptr 0 byte/offset (fx* count/byte (ctype-sizeof type/count)))] + [else + (check who exact-integer? byte/offset) + (check who byte? count/byte) + (check who exact-nonnegative-integer? type/count) + (memset* cptr byte/offset count/byte type/count)])] + [(cptr offset byte count type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who byte? byte) + (check who exact-nonnegative-integer? count) + (check who ctype? type) + (memset* cptr (fx* offset (ctype-sizeof type)) byte (fx* count (ctype-sizeof type)))])) + +;; ---------------------------------------- + +;; With finalization through an ordered guardian, +;; a "late" weak hash table is just a hash table. +(define (make-late-weak-hasheq) + (make-weak-hasheq)) + +;; Same for late weak boxes: +(define (make-late-weak-box b) + (make-weak-box b)) + +(define malloc + ;; Recognize common ordering as fast cases, and dispatch to + ;; a general handler to arbtrary argument order + (case-lambda + [(arg1) + (cond + [(nonnegative-fixnum? arg1) + (normalized-malloc arg1 'atomic)] + [(ctype? arg1) + (normalized-malloc (ctype-sizeof arg1) (ctype-malloc-mode arg1))] + [else + (do-malloc (list arg1))])] + [(arg1 arg2) + (cond + [(and (nonnegative-fixnum? arg1) + (ctype? arg2)) + (normalized-malloc (* arg1 (ctype-sizeof arg2)) (ctype-malloc-mode arg2))] + [(and (ctype? arg1) + (nonnegative-fixnum? arg2)) + (normalized-malloc (* arg2 (ctype-sizeof arg1)) (ctype-malloc-mode arg1))] + [(and (nonnegative-fixnum? arg1) + (malloc-mode? arg2)) + (normalized-malloc arg1 arg2)] + [else + (do-malloc (list arg1 arg2))])] + [(arg1 arg2 arg3) (do-malloc (list arg1 arg2 arg3))] + [(arg1 arg2 arg3 arg4) (do-malloc (list arg1 arg2 arg3 arg4))] + [(arg1 arg2 arg3 arg4 arg5) (do-malloc (list arg1 arg2 arg3 arg4 arg5))])) + +(define (do-malloc args) + (let ([duplicate-argument + (lambda (what a1 a2) + (raise-arguments-error 'malloc + (string-append "mulitple " what " arguments") + "first" a1 + "second" a2))]) + (let loop ([args args] [count #f] [type #f] [copy-from #f] [mode #f] [fail-mode #f]) + (cond + [(null? args) + (let* ([len (* (or count 1) (if type (ctype-sizeof type) 1))] + [p (normalized-malloc len + (or mode (if type (ctype-malloc-mode type) 'atomic)))]) + (when copy-from + (memcpy* p 0 copy-from 0 len #f)) + p)] + [(nonnegative-fixnum? (car args)) + (if count + (duplicate-argument "size" count (car args)) + (loop (cdr args) (car args) type copy-from mode fail-mode))] + [(ctype? (car args)) + (if type + (duplicate-argument "type" type (car args)) + (loop (cdr args) count (car args) copy-from mode fail-mode))] + [(and (cpointer? (car args)) (car args)) + (if copy-from + (duplicate-argument "source for copy" copy-from (car args)) + (loop (cdr args) count type (car args) mode fail-mode))] + [(malloc-mode? (car args)) + (if copy-from + (duplicate-argument "mode" mode (car args)) + (loop (cdr args) count type copy-from (car args) fail-mode))] + [(eq? (car args) 'failok) + (if copy-from + (duplicate-argument "failure mode" fail-mode (car args)) + (loop (cdr args) count type copy-from mode (car args)))] + [else + (raise-argument-error 'malloc + (string-append "(or/c (and/c exact-nonnegative-integer? fixnum?)\n" + " ctype? cpointer?\n" + " (or/c 'raw 'atomic 'nonatomic 'tagged\n" + " 'atomic-interior 'interior\n" + " 'stubborn 'uncollectable 'eternal)\n" + " 'fail-ok)") + (car args))])))) + +(define (normalized-malloc size mode) + (cond + [(eqv? size 0) #f] + [(eq? mode 'raw) + (make-cpointer (foreign-alloc size) #f)] + [(eq? mode 'atomic) + (make-cpointer (make-bytevector size) #f)] + [(eq? mode 'nonatomic) + (make-cpointer (make-vector (quotient size 8) 0) #f)] + [(eq? mode 'atomic-interior) + ;; This is not quite the same as traditional Racket, because + ;; a finalizer is associated with the cpointer (as opposed to + ;; the address that is wrapped by the cpointer). Also, interior + ;; pointers are not allowed as GCable pointers. + (let* ([bstr (make-bytevector size)] + [p (make-cpointer bstr #f)]) + (lock-object bstr) + (the-foreign-guardian p (lambda () (unlock-object bstr))) + p)] + [else + (raise-unsupported-error 'malloc + (format "'~a mode is not supported" mode))])) + +(define/who (free p) + (let ([p (unwrap-cpointer who p)]) + (with-interrupts-disabled + (foreign-free (cpointer-address p))))) + +(define-record-type (cpointer/cell make-cpointer/cell cpointer/cell?) + (parent cpointer) + (fields)) + +(define (malloc-immobile-cell v) + (let ([vec (vector v)]) + (lock-object vec) + (make-cpointer/cell vec #f))) + +(define (free-immobile-cell b) + (unlock-object (cpointer-memory b))) + +(define (malloc-mode? v) + (chez:memq v '(raw atomic nonatomic tagged + atomic-interior interior + stubborn uncollectable eternal))) + +(define (end-stubborn-change p) + (raise-unsupported-error 'end-stubborn-change)) + +(define (extflvector->cpointer extfl-vector) + (raise-unsupported-error 'extflvector->cpointer)) + +(define (vector->cpointer vec) + (make-cpointer vec #f)) + +(define (flvector->cpointer flvec) + (make-cpointer (flvector-bstr flvec) #f)) + +;; ---------------------------------------- + +(define the-foreign-guardian (make-guardian)) + +;; Can be called in any host thread +(define (poll-foreign-guardian) + (let ([v (the-foreign-guardian)]) + (when v + (v) + (poll-foreign-guardian)))) + +;; ---------------------------------------- + +(define/who ffi-call + (case-lambda + [(p in-types out-type) + (ffi-call p in-types out-type #f #f #f)] + [(p in-types out-type abi) + (ffi-call p in-types out-type abi #f #f)] + [(p in-types out-type abi save-errno) + (ffi-call p in-types out-type abi save-errno #f)] + [(p in-types out-type abi save-errno orig-place?) + (ffi-call p in-types out-type abi save-errno orig-place? #f)] + [(p in-types out-type abi save-errno orig-place? lock-name) + (ffi-call p in-types out-type abi save-errno orig-place? lock-name #f)] + [(p in-types out-type abi save-errno orig-place? lock-name blocking?) + (check who cpointer? p) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + ((ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f) p)])) + +(define/who ffi-call-maker + (case-lambda + [(in-types out-type) + (ffi-call-maker in-types out-type #f #f #f)] + [(in-types out-type abi) + (ffi-call-maker in-types out-type abi #f #f)] + [(in-types out-type abi save-errno) + (ffi-call-maker in-types out-type abi save-errno #f)] + [(in-types out-type abi save-errno orig-place?) + (ffi-call-maker in-types out-type abi save-errno orig-place? #f)] + [(in-types out-type abi save-errno orig-place? lock-name) + (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f)] + [(in-types out-type abi save-errno orig-place? lock-name blocking?) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + (ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f)])) + +(define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply) + (let* ([conv (case abi + [(stdcall) '__stdcall] + [(sysv) '__cdecl] + [else #f])] + [by-value? (lambda (type) + ;; An 'array rep is compound, but should be + ;; passed as a pointer, so only pass 'struct and + ;; 'union "by value": + (chez:memq (ctype-host-rep type) '(struct union)))] + [array-rep-to-pointer-rep (lambda (host-rep) + (if (eq? host-rep 'array) + 'void* + host-rep))] + [ids (map (lambda (in-type) + (and (by-value? in-type) + (gensym))) + in-types)] + [ret-id (and (by-value? out-type) + (gensym))] + [decls (let loop ([in-types in-types] [ids ids] [decls '()]) + (cond + [(null? in-types) decls] + [(car ids) + (let ([id-decls ((compound-ctype-get-decls (car in-types)) (car ids))]) + (loop (cdr in-types) (cdr ids) (append decls id-decls)))] + [else + (loop (cdr in-types) (cdr ids) decls)]))] + [ret-decls (if ret-id + ((compound-ctype-get-decls out-type) ret-id) + '())] + [ret-size (and ret-id (ctype-sizeof out-type))] + [gen-proc+ret-maker+arg-makers + (let ([expr `(let () + ,@decls + ,@ret-decls + (list + (lambda (to-wrap) + (,(if call? 'foreign-procedure 'foreign-callable) + ,conv + ,@(if (or blocking? async-apply) '(__thread) '()) + to-wrap + ,(map (lambda (in-type id) + (if id + `(& ,id) + (array-rep-to-pointer-rep + (ctype-host-rep in-type)))) + in-types ids) + ,(if ret-id + `(& ,ret-id) + (array-rep-to-pointer-rep + (ctype-host-rep out-type))))) + ,(and call? + ret-id + `(lambda (p) + (make-ftype-pointer ,ret-id p))) + ,@(if call? + (map (lambda (id) + (and id + `(lambda (p) + (make-ftype-pointer ,id p)))) + ids) + '())))]) + (call-with-system-wind (lambda () (eval expr))))] + [gen-proc (car gen-proc+ret-maker+arg-makers)] + [ret-maker (cadr gen-proc+ret-maker+arg-makers)] + [arg-makers (cddr gen-proc+ret-maker+arg-makers)] + [async-callback-queue (and (procedure? async-apply) (current-async-callback-queue))]) + (cond + [call? + (lambda (to-wrap) + (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]) + (lambda args + (let* ([args (map (lambda (orig-arg in-type) + (let ([arg (s->c in-type orig-arg)]) + (if (and (cpointer? arg) + (not (eq? 'scheme-object (ctype-host-rep in-type)))) + (let ([p (unwrap-cpointer 'ffi-call arg)]) + (when (and (cpointer-nonatomic? p) + (not (cpointer/cell? p))) + (disallow-nonatomic-pointer 'argument orig-arg proc-p)) + p) + arg))) + args in-types)] + [r (let ([ret-ptr (and ret-id + ;; result is a struct type; need to allocate space for it + (make-bytevector ret-size))]) + (with-interrupts-disabled + (let ([r (#%apply (gen-proc (cpointer-address proc-p)) + (append + (if ret-ptr + (list (ret-maker (memory-address ret-ptr))) + '()) + (map (lambda (arg in-type maker) + (let ([host-rep (array-rep-to-pointer-rep + (ctype-host-rep in-type))]) + (case host-rep + [(void*) (cpointer-address arg)] + [(struct union) + (maker (cpointer-address arg))] + [else arg]))) + args in-types arg-makers)))]) + (case save-errno + [(posix) (thread-cell-set! errno-cell (get-errno))] + [(windows) (thread-cell-set! errno-cell (get-last-error))]) + (cond + [ret-ptr + (make-cpointer ret-ptr #f)] + [(eq? (ctype-our-rep out-type) 'gcpointer) + (addr->gcpointer-memory r)] + [else r]))))]) + (c->s out-type r)))))] + [else ; callable + (lambda (to-wrap) + (gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result + (let ([v (call-as-atomic-callback + (lambda () + (s->c + out-type + (apply to-wrap + (let loop ([args (if ret-id (cdr args) args)] [in-types in-types]) + (cond + [(null? args) '()] + [else + (let* ([arg (car args)] + [type (car in-types)] + [arg (c->s type + (case (ctype-host-rep type) + [(struct union) + (let* ([size (compound-ctype-size type)] + [addr (ftype-pointer-address arg)] + [bstr (make-bytevector size)]) + (memcpy* bstr 0 addr 0 size #f) + (make-cpointer bstr #f))] + [else + (cond + [(eq? (ctype-our-rep type) 'gcpointer) + (addr->gcpointer-memory arg)] + [else arg])]))]) + (cons arg (loop (cdr args) (cdr in-types))))]))))) + atomic? + async-apply + async-callback-queue)]) + (if ret-id + (let* ([size (compound-ctype-size out-type)] + [addr (ftype-pointer-address (car args))]) + (memcpy* addr 0 v 0 size #f)) + (case (ctype-host-rep out-type) + [(void*) (cpointer-address v)] + [else v]))))))]))) + +(define (types->reps types) + (let loop ([types types] [reps '()] [decls '()]) + (cond + [(null? types) (values (reverse reps) decls)] + [else + (let ([type (car types)]) + (if (compound-ctype? type) + (let* ([id (gensym)] + [id-decls ((compound-ctype-get-decls type) id)]) + (loop (cdr types) (cons id reps) (append id-decls decls))) + (loop (cdr types) (cons (ctype-host-rep type) reps) decls)))]))) + +(define (disallow-nonatomic-pointer what arg proc-p) + (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function" + "pointer" arg + "function" (or (and (ffi-obj? proc-p) + (cpointer/ffi-obj-name proc-p)) + 'unknown))) + +;; Rely on the fact that a virtual register defaults to 0 to detect a +;; thread that we didn't start. For a thread that we did start, a +(define PLACE-UNKNOWN-THREAD 0) +(define PLACE-KNOWN-THREAD 1) +(define PLACE-MAIN-THREAD 2) +(define-virtual-register place-thread-category PLACE-KNOWN-THREAD) +(define (register-as-place-main!) + (place-thread-category PLACE-MAIN-THREAD) + (current-async-callback-queue (make-async-callback-queue (make-mutex) + (make-condition) + '()))) + +;; Can be called in any Scheme thread +(define (call-as-atomic-callback thunk atomic? async-apply async-callback-queue) + (cond + [(eqv? (place-thread-category) PLACE-MAIN-THREAD) + ;; In the main thread of a place. We must have gotten here by a + ;; foreign call that called back, so interrupts are currently + ;; disabled. + (cond + [(not atomic?) + ;; reenable interrupts + (enable-interrupts) + (let ([v (thunk)]) + (disable-interrupts) + v)] + [else + ;; Inform the scheduler that it's in atomic mode + (scheduler-start-atomic) + (let ([v (thunk)]) + (scheduler-end-atomic) + v)])] + [(box? async-apply) + ;; Not in a place's main thread; return the box's content + (unbox async-apply)] + [else + ;; Not in a place's main thread; queue an async callback + ;; and wait for the response + (let* ([result-done? (box #f)] + [result #f] + [q async-callback-queue] + [m (async-callback-queue-lock q)] + [need-interrupts? + ;; If we created this therad by `fork-pthread`, we must + ;; have gotten here by a foreign call, so interrupts are + ;; currently disabled + (eqv? (place-thread-category) PLACE-KNOWN-THREAD)]) + (mutex-acquire m) + (set-async-callback-queue-in! q (cons (lambda () + (set! result (|#%app| async-apply thunk)) + (mutex-acquire m) + (set-box! result-done? #t) + (condition-broadcast (async-callback-queue-condition q)) + (mutex-release m)) + (async-callback-queue-in q))) + (async-callback-poll-wakeup) + (let loop () + (unless (unbox result-done?) + (when need-interrupts? + ;; Enable interrupts so that the thread is deactivated + ;; when we wait on the condition + (enable-interrupts)) + (condition-wait (async-callback-queue-condition q) m) + (when need-interrupts? (disable-interrupts)) + (loop))) + (mutex-release m) + result)])) + +(define scheduler-start-atomic void) +(define scheduler-end-atomic void) +(define (set-scheduler-atomicity-callbacks! start-atomic end-atomic) + (set! scheduler-start-atomic start-atomic) + (set! scheduler-end-atomic end-atomic)) + +(define async-callback-poll-wakeup void) +(define (set-async-callback-poll-wakeup! wakeup) + (set! async-callback-poll-wakeup wakeup)) + +(define-record async-callback-queue (lock condition in)) + +(define-virtual-register current-async-callback-queue #f) + +;; Returns callbacks to run in atomic mode +(define (poll-async-callbacks) + (let ([q (current-async-callback-queue)]) + (mutex-acquire (async-callback-queue-lock q)) + (let ([in (async-callback-queue-in q)]) + (cond + [(null? in) + (mutex-release (async-callback-queue-lock q)) + '()] + [else + (set-async-callback-queue-in! q '()) + (mutex-release (async-callback-queue-lock q)) + (reverse in)])))) + +;; ---------------------------------------- + +(define-record-type (callback create-callback ffi-callback?) + (fields code)) + +(define/who ffi-callback + (case-lambda + [(proc in-types out-type) + (ffi-callback proc in-types out-type #f #f #f)] + [(proc in-types out-type abi) + (ffi-callback proc in-types out-type abi #f #f)] + [(proc in-types out-type abi atomic?) + (ffi-callback proc in-types out-type abi atomic? #f)] + [(proc in-types out-type abi atomic? async-apply) + (check who procedure? proc) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + ((ffi-callback-maker in-types out-type abi atomic? async-apply) proc)])) + +(define/who ffi-callback-maker + (case-lambda + [(in-types out-type) + (ffi-callback-maker in-types out-type #f #f #f)] + [(in-types out-type abi) + (ffi-callback-maker in-types out-type abi #f #f)] + [(in-types out-type abi atomic?) + (ffi-callback-maker in-types out-type abi atomic? #f)] + [(in-types out-type abi atomic? async-apply) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + (let ([make-code (ffi-call/callable #f in-types out-type abi #f #f (and atomic? #t) async-apply)]) + (lambda (proc) + (check 'make-ffi-callback procedure? proc) + (let* ([code (make-code proc)] + [cb (create-callback code)]) + (lock-object code) + (the-foreign-guardian cb (lambda () (unlock-object code))) + cb)))])) + +;; ---------------------------------------- + +(define/who (make-sized-byte-string cptr len) + (check who cpointer? cptr) + (check who exact-nonnegative-integer? len) + (raise-unsupported-error who)) + +(define errno-cell (make-thread-cell 0)) + +(define/who saved-errno + (case-lambda + [() (thread-cell-ref errno-cell)] + [(v) + (check who exact-integer? v) + (thread-cell-set! errno-cell v)])) + +(define/who (lookup-errno sym) + (check who symbol? sym) + (raise-unsupported-error who)) + +;; function is called with interrupts disabled +(define get-errno + (let ([get-&errno-name + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) + (load-shared-object "msvcrt.dll") + "_errno"] + [(a6osx ta6osx i3osx ti3osx) + (load-shared-object "libc.dylib") + "__error"] + [(a6le ta6le i3le ti3le) + (load-shared-object "libc.so.6") + "__errno_location"] + [else + ;; FIXME for more platforms + (load-shared-object "libc.so") + "__error"])]) + (let ([get-&errno (foreign-procedure get-&errno-name () void*)]) + (lambda () + (foreign-ref 'int (get-&errno) 0))))) + +;; function is called with interrupts disabled +(define get-last-error + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) + (load-shared-object "kernel32.dll") + (foreign-procedure "GetLastError" () int)] + [else (lambda () 0)])) + +;; ---------------------------------------- + +(define process-global-table (make-hashtable equal-hash-code equal?)) +(define process-table-lock (make-mutex)) + +(define (unsafe-register-process-global key val) + (with-interrupts-disabled + (mutex-acquire process-table-lock) + (let ([result (cond + [(not val) + (hashtable-ref process-global-table key #f)] + [else + (let ([old-val (hashtable-ref process-global-table key #f)]) + (cond + [(not old-val) + (hashtable-set! process-global-table key val) + #f] + [else old-val]))])]) + (mutex-release process-table-lock) + result))) + +;; ---------------------------------------- + +(define (set-cpointer-hash!) + (record-type-equal-procedure (record-type-descriptor cpointer) + (lambda (a b eql?) + (ptr-equal? a b))) + (record-type-hash-procedure (record-type-descriptor cpointer) + (lambda (a hc) + (if (number? (cpointer-memory a)) + (hc (+ (cpointer-memory a) + (ptr-offset* a))) + (eq-hash-code (cpointer-memory a)))))) diff -Nru racket-6.12+ppa1/src/cs/rumble/fsemaphore.ss racket-7.0+ppa1/src/cs/rumble/fsemaphore.ss --- racket-6.12+ppa1/src/cs/rumble/fsemaphore.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/fsemaphore.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +;; future semaphores + +;; just copied from expander-compat.scm +(define-record-type (fsemaphore create-fsemaphore fsemaphore?) + (fields sema)) + +(define (make-fsemaphore init) + (create-fsemaphore (make-semaphore init))) + +(define (fsemaphore-post fsema) + (semaphore-post (fsemaphore-sema f))) + +(define (fsemaphore-wait fsema) + (semaphore-wait (fsemaphore-sema f))) + +(define (fsemaphore-try-wait fsema) + (semaphore-try-wait? (fsemaphore-sema f))) + +(define (fsemaphore-count fsema) + (semaphore-count (fsemaphore-sema f))) diff -Nru racket-6.12+ppa1/src/cs/rumble/future.ss racket-7.0+ppa1/src/cs/rumble/future.ss --- racket-6.12+ppa1/src/cs/rumble/future.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/future.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +;; Futures API + +(define future? (lambda (f) #f)) +(define current-future (lambda () #f)) +(define block (lambda () (void))) +(define current-future-prompt (lambda () (void))) +(define future-wait (lambda () (void))) + +(define (set-future-callbacks! _future? _current-future _block wait cfp) + (set! future? _future?) + (set! current-future _current-future) + (set! block _block) + (set! future-wait wait) + (set! current-future-prompt cfp)) diff -Nru racket-6.12+ppa1/src/cs/rumble/graph.ss racket-7.0+ppa1/src/cs/rumble/graph.ss --- racket-6.12+ppa1/src/cs/rumble/graph.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/graph.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,172 @@ + +(define-record placeholder (val)) +(define-record-type (hash-placeholder create-hash-placeholder hash-placeholder?) + (fields (mutable alist))) +(define-record-type (hasheq-placeholder create-hasheq-placeholder hasheq-placeholder?) + (parent hash-placeholder) + (fields)) +(define-record-type (hasheqv-placeholder create-hasheqv-placeholder hasheqv-placeholder?) + (parent hash-placeholder) + (fields)) + +(define (placeholder-set! ph datum) + (set-placeholder-val! ph datum)) + +(define (placeholder-get ph) + (placeholder-val ph)) + +(define/who (make-hash-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hash-placeholder alst)) + +(define/who (make-hasheq-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hasheq-placeholder alst)) + +(define/who (make-hasheqv-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hasheqv-placeholder alst)) + +(define/who (make-reader-graph orig-v) + (let ([ht (make-eq-hashtable)]) + (let loop ([v orig-v]) + (cond + [(hashtable-ref ht v #f) + => (lambda (p) p)] + [(placeholder? v) + (let ([next (placeholder-val v)]) + (when (eq? v next) + (raise-arguments-error who + "illegal placeholder cycle in value" + "value" orig-v)) + (loop next))] + [(pair? v) + (let ([p (cons #f #f)]) + (hashtable-set! ht v p) + (set-car! p (loop (car v))) + (set-cdr! p (loop (cdr v))) + (cond + [(and (eq? (car p) (car v)) + (eq? (cdr p) (cdr v))) + ;; No change, so we don't have to make a copy: + (hashtable-set! ht v v) + v] + [else p]))] + [(vector? v) + (let* ([len (vector-length v)] + [p (make-vector len)]) + (hashtable-set! ht v p) + (let vloop ([i 0] [diff? #f]) + (cond + [(fx= i len) + (cond + [diff? + (if (mutable-vector? v) + p + (begin + (#%$vector-set-immutable! p) + p))] + [else + (hashtable-set! ht v v) + v])] + [else + (vector-set! p i (loop (vector-ref v i))) + (vloop (fx1+ i) (or diff? (not (eq? (vector-ref v i) (vector-ref p i)))))])))] + [(box? v) + (let ([p (box #f)]) + (hashtable-set! ht v p) + (set-box! p (loop (unbox v))) + (cond + [(eq? (unbox p) (unbox v)) + (hashtable-set! ht v v) + v] + [(mutable-box? v) + p] + [else + ;; FIXME: need a way to change a box to immutable + p]))] + [(hash? v) + (let* ([mutable? (mutable-hash? v)] + [orig-p (if mutable? + (if (hash-weak? v) + (cond + [(hash-eq? v) (make-weak-hasheq)] + [(hash-eqv? v) (make-weak-hasheqv)] + [else (make-weak-hasheq)]) + (cond + [(hash-eq? v) (make-hasheq)] + [(hash-eqv? v) (make-hasheqv)] + [else (make-hasheq)])) + (cond + [(hash-eq? v) (make-intmap-shell 'eq)] + [(hash-eqv? v) (make-intmap-shell 'eqv)] + [else (make-intmap-shell 'equal)]))]) + (hashtable-set! ht v orig-p) + (let hloop ([p orig-p] [i (hash-iterate-first v)] [diff? #f]) + (cond + [(not i) + (cond + [diff? + (cond + [mutable? orig-p] + [else + (intmap-shell-sync! orig-p p) + orig-p])] + [else + (hashtable-set! ht v v) + v])] + [else + (let-values ([(key val) (hash-iterate-key+value v i)]) + (let ([new-key (loop key)] + [new-val (loop val)]) + (hloop (if mutable? + (hash-set! orig-p key val) + (hash-set p key val)) + (hash-iterate-next v i) + (or diff? (not (and (eq? key new-key) (eq? val new-val)))))))])))] + [(hash-placeholder? v) + (let* ([orig-p (cond + [(hasheq-placeholder? v) (make-intmap-shell 'eq)] + [(hasheqv-placeholder? v) (make-intmap-shell 'eqv)] + [else (make-intmap-shell 'equal)])]) + (hashtable-set! ht v orig-p) + (let hloop ([p orig-p] [alst (hash-placeholder-alist v)]) + (cond + [(null? alst) + (intmap-shell-sync! orig-p p) + orig-p] + [else + (hloop (hash-set p (loop (caar alst)) (loop (cdar alst))) + (cdr alst))])))] + [(prefab-struct-key v) + => (lambda (key) + (let ([args (cdr (vector->list (struct->vector v)))]) + (let ([p (apply make-prefab-struct key args)]) + (hashtable-set! ht v p) + (let aloop ([args args] [i 0] [diff? #f]) + (cond + [(null? args) + (cond + [diff? p] + [else + (hashtable-set! ht v v) + v])] + [else + (let* ([a (car args)] + [new-a (loop a)]) + (unless (eq? a new-a) + (unsafe-struct-set! p i new-a)) + (aloop (cdr args) (fx1+ i) (or diff? (not (eq? a new-a)))))])))))] + [else v])))) diff -Nru racket-6.12+ppa1/src/cs/rumble/hamt.ss racket-7.0+ppa1/src/cs/rumble/hamt.ss --- racket-6.12+ppa1/src/cs/rumble/hamt.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/hamt.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,932 @@ +;; HAMT + +;; the absence of something +(define NOTHING (gensym 'nothing)) + +;; 16-bit popcount +(define (popcount x) + (let* ([x (fx- x (fxand (fxsrl x 1) #x5555))] + [x (fx+ (fxand x #x3333) (fxand (fxsrl x 2) #x3333))] + [x (fxand (fx+ x (fxsrl x 4)) #x0f0f)] + [x (fx+ x (fxsrl x 8))]) + (fxand x #x1f))) + +;; record types +(define-record-type hnode + [fields (immutable eqtype) + (mutable count) + (mutable keys) + (mutable vals)] + [nongenerative #{hnode pfwh8wvaevt3r6pcwsqn90ry8-0}]) + +(meta-cond + [(> (most-positive-fixnum) (expt 2 32)) + + ;; 64-bit bnode (pack the bitmaps into a single fixnum) + (define-record-type (bnode make-raw-bnode bnode?) + [parent hnode] + [fields (mutable bitmap)] + [nongenerative #{bnode pfwhzqkm2ycuuyedzz2nxjx2e-0}] + [sealed #t]) + + (define (make-bnode eqtype count keys vals keymap childmap) + (let ([bitmap (fxior keymap (fxsll childmap 16))]) + (make-raw-bnode eqtype count keys vals bitmap))) + + (define (bnode-keymap n) + (fxand #xffff (bnode-bitmap n))) + + (define (bnode-childmap n) + (fxsrl (bnode-bitmap n) 16)) + + (define (bnode-copy-bitmaps! dest src) + (bnode-bitmap-set! dest (bnode-bitmap src)))] + + [else + + ;; 32-bit bnode (separate bitmaps) + (define-record-type bnode + [parent hnode] + [fields (mutable keymap) + (mutable childmap)] + [nongenerative #{bnode pfwhzqkm2ycuuyedzz2nxjx2e-1}] + [sealed #t]) + + (define (bnode-copy-bitmaps! dest src) + (bnode-set-keymap! dest (bnode-keymap src)) + (bnode-set-childmap! dest (bnode-childmap src)))]) + +(define-record-type cnode + [parent hnode] + [fields (immutable hash)] + [nongenerative #{cnode pfwh0bwrq2nqlke97ikru0ds2-0}] + [sealed #t]) + +(define (make-empty-bnode eqtype) + (make-bnode eqtype + 0 + (vector) + #f + 0 + 0)) + +(define empty-hasheq (make-empty-bnode 'eq)) +(define empty-hasheqv (make-empty-bnode 'eqv)) +(define empty-hash (make-empty-bnode 'equal)) + +(define (make-hamt-shell eqtype) + (make-empty-bnode eqtype)) + +(define (hamt-shell-sync! dest src) + (hnode-count-set! dest (hnode-count src)) + (hnode-keys-set! dest (hnode-keys src)) + (hnode-vals-set! dest (hnode-vals src)) + (bnode-copy-bitmaps! dest src)) + +;; hamt interface +(define hamt? hnode?) +(define immutable-hash? hnode?) + +(define (hamt-eq? h) + (eq? (hnode-eqtype h) 'eq)) + +(define (hamt-eqv? h) + (eq? (hnode-eqtype h) 'eqv)) + +(define (hamt-equal? h) + (eq? (hnode-eqtype h) 'equal)) + +(define (hamt-has-key? h key) + (node-has-key? h key (hash-code h key) 0)) + +(define (node-has-key? n key keyhash shift) + (cond [(bnode? n) (bnode-has-key? n key keyhash shift)] + [else (cnode-has-key? n key)])) + +(define (hamt-ref h key default) + (cond + [(hamt-empty? h) + ;; Access on an empty HAMT is common, so don't even hash in that case + (if (procedure? default) + (default) + default)] + [else + (let ([res (bnode-ref h key (hash-code h key) 0)]) + (if (eq? res NOTHING) + (if (procedure? default) + (default) + default) + res))])) + +(define (hamt-set h key val) + (bnode-set h key val (hash-code h key) 0)) + +(define (hamt-remove h key) + (bnode-remove h key (hash-code h key) 0)) + +(define (hamt-count h) + (hnode-count h)) + +(define (hamt-empty? h) + (fxzero? (hamt-count h))) + +(define (hamt=? a b eql?) + (and (eq? (hnode-eqtype a) + (hnode-eqtype b)) + (node=? a b eql? 0))) + +(define (hamt-hash-code a hash) + (node-hash-code a hash 0)) + +(define ignored/hamt + (begin + ;; Go through generic `hash` versions to support `a` + ;; and `b` as impersonated hash tables + (record-type-equal-procedure (record-type-descriptor bnode) + (lambda (a b eql?) + (hash=? a b eql?))) + (record-type-hash-procedure (record-type-descriptor bnode) + (lambda (a hash) + (hash-hash-code a hash))))) + +(define (hamt-keys-subset? a b) + (or (hamt-empty? a) + (node-keys-subset? a b 0))) + +(define (hamt-foldk h f nil kont) + (bnode-foldk h f nil kont)) + +(define (hamt-fold h nil fn) + (hamt-foldk + h + (lambda (key val nil k) + (k (fn key val nil))) + nil + (lambda (x) x))) + +(define (hamt->list h) + (hamt-fold h '() (lambda (k v xs) (cons (cons k v) xs)))) + +(define (hamt-keys h) + (hamt-fold h '() (lambda (k _ xs) (cons k xs)))) + +(define (hamt-values h) + (hamt-fold h '() (lambda (_ v xs) (cons v xs)))) + +(define (hamt-for-each h proc) + (hamt-fold h (void) (lambda (k v _) (proc k v) (void)))) + +(define (hamt-map h proc) + (hamt-fold h '() (lambda (k v xs) (cons (proc k v) xs)))) + +;; generatic iteration by counting +(define (hamt-iterate-first h) + (and (not (hamt-empty? h)) + 0)) + +(define (hamt-iterate-next h pos) + (let ([pos (fx1+ pos)]) + (and (not (fx= pos (hamt-count h))) + pos))) + +(define (hamt-iterate-key h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (car p) + fail))) + +(define (hamt-iterate-value h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (cdr p) + fail))) + +(define (hamt-iterate-key+value h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (values (car p) (cdr p)) + fail))) + +(define (hamt-iterate-pair h pos fail) + (let ([p (node-entry-at-position h pos)]) + (or p fail))) + +;; unsafe iteration; position is a stack +;; represented by a list of (cons node index) +(define (unsafe-hamt-iterate-first h) + (and (not (hamt-empty? h)) + (unsafe-node-iterate-first h '()))) + +(define (unsafe-node-iterate-first n stack) + (cond + [(bnode? n) + (let ([i (fx1- (#%vector-length (hnode-keys n)))] + [key-count (popcount (bnode-keymap n))]) + (let ([stack (cons (cons n i) stack)]) + (if (fx>= i key-count) + (unsafe-node-iterate-first (key-ref n i) stack) + stack)))] + [(cnode? n) + (let ([i (fx1- (#%vector-length (hnode-keys n)))]) + (cons (cons n i) stack))])) + +(define (unsafe-hamt-iterate-next h pos) + (unsafe-node-iterate-next pos)) + +(define (unsafe-node-iterate-next pos) + (cond + [(null? pos) + ;; Stack is empty, so we're done + #f] + [else + (let ([p (car pos)] + [stack (cdr pos)]) + (let ([n (car p)] + [i (cdr p)]) + (cond + [(fx= 0 i) + ;; Exhausted this node, so return to parent node + (unsafe-node-iterate-next stack)] + [else + ;; Move to next (lower) index in the current node + (let ([i (fx1- i)]) + (cond + [(bnode? n) + (let ([key-count (popcount (bnode-keymap n))] + [stack (cons (cons n i) stack)]) + (if (fx>= i key-count) + (unsafe-node-iterate-first (key-ref n i) stack) + stack))] + [(cnode? n) + (cons (cons n i) stack)]))])))])) + +(define (unsafe-hamt-iterate-key h pos) + (let ([p (car pos)]) + (key-ref (car p) (cdr p)))) + +(define (unsafe-hamt-iterate-value h pos) + (let ([p (car pos)]) + (val-ref (car p) (cdr p)))) + +(define (unsafe-hamt-iterate-key+value h pos) + (let ([p (car pos)]) + (let ([n (car p)] + [i (cdr p)]) + (values (key-ref n i) + (val-ref n i))))) + +(define (unsafe-hamt-iterate-pair h pos) + (let ([p (car pos)]) + (let ([n (car p)] + [i (cdr p)]) + (cons (key-ref n i) + (val-ref n i))))) + +;; constants +(define HASHCODE-BITS (fxbit-count (most-positive-fixnum))) +(define BNODE-BITS 4) +(define BNODE-MASK (fx1- (fxsll 1 BNODE-BITS))) + +;; vector operations +(define (vector-insert v i x) + (let* ([len (#%vector-length v)] + [new (make-vector (fx1+ len))]) + (vector*-copy! new 0 v 0 i) + (#%vector-set! new i x) + (vector*-copy! new (fx1+ i) v i len) + new)) + +(define (vector-remove v i) + (let* ([len (#%vector-length v)] + [new (make-vector (fx1- len))]) + (vector*-copy! new 0 v 0 i) + (vector*-copy! new i v (fx1+ i) len) + new)) + +;; hnode operations +(define (key=? n k1 k2) + (case (hnode-eqtype n) + [(eq) (eq? k1 k2)] + [(eqv) (eqv? k1 k2)] + [else (key-equal? k1 k2)])) + +(define (hash-code n k) + (case (hnode-eqtype n) + [(eq) (eq-hash-code k)] + [(eqv) (eqv-hash-code k)] + [else (key-equal-hash-code k)])) + +(define (key-ref n i) + (#%vector-ref (hnode-keys n) i)) + +(define (val-ref n i) + (let ([vals (hnode-vals n)]) + (or (not vals) + (#%vector-ref vals i)))) + +(define (node-ref n key keyhash shift) + (cond [(bnode? n) (bnode-ref n key keyhash shift)] + [else (cnode-ref n key)])) + +(define (node-set n key val keyhash shift) + (cond [(bnode? n) (bnode-set n key val keyhash shift)] + [else (cnode-set n key val)])) + +(define (node-remove n key keyhash shift) + (cond [(bnode? n) (bnode-remove n key keyhash shift)] + [else (cnode-remove n key keyhash)])) + +(define (node-singleton? node) + (fx= (hnode-count node) 1)) + +(define (node=? a b eql? shift) + (or (eq? a b) + (and (fx= (hnode-count a) (hnode-count b)) + (cond [(bnode? a) (bnode=? a b eql? shift)] + [else (cnode=? a b eql?)])))) + +(define (node-hash-code n hash hc) + (cond + [(bnode? n) + (let* ([bm (fxior (bnode-keymap n) (bnode-childmap n))] + [hc (hash-code-combine hc bm)] + [len (#%vector-length (hnode-keys n))] + [key-count (popcount (bnode-keymap n))]) + (let loop ([i 0] [hc hc]) + (cond + [(fx= i len) hc] + [else + (let ([x (key-ref n i)]) + (cond + [(fx>= i key-count) + (loop (fx1+ i) + (node-hash-code x hash hc))] + [else + (loop (fx1+ i) + (hash-code-combine hc (hash (val-ref n i))))]))])))] + [else + ;; Hash code needs to be order-independent, so + ;; collision nodes are a problem; simplify by just + ;; using the hash code and hope that collisions are + ;; rare. + (hash-code-combine hc (cnode-hash n))])) + +(define (node-keys-subset? a b shift) + (or (eq? a b) + (and (fx<= (hnode-count a) (hnode-count b)) + (cond [(bnode? a) (bnode-keys-subset? a b shift)] + [else (cnode-keys-subset? a b shift)])))) + +(define (node-entry-at-position n pos) + (cond [(bnode? n) (bnode-entry-at-position n pos)] + [else (cnode-entry-at-position n pos)])) + +(define (node-foldk n f nil kont) + (cond [(bnode? n) (bnode-foldk n f nil kont)] + [else (cnode-foldk n f nil kont)])) + +;; bnode operations +(define (bnode-ref node key keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)]) + (if (key=? node key k) + (val-ref node ki) + NOTHING))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [c (child-ref node ci)]) + (node-ref c key keyhash (down shift)))] + + [else + NOTHING]))) + +(define (bnode-has-key? n key keyhash shift) + (not (eq? NOTHING (bnode-ref n key keyhash shift)))) + +(define (bnode-set node key val keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)] + [v (val-ref node ki)]) + (cond + [(key=? node key k) + (if (eq? val v) + node + (bnode-replace-val node ki val))] + [else + (let* ([h (hash-code node k)] + [eqtype (hnode-eqtype node)] + [child (node-merge eqtype k v h key val keyhash (down shift))]) + (bnode-add-child node child ki bit))]))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [child (child-ref node ci)] + [new-child (node-set child key val keyhash (down shift))]) + (if (eq? new-child child) + node + (bnode-replace-child node child new-child ci)))] + + [else + (bnode-add-key node key val bit)]))) + +(define (bnode-remove node key keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)]) + (cond + [(key=? node key k) + (let ([km (bnode-keymap node)] + [cm (bnode-childmap node)]) + (if (and (fx= (popcount km) 2) + (fxzero? cm)) + (bnode-singleton node ki bit keyhash shift) + (bnode-remove-key node ki bit)))] + [else + node]))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [child (child-ref node ci)] + [new-child (node-remove child key keyhash (down shift))]) + (cond + [(eq? new-child child) node] + [(node-singleton? new-child) + (if (and (fxzero? (bnode-childmap node)) + (fx= (popcount (bnode-keymap node)) 1)) + new-child + (bnode-remove-child node new-child ci bit))] + [else + (bnode-replace-child node child new-child ci)]))] + + [else + node]))) + +(define (bnode=? a b eql? shift) + (and + (bnode? b) + (fx= (bnode-keymap a) (bnode-keymap b)) + (fx= (bnode-childmap a) (bnode-childmap b)) + + (let* ([keys (hnode-keys a)] + [len (#%vector-length keys)] + [key-count (popcount (bnode-keymap a))]) + (let loop ([i 0]) + (cond + [(fx= i len) #t] + [else + (let ([ak (key-ref a i)] + [bk (key-ref b i)]) + (and + (cond + [(fx>= i key-count) + (node=? ak bk eql? (down shift))] + [else + (and (key=? a ak bk) + (eql? (val-ref a i) (val-ref b i)))]) + (loop (fx1+ i))))]))))) + +(define (bnode-keys-subset? a b shift) + (cond + [(bnode? b) + (let* ([akm (bnode-keymap a)] + [bkm (bnode-keymap b)] + [acm (bnode-childmap a)] + [bcm (bnode-childmap b)] + [abm (fxior akm acm)] + [bbm (fxior bkm bcm)]) + (and + (fx= abm (fxand abm bbm)) + + (let loop ([abm abm] [bit 0] [aki 0] [bki 0] [aci 0] [bci 0]) + (cond + [(fxzero? abm) #t] + [(fxbit-set? akm bit) + (cond + [(fxbit-set? bkm bit) + (and + (key=? a (key-ref a aki) (key-ref b bki)) + (loop (fxsrl abm 1) (fx1+ bit) (fx1+ aki) (fx1+ bki) aci bci))] + [else + (and + (let ([akey (key-ref a aki)] + [bchild (child-ref b bci)]) + (node-has-key? bchild akey (hash-code a akey) (down shift))) + (loop (fxsrl abm 1) (fx1+ bit) (fx1+ aki) bki aci (fx1+ bci)))])] + [(fxbit-set? acm bit) + (cond + [(fxbit-set? bkm bit) #f] + [else + (and + (node-keys-subset? (child-ref a aci) (child-ref b bci) (down shift)) + (loop (fxsrl abm 1) (fx1+ bit) aki bki (fx1+ aci) (fx1+ bci)))])] + [(fxbit-set? bkm bit) + (loop (fxsrl abm 1) (fx1+ bit) aki (fx1+ bki) aci bci)] + [(fxbit-set? bcm bit) + (loop (fxsrl abm 1) (fx1+ bit) aki bki aci (fx1+ bci))] + [else + (loop (fxsrl abm 1) (fx1+ bit) aki bki aci bci)]))))] + + [else + (let* ([akeys (hnode-keys a)] + [len (#%vector-length akeys)]) + (and (fx= len 1) + (let ([x (#%vector-ref akeys 0)]) + (if (fx= 0 (bnode-keymap a)) + (node-keys-subset? x b (down shift)) + (not (not (cnode-index b x)))))))])) + +(define (bnode-bit-pos hash shift) + (fxsll 1 (bnode-mask hash shift))) + +(define (bnode-mask hash shift) + (fxand (fxsrl hash shift) BNODE-MASK)) + +(define (bnode-maps-key? node bit) + (bnode-maps-bit? (bnode-keymap node) bit)) + +(define (bnode-maps-child? node bit) + (bnode-maps-bit? (bnode-childmap node) bit)) + +(define (bnode-maps-bit? bitmap bit) + (not (fxzero? (fxand bitmap bit)))) + +(define (bnode-index bitmap bit) + (popcount (fxand bitmap (fx1- bit)))) + +(define (bnode-key-index node bit) + (bnode-index (bnode-keymap node) bit)) + +(define (bnode-child-index node bit) + (bnode-index (bnode-childmap node) bit)) + +(define (child-ref n i) + (let ([keys (hnode-keys n)]) + (#%vector-ref keys (fx- (#%vector-length keys) 1 i)))) + +(define (down shift) + (fx+ shift BNODE-BITS)) + +(define (bnode-add-key node key val bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [ki (bnode-key-index node bit)] + [new-keys (vector-insert keys ki key)] + [new-vals + (cond + [vals (vector-insert vals ki val)] + [(eq? val #t) #f] + [else ; reify values + (pariah + (let* ([pop (popcount (bnode-keymap node))] + [v (make-vector (fx1+ pop) #t)]) + (#%vector-set! v ki val) + v))])]) + + (make-bnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + new-keys + new-vals + (fxior (bnode-keymap node) bit) + (bnode-childmap node)))) + +(define (bnode-remove-key node ki bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [new-keys (vector-remove keys ki)] + [new-vals (and vals (vector-remove vals ki))]) + + (make-bnode (hnode-eqtype node) + (fx1- (hnode-count node)) + new-keys + new-vals + (fxxor (bnode-keymap node) bit) + (bnode-childmap node)))) + +(define (bnode-replace-val node ki val) + (let* ([vals (hnode-vals node)] + [new-vals + (if vals + (#%vector-copy vals) + (pariah ; reify values + (let ([pop (popcount (bnode-keymap node))]) + (make-vector pop #t))))]) + + (#%vector-set! new-vals ki val) + + (make-bnode (hnode-eqtype node) + (hnode-count node) + (hnode-keys node) + new-vals + (bnode-keymap node) + (bnode-childmap node)))) + +(define (bnode-add-child node child ki bit) + ;; We're removing a key from, and adding a child to, node. + ;; So length stays the same. + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-keys (make-vector len)] + [ci (fx- len 1 (bnode-child-index node bit))]) + + (vector*-copy! new-keys 0 keys 0 ki) + (vector*-copy! new-keys ki keys (fx1+ ki) (fx1+ ci)) + (#%vector-set! new-keys ci child) + (vector*-copy! new-keys (fx1+ ci) keys (fx1+ ci) len) + + (make-bnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + new-keys + (and vals (vector-remove vals ki)) + (fxxor (bnode-keymap node) bit) + (fxior (bnode-childmap node) bit)))) + +;; `child` is a singleton. +;; `lci` is the logical child index; the physical index is computed below. +(define (bnode-remove-child node child lci bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [ci (fx- len 1 lci)] + [ki (bnode-key-index node bit)] + [k (key-ref child 0)] + [v (val-ref child 0)] + + [new-keys + (let ([cpy (make-vector len)]) + (vector*-copy! cpy 0 keys 0 ki) + (#%vector-set! cpy ki k) + (vector*-copy! cpy (fx1+ ki) keys ki ci) + (vector*-copy! cpy (fx1+ ci) keys (fx1+ ci) len) + cpy)] + + [new-vals + (cond + [vals (vector-insert vals ki v)] + [(eq? v #t) #f] + [else ; reify values + (pariah + (let* ([pop (popcount (bnode-keymap node))] + [cpy (make-vector (fx1+ pop) #t)]) + (#%vector-set! cpy ki v) + cpy))])]) + + (make-bnode (hnode-eqtype node) + (fx1- (hnode-count node)) + new-keys + new-vals + (fxior (bnode-keymap node) bit) + (fxxor (bnode-childmap node) bit)))) + +(define (bnode-replace-child node old-child new-child ci) + (let* ([keys (hnode-keys node)] + [len (#%vector-length keys)] + [new-keys (vector-copy keys)]) + (#%vector-set! new-keys (fx- len 1 ci) new-child) + + (make-bnode (hnode-eqtype node) + (fx+ (hnode-count node) + (fx- (hnode-count new-child) + (hnode-count old-child))) + new-keys + (hnode-vals node) + (bnode-keymap node) + (bnode-childmap node)))) + +(define (bnode-singleton node ki bit keyhash shift) + (let* ([km (bnode-keymap node)] + [new-km + ;; I'll admit: I do not understand the false arm of this + ;; conditional. Shouldn't the new keymap use the hash of + ;; the key that will remain, rather than the one that's + ;; being removed? + (if (fxzero? shift) + (fxxor km bit) + (bnode-bit-pos keyhash 0))] + [idx (if (fxzero? ki) 1 0)] + [val (val-ref node idx)]) + + (make-bnode (hnode-eqtype node) + 1 + (vector (key-ref node idx)) + (if (eq? val #t) #f (vector val)) + new-km + 0))) + +(define (node-merge eqtype k1 v1 h1 k2 v2 h2 shift) + (cond + [(and (fx< HASHCODE-BITS shift) + (fx= h1 h2)) + (pariah + ;; hash collision: make a cnode + (let ([vals + (if (and (eq? v1 #t) (eq? v2 #t)) + #f + (vector v1 v2))]) + (make-cnode eqtype 2 (vector k1 k2) vals h1)))] + + [else + (let ([m1 (bnode-mask h1 shift)] + [m2 (bnode-mask h2 shift)]) + (cond + [(fx= m1 m2) + ;; partial collision: descend + (let* ([child (node-merge eqtype k1 v1 h1 k2 v2 h2 (down shift))] + [count (hnode-count child)] + [cm (bnode-bit-pos h1 shift)]) + (make-bnode eqtype count (vector child) #f 0 cm))] + + [else + ;; no collision + (let ([km (fxior (bnode-bit-pos h1 shift) + (bnode-bit-pos h2 shift))]) + (if (and (eq? v1 #t) (eq? v2 #t)) + (if (fx< m1 m2) + (make-bnode eqtype 2 (vector k1 k2) #f km 0) + (make-bnode eqtype 2 (vector k2 k1) #f km 0)) + (if (fx< m1 m2) + (make-bnode eqtype 2 (vector k1 k2) (vector v1 v2) km 0) + (make-bnode eqtype 2 (vector k2 k1) (vector v2 v1) km 0))))]))])) + +(define (bnode-entry-at-position n pos) + (let ([kpop (popcount (bnode-keymap n))]) + (cond + [(fx< pos kpop) + (cons (key-ref n pos) (val-ref n pos))] + [else + (let ([cpop (popcount (bnode-childmap n))]) + (let loop ([i 0] [pos (fx- pos kpop)]) + (cond + [(fx= i cpop) #f] + [else + (let* ([child (child-ref n i)] + [count (hnode-count child)]) + (if (fx< pos count) + (node-entry-at-position child pos) + (loop (fx1+ i) (fx- pos count))))])))]))) + +(define (bnode-foldk n f nil kont) + (let ([kpop (popcount (bnode-keymap n))]) + (keys-foldk kpop n f nil + (lambda (nil) (child-foldk kpop n f nil kont))))) + +(define (keys-foldk pop n f nil kont) + (let loop ([i 0] [nil nil] [kont kont]) + (cond + [(fx= i pop) (kont nil)] + [else + (f (key-ref n i) (val-ref n i) nil + (lambda (nil) (loop (fx1+ i) nil kont)))]))) + +(define (child-foldk pop n f nil kont) + (let* ([keys (hnode-keys n)] + [len (#%vector-length keys)]) + (let loop ([i pop] [nil nil] [kont kont]) + (cond + [(fx= i len) (kont nil)] + [else + (node-foldk (#%vector-ref keys i) f nil + (lambda (nil) (loop (fx1+ i) nil kont)))])))) + +;; cnode operations +(define (cnode-index node key) + (let* ([keys (hnode-keys node)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (cond [(fx= i len) #f] + [(key=? node key (#%vector-ref keys i)) i] + [else (loop (fx1+ i))])))) + +(define (cnode-ref node key) + (let ([i (cnode-index node key)]) + (if i + (val-ref node i) + NOTHING))) + +(define (cnode-has-key? n key) + (not (not (cnode-index n key)))) + +(define (cnode-set node key val) + (let* ([i (cnode-index node key)] + [keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)]) + (if i + (cnode-replace-val node i val) + (cnode-add-key node key val)))) + +(define (cnode-remove node key keyhash) + (let ([ki (cnode-index node key)] + [eqtype (hnode-eqtype node)]) + (cond + [ki + (case (hnode-count node) + [(1) + (make-empty-bnode eqtype)] + [(2) + (let ([empty (make-empty-bnode eqtype)] + [i (if (fx= ki 0) 1 0)]) + (bnode-set empty (key-ref node i) (val-ref node i) keyhash 0))] + [else + (make-cnode eqtype + (fx1- (hnode-count node)) + (vector-remove (hnode-keys node) ki) + (let ([vals (hnode-vals node)]) + (and vals (vector-remove vals ki))) + (cnode-hash node))])] + [else + node]))) + +(define (cnode=? a b eql?) + (and + (cnode? b) + (fx= (cnode-hash a) (cnode-hash b)) + (let* ([akeys (hnode-keys a)] + [alen (#%vector-length akeys)]) + (and (let loop ([i 0]) + (cond + [(fx= i alen) #t] + [else + (let* ([akey (key-ref a i)] + [bval (cnode-ref b akey)]) + (and + (eql? (val-ref a i) bval) + (loop (fx1+ i))))])))))) + +(define (cnode-keys-subset? a b shift) + (cond + [(cnode? b) + (and (fx= (cnode-hash a) (cnode-hash b)) + (let loop ([i (hnode-count a)]) + (cond + [(fxzero? i) #t] + [else + (and (cnode-index b (key-ref a (fx1- i))) + (loop (fx1- i)))])))] + [else + (let loop ([i (hnode-count a)]) + (cond + [(fxzero? i) #t] + [else + (let ([k (key-ref a (fx1- i))]) + (and (bnode-has-key? b k (hash-code a k) shift) + (loop (fx1- i))))]))])) + +(define (cnode-replace-val node i val) + (let ([v (val-ref node i)]) + (cond + [(eq? v val) + node] + + [else + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-vals + (if vals + (#%vector-copy vals) + (make-vector len #t))]) + (#%vector-set! new-vals i val) + + (make-cnode (hnode-eqtype node) + (hnode-count node) + keys + new-vals + (cnode-hash node)))]))) + +(define (cnode-add-key node key val) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-vals + (cond + [vals (vector-insert vals len val)] + [(eq? val #t) #f] + [else + (let ([vec (make-vector (fx1+ len) #t)]) + (#%vector-set! vec len val) + vec)])]) + + (make-cnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + (vector-insert keys len key) + new-vals + (cnode-hash node)))) + +(define (cnode-entry-at-position n pos) + (and (fx< pos (hnode-count n)) + (cons (key-ref n pos) (val-ref n pos)))) + +(define (cnode-foldk n f nil kont) + (keys-foldk (hnode-count n) n f nil kont)) diff -Nru racket-6.12+ppa1/src/cs/rumble/hash-code.ss racket-7.0+ppa1/src/cs/rumble/hash-code.ss --- racket-6.12+ppa1/src/cs/rumble/hash-code.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/hash-code.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,150 @@ +;;; Parts from "newhash.ss" in Chez Scheme's implementation + +;;; newhash.ss +;;; Copyright 1984-2016 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define codes (make-weak-eq-hashtable)) +(define counter 12345) + +(define (eq-hash-code x) + (cond + [(and (symbol? x) + ;; Avoid forcing the universal name of a gensym, + ;; which is more expensive than registering in + ;; the `codes` table. + (not (gensym? x))) + (symbol-hash x)] + [(number? x) (number-hash x)] + [(char? x) (char->integer x)] + [else + (or (eq-hashtable-ref codes x #f) + (let ([c (fx1+ counter)]) + (set! counter c) + (eq-hashtable-set! codes x counter) + c))])) + +;; Mostly copied from Chez Scheme's "newhash.ss": +(define number-hash + (lambda (z) + (cond + [(fixnum? z) (if (fx< z 0) (fxnot z) z)] + [(flonum? z) (#3%$flhash z)] + [(bignum? z) (modulo z (most-positive-fixnum))] + [(ratnum? z) (number-hash (+ (* (numerator z) 5) (denominator z)))] + [else (logand (logxor (lognot (number-hash (real-part z))) (number-hash (imag-part z))) + (most-positive-fixnum))]))) + +(define (eqv-hash-code x) + (cond + [(number? x) (number-hash x)] + [(char? x) (char->integer x)] + [else (eq-hash-code x)])) + +;; We don't use `equal-hash` because we need impersonators to be able +;; to generate the same hash code as the unwrapped value. +(define (equal-hash-code x) + (call-with-values (lambda () (equal-hash-loop x 0 0)) + (lambda (hc burn) (logand hc (most-positive-fixnum))))) + +(define (equal-secondary-hash-code x) + (cond + [(boolean? x) 1] + [(null? x) 2] + [(number? x) 3] + [(char? x) 4] + [(symbol? x) 5] + [(string? x) 6] + [(bytevector? x) 7] + [(box? x) 8] + [(pair? x) 9] + [(vector? x) (vector-length x)] + [(#%$record? x) (eq-hash-code (record-rtd x))] + [(impersonator? x) (equal-secondary-hash-code (impersonator-val x))] + [else 100])) + +(define MAX-HASH-BURN 128) + +(define (equal-hash-loop x burn hc) + (let* ([+/fx + (lambda (hc k) + (#3%fx+ hc k))] + [sll/fs + (lambda (hc i) + (#3%fxsll hc i))] + [->fx + (lambda (v) + (if (fixnum? v) + v + (modulo v (greatest-fixnum))))] + [mix1 + (lambda (hc) + (+/fx hc (sll/fs hc 3)))] + [mix2 + (lambda (hc) + (+/fx hc (sll/fs hc 5)))]) + (cond + [(fx> burn MAX-HASH-BURN) (values hc burn)] + [(boolean? x) (values (+/fx hc (if x #x0ace0120 #x0cafe121)) burn)] + [(null? x) (values (+/fx hc #x0cabd122) burn)] + [(number? x) (values (+/fx hc (number-hash x)) burn)] + [(char? x) (values (+/fx hc (char->integer x)) burn)] + [(symbol? x) (values (+/fx hc (symbol-hash x)) burn)] + [(string? x) (values (+/fx hc (string-hash x)) burn)] + [(bytevector? x) (values (+/fx hc (equal-hash x)) burn)] + [(box? x) (equal-hash-loop (unbox x) (fx+ burn 1) (+/fx hc 1))] + [(pair? x) + (let-values ([(hc0 burn) (equal-hash-loop (car x) (fx+ burn 2) 0)]) + (let ([hc (+/fx (mix1 hc) hc0)] + [r (cdr x)]) + (if (and (pair? r) (list? r)) + ;; If it continues as a list, don't count cdr direction as burn: + (equal-hash-loop r (fx- burn 2) hc) + (equal-hash-loop r burn hc))))] + [(vector? x) + (let ([len (vector-length x)]) + (cond + [(fx= len 0) (values (+/fx hc 1) burn)] + [else + (let vec-loop ([i 0] [burn burn] [hc hc]) + (cond + [(fx= i len) (values hc burn)] + [else + (let-values ([(hc0 burn) (equal-hash-loop (vector-ref x i) burn 0)]) + (vec-loop (fx+ i 1) + burn + (+/fx (mix2 hc) hc0)))]))]))] + [(and (#%$record? x) (#%$record-hash-procedure x)) + => (lambda (rec-hash) + (let ([burn (fx+ burn 2)]) + (let ([hc (+/fx hc (->fx (rec-hash x (lambda (x) + (let-values ([(hc0 burn0) (equal-hash-loop x burn 0)]) + (set! burn burn0) + hc0)))))]) + (values hc burn))))] + [(impersonator? x) + ;; If an impersonator wraps a value where `equal?` hashing is + ;; `eq?` hashing, such as for a procedure, then make sure + ;; we discard the impersonator wrapper. + (equal-hash-loop (impersonator-val x) burn hc)] + [else (values (+/fx hc (eq-hash-code x)) burn)]))) + +(define (hash-code-combine hc v) + (bitwise-and (+ (bitwise-arithmetic-shift-left hc 2) + v) + (greatest-fixnum))) + +(define (hash-code-combine-unordered hc v) + (bitwise-and (+ hc v) + (greatest-fixnum))) diff -Nru racket-6.12+ppa1/src/cs/rumble/hash.ss racket-7.0+ppa1/src/cs/rumble/hash.ss --- racket-6.12+ppa1/src/cs/rumble/hash.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/hash.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1233 @@ +;; To support iteration and locking, we wrap Chez's mutable hash +;; tables in a `mutable-hash` record: +(define-record mutable-hash (ht ; Chez Scheme hashtable + keys ; vector of keys for iteration + keys-removed ; 'check or a weak, `eqv?`-based mapping of `keys` values + lock)) +(define (create-mutable-hash ht kind) (make-mutable-hash ht #f #f (make-lock kind))) + +(define (authentic-hash? v) (or (intmap? v) (mutable-hash? v) (weak-equal-hash? v))) +(define (hash? v) (or (authentic-hash? v) + (and (impersonator? v) + (authentic-hash? (impersonator-val v))))) + +(define make-hash + (case-lambda + [() (create-mutable-hash (make-hashtable key-equal-hash-code key-equal?) 'equal?)] + [(alist) (fill-hash! 'make-hash (make-hash) alist)])) + +(define make-hasheq + (case-lambda + [() (create-mutable-hash (make-eq-hashtable) 'eq?)] + [(alist) (fill-hash! 'make-hasheq (make-hasheq) alist)])) + +(define make-weak-hasheq + (case-lambda + [() (create-mutable-hash (make-weak-eq-hashtable) 'eq?)] + [(alist) (fill-hash! 'make-weak-hasheq (make-weak-hasheq) alist)])) + +(define make-hasheqv + (case-lambda + [() (create-mutable-hash (make-eqv-hashtable) 'eqv?)] + [(alist) (fill-hash! 'make-hasheqv (make-hasheqv) alist)])) + +(define make-weak-hasheqv + (case-lambda + [() (create-mutable-hash (make-weak-eqv-hashtable) 'eqv?)] + [(alist) (fill-hash! 'make-weak-hasheqv (make-weak-hasheqv) alist)])) + +(define/who (fill-hash! who ht alist) + (check who :test (and (list? alist) (andmap pair? alist)) :contract "(listof pair?)" alist) + (for-each (lambda (p) + (hash-set! ht (car p) (cdr p))) + alist) + ht) + +(define-syntax define-hash-constructors + (syntax-rules () + [(_ vararg-ctor list-ctor empty-hash) + (begin + (define (vararg-ctor . kvs) + (let loop ([kvs kvs] [h empty-hash]) + (cond [(null? kvs) h] + [else + (loop (cddr kvs) (intmap-set h (car kvs) (cadr kvs)))]))) + + (define list-ctor + (case-lambda + [() (vararg-ctor)] + [(alist) + (check 'list-ctor + :test (and (list? alist) (andmap pair? alist)) + :contract "(listof pair?)" + alist) + (let loop ([h (vararg-ctor)] [alist alist]) + (if (null? alist) + h + (loop (intmap-set h (caar alist) (cdar alist)) + (cdr alist))))])))])) + +(define-hash-constructors hash make-immutable-hash empty-hash) +(define-hash-constructors hasheqv make-immutable-hasheqv empty-hasheqv) +(define-hash-constructors hasheq make-immutable-hasheq empty-hasheq) + +(define (hash-set! ht k v) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (when (and (mutable-hash-keys ht) + (not (hashtable-contains? (mutable-hash-ht ht) k))) + (set-mutable-hash-keys! ht #f) + (set-mutable-hash-keys-removed! ht #f)) + (hashtable-set! (mutable-hash-ht ht) k v) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-set! ht k v)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-set! ht k v)] + [else (raise-argument-error 'hash-set! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-remove! ht k) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (when (mutable-hash-keys ht) + (cond + [(hash-equal? ht) + ;; Track which keys in the vector are no longer mapped + (unless (mutable-hash-keys-removed ht) + ;; We use an `eqv?` table to work with flonums + (set-mutable-hash-keys-removed! ht (make-weak-eqv-hashtable))) + ;; Get specific key that is currently mapped for `k` + ;; by getting the entry pair: + (let ([e (hashtable-cell (mutable-hash-ht ht) k #f)]) + (hashtable-set! (mutable-hash-keys-removed ht) (car e) #t))] + [else + ; Record that we need to check the table: + (set-mutable-hash-keys-removed! ht 'check)])) + (hashtable-delete! (mutable-hash-ht ht) k) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-remove! ht k)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-remove! ht k)] + [else (raise-argument-error 'hash-remove! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-clear! ht) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (set-mutable-hash-keys! ht #f) + (set-mutable-hash-keys-removed! ht #f) + (hashtable-clear! (mutable-hash-ht ht)) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-clear! ht)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-clear! ht)] + [else (raise-argument-error 'hash-clear! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-copy ht) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (let ([new-ht (create-mutable-hash (hashtable-copy (mutable-hash-ht ht) #t) + (cond + [(hash-eq? ht) 'eq?] + [(hash-eqv? ht) 'eqv?] + [else 'equal?]))]) + (lock-release (mutable-hash-lock ht)) + new-ht)] + [(weak-equal-hash? ht) (weak-hash-copy ht)] + [(intmap? ht) + (let ([new-ht (cond + [(intmap-eq? ht) (make-hasheq)] + [(intmap-eqv? ht) (make-hasheqv)] + [else (make-hash)])]) + (let loop ([i (intmap-iterate-first ht)]) + (when i + (let-values ([(k v) (intmap-iterate-key+value ht i #f)]) + (hash-set! new-ht k v) + (loop (intmap-iterate-next ht i))))) + new-ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (impersonate-hash-copy ht)] + [else (raise-argument-error 'hash-copy "hash?" ht)])) + +(define (hash-set ht k v) + (cond + [(intmap? ht) (intmap-set ht k v)] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (impersonate-hash-set ht k v)] + [else (raise-argument-error 'hash-set! "(and/c hash? immutable?)" ht)])) + +(define (hash-remove ht k) + (cond + [(intmap? ht) (intmap-remove ht k)] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (impersonate-hash-remove ht k)] + [else (raise-argument-error 'hash-remove "(and/c hash? immutable?)" ht)])) + +(define (hash-clear ht) + (cond + [(intmap? ht) + (cond + [(hash-eq? ht) empty-hasheq] + [(hash-eqv? ht) empty-hasheqv] + [else empty-hash])] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (let loop ([ht ht]) + (let ([i (hash-iterate-first ht)]) + (if i + (loop (hash-remove ht (hash-iterate-key ht i))) + ht)))] + [else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)])) + +(define (hash-eq? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) eq?)] + [(intmap? ht) + (intmap-eq? ht)] + [(weak-equal-hash? ht) #f] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-eq? (impersonator-val ht))] + [else (raise-argument-error 'hash-eq? "hash?" ht)])) + +(define (hash-eqv? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) eqv?)] + [(intmap? ht) + (intmap-eqv? ht)] + [(weak-equal-hash? ht) #f] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-eqv? (impersonator-val ht))] + [else (raise-argument-error 'hash-eqv? "hash?" ht)])) + +(define (hash-equal? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) key-equal?)] + [(intmap? ht) + (intmap-equal? ht)] + [(weak-equal-hash? ht) #t] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-equal? (impersonator-val ht))] + [else (raise-argument-error 'hash-equal? "hash?" ht)])) + +(define (hash-weak? ht) + (cond + [(mutable-hash? ht) + (hashtable-weak? (mutable-hash-ht ht))] + [(intmap? ht) #f] + [(weak-equal-hash? ht) #t] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-weak? (impersonator-val ht))] + [else (raise-argument-error 'hash-weak? "hash?" ht)])) + +(define hash-ref + (case-lambda + [(ht k) + (let ([v (hash-ref ht k none)]) + (if (eq? v none) + (raise-arguments-error + 'hash-ref + "no value found for key" + "key" k) + v))] + [(ht k fail) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (let ([v (hashtable-ref (mutable-hash-ht ht) k none)]) + (lock-release (mutable-hash-lock ht)) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [(intmap? ht) (intmap-ref ht k fail)] + [(weak-equal-hash? ht) (weak-hash-ref ht k fail)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (let ([v (impersonate-hash-ref ht k)]) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [else (raise-argument-error 'hash-ref "hash?" ht)])])) + +(define/who hash-for-each + (case-lambda + [(ht proc) (hash-for-each ht proc #f)] + [(ht proc try-order?) + (check who hash? ht) + (check who (procedure-arity-includes/c 2) proc) + (cond + [(mutable-hash? ht) + (let loop ([i (hash-iterate-first ht)]) + (when i + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val)) + (loop (hash-iterate-next ht i))))] + [(intmap? ht) (intmap-for-each ht proc)] + [(weak-equal-hash? ht) (weak-hash-for-each ht proc)] + [else + ;; impersonated + (let loop ([i (hash-iterate-first ht)]) + (when i + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val) + (loop (hash-iterate-next ht i)))))])])) + +(define/who hash-map + (case-lambda + [(ht proc) + (check who hash? ht) + (check who (procedure-arity-includes/c 2) proc) + (cond + [(mutable-hash? ht) + (let loop ([i (hash-iterate-first ht)]) + (if (not i) + '() + (cons + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val)) + (loop (hash-iterate-next ht i)))))] + [(intmap? ht) (intmap-map ht proc)] + [(weak-equal-hash? ht) (weak-hash-map ht proc)] + [else + ;; impersonated + (let loop ([i (hash-iterate-first ht)]) + (cond + [(not i) '()] + [else + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (cons (|#%app| proc key val) + (loop (hash-iterate-next ht i))))]))])] + [(ht proc try-order?) + (hash-map ht proc)])) + +(define (hash-count ht) + (cond + [(mutable-hash? ht) (hashtable-size (mutable-hash-ht ht))] + [(intmap? ht) (intmap-count ht)] + [(weak-equal-hash? ht) (weak-hash-count ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-count (impersonator-val ht))] + [else (raise-argument-error 'hash-count "hash?" ht)])) + +(define (hash-keys-subset? ht1 ht2) + (cond + [(and (intmap? ht1) + (intmap? ht2) + (or (and (intmap-eq? ht1) + (intmap-eq? ht2)) + (and (intmap-eqv? ht1) + (intmap-eqv? ht2)) + (and (intmap-equal? ht1) + (intmap-equal? ht2)))) + (intmap-keys-subset? ht1 ht2)] + [(and (hash? ht1) + (hash? ht2) + (or (and (hash-eq? ht1) + (hash-eq? ht2)) + (and (hash-eqv? ht1) + (hash-eqv? ht2)) + (and (hash-equal? ht1) + (hash-equal? ht2)))) + (and (<= (hash-count ht1) (hash-count ht2)) + (let ([ok? #t]) + (hash-for-each + ht1 + (lambda (k v) + (when ok? + (set! ok? (not (eq? none (hash-ref ht2 k none))))))) + ok?))] + [(not (hash? ht1)) + (raise-argument-error 'hash-keys-subset? "hash?" ht1)] + [(not (hash? ht2)) + (raise-argument-error 'hash-keys-subset? "hash?" ht2)] + [else + (raise-arguments-error 'hash-keys-subset? + "given hash tables do not use the same key comparison" + "first table" ht1 + "first table" ht2)])) + +;; Use `eql?` for recursive comparisons +(define (hash=? ht1 ht2 eql?) + (cond + [(and (intmap? ht1) + (intmap? ht2)) + (intmap=? ht1 ht2 eql?)] + [(and (hash? ht1) + (hash? ht2) + (or (and (hash-eq? ht1) + (hash-eq? ht2)) + (and (hash-eqv? ht1) + (hash-eqv? ht2)) + (and (hash-equal? ht1) + (hash-equal? ht2))) + (eq? (hash-weak? ht1) (hash-weak? ht2))) + (and (= (hash-count ht1) (hash-count ht2)) + ;; This generic comparison supports impersonators + (let loop ([i (hash-iterate-first ht1)]) + (cond + [(not i) #t] + [else + (let-values ([(key val) (hash-iterate-key+value ht1 i)]) + (let ([val2 (hash-ref ht2 key none)]) + (cond + [(eq? val2 none) #f] + [else (and (eql? val val2) + (loop (hash-iterate-next ht1 i)))])))])))] + [else #f])) + + +;; Use `hash` for recursive hashing +(define (hash-hash-code ht hash) + (cond + [(intmap? ht) (intmap-hash-code ht hash)] + [else + ;; This generic hashing supports impersonators + (let loop ([hc 0] [i (hash-iterate-first ht)]) + (cond + [(not i) hc] + [else + (let* ([eq-key? (hash-eq? ht)] + [eqv-key? (and (not eq?) (hash-eqv? ht))]) + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (let ([hc (hash-code-combine-unordered hc + (cond + [eq-key? (eq-hash-code key)] + [eqv-key? (eqv-hash-code key)] + [else (hash key)]))]) + (loop (hash-code-combine-unordered hc (hash val)) + (hash-iterate-next ht i)))))]))])) + + +;; A `hash-iterate-first` operation triggers an O(n) +;; gathering of the keys of a mutable hash table. That's +;; unfortunate, but there appears to be no way around it. +(define (prepare-iterate! ht i) + (lock-acquire (mutable-hash-lock ht)) + (let ([vec (mutable-hash-keys ht)]) + (cond + [vec + (lock-release (mutable-hash-lock ht)) + vec] + [else + (let ([vec (hashtable-keys (mutable-hash-ht ht))]) + ;; Keep a weak reference to each key, in case + ;; it's removed or we have a weak hash table: + (let loop ([i (vector-length vec)]) + (unless (zero? i) + (let* ([i (sub1 i)] + [key (vector-ref vec i)]) + (vector-set! vec i (weak/fl-cons key #f)) + (loop i)))) + (set-mutable-hash-keys! ht vec) + (set-mutable-hash-keys-removed! ht #f) + (lock-release (mutable-hash-lock ht)) + vec)]))) + +(define/who (hash-iterate-first ht) + (cond + [(intmap? ht) + (intmap-iterate-first ht)] + [(mutable-hash? ht) + (mutable-hash-iterate-next ht #f)] + [(weak-equal-hash? ht) (weak-hash-iterate-first ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + ;; `hash-iterate-first` must not hash any keys: + (hash-iterate-first (impersonator-val ht))] + [else (raise-argument-error who "hash?" ht)])) + +(define (check-i who i) + (check who exact-nonnegative-integer? i)) + +(define/who (hash-iterate-next ht i) + (cond + [(intmap? ht) + (check-i 'hash-iterate-next i) + (intmap-iterate-next ht i)] + [(mutable-hash? ht) + (check-i 'hash-iterate-next i) + (mutable-hash-iterate-next ht i)] + [(weak-equal-hash? ht) + (check-i 'hash-iterate-next i) + (weak-hash-iterate-next ht i)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + ;; `hash-iterate-next` must not hash any keys: + (hash-iterate-next (impersonator-val ht) i)] + [else (raise-argument-error who "hash?" ht)])) + +(define (mutable-hash-iterate-next ht init-i) + (let* ([vec (prepare-iterate! ht init-i)] ; vec expected to have > `init-i` elements + [len (vector-length vec)]) + (let loop ([i (or init-i -1)]) + (let ([i (add1 i)]) + (cond + [(> i len) + (raise-arguments-error 'hash-iterate-next "no element at index" + "index" init-i + "within length" len + "vec" vec)] + [(= i len) + #f] + [else + (let* ([p (vector-ref vec i)] + [key (car p)]) + (cond + [(bwp-object? key) + ;; A hash table change or disappeared weak reference + (loop i)] + [(mutable-hash-keys-removed ht) + => (lambda (keys-removed) + (lock-acquire (mutable-hash-lock ht)) + (let ([removed? + (if (eq? keys-removed 'check) + (not (hashtable-contains? (mutable-hash-ht ht) key)) + (hashtable-contains? keys-removed key))]) + (lock-release (mutable-hash-lock ht)) + (if removed? + ;; Skip, due to a hash table change + (loop i) + ;; Key is still mapped: + i)))] + [else i]))]))))) + +(define (do-hash-iterate-key+value who ht i + intmap-iterate-key+value + weak-hash-iterate-key+value + key? value? pair?) + (cond + [(intmap? ht) + (check-i who i) + (call-with-values (lambda () (intmap-iterate-key+value ht i none)) + (case-lambda + [(v) (if (eq? v none) + (raise-arguments-error who "no element at index" + "index" i) + v)] + [(k v) (values k v)]))] + [(mutable-hash? ht) + (check-i who i) + (let* ([vec (prepare-iterate! ht i)] + [len (vector-length vec)] + [p (if (< i len) + (vector-ref vec i) + '(#f . #f))] + [key (car p)] + [v (if (bwp-object? key) + none + (cond + [(not value?) + ;; We need to check whether the key is still + ;; mapped by the hash table, but impersonator + ;; support relies on not `equal?`-hashing the + ;; candidate key at this point. The `keys-removed` + ;; weak `eq?`-based table serves that purpose. + (cond + [(mutable-hash-keys-removed ht) + => (lambda (keys-removed) + (lock-acquire (mutable-hash-lock ht)) + (let ([removed? + (if (eq? keys-removed 'check) + (not (hashtable-contains? (mutable-hash-ht ht) key)) + (hashtable-contains? keys-removed key))]) + (lock-release (mutable-hash-lock ht)) + (if removed? none #t)))] + [else #t])] + [else + (lock-acquire (mutable-hash-lock ht)) + (let ([v (hashtable-ref (mutable-hash-ht ht) key none)]) + (lock-release (mutable-hash-lock ht)) + v)]))]) + (if (eq? v none) + (raise-arguments-error who "no element at index" + "index" i) + (cond + [(and key? value?) + (if pair? + (cons key v) + (values key v))] + [key? key] + [else v])))] + [(weak-equal-hash? ht) + (check-i who i) + (weak-hash-iterate-key+value ht i)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (impersonate-hash-iterate-key+value who ht i key? value? pair?)] + [else (raise-argument-error who "hash?" ht)])) + +(define (hash-iterate-key ht i) + (do-hash-iterate-key+value 'hash-iterate-key ht i + intmap-iterate-key + weak-hash-iterate-key + #t #f #f)) + +(define (hash-iterate-value ht i) + (do-hash-iterate-key+value 'hash-iterate-value ht i + intmap-iterate-value + weak-hash-iterate-value + #f #t #f)) + +(define (hash-iterate-key+value ht i) + (do-hash-iterate-key+value 'hash-iterate-key+value ht i + intmap-iterate-key+value + weak-hash-iterate-key+value + #t #t #f)) + +(define (hash-iterate-pair ht i) + (do-hash-iterate-key+value 'hash-iterate-pair ht i + intmap-iterate-pair + weak-hash-iterate-pair + #t #t #t)) + +(define (unsafe-immutable-hash-iterate-first ht) + (if (impersonator? ht) + (hash-iterate-first ht) + (unsafe-intmap-iterate-first ht))) + +(define (iterator-for-impersonator? i) (fixnum? i)) + +(define (unsafe-immutable-hash-iterate-next ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-next ht i) + (unsafe-intmap-iterate-next ht i))) + +(define (unsafe-immutable-hash-iterate-key ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-key ht i) + (unsafe-intmap-iterate-key ht i))) + +(define (unsafe-immutable-hash-iterate-value ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-value ht i) + (unsafe-intmap-iterate-value ht i))) + +(define (unsafe-immutable-hash-iterate-key+value ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-key+value ht i) + (unsafe-intmap-iterate-key+value ht i))) + +(define (unsafe-immutable-hash-iterate-pair ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-pair ht i) + (unsafe-intmap-iterate-pair ht i))) + +(define unsafe-mutable-hash-iterate-first hash-iterate-first) +(define unsafe-mutable-hash-iterate-next hash-iterate-next) +(define unsafe-mutable-hash-iterate-key hash-iterate-key) +(define unsafe-mutable-hash-iterate-value hash-iterate-value) +(define unsafe-mutable-hash-iterate-key+value hash-iterate-key+value) +(define unsafe-mutable-hash-iterate-pair hash-iterate-pair) + +(define unsafe-weak-hash-iterate-first hash-iterate-first) +(define unsafe-weak-hash-iterate-next hash-iterate-next) +(define unsafe-weak-hash-iterate-key hash-iterate-key) +(define unsafe-weak-hash-iterate-value hash-iterate-value) +(define unsafe-weak-hash-iterate-key+value hash-iterate-key+value) +(define unsafe-weak-hash-iterate-pair hash-iterate-pair) + +;; ---------------------------------------- + +;; Chez Scheme doesn't provide weak hash table with `equal?` comparisons, +;; so build our own + +(define-record weak-equal-hash (lock + keys-ht ; integer[equal hash code] -> weak list of keys + vals-ht ; weak, eq?-based hash table: key -> value + count ; number of items in the table (= sum of list lengths) + prune-at ; count at which we should try to prune empty weak boxes + keys)) ; for iteration: a vector that is enlarged on demand + +(define make-weak-hash + (case-lambda + [() (make-weak-equal-hash (make-lock 'equal?) (hasheqv) (make-weak-eq-hashtable) 0 128 #f)] + [(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)])) + +(define (weak-hash-copy ht) + (lock-acquire (weak-equal-hash-lock ht)) + (let ([new-ht (make-weak-equal-hash (weak-equal-hash-keys-ht ht) + (hashtable-copy (weak-equal-hash-vals-ht ht) #t) + (weak-equal-hash-count ht) + (weak-equal-hash-prune-at ht) + #f)]) + (lock-release (weak-equal-hash-lock ht)) + new-ht)) + +(define (weak-hash-ref t key fail) + (let ([code (key-equal-hash-code key)]) + (lock-acquire (weak-equal-hash-lock t)) + (let ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table: + (lock-release (weak-equal-hash-lock t)) + (if (procedure? fail) + (|#%app| fail) + fail)] + [(key-equal? (car keys) key) + (let ([v (hashtable-ref (weak-equal-hash-vals-ht t) (car keys) none)]) + (lock-release (weak-equal-hash-lock t)) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [else (loop (cdr keys))]))))) + +;; Only used in atomic mode: +(define (weak-hash-ref-key ht key) + (let* ([code (key-equal-hash-code key)] + [keys (intmap-ref (weak-equal-hash-keys-ht ht) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) #f] + [(key-equal? (car keys) key) (car keys)] + [else (loop (cdr keys))])))) + +(define (weak-hash-set! t k v) + (let ([code (key-equal-hash-code k)]) + (lock-acquire (weak-equal-hash-lock t)) + (let ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table: + (set-weak-equal-hash-keys! t #f) + (when (= (weak-equal-hash-count t) (weak-equal-hash-prune-at t)) + (prune-table! t)) + (let* ([ht (weak-equal-hash-keys-ht t)]) + (set-weak-equal-hash-count! t + (add1 (weak-equal-hash-count t))) + (set-weak-equal-hash-keys-ht! t + (intmap-set ht code + (weak/fl-cons k + (intmap-ref ht code '())))) + (hashtable-set! (weak-equal-hash-vals-ht t) k v)) + (lock-release (weak-equal-hash-lock t))] + [(key-equal? (car keys) k) + (hashtable-set! (weak-equal-hash-vals-ht t) (car keys) v) + (lock-release (weak-equal-hash-lock t))] + [else (loop (cdr keys))]))))) + +(define (weak-hash-remove! t k) + (let ([code (key-equal-hash-code k)]) + (lock-acquire (weak-equal-hash-lock t)) + (let* ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())] + [keep-bwp? + ;; If we have a `keys` array, then preserve the shape of + ;; each key lst in `(weak-equal-hash-keys-ht t)` so that + ;; the `keys` array remains consistent with that shape + (and (weak-equal-hash-keys t) #t)] + [new-keys + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table + #f] + [(key-equal? (car keys) k) + (hashtable-delete! (weak-equal-hash-vals-ht t) (car keys)) + (if keep-bwp? + (cons #!bwp keys) + (cdr keys))] + [else + (let ([new-keys (loop (cdr keys))]) + (and new-keys + (if (and (not keep-bwp?) + (bwp-object? (car keys))) + new-keys + (weak/fl-cons (car keys) new-keys))))]))]) + (when new-keys + (set-weak-equal-hash-keys-ht! t + (if (null? new-keys) + (intmap-remove (weak-equal-hash-keys-ht t) code) + (intmap-set (weak-equal-hash-keys-ht t) code new-keys)))) + (lock-release (weak-equal-hash-lock t))))) + +(define (weak-hash-clear! t) + (lock-acquire (weak-equal-hash-lock t)) + (set-weak-equal-hash-keys-ht! t (hasheqv)) + (hashtable-clear! (weak-equal-hash-vals-ht t)) + (set-weak-equal-hash-count! t 0) + (set-weak-equal-hash-prune-at! t 128) + (set-weak-equal-hash-keys! t #f) + (lock-release (weak-equal-hash-lock t))) + +(define (weak-hash-for-each t proc) + (let* ([ht (weak-equal-hash-vals-ht t)] + [keys (hashtable-keys ht)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (unless (fx= i len) + (let ([key (#%vector-ref keys i)]) + (|#%app| proc key (hashtable-ref ht key #f))) + (loop (fx1+ i)))))) + +(define (weak-hash-map t proc) + (let* ([ht (weak-equal-hash-vals-ht t)] + [keys (hashtable-keys ht)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (cond + [(fx= i len) '()] + [else + (let ([key (#%vector-ref keys i)]) + (cons (|#%app| proc key (hashtable-ref ht key #f)) + (loop (fx1+ i))))])))) + +(define (weak-hash-count t) + (hashtable-size (weak-equal-hash-vals-ht t))) + +(define (prepare-weak-iterate! ht i) + (let* ([current-vec (weak-equal-hash-keys ht)]) + (or (and current-vec + (> (vector-length current-vec) (or i 1)) + current-vec) + (let* ([len (max 16 + (* 2 (if current-vec + (vector-length current-vec) + 0)) + (if i (* 2 i) 0))] + [vec (make-vector len #f)] + [pos (box 0)]) + (call/cc + (lambda (esc) + (intmap-for-each + (weak-equal-hash-keys-ht ht) + (lambda (k l) + (let loop ([l l]) + (cond + [(null? l) (void)] + [else + ;; Add `l` even if the key is #!bwp, + ;; so that iteration works right if a key + ;; is removed + (vector-set! vec (unbox pos) l) + (set-box! pos (add1 (unbox pos))) + (if (= (unbox pos) len) + ;; That's enough keys + (esc (void)) + (loop (cdr l)))])))))) + (set-weak-equal-hash-keys! ht vec) + vec)))) + +(define (weak-hash-iterate-first ht) + (weak-hash-iterate-next ht #f)) + +(define (weak-hash-iterate-next ht init-i) + (lock-acquire (weak-equal-hash-lock ht)) + (let retry ([i (and init-i (add1 init-i))]) + (let* ([vec (prepare-weak-iterate! ht i)] + [len (vector-length vec)]) + (let loop ([i (or i 0)]) + (cond + [(= i len) + ;; expand set of prepared keys + (retry i)] + [(> i len) + (lock-release (weak-equal-hash-lock ht)) + (raise-arguments-error 'hash-iterate-next "no element at weak index" + "index" init-i)] + [else + (let ([p (vector-ref vec i)]) + (cond + [(not p) + ;; no more keys available + (lock-release (weak-equal-hash-lock ht)) + #f] + [(bwp-object? (car p)) (loop (add1 i))] + [(not (hashtable-contains? (weak-equal-hash-vals-ht ht) (car p))) + ;; key was removed from table after `keys` array was formed + (loop (add1 i))] + [else + (lock-release (weak-equal-hash-lock ht)) + i]))]))))) + +(define (do-weak-hash-iterate-key who ht i release-lock?) + (lock-acquire (weak-equal-hash-lock ht)) + (let* ([vec (weak-equal-hash-keys ht)] + [p (and vec + (< i (vector-length vec)) + (vector-ref vec i))] + [k (if p + (car p) + #!bwp)]) + (when release-lock? + (lock-release (weak-equal-hash-lock ht))) + (cond + [(bwp-object? k) + (raise-arguments-error who "no element at index" + "index" i)] + [else k]))) + +(define (weak-hash-iterate-key ht i) + (do-weak-hash-iterate-key 'hash-iterate-key ht i #t)) + +(define (weak-hash-iterate-value ht i) + (let* ([key (do-weak-hash-iterate-key 'hash-iterate-value ht i #f)] + [val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (lock-release (weak-equal-hash-lock ht)) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-value "no element at index" + "index" i) + val))) + +(define (weak-hash-iterate-key+value ht i) + (let ([key (do-weak-hash-iterate-key 'hash-iterate-key+value ht i #f)]) + (values key + (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (lock-release (weak-equal-hash-lock ht)) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-key+value "no element at index" + "index" i) + val))))) + +(define (weak-hash-iterate-pair ht i) + (let ([key (do-weak-hash-iterate-key 'hash-iterate-pair ht i #f)]) + (cons key + (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (lock-release (weak-equal-hash-lock ht)) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-paur "no element at index" + "index" i) + val))))) + +;; Remove empty weak boxes from a table. Count the number +;; of remaining entries, and remember to prune again when +;; the number of entries doubles (up to at least reaches 128) +(define (prune-table! t) + (let ([ht (weak-equal-hash-keys-ht t)]) + (let-values ([(new-ht count) + (let loop ([ht ht] + [i (intmap-iterate-first ht)] + [count 0]) + (cond + [(not i) (values ht count)] + [else + (let-values ([(key l) (intmap-iterate-key+value ht i #f)]) + (let ([l (let loop ([l l]) + (cond + [(null? l) l] + [(bwp-object? (car l)) (loop (cdr l))] + [else (weak/fl-cons (car l) (loop (cdr l)))]))]) + (loop (if (null? l) + ht + (hash-set ht key l)) + (intmap-iterate-next ht i) + (+ count (length l)))))]))]) + (set-weak-equal-hash-keys-ht! t new-ht) + (set-weak-equal-hash-count! t count) + (set-weak-equal-hash-prune-at! t (max 128 (* 2 count)))))) + +;; ---------------------------------------- + +(define (weak/fl-cons key d) + ;; Special case for flonums, which are never retained in weak pairs, + ;; but we want to treat them like fixnums and other immediates: + (if (flonum? key) + (cons key d) + (weak-cons key d))) + +;; ---------------------------------------- + +(define (set-hash-hash!) + (record-type-equal-procedure (record-type-descriptor mutable-hash) + hash=?) + (record-type-hash-procedure (record-type-descriptor mutable-hash) + hash-hash-code) + (record-type-equal-procedure (record-type-descriptor weak-equal-hash) + hash=?) + (record-type-hash-procedure (record-type-descriptor weak-equal-hash) + hash-hash-code) + + (record-type-hash-procedure (record-type-descriptor hash-impersonator) + hash-hash-code) + (record-type-hash-procedure (record-type-descriptor hash-chaperone) + hash-hash-code)) + +;; ---------------------------------------- + +;; `eq?` identity of a `hash-procs` instance matters for +;; `impersonator-of?` and `chaperone-of?`: +(define-record hash-procs (ref set remove key clear equal-key)) + +(define-record hash-impersonator impersonator (procs)) +(define-record hash-chaperone chaperone (procs)) + +(define/who (impersonate-hash ht ref set remove key . args) + (check who + (lambda (p) (let ([p (strip-impersonator p)]) + (or (mutable-hash? p) (weak-equal-hash? p)))) + :contract "(and/c hash? (not/c immutable?))" + ht) + (do-impersonate-hash who ht ref set remove key args + make-hash-impersonator)) + +(define/who (chaperone-hash ht ref set remove key . args) + (check who hash? ht) + (do-impersonate-hash who ht ref set remove key args + make-hash-chaperone)) + +(define (do-impersonate-hash who ht ref set remove key args + make-hash-chaperone) + (check who (procedure-arity-includes/c 2) ref) + (check who (procedure-arity-includes/c 3) set) + (check who (procedure-arity-includes/c 2) remove) + (check who (procedure-arity-includes/c 2) key) + (let* ([clear-given? (and (pair? args) + (or (not (car args)) + (and (procedure? (car args)) + (procedure-arity-includes? (car args) 1))))] + [clear (if clear-given? (car args) void)] + [args (if clear-given? (cdr args) args)] + [equal-key-given? (and (pair? args) + (or (not (car args)) + (and (procedure? (car args)) + (procedure-arity-includes? (car args) 2))))] + [equal-key (if equal-key-given? + (car args) + (lambda (ht k) k))] + [args (if equal-key-given? (cdr args) args)]) + (make-hash-chaperone (strip-impersonator ht) + ht + (add-impersonator-properties who + args + (if (impersonator? ht) + (impersonator-props ht) + empty-hasheq)) + (make-hash-procs ref set remove key clear equal-key)))) + +;; ---------------------------------------- + +(define (impersonate-hash-ref ht k) + (impersonate-hash-ref/set 'hash-ref #f + (lambda (ht k v) (hash-ref ht k none)) + (lambda (procs ht k none-v) + ((hash-procs-ref procs) ht k)) + hash-procs-ref + ht k none)) + +(define (impersonate-hash-set! ht k v) + (impersonate-hash-ref/set 'hash-set! #t + hash-set! + (lambda (procs ht k v) + ((hash-procs-set procs) ht k v)) + hash-procs-set + ht k v)) + +(define (impersonate-hash-set ht k v) + (impersonate-hash-ref/set 'hash-set #t + hash-set + (lambda (procs ht k v) + ((hash-procs-set procs) ht k v)) + hash-procs-set + ht k v)) + +(define (impersonate-hash-remove! ht k) + (impersonate-hash-ref/set 'hash-remove! #t + (lambda (ht k false-v) (hash-remove! ht k)) + (lambda (procs ht k false-v) + (values ((hash-procs-remove procs) ht k) #f)) + hash-procs-remove + ht k #f)) + +(define (impersonate-hash-remove ht k) + (impersonate-hash-ref/set 'hash-remove #t + (lambda (ht k false-v) (hash-remove ht k)) + (lambda (procs ht k false-v) + (values ((hash-procs-remove procs) ht k) #f)) + hash-procs-remove + ht k #f)) + +(define (impersonate-hash-ref/set who set? authentic-op apply-wrapper get-wrapper ht k v) + (let ([wrap-key? (hash-equal? ht)]) + (let loop ([ht ht] [get-k (and wrap-key? values)] [k k] [v v]) + (cond + [(or (hash-impersonator? ht) + (hash-chaperone? ht)) + (let ([chaperone? (hash-chaperone? ht)] + [procs (if (hash-impersonator? ht) + (hash-impersonator-procs ht) + (hash-chaperone-procs ht))] + [next-ht (impersonator-next ht)]) + (let ([get-k (and wrap-key? (extend-get-k who get-k procs next-ht chaperone?))]) + (call-with-values + (lambda () (apply-wrapper procs next-ht k v)) + (case-lambda + [(new-k new-v-or-wrap) + ;; In `ref` mode, `new-v-or-wrap` is a wrapper procedure for the result. + ;; In `set` mode, `new-v-or-wrap` is a replacement value. + (when chaperone? + (unless (or (not chaperone?) (chaperone-of? new-k k)) + (raise-chaperone-error who "key" new-k k)) + (when set? + (unless (or (not chaperone?) (chaperone-of? new-v-or-wrap v)) + (raise-chaperone-error who "value" new-v-or-wrap v)))) + ;; Recur... + (let ([r (loop next-ht get-k new-k (if set? new-v-or-wrap none))]) + ;; In `ref` mode, `r` is the result value. + ;; In `set` mode, `r` is void or an updated hash table. + (cond + [(and set? (void? r)) + (void)] + [set? + ((if chaperone? make-hash-chaperone make-hash-impersonator) + (strip-impersonator r) + r + (impersonator-props ht) + procs)] + [(eq? r none) none] + [else + (let ([new-r (new-v-or-wrap next-ht new-k r)]) + (when chaperone? + (unless (chaperone-of? new-r r) + (raise-chaperone-error who "value" new-r r))) + new-r)]))] + [args + (raise-arguments-error who + (string-append (if chaperone? "chaperone" "impersonator") + " did not return 2 values") + (string-append (if chaperone? "chaperone" "impersonator") + " procedure") + (get-wrapper procs) + "number of returned values" (length args))]))))] + [(impersonator? ht) + (let ([r (loop (impersonator-next ht) get-k k v)]) + (cond + [(and set? (void? r)) + (void)] + [set? + (rewrap-props-impersonator ht r)] + [else r]))] + [else + (if (and get-k (not (eq? get-k values))) + (call-with-equality-wrap + get-k + k + (lambda () (authentic-op ht k v))) + (authentic-op ht k v))])))) + +;; Add a layer of interposition on `equal?` and `equal-hash-code`: +(define (extend-get-k who get-k procs next-ht chaperone?) + (lambda (k) + (let* ([k (get-k k)] + [new-k ((hash-procs-equal-key procs) next-ht k)]) + (unless (or (not chaperone?) (chaperone-of? new-k k)) + (raise-chaperone-error who "key" new-k k)) + new-k))) + +(define (impersonate-hash-clear! ht) + (let loop ([ht ht]) + (cond + [(or (hash-impersonator? ht) + (hash-chaperone? ht)) + (let ([procs (if (hash-impersonator? ht) + (hash-impersonator-procs ht) + (hash-chaperone-procs ht))] + [ht (impersonator-next ht)]) + ((hash-procs-clear procs) ht) + (loop ht))] + [(impersonator? ht) + (loop (impersonator-next ht))] + [else + (hash-clear! ht)]))) + +(define (impersonate-hash-copy ht) + (let* ([val-ht (impersonator-val ht)] + [mutable? (mutable-hash? val-ht)] + [new-ht + (cond + [mutable? + (cond + [(hash-weak? ht) + (cond + [(hash-eq? val-ht) (make-weak-hasheq)] + [(hash-eqv? val-ht) (make-weak-hasheq)] + [else (make-weak-hash)])] + [else + (cond + [(hash-eq? val-ht) (make-hasheq)] + [(hash-eqv? val-ht) (make-hasheq)] + [else (make-hash)])])] + [else + (cond + [(hash-eq? val-ht) (make-hasheq)] + [(hash-eqv? val-ht) (make-hasheqv)] + [else (make-hash)])])]) + (let loop ([i (hash-iterate-first ht)]) + (cond + [i (let-values ([(key val) (hash-iterate-key+value ht i)]) + (hash-set! new-ht key val) + (loop (hash-iterate-next ht i)))] + [else new-ht])))) + +(define (impersonate-hash-iterate-key+value who ht i key? value? pair?) + (let ([key (impersonate-hash-iterate-key who ht i)]) + (cond + [(not value?) key] + [else + (let ([val (hash-ref ht key none)]) + (cond + [(eq? val none) + (raise-arguments-error who + (string-append "no value found for post-" + (if (impersonator? ht) "impersonator" "chaperone") + " key") + "key" key)] + [pair? (cons key val)] + [key? (values key val)] + [else val]))]))) + +(define (impersonate-hash-iterate-key who ht i) + ;; We don't have to set up `get-k`, because `hash-iterate-key` + ;; is prohibited from hashing any keys + (let loop ([ht ht]) + (cond + [(hash-impersonator? ht) + (let ([procs (hash-impersonator-procs ht)] + [ht (impersonator-next ht)]) + ((hash-procs-key procs) ht (loop ht)))] + [(hash-chaperone? ht) + (let ([procs (hash-chaperone-procs ht)] + [ht (impersonator-next ht)]) + (let* ([k (loop ht)] + [new-k ((hash-procs-key procs) ht k)]) + (unless (chaperone-of? new-k k) + (raise-chaperone-error who "key" new-k k)) + new-k))] + [(impersonator? ht) + (loop (impersonator-next ht))] + [else + ;; The same as `hash-iterate-key`, but with the correct `who`: + (do-hash-iterate-key+value who ht i + intmap-iterate-key + weak-hash-iterate-key + #t #f #f)]))) diff -Nru racket-6.12+ppa1/src/cs/rumble/immutable.ss racket-7.0+ppa1/src/cs/rumble/immutable.ss --- racket-6.12+ppa1/src/cs/rumble/immutable.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/immutable.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ + +(define (immutable? v) + (let ([v (strip-impersonator v)]) + (or (intmap? v) + (immutable-string? v) + (immutable-bytevector? v) + (immutable-vector? v) + (immutable-box? v)))) diff -Nru racket-6.12+ppa1/src/cs/rumble/impersonator.ss racket-7.0+ppa1/src/cs/rumble/impersonator.ss --- racket-6.12+ppa1/src/cs/rumble/impersonator.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/impersonator.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,591 @@ + +(define-record impersonator (val next props)) +(define-record chaperone impersonator ()) + +(define (impersonator-ephemeron i) + (if (impersonator? i) + (make-ephemeron (impersonator-val i) i) + ;; This is a useless ephemeron, but we create one for consistency + ;; with the case that we have an impersonator: + (make-ephemeron i i))) + +(define (strip-impersonator v) + (if (impersonator? v) + (impersonator-val v) + v)) + +(define (raise-chaperone-error who what e e2) + (raise-arguments-error + who + (string-append "non-chaperone result; received a" (if (equal? what "argument") "n" "") " " what + " that is not a chaperone of the original " what) + "original" e + "received" e2)) + +(define (impersonate-ref acc rtd pos orig) + (impersonate-struct-or-property-ref acc rtd (cons rtd pos) orig)) + +(define (impersonate-struct-or-property-ref acc rtd key orig) + (cond + [(and (impersonator? orig) + (or (not rtd) + (record? (impersonator-val orig) rtd))) + (let loop ([v orig]) + (cond + [(or (struct-impersonator? v) + (struct-chaperone? v)) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) + (cond + [wrapper + (let* ([r (cond + [(pair? wrapper) + (|#%app| (car wrapper) (impersonator-next v))] + [else + (loop (impersonator-next v))])] + [new-r (cond + [(pair? wrapper) + (|#%app| (cdr wrapper) orig r)] + [else (|#%app| wrapper orig r)])]) + (when (struct-chaperone? v) + (unless (chaperone-of? new-r r) + (raise-chaperone-error 'struct-ref "value" r new-r))) + new-r)] + [else + (loop (impersonator-next v))]))] + [(and (struct-undefined-chaperone? v) + rtd) + (let ([r (loop (impersonator-next v))]) + (when (eq? r unsafe-undefined) + (raise-unsafe-undefined 'struct-ref "undefined" "use" acc (impersonator-val v) (cdr key))) + r)] + [(impersonator? v) + (loop (impersonator-next v))] + [else (|#%app| acc v)]))] + [else + ;; Let accessor report the error: + (|#%app| acc orig)])) + +(define (impersonate-set! set rtd pos abs-pos orig a) + (cond + [(and (impersonator? orig) + (record? (impersonator-val orig) rtd)) + (let ([key (vector rtd pos)]) + (let loop ([v orig] [a a]) + (cond + [(or (struct-impersonator? v) + (struct-chaperone? v)) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) + (cond + [wrapper + (let ([new-a (cond + [(pair? wrapper) + (|#%app| (cdr wrapper) orig a)] + [else (wrapper orig a)])]) + (when (struct-chaperone? v) + (unless (chaperone-of? new-a a) + (raise-chaperone-error 'struct-set! "value" a new-a))) + (cond + [(pair? wrapper) + (|#%app| (car wrapper) (impersonator-next v) new-a)] + [else + (loop (impersonator-next v) new-a)]))] + [else + (loop (impersonator-next v) a)]))] + [(struct-undefined-chaperone? v) + (when (eq? (unsafe-struct*-ref (impersonator-val v) abs-pos) unsafe-undefined) + (unless (eq? (continuation-mark-set-first #f prop:chaperone-unsafe-undefined) + unsafe-undefined) + (raise-unsafe-undefined 'struct-set! "assignment disallowed" "assign" set (impersonator-val v) pos))) + (loop (impersonator-next v) a)] + [(impersonator? v) + (loop (impersonator-next v) a)] + [else (set v a)])))] + [else + ;; Let mutator report the error: + (set orig a)])) + +(define (impersonate-struct-info orig) + (let loop ([v orig]) + (cond + [(struct-chaperone? v) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) struct-info #f)]) + (cond + [wrapper + (let-values ([(rtd skipped?) (loop (impersonator-next v))]) + (cond + [(not rtd) (values #f skipped?)] + [else + (call-with-values (lambda () (wrapper rtd skipped?)) + (case-lambda + [(new-rtd new-skipped?) + (unless (chaperone-of? new-rtd rtd) + (raise-chaperone-error 'struct-info "value" rtd new-rtd)) + (unless (chaperone-of? new-skipped? skipped?) + (raise-chaperone-error 'struct-info "value" skipped? new-skipped?)) + (values new-rtd new-skipped?)] + [args (raise-impersonator-result-arity-error 'struct-info orig 2 args)]))]))] + [else + (loop (impersonator-next v))]))] + [(impersonator? v) + (loop (impersonator-next v))] + [else (struct-info v)]))) + +(define (raise-impersonator-result-arity-error who orig n args) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (symbol->string who) ": arity mismatch;\n" + " received wrong number of values from a chaperone's replacement procedure\n" + " expected: " (number->string n) "\n" + " received: " (number->string (length args)) "\n" + " chaperone: " (error-value->string orig))))) + +;; ---------------------------------------- + +(define-record struct-type-chaperone chaperone (struct-info make-constructor guard)) + +(define/who (chaperone-struct-type rtd struct-info-proc make-constructor-proc guard-proc . props) + (check who struct-type? rtd) + (check who (procedure-arity-includes/c 8) struct-info-proc) + (check who (procedure-arity-includes/c 1) make-constructor-proc) + (check who procedure? guard-proc) + (make-struct-type-chaperone + (strip-impersonator rtd) + rtd + (add-impersonator-properties who + props + (if (impersonator? rtd) + (impersonator-props rtd) + empty-hasheq)) + struct-info-proc + make-constructor-proc + guard-proc)) + +(define (chaperone-constructor rtd ctr) + (let loop ([rtd rtd]) + (cond + [(struct-type-chaperone? rtd) + (let* ([ctr (loop (impersonator-next rtd))] + [new-ctr ((struct-type-chaperone-make-constructor rtd) ctr)]) + (unless (chaperone-of? new-ctr ctr) + (raise-chaperone-error 'struct-type-make-constructor "value" ctr new-ctr)) + new-ctr)] + [(impersonator? rtd) + (loop (impersonator-next rtd))] + [else ctr]))) + +(define (chaperone-struct-type-info orig-rtd get-results) + (apply + values + (let loop ([rtd orig-rtd]) + (cond + [(struct-type-chaperone? rtd) + (let ([results (loop (impersonator-next rtd))]) + (let-values ([new-results (apply (struct-type-chaperone-struct-info rtd) results)]) + (cond + [(= (length results) (length new-results)) + (for-each (lambda (r new-r) + (unless (chaperone-of? new-r r) + (raise-chaperone-error 'struct-type-info "value" r new-r))) + results + new-results) + new-results] + [else + (raise-impersonator-result-arity-error 'struct-type-info orig-rtd (length results) new-results)])))] + [(impersonator? rtd) + (loop (impersonator-next rtd))] + [else (call-with-values get-results list)])))) + +;; ---------------------------------------- + +(define-record-type (impersonator-property create-impersonator-property impersonator-property?) + (fields name)) + +(define-record-type (impersonator-property-accessor-procedure + make-impersonator-property-accessor-procedure + raw:impersonator-property-accessor-procedure?) + (fields proc name)) + +(define/who (make-impersonator-property name) + (check who symbol? name) + (let ([p (create-impersonator-property name)] + [predicate-name (string->symbol (format "~a?" name))] + [accessor-name (string->symbol (format "~a-accessor" name))]) + (letrec ([predicate + (lambda (v) + (if (impersonator? v) + (not (eq? none (hash-ref (impersonator-props v) p none))) + (let ([iv (extract-impersonator-of predicate-name v)]) + (and iv + (predicate iv)))))] + [accessor + (lambda (v) + (if (impersonator? v) + (let ([pv (hash-ref (impersonator-props v) p none)]) + (if (eq? none pv) + (raise-argument-error accessor-name + (format "~a?" name) + v) + pv)) + (let ([iv (extract-impersonator-of accessor-name v)]) + (and iv + (accessor iv)))))]) + (values p + (make-named-procedure predicate predicate-name) + (make-impersonator-property-accessor-procedure accessor accessor-name))))) + +(define (impersonator-property-accessor-procedure? v) + (or (raw:impersonator-property-accessor-procedure? v) + (and (impersonator? v) (raw:impersonator-property-accessor-procedure? (impersonator-val v))))) + +;; ---------------------------------------- + +(define-record props-impersonator impersonator ()) +(define-record props-chaperone chaperone ()) + +;; Applicable variants: +(define-record props-procedure-impersonator props-impersonator ()) +(define-record props-procedure-chaperone props-chaperone ()) + +(define (add-impersonator-properties who props base-props) + (let loop ([props props] [base-props base-props]) + (cond + [(null? props) + base-props] + [(impersonator-property? (car props)) + (when (null? (cdr props)) + (raise-arguments-error who "missing value argument after an imperonsonator-property argument" + "impersonator property" (car props))) + (loop (cddr props) (hash-set base-props (car props) (cadr props)))] + [else + (raise-argument-error who "impersonator-property?" (car props))]))) + +(define (rewrap-props-impersonator orig new) + ((cond + [(props-procedure-impersonator? orig) make-props-procedure-impersonator] + [(props-procedure-chaperone? orig) make-props-procedure-chaperone] + [(props-chaperone? orig) make-props-chaperone] + [(props-impersonator? orig) make-props-impersonator] + [else (raise-arguments-error 'rewrap-props-impersonator "internal error: unknown impersonator variant")]) + (strip-impersonator new) + new + (impersonator-props orig))) + +;; ---------------------------------------- + +(define-record struct-impersonator impersonator (procs)) ; hash of proc -> (cons orig-orig wrapper-proc) +(define-record struct-chaperone chaperone (procs)) + +(define (struct-impersonator/chaperone-procs i) + (if (struct-impersonator? i) + (struct-impersonator-procs i) + (struct-chaperone-procs i))) + +(define-record procedure-struct-impersonator struct-impersonator ()) +(define-record procedure-struct-chaperone struct-chaperone ()) + +(define (impersonate-struct v . args) + (do-impersonate-struct 'impersonate-struct #f v args make-struct-impersonator make-procedure-struct-impersonator)) + +(define (chaperone-struct v . args) + (do-impersonate-struct 'chaperone-struct #t v args make-struct-chaperone make-procedure-struct-chaperone)) + +(define (do-impersonate-struct who as-chaperone? v args make-struct-impersonator make-procedure-struct-impersonator) + (cond + [(null? args) v] + [else + (let* ([st (if (struct-type? (car args)) + (car args) + #f)] + [orig-args (if st (cdr args) args)] + [val (strip-impersonator v)] + [orig-iprops (if (impersonator? v) (impersonator-props v) empty-hasheq)]) + (unless (or (not st) (record? val (strip-impersonator st))) + (raise-arguments-error who "given value is not an instance of the given structure type" + "struct type" st + "value" v)) + (let loop ([first? (not st)] + [args orig-args] + [props empty-hash] + [saw-props empty-hash] + [witnessed? (and st #t)] + [iprops orig-iprops]) + (let ([get-proc + (lambda (what args arity proc->key key-applies?) + (let* ([key-proc (strip-impersonator (car args))] + [key (proc->key key-proc)]) + (when (hash-ref saw-props key #f) + (raise-arguments-error who + "given operation accesses the same value as a previous operation argument" + "operation kind" what + "operation procedure" (car args))) + (when key-applies? + (unless (key-applies? key val) + (raise-arguments-error who + "operation does not apply to given value" + "operation kind" what + "operation procedure" (car args) + "value" v))) + (when (null? (cdr args)) + (raise-arguments-error who + "missing redirection procedure after operation" + "operation kind" what + "operation procedure" (car args))) + (let ([proc (cadr args)]) + (when proc + (unless (procedure-arity-includes? proc arity) + (raise-arguments-error who + "operation's redirection procedure does not match the expected arity" + "given" proc + "expected" (string-append + "(or/c #f (procedure-arity-includes/c " (number->string arity) "))") + "operation kind" what + "operation procedure" (car args)))) + (loop #f + (cddr args) + (if proc + (hash-set props key + (if (impersonator? (car args)) + (cons (car args) ; save original accessor, in case it's impersonated + proc) ; the interposition proc + proc)) + props) + (hash-set saw-props key #t) + (or witnessed? key-applies?) + iprops))))]) + (cond + [(null? args) + (unless as-chaperone? + (check-accessors-paired-with-mutators who orig-args v)) + (unless witnessed? + (raise-arguments-error who + (string-append "cannot " + (if as-chaperone? "chaperone" "impersonate") + " value as a structure without a witness") + "explanation" (string-append + "a structure type, accessor, or mutator acts as a witness\n" + " that the given value's representation can be chaperoned or impersonated") + "given value" v)) + (when (authentic? v) + (raise-arguments-error who + (string-append "cannot " + (if as-chaperone? "chaperone" "impersonate") + " instance of an authentic structure type") + "given value" v)) + (if (and (zero? (hash-count props)) + (eq? iprops orig-iprops)) + v + (let ([mk (if (procedure? v) make-procedure-struct-impersonator make-struct-impersonator)]) + (mk val v iprops props)))] + [(impersonator-property? (car args)) + (loop #f + '() + props + saw-props + witnessed? + (add-impersonator-properties who args iprops))] + [(struct-accessor-procedure? (car args)) + (get-proc "accessor" args 2 + struct-accessor-procedure-rtd+pos + (lambda (rtd+pos v) + (and (record? v (car rtd+pos)) + (begin + (unless (or as-chaperone? + (struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos))) + (raise-arguments-error who + "cannot replace operation for an immutable field" + "operation kind" "property accessor" + "operation procedure" (car args))) + #t))))] + [(struct-mutator-procedure? (car args)) + (get-proc "mutator" args 2 + (lambda (proc) + (let ([rtd+pos (struct-mutator-procedure-rtd+pos proc)]) + (vector (car rtd+pos) (cdr rtd+pos)))) + (lambda (rtd++pos v) + (record? v (vector-ref rtd++pos 0))))] + [(struct-type-property-accessor-procedure? (car args)) + (get-proc "property accessor" args 2 + (lambda (proc) proc) + (lambda (proc v) + (unless (or as-chaperone? + (struct-type-property-accessor-procedure-can-impersonate? proc)) + (raise-arguments-error who + "operation cannot be impersonated" + "operation kind" "property accessor" + "operation procedure" (car args))) + ((struct-type-property-accessor-procedure-pred proc) v)))] + [(and as-chaperone? + (equal? struct-info (car args))) + (get-proc "struct-info procedure" args 2 (lambda (proc) proc) #f)] + [else + (raise-argument-error who + (string-append + "(or/c " + (if first? "struct-type?\n " "") + "struct-accessor-procedure?" + "\n struct-mutator-procedure?" + "\n struct-type-property-accessor-procedure?" + (if as-chaperone? "\n struct-info" "") + ")") + (car args))]))))])) + +(define (check-accessors-paired-with-mutators who args v) + (let ([mutator-reps + (let loop ([args args]) + (cond + [(null? args) empty-hash] + [(struct-mutator-procedure? (car args)) + (hash-set (loop (cddr args)) + (struct-mutator-procedure-rtd+pos (strip-impersonator (car args))) + #t)] + [else + (loop (cddr args))]))]) + (let loop ([args args]) + (cond + [(null? args) empty-hash] + [(struct-accessor-procedure? (car args)) + (let ([rtd+pos (struct-accessor-procedure-rtd+pos (strip-impersonator (car args)))]) + (unless (or (struct-type-immediate-transparent? (car rtd+pos)) + (hash-ref mutator-reps rtd+pos #f)) + (raise-arguments-error who + "accessor redirection for a non-transparent field requires a mutator redirection" + "explanation" "a mutator redirection acts as a witness that access is allowed" + "accessor" (car args) + "value to impersonate" v))) + (loop (cddr args))] + [else + (loop (cddr args))])))) + +;; ---------------------------------------- + +(define-record struct-undefined-chaperone chaperone ()) +(define-record procedure-struct-undefined-chaperone chaperone ()) + +(define-values (prop:chaperone-unsafe-undefined chaperone-unsafe-undefined? chaperone-unsafe-undefined-ref) + (make-struct-type-property 'chaperone-unsafe-undefined + (lambda (v info) + (check 'guard-for-prop:chaperone-unsafe-undefined + (lambda (v) (and (list? v) (andmap symbol? v))) + :contract "(listof symbol?)" + v) + v))) + +(define (chaperone-struct-unsafe-undefined v) + (cond + [(not (record? v)) + v] + [else + ((if (procedure? v) + make-procedure-struct-undefined-chaperone + make-struct-undefined-chaperone) + (strip-impersonator v) + v + (if (impersonator? v) + (impersonator-props v) + empty-hasheq))])) + +(define (raise-unsafe-undefined who short-msg what orig-proc v pos) + (let* ([names (if (chaperone-unsafe-undefined? v) + (chaperone-unsafe-undefined-ref v) + '())] + [len (length names)]) + (cond + [(< pos len) + (let ([n (list-ref names (- len pos 1))]) + (raise + (|#%app| + exn:fail:contract:variable + (format "~a: ~a;\n cannot ~a field before initialization" + n short-msg what) + (current-continuation-marks) + n)))] + [else + (raise + (|#%app| + exn:fail:contract + (format "~a: ~a;\n cannot ~as field before initialization" + (object-name orig-proc) short-msg what) + (current-continuation-marks)))]))) + +;; ---------------------------------------- + +(define-values (prop:impersonator-of impersonator-of-redirect? impersonator-of-ref) + (make-struct-type-property 'impersonator-of + (lambda (v info) + (check 'guard-for-prop:impersonator-of (procedure-arity-includes/c 1) v) + ;; Add a tag to track origin of the `prop:impersonator-of` value + (cons (gensym "tag") v)))) + +(define (extract-impersonator-of who a) + (and (impersonator-of-redirect? a) + (let* ([tag+ref (impersonator-of-ref a)] + [a2 (|#%app| (cdr tag+ref) a)]) + (cond + [(not a2) + ;; `prop:impersonator-of` function can report #f to mean + ;; "not an impersonator, after all" + #f] + [else + (let ([different + (lambda (what) + (raise-arguments-error who (format (string-append "impersonator-of property procedure returned a" + " value with a different `~a` source") + what) + "original value" a + "returned value" a2))]) + (unless (and (impersonator-of-redirect? a2) + (eq? (car tag+ref) + (car (impersonator-of-ref a2)))) + (different 'prop:impersonator-of)) + (unless (record-equal-procedure a (strip-impersonator a2)) + (different 'prop:equal+hash)) + a2)])))) + +;; ---------------------------------------- + +(define (set-impersonator-applicables!) + (struct-property-set! prop:procedure + (record-type-descriptor props-procedure-impersonator) + impersonate-apply) + (struct-property-set! prop:procedure + (record-type-descriptor props-procedure-chaperone) + impersonate-apply) + (struct-property-set! prop:procedure-arity + (record-type-descriptor props-procedure-impersonator) + 0) + (struct-property-set! prop:procedure-arity + (record-type-descriptor props-procedure-chaperone) + 0) + + (struct-property-set! prop:procedure + (record-type-descriptor impersonator-property-accessor-procedure) + 0)) + +(define (set-impersonator-hash!) + (let ([struct-impersonator-hash-code + (escapes-ok + (lambda (c hash-code) + ((record-type-hash-procedure + (record-rtd (impersonator-val c))) + c + hash-code)))]) + (let ([add (lambda (rtd) + (record-type-hash-procedure rtd struct-impersonator-hash-code))]) + (add (record-type-descriptor struct-impersonator)) + (add (record-type-descriptor struct-chaperone)) + (add (record-type-descriptor procedure-struct-impersonator)) + (add (record-type-descriptor procedure-struct-chaperone))) + (let ([add (lambda (rtd) + (record-type-hash-procedure rtd + (lambda (c hash-code) + (cond + [(record? (impersonator-val c)) + (struct-impersonator-hash-code c hash-code)] + [else + (hash-code (impersonator-next c))]))))]) + (add (record-type-descriptor props-impersonator)) + (add (record-type-descriptor props-chaperone)) + (add (record-type-descriptor props-procedure-impersonator)) + (add (record-type-descriptor props-procedure-chaperone))))) diff -Nru racket-6.12+ppa1/src/cs/rumble/inline.ss racket-7.0+ppa1/src/cs/rumble/inline.ss --- racket-6.12+ppa1/src/cs/rumble/inline.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/inline.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +;; Force inlining of the fast path for various primitives that are +;; otherwise wrapped with impersonator checks + +(define-syntax (define-inline stx) + (syntax-case stx () + [(_ (orig-id arg ...) guard op) + (with-syntax ([(tmp ...) (generate-temporaries #'(arg ...))] + [id (datum->syntax #'orig-id + (#%string->symbol + (string-append "inline:" + (#%symbol->string (syntax->datum #'orig-id)))))]) + #'(define-syntax (id stx) + (syntax-case stx () + [(_ tmp ...) + #'(let ([arg tmp] ...) + (if guard + op + (orig-id arg ...)))] + [(_ . args) + #'(orig-id . args)] + [_ #'orig-id])))])) + +(define-inline (vector-length v) + (#%vector? v) + (#3%vector-length v)) + +(define-inline (vector-ref v i) + (#%vector? v) + (#2%vector-ref v i)) + +(define-inline (vector-set! v i n) + (#%vector? v) + (#2%vector-set! v i n)) + +(define-inline (unbox b) + (#%box? b) + (#3%unbox b)) + +(define-inline (set-box! b v) + (#%mutable-box? b) + (#3%set-box! b v)) + +(define-inline (mcar p) + (mpair? p) + (unsafe-mcar p)) + +(define-inline (mcdr p) + (mpair? p) + (unsafe-mcdr p)) + +(define-inline (set-mcar! p v) + (mpair? p) + (unsafe-set-mcar! p v)) + +(define-inline (set-mcdr! p v) + (mpair? p) + (unsafe-set-mcdr! p v)) diff -Nru racket-6.12+ppa1/src/cs/rumble/interrupt.ss racket-7.0+ppa1/src/cs/rumble/interrupt.ss --- racket-6.12+ppa1/src/cs/rumble/interrupt.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/interrupt.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,59 @@ + +;; Enabling uninterrupted mode defers a timer callback +;; until leaving uninterrupted mode. This is the same +;; as disabling and enabling interrupts at the Chez +;; level, but cheaper and more limited. + +(define-virtual-register current-in-uninterrupted #f) +(define-virtual-register pending-interrupt-callback #f) + +(define-syntax CHECK-uninterrupted + (syntax-rules () + [(_ e ...) (void) #;(begin e ...)])) + +(define (start-uninterrupted who) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'start-uninterrupted (format "~a: already started" who)))) + (current-in-uninterrupted #t)) + +(define (end-uninterrupted who) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'end-uninterrupted (format "~a: not started" who)))) + (current-in-uninterrupted #f) + (when (pending-interrupt-callback) + (pariah + (let ([callback (pending-interrupt-callback)]) + (pending-interrupt-callback #f) + (callback))))) + +(define (assert-in-uninterrupted) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'assert-in-uninterrupted "assertion failed")))) + +(define (assert-not-in-uninterrupted) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'assert-not-in-uninterrupted "assertion failed")))) + +;; An implicit context is when a relevant interrupt can't happen, but +;; `assert-in-uninterrupted` might be called. + +(define (start-implicit-uninterrupted who) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'start-implicit-uninterrupted "already started")) + (current-in-uninterrupted #t))) + +(define (end-implicit-uninterrupted who) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'end-implicit-uninterrupted "not started")) + (current-in-uninterrupted #f))) + +(define (internal-error who s) + (CHECK-uninterrupted + (chez:fprintf (current-error-port) "~a: ~a\n" who s) + (chez:exit 1))) diff -Nru racket-6.12+ppa1/src/cs/rumble/intmap.ss racket-7.0+ppa1/src/cs/rumble/intmap.ss --- racket-6.12+ppa1/src/cs/rumble/intmap.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/intmap.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,469 @@ +;; Immutable maps represented as big-endian Patricia tries. +;; Based on Okasaki & Gill's "Fast Mergeable Integer Maps," +;; (1998) with an added collision node. +;; +;; I also consulted Leijen and Palamarchuk's Haskell implementation +;; of Data.IntMap. + +(define-record-type intmap + [fields (immutable eqtype) + (mutable root)] + [nongenerative #{intmap pfwguidjcvqbvofiirp097jco-0}] + [sealed #t]) + +(define-record-type Br + [fields (immutable count) + (immutable prefix) + (immutable mask) + (immutable left) + (immutable right)] + [nongenerative #{Br pfwguidjcvqbvofiirp097jco-1}] + [sealed #t]) + +(define-record-type Lf + [fields (immutable hash) + (immutable key) + (immutable value)] + [nongenerative #{Lf pfwguidjcvqbvofiirp097jco-2}] + [sealed #t]) + +(define-record-type Co + [fields (immutable hash) + (immutable pairs)] + [nongenerative #{Co pfwguidjcvqbvofiirp097jco-3}] + [sealed #t]) + +(define *nothing* (gensym)) + +(define immutable-hash? intmap?) + +(define empty-hash (make-intmap 'equal #f)) +(define empty-hasheqv (make-intmap 'eqv #f)) +(define empty-hasheq (make-intmap 'eq #f)) + +(define (make-intmap-shell et) + (make-intmap et #f)) + +(define (intmap-shell-sync! dst src) + (intmap-root-set! dst (intmap-root src))) + +(define (intmap-equal? t) (eq? 'equal (intmap-eqtype t))) +(define (intmap-eqv? t) (eq? 'eqv (intmap-eqtype t))) +(define (intmap-eq? t) (eq? 'eq (intmap-eqtype t))) + +(define (intmap-count t) + ($intmap-count (intmap-root t))) + +(define (intmap-empty? t) + (fx= 0 (intmap-count t))) + +(define ($intmap-count t) + (cond [(Br? t) (Br-count t)] + [(Lf? t) 1] + [(Co? t) (length (Co-pairs t))] + [else 0])) + +(define (intmap-ref t key def) + (let ([et (intmap-eqtype t)] + [root (intmap-root t)]) + (if root + ($intmap-ref et root (hash-code et key) key def) + ($fail def)))) + +(define ($intmap-ref et t h key def) + (cond + [(Br? t) + (if (fx<= h (Br-prefix t)) + ($intmap-ref et (Br-left t) h key def) + ($intmap-ref et (Br-right t) h key def))] + + [(Lf? t) + (if (key=? et key (Lf-key t)) + (Lf-value t) + ($fail def))] + + [(Co? t) + (if (fx= h (Co-hash t)) + ($collision-ref et t key def) + ($fail def))] + + [else + ($fail def)])) + +(define ($intmap-has-key? et t h key) + (not (eq? *nothing* ($intmap-ref et t h key *nothing*)))) + +(define (intmap-set t key val) + (let ([et (intmap-eqtype t)]) + (make-intmap + et + ($intmap-set et (intmap-root t) (hash-code et key) key val)))) + +(define ($intmap-set et t h key val) + (cond + [(Br? t) + (let ([p (Br-prefix t)] + [m (Br-mask t)]) + (cond + [(not (match-prefix? h p m)) + (join h (make-Lf h key val) p t)] + [(fx<= h p) + (br p m ($intmap-set et (Br-left t) h key val) (Br-right t))] + [else + (br p m (Br-left t) ($intmap-set et (Br-right t) h key val))]))] + + [(Lf? t) + (let ([j (Lf-hash t)]) + (cond + [(not (fx= h j)) + (join h (make-Lf h key val) j t)] + [(key=? et key (Lf-key t)) + (make-Lf h key val)] + [else + (make-Co h (list (cons key val) (cons (Lf-key t) (Lf-value t))))]))] + + [(Co? t) + (let ([j (Co-hash t)]) + (if (fx= h j) + (make-Co j ($collision-set et t key val)) + (join h (make-Lf h key val) j t)))] + + [else + (make-Lf h key val)])) + +(define (join p0 t0 p1 t1) + (let* ([m (branching-bit p0 p1)] + [p (mask p0 m)]) + (if (fx<= p0 p1) + (br p m t0 t1) + (br p m t1 t0)))) + +(define (intmap-remove t key) + (let ([et (intmap-eqtype t)]) + (make-intmap + et + ($intmap-remove et (intmap-root t) (hash-code et key) key)))) + +(define ($intmap-remove et t h key) + (cond + [(Br? t) + (let ([p (Br-prefix t)] + [m (Br-mask t)]) + (cond + [(not (match-prefix? h p m)) + t] + [(fx<= h p) + (br/check-left p m ($intmap-remove et (Br-left t) h key) (Br-right t))] + [else + (br/check-right p m (Br-left t) ($intmap-remove et (Br-right t) h key))]))] + + [(Lf? t) + (if (key=? et key (Lf-key t)) + #f + t)] + + [(Co? t) + (cond + [(fx=? h (Co-hash t)) + ;; A collision node always has at least 2 key-value pairs, + ;; so when we remove one, we know the resulting list is non-empty. + (let ([pairs ($collision-remove et t key)]) + (if (null? (cdr pairs)) + (make-Lf h (caar pairs) (cdar pairs)) + (make-Co h pairs)))] + [else + t])] + + [else + #f])) + +;; collision ops +(define ($collision-ref et t key def) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) ($fail def)] + [(key=? et key (caar xs)) (cdar xs)] + [else (loop (cdr xs))]))) + +(define ($collision-set et t key val) + (cons (cons key val) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) '()] + [(key=? et key (caar xs)) (loop (cdr xs))] + [else (cons (car xs) (loop (cdr xs)))])))) + +(define ($collision-remove et t key) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) '()] + [(key=? et key (caar xs)) (loop (cdr xs))] + [else (cons (car xs) (loop (cdr xs)))]))) + +(define ($collision-has-key? et t key) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) #f] + [(key=? et key (caar xs)) #t] + [else (loop (cdr xs))]))) + +;; bit twiddling +(define-syntax-rule (match-prefix? h p m) + (fx= (mask h m) p)) + +(define-syntax-rule (mask h m) + (fxand (fxior h (fx1- m)) (fxnot m))) + +(define-syntax-rule (branching-bit p m) + (highest-set-bit (fxxor p m))) + +(define-syntax-rule (highest-set-bit x1) + (let* ([x2 (fxior x1 (fxsrl x1 1))] + [x3 (fxior x2 (fxsrl x2 2))] + [x4 (fxior x3 (fxsrl x3 4))] + [x5 (fxior x4 (fxsrl x4 8))] + [x6 (fxior x5 (fxsrl x5 16))] + [x7 (fxior x6 (fxsrl x6 32))]) + (fxxor x7 (fxsrl x7 1)))) + +;; basic utils +(define (br p m l r) + (let ([c (fx+ ($intmap-count l) ($intmap-count r))]) + (make-Br c p m l r))) + +(define (br/check-left p m l r) + (if l + (br p m l r) + r)) + +(define (br/check-right p m l r) + (if r + (br p m l r) + l)) + +(define-syntax-rule (key=? et k1 k2) + (cond [(eq? et 'eq) (eq? k1 k2)] + [(eq? et 'eqv) (eqv? k1 k2)] + [else (equal? k1 k2)])) + +(define-syntax-rule (hash-code et k) + (cond [(eq? et 'eq) (eq-hash-code k)] + [(eq? et 'eqv) (eqv-hash-code k)] + [else (key-equal-hash-code k)])) + +(define ($fail default) + (if (procedure? default) + (|#%app| default) + default)) + +;; iteration +(define (intmap-iterate-first t) + (and (fx> (intmap-count t) 0) + 0)) + +(define (intmap-iterate-next t pos) + (let ([pos (fx1+ pos)]) + (and (fx< pos (intmap-count t)) + pos))) + +(define (intmap-iterate-pair t pos fail) + (or ($intmap-nth (intmap-root t) pos) + fail)) + +(define (intmap-iterate-key t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p (car p) fail))) + +(define (intmap-iterate-value t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p (cdr p) fail))) + +(define (intmap-iterate-key+value t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p + (values (car p) (cdr p)) + fail))) + +(define ($intmap-nth t n) + (cond + [(Br? t) + (let* ([left (Br-left t)] + [left-count ($intmap-count left)]) + (if (fx< n left-count) + ($intmap-nth left n) + ($intmap-nth (Br-right t) (fx- n left-count))))] + + [(Lf? t) + (and (fx= 0 n) + (cons (Lf-key t) (Lf-value t)))] + + [(Co? t) + (let ([pairs (Co-pairs t)]) + (and (fx< n (length pairs)) + (list-ref pairs n)))] + + [else + #f])) + +(define (unsafe-intmap-iterate-first t) + ($intmap-enum (intmap-root t) #f)) + +(define (unsafe-intmap-iterate-next t pos) + (let ([next (cdr pos)]) + (and next + ($intmap-enum (car next) (cdr next))))) + +(define (unsafe-intmap-iterate-pair t pos) + (car pos)) + +(define (unsafe-intmap-iterate-key t pos) + (caar pos)) + +(define (unsafe-intmap-iterate-value t pos) + (cdar pos)) + +(define (unsafe-intmap-iterate-key+value t pos) + (values (caar pos) (cdar pos))) + +(define ($intmap-enum t next) + (cond + [(Br? t) + ($intmap-enum (Br-left t) (cons (Br-right t) next))] + + [(Lf? t) + (cons (cons (Lf-key t) (Lf-value t)) next)] + + [(Co? t) + (let ([pairs (Co-pairs t)]) + (let ([fst (car pairs)] + [rst (cdr pairs)]) + (if (null? rst) + (cons fst next) + (cons fst (cons (make-Co #f rst) next)))))] + + [else + next])) + +(define (intmap-fold t nil proc) + (let loop ([pos (unsafe-intmap-iterate-first t)] [nil nil]) + (cond + [pos + (let ([p (unsafe-intmap-iterate-pair t pos)]) + (loop (unsafe-intmap-iterate-next t pos) + (proc (car p) (cdr p) nil)))] + [else + nil]))) + +(define (intmap-for-each t proc) + (intmap-fold t (void) (lambda (k v _) (|#%app| proc k v) (void)))) + +(define (intmap-map t proc) + (intmap-fold t '() (lambda (k v xs) (cons (|#%app| proc k v) xs)))) + +;; equality +(define (intmap=? a b eql?) + (and (eq? (intmap-eqtype a) (intmap-eqtype b)) + ($intmap=? (intmap-eqtype a) (intmap-root a) (intmap-root b) eql?))) + +(define ($intmap=? et a b eql?) + (or + (eq? a b) + + (cond + [(Br? a) + (and (Br? b) + (fx= (Br-count a) (Br-count b)) + (fx= (Br-prefix a) (Br-prefix b)) + (fx= (Br-mask a) (Br-mask b)) + ($intmap=? et (Br-left a) (Br-left b) eql?) + ($intmap=? et (Br-right a) (Br-right b) eql?))] + + [(Lf? a) + (and (Lf? b) + (key=? et (Lf-key a) (Lf-key b)) + (eql? (Lf-value a) (Lf-value b)))] + + [(Co? a) + (and (Co? b) + (let ([xs (Co-pairs a)]) + (and (fx= (length xs) (length (Co-pairs b))) + (let loop ([xs xs]) + (cond [(null? xs) #t] + [($collision-has-key? et b (caar xs)) (loop (cdr xs))] + [else #f])))))] + + [else (and (not a) (not b))]))) + +;; hash code +(define (intmap-hash-code t hash) + ($intmap-hash-code (intmap-root t) hash 0)) + +(define ($intmap-hash-code t hash hc) + (cond + [(Br? t) + (let* ([hc (hash-code-combine hc (hash (Br-prefix t)))] + [hc (hash-code-combine hc (hash (Br-mask t)))] + [hc (hash-code-combine hc ($intmap-hash-code (Br-left t) hash hc))] + [hc (hash-code-combine hc ($intmap-hash-code (Br-right t) hash hc))]) + hc)] + + [(Lf? t) + (let* ([hc (hash-code-combine hc (Lf-hash t))] + [hc (hash-code-combine hc (hash (Lf-value t)))]) + hc)] + + [(Co? t) + (hash-code-combine hc (Co-hash t))] + + [else + (hash-code-combine hc (hash #f))])) + +(define ignored/intmap + (begin + ;; Go through generic `hash` versions to support `a` + ;; and `b` as impersonated hash tables + (record-type-equal-procedure (record-type-descriptor intmap) + (lambda (a b eql?) + (hash=? a b eql?))) + (record-type-hash-procedure (record-type-descriptor intmap) + (lambda (a hash) + (hash-hash-code a hash))))) + +;; subset +(define (intmap-keys-subset? a b) + ($intmap-keys-subset? (intmap-eqtype a) (intmap-root a) (intmap-root b))) + +(define ($intmap-keys-subset? et a b) + (or + (eq? a b) + + (cond + [(Br? a) + (and + (Br? b) + + (let ([p1 (Br-prefix a)] + [m1 (Br-mask a)] + [p2 (Br-prefix b)] + [m2 (Br-mask b)]) + (cond + [(fx> m1 m2) #f] + [(fx> m2 m1) + (and (match-prefix? p1 p2 m2) + (if (fx<= p1 p2) + ($intmap-keys-subset? et a (Br-left b)) + ($intmap-keys-subset? et a (Br-right b))))] + [else + (and (fx= p1 p2) + ($intmap-keys-subset? et (Br-left a) (Br-left b)) + ($intmap-keys-subset? et (Br-right a) (Br-right b)))])))] + + [(Lf? a) + (if (Lf? b) + (key=? et (Lf-key a) (Lf-key b)) + ($intmap-has-key? et b (Lf-hash a) (Lf-key a)))] + + [(Co? a) + (let loop ([xs (Co-pairs a)]) + (cond [(null? xs) #t] + [($intmap-has-key? et b (Co-hash a) (caar xs)) (loop (cdr xs))] + [else #f]))] + + [else + #t]))) diff -Nru racket-6.12+ppa1/src/cs/rumble/keyword.ss racket-7.0+ppa1/src/cs/rumble/keyword.ss --- racket-6.12+ppa1/src/cs/rumble/keyword.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/keyword.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ + +(define-record-type keyword + (fields symbol) + (nongenerative #{keyword dhghafpy3v03qbye1a9lwf-0})) + +(define keywords (make-weak-eq-hashtable)) + +(define/who (string->keyword s) + (check who string? s) + (let ([sym (string->symbol s)]) + (let ([e (eq-hashtable-ref keywords sym #f)]) + (or (and e + (ephemeron-value e)) + (let ([kw (make-keyword sym)]) + (eq-hashtable-set! keywords sym (make-ephemeron sym kw)) + kw))))) + +(define/who (keyword->string kw) + (check who keyword? kw) + (symbol->string (keyword-symbol kw))) + +(define/who keyword (add1 this-counter) (bitwise-arithmetic-shift-left 1 (* log-collect-generation-radix (sub1 (collect-maximum-generation))))) + (set! gc-counter 1) + (set! gc-counter (add1 this-counter))) + (let ([gen (cond + [(and (not g) + (>= pre-allocated (* 2 allocated-after-major))) + ;; Force a major collection if memory use has doubled + (collect-maximum-generation)] + [else + ;; Find the minor generation implied by the counter + (let loop ([c this-counter] [gen 0]) + (cond + [(zero? (bitwise-and c collect-generation-radix-mask)) + (loop (bitwise-arithmetic-shift-right c log-collect-generation-radix) (add1 gen))] + [else gen]))])]) + (collect gen) + (let ([post-allocated (bytes-allocated)]) + (when (= gen (collect-maximum-generation)) + (set! allocated-after-major post-allocated)) + (garbage-collect-notify gen + pre-allocated pre-allocated+overhead pre-time pre-cpu-time + post-allocated (current-memory-bytes) (real-time) (cpu-time))) + (poll-foreign-guardian)))) + +(define collect-garbage + (case-lambda + [() (collect-garbage 'major)] + [(request) + (cond + [(eq? request 'incremental) + (void)] + [else + (let ([req (case request + [(minor) 0] + [(major) (collect-maximum-generation)] + [else + (raise-argument-error 'collect-garbage + "(or/c 'major 'minor 'incremental)" + request)])]) + (let loop () + (let ([current-req (unbox collect-request)]) + (unless (#%box-cas! collect-request current-req (max req (or current-req 0))) + (loop)))) + (collect-rendezvous))])])) + +(define current-memory-use + (case-lambda + [() (bytes-allocated)] + [(mode) + (cond + [(not mode) (bytes-allocated)] + [(eq? mode 'cumulative) (sstats-bytes (statistics))] + [else + ;; must be a custodian... + (bytes-allocated)])])) + +(define prev-stats-objects #f) + +(define (dump-memory-stats . args) + (let-values ([(backtrace-predicate use-prev? max-path-length) (parse-dump-memory-stats-arguments args)]) + (enable-object-counts #t) + (enable-object-backreferences (and backtrace-predicate #t)) + (collect (collect-maximum-generation)) + (let* ([counts (object-counts)] + [backreferences (object-backreferences)] + [extract (lambda (static? cxr) + (lambda (c) (if (or static? (not (eq? (car c) 'static))) + (cxr c) + 0)))] + [get-count (lambda (static?) (lambda (e) (apply + (map (extract static? cadr) (cdr e)))))] + [get-bytes (lambda (static?) (lambda (e) (apply + (map (extract static? cddr) (cdr e)))))] + [pad (lambda (s n) + (string-append (make-string (max 0 (- n (string-length s))) #\space) s))] + [pad-right (lambda (s n) + (string-append s (make-string (max 0 (- n (string-length s))) #\space)))] + [commas (lambda (n) + (let* ([l (string->list (number->string n))] + [len (length l)]) + (list->string + (cons #\space + (let loop ([l l] [len len]) + (cond + [(<= len 3) l] + [else + (let ([m (modulo len 3)]) + (case m + [(0) (list* (car l) + (cadr l) + (caddr l) + #\, + (loop (cdddr l) (- len 3)))] + [(2) (list* (car l) + (cadr l) + #\, + (loop (cddr l) (- len 2)))] + [else (list* (car l) + #\, + (loop (cdr l) (- len 1)))]))]))))))] + [count-width 11] + [size-width 13] + [trim-type (lambda (s) + (let ([len (string-length s)]) + (cond + [(and (> len 14) + (string=? (substring s 2 14) "record type ")) + (string-append "#<" (substring s 14 len))] + [else s])))] + [layout (lambda args + (let loop ([args args] [actual-col 0] [want-col 0]) + (cond + [(null? args) "\n"] + [(< actual-col want-col) + (string-append (make-string (- want-col actual-col) #\space) + (loop args want-col want-col))] + [(integer? (car args)) + (loop (cons (pad (commas (car args)) + (- (+ want-col (sub1 (cadr args))) + actual-col)) + (cdr args)) + actual-col + want-col)] + [else + (string-append (car args) + (loop (cddr args) + (+ actual-col (string-length (car args))) + (+ want-col (cadr args))))])))] + [layout-line (lambda (label c1 s1 c2 s2) + (layout " " 1 + (trim-type label) 22 + c1 count-width + s1 size-width + " | " 3 + c2 count-width + s2 size-width))]) + (enable-object-counts #f) + (enable-object-backreferences #f) + (chez:fprintf (current-error-port) "Begin Dump\n") + (chez:fprintf (current-error-port) "Current memory use: ~a\n" (bytes-allocated)) + (chez:fprintf (current-error-port) "Begin RacketCS\n") + (for-each (lambda (e) + (chez:fprintf (current-error-port) + (layout-line (chez:format "~a" (car e)) + ((get-count #f) e) ((get-bytes #f) e) + ((get-count #t) e) ((get-bytes #t) e)))) + (list-sort (lambda (a b) (< ((get-bytes #f) a) ((get-bytes #f) b))) counts)) + (chez:fprintf (current-error-port) (layout-line "total" + (apply + (map (get-count #f) counts)) + (apply + (map (get-bytes #f) counts)) + (apply + (map (get-count #t) counts)) + (apply + (map (get-bytes #t) counts)))) + (chez:fprintf (current-error-port) "End RacketCS\n") + (when backtrace-predicate + (when (and use-prev? (not prev-stats-objects)) + (set! prev-stats-objects (make-weak-eq-hashtable))) + (let ([backreference-ht (make-eq-hashtable)]) + (for-each (lambda (l) + (for-each (lambda (p) + (hashtable-set! backreference-ht (car p) (cdr p))) + l)) + backreferences) + (chez:fprintf (current-error-port) "Begin Traces\n") + (let ([prev-trace (box '())]) + (for-each (lambda (l) + (for-each (lambda (p) + (when (backtrace-predicate (car p)) + (unless (and use-prev? + (hashtable-ref prev-stats-objects (car p) #f)) + (when use-prev? + (hashtable-set! prev-stats-objects (car p) #t)) + (unless (eqv? 0 max-path-length) + (chez:printf "*== ~a" (object->backreference-string (car p))) + (let loop ([prev (car p)] [o (cdr p)] [accum '()] [len (sub1 (or max-path-length +inf.0))]) + (cond + [(zero? len) (void)] + [(not o) (set-box! prev-trace (reverse accum))] + [(chez:memq o (unbox prev-trace)) + => (lambda (l) + (chez:printf " <- DITTO\n") + (set-box! prev-trace (append (reverse accum) l)))] + [else + (chez:printf " <- ~a" (object->backreference-string + (cond + [(and (pair? o) + (eq? prev (car o))) + (cons 'PREV (cdr o))] + [(and (pair? o) + (eq? prev (cdr o))) + (cons (car o) 'PREV)] + [else o]))) + (loop o (hashtable-ref backreference-ht o #f) (cons o accum) (sub1 len))])))))) + l)) + backreferences)) + (chez:fprintf (current-error-port) "End Traces\n"))) + (chez:fprintf (current-error-port) "End Dump\n")))) + +(define (parse-dump-memory-stats-arguments args) + (values + ;; backtrace predicate: + (cond + [(null? args) #f] + [(eq? (car args) 'struct) #f] + [(and (list? (car args)) + (= 2 (length (car args))) + (eq? (caar args) 'struct) + (symbol? (cadar args))) + (let ([struct-name (cadar args)]) + (lambda (o) + (and (#%$record? o) + (eq? (record-type-name (#%$record-type-descriptor o)) struct-name))))] + [(eq? 'code (car args)) + #%$code?] + [(eq? 'ephemeron (car args)) + ephemeron-pair?] + [(symbol? (car args)) + (let ([type (car args)]) + (lambda (o) + (eq? ((inspect/object o) 'type) type)))] + [else #f]) + ;; 'new mode for backtrace? + (and (pair? args) + (pair? (cdr args)) + (eq? 'new (cadr args))) + ;; max path length + (and (pair? args) + (pair? (cdr args)) + (or (and (exact-nonnegative-integer? (cadr args)) + (cadr args)) + (and (pair? (cddr args)) + (exact-nonnegative-integer? (caddr args)) + (caddr args)))))) + +(define (object->backreference-string o) + (parameterize ([print-level 3]) + (let ([s (call-with-string-output-port + (lambda (dest) + (pretty-print o dest)))]) + (if (> (string-length s) 256) + (let ([s (substring s 0 256)]) + (string-set! s 252 #\.) + (string-set! s 253 #\.) + (string-set! s 254 #\.) + (string-set! s 255 #\newline) + s) + s)))) + +;; ---------------------------------------- + +(define-record-type (phantom-bytes create-phantom-bytes phantom-bytes?) + (fields [mutable size])) + +(define/who (make-phantom-bytes k) + (check who exact-nonnegative-integer? k) + (create-phantom-bytes k)) + +(define/who (set-phantom-bytes! phantom-bstr k) + (check who phantom-bytes? phantom-bstr) + (check who exact-nonnegative-integer? k) + (phantom-bytes-size-set! phantom-bstr k)) diff -Nru racket-6.12+ppa1/src/cs/rumble/mpair.ss racket-7.0+ppa1/src/cs/rumble/mpair.ss --- racket-6.12+ppa1/src/cs/rumble/mpair.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/mpair.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +(define-record mpair (car cdr)) + +(define (mcons a b) + (make-mpair a b)) + +(define/who (mcar m) + (check who mpair? m) + (mpair-car m)) + +(define/who (mcdr m) + (check who mpair? m) + (mpair-cdr m)) + +(define/who (set-mcar! m v) + (check who mpair? m) + (set-mpair-car! m v)) + +(define/who (set-mcdr! m v) + (check who mpair? m) + (set-mpair-cdr! m v)) + +(define (unsafe-mcar m) + (mpair-car m)) + +(define (unsafe-mcdr m) + (mpair-cdr m)) + +(define (unsafe-set-mcar! m v) + (set-mpair-car! m v)) + +(define (unsafe-set-mcdr! m v) + (set-mpair-cdr! m v)) + +(define (set-mpair-hash!) + (record-type-equal-procedure (record-type-descriptor mpair) + (lambda (a b eql?) + (and (eql? (mcar a) (mcar b)) + (eql? (mcdr a) (mcdr b))))) + (record-type-hash-procedure (record-type-descriptor mpair) + (lambda (a hc) + (hash-code-combine (hc (mcar a)) + (hc (mcar a)))))) diff -Nru racket-6.12+ppa1/src/cs/rumble/number.ss racket-7.0+ppa1/src/cs/rumble/number.ss --- racket-6.12+ppa1/src/cs/rumble/number.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/number.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,295 @@ + +(define (nonnegative-fixnum? n) (and (fixnum? n) (fx>= n 0))) + +(define (exact-integer? n) (and (integer? n) (exact? n))) +(define (exact-nonnegative-integer? n) (and (exact-integer? n) (>= n 0))) +(define (exact-positive-integer? n) (and (exact-integer? n) (> n 0))) +(define (inexact-real? n) (and (real? n) (inexact? n))) +(define (byte? n) (and (exact-integer? n) (>= n 0) (<= n 255))) + +(define (double-flonum? x) (flonum? x)) +(define (single-flonum? x) #f) + +(define/who (real->double-flonum x) + (check who real? x) + (exact->inexact x)) + +(define (real->single-flonum x) + (raise-unsupported-error 'real->single-flonum)) + +(define arithmetic-shift bitwise-arithmetic-shift) + +(define/who (integer-sqrt n) + (check who integer? n) + (cond + [(negative? n) (* (integer-sqrt (- n)) 0+1i)] + [(positive? n) + (let-values ([(s r) (exact-integer-sqrt (inexact->exact n))]) + (if (inexact? n) + (exact->inexact s) + s))])) + +(define/who (integer-sqrt/remainder n) + (check who integer? n) + (let ([m (integer-sqrt n)]) + (values m (- n (* m m))))) + +(define fx->fl fixnum->flonum) +(define fxrshift fxarithmetic-shift-right) +(define fxlshift fxarithmetic-shift-left) + +(define fl->fx flonum->fixnum) +(define ->fl real->flonum) +(define/who (fl->exact-integer fl) + (check who flonum? fl) + (inexact->exact (flfloor fl))) + +(define/who (flreal-part a) + (or (and + (complex? a) + (not (real? a)) ; => complex imaginary part + (let ([r (real-part a)]) + (and (flonum? r) r))) + (check who (lambda (a) #f) + :contract (string-append + "(and/c complex?\n" + " (lambda (c) (flonum? (real-part c)))\n" + " (lambda (c) (flonum? (imag-part c))))") + a))) + +(define/who (flimag-part a) + (or (and + (complex? a) + (let ([r (imag-part a)]) + (and (flonum? r) ; => complex real part + r))) + (check who (lambda (a) #f) + :contract (string-append + "(and/c complex?\n" + " (lambda (c) (flonum? (real-part c)))\n" + " (lambda (c) (flonum? (imag-part c))))") + a))) + +(define/who (make-flrectangular a b) + (check who flonum? a) + (check who flonum? b) + (make-rectangular a b)) + +(define (system-big-endian?) + (eq? (native-endianness) (endianness big))) + +(define/who integer->integer-bytes + (case-lambda + [(num size signed? big-endian? bstr start) + (check who bytes? bstr) + (case size + [(2) + (if signed? + (bytevector-s16-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u16-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [(4) + (if signed? + (bytevector-s32-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u32-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [(8) + (if signed? + (bytevector-s64-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u64-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [else + (raise-argument-error 'integer->integer-bytes + "(or/c 2 4 8)" size)]) + bstr] + [(num size signed?) + (integer->integer-bytes num size signed? (system-big-endian?) + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size signed? big-endian?) + (integer->integer-bytes num size signed? big-endian? + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size signed? big-endian? bstr) + (integer->integer-bytes num size signed? big-endian? bstr 0)])) + +(define/who integer-bytes->integer + (case-lambda + [(bstr signed? big-endian? start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (case (- end start) + [(2) + (if signed? + (bytevector-s16-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u16-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [(4) + (if signed? + (bytevector-s32-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u32-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [(8) + (if signed? + (bytevector-s64-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u64-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [else + (raise-arguments-error 'integer-bytes->integer + "length is not 2, 4, or 8 bytes" + "length" (- end start))])] + [(bstr signed?) + (integer-bytes->integer bstr signed? (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr signed? big-endian?) + (integer-bytes->integer bstr signed? big-endian? 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr signed? big-endian? start) + (integer-bytes->integer bstr signed? big-endian? start (and (bytes? bstr) (bytes-length bstr)))])) + +(define/who real->floating-point-bytes + (case-lambda + [(num size big-endian? bstr start) + (check who bytes? bstr) + (case size + [(4) + (bytevector-ieee-single-set! bstr start num (if big-endian? + (endianness big) + (endianness little)))] + [(8) + (bytevector-ieee-double-set! bstr start num (if big-endian? + (endianness big) + (endianness little)))] + [else + (raise-argument-error 'real->floating-point-bytes + "(or/c 4 8)" size)]) + bstr] + [(num size) + (real->floating-point-bytes num size (system-big-endian?) + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size big-endian?) + (real->floating-point-bytes num size big-endian? + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size big-endian? bstr) + (real->floating-point-bytes num size big-endian? bstr 0)])) + +(define/who floating-point-bytes->real + (case-lambda + [(bstr big-endian? start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (case (- end start) + [(4) + (bytevector-ieee-single-ref bstr start (if big-endian? + (endianness big) + (endianness little)))] + [(8) + (bytevector-ieee-double-ref bstr start (if big-endian? + (endianness big) + (endianness little)))] + [else + (raise-arguments-error 'floating-point-bytes->real + "length is not 4 or 8 bytes" + "length" (- end start))])] + [(bstr) + (floating-point-bytes->real bstr (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr big-endian?) + (floating-point-bytes->real bstr big-endian? 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr big-endian? start) + (floating-point-bytes->real bstr big-endian? start (and (bytes? bstr) (bytes-length bstr)))])) + +(define string->number + (case-lambda + [(s) (string->number s 10 #f 'decimal-as-inexact)] + [(s radix) (string->number s radix #f 'decimal-as-inexact)] + [(s radix mode) (string->number s radix mode 'decimal-as-inexact)] + [(s radix mode decimal) + (if (and (eq? mode 'read) ; => need to watch out for extflonums + (extflonum-string? s)) + (make-extflonum s) + ;; The argument is constrained to fixnum, bignum, and flonum forms + (chez:string->number s radix))])) + +(define/who number->string + (case-lambda + [(n) (number->string n 10)] + [(n radix) + (check who number? n) + (cond + [(eq? radix 16) + ;; Host generates uppercase letters, Racket generates lowercase + (string-downcase (chez:number->string n 16))] + [else + (check who (lambda (radix) (or (eq? radix 2) (eq? radix 8) (eq? radix 10) (eq? radix 16))) + :contract "(or/c 2 8 10 16)" + radix) + (chez:number->string n radix)])])) + +(define/who (quotient/remainder n m) + (check who integer? n) + (check who integer? m) + (values (quotient n m) (remainder n m))) + +(define/who gcd + (case-lambda + [(n) + (check who rational? n) + n] + [(n m) + (check who rational? n) + (check who rational? m) + (cond + [(and (integer? n) + (integer? m)) + (chez:gcd n m)] + [else + (let ([n-n (numerator n)] + [n-d (denominator n)] + [m-n (numerator m)] + [m-d (denominator m)]) + (/ (chez:gcd n-n m-n) + (chez:lcm n-d m-d)))])] + [(n . ms) + (check who rational? n) + (let loop ([n n] [ms ms]) + (cond + [(null? ms) n] + [else (loop (gcd n (car ms)) (cdr ms))]))])) + +(define/who lcm + (case-lambda + [(n) + (check who rational? n) + n] + [(n m) + (check who rational? n) + (check who rational? m) + (cond + [(and (integer? n) + (integer? m)) + (chez:lcm n m)] + [else + (let ([d (gcd n m)]) + (* n (/ m d)))])] + [(n . ms) + (check who rational? n) + (let loop ([n n] [ms ms]) + (cond + [(null? ms) n] + [else (loop (lcm n (car ms)) (cdr ms))]))])) diff -Nru racket-6.12+ppa1/src/cs/rumble/object-name.ss racket-7.0+ppa1/src/cs/rumble/object-name.ss --- racket-6.12+ppa1/src/cs/rumble/object-name.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/object-name.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,62 @@ + +(define-values (prop:object-name object-name? object-name-ref) + (make-struct-type-property 'object-name + (lambda (v info) + (cond + [(exact-nonnegative-integer? v) + (unless (< v (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:object-name + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (chez:memv v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:object-name "field index not declared immutable" + "field index" v)) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0)))] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [else + (raise-argument-error 'guard-for-prop:object-name + "(or/c exact-nonnegative-integer? (procedure-arity-includes/c 1))" + v)])))) + +(define (object-name v) + (cond + [(object-name? v) + (let ([n (object-name-ref v)]) + (cond + [(exact-integer? n) + (unsafe-struct-ref v n)] + [else + (n v)]))] + [(#%procedure? v) + (cond + [(arity-wrapper-procedure? v) + (extract-jit-procedure-name v)] + [else + (let ([name (((inspect/object v) 'code) 'name)]) + (and name + (string->symbol name)))])] + [(impersonator? v) + (object-name (impersonator-val v))] + [(procedure? v) + (extract-procedure-name v)] + [(struct-type? v) + (record-type-name v)] + [(struct-type-property? v) + (struct-type-prop-name v)] + [(record? v) + (struct-object-name v)] + [else #f])) + +(define (struct-object-name v) + (let ([rtd (record-rtd v)]) + (and + ;; Having an entry in `rtd-props` is a sign that + ;; this structure type was created with `make-struct-type`: + (hashtable-contains? rtd-props rtd) + (object-name (record-rtd v))))) diff -Nru racket-6.12+ppa1/src/cs/rumble/parameter.ss racket-7.0+ppa1/src/cs/rumble/parameter.ss --- racket-6.12+ppa1/src/cs/rumble/parameter.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/parameter.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,121 @@ + +;; Continuation-mark key: +(define parameterization-key (gensym "parameterization-key")) + +(define-record parameterization (ht)) + +(define empty-parameterization (make-parameterization empty-hasheq)) + +(define/who (extend-parameterization p . args) + (check who parameterization? p) + (let loop ([ht (parameterization-ht p)] [args args]) + (cond + [(null? args) (make-parameterization ht)] + [(and (parameter? (car args)) + (pair? (cdr args))) + (let dloop ([p (car args)] [v (cadr args)]) + (cond + [(impersonator? p) + (dloop (impersonator-val p) (impersonate-apply/parameter p #f (list v)))] + [(derived-parameter? p) + (dloop (derived-parameter-next p) (|#%app| (parameter-guard p) v))] + [else + (let* ([guard (parameter-guard p)] + [v (if guard + (|#%app| guard v) + v)]) + (loop (intmap-set ht p (make-thread-cell v #t)) + (cddr args)))]))] + [(parameter? (car args)) + (raise-arguments-error 'extend-parameterization + "missing value for parameter" + "parameter" (car args))] + [else + (raise-argument-error 'extend-parameterization "parameter?" (car args))]))) + +(define (call-with-parameterization parameter value thunk) + (call/cm + parameterization-key + (extend-parameterization (current-parameterization) parameter value) + thunk)) + +(define (current-parameterization) + (continuation-mark-set-first + #f + parameterization-key + empty-parameterization + the-root-continuation-prompt-tag)) + +(define (parameter-cell key) + (intmap-ref (parameterization-ht + (current-parameterization)) + key + #f)) + +(define-record-type (parameter create-parameter authentic-parameter?) + (fields proc guard)) + +(define-record-type (derived-parameter create-derived-parameter derived-parameter?) + (parent parameter) + (fields next)) + +(define (parameter? v) + (authentic-parameter? (strip-impersonator v))) + +(define/who make-parameter + (case-lambda + [(v) (make-parameter v #f)] + [(v guard) + (check who (procedure-arity-includes/c 1) :or-false guard) + (let ([default-c (make-thread-cell v #t)]) + (letrec ([self + (create-parameter + (case-lambda + [() + (let ([c (or (parameter-cell self) + default-c)]) + (thread-cell-ref c))] + [(v) + (let ([c (or (parameter-cell self) + default-c)]) + (thread-cell-set! c (if guard + (guard v) + v)))]) + guard)]) + self))])) + +(define/who (make-derived-parameter p guard wrap) + (check who authentic-parameter? + :contract "(and/c parameter? (not/c impersonator?))" + p) + (check who (procedure-arity-includes/c 1) guard) + (check who (procedure-arity-includes/c 1) wrap) + (create-derived-parameter (let ([self (parameter-proc p)]) + (case-lambda + [(v) (self (guard v))] + [() (wrap (self))])) + guard + p)) + +(define/who (parameter-procedure=? a b) + (check who parameter? a) + (check who parameter? b) + (eq? (strip-impersonator a) (strip-impersonator b))) + +(define/who (reparameterize p) + (check who parameterization? p) + p) + +;; ---------------------------------------- + +(define/who current-inspector + (make-parameter root-inspector + (lambda (v) + (check who inspector? v) + v))) + +(define/who current-code-inspector + (make-parameter root-inspector + (lambda (v) + (check who inspector? v) + v))) diff -Nru racket-6.12+ppa1/src/cs/rumble/place.ss racket-7.0+ppa1/src/cs/rumble/place.ss --- racket-6.12+ppa1/src/cs/rumble/place.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/place.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ + +(define (place-enabled?) + #f) + +(define (place? v) + #f) + +(define (place-channel? v) + #f) + +(define place-specific-table (make-hasheq)) + +(define (unsafe-get-place-table) + place-specific-table) + +(define-syntax define-place-not-yet-available + (syntax-rules () + [(_ id) + (define (id . args) + (error 'id "place API not yet supported"))] + [(_ id ...) + (begin (define-place-not-yet-available id) ...)])) + +(define-place-not-yet-available + place-break + place-channel-get + place-channel-put + place-sleep + place-channel + place-dead-evt + place-kill + place-message-allowed? + dynamic-place + place-wait + place-pumper-threads + place-shared?) diff -Nru racket-6.12+ppa1/src/cs/rumble/prefab.ss racket-7.0+ppa1/src/cs/rumble/prefab.ss --- racket-6.12+ppa1/src/cs/rumble/prefab.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/prefab.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,331 @@ +;; maps (cons prefab-key total-field-count) to rtd: +(define prefabs #f) + +(define (prefab-struct-key v) + (let ([v (strip-impersonator v)]) + (and (record? v) + (let ([p (getprop (record-type-uid (record-rtd v)) 'prefab-key+count #f)]) + (and p (car p)))))) + +(define/who (prefab-key->struct-type key field-count) + (prefab-key+count->rtd + (cons (normalized-prefab-key/check who key field-count) + field-count))) + +(define/who (make-prefab-struct key . args) + (let* ([field-count (length args)] + [norm-key (normalized-prefab-key/check who key field-count)]) + (let ([rtd (prefab-key->struct-type key field-count)]) + (apply (record-constructor rtd) args)))) + +;; ---------------------------------------- + +;; Check that `k` is valid as a prefab key +(define (prefab-key? k) + (or (symbol? k) + (and (pair? k) + (symbol? (car k)) + (let* ([k (cdr k)] ; skip name + [prev-k k] + ;; The initial field count can be omitted: + [k (if (and (pair? k) + (exact-nonnegative-integer? (car k))) + (cdr k) + k)] + [field-count (if (eq? prev-k k) + #f + (car prev-k))]) + (let loop ([field-count field-count] [k k]) ; `k` is after name and field count + (or (null? k) + (and (pair? k) + (let* ([prev-k k] + [k (if (and (pair? (car k)) + (pair? (cdar k)) + (null? (cddar k)) + (exact-nonnegative-integer? (caar k))) + ;; Has a (list ) element + (cdr k) + ;; Doesn't have auto-value element: + k)] + [auto-count (if (eq? prev-k k) + 0 + (caar prev-k))]) + (or (null? k) + (and (pair? k) + (let* ([k (if (and (pair? k) + (vector? (car k))) + ;; Make sure it's a vector of indices + ;; that are in range and distinct: + (let* ([vec (car k)] + [len (vector-length vec)]) + (let loop ([i 0] [set 0]) + (cond + [(= i len) (cdr k)] + [else + (let ([pos (vector-ref vec i)]) + (and (exact-nonnegative-integer? pos) + (or (not field-count) + (< pos (+ field-count auto-count))) + (not (bitwise-bit-set? set pos)) + (loop (add1 i) (bitwise-ior set (bitwise-arithmetic-shift-left 1 pos)))))]))) + k)]) + (or (null? k) + (and (pair? k) + ;; Supertype: make sure it's a pair with a + ;; symbol and a field count, and loop: + (symbol? (car k)) + (pair? (cdr k)) + (exact-nonnegative-integer? (cadr k)) + (loop (cadr k) (cddr k))))))))))))))) + +;; Assuming `(prefab-key? k)`, check that it's consistent with the +;; given total field count +(define (prefab-key-compatible-count? k total-field-count) + (letrec ([field-count-after-name+count + (lambda (k) + (cond + [(null? k) 0] + [(pair? (car k)) + (+ (caar k) + (field-count-after-name+count+auto (cdr k)))] + [else + (field-count-after-name+count+auto k)]))] + [field-count-after-name+count+auto + (lambda (k) + (cond + [(null? k) 0] + [(vector? (car k)) + (if (null? (cdr k)) + 0 + (field-count (cdr k)))] + [else (field-count k)]))] + [field-count + (lambda (k) ; k has symbol and count + (+ (cadr k) + (field-count-after-name+count (cddr k))))]) + (cond + [(symbol? k) #t] + [(null? (cdr k)) #t] + [(exact-integer? (cadr k)) + ;; Info must match exactly + (= total-field-count + (+ (cadr k) (field-count-after-name+count (cddr k))))] + [else + (let ([n (field-count-after-name+count (cdr k))]) + (and + ;; Field count must be <= total-field-count + (>= total-field-count n) + ;; Initial mutables vector (if any) must be in range + ;; for the target field count; any later immutables vector + ;; has been checked already by `prefab-key?` + (let* ([k (cdr k)] + [auto (and (pair? (car k)) + (car k))] + [k (if auto + (cdr k) + k)]) + (or (null? k) + (not (vector? (car k))) + (let* ([n (- total-field-count + (if auto + (car auto) + 0))] + [vec (car k)] + [len (vector-length vec)]) + (let loop ([i 0]) + (or (= i len) + (let ([m (vector-ref vec i)]) + (and (exact-nonnegative-integer? m) ; in case the vector is mutated + (< m n) + (loop (fx1+ i)))))))))))]))) + +;; Convert a prefab key to normalized, compact from +(define (normalize-prefab-key k keep-count?) + (cond + [(symbol? k) k] + [else + (let* ([name (car k)] + [k (cdr k)] + [count (if (and (pair? k) + (exact-nonnegative-integer? (car k))) + (car k) + #f)] + [k (if count + (cdr k) + k)] + [auto (if (and (pair? k) + (pair? (car k))) + (car k) + #f)] + [k (if auto + (cdr k) + k)] + [mutables (if (and (pair? k) + (vector? (car k))) + (car k) + #f)] + [k (if mutables + (cdr k) + k)] + [norm-auto (cond + [(not auto) #f] + [(eq? 0 (car auto)) #f] + [else auto])] + [norm-mutables (cond + [(not mutables) #f] + [(zero? (vector-length mutables)) #f] + [else + (vector->immutable-vector + (chez:vector-sort (lambda (a b) + ;; Double-check exact integers, just in case + ;; a mutation happens; we'll have tou double-check + ;; that the result is still a prefab + (if (and (exact-nonnegative-integer? a) + (exact-nonnegative-integer? b)) + (< a b) + #f)) + mutables))])] + [r (if (null? k) + '() + (normalize-prefab-key k #t))] + [r (if norm-mutables + (cons norm-mutables + r) + r)] + [r (if norm-auto + (cons norm-auto r) + r)]) + (if keep-count? + (cons name (cons count r)) + (if (null? r) + name + (cons name r))))])) + +(define (normalized-prefab-key/check who key field-count) + (check who prefab-key? key) + (unless (prefab-key-compatible-count? key field-count) + (raise-arguments-error who + "mismatch between prefab key and field count" + "prefab key" key + "field count" field-count)) + (let ([norm-key (normalize-prefab-key key #f)]) + (unless (and (prefab-key? norm-key) + (prefab-key-compatible-count? norm-key field-count)) + (raise-arguments-error who + "prefab key mutated after initial check" + "prefab key" key)) + norm-key)) + +(define (prefab-key+size->prefab-key-tail key+size) + (let ([key (car key+size)]) + (cond + [(symbol? key) + (list key (cdr key+size))] + [else + (cons* (car key) + (- (cdr key+size) + (prefab-key-count-explicit-fields key)) + (cdr key))]))) + +(define (prefab-key-count-explicit-fields key) + ;; Count fields other than initial non-auto: + (let loop ([k (cdr key)]) + (let* ([count (and (pair? k) + (exact-integer? (car k)) + (car k))] + [k (if count + (cdr k) + k)] + [mutable (and (pair? k) + (pair? (car k)) + (car k))] + [k (if mutable + (cdr k) + k)] + [k (if (and (pair? k) + (vector? (car k))) + (cdr k) + k)]) + (+ (or count 0) + (if mutable (car mutable) 0) + (cond + [(null? k) 0] + [else (loop (cdr k))]))))) + +(define (prefab-key->parent-prefab-key+count key) + (cond + [(symbol? key) #f] + [else + (let* ([k (cdr key)] ; skip name; non-auto count will no be present + [k (if (and (pair? k) + (pair? (car k))) + (cdr k) + k)] + [k (if (and (pair? k) + (vector? (car k))) + (cdr k) + k)]) + (if (null? k) + #f + ;; Normalize parent by dropping auto field count out: + (let* ([name (car k)] + [count (cadr k)] + [rest-k (cddr k)] + [total-count (prefab-key-count-explicit-fields k)]) + (cond + [(null? rest-k) + (cons name total-count)] + [else + (cons (cons name rest-k) total-count)]))))])) + +(define (derive-prefab-key name parent-key+size fields-count immutables auto-fields auto-val) + (let* ([l (if parent-key+size + (prefab-key+size->prefab-key-tail parent-key+size) + '())] + [l (let ([mutables (immutables->mutables immutables fields-count)]) + (if (fx= 0 (#%vector-length mutables)) + l + (cons mutables l)))] + [l (if (zero? auto-fields) + l + (cons (list auto-fields auto-val) + l))]) + (if (null? l) + name + (cons name l)))) + +(define (prefab-key-mutables prefab-key) + (if (pair? prefab-key) + (if (vector? (cadr prefab-key)) + (cadr prefab-key) + (if (and (pair? (cddr prefab-key)) + (vector? (caddr prefab-key))) + (caddr prefab-key) + '#())) + '#())) + +(define (encode-prefab-key+count-as-symbol prefab-key+count) + (string->symbol (chez:format "~a" prefab-key+count))) + +(define (immutables->mutables immutables init-count) + (vector->immutable-vector + (list->vector + (let loop ([i 0]) + (cond + [(= i init-count) null] + [(chez:member i immutables) (loop (add1 i))] + [else (cons i (loop (add1 i)))]))))) + +(define (mutables->immutables mutables init-count) + (let loop ([i 0]) + (cond + [(fx= i init-count) '()] + [else + (let jloop ([j (vector-length mutables)]) + (cond + [(fx= j 0) (cons i (loop (fx1+ i)))] + [else + (let ([j (fx1- j)]) + (if (eqv? i (vector-ref mutables j)) + (loop (fx1+ i)) + (jloop j)))]))]))) diff -Nru racket-6.12+ppa1/src/cs/rumble/procedure.ss racket-7.0+ppa1/src/cs/rumble/procedure.ss --- racket-6.12+ppa1/src/cs/rumble/procedure.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/procedure.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,755 @@ +(define-values (prop:method-arity-error method-arity-error? method-arity-error-ref) + (make-struct-type-property 'method-arity-error)) + +(define-values (prop:arity-string arity-string? arity-string-ref) + (make-struct-type-property 'arity-string)) + +(define-values (prop:procedure procedure-struct? procedure-struct-ref) + (make-struct-type-property 'procedure (lambda (v info) + ;; We don't have to check whether `v` is valid here, + ;; because `make-struct-type` handles `prop:procedure` + ;; directly; we just convert a relative position to + ;; an absolute one + (if (exact-integer? v) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0))) + v)))) + +(define-values (prop:incomplete-arity incomplete-arity? incomplete-arity-ref) + (make-struct-type-property 'incomplete-arity)) + +;; Integer value is a field to use; boxed value is a field that provides a mask +(define-values (prop:procedure-arity procedure-arity-prop? procedure-arity-ref) + (make-struct-type-property 'procedure-arity)) + +(define (procedure? v) + (or (chez:procedure? v) + (and (record? v) + (not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none))))) + +(define/who (procedure-specialize proc) + (check who procedure? proc) + proc) + +(define apply + (case-lambda + [(proc args) + (if (chez:procedure? proc) + (chez:apply proc args) + (chez:apply (extract-procedure proc (length args)) args))] + [(proc) + (raise-arity-error 'apply (|#%app| arity-at-least 2) proc)] + [(proc . argss) + (if (chez:procedure? proc) + (chez:apply chez:apply proc argss) + (let ([len (let loop ([argss argss]) + (cond + [(null? (cdr argss)) (length (car argss))] + [else (fx+ 1 (loop (cdr argss)))]))]) + (chez:apply chez:apply (extract-procedure proc len) argss)))])) + +;; See copy in "expander.sls" +(define-syntax (|#%app| stx) + (syntax-case stx () + [(_ rator rand ...) + (with-syntax ([n-args (length #'(rand ...))]) + #'((extract-procedure rator n-args) rand ...))])) + +(define (|#%call-with-values| generator receiver) + (call-with-values (if (chez:procedure? generator) + generator + (lambda () (|#%app| generator))) + (if (chez:procedure? receiver) + receiver + (lambda args (apply receiver args))))) + +(define (extract-procedure f n-args) + (cond + [(chez:procedure? f) f] + [else (or (try-extract-procedure/check-arity f n-args) + (not-a-procedure f))])) + +;; returns #f or a host-Scheme procedure, and checks arity so that +;; checking and reporting use the right top-level function +(define (try-extract-procedure/check-arity f n-args) + (let ([v (try-extract-procedure f)]) + (cond + [(not v) #f] + [(procedure-arity-includes? f n-args) v] + [else (wrong-arity-wrapper f)]))) + +(define (try-extract-procedure f) + (cond + [(chez:procedure? f) f] + [(record? f) + (let ([v (struct-property-ref prop:procedure (record-rtd f) none)]) + (cond + [(eq? v none) #f] + [(fixnum? v) + (try-extract-procedure (unsafe-struct-ref f v))] + [(eq? v 'unsafe) + (try-extract-procedure + (if (chaperone? f) + (unsafe-procedure-chaperone-replace-proc f) + (unsafe-procedure-impersonator-replace-proc f)))] + [else + (let ([v (try-extract-procedure v)]) + (cond + [(not v) (case-lambda)] + [else + (case-lambda + [() (v f)] + [(a) (v f a)] + [(a b) (v f a b)] + [(a b c) (v f a b c)] + [args (chez:apply v f args)])]))]))] + [else #f])) + +(define (extract-procedure-name f) + (cond + [(and (reduced-arity-procedure? f) + (reduced-arity-procedure-name f)) + => (lambda (name) name)] + [(record? f) + (let* ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) + (cond + [(fixnum? v) + (let ([v (unsafe-struct-ref f v)]) + (cond + [(procedure? v) (object-name v)] + [else (struct-object-name f)]))] + [else (struct-object-name f)]))] + [else #f])) + +(define/who procedure-arity-includes? + (case-lambda + [(f n incomplete-ok?) + (let ([mask (get-procedure-arity-mask who f incomplete-ok?)]) + (check who exact-nonnegative-integer? n) + (bitwise-bit-set? mask n))] + [(f n) (procedure-arity-includes? f n #f)])) + +(define (chez:procedure-arity-includes? proc n) + (bitwise-bit-set? (#%procedure-arity-mask proc) n)) + +(define (procedure-arity orig-f) + (mask->arity (get-procedure-arity-mask 'procedure-arity orig-f #t))) + +(define/who (procedure-arity-mask orig-f) + (get-procedure-arity-mask who orig-f #t)) + +(define (get-procedure-arity-mask who orig-f incomplete-ok?) + (cond + [(chez:procedure? orig-f) + (#%procedure-arity-mask orig-f)] + [else + (let proc-arity-mask ([f orig-f] [shift 0]) + (cond + [(chez:procedure? f) + (bitwise-arithmetic-shift-right (#%procedure-arity-mask f) shift)] + [(record? f) + (cond + [(and (not incomplete-ok?) + (incomplete-arity? f)) + 0] + [else + (let* ([rtd (record-rtd f)] + [a (struct-property-ref prop:procedure-arity rtd #f)]) + (cond + [a + (if (exact-integer? a) + (proc-arity-mask (unsafe-struct*-ref f a) shift) + (bitwise-arithmetic-shift-right (unsafe-struct*-ref f (unbox a)) shift))] + [else + (let ([v (struct-property-ref prop:procedure rtd #f)]) + (cond + [(fixnum? v) + (proc-arity-mask (unsafe-struct-ref f v) shift)] + [else + (proc-arity-mask v (add1 shift))]))]))])] + [(eq? f orig-f) + (raise-argument-error who "procedure?" orig-f)] + [else 0]))])) + +;; Public, limited variant: +(define/who (procedure-extract-target f) + (cond + [(record? f) + (let* ([rtd (record-rtd f)] + [v (struct-property-ref prop:procedure rtd #f)]) + (cond + [(fixnum? v) + (let ([v (unsafe-struct-ref f v)]) + (and (chez:procedure? v) v))] + [else + (check who procedure? f) + #f]))] + [else + (check who procedure? f) + #f])) + +(define (not-a-procedure f) + (raise-arguments-error 'application + "not a procedure;\n expected a procedure that can be applied to arguments" + "given" f)) + +(define (wrong-arity-wrapper f) + (lambda args + (cond + [(procedure-is-method? f) + (chez:apply raise-arity-error + f + (let ([m (procedure-arity-mask f)]) + (if (not (bitwise-bit-set? m 0)) + (mask->arity (bitwise-arithmetic-shift-right m 1)) + (mask->arity m))) + (cdr args))] + [else + (chez:apply raise-arity-error f (procedure-arity f) args)]))) + +(define/who (procedure-result-arity p) + (check who procedure? p) + #f) + +;; ---------------------------------------- + +(define-record method-procedure (proc)) + +(define/who (procedure->method proc) + (check who procedure? proc) + (if (procedure-is-method? proc) + proc + (make-method-procedure proc))) + +(define (procedure-is-method? f) + (cond + [(chez:procedure? f) #f] + [(record? f) + (or (method-arity-error? f) + (let ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) + (cond + [(fixnum? v) + (procedure-is-method? (unsafe-struct-ref f v))] + [(eq? v 'unsafe) + (procedure-is-method? (impersonator-val f))] + [else (procedure-is-method? v)])))] + [else #f])) + +;; ---------------------------------------- + +(define-record reduced-arity-procedure (proc mask name)) + +(define/who (procedure-reduce-arity proc a) + (check who procedure? proc) + (let ([mask (arity->mask a)]) + (unless mask + (raise-arguments-error who "procedure-arity?" a)) + (unless (= mask (bitwise-and mask (procedure-arity-mask proc))) + (raise-arguments-error who + "arity of procedure does not include requested arity" + "procedure" proc + "requested arity" a)) + (make-reduced-arity-procedure + (lambda args + (unless (bitwise-bit-set? mask (length args)) + (apply raise-arity-error + (or (object-name proc) 'procedure) + (mask->arity mask) + args)) + (apply proc args)) + mask + (object-name proc)))) + +;; ---------------------------------------- + +(define-record named-procedure (proc name)) + +(define/who (procedure-rename proc name) + (cond + [(reduced-arity-procedure? proc) + ;; Avoid an extra wrapper layer, and also work before + ;; `procedure?` is fully filled in + (check who symbol? name) + (make-reduced-arity-procedure + (reduced-arity-procedure-proc proc) + (reduced-arity-procedure-mask proc) + name)] + [else + (check who procedure? proc) + (check who symbol? name) + (make-named-procedure proc name)])) + +(define (procedure-maybe-rename proc name) + (if name + (procedure-rename proc name) + proc)) + +;; ---------------------------------------- + +(define (make-jit-procedure force mask name) + (letrec ([p (make-arity-wrapper-procedure + (lambda args + (let ([f (force)]) + (with-interrupts-disabled + ;; atomic with respect to Racket threads, + (let ([name (arity-wrapper-procedure-data p)]) + (unless (#%box? name) + (set-arity-wrapper-procedure! p f) + (set-arity-wrapper-procedure-data! p (box name))))) + (apply p args))) + mask + name)]) + p)) + +(define (extract-jit-procedure-name p) + (let ([name (arity-wrapper-procedure-data p)]) + (if (#%box? name) + (#%unbox name) + name))) + +;; ---------------------------------------- + +(define-record procedure-impersonator impersonator (wrapper)) +(define-record procedure-chaperone chaperone (wrapper)) + +(define-record procedure*-impersonator procedure-impersonator ()) +(define-record procedure*-chaperone procedure-chaperone ()) + +(define-values (impersonator-prop:application-mark application-mark? application-mark-ref) + (make-impersonator-property 'application-mark)) + +(define/who (impersonate-procedure proc wrapper . props) + (do-impersonate-procedure who make-procedure-impersonator proc wrapper + make-props-procedure-impersonator props + values "")) + +(define/who (chaperone-procedure proc wrapper . props) + (do-impersonate-procedure who make-procedure-chaperone proc wrapper + make-props-procedure-chaperone props + values "")) + +(define/who (impersonate-procedure* proc wrapper . props) + (do-impersonate-procedure who make-procedure*-impersonator proc wrapper + make-props-procedure-impersonator props + (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) + +(define/who (chaperone-procedure* proc wrapper . props) + (do-impersonate-procedure who make-procedure*-chaperone proc wrapper + make-props-procedure-chaperone props + (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) + +(define (do-impersonate-procedure who make-procedure-impersonator proc wrapper + make-props-procedure-impersonator props + arity-shift arity-shift-str) + (check who procedure? proc) + (when wrapper + (check who procedure? wrapper) + (let ([m (procedure-arity-mask proc)]) + (unless (= m (bitwise-and m (arity-shift (procedure-arity-mask wrapper)))) + (raise-arguments-error who + (string-append + "arity of wrapper procedure does not cover arity of original procedure" + arity-shift-str) + "wrapper" wrapper + "original" proc)))) + (let ([val (if (impersonator? proc) + (impersonator-val proc) + proc)] + [props (add-impersonator-properties who + props + (if (impersonator? proc) + (impersonator-props proc) + empty-hasheq))]) + (if wrapper + (make-procedure-impersonator val proc props wrapper) + (make-props-procedure-impersonator val proc props)))) + +(define (procedure-impersonator*? v) + (or (procedure*-impersonator? v) + (procedure*-chaperone? v) + (and (impersonator? v) + (procedure-impersonator*? (impersonator-next v))))) + +(define (call-with-application-mark props k) + (let ([mark (intmap-ref props impersonator-prop:application-mark #f)]) + (cond + [(pair? mark) + (call-with-immediate-continuation-mark + (car mark) + (lambda (v) + (if (eq? v none) + (k mark #f #f) + (k mark #t v))) + none)] + [else + (k #f #f #f)]))) + +(define (impersonate-apply proc . args) + (impersonate-apply/parameter proc #t args)) + +;; If `actually-call?` is #f, then don't call the procedure in `proc`, +;; because we're trying to get an inpersonated-parameter value +(define (impersonate-apply/parameter proc actually-call? args) + (let ([n (length args)]) + (cond + [(not (procedure-arity-includes? (impersonator-val proc) n)) + ;; Let primitive application complain: + (|#%app| (impersonator-val proc) args)] + [else + ;; Loop through wrappers so that `{chaperone,impersonate}-procedure*` + ;; wrappers can receive the original `proc` argument + (let loop ([p proc] [args args]) + (cond + [(or (procedure-impersonator? p) + (procedure-chaperone? p)) + ;; Check for `impersonator-prop:application-mark`, since we'll need + ;; to grab any immediately available mark in that case + (call-with-application-mark + (impersonator-props p) + ;; The `mark-pair` argument is the `impersonator-prop:application-mark` value, + ;; and `has-current-mark?` indincates whether `current-mark-val` is the value + ;; of that mark on the current continuation frame + (lambda (mark-pair has-current-mark? current-mark-val) + (let* ([chaperone? (procedure-chaperone? p)] + [wrapper (if chaperone? + (procedure-chaperone-wrapper p) + (procedure-impersonator-wrapper p))] + [next-p (impersonator-next p)] + [new-args + ;; Call the wrapper procedure, propagating the current value + ;; (if any) of the `impersonator-prop:application-mark`-specified mark + (call-with-values + (lambda () + (let ([call + (lambda () + ;; Calling convention is different for `procedure*` + ;; and non-`procedure*` variants: + (if (if chaperone? + (procedure*-chaperone? p) + (procedure*-impersonator? p)) + (apply wrapper proc args) + (apply wrapper args)))]) + ;; Set mark, if any, while calling: + (cond + [has-current-mark? + (with-continuation-mark (car mark-pair) current-mark-val (call))] + [else (call)]))) + list)] + [nn (length new-args)] + [check + (lambda (who args new-args) + (when chaperone? + (for-each (lambda (e e2) + (unless (chaperone-of? e2 e) + (raise-chaperone-error who "argument" e e2))) + args + new-args)))] + [continue + ;; To continue iterating through wrappers: + (lambda (new-args) + (if mark-pair + (with-continuation-mark (car mark-pair) (cdr mark-pair) + (loop next-p new-args)) + (loop next-p new-args)))]) + ;; Loop to check for extra post proc or `'mark ` + (let loop ([nn nn] [new-args new-args] [post-proc #f] [pos 0]) + (cond + [(fx= n nn) + ;; No more extra results, so `new-args` should match up with `args`: + (check '|procedure chaperone| args new-args) + (cond + [post-proc + (call-with-values + (lambda () (continue new-args)) + (lambda results + (let ([new-results (call-with-values (lambda () (apply post-proc results)) list)]) + (unless (= (length results) (length new-results)) + (raise-result-wrapper-result-arity-error)) + (check '|procedure-result chaperone| results new-results) + (#%apply values new-results))))] + [else + (continue new-args)])] + [(and (fx> nn n) + (not post-proc) + (procedure? (car new-args))) + ;; Extra procedure result => wrapper to apply to function results + (loop (fx1- nn) (cdr new-args) (car new-args) (fx1+ pos))] + [(and (fx> nn n) + (eq? 'mark (car new-args))) + ;; 'mark => wrap call with a continuation mark + (unless (fx>= (fx- nn 3) n) + (raise-mark-missing-key-or-val-error chaperone? pos next-p wrapper)) + (with-continuation-mark (cadr new-args) (caddr new-args) + (loop (fx- nn 3) (cdddr new-args) post-proc (fx+ pos 3)))] + [(fx> nn n) + (raise-wrapper-bad-extra-result-error chaperone? pos (car new-args) next-p wrapper)] + [else + (raise-wrapper-result-arity-error chaperone? proc wrapper n nn)])))))] + [(unsafe-procedure-impersonator? p) + (apply p args)] + [(unsafe-procedure-chaperone? p) + (apply p args)] + [(impersonator? p) + (loop (impersonator-next p) args)] + [(not actually-call?) + (apply values args)] + [else + ;; If `p` is a structure whose `prop:procedure` value is an + ;; integer `i`, then we should extract the field at position + ;; `i` from `proc`, not from `p`, so that any interpositions + ;; on that access are performed. + (let ([v (and (record? p) + (struct-property-ref prop:procedure (record-rtd p) #f))]) + (cond + [(integer? v) + (apply (unsafe-struct-ref proc v) args)] + [else + (apply p args)]))]))]))) + +(define (set-procedure-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor procedure-chaperone) + (lambda (c hash-code) + (hash-code (impersonator-next c)))) + (record-type-hash-procedure (record-type-descriptor procedure-impersonator) + (lambda (i hash-code) + (hash-code (impersonator-next i))))) + +(define (raise-result-wrapper-result-arity-error) + (raise + (|#%app| + exn:fail:contract:arity + (string-append "procedure-result chaperone: result arity mismatch;\n" + " expected number of values not received from wrapper on the original procedure's result") + (current-continuation-marks)))) + +(define (raise-mark-missing-key-or-val-error chaperone? pos next-p wrapper) + (raise-arguments-error (if chaperone? + '|procedure chaperone| + '|procedure impersonator|) + (string-append + "wrapper's " (nth-str pos) " result needs addition extra results;\n" + " " (nth-str pos) " extra result (before original argument count) needs an additional\n" + " two results after 'mark") + "original" next-p + "wrapper" wrapper)) + +(define (raise-wrapper-bad-extra-result-error chaperone? pos v next-p wrapper) + (raise-arguments-error (if chaperone? + '|procedure chaperone| + '|procedure impersonator|) + (string-append + "wrapper's " (nth-str pos) " result is not valid;\n" + " " (nth-str pos) " extra result (before original argument count) should be\n" + " 'mark" (if (zero? pos) + " or a wrapper for the original procedure's result" + "")) + "original" next-p + "wrapper" wrapper + "received" v)) + +(define (raise-wrapper-result-arity-error chaperone? proc wrapper expected-n got-n) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (if chaperone? + "procedure chaperone" + "procedure impersonator") + ": arity mismatch;\n" + " expected number of results not received from wrapper on the original\n" + " procedure's arguments\n" + " original: " (error-value->string proc) + "\n" + " wrapper: " (error-value->string wrapper) + "\n" + " expected: " (number->string expected-n) " or more\n" + " received: " (number->string got-n)) + (current-continuation-marks)))) + +;; ---------------------------------------- + +(define-record unsafe-procedure-impersonator impersonator (replace-proc)) +(define-record unsafe-procedure-chaperone chaperone (replace-proc)) + +(define/who (unsafe-impersonate-procedure proc replace-proc . props) + (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator + proc replace-proc props)) + +(define/who (unsafe-chaperone-procedure proc replace-proc . props) + (do-unsafe-impersonate-procedure who make-unsafe-procedure-chaperone + proc replace-proc props)) + +(define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props) + (let ([m (procedure-arity-mask proc)]) + (unless (= m (bitwise-and m (procedure-arity-mask replace-proc))) + (raise-arguments-error who + "arity of replacement procedure does not cover arity of original procedure" + "replacement" replace-proc + "original" proc)) + (make-unsafe-procedure-impersonator + (strip-impersonator proc) + proc + (add-impersonator-properties who + props + (if (impersonator? proc) + (impersonator-props proc) + empty-hasheq)) + replace-proc))) + +;; ---------------------------------------- + +(define/who (procedure-closure-contents-eq? p1 p2) + (check who procedure? p1) + (check who procedure? p2) + (when (and (#%procedure? p1) + (#%procedure? p2)) + (let* ([i1 (inspect/object p1)] + [i2 (inspect/object p2)] + [l1 (i2 'length)] + [l2 (i2 'length)]) + (and (eq? ((i1 'code) 'value) + ((i2 'code) 'value)) + (= l1 l2) + (let loop ([i 0]) + (or (fx= i l1) + (and (eq? (((i1 'ref i) 'ref) 'value) (((i2 'ref i) 'ref) 'value)) + (loop (fx1+ i))))))))) + +;; ---------------------------------------- + +(define-values (prop:checked-procedure checked-procedure? checked-procedure-ref) + (make-struct-type-property 'checked-procedure + (lambda (v s) + (unless (not (list-ref s 6)) + (raise-arguments-error 'prop:checked-procedure + "not allowed on a structure type with a supertype")) + (unless (>= (+ (list-ref s 1) (list-ref s 2)) 2) + (raise-arguments-error 'prop:checked-procedure + "need at least two fields in the structure type")) + #t))) + +(define/who (checked-procedure-check-and-extract st v alt-proc v1 v2) + (check who record-type-descriptor? + :contract "(and/c struct-type? (not/c impersonator?))" + st) + (if (and (checked-procedure? v) + (record? v st) + (|#%app| (unsafe-struct*-ref v 0) v1 v2)) + (unsafe-struct*-ref v 1) + (|#%app| alt-proc v v1 v2))) + +;; ---------------------------------------- + +(define (primitive? v) + (or (eq? v make-struct-type-property) + (eq? v make-struct-type))) + +(define (primitive-closure? v) #f) + +(define (primitive-result-arity prim) + (cond + [(eq? prim make-struct-type-property) 3] + [(eq? prim make-struct-type) 5] + [else + (raise-argument-error 'primitive-result-arity "primitive?" prim)])) + +;; ---------------------------------------- + +(define (set-primitive-applicables!) + (struct-property-set! prop:procedure + (record-type-descriptor parameter) + 0) + (struct-property-set! prop:procedure + (record-type-descriptor derived-parameter) + 0) + + (struct-property-set! prop:procedure + (record-type-descriptor position-based-accessor) + (lambda (pba s p) + (cond + [(and (record? s (position-based-accessor-rtd pba)) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))] + [(and (impersonator? s) + (record? (impersonator-val s) (position-based-accessor-rtd pba)) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (impersonate-ref (lambda (s) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))) + (position-based-accessor-rtd pba) + p + s)] + [else (error 'struct-ref "bad access")]))) + + (struct-property-set! prop:procedure + (record-type-descriptor position-based-mutator) + (lambda (pbm s p v) + (cond + [(and (record? s (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm))) + (unsafe-struct-set! s (+ p (position-based-mutator-offset pbm)) v)] + [(and (impersonator? s) + (record? (impersonator-val s) (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm))) + (let ([abs-pos (+ p (position-based-mutator-offset pbm))]) + (impersonate-set! (lambda (s v) + (unsafe-struct-set! s abs-pos v)) + (position-based-mutator-rtd pbm) + p + abs-pos + s + v))] + [else + (error 'struct-set! "bad assignment")]))) + + (struct-property-set! prop:procedure + (record-type-descriptor named-procedure) + 0) + (struct-property-set! prop:object-name + (record-type-descriptor named-procedure) + 1) + + (struct-property-set! prop:procedure + (record-type-descriptor reduced-arity-procedure) + 0) + (struct-property-set! prop:procedure-arity + (record-type-descriptor reduced-arity-procedure) + (box 1)) + (struct-property-set! prop:object-name + (record-type-descriptor reduced-arity-procedure) + 2) + + (struct-property-set! prop:procedure + (record-type-descriptor method-procedure) + 0) + (struct-property-set! prop:method-arity-error + (record-type-descriptor method-procedure) + #t) + + (let ([register-procedure-impersonator-struct-type! + (lambda (rtd) + (struct-property-set! prop:procedure rtd impersonate-apply) + (struct-property-set! prop:procedure-arity rtd 0))]) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-undefined-chaperone))) + + (let ([register-unsafe-procedure-impersonator-struct-type! + (lambda (rtd) + (struct-property-set! prop:procedure rtd 'unsafe) + (struct-property-set! prop:procedure-arity rtd 0))]) + (register-unsafe-procedure-impersonator-struct-type! (record-type-descriptor unsafe-procedure-impersonator)) + (register-unsafe-procedure-impersonator-struct-type! (record-type-descriptor unsafe-procedure-chaperone)))) diff -Nru racket-6.12+ppa1/src/cs/rumble/pthread.ss racket-7.0+ppa1/src/cs/rumble/pthread.ss --- racket-6.12+ppa1/src/cs/rumble/pthread.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/pthread.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +(meta-cond + [(threaded?) + (define make-pthread-parameter make-thread-parameter) + (define (fork-pthread thunk) + (fork-thread (lambda () + (init-virtual-registers) + (thunk)))) + (define pthread? thread?) + ;; make-condition + ;; condition-wait + ;; condition-signal + ;; condition-broadcast + ;; make-mutex + ;; mutex-acquire + ;; mutex-release + ] + [else + (define make-pthread-parameter #%make-parameter) + (define (fork-pthread) (void)) + (define (pthread?) #f) + (define (make-condition) (void)) + (define (condition-wait c m) (void)) + (define (condition-signal c) (void)) + (define (condition-broadcast c) (void)) + (define (make-mutex) (void)) + (define mutex-acquire + (case-lambda + [(m block?) (void)] + [(m) (void)])) + (define (mutex-release m) (void)) + ]) + +(define (active-pthreads) #%$active-threads) diff -Nru racket-6.12+ppa1/src/cs/rumble/random.ss racket-7.0+ppa1/src/cs/rumble/random.ss --- racket-6.12+ppa1/src/cs/rumble/random.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/random.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,275 @@ +;; /* +;; Based on +;; +;; Implementation of SRFI-27 core generator in C for Racket. +;; dvanhorn@cs.uvm.edu +;; +;; and +;; +;; 54-BIT (double) IMPLEMENTATION IN C OF THE "MRG32K3A" GENERATOR +;; =============================================================== +;; +;; Sebastian.Egner@philips.com, Mar-2002, in ANSI-C and Scheme 48 0.57 +;; +;; This code is a C-implementation of Pierre L'Ecuyer's MRG32k3a generator. +;; The code uses (double)-arithmetics, assuming that it covers the range +;; {-2^53..2^53-1} exactly (!). The code of the generator is based on the +;; L'Ecuyer's own implementation of the generator. Please refer to the +;; file 'mrg32k3a.scm' for more information about the method. +;; */ + +;; The Generator +;; ============= + +;; moduli of the components +(define Im1 #xffffff2f) +(define Im2 #xffffa6bb) +(define m1 4294967087.0) +(define m2 4294944443.0) + +;; recursion coefficients of the components +(define a12 1403580.0) +(define a13n 810728.0) +(define a21 527612.0) +(define a23n 1370589.0) + +;; normalization factor 1/(m1 + 1) +(define norm 2.328306549295728e-10) + +;; the actual generator + +(define-record-type (pseudo-random-generator new-pseudo-random-generator pseudo-random-generator?) + (fields (mutable x10) (mutable x11) (mutable x12) (mutable x20) (mutable x21) (mutable x22)) + (nongenerative)) + +(define (mrg32k3a s) ;; -> flonum in {0..m1-1} + ;; component 1 + (let* ([x10 (fl- (fl* a12 (pseudo-random-generator-x11 s)) + (fl* a13n (pseudo-random-generator-x12 s)))] + [k10 (fltruncate (fl/ x10 m1))] + [x10 (fl- x10 (fl* k10 m1))] + [x10 (if (fl< x10 0.0) + (fl+ x10 m1) + x10)]) + (pseudo-random-generator-x12-set! s (pseudo-random-generator-x11 s)) + (pseudo-random-generator-x11-set! s (pseudo-random-generator-x10 s)) + (pseudo-random-generator-x10-set! s x10) + + ;; component 2 + (let* ([x20 (fl- (fl* a21 (pseudo-random-generator-x20 s)) + (fl* a23n (pseudo-random-generator-x22 s)))] + [k20 (fltruncate (fl/ x20 m2))] + [x20 (fl- x20 (fl* k20 m2))] + [x20 (if (fl< x20 0.0) + (fl+ x20 m2) + x20)]) + (pseudo-random-generator-x22-set! s (pseudo-random-generator-x21 s)) + (pseudo-random-generator-x21-set! s (pseudo-random-generator-x20 s)) + (pseudo-random-generator-x20-set! s x20) + + ;; combination of components + (let* ([y (fl- x10 x20)]) + (if (fl< y 0.0) + (fl+ y m1) + y))))) + +(define (make-pseudo-random-generator) + (let ([s (new-pseudo-random-generator 1.0 1.0 1.0 1.0 1.0 1.0)]) + (pseudo-random-generator-seed! s (current-milliseconds)) + s)) + +(define (pseudo-random-generator-seed! s x) + ;; Initial values are from Sebastian Egner's implementation: + (pseudo-random-generator-x10-set! s 1062452522.0) + (pseudo-random-generator-x11-set! s 2961816100.0) + (pseudo-random-generator-x12-set! s 342112271.0) + (pseudo-random-generator-x20-set! s 2854655037.0) + (pseudo-random-generator-x21-set! s 3321940838.0) + (pseudo-random-generator-x22-set! s 3542344109.0) + (srand-half! s (bitwise-and x #xFFFF)) + (srand-half! s (bitwise-and (bitwise-arithmetic-shift-right x 16) #xFFFF))) + +(define (srand-half! s x) + (let* ([x (random-n! x + (- Im1 1) + (lambda (z) + (pseudo-random-generator-x10-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x10 s)) + z) + (- Im1 1)))))))] + [x (random-n! x + Im1 + (lambda (z) + (pseudo-random-generator-x11-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x11 s)) + z) + Im1))))))] + [x (random-n! x + Im1 + (lambda (z) + (pseudo-random-generator-x12-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x12 s)) + z) + Im1))))))] + [x (random-n! x + (- Im2 1) + (lambda (z) + (pseudo-random-generator-x20-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x20 s)) + z) + (- Im2 1)))))))] + [x (random-n! x + Im2 + (lambda (z) + (pseudo-random-generator-x21-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x21 s)) + z) + Im2))))))] + [x (random-n! x + Im2 + (lambda (z) + (pseudo-random-generator-x22-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x22 s)) + z) + Im2))))))]) + (void))) + +(define (random-n! x Im k) + (let* ([y1 (bitwise-and x #xFFFF)] + [x (+ (* 30903 y1) (bitwise-arithmetic-shift-right x 16))] + [y2 (bitwise-and x #xFFFF)] + [x (+ (* 30903 y2) (bitwise-arithmetic-shift-right x 16))]) + (k (modulo (+ (arithmetic-shift y1 16) y2) Im)) + x)) + +(define/who (pseudo-random-generator->vector s) + (check who pseudo-random-generator? s) + (vector (inexact->exact (pseudo-random-generator-x10 s)) + (inexact->exact (pseudo-random-generator-x11 s)) + (inexact->exact (pseudo-random-generator-x12 s)) + (inexact->exact (pseudo-random-generator-x20 s)) + (inexact->exact (pseudo-random-generator-x21 s)) + (inexact->exact (pseudo-random-generator-x22 s)))) + +(define (pseudo-random-generator-vector? v) + (let ([in-range? + (lambda (i mx) + (let ([x (vector-ref v i)]) + (and (exact-nonnegative-integer? x) + (<= x mx))))] + [nonzero? + (lambda (i) + (not (zero? (vector-ref v i))))]) + (and (vector? v) + (= 6 (vector-length v)) + (in-range? 0 4294967086) + (in-range? 1 4294967086) + (in-range? 2 4294967086) + (in-range? 3 4294944442) + (in-range? 4 4294944442) + (in-range? 5 4294944442) + (or (nonzero? 0) (nonzero? 1) (nonzero? 2)) + (or (nonzero? 3) (nonzero? 4) (nonzero? 5))))) + +(define/who (vector->pseudo-random-generator orig-v) + (let ([iv (and (vector? orig-v) + (= 6 (vector-length orig-v)) + (vector->immutable-vector orig-v))]) + (check who pseudo-random-generator-vector? iv) + (let ([r (lambda (i) (exact->inexact (vector-ref iv i)))]) + (new-pseudo-random-generator (r 0) + (r 1) + (r 2) + (r 3) + (r 4) + (r 5))))) + +(define/who (vector->pseudo-random-generator! s orig-v) + (check who pseudo-random-generator? s) + (let ([iv (and (vector? orig-v) + (= 6 (vector-length orig-v)) + (vector->immutable-vector orig-v))]) + (unless (pseudo-random-generator-vector? iv) + (raise-argument-error 'vector->pseudo-random-generator! "pseudo-random-generator-vector?" orig-v)) + (let ([r (lambda (i) (exact->inexact (vector-ref iv i)))]) + (pseudo-random-generator-x10-set! s (r 0)) + (pseudo-random-generator-x11-set! s (r 1)) + (pseudo-random-generator-x12-set! s (r 2)) + (pseudo-random-generator-x20-set! s (r 3)) + (pseudo-random-generator-x21-set! s (r 4)) + (pseudo-random-generator-x22-set! s (r 5))))) + +(define (pseudo-random-generator-integer! s n) + ;; generate result in {0..n-1} using the rejection method + (let* ([n (exact->inexact n)] + [q (fltruncate (fl/ m1 n))] + [qn (fl* q n)] + [x (let loop () + (let ([x (mrg32k3a s)]) + (if (fl>= x qn) + (loop) + x)))] + [xq (fl/ x q)]) + (inexact->exact (flfloor xq)))) + +(define (pseudo-random-generator-real! s) + (fl* (fl+ (mrg32k3a s) 1.0) norm)) + +;; ---------------------------------------- + +(define/who current-pseudo-random-generator + (make-parameter (make-pseudo-random-generator) + (lambda (v) + (check who pseudo-random-generator? v) + v))) + +(define/who random + (case-lambda + [() (pseudo-random-generator-real! (|#%app| current-pseudo-random-generator))] + [(n) + (cond + [(pseudo-random-generator? n) + (pseudo-random-generator-real! n)] + [else + (check who + :test (and (integer? n) + (exact? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (pseudo-random-generator-integer! (|#%app| current-pseudo-random-generator) n)])] + [(n prg) + (check who + :test (and (integer? n) + (exact? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (check who pseudo-random-generator? prg) + (pseudo-random-generator-integer! prg n)])) + +(define/who (random-seed k) + (check who + :test (and (exact-nonnegative-integer? k) + (<= k (sub1 (expt 2 31)))) + :contract "(integer-in 0 (sub1 (expt 2 31)))" + k) + (pseudo-random-generator-seed! (|#%app| current-pseudo-random-generator) k)) diff -Nru racket-6.12+ppa1/src/cs/rumble/srcloc.ss racket-7.0+ppa1/src/cs/rumble/srcloc.ss --- racket-6.12+ppa1/src/cs/rumble/srcloc.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/srcloc.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ + +(define-struct srcloc (source line column position span) + :guard (lambda (source line column position span who) + (check who exact-positive-integer? :or-false line) + (check who exact-nonnegative-integer? :or-false column) + (check who exact-positive-integer? :or-false position) + (check who exact-nonnegative-integer? :or-false span) + (values source line column position span))) + +(define-values (prop:exn:srclocs exn:srclocs? exn:srclocs-accessor) + (make-struct-type-property 'exn:srclocs + (lambda (v info) + (check 'guard-for-prop:exn:srclocs (procedure-arity-includes/c 1) v) + v))) diff -Nru racket-6.12+ppa1/src/cs/rumble/string.ss racket-7.0+ppa1/src/cs/rumble/string.ss --- racket-6.12+ppa1/src/cs/rumble/string.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/string.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,28 @@ +(define/who string-copy! + (case-lambda + [(dest d-start src) + (string-copy! dest d-start src 0 (and (string? src) (string-length src)))] + [(dest d-start src s-start) + (string-copy! dest d-start src s-start (and (string? src) (string-length src)))] + [(dest d-start src s-start s-end) + (check who mutable-string? :contract "(and/c string? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who string? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (string-length dest)]) + (check-range who "string" dest d-start #f d-len) + (check-range who "string" src s-start s-end (string-length src)) + (let ([s-len (fx- s-end s-start)]) + (check-space who "string" d-start d-len s-len) + (#%string-copy! src s-start dest d-start s-len)))])) + +(define/who substring + (case-lambda + [(s start) (substring s start (and (string? s) (string-length s)))] + [(s start end) + (check who string? s) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "string" s start end (string-length s)) + (#%substring s start end)])) diff -Nru racket-6.12+ppa1/src/cs/rumble/struct.ss racket-7.0+ppa1/src/cs/rumble/struct.ss --- racket-6.12+ppa1/src/cs/rumble/struct.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/struct.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1155 @@ +;; Naming conventions: +;; - `rtd*` means an rtd that is not impersonators +;; - `init-count` means the number of fields supplied to the constructor, +;; not counting inherited fields +;; - `init*-count` means `init-count` plus inherited constructed fields +;; - `auto-count` means the number of fields automatically added, +;; not counting inherited fields +;; - `auto*-count` means `auto-count` plus inherited auto fields +;; - `total-count` means `init-count` plus `auto-count` +;; - `total*-count` means `init*-count` plus `auto*-count` +;; - `prefab-key+count` has a `total*-count` + +(define-record struct-type-prop (name guard supers)) + +;; Record the properties that are implemented by each rtd: +(define rtd-props (make-ephemeron-eq-hashtable)) + +;; Maps a property-accessor function to `(cons predicate-proc can-impersonate)`: +(define property-accessors (make-ephemeron-eq-hashtable)) + +(define (struct-type-property? v) + (struct-type-prop? v)) + +(define/who make-struct-type-property + (case-lambda + [(name) (make-struct-type-property name #f '() #f)] + [(name guard) (make-struct-type-property name guard '() #f)] + [(name guard supers) (make-struct-type-property name guard supers #f)] + [(name guard supers can-impersonate?) + (check who symbol? name) + (unless (or (not guard) + (eq? guard 'can-impersonate) + (and (#%procedure? guard) ; avoid `procedure?` until it's defined + (bitwise-bit-set? (#%procedure-arity-mask guard) 2)) + (and (procedure? guard) + (procedure-arity-includes? guard 2))) + (raise-argument-error who "(or/c (procedure-arity-includes/c 2) #f 'can-impersonate)" guard)) + (unless (and (or (null? supers) ; avoid `list?` until it's defined + (list? supers)) + (andmap (lambda (p) + (and (pair? p) + (struct-type-property? (car p)) + (procedure? (cdr p)) + (procedure-arity-includes? (cdr p) 1))) + supers)) + (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers)) + (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)] + [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)] + [pred (escapes-ok + (lambda (v) + (let* ([v (strip-impersonator v)] + [rtd (if (record-type-descriptor? v) + v + (and (record? v) + (record-rtd v)))]) + (and rtd + (not (eq? none (struct-property-ref st rtd none)))))))] + [accessor-name (string->symbol (string-append + (symbol->string name) + "-ref"))] + [predicate-name (string->symbol + (string-append + (symbol->string name) + "?"))] + [default-fail + (escapes-ok + (lambda (v) + (raise-argument-error accessor-name + (symbol->string predicate-name) + v)))] + [do-fail (lambda (fail v) + (cond + [(eq? fail default-fail) (default-fail v)] + [(procedure? fail) (|#%app| fail)] + [else fail]))]) + (letrec ([acc + (case-lambda + [(v fail) + (cond + [(and (impersonator? v) + (pred v)) + (impersonate-struct-or-property-ref acc #f acc v)] + [else + (let* ([rtd (if (record-type-descriptor? v) + v + (and (record? v) + (record-rtd v)))]) + (if rtd + (let ([pv (struct-property-ref st rtd none)]) + (if (eq? pv none) + (do-fail fail v) + pv)) + (do-fail fail v)))])] + [(v) (acc v default-fail)])]) + (hashtable-set! property-accessors + acc + (cons pred can-impersonate?)) + (values st + pred + acc)))])) + +(define (struct-type-property-accessor-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (hashtable-ref property-accessors v #f)) + #t)) + +(define (struct-type-property-accessor-procedure-pred v) + (car (hashtable-ref property-accessors v #f))) + +(define (struct-type-property-accessor-procedure-can-impersonate? v) + (cdr (hashtable-ref property-accessors v #f))) + +(define (struct-property-ref prop rtd default) + (getprop (record-type-uid rtd) prop default)) + +(define (struct-property-set! prop rtd val) + (putprop (record-type-uid rtd) prop val)) + +;; ---------------------------------------- + +(define-record-type (inspector new-inspector inspector?) (fields parent)) + +(define root-inspector (new-inspector #f)) + +(define/who make-inspector + (case-lambda + [() (new-inspector (|#%app| current-inspector))] + [(i) + (check who inspector? i) + (new-inspector i)])) + +(define/who make-sibling-inspector + (case-lambda + [() (make-sibling-inspector (current-inspector))] + [(i) + (check who inspector? i) + (make-inspector (inspector-parent i))])) + +(define/who (inspector-superior? sup-insp sub-insp) + (check who inspector? sup-insp) + (check who inspector? sub-insp) + (if (eq? sub-insp root-inspector) + #f + (let ([parent (inspector-parent sub-insp)]) + (or (eq? parent sup-insp) + (inspector-superior? sup-insp parent))))) + +(define (inspector-ref rtd) + (getprop (record-type-uid rtd) 'inspector none)) + +(define (inspector-set! rtd insp) + (putprop (record-type-uid rtd) 'inspector insp)) + +;; ---------------------------------------- + +(define (check-make-struct-type-arguments who name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name) + (check who symbol? name) + (check who :or-false struct-type? parent-rtd) + (check who exact-nonnegative-integer? init-count) + (check who exact-nonnegative-integer? auto-count) + (check who + :test (or (not proc-spec) + (procedure? proc-spec) + (exact-nonnegative-integer? proc-spec)) + :contract "(or/c procedure? exact-nonnegative-integer? #f)" + proc-spec) + (check who + :test (and (list props) + (andmap (lambda (i) (and (pair? i) (struct-type-property? (car i)))) + props)) + :contract "(listof (cons/c struct-type-property? any/c))" + props) + (check who + :test (or (not insp) + (inspector? insp) + (eq? insp 'prefab)) + :contract "(or/c inspector? #f 'prefab)" + insp) + (check who + :test (and (list? immutables) + (andmap exact-nonnegative-integer? immutables)) + :contract "(listof exact-nonnegative-integer?)" + immutables) + (check who :or-false procedure? guard) + (check who :or-false symbol? constructor-name) + + ;; The rest has to be delayed until we have an rtd: + (lambda (rtd parent-rtd* all-immutables) + (let ([props-ht + ;; Check for duplicates and record property values + (let ([get-struct-info + (escapes-ok + (lambda () + (let ([parent-total*-count (if parent-rtd* + (struct-type-total*-field-count parent-rtd*) + 0)]) + (list name + init-count + auto-count + (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)) + all-immutables + parent-rtd + #f))))]) + (let loop ([props props] [ht empty-hasheq]) + (cond + [(null? props) + (if proc-spec + (let-values ([(ht props) (check-and-add-property who prop:procedure proc-spec rtd ht '() + get-struct-info)]) + ht) + ht)] + [else + (let-values ([(ht props) (check-and-add-property who (caar props) (cdar props) rtd ht (cdr props) + get-struct-info)]) + (loop props ht))])))]) + + (when (eq? insp 'prefab) + (let ([bad + (or (and (impersonator? parent-rtd) + "chaperoned supertype disallowed for non-generative structure type") + (and parent-rtd + (not (eq? (inspector-ref parent-rtd) 'prefab)) + "generative supertype disallowed for non-generative structure type") + (and (pair? props) + "properties disallowed for non-generative structure type") + (and proc-spec + "procedure specification disallowed for non-generative structure type") + (and guard + "guard disallowed for non-generative structure type"))]) + (when bad + (raise-arguments-error who bad + "structure type name" name)))) + + (let loop ([ht empty-hasheqv] [imms immutables]) + (cond + [(null? imms) (void)] + [else + (let ([i (car imms)]) + (when (hash-ref ht i #f) + (raise-arguments-error who + "redundant immutable field index" + "index" i + "in list" immutables)) + (unless (< i init-count) + (raise-arguments-error who + "index for immutable field >= initialized-field count" + "index" i + "initialized-field count" init-count + "in list" immutables)) + (loop (hash-set ht i #t) (cdr imms)))])) + + (let ([v (hash-ref props-ht prop:procedure #f)]) + (when v + (cond + [(exact-nonnegative-integer? v) + (unless (< v init-count) + (raise-arguments-error who + "index for procedure >= initialized-field count" + "index" v + "field count" init-count)) + (unless (or (eq? v proc-spec) (chez:memv v immutables)) + (raise-arguments-error who + "field is not specified as immutable for a prop:procedure index" + "index" v))] + [(procedure? v) + (void)] + [else + (raise-arguments-error who + "given value did not satisfy the contract for prop:procedure" + "expected" "(or/c procedure? exact-nonnegative-integer?)" + "given" v)]))) + + (let ([parent-rtd* (strip-impersonator parent-rtd)]) + (when parent-rtd* + (let ([authentic? (not (eq? (hash-ref props-ht prop:authentic none) none))] + [authentic-parent? (struct-property-ref prop:authentic parent-rtd* #f)]) + (when (not (eq? authentic? authentic-parent?)) + (if authentic? + (raise-arguments-error who + "cannot make an authentic subtype of a non-authentic type" + "type name" name + "non-authentic type" parent-rtd) + (raise-arguments-error who + "cannot make a non-authentic subtype of an authentic type" + "type name" name + "authentic type" parent-rtd))))) + + (when guard + (let ([expected-count (+ 1 + init-count + (if parent-rtd* + (get-field-info-init*-count (struct-type-field-info parent-rtd*)) + 0))]) + (unless (procedure-arity-includes? guard expected-count) + (raise-arguments-error who + (string-append + "guard procedure does not accept correct number of arguments;\n" + " should accept one more than the number of constructor arguments") + "guard procedure" guard + "expected arity" expected-count)))))))) + +(define (check-and-add-property who prop val rtd ht props get-struct-info) + (let* ([guarded-val + (let ([guard (struct-type-prop-guard prop)]) + (if guard + (|#%app| guard val (get-struct-info)) + val))] + [check-val (cond + [(eq? prop prop:procedure) + ;; Save and check the original value, since the true + ;; guard is in `check-make-struct-type-arguments` + ;; (for historical reasons) + val] + [else guarded-val])] + [old-v (hash-ref ht prop none)]) + (unless (or (eq? old-v none) + (eq? old-v check-val)) + (raise-arguments-error who + "duplicate property binding" + "property" prop)) + (when (eq? prop prop:equal+hash) + (record-type-equal-procedure rtd (let ([p (cadr guarded-val)]) + (if (#%procedure? p) + p + (lambda (v1 v2 e?) (|#%app| p v1 v2 e?))))) + (record-type-hash-procedure rtd (let ([p (caddr guarded-val)]) + (if (#%procedure? p) + p + (lambda (v h) (|#%app| p v h)))))) + (struct-property-set! prop rtd guarded-val) + (values (hash-set ht prop check-val) + (append + (if (eq? old-v none) + (map (lambda (super) + (cons (car super) + (|#%app| (cdr super) guarded-val))) + (struct-type-prop-supers prop)) + ;; skip supers, because property is already added + null) + props)))) + +;; ---------------------------------------- + +;; Records which fields of an rtd are mutable, where an rtd that is +;; not in the table has no mutable fields: +(define rtd-mutables (make-ephemeron-eq-hashtable)) + +;; Accessors and mutators that need a position are wrapped in these records: +(define-record position-based-accessor (rtd offset field-count)) +(define-record position-based-mutator (rtd offset field-count)) + +;; Register other procedures in hash tables; avoid wrapping to +;; avoid making the procedures slower +(define struct-constructors (make-ephemeron-eq-hashtable)) +(define struct-predicates (make-ephemeron-eq-hashtable)) +(define struct-field-accessors (make-ephemeron-eq-hashtable)) +(define struct-field-mutators (make-ephemeron-eq-hashtable)) + +(define (register-struct-constructor! p) + (hashtable-set! struct-constructors p #t)) + +(define (register-struct-predicate! p) + (hashtable-set! struct-predicates p #t)) + +(define (register-struct-field-accessor! p rtd pos) + (hashtable-set! struct-field-accessors p (cons rtd pos))) + +(define (register-struct-field-mutator! p rtd pos) + (hashtable-set! struct-field-mutators p (cons rtd pos))) + +(define (struct-constructor-procedure? v) + (and (procedure? v) + (hashtable-ref struct-constructors (strip-impersonator v) #f))) + +(define (struct-predicate-procedure? v) + (and (procedure? v) + (hashtable-ref struct-predicates (strip-impersonator v) #f))) + +(define (struct-accessor-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (or (position-based-accessor? v) + (hashtable-ref struct-field-accessors v #f))) + #t)) + +(define (struct-mutator-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (or (position-based-mutator? v) + (hashtable-ref struct-field-mutators v #f))) + #t)) + +(define (struct-accessor-procedure-rtd+pos v) + (hashtable-ref struct-field-accessors v #f)) + +(define (struct-mutator-procedure-rtd+pos v) + (hashtable-ref struct-field-mutators v #f)) + +;; ---------------------------------------- + +;; General structure-type creation, but not called when a `schemify` +;; transformation keeps the record type exposed to the compiler +(define make-struct-type + (case-lambda + [(name parent-rtd init-count auto-count) + (make-struct-type name parent-rtd init-count auto-count #f '() (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val) + (make-struct-type name parent-rtd init-count auto-count auto-val '() (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props) + (make-struct-type name parent-rtd init-count auto-count auto-val props (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard constructor-name) + (let* ([install-props! + (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name)] + [prefab-uid (and (eq? insp 'prefab) + (structure-type-lookup-prefab-uid name parent-rtd init-count auto-count auto-val immutables))] + [parent-rtd* (strip-impersonator parent-rtd)] + [parent-fi (if parent-rtd* + (struct-type-field-info parent-rtd*) + empty-field-info)] + [rtd (make-record-type-descriptor name + parent-rtd* + prefab-uid #f #f + (make-fields (+ init-count auto-count)))] + [parent-auto*-count (get-field-info-auto*-count parent-fi)] + [parent-init*-count (get-field-info-init*-count parent-fi)] + [parent-total*-count (get-field-info-total*-count parent-fi)] + [init*-count (+ init-count parent-init*-count)] + [auto*-count (+ auto-count parent-auto*-count)] + [auto-field-adder (and (positive? auto*-count) + (let ([pfa (get-field-info-auto-adder parent-fi)]) + (lambda (args) + (args-insert args init-count auto-count auto-val pfa))))]) + (when (or parent-rtd* auto-field-adder) + (putprop (record-type-uid rtd) 'field-info (make-field-info init*-count auto*-count auto-field-adder))) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd + props insp proc-spec immutables guard constructor-name + install-props!) + (let ([ctr (struct-type-constructor-add-guards + (let ([c (record-constructor rtd)]) + (if (zero? auto*-count) + c + (procedure-rename + (procedure-reduce-arity + (lambda args + (apply c (reverse (auto-field-adder (reverse args))))) + init*-count) + (or constructor-name name)))) + rtd + (or constructor-name name))] + [pred (escapes-ok + (lambda (v) + (or (record? v rtd) + (and (impersonator? v) + (record? (impersonator-val v) rtd)))))]) + (register-struct-constructor! ctr) + (register-struct-constructor! pred) + (values rtd + ctr + pred + (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)))))])) + +;; Called both by `make-struct-type` and by a `schemify` transformation: +(define struct-type-install-properties! + (case-lambda + [(rtd name init-count auto-count parent-rtd) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (|#%app| current-inspector) #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (|#%app| current-inspector) #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!) + (let ([install-props! + (or install-props! + (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name))]) + (unless (eq? insp 'prefab) ; everything for prefab must be covered in `prefab-key+count->rtd` + (let* ([parent-rtd* (strip-impersonator parent-rtd)] + [parent-props + (if parent-rtd* + (hashtable-ref rtd-props parent-rtd* '()) + '())] + [all-immutables (if (integer? proc-spec) + (cons proc-spec immutables) + immutables)] + [mutables (immutables->mutables all-immutables init-count)]) + (when (not parent-rtd*) + (record-type-equal-procedure rtd default-struct-equal?) + (record-type-hash-procedure rtd default-struct-hash)) + ;; Record properties implemented by this type: + (hashtable-set! rtd-props rtd (let ([props (append (map car props) parent-props)]) + (if proc-spec + (cons prop:procedure props) + props))) + (unless (equal? '#() mutables) + (hashtable-set! rtd-mutables rtd mutables)) + ;; Copy parent properties for this type: + (for-each (lambda (prop) + (let loop ([prop prop]) + (struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f)) + (for-each (lambda (super) + (loop (car super))) + (struct-type-prop-supers prop)))) + parent-props) + ;; Finish checking and install new property values: + (install-props! rtd parent-rtd* all-immutables) + ;; Record inspector + (inspector-set! rtd insp) + ;; Register guard + (register-guards! rtd parent-rtd guard 'at-start))))])) + +;; Used by a `schemify` transformation: +(define (structure-type-lookup-prefab-uid name parent-rtd* init-count auto-count auto-val immutables) + ;; Return a UID for a prefab structure type. We can assume that + ;; `immutables` is well-formed, and checking an error reporting will + ;; happen latter if necessary. + (let ([prefab-key (derive-prefab-key name + (and parent-rtd* + (getprop (record-type-uid parent-rtd*) 'prefab-key+count)) + init-count + immutables auto-count auto-val)] + [total*-count (+ (if parent-rtd* + (struct-type-total*-field-count parent-rtd*) + 0) + init-count + auto-count)]) + (record-type-uid + (prefab-key+count->rtd (cons prefab-key total*-count))))) + +(define (prefab-ref prefab-key+count) + (with-interrupts-disabled ; atomic access of `prefabs` + (and prefabs + (hash-ref prefabs prefab-key+count #f)))) + +(define (prefab-key+count->rtd prefab-key+count) + (cond + [(prefab-ref prefab-key+count) + => (lambda (rtd) rtd)] + [else + (let* ([prefab-key (car prefab-key+count)] + [name (if (symbol? prefab-key) + prefab-key + (car prefab-key))] + [parent-prefab-key+count + (prefab-key->parent-prefab-key+count (car prefab-key+count))] + [parent-rtd (and parent-prefab-key+count + (prefab-key+count->rtd parent-prefab-key+count))] + [total-count (- (cdr prefab-key+count) + (if parent-prefab-key+count + (cdr parent-prefab-key+count) + 0))] + [uid (encode-prefab-key+count-as-symbol prefab-key+count)] + [rtd (make-record-type-descriptor name + parent-rtd + uid #f #f + (make-fields total-count))] + [mutables (prefab-key-mutables prefab-key)]) + (with-interrupts-disabled + (cond + [(prefab-ref prefab-key+count) + ;; rtd was created concurrently + => (lambda (rtd) rtd)] + [else + (putprop uid 'prefab-key+count prefab-key+count) + (with-interrupts-disabled ; atomic use of `prefabs` table + (unless prefabs (set! prefabs (make-weak-hash))) + (hash-set! prefabs prefab-key+count rtd)) + (unless parent-rtd + (record-type-equal-procedure rtd default-struct-equal?) + (record-type-hash-procedure rtd default-struct-hash)) + (unless (equal? mutables '#()) + (hashtable-set! rtd-mutables rtd mutables)) + (inspector-set! rtd 'prefab) + rtd])))])) + +(define (check-accessor-or-mutator-index who rtd pos) + (let* ([total-count (#%vector-length (record-type-field-names rtd))]) + (unless (< pos total-count) + (if (zero? total-count) + (raise-arguments-error who + "index too large; no fields accessible" + "index" pos + "structure type" rtd) + (raise-arguments-error who + "index too large" + "index" pos + "maximum allowed index" (sub1 total-count) + "structure type" rtd))))) + +(define/who make-struct-field-accessor + (case-lambda + [(pba pos name) + (check who position-based-accessor? + :contract "(and/c struct-accessor-procedure? (procedure-arity-includes/c 2))" + pba) + (check who exact-nonnegative-integer? pos) + (check who symbol? :or-false name) + (let ([rtd (position-based-accessor-rtd pba)]) + (check-accessor-or-mutator-index who rtd pos) + (let* ([p (record-field-accessor rtd + (+ pos (position-based-accessor-offset pba)))] + [wrap-p + (escapes-ok + (lambda (v) + (if (impersonator? v) + (impersonate-ref p rtd pos v) + (p v))))]) + (register-struct-field-accessor! wrap-p rtd pos) + wrap-p))] + [(pba pos) + (make-struct-field-accessor pba pos #f)])) + +(define/who make-struct-field-mutator + (case-lambda + [(pbm pos name) + (check who position-based-mutator? + :contract "(and/c struct-mutator-procedure? (procedure-arity-includes/c 3))" + pbm) + (check who exact-nonnegative-integer? pos) + (check who symbol? :or-false name) + (let ([rtd (position-based-mutator-rtd pbm)]) + (check-accessor-or-mutator-index who rtd pos) + (let* ([abs-pos (+ pos (position-based-mutator-offset pbm))] + [p (record-field-mutator rtd abs-pos)] + [wrap-p + (escapes-ok + (lambda (v a) + (if (impersonator? v) + (impersonate-set! p rtd pos abs-pos v a) + (p v a))))]) + (register-struct-field-mutator! wrap-p rtd pos) + wrap-p))] + [(pbm pos) + (make-struct-field-mutator pbm pos #f)])) + +;; Takes constructor arguments and adds auto-argument values. +;; Receives and returns `args` is in reverse order. +(define (args-insert args fields-count auto-count auto-val pfa) + (let loop ([auto-count auto-count]) + (if (zero? auto-count) + (if pfa + (let loop ([fields-count fields-count] [args args]) + (if (zero? fields-count) + (pfa args) + (cons (car args) (loop (fx1- fields-count) (cdr args))))) + args) + (cons auto-val (loop (fx1- auto-count)))))) + +;; ---------------------------------------- + +(define (struct-type? v) (record-type-descriptor? (strip-impersonator v))) + +(define/who (procedure-struct-type? v) + (check who struct-type? v) + (procedure-struct? v)) + +(define (struct? v) + (let ([v (strip-impersonator v)]) + (and (record? v) + (struct-type-any-transparent? (record-rtd v))))) + +(define (struct-info v) + (cond + [(impersonator? v) + (if (record? (impersonator-val v)) + (impersonate-struct-info v) + (values #f #t))] + [(not (record? v)) (values #f #t)] + [else (next-visible-struct-type (record-rtd v))])) + +(define (next-visible-struct-type rtd) + (let loop ([rtd rtd] [skipped? #f]) + (cond + [(struct-type-immediate-transparent? rtd) + (values rtd skipped?)] + [else + (let ([parent-rtd (record-type-parent rtd)]) + (if parent-rtd + (loop parent-rtd #t) + (values #f #t)))]))) + +(define/who (struct-type-info rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access 'struct-type-info rtd*) + (let* ([fi (struct-type-field-info rtd*)] + [parent-rtd* (record-type-parent rtd*)] + [parent-fi (if parent-rtd* + (struct-type-field-info parent-rtd*) + empty-field-info)] + [init-count (get-field-info-init-count fi parent-fi)] + [auto-count (get-field-info-auto-count fi parent-fi)] + [parent-total*-count (get-field-info-total*-count parent-fi)]) + (let-values ([(next-rtd* skipped?) + (if parent-rtd* + (next-visible-struct-type parent-rtd*) + (values #f #f))]) + (letrec ([get-results + (lambda () + (values (record-type-name rtd*) + init-count + auto-count + (make-position-based-accessor rtd* parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd* parent-total*-count (+ init-count auto-count)) + (mutables->immutables (hashtable-ref rtd-mutables rtd* '#()) init-count) + next-rtd* + skipped?))]) + (cond + [(struct-type-chaperone? rtd) + (chaperone-struct-type-info rtd get-results)] + [else + (get-results)])))))) + +(define (check-inspector-access who rtd) + (unless (struct-type-immediate-transparent? rtd) + (raise-arguments-error who + "current inspector cannot extract info for structure type" + "structure type" rtd))) + +(define/who (struct-type-make-constructor rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access who rtd*) + (let ([ctr (struct-type-constructor-add-guards + (let* ([c (record-constructor rtd*)] + [fi (struct-type-field-info rtd*)] + [auto-field-adder (get-field-info-auto-adder fi)]) + (cond + [auto-field-adder + (procedure-maybe-rename + (procedure-reduce-arity + (lambda args + (apply c (reverse (auto-field-adder (reverse args))))) + (get-field-info-init*-count fi)) + (object-name c))] + [else c])) + rtd* + #f)]) + (register-struct-constructor! ctr) + (cond + [(struct-type-chaperone? rtd) + (chaperone-constructor rtd ctr)] + [else ctr])))) + +;; Called directly from a schemified declaration that has a guard: +(define (struct-type-constructor-add-guards ctr rtd name) + (let ([guards (struct-type-guards rtd)] + [chaparone-undefined? (chaperone-unsafe-undefined? rtd)]) + (if (and (null? guards) + (not chaparone-undefined?)) + ctr + (procedure-maybe-rename + (procedure-reduce-arity + (let ([base-ctr + (if (null? guards) + ctr + (let ([name (record-type-name rtd)]) + (lambda args + (let loop ([guards guards] [args args]) + (cond + [(null? guards) + (apply ctr args)] + [else + (let ([guard (caar guards)] + [init*-count (cdar guards)]) + (call-with-values + (lambda () + (apply guard (append-n args init*-count (list name)))) + (lambda results + (unless (= (length results) init*-count) + (raise-result-arity-error "calling guard procedure" init*-count results)) + (loop (cdr guards) + (if (= init*-count (length args)) + results + (append results (list-tail args init*-count)))))))])))))]) + (if chaparone-undefined? + (lambda args + (chaperone-struct-unsafe-undefined (apply base-ctr args))) + base-ctr)) + (get-field-info-init*-count (struct-type-field-info rtd))) + (or name (object-name ctr)))))) + +(define (struct-type-constructor-add-guards* ctr rtd guard name) + (register-guards! rtd #f guard 'at-end) + (struct-type-constructor-add-guards ctr rtd name)) + +(define/who (struct-type-make-predicate rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access who rtd*) + (let ([pred (escapes-ok + (lambda (v) + (or (record? v rtd*) + (and (impersonator? v) + (record? (impersonator-val v) rtd*)))))]) + (register-struct-constructor! pred) + pred))) + +;; ---------------------------------------- + +(define-record field-info (init*-count ; includes parent init fields + auto*-count ; includes parent auto fields + auto-adder)) ; #f or procedure to add auto fields for constructor + +(define empty-field-info 0) + +;; Returns either a `field-info` record or a fixnum N that +;; corresponds to `(make-field-info N 0 #f)`. +(define (struct-type-field-info rtd*) + (or (getprop (record-type-uid rtd*) 'field-info #f) + (let ([n (#%vector-length (record-type-field-names rtd*))] + [parent-rtd* (record-type-parent rtd*)]) + ;; If `parent-rtd` is not #f, then we'll get here + ;; only if were still in the process of setting up + ;; `rtd`, so we won't have to recur far or often + ;; construct field-info records + (if parent-rtd* + (let ([parent-fi (struct-type-field-info parent-rtd*)]) + (if (fixnum? parent-fi) + (+ n parent-fi) + (make-field-info (+ n (field-info-init*-count parent-fi)) + (field-info-auto*-count parent-fi) + #f))) + n)))) + +(define (get-field-info-init*-count fi) + (if (fixnum? fi) + fi + (field-info-init*-count fi))) + +(define (get-field-info-auto*-count fi) + (if (fixnum? fi) + 0 + (field-info-auto*-count fi))) + +(define (get-field-info-total*-count fi) + (if (fixnum? fi) + fi + (+ (field-info-init*-count fi) + (field-info-auto*-count fi)))) + +(define (get-field-info-init-count fi parent-fi) + (- (get-field-info-init*-count fi) + (get-field-info-init*-count parent-fi))) + +(define (get-field-info-auto-count fi parent-fi) + (- (get-field-info-auto*-count fi) + (get-field-info-auto*-count parent-fi))) + +(define (get-field-info-auto-adder fi) + (if (fixnum? fi) + #f + (field-info-auto-adder fi))) + +(define (struct-type-total*-field-count rtd*) + (get-field-info-total*-count (struct-type-field-info rtd*))) + +(define (struct-type-parent-total*-count rtd*) + (let ([p-rtd* (record-type-parent rtd*)]) + (if p-rtd* + (struct-type-total*-field-count p-rtd*) + 0))) + +;; ---------------------------------------- + +(define (struct-type-field-mutable? rtd pos) + (let ([mutables (hashtable-ref rtd-mutables rtd '#())]) + (let loop ([j (#%vector-length mutables)]) + (cond + [(fx= j 0) #f] + [else + (let ([j (fx1- j)]) + (or (eqv? pos (#%vector-ref mutables j)) + (loop j)))])))) + +;; Returns a list of (cons guard-proc field-count) +(define (struct-type-guards rtd) + (getprop (record-type-uid rtd) 'guards '())) + +(define (register-guards! rtd parent-rtd guard which-end) + (let* ([parent-rtd* (record-type-parent rtd)] + [parent-guards (if parent-rtd* + (struct-type-guards parent-rtd*) + '())]) + (when (or guard (pair? parent-guards) (struct-type-chaperone? parent-rtd)) + (let* ([fi (struct-type-field-info rtd)] + [parent-guards (if (struct-type-chaperone? parent-rtd) + (cons (cons (struct-type-chaperone-guard parent-rtd) + (get-field-info-init*-count + (struct-type-field-info parent-rtd*))) + parent-guards) + parent-guards)]) + (putprop (record-type-uid rtd) 'guards (if guard + (if (eq? which-end 'at-start) + ;; Normal: + (cons (cons guard (get-field-info-init*-count fi)) + parent-guards) + ;; Internal, makes primitive guards have a natural + ;; error order: + (append parent-guards + (list (cons guard (get-field-info-init*-count fi))))) + parent-guards)))))) + +(define (unsafe-struct*-ref s i) + (#3%vector-ref s i)) +(define (unsafe-struct*-set! s i v) + (#3%vector-set! s i v)) + +(define (unsafe-struct-ref s i) + (if (impersonator? s) + (let loop ([rtd* (record-rtd (impersonator-val s))]) + (let ([pos (- i (struct-type-parent-total*-count rtd*))]) + (if (fx>= pos 0) + (impersonate-ref (record-field-accessor rtd* i) rtd* pos s) + (loop (record-type-parent rtd*))))) + (unsafe-struct*-ref s i))) + +(define (unsafe-struct-set! s i v) + (if (impersonator? s) + (let loop ([rtd* (record-rtd (impersonator-val s))]) + (let* ([pos (- i (struct-type-parent-total*-count rtd*))]) + (if (fx>= pos 0) + (impersonate-set! (record-field-mutator rtd* i) rtd* pos i s v) + (loop (record-type-parent rtd*))))) + (unsafe-struct*-set! s i v))) + +(define-values (prop:equal+hash equal+hash? equal+hash-ref) + (make-struct-type-property 'equal+hash + (lambda (val info) + (check 'guard-for-prop:equal+hash + :test (and (list? val) + (= 3 (length val)) + (andmap procedure? val) + (procedure-arity-includes? (car val) 3) + (procedure-arity-includes? (cadr val) 2) + (procedure-arity-includes? (caddr val) 2)) + :contract (string-append + "(list/c (procedure-arity-includes/c 3)\n" + " (procedure-arity-includes/c 2)\n" + " (procedure-arity-includes/c 2))") + val) + (cons (gensym) val)))) + +(define-values (prop:authentic authentic? authentic-ref) + (make-struct-type-property 'authentic (lambda (val info) #t))) + +(define (struct-type-immediate-transparent? rtd) + (let ([insp (inspector-ref rtd)]) + (and (not (eq? insp none)) + (or (not insp) + (eq? insp 'prefab) + (inspector-superior? (|#%app| current-inspector) insp))))) + +;; Check whether a structure type is fully transparent +(define (struct-type-transparent? rtd) + (and (struct-type-immediate-transparent? rtd) + (let ([p-rtd (record-type-parent rtd)]) + (or (not p-rtd) + (struct-type-transparent? p-rtd))))) + +;; Checks whether a structure type is at least partially trasparent +(define (struct-type-any-transparent? rtd) + (or (struct-type-immediate-transparent? rtd) + (let ([p-rtd (record-type-parent rtd)]) + (and p-rtd + (struct-type-any-transparent? p-rtd))))) + +(define (default-struct-equal? s1 s2 eql?) + (let ([t1 (record-rtd (strip-impersonator s1))] + [t2 (record-rtd (strip-impersonator s2))]) + (and (eq? t1 t2) + (struct-type-transparent? t1) + (let ([n (struct-type-total*-field-count t1)]) + (let loop ([j 0]) + (if (fx= j n) + #t + (and (eql? (unsafe-struct-ref s1 j) + (unsafe-struct-ref s2 j)) + (loop (fx+ j 1))))))))) + +(define (default-struct-hash s hash-code) + (cond + [(not (impersonator? s)) + ;; Same as the loop below, but uses `unsafe-struct*-ref`: + (let ([t (record-rtd s)]) + (if (struct-type-transparent? t) + (let ([n (struct-type-total*-field-count t)]) + (let loop ([j 0] [hc 0]) + (if (fx= j n) + hc + (loop (fx+ j 1) + (hash-code-combine hc (hash-code (unsafe-struct*-ref s j))))))) + (eq-hash-code s)))] + [else + ;; Impersonator variant uses `unsafe-struct-ref` to trigger wrappers: + (let ([raw-s (impersonator-val s)]) + (let ([t (record-rtd raw-s)]) + (if (struct-type-transparent? t) + (let ([n (struct-type-total*-field-count t)]) + (let loop ([j 0] [hc 0]) + (if (fx= j n) + hc + (loop (fx+ j 1) + (hash-code-combine hc (hash-code (unsafe-struct-ref s j))))))) + (eq-hash-code raw-s))))])) + +(define struct->vector + (case-lambda + [(s dots) + (if (record? (strip-impersonator s)) + (let ([rtd (record-rtd (strip-impersonator s))]) + ;; Create that vector that has '... for opaque ranges and each field + ;; value otherwise + (let-values ([(vec-len rec-len) + ;; First, get the vector and record sizes + (let loop ([vec-len 1] [rec-len 0] [rtd rtd] [dots-already? #f]) + (cond + [(not rtd) (values vec-len rec-len)] + [else + (let ([len (#%vector-length (record-type-field-names rtd))]) + (cond + [(struct-type-immediate-transparent? rtd) + ;; A transparent region + (loop (+ vec-len len) (+ rec-len len) (record-type-parent rtd) #f)] + [dots-already? + ;; An opaque region that follows an opaque region + (loop vec-len (+ rec-len len) (record-type-parent rtd) #t)] + [else + ;; The start of opaque regions + (loop (add1 vec-len) (+ rec-len len) (record-type-parent rtd) #t)]))]))]) + ;; Walk though the record's types again, this time filling in the vector + (let ([vec (make-vector vec-len dots)]) + (vector-set! vec 0 (string->symbol (format "struct:~a" (record-type-name rtd)))) + (let loop ([vec-pos vec-len] [rec-pos rec-len] [rtd rtd] [dots-already? #f]) + (when rtd + (let* ([len (#%vector-length (record-type-field-names rtd))] + [rec-pos (- rec-pos len)]) + (cond + [(struct-type-immediate-transparent? rtd) + ;; Copy over a transparent region + (let ([vec-pos (- vec-pos len)]) + (let floop ([n 0]) + (cond + [(= n len) (loop vec-pos rec-pos (record-type-parent rtd) #f)] + [else + (vector-set! vec (+ vec-pos n) (unsafe-struct-ref s (+ rec-pos n))) + (floop (add1 n))])))] + [dots-already? + ;; Skip another opaque region + (loop vec-pos rec-pos (record-type-parent rtd) #t)] + [else + ;; The vector already has `dots` + (loop (sub1 vec-pos) rec-pos (record-type-parent rtd) #t)])))) + vec))) + ;; Any value that is not implemented as a record is treated as + ;; a fully opaque struct + (vector (string->symbol (format "struct:~a" ((inspect/object s) 'type))) dots))] + [(s) (struct->vector s '...)])) + +;; ---------------------------------------- + +(define (make-fields field-count) + (list->vector + (let loop ([i 0]) + (if (= i field-count) + '() + (cons `(mutable ,(string->symbol (format "f~a" i))) + (loop (fx1+ i))))))) + +;; ---------------------------------------- +;; Convenience for Rumble implementation: + +(define-syntax struct + (lambda (stx) + (syntax-case stx (:guard) + [(_ name (field ...)) + #'(struct name #f (field ...))] + [(_ name (field ...) :guard guard-expr) + #'(struct name #f (field ...) :guard guard-expr)] + [(_ name parent (field ...)) + #'(struct name parent (field ...) :guard #f)] + [(_ name parent (field ...) :guard guard-expr) + (let ([make-id (lambda (id fmt . args) + (datum->syntax id + (string->symbol (chez:apply format fmt args))))]) + (with-syntax ([struct:name (make-id #'name "struct:~a" (syntax->datum #'name))] + [authentic-name? (make-id #'name "authentic-~a?" (syntax->datum #'name))] + [name? (make-id #'name "~a?" (syntax->datum #'name))] + [(name-field ...) (map (lambda (field) + (make-id field "~a-~a" (syntax->datum #'name) (syntax->datum field))) + #'(field ...))] + [(field-index ...) (let loop ([fields #'(field ...)] [accum '()] [pos 0]) + (cond + [(null? fields) (reverse accum)] + [else (loop (cdr fields) (cons pos accum) (add1 pos))]))] + [struct:parent (if (syntax->datum #'parent) + (make-id #'parent "struct:~a" (syntax->datum #'parent)) + #f)]) + (with-syntax ([ctr-expr (with-syntax ([mk #'(record-constructor (make-record-constructor-descriptor struct:name #f #f))]) + (if (or (syntax->datum #'parent) (syntax->datum #'guard-expr)) + #'(struct-type-constructor-add-guards* mk struct:name guard-expr 'name) + #'mk))] + [uid (datum->syntax #'name ((current-generate-id) (syntax->datum #'name)))]) + #'(begin + (define struct:name (make-record-type-descriptor 'name struct:parent 'uid #f #f '#((immutable field) ...))) + (define name ctr-expr) + (define authentic-name? (record-predicate struct:name)) + (define name? (lambda (v) (or (authentic-name? v) + (and (impersonator? v) + (authentic-name? (impersonator-val v)))))) + (define name-field + (let ([name-field (record-accessor struct:name field-index)]) + (lambda (v) + (if (authentic-name? v) + (name-field v) + (pariah (impersonate-ref name-field struct:name field-index v)))))) + ... + (define dummy + (begin + (register-struct-constructor! name) + (register-struct-field-accessor! name-field struct:name field-index) ... + (record-type-equal-procedure struct:name default-struct-equal?) + (record-type-hash-procedure struct:name default-struct-hash) + (inspector-set! struct:name #f)))))))]))) + +(define-syntax define-struct + (lambda (stx) + (syntax-case stx () + [(_ name . rest) + (with-syntax ([make-name + (datum->syntax #'name + (string->symbol (format "make-~a" (syntax->datum #'name))))]) + #'(begin + (struct name . rest) + (define make-name name)))]))) diff -Nru racket-6.12+ppa1/src/cs/rumble/symbol.ss racket-7.0+ppa1/src/cs/rumble/symbol.ss --- racket-6.12+ppa1/src/cs/rumble/symbol.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/symbol.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,53 @@ + +(define gensym + (case-lambda + [() (chez:gensym)] + [(s) (cond + [(string? s) (chez:gensym (string->immutable-string s))] + [(symbol? s) (chez:gensym (chez:symbol->string s))] + [else (raise-argument-error + 'gensym + "(or/c symbol? string?)" + s)])])) + +(define/who (symbol-interned? s) + (check who symbol? s) + (not (gensym? s))) + +(define unreadable-unique-name "gr8mwsuasnvzbl9jjo6e9b-") + +(define/who (symbol-unreadable? s) + (check who symbol? s) + (and (gensym? s) + (equal? (gensym->unique-string s) + (string-append unreadable-unique-name (symbol->string s))))) + +(define/who (symbol->string s) + (check who symbol? s) + (string-copy (chez:symbol->string s))) + +(define/who (string->uninterned-symbol str) + (check who string? str) + (chez:gensym (string->immutable-string str))) + +(define/who (string->unreadable-symbol str) + (check who string? str) + (chez:gensym (string->immutable-string str) + (string-append unreadable-unique-name str))) + +(define/who symbolstring a) + (symbol->string b))] + [(a . as) + (check who symbol? a) + (let loop ([a a] [as as] [r #t]) + (cond + [(null? as) r] + [else + (let ([b (car as)]) + (check who symbol? b) + (loop b (cdr as) (and r (symbol (fixnum-width) 32) 64 32)] + [(gc) 'cs] + [(link) 'framework] + [(machine) "localhost info..."] + [(so-suffix) (case (machine-type) + [(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")] + [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] + [else (string->utf8 ".so")])] + [(so-mode) 'local] + [(fs-change) '#(#f #f #f #f)] + [(cross) 'infer] + [else (raise-argument-error 'system-type + (string-append + "(or/c 'os 'word 'vm 'gc 'link 'machine\n" + " 'so-suffix 'so-mode 'fs-change 'cross)") + mode)])) + +(define (system-path-convention-type) + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) 'windows] + [else 'unix])) + +(define system-library-subpath-string + (case (machine-type) + [(a6nt ta6nt) "win32\\x86_64"] + [(i3nt ti3nt) "win32\\i386"] + [(a6osx ta6osx) (if unix-style-macos? "x86_64-darwin" "x86_64-macosx")] + [(i3osx ti3osx) (if unix-style-macos? "i386-darwin" "i386-macosx")] + [(a6le ta6le) "x86_64-linux"] + [(i3le ti3le) "i386-linux"] + [(arm32le tarm32le) "arm-linux"] + [(ppc32le tppc32le) "ppc-linux"] + [(i3ob ti3ob) "i386-openbsd"] + [(a6ob ta6ob) "x86_64-openbsd"] + [(i3ob ti3ob) "i386-openbsd"] + [(a6fb ta6fb) "x86_64-freebsd"] + [(i3fb ti3fb) "i386-freebsd"] + [(a6nb ta6nb) "x86_64-netbsd"] + [(i3nb ti3nb) "i386-netbsd"] + [(a6s2 ta6s2) "x86_64-solaris"] + [(i3s2 ti3s2) "i386-solaris"] + [else "unix"])) diff -Nru racket-6.12+ppa1/src/cs/rumble/thread-cell.ss racket-7.0+ppa1/src/cs/rumble/thread-cell.ss --- racket-6.12+ppa1/src/cs/rumble/thread-cell.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/thread-cell.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +;; A "thread cell" is actually an "engine cell" at the Rumble level + +(define-record-type (thread-cell create-thread-cell thread-cell?) + (fields (mutable default-value) ; declare mutable so allocated each time + preserved?)) + +(define make-thread-cell + (case-lambda + [(v) (make-thread-cell v #f)] + [(v preserved?) (create-thread-cell v (and preserved? #t))])) + +(define/who (thread-cell-ref c) + (check who thread-cell? c) + (let* ([t (current-engine-thread-cell-values)] + [v (if t + (hashtable-ref t c none) + none)]) + (cond + [(eq? v none) + (thread-cell-default-value c)] + [else v]))) + +(define/who (thread-cell-set! c v) + (check who thread-cell? c) + (hashtable-set! (current-engine-thread-cell-values) + c + v)) + +;; ---------------------------------------- + +(define-record thread-cell-values (t)) + +(define/who current-preserved-thread-cell-values + (case-lambda + [() (make-thread-cell-values (new-engine-thread-cell-values))] + [(tcvs) + (check who thread-cell-values? tcvs) + (set-current-engine-thread-cell-values! (thread-cell-values-t tcvs))])) diff -Nru racket-6.12+ppa1/src/cs/rumble/time.ss racket-7.0+ppa1/src/cs/rumble/time.ss --- racket-6.12+ppa1/src/cs/rumble/time.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/time.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,136 @@ +(define-struct date (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset) + :guard (lambda (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + who) + (check-integer who 0 60 second) + (check-integer who 0 59 minute) + (check-integer who 0 23 hour) + (check-integer who 1 31 day) + (check-integer who 1 12 month) + (check who exact-integer? year) + (check-integer who 0 6 week-day) + (check-integer who 0 365 year-day) + (check who boolean? dst?) + (check who exact-integer? time-zone-offset) + (values second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset))) + +(define-struct date* date (nanosecond time-zone-name) + :guard (lambda (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + nanosecond + time-zone-name + who) + (check-integer who 0 999999999 nanosecond) + (check who string? time-zone-name) + (values second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + nanosecond + (string->immutable-string time-zone-name)))) + +;; Direct constructor to avoid checks: +(define make-date*/direct + (record-constructor (make-record-constructor-descriptor struct:date* #f #f))) + +(define (time->ms t) + (+ (* 1000. (time-second t)) + (/ (time-nanosecond t) 1000000.))) + +(define (time-apply f extra) + (let ([stats (statistics)]) + (call-with-values (lambda () (apply f extra)) + (lambda args + (let ([new-stats (statistics)]) + (values + args + (inexact->exact (floor (time->ms + (time-difference (sstats-cpu new-stats) + (sstats-cpu stats))))) + (inexact->exact (floor (time->ms + (time-difference (sstats-real new-stats) + (sstats-real stats))))) + (inexact->exact (floor (time->ms + (time-difference (sstats-gc-cpu new-stats) + (sstats-gc-cpu stats))))))))))) + +(define (current-gc-milliseconds) + (let ([stats (statistics)]) + (inexact->exact (floor (time->ms (sstats-gc-cpu stats)))))) + +(define (current-milliseconds) + (inexact->exact (floor (current-inexact-milliseconds)))) + +(define (current-inexact-milliseconds) + (time->ms (current-time 'time-utc))) + +(define (current-seconds) + (let ((t (current-time 'time-utc))) + (time-second t))) + +(define/who seconds->date + (case-lambda + [(s) (seconds->date s #t)] + [(s local?) + (check who real? s) + (let* ([s (inexact->exact s)] + [tm (make-time 'time-utc + (floor (* (- s (floor s)) 1000000000)) + (floor s))] + [d (if local? + (time-utc->date tm) + (time-utc->date tm 0))]) + (make-date*/direct (chez:date-second d) + (chez:date-minute d) + (chez:date-hour d) + (chez:date-day d) + (chez:date-month d) + (chez:date-year d) + (chez:date-week-day d) + (chez:date-year-day d) + (chez:date-dst? d) + (date-zone-offset d) + (date-nanosecond d) + (or (date-zone-name d) utc-string)))])) + +(define utc-string (string->immutable-string "UTC")) diff -Nru racket-6.12+ppa1/src/cs/rumble/unsafe.ss racket-7.0+ppa1/src/cs/rumble/unsafe.ss --- racket-6.12+ppa1/src/cs/rumble/unsafe.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/unsafe.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,147 @@ +(define unsafe-car #3%car) +(define unsafe-cdr #3%cdr) +(define unsafe-list-tail #3%list-tail) +(define unsafe-list-ref #3%list-ref) + +(define unsafe-fx+ #3%fx+) +(define unsafe-fx- #3%fx-) +(define unsafe-fx* #3%fx*) +(define unsafe-fxquotient #3%fxquotient) +(define unsafe-fxremainder #3%fxremainder) +(define unsafe-fxmodulo #3%fxmodulo) +(define unsafe-fxabs #3%fxabs) +(define unsafe-fxand #3%fxand) +(define unsafe-fxior #3%fxior) +(define unsafe-fxxor #3%fxxor) +(define unsafe-fxnot #3%fxnot) +(define unsafe-fxrshift #3%fxarithmetic-shift-right) +(define unsafe-fxlshift #3%fxarithmetic-shift-left) + +(define unsafe-fx= #3%fx=) +(define unsafe-fx< #3%fx<) +(define unsafe-fx> #3%fx>) +(define unsafe-fx>= #3%fx>=) +(define unsafe-fx<= #3%fx<=) +(define unsafe-fxmin #3%fxmin) +(define unsafe-fxmax #3%fxmax) + +(define unsafe-fl+ #3%fl+) +(define unsafe-fl- #3%fl-) +(define unsafe-fl* #3%fl*) +(define unsafe-fl/ #3%fl/) +(define unsafe-flabs #3%flabs) + +(define unsafe-fl= #3%fl=) +(define unsafe-fl< #3%fl<) +(define unsafe-fl> #3%fl>) +(define unsafe-fl>= #3%fl>=) +(define unsafe-fl<= #3%fl<=) +(define unsafe-flmin #3%flmin) +(define unsafe-flmax #3%flmax) + +(define unsafe-fx->fl #3%fixnum->flonum) +(define unsafe-fl->fx #3%flonum->fixnum) + +(define unsafe-flround #3%flround) +(define unsafe-flfloor #3%flfloor) +(define unsafe-flceiling #3%flceiling) +(define unsafe-fltruncate #3%fltruncate) + +(define unsafe-flsin #3%flsin) +(define unsafe-flcos #3%flcos) +(define unsafe-fltan #3%fltan) +(define unsafe-flasin #3%flasin) +(define unsafe-flacos #3%flacos) +(define unsafe-flatan #3%flatan) +(define unsafe-fllog #3%fllog) +(define unsafe-flexp #3%flexp) +(define unsafe-flsqrt #3%flsqrt) +(define unsafe-flexpt #3%flexpt) + +(define (unsafe-flrandom gen) (random gen)) + +(define unsafe-vector*-length #3%vector-length) +(define unsafe-vector*-ref #3%vector-ref) +(define unsafe-vector*-set! #3%vector-set!) +(define unsafe-vector*-cas! #3%vector-cas!) + +(define unsafe-unbox* #3%unbox) +(define unsafe-set-box*! #3%set-box!) +(define unsafe-box*-cas! #3%box-cas!) + +(define unsafe-bytes-length #3%bytevector-length) +(define unsafe-bytes-ref #3%bytevector-u8-ref) +(define unsafe-bytes-set! #3%bytevector-u8-set!) + +(define unsafe-string-length #3%string-length) +(define unsafe-string-ref #3%string-ref) +(define unsafe-string-set! #3%string-set!) + +(define unsafe-fxvector-length #3%fxvector-length) +(define unsafe-fxvector-ref #3%fxvector-ref) +(define unsafe-fxvector-set! #3%fxvector-set!) + +(define (unsafe-s16vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-s16-native-ref mem k) + (foreign-ref 'int16 mem k)))) +(define (unsafe-s16vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-s16-native-set! mem k v) + (foreign-set! 'int16 mem k v)))) + +(define (unsafe-u16vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-u16-native-ref mem k) + (foreign-ref 'uint16 mem k)))) +(define (unsafe-u16vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-u16-native-set! mem k v) + (foreign-set! 'uint16 mem k v)))) + +(define (unsafe-f64vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-ref mem k) + (foreign-ref 'double mem k)))) +(define (unsafe-f64vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-set! mem k v) + (foreign-set! 'double mem k v)))) + +;; FIXME +(define (unsafe-f80vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-ref mem k) + (foreign-ref 'double mem k)))) +(define (unsafe-f80vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-set! mem k v) + (foreign-set! 'double mem k v)))) + +(define (unsafe-make-flrectangular r i) + (#3%make-rectangular r i)) +(define (unsafe-flreal-part c) + (#3%real-part c)) +(define (unsafe-flimag-part c) + (#3%imag-part c)) + +(define unsafe-undefined (let ([p (make-record-type "undefined" '())]) + ((record-constructor p)))) + +(define (check-not-unsafe-undefined v sym) + (when (eq? v unsafe-undefined) + (raise-arguments-error sym "undefined;\n cannot use before initialization")) + v) + +(define (check-not-unsafe-undefined/assign v sym) + (when (eq? v unsafe-undefined) + (raise-arguments-error sym "assignment disallowed;\n cannot assign before initialization")) + v) diff -Nru racket-6.12+ppa1/src/cs/rumble/variable.ss racket-7.0+ppa1/src/cs/rumble/variable.ss --- racket-6.12+ppa1/src/cs/rumble/variable.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/variable.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +;; A "variable" is a linklet import or export + +(define undefined (gensym "undefined")) + +(define-record-type variable (fields (mutable val) name)) + +(define (variable-set! var val) + (variable-val-set! var val)) + +(define (variable-ref var) + (define v (variable-val var)) + (if (eq? v undefined) + (raise-undefined var) + v)) + +(define (raise-undefined var) + (raise + (|#%app| + exn:fail:contract:variable + (string-append (symbol->string (variable-name var)) + ": undefined;\n cannot reference undefined identifier") + (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/src/cs/rumble/vector.ss racket-7.0+ppa1/src/cs/rumble/vector.ss --- racket-6.12+ppa1/src/cs/rumble/vector.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/vector.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,400 @@ +(define (vector-immutable . args) + (if (null? args) + (vector->immutable-vector '#()) + (let ([vec (apply vector args)]) + (#%$vector-set-immutable! vec) + vec))) + +;; ---------------------------------------- + +(define (vector? v) + (or (#%vector? v) + (and (impersonator? v) + (#%vector? (impersonator-val v))))) + +(define (mutable-vector? v) + (or (#%mutable-vector? v) + (and (impersonator? v) + (#%mutable-vector? (impersonator-val v))))) + +;; ---------------------------------------- + +(define-record vector-chaperone chaperone (ref set)) +(define-record vector-impersonator impersonator (ref set)) + +(define/who (chaperone-vector vec ref set . props) + (check who vector? vec) + (do-impersonate-vector who make-vector-chaperone vec ref set + make-props-chaperone props)) + +(define/who (impersonate-vector vec ref set . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (do-impersonate-vector who make-vector-impersonator vec ref set + make-props-impersonator props)) + +(define (do-impersonate-vector who make-vector-impersonator vec ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 3) :or-false ref) + (check who (procedure-arity-includes/c 3) :or-false set) + (check-vector-wrapper-consistent who ref set) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (if (or ref set) + (make-vector-impersonator val vec props ref set) + (make-props-impersonator val vec props)))) + +(define (set-vector-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor vector-chaperone) + (lambda (c hash-code) + (hash-code (vector-copy c)))) + (record-type-hash-procedure (record-type-descriptor vector-impersonator) + (lambda (i hash-code) + (hash-code (vector-copy i))))) + +(define (check-vector-wrapper-consistent who ref set) + (unless (eq? (not ref) (not set)) + (raise-arguments-error who + "accessor and mutator wrapper must be both `#f` or neither `#f`" + "accessor wrapper" ref + "mutator wrapper" set))) + +;; ---------------------------------------- + +(define-record vector*-chaperone vector-chaperone ()) +(define-record vector*-impersonator vector-impersonator ()) + +(define/who (chaperone-vector* vec ref set . props) + (check who vector? vec) + (do-impersonate-vector* who make-vector*-chaperone vec ref set + make-props-chaperone props)) + +(define/who (impersonate-vector* vec ref set . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (do-impersonate-vector* who make-vector*-impersonator vec ref set + make-props-impersonator props)) + +(define (do-impersonate-vector* who make-vector*-impersonator vec ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 4) :or-false ref) + (check who (procedure-arity-includes/c 4) :or-false set) + (check-vector-wrapper-consistent who ref set) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (if (or ref set) + (make-vector*-impersonator val vec props ref set) + (make-props-impersonator val vec props)))) + +;; ---------------------------------------- + +(define-record vector-unsafe-chaperone chaperone (vec)) +(define-record vector-unsafe-impersonator impersonator (vec)) + +(define/who (unsafe-impersonate-vector vec alt-vec . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (check who (lambda (p) (and (vector? p) (not (impersonator? p)))) + :contract "(and/c vector? (not/c impersonator?))" + alt-vec) + (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props)) + +(define/who (unsafe-chaperone-vector vec alt-vec . props) + (check who vector? vec) + (check who (lambda (p) (and (vector? p) (not (impersonator? p)))) + :contract "(and/c vector? (not/c impersonator?))" + alt-vec) + (do-unsafe-impersonate-vector who make-vector-unsafe-chaperone vec alt-vec props)) + +(define (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (make-vector-unsafe-impersonator val vec props alt-vec))) + +;; ---------------------------------------- + +(define (vector-length vec) + (if (#%vector? vec) + (#3%vector-length vec) + (pariah (impersonate-vector-length vec)))) + +(define (unsafe-vector-length vec) + (vector-length vec)) + +(define (vector*-length vec) + (#2%vector-length vec)) + +(define (impersonate-vector-length vec) + (if (and (impersonator? vec) + (#%vector? (impersonator-val vec))) + (cond + [(vector-unsafe-chaperone? vec) + (#%vector-length (vector-unsafe-chaperone-vec vec))] + [(vector-unsafe-impersonator? vec) + (#%vector-length (vector-unsafe-impersonator-vec vec))] + [else + (#%vector-length (impersonator-val vec))]) + ;; Let primitive report the error: + (#2%vector-length vec))) + +;; ---------------------------------------- + +(define (vector-ref vec idx) + (if (#%vector? vec) + (#2%vector-ref vec idx) + (pariah (impersonate-vector-ref vec idx)))) + +(define (unsafe-vector-ref vec idx) + (if (#%vector? vec) + (#3%vector-ref vec idx) + (pariah (impersonate-vector-ref vec idx)))) + +(define (vector*-ref vec idx) + (#2%vector-ref vec idx)) + +(define (impersonate-vector-ref orig idx) + (if (and (impersonator? orig) + (#%vector? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%vector? o) (#%vector-ref o idx)] + [(vector-chaperone? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)] + [new-val (if (vector*-chaperone? o) + ((vector-chaperone-ref o) orig o-next idx val) + ((vector-chaperone-ref o) o-next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-ref + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(vector-impersonator? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)]) + (if (vector*-impersonator? o) + ((vector-impersonator-ref o) orig o-next idx val) + ((vector-impersonator-ref o) o-next idx val)))] + [(vector-unsafe-impersonator? o) + (vector-ref (vector-unsafe-impersonator-vec o) idx)] + [(vector-unsafe-chaperone? o) + (vector-ref (vector-unsafe-chaperone-vec o) idx)] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%vector-ref orig idx))) + +;; ---------------------------------------- + +(define (vector-set! vec idx val) + (if (#%vector? vec) + (#2%vector-set! vec idx val) + (pariah (impersonate-vector-set! vec idx val)))) + +(define (unsafe-vector-set! vec idx val) + (if (#%vector? vec) + (#3%vector-set! vec idx val) + (pariah (impersonate-vector-set! vec idx val)))) + +(define (vector*-set! vec idx val) + (#2%vector-set! vec idx val)) + +(define (impersonate-vector-set! orig idx val) + (cond + [(not (and (impersonator? orig) + (mutable-vector? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%vector-set! orig idx val)] + [(or (not (exact-nonnegative-integer? idx)) + (>= idx (vector-length (impersonator-val orig)))) + ;; Let primitive report the index error: + (#2%vector-set! (impersonator-val orig) idx val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%vector? o) (#2%vector-set! o idx val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(vector-chaperone? o) + (let ([new-val (if (vector*-chaperone? o) + ((vector-chaperone-set o) orig next idx val) + ((vector-chaperone-set o) next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-set! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(vector-impersonator? o) + (loop next + (if (vector*-impersonator? o) + ((vector-impersonator-set o) orig next idx val) + ((vector-impersonator-set o) next idx val)))] + [(vector-unsafe-impersonator? o) + (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] + [(vector-unsafe-chaperone? o) + (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)] + [else (loop next val)]))]))])) + +;; ---------------------------------------- + +(define/who (vector->list vec) + (cond + [(#%vector? vec) + (#3%vector->list vec)] + [(vector? vec) + (let ([len (vector-length vec)]) + (let loop ([i len] [accum '()]) + (cond + [(fx= i 0) accum] + [else + (let ([i (fx- i 1)]) + (loop i (cons (vector-ref vec i) accum)))])))] + [else + (raise-argument-error who "vector?" vec)])) + +;; ---------------------------------------- + +(define/who (vector-copy vec) + (cond + [(#%vector? vec) + (#3%vector-copy vec)] + [(vector? vec) + (let* ([len (vector-length vec)] + [vec2 (make-vector len)]) + (vector-copy! vec2 0 vec) + vec2)] + [else + (raise-argument-error who "vector?" vec)])) + +(define/who vector-copy! + (case-lambda + [(dest d-start src) + (vector-copy! dest d-start src 0 (and (vector? src) (vector-length src)))] + [(src s-start dest d-start) + (vector-copy! dest d-start src s-start (and (vector? src) (vector-length src)))] + [(dest d-start src s-start s-end) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who vector? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (vector-length dest)]) + (check-range who "vector" dest d-start #f d-len) + (check-range who "vector" src s-start s-end (vector-length src)) + (let ([len (fx- s-end s-start)]) + (check-space who "vector" d-start d-len len) + (cond + [(and (#%vector? src) (#%vector? dest)) + (vector*-copy! dest d-start src s-start s-end)] + [(and (eq? (strip-impersonator dest) + (strip-impersonator src)) + (< d-start s-start)) + ;; Need to copy from low to high to be memmove-like + (let loop ([i 0]) + (unless (fx= i len) + (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i))) + (loop (fx+ i 1))))] + [else + (let loop ([i len]) + (unless (fx= 0 i) + (let ([i (fx1- i)]) + (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i))) + (loop i))))])))])) + +;; Like `vector-copy!`, but doesn't work on impersonators, and doesn't +;; add its own tests on the vector or range (so unsafe if Rumble is +;; compiled as unsafe) +(define/who vector*-copy! + (case-lambda + [(dest dest-start src) + (vector*-copy! dest dest-start src 0 (#%vector-length src))] + [(src src-start dest dest-start) + (vector*-copy! dest dest-start src src-start (#%vector-length src))] + [(dest dest-start src src-start src-end) + (let ([len (fx- src-end src-start)]) + (cond + [(and (eq? (strip-impersonator dest) + (strip-impersonator src)) + (< dest-start src-start)) + ;; Need to copy from low to high to be memmove-like + (let loop ([i 0]) + (unless (fx= len i) + (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i))) + (loop (fx+ i 1))))] + [else + (let loop ([i len]) + (unless (fx= 0 i) + (let ([i (fx1- i)]) + (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i))) + (loop i))))]))])) + +(define/who vector->values + (case-lambda + [(vec) + (check who vector? vec) + (let ([len (vector-length vec)]) + (cond + [(fx= len 0) (values)] + [(fx= len 1) (vector-ref vec 0)] + [(fx= len 2) (values (vector-ref vec 0) (vector-ref vec 1))] + [(fx= len 3) (values (vector-ref vec 0) (vector-ref vec 1) (vector-ref vec 2))] + [else (chez:apply values (vector->list vec))]))] + [(vec start) + (vector->values vec start (and (vector? vec) (vector-length vec)))] + [(vec start end) + (check who vector? vec) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "vector" vec start end (vector-length vec)) + (chez:apply values + (let loop ([start start]) + (cond + [(fx= start end) null] + [else (cons (vector-ref vec start) + (loop (fx1+ start)))])))])) + +(define/who (vector-fill! vec v) + (cond + [(#%vector? vec) + (#3%vector-fill! vec v)] + [(vector? vec) + (check who mutable-vector? :contract "(and/c vector? (not immutable?))" v) + (let ([len (vector-length vec)]) + (let loop ([i 0]) + (unless (= i len) + (vector-set! vec i v) + (loop (fx1+ i)))))] + [else + (raise-argument-error who "vector?" vec)])) + +(define/who (vector->immutable-vector v) + (cond + [(#%vector? v) + (#3%vector->immutable-vector v)] + [(vector? v) + (if (mutable-vector? v) + (#3%vector->immutable-vector + (vector-copy v)) + v)] + [else + (raise-argument-error who "vector?" v)])) + +(define shared-fxvector fxvector) +(define make-shared-fxvector make-fxvector) diff -Nru racket-6.12+ppa1/src/cs/rumble/version.ss racket-7.0+ppa1/src/cs/rumble/version.ss --- racket-6.12+ppa1/src/cs/rumble/version.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/version.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,25 @@ + +(define-syntax (extract-version-string stx) + (chez:call-with-input-file + "../racket/src/schvers.h" + (lambda (i) + (let ([to-find "#define MZSCHEME_VERSION \""]) + (let loop ([pos 0]) + (cond + [(= pos (string-length to-find)) + (list->string + (let loop () + (let ([ch (chez:read-char i)]) + (if (char=? ch #\") + '() + (cons ch (loop))))))] + [else + (let ([ch (chez:read-char i)]) + (cond + [(char=? ch (string-ref to-find pos)) + (loop (add1 pos))] + [else + (loop 0)]))])))))) + +(define (version) (extract-version-string)) +(define (banner) (string-append "Welcome to Racket " (version) "\n")) diff -Nru racket-6.12+ppa1/src/cs/rumble/virtual-register.ss racket-7.0+ppa1/src/cs/rumble/virtual-register.ss --- racket-6.12+ppa1/src/cs/rumble/virtual-register.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/virtual-register.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +;; We get a small number of virtual registers for fast, +;; pthread-specific bindings. + +;; The last virtual register is reserved for use by the thread system +(meta define num-reserved-virtual-registers 1) + +(meta define virtual-register-initial-values '()) + +(define-syntax (define-virtual-register stx) + (syntax-case stx () + [(_ id init-val) + (with-syntax ([pos (datum->syntax #'here (length virtual-register-initial-values))]) + (set! virtual-register-initial-values (cons #'init-val virtual-register-initial-values)) + (when (>= (length virtual-register-initial-values) (- (virtual-register-count) + num-reserved-virtual-registers)) + (syntax-error stx "too many virtual-register definitions:")) + #`(define-syntax id + (syntax-rules () + [(_) (virtual-register pos)] + [(_ v) (set-virtual-register! pos v)])))])) + +(define-syntax (define-virtual-registers-init stx) + (syntax-case stx () + [(_ id) + (with-syntax ([(init ...) + (let loop ([l (reverse virtual-register-initial-values)] + [pos 0]) + (cond + [(null? l) '()] + [else (cons (with-syntax ([pos (datum->syntax #'here pos)] + [init (car l)]) + #'(set-virtual-register! pos init)) + (loop (cdr l) (add1 pos)))]))]) + #'(define (id) init ...))])) diff -Nru racket-6.12+ppa1/src/cs/rumble/will-executor.ss racket-7.0+ppa1/src/cs/rumble/will-executor.ss --- racket-6.12+ppa1/src/cs/rumble/will-executor.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble/will-executor.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,93 @@ + +;; Implements a variant of will executors with polling and a callback +;; for when a will becomes ready + +(define the-will-guardian (make-guardian)) +(define the-stubborn-will-guardian (make-guardian #t)) + +;; Guardian callbacks are called fifo, but will executors are called +;; lifo. The `will-stacks` tables map a finalized value to a list +;; of finalizers, where each finalizer is an ephemeron pairing a will +;; executor with a will function (so that the function is not retained +;; if the will executor is dropped) +(define the-will-stacks (make-weak-eq-hashtable)) +(define the-stubborn-will-stacks (make-weak-eq-hashtable)) + +(define-record-type (will-executor create-will-executor will-executor?) + (fields guardian will-stacks (mutable ready) notify)) + +(define (make-will-executor notify) + (create-will-executor the-will-guardian the-will-stacks '() notify)) + +;; A "stubborn" will executor corresponds to an ordered guardian. It +;; doesn't need to make any guarantees about order for multiple +;; registrations, so use a fresh guardian each time. +(define (make-stubborn-will-executor notify) + (create-will-executor the-stubborn-will-guardian the-stubborn-will-stacks '() notify)) + +(define/who (will-register executor v proc) + (check who will-executor? executor) + (check who (procedure-arity-includes/c 1) proc) + (disable-interrupts) + (let ([l (hashtable-ref (will-executor-will-stacks executor) v '())] + ;; By using an ephemeron pair, if the excutor becomes + ;; unreachable, then we can drop the finalizer procedure. That + ;; pattern prevents unbreakable cycles by an untrusted process + ;; that has no access to a will executor that outlives the + ;; process. + [e+proc (ephemeron-cons executor proc)]) + (hashtable-set! (will-executor-will-stacks executor) v (cons e+proc l)) + (when (null? l) + ((will-executor-guardian executor) v))) + (enable-interrupts) + (void)) + +;; Returns #f or a pair: procedure and value +(define/who (will-try-execute executor) + (check who will-executor? executor) + (disable-interrupts) + (poll-guardian (will-executor-guardian executor) + (will-executor-will-stacks executor)) + (let ([l (will-executor-ready executor)]) + (cond + [(pair? l) + (will-executor-ready-set! executor (cdr l)) + (enable-interrupts) + (car l)] + [else + (enable-interrupts) + #f]))) + +;; Call with interrupts disabled or from the thread scheduler +(define (poll-guardian guardian will-stacks) + ;; Poll the guardian (which is shared among will executors) + ;; for ready values, and add any ready value to the receiving will + ;; executor + (let loop () + (let ([v (guardian)]) + (when v + (let we-loop ([l (hashtable-ref will-stacks v '())]) + (when (pair? l) + (let* ([e+proc (car l)] + [e (car e+proc)] + [proc (cdr e+proc)] + [l (cdr l)]) + (cond + [(eq? #!bwp e) + ;; The will executor became inaccesible, so continue looking + (we-loop l)] + [else + (cond + [(null? l) + (hashtable-delete! will-stacks v)] + [else + ;; Re-finalize for the next will registration + (hashtable-set! will-stacks v l) + (guardian v)]) + ((will-executor-notify e)) + (will-executor-ready-set! e (cons (cons proc v) (will-executor-ready e)))])))) + (loop))))) + +(define (poll-will-executors) + (poll-guardian the-will-guardian the-will-stacks) + (poll-guardian the-stubborn-will-guardian the-stubborn-will-stacks)) diff -Nru racket-6.12+ppa1/src/cs/rumble.sls racket-7.0+ppa1/src/cs/rumble.sls --- racket-6.12+ppa1/src/cs/rumble.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/rumble.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,739 @@ +(library (rumble) + (export version + banner + + null eof void void? + + begin0 + + dynamic-wind + call-with-current-continuation + call-with-composable-continuation + call-with-escape-continuation + continuation? + + make-continuation-prompt-tag + continuation-prompt-tag? + default-continuation-prompt-tag + root-continuation-prompt-tag + call-with-continuation-prompt + call-with-continuation-barrier + abort-current-continuation + continuation-prompt-available? + impersonate-prompt-tag + chaperone-prompt-tag + (rename [break-enabled-key rumble:break-enabled-key]) + set-break-enabled-transition-hook! ; not exported to Racket + unsafe-abort-current-continuation/no-wind + unsafe-call-with-composable-continuation/no-wind + + with-continuation-mark + call/cm ; not exported to Racket + call-with-immediate-continuation-mark + continuation-mark-set-first + continuation-mark-set->list + continuation-mark-set->list* + continuation-mark-set->context + current-continuation-marks + (rename [continuation-marks rumble:continuation-marks]) ; wrapped at threads layer + continuation-mark-set? + make-continuation-mark-key + continuation-mark-key? + impersonate-continuation-mark-key + chaperone-continuation-mark-key + call-with-system-wind ; not exported to Racket + + make-engine + engine-block + engine-return + current-engine-state ; not exported to Racket + set-ctl-c-handler! ; not exported to Racket + get-ctl-c-handler ; not exported to Racket + set-scheduler-lock-callbacks! ; not exported to Racket + set-scheduler-atomicity-callbacks! ; not exported to Racket + set-engine-exit-handler! ; not exported to Racket + + make-thread-cell + thread-cell? + thread-cell-ref + thread-cell-set! + current-preserved-thread-cell-values + thread-cell-values? + + parameterization-key + make-parameter + make-derived-parameter + parameter? + extend-parameterization + parameterization? + parameter-procedure=? + reparameterize + + raise + error-print-width + error-value->string-handler + error-print-context-length + exception-handler-key + uncaught-exception-handler + error-display-handler + error-escape-handler + register-linklet-instantiate-continuation! ; not exported to Racket + set-error-display-eprintf! ; not exported to Racket + set-log-system-message! ; not exported to Racket + + current-inspector + make-inspector + make-sibling-inspector + current-code-inspector + + struct:exn exn exn? exn-message exn-continuation-marks + struct:exn:break exn:break exn:break? exn:break-continuation + struct:exn:break:hang-up exn:break:hang-up exn:break:hang-up? + struct:exn:break:terminate exn:break:terminate exn:break:terminate? + struct:exn:fail exn:fail exn:fail? + struct:exn:fail:contract exn:fail:contract exn:fail:contract? + struct:exn:fail:contract:arity exn:fail:contract:arity exn:fail:contract:arity? + struct:exn:fail:contract:divide-by-zero exn:fail:contract:divide-by-zero exn:fail:contract:divide-by-zero? + struct:exn:fail:contract:non-fixnum-result exn:fail:contract:non-fixnum-result exn:fail:contract:non-fixnum-result? + struct:exn:fail:contract:continuation exn:fail:contract:continuation exn:fail:contract:continuation? + struct:exn:fail:contract:variable exn:fail:contract:variable exn:fail:contract:variable? exn:fail:contract:variable-id + struct:exn:fail:read exn:fail:read exn:fail:read? exn:fail:read-srclocs + struct:exn:fail:read:eof exn:fail:read:eof exn:fail:read:eof? + struct:exn:fail:read:non-char exn:fail:read:non-char exn:fail:read:non-char? + struct:exn:fail:filesystem exn:fail:filesystem exn:fail:filesystem? + struct:exn:fail:filesystem:exists exn:fail:filesystem:exists exn:fail:filesystem:exists? + struct:exn:fail:filesystem:version exn:fail:filesystem:version exn:fail:filesystem:version? + struct:exn:fail:filesystem:errno exn:fail:filesystem:errno exn:fail:filesystem:errno? exn:fail:filesystem:errno-errno + struct:exn:fail:network exn:fail:network exn:fail:network? + struct:exn:fail:network:errno exn:fail:network:errno exn:fail:network:errno? exn:fail:network:errno-errno + struct:exn:fail:out-of-memory exn:fail:out-of-memory exn:fail:out-of-memory? + struct:exn:fail:unsupported exn:fail:unsupported exn:fail:unsupported? + struct:exn:fail:user exn:fail:user exn:fail:user? + + struct:srcloc srcloc srcloc? + srcloc-source srcloc-line srcloc-column srcloc-position srcloc-span + prop:exn:srclocs exn:srclocs? exn:srclocs-accessor + + struct:date date? date make-date + date-second date-minute date-hour date-day date-month date-year + date-week-day date-year-day date-dst? date-time-zone-offset + + struct:date* date*? date* make-date* + date*-nanosecond date*-time-zone-name + + struct:arity-at-least arity-at-least arity-at-least? + arity-at-least-value + + prop:procedure + prop:incomplete-arity + prop:method-arity-error + prop:arity-string + apply + procedure? + procedure-specialize + |#%app| + |#%call-with-values| + extract-procedure ; not exported to Racket + procedure-arity-includes? + procedure-arity + procedure-result-arity + procedure-extract-target + procedure-closure-contents-eq? + procedure-reduce-arity + procedure-rename + procedure->method + procedure-arity? + prop:checked-procedure + checked-procedure-check-and-extract + primitive? + primitive-closure? + primitive-result-arity + make-jit-procedure ; not exported to racket + + equal? + equal?/recur + + impersonator? + chaperone? + impersonator-of? + chaperone-of? + impersonator-val ; not exported to Racket + impersonate-ref ; not exported to Racket + impersonate-set! ; not exported to Racket + impersonator-property? + make-impersonator-property + impersonator-property-accessor-procedure? + impersonator-ephemeron + prop:impersonator-of + + impersonate-procedure + chaperone-procedure + impersonate-procedure* + chaperone-procedure* + procedure-impersonator*? + impersonator-prop:application-mark + unsafe-impersonate-procedure + unsafe-chaperone-procedure + + raise-argument-error + raise-arguments-error + raise-result-error + raise-mismatch-error + raise-range-error + raise-arity-error + raise-result-arity-error + raise-type-error + raise-binding-result-arity-error ; not exported to Racket + + (rename [make-unquoted-printing-string unquoted-printing-string]) + unquoted-printing-string? + unquoted-printing-string-value + + make-struct-type-property + struct-type-property? + struct-type-property-accessor-procedure? + make-struct-type + struct-type-install-properties! ; not exported to Racket + structure-type-lookup-prefab-uid ; not exported to Racket + make-struct-field-accessor + make-struct-field-mutator + struct-type-constructor-add-guards ; not exported to Racket + register-struct-constructor! ; not exported to Racket + register-struct-predicate! ; not exported to Racket + register-struct-field-accessor! ; not exported to Racket + register-struct-field-mutator! ; not exported to Racket + struct-property-set! ; not exported to Racket + struct-constructor-procedure? + struct-predicate-procedure? + struct-accessor-procedure? + struct-mutator-procedure? + struct? + struct-type? + procedure-struct-type? + struct-type-info + struct-info + struct-type-make-constructor + struct-type-make-predicate + struct->vector + prefab-key? + prefab-struct-key + prefab-key->struct-type + make-prefab-struct + prop:authentic + prop:equal+hash + inspector? + inspector-superior? + impersonate-struct + chaperone-struct + chaperone-struct-unsafe-undefined + prop:chaperone-unsafe-undefined + chaperone-struct-type + + prop:object-name + object-name + + eq-hash-code + eqv-hash-code + equal-hash-code + equal-secondary-hash-code + + hash hasheqv hasheq + make-hash make-hasheqv make-hasheq + make-immutable-hash make-immutable-hasheqv make-immutable-hasheq + make-weak-hash make-weak-hasheq make-weak-hasheqv + hash-ref hash-set hash-set! hash-remove hash-remove! + hash-for-each hash-map hash-copy hash-clear hash-clear! + hash-iterate-first hash-iterate-next + hash-iterate-key hash-iterate-value + hash-iterate-key+value hash-iterate-pair + unsafe-immutable-hash-iterate-first unsafe-immutable-hash-iterate-next + unsafe-immutable-hash-iterate-key unsafe-immutable-hash-iterate-value + unsafe-immutable-hash-iterate-key+value unsafe-immutable-hash-iterate-pair + unsafe-mutable-hash-iterate-first unsafe-mutable-hash-iterate-next + unsafe-mutable-hash-iterate-key unsafe-mutable-hash-iterate-value + unsafe-mutable-hash-iterate-key+value unsafe-mutable-hash-iterate-pair + unsafe-weak-hash-iterate-first unsafe-weak-hash-iterate-next + unsafe-weak-hash-iterate-key unsafe-weak-hash-iterate-value + unsafe-weak-hash-iterate-key+value unsafe-weak-hash-iterate-pair + + hash? hash-eq? hash-equal? hash-eqv? hash-weak? immutable-hash? + hash-count + hash-keys-subset? + + datum-intern-literal + set-intern-regexp?! ; not exported to racket + + impersonate-hash + chaperone-hash + + true-object? + + bytes shared-bytes + bytes? + bytes-length + make-bytes make-shared-bytes + bytes-ref bytes-set! + bytes->list list->bytes + bytes->immutable-bytes + bytes-copy! bytes-copy bytes-fill! + bytes=? bytes? bytes<=? bytes>=? + bytes-append + subbytes + + string-copy! + substring + + char-blank? + char-iso-control? + char-punctuation? + char-graphic? + char-symbolic? + interned-char? + make-known-char-range-list + char-general-category + + gensym + symbol-interned? + symbol-unreadable? + string->uninterned-symbol + string->unreadable-symbol + symbol->string + + list? + list-pair? + (rename [|#%map| map] + [|#%for-each| for-each] + [|#%andmap| andmap] + [|#%ormap| ormap]) + + vector? + mutable-vector? + (rename [inline:vector-length vector-length] + [inline:vector-ref vector-ref] + [inline:vector-set! vector-set!]) + vector-copy + vector-copy! + vector-immutable + vector->values + vector-fill! + vector->immutable-vector + vector->list + vector*-length + vector*-ref + vector*-set! + + impersonate-vector + impersonate-vector* + chaperone-vector + chaperone-vector* + unsafe-impersonate-vector + unsafe-chaperone-vector + + box? + (rename [inline:unbox unbox] + [inline:set-box! set-box!]) + unbox* set-box*! + make-weak-box weak-box? weak-box-value + impersonate-box + chaperone-box + unbox/check-undefined ; not exported to Racket + set-box!/check-undefined ; not exported to Racket + + immutable? + + keyword? + keyword->string + string->keyword + keyworddouble-flonum + real->single-flonum + arithmetic-shift + integer-sqrt + integer-sqrt/remainder + integer->integer-bytes + integer-bytes->integer + real->floating-point-bytes + floating-point-bytes->real + system-big-endian? + string->number + number->string + quotient/remainder + fx->fl + fxrshift + fxlshift + fl->fx + ->fl + fl->exact-integer + flreal-part + flimag-part + make-flrectangular + gcd + lcm + + random + random-seed + pseudo-random-generator? + make-pseudo-random-generator + current-pseudo-random-generator + vector->pseudo-random-generator + vector->pseudo-random-generator! + pseudo-random-generator->vector + pseudo-random-generator-vector? + + mpair? + mcons + (rename [inline:mcar mcar] + [inline:mcdr mcdr] + [inline:set-mcar! set-mcar!] + [inline:set-mcdr! set-mcdr!]) + + flvector? + (rename [new-flvector flvector]) + make-flvector + flvector-length + flvector-ref + flvector-set! + flvector-copy + shared-flvector + make-shared-flvector + unsafe-flvector-length + unsafe-flvector-set! + unsafe-flvector-ref + + shared-fxvector + make-shared-fxvector + + correlated? + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span + correlated-e + correlated->datum + datum->correlated + correlated-property + correlated-property-symbol-keys + + make-reader-graph + make-placeholder + placeholder? + placeholder-set! + placeholder-get + hash-placeholder? + make-hash-placeholder + make-hasheq-placeholder + make-hasheqv-placeholder + + time-apply + current-inexact-milliseconds + current-milliseconds + current-gc-milliseconds + current-seconds + seconds->date + + collect-garbage + current-memory-use + dump-memory-stats + phantom-bytes? + make-phantom-bytes + set-phantom-bytes! + set-garbage-collect-notify! ; not exported to Racket + + ;; not the same as Racket will executors: + (rename + [make-will-executor rumble:make-will-executor] + [make-stubborn-will-executor rumble:make-stubborn-will-executor] + [will-executor? rumble:will-executor?] + [will-register rumble:will-register] + [will-try-execute rumble:will-try-execute]) + poll-will-executors ; not exported to Racket + + make-ephemeron + ephemeron? + ephemeron-value + + system-type + system-path-convention-type + system-library-subpath-string ; not exported to Racket + + unsafe-car + unsafe-cdr + unsafe-list-tail + unsafe-list-ref + unsafe-cons-list + + unsafe-fx+ + unsafe-fx- + unsafe-fx* + unsafe-fxquotient + unsafe-fxremainder + unsafe-fxmodulo + unsafe-fxabs + unsafe-fxand + unsafe-fxior + unsafe-fxxor + unsafe-fxnot + unsafe-fxrshift + unsafe-fxlshift + + unsafe-fx= + unsafe-fx< + unsafe-fx> + unsafe-fx>= + unsafe-fx<= + unsafe-fxmin + unsafe-fxmax + + unsafe-fl+ + unsafe-fl- + unsafe-fl* + unsafe-fl/ + unsafe-flabs + + unsafe-fl= + unsafe-fl< + unsafe-fl> + unsafe-fl>= + unsafe-fl<= + unsafe-flmin + unsafe-flmax + + unsafe-fl->fx + unsafe-fx->fl + + unsafe-make-flrectangular + unsafe-flreal-part + unsafe-flimag-part + + unsafe-flround + unsafe-flfloor + unsafe-flceiling + unsafe-fltruncate + + unsafe-flsin + unsafe-flcos + unsafe-fltan + unsafe-flasin + unsafe-flacos + unsafe-flatan + unsafe-fllog + unsafe-flexp + unsafe-flsqrt + unsafe-flexpt + + unsafe-flrandom + + extfl* extfl+ extfl- ->extfl + extfl->exact extfl->exact-integer + extfl->floating-point-bytes extfl->fx + extfl->inexact + extfl/ extfl< extfl<= extfl= extfl> extfl>= + extflabs extflacos extflasin extflatan extflceiling + extflcos extflexp extflexpt floating-point-bytes->extfl + extflfloor fx->extfl extfllog make-shared-extflvector + make-extflvector extflmax extflmin extflonum-available? + extflonum? real->extfl extflround shared-extflvector + extflsin extflsqrt extfltan extfltruncate extflvector + extflvector-length extflvector-ref extflvector-set! extflvector? + + unsafe-extfl* unsafe-extfl+ unsafe-extfl- unsafe-extfl/ + unsafe-extfl< unsafe-extfl<= unsafe-extfl= unsafe-extfl> unsafe-extfl>= + unsafe-extflabs unsafe-extflmax unsafe-extflmin + unsafe-extfl->fx unsafe-fx->extfl unsafe-extflsqrt + unsafe-extflvector-length unsafe-extflvector-ref unsafe-extflvector-set! + + place-enabled? place? place-channel? place-break + place-channel-get place-channel-put place-sleep + place-channel place-dead-evt place-kill place-message-allowed? + dynamic-place place-wait place-pumper-threads place-shared? + unsafe-get-place-table + + _bool _bytes _short_bytes _double _double* _fixint _fixnum _float _fpointer _gcpointer + _int16 _int32 _int64 _int8 _longdouble _pointer _scheme _stdbool _void + _string/ucs-4 _string/utf-16 _symbol _ufixint _ufixnum _uint16 _uint32 _uint64 _uint8 + compiler-sizeof cpointer-gcable? cpointer-tag cpointer? + ctype-alignof ctype-basetype ctype-c->scheme ctype-scheme->c ctype-sizeof ctype? + end-stubborn-change extflvector->cpointer + ffi-call ffi-call-maker ffi-callback ffi-callback-maker ffi-callback? + ffi-lib-name ffi-lib? ffi-obj ffi-obj-lib + ffi-obj-name ffi-obj? flvector->cpointer free free-immobile-cell lookup-errno + make-array-type make-cstruct-type make-ctype make-late-weak-box make-late-weak-hasheq + make-sized-byte-string make-union-type malloc malloc-immobile-cell + memcpy memmove memset offset-ptr? prop:cpointer ptr-add ptr-add! ptr-equal? ptr-offset ptr-ref + ptr-set! saved-errno set-cpointer-tag! set-ptr-offset! vector->cpointer + unsafe-register-process-global + (rename [ffi-lib* ffi-lib]) + set-ffi-get-lib-and-obj! ; not exported to Racket + poll-async-callbacks ; not exported to Racket + set-async-callback-poll-wakeup! ; not exported to Racket + + unsafe-unbox + unsafe-unbox* + unsafe-set-box! + unsafe-set-box*! + unsafe-box*-cas! + + unsafe-mcar + unsafe-mcdr + unsafe-set-mcar! + unsafe-set-mcdr! + + unsafe-vector-ref + unsafe-vector-set! + unsafe-vector*-ref + unsafe-vector*-set! + unsafe-vector*-cas! + unsafe-vector-length + unsafe-vector*-length + + unsafe-fxvector-length + unsafe-fxvector-ref + unsafe-fxvector-set! + + unsafe-bytes-length + unsafe-bytes-ref + unsafe-bytes-set! + + unsafe-undefined + check-not-unsafe-undefined + check-not-unsafe-undefined/assign + + unsafe-string-length + unsafe-string-ref + unsafe-string-set! + + unsafe-struct-ref + unsafe-struct-set! + unsafe-struct*-ref + unsafe-struct*-set! + + unsafe-s16vector-ref + unsafe-s16vector-set! + unsafe-u16vector-ref + unsafe-u16vector-set! + unsafe-f64vector-ref + unsafe-f64vector-set! + unsafe-f80vector-set! + unsafe-f80vector-ref + + ;; --- not exported to Racket: --- + make-pthread-parameter + fork-pthread + pthread? + get-thread-id + make-condition + condition-wait + condition-signal + condition-broadcast + make-mutex + mutex-acquire + mutex-release + threaded? + set-future-callbacks!) + (import (rename (chezpart) + [define define/no-lift]) + (rename (only (chezscheme) sleep) + [sleep chez:sleep]) + (only (chezscheme) + thread? + threaded? + get-thread-id + format + fprintf + current-error-port + error + map for-each andmap ormap) + (only (chezscheme csv7) + record-field-accessor + record-field-mutator)) + + (define/no-lift none (chez:gensym "none")) + (define/no-lift none2 (chez:gensym "none2")) + + (include "rumble/define.ss") + (include "rumble/virtual-register.ss") + (include "rumble/version.ss") + (include "rumble/syntax-rule.ss") + (include "rumble/check.ss") + (include "rumble/constant.ss") + (include "rumble/hash-code.ss") + (include "rumble/symbol.ss") + (include "rumble/struct.ss") + (include "rumble/prefab.ss") + (include "rumble/impersonator.ss") + (include "rumble/equal.ss") + (include "rumble/number.ss") + (include "rumble/procedure.ss") + (include "rumble/object-name.ss") + (include "rumble/arity.ss") + (include "rumble/intmap.ss") + (include "rumble/lock.ss") + (include "rumble/hash.ss") + (include "rumble/datum.ss") + (include "rumble/thread-cell.ss") + (include "rumble/begin0.ss") + (include "rumble/pthread.ss") + (include "rumble/control.ss") + (include "rumble/interrupt.ss") + (include "rumble/parameter.ss") + (include "rumble/engine.ss") + (include "rumble/error.ss") + (include "rumble/srcloc.ss") + (include "rumble/boolean.ss") + (include "rumble/bytes.ss") + (include "rumble/string.ss") + (include "rumble/char.ss") + (include "rumble/list.ss") + (include "rumble/vector.ss") + (include "rumble/box.ss") + (include "rumble/immutable.ss") + (include "rumble/keyword.ss") + (include "rumble/mpair.ss") + (include "rumble/flvector.ss") + (include "rumble/correlated.ss") + (include "rumble/graph.ss") + (include "rumble/time.ss") + (include "rumble/random.ss") + (include "rumble/memory.ss") + (include "rumble/ephemeron.ss") + (include "rumble/will-executor.ss") + (include "rumble/system.ss") + (include "rumble/unsafe.ss") + (include "rumble/extfl.ss") + (include "rumble/place.ss") + (include "rumble/foreign.ss") + (include "rumble/future.ss") + (include "rumble/inline.ss") + + (define-virtual-registers-init init-virtual-registers) + (init-virtual-registers) + + (set-no-locate-source!) + ;; Note: if there's a bug in `rumble` that causes exception handling to error, + ;; the the following line will cause the error to loop with another error, etc., + ;; probably without printing anything: + (set-base-exception-handler!) + (register-as-place-main!) + (set-collect-handler!) + (set-primitive-applicables!) + (set-continuation-applicables!) + (set-impersonator-applicables!) + (set-mpair-hash!) + (set-hash-hash!) + (set-flvector-hash!) + (set-impersonator-hash!) + (set-procedure-impersonator-hash!) + (set-vector-impersonator-hash!) + (set-box-impersonator-hash!) + (set-cpointer-hash!)) diff -Nru racket-6.12+ppa1/src/cs/schemify.sls racket-7.0+ppa1/src/cs/schemify.sls --- racket-6.12+ppa1/src/cs/schemify.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/schemify.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,66 @@ +(library (schemify) + (export schemify-linklet + lift-in-schemified-linklet + jitify-schemified-linklet + interpretable-jitified-linklet + interpret-linklet + linklet-bigger-than? + prim-knowns + known-procedure + a-known-constant) + (import (chezpart) + (rename (rumble) + [correlated? rumble:correlated?] + [correlated-e rumble:correlated-e] + [correlated-property rumble:correlated-property]) + (regexp) + (io)) + + ;; Bridge for flattened "schemify/wrap.rkt" + ;; and "schemify/wrap-annotation.rkt" + (define (primitive-table name) + (case name + [(|#%kernel|) + ;; Normally, schemify is schemified so that these are accessed + ;; directly, instead: + (hash 'syntax? rumble:correlated? + 'syntax-e rumble:correlated-e + 'syntax-property rumble:correlated-property)] + [else #f])) + + ;; For direct access by schemified schemify: + (define syntax? rumble:correlated?) + (define syntax-e rumble:correlated-e) + (define syntax-property rumble:correlated-property) + + (include "include.ss") + (include-generated "schemify.scm") + + (define prim-knowns + (let-syntax ([gen + (lambda (stx) + (include-generated "known.scm") + ;; Constructed a quoted literal hash table that + ;; maps symbols to `known` prefabs + (let ([known-l '()]) + (define-syntax define-primitive-table + (syntax-rules () + [(_ id [prim known] ...) + (begin (set! known-l (cons (cons 'prim known) known-l)) + ...)])) + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (let loop ([l known-l] [knowns (hasheq)]) + (if (null? l) + #`(quote #,knowns) + (loop (cdr l) + (hash-set knowns (caar l) (cdar l)))))))]) + (gen)))) diff -Nru racket-6.12+ppa1/src/cs/strip.ss racket-7.0+ppa1/src/cs/strip.ss --- racket-6.12+ppa1/src/cs/strip.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/strip.ss 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ + +(for-each (lambda (so) + (when (file-exists? so) + (printf "Stripping ~s\n" so) + (strip-fasl-file so so (fasl-strip-options inspector-source source-annotations)))) + (command-line-arguments)) diff -Nru racket-6.12+ppa1/src/cs/thread.sls racket-7.0+ppa1/src/cs/thread.sls --- racket-6.12+ppa1/src/cs/thread.sls 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/cs/thread.sls 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,121 @@ +(library (thread) + (export) + (import (rename (chezpart) + [define chez:define]) + (rename (only (chezscheme) + sleep + printf) + [sleep chez:sleep]) + (rename (rumble) + [rumble:break-enabled-key break-enabled-key] + ;; These are extracted via `#%linklet`: + [make-engine rumble:make-engine] + [engine-block rumble:engine-block] + [engine-return rumble:engine-return] + [current-engine-state rumble:current-engine-state] + [make-condition rumble:make-condition] + [condition-wait rumble:condition-wait] + [condition-signal rumble:condition-signal] + [condition-broadcast rumble:condition-broadcast] + [make-mutex rumble:make-mutex] + [mutex-acquire rumble:mutex-acquire] + [mutex-release rumble:mutex-release] + [pthread? rumble:thread?] + [fork-pthread rumble:fork-thread] + [threaded? rumble:threaded?] + [get-thread-id rumble:get-thread-id] + [set-ctl-c-handler! rumble:set-ctl-c-handler!] + [root-continuation-prompt-tag rumble:root-continuation-prompt-tag] + [set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!])) + + ;; Special handling of `current-atomic`: use the last virtual register. + ;; We rely on the fact that the register's default value is 0. + (define-syntax (define stx) + (syntax-case stx (current-atomic make-pthread-parameter) + [(_ current-atomic (make-pthread-parameter 0)) + (with-syntax ([(_ id _) stx] + [n (datum->syntax #'here (sub1 (virtual-register-count)))]) + #'(define-syntax id + (syntax-rules () + [(_) (virtual-register n)] + [(_ v) (set-virtual-register! n v)])))] + [(_ . rest) #'(chez:define . rest)])) + + (define (exit n) + (chez:exit n)) + + (define (sleep secs) + (define isecs (inexact->exact (floor secs))) + (chez:sleep (make-time 'time-duration + (inexact->exact (floor (* (- secs isecs) 1e9))) + isecs))) + + (define (primitive-table key) + (case key + [(|#%pthread|) + ;; Entries in the `#%pthread` table are referenced more + ;; directly in "compiled/thread.scm". To make that work, the + ;; entries need to be registered as built-in names with the + ;; expander, and they need to be listed in + ;; "primitives/internal.ss". + (hash + 'make-pthread-parameter make-pthread-parameter)] + [(|#%engine|) + (hash + 'make-engine rumble:make-engine + 'engine-block rumble:engine-block + 'engine-return rumble:engine-return + 'current-engine-state (lambda (v) (rumble:current-engine-state v)) + 'set-ctl-c-handler! rumble:set-ctl-c-handler! + 'root-continuation-prompt-tag rumble:root-continuation-prompt-tag + 'poll-will-executors poll-will-executors + 'make-will-executor rumble:make-will-executor + 'make-stubborn-will-executor rumble:make-stubborn-will-executor + 'will-executor? rumble:will-executor? + 'will-register rumble:will-register + 'will-try-execute rumble:will-try-execute + 'break-enabled-key break-enabled-key + 'set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook! + 'continuation-marks rumble:continuation-marks + 'exn:break/non-engine exn:break + 'exn:break:hang-up/non-engine exn:break:hang-up + 'exn:break:terminate/non-engine exn:break:terminate + 'current-process-milliseconds cpu-time + 'poll-async-callbacks poll-async-callbacks + 'disable-interrupts disable-interrupts + 'enable-interrupts enable-interrupts + 'fork-pthread rumble:fork-thread + 'pthread? rumble:thread? + 'get-thread-id rumble:get-thread-id + 'make-condition rumble:make-condition + 'condition-wait rumble:condition-wait + 'condition-signal rumble:condition-signal + 'condition-broadcast rumble:condition-broadcast + 'make-mutex rumble:make-mutex + 'mutex-acquire rumble:mutex-acquire + 'mutex-release rumble:mutex-release + 'threaded? rumble:threaded?)] + [else #f])) + + ;; Tie knots: + (define (check-for-break) (1/check-for-break)) + (define (break-enabled) (1/break-enabled)) + + (include "include.ss") + (include-generated "thread.scm") + + (set-engine-exit-handler! + (lambda (v) + (|#%app| (|#%app| 1/exit-handler) v))) + + (set-scheduler-lock-callbacks! (lambda () (1/make-semaphore 1)) + 1/semaphore-wait + 1/semaphore-post) + + (set-scheduler-atomicity-callbacks! (lambda () + (current-atomic (fx+ (current-atomic) 1))) + (lambda () + (current-atomic (fx- (current-atomic) 1)))) + + (set-future-callbacks! 1/future? 1/current-future + future-block future-wait current-future-prompt)) diff -Nru racket-6.12+ppa1/src/expander/boot/core-primitive.rkt racket-7.0+ppa1/src/expander/boot/core-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/core-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/core-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,204 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/srcloc.rkt" + "../common/phase.rkt" + (except-in "../syntax/scope.rkt" + syntax-e + bound-identifier=? + syntax-shift-phase-level) + "../namespace/namespace.rkt" + (except-in "../syntax/binding.rkt" + free-identifier=? + identifier-binding + identifier-binding-symbol) + "../namespace/core.rkt" + "../expand/set-bang-trans.rkt" + "../expand/rename-trans.rkt" + "../expand/liberal-def-ctx.rkt" + "../expand/syntax-local.rkt" + "../expand/definition-context.rkt" + "../expand/local-expand.rkt" + "../syntax/api.rkt" + "../syntax/api-taint.rkt" + "../syntax/error.rkt" + "../read/api.rkt" + "../common/module-path.rkt" + "../namespace/variable-reference.rkt" + "../expand/allowed-context.rkt" + "../expand/missing-module.rkt") + +(provide primitive-ids) + +;; Register core primitives: +(define-syntax-rule (add-core-primitives! #:table primitive-ids id ...) + (begin + (define primitive-ids (seteq 'id ...)) + (void + (begin + (add-core-primitive! 'id id) + ...)))) + +(add-core-primitives! #:table primitive-ids + + syntax? + syntax-e + syntax->datum + datum->syntax + + bound-identifier=? + free-identifier=? + free-transformer-identifier=? + free-template-identifier=? + free-label-identifier=? + identifier-binding + identifier-transformer-binding + identifier-template-binding + identifier-label-binding + identifier-binding-symbol + identifier-prune-lexical-context + syntax-debug-info + syntax-track-origin + syntax-shift-phase-level + syntax-source-module + identifier-prune-to-source-module + + syntax-source + syntax-line + syntax-column + syntax-position + syntax-span + syntax->list + syntax-property + syntax-property-remove + syntax-property-preserved? + syntax-property-symbol-keys + syntax-original? + + syntax-tainted? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint + + raise-syntax-error + struct:exn:fail:syntax + exn:fail:syntax + make-exn:fail:syntax + exn:fail:syntax? + exn:fail:syntax-exprs + struct:exn:fail:syntax:unbound + exn:fail:syntax:unbound + make-exn:fail:syntax:unbound + exn:fail:syntax:unbound? + + current-module-path-for-load + prop:exn:missing-module + exn:missing-module? + exn:missing-module-accessor + struct:exn:fail:filesystem:missing-module + exn:fail:filesystem:missing-module + make-exn:fail:filesystem:missing-module + exn:fail:filesystem:missing-module? + exn:fail:filesystem:missing-module-path + struct:exn:fail:syntax:missing-module + exn:fail:syntax:missing-module + make-exn:fail:syntax:missing-module + exn:fail:syntax:missing-module? + exn:fail:syntax:missing-module-path + + syntax-transforming? + syntax-transforming-with-lifts? + syntax-transforming-module-expression? + syntax-local-transforming-module-provides? + + syntax-local-context + syntax-local-introduce + syntax-local-identifier-as-binding + syntax-local-phase-level + syntax-local-name + + make-syntax-introducer + make-interned-syntax-introducer + make-syntax-delta-introducer + syntax-local-make-delta-introducer + + syntax-local-value + syntax-local-value/immediate + + syntax-local-lift-expression + syntax-local-lift-values-expression + syntax-local-lift-context + + syntax-local-lift-module + + syntax-local-lift-require + syntax-local-lift-provide + syntax-local-lift-module-end-declaration + + syntax-local-module-defined-identifiers + syntax-local-module-required-identifiers + syntax-local-module-exports + syntax-local-submodules + + syntax-local-get-shadower + + local-expand + local-expand/capture-lifts + local-transformer-expand + local-transformer-expand/capture-lifts + syntax-local-expand-expression + + internal-definition-context? + syntax-local-make-definition-context + syntax-local-bind-syntaxes + internal-definition-context-binding-identifiers + internal-definition-context-introduce + internal-definition-context-seal + identifier-remove-from-definition-context + + make-set!-transformer + prop:set!-transformer + set!-transformer? + set!-transformer-procedure + + rename-transformer? + prop:rename-transformer + make-rename-transformer + rename-transformer-target + + prop:liberal-define-context + liberal-define-context? + + prop:expansion-contexts + + module-path? + + resolved-module-path? + make-resolved-module-path + resolved-module-path-name + + module-path-index? + module-path-index-resolve + module-path-index-join + module-path-index-split + module-path-index-submodule + + current-module-name-resolver + current-module-declare-name + current-module-declare-source + + current-namespace + namespace-module-registry + namespace? + + variable-reference->empty-namespace + variable-reference->namespace + variable-reference->resolved-module-path + variable-reference->module-path-index + variable-reference->module-source + variable-reference->phase + variable-reference->module-base-phase + variable-reference->module-declaration-inspector + + read-syntax + read-syntax/recursive) diff -Nru racket-6.12+ppa1/src/expander/boot/expobs-primitive.rkt racket-7.0+ppa1/src/expander/boot/expobs-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/expobs-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/expobs-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base +(require "../expand/context.rkt") + +(provide expobs-primitives) + +(define expobs-primitives + (hasheq 'current-expand-observe current-expand-observe)) diff -Nru racket-6.12+ppa1/src/expander/boot/handler.rkt racket-7.0+ppa1/src/expander/boot/handler.rkt --- racket-6.12+ppa1/src/expander/boot/handler.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/handler.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,688 @@ +#lang racket/base +(require '#%paramz + "../eval/collection.rkt" + "../syntax/api.rkt" + "../syntax/error.rkt" + "../syntax/srcloc.rkt" + "../namespace/namespace.rkt" + "../eval/parameter.rkt" + "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../namespace/api.rkt" + "../common/module-path.rkt" + "../eval/module-read.rkt" + "../expand/missing-module.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt" + "load-handler.rkt") + +(provide boot + seal + orig-paramz + + boot-primitives) + +(define-values (dll-suffix) + (system-type 'so-suffix)) + +(define default-load/use-compiled + (let* ([resolve (lambda (s) + (if (complete-path? s) + s + (let ([d (current-load-relative-directory)]) + (if d (path->complete-path s d) s))))] + [date-of-1 (lambda (a) + (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))]) + (and v (cons a v))))] + [date-of (lambda (a modes roots) + (ormap (lambda (root-dir) + (ormap + (lambda (compiled-dir) + (let ([a (a root-dir compiled-dir)]) + (date-of-1 a))) + modes)) + roots))] + [date>=? + (lambda (modes roots a bm) + (and a + (let ([am (date-of a modes roots)]) + (or (and (not bm) am) + (and am bm (>= (cdr am) (cdr bm)) am)))))] + [with-dir* (lambda (base t) + (parameterize ([current-load-relative-directory + (if (path? base) + base + (current-directory))]) + (t)))]) + (lambda (path expect-module) + (unless (path-string? path) + (raise-argument-error 'load/use-compiled "path-string?" path)) + (unless (or (not expect-module) + (symbol? expect-module) + (and (list? expect-module) + ((length expect-module) . > . 1) + (or (symbol? (car expect-module)) + (not (car expect-module))) + (andmap symbol? (cdr expect-module)))) + (raise-argument-error 'load/use-compiled "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" path)) + (define name (and expect-module (current-module-declare-name))) + (define ns-hts (and name (registry-table-ref (namespace-module-registry (current-namespace))))) + (define use-path/src (and ns-hts (hash-ref (cdr ns-hts) name #f))) + (if use-path/src + ;; Use previous decision of .zo vs. source: + (parameterize ([current-module-declare-source (cadr use-path/src)]) + (with-dir* (caddr use-path/src) + (lambda () ((current-load) (car use-path/src) expect-module)))) + ;; Check .zo vs. src dates, etc.: + (let*-values ([(orig-path) (resolve path)] + [(base orig-file dir?) (split-path path)] + [(file alt-file) (if expect-module + (let* ([b (path->bytes orig-file)] + [len (bytes-length b)]) + (cond + [(and (len . >= . 4) + (bytes=? #".rkt" (subbytes b (- len 4)))) + ;; .rkt => try .rkt then .ss + (values orig-file + (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] + [else + ;; No search path + (values orig-file #f)])) + (values orig-file #f))] + [(path) (if (eq? file orig-file) + orig-path + (build-path base file))] + [(alt-path) (and alt-file + (if (eq? alt-file orig-file) + orig-path + (build-path base alt-file)))] + [(base) (if (eq? base 'relative) 'same base)] + [(modes) (use-compiled-file-paths)] + [(roots) (current-compiled-file-roots)] + [(reroot) (lambda (p d) + (cond + [(eq? d 'same) p] + [(relative-path? d) (build-path p d)] + [else (reroot-path p d)]))]) + (let* ([main-path-d (date-of-1 path)] + [alt-path-d (and alt-path + (not main-path-d) + (date-of-1 alt-path))] + [path-d (or main-path-d alt-path-d)] + [get-so (lambda (file rep-sfx?) + (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + "native" + (system-library-subpath) + (if rep-sfx? + (path-add-extension + file + dll-suffix) + file))))] + [zo (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + (path-add-extension file #".zo")))] + [alt-zo (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + (path-add-extension alt-file #".zo")))] + [so (get-so file #t)] + [alt-so (get-so alt-file #t)] + [try-main? (or main-path-d (not alt-path-d))] + [try-alt? (and alt-file (or alt-path-d (not main-path-d)))] + [with-dir (lambda (t) (with-dir* base t))]) + (cond + [(and try-main? + (date>=? modes roots so path-d)) + => (lambda (so-d) + (parameterize ([current-module-declare-source #f]) + (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] + [(and try-alt? + (date>=? modes roots alt-so alt-path-d)) + => (lambda (so-d) + (parameterize ([current-module-declare-source alt-path]) + (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] + [(and try-main? + (date>=? modes roots zo path-d)) + => (lambda (zo-d) + (register-zo-path name ns-hts (car zo-d) #f base) + (parameterize ([current-module-declare-source #f]) + (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] + [(and try-alt? + (date>=? modes roots alt-zo path-d)) + => (lambda (zo-d) + (register-zo-path name ns-hts (car zo-d) alt-path base) + (parameterize ([current-module-declare-source alt-path]) + (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] + [(or (not (pair? expect-module)) + (car expect-module)) + (let ([p (if try-main? path alt-path)]) + ;; "quiet" failure when asking for a submodule: + (unless (and (pair? expect-module) + (not (file-exists? p))) + (parameterize ([current-module-declare-source (and expect-module + (not try-main?) + p)]) + (with-dir (lambda () ((current-load) p expect-module))))))]))))))) + +(define (register-zo-path name ns-hts path src-path base) + (when ns-hts + (hash-set! (cdr ns-hts) name (list path src-path base)))) + +(define (default-reader-guard path) + path) + +;; weak map from namespace to pair of module-name hts +(define -module-hash-table-table + (make-weak-hasheq)) + +(define (registry-table-ref reg) + (define e (hash-ref -module-hash-table-table + reg + #f)) + (and e (ephemeron-value e))) + +(define (registry-table-set! reg v) + (hash-set! -module-hash-table-table + reg + (make-ephemeron reg v))) + +;; weak map from `lib' path + current-library-paths to symbols: +;; We'd like to use a weak `equal?'-based hash table here, +;; but that's not kill-safe. Instead, we use a non-thread-safe +;; custom hash table; a race could lose cache entries, but +;; that's ok. +(define CACHE-N 512) +(define -path-cache (make-vector CACHE-N #f)) +(define (path-cache-get p) + (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] + [w (vector-ref -path-cache i)] + [l (and w (weak-box-value w))]) + (and l + (let ([a (assoc p l)]) + (and a (cdr a)))))) +(define (path-cache-set! p v) + (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] + [w (vector-ref -path-cache i)] + [l (and w (weak-box-value w))]) + (vector-set! -path-cache i (make-weak-box (cons (cons p v) (or l null)))))) + +(define -loading-filename (gensym)) +(define -loading-prompt-tag (make-continuation-prompt-tag 'module-loading)) +(define -prev-relto #f) +(define -prev-relto-dir #f) + +(define (split-relative-string s coll-mode?) + (let ([l (let loop ([s s]) + (let ([len (string-length s)]) + (let iloop ([i 0]) + (cond + [(= i len) (list s)] + [(char=? #\/ (string-ref s i)) + (cons (substring s 0 i) + (loop (substring s (add1 i))))] + [else (iloop (add1 i))]))))]) + (if coll-mode? + l + (let loop ([l l]) + (if (null? (cdr l)) + (values null (car l)) + (let-values ([(c f) (loop (cdr l))]) + (values (cons (car l) c) f))))))) + +(define (format-source-location stx) + (srcloc->string (srcloc (syntax-source stx) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx)))) + +(define orig-paramz #f) + +(define-values (standard-module-name-resolver) + (let-values () + (define-values (planet-resolver) #f) + (define-values (prep-planet-resolver!) + (lambda () + (unless planet-resolver + (with-continuation-mark + parameterization-key + orig-paramz + (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))) + (define-values (standard-module-name-resolver) + (case-lambda + [(s from-namespace) + (unless (resolved-module-path? s) + (raise-argument-error 'standard-module-name-resolver + "resolved-module-path?" + s)) + (unless (or (not from-namespace) (namespace? from-namespace)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f namespace?)" + from-namespace)) + (when planet-resolver + ;; Let planet resolver register, too: + (planet-resolver s)) + ;; Register s as loaded: + (let ([hts (or (registry-table-ref (namespace-module-registry (current-namespace))) + (let ([hts (cons (make-hasheq) (make-hasheq))]) + (registry-table-set! (namespace-module-registry (current-namespace)) + hts) + hts))]) + (hash-set! (car hts) s 'declared) + ;; If attach from another namespace, copy over source-file path, if any: + (when from-namespace + (let ([root-name (if (pair? (resolved-module-path-name s)) + (make-resolved-module-path (car (resolved-module-path-name s))) + s)] + [from-hts (registry-table-ref (namespace-module-registry from-namespace))]) + (when from-hts + (let ([use-path/src (hash-ref (cdr from-hts) root-name #f)]) + (when use-path/src + (hash-set! (cdr hts) root-name use-path/src)))))))] + [(s relto stx) ; for backward-compatibility + (log-message (current-logger) 'error + "default module name resolver called with three arguments (deprecated)" + #f) + (standard-module-name-resolver s relto stx #t)] + [(s relto stx load?) + ;; If stx is not #f, raise syntax error for ill-formed paths + (unless (module-path? s) + (if (syntax? stx) + (raise-syntax-error #f + "bad module path" + stx) + (raise-argument-error 'standard-module-name-resolver + "module-path?" + s))) + (unless (or (not relto) (resolved-module-path? relto)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f resolved-module-path?)" + relto)) + (unless (or (not stx) (syntax? stx)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f syntax?)" + stx)) + (define (flatten-sub-path base orig-l) + (let loop ([a null] [l orig-l]) + (cond + [(null? l) (if (null? a) + base + (cons base (reverse a)))] + [(equal? (car l) "..") + (if (null? a) + (error + 'standard-module-name-resolver + "too many \"..\"s in submodule path: ~.s" + (list* 'submod + (if (equal? base ".") + base + (if (path? base) + base + (list (if (symbol? base) 'quote 'file) base))) + orig-l)) + (loop (cdr a) (cdr l)))] + [else (loop (cons (car l) a) (cdr l))]))) + (cond + [(and (pair? s) (eq? (car s) 'quote)) + (make-resolved-module-path (cadr s))] + [(and (pair? s) (eq? (car s) 'submod) + (pair? (cadr s)) (eq? (caadr s) 'quote)) + (make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))] + [(and (pair? s) (eq? (car s) 'submod) + (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (and relto + (let ([p (resolved-module-path-name relto)]) + (or (symbol? p) + (and (pair? p) (symbol? (car p))))))) + (define rp (resolved-module-path-name relto)) + (make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp) + (let ([r (if (equal? (cadr s) "..") + (cdr s) + (cddr s))]) + (if (pair? rp) + (append (cdr rp) r) + r))))] + [(and (pair? s) (eq? (car s) 'planet)) + (prep-planet-resolver!) + (planet-resolver s relto stx load? #f orig-paramz)] + [(and (pair? s) + (eq? (car s) 'submod) + (pair? (cadr s)) + (eq? (caadr s) 'planet)) + (prep-planet-resolver!) + (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] + [else + (let ([get-dir (lambda () + (or (and relto + (if (eq? relto -prev-relto) + -prev-relto-dir + (let ([p (resolved-module-path-name relto)]) + (let ([p (if (pair? p) (car p) p)]) + (and (path? p) + (let-values ([(base n d?) (split-path p)]) + (set! -prev-relto relto) + (set! -prev-relto-dir base) + base)))))) + (current-load-relative-directory) + (current-directory)))] + [get-reg (lambda () + (namespace-module-registry (current-namespace)))] + [show-collection-err (lambda (msg) + (let ([msg (string-append + (or (and stx + (error-print-source-location) + (format-source-location stx)) + "standard-module-name-resolver") + ": " + (regexp-replace #rx"\n" + msg + (format "\n for module path: ~s\n" + s)))]) + (raise + (if stx + (exn:fail:syntax:missing-module + msg + (current-continuation-marks) + (list stx) + s) + (exn:fail:filesystem:missing-module + msg + (current-continuation-marks) + s)))))] + [ss->rkt (lambda (s) + (let ([len (string-length s)]) + (if (and (len . >= . 3) + ;; ".ss" + (equal? #\. (string-ref s (- len 3))) + (equal? #\s (string-ref s (- len 2))) + (equal? #\s (string-ref s (- len 1)))) + (string-append (substring s 0 (- len 3)) ".rkt") + s)))] + [path-ss->rkt (lambda (p) + (let-values ([(base name dir?) (split-path p)]) + (if (regexp-match #rx"[.]ss$" (path->bytes name)) + (path-replace-extension p #".rkt") + p)))] + [s (if (and (pair? s) (eq? 'submod (car s))) + (let ([v (cadr s)]) + (if (or (equal? v ".") + (equal? v "..")) + (if relto + ;; must have a path inside, or we wouldn't get here + (let ([p (resolved-module-path-name relto)]) + (if (pair? p) + (car p) + p)) + (error 'standard-module-name-resolver + "no base path for relative submodule path: ~.s" + s)) + v)) + s)] + [subm-path (if (and (pair? s) (eq? 'submod (car s))) + (let ([p (if (and (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + relto) + (let ([p (resolved-module-path-name relto)] + [r (if (equal? (cadr s) "..") + (cdr s) + (cddr s))]) + (if (pair? p) + (flatten-sub-path (car p) (append (cdr p) r)) + (flatten-sub-path p r))) + (flatten-sub-path "." + (if (equal? (cadr s) "..") + (cdr s) + (cddr s))))]) + ;; flattening may erase the submodule path: + (if (pair? p) + (cdr p) + #f)) + #f)]) + (let ([s-parsed + ;; Non-string result represents an error + (cond + [(symbol? s) + (or (path-cache-get (cons s (get-reg))) + (let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) + (let* ([f-file (if (null? cols) + "main.rkt" + (string-append file ".rkt"))]) + (find-col-file show-collection-err + (if (null? cols) file (car cols)) + (if (null? cols) null (cdr cols)) + f-file + #t))))] + [(string? s) + (let* ([dir (get-dir)]) + (or (path-cache-get (cons s dir)) + (let-values ([(cols file) (split-relative-string s #f)]) + (if (null? cols) + (build-path dir (ss->rkt file)) + (apply build-path + dir + (append + (map (lambda (s) + (cond + [(string=? s ".") 'same] + [(string=? s "..") 'up] + [else s])) + cols) + (list (ss->rkt file))))))))] + [(path? s) + ;; Use filesystem-sensitive `simplify-path' here: + (path-ss->rkt (simplify-path (if (complete-path? s) + s + (path->complete-path s (get-dir)))))] + [(eq? (car s) 'lib) + (or (path-cache-get (cons s (get-reg))) + (let*-values ([(cols file) (split-relative-string (cadr s) #f)] + [(old-style?) (if (null? (cddr s)) + (and (null? cols) + (regexp-match? #rx"[.]" file)) + #t)]) + (let* ([f-file (if old-style? + (ss->rkt file) + (if (null? cols) + "main.rkt" + (if (regexp-match? #rx"[.]" file) + (ss->rkt file) + (string-append file ".rkt"))))]) + (let-values ([(cols) + (if old-style? + (append (if (null? (cddr s)) + '("mzlib") + (apply append + (map (lambda (p) + (split-relative-string p #t)) + (cddr s)))) + cols) + (if (null? cols) + (list file) + cols))]) + (find-col-file show-collection-err + (car cols) + (cdr cols) + f-file + #t)))))] + [(eq? (car s) 'file) + ;; Use filesystem-sensitive `simplify-path' here: + (path-ss->rkt + (simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])]) + (unless (or (path? s-parsed) + (vector? s-parsed)) + (if stx + (raise-syntax-error + 'require + (format "bad module path~a" (if s-parsed + (car s-parsed) + "")) + stx) + (raise-argument-error + 'standard-module-name-resolver + "module-path?" + s))) + ;; At this point, s-parsed is a complete path (or a cached vector) + (let* ([filename (if (vector? s-parsed) + (vector-ref s-parsed 0) + (simplify-path (cleanse-path s-parsed) #f))] + [normal-filename (if (vector? s-parsed) + (vector-ref s-parsed 1) + (normal-case-path filename))]) + (let-values ([(base name dir?) (if (vector? s-parsed) + (values 'ignored (vector-ref s-parsed 2) 'ignored) + (split-path filename))]) + (let* ([no-sfx (if (vector? s-parsed) + (vector-ref s-parsed 3) + (path-replace-extension name #""))]) + (let* ([root-modname (if (vector? s-parsed) + (vector-ref s-parsed 4) + (make-resolved-module-path filename))] + [hts (or (registry-table-ref (get-reg)) + (let ([hts (cons (make-hasheq) (make-hasheq))]) + (registry-table-set! (get-reg) + hts) + hts))] + [modname (if subm-path + (make-resolved-module-path + (cons (resolved-module-path-name root-modname) + subm-path)) + root-modname)]) + ;; Loaded already? + (when load? + (let ([got (hash-ref (car hts) modname #f)]) + (unless got + ;; Currently loading? + (let ([loading + (let ([tag (if (continuation-prompt-available? -loading-prompt-tag) + -loading-prompt-tag + (default-continuation-prompt-tag))]) + (continuation-mark-set-first + #f + -loading-filename + null + tag))] + [nsr (get-reg)]) + (for-each + (lambda (s) + (when (and (equal? (cdr s) normal-filename) + (eq? (car s) nsr)) + (error + 'standard-module-name-resolver + "cycle in loading\n at path: ~a\n paths:~a" + filename + (apply string-append + (let loop ([l (reverse loading)]) + (if (null? l) + '() + (list* "\n " (path->string (cdar l)) (loop (cdr l))))))))) + loading) + ((if (continuation-prompt-available? -loading-prompt-tag) + (lambda (f) (f)) + (lambda (f) (call-with-continuation-prompt f -loading-prompt-tag))) + (lambda () + (with-continuation-mark -loading-filename (cons (cons nsr normal-filename) + loading) + (parameterize ([current-module-declare-name root-modname] + [current-module-path-for-load + ;; If `s' is an absolute module path, then + ;; keep it as-is, the better to let a tool + ;; recommend how to get an unavailable module; + ;; also, propagate the source location. + ((if stx + (lambda (p) (datum->syntax #f p stx)) + values) + (cond + [(symbol? s) s] + [(and (pair? s) (eq? (car s) 'lib)) s] + [else (if (resolved-module-path? root-modname) + (let ([src (resolved-module-path-name root-modname)]) + (if (symbol? src) + (list 'quote src) + src)) + root-modname)]))]) + ((current-load/use-compiled) + filename + (let ([sym (string->symbol (path->string no-sfx))]) + (if subm-path + (if (hash-ref (car hts) root-modname #f) + ;; Root is already loaded, so only use .zo + (cons #f subm-path) + ;; Root isn't loaded, so it's ok to load form source: + (cons sym subm-path)) + sym))))))))))) + ;; If a `lib' path, cache pathname manipulations + (when (and (not (vector? s-parsed)) + load? + (or (string? s) + (symbol? s) + (and (pair? s) + (eq? (car s) 'lib)))) + (path-cache-set! (if (string? s) + (cons s (get-dir)) + (cons s (get-reg))) + (vector filename + normal-filename + name + no-sfx + root-modname))) + ;; Result is the module name: + modname))))))])])) + standard-module-name-resolver)) + +(define default-eval-handler + (lambda (s) + (eval s + (current-namespace) + (let ([c (current-compile)]) + (lambda (e ns) + ;; `ns` is `(current-namespace)`, but possibly + ;; phase-shifted + (if (eq? ns (current-namespace)) + (c e #t) + (parameterize ([current-namespace ns]) + (c e #t)))))))) + +(define default-compile-handler + ;; Constrained to a single argument: + (lambda (s immediate-eval?) (compile s + (current-namespace) + (not immediate-eval?)))) + +(define (default-read-interaction src in) + (unless (input-port? in) + (raise-argument-error 'default-read-interaction "input-port?" in)) + (parameterize ([read-accept-reader #t] + [read-accept-lang #f]) + (read-syntax src in))) + +(define (boot) + (seal) + (current-module-name-resolver standard-module-name-resolver) + (current-load/use-compiled default-load/use-compiled) + (current-reader-guard default-reader-guard) + (current-eval default-eval-handler) + (current-compile default-compile-handler) + (current-load default-load-handler) + (current-read-interaction default-read-interaction)) + +(define (seal) + (set! orig-paramz + (reparameterize + (continuation-mark-set-first #f parameterization-key)))) + +(define (get-original-parameterization) + orig-paramz) + +;; ---------------------------------------- +;; For historical uses of '#%boot + +(define boot-primitives + (hash 'boot boot + 'seal seal + ;; Historically, exported a `orig-paramz` after place + ;; initialization, but we now need an indirection + 'get-original-parameterization get-original-parameterization)) diff -Nru racket-6.12+ppa1/src/expander/boot/kernel.rkt racket-7.0+ppa1/src/expander/boot/kernel.rkt --- racket-6.12+ppa1/src/expander/boot/kernel.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/kernel.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,120 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../namespace/core.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt" + "../syntax/binding.rkt" + "core-primitive.rkt" + "../common/module-path.rkt" + "../expand/require+provide.rkt" + "../host/linklet.rkt" + "../compile/built-in-symbol.rkt") + +;; The '#%kernel module combines '#%core, '#%runtime, and '#%main + +(provide declare-kernel-module! + copy-runtime-module! + declare-hash-based-module! + declare-reexporting-module!) + +(define (declare-kernel-module! ns + #:eval eval + #:main-ids main-ids + #:read-ids read-ids) + (copy-runtime-module! '#%kernel + #:to '#%runtime + #:skip (set-union primitive-ids + (set-union main-ids + read-ids)) + #:extras (hasheq 'variable-reference? variable-reference? + 'variable-reference-constant? variable-reference-constant? + 'variable-reference-from-unsafe? variable-reference-from-unsafe?) + #:namespace ns) + (declare-reexporting-module! '#%kernel '(#%core #%runtime #%main #%read) + #:namespace ns)) + +(define (copy-runtime-module! name + #:to [to-name name] + #:namespace ns + #:skip [skip-syms (seteq)] + #:alts [alts #hasheq()] + #:extras [extras #hasheq()] + #:primitive? [primitive? #t] + #:protected? [protected? #f]) + (define prims (primitive-table name)) + (for ([sym (in-hash-keys prims)]) + (register-built-in-symbol! sym)) + (define ht (for/hasheq ([(sym val) (in-hash prims)] + #:unless (set-member? skip-syms sym)) + (values sym + (or (hash-ref alts sym #f) val)))) + (define ht+extras (for/fold ([ht ht]) ([(k v) (in-hash extras)]) + (hash-set ht k v))) + (declare-hash-based-module! to-name ht+extras + #:namespace ns + #:primitive? primitive? + #:protected? protected?)) + +(define (declare-hash-based-module! name ht + #:namespace ns + #:primitive? [primitive? #f] + #:protected? [protected? #f] + #:protected [protected-syms null] + #:register-builtin? [register-builtin? #f]) + (define mpi (module-path-index-join (list 'quote name) #f)) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:primitive? primitive? + #:predefined? #t + #:no-protected? (not protected?) + #:self mpi + #:provides + (hasheqv 0 (for/hash ([sym (in-hash-keys ht)]) + (when register-builtin? + (register-built-in-symbol! sym)) + (define binding (make-module-binding mpi 0 sym)) + (values sym + (if (or protected? + (member sym protected-syms)) + (provided binding #t #f) + binding)))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (when (= 0 phase-level) + (for ([(sym val) (in-hash ht)]) + (namespace-set-variable! ns 0 sym val))))) + (module-path-index-resolve mpi))) + +(define (declare-reexporting-module! name require-names + #:reexport? [reexport? #t] + #:namespace ns) + (define mpi (module-path-index-join (list 'quote name) #f)) + (define require-mpis (for/list ([require-name (in-list require-names)]) + (module-path-index-join (list 'quote require-name) #f))) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:predefined? #t + #:self mpi + #:requires (list (cons 0 require-mpis)) + #:provides + (if reexport? + (hasheqv 0 + (for*/hash ([require-mpi (in-list require-mpis)] + [m (in-value (namespace->module + ns + (module-path-index-resolve require-mpi)))] + [(sym binding) (in-hash + (hash-ref + (shift-provides-module-path-index + (module-provides m) + (module-self m) + require-mpi) + 0))]) + (values sym binding))) + #hasheqv()) + #:instantiate-phase-callback void) + (module-path-index-resolve mpi))) diff -Nru racket-6.12+ppa1/src/expander/boot/linklet-primitive.rkt racket-7.0+ppa1/src/expander/boot/linklet-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/linklet-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/linklet-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../common/reflect-hash.rkt" + "../run/linklet-operation.rkt") + +(provide linklet-primitives) + +(define linklet-primitives + (linklet-operations=> reflect-hash)) diff -Nru racket-6.12+ppa1/src/expander/boot/load-handler.rkt racket-7.0+ppa1/src/expander/boot/load-handler.rkt --- racket-6.12+ppa1/src/expander/boot/load-handler.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/load-handler.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,222 @@ +#lang racket/base +(require '#%paramz + "../eval/collection.rkt" + "../syntax/api.rkt" + "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../eval/parameter.rkt" + "../host/linklet.rkt" + "../namespace/namespace.rkt" + "../namespace/api.rkt" + "../eval/module-read.rkt" + "../eval/module-cache.rkt" + "../eval/reflect.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt") + +(provide default-load-handler) + +(define default-load-handler + (lambda (path expected-mod) + (unless (path-string? path) + (raise-argument-error 'default-load-handler "path-string?" path)) + (unless (or (not expected-mod) + (symbol? expected-mod) + (and (pair? expected-mod) + (list? expected-mod) + (or (not (car expected-mod)) (symbol? (car expected-mod))) + (andmap symbol? (cdr expected-mod)))) + (raise-argument-error 'default-load-handler + "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" + expected-mod)) + (define (maybe-count-lines! i) + (unless (regexp-match? #rx"[.]zo$" path) + (port-count-lines! i))) + (cond + [expected-mod + ((call-with-input-module-file + path + (lambda (i) + (maybe-count-lines! i) + (with-module-reading-parameterization+delay-source + path + (lambda () + (cond + [(linklet-directory-start i) + => (lambda (pos) + ;; Find and load individual submodule + (define b-pos (search-directory i pos (encode-symbols expected-mod))) + (cond + [b-pos + (file-position i b-pos) + (or (cached-bundle i) + (let ([v (read i)]) + (if (compiled-module-expression? v) + (lambda () ((current-eval) v)) + (error 'default-load-handler + (string-append "expected a compiled module\n" + " in: ~e\n" + " found: ~e") + (object-name i) + v))))] + [(and (pair? expected-mod)) + ;; Cannot load submodule, so do nothing + void] + [else + (error 'default-load-handler + (string-append "could not find main module\n" + " in: ~e") + (object-name i))]))] + [(and (pair? expected-mod) (not (car expected-mod))) + ;; Cannot load submodule independently, so do nothing + void] + [(cached-bundle i) + => (lambda (thunk) thunk)] + [else + (define s (read-syntax (object-name i) i)) + (when (eof-object? s) + (error 'default-load-handler + (string-append "expected a `module' declaration;\n" + " found end-of-file\n" + " in: ~e") + (object-name i))) + (define m-s (check-module-form s path)) + (define s2 (read-syntax (object-name i) i)) + (unless (eof-object? s2) + (error 'default-load-handler + (string-append "expected a `module' declaration;\n" + " found an extra form\n" + " in: ~e\n" + " found: ~.s") + (object-name i) + s2)) + (lambda () ((current-eval) m-s))]))))))] + [else + (define (add-top-interaction s) + (namespace-syntax-introduce + (datum->syntax #f (cons '#%top-interaction s) s))) + (call-with-input-file* + path + (lambda (i) + (maybe-count-lines! i) + (let loop ([vals (list (void))]) + (define s + (parameterize ([read-accept-compiled #t] + [read-accept-reader #t] + [read-accept-lang #t]) + (if (load-on-demand-enabled) + (parameterize ([read-on-demand-source (path->complete-path path)]) + (read-syntax (object-name i) i)) + (read-syntax (object-name i) i)))) + (if (eof-object? s) + (apply values vals) + (loop + (call-with-continuation-prompt + (lambda () + (call-with-values (lambda () ((current-eval) (add-top-interaction s))) list)) + (default-continuation-prompt-tag) + (lambda args + (apply abort-current-continuation (default-continuation-prompt-tag) args))))))))]))) + +(define (linklet-bundle-or-directory-start i tag) + (define version-length (string-length (version))) + (and (equal? (peek-byte i) (char->integer #\#)) + (equal? (peek-byte i 1) (char->integer #\~)) + (equal? (peek-byte i 2) version-length) + (equal? (peek-bytes version-length 3 i) (string->bytes/utf-8 (version))) + (equal? (peek-byte i (+ 3 version-length)) (char->integer tag)) + (+ version-length + ;; "#~" and tag and length byte: + 4))) + +(define (linklet-directory-start i) + (define pos (linklet-bundle-or-directory-start i #\D)) + (and pos (+ pos + ;; Bundle count: + 4))) + +(define (linklet-bundle-hash-code i) + (define pos (linklet-bundle-or-directory-start i #\B)) + (define hash-code (and pos (peek-bytes 20 pos i))) + (and (bytes? hash-code) + (= 20 (bytes-length hash-code)) + (for/or ([c (in-bytes hash-code)]) + (not (eq? c 0))) + hash-code)) + +(define (cached-bundle i) + (cond + [(module-cache-ref (make-module-cache-key (linklet-bundle-hash-code i))) + => (lambda (declare-module) + ;; The `declare-module` function has registered in the cace by + ;; `eval-module` in "eval/module.rkt"; we can call the function + ;; instead of loading from scratch and `eval`ing; + ;; FIXME: go though `current-eval` + (lambda () + (declare-module (current-namespace))))] + [else #f])) + +(define (read-number i) + (define (read-byte/not-eof i) + (define v (read-byte i)) + (if (eof-object? v) 0 v)) + (bitwise-ior (read-byte/not-eof i) + (arithmetic-shift (read-byte/not-eof i) 8) + (arithmetic-shift (read-byte/not-eof i) 16) + (arithmetic-shift (read-byte/not-eof i) 24))) + +(define (search-directory i pos bstr) + (cond + [(zero? pos) #f] + [else + (file-position i pos) + (define name-len (read-number i)) + (define v (read-bytes name-len i)) + (unless (and (bytes? v) (= (bytes-length v) name-len)) + (error 'deafult-load-handler + (string-append "failure getting submodule path\n" + " in: ~e\n" + " at position: ~a\n" + " expected bytes: ~a\n" + " read bytes: ~e") + (object-name i) + pos + name-len + v)) + (cond + [(bytes=? bstr v) (read-number i)] + [(bytesbytes/utf-8 (symbol->string s))) + (define len (bytes-length bstr)) + (cond + [(len . < . 255) (bytes-append (bytes len) bstr)] + [else (bytes-append 255 (integer->integer-bytes len 4 #f #f) bstr)])))])) + +(define (with-module-reading-parameterization+delay-source path thunk) + (if (load-on-demand-enabled) + (parameterize ([read-on-demand-source (path->complete-path path)]) + (with-module-reading-parameterization thunk)) + (with-module-reading-parameterization thunk))) + +(define (call-with-input-module-file path proc) + (define i #f) + (dynamic-wind + (lambda () (set! i (open-input-file path #:for-module? #t))) + (lambda () (proc i)) + (lambda () (close-input-port i)))) diff -Nru racket-6.12+ppa1/src/expander/boot/main-primitive.rkt racket-7.0+ppa1/src/expander/boot/main-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/main-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/main-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,90 @@ +#lang racket/base +(require "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../eval/reflect.rkt" + "../eval/load.rkt" + "../eval/parameter.rkt" + "../eval/collection.rkt" + (prefix-in wrapper: "../eval/api.rkt") + "../compile/recompile.rkt" + "../namespace/namespace.rkt" + "../namespace/api.rkt" + "../namespace/attach.rkt" + "../namespace/api-module.rkt") + +(provide main-primitives) + +(define main-primitives + (hasheq 'eval wrapper:eval + 'eval-syntax wrapper:eval-syntax + 'compile wrapper:compile + 'compile-syntax wrapper:compile-syntax + 'expand wrapper:expand + 'expand-syntax wrapper:expand-syntax + 'expand-once wrapper:expand-once + 'expand-syntax-once wrapper:expand-syntax-once + 'expand-to-top-form wrapper:expand-to-top-form + 'expand-syntax-to-top-form wrapper:expand-syntax-to-top-form + 'dynamic-require dynamic-require + 'dynamic-require-for-syntax dynamic-require-for-syntax + 'load load + 'load-extension load-extension + 'load/use-compiled load/use-compiled + + 'current-eval current-eval + 'current-compile current-compile + 'current-load current-load + 'current-load/use-compiled current-load/use-compiled + + 'collection-path collection-path + 'collection-file-path collection-file-path + 'find-library-collection-paths find-library-collection-paths + 'find-library-collection-links find-library-collection-links + + 'current-library-collection-paths current-library-collection-paths + 'current-library-collection-links current-library-collection-links + 'use-compiled-file-paths use-compiled-file-paths + 'current-compiled-file-roots current-compiled-file-roots + 'use-compiled-file-check use-compiled-file-check + 'use-collection-link-paths use-collection-link-paths + 'use-user-specific-search-paths use-user-specific-search-paths + + 'compiled-expression? compiled-expression? + 'compiled-module-expression? compiled-module-expression? + 'module-compiled-name module-compiled-name + 'module-compiled-submodules module-compiled-submodules + 'module-compiled-language-info module-compiled-language-info + 'module-compiled-imports module-compiled-imports + 'module-compiled-exports module-compiled-exports + 'module-compiled-indirect-exports module-compiled-indirect-exports + + 'compiled-expression-recompile compiled-expression-recompile + + 'make-empty-namespace make-empty-namespace + + 'namespace-attach-module namespace-attach-module + 'namespace-attach-module-declaration namespace-attach-module-declaration + + 'namespace-symbol->identifier namespace-symbol->identifier + 'namespace-module-identifier namespace-module-identifier + 'namespace-syntax-introduce namespace-syntax-introduce + 'namespace-require namespace-require + 'namespace-require/copy namespace-require/copy + 'namespace-require/constant namespace-require/constant + 'namespace-require/expansion-time namespace-require/expansion-time + 'namespace-variable-value namespace-variable-value + 'namespace-set-variable-value! namespace-set-variable-value! + 'namespace-undefine-variable! namespace-undefine-variable! + 'namespace-mapped-symbols namespace-mapped-symbols + 'namespace-base-phase namespace-base-phase + + 'module-declared? module-declared? + 'module-predefined? module-predefined? + 'module->language-info module->language-info + 'module->imports module->imports + 'module->exports module->exports + 'module->indirect-exports module->indirect-exports + 'module-compiled-cross-phase-persistent? module-compiled-cross-phase-persistent? + 'module-provide-protected? module-provide-protected? + 'module->namespace module->namespace + 'namespace-unprotect-module namespace-unprotect-module)) diff -Nru racket-6.12+ppa1/src/expander/boot/place-primitive.rkt racket-7.0+ppa1/src/expander/boot/place-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/place-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/place-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base + +;; When places are implemented by plain old threads, +;; place channels need to be shared across namespaces, +;; so `#%place-struct' is included in builtins. + +(provide place-struct-primitives) + +(define-values (struct:TH-place-channel TH-place-channel TH-place-channel? + TH-place-channel-ref TH-place-channel-set!) + (make-struct-type 'TH-place-channel #f 2 0 #f (list (cons prop:evt (lambda (x) (TH-place-channel-ref x 0)))))) + +(define-values (TH-place-channel-in TH-place-channel-out) + (values + (lambda (x) (TH-place-channel-ref x 0)) + (lambda (x) (TH-place-channel-ref x 1)))) + +(define place-struct-primitives + (hasheq 'struct:TH-place-channel struct:TH-place-channel + 'TH-place-channel TH-place-channel + 'TH-place-channel? TH-place-channel? + 'TH-place-channel-in TH-place-channel-in + 'TH-place-channel-out TH-place-channel-out)) diff -Nru racket-6.12+ppa1/src/expander/boot/read-primitive.rkt racket-7.0+ppa1/src/expander/boot/read-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/read-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/read-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,48 @@ +#lang racket/base +(require "../common/reflect-hash.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt" + "../read/readtable.rkt" + "../read/special-comment.rkt" + "../read/number.rkt") + +;; Reader primitives are in their own module so that they can be +;; treated specially by the bootstrapped flattened. The expanded form +;; of the expander can refer to the host's implementations, and those +;; references are replaced by these implementations. + +(provide read-primitives) + +(define read-primitives + (reflect-hash read + read/recursive + read-language + + string->number + + current-reader-guard + ;; read-case-sensitive - shared with printer + read-square-bracket-as-paren + read-curly-brace-as-paren + read-square-bracket-with-tag + read-curly-brace-with-tag + read-cdot + read-accept-graph + read-accept-compiled + read-accept-box + ;; read-accept-bar-quote - shared with printer + read-decimal-as-inexact + read-accept-dot + read-accept-infix-dot + read-accept-quasiquote + read-accept-reader + read-accept-lang + + current-readtable + readtable? + make-readtable + readtable-mapping + + special-comment? + make-special-comment + special-comment-value)) diff -Nru racket-6.12+ppa1/src/expander/boot/runtime-primitive.rkt racket-7.0+ppa1/src/expander/boot/runtime-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/runtime-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/runtime-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,52 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/module-path.rkt") + +(provide runtime-stx + runtime-module-name + + runtime-instances) + +;; Runtime primitives are implemented in the runtime system (and not +;; shadowed by the expander's primitives). They're re-exported by +;; '#%kernel, but originally exported by a '#%runtime module. The +;; expander needs to generate references to some '#%runtime` bindings. + +(define runtime-scope (new-multi-scope)) +(define runtime-stx (add-scope empty-syntax runtime-scope)) + +(define runtime-module-name (make-resolved-module-path '#%runtime)) +(define runtime-mpi (module-path-index-join ''#%runtime #f)) + +(define (add-runtime-primitive! sym) + (add-binding-in-scopes! (syntax-scope-set runtime-stx 0) + sym + (make-module-binding runtime-mpi 0 sym))) + +;; This is only a subset that we need to have bound; +;; the rest are added in "kernel.rkt" +(void + (begin + (add-runtime-primitive! 'values) + (add-runtime-primitive! 'cons) + (add-runtime-primitive! 'list) + (add-runtime-primitive! 'make-struct-type) + (add-runtime-primitive! 'make-struct-type-property) + (add-runtime-primitive! 'gensym) + (add-runtime-primitive! 'string->uninterned-symbol))) + +;; Instances that are built into the runtime system, but +;; not including '#%linklet +(define runtime-instances + '(#%kernel + #%paramz + #%foreign + #%unsafe + #%flfxnum + #%extfl + #%network + #%place + #%futures)) diff -Nru racket-6.12+ppa1/src/expander/boot/utils-primitive.rkt racket-7.0+ppa1/src/expander/boot/utils-primitive.rkt --- racket-6.12+ppa1/src/expander/boot/utils-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/boot/utils-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base +(require racket/private/config + "../common/reflect-hash.rkt" + (only-in "../eval/load.rkt" load/use-compiled) + "../eval/collection.rkt") + +(provide utils-primitives) + +;; These functions are a small step away from `#%kernel`, and they +;; have traditionally been available as the `#%utils` module. Don't +;; use `#%utils` in `racket/base`, since that's where the actual +;; implementation sometimes is. We turn the functions into a +;; "primitive" module using this table in a bootstrapped load. + +(define utils-primitives + (reflect-hash path-string? + normal-case-path + path-replace-extension + path-add-extension + reroot-path + + path-list-string->path-list + + find-executable-path + + call-with-default-reading-parameterization + + collection-path + collection-file-path + find-library-collection-paths + find-library-collection-links + + load/use-compiled + + find-main-config + find-main-collects)) diff -Nru racket-6.12+ppa1/src/expander/bootstrap-demo.rkt racket-7.0+ppa1/src/expander/bootstrap-demo.rkt --- racket-6.12+ppa1/src/expander/bootstrap-demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/bootstrap-demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,3 @@ +#lang racket/base +(require "run/bootstrap.rkt" ; must be before anything that uses "host/linklet.rkt" + "demo.rkt") diff -Nru racket-6.12+ppa1/src/expander/bootstrap-run.rkt racket-7.0+ppa1/src/expander/bootstrap-run.rkt --- racket-6.12+ppa1/src/expander/bootstrap-run.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/bootstrap-run.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +#lang racket/base +(require "run/bootstrap.rkt" ; must be before anything that uses "host/linklet.rkt" + "run.rkt") + diff -Nru racket-6.12+ppa1/src/expander/common/contract.rkt racket-7.0+ppa1/src/expander/common/contract.rkt --- racket-6.12+ppa1/src/expander/common/contract.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/contract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +#lang racket/base +(require racket/private/check) + +(provide (all-from-out racket/private/check)) diff -Nru racket-6.12+ppa1/src/expander/common/inline.rkt racket-7.0+ppa1/src/expander/common/inline.rkt --- racket-6.12+ppa1/src/expander/common/inline.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/inline.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-inline) + +(define-syntax (define-inline stx) + (syntax-case stx () + [(_ (proc-id arg ...) body ...) + (with-syntax ([(arg-id ...) + (for/list ([arg (in-list (syntax->list #'(arg ...)))]) + (syntax-case arg () + [(id def-val) #'id] + [else arg]))]) + (with-syntax ([(gen-id ...) + (generate-temporaries #'(arg-id ...))]) + #`(define-syntax proc-id + (syntax-rules () + [(_ gen-id ...) + (let ([arg-id gen-id] ...) + body ...)] + #,@(let loop ([args (syntax->list #'(arg ...))] [ids null]) + (cond + [(null? args) null] + [(identifier? (car args)) (loop (cdr args) (cons (car args) ids))] + [else + (syntax-case (car args) () + [(id def-expr) + (cons #`[(_ #,@(reverse ids)) + (proc-id #,@(reverse ids) def-expr)] + (loop (cdr args) (cons #'id ids)))])]))))))])) diff -Nru racket-6.12+ppa1/src/expander/common/intern.rkt racket-7.0+ppa1/src/expander/common/intern.rkt --- racket-6.12+ppa1/src/expander/common/intern.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/intern.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,141 @@ +#lang racket/base + +(provide make-weak-intern-table + weak-intern!) + +;; We can't always use Racket's weak hash tables for interning, +;; because those have a lock for `equal?` comparisons. This +;; implementation uses a box and `box-cas!` to transactionally update +;; the table after failing to find an entry (and if the transaction +;; fails, we look again for an entry). + +(struct weak-intern-table (box) + #:authentic) +(struct table (ht ; integer[hash code] -> list of weak boxes + count ; number of items in the table (= sum of list lengths) + prune-at) ; count at which we should try to prune empty weak boxes + #:authentic) + +(define (make-weak-intern-table) + (weak-intern-table (box (table (hasheqv) 0 128)))) + +(define (weak-intern! tt v) + (define b (weak-intern-table-box tt)) + (define t (unbox b)) + + (define code (equal-hash-code v)) + (define vals (hash-ref (table-ht t) code null)) + + (or + ;; In the table? + (for/or ([b (in-list vals)]) + (define bv (weak-box-value b)) + (and (equal? bv v) bv)) + ;; Not in the table: + (let* ([pruned-t (if (= (table-count t) (table-prune-at t)) + (prune-table t) + t)]) + (define ht (table-ht pruned-t)) + (define new-t + (table (hash-set ht code (cons (make-weak-box v) + (hash-ref ht code null))) + (add1 (table-count pruned-t)) + (table-prune-at pruned-t))) + ;; Try to install the updated table, and return `v` if it + ;; is successfully installed + (or (and (box-cas! b t new-t) + v) + ;; Transaction failed, so try again + (weak-intern! tt v))))) + +;; Remove empty weak boxes from a table. Count the number +;; of remaining entries, and remember to prune again when +;; the number of entries doubles (up to at least reaches 128) +(define (prune-table t) + (define new-ht + (for*/hash ([(k vals) (in-hash (table-ht t))] + [new-vals (in-value + (for/list ([b (in-list vals)] + #:when (weak-box-value b)) + b))] + #:when (pair? new-vals)) + (values k new-vals))) + (define count (for/sum ([(k vals) (in-hash new-ht)]) + (length vals))) + (table new-ht + count + (max 128 (* 2 count)))) + +;; ---------------------------------------- + +(module+ test + (define show-status? #f) + + (define N 10) ; number of threads + (define M 1000) ; number of values to intern and remember + (define P 100) ; number of values to intern and discard + + (struct val (key other) + #:transparent + #:property prop:equal+hash (list + (lambda (v1 v2 eql?) (eql? (val-key v1) (val-key v2))) + (lambda (v1 code) (code (val-key v1))) + (lambda (v1 code) (code (val-key v1))))) + + (define tt (make-weak-intern-table)) + + (define results (make-vector N #f)) + + (define threads + (for/list ([i (in-range N)]) + (thread + (lambda () + (vector-set! + results + i + (for/list ([j (in-range M)]) + (for/list ([k (in-range P)]) + (weak-intern! + tt + (val (format "~a + ~a" j k) i))) + (weak-intern! tt (val (number->string j) i)))))))) + + (define done? #f) + (define measure-thread + (thread + (lambda () + (when show-status? + (let loop () + (define t (unbox (weak-intern-table-box tt))) + (printf "~s [~s]\n" + (table-count t) + (hash-count (table-ht t))) + (unless done? + (sleep 1) + (loop))))))) + + (for-each sync threads) + + (collect-garbage) + (collect-garbage) + (set! done? #t) + + (void (sync measure-thread)) + + (let ([t (prune-table (unbox (weak-intern-table-box tt)))]) + (printf "Final pruning: ~s [~s]\n" + (table-count t) + (hash-count (table-ht t))) + (unless ((table-count t) . < . (* 3 M)) + (error "too many items are still in the table; not weak enough?"))) + + (for ([i (in-range N)]) + (unless (equal? (vector-ref results i) (vector-ref results 0)) + (error "mismatch" i))) + + ;; Make sure the results come from different threads: + (define representatives + (for/fold ([ht (hasheqv)]) ([v (in-list (vector-ref results 0))]) + (hash-update ht (val-other v) add1 0))) + (unless ((hash-count representatives) . > . (* 0.25 N)) + (error "poor representation among threads;\n something is wrong, or the test is not balanced enough"))) diff -Nru racket-6.12+ppa1/src/expander/common/list-ish.rkt racket-7.0+ppa1/src/expander/common/list-ish.rkt --- racket-6.12+ppa1/src/expander/common/list-ish.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/list-ish.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; A `list-ish` is like a `list`, but it can be an "improper list" that +;; doesn't end in null. Using `cons-ish` on an element and `null` returns +;; just the element. A `list-ish` makes sense when lists of length 1 +;; would otherwise be common, but only when elements are never lists. + +(provide cons-ish + in-list-ish) + +(define (cons-ish a b) + (if (null? b) + a + (cons a b))) + +(define-sequence-syntax in-list-ish + (lambda (stx) (raise-syntax-error #f "only allowed in a `for` form" stx)) + (lambda (stx) + (syntax-case stx () + [[(id) (_ lst-expr)] + (for-clause-syntax-protect + #'[(id) + (:do-in + ;;outer bindings + ([(lst) lst-expr]) + ;; outer check + (void) + ;; loop bindings + ([lst lst]) + ;; pos check + (not (null? lst)) + ;; inner bindings + ([(id) (if (pair? lst) (car lst) lst)] + [(rest) (if (pair? lst) (cdr lst) null)]) + ;; pre guard + #t + ;; post guard + #t + ;; loop args + (rest))])] + [_ #f]))) diff -Nru racket-6.12+ppa1/src/expander/common/make-match.rkt racket-7.0+ppa1/src/expander/common/make-match.rkt --- racket-6.12+ppa1/src/expander/common/make-match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/make-match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,229 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-define-match) + +;; Yet another pattern matcher along the lines of `syntax-rules`, but +;; intended for relatively simple and small patterns. +;; +;; The `define-match` form generated here has the following syntax to +;; match the result of against : +;; +;; (define-match ') +;; +;; = | #:when | #:unless +;; = | #:try +;; +;; = ; matches anything +;; | id: ; matches only identifiers +;; | ( ...) ; zero or more +;; | ( ...+) ; one or more +;; | ( . ) +;; +;; Note that the ' before doesn't produce a symbol or list; +;; it's just a literal to textually highlight the pattern. +;; +;; The bound by `define-match` is used as either +;; +;; () +;; +;; to check whether the match suceeded (which makes sense only if a +;; guard or `#:try` is included) or +;; +;; ( ') +;; +;; to access the value for a match. Again, the ' here does not produce +;; a symbol, but serves only as visual highlighting. +;; +;; Unlike `syntax-rules`/`syntax-case`/`syntax-parse`, there's no +;; template system and no help in making sure your uses of variables +;; before `...` expect the right shape. For example, with +;; +;; (define-match m s '(a ...)) +;; +;; then `(m 'a)` will always produce a list of matches of `a`. +;; +;; If a pattern doesn't match and there's no `#:try`, then a syntax +;; error is reported. +;; +;; The `define-define-match` form is a macro-generating macro so that +;; it can be used with different underlying notions of syntax, as +;; specific by the `rt-syntax?`, etc., macro arguments. + +(define-syntax-rule (define-define-match define-match + rt-syntax? rt-syntax-e rt-raise-syntax-error) + (... + (begin + (define-for-syntax (extract-pattern-ids pattern) + (cond + [(identifier? pattern) + (if (or (eq? '... (syntax-e pattern)) + (eq? '...+ (syntax-e pattern))) + null + (list pattern))] + [(symbol? pattern) + (if (or (eq? '... pattern) + (eq? '...+ pattern)) + null + (list pattern))] + [(syntax? pattern) (extract-pattern-ids (syntax-e pattern))] + [(pair? pattern) + (append (extract-pattern-ids (car pattern)) + (extract-pattern-ids (cdr pattern)))] + [else null])) + + ;; This pattern compiler has bad time complexity for complex + ;; patterns, because it keeps recomputing the set of pattern + ;; variables, but we're only going to use it on simple patterns + + (define-for-syntax (identifier-pattern? pattern) + (regexp-match? #rx"^id(:|$)" (symbol->string pattern))) + + (define-for-syntax (compile-pattern pattern already-checked?) + (cond + [(symbol? pattern) + (if (identifier-pattern? pattern) + (if already-checked? + #'s + #`(if (or (and (rt-syntax? s) + (symbol? (rt-syntax-e s))) + (symbol? s)) + s + (rt-raise-syntax-error #f "not an identifier" orig-s s))) + #'s)] + [else + #`(let ([s (if (rt-syntax? s) (rt-syntax-e s) s)]) + #,(cond + [(and (list? pattern) + (= (length pattern) 2) + (or (eq? '... (cadr pattern)) + (eq? '...+ (cadr pattern)))) + (with-syntax ([(pattern-id ...) (extract-pattern-ids (car pattern))]) + #`(let ([flat-s (to-syntax-list s)]) + (cond + [#,(if already-checked? #'#f #'(not flat-s)) + (rt-raise-syntax-error #f "bad syntax" orig-s)] + [#,(if (and (eq? '...+ (cadr pattern)) (not already-checked?)) #'(null? flat-s) #'#f) + (rt-raise-syntax-error #f "bad syntax" orig-s)] + [else + #,(if (and (symbol? (car pattern)) + (or (not (identifier-pattern? (car pattern))) + already-checked?)) + #`flat-s + #`(for/lists (pattern-id ...) ([s (in-list flat-s)]) + #,(compile-pattern (car pattern) already-checked?)))])))] + [(pair? pattern) + (with-syntax ([(a-pattern-id ...) (generate-temporaries (extract-pattern-ids (car pattern)))] + [(d-pattern-id ...) (generate-temporaries (extract-pattern-ids (cdr pattern)))]) + #`(if #,(if already-checked? #'#t #'(pair? s)) + (let-values ([(a-pattern-id ...) (let ([s (car s)]) #,(compile-pattern (car pattern) + already-checked?))] + [(d-pattern-id ...) (let ([s (cdr s)]) #,(compile-pattern (cdr pattern) + already-checked?))]) + (values a-pattern-id ... d-pattern-id ...)) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [(null? pattern) + (if already-checked? + #'(values) + #'(if (null? s) + (values) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [(or (keyword? pattern) + (boolean? pattern)) + (if already-checked? + #'(values) + #`(if (eq? '#,pattern s) + (values) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [else + (raise-syntax-error 'define-match "bad pattern" pattern)]))])) + + (define-for-syntax (compile-pattern-check pattern) + (cond + [(symbol? pattern) + (if (identifier-pattern? pattern) + #`(or (and (rt-syntax? s) + (symbol? (rt-syntax-e s))) + (symbol? s)) + #'#t)] + [else + #`(let ([s (if (rt-syntax? s) (rt-syntax-e s) s)]) + #,(cond + [(and (list? pattern) + (= (length pattern) 2) + (or (eq? '... (cadr pattern)) + (eq? '...+ (cadr pattern)))) + (with-syntax ([(pattern-id ...) (extract-pattern-ids (car pattern))]) + #`(let ([flat-s (to-syntax-list s)]) + (cond + [(not flat-s) #f] + [#,(if (eq? '...+ (cadr pattern)) #'(null? flat-s) #'#f) #f] + [else #,(if (and (symbol? (car pattern)) + (not (identifier-pattern? (car pattern)))) + #`#t + #`(for/and ([s (in-list flat-s)]) + #,(compile-pattern-check (car pattern))))])))] + [(pair? pattern) + (with-syntax ([(a-pattern-id ...) (extract-pattern-ids (car pattern))] + [(d-pattern-id ...) (extract-pattern-ids (cdr pattern))]) + #`(and (pair? s) + (let ([s (car s)]) #,(compile-pattern-check (car pattern))) + (let ([s (cdr s)]) #,(compile-pattern-check (cdr pattern)))))] + [(null? pattern) + #'(null? s)] + [(or (keyword? pattern) + (boolean? pattern)) + #`(eq? '#,pattern s)] + [else + (raise-syntax-error 'define-match "bad pattern" pattern)]))])) + + (define (to-syntax-list s) + (cond + [(list? s) s] + [(pair? s) + (define r (to-syntax-list (cdr s))) + (and r (cons (car s) r))] + [(rt-syntax? s) (to-syntax-list (rt-syntax-e s))] + [else #f])) + + (define-syntax (define-match stx) + (syntax-case stx (quote) + [(_ id expr 'pattern) + #'(do-define-match id expr 'pattern #:when #t #:try? #f)] + [(_ id expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when #t #:try? #t)] + [(_ id expr #:when guard-expr 'pattern) + #'(do-define-match id expr 'pattern #:when guard-expr #:try? #f)] + [(_ id expr #:when guard-expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when guard-expr #:try? #t)] + [(_ id expr #:unless guard-expr 'pattern) + #'(do-define-match id expr 'pattern #:when (not guard-expr) #:try? #f)] + [(_ id expr #:unless guard-expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when (not guard-expr) #:try? #t)])) + + (define-syntax (do-define-match stx) + (syntax-case stx (quote) + [(_ id expr 'pattern #:when guard-expr #:try? try?) + (let ([pattern-ids (extract-pattern-ids #'pattern)] + [try? (syntax-e #'try?)]) + (with-syntax ([(pattern-id ...) pattern-ids] + [(pattern-result-id ...) (generate-temporaries pattern-ids)] + [(false-result ...) (map (lambda (x) #'#f) pattern-ids)] + [matcher (compile-pattern (syntax->datum #'pattern) try?)]) + #`(begin + (define-values (ok? pattern-result-id ...) + (let ([s expr]) + (if (and guard-expr + #,(if try? + (compile-pattern-check (syntax->datum #'pattern)) + #'#t)) + (let ([orig-s s]) + (let-values ([(pattern-result-id ...) matcher]) + (values #t pattern-result-id ...))) + (values #f false-result ...)))) + (define-syntax id + (syntax-rules (quote pattern-id ...) + [(m) ok?] + [(m (quote pattern-id)) + pattern-result-id] + ...)))))]))))) diff -Nru racket-6.12+ppa1/src/expander/common/memo.rkt racket-7.0+ppa1/src/expander/common/memo.rkt --- racket-6.12+ppa1/src/expander/common/memo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/memo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-memo-lite) + +;; Lightweight memorization by storing only the most recent result +(define-syntax (define-memo-lite stx) + (syntax-case stx () + [(_ (id arg ...) body0 body ...) + (with-syntax ([(prev-val ...) (generate-temporaries #'(arg ...))]) + #'(begin + (define prev-val #f) ... + (define prev-result #f) + (define (id arg ...) + (cond + [(and (eq? prev-val arg) ...) + prev-result] + [else + (define r (let () + body0 + body ...)) + (set! prev-val arg) ... + (set! prev-result r) + r]))))])) diff -Nru racket-6.12+ppa1/src/expander/common/module-path-intern.rkt racket-7.0+ppa1/src/expander/common/module-path-intern.rkt --- racket-6.12+ppa1/src/expander/common/module-path-intern.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/module-path-intern.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +#lang racket/base +(require "module-path.rkt" + (submod "module-path.rkt" for-intern)) + +(provide make-module-path-index-intern-table + intern-module-path-index!) + +(struct mpi-intern-table (normal ; name[not #f] -[`equal?`-based]-> base -[`eq?`-based]-> module path index + fast)) ; superset, but `eq?`-keyed for fast already-interned checks + +(define (make-module-path-index-intern-table) + (mpi-intern-table (make-hash) (make-hasheq))) + +(define (intern-module-path-index! t mpi) + (or (hash-ref (mpi-intern-table-fast t) mpi #f) + (let-values ([(name base) (module-path-index-split mpi)]) + (cond + [(not name) + (hash-set! (mpi-intern-table-fast t) mpi mpi) + mpi] + [else + (define interned-base (and base + (intern-module-path-index! t base))) + (define at-name + (or (hash-ref (mpi-intern-table-normal t) name #f) + (let ([at-name (make-hasheq)]) + (hash-set! (mpi-intern-table-normal t) name at-name) + at-name))) + (define i-mpi + (or (hash-ref at-name interned-base #f) + (let ([mpi (if (eq? base interned-base) + mpi + (struct-copy module-path-index mpi + [base interned-base]))]) + (hash-set! at-name interned-base mpi) + mpi))) + (hash-set! (mpi-intern-table-fast t) mpi i-mpi) + i-mpi])))) diff -Nru racket-6.12+ppa1/src/expander/common/module-path.rkt racket-7.0+ppa1/src/expander/common/module-path.rkt --- racket-6.12+ppa1/src/expander/common/module-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/module-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,479 @@ +#lang racket/base +(require ffi/unsafe/atomic + "../compile/serialize-property.rkt" + "contract.rkt" + "parse-module-path.rkt" + "intern.rkt") + +(provide module-path? + + resolved-module-path? + make-resolved-module-path + resolved-module-path-name + resolved-module-path-root-name + resolved-module-path->module-path + + module-path-index? + module-path-index-resolve + module-path-index-unresolve + module-path-index-join + module-path-index-split + module-path-index-submodule + make-self-module-path-index + make-generic-self-module-path-index + imitate-generic-module-path-index! + module-path-index-shift + module-path-index-resolved ; returns #f if not yet resolved + + top-level-module-path-index + top-level-module-path-index? + non-self-module-path-index? + + resolve-module-path + current-module-name-resolver + build-module-name + + current-module-declare-name + current-module-declare-source + substitute-module-declare-name + + deserialize-module-path-index) + +(module+ for-intern + (provide (struct-out module-path-index))) + +;; ---------------------------------------- + +(struct resolved-module-path (name) + #:authentic + #:property prop:equal+hash + ;; Although equal resolved module paths are `eq?` externally, + ;; we need this equality predicate to hash them for the + ;; interning table + (list (lambda (a b eql?) + (eql? (resolved-module-path-name a) + (resolved-module-path-name b))) + (lambda (a hash-code) + (hash-code (resolved-module-path-name a))) + (lambda (a hash-code) + (hash-code (resolved-module-path-name a)))) + #:property prop:custom-write + (lambda (r port mode) + (when mode + (write-string "#" port))) + #:property prop:serialize + (lambda (r ser-push! state) + (ser-push! 'tag '#:resolved-module-path) + (ser-push! (resolved-module-path-name r)))) + +(define (deserialize-resolved-module-path n) + (make-resolved-module-path n)) + +(define (format-resolved-module-path-name p) + (cond + [(path? p) (string-append "\"" (path->string p) "\"")] + [(symbol? p) (format-symbol p)] + [else (format-submod (format-resolved-module-path-name (car p)) + (cdr p))])) + +(define (format-symbol p) + (format "'~s~a" p (if (symbol-interned? p) + "" + (format "[~a]" (eq-hash-code p))))) + +(define (format-submod base syms) + (format "(submod ~a~a)" + base + (apply string-append (for/list ([i (in-list syms)]) + (format " ~s" i))))) + +(define (resolved-module-path-root-name r) + (define name (resolved-module-path-name r)) + (if (pair? name) + (car name) + name)) + +(define resolved-module-paths (make-weak-intern-table)) + +(define (make-resolved-module-path p) + (unless (or (symbol? p) + (and (path? p) (complete-path? p)) + (and (pair? p) + (pair? (cdr p)) + (list? p) + (or (symbol? (car p)) + (and (path? (car p)) (complete-path? (car p)))) + (for/and ([s (in-list (cdr p))]) + (symbol? s)))) + (raise-argument-error 'make-resolved-module-path + (string-append + "(or/c symbol?\n" + " (and/c path? complete-path?)\n" + " (cons/c (or/c symbol?\n" + " (and/c path? complete-path?))\n" + " (non-empty-listof symbol?)))") + p)) + (weak-intern! resolved-module-paths (resolved-module-path p))) + +(define (resolved-module-path->module-path r) + (define name (resolved-module-path-name r)) + (define root-name (if (pair? name) (car name) name)) + (define root-mod-path (if (path? root-name) + root-name + `(quote ,root-name))) + (if (pair? name) + `(submod ,root-mod-path ,@(cdr name)) + root-mod-path)) + +;; ---------------------------------------- + +(struct module-path-index (path base [resolved #:mutable] [shift-cache #:mutable]) + #:authentic + #:property prop:equal+hash + (list (lambda (a b eql?) + (and (eql? (module-path-index-path a) + (module-path-index-path b)) + (eql? (module-path-index-base a) + (module-path-index-base b)))) + (lambda (a hash-code) + (+ (hash-code (module-path-index-path a)) + (hash-code (module-path-index-base a)))) + (lambda (a hash-code) + (+ (hash-code (module-path-index-path a)) + (hash-code (module-path-index-base a))))) + #:property prop:custom-write + (lambda (r port mode) + (write-string "#" port))) + +;; Serialization of a module path index is handled specially, because they +;; must be shared across phases of a module +(define deserialize-module-path-index + (case-lambda + [(path base) (module-path-index-join path base)] + [(name) (make-self-module-path-index (make-resolved-module-path name))] + [() top-level-module-path-index])) + +(define/who (module-path-index-resolve mpi [load? #f]) + (check who module-path-index? mpi) + (or (module-path-index-resolved mpi) + (let ([mod-name ((current-module-name-resolver) + (module-path-index-path mpi) + (module-path-index-resolve/maybe + (module-path-index-base mpi) + load?) + #f + load?)]) + (unless (resolved-module-path? mod-name) + (raise-arguments-error 'module-path-index-resolve + "current module name resolver's result is not a resolved module path" + "result" mod-name)) + (set-module-path-index-resolved! mpi mod-name) + mod-name))) + +(define (module-path-index-unresolve mpi) + (cond + [(module-path-index-resolved mpi) + (define-values (path base) (module-path-index-split mpi)) + (module-path-index-join path base)] + [else mpi])) + +(define/who (module-path-index-join mod-path base [submod #f]) + (check who #:or-false module-path? mod-path) + (unless (or (not base) + (resolved-module-path? base) + (module-path-index? base)) + (raise-argument-error who "(or/c #f resolved-module-path? module-path-index?)" base)) + (unless (or (not submod) + (and (pair? submod) + (list? submod) + (andmap symbol? submod))) + (raise-argument-error who "(or/c #f (non-empty-listof symbol?))" submod)) + (when (and (not mod-path) + base) + (raise-arguments-error who + "cannot combine #f path with non-#f base" + "given base" base)) + (when (and submod mod-path) + (raise-arguments-error who + "cannot combine #f submodule list with non-#f module path" + "given module path" mod-path + "given submodule list" submod)) + (cond + [submod + (make-self-module-path-index (make-resolved-module-path + (cons generic-module-name submod)))] + [else + (define keep-base + (let loop ([mod-path mod-path]) + (cond + [(path? mod-path) #f] + [(and (pair? mod-path) (eq? 'quote (car mod-path))) #f] + [(symbol? mod-path) #f] + [(and (pair? mod-path) (eq? 'submod (car mod-path))) + (loop (cadr mod-path))] + [else base]))) + (module-path-index mod-path keep-base #f #f)])) + +(define (module-path-index-resolve/maybe base load?) + (if (module-path-index? base) + (module-path-index-resolve base load?) + base)) + +(define/who (module-path-index-split mpi) + (check who module-path-index? mpi) + (values (module-path-index-path mpi) + (module-path-index-base mpi))) + +(define/who (module-path-index-submodule mpi) + (check who module-path-index? mpi) + (and (not (module-path-index-path mpi)) + (let ([r (module-path-index-resolved mpi)]) + (and r + (let ([p (resolved-module-path-name r)]) + (and (pair? p) + (cdr p))))))) + +(define make-self-module-path-index + (case-lambda + [(name) (module-path-index #f #f name #f)] + [(name enclosing) + (make-self-module-path-index (build-module-name name + (and enclosing + (module-path-index-resolve enclosing))))])) + +;; A "generic" module path index is used by the exansion of `module`; every +;; expanded module (at the same submodule nesting and name) uses the same +;; generic module path, so that compilation can recognize references within +;; the module to itself, and so on +(define generic-self-mpis (make-weak-hash)) +(define generic-module-name '|expanded module|) + +;; Return a module path index that is the same for a given +;; submodule path in the given self module path index +(define (make-generic-self-module-path-index self) + (define r (resolved-module-path-to-generic-resolved-module-path + (module-path-index-resolved self))) + ;; The use of `generic-self-mpis` must be atomic, so that the + ;; current thread cannot be killed, since that could leave + ;; the table locked + (start-atomic) + (begin0 + (or (let ([e (hash-ref generic-self-mpis r #f)]) + (and e (ephemeron-value e))) + (let ([mpi (module-path-index #f #f r #f)]) + (hash-set! generic-self-mpis r (make-ephemeron r mpi)) + mpi)) + (end-atomic))) + +(define (resolved-module-path-to-generic-resolved-module-path r) + (define name (resolved-module-path-name r)) + (make-resolved-module-path + (if (symbol? name) + generic-module-name + (cons generic-module-name (cdr name))))) + +;; Mutate the resolved path in `mpi` to use the root module name of a +;; generic module path index, which means that future +;; `free-identifier=?` comparisons with the generic module path index +;; will succeed +(define (imitate-generic-module-path-index! mpi) + (define r (module-path-index-resolved mpi)) + (when r + (set-module-path-index-resolved! mpi + (resolved-module-path-to-generic-resolved-module-path r)))) + +(define (module-path-index-shift mpi from-mpi to-mpi) + (cond + [(eq? mpi from-mpi) to-mpi] + [else + (define base (module-path-index-base mpi)) + (cond + [(not base) mpi] + [else + (define shifted-base (module-path-index-shift base from-mpi to-mpi)) + (cond + [(eq? shifted-base base) mpi] + [(shift-cache-ref (module-path-index-shift-cache shifted-base) mpi)] + [else + (define shifted-mpi + (module-path-index (module-path-index-path mpi) shifted-base #f #f)) + (shift-cache-set! (module-path-index-shift-cache! shifted-base) mpi shifted-mpi) + shifted-mpi])])])) + +(define (module-path-index-shift-cache! mpi) + (or (let ([cache (module-path-index-shift-cache mpi)]) + (and cache + (weak-box-value cache) + cache)) + (let ([cache (make-weak-box (box #hasheq()))]) + (set-module-path-index-shift-cache! mpi cache) + cache))) + +(define (shift-cache-ref cache v) + (and cache + (let ([b (weak-box-value cache)]) + (and b (hash-ref (unbox b) v #f))))) + +(define (shift-cache-set! cache v r) + (define b (weak-box-value cache)) + (when b + (set-box! b (hash-set (unbox b) v r)))) + +;; A constant module path index to represent the top level +(define top-level-module-path-index + (make-self-module-path-index + (make-resolved-module-path 'top-level))) + +(define (top-level-module-path-index? mpi) + (eq? top-level-module-path-index mpi)) + +(define (non-self-module-path-index? mpi) + (and (module-path-index-path mpi) #t)) + +;; ---------------------------------------- + +(define (resolve-module-path mod-path base) + ((current-module-name-resolver) mod-path base #f #t)) + +;; The resolver in "../boot/handler.rkt" replaces this one +;; as the value of `current-module-name-resolver` +(define core-module-name-resolver + (case-lambda + [(name from-namespace) + ;; No need to register + (void)] + [(p enclosing source-stx-stx load?) + (unless (module-path? p) + (raise-argument-error 'core-module-name-resolver "module-path?" p)) + (unless (or (not enclosing) + (resolved-module-path? enclosing)) + (raise-argument-error 'core-module-name-resolver "resolved-module-path?" enclosing)) + (cond + [(and (list? p) + (= (length p) 2) + (eq? 'quote (car p)) + (symbol? (cadr p))) + (make-resolved-module-path (cadr p))] + [(and (list? p) + (eq? 'submod (car p)) + (equal? ".." (cadr p))) + (for/fold ([enclosing enclosing]) ([s (in-list (cdr p))]) + (build-module-name s enclosing #:original p))] + [(and (list? p) + (eq? 'submod (car p)) + (equal? "." (cadr p))) + (for/fold ([enclosing enclosing]) ([s (in-list (cddr p))]) + (build-module-name s enclosing #:original p))] + [(and (list? p) + (eq? 'submod (car p))) + (let ([base ((current-module-name-resolver) (cadr p) enclosing #f #f)]) + (for/fold ([enclosing base]) ([s (in-list (cddr p))]) + (build-module-name s enclosing #:original p)))] + [else + (error 'core-module-name-resolver + "not a supported module path: ~v" p)])])) + +;; Build a submodule name given an enclosing module name, if cany +(define (build-module-name name ; a symbol + enclosing ; #f => no enclosing module + #:original [orig-name name]) ; for error reporting + (define enclosing-module-name (and enclosing + (resolved-module-path-name enclosing))) + (make-resolved-module-path + (cond + [(not enclosing-module-name) name] + [(symbol? enclosing-module-name) (list enclosing-module-name name)] + [(equal? name "..") + (cond + [(symbol? enclosing-module-name) + (error "too many \"..\"s:" orig-name)] + [(= 2 (length enclosing-module-name)) (car enclosing-module-name)] + [else (reverse (cdr (reverse enclosing-module-name)))])] + [else (append enclosing-module-name (list name))]))) + +;; Parameter that can be set externally: +(define current-module-name-resolver + (make-parameter + core-module-name-resolver + (lambda (v) + (unless (and (procedure? v) + (procedure-arity-includes? v 2) + (procedure-arity-includes? v 4)) + (raise-argument-error 'current-module-name-resolver + "(and/c (procedure-arity-includes/c 2) (procedure-arity-includes/c 4))" + v)) + v))) + +;; ---------------------------------------- + +(define current-module-declare-name + (make-parameter #f + (lambda (r) + (unless (or (not r) + (resolved-module-path? r)) + (raise-argument-error 'current-module-declare-name + "(or/c #f resolved-module-path?)" + r)) + r))) + +(define current-module-declare-source + (make-parameter #f + (lambda (s) + (unless (or (not s) + (symbol? s) + (and (path? s) (complete-path? s))) + (raise-argument-error 'current-module-declare-source + "(or/c #f symbol? (and/c path? complete-path?))" + s)) + s))) + +(define (substitute-module-declare-name default-name) + (define current-name (current-module-declare-name)) + (define root-name (if current-name + (resolved-module-path-root-name current-name) + (if (pair? default-name) + (car default-name) + default-name))) + (make-resolved-module-path + (if (pair? default-name) + (cons root-name (cdr default-name)) + root-name))) diff -Nru racket-6.12+ppa1/src/expander/common/parse-module-path.rkt racket-7.0+ppa1/src/expander/common/parse-module-path.rkt --- racket-6.12+ppa1/src/expander/common/parse-module-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/parse-module-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,452 @@ +#lang racket/base + +(provide module-path?) + +;; This parser for module paths is written in a relatively primitive +;; style, becaue it's applied often and we want it to be fast. + +(define (module-path? v) + (or (and (pair? v) + (eq? (car v) 'submod) + (submodule-module-path? v)) + (root-module-path? v))) + +(define (root-module-path? v) + (or (path? v) + (and (string? v) + (string-module-path? v)) + (and (symbol? v) + (symbol-module-path? v)) + (and (pair? v) + (case (car v) + [(quote) (and (pair? (cdr v)) + (symbol? (cadr v)) + (null? (cddr v)))] + [(lib) (lib-module-path? v)] + [(file) (and (pair? (cdr v)) + (string? (cadr v)) + (path-string? (cadr v)) + (null? (cddr v)))] + [(planet) (planet-module-path? v)] + [else #f])))) + +(define (submodule-module-path? v) + (and (pair? (cdr v)) + (list? v) + (or (equal? (cadr v) "..") + (equal? (cadr v) ".") + (root-module-path? (cadr v))) + (for/and ([e (in-list (cddr v))]) + (or (equal? e "..") + (symbol? e))))) + +(define (string-module-path? v) + (module-path-string? v #:dots-dir-ok? #t #:just-file-ok? #t #:file-end-ok? #t)) + +(define (symbol-module-path? v) + (module-path-string? (symbol->string v))) + +(define (lib-module-path? v) + (and (list? v) + (pair? (cdr v)) + (let loop ([v (cdr v)] [first? #t]) + (or (null? v) + (and (string? (car v)) + (module-path-string? (car v) + #:just-file-ok? first? + #:file-end-ok? first?) + (loop (cdr v) #f)))))) + +(define (planet-module-path? v) + (and (list? v) + (case (length v) + [(1) #f] + [(2) + (define e (cadr v)) + (cond + [(string? e) + (module-path-string? e + #:for-planet? #t + #:file-end-ok? #t)] + [(symbol? e) + (module-path-string? (symbol->string e) + #:for-planet? #t)] + [else #f])] + [else + (define file (cadr v)) + (define pkg (caddr v)) + (define subs (cdddr v)) + (and file + (module-path-string? file + #:just-file-ok? #t + #:file-end-ok? #t) + (and (list? pkg) + (<= 2 (length pkg) 4) + (planet-user/pkg-string? (car pkg)) + (planet-user/pkg-string? (cadr pkg)) + (or (null? (cddr pkg)) + (planet-version-number? (caddr pkg)) + (and (or (null? (cddr pkg)) + (planet-version-minor-spec? (cadddr pkg)))))) + (for/and ([sub (in-list subs)]) + (module-path-string? sub)))]))) + +(define (planet-version-number? v) + (exact-nonnegative-integer? v)) + +(define (planet-version-minor-spec? v) + (or (planet-version-number? v) + (and (pair? v) + (list? v) + (= 2 (length v)) + (case (car v) + [(= + -) + (planet-version-number? (cadr v))] + [else + (and (planet-version-number? (car v)) + (planet-version-number? (cadr v)))])))) + +;; ---------------------------------------- + +(define (module-path-string? v + #:for-planet? [for-planet? #f] + #:dots-dir-ok? [dots-dir-ok? #f] + #:just-file-ok? [just-file-ok? #f] + #:file-end-ok? [file-end-ok? #f]) + (define len (string-length v)) + (and (positive? len) + (not (char=? #\/ (string-ref v 0))) + (not (char=? #\/ (string-ref v (sub1 len)))) + (let-values ([(start-package-version-pos end-package-version-pos) + (if for-planet? + (check-planet-part v len) + (values 0 0))]) + (and + start-package-version-pos + (let loop ([i (sub1 len)] + [prev-was-slash? #f] + [saw-slash? (not file-end-ok?)] + [saw-dot? #f]) + (cond + [(not (negative? i)) + ;; check next character + (define c (string-ref v i)) + (cond + [(char=? c #\/) + (and (not prev-was-slash?) + (loop (sub1 i) #t #t saw-dot?))] + [(char=? c #\.) + (if (and ((add1 i) . < . len) + (not (char=? (string-ref v (add1 i)) #\/)) + (not (char=? (string-ref v (add1 i)) #\.))) + (and (not saw-slash?) ; can't have suffix on a directory + (loop (sub1 i) #f saw-slash? #t)) + (loop (sub1 i) #f saw-slash? saw-dot?))] + [(or (plain-char? c) + (and (char=? c #\%) + ((+ i 2) . < . len) + (hex-sequence? v (add1 i)))) + (loop (sub1 i) #f saw-slash? saw-dot?)] + [(and (i . >= . start-package-version-pos) (i . < . end-package-version-pos)) + ;; We've already checked characters in the package-version range + (loop (sub1 i) #f saw-slash? saw-dot?)] + [else #f])] + [else + ;; checked all characters + (and + ;; can't have a file name with no directory + (not (and (not just-file-ok?) + saw-dot? + (not saw-slash?))) + + (or dots-dir-ok? + ;; double-check for delimited "." or ".." + (let loop ([i 0]) + (cond + [(= i len) #t] + [(char=? (string-ref v i) #\.) + (and + ;; not "." + (not (or (= len (add1 i)) + (char=? (string-ref v (add1 i)) #\/))) + ;; not ".." + (not (and (char=? (string-ref v (add1 i)) #\.) + (or (= len (+ i 2)) + (char=? (string-ref v (+ i 2)) #\/)))) + ;; Skip over "."s: + (loop (let loop ([i i]) + (if (char=? #\. (string-ref v i)) + (loop (add1 i)) + i))))] + [else (loop (add1 i))]))))])))))) + +(define (planet-user/pkg-string? v) + (and (string? v) + (let ([len (string-length v)]) + (and (positive? len) + (for/and ([c (in-string v)] + [i (in-naturals)]) + (or (plain-char? c) + (char=? #\. c) + (and (char=? #\% c) + (i . < . (- len 2)) + (hex-sequence? v (add1 i))))))))) + +(define (plain-char? c) + (or (char<=? #\a c #\z) + (char<=? #\A c #\Z) + (char<=? #\0 c #\9) + (char=? #\- c) + (char=? #\_ c) + (char=? #\+ c))) + +(define (hex-sequence? s i) + (define c1 (string-ref s i)) + (define c2 (string-ref s (add1 i))) + (and (hex-char? c1) + (hex-char? c2) + (let ([c (integer->char (+ (* (hex-char->integer c1) 16) + (hex-char->integer c2)))]) + (not (plain-char? c))))) + +(define (hex-char? c) + (or (char<=? #\a c #\f) + (char<=? #\0 c #\9))) + +(define (hex-char->integer c) + (cond + [(char<=? #\a c #\f) + (- (char->integer c) (+ 10 (char->integer #\a)))] + [(char<=? #\A c #\F) + (- (char->integer c) (+ 10 (char->integer #\A)))] + [else + (- (char->integer c) (char->integer #\0))])) + +;; ---------------------------------------- + +(define (check-planet-part v len) + ;; Must have at least two slashes, and a version spec is allowed between them + (define-values (start-package-version-pos end-package-version-pos colon1-pos colon2-pos) + (let loop ([j 0] + [start-package-version-pos #f] [end-package-version-pos #f] + [colon1-pos #f] [colon2-pos #f]) + (cond + [(= j len) (values start-package-version-pos (or end-package-version-pos j) + colon1-pos colon2-pos)] + [else + (case (string-ref v j) + [(#\/) + (loop (add1 j) + (or start-package-version-pos (add1 j)) + (and start-package-version-pos + (or end-package-version-pos j)) + colon1-pos colon2-pos)] + [(#\:) + (cond + [colon2-pos (values #f #f #f #f)] + [colon1-pos + (loop (add1 j) + start-package-version-pos end-package-version-pos + colon1-pos j)] + [else + (loop (add1 j) + start-package-version-pos end-package-version-pos + j #f)])] + [else + (loop (add1 j) + start-package-version-pos end-package-version-pos + colon1-pos colon2-pos)])]))) + + (cond + [(and start-package-version-pos + (end-package-version-pos . > . start-package-version-pos) + (or (not colon2-pos) ((add1 colon2-pos) . < . end-package-version-pos))) + (cond + [colon1-pos + ;; Check that the version spec is well-formed + (define colon1-end (or colon2-pos end-package-version-pos)) + (cond + [(and (integer-sequence? v (add1 colon1-pos) colon1-end) + (or (not colon2-pos) + (case (string-ref v (add1 colon2-pos)) + [(#\=) + (integer-sequence? v (+ 2 colon2-pos) end-package-version-pos)] + [(#\> #\<) + (cond + [(and ((+ 2 colon2-pos) . < . end-package-version-pos) + (char=? #\= (string-ref v (+ colon2-pos 2)))) + (integer-sequence? v (+ 3 colon2-pos) end-package-version-pos)] + [else + (integer-sequence? v (+ 2 colon2-pos) end-package-version-pos)])] + [else + (integer-range-sequence? v (add1 colon2-pos) end-package-version-pos)]))) + ;; Version spec => need to skip a range + (values colon1-pos end-package-version-pos)] + [else + ;; Bad version spec + (values #f #f)])] + [else + ;; No version spec => nothing to skip later + (values 0 0)])] + [else + ;; Bad 'planet path + (values #f #f)])) + +(define (integer-sequence? s start end) + (and (start . < . end) + (for/and ([i (in-range start end)]) + (char<=? #\0 (string-ref s i) #\9)))) + +(define (integer-range-sequence? s start end) + (and (start . < . end) + (for/and ([i (in-range start end)]) + (define c (string-ref s i)) + (or (char=? c #\-) + (char<=? #\0 c #\9))) + (1 . >= . (for/sum ([i (in-range start end)]) + (if (char=? (string-ref s i) #\-) + 1 + 0))))) + +;; ---------------------------------------- + +(module+ test + (define (test ok? v) + (unless (equal? ok? (module-path? v)) + (error 'module-path?-test "failed ~s; expected ~a" v ok?))) + + (test #t "hello") + (test #t "hello.rkt") + (test #f "hello*ss") + (test #t "hello%2ess") + (test #t "hello%00ss") + (test #f "hello%2Ess") + (test #f "hello%41ss") + (test #f "hello%4") + (test #f "hello%") + (test #f "hello%q0") + (test #f "hello%0q") + (test #f "foo.rkt/hello") + (test #f "foo/") + (test #f "a/foo/") + (test #f "/foo.rkt") + (test #f "/a/foo.rkt") + (test #f "a/foo.rkt/b") + (test #t "a/foo%2ess/b") + (test #t "a/_/b") + (test #t "a/0123456789+-_/b.---") + (test #t "a/0123456789+-_/b.-%2e") + (test #t "../foo.rkt") + (test #t "x/../foo.rkt") + (test #t "x/./foo.rkt") + (test #t "x/.") + (test #t "x/..") + + (test #f "@") + (test #f "\0") + (test #f "x@") + (test #f "x\0") + (test #f "@x") + (test #f "\0x") + + (test #t (collection-file-path "module.rktl" "tests" "racket")) + (test #t (string->path "x")) + + (test #t 'hello) + (test #f 'hello/) + (test #f 'hello.rkt) + (test #t 'hello%2ess) + (test #f 'hello%2Ess) + (test #f 'hello/a.rkt) + (test #f '/hello/a.rkt) + (test #f '/hello) + (test #f '/a/hello) + (test #f 'a//hello) + (test #f '../hello) + (test #f './hello) + (test #f 'a/../hello) + (test #f 'b/./hello) + (test #f 'b/*/hello) + + (test #t '(lib "hello")) + (test #f '(lib "hello/")) + (test #f '(lib "hello/../b")) + (test #t '(lib "hello/a")) + (test #t '(lib "hello/a.rkt")) + (test #f '(lib "hello.bb/a.rkt")) + (test #f '(lib "/hello/a.rkt")) + (test #t '(lib "hello/a.rkt" "ack")) + (test #t '(lib "hello/a.rkt" "ack" "bar")) + (test #t '(lib "hello/a.rkt" "ack/bar")) + (test #f '(lib "hello/a.rkt" "ack/")) + (test #f '(lib "hello/a.rkt" "ack" "/bar")) + (test #f '(lib "hello/a.rkt" "ack" "..")) + (test #f '(lib "hello/a.rkt" "ack" bar)) + (test #f '(lib "hello/a.rkt" . bar)) + (test #f '(lib . "hello/a.rkt")) + (test #f '(lib)) + + (test #f '(planet)) + (test #f '(planet robby)) + (test #t '(planet robby/redex)) + (test #t '(planet robby%2e/%2eredex)) + (test #f '(planet robby%2/redex)) + (test #f '(planet robby/redex%2)) + (test #f '(planet robby/redex/)) + (test #f '(planet robby/redex/foo/)) + (test #f '(planet /robby/redex/foo)) + (test #f '(planet robby/redex.plt/foo)) + (test #f '(planet robby/redex/foo.rkt)) + (test #f '(planet robby/redex/foo.rkt/bar)) + (test #f '(planet robby/../foo)) + (test #t '(planet robby/redex/foo)) + (test #t '(planet robby/redex/foo/bar)) + (test #t '(planet robby/redex:7/foo)) + (test #t '(planet robby/redex:7)) + (test #t '(planet robby/redex:7:8/foo)) + (test #t '(planet robby/redex:7:<=8/foo)) + (test #t '(planet robby/redex:7:>=8/foo)) + (test #t '(planet robby/redex:7:8-9/foo)) + (test #t '(planet robby/redex:7:8-9)) + (test #t '(planet robby/redex:700:800-00900/foo)) + (test #t '(planet robby/redex:700:800-00900/foo%2e)) + (test #f '(planet robby/redex:=7/foo)) + (test #f '(planet robby/redex::8/foo)) + (test #f '(planet robby/redex:7:/foo)) + (test #f '(planet robby/redex.plt:7:8/foo)) + (test #f '(planet robby/redex:a/foo)) + (test #f '(planet robby/redex:7:a/foo)) + (test #f '(planet robby/redex:7:a-10/foo)) + (test #f '(planet robby/redex:7:10-a/foo)) + + (test #f '(planet "foo.rkt")) + (test #t '(planet "foo.rkt" ("robby" "redex.plt"))) + (test #f '(planet "../foo.rkt" ("robby" "redex.plt"))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 (7 8)))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 8))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 (= 8)))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt") "sub" "deeper")) + (test #t '(planet "foo%2e.rkt" ("robby%2e" "redex%2e.plt") "sub%2e" "%2edeeper")) + + (test #t '(submod ".")) + (test #t '(submod "." x)) + (test #t '(submod "." x y)) + (test #t '(submod "." x ".." y)) + (test #t '(submod "." x ".." y ".." ".." "..")) + (test #f '(submod "." "x" y)) + (test #f '(submod "." x "y")) + (test #t '(submod "..")) + (test #t '(submod ".." x)) + (test #t '(submod ".." x y)) + (test #f '(submod ".." "x" y)) + (test #f '(submod ".." x "y")) + (test #t '(submod ".." "..")) + (test #f '(submod ".." ".")) + + (test #t '(submod x a b)) + (test #f '(submod x "a" b)) + + (test #t '(submod 'x a)) + (test #t '(submod 'x)) + + (printf "Passed all tests\n")) diff -Nru racket-6.12+ppa1/src/expander/common/performance.rkt racket-7.0+ppa1/src/expander/common/performance.rkt --- racket-6.12+ppa1/src/expander/common/performance.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/performance.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,197 @@ +#lang racket/base + +(provide performance-region) + +;; To enable measurement, see the end of this file. + +;; The expression form +;; +;; (performance-region [key-expr ...] body ....) +;; +;; records the time of `body ...` and associated it with +;; the path `(list key-expr ...)`. Times for a path +;; are included in the times for the path's prefixes, but +;; not for any other path. When regions that are nested +;; dynamically, time accumlates only for the most nested +;; region. +;; +;; For example, +;; +;; (performance-region +;; ['compile 'module] +;; (do-expand-module)) +;; +;; counts the time for `(do-expand-module)` to '(compile) and +;; to '(compile module), and not to any other path, even if +;; the compilation occurs while expanding another module. +;; +;; The key '_ as a path element is special: it is replaced +;; by the correspondig element of the enclosing region's +;; path (if any). +;; +;; Beware that `body ...` is not in tail position when +;; performance measurement is enabled. + +;; ------------------------------------------------------------ +;; Re-export this submodule to enable performance measurements + +(module measure-mode racket/base + (provide performance-region) + + (define-syntax-rule (performance-region [tag0-expr tag-expr ...] body ...) + (begin + (start-performance-region tag0-expr tag-expr ...) + (begin0 + (let () body ...) + (end-performance-region)))) + + (define region-stack #f) + (define accums (make-hasheq)) + + (struct region (path + [start #:mutable] ; start time + [start-memory #:mutable] ; memory allocated before start time + [as-nested #:mutable] ; time accumulated for nested regions + [as-nested-memory #:mutable])) ; ditto, for memory + (struct stat ([msecs #:mutable] [memory #:mutable] [count #:mutable])) + + (define stat-key (gensym)) + + (define-logger performance) + + (define (start-performance-region . path) + (set! region-stack (cons (region (if region-stack + ;; Replace '_ elements: + (let loop ([path path] + [enclosing-path (region-path (car region-stack))]) + (if (null? path) + null + (cons (if (and (eq? '_ (car path)) + (pair? enclosing-path)) + (car enclosing-path) + (car path)) + (loop (cdr path) + (if (pair? enclosing-path) + (cdr enclosing-path) + null))))) + path) + (current-inexact-milliseconds) + (current-memory-use 'cumulative) + 0.0 + 0) + region-stack))) + + (define (end-performance-region) + (define now (current-inexact-milliseconds)) + (define now-memory (current-memory-use 'cumulative)) + (define r (car region-stack)) + (set! region-stack (cdr region-stack)) + + (define full-delta (- now (region-start r))) + (define delta (- full-delta (region-as-nested r))) + + (define full-delta-memory (- now-memory (region-start-memory r))) + (define delta-memory (- full-delta-memory (region-as-nested-memory r))) + + (let loop ([accums accums] [path (region-path r)]) + (define key (car path)) + (let ([accum (or (hash-ref accums key #f) + (let ([accum (make-hasheq)]) + (hash-set! accums key accum) + accum))]) + (define s (or (hash-ref accum stat-key #f) + (let ([s (stat 0.0 0 0)]) + (hash-set! accum stat-key s) + s))) + (set-stat-msecs! s (+ delta (stat-msecs s))) + (set-stat-memory! s (+ delta-memory (stat-memory s))) + (when (null? (cdr path)) + (set-stat-count! s (add1 (stat-count s)))) + (unless (null? (cdr path)) + (loop accum (cdr path))))) + + (when region-stack + (set-region-as-nested! (car region-stack) + (+ (region-as-nested (car region-stack)) + full-delta)) + (set-region-as-nested-memory! (car region-stack) + (+ (region-as-nested-memory (car region-stack)) + full-delta-memory)))) + + (void (plumber-add-flush! (current-plumber) + (lambda (h) + (define (whole-len s) + (caar (or (regexp-match-positions #rx"[.]" s) '(0)))) + (define (kb b) + (define s (number->string (quotient b 1024))) + (list->string + (for/fold ([l null]) ([c (in-list (reverse (string->list s)))] + [i (in-naturals)]) + (cond + [(and (positive? i) (zero? (modulo i 3))) + (list* c #\, l)] + [else (cons c l)])))) + (define-values (label-max-len value-max-len memory-max-len count-max-len) + (let loop ([accums accums] [label-len 6] [value-len 5] [memory-len 4] [count-len 5] [indent 2]) + (for/fold ([label-len label-len] + [value-len value-len] + [memory-len memory-len] + [count-len count-len]) + ([(k v) (in-hash accums)]) + (cond + [(eq? k stat-key) + (values label-len + (max value-len (whole-len (format "~a" (stat-msecs v)))) + (max memory-len (string-length (format "~a" (kb (stat-memory v))))) + (max count-len (string-length (format "~a" (stat-count v)))))] + [else (loop v + (max label-len (+ indent (string-length (format "~a" k)))) + value-len + memory-len + count-len + (+ 2 indent))])))) + (log-performance-info "REGION ~aMSECS ~aMEMK ~aCOUNT" + (make-string (- (+ label-max-len value-max-len) 11) + #\space) + (make-string (- memory-max-len 4) + #\space) + (make-string (- count-max-len 5) + #\space)) + (let loop ([name #f] [accums accums] [indent ""] [newline? #t]) + (when name + (define v (hash-ref accums stat-key)) + (log-performance-info "~a~a ~a~a ~a~a ~a~a" + indent + name + (make-string (+ (- label-max-len (string-length (format "~a" name)) (string-length indent)) + (- value-max-len (whole-len (format "~a" (stat-msecs v))))) + #\space) + (regexp-replace #rx"[.](..).*" (format "~a00" (stat-msecs v)) ".\\1") + (make-string (- memory-max-len (string-length (format "~a" (kb (stat-memory v))))) + #\space) + (kb (stat-memory v)) + (make-string (- count-max-len (string-length (format "~a" (stat-count v)))) + #\space) + (stat-count v))) + (define keys (sort (for/list ([k (in-hash-keys accums)] #:when (not (eq? k stat-key))) k) + > + #:key (lambda (key) (stat-msecs (hash-ref (hash-ref accums key) stat-key))))) + (for ([k (in-list keys)] + [i (in-naturals)]) + (when (and newline? (positive? i)) (log-performance-info "")) + (loop k (hash-ref accums k) (string-append indent " ") #f))))))) + +;; ------------------------------------------------------------ +;; Re-export this submodule to disable measurements + +(module no-measure-mode racket/base + (provide performance-region) + + (define-syntax-rule (performance-region [tag0-expr tag-expr ...] body ...) + (let () body ...))) + + +;; ------------------------------------------------------------ +;; Select whether to measure (has overhead) or not: + +(require (submod "." no-measure-mode)) diff -Nru racket-6.12+ppa1/src/expander/common/phase.rkt racket-7.0+ppa1/src/expander/common/phase.rkt --- racket-6.12+ppa1/src/expander/common/phase.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/phase.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,45 @@ +#lang racket/base + +(provide phase? + phase+ + phase- + phaselist + list->set + list->seteq + for/set + for/seteq + for/seteqv + for*/set + for*/seteq + in-set) + +(define the-empty-hash #hash()) +(define the-empty-hasheq #hasheq()) +(define the-empty-hasheqv #hasheqv()) + +(define set + (case-lambda + [() the-empty-hash] + [l (for/fold ([s the-empty-hash]) ([e (in-list l)]) + (hash-set s e #t))])) +(define seteq + (case-lambda + [() the-empty-hasheq] + [l (for/fold ([s the-empty-hasheq]) ([e (in-list l)]) + (hash-set s e #t))])) +(define (seteqv) the-empty-hasheqv) + +(define (set? s) (hash? s)) + +(define (set-empty? s) (zero? (hash-count s))) +(define (set-member? s e) (hash-ref s e #f)) +(define (set-count s) (hash-count s)) + +(define (set-add s e) (hash-set s e #t)) +(define (set-remove s e) (hash-remove s e)) +(define (set-first s) (hash-iterate-key s (hash-iterate-first s))) + +(define-syntax in-set (make-rename-transformer #'in-immutable-hash-keys)) + +(define (subset? s1 s2) + (hash-keys-subset? s1 s2)) + +(define (set=? s1 s2) + (or (eq? s1 s2) + (and (= (hash-count s1) (hash-count s2)) + (hash-keys-subset? s1 s2)))) + +(define (set-subtract s1 s2) + (for/fold ([s1 s1]) ([k (in-set s2)]) + (hash-remove s1 k))) + +(define (set-union s1 s2) + (if ((set-count s1) . < . (set-count s2)) + (set-union s2 s1) + (for/fold ([s1 s1]) ([k (in-set s2)]) + (hash-set s1 k #t)))) + +(define (set-intersect s1 s2) + (if ((set-count s1) . < . (set-count s2)) + (set-intersect s2 s1) + (for/fold ([s s2]) ([k (in-set s2)]) + (if (hash-ref s1 k #f) + s + (hash-remove s k))))) + +(define (set-partition s pred empty-y-set empty-n-set) + (for/fold ([y empty-y-set] [n empty-n-set]) ([v (in-set s)]) + (if (pred v) + (values (set-add y v) n) + (values y (set-add n v))))) + +(define (set->list s) + (for/list ([k (in-set s)]) + k)) + +(define (list->set l) + (for/set ([k (in-list l)]) + k)) + +(define (list->seteq l) + (for/seteq ([k (in-list l)]) + k)) + +(define-syntax-rule (for/set bindings body ...) + (for/hash bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for/seteq bindings body ...) + (for/hasheq bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for/seteqv bindings body ...) + (for/hasheqv bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for*/set bindings body ...) + (for*/hash bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for*/seteq bindings body ...) + (for*/hasheq bindings (values + (let () + body ...) + #t))) diff -Nru racket-6.12+ppa1/src/expander/common/small-hash.rkt racket-7.0+ppa1/src/expander/common/small-hash.rkt --- racket-6.12+ppa1/src/expander/common/small-hash.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/small-hash.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,25 @@ +#lang racket/base + +;; For a hash table that's likely to be small, then a boxed immutable +;; hash table can be more efficient + +(provide make-small-hasheq + make-small-hasheqv + small-hash-ref + small-hash-set! + small-hash-keys) + +(define (make-small-hasheq) + (box #hasheq())) + +(define (make-small-hasheqv) + (box #hasheqv())) + +(define (small-hash-ref small-ht key default) + (hash-ref (unbox small-ht) key default)) + +(define (small-hash-set! small-ht key val) + (set-box! small-ht (hash-set (unbox small-ht) key val))) + +(define (small-hash-keys small-ht) + (hash-keys (unbox small-ht))) diff -Nru racket-6.12+ppa1/src/expander/common/struct-star.rkt racket-7.0+ppa1/src/expander/common/struct-star.rkt --- racket-6.12+ppa1/src/expander/common/struct-star.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/common/struct-star.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,267 @@ +#lang racket/base +(require (for-syntax racket/base + racket/provide-transform)) + +(provide struct* + struct*-copy + struct*-out) + +;; The `struct*` form is like `struct`, but a field can be have a `*` +;; before it or not: the fields without `*` are moved into a nested +;; structure (and cannot be mutable), and the ones with `*` are kept +;; immediate. This distinction is useful is `struct*-copy` is used +;; often to asjust some fields and not others in a relatively larger +;; struct. + +;; Example: +#; +(struct* fish (* weight + color + name)) +;; Makes a `fish` struct where `struct*-copy` is used +;; frequently to change `weight`, but not `color` or +;; `name` --- so `color` and `name` will be represented +;; together in an inner structure that is referenced +;; though one field in the outer structure. + +;; Currently doesn't support: +;; * Subtypes deeper than one + +(begin-for-syntax + (struct struct*-shape (constructor + parent + outer-name inner-name outer-name-inner + all-fields ; including parent fields + outer-fields inner-fields mutators) + #:property prop:procedure (lambda (shape stx) + (with-syntax ([make-id (struct*-shape-constructor shape)]) + (syntax-case stx () + [(id arg ...) + (syntax/loc stx (make-id arg ...))] + [else + (syntax/loc stx make-id)]))))) + +(define-syntax (struct* stx) + (let-values ([(name parent-name fields options) + (syntax-case stx () + [(_ name parent-name (field ...) options ...) + (values #'name #'parent-name #'(field ...) #'(options ...))] + [(_ name (field ...) options ...) + (values #'name #f #'(field ...) #'(options ...))])]) + (define parent-shape (and parent-name + (syntax-local-value parent-name (lambda () #f)))) + (when parent-name + (check-struct* parent-shape stx parent-name)) + (with-syntax ([((outer-field ...) (inner-field ...)) (split-star-fields fields)] + [outer-name (make-id name '/outer)] + [inner-name (make-id name '/inner)] + [(option ...) options]) + (with-syntax ([(outer-field-name ...) (map field-id (syntax->list #'(outer-field ...)))] + [(inner-field-name ...) (map field-id (syntax->list #'(inner-field ...)))] + [(outer-parent-name ...) + (if parent-name + (list (struct*-shape-outer-name parent-shape)) + null)] + [(inner-parent-name ...) + (if parent-name + (list (struct*-shape-inner-name parent-shape)) + null)] + [(chain-field ...) (if parent-name + '() + (list (datum->syntax name 'inner)))] + [(every-field ...) (append (if parent-shape + (struct*-shape-all-fields parent-shape) + null) + (extract-all-fields fields))] + [(parent-outer-field ...) (if parent-shape + (struct*-shape-outer-fields parent-shape) + null)] + [(parent-inner-field ...) (if parent-shape + (struct*-shape-inner-fields parent-shape) + null)] + [(name-outer-field ...) (make-accessor-ids name #'(outer-field ...))] + [(set-name-outer-field! ...) (make-mutator-ids name #'(outer-field ...))] + [(name-inner-field ...) (make-accessor-ids name #'(inner-field ...))] + [(outer-name-outer-field ...) (make-accessor-ids #'outer-name #'(outer-field ...))] + [(set-outer-name-outer-field! ...) (make-mutator-ids #'outer-name #'(outer-field ...))] + [(inner-name-inner-field ...) (make-accessor-ids #'inner-name #'(inner-field ...))] + [outer-name-inner (if parent-shape + (struct*-shape-outer-name-inner parent-shape) + (make-id #'outer-name '-inner))] + [parent-name parent-name] + [name name] + [make-name (make-id name '/make)] + [name? (make-id name '?)] + [outer-name? (make-id #'outer-name '?)] + [quote-parent-syntax (if parent-shape + #'quote-syntax + #'quote)]) + #`(begin + (struct outer-name outer-parent-name ... (chain-field ... outer-field ...) + option ... + #:reflection-name 'name + #:authentic) + (struct inner-name inner-parent-name ... (inner-field ...) + #:authentic) + (define-syntax name (struct*-shape + (quote-syntax make-name) + (quote-parent-syntax parent-name) + (quote-syntax outer-name) + (quote-syntax inner-name) + (quote-syntax outer-name-inner) + '(every-field ...) + '(outer-field-name ...) + '(inner-field-name ...) + '(set-name-outer-field! ...))) + (define (name? v) (outer-name? v)) + (define (make-name every-field ...) + (outer-name (inner-name parent-inner-field ... inner-field-name ...) + parent-outer-field ... outer-field-name ...)) + (define (name-outer-field v) (outer-name-outer-field v)) ... + (define (set-name-outer-field! v f) (set-outer-name-outer-field! v f)) ... + (define (name-inner-field v) (inner-name-inner-field (outer-name-inner v))) ...))))) + +;; ---------------------------------------- + +(define-syntax (struct*-copy stx) + (syntax-case stx () + [(_ name expr binding ...) + (identifier? #'name) + (let ([shape (syntax-local-value #'name (lambda () #f))]) + (check-struct* shape stx #'name) + (with-syntax ([outer-name (struct*-shape-outer-name shape)] + [inner-name (struct*-shape-inner-name shape)] + [((outer-binding ...) (inner-binding ...)) + (split-star-bindings #'(binding ...) + shape + stx)] + [(inner-place ...) (if (struct*-shape-parent shape) + `(#:parent ,(struct*-shape-outer-name + (syntax-local-value + (struct*-shape-parent shape)))) + '())] + [outer-name-inner (struct*-shape-outer-name-inner shape)] + [inner (datum->syntax (struct*-shape-outer-name-inner shape) 'inner)]) + #`(let ([v expr]) + (struct-copy outer-name v + outer-binding ... + [inner inner-place ... + (struct-copy/maybe inner-name (outer-name-inner v) + inner-binding ...)]))))])) + +(define-syntax struct-copy/maybe + (syntax-rules () + [(struct-copy/maybe struct val) val] + [(struct-copy/maybe struct val binding ...) + (struct-copy struct val binding ...)])) + +;; ---------------------------------------- + +(define-syntax struct*-out + (make-provide-pre-transformer + (lambda (stx modes) + (syntax-case stx () + [(_ name) + (begin + (syntax-local-lift-module-end-declaration #'(provide-struct* name)) + #'(combine-out))])))) + +(define-syntax (provide-struct* stx) + (syntax-case stx () + [(_ name) + (let () + (define shape (syntax-local-value #'name (lambda () #f))) + (check-struct* shape stx #'name) + (with-syntax ([name? (make-id #'name '?)] + [(name-field ...) + (for/list ([field (in-list (append + (struct*-shape-outer-fields shape) + (struct*-shape-inner-fields shape)))]) + (make-id #'name (string->symbol (format "-~a" field))))] + [(mutator ...) + (for/list ([mutator (in-list (struct*-shape-mutators shape))]) + (datum->syntax #'name mutator))]) + #'(provide name name? name-field ... mutator ...)))])) + +;; ---------------------------------------- + +(define-for-syntax (check-struct* shape stx id) + (unless (struct*-shape? shape) + (raise-syntax-error #f "not a struct* binding" stx id))) + +(define-for-syntax (make-id base sym) + (datum->syntax base (string->symbol (format "~a~a" (syntax-e base) sym)) base)) + +(define-for-syntax (make-accessor-ids name fields) + (for/list ([f (in-list (syntax->list fields))]) + (define id (field-id f)) + (datum->syntax id (string->symbol (format "~a-~a" (syntax-e name) (syntax-e id)))))) + +(define-for-syntax (make-mutator-ids name fields) + (for/list ([f (in-list (syntax->list fields))] + #:when (syntax-case f () + [(_ #:mutable) #t] + [_ #f])) + (define id (field-id f)) + (datum->syntax id (string->symbol (format "set-~a-~a!" (syntax-e name) (syntax-e id)))))) + +(define-for-syntax (field-id f) + (syntax-case f () + [(id . _) #'id] + [id #'id])) + +(define-for-syntax (extract-all-fields fields) + (let loop ([fields (syntax->list fields)]) + (cond + [(null? fields) null] + [(eq? '* (syntax-e (car fields))) + (cons (field-id (cadr fields)) (loop (cddr fields)))] + [else + (cons (field-id (car fields)) (loop (cdr fields)))]))) + +(define-for-syntax (split-star-fields fields) + (let loop ([fields (syntax->list fields)] [accum-outer null] [accum-inner null]) + (cond + [(null? fields) (list (reverse accum-outer) (reverse accum-inner))] + [(eq? '* (syntax-e (car fields))) + (loop (cddr fields) (cons (cadr fields) accum-outer) accum-inner)] + [else + (loop (cdr fields) accum-outer (cons (car fields) accum-inner))]))) + +(define-for-syntax (split-star-bindings bindings shape stx) + (let loop ([bindings (syntax->list bindings)] [accum-outer null] [accum-inner null]) + (cond + [(null? bindings) (list (reverse accum-outer) (reverse accum-inner))] + [else + (define binding (car bindings)) + (define (outer-in-shape? shape id) + (memq (syntax-e id) (struct*-shape-outer-fields shape))) + (define-values (new-binding outer?) + (syntax-case binding () + [[id val] + (begin + (define outer? (outer-in-shape? shape #'id)) + (with-syntax ([id (datum->syntax (if outer? + (struct*-shape-outer-name shape) + (struct*-shape-outer-name shape)) + (syntax-e #'id))]) + (values (syntax/loc stx [id val]) outer?)))] + [[id #:parent parent val] + (begin + (unless (and (struct*-shape-parent shape) + (free-identifier=? #'parent + (struct*-shape-parent shape))) + (raise-syntax-error #f "bad parent name" + stx #'parent)) + (define parent-shape (syntax-local-value #'parent #f)) + (define outer? (outer-in-shape? parent-shape #'id)) + (define parent-name (if outer? + (struct*-shape-outer-name parent-shape) + (struct*-shape-inner-name parent-shape))) + (with-syntax ([parent-name parent-name] + [id (datum->syntax parent-name (syntax-e #'id))]) + (values (syntax/loc binding [id #:parent parent-name val]) + outer?)))])) + (if outer? + (loop (cdr bindings) (cons new-binding accum-outer) accum-inner) + (loop (cdr bindings) accum-outer (cons new-binding accum-inner)))]))) diff -Nru racket-6.12+ppa1/src/expander/compile/built-in-symbol.rkt racket-7.0+ppa1/src/expander/compile/built-in-symbol.rkt --- racket-6.12+ppa1/src/expander/compile/built-in-symbol.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/built-in-symbol.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,65 @@ +#lang racket/base + +;; A built-in symbol is one that the compiler must avoid using for a +;; binding. Built-in symbols include the names of run-time primitives +;; and identifiers reserved by the compiler itself (see +;; "reserved-symbol.rkt") + +(provide register-built-in-symbol! + built-in-symbol? + make-built-in-symbol!) + +(define built-in-symbols (make-hasheq)) + +(define (register-built-in-symbol! s) + (hash-set! built-in-symbols s #t)) + +(define (built-in-symbol? s) + (hash-ref built-in-symbols s #f)) + +(define (make-built-in-symbol! s) + ;; Make a symbol that is a little more obscure than just `s` + (define built-in-s (string->symbol (format ".~s" s))) + (register-built-in-symbol! built-in-s) + built-in-s) + +;; ---------------------------------------- + +(void + (begin + ;; Primitive expression forms + (for-each register-built-in-symbol! + '(lambda case-lambda + if begin begin0 + let-values letrec-values + set! quote + with-continuation-mark + #%variable-reference)) + + ;; Source-mode linklet glue + (for-each register-built-in-symbol! + '(check-not-undefined + instance-variable-box + variable-reference + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe?)) + + ;; Linklet compilation on Chez Scheme + (for-each register-built-in-symbol! + '(let + letrec* + define + or + and + pariah + variable-set! + variable-ref + variable-ref/no-check + make-instance-variable-reference + annotation? + annotation-expression + #%app + #%call-with-values + make-pthread-parameter)))) diff -Nru racket-6.12+ppa1/src/expander/compile/compiled-in-memory.rkt racket-7.0+ppa1/src/expander/compile/compiled-in-memory.rkt --- racket-6.12+ppa1/src/expander/compile/compiled-in-memory.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/compiled-in-memory.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base + +;; A `compiled-in-memory` structure holds the result of compilation. +;; It's produced by `compile-top` or `compile-module` and consumed by +;; `eval-compiled-in-memory`. The marshaled form is just the linklet +;; directory, which has the same essential information, but loses sharing +;; with anything else currently in memory. The marshaled form also loses +;; extra inspectors. +(provide (struct-out compiled-in-memory)) + +(struct compiled-in-memory (linklet-directory ;; includes content of `{pre,post}-compiled-tops`; may be just a bundle + ;; Shortcuts, instead of using the metadata linklet: + original-self + requires + provides + phase-to-link-module-uses + ;; Maybe provide more capability than the module's declaration inspector: + compile-time-inspector + ;; For each phase (that has a linklet), optionally report + ;; a list of lists; the outer list matches the order of imports + ;; into the linklet, and each inner list matches the order of + ;; variables from that imported linklet; each member of the + ;; inner list is #f or an extra inspector that has been carried + ;; over from the originally compiled reference + phase-to-link-extra-inspectorsss ; phase -> list of hash tables to "extra inspectors" + ;; For using existing values directly, instead of unmarshaling: + mpis + syntax-literals + ;; Shortcuts for associated code (submodules or sequence of top levels) + pre-compiled-in-memorys + post-compiled-in-memorys + ;; Namespace scopes from top-level compilation, so syntax objects + ;; can be adjusted for a target namespace: + namespace-scopes + ;; To track whether a form in a top-level sequence can be discarded: + purely-functional?) + #:property prop:custom-write + (lambda (cim port mode) + (write (compiled-in-memory-linklet-directory cim) port))) diff -Nru racket-6.12+ppa1/src/expander/compile/context.rkt racket-7.0+ppa1/src/expander/compile/context.rkt --- racket-6.12+ppa1/src/expander/compile/context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require "../namespace/namespace.rkt") + +(provide (struct-out compile-context) + make-compile-context) + +(struct compile-context (namespace ; compile-time namespace + phase ; phase (top level) or phase level (within a module) + self ; to detect bindings within the same namespace + module-self ; if non-#f, same as `self` and compiling the body of a module + full-module-name ; set to a symbol or symbol list if `self` is non-#f + lazy-syntax-literals? ; #t (for modules) => deserialize and shift syntax on demand + header) ; accumulates initialization and other parts shared among expressions + #:authentic) + +(define (make-compile-context #:namespace [namespace (current-namespace)] + #:phase [phase (namespace-phase namespace)] + #:self [self (namespace-self-mpi namespace)] + #:module-self [module-self #f] + #:full-module-name [full-module-name #f] + #:lazy-syntax-literals? [lazy-syntax-literals? (and module-self #t)]) + (when (and module-self (not full-module-name)) + (error "internal error: module-self provided without full name")) + (compile-context namespace + phase + self + module-self + full-module-name + lazy-syntax-literals? + #f)) diff -Nru racket-6.12+ppa1/src/expander/compile/correlate.rkt racket-7.0+ppa1/src/expander/compile/correlate.rkt --- racket-6.12+ppa1/src/expander/compile/correlate.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/correlate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/datum-map.rkt" + "../host/correlate.rkt" + (only-in "../host/syntax-to-reader-syntax.rkt" srcloc->vector)) + +;; The `correlate*` function takes the source location of an expander +;; syntax object and applies it to a host-system syntax object (i.e., +;; a "correlated") + +(provide correlate* + correlate~ + correlate/app + ->correlated) + +(define (correlate* stx s-exp) + (if (syntax-srcloc stx) + (datum->correlated s-exp (srcloc->vector (syntax-srcloc stx))) + s-exp)) + +;; For terms where we know the compiler currently doesn't +;; pay attention to source locations, so there's no reason +;; to keep them: +(define (correlate~ stx s-exp) + s-exp) + +(define (correlate/app stx s-exp) + (if (eq? (system-type 'vm) 'chez-scheme) + (correlate* stx s-exp) + (correlate~ stx s-exp))) + +(define (->correlated s) + (datum->correlated s #f)) diff -Nru racket-6.12+ppa1/src/expander/compile/eager-instance.rkt racket-7.0+ppa1/src/expander/compile/eager-instance.rkt --- racket-6.12+ppa1/src/expander/compile/eager-instance.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/eager-instance.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base +(require "reserved-symbol.rkt" + "../host/linklet.rkt" + "namespace-scope.rkt") + +;; Compilation of top-level forms generates a link that has an +;; `eager-instance` argument to receive deserialization information: a +;; namspace, its phase, etc. + +(provide eager-instance-imports + make-eager-instance-instance + empty-eager-instance-instance) + +(define eager-instance-imports + `(,ns-id + ,dest-phase-id + ,self-id + ,bulk-binding-registry-id + ,inspector-id + swap-top-level-scopes)) + +(define (make-eager-instance-instance #:namespace ns + #:dest-phase dest-phase + #:self self + #:bulk-binding-registry bulk-binding-registry + #:inspector inspector) + (make-instance 'instance #f 'constant + ns-id ns + dest-phase-id dest-phase + self-id self + bulk-binding-registry-id bulk-binding-registry + inspector-id inspector + 'swap-top-level-scopes swap-top-level-scopes)) + +(define empty-eager-instance-instance + (make-eager-instance-instance #:namespace #f + #:dest-phase #f + #:self #f + #:bulk-binding-registry #f + #:inspector #f)) diff -Nru racket-6.12+ppa1/src/expander/compile/expr.rkt racket-7.0+ppa1/src/expander/compile/expr.rkt --- racket-6.12+ppa1/src/expander/compile/expr.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/expr.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,236 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/to-list.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/property.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "../syntax/match.rkt" + "../common/module-path.rkt" + "../expand/parsed.rkt" + "built-in-symbol.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "self-quoting.rkt" + "../host/correlate.rkt" + "correlate.rkt") + +(provide compile + compile-quote-syntax) + +;; Convert an expanded syntax object to an expression that is +;; represented by a plain S-expression plus source location info (so, +;; still represented as a syntax object). The expression is compiled +;; for a particular phase, but if the expression is in a module, its +;; phase can be shifted at run time by the amount bound to +;; `phase-shift-id`. Module bindings are accessed through a namespace +;; that is bound to `ns-id` at run time. +;; The `result-used?` hint lets us drop `quote-syntax` forms that will +;; not be used in the result, so we can avoid serializing them; a value +;; of `#f` for `result-used?` means that the expression can be replaced +;; by a boolean-equivalent value if it has no side effect. +(define (compile p cctx [name #f] [result-used? #t]) + (let ([compile (lambda (p name result-used?) (compile p cctx name result-used?))]) + (define s (parsed-s p)) + (cond + [(parsed-id? p) + (compile-identifier p cctx)] + [(parsed-lambda? p) + (cond + [result-used? + (add-lambda-properties + (correlate* s `(lambda ,@(compile-lambda (parsed-lambda-keys p) (parsed-lambda-body p) cctx))) + name + s)] + [else (correlate~ s `(quote unused-lambda))])] + [(parsed-case-lambda? p) + (cond + [result-used? + (add-lambda-properties + (correlate* s `(case-lambda ,@(for/list ([clause (in-list (parsed-case-lambda-clauses p))]) + (compile-lambda (car clause) (cadr clause) cctx)))) + name + s)] + [else (correlate~ s `(quote unused-case-lambda))])] + [(parsed-app? p) + (define rands (parsed-app-rands p)) + (correlate/app s (cons + (compile (parsed-app-rator p) #f #t) + (for/list ([r (in-list rands)]) + (compile r #f #t))))] + [(parsed-if? p) + (define tst-e (compile (parsed-if-tst p) #f #f)) + ;; Ad hoc optimization of `(if #t ... ...)` or `(if #f ... ...)` + ;; happens to help avoid syntax literals in pattern matching. + (cond + [(eq? (correlated-e tst-e) #t) (compile (parsed-if-thn p) name result-used?)] + [(eq? (correlated-e tst-e) #f) (compile (parsed-if-els p) name result-used?)] + [else + (correlate~ s `(if + ,tst-e + ,(compile (parsed-if-thn p) name result-used?) + ,(compile (parsed-if-els p) name result-used?)))])] + [(parsed-with-continuation-mark? p) + (correlate~ s `(with-continuation-mark + ,(compile (parsed-with-continuation-mark-key p) #f #t) + ,(compile (parsed-with-continuation-mark-val p) #f #t) + ,(compile (parsed-with-continuation-mark-body p) name result-used?)))] + [(parsed-begin0? p) + (correlate~ s `(begin0 + ,(compile (car (parsed-begin0-body p)) name result-used?) + ,@(for/list ([e (in-list (cdr (parsed-begin0-body p)))]) + (compile e #f #f))))] + [(parsed-begin? p) + (correlate~ s (compile-begin (parsed-begin-body p) cctx name result-used?))] + [(parsed-set!? p) + (correlate~ s `(,@(compile-identifier (parsed-set!-id p) cctx + #:set-to? #t + #:set-to (compile (parsed-set!-rhs p) (parsed-s (parsed-set!-id p)) #t))))] + [(parsed-let-values? p) + (compile-let p cctx name #:rec? #f result-used?)] + [(parsed-letrec-values? p) + (compile-let p cctx name #:rec? #t result-used?)] + [(parsed-quote? p) + (define datum (parsed-quote-datum p)) + (cond + [(self-quoting-in-linklet? datum) + (correlate~ s datum)] + [else + (correlate~ s `(quote ,datum))])] + [(parsed-quote-syntax? p) + (if result-used? + (compile-quote-syntax (parsed-quote-syntax-datum p) cctx) + (correlate~ s `(quote ,(syntax->datum s))))] + [(parsed-#%variable-reference? p) + (define id (parsed-#%variable-reference-id p)) + (correlate~ s + (if id + `(#%variable-reference ,(compile-identifier id cctx)) + `(#%variable-reference)))] + [else + (error "unrecognized parsed form:" p)]))) + +(define (compile-lambda formals bodys cctx) + `(,formals ,(compile-sequence bodys cctx #f #t))) + +(define (compile-sequence bodys cctx name result-used?) + (if (null? (cdr bodys)) + (compile (car bodys) cctx name result-used?) + (compile-begin bodys cctx name result-used?))) + +(define (compile-begin es cctx name result-used?) + (define used-pos (sub1 (length es))) + `(begin ,@(for/list ([e (in-list es)] + [i (in-naturals)]) + (define used? (= i used-pos)) + (compile e cctx (and used? name) (and used? result-used?))))) + +(define (add-lambda-properties s inferred-name orig-s) + ;; Allow pairs formed by origin tracking to provide the + ;; same name multiple times: + (define (simplify-name v) + (cond + [(pair? v) + (define n1 (simplify-name (car v))) + (define n2 (simplify-name (cdr v))) + (if (eq? n1 n2) n1 v)] + [else v])) + ;; Get either a declared 'inferred-name or one accumulated by the compiler + (define name (or (let ([v (simplify-name (syntax-property orig-s 'inferred-name))]) + (and (or (symbol? v) (syntax? v) (void? v)) + v)) + inferred-name)) + (define named-s (if name + (correlated-property (->correlated s) + 'inferred-name + (if (syntax? name) (syntax-e name) name)) + s)) + (define as-method (syntax-property orig-s 'method-arity-error)) + (if as-method + (correlated-property (->correlated named-s) 'method-arity-error as-method) + named-s)) + +(define (compile-let p cctx name #:rec? rec? result-used?) + (define body (parsed-let_-values-body p)) + (correlate~ (parsed-s p) + `(,(if rec? 'letrec-values 'let-values) + ,(for/list ([clause (in-list (parsed-let_-values-clauses p))] + [ids (in-list (parsed-let_-values-idss p))]) + `[,(if rec? + (for/list ([sym (in-list (car clause))] + [id (in-list ids)]) + (add-undefined-error-name-property sym id)) + (car clause)) + ,(compile (cadr clause) + cctx + (and (= 1 (length ids)) (car ids)))]) + ,(compile-sequence body cctx name result-used?)))) + +(define (add-undefined-error-name-property sym orig-id) + (define id (correlate~ orig-id sym)) + (correlated-property (->correlated id) 'undefined-error-name + (or (syntax-property orig-id 'undefined-error-name) + (syntax-e orig-id)))) + +(define (compile-identifier p cctx #:set-to? [set-to? #f] #:set-to [rhs #f]) + (define normal-b (parsed-id-binding p)) + ;; If `normal-b`, then `(parsed-s p)` might be #f + (define b + (or normal-b + ;; Assume a variable reference + (make-module-binding (compile-context-self cctx) + (compile-context-phase cctx) + (syntax-e (parsed-s p))))) + (define sym + (cond + [(local-binding? b) + (local-binding-key b)] + [(module-binding? b) + (define mpi (if (parsed-top-id? p) + (compile-context-self cctx) + (module-binding-module b))) + (cond + [(parsed-primitive-id? p) + ;; Direct reference to a runtime primitive: + (unless (zero? (module-binding-phase b)) + (error "internal error: non-zero phase for a primitive")) + (when set-to? + (error "internal error: cannot assign to a primitive:" (module-binding-sym b))) + ;; Expect each primitive to be bound: + (module-binding-sym b)] + [(eq? mpi (compile-context-module-self cctx)) + ;; Direct reference to a variable defined in the same module: + (define header (compile-context-header cctx)) + (hash-ref (header-binding-sym-to-define-sym header) + (module-binding-sym b))] + [else + ;; Reference to a variable defined in another module or in an + ;; environment (such as the top level) other than a module + ;; context; register as a linklet import + (register-required-variable-use! (compile-context-header cctx) + mpi + (module-binding-phase b) + (module-binding-sym b) + (or (module-binding-extra-inspector b) + (parsed-id-inspector p) + (and (parsed-s p) + (syntax-inspector (parsed-s p)))))])] + [else + (error "not a reference to a module or local binding:" b (parsed-s p))])) + (correlate~ (parsed-s p) (if set-to? + `(set! ,sym ,rhs) + sym))) + +(define (compile-quote-syntax q cctx) + (define pos (add-syntax-literal! (compile-context-header cctx) q)) + (cond + [(compile-context-lazy-syntax-literals? cctx) + (generate-lazy-syntax-literal-lookup pos)] + [else + (generate-eager-syntax-literal-lookup pos)])) diff -Nru racket-6.12+ppa1/src/expander/compile/extra-inspector.rkt racket-7.0+ppa1/src/expander/compile/extra-inspector.rkt --- racket-6.12+ppa1/src/expander/compile/extra-inspector.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/extra-inspector.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,142 @@ +#lang racket/base +(require "../common/set.rkt" + "module-use.rkt" + "../host/linklet.rkt") + +(provide extra-inspectors-allow? + + module-uses-add-extra-inspectorsss + module-uses-strip-extra-inspectorsss + module-uses-extract-extra-inspectorsss + module-use*-declaration-inspector! + + module-use+extra-inspectors + module-use-merge-extra-inspectorss!) + +;; Compilation leaves a linklet with some "or" inspectors that apply +;; to the whole linklet plus (potentially) some "and" inspectors for +;; each invdidual binding. Cross-module optimization can move this +;; or+and combination to the "and" part of a different module, so we +;; use functions in general + +(define (extra-inspectors-allow? extra-inspectors guard-insp) + (cond + [(not extra-inspectors) #f] + [(set? extra-inspectors) + (for/and ([extra-insp (in-set extra-inspectors)]) + (inspector-superior? extra-insp guard-insp))] + [(procedure? extra-inspectors) + (extra-inspectors guard-insp)] + [else + (error 'extra-inspectors-allow? + "unknown representation of extra inspectors: ~e" + extra-inspectors)])) + +(define (extra-inspectors-merge extra-inspectors-1 extra-inspectors-2) + (cond + [(or (not extra-inspectors-1) + (not extra-inspectors-2)) + #f] + [(and (set? extra-inspectors-1) + (set? extra-inspectors-2)) + (set-union extra-inspectors-1 extra-inspectors-2)] + [else + (lambda (guard-insp) + (and (extra-inspectors-allow? extra-inspectors-1 guard-insp) + (extra-inspectors-allow? extra-inspectors-2 guard-insp)))])) + +;; ---------------------------------------- + +;; While compiling a linklet, we start out with parallel lists of +;; module uses and extra inspectors, but it's more convenient to +;; manage inlining if we put those together. We may need to merge +;; extra-inspector sets while preserving `eq?` identity of the +;; `module-use*`, so that field is mutable. +(struct module-use* module-use ([extra-inspectorss #:mutable] + [self-inspector #:mutable])) + +;; Parallel lists into one list +(define (module-uses-add-extra-inspectorsss mus extra-inspectorsss) + (cond + [extra-inspectorsss + (for/list ([mu (in-list mus)] + [extra-inspectorss (in-list extra-inspectorsss)]) + (module-use* (module-use-module mu) + (module-use-phase mu) + extra-inspectorss + #f))] + [else + (for/list ([mu (in-list mus)]) + (module-use* (module-use-module mu) + (module-use-phase mu) + #f + #f))])) + +;; Split the list back into one of the parallel lists +(define (module-uses-strip-extra-inspectorsss mu*s) + (for/list ([mu* (in-list mu*s)]) + (module-use (module-use-module mu*) + (module-use-phase mu*)))) + +;; Split the list back into the other parallel list --- but also check +;; for inlining-introduced references that must have formerly been +;; module-internal references (i.e., referenecs that are not already +;; recorded as imports) +(define (module-uses-extract-extra-inspectorsss mu*s linklet check-inlined-reference? skip-n) + (cond + [(not check-inlined-reference?) + (for/list ([mu* (in-list mu*s)]) + (module-use*-extra-inspectorss mu*))] + [else + (for/list ([mu* (in-list mu*s)] + [imports (in-list (list-tail (linklet-import-variables linklet) skip-n))]) + (define extra-inspectorss (module-use*-extra-inspectorss mu*)) + (for/fold ([extra-inspectorss extra-inspectorss]) ([import (in-list imports)]) + (cond + [(eq? (hash-ref extra-inspectorss import '#:not-recorded) '#:not-recorded) + (hash-set extra-inspectorss import (set (module-use*-self-inspector mu*)))] + [else extra-inspectorss])))])) + +(define (module-use*-declaration-inspector! mu* insp) + (set-module-use*-self-inspector! mu* insp)) + +;; ---------------------------------------- + +(define (module-use+extra-inspectors mpi phase imports inspector extra-inspector extra-inspectorss) + ;; If `inspector` or `extra-inspector` is not subsumed by the + ;; current inspector, then propagate it by adding to each imported + ;; variable's set of "or" inspectors + (define now-inspector (current-code-inspector)) + (define add-insp? (and inspector (inspector-superior? inspector now-inspector))) + (define add-extra-insp? (and extra-inspector (inspector-superior? extra-inspector now-inspector))) + (define new-extra-inspectorss + (cond + [(or add-insp? add-extra-insp?) + (for/hash ([import (in-list imports)]) + (values import + (let ([extra-inspectors (and extra-inspectorss + (hash-ref extra-inspectorss import #f))]) + (lambda (guard-insp) + (or (and add-insp? (inspector-superior? inspector guard-insp)) + (and add-extra-insp? (inspector-superior? extra-inspector guard-insp)) + (extra-inspectors-allow? extra-inspectors guard-insp))))))] + [else + ;; Make sure every import is mapped, because w may need to distinguish + ;; between "not accessed" and "accessed without extra inspectors" + (for/fold ([extra-inspectorss (or extra-inspectorss (seteq))]) ([import (in-list imports)]) + (if (hash-ref extra-inspectorss import #f) + extra-inspectorss + (hash-set extra-inspectorss import #f)))])) + (module-use* mpi phase new-extra-inspectorss #f)) + +;; Merge inspectors from potentially different paths through imported linklets +(define (module-use-merge-extra-inspectorss! existing-mu* mu*) + (define extra-inspectorss (module-use*-extra-inspectorss mu*)) + (define existing-extra-inspectorss (module-use*-extra-inspectorss existing-mu*)) + (define new-extra-inspectorss + (for/fold ([new-extra-inspectorss existing-extra-inspectorss]) ([(sym extra-inspectors) (in-hash extra-inspectorss)]) + (hash-set new-extra-inspectorss + sym + (extra-inspectors-merge extra-inspectors + (hash-ref new-extra-inspectorss sym (seteq)))))) + (set-module-use*-extra-inspectorss! existing-mu* new-extra-inspectorss)) diff -Nru racket-6.12+ppa1/src/expander/compile/form.rkt racket-7.0+ppa1/src/expander/compile/form.rkt --- racket-6.12+ppa1/src/expander/compile/form.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/form.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,463 @@ +#lang racket/base +(require "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/property.rkt" + "../syntax/match.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../expand/root-expand-context.rkt" + "../expand/parsed.rkt" + "../common/module-path.rkt" + "module-use.rkt" + "serialize.rkt" + "built-in-symbol.rkt" + "../host/linklet.rkt" + "../host/correlate.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "namespace-scope.rkt" + "expr.rkt" + "extra-inspector.rkt" + "correlate.rkt") + +(provide compile-forms + + compile-namespace-scopes) + +(struct link-info (link-module-uses imports extra-inspectorsss def-decls)) + +;; Compiles a module body or sequence of top-level forms, returning a +;; linklet directory to cover all phases covered by the forms +(define (compile-forms bodys cctx mpis + #:body-imports body-imports + #:body-import-instances body-import-instances + #:body-suffix-forms [body-suffix-forms null] + #:force-phases [force-phases null] + #:encoded-root-expand-ctx-box [encoded-root-expand-ctx-box #f] ; encoded root context, if any + #:root-ctx-only-if-syntax? [root-ctx-only-if-syntax? #f] + #:compiled-expression-callback [compiled-expression-callback void] + #:definition-callback [definition-callback void] + #:other-form-callback [other-form-callback void] + #:get-module-linklet-info [get-module-linklet-info (lambda (mod-name p) #f)] ; to support submodules + #:to-source? [to-source? #f] + #:serializable? [serializable? #t] + #:cross-linklet-inlining? [cross-linklet-inlining? #t]) + (define phase (compile-context-phase cctx)) + (define self (compile-context-self cctx)) + + ;; Accumulate syntax objects across all phases: + (define syntax-literals (make-syntax-literals)) + + ;; For each phase, keep track of all compiled expressions for the + ;; phase + (define phase-to-body (make-hasheqv)) ; phase -> list of S-expression + (define (add-body! phase body) + (hash-update! phase-to-body phase (lambda (l) (cons body l)) null)) + + ;; For each phase, accumulate a header for referenced imports and + ;; syntax literals + (define phase-to-header (make-hasheqv)) ; phase -> header + (define (find-or-create-header! phase) + (or (hash-ref phase-to-header phase #f) + (let ([header (make-header mpis syntax-literals)]) + (hash-set! phase-to-header phase header) + header))) + + ;; Ensure that some requested phases are realized: + (for ([phase (in-list force-phases)]) + (find-or-create-header! phase) + (add-body! phase '(void))) + + ;; Keep track of whether any `define-syntaxes` appeared at any phase + (define saw-define-syntaxes? #f) + + (when (compile-context-module-self cctx) + ;; In a module, select non-conflicting symbols for definitions, + ;; first, in the hope that we can just the names as-is; and we'll + ;; rename locals as needed to avoid these names + (let loop! ([bodys bodys] [phase phase] [header (find-or-create-header! phase)]) + (for ([body (in-list bodys)]) + (cond + [(parsed-define-values? body) + (for ([sym (in-list (parsed-define-values-syms body))]) + (define def-sym (select-fresh sym header)) + (hash-set! (header-binding-sym-to-define-sym header) + sym + def-sym) + (set-header-binding-syms-in-order! header + (cons sym + (header-binding-syms-in-order header))) + (register-as-defined! header def-sym))] + [(parsed-begin-for-syntax? body) + (loop! (parsed-begin-for-syntax-body body) (add1 phase) (find-or-create-header! (add1 phase)))])))) + + ;; Provided for callbacks to detect required references: + (define ((as-required? header) sym) + (registered-as-required? header sym)) + + ;; Compile each form in `bodys`, recording results in `phase-to-body` + (define last-i (sub1 (length bodys))) + (let loop! ([bodys bodys] [phase phase] [header (find-or-create-header! phase)]) + (for ([body (in-list bodys)] + [i (in-naturals)]) + (cond + [(parsed-define-values? body) + (define ids (parsed-define-values-ids body)) + (define binding-syms (parsed-define-values-syms body)) + (define def-syms + (cond + [(compile-context-module-self cctx) + ;; In a module, look up name for local definition: + (for/list ([binding-sym (in-list binding-syms)]) + (hash-ref (header-binding-sym-to-define-sym header) + binding-sym))] + [else + ;; Outside of a module, look up name to `set!` + (for/list ([binding-sym (in-list binding-syms)]) + (register-required-variable-use! header + (compile-context-self cctx) + phase + binding-sym + #f + #:defined? #t))])) + (define rhs (compile (parsed-define-values-rhs body) + (struct-copy compile-context cctx + [phase phase] + [header header]) + (and (= (length ids) 1) (car ids)))) + (definition-callback) + (compiled-expression-callback rhs (length def-syms) phase (as-required? header)) + ;; Generate a definition: + (add-body! phase (propagate-inline-property + (correlate* (parsed-s body) `(define-values ,def-syms ,rhs)) + (parsed-s body))) + (unless (or (compile-context-module-self cctx) + (null? ids)) + ;; Not in a module; ensure that the defined names are + ;; treated as mutable + (add-body! phase + `(if #f + (begin + ,@(for/list ([def-sym (in-list def-syms)]) + `(set! ,def-sym #f))) + (void))) + ;; Also, install a binding at run time + (add-body! phase (compile-top-level-bind + ids binding-syms + (struct-copy compile-context cctx + [phase phase] + [header header]) + #f)))] + [(parsed-define-syntaxes? body) + (define ids (parsed-define-syntaxes-ids body)) + (define binding-syms (parsed-define-syntaxes-syms body)) + (define next-header (find-or-create-header! (add1 phase))) + (define gen-syms (for/list ([binding-sym (in-list binding-syms)]) + (define gen-sym (select-fresh binding-sym next-header)) + (register-as-defined! next-header gen-sym) + gen-sym)) + (define rhs (compile (parsed-define-syntaxes-rhs body) + (struct-copy compile-context cctx + [phase (add1 phase)] + [header next-header]))) + (definition-callback) + (compiled-expression-callback rhs (length gen-syms) (add1 phase) (as-required? header)) + (define transformer-set!s (for/list ([binding-sym (in-list binding-syms)] + [gen-sym (in-list gen-syms)]) + `(,set-transformer!-id ',binding-sym ,gen-sym))) + (cond + [(compile-context-module-self cctx) + (add-body! (add1 phase) `(let-values ([,gen-syms ,rhs]) + (begin + ,@transformer-set!s + (void))))] + [else + (add-body! (add1 phase) + (generate-top-level-define-syntaxes + gen-syms rhs transformer-set!s + (compile-top-level-bind + ids binding-syms + (struct-copy compile-context cctx + [phase phase] + [header header]) + gen-syms)))]) + (set! saw-define-syntaxes? #t)] + [(parsed-begin-for-syntax? body) + (loop! (parsed-begin-for-syntax-body body) (add1 phase) (find-or-create-header! (add1 phase)))] + [(or (parsed-#%declare? body) (parsed-module? body) (parsed-require? body)) + ;; Must be handled separately, if allowed at all + (define e (other-form-callback body (struct-copy compile-context cctx + [phase phase] + [header header]))) + (when e + (compiled-expression-callback e #f phase (as-required? header)) + (add-body! phase e))] + [else + (define e (compile body + (struct-copy compile-context cctx + [phase phase] + [header header]) + #f + (= i last-i))) + (compiled-expression-callback e #f phase (as-required? header)) + (add-body! phase e)]))) + + ;; Register root-expand-context, if any, encoded as a syntax object; + ;; see also "../eval/root-context.rkt" + (define encoded-root-expand-pos + (and encoded-root-expand-ctx-box + (unbox encoded-root-expand-ctx-box) ; box => can be cleared by a callback + (not (and root-ctx-only-if-syntax? + (not saw-define-syntaxes?) + (syntax-literals-empty? syntax-literals))) + (add-syntax-literal! syntax-literals (unbox encoded-root-expand-ctx-box)))) + + ;; Collect resulting phases + (define phases-in-order (sort (hash-keys phase-to-body) <)) + (define min-phase (if (pair? phases-in-order) + (car phases-in-order) + phase)) + (define max-phase (if (pair? phases-in-order) + (car (reverse phases-in-order)) + phase)) + + ;; Compute linking info for each phase + (define phase-to-link-info + (for/hash ([phase (in-list phases-in-order)]) + (define header (hash-ref phase-to-header phase #f)) + (define-values (link-module-uses imports extra-inspectorsss def-decls) + (generate-links+imports header phase cctx cross-linklet-inlining?)) + (values phase (link-info link-module-uses imports extra-inspectorsss def-decls)))) + + ;; Generate the phase-specific linking units + (define body-linklets+module-use*s + (for/hasheq ([phase (in-list phases-in-order)]) + (define bodys (hash-ref phase-to-body phase)) + (define li (hash-ref phase-to-link-info phase)) + (define binding-sym-to-define-sym + (header-binding-sym-to-define-sym (hash-ref phase-to-header phase))) + (define module-use*s + (module-uses-add-extra-inspectorsss (link-info-link-module-uses li) + (link-info-extra-inspectorsss li))) + ;; Compile the linklet with support for cross-module inlining, which + ;; means that the set of imports can change: + (define-values (linklet new-module-use*s) + (performance-region + ['compile '_ 'linklet] + ((if to-source? + (lambda (l name keys getter) (values l keys)) + (lambda (l name keys getter) + (compile-linklet l name keys getter (if serializable? '(serializable) '())))) + `(linklet + ;; imports + (,@body-imports + ,@(link-info-imports li)) + ;; exports + (,@(link-info-def-decls li) + ,@(for/list ([binding-sym (in-list (header-binding-syms-in-order + (hash-ref phase-to-header phase)))]) + (define def-sym (hash-ref binding-sym-to-define-sym binding-sym)) + (if (eq? def-sym binding-sym) + def-sym + `[,def-sym ,binding-sym]))) + ;; body + ,@(reverse bodys) + ,@body-suffix-forms) + 'module + ;; Support for cross-module optimization starts with a vector + ;; of keys for the linklet imports; we use `module-use` values + ;; as keys, plus #f or an instance (=> cannot be pruned) for + ;; each boilerplate linklet + (list->vector (append body-import-instances + module-use*s)) + ;; To complete cross-module support, map a key (which is a `module-use`) + ;; to a linklet and an optional vector of keys for that linklet's + ;; imports: + (make-module-use-to-linklet cross-linklet-inlining? + (compile-context-namespace cctx) + get-module-linklet-info + module-use*s)))) + (values phase (cons linklet (list-tail (vector->list new-module-use*s) + (length body-imports)))))) + + (define body-linklets + (for/hasheq ([(phase l+mu*s) (in-hash body-linklets+module-use*s)]) + (values phase (car l+mu*s)))) + + (define phase-to-link-module-uses + (for/hasheq ([(phase l+mu*s) (in-hash body-linklets+module-use*s)]) + (values phase (module-uses-strip-extra-inspectorsss (cdr l+mu*s))))) + + (define phase-to-link-module-uses-expr + (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis)) + + (define phase-to-link-extra-inspectorsss + (for*/hash ([(phase l+mu*s) (in-hash body-linklets+module-use*s)] + [(extra-inspectorsss) (in-value (module-uses-extract-extra-inspectorsss + (cdr l+mu*s) + (car l+mu*s) + cross-linklet-inlining? + (length body-imports)))] + #:when extra-inspectorsss) + (values phase extra-inspectorsss))) + + (values body-linklets ; main compilation result + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorsss + syntax-literals + encoded-root-expand-pos)) + +;; ---------------------------------------- + +;; Evaluating a top-level definition has a secondary effect: it +;; adjusts the binding of defined identifiers. This mingling of +;; evaluation and expansion is the main weirdness of the top +;; level. +(define (compile-top-level-bind ids binding-syms cctx trans-exprs) + (define phase (compile-context-phase cctx)) + (define self (compile-context-self cctx)) + (define header (compile-context-header cctx)) + (define mpis (header-module-path-indexes header)) + ;; The binding that we install at run time should not include + ;; the temporary binding scope that the expander added: + (define top-level-bind-scope (root-expand-context-top-level-bind-scope + (namespace-get-root-expand-ctx + (compile-context-namespace cctx)))) + ;; For installing a binding: + (define self-expr (add-module-path-index! mpis self)) + ;; Generate calls to `top-level-bind!`: + `(begin + ,@(for/list ([id (in-list ids)] + [binding-sym (in-list binding-syms)] + [trans-expr (in-list (or trans-exprs + (for/list ([id (in-list ids)]) + `'#f)))]) + (define id-stx + (compile-quote-syntax (remove-scope id top-level-bind-scope) + cctx)) + `(,top-level-bind!-id ,id-stx ,self-expr ,phase ,phase-shift-id ,ns-id ',binding-sym + ,(and trans-exprs #t) ,trans-expr)))) + +;; To support namespace-relative binding, bundle scope information for +;; the current namespace into a syntax object +(define (compile-namespace-scopes cctx) + (define v (encode-namespace-scopes (compile-context-namespace cctx))) + (compile-quote-syntax v cctx)) + +;; ---------------------------------------- + +;; Handle the `define-syntaxes`-with-zero-results hack for the top level; +;; beware that we make two copies of `finish` +(define (generate-top-level-define-syntaxes gen-syms rhs transformer-set!s finish) + `(call-with-values + (lambda () ,rhs) + (case-lambda + [,gen-syms + (begin + ,@transformer-set!s + ,finish + (void))] + [() + (let-values ([,gen-syms (values ,@(for/list ([s (in-list gen-syms)]) `'#f))]) + (begin + ,finish + (void)))] + [args + ;; Provoke the wrong-number-of-arguments error: + (let-values ([,gen-syms (apply values args)]) + (void))]))) + +;; ---------------------------------------- + +(define (propagate-inline-property e orig-s) + (define v (syntax-property orig-s 'compiler-hint:cross-module-inline)) + (if v + (correlated-property e 'compiler-hint:cross-module-inline v) + e)) + +;; ---------------------------------------- + +(define (make-module-use-to-linklet cross-linklet-inlining? ns get-module-linklet-info init-mu*s) + ;; Inlining might reach the same module though different indirections; + ;; use a consistent `module-use` value so that the compiler knows to + ;; collapse them to a single import + (define mu*-intern-table (make-hash)) + (define (intern-module-use* mu*) + (define mod-name (module-path-index-resolve (module-use-module mu*))) + (define existing-mu* (hash-ref mu*-intern-table (cons mod-name (module-use-phase mu*)) #f)) + (cond + [existing-mu* + (module-use-merge-extra-inspectorss! existing-mu* mu*) + existing-mu*] + [else + (hash-set! mu*-intern-table (cons mod-name (module-use-phase mu*)) mu*) + mu*])) + (for ([mu* (in-list init-mu*s)]) + (intern-module-use* mu*)) + ;; The callback function supplied to `compile-linklet`: + (lambda (mu*-or-instance) + (cond + [(instance? mu*-or-instance) + ;; An instance represents a boilerplate linklet. An instance + ;; doesn't enable inlining (and we don't want inlining, since + ;; that would change the overall protocol for module or + ;; top-level linklets), but it can describe shapes. + (values mu*-or-instance #f)] + [(not cross-linklet-inlining?) + ;; Although we let instances through, because that's cheap, + ;; don't track down linklets and allow inlining of functions + (values #f #f)] + [mu*-or-instance + (define mu* mu*-or-instance) + (define mod-name (module-path-index-resolve (module-use-module mu*))) + (define mli (or (get-module-linklet-info mod-name (module-use-phase mu*)) + (namespace->module-linklet-info ns + mod-name + (module-use-phase mu*)))) + (when mli + ;; Record the module's declaration-time inspector, for use + ;; later recording extra inspectors for inlined referenced + (module-use*-declaration-inspector! mu* (module-linklet-info-inspector mli))) + (if mli + ;; Found info for inlining: + (values (module-linklet-info-linklet-or-instance mli) + (and (module-linklet-info-module-uses mli) ; => linklet + (list->vector + (append + '(#f #f) ; boilerplate imports common to all modules + (let ([mus (module-linklet-info-module-uses mli)] + [extra-inspectorsss (module-linklet-info-extra-inspectorsss mli)]) + (for/list ([sub-mu (in-list mus)] + [imports (in-list + (linklet-import-variables + (module-linklet-info-linklet-or-instance mli)))] + [extra-inspectorss (in-list (or extra-inspectorsss + ;; a list of the right length: + mus))]) + (intern-module-use* + (module-use+extra-inspectors (module-path-index-shift + (module-use-module sub-mu) + (module-linklet-info-self mli) + (module-use-module mu*)) + (module-use-phase sub-mu) + ;; The remaining arguments are used to + ;; make an `module-use*` instead of a + ;; plain `module-use` + imports + (module-linklet-info-inspector mli) + (module-linklet-info-extra-inspector mli) + (and extra-inspectorsss + extra-inspectorss))))))))) + ;; Didn't find info, for some reason: + (values #f #f))] + [else + ;; Boilerplate linklet with no compile-time information + (values #f #f)]))) diff -Nru racket-6.12+ppa1/src/expander/compile/header.rkt racket-7.0+ppa1/src/expander/compile/header.rkt --- racket-6.12+ppa1/src/expander/compile/header.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/header.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,328 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/scope.rkt" + "module-use.rkt" + "../common/module-path.rkt" + "context.rkt" + "built-in-symbol.rkt" + "reserved-symbol.rkt" + "namespace-scope.rkt" + "serialize.rkt") + +(provide (struct-out header) + make-header + + make-syntax-literals + syntax-literals-empty? + syntax-literals-count + add-syntax-literal! + add-syntax-literals! + generate-eager-syntax-literals! + generate-eager-syntax-literal-lookup + generate-lazy-syntax-literals! + generate-lazy-syntax-literals-data! + generate-lazy-syntax-literal-lookup + syntax-literals-as-vector + + header-empty-syntax-literals? + + local-key->symbol + select-fresh + + register-required-variable-use! + register-as-defined! + registered-as-required? + generate-links+imports) + +;; A compilation header accumulates information about syntax literals +;; and about referenced required and defined variables. This +;; information is accumulated while compiling expressions, and then +;; header information is extracted into deserialization code that +;; reconstructs syntax literals, module path indexes, and so on. The +;; header also keeps track of which variable references correspond to +;; which linklet imports, and it keeps track of compile-time +;; inspectors that may grant access to some of those imports. + +(struct syntax-literals ([stxes #:mutable] + [count #:mutable])) + +(struct header (module-path-indexes ; module-path-index -> linklet import position + binding-sym-to-define-sym ; sym -> sym; avoid conflicts with primitives + [binding-syms-in-order #:mutable] ; list of sym + require-var-to-import-sym ; variable-use -> sym + import-sym-to-extra-inspectors ; sym -> set of inspectors + [require-vars-in-order #:mutable] ; list of variable-use + define-and-import-syms ; hash of sym -> 'defined/'imported, to select distinct symbols + syntax-literals)) ; syntax-literals + +(struct variable-use (module-use sym) + #:transparent) ; for hashing + +(define (make-syntax-literals) + (syntax-literals null 0)) + +(define (make-header mpis syntax-literals) + (header mpis + (make-hasheq) ; binding-sym-to-define-sym + null ; binding-syms-in-order + (make-variable-uses) ; require-var-to-import-sym + (make-hasheq) ; import-sym-to-extra-inspectors + null ; require-vars-in-order + (make-hasheq) ; define-and-import-syms + syntax-literals)) + +(define (make-variable-uses) + (make-hash)) + +(define (add-syntax-literal! header-or-literals q) + (define sl (if (header? header-or-literals) + (header-syntax-literals header-or-literals) + header-or-literals)) + (define pos (syntax-literals-count sl)) + (set-syntax-literals-count! sl (add1 pos)) + (set-syntax-literals-stxes! sl (cons q (syntax-literals-stxes sl))) + pos) + +;; Return a position in a larger vector where the given vector will +;; start; for convenience, pair that position with the size of the +;; vector +(define (add-syntax-literals! sl vec) + (define pos (syntax-literals-count sl)) + (for ([e (in-vector vec)]) + (add-syntax-literal! sl e)) + (cons pos (vector-length vec))) + +(define (syntax-literals-empty? sl) + (null? (syntax-literals-stxes sl))) + +;; Generate on-demand shifting (not shared among module instances) +;; using `deserialize-syntax-literal-data` (shared among module +;; instances); the result defines `syntax-literals-id` and +;; `get-syntax-literal!-id` +(define (generate-lazy-syntax-literals! sl mpis self + #:skip-deserialize? [skip-deserialize? #f]) + `((define-values (,syntax-literals-id) + (make-vector ,(syntax-literals-count sl) #f)) + (define-values (,get-syntax-literal!-id) + (lambda (pos) + (let-values ([(ready-stx) (unsafe-vector*-ref ,syntax-literals-id pos)]) + (if ready-stx + ready-stx + (begin + ,@(if skip-deserialize? + null + `((if (unsafe-vector*-ref ,deserialized-syntax-vector-id 0) + (void) + (,deserialize-syntax-id ,bulk-binding-registry-id)))) + (let-values ([(stx) + (syntax-module-path-index-shift + (syntax-shift-phase-level + (unsafe-vector*-ref ,deserialized-syntax-vector-id pos) + ,phase-shift-id) + ,(add-module-path-index! mpis self) + ,self-id + ,inspector-id)]) + (begin + (vector-cas! ,syntax-literals-id pos #f stx) + (unsafe-vector*-ref ,syntax-literals-id pos)))))))))) + +;; Generate on-demand deserialization (shared across instances); the +;; result defines `deserialize-syntax-id` +(define (generate-lazy-syntax-literals-data! sl mpis) + (cond + [(syntax-literals-empty? sl) + `((define-values (,deserialize-syntax-id) #f))] + [else + `((define-values (,deserialize-syntax-id) + ;; Put deserialization under a `lambda` so that it's loaded + ;; from bytecode on demand, and in a function that can be + ;; discarded via `set!` after deserialization. Since this + ;; deserialized form is shared via the module cache across + ;; module instances and even module declarations, it must not + ;; depend on anything namespace-, declaration-, or + ;; instance-specific. As an exception, however, a bulk-binding + ;; registry can be namespace- or declaration-specific + ;; declaration on the grounds that all declarations should + ;; provide the same information for bulk bindings. + (lambda (,bulk-binding-registry-id) + (begin + (vector-copy! + ,deserialized-syntax-vector-id + '0 + (let-values ([(,inspector-id) #f]) + ,(generate-deserialize (vector->immutable-vector + (list->vector + (reverse (syntax-literals-stxes sl)))) + mpis))) + (set! ,deserialize-syntax-id #f)))))])) + +(define (generate-lazy-syntax-literal-lookup pos) + `(,get-syntax-literal!-id ,pos)) + +;; Generate immediate deserialization and shifting of a set of syntax +;; objects across multiple phases; the result is an expression for a +;; vector (indexed by syntax-literal position). +(define (generate-eager-syntax-literals! sl mpis base-phase self ns) + (cond + [(syntax-literals-empty? sl) + ;; Avoid serializing unneeded namespace scope: + #f] + [else + `(let-values ([(ns+stxss) ,(generate-deserialize (cons + ;; Prefix with namespace scope: + (encode-namespace-scopes ns) + (reverse + (syntax-literals-stxes sl))) + mpis)]) + (let-values ([(ns-scope-s) (car ns+stxss)]) + (list->vector + (map (lambda (stx) + (swap-top-level-scopes + (syntax-module-path-index-shift + (syntax-shift-phase-level + stx + (- ,base-phase ,dest-phase-id)) + ,(add-module-path-index! mpis self) + ,self-id) + ns-scope-s ,ns-id)) + (cdr ns+stxss)))))])) + +(define (generate-eager-syntax-literal-lookup pos) + `(unsafe-vector*-ref ,syntax-literals-id ,pos)) + +;; Genereate a vector for a set of syntax objects; the result is a +;; vector like the one generated in expression from by +;; `generate-eager-syntax-literals!`, where no shifts are needed +(define (syntax-literals-as-vector sl) + (list->vector + (reverse (syntax-literals-stxes sl)))) + +(define (header-empty-syntax-literals? h) + (syntax-literals-empty? (header-syntax-literals h))) + +;; ---------------------------------------- + +;; Pick a symbol to represent a local binding, given the binding's key +(define (local-key->symbol key) + ;; A local-binding key is already an distinct uninterned symbol + ;; (with a deterministic label) + key) + +;; Select a symbol not yet used in the header or as a built-in name +(define (select-fresh sym header) + (if (symbol-conflicts? sym header) + (let loop ([pos 1]) + (define new-sym (string->symbol (format "~a/~a" pos sym))) + (if (symbol-conflicts? new-sym header) + (loop (add1 pos)) + new-sym)) + sym)) + +(define (symbol-conflicts? sym header) + (or (built-in-symbol? sym) + (hash-ref (header-define-and-import-syms header) sym #f))) + +;; ---------------------------------------- + +(define (register-required-variable-use! header mpi phase sym extra-inspector + #:defined? [defined? #f]) + (define key (variable-use (module-use mpi phase) sym)) + (define variable-uses (header-require-var-to-import-sym header)) + (define prev-var-sym (hash-ref variable-uses key #f)) + (define var-sym + (or prev-var-sym + (let ([sym (select-fresh (variable-use-sym key) header)]) + (hash-set! variable-uses key sym) + (set-header-require-vars-in-order! header + (cons key + (header-require-vars-in-order header))) + (hash-set! (header-define-and-import-syms header) sym (if defined? 'defined 'required)) + sym))) + (when (and extra-inspector + ;; Only track extra inspectors if all references have an inspector; + ;; otherwise, the one without an extra inspector has the least access + (not prev-var-sym)) + (define extra-inspectors (header-import-sym-to-extra-inspectors header)) + (hash-update! extra-inspectors var-sym (lambda (s) (set-add s extra-inspector)) #hasheq())) + var-sym) + +(define (register-as-defined! header def-sym) + (hash-set! (header-define-and-import-syms header) def-sym 'defined)) + +(define (registered-as-required? header var-sym) + (eq? 'required (hash-ref (header-define-and-import-syms header) var-sym #f))) + +;; Returns: +;; link-names : a list of sym +;; link-requires : a list of module path indexes +;; imports : a list of S-expressions for imports; refers to `link-names` +;; extra-inspectorsss : a list of hash of symbol to (or/c #f (set/c inspector?)) +;; def-decls : a list of S-expressions for forward-reference declarations +(define (generate-links+imports header phase cctx cross-linklet-inlining?) + ;; Find each distinct module+phase, where `link-mod-uses` is in a + ;; determinsitic order + (define-values (mod-use-ht link-mod-uses) + (for/fold ([ht #hash()] [link-mod-uses null]) ([(vu) (in-list (header-require-vars-in-order header))]) + (define mu (variable-use-module-use vu)) + (if (or (hash-ref ht mu #f) + (eq? (module-use-module mu) + (compile-context-self cctx)) + (top-level-module-path-index? (module-use-module mu))) + (values ht link-mod-uses) + (values (hash-set ht mu #t) + (cons mu link-mod-uses))))) + + (values + ;; Module-uses list: + link-mod-uses + ;; Imports, using the same order as module-uses list: + (for/list ([mu (in-list link-mod-uses)]) + (for/list ([vu (in-list (header-require-vars-in-order header))] + #:when (equal? mu (variable-use-module-use vu))) + (define var-sym (hash-ref (header-require-var-to-import-sym header) vu)) + (define ex-sym (variable-use-sym vu)) + (if (eq? var-sym ex-sym) + var-sym + `[,ex-sym ,var-sym]))) + ;; Extra inspectorsss, in parallel to imports + (for/list ([mu (in-list link-mod-uses)]) + (define extra-inspectorss + (for*/hash ([vu (in-list (header-require-vars-in-order header))] + #:when (equal? mu (variable-use-module-use vu)) + [var-sym (in-value (hash-ref (header-require-var-to-import-sym header) vu))] + [extra-inspectors (in-value (hash-ref (header-import-sym-to-extra-inspectors header) var-sym #f))] + #:when (or extra-inspectors + ;; For inlining purposes, keep track of all referenced, + ;; since formerly unreferenced will mean inlined + cross-linklet-inlining?)) + (values var-sym extra-inspectors))) + (and (hash-count extra-inspectorss) + extra-inspectorss)) + ;; Declarations (for non-module contexts) + (for/list ([vu (in-list (header-require-vars-in-order header))] + #:when (let ([mod (module-use-module (variable-use-module-use vu))]) + (or (eq? mod (compile-context-self cctx)) + (top-level-module-path-index? mod)))) + (define var-sym (hash-ref (header-require-var-to-import-sym header) vu)) + (define ex-sym (variable-use-sym vu)) + (if (eq? var-sym ex-sym) + var-sym + `(,var-sym ,ex-sym))))) + +;; Get a reasonably nice name from a module-path-index +(define (extract-name mpi) + (define-values (p base) (module-path-index-split mpi)) + (cond + [(symbol? p) p] + [(path? p) (let-values ([(base name dir?) (split-path p)]) + (path-replace-extension name #""))] + [(string? p) (path-replace-extension p #"")] + [(and (pair? p) (eq? (car p) 'quote)) + (cadr p)] + [(and (pair? p) (eq? (car p) 'file)) + (let-values ([(base name dir?) (split-path (cadr p))]) + (path-replace-extension name #""))] + [(and (pair? p) (eq? (car p) 'lib)) + (path-replace-extension (cadr p) #"")] + [else 'module])) + diff -Nru racket-6.12+ppa1/src/expander/compile/instance.rkt racket-7.0+ppa1/src/expander/compile/instance.rkt --- racket-6.12+ppa1/src/expander/compile/instance.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/instance.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,67 @@ +#lang racket/base +(require "reserved-symbol.rkt" + "../host/linklet.rkt") + +;; Compilation generates a linklet that has an `instance` argument to +;; receive instantiation information: a namspace, its phase, etc. + +(provide instance-imports + make-instance-instance + make-module-body-instance-instance + empty-syntax-literals-instance + empty-module-body-instance + empty-syntax-literals-data-instance + empty-top-syntax-literal-instance + empty-instance-instance) + +(define instance-imports + `(,ns-id + ,phase-shift-id + ,self-id + ,inspector-id ; declaration-time inspector to grant to syntax objects + ,bulk-binding-registry-id ; declaration-time registry to connect to bulk bindings + ,set-transformer!-id)) + +(define (make-instance-instance #:namespace ns + #:phase-shift phase-shift + #:self self + #:inspector inspector + #:bulk-binding-registry bulk-binding-registry + #:set-transformer! set-transformer!) + (make-instance 'instance #f 'constant + ns-id ns + phase-shift-id phase-shift + self-id self + inspector-id inspector + bulk-binding-registry-id bulk-binding-registry + set-transformer!-id set-transformer!)) + +(define (make-module-body-instance-instance #:set-transformer! set-transformer!) + (make-instance 'body-instance #f 'constant + set-transformer!-id set-transformer!)) + +(define empty-syntax-literals-instance + (make-instance 'empty-stx #f 'constant + get-syntax-literal!-id (lambda (pos) #f) + 'get-encoded-root-expand-ctx #f)) + +(define empty-module-body-instance + (make-module-body-instance-instance #:set-transformer! (lambda (name val) (void)))) + +(define empty-top-syntax-literal-instance + (make-instance 'top-syntax-literal #f 'constant + mpi-vector-id #f + syntax-literals-id #f)) + +(define empty-syntax-literals-data-instance + (make-instance 'empty-stx-data #f 'constant + deserialized-syntax-vector-id (vector) + deserialize-syntax-id void)) + +(define empty-instance-instance + (make-instance-instance #:namespace #f + #:phase-shift #f + #:self #f + #:inspector #f + #:bulk-binding-registry #f + #:set-transformer! #f)) diff -Nru racket-6.12+ppa1/src/expander/compile/known.rkt racket-7.0+ppa1/src/expander/compile/known.rkt --- racket-6.12+ppa1/src/expander/compile/known.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/known.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,55 @@ +#lang racket/base + +(provide (struct-out known-defined) + (struct-out known-defined/delay) + (struct-out known-property) + (struct-out known-function) + (struct-out known-function-of-satisfying) + (struct-out known-predicate) + (struct-out known-satisfies) + (struct-out known-struct-op) + lookup-defn) + +;; Known locals and defined variables map to one of he following: + +(struct known-defined () #:prefab) +;; all we know is that it's defined and can be referenced now + +(struct known-defined/delay (thunk) #:prefab) +;; force the thunk and try again + +(struct known-property () #:prefab) +;; defined as a struct property with no guard + +(struct known-function (arity pure?) #:prefab) +;; function of known arity and maybe known pure, where +;; pure must return 1 value + +(struct known-function-of-satisfying (arg-predicate-keys) #:prefab) +;; function that is known to be pure as long as its arguments +;; are known to satisfy certain predicates + +(struct known-predicate (key) #:prefab) +;; a predicate that is pure and categorizes an argument + +(struct known-satisfies (predicate-key) #:prefab) +;; a value that is known to satisfy a specific predicate + +(struct known-struct-op (type field-count) #:prefab) +;; struct operation for a type with n fields +;; where type is one of: 'struct-type, 'constructor +;; 'predicate, 'accessor, 'mutator +;; 'general-accessor, +;; or 'general-mutator (needs field index) +;; and the 'constructor mode can be used for things that +;; construct built-in datatypes; for 'general-accessor or +;; 'general-mutator, the field count doesn't include inherited + +;; Supports `known-defined/delay`: +(define (lookup-defn defns sym) + (define d (hash-ref defns sym #f)) + (cond + [(known-defined/delay? d) + ((known-defined/delay-thunk d)) + (lookup-defn defns sym)] + [else d])) diff -Nru racket-6.12+ppa1/src/expander/compile/main.rkt racket-7.0+ppa1/src/expander/compile/main.rkt --- racket-6.12+ppa1/src/expander/compile/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,72 @@ +#lang racket/base +(require "context.rkt" + "top.rkt" + "multi-top.rkt" + "module.rkt" + "recompile.rkt") + +;; Compilation of expanded code produces an S-expression (but enriched +;; with source locations and properties) where run-time primitive are +;; accessed directly, and all linklet imports and local variables are +;; renamed to avoid collisions with the primitive names and to avoid +;; all shadowing (but the same variable might be used in +;; non-overlapping local contexts). A `compile-linklet` function +;; (currently provided by the runtime system) then compiles the +;; enriched S-expression to bytecode. + +;; Compilation to linklets uses one of two protocols, which differ in +;; the shapes of linklets that they generate: +;; +;; * Top-level forms or stand-alone expressions (such as the +;; right-hand side of a `define-syntaxes` form within a module, +;; which must be compiled to continue expanding the module) are +;; compiled using one protocol. +;; +;; In the case of top-level forms, a sequence of forms that affect +;; binding or transformers must be compiled separately --- normally +;; via `per-top-level` in "../eval/main.rkt". The separarately +;; compiled forms can them be combined into a single compilation +;; record. +;; +;; The generated linklets for a single form include one linklet for +;; potentially serialized module path indices and syntax objects, +;; plus one linklet per relevant phase. +;; +;; Multi-form combinations group the linklet sets for individual +;; compilations in nested linklet directories. In addition, a +;; linklet implements deserialization of all the data across +;; top-level forms that are compiled together, so that they share. +;; (In that case, the deserialization linklet with each inidvidual +;; form turns out not to be used.) +;; +;; * Modules are compiled to a slightly different protocol. Like the +;; top-level protocol, the resulting set of linklets includes on +;; linklet per phase plus three linklets for housing potentially +;; serialized data. An additional linklet reports metadata about the +;; modules, such as its requires and provides. An individual module +;; is represented by a linklet bundle, and a module is compiled with +;; submodules through nested linklet directories. +;; +;; Besides the extra metadata module, the handling of syntax-object +;; deserialization is a little different for modules than top-level +;; forms, because syntax-literal unmarshaling is lazy for modules. +;; +;; Whichever protocol is used, the result is wrapped in a +;; `compiled-in-memory` structure, which retains original module path +;; indices and syntax objects. If the compiled code is evaluated +;; directly, then the retained values are used instead of running +;; unmarshaling code in generated linklets. That's both faster an +;; preserves some expected sharing. When a `compile-in-memory` +;; structure is written, it writes the same as a linklet directory +;; (i.e., it loses the shortcut information, as well as some +;; inspector information). + +(provide make-compile-context + + compile-single + compile-top + compiled-tops->compiled-top + + compile-module + + compiled-expression-recompile) diff -Nru racket-6.12+ppa1/src/expander/compile/module.rkt racket-7.0+ppa1/src/expander/compile/module.rkt --- racket-6.12+ppa1/src/expander/compile/module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,420 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../common/phase.rkt" + "../namespace/core.rkt" + "../namespace/module.rkt" + "../common/module-path.rkt" + "../common/performance.rkt" + "../expand/parsed.rkt" + "module-use.rkt" + "serialize.rkt" + "side-effect.rkt" + "built-in-symbol.rkt" + "../host/linklet.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "form.rkt" + "compiled-in-memory.rkt" + "../eval/reflect.rkt" + "../eval/reflect-name.rkt") + +(provide compile-module) + +;; Compiles module to a set of linklets that is returned as a +;; `compiled-in-memory` --- or a hash table containing S-expression +;; linklets if `to-source?` is true. +(define (compile-module p cctx + #:force-linklet-directory? [force-linklet-directory? #f] + #:serializable? [serializable? #f] + #:to-source? [to-source? #f] + #:modules-being-compiled [modules-being-compiled (make-hasheq)] + #:need-compiled-submodule-rename? [need-compiled-submodule-rename? #t]) + + (define full-module-name (let ([parent-full-name (compile-context-full-module-name cctx)] + [name (syntax-e (parsed-module-name-id p))]) + (if parent-full-name + (append (if (list? parent-full-name) + parent-full-name + (list parent-full-name)) + (list name)) + name))) + + ;; Extract submodules; each list is (cons linklet-directory-key compiled-in-memory) + (define compiled-submodules (parsed-module-compiled-submodules p)) + (define (get-submodules star?) + (for/list ([(name star?+compiled) (in-hash compiled-submodules)] + #:when (eq? star? (car star?+compiled))) + (cons name (if (and need-compiled-submodule-rename? + (not (parsed-module-compiled-module p))) + (update-submodule-names (cdr star?+compiled) name full-module-name) + (cdr star?+compiled))))) + (define pre-submodules (get-submodules #f)) + (define post-submodules (get-submodules #t)) + + (cond + [(parsed-module-compiled-module p) + => (lambda (c) + ;; We've already compiled the module body during expansion. + ;; Update the name in the compiled form and add in submodules. + (define-values (name prefix) (if (symbol? full-module-name) + (values full-module-name null) + (let ([r (reverse full-module-name)]) + (values (car r) (reverse (cdr r)))))) + (define m (change-module-name c name prefix)) + (module-compiled-submodules (module-compiled-submodules m #t (map cdr pre-submodules)) + #f + (map cdr post-submodules)))] + [else + (compile-module-from-parsed p cctx + #:full-module-name full-module-name + #:force-linklet-directory? force-linklet-directory? + #:serializable? serializable? + #:to-source? to-source? + #:modules-being-compiled modules-being-compiled + #:pre-submodules pre-submodules + #:post-submodules post-submodules + #:need-compiled-submodule-rename? need-compiled-submodule-rename?)])) + +;; ------------------------------------------------------------ + +(define (compile-module-from-parsed p cctx + #:full-module-name full-module-name + #:force-linklet-directory? force-linklet-directory? + #:serializable? serializable? + #:to-source? to-source? + #:modules-being-compiled modules-being-compiled + #:pre-submodules pre-submodules + #:post-submodules post-submodules + #:need-compiled-submodule-rename? need-compiled-submodule-rename?) + (performance-region + ['compile 'module] + + (define enclosing-self (compile-context-module-self cctx)) + (define self (parsed-module-self p)) + (define requires (parsed-module-requires p)) + (define provides (parsed-module-provides p)) + (define encoded-root-expand-ctx-box (box (parsed-module-encoded-root-ctx p))) ; for `module->namespace` + (define body-context-simple? (parsed-module-root-ctx-simple? p)) + (define language-info (filter-language-info (syntax-property (parsed-s p) 'module-language))) + (define bodys (parsed-module-body p)) + + (define empty-result-for-module->namespace? #f) + + (define mpis (make-module-path-index-table)) + + (define body-cctx (struct-copy compile-context cctx + [phase 0] + [self self] + [module-self self] + [full-module-name full-module-name] + [lazy-syntax-literals? #t])) + + (define cross-phase-persistent? #f) + + ;; Callback to track phases that have side effects + (define side-effects (make-hasheqv)) + (define (check-side-effects! e ; compiled expression + expected-results ; number of expected results, or #f if any number is ok + phase + required-reference?) + (unless (hash-ref side-effects phase #f) + (when (any-side-effects? e expected-results #:ready-variable? required-reference?) + (hash-set! side-effects phase #t)))) + + (when (and need-compiled-submodule-rename? + modules-being-compiled) + ;; Re-register submodules, since they're so far registered under + ;; the expand-time module path. + (unless (null? post-submodules) + (error "internal error: have post submodules, but not already compiled")) + (register-compiled-submodules modules-being-compiled pre-submodules self)) + + ;; Compile the sequence of body forms: + (define-values (body-linklets + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorsss + syntax-literals + root-ctx-pos) + (compile-forms bodys body-cctx mpis + #:body-imports `([,get-syntax-literal!-id] + [,set-transformer!-id]) + #:body-import-instances (list empty-syntax-literals-instance + empty-module-body-instance) + #:body-suffix-forms '((void)) ; otherwise, compiler always preserves last form + #:force-phases '(0) ; minor hack for more consistent compilation + #:encoded-root-expand-ctx-box encoded-root-expand-ctx-box + #:root-ctx-only-if-syntax? body-context-simple? + #:compiled-expression-callback check-side-effects! + #:other-form-callback (lambda (body cctx) + (cond + [(parsed-#%declare? body) + (define-match m (parsed-s body) '(_ kw ...)) + (for ([kw (in-list (m 'kw))]) + (when (eq? (syntax-e kw) '#:cross-phase-persistent) + (set! cross-phase-persistent? #t)) + (when (eq? (syntax-e kw) '#:empty-namespace) + (set! empty-result-for-module->namespace? #t) + (set-box! encoded-root-expand-ctx-box #f))) + #f] + [else #f])) + #:get-module-linklet-info (lambda (mod-name phase) + (define ht (and modules-being-compiled + (hash-ref modules-being-compiled mod-name #f))) + (and ht (hash-ref ht phase #f))) + #:to-source? to-source? + #:serializable? serializable?)) + + (when modules-being-compiled + ;; Record this module's linklets for cross-module inlining among (sub)modules + ;; that are compiled together + (hash-set! modules-being-compiled + (module-path-index-resolve self) + (for/hasheq ([(phase linklet) (in-hash body-linklets)]) + (values phase + (module-linklet-info linklet + (hash-ref phase-to-link-module-uses phase #f) + self + #f ; inspector is the same as other modules + #f ; no extra inspector, so far + (and phase-to-link-extra-inspectorsss + (hash-ref phase-to-link-extra-inspectorsss phase #f))))))) + + ;; Assemble the declaration linking unit, which includes linking + ;; information for each phase, is instanted once for a module + ;; declaration, and is shared among instances + (define declaration-linklet + (and serializable? + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'decl)))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id]) + ;; exports + (self-mpi + requires + provides + phase-to-link-modules) + ;; body + (define-values (self-mpi) ,(add-module-path-index! mpis self)) + (define-values (requires) ,(generate-deserialize requires mpis #:syntax-support? #f)) + (define-values (provides) ,(generate-deserialize provides mpis #:syntax-support? #f)) + (define-values (phase-to-link-modules) ,phase-to-link-module-uses-expr))))) + + ;; Assemble a linklet that shifts syntax objects on demand. + ;; Include an encoding of the root expand context, if any, so that + ;; `module->namespace` can have the same scopes as literal syntax + ;; objects in the module. + (define syntax-literals-linklet + (and (not (syntax-literals-empty? syntax-literals)) + ((if to-source? values (lambda (s) + (performance-region + ['compile 'module 'linklet] + (define-values (linklet new-keys) + (compile-linklet s 'syntax-literals + (vector deserialize-instance + empty-top-syntax-literal-instance + empty-syntax-literals-data-instance + empty-instance-instance) + (lambda (inst) (values inst #f)) + (if serializable? '(serializable) '()))) + linklet))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id] + [,deserialized-syntax-vector-id + ,@(if serializable? + `(,deserialize-syntax-id) + '())] + ,instance-imports) + ;; exports + (,get-syntax-literal!-id + get-encoded-root-expand-ctx) + ;; body + ,@(generate-lazy-syntax-literals! syntax-literals mpis self + #:skip-deserialize? (not serializable?)) + (define-values (get-encoded-root-expand-ctx) + ,(cond + [root-ctx-pos + `(lambda () + ,(generate-lazy-syntax-literal-lookup root-ctx-pos))] + [empty-result-for-module->namespace? + ;; We also attach this information directly to the bundle, + ;; in case this linklet is not included (due to an empty + ;; set of syntax literals) + `'empty] + [else + `'#f])))))) + + ;; Assemble a linklet that deserializes unshifted syntax objects on + ;; demand. An instance of this linklet is shared for all + ;; instantiations of the module, like the data linklet. It's + ;; separate from the data linklet so that the data linklet can be + ;; instantiated for information that just depends on module path + ;; indexes, such as required modules. + (define syntax-literals-data-linklet + (and serializable? + (not (syntax-literals-empty? syntax-literals)) + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'syntax-literals-data)))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id]) + ;; exports + (,deserialized-syntax-vector-id + ,deserialize-syntax-id) + ;; body + (define-values (,deserialized-syntax-vector-id) + (make-vector ,(syntax-literals-count syntax-literals) #f)) + ,@(performance-region + ['compile 'module 'serialize] + (generate-lazy-syntax-literals-data! syntax-literals mpis)))))) + + ;; The data linklet houses deserialized data for use by the + ;; declaration and module-body linklets. Its instance is shared + ;; across module instances. + (define data-linklet + (and serializable? + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'data)))) + `(linklet + ;; imports + (,deserialize-imports) + ;; exports + (,mpi-vector-id) + ;; body + (define-values (,inspector-id) (current-code-inspector)) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)))))) + + ;; Combine linklets with other metadata as the bundle: + (define bundle + (let* ([bundle (hash-set body-linklets 'name full-module-name)] + [bundle (hash-set bundle 'decl (or declaration-linklet + ;; Need a 'decl mapping to indicate + ;; that bundle is a module: + 'in-memory))] + [bundle (if data-linklet + (hash-set bundle 'data data-linklet) + bundle)] + [bundle (if syntax-literals-linklet + (hash-set bundle 'stx syntax-literals-linklet) + bundle)] + [bundle (if syntax-literals-data-linklet + (hash-set bundle 'stx-data syntax-literals-data-linklet) + bundle)] + [bundle (if (null? pre-submodules) + bundle + (hash-set bundle 'pre (map car pre-submodules)))] + [bundle (if (null? post-submodules) + bundle + (hash-set bundle 'post (map car post-submodules)))] + [bundle (if cross-phase-persistent? + (hash-set bundle 'cross-phase-persistent? #t) + bundle)] + [bundle (if language-info + (hash-set bundle 'language-info language-info) + bundle)] + [bundle (if (zero? min-phase) + bundle + (hash-set bundle 'min-phase min-phase))] + [bundle (if (zero? max-phase) + bundle + (hash-set bundle 'max-phase max-phase))] + [bundle (if (hash-count side-effects) + (hash-set bundle 'side-effects (sort (hash-keys side-effects) <)) + bundle)] + [bundle (if empty-result-for-module->namespace? + (hash-set bundle 'module->namespace 'empty) + bundle)]) + (hash->linklet-bundle bundle))) + + ;; Combine with submodules in a linklet directory + (define ld + (cond + [(and (null? pre-submodules) + (null? post-submodules) + (not force-linklet-directory?)) + ;; Just use the bundle representation directly: + bundle] + [else + ((if to-source? values hash->linklet-directory) + (for/fold ([ht (hasheq #f bundle)]) ([sm (in-list (append pre-submodules post-submodules))]) + (hash-set ht + (car sm) + ((if to-source? values compiled-in-memory-linklet-directory) + (cdr sm)))))])) + + (cond + [to-source? ld] + [else + ;; Save mpis and syntax for direct evaluation, instead of unmarshaling: + (compiled-in-memory ld + self + requires + provides + phase-to-link-module-uses + (current-code-inspector) + phase-to-link-extra-inspectorsss + (mpis-as-vector mpis) + (syntax-literals-as-vector syntax-literals) + (map cdr pre-submodules) + (map cdr post-submodules) + #f ; no namespace scopes + #f)]))) ; not purely functional, since it declares a module + +;; ---------------------------------------- + +;; When a submodule is compiled while expanding a module, then it has a base +;; module name that is an uninterned symbol. +(define (update-submodule-names cim name full-module-name) + (change-module-name cim name (if (symbol? full-module-name) + (list full-module-name) + (reverse (cdr (reverse full-module-name)))))) + +(define (register-compiled-submodules modules-being-compiled pre-submodules self) + (for ([s (in-list pre-submodules)]) + (define name (car s)) + (define cim (cdr s)) + (define phase-to-link-module-uses (compiled-in-memory-phase-to-link-module-uses cim)) + (define ld (compiled-in-memory-linklet-directory cim)) + (define sm-self (module-path-index-join `(submod "." ,name) self)) + (define phase-to-extra-inspectorsss (compiled-in-memory-phase-to-link-extra-inspectorsss cim)) + (hash-set! modules-being-compiled + (module-path-index-resolve sm-self) + (for/hasheq ([(phase linklet) (in-hash (linklet-bundle->hash + (if (linklet-directory? ld) + (hash-ref (linklet-directory->hash ld) #f) + ld)))] + #:when (number? phase)) + (values phase + (module-linklet-info linklet + (hash-ref phase-to-link-module-uses phase #f) + (compiled-in-memory-original-self cim) + #f ; inspector is the same as the module being compiled + (compiled-in-memory-compile-time-inspector cim) + (and phase-to-extra-inspectorsss + (hash-ref phase-to-extra-inspectorsss phase #f)))))))) + +;; ---------------------------------------- + +(define (filter-language-info li) + (and (vector? li) + (= 3 (vector-length li)) + (module-path? (vector-ref li 0)) + (symbol? (vector-ref li 1)) + li)) diff -Nru racket-6.12+ppa1/src/expander/compile/module-use.rkt racket-7.0+ppa1/src/expander/compile/module-use.rkt --- racket-6.12+ppa1/src/expander/compile/module-use.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/module-use.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require "../common/module-path.rkt") + +;; A `module-use` record is just a part of module path index plus +;; phase, since that combination is commonly needed + +(provide (struct-out module-use)) + +(struct module-use (module phase) + #:property prop:equal+hash + (list (lambda (a b eql?) + (define a-mod (module-use-module a)) + (define b-mod (module-use-module b)) + (and (eql? a-mod b-mod) + (eql? (module-use-phase a) + (module-use-phase b)) + ;; Unusual, but possible with top-level evaluation: can have + ;; different "self" MPIs that refer to different modules + (let-values ([(a-path a-base) (module-path-index-split a-mod)] + [(b-path b-base) (module-path-index-split b-mod)]) + (or a-path + b-path + (eq? (module-path-index-resolved a-mod) + (module-path-index-resolved b-mod)))))) + (lambda (a hash-code) + (+ (hash-code (module-use-module a)) + (hash-code (module-use-phase a)))) + (lambda (a hash-code) + (+ (hash-code (module-use-module a)) + (hash-code (module-use-phase a)))))) diff -Nru racket-6.12+ppa1/src/expander/compile/multi-top-data.rkt racket-7.0+ppa1/src/expander/compile/multi-top-data.rkt --- racket-6.12+ppa1/src/expander/compile/multi-top-data.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/multi-top-data.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,94 @@ +#lang racket/base +(require "compiled-in-memory.rkt" + "serialize.rkt" + "header.rkt" + "eager-instance.rkt" + "reserved-symbol.rkt" + "../host/linklet.rkt") + +(provide build-shared-data-linklet) + +;; When multiple top-level forms are compiled separately (e.g., for a +;; `begin` sequence), then each has its own serialization of syntax +;; objects and module path indxes, but we want that information to be +;; shared acrosss forms that are compiled together. So, re-serialize +;; the data here in a way that can be shared across the forms. +;; +;; When a multi-form top-level sequence is evaluated, the shared +;; deserialization is propagated to each individual form by +;; reconstructing a `compiled-in-memory` structure and using the same +;; protocol as when top-level forms are evaluated immediately after +;; compilation. See "../eval/multi-top.rkt" for that part, which is +;; the run-time complement to the encoding here. + +(define (build-shared-data-linklet cims ns) + ;; Gather all mpis: + (define mpis (make-module-path-index-table)) + (define mpi-trees + (map-cim-tree cims + (lambda (cim) + (for/vector ([mpi (in-vector (compiled-in-memory-mpis cim))]) + (add-module-path-index!/pos mpis mpi))))) + + ;; Gather all syntax literals: + (define syntax-literals (make-syntax-literals)) + (define syntax-literals-trees + (map-cim-tree cims + (lambda (cim) + (add-syntax-literals! + syntax-literals + (compiled-in-memory-syntax-literals cim))))) + + ;; Gather all phase-to-module-uses tables: + (define module-uses-tables null) + (define module-uses-tables-count 0) + (define phase-to-link-module-uses-trees + (map-cim-tree cims + (lambda (cim) + (define pos module-uses-tables-count) + (set! module-uses-tables (cons (compiled-in-memory-phase-to-link-module-uses cim) + module-uses-tables)) + (set! module-uses-tables-count (add1 pos)) + pos))) + + (define syntax-literals-expr + (generate-eager-syntax-literals! + syntax-literals + mpis + 0 + #f ; self + ns)) + + (define phase-to-link-module-uses-expr + `(vector + ,@(for/list ([phase-to-link-module-uses (in-list (reverse module-uses-tables))]) + (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis)))) + + (compile-linklet + `(linklet + ;; imports + (,deserialize-imports + ,eager-instance-imports) + ;; exports + (,mpi-vector-id + mpi-vector-trees + phase-to-link-modules-vector + phase-to-link-modules-trees + syntax-literals + syntax-literals-trees) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)) + (define-values (mpi-vector-trees) ',mpi-trees) + (define-values (phase-to-link-modules-vector) ,phase-to-link-module-uses-expr) + (define-values (phase-to-link-modules-trees) ',phase-to-link-module-uses-trees) + (define-values (syntax-literals) ,syntax-literals-expr) + (define-values (syntax-literals-trees) ',syntax-literals-trees)))) + +;; ---------------------------------------- + +(define (map-cim-tree cims proc) + (let loop ([cims cims]) + (for/list ([cim (in-list cims)]) + (vector (proc cim) + (loop (compiled-in-memory-pre-compiled-in-memorys cim)) + (loop (compiled-in-memory-post-compiled-in-memorys cim)))))) diff -Nru racket-6.12+ppa1/src/expander/compile/multi-top.rkt racket-7.0+ppa1/src/expander/compile/multi-top.rkt --- racket-6.12+ppa1/src/expander/compile/multi-top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/multi-top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,82 @@ +#lang racket/base +(require "compiled-in-memory.rkt" + "multi-top-data.rkt" + "../host/linklet.rkt") + +(provide compiled-tops->compiled-top + compiled-top->compiled-tops) + +;; Encode a sequence of compiled top-level forms by creating a linklet +;; directory using labels |0|, |1|, etc., to map to the given linklet +;; directories. Keep all the existing compile-in-memory records as +;; "pre" records, too. +;; +;; If `merge-serialization?` is true, then merge all serialized data +;; and generate a new serialization to be used across all top-level +;; forms in the sequence, so that sharing across the top-level forms +;; is preserved. (By doing that only on request for the very +;; top of a tree, we repeat work only twice and avoid non-linear +;; behavior.) +(define (compiled-tops->compiled-top all-cims + #:to-source? [to-source? #f] + #:merge-serialization? [merge-serialization? #f] + #:namespace [ns #f]) ; need for `merge-serialization?` + (define cims (remove-nontail-purely-functional all-cims)) + (cond + [(= 1 (length cims)) + (car cims)] + [else + (define sequence-ht + (for/hasheq ([cim (in-list cims)] + [i (in-naturals)]) + (values (string->symbol (number->string i)) + ((if to-source? values compiled-in-memory-linklet-directory) + cim)))) + (define ht (if merge-serialization? + (hash-set sequence-ht + 'data + (hash->linklet-directory + (hasheq #f + (hash->linklet-bundle + (hasheq + 0 + (build-shared-data-linklet cims ns)))))) + sequence-ht)) + (cond + [to-source? ht] + [else + (compiled-in-memory (hash->linklet-directory ht) + #f ; self + #f ; requires + #f ; provides + #hasheqv() + #f + #hasheqv() + #() ; mpis + #() ; syntax-literals + cims + null + #f + #f)])])) + +;; Decode a sequence of compiled top-level forms by unpacking the +;; linklet directory into a list of linklet directories +(define (compiled-top->compiled-tops ld) + (define ht (linklet-directory->hash ld)) + (for*/list ([i (in-range (hash-count ht))] + [top (in-value (hash-ref ht (string->symbol (number->string i)) #f))] + #:when top) + top)) + +;; ---------------------------------------- + +(define (remove-nontail-purely-functional cims) + (let loop ([cims cims]) + (cond + [(null? cims) null] + [(null? (cdr cims)) cims] + [(and (compiled-in-memory? (car cims)) + (compiled-in-memory-purely-functional? (car cims))) + (loop (cdr cims))] + [else + (cons (car cims) (cdr cims))]))) diff -Nru racket-6.12+ppa1/src/expander/compile/namespace-scope.rkt racket-7.0+ppa1/src/expander/compile/namespace-scope.rkt --- racket-6.12+ppa1/src/expander/compile/namespace-scope.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/namespace-scope.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,67 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt") + +(provide swap-top-level-scopes + extract-namespace-scopes + encode-namespace-scopes + namespace-scopes=?) + +;; In case a syntax object in compiled top-level code is from a +;; different namespace or deserialized, swap the current namespace's +;; scope for the original namespace's scope. +;; +;; To swap a namespace scopes, we partition the namespace scopes into +;; two groups: the scope that's added after every expansion (and +;; therefore appears on every binding form), and the other scopes that +;; indicate being original to the namespace. We swap those groups +;; separately. + +(struct namespace-scopes (post other) #:prefab) + +;; Swapping function, used at run time: +(define (swap-top-level-scopes s original-scopes-s new-ns) + (define-values (old-scs-post old-scs-other) + (if (namespace-scopes? original-scopes-s) + (values (namespace-scopes-post original-scopes-s) + (namespace-scopes-other original-scopes-s)) + (decode-namespace-scopes original-scopes-s))) + (define-values (new-scs-post new-scs-other) (extract-namespace-scopes/values new-ns)) + (syntax-swap-scopes (syntax-swap-scopes s old-scs-post new-scs-post) + old-scs-other new-scs-other)) + +(define (extract-namespace-scopes/values ns) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (define post-expansion-sc (post-expansion-scope (root-expand-context-post-expansion root-ctx))) + (values (seteq post-expansion-sc) + (set-remove (list->seteq (root-expand-context-module-scopes root-ctx)) + post-expansion-sc))) + +(define (extract-namespace-scopes ns) + (define-values (scs-post scs-other) (extract-namespace-scopes/values ns)) + (namespace-scopes scs-post scs-other)) + +;; Extract namespace scopes to a syntax object, used at compile time: +(define (encode-namespace-scopes ns) + (define-values (post-expansion-scs other-scs) (extract-namespace-scopes/values ns)) + (define post-expansion-s (add-scopes (datum->syntax #f 'post) + (set->list post-expansion-scs))) + (define other-s (add-scopes (datum->syntax #f 'other) + (set->list other-scs))) + (datum->syntax #f (vector post-expansion-s other-s))) + +;; Decoding, used at run time: +(define (decode-namespace-scopes stx) + (define vec (syntax-e stx)) + (values (syntax-scope-set (vector-ref vec 0) 0) + (syntax-scope-set (vector-ref vec 1) 0))) + +(define (namespace-scopes=? nss1 nss2) + (and (set=? (namespace-scopes-post nss1) + (namespace-scopes-post nss2)) + (set=? (namespace-scopes-other nss1) + (namespace-scopes-other nss2)))) diff -Nru racket-6.12+ppa1/src/expander/compile/recompile.rkt racket-7.0+ppa1/src/expander/compile/recompile.rkt --- racket-6.12+ppa1/src/expander/compile/recompile.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/recompile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,25 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../eval/reflect.rkt") + +(provide compiled-expression-recompile) + +(define (compiled-expression-recompile c) + (unless (compiled-expression? c) + (raise-argument-error 'compiled-expression-recompile "compiled-expression?" c)) + (cond + [(linklet-bundle? c) + (hash->linklet-bundle + (for/hasheq ([(k v) (in-hash (linklet-bundle->hash c))]) + (cond + [(linklet? v) (values k (recompile-linklet v))] + [else (values k v)])))] + [(linklet-directory? c) + (hash->linklet-directory + (for/hasheq ([(k v) (in-hash (linklet-directory->hash c))]) + (cond + [(compiled-expression? v) + (values k (compiled-expression-recompile v))] + [else + (values k v)])))] + [else c])) diff -Nru racket-6.12+ppa1/src/expander/compile/reserved-symbol.rkt racket-7.0+ppa1/src/expander/compile/reserved-symbol.rkt --- racket-6.12+ppa1/src/expander/compile/reserved-symbol.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/reserved-symbol.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +#lang racket/base +(require "built-in-symbol.rkt") + +;; Identifers used in the compiler's output; we make distinct names +;; for them once to avoid shadowing of other collisions +(provide phase-shift-id + dest-phase-id + ns-id + self-id + syntax-literals-id + get-syntax-literal!-id + bulk-binding-registry-id + inspector-id + deserialize-syntax-id + deserialized-syntax-vector-id + set-transformer!-id + top-level-bind!-id + top-level-require!-id + mpi-vector-id) + +(define phase-shift-id (make-built-in-symbol! 'phase)) +(define dest-phase-id (make-built-in-symbol! 'dest-phase)) +(define ns-id (make-built-in-symbol! 'namespace)) +(define self-id (make-built-in-symbol! 'self)) +(define syntax-literals-id (make-built-in-symbol! 'syntax-literals)) +(define get-syntax-literal!-id (make-built-in-symbol! 'get-syntax-literal!)) +(define bulk-binding-registry-id (make-built-in-symbol! 'bulk-binding-registry)) +(define inspector-id (make-built-in-symbol! 'inspector)) +(define deserialize-syntax-id (make-built-in-symbol! 'deserialize-syntax)) +(define deserialized-syntax-vector-id (make-built-in-symbol! 'deserialized-syntax-vector)) +(define set-transformer!-id (make-built-in-symbol! 'set-transformer!)) +(define top-level-bind!-id (make-built-in-symbol! 'top-level-bind!)) +(define top-level-require!-id (make-built-in-symbol! 'top-level-require!)) +(define mpi-vector-id (make-built-in-symbol! 'mpi-vector)) diff -Nru racket-6.12+ppa1/src/expander/compile/self-quoting.rkt racket-7.0+ppa1/src/expander/compile/self-quoting.rkt --- racket-6.12+ppa1/src/expander/compile/self-quoting.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/self-quoting.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(provide self-quoting-in-linklet?) + +(define (self-quoting-in-linklet? datum) + (or (number? datum) (boolean? datum) (string? datum) (bytes? datum))) diff -Nru racket-6.12+ppa1/src/expander/compile/serialize-property.rkt racket-7.0+ppa1/src/expander/compile/serialize-property.rkt --- racket-6.12+ppa1/src/expander/compile/serialize-property.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/serialize-property.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,45 @@ +#lang racket/base + +;; Structures that support serialization (e.g., syntax objects) +;; implement the `prop:serialize` property, and so on. + +(provide prop:serialize + serialize? + serialize-ref + + prop:serialize-fill! + serialize-fill!? + serialize-fill!-ref + + prop:reach-scopes + reach-scopes? + reach-scopes-ref + + prop:scope-with-bindings + scope-with-bindings? + scope-with-bindings-ref + + prop:binding-reach-scopes + binding-reach-scopes? + binding-reach-scopes-ref) + +(define-values (prop:serialize serialize? serialize-ref) + (make-struct-type-property 'serialize)) + +;; For values with mutable fields, so that cycles can be reconstructed +(define-values (prop:serialize-fill! serialize-fill!? serialize-fill!-ref) + (make-struct-type-property 'serialize-fill!)) + +;; A property for a value that contains references to scopes, so that +;; all reachable scopes can be found +(define-values (prop:reach-scopes reach-scopes? reach-scopes-ref) + (make-struct-type-property 'reach-scopes)) + +;; A property for scopes, used when detecting reachable scopes; +;; a scope has bindings that conditionally reach additional scopes +(define-values (prop:scope-with-bindings scope-with-bindings? scope-with-bindings-ref) + (make-struct-type-property 'scope-with-bindings)) + +;; Like `prop:reach-scopes`, but return a single value; used for bindings: +(define-values (prop:binding-reach-scopes binding-reach-scopes? binding-reach-scopes-ref) + (make-struct-type-property 'binding-reach-scopes)) diff -Nru racket-6.12+ppa1/src/expander/compile/serialize.rkt racket-7.0+ppa1/src/expander/compile/serialize.rkt --- racket-6.12+ppa1/src/expander/compile/serialize.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/serialize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,908 @@ +#lang racket/base +(require (for-syntax racket/base) + "serialize-property.rkt" + "serialize-state.rkt" + "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/binding-table.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "../syntax/local-binding.rkt" + "../syntax/bulk-binding.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../common/module-path-intern.rkt" + "module-use.rkt" + "../host/linklet.rkt" + "built-in-symbol.rkt" + "reserved-symbol.rkt") + +;; Serialization is mostly for syntax object and module path indexes. +;; +;; Serialization is implemented by a combination of direct handling +;; for some primitive datatypes, `prop:serialize` handlers attached +;; to some structure types, and deserialization functions provided +;; by the same modules as the serialization handlers. +;; +;; Module path indexes are serialized to code that runs to reconstruct +;; the module path indexes. Syntax objects and other data is +;; serialized to somewhat expression-shaped data and interpreted for +;; deserialization, where that interpretation can refer to an array of +;; already-deserialized module path indexes. +;; +;; To support sharing and cycles, serialized data is represented by: +;; +;; - a vector of "shell" descriptions to allocate mutatable objects, +;; such as mutable vectors and hash tables; +;; +;; - a vector of initializations for shared, immutable values (which +;; can refer to mutable values) +;; +;; - a vector of "fill" descriptions to complete the construction of +;; mutable values (whcih can refer to mutable and shared values); +;; and +;; +;; - a final value construction (which can refer to shared and +;; mutable values). +;; +;; In general, a deserialized object is represented as a pair of a +;; symbol tag and data, including a `quote` tag to represent arbitrary +;; quoted data (that's non-cyclic and with no internal sharing). A few +;; special cases enable a more compact representation: +;; +;; - numbers, booleans, symbols, and path srclocs are represented +;; as themselves (i.e., self-quoting, in a sense); +;; +;; - #& is a reference to a mutable or shared value at +;; position in a deserialization array; +;; +;; - #( ...) is a srcloc whose source is not a path +;; +;; - #:inspector and #:bulk-binding-registry refer to +;; instantiation-time values supplied as imported to the +;; deserializing linklet +;; +;; In addition to all the complexities of detecting sharing and cycles +;; and breaking cycles on mutable boundaries, the serialization +;; process also prunes unreachable scopes and interns some values that +;; formerly were not shared. + +(provide make-module-path-index-table + add-module-path-index! + add-module-path-index!/pos + generate-module-path-index-deserialize + mpis-as-vector + + generate-deserialize + + deserialize-instance + deserialize-imports + + serialize-module-uses + serialize-phase-to-link-module-uses) + +;; ---------------------------------------- +;; Module path index serialization + +(struct module-path-index-table (positions intern)) + +(define (make-module-path-index-table) + (module-path-index-table (make-hasheq) ; module-path-index -> pos + (make-module-path-index-intern-table))) + +(define (add-module-path-index! mpis mpi) + (define pos + (add-module-path-index!/pos mpis mpi)) + (and pos + `(unsafe-vector*-ref ,mpi-vector-id ,pos))) + +(define (add-module-path-index!/pos mpis mpi) + (cond + [(not mpi) #f] + [mpi + (let ([mpi (intern-module-path-index! (module-path-index-table-intern mpis) mpi)] + [positions (module-path-index-table-positions mpis)]) + (or (hash-ref positions mpi #f) + (let ([pos (hash-count positions)]) + (hash-set! positions mpi pos) + pos)))])) + +(define (generate-module-path-index-deserialize mpis) + (define (unique-list v) + (if (pair? v) + (for/list ([i (in-list v)]) i) ; avoid non-deterministic sharing + v)) + (define positions (module-path-index-table-positions mpis)) + (define gen-order (make-hasheqv)) + (define rev-positions + (for/hasheqv ([(k v) (in-hash positions)]) + (values v k))) + ;; Create mpis used earlier first: + (for ([i (in-range (hash-count rev-positions))]) + (define mpi (hash-ref rev-positions i)) + (let loop ([mpi mpi]) + (unless (hash-ref gen-order mpi #f) + (define-values (name base) (module-path-index-split mpi)) + (when base + (loop base)) + (hash-set! gen-order mpi (hash-count gen-order))))) + (define rev-gen-order + (for/hasheqv ([(k v) (in-hash gen-order)]) + (values v k))) + (define gens + (for/vector #:length (hash-count gen-order) ([i (in-range (hash-count gen-order))]) + (define mpi (hash-ref rev-gen-order i)) + (define-values (path base) (module-path-index-split mpi)) + (cond + [(top-level-module-path-index? mpi) + 'top] + [(not path) + (box (or (unique-list + (resolved-module-path-name + (module-path-index-resolved mpi))) + 'self))] + [(not base) + (vector path)] + [base + (vector path (hash-ref gen-order base))]))) + `(deserialize-module-path-indexes + ;; Vector of deserialization instructions, where earlier + ;; must be constructed first: + ',gens + ;; Vector of reordering to match reference order: + ',(for/vector ([i (in-range (hash-count rev-positions))]) + (hash-ref gen-order (hash-ref rev-positions i))))) + +(define (deserialize-module-path-indexes gen-vec order-vec) + (define gen (make-vector (vector-length gen-vec) #f)) + (for ([d (in-vector gen-vec)] + [i (in-naturals)]) + (vector-set! + gen + i + (cond + [(eq? d 'top) (deserialize-module-path-index)] + [(box? d) (deserialize-module-path-index (unbox d))] + [else + (deserialize-module-path-index (vector*-ref d 0) + (and ((vector*-length d) . > . 1) + (vector*-ref gen (vector*-ref d 1))))]))) + (for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)]) + (vector*-ref gen p))) + +(define (mpis-as-vector mpis) + (define positions (module-path-index-table-positions mpis)) + (define vec (make-vector (hash-count positions) #f)) + (for ([(mpi pos) (in-hash positions)]) + (vector-set! vec pos mpi)) + vec) + +;; Convert `let*` into chunks of `let` as much as possible +(define (make-let* bindings body) + (let loop ([vars #hasheq()] [group null] [bindings bindings]) + (cond + [(null? bindings) `(let-values ,(reverse group) ,body)] + [(has-symbol? (cadar bindings) vars) + `(let-values ,(reverse group) ,(loop #hasheq() null bindings))] + [else + (loop (hash-set vars (caaar bindings) #t) + (cons (car bindings) group) + (cdr bindings))]))) + +(define (has-symbol? d vars) + (or (and (symbol? d) (hash-ref vars d #f)) + (and (pair? d) + (or (has-symbol? (car d) vars) + (has-symbol? (cdr d) vars))))) + +;; ---------------------------------------- +;; Module-use serialization --- as an expression, like module path +;; indexes, and unlike everything else + +(define (serialize-module-uses mus mpis) + (for/list ([mu (in-list mus)]) + `(module-use + ,(add-module-path-index! mpis (module-use-module mu)) + ,(module-use-phase mu)))) + +(define (interned-literal? v) + (or (null? v) + (boolean? v) + (and (fixnum? v) + (v . < . (sub1 (expt 2 30))) + (v . > . (- (expt 2 30)))) + (symbol? v) + (char? v) + (keyword? v))) + +(define (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis) + (define phases-in-order (sort (hash-keys phase-to-link-module-uses) <)) + `(hasheqv ,@(apply + append + (for/list ([phase (in-list phases-in-order)]) + (list phase `(list ,@(serialize-module-uses (hash-ref phase-to-link-module-uses phase) + mpis))))))) + +;; ---------------------------------------- +;; Serialization for everything else + +(define (generate-deserialize v mpis #:syntax-support? [syntax-support? #t]) + (define reachable-scopes (find-reachable-scopes v)) + + (define state (make-serialize-state reachable-scopes)) + + (define mutables (make-hasheq)) ; v -> pos + (define objs (make-hasheq)) ; v -> step + (define shares (make-hasheq)) ; v -> #t + (define obj-step 0) + + ;; Build table of sharing and mutable values + (define frontier null) + (define add-frontier! + (case-lambda + [(v) (set! frontier (cons v frontier))] + [(kind v) (add-frontier! v)])) + (let frontier-loop ([v v]) + (let loop ([v v]) + (cond + [(or (interned-literal? v) + (module-path-index? v)) + ;; no need to find sharing + (void)] + [(hash-ref objs v #f) + (unless (hash-ref mutables v #f) + (hash-set! shares v #t))] + [else + (cond + [(serialize-fill!? v) + ;; Assume no sharing in non-mutable part + (hash-set! mutables v (hash-count mutables)) + ((serialize-fill!-ref v) v add-frontier! state)] + [(serialize? v) + ((serialize-ref v) v + (case-lambda + [(sub-v) (loop sub-v)] + [(kind sub-v) (loop sub-v)]) + state)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (if (or (immutable? v) + (zero? (vector-length v))) + (for ([e (in-vector v)]) + (loop e)) + (begin + (hash-set! mutables v (hash-count mutables)) + (for ([e (in-vector v)]) + (add-frontier! e))))] + [(box? v) + (if (immutable? v) + (loop (unbox v)) + (begin + (hash-set! mutables v (hash-count mutables)) + (add-frontier! (unbox v))))] + [(hash? v) + (if (immutable? v) + (for ([k (in-list (sorted-hash-keys v))]) + (loop k) + (loop (hash-ref v k))) + (begin + (hash-set! mutables v (hash-count mutables)) + (for ([k (in-list (sorted-hash-keys v))]) + (add-frontier! k) + (add-frontier! (hash-ref v k)))))] + [(prefab-struct-key v) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e))] + [(srcloc? v) + (unless (path? (srcloc-source v)) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e)))] + [else + (void)]) + ;; `v` may already be in `objs`, but to get the order right + ;; for unmarshaling, we need to map it to ka new step number + (hash-set! objs v obj-step) + (set! obj-step (add1 obj-step))])) + (unless (null? frontier) + (define l frontier) + (set! frontier null) + (for ([v (in-list l)]) + (frontier-loop v)))) + + ;; Maybe object steps to positions in a vector after mutables + (define num-mutables (hash-count mutables)) + (define share-step-positions + (let ([share-steps (for/list ([obj (in-hash-keys shares)]) + (hash-ref objs obj))]) + (for/hasheqv ([step (in-list (sort share-steps <))] + [pos (in-naturals num-mutables)]) + (values step pos)))) + + ;; Accumulate the serialized stream: + (define stream null) + (define stream-size 0) + + (define (next-push-position) stream-size) + + (define (quoted? pos) + (define v (list-ref stream (- stream-size (add1 pos)))) + (or (not (keyword? v)) + (eq? '#:quote v))) + + (define (ser-reset! pos) + (set! stream (list-tail stream (- stream-size pos))) + (set! stream-size pos)) + + (define (reap-stream!) + (begin0 + (list->vector (reverse stream)) + (set! stream null) + (set! stream-size 0))) + + ;; Handle a reference to an object that may be shared + ;; or mutable + (define ser-push! + (case-lambda + [(v) + (cond + [(hash-ref shares v #f) + (define n (hash-ref share-step-positions (hash-ref objs v))) + (ser-push! 'tag '#:ref) + (ser-push! 'exact n)] + [(hash-ref mutables v #f) + => (lambda (n) + (ser-push! 'tag '#:ref) + (ser-push! 'exact n))] + [else (ser-push-encoded! v)])] + [(kind v) + (case kind + [(exact) + (set! stream (cons v stream)) + (set! stream-size (add1 stream-size))] + [(tag) + (ser-push! 'exact v)] + [(reference) + (cond + [(hash-ref shares v #f) + (define n (hash-ref share-step-positions (hash-ref objs v))) + (ser-push! 'exact n)] + [(hash-ref mutables v #f) + => (lambda (n) + (ser-push! 'exact n))] + [else + (ser-push! v)])] + [else (ser-push! v)])])) + + ;; Handle an immutable, not-shared (or on RHS of binding) value + (define (ser-push-encoded! v) + (cond + [(keyword? v) + (ser-push! 'tag '#:quote) + (ser-push! 'exact v)] + [(module-path-index? v) + (ser-push! 'tag '#:mpi) + (ser-push! 'exact (add-module-path-index!/pos mpis v))] + [(serialize? v) + ((serialize-ref v) v ser-push! state)] + [(and (list? v) + (pair? v) + (pair? (cdr v))) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:list) + (ser-push! 'exact (length v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-list v)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(pair? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:cons) + (define a-pos (next-push-position)) + (ser-push! (car v)) + (define d-pos (next-push-position)) + (ser-push! (cdr v)) + (when (and (quoted? a-pos) (quoted? d-pos)) + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(box? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:box) + (define v-pos (next-push-position)) + (ser-push! (unbox v)) + (when (quoted? v-pos) + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(vector? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:vector) + (ser-push! 'exact (vector-length v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-vector v)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(hash? v) + (define start-pos (next-push-position)) + (define as-set? (for/and ([val (in-hash-values v)]) + (eq? val #t))) + (ser-push! 'tag (if as-set? + (cond + [(hash-eq? v) '#:seteq] + [(hash-eqv? v) '#:seteqv] + [else '#:set]) + (cond + [(hash-eq? v) '#:hasheq] + [(hash-eqv? v) '#:hasheqv] + [else '#:hash]))) + (ser-push! 'exact (hash-count v)) + (define ks (sorted-hash-keys v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([k (in-list ks)]) + (define k-pos (next-push-position)) + (ser-push! k) + (define v-pos (next-push-position)) + (unless as-set? + (ser-push! (hash-ref v k))) + (and all-quoted? + (quoted? k-pos) + (or as-set? (quoted? v-pos))))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(prefab-struct-key v) + => (lambda (k) + (define vec (struct->vector v)) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:prefab) + (ser-push! 'exact k) + (ser-push! 'exact (sub1 (vector-length vec))) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-vector vec 1)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v)))] + [(srcloc? v) + (cond + [(path? (srcloc-source v)) + ;; Let core printer handle it --- and truncate the path if it + ;; can't be made relative on serialize + (ser-push-optional-quote!) + (ser-push! 'exact v)] + [else + (ser-push! 'tag '#:srcloc) + (ser-push! (srcloc-source v)) + (ser-push! (srcloc-line v)) + (ser-push! (srcloc-column v)) + (ser-push! (srcloc-position v)) + (ser-push! (srcloc-span v))])] + [else + (ser-push-optional-quote!) + (ser-push! 'exact v)])) + + ;; A no-op, but can be made to push '#:quote as a debugging aid + (define (ser-push-optional-quote!) + ;; (ser-push! 'tag '#:quote) + (void)) + + ;; Generate the shell of a mutable value --- uses a different + ;; encoding then the one for most other purposes + (define (ser-shell! v) + (cond + [(serialize-fill!? v) ((serialize-ref v) v ser-push! state)] + [(box? v) (ser-push! 'tag '#:box)] + [(vector? v) + (ser-push! 'tag '#:vector) + (ser-push! 'exact (vector-length v))] + [(hash? v) (ser-push! 'tag (cond + [(hash-eq? v) '#:hasheq] + [(hash-eqv? v) '#:hasheqv] + [else '#:hash]))] + [else + (error 'ser-shell "unknown mutable: ~e" v)])) + + ;; Fill in the content of a mutable shell --- also a different + ;; encoding + (define (ser-shell-fill! v) + (cond + [(serialize-fill!? v) ((serialize-fill!-ref v) v ser-push! state)] + [(box? v) + (ser-push! 'tag '#:set-box!) + (ser-push! (unbox v))] + [(vector? v) + (ser-push! 'tag '#:set-vector!) + (ser-push! 'exact (vector-length v)) + (for ([v (in-vector v)]) + (ser-push! v))] + [(hash? v) + (ser-push! 'tag '#:set-hash!) + (ser-push! 'exact (hash-count v)) + (define ks (sorted-hash-keys v)) + (for ([k (in-list ks)]) + (ser-push! k) + (ser-push! (hash-ref v k)))] + [else + (error 'ser-shell-fill "unknown mutable: ~e" v)])) + + ;; Prepare mutable shells, first: + (define rev-mutables (for/hasheqv ([(k v) (in-hash mutables)]) + (values v k))) + (define mutable-shell-bindings + (begin + (for ([i (in-range (hash-count mutables))]) + (ser-shell! (hash-ref rev-mutables i))) + (reap-stream!))) + + ;; Prepare shared values: + (define rev-shares (for/hasheqv ([obj (in-hash-keys shares)]) + (values (hash-ref share-step-positions (hash-ref objs obj)) + obj))) + (define shared-bindings + (begin + (for ([i (in-range num-mutables (+ num-mutables (hash-count shares)))]) + (ser-push-encoded! (hash-ref rev-shares i))) + (reap-stream!))) + + ;; Fill in mutable values + (define mutable-fills + (begin + (for ([i (in-range (hash-count mutables))]) + (ser-shell-fill! (hash-ref rev-mutables i))) + (reap-stream!))) + + ;; Put it all together: + `(deserialize + ,mpi-vector-id + ,(if syntax-support? inspector-id #f) + ,(if syntax-support? bulk-binding-registry-id #f) + ',(hash-count mutables) + ',mutable-shell-bindings + ',(hash-count shares) + ',shared-bindings + ',mutable-fills + ',(begin + (ser-push! v) + (reap-stream!)))) + +(define (sorted-hash-keys ht) + (define ks (hash-keys ht)) + (cond + [(null? ks) ks] + [(null? (cdr ks)) ks] + [(andmap symbol? ks) + (sort ks symbolsyntax) + (decodes + (content [#:ref context] [#:ref srcloc]) + (deserialize-datum->syntax content + context + srcloc + inspector))] + [(#:syntax+props) + (decodes + (content [#:ref context] [#:ref srcloc] props tamper) + (deserialize-syntax content + context + srcloc + props + tamper + inspector))] + [(#:srcloc) + (decode* (srcloc source line column position span))] + [(#:quote) + (values (vector*-ref vec (add1 pos)) (+ pos 2))] + [(#:mpi) + (values (vector*-ref mpis (vector*-ref vec (add1 pos))) + (+ pos 2))] + [(#:box) + (decode* (box-immutable v))] + [(#:cons) + (decode* (cons a d))] + [(#:list #:vector) + (define len (vector*-ref vec (add1 pos))) + (define r (make-vector len)) + (define next-pos + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (v next-pos) (decodes #:pos pos (v) v)) + (vector-set! r i v) + next-pos)) + (values (if (eq? (vector*-ref vec pos) '#:list) + (vector->list r) + (vector->immutable-vector r)) + next-pos)] + [(#:hash #:hasheq #:hasheqv) + (define ht (case (vector*-ref vec pos) + [(#:hash) (hash)] + [(#:hasheq) (hasheq)] + [(#:hasheqv) (hasheqv)])) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([ht ht] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k v) (hash-set ht k v)))] + [(#:set #:seteq #:seteqv) + (define s (case (vector*-ref vec pos) + [(#:set) (set)] + [(#:seteq) (seteq)] + [(#:seteqv) (seteqv)])) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([s s] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k) (set-add s k)))] + [(#:prefab) + (define-values (key next-pos) (decodes #:pos (add1 pos) (k) k)) + (define len (vector*-ref vec next-pos)) + (define-values (r done-pos) + (for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)]) + (decodes #:pos pos (v) (cons v r)))) + (values (apply make-prefab-struct key (reverse r)) + done-pos)] + [(#:scope) + (decode* (deserialize-scope))] + [(#:scope+kind) + (decode* (deserialize-scope kind))] + [(#:interned-scope) + (decode* (make-interned-scope id))] + [(#:multi-scope) + (decode* (deserialize-multi-scope name scopes))] + [(#:shifted-multi-scope) + (decode* (deserialize-shifted-multi-scope phase multi-scope))] + [(#:table-with-bulk-bindings) + (decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))] + [(#:bulk-binding-at) + (decode* (deserialize-bulk-binding-at scopes bulk))] + [(#:representative-scope) + (decode* (deserialize-representative-scope kind phase))] + [(#:module-binding) + (decode* (deserialize-full-module-binding + module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings))] + [(#:simple-module-binding) + (decode* (deserialize-simple-module-binding module sym phase nominal-module))] + [(#:local-binding) + (decode* (deserialize-full-local-binding key free=id))] + [(#:bulk-binding) + (decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))] + [(#:provided) + (decode* (deserialize-provided binding protected? syntax?))] + [else + (values (vector*-ref vec pos) (add1 pos))])) + +;; Decode the filling of mutable values, which has its own encoding +;; variant +(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared) + (case (vector*-ref vec pos) + [(#f) (add1 pos)] + [(#:set-box!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (set-box! v c) + next-pos] + [(#:set-vector!) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (c next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! v i c) + next-pos)] + [(#:set-hash!) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (key next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (define-values (val done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (hash-set! v key val) + done-pos)] + [(#:scope-fill!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (deserialize-scope-fill! v c) + next-pos] + [(#:representative-scope-fill!) + (define-values (a next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (define-values (d done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (deserialize-representative-scope-fill! v a d) + done-pos] + [else + (error 'deserialize "bad fill encoding: ~v" (vector*-ref vec pos))])) + +;; ---------------------------------------- +;; For pruning unreachable scopes in serialization + +(define (find-reachable-scopes v) + (define seen (make-hasheq)) + (define reachable-scopes (seteq)) + (define (get-reachable-scopes) reachable-scopes) + (define scope-triggers (make-hasheq)) + + (let loop ([v v]) + (cond + [(interned-literal? v) (void)] + [(hash-ref seen v #f) (void)] + [else + (hash-set! seen v #t) + (cond + [(scope-with-bindings? v) + (set! reachable-scopes (set-add reachable-scopes v)) + + ((reach-scopes-ref v) v loop) + + (for ([proc (in-list (hash-ref scope-triggers v null))]) + (proc loop)) + (hash-remove! scope-triggers v) + + ;; A binding may have a `free-id=?` equivalence; + ;; that equivalence is reachable if all the scopes in the + ;; binding set are reachable; for a so-far unreachable scope, + ;; record a trigger in case the scope bcomes reachable later + ((scope-with-bindings-ref v) + v + get-reachable-scopes + loop + (lambda (sc-unreachable b) + (hash-update! scope-triggers + sc-unreachable + (lambda (l) (cons b l)) + null)))] + [(reach-scopes? v) + ((reach-scopes-ref v) v loop)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (loop (unbox v))] + [(hash? v) + (for ([(k v) (in-hash v)]) + (loop k) + (loop v))] + [(prefab-struct-key v) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e))] + [(srcloc? v) + (loop (srcloc-source v))] + [else + (void)])])) + + reachable-scopes) + +;; ---------------------------------------- +;; Set up the instance to import into deserializing linklets + +(define deserialize-imports + '(deserialize-module-path-indexes + syntax-module-path-index-shift + syntax-shift-phase-level + module-use + deserialize)) + +;; To avoid a higher-order use of a keyword-accepting function: +(define syntax-module-path-index-shift/no-keywords + (let ([syntax-module-path-index-shift + (lambda (s from-mpi to-mpi [inspector #f]) + (syntax-module-path-index-shift s from-mpi to-mpi inspector))]) + syntax-module-path-index-shift)) + +(define deserialize-instance + (make-instance 'deserialize #f 'constant + 'deserialize-module-path-indexes deserialize-module-path-indexes + 'syntax-module-path-index-shift syntax-module-path-index-shift/no-keywords + 'syntax-shift-phase-level syntax-shift-phase-level + 'module-use module-use + 'deserialize deserialize)) diff -Nru racket-6.12+ppa1/src/expander/compile/serialize-state.rkt racket-7.0+ppa1/src/expander/compile/serialize-state.rkt --- racket-6.12+ppa1/src/expander/compile/serialize-state.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/serialize-state.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,124 @@ +#lang racket/base +(require "../common/set.rkt") + +(provide (struct-out serialize-state) + make-serialize-state + + intern-scopes + intern-shifted-multi-scopes + intern-mpi-shifts + intern-context-triple + intern-properties + + push-syntax-context! + get-syntax-context + pop-syntax-context!) + +;; A `serialize-state` record is threaded through the construction of +;; a deserialization expression + +(struct serialize-state (reachable-scopes ; the set of all reachable scopes + bindings-intern ; to record pruned binding tables + bulk-bindings-intern ; to record pruned bulk-binding lists + scopes ; interned scope sets + shifted-multi-scopes ; interned shifted multi-scope sets + multi-scope-tables ; interned phase -> scope tables + mpi-shifts ; interned module path index shifts + context-triples ; combinations of the previous three + props ; map full props to previously calculated + interned-props ; intern filtered props + syntax-context ; used to collapse encoding of syntax literals + sharing-syntaxes)) ; record which syntax objects are `datum->syntax` form + +(define (make-serialize-state reachable-scopes) + (define state + (serialize-state reachable-scopes + (make-hasheq) ; bindings-intern + (make-hasheq) ; bulk-bindings-intern + (make-hash) ; scopes + (make-hash) ; shifted-multi-scopes + (make-hasheq) ; multi-scope-tables + (make-hasheq) ; mpi-shifts + (make-hasheq) ; context-triples + (make-hasheq) ; props + (make-hash) ; interned-props + (box null) ; syntax-context + (make-hasheq))) ; sharing-syntaxes + ;; Seed intern tables for sets and hashes to use the canonical + ;; empty version for consistent sharing: + (define empty-seteq (seteq)) + (hash-set! (serialize-state-scopes state) empty-seteq empty-seteq) + (hash-set! (serialize-state-shifted-multi-scopes state) empty-seteq empty-seteq) + (hash-set! (serialize-state-interned-props state) empty-seteq empty-seteq) + state) + +(define (intern-scopes scs state) + (or (hash-ref (serialize-state-scopes state) scs #f) + (begin + (hash-set! (serialize-state-scopes state) scs scs) + scs))) + +(define (intern-shifted-multi-scopes sms state) + (or (hash-ref (serialize-state-shifted-multi-scopes state) sms #f) + (begin + (hash-set! (serialize-state-shifted-multi-scopes state) sms sms) + sms))) + +(define (intern-mpi-shifts mpi-shifts state) + (cond + [(null? mpi-shifts) null] + [else + (define tail (intern-mpi-shifts (cdr mpi-shifts) state)) + (define tail-table (or (hash-ref (serialize-state-mpi-shifts state) tail #f) + (let ([ht (make-hasheq)]) + (hash-set! (serialize-state-mpi-shifts state) tail ht) + ht))) + (or (hash-ref tail-table (car mpi-shifts) #f) + (let ([v (cons (car mpi-shifts) tail)]) + (hash-set! tail-table (car mpi-shifts) v) + v))])) + +(define (intern-context-triple scs sms mpi-shifts state) + (define scs-ht (or (hash-ref (serialize-state-context-triples state) scs #f) + (let ([ht (make-hasheq)]) + (hash-set! (serialize-state-context-triples state) scs ht) + ht))) + (define sms-ht (or (hash-ref scs-ht sms #f) + (let ([ht (make-hasheq)]) + (hash-set! scs-ht sms ht) + ht))) + (or (hash-ref sms-ht mpi-shifts #f) + (let ([vec (vector-immutable scs sms mpi-shifts)]) + (hash-set! sms-ht mpi-shifts vec) + vec))) + +(define (intern-properties all-props get-preserved-props state) + (define v (hash-ref (serialize-state-props state) all-props 'no)) + (cond + [(eq? v 'no) + (define preserved-props (get-preserved-props)) + (define p + (cond + [(zero? (hash-count preserved-props)) #f] + [(hash-ref (serialize-state-interned-props state) preserved-props #f) + => (lambda (p) p)] + [else + (hash-set! (serialize-state-interned-props state) preserved-props preserved-props) + preserved-props])) + (hash-set! (serialize-state-props state) all-props p) + p] + [else v])) + +(define (push-syntax-context! state v) + (define b (serialize-state-syntax-context state)) + (set-box! b (cons v (unbox b)))) + +(define (get-syntax-context state) + (define b (serialize-state-syntax-context state)) + (if (null? (unbox b)) + #f + (car (unbox b)))) + +(define (pop-syntax-context! state) + (define b (serialize-state-syntax-context state)) + (set-box! b (cdr (unbox b)))) diff -Nru racket-6.12+ppa1/src/expander/compile/side-effect.rkt racket-7.0+ppa1/src/expander/compile/side-effect.rkt --- racket-6.12+ppa1/src/expander/compile/side-effect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/side-effect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,464 @@ +#lang racket/base +(require "../common/set.rkt" + "built-in-symbol.rkt" + "self-quoting.rkt" + "known.rkt" + "../host/correlate.rkt") + +;; To support extraction of a bootstrapped version of the expander, we +;; need to be able to prune unused module content. Pruning is usefully +;; improved by a simple analysis of whether a module body has any +;; side-effects. + +;; See "known.rkt" for classifications of definitions and locals + +(provide any-side-effects?) + +(define (any-side-effects? e ; compiled expression + expected-results ; number of expected results, or #f if any number is ok + #:known-locals [locals #hasheq()] ; known local-variable bindings + #:known-defns [defns #hasheq()] ; other variables to known-value information + #:ready-variable? [ready-variable? (lambda (id) #f)]) ; other variables known to be ready + (define (effects? e expected-results locals) + (any-side-effects? e expected-results + #:known-locals locals + #:known-defns defns + #:ready-variable? ready-variable?)) + (define actual-results + (let loop ([e e] [locals locals]) + (case (and (pair? (correlated-e e)) + (correlated-e (car (correlated-e e)))) + [(quote lambda case-lambda #%variable-reference) 1] + [(letrec-values let-values) + (define-correlated-match m e '(_ ([ids rhs] ...) body)) + (and (not (for/or ([ids (in-list (m 'ids))] + [rhs (in-list (m 'rhs))]) + (effects? rhs (correlated-length ids) locals))) + (loop (m 'body) (add-binding-info locals (m 'ids) (m 'rhs))))] + [(values) + (define-correlated-match m e '(_ e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals))) + (length (m 'e)))] + [(void) + (define-correlated-match m e '(_ e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals))) + 1)] + [(begin) + (define-correlated-match m e '(_ e ...)) + (let bloop ([es (m 'e)]) + (cond + [(null? es) #f] + [(null? (cdr es)) (loop (car es) locals)] + [else (and (not (effects? (car es) #f locals)) + (bloop (cdr es)))]))] + [(begin0) + (define-correlated-match m e '(_ e0 e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e #f locals))) + (loop (m 'e0) locals))] + [(make-struct-type) + (and (ok-make-struct-type? e ready-variable? defns) + 5)] + [(make-struct-field-accessor) + (and (ok-make-struct-field-accessor/mutator? e locals 'general-accessor defns) + 1)] + [(make-struct-field-mutator) + (and (ok-make-struct-field-accessor/mutator? e locals 'general-mutator defns) + 1)] + [(make-struct-type-property) + (and (ok-make-struct-type-property? e defns) + 3)] + [(gensym) + (define-correlated-match m e #:try '(gs (quot datum))) + (and (or (and (m) + (eq? 'quote (m 'quot)) + (or (symbol? (m 'datum)) + (string? (m 'datum)))) + (null? (cdr (correlated-e e)))) + 1)] + [(if) + (define-correlated-match m e #:try '(_ (id:rator id:arg) thn els)) + (cond + [(m) + (cond + [(or (hash-ref locals (m 'id:rator) #f) + (lookup-defn defns (m 'id:rator))) + => (lambda (d) + (and (known-predicate? d) + (not (effects? (m 'thn) + expected-results + (hash-set locals (m 'id:arg) + (known-satisfies (known-predicate-key d))))) + (loop (m 'els) locals)))] + [else #f])] + [else + (define-correlated-match m e #:try '(_ tst thn els)) + (and (m) + (not (effects? (m 'tst) 1 locals)) + (not (effects? (m 'thn) expected-results locals)) + (loop (m 'els) locals))])] + [else + (define v (correlated-e e)) + (cond + [(or (string? v) (number? v) (boolean? v) (char? v)) + 1] ;; unquoted vals + [(and (pair? v) + (let ([rator (correlated-e (car v))]) + (or (hash-ref locals rator #f) + (lookup-defn defns rator)))) + => + (lambda (d) + (define-correlated-match m e '(_ e ...)) + (define n-args (length (m 'e))) + (and (or (and (or (and (known-struct-op? d) + (eq? 'constructor (known-struct-op-type d)) + (= (known-struct-op-field-count d) n-args)) + (and (known-function? d) + (known-function-pure? d) + (arity-includes? (known-function-arity d) n-args))) + (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals)))) + (and (known-function-of-satisfying? d) + (= n-args (length (known-function-of-satisfying-arg-predicate-keys d))) + (for/and ([e (in-list (m 'e))] + [key (in-list (known-function-of-satisfying-arg-predicate-keys d))]) + (and (not (effects? e 1 locals)) + (satisfies? e key defns locals))))) + 1))] + [else + (and + (or (self-quoting-in-linklet? v) + (and (symbol? v) + (or (hash-ref locals v #f) + (lookup-defn defns v) + (built-in-symbol? v) + (ready-variable? v)))) + 1)])]))) + (not (and actual-results + (or (not expected-results) + (= actual-results expected-results))))) + +(define (satisfies? e key defns locals) + (define d (or (hash-ref locals e #f) + (lookup-defn defns e))) + (and d + (known-satisfies? d) + (eq? key (known-satisfies-predicate-key d)))) + +;; ---------------------------------------- + +(define (add-binding-info locals idss rhss) + (for/fold ([locals locals]) ([ids (in-list idss)] + [rhs (in-list rhss)]) + (let loop ([rhs rhs]) + (case (and (pair? (correlated-e rhs)) + (correlated-e (car (correlated-e rhs)))) + [(make-struct-type) + ;; Record result "types" + (define field-count (extract-struct-field-count-lower-bound rhs)) + (for/fold ([locals locals]) ([id (in-list (correlated->list ids))] + [type (in-list '(struct-type + constructor + predicate + general-accessor + general-mutator))]) + (hash-set locals (correlated-e id) (known-struct-op type field-count)))] + [(let-values) + (if (null? (correlated-e (correlated-cadr rhs))) + (loop (caddr (correlated->list rhs))) + (loop #f))] + [else + (for/fold ([locals locals]) ([id (in-list (correlated->list ids))]) + (hash-set locals (correlated-e id) #t))])))) + +;; ---------------------------------------- + +(define (ok-make-struct-type-property? e defns) + (define l (correlated->list e)) + (and (<= 2 (length l) 5) + (for/and ([arg (in-list (cdr l))] + [pred (in-list + (list + (lambda (v) (quoted? symbol? v)) + (lambda (v) (is-lambda? v 2 defns)) + (lambda (v) (ok-make-struct-type-property-super? v defns)) + (lambda (v) (any-side-effects? v 1 #:known-defns defns))))]) + (pred arg)))) + +(define (ok-make-struct-type-property-super? v defns) + (or (quoted? null? v) + (eq? 'null (correlated-e v)) + (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'list) + (for/and ([prop+val (in-list (cdr (correlated->list v)))]) + (and (= (correlated-length prop+val) 3) + (let ([prop+val (correlated->list prop+val)]) + (and (eq? 'cons (correlated-e (car prop+val))) + (or (memq (correlated-e (list-ref prop+val 1)) + '(prop:procedure prop:equal+hash prop:custom-write)) + (known-property? (lookup-defn defns (correlated-e (list-ref prop+val 1))))) + (not (any-side-effects? (list-ref prop+val 2) 1 #:known-defns defns)))))) + ;; All properties must be distinct + (= (sub1 (correlated-length v)) + (set-count (for/set ([prop+val (in-list (cdr (correlated->list v)))]) + (correlated-e (list-ref (correlated->list prop+val) 1)))))))) + +;; ---------------------------------------- + +(define (ok-make-struct-type? e ready-variable? defns) + (define l (correlated->list e)) + (define init-field-count-expr (and ((length l) . > . 3) + (list-ref l 3))) + (define auto-field-count-expr (and ((length l) . > . 4) + (list-ref l 4))) + (define num-fields + (maybe+ (field-count-expr-to-field-count init-field-count-expr) + (field-count-expr-to-field-count auto-field-count-expr))) + (define immutables-expr (or (and ((length l) . > . 9) + (list-ref l 9)) + 'null)) + (define super-expr (and ((length l) . > . 2) + (list-ref l 2))) + + (and ((length l) . >= . 5) + ((length l) . <= . 12) + (for/and ([arg (in-list (cdr l))] + [pred (in-list (list + (lambda (v) (quoted? symbol? v)) + (lambda (v) (super-ok? v defns)) + (lambda (v) (field-count-expr-to-field-count v)) + (lambda (v) (field-count-expr-to-field-count v)) + (lambda (v) (not (any-side-effects? v 1 #:ready-variable? ready-variable? #:known-defns defns))) + (lambda (v) (known-good-struct-properties? v immutables-expr super-expr defns)) + (lambda (v) (inspector-or-false? v)) + (lambda (v) (procedure-spec? v num-fields)) + (lambda (v) (immutables-ok? v init-field-count-expr))))]) + (pred arg)))) + +(define (super-ok? e defns) + (or (quoted? false? e) + (let ([o (lookup-defn defns (correlated-e e))]) + (and o + (known-struct-op? o) + (eq? 'struct-type (known-struct-op-type o)))))) + +(define (extract-struct-field-count-lower-bound e) + ;; e is already checked by `ok-make-struct-type?` + (define l (correlated->list e)) + (+ (field-count-expr-to-field-count (list-ref l 3)) + (field-count-expr-to-field-count (list-ref l 4)))) + +(define (quoted? val? v) + (or (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'quote) + (val? (correlated-e (correlated-cadr v)))) + (val? (correlated-e v)))) + +(define (quoted-value v) + (if (pair? (correlated-e v)) + (correlated-e (correlated-cadr v)) + (correlated-e v))) + +(define (false? v) + (eq? (correlated-e v) #f)) + +(define (field-count-expr-to-field-count v) + (and (quoted? exact-nonnegative-integer? v) + (quoted-value v))) + +(define (inspector-or-false? v) + (or (quoted? false? v) + (and (quoted? symbol? v) + (eq? 'prefab (quoted-value v))) + (and (= 1 (correlated-length v)) + (eq? 'current-inspector (correlated-e (car (correlated-e v))))))) + +(define (known-good-struct-properties? v immutables-expr super-expr defns) + (or (quoted? null? v) + (eq? 'null (correlated-e v)) + (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'list) + (for/and ([prop+val (in-list (cdr (correlated->list v)))]) + (and (= (correlated-length prop+val) 3) + (let ([prop+val (correlated->list prop+val)]) + (and (eq? 'cons (correlated-e (car prop+val))) + (known-good-struct-property+value? (list-ref prop+val 1) + (list-ref prop+val 2) + immutables-expr + super-expr + defns))))) + ;; All properties must be distinct + (= (sub1 (correlated-length v)) + (set-count (for/set ([prop+val (in-list (cdr (correlated->list v)))]) + (correlated-e (list-ref (correlated->list prop+val) 1)))))))) + +(define (known-good-struct-property+value? prop-expr val-expr immutables-expr super-expr defns) + (define prop-name (correlated-e prop-expr)) + (case prop-name + [(prop:evt) (or (is-lambda? val-expr 1 defns) + (immutable-field? val-expr immutables-expr))] + [(prop:procedure) (or (is-lambda? val-expr 1 defns) + (immutable-field? val-expr immutables-expr))] + [(prop:custom-write) (is-lambda? val-expr 3 defns)] + [(prop:equal+hash) + (define l (correlated->list val-expr)) + (and (eq? 'list (car l)) + (is-lambda? (list-ref l 1) 3 defns) + (is-lambda? (list-ref l 2) 2 defns) + (is-lambda? (list-ref l 3) 2 defns))] + [(prop:method-arity-error prop:incomplete-arity) + (not (any-side-effects? val-expr 1 #:known-defns defns))] + [(prop:impersonator-of) + (is-lambda? val-expr 1 defns)] + [(prop:arity-string) (is-lambda? val-expr 1 defns)] + [(prop:checked-procedure) + (and (quoted? false? super-expr) + ;; checking that we have at least 2 fields + (immutable-field? 1 immutables-expr))] + [else + (define o (lookup-defn defns prop-name)) + (and o + (known-property? o) + (not (any-side-effects? val-expr 1 #:known-defns defns)))])) + +;; is expr a procedure of specified arity? (arity irrelevant if #f) +(define (is-lambda? expr arity defns) + (define lookup (lookup-defn defns expr)) + (or (and lookup (known-function? lookup) ;; is it a known procedure? + (or (not arity) ;; arity doesn't matter + (arity-includes? (known-function-arity lookup) arity))) ;; arity compatible + (and (pair? (correlated-e expr)) + (eq? 'case-lambda (car (correlated-e expr))) + (not arity)) + (and (pair? (correlated-e expr)) + (eq? 'lambda (car (correlated-e expr))) + (or (not arity) + (let loop ([args (cadr (correlated->list expr))] + [arity arity]) + (cond + [(correlated? args) (loop (correlated-e args) arity)] + [(null? args) (zero? arity)] + [(pair? args) (loop (cdr args) (sub1 arity))] + [else (not (negative? arity))])))))) + +(define (arity-includes? a n) + (or (equal? a n) + (and (list? a) + (for/or ([a (in-list a)]) + (equal? a n))))) + +(define (immutable-field? val-expr immutables-expr) + (and (quoted? exact-nonnegative-integer? val-expr) + (memv (quoted-value val-expr) + (immutables-expr-to-immutables immutables-expr null)))) + +(define (immutables-expr-to-immutables e fail-v) + (case (and (pair? (correlated-e e)) + (correlated-e (car (correlated-e e)))) + [(quote) + (define v (correlated-cadr e)) + (or (and (correlated-length v) + (let ([l (map correlated-e (correlated->list v))]) + (and (andmap exact-nonnegative-integer? l) + (= (length l) (set-count (list->set l))) + l))) + fail-v)] + [else fail-v])) + +(define (procedure-spec? e field-count) + (or (quoted? false? e) + (and (quoted? exact-nonnegative-integer? e) + field-count + (< (quoted-value e) field-count)) + (is-lambda? e #f #hasheq()))) + +(define (immutables-ok? e init-field-count-expr) + (define l (immutables-expr-to-immutables e #f)) + (define c (field-count-expr-to-field-count init-field-count-expr)) + (and l + (for/and ([n (in-list l)]) + (n . < . c)))) + +;; ---------------------------------------- + +(define (ok-make-struct-field-accessor/mutator? e locals type defns) + (define l (correlated->list e)) + (define a (and (or (= (length l) 3) (= (length l) 4)) + (or (hash-ref locals (correlated-e (list-ref l 1)) #f) + (lookup-defn defns (correlated-e (list-ref l 1)))))) + (and (known-struct-op? a) + (eq? (known-struct-op-type a) type) + ((field-count-expr-to-field-count (list-ref l 2)) . < . (known-struct-op-field-count a)) + (or (= (length l) 3) (quoted? symbol? (list-ref l 3))))) + +;; ---------------------------------------- + +(define (maybe+ x y) + (and x y (+ x y))) + +;; ---------------------------------------- + +(module+ test + (define-syntax-rule (check expr result) + (unless (equal? expr result) + (error 'failed "~s" #'expr))) + + (define (any-side-effects?* e n) + (define v1 (any-side-effects? e n)) + (define v2 (any-side-effects? (datum->correlated e) n)) + (unless (equal? v1 v2) + (error "problem with correlated:" e)) + v1) + + (check (any-side-effects?* ''1 1) + #f) + + (check (any-side-effects?* ''1 #f) + #f) + + (check (any-side-effects?* '(lambda (x) x) 1) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list (cons prop:evt '0)) + (current-inspector) + '#f + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + '() + (current-inspector) + '#f + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + '() + (current-inspector) + '0 + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list + (cons prop:evt '0) + (cons prop:evt '0)) ; duplicate + (current-inspector) + '#f + '(0)) + 5) + #t) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list (cons prop:evt '0)) + (current-inspector) + '#f + '(1)) ; <- too big + 5) + #t)) diff -Nru racket-6.12+ppa1/src/expander/compile/top.rkt racket-7.0+ppa1/src/expander/compile/top.rkt --- racket-6.12+ppa1/src/expander/compile/top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/compile/top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,170 @@ +#lang racket/base +(require "serialize.rkt" + "../host/linklet.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt" + "../expand/parsed.rkt" + "../compile/reserved-symbol.rkt" + "../common/performance.rkt" + "../eval/top-level-instance.rkt" + "compiled-in-memory.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "eager-instance.rkt" + "expr.rkt" + "form.rkt" + "multi-top.rkt" + "namespace-scope.rkt" + "side-effect.rkt") + +(provide compile-single + compile-top) + +;; Compile a stand-alone expression, such as the right-hand side of a +;; `define-syntaxes` in a module +(define (compile-single p cctx) + (compile-top p cctx + #:serializable? #f + #:single-expression? #t)) + +;; Compile a single form, which can be a `define-values` form, a +;; `define-syntaxes` form, or an expression (where `begin` is treated +;; as an expression form). If `serializable?` is false, don't bother +;; generating the linklet for serialized data, because it won't be +;; used. If `to-source?` is true, the result is a hash table containing +;; S-expression linkets, instead of a `compiled-in-memory` containing +;; compiled linklets. +(define (compile-top p cctx + #:serializable? [serializable? #t] + #:single-expression? [single-expression? #f] + #:to-source? [to-source? #f]) + (performance-region + ['compile (if single-expression? 'transformer 'top)] + + (define phase (compile-context-phase cctx)) + + (define mpis (make-module-path-index-table)) + (define purely-functional? #t) + + ;; Compile the body forms, similar to compiling the body of a module + (define-values (body-linklets + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorss + syntax-literals + no-root-context-pos) + (compile-forms (list p) cctx mpis + #:body-imports (if single-expression? + `([] + [,syntax-literals-id] + []) + `([,top-level-bind!-id + ,top-level-require!-id] + [,mpi-vector-id + ,syntax-literals-id] + ,instance-imports)) + #:body-import-instances (list top-level-instance + empty-top-syntax-literal-instance + empty-instance-instance) + #:to-source? to-source? + #:serializable? serializable? + #:definition-callback (lambda () (set! purely-functional? #f)) + #:compiled-expression-callback + (lambda (e expected-results phase required-reference?) + (when (and purely-functional? + (any-side-effects? e expected-results #:ready-variable? required-reference?)) + (set! purely-functional? #f))) + #:other-form-callback (lambda (s cctx) + (set! purely-functional? #f) + (compile-top-level-require s cctx)) + #:cross-linklet-inlining? (not single-expression?))) + + (define (add-metadata ht) + (let* ([ht (hash-set ht 'original-phase phase)] + [ht (hash-set ht 'max-phase max-phase)]) + ht)) + + (define bundle + ((if to-source? values hash->linklet-bundle) + (add-metadata + (cond + [serializable? + ;; To support seialization, construct a linklet that will + ;; deserialize module path indexes, syntax objects, etc. + (define syntax-literals-expr + (performance-region + ['compile 'top 'serialize] + (generate-eager-syntax-literals! + syntax-literals + mpis + phase + (compile-context-self cctx) + (compile-context-namespace cctx)))) + + (define link-linklet + ((if to-source? values (lambda (s) + (performance-region + ['compile 'top 'linklet] + (define-values (linklet new-keys) + (compile-linklet s + #f + (vector deserialize-instance + empty-eager-instance-instance) + (lambda (inst) (values inst #f)))) + linklet))) + `(linklet + ;; imports + (,deserialize-imports + ,eager-instance-imports) + ;; exports + (,mpi-vector-id + ,deserialized-syntax-vector-id + phase-to-link-modules + ,syntax-literals-id) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)) + (define-values (,deserialized-syntax-vector-id) + (make-vector ,(add1 phase) #f)) + (define-values (phase-to-link-modules) ,phase-to-link-module-uses-expr) + (define-values (,syntax-literals-id) ,syntax-literals-expr)))) + + (hash-set body-linklets 'link link-linklet)] + [else + ;; Will combine the linking unit with non-serialized link info + body-linklets])))) + + (cond + [to-source? + (hasheq #f bundle)] + [else + ;; If the compiled code is executed directly, it must be in its + ;; original phase, and we'll share the original values + (compiled-in-memory (hash->linklet-directory (hasheq #f bundle)) + #f ; self + #f ; requires + #f ; provides + phase-to-link-module-uses + (current-code-inspector) + phase-to-link-extra-inspectorss + (mpis-as-vector mpis) + (syntax-literals-as-vector syntax-literals) + null + null + (extract-namespace-scopes (compile-context-namespace cctx)) + purely-functional?)]))) + +;; Callback for compiling a sequence of expressions: handle `require` +;; (which is handled separately for modules) +(define (compile-top-level-require p cctx) + (define phase (compile-context-phase cctx)) + (cond + [(parsed-require? p) + (define form-stx (compile-quote-syntax (syntax-disarm (parsed-s p)) cctx)) + `(,top-level-require!-id ,form-stx ,ns-id)] + [else #f])) diff -Nru racket-6.12+ppa1/src/expander/demo.rkt racket-7.0+ppa1/src/expander/demo.rkt --- racket-6.12+ppa1/src/expander/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1409 @@ +#lang racket/base +(require "main.rkt" + "common/set.rkt") + +;; ---------------------------------------- + +(define demo-ns (make-namespace)) +(namespace-attach-module (current-namespace) ''#%kernel demo-ns) + +(namespace-require ''#%kernel demo-ns) +(namespace-require '(for-syntax '#%kernel) demo-ns) + +(define check-reexpand? #f) +(define check-serialize? #f) + +(define (expand-expression e #:namespace [ns demo-ns]) + (expand (namespace-syntax-introduce (datum->syntax #f e) ns) + ns)) + +(define (compile+eval-expression e #:namespace [ns demo-ns]) + (define exp-e (expand-expression e #:namespace ns)) + (define c (compile (if check-reexpand? exp-e e) ns check-serialize?)) + (define ready-c (if check-serialize? + (let ([o (open-output-bytes)]) + (display c o) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o))))) + c)) + (values exp-e + (eval ready-c ns))) + +(define (eval-expression e #:check [check-val 'no-value-to-check] + #:namespace [ns demo-ns]) + (define-values (c v) (compile+eval-expression e #:namespace ns)) + (unless (eq? check-val 'no-value-to-check) + (unless (equal? v check-val) + (error "check failed:" v "vs." check-val))) + v) + +(define (eval-expression/interleaved e #:check [check-val 'no-value-to-check] + #:namespace [ns demo-ns]) + (define v (eval e ns)) + (unless (eq? check-val 'no-value-to-check) + (check-value v check-val)) + v) + +(define (check-value v check-val) + (unless (equal? v check-val) + (error "check failed:" v "vs." check-val))) + +(define-syntax-rule (check-print expr out ...) + (check-thunk-print (lambda () expr) out ...)) + +(define (check-thunk-print t . outs) + (define o (open-output-bytes)) + (parameterize ([current-output-port o]) + (t)) + (write-bytes (get-output-bytes o)) + (define o-expected (open-output-bytes)) + (for ([out (in-list outs)]) (println out o-expected)) + (unless (equal? (get-output-bytes o) + (get-output-bytes o-expected)) + (error "output check failed:" + (get-output-bytes o) + "vs." (get-output-bytes o-expected)))) + +(define-syntax-rule (check-error expr rx) + (check-thunk-error (lambda () expr) rx)) + +(define (check-thunk-error t rx) + (void) + (with-handlers ([exn:fail? (lambda (exn) + (unless (regexp-match? rx (exn-message exn)) + (error "wrong error" (exn-message exn))) + `(ok ,(exn-message exn)))]) + (t) + (error "shouldn't get here"))) + +;; ---------------------------------------- + +(compile+eval-expression + '(+ 1 1)) + +(compile+eval-expression + '(case-lambda + [(x) (set! x 5)] + [(x y) (begin0 y x)] + [() (with-continuation-mark 1 2 3)])) + +(compile+eval-expression + '(lambda (x) (define-values (y) x) y)) + +(compile+eval-expression + '(lambda (x) + (define-syntaxes (y) (lambda (stx) (quote-syntax 7))) + y)) + +;; Expands to `let-values`: +(compile+eval-expression + '(lambda (x) + (define-values (z) 1) + (define-values (y) z) + y)) + +;; Expands to two separate `letrec-values`: +(compile+eval-expression + '(lambda (x) + (define-values (z) (lambda () y)) + (define-values (y) 1) + (define-values (q) (lambda () q)) + z)) + +;; Same as previous: +(compile+eval-expression + '(lambda (x) + (letrec-syntaxes+values + () + ([(z) (lambda () y)] + [(y) 1] + [(q) (lambda () q)]) + z))) + +(compile+eval-expression + '(let-values ([(z) 9]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (car (cdr (syntax-e stx))))]) + ([(x) 5] [(y) (lambda (z) z)]) + (let-values ([(z) 10]) + (begin z (if (m 10) 1 2)))))) + +"expansion not captured" +(eval-expression + #:check 'x-1 + '(let-values ([(x) 'x-1]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax x))]) + () + (let-values ([(x) 'x-3]) + (m))))) + +"non-capturing expansion" +(eval-expression + #:check 'x-3 + '(let-values ([(x) 'x-1]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + #f + (list (quote-syntax let-values) + (list (list (list (quote-syntax x)) + (quote-syntax 'x-2))) + (car (cdr (syntax-e stx))))))]) + () + (let-values ([(x) 'x-3]) + (m x))))) + +"distinct generated variables" +(eval-expression + #:check '(2 1) + '(letrec-syntaxes+values + ([(gen) (lambda (stx) + (let-values ([(vals) (syntax-e (car (cdr (syntax-e stx))))] + [(binds) (syntax-e (car (cdr (cdr (syntax-e stx)))))] + [(refs) (syntax-e (car (cdr (cdr (cdr (syntax-e stx))))))]) + (datum->syntax + #f + (if (null? vals) + (list (quote-syntax bind) binds refs) + (list (quote-syntax gen) + (cdr vals) + (cons (list (list (quote-syntax x)) + (car vals)) + binds) + (cons (quote-syntax x) + refs))))))] + [(bind) (lambda (stx) + (let-values ([(binds) (car (cdr (syntax-e stx)))] + [(refs) (car (cdr (cdr (syntax-e stx))))]) + (datum->syntax + (quote-syntax here) + (list (quote-syntax let-values) + binds + (cons (quote-syntax list) + refs)))))]) + () + (gen (1 2) () ()))) + +"use-site scopes (so not ambiguous)" +(eval-expression + #:check 'ok + '((let-values () + (define-syntaxes (identity) + (lambda (stx) + (let-values ([(misc-id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'lambda '(x) + (list 'let-values (list + (list (list misc-id) ''other)) + 'x)))))) + (identity x)) + 'ok)) + +"use-site scope remove from binding position" +(eval-expression + #:check 'still-ok + '(let-values () + (define-syntaxes (define-identity) + (lambda (stx) + (let-values ([(id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'define-values (list id) '(lambda (x) x)))))) + (define-identity f) + (f 'still-ok))) + +"compile-time scopes pruned by `quote-syntax`" +(namespace-require '(for-meta 2 '#%kernel) demo-ns) +(eval-expression + #:check 'bound + '(letrec-syntaxes+values + ([(m) + (lambda (stx) + (let-values ([(id1) (let-values ([(x) 1]) + (define-syntaxes (wrap) ; to provoke a use-site scope + (lambda (stx) (car (cdr (syntax-e stx))))) + (wrap (quote-syntax x)))] + [(id2) (let-values ([(x) 1]) + (define-syntaxes (wrap) + (lambda (stx) (car (cdr (syntax-e stx))))) + (wrap (quote-syntax x)))]) + (datum->syntax + (quote-syntax here) + (list 'let-values (list (list (list id1) ''bound)) + id2))))]) + () + (m))) + +"`(quote-syntax .... #:local)` doesn't prune" +(eval-expression + #:check 'bound-2 + '(letrec-syntaxes+values + ([(m) + (lambda (stx) + (let-values ([(id1) (let-values ([(x) 1]) + (quote-syntax x #:local))] + [(id2) (let-values ([(x) 1]) + (define-syntaxes (wrap) + (lambda (stx) (car (cdr (syntax-e stx))))) + (quote-syntax x #:local))]) + (datum->syntax + (quote-syntax here) + (list 'let-values (list (list (list id1) ''bound-1) + (list (list id2) ''bound-2)) + id2))))]) + () + (m))) + +"non-transformer binding misuse" +(check-error + (expand-expression '(letrec-syntaxes+values + ([(v) 1]) + () + v)) + #rx"illegal use of syntax") + +"free-identifier=? and bound-identifier=?" +(eval-expression + #:check '(a (#t #f #t) + b (#f #f #t) + c (#t #f #t) + d (#t #f #f) + e (#f #f #t) (#f #f #f) + f ((#t #f) (#f #f))) + '(let-values ([(x) 0]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (list + (free-identifier=? (quote-syntax x) (car (cdr (syntax-e stx)))) + (bound-identifier=? (quote-syntax x) (car (cdr (syntax-e stx)))) + (bound-identifier=? (car (cdr (syntax-e stx))) + (car (cdr (cdr (syntax-e stx)))))))))]) + () + (list + 'a + (m x x) + 'b + (let-values ([(x) 1]) + (m x x)) + 'c + (letrec-syntaxes+values + ([(n) (lambda (stx) + (quote-syntax (m x x)))]) + () + (n)) + 'd + (letrec-syntaxes+values + ([(o) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax m) + (car (cdr (syntax-e stx))) + (quote-syntax x))))]) + () + (o x)) + 'e + (m not-x not-x) + (m not-x also-not-x) + 'f + (letrec-syntaxes+values + ([(p) (lambda (stx) + (letrec-syntaxes+values + ([(q) (lambda (nested-stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + ;; These `free-identifier=?` test should be at phase 1: + (list + (free-identifier=? (quote-syntax stx) (car (cdr (syntax-e nested-stx)))) + (free-identifier=? (quote-syntax stx) (car (cdr (cdr (syntax-e nested-stx)))))))))]) + () + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (list (q stx not-stx) + (let-values ([(stx) 0]) + (q stx stx)))))))]) + () + (p)))))) + +"syntax-local-value" +(eval-expression + '(let-values ([(x) 1]) + (letrec-syntaxes+values + ([(x-id) (quote-syntax x)]) + () + (letrec-syntaxes+values + ([(m) (lambda (stx) (syntax-local-value (quote-syntax x-id)))]) + () + (let-values ([(x) 2]) + (m))))) + #:check 1) + +"local-expand" +(eval-expression + '(let-values ([(x) 10]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax (something x)))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) (car + (cdr + (syntax-e + (local-expand (car (cdr (syntax-e stx))) + 'expression + (list (quote-syntax #%app)))))))]) + () + (let-values ([(x) 20]) + (n (m)))))) + #:check 10) + +"local-expand-expression" +(eval-expression + '(letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax 5))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (let-values ([(expr already) + (syntax-local-expand-expression (car (cdr (syntax-e stx))))]) + (datum->syntax + (quote-syntax here) + (list (quote-syntax +) + (quote-syntax 1) + already))))]) + () + (n (m)))) + #:check 6) + +(check-error + (eval-expression + '(letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax 5))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (let-values ([(expr already) + (syntax-local-expand-expression (car (cdr (syntax-e stx))))]) + (datum->syntax + #f + (list + (quote-syntax let-values) + (list (list (list (quote-syntax x)) (quote-syntax 1))) + already))))]) + () + (n (m))))) + #rx"expanded syntax not in its original lexical context") + +"internal definition context" +(eval-expression + '(let-values ([(x) 10]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (let-values ([(id) (car (cdr (syntax-e stx)))] + [(id2) (car (cdr (cdr (syntax-e stx))))] + [(intdef) (syntax-local-make-definition-context)]) + (syntax-local-bind-syntaxes (list id) + (quote-syntax (lambda (stx) (quote-syntax 5))) + intdef) + (syntax-local-bind-syntaxes (list id2) + #f + intdef) + (datum->syntax + (quote-syntax here) + (list (quote-syntax let-values) + (list (list (list + (let-values ([(id2-by-expand) + (car + (cdr + (syntax-e (local-expand (datum->syntax + #f + (list (quote-syntax quote) + id2)) + (list 'intdef) + (list (quote-syntax quote)) + intdef))))] + [(id2-by-intro) + (internal-definition-context-introduce + intdef + id2)] + [(flip) (make-syntax-introducer)]) + (if (bound-identifier=? id2-by-expand id2-by-intro) + (let-values ([(delta) + (make-syntax-delta-introducer + (flip (quote-syntax here)) + (quote-syntax here))]) + (syntax-local-identifier-as-binding + (delta (flip id2-by-intro) 'remove))) + (error "should have been the same")))) + 7)) + (local-expand (datum->syntax + (quote-syntax here) + (list (quote-syntax +) + (list id) + id2)) + (list 'intdef) + (list) + intdef)))))]) + + () + (m x y))) + #:check 12) + +"set! transformer" +(eval-expression + '(let-values ([(real-one) 1] + [(check-one) (lambda (v) + (if (equal? v 1) + 'ok + 'oops))]) + (letrec-syntaxes+values + ([(one) + (make-set!-transformer + (lambda (stx) + (if (pair? (syntax-e stx)) + (if (free-identifier=? (car (syntax-e stx)) + (quote-syntax set!)) + (datum->syntax + (quote-syntax here) + (list (quote-syntax check-one) + (car (cdr (cdr (syntax-e stx)))))) + (datum->syntax + stx + (cons + (quote-syntax list) + (cons + (quote-syntax real-one) + (cdr (syntax-e stx)))))) + (quote-syntax real-one))))]) + () + (list one + (set! one 5) + (set! one 1) + (one 8)))) + #:check (list 1 'oops 'ok '(1 8))) + +"rename transformer" +(eval-expression + '(let-values ([(f) (lambda (v) (+ v 1))]) + (letrec-syntaxes+values + ([(g) (make-rename-transformer (quote-syntax f))]) + () + (list (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax (quote-syntax here) + (free-identifier=? (quote-syntax f) + (quote-syntax g))))]) + () + (m)) + (let-values ([(h) g]) (h 0)) + (g 1) + (begin + (set! g 3) + f) + (letrec-syntaxes+values + ([(f-id) (quote-syntax f)]) + () + (letrec-syntaxes+values + ([(g-id) (make-rename-transformer (quote-syntax f-id))]) + () + (letrec-syntaxes+values + ([(m) (lambda (stx) (syntax-local-value (quote-syntax g-id)))]) + () + (+ 1 (m)))))))) + #:check (list #t 1 2 3 4)) + +"lifts in transformer; same number twice" +(eval-expression '(letrec-syntaxes+values + ([(n) (lambda (stx) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) + (syntax-local-lift-expression + (quote-syntax (random)))) + (list (quote-syntax newline)))))]) + () + (datum->syntax (quote-syntax here) + (m))))]) + () + (list (n) (n)))) + +"local-expand/capture-lifts" +(eval-expression '(letrec-syntaxes+values + ([(m) (lambda (stx) + (syntax-local-lift-expression (quote-syntax 1)))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (local-expand/capture-lifts + (quote-syntax (m)) + 'expression + '()))))]) + () + (let-values ([(x) (n)]) + (list (car x) + (car (car (cdr x))) + (car (cdr (cdr (car (cdr x))))))))) + #:check '(begin define-values 1)) + +"get shadower" +(eval-expression + '(let-values ([(x) 1]) + (letrec-syntaxes+values + ([(m) + (lambda (stx) + (datum->syntax + #f + (list (quote-syntax let-values) + (list + (list + (list (syntax-local-introduce + (syntax-local-get-shadower (quote-syntax x)))) + (quote-syntax 2))) + (car (cdr (syntax-e stx))))))]) + () + (let-values ([(x) 3]) + (m x)))) + #:check 2) + +"top-level definitions" +(eval-expression '(define-values (top-x) 'x-at-top)) +(eval-expression 'top-x #:check 'x-at-top) +(check-error (eval-expression 'top-y) #rx"undefined") +(eval-expression '(define-values (top-f) (lambda () top-y))) +(check-error (eval-expression '(top-f)) #rx"undefined") +(eval-expression '(define-values (top-y) 'y-at-top)) +(eval-expression '(top-f) #:check 'y-at-top) +(eval-expression '(define-values (top-y) 'changed-y-at-top)) +(eval-expression '(top-f) #:check 'changed-y-at-top) +(eval-expression '(define-syntaxes (top-m) (lambda (stx) + (datum->syntax + #f + (list (quote-syntax quote) + (car (cdr (syntax-e stx)))))))) +(eval-expression '(top-m 8) #:check 8) +(eval-expression '(define-syntaxes (top-def-top-x) + (lambda (stx) + (quote-syntax + (begin + (define-values (top-x) 'macro-introduced-top-x) + top-x))))) +(eval-expression/interleaved '(top-def-top-x) #:check 'macro-introduced-top-x) +(eval-expression 'top-x #:check 'x-at-top) +(eval-expression '(begin ; check compilation of multiple top-level forms + (define-values (top-z) 'z-at-top) + top-z) + #:check 'z-at-top) + +;; ---------------------------------------- + +(define (eval-module-declaration mod #:namespace [ns demo-ns]) + (parameterize ([current-namespace ns]) + (eval-expression mod #:namespace ns))) + +(eval-module-declaration '(module m0 '#%kernel + (define-values (x) 0) + (print x) (newline))) + +(check-print + (eval-expression '(#%require 'm0)) + 0) + +(eval-module-declaration '(module m1 '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (define-values (ten) (quote-syntax 10))) + (define-syntaxes (m) (lambda (stx) ten)) + (define-values (x) 1) + (print x) (newline) + (define-values (posn make-posn struct:posn posn? + posn-x posn-y + set-posn-x! set-posn-y!) + (values 1 2 3 4 5 6 7 8)) + (#%provide (prefix-all-defined def:) + (struct posn (x y))) + (print (m)) (newline) + (m))) + +(eval-module-declaration '(module m2 '#%kernel + (#%require 'm1) + (print def:x) (newline))) + +(check-print + (eval-expression '(#%require 'm2)) + 1 + 10 + 1) + +(eval-module-declaration '(module with-use-site-scope '#%kernel + (#%require (for-syntax '#%kernel)) + + (define-syntaxes (identity) + (lambda (stx) + (let-values ([(misc-id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'lambda '(x) + (list 'let-values (list + (list (list misc-id) ''other)) + 'x)))))) + (identity x) + + (define-syntaxes (define-identity) + (lambda (stx) + (datum->syntax + #f + (list (quote-syntax define-values) + (list (car (cdr (syntax-e stx)))) + (quote-syntax (lambda (x) x)))))) + (define-identity f) + (print (f 5)) (newline) + + (define-syntaxes (define-x) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax begin-for-syntax) + (list (quote-syntax define-values) + (list (car (cdr (syntax-e stx)))) + (quote-syntax 'ct-5)))))) + (define-x ct-5) + (define-syntaxes (ct-five) + (lambda (stx) + (datum->syntax (quote-syntax here) + (list (quote-syntax quote) + ct-5)))) + (print (ct-five)) (newline))) + +(check-print + (namespace-require ''with-use-site-scope demo-ns) + 5 + 'ct-5) + +(eval-module-declaration '(module definition-shadows-initial-require '#%kernel + (#%require (rename '#%kernel orig:list list)) + (#%provide list) + (define-values (list) + (lambda (a b) + (print a) (newline) + (orig:list a b))))) + +(eval-module-declaration '(module definition-shadows-plain-require '#%kernel + (#%require '#%kernel) + (#%provide map) + (define-values (map) + (lambda (f l) + (if (null? l) + '() + (cons (car l) ; don't use `f` + (map f (cdr l)))))))) + +(eval-module-declaration '(module require-shadows-initial-require '#%kernel + (#%require 'definition-shadows-initial-require + 'definition-shadows-plain-require) + (print (map pair? (list 'a 'b))) (newline))) + +(check-print + (namespace-require ''require-shadows-initial-require demo-ns) + 'a + '(a b)) + +(check-error + (eval-module-declaration '(module m '#%kernel + (#%require '#%kernel + 'definition-shadows-initial-require))) + #rx"already required") + +(eval-module-declaration '(module m '#%kernel + (define-values (list) 5) + (#%require '#%kernel))) + +;; ---------------------------------------- + +(check-print + (eval-module-declaration '(module forward-reference-in-begin-for-syntax '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (define-values (even) (lambda () odd))) + (begin-for-syntax + (define-values (odd) (lambda () even))) + (begin-for-syntax + (define-values (assign-later!) (lambda () (set! later also-later)))) + (begin-for-syntax + (define-values (later) 5) + (define-values (also-later) 6) + (assign-later!) + (print later) (newline)))) + 6 + 6) ; re-expansion + +;; ---------------------------------------- + +(eval-module-declaration '(module random-n '#%kernel + (define-values (n) (random)) + (#%provide n))) + +(eval-module-declaration '(module use-random-n '#%kernel + (#%require 'random-n + (for-syntax '#%kernel + 'random-n)) + (define-syntaxes (m) + (lambda (stx) (datum->syntax (quote-syntax here) + n))) + (print (m)) (newline) + (print (m)) (newline) + (print n) (newline) + (print n) (newline))) + +"print same number twice, then different number twice" +(namespace-require ''use-random-n demo-ns) + +;; ---------------------------------------- + +;; Fresh compile-time, same run-time: +(eval-module-declaration '(module use-random-n-again '#%kernel + (#%require 'random-n + (for-syntax '#%kernel + 'random-n)) + (define-syntaxes (m) + (lambda (stx) (datum->syntax (quote-syntax here) + n))) + (print (m)) (newline) + (print n) (newline))) + +"first number is fresh, second number is same" +(namespace-require ''use-random-n-again demo-ns) + +;; ---------------------------------------- + +;; Check phase shifting of syntax objects: +(eval-module-declaration '(module two-xes '#%kernel + (#%require (for-syntax '#%kernel)) + (define-values (x) 0) + (begin-for-syntax + (define-values (x) 1)) + (#%provide x + (for-syntax x)))) + +(eval-module-declaration '(module use-two-xes '#%kernel + (#%require (for-template 'two-xes) + (for-syntax '#%kernel)) + (define-values (rt-x-ref) (quote-syntax x)) + (begin-for-syntax + (define-values (ct-x-ref) (quote-syntax x))) + (#%provide rt-x-ref + (for-syntax ct-x-ref)))) + +(eval-module-declaration '(module use-x-ref '#%kernel + (#%require 'use-two-xes + (for-syntax '#%kernel + 'use-two-xes)) + (define-syntaxes (ct-m) (lambda (stx) ct-x-ref)) + (define-syntaxes (rt-m) (lambda (stx) rt-x-ref)) + (print (ct-m)) (newline) + (print (rt-m)) (newline))) + +(check-print + (namespace-require ''use-x-ref demo-ns) + 1 + 0) + +;; ---------------------------------------- +;; Custom `#%module-begin' + +(eval-module-declaration '(module printing-mb '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide (all-from-except '#%kernel #%module-begin) + (rename module-begin #%module-begin)) + (define-syntaxes (module-begin) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (cons + (quote-syntax #%module-begin) + (map (lambda (b) + (datum->syntax + (quote-syntax here) + (list (quote-syntax begin) + (list (quote-syntax print) b) + (list (quote-syntax newline))))) + (cdr (syntax-e stx))))))))) + +(eval-module-declaration '(module printed 'printing-mb + (+ 1 2) + (+ 3 4))) + +(check-print + (namespace-require ''printed demo-ns) + 3 + 7) + +(eval-module-declaration '(module intro-printed-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide m) + (define-syntaxes (m) + (lambda (stx) + (quote-syntax + (module sub 'printing-mb + (+ 5 6) + (+ 7 8))))))) + +(eval-module-declaration '(module printed-submodule '#%kernel + (#%require 'intro-printed-submodule) + (m))) + +(check-print + (namespace-require '(submod 'printed-submodule sub) demo-ns) + 11 + 15) + +;; ---------------------------------------- +;; local-expanding `#%module-begin' + +(eval-module-declaration '(module local-expanding-mb '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide (all-from-except '#%kernel #%module-begin) + (rename module-begin #%module-begin)) + (define-syntaxes (module-begin) + (lambda (stx) + (local-expand (datum->syntax + #f + (cons + (quote-syntax #%module-begin) + (cdr (syntax-e stx)))) + 'module-begin + null))))) + +(eval-module-declaration '(module local-expanded-mb 'local-expanding-mb + (define-values (x) 'x) + (print x) (newline))) + +(check-print + (namespace-require ''local-expanded-mb demo-ns) + 'x) + +;; ---------------------------------------- +;; Submodule + +(eval-module-declaration '(module with-pre-submodule '#%kernel + (module a '#%kernel + (#%provide a) + (define-values (a) 'a)) + (#%require (submod "." a)) + (print a) (newline))) + +(check-print + (namespace-require ''with-pre-submodule demo-ns) + 'a) + +(eval-module-declaration '(module with-post-submodule '#%kernel + (#%provide b) + (define-values (b) 'b) + (module* b '#%kernel + (#%require (submod "..")) + (print b) (newline)))) + +(check-print + (namespace-require '(submod 'with-post-submodule b) demo-ns) + 'b) + +(eval-module-declaration '(module with-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (define-values (c) 'c) + (define-syntaxes (c2) (lambda (stx) (quote-syntax c))) + (module* c #f + (print c) (newline) + (print c2) (newline)))) + +(check-print + (namespace-require '(submod 'with-#f-submodule c) demo-ns) + 'c + 'c) + +(eval-module-declaration '(module used-by-shifted-submodule '#%kernel + (define-values (x) 'x) + (#%provide x))) + +(eval-module-declaration '(module with-shifted-pre-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (module xa '#%kernel + (#%require 'used-by-shifted-submodule) + (#%provide xa) + (define-values (xa) x))) + (#%require (submod "." xa)) + (print xa) (newline))) + +(check-print + (namespace-require ''with-shifted-pre-submodule demo-ns) + 'x) + +(eval-module-declaration '(module with-shifted-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel + 'used-by-shifted-submodule)) + (define-values (d) 'd) + (begin-for-syntax + (define-values (d-stx) (quote-syntax d)) + (module* d #f + (#%provide get-d-stx) + x + (define-values (get-d-stx) (lambda () d-stx)))))) + +(eval-module-declaration '(module use-shifted-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel + (submod 'with-shifted-#f-submodule d))) + (define-syntaxes (m) (lambda (stx) (get-d-stx))) + (print (m)) (newline))) + +(check-print + (namespace-require ''use-shifted-#f-submodule demo-ns) + 'd) + +(eval-module-declaration '(module with-#f-submodule-provide '#%kernel + (define-values (e) 'e) + (module* e #f + (#%provide e)))) + +(eval-module-declaration '(module use-submodule-provide '#%kernel + (#%require (submod 'with-#f-submodule-provide e)) + (print e) (newline))) + +(check-print + (namespace-require ''use-submodule-provide demo-ns) + 'e) + +;; ---------------------------------------- +;; rename-transformer provide redirection + +(eval-module-declaration '(module provides-original-binding '#%kernel + (#%provide x) + (define-values (x) 'x))) + +(eval-module-declaration '(module provides-rename-transformer '#%kernel + (#%require (for-syntax '#%kernel) + 'provides-original-binding) + (#%provide y) + (define-syntaxes (y) (make-rename-transformer + (quote-syntax x))))) + +(eval-module-declaration '(module checks-free=id '#%kernel + (#%require (for-syntax '#%kernel) + 'provides-original-binding + 'provides-rename-transformer) + (print (if (free-identifier=? (quote-syntax x) + (quote-syntax y)) + 'free=id + 'not-free=id)) + (newline))) + +(check-print + (namespace-require ''checks-free=id demo-ns) + 'free=id) + +;; ---------------------------------------- +;; syntax-local-value of module binding + +(eval-module-declaration '(module define-non-transformer '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide car-id) + (define-syntaxes (car-id) (quote-syntax car)))) + +(eval-module-declaration '(module use-non-transformer '#%kernel + (#%require (for-syntax '#%kernel) + 'define-non-transformer) + (define-syntaxes (m) + (lambda (stx) (syntax-local-value (quote-syntax car-id)))) + (print ((m) '(1 2))) + (newline))) + +(check-print + (namespace-require ''use-non-transformer demo-ns) + 1) + +;; ---------------------------------------- +;; syntax-local-lift-{expression,module}, etc. + +(eval-module-declaration '(module lifts '#%kernel + (#%require (for-syntax '#%kernel)) + (module pre '#%kernel + (#%provide pre) + (define-values (pre) 'pre)) + (define-syntaxes (m) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) + (syntax-local-lift-expression + (quote-syntax (+ 1 2)))) + (list (quote-syntax newline)))))) + (m) + (list (m)) + (define-values (dummy) (m)) + (define-syntaxes (n) + (lambda (stx) + (syntax-local-lift-module + (quote-syntax (module sub '#%kernel + (#%provide sub) + (define-values (sub) 'sub)))) + (syntax-local-lift-module + (quote-syntax (module* main #f + (print x) (newline)))) + (syntax-local-lift-module-end-declaration + (quote-syntax (define-values (done) 'done))) + (syntax-local-lift-provide + (quote-syntax done)) + (let-values ([(pre-id) (syntax-local-lift-require + (quote-syntax (submod "." pre)) + (quote-syntax pre))]) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) pre-id) + (quote-syntax (newline)) + (quote-syntax (#%require (submod "." sub))) + (quote-syntax (print sub)) + (quote-syntax (newline))))))) + (n) + (define-values (x) '*) + (define-syntaxes (as-expr) + (lambda (stx) + ;; (syntax-local-lift-module-end-declaration + ;; (quote-syntax (define-values (fail) 'this-wont-work))) + (syntax-local-lift-module-end-declaration + (quote-syntax (begin (print 'end) (newline)))) + (quote-syntax (void)))) + (list (as-expr)))) + +(check-print + (namespace-require '(submod 'lifts main) demo-ns) + 3 + 3 + 3 + 'pre + 'sub + 'end + '*) + +(eval-module-declaration '(module use-lifted-provide '#%kernel + (#%require 'lifts) + (print done) (newline))) + +(check-print + (namespace-require ''use-lifted-provide demo-ns) + 'done) + +;; ---------------------------------------- +;; `local-transformer-expand` + +(eval-module-declaration '(module local-transformer-expand '#%kernel + (#%require (for-syntax '#%kernel)) + (define-syntaxes (m) + (lambda (stx) + (datum->syntax + #f + (list + (quote-syntax letrec-syntaxes+values) + (list + (list (list (car (cdr (syntax-e stx)))) + (local-transformer-expand + (car (cdr (cdr (syntax-e stx)))) + 'expression + '()))) + (list) + (car (cdr (cdr (cdr (syntax-e stx))))))))) + (begin-for-syntax + (#%require (for-syntax '#%kernel)) + (define-syntaxes (tm) + (lambda (stx) + (quote-syntax (quote-syntax 'local-trans))))) + (print (m p (lambda (stx) (tm)) (p))) (newline))) + +(check-print + (namespace-require ''local-transformer-expand demo-ns) + 'local-trans) + +;; ---------------------------------------- +;; `expand` in `#%provide` + +(eval-module-declaration '(module expand-provide '#%kernel + (#%require (for-syntax '#%kernel)) + (module sub '#%kernel + (#%provide a-sub b-sub) + (define-values (a-sub) 'a-sub) + (define-values (b-sub) 'b-sub)) + (#%require (submod "." sub)) + (define-values (a-here) 'a-here) + (define-values (b-here) 'b-here) + (define-syntaxes (all-a) + (lambda (stx) + (let-values ([(here) (syntax-local-module-defined-identifiers)] + [(there) (syntax-local-module-required-identifiers + '(submod "." sub) + 0)] + [(keep-a) (lambda (id) + (regexp-match? #rx"^a" + (symbol->string + (syntax-e id))))]) + (define-values (filter) + (lambda (f l) + (if (null? l) + null + (if (f (car l)) + (cons (car l) (filter f (cdr l))) + (filter f (cdr l)))))) + (datum->syntax + #f + (cons + (quote-syntax begin) + (append + (filter keep-a (hash-ref here 0)) + (filter keep-a (cdr (assv 0 there))))))))) + (#%provide (expand (all-a))))) + +(eval-module-declaration '(module use-expand-provide '#%kernel + (#%require 'expand-provide) + (print (list a-sub a-here)) (newline))) + +(check-print + (namespace-require ''use-expand-provide demo-ns) + (list 'a-sub 'a-here)) + +;; ---------------------------------------- +;; cross-phase persistent declaration + +(eval-module-declaration '(module cross-phase-persistent '#%kernel + (#%declare #:cross-phase-persistent) + (#%require '#%kernel) + (#%provide gen) + (define-values (gen) (gensym "g")) + (module ignored '#%kernel) + (module* also-ignored '#%kernel) + (begin + (define-values (y) (lambda () (error "anything"))) + (define-values (x) (case-lambda + [() (error "anything")] + [(x) (set! x x)]))) + (define-values (z) (list + #t + (cons 1 2) + "string" + #"bytes" + 'symbol + (gensym) + (string->uninterned-symbol "u"))))) + +(eval-module-declaration '(module use-cross-phase-persistent '#%kernel + (#%require (for-syntax '#%kernel + 'cross-phase-persistent) + (for-meta 2 '#%kernel + 'cross-phase-persistent)) + (begin-for-syntax + (define-syntaxes (ctct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + gen))))) + (define-syntaxes (ct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + gen)))) + (define-syntaxes (use-ctct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (ctct-gen))))) + + (print (equal? (ct-gen) (use-ctct-gen))) (newline))) + +(check-print + (namespace-require ''use-cross-phase-persistent demo-ns) + #t) + +;; ---------------------------------------- +;; for-label imports + +(eval-module-declaration '(module provides-title '#%kernel + (#%provide title) + (define-values (title) "Of Mice and Men"))) + +(eval-module-declaration '(module imports-title-for-label '#%kernel + (#%require (for-label 'provides-title)) + (print (identifier-binding (quote-syntax title))) (newline) + (print (cadr (identifier-label-binding (quote-syntax title)))) (newline))) + +(check-print + (namespace-require ''imports-title-for-label demo-ns) + #f + 'title) + +;; ---------------------------------------- +;; namespace-attach + +(eval-module-declaration '(module provides-random-r '#%kernel + (define-values (r) (random)) + (#%provide r))) + + +(define random-r (parameterize ([current-namespace demo-ns]) + (dynamic-require ''provides-random-r 'r))) +(unless (equal? random-r (parameterize ([current-namespace demo-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "not the same random number")) +'ok-dynamic + +(define other-ns (make-namespace)) +(namespace-attach-module demo-ns ''provides-random-r other-ns) + +(unless (equal? random-r (parameterize ([current-namespace other-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "not the same random number after attach")) +'ok-instance + +(namespace-attach-module demo-ns ''provides-random-r other-ns) ; re-attach ok +'ok-reattach + +(define third-ns (make-namespace)) +(namespace-attach-module-declaration demo-ns ''provides-random-r third-ns) + +(when (equal? random-r (parameterize ([current-namespace third-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "the same random number after declaration attach")) +'ok-declaration + +(namespace-attach-module-declaration demo-ns ''provides-random-r third-ns) ; re-attach ok +(check-error + (namespace-attach-module demo-ns ''provides-random-r third-ns) + #rx"different instance") + +(define has-already-ns (make-namespace)) +(namespace-attach-module (current-namespace) ''#%kernel has-already-ns) +(namespace-require ''#%kernel has-already-ns) +(eval-module-declaration '(module provides-random-r '#%kernel + (define-values (r) 5) + (#%provide r)) + #:namespace has-already-ns) +(parameterize ([current-namespace has-already-ns]) + (dynamic-require ''provides-random-r 'r)) +(check-error + (namespace-attach-module-declaration demo-ns ''provides-random-r has-already-ns) + #rx"different declaration") + +;; ---------------------------------------- +;; module redeclaration + +(eval-module-declaration '(module to-be-redeclared '#%kernel + (define-values (tbr-x) 'x) + (print tbr-x) (newline))) +(check-print + (eval-expression '(#%require 'to-be-redeclared)) + 'x) + +(check-print + (eval-module-declaration '(module to-be-redeclared '#%kernel + (define-values (tbr-y) 'y) + (print tbr-y) (newline))) + 'y) + +;; ---------------------------------------- +;; module exports + +(define one-of-each-provide-at-each-phase-expr + '(module one-of-each-provide-at-each-phase '#%kernel + (#%require (for-syntax '#%kernel) + (for-meta 2 '#%kernel)) + (define-values (one) 1) + (define-values (also-one) 1) + (define-syntaxes (one-s) (quote-syntax 1)) + (begin-for-syntax + (define-values (two) 2) + (define-values (also-two) 2) + (define-syntaxes (two-s) (quote-syntax 2))) + (#%provide one one-s + (for-syntax two two-s)))) + +(eval-module-declaration one-of-each-provide-at-each-phase-expr) + +(parameterize ([current-namespace demo-ns]) + (eval-expression '(call-with-values + (lambda () (module->exports ''one-of-each-provide-at-each-phase)) + list) + #:check '(((0 (one ())) (1 (two ()))) + ((0 (one-s ())) (1 (two-s ())))))) + +(parameterize ([current-namespace demo-ns]) + (eval-expression '(module->indirect-exports ''one-of-each-provide-at-each-phase) + #:check '((0 also-one) (1 also-two)))) + +(check-value (call-with-values + (lambda () (module-compiled-exports + (compile one-of-each-provide-at-each-phase-expr demo-ns))) + list) + '(((0 (one ())) (1 (two ()))) + ((0 (one-s ())) (1 (two-s ()))))) + +(check-value (module-compiled-indirect-exports + (compile one-of-each-provide-at-each-phase-expr demo-ns)) + '((0 also-one) (1 also-two))) + +;; ---------------------------------------- +;; top-level fallbacks + +(define s-only-in-demo (namespace-syntax-introduce (datum->syntax #f 'car) demo-ns)) + +(define alt-ns (make-namespace)) +(namespace-attach-module demo-ns ''#%kernel alt-ns) + +(define s-also-in-alt (namespace-syntax-introduce s-only-in-demo alt-ns)) +(define s-only-in-alt (namespace-syntax-introduce (datum->syntax #f 'car) alt-ns)) + +(check-value (hash-ref (syntax-debug-info s-only-in-demo) 'fallbacks #f) + #f) +(check-value (hash-ref (syntax-debug-info s-only-in-alt) 'fallbacks #f) + #f) +(check-value (length (hash-ref (syntax-debug-info s-also-in-alt) 'fallbacks null)) + 1) +(check-value (list->set (hash-ref (syntax-debug-info s-also-in-alt) 'context #f)) + (set-union (list->set (hash-ref (syntax-debug-info s-only-in-demo) 'context #f)) + (list->set (hash-ref (syntax-debug-info s-only-in-alt) 'context #f)))) + +(check-value (cadr (identifier-binding s-only-in-demo)) + 'car) +(check-value (identifier-binding s-only-in-alt) + #f) +(check-value (cadr (identifier-binding s-also-in-alt)) + 'car) + +(namespace-require ''#%kernel alt-ns) +(check-value (cadr (identifier-binding s-only-in-alt)) + 'car) + +(eval-module-declaration '(module kar '#%kernel + (#%provide (rename kar car)) + (define-values (kar) 5)) + #:namespace alt-ns) +(eval-expression '(#%require 'kar) #:namespace alt-ns) +(eval-expression 'car #:namespace alt-ns + #:check 5) + +(check-value (cadr (identifier-binding s-only-in-alt)) + 'kar) +(check-value (cadr (identifier-binding s-also-in-alt)) + 'car) ; because using combined scopes is ambiguous diff -Nru racket-6.12+ppa1/src/expander/eval/api.rkt racket-7.0+ppa1/src/expander/eval/api.rkt --- racket-6.12+ppa1/src/expander/eval/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,77 @@ +#lang racket/base +(require (prefix-in direct: "main.rkt") + (prefix-in direct: "../namespace/api.rkt") + "../syntax/api.rkt" + "../namespace/namespace.rkt" + "../common/contract.rkt" + "parameter.rkt") + +;; These wrappers implement the protocol for whether to use +;; `namespace-synatx-introduce` on the argument to `eval`, etc. + +(provide eval + eval-syntax + + compile + compile-syntax + + expand + expand-syntax + + expand-to-top-form + expand-syntax-to-top-form + + expand-once + expand-syntax-once) + +(define/who eval + (case-lambda + [(s) ((current-eval) (intro s))] + [(s ns) + (check who namespace? ns) + (parameterize ([current-namespace ns]) + ((current-eval) (intro s ns)))])) + +(define/who eval-syntax + (case-lambda + [(s) + (check who syntax? s) + ((current-eval) s)] + [(s ns) + (check who syntax? s) + (check who namespace? ns) + (parameterize ([current-namespace ns]) + ((current-eval) s))])) + +(define (compile s) + ((current-compile) (intro s) #f)) + +(define/who (compile-syntax s) + (check who syntax? s) + ((current-compile) s #f)) + +(define (expand s) + (direct:expand (intro s) (current-namespace) #t)) + +(define/who (expand-syntax s) + (check who syntax? s) + (direct:expand s (current-namespace) #t)) + +(define (expand-once s) + (direct:expand-once (intro s))) + +(define/who (expand-syntax-once s) + (check who syntax? s) + (direct:expand-once s)) + +(define (expand-to-top-form s) + (direct:expand-to-top-form (intro s))) + +(define/who (expand-syntax-to-top-form s) + (check who syntax? s) + (direct:expand-to-top-form s)) + + +(define (intro given-s [ns (current-namespace)]) + (define s (if (syntax? given-s) given-s (datum->syntax #f given-s))) + (direct:namespace-syntax-introduce s ns)) diff -Nru racket-6.12+ppa1/src/expander/eval/collection.rkt racket-7.0+ppa1/src/expander/eval/collection.rkt --- racket-6.12+ppa1/src/expander/eval/collection.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/collection.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,484 @@ +#lang racket/base +(require racket/private/check + racket/private/config + "parameter.rkt" + ;; Avoid keyword-argument variant: + (only-in '#%kernel directory-list)) + +(provide collection-path + collection-file-path + find-library-collection-paths + find-library-collection-links + + find-col-file) + +(define (relative-path-string? s) + (and (path-string? s) (relative-path? s))) + +(define (check-collection who s l) + (check who relative-path-string? + #:contract "(and/c path-string? relative-path?)" + s) + (check who (lambda (l) + (and (list? l) + (andmap relative-path-string? l))) + #:contract "(listof (and/c path-string? relative-path?))" + l)) + +(define (check-fail who fail) + (check who (procedure-arity-includes/c 1) fail)) + +;; Non-keyword variant is wrapped by a kerword variant in `racket/base` +(define/who (collection-path fail collection collection-path) + (check-collection who collection collection-path) + (check-fail who fail) + (find-col-file fail + collection collection-path + #f + #f)) + +;; Non-keyword variant is wrapped by a kerword variant in `racket/base` +(define/who (collection-file-path fail check-compiled? file-name collection collection-path) + (check who relative-path-string? + #:contract "(and/c path-string? relative-path?)" + file-name) + (check-collection who collection collection-path) + (check-fail who fail) + (find-col-file fail + collection collection-path + file-name + check-compiled?)) + +(define (get-config-table d) + (define p (and d (build-path d "config.rktd"))) + (or (and p + (file-exists? p) + (with-input-from-file p + (lambda () + (let ([v (call-with-default-reading-parameterization read)]) + (and (hash? v) + v))))) + #hash())) + +(define (get-installation-name config-table) + (hash-ref config-table + 'installation-name + (version))) + +(define (coerce-to-path p) + (cond + [(string? p) (collects-relative-path->complete-path (string->path p))] + [(bytes? p) (collects-relative-path->complete-path (bytes->path p))] + [(path? p) (collects-relative-path->complete-path p)] + [else p])) + +(define (collects-relative-path->complete-path p) + (cond + [(complete-path? p) p] + [else + (path->complete-path p (or (find-main-collects) + ;; If we get here, then something is configured wrong, + ;; and making up paths relative to the current directory + ;; is not great --- but we have to come up with some + ;; path at this point. + (current-directory)))])) + +(define (add-config-search ht key orig-l) + (define l (hash-ref ht key #f)) + (if l + (let loop ([l l]) + (cond + [(null? l) null] + [(not (car l)) (append orig-l (loop (cdr l)))] + [else (cons (coerce-to-path (car l)) (loop (cdr l)))])) + orig-l)) + +(define (find-library-collection-links) + (define ht (get-config-table (find-main-config))) + (define lf (coerce-to-path + (or (hash-ref ht 'links-file #f) + (build-path (or (hash-ref ht 'share-dir #f) + (build-path 'up "share")) + "links.rktd")))) + (append + ;; `#f' means `current-library-collection-paths': + (list #f) + ;; user-specific + (if (and (use-user-specific-search-paths) + (use-collection-link-paths)) + (list (build-path (find-system-path 'addon-dir) + (get-installation-name ht) + "links.rktd")) + null) + ;; installation-wide: + (if (use-collection-link-paths) + (add-config-search + ht + 'links-search-files + (list lf)) + null))) + +;; map from link-file names to cached information: +(define links-cache (make-weak-hash)) + +;; used for low-level exception abort below: +(define stamp-prompt-tag (make-continuation-prompt-tag 'stamp)) + +(define (file->stamp path old-stamp) + ;; Using just the file's modification date almost works as a stamp, + ;; but 1-second granularity isn't fine enough. A stamp is therefore + ;; the file content paired with a filesystem-change event (where + ;; supported), and the event lets us recycle the old stamp almost + ;; always. + (cond + [(and old-stamp + (cdr old-stamp) + (not (sync/timeout 0 (cdr old-stamp)))) + old-stamp] + [else + (call-with-continuation-prompt + (lambda () + (call-with-exception-handler + (lambda (exn) + (abort-current-continuation + stamp-prompt-tag + (if (exn:fail:filesystem? exn) + (lambda () #f) + (lambda () (raise exn))))) + (lambda () + (define dir-evt + (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? + (let loop ([path path]) + (let-values ([(base name dir?) (split-path path)]) + (and (path? base) + (if (directory-exists? base) + (filesystem-change-evt base (lambda () #f)) + (loop base))))))) + (cond + [(not (file-exists? path)) + (cons #f dir-evt)] + [else + (define evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? + (filesystem-change-evt path (lambda () #f)))) + (when dir-evt (filesystem-change-evt-cancel dir-evt)) + (cons (file->bytes path) + evt)])))) + stamp-prompt-tag)])) + +(define (file->bytes path) + (call-with-input-file* + path + (lambda (p) + (let ([bstr (read-bytes 8192 p)]) + (if (and (bytes? bstr) + ((bytes-length bstr) . >= . 8192)) + (apply + bytes-append + (cons + bstr + (let loop () + (let ([bstr (read-bytes 8192 p)]) + (if (eof-object? bstr) + null + (cons bstr (loop))))))) + bstr))))) + +(define (no-file-stamp? a) + (or (not a) + (not (car a)))) + +(define (get-linked-collections links-path) + ;; Use/save information in `links-cache', relying on filesystem-change events + ;; or a copy of the file to detect when the cache is stale. + (let/ec esc + (define (make-handler ts) + (lambda (exn) + (if (exn:fail? exn) + (let ([l (current-logger)]) + (when (log-level? l 'error) + (log-message l 'error + (format + "error reading collection links file ~s: ~a" + links-path + (exn-message exn)) + (current-continuation-marks)))) + (void)) + (when ts + (hash-set! links-cache links-path (cons ts #hasheq()))) + (if (exn:fail? exn) + (esc (make-hasheq)) + ;; re-raise the exception (which is probably a break) + exn))) + (call-with-exception-handler + (make-handler #f) + (lambda () + (define links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))) + (define a-links-stamp (car links-stamp+cache)) + (define ts (file->stamp links-path a-links-stamp)) + (cond + [(equal? ts a-links-stamp) + (cdr links-stamp+cache)] + [else + (call-with-exception-handler + (make-handler ts) + (lambda () + (call-with-default-reading-parameterization + (lambda () + (define v (if (no-file-stamp? ts) + null + (call-with-input-file* + links-path + (lambda (p) + (begin0 + (read p) + (unless (eof-object? (read p)) + (error "expected a single S-expression"))))))) + (unless (and (list? v) + (andmap (lambda (p) + (and (list? p) + (or (= 2 (length p)) + (= 3 (length p))) + (or (string? (car p)) + (eq? 'root (car p)) + (eq? 'static-root (car p))) + (path-string? (cadr p)) + (or (null? (cddr p)) + (regexp? (caddr p))))) + v)) + (error "ill-formed content")) + (define ht (make-hasheq)) + (define dir (let-values ([(base name dir?) (split-path links-path)]) + base)) + (for-each (lambda (p) + (when (or (null? (cddr p)) + (regexp-match? (caddr p) (version))) + (let ([dir (simplify-path + (path->complete-path (cadr p) dir))]) + (cond + [(eq? (car p) 'static-root) + ;; multi-collection, constant content: + (for-each + (lambda (sub) + (when (directory-exists? (build-path dir sub)) + (let ([k (string->symbol (path->string sub))]) + (hash-set! ht k (cons dir (hash-ref ht k null)))))) + (directory-list dir))] + [(eq? (car p) 'root) + ;; multi-collection, dynamic content: + ;; Add directory to the #f mapping, and also + ;; add to every existing table element (to keep + ;; the choices in order) + (unless (hash-ref ht #f #f) + (hash-set! ht #f null)) + (hash-for-each + ht + (lambda (k v) + (hash-set! ht k (cons dir v))))] + [else + ;; single collection: + (let ([s (string->symbol (car p))]) + (hash-set! ht s (cons (box dir) + (hash-ref ht s null))))])))) + v) + ;; reverse all lists: + (hash-for-each + ht + (lambda (k v) (hash-set! ht k (reverse v)))) + ;; save table & file content: + (hash-set! links-cache links-path (cons ts ht)) + ht))))]))))) + +(define (normalize-collection-reference collection collection-path) + ;; make sure that `collection' is a top-level collection name + (cond + [(string? collection) + (let ([m (regexp-match-positions #rx"/+" collection)]) + (if m + (cond + [(= (caar m) (sub1 (string-length collection))) + (values (substring collection 0 (caar m)) collection-path)] + [else + (values (substring collection 0 (caar m)) + (cons (substring collection (cdar m)) + collection-path))]) + (values collection collection-path)))] + [else + (define-values (base name dir?) (split-path collection)) + (if (eq? base 'relative) + (values name collection-path) + (normalize-collection-reference base (cons name collection-path)))])) + +(define (find-col-file fail collection-in collection-path-in file-name check-compiled?) + (define-values (collection collection-path) + (normalize-collection-reference collection-in collection-path-in)) + (define all-paths (let ([sym (string->symbol + (if (path? collection) + (path->string collection) + collection))]) + (let loop ([l (current-library-collection-links)]) + (cond + [(null? l) null] + [(not (car l)) + ;; #f is the point where we try the old parameter: + (append + (current-library-collection-paths) + (loop (cdr l)))] + [(hash? (car l)) + ;; A hash table maps a collection-name symbol + ;; to a list of paths. We need to wrap each path + ;; in a box, because that's how the code below + ;; knows that it's a single collection's directory. + ;; A hash table can also map #f to a list of paths + ;; for directories that hold collections. + (append + (map box (hash-ref (car l) sym null)) + (hash-ref (car l) #f null) + (loop (cdr l)))] + [else + (let ([ht (get-linked-collections (car l))]) + (append + ;; Table values are lists of paths and (box path)s, + ;; where a (box path) is a collection directory + ;; (instead of a directory containing collections). + (hash-ref ht sym null) + (hash-ref ht #f null) + (loop (cdr l))))])))) + (define (done p) + (if file-name (build-path p file-name) p)) + (define (*build-path-rep p c) + (if (path? p) + (build-path p c) + ;; box => from links table for c + (unbox p))) + (define (*directory-exists? orig p) + (if (path? orig) + (directory-exists? p) + ;; orig is box => from links table + #t)) + (define (to-string p) (if (path? p) (path->string p) p)) + + (let cloop ([paths all-paths] [found-col #f]) + (if (null? paths) + (if found-col + (done found-col) + (let ([rest-coll + (if (null? collection-path) + "" + (apply + string-append + (let loop ([cp collection-path]) + (if (null? (cdr cp)) + (list (to-string (car cp))) + (list* (to-string (car cp)) "/" (loop (cdr cp)))))))]) + (define-values (filter) + (lambda (f l) + (if (null? l) + null + (if (f (car l)) + (cons (car l) (filter f (cdr l))) + (filter f (cdr l)))))) + (fail + (format "collection not found\n collection: ~s\n in collection directories:~a~a" + (if (null? collection-path) + (to-string collection) + (string-append (to-string collection) "/" rest-coll)) + (apply + string-append + (map (lambda (p) + (format "\n ~a ~a" " " p)) + (let ([len (length all-paths)] + [clen (length (current-library-collection-paths))]) + (if ((- len clen) . < . 5) + all-paths + (append (current-library-collection-paths) + (list (format "... [~a additional linked and package directories]" + (- len clen)))))))) + (if (ormap box? all-paths) + (format "\n sub-collection: ~s\n in parent directories:~a" + rest-coll + (apply + string-append + (map (lambda (p) + (format "\n ~a" (unbox p))) + (filter box? all-paths)))) + ""))))) + (let ([dir (*build-path-rep (car paths) collection)]) + (if (*directory-exists? (car paths) dir) + (let ([cpath (apply build-path dir collection-path)]) + (if (if (null? collection-path) + #t + (directory-exists? cpath)) + (if file-name + (if (or (file-exists?/maybe-compiled cpath file-name + check-compiled?) + (let ([alt-file-name + (let* ([file-name (if (path? file-name) + (path->string file-name) + file-name)] + [len (string-length file-name)]) + (and (len . >= . 4) + (string=? ".rkt" (substring file-name (- len 4))) + (string-append (substring file-name 0 (- len 4)) ".ss")))]) + (and alt-file-name + (file-exists?/maybe-compiled cpath alt-file-name + check-compiled?)))) + (done cpath) + ;; Look further for specific file, but remember + ;; first found directory + (cloop (cdr paths) (or found-col cpath))) + ;; Just looking for dir; found it: + (done cpath)) + ;; sub-collection not here; try next instance + ;; of the top-level collection + (cloop (cdr paths) found-col))) + (cloop (cdr paths) found-col)))))) + +(define (file-exists?/maybe-compiled dir path check-compiled?) + (or (file-exists? (build-path dir path)) + (and check-compiled? + (let ([try-path (path-add-extension path #".zo")] + [modes (use-compiled-file-paths)] + [roots (current-compiled-file-roots)]) + (ormap (lambda (d) + (ormap (lambda (mode) + (file-exists? + (let ([p (build-path dir mode try-path)]) + (cond + [(eq? d 'same) p] + [(relative-path? d) (build-path p d)] + [else (reroot-path p d)])))) + modes)) + roots))))) + +(define (find-library-collection-paths [extra-collects-dirs null] [post-collects-dirs null]) + (let ([user-too? (use-user-specific-search-paths)] + [cons-if (lambda (f r) (if f (cons f r) r))] + [config-table (get-config-table (find-main-config))]) + (path-list-string->path-list + (if user-too? + (let ([c (environment-variables-ref (current-environment-variables) + #"PLTCOLLECTS")]) + (if c + (bytes->string/locale c #\?) + "")) + "") + (add-config-search + config-table + 'collects-search-dirs + (cons-if + (and user-too? + (build-path (find-system-path 'addon-dir) + (get-installation-name config-table) + "collects")) + (let loop ([l (append + extra-collects-dirs + (list (find-system-path 'collects-dir)) + post-collects-dirs)]) + (if (null? l) + null + (let* ([collects-path (car l)] + [v (exe-relative-path->complete-path collects-path)]) + (if v + (cons (simplify-path (path->complete-path v (current-directory))) + (loop (cdr l))) + (loop (cdr l))))))))))) diff -Nru racket-6.12+ppa1/src/expander/eval/direct.rkt racket-7.0+ppa1/src/expander/eval/direct.rkt --- racket-6.12+ppa1/src/expander/eval/direct.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/direct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,75 @@ +#lang racket/base +(require "../common/phase.rkt" + "../common/module-path.rkt" + "../syntax/scope.rkt" + "../syntax/module-binding.rkt" + "../expand/parsed.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../host/linklet.rkt" + "protect.rkt") + +;; Instead of going through all the work to compile, optimize, and +;; evaluate a compile-time expression, it might be easier and faster +;; to evaluate the expression directly. + +(provide can-direct-eval? + direct-eval) + +(define not-available (gensym 'not-available)) +(define (get-not-available) not-available) + +(define (can-direct-eval? p ns self-mpi) + (cond + [(parsed-app? p) + (and (can-direct-eval? (parsed-app-rator p) ns self-mpi) + (for/and ([r (in-list (parsed-app-rands p))]) + (can-direct-eval? r ns self-mpi)))] + [(parsed-id? p) (not (eq? (get-id-value p ns self-mpi) not-available))] + [(parsed-quote? p) #t] + [(parsed-quote-syntax? p) #t] + [else #f])) + +(define (direct-eval p ns self-mpi) + (cond + [(parsed-app? p) + (apply (direct-eval (parsed-app-rator p) ns self-mpi) + (for/list ([r (in-list (parsed-app-rands p))]) + (direct-eval r ns self-mpi)))] + [(parsed-id? p) (get-id-value p ns self-mpi)] + [(parsed-quote? p) (parsed-quote-datum p)] + [(parsed-quote-syntax? p) (parsed-quote-syntax-datum p)] + [else #f])) + +;; Return `not-available` if the value is not readily available. +(define (get-id-value p ns self-mpi) + (define b (parsed-id-binding p)) + (cond + [(parsed-primitive-id? p) + (hash-ref (primitive-table '#%kernel) + (module-binding-sym b) + get-not-available)] + [(or (parsed-top-id? p) + (not b) + (eq? self-mpi (module-binding-module b))) + (namespace-get-variable + ns + (if b (module-binding-phase b) (namespace-phase ns)) + (if b (module-binding-sym b) (syntax-e (parsed-s p))) + get-not-available)] + [else + (define mi + (namespace->module-instance ns + (module-path-index-resolve (module-binding-module b)) + (phase- (namespace-phase ns) (module-binding-phase b)))) + (cond + [(not mi) not-available] + [(check-single-require-access mi + (module-binding-phase b) + (module-binding-sym b) + (module-binding-extra-inspector b)) + (namespace-get-variable (module-instance-namespace mi) + (module-binding-phase b) + (module-binding-sym b) + get-not-available)] + [else not-available])])) diff -Nru racket-6.12+ppa1/src/expander/eval/dynamic-require.rkt racket-7.0+ppa1/src/expander/eval/dynamic-require.rkt --- racket-6.12+ppa1/src/expander/eval/dynamic-require.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/dynamic-require.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,131 @@ +#lang racket/base +(require "../common/phase.rkt" + "../common/contract.rkt" + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../namespace/api.rkt" + "main.rkt") + +(provide dynamic-require + dynamic-require-for-syntax + default-dynamic-require-fail-thunk) + +(define (do-dynamic-require who mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (unless (or (module-path? mod-path) + (module-path-index? mod-path) + (resolved-module-path? mod-path)) + (raise-argument-error who + "(or/c module-path? module-path-index? resolved-module-path?)" + mod-path)) + (unless (or (symbol? sym) + (not sym) + (equal? sym 0) + (void? sym)) + (raise-argument-error who "(or/c symbol? #f 0 void?)" sym)) + (unless (and (procedure? fail-k) (procedure-arity-includes? fail-k 0)) + (raise-argument-error who "(-> any)" fail-k)) + (define ns (current-namespace)) + (define mpi + (cond + [(module-path? mod-path) (module-path-index-join mod-path #f)] + [(module-path-index? mod-path) mod-path] + [else (module-path-index-join (resolved-module-path->module-path mod-path) #f)])) + (define mod-name (module-path-index-resolve mpi #t)) + (define phase (namespace-phase ns)) + ;; Dispatch to the variant of `dynamic-require` that is determined + ;; by the second argument: + (cond + [(not sym) + ;; Run phase 0; don't visit or make available + (namespace-module-instantiate! ns mpi phase #:run-phase phase + #:otherwise-available? #f)] + [(equal? sym 0) + ;; Run phase 0, also make available + (namespace-module-instantiate! ns mpi phase #:run-phase phase)] + [(void? sym) + ;; Just visit + (namespace-module-visit! ns mpi phase #:visit-phase phase)] + [else + ;; Extract a particular value via phase 0.... + (define m (namespace->module ns mod-name)) + (unless m (raise-unknown-module-error 'dynamic-require mod-name)) + (define binding/p (hash-ref (hash-ref (module-provides m) 0 #hasheq()) + sym + #f)) + (cond + [(not binding/p) + (if (eq? fail-k default-dynamic-require-fail-thunk) + (raise-arguments-error 'dynamic-require + "name is not provided" + "name" sym + "module" mod-name) + (fail-k))] + [else + ;; The provided binding may correspond to an immediate provide, + ;; or it may by re-provided from a different module + (define binding (provided-as-binding binding/p)) + (define ex-sym (module-binding-sym binding)) + (define ex-phase (module-binding-phase binding)) + (namespace-module-instantiate! ns mpi phase #:run-phase phase + #:otherwise-available? #f) + (define ex-mod-name (module-path-index-resolve + (module-path-index-shift + (module-binding-module binding) + (module-self m) + mpi))) + (define m-ns (namespace->module-namespace ns ex-mod-name (phase- phase ex-phase) + #:complain-on-failure? #t)) + ;; Before continuing, make sure that we're allowed to access the binding + (define ex-m (namespace->module ns ex-mod-name)) + (define access (or (module-access ex-m) (module-compute-access! ex-m))) + (when (and (not (eq? 'provided (hash-ref (hash-ref access ex-phase #hasheq()) ex-sym #f))) + (and (not (inspector-superior? (current-code-inspector) (namespace-inspector m-ns))) + (not (and (module-binding-extra-inspector binding) + (inspector-superior? (module-binding-extra-inspector binding) + (namespace-inspector m-ns)))))) + (raise-arguments-error 'dynamic-require + "name is protected" + "name" sym + "module" mod-name)) + (define (fail) + (if (eq? fail-k default-dynamic-require-fail-thunk) + (raise-arguments-error 'dynamic-require + "name's binding is missing" + "name" sym + "module" mod-name) + (fail-k))) + (cond + [(not (provided-as-transformer? binding/p)) + (namespace-get-variable m-ns ex-phase ex-sym fail)] + [else + (define missing (gensym 'missing)) + (namespace-module-visit! ns mpi phase #:visit-phase phase) + (define t (namespace-get-transformer m-ns ex-phase ex-sym missing)) + (cond + [(eq? t missing) + (fail)] + [else + ;; Found transformer; expand in a fresh namespace + (define tmp-ns (new-namespace ns)) + (define mod-path (resolved-module-path->module-path mod-name)) + (namespace-require mod-path tmp-ns) + (parameterize ([current-namespace tmp-ns]) + (eval sym tmp-ns))])])])])) + +;; The `dynamic-require` function cheats by recognizing this failure +;; thunk and substituting a more specific error: +(define (default-dynamic-require-fail-thunk) + (error "failed")) + +(define/who (dynamic-require mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (do-dynamic-require who mod-path sym fail-k)) + +(define/who (dynamic-require-for-syntax mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (parameterize ([current-namespace + (let ([ns (current-namespace)]) + (namespace->namespace-at-phase ns (add1 (namespace-phase ns))))]) + (do-dynamic-require who mod-path sym fail-k))) diff -Nru racket-6.12+ppa1/src/expander/eval/load.rkt racket-7.0+ppa1/src/expander/eval/load.rkt --- racket-6.12+ppa1/src/expander/eval/load.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/load.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,70 @@ +#lang racket/base +(require racket/private/check + racket/private/executable-path + "module.rkt" + "parameter.rkt") + +(provide load + load-extension + load/use-compiled + embedded-load) + +(define/who (load s) + (check who path-string? s) + (define p (->path s)) + (call-with-current-load-relative-directory + p + (lambda () + ((current-load) p #f)))) + +(define/who (load-extension s) + (check who path-string? s) + (define p (->path s)) + (call-with-current-load-relative-directory + p + (lambda () + ((current-load-extension) p #f)))) + +(define (call-with-current-load-relative-directory p thunk) + (define-values (base name dir?) (split-path p)) + (parameterize ([current-load-relative-directory + (if (eq? base 'relative) + (current-directory) + (path->complete-path base))]) + (thunk))) + +;; ---------------------------------------- + +(define/who (load/use-compiled f) + (check who path-string? f) + (define p (->path f)) + ((current-load/use-compiled) p #f)) + +;; used for the -k command-line argument: +(define (embedded-load start end str as-predefined?) + (let* ([s (if str + str + (let* ([sp (find-system-path 'exec-file)] + [exe (find-executable-path sp #f)] + [start (or (string->number start) 0)] + [end (or (string->number end) 0)]) + (with-input-from-file exe + (lambda () + (file-position (current-input-port) start) + (read-bytes (max 0 (- end start)))))))] + [p (open-input-bytes s)]) + (let loop () + (let ([e (parameterize ([read-accept-compiled #t] + [read-accept-reader #t] + [read-accept-lang #t] + [read-on-demand-source #t]) + (read p))]) + (unless (eof-object? e) + (parameterize ([current-module-declare-as-predefined as-predefined?]) + ((current-eval) e)) + (loop)))))) + +;; ---------------------------------------- + +(define (->path s) + (if (string? s) (string->path s) s)) diff -Nru racket-6.12+ppa1/src/expander/eval/main.rkt racket-7.0+ppa1/src/expander/eval/main.rkt --- racket-6.12+ppa1/src/expander/eval/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,405 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + (only-in "../syntax/taint.rkt" + [syntax-disarm raw:syntax-disarm] + [syntax-rearm raw:syntax-rearm]) + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/core.rkt" + "../common/phase.rkt" + "../syntax/match.rkt" + "../expand/context.rkt" + (rename-in "../expand/main.rkt" [expand expand-in-context]) + "../compile/main.rkt" + "../compile/compiled-in-memory.rkt" + "top.rkt" + "module.rkt" + "../common/module-path.rkt" + "../host/linklet.rkt" + "../syntax/bulk-binding.rkt" + "../common/contract.rkt" + "../namespace/api.rkt" + "../expand/lift-context.rkt" + "../expand/require.rkt" + "../expand/require+provide.rkt" + "reflect.rkt" + "../expand/log.rkt" + "../expand/parsed.rkt" + "../common/performance.rkt") + +(provide eval + compile + expand + expand-once + expand-to-top-form + + compile-to-linklets) + +;; This `eval` is suitable as an eval handler that will be called by +;; the `eval` and `eval-syntax` of '#%kernel. +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (eval s [ns (current-namespace)] [compile (lambda (s ns) + (compile s ns #f))]) + (cond + [(or (compiled-in-memory? s) + (linklet-directory? s) + (linklet-bundle? s)) + (eval-compiled s ns)] + [(and (syntax? s) + (or (compiled-in-memory? (syntax-e s)) + (linklet-directory? (syntax-e s)) + (linklet-bundle? (syntax-e s)))) + (eval-compiled (syntax->datum s) ns)] + [else + (per-top-level s ns + #:single (lambda (s ns tail?) + (eval-compiled (compile s ns) ns tail?)) + #:observer #f)])) + +(define (eval-compiled c ns [as-tail? #t]) + (cond + [(compiled-module-expression? c) + (eval-module c #:namespace ns)] + [else + (eval-top c ns eval-compiled as-tail?)])) + +;; This `compile` is suitable as a compile handler that will be called +;; by the `compile` and `compile-syntax` of '#%kernel +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (compile s [ns (current-namespace)] [serializable? #t] [expand expand] [to-source? #f]) + ;; The given `s` might be an already-compiled expression because it + ;; went through some strange path, such as a `load` on a bytecode + ;; file, which would wrap `#%top-interaction` around the compiled + ;; expression where the expansion just discards the wrapper + (define cs + (cond + [(compiled-expression? s) (list s)] + [(and (syntax? s) + (compiled-expression? (syntax-e s))) + (list (syntax-e s))] + [else + (per-top-level s ns + #:single (lambda (s ns as-tail?) + (list (compile-single s ns expand + serializable? + to-source?))) + #:combine append + #:observer #f)])) + (if (and (= 1 (length cs)) + (not (compiled-multiple-top? (car cs)))) + (car cs) + (compiled-tops->compiled-top cs + #:to-source? to-source? + #:merge-serialization? serializable? + #:namespace ns))) + +;; Result is a hash table containing S-expressons that may have +;; "correlated" parts in the sense of "host/correlate.rkt"; use +;; `datum->correlated` plus `correlated->datum` to get a plain +;; S-expression +(define (compile-to-linklets s [ns (current-namespace)]) + (compile s ns #t expand #t)) + +;; To communicate lifts from `expand-single` to `compile-single`: +(struct lifted-parsed-begin (seq last)) + +(define (compile-single s ns expand serializable? to-source?) + (define exp-s (expand s ns #f #t serializable?)) + (let loop ([exp-s exp-s]) + (cond + [(parsed-module? exp-s) + (compile-module exp-s (make-compile-context #:namespace ns) + #:serializable? serializable? + #:to-source? to-source?)] + [(lifted-parsed-begin? exp-s) + ;; expansion must have captured lifts + (compiled-tops->compiled-top + (for/list ([e (in-list (append (lifted-parsed-begin-seq exp-s) + (list (lifted-parsed-begin-last exp-s))))]) + (loop e)) + #:to-source? to-source?)] + [else + (compile-top exp-s (make-compile-context #:namespace ns) + #:serializable? serializable? + #:to-source? to-source?)]))) + +;; This `expand` is suitable as an expand handler (if such a thing +;; existed) to be called by `expand` and `expand-syntax`. +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (expand s [ns (current-namespace)] [observable? #f] [to-parsed? #f] [serializable? #f]) + (define observer (and observable? (current-expand-observe))) + (when observer (...log-expand observer ['start-top])) + (parameterize ((current-expand-observe #f)) + (per-top-level s ns + #:single (lambda (s ns as-tail?) (expand-single s ns observer to-parsed? serializable?)) + #:combine cons + #:wrap re-pair + #:observer observer))) + +(define (expand-single s ns observer to-parsed? serializable?) + (define rebuild-s (keep-properties-only s)) + (define ctx (make-expand-context ns + #:to-parsed? to-parsed? + #:for-serializable? serializable? + #:observer observer)) + (define-values (require-lifts lifts exp-s) (expand-capturing-lifts s ctx)) + (cond + [(and (null? require-lifts) (null? lifts)) exp-s] + [to-parsed? + (wrap-lifts-as-lifted-parsed-begin require-lifts + lifts + exp-s rebuild-s + #:adjust-form (lambda (form) + (expand-single form ns observer to-parsed? serializable?)))] + [else + (log-top-lift-begin-before ctx require-lifts lifts exp-s ns) + (define new-s + (wrap-lifts-as-begin (append require-lifts lifts) + #:adjust-form (lambda (form) + (log-expand ctx 'next) + (expand-single form ns observer to-parsed? serializable?)) + #:adjust-body (lambda (form) + (cond + [to-parsed? form] + [else + (log-expand ctx 'next) + ;; This re-expansion should be unnecessary, but we do it + ;; for a kind of consistentcy with `expand/capture-lifts` + ;; and for expansion observers + (expand-single form ns observer to-parsed? serializable?)])) + exp-s + (namespace-phase ns))) + (log-top-begin-after ctx new-s) + new-s])) + +(define (expand-once s [ns (current-namespace)]) + (per-top-level s ns + #:single (lambda (s ns as-tail?) (expand-single-once s ns)) + #:combine cons + #:wrap re-pair + #:just-once? #t + #:observer #f)) + +(define (expand-single-once s ns) + (define-values (require-lifts lifts exp-s) + (expand-capturing-lifts s (struct*-copy expand-context (make-expand-context ns) + [just-once? #t]))) + (cond + [(and (null? require-lifts) (null? lifts)) exp-s] + [else + (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + (namespace-phase ns))])) + +(define (expand-to-top-form s [ns (current-namespace)]) + ;; Use `per-top-level` for immediate expansion and lift handling, + ;; but `#:single #f` makes it return immediately + (define observer (current-expand-observe)) + (when observer (...log-expand observer ['start-top])) + (parameterize ((current-expand-observe #f)) + (per-top-level s ns + #:single #f + #:quick-immediate? #f + #:observer observer))) + +;; ---------------------------------------- + +;; Top-level compilation and evaluation, which involves partial +;; expansion to detect `begin` and `begin-for-syntax` to interleave +;; expansions +(define (per-top-level given-s ns + #:single single ; handle discovered form; #f => stop after immediate + #:combine [combine #f] ; how to cons a recur result, or not + #:wrap [wrap #f] ; how to wrap a list of recur results, or not + #:just-once? [just-once? #f] ; single expansion step + #:quick-immediate? [quick-immediate? #t] + #:serializable? [serializable? #f] ; for module+submodule expansion + #:observer observer) + (define s (maybe-intro given-s ns)) + (define ctx (make-expand-context ns #:observer observer)) + (define phase (namespace-phase ns)) + (let loop ([s s] [phase phase] [ns ns] [as-tail? #t]) + (define tl-ctx (struct*-copy expand-context ctx + [phase phase] + [namespace ns] + [just-once? just-once?] + [for-serializable? serializable?])) + (define wb-s (and just-once? s)) + (log-expand tl-ctx 'visit s) + (define-values (require-lifts lifts exp-s) + (expand-capturing-lifts s (struct*-copy expand-context tl-ctx + [only-immediate? #t] + [phase phase] + [namespace ns]))) + (define disarmed-exp-s (raw:syntax-disarm exp-s)) + (cond + [(or (pair? require-lifts) (pair? lifts)) + ;; Fold in lifted definitions and try again + (define new-s (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + phase)) + (log-expand tl-ctx 'lift-loop new-s) + (if just-once? + new-s + (loop new-s phase ns as-tail?))] + [(not single) + (log-expand tl-ctx 'return exp-s) + exp-s] + [(and just-once? (not (eq? exp-s wb-s))) exp-s] + [else + (case (core-form-sym disarmed-exp-s phase) + [(begin) + (log-expand ctx 'prim-begin) + (define-match m disarmed-exp-s '(begin e ...)) + ;; Map `loop` over the `e`s, but in the case of `eval`, + ;; tail-call for last one: + (define (begin-loop es) + (cond + [(null? es) (if combine null (void))] + [(and (not combine) (null? (cdr es))) + (loop (car es) phase ns as-tail?)] + [else + (log-expand tl-ctx 'next) + (define a (if combine + (loop (car es) phase ns #f) + (begin + ;; Allow any number of results: + (loop (car es) phase ns #f) + (void)))) + (if combine + (combine a (begin-loop (cdr es))) + (begin-loop (cdr es)))])) + (cond + [wrap + (define new-s (wrap (m 'begin) exp-s (begin-loop (m 'e)))) + (log-expand tl-ctx 'return new-s) + new-s] + [else (begin-loop (m 'e))])] + [(begin-for-syntax) + (log-expand tl-ctx 'prim-begin-for-syntax) + (define-match m disarmed-exp-s '(begin-for-syntax e ...)) + (define next-phase (add1 phase)) + (define next-ns (namespace->namespace-at-phase ns next-phase)) + (log-expand tl-ctx 'prepare-env) + (when quick-immediate? + ;; In case `expand-capturing-lifts` didn't already: + (namespace-visit-available-modules! ns)) + (namespace-visit-available-modules! next-ns) ; to match old behavior for empty body + (define l + (for/list ([s (in-list (m 'e))]) + (log-expand tl-ctx 'next) + (loop s next-phase next-ns #f))) + (cond + [wrap + (define new-s (wrap (m 'begin-for-syntax) exp-s l)) + (log-expand tl-ctx 'return new-s) + new-s] + [combine (apply append l)] + [else (void)])] + [else + (single exp-s ns as-tail?)])]))) + +;; Add scopes to `s` if it's not syntax: +(define (maybe-intro s ns) + (if (syntax? s) + s + (namespace-syntax-introduce (datum->syntax #f s) ns))) + +(define (re-pair form-id s r) + (raw:syntax-rearm + (datum->syntax (raw:syntax-disarm s) + (cons form-id r) + s + s) + s)) + +;; ---------------------------------------- + +(define (expand-capturing-lifts s ctx) + (performance-region + ['expand 'top] + + (define ns (expand-context-namespace ctx)) + (namespace-visit-available-modules! ns) + + (define lift-ctx (make-lift-context (make-top-level-lift ctx))) + (define require-lift-ctx (make-require-lift-context + (namespace-phase ns) + (make-parse-top-lifted-require ns))) + (define exp-s + (expand-in-context s (struct*-copy expand-context ctx + [lifts lift-ctx] + [module-lifts lift-ctx] + [require-lifts require-lift-ctx]))) + (values (get-and-clear-require-lifts! require-lift-ctx) + (get-and-clear-lifts! lift-ctx) + exp-s))) + +(define (make-parse-top-lifted-require ns) + (lambda (s phase) + ;; We don't "hide" this require in the same way as + ;; a top-level `#%require`, because it's already + ;; hidden in the sense of having an extra scope + (define-match m (raw:syntax-disarm s) '(#%require req)) + (parse-and-perform-requires! (list (m 'req)) s + ns phase #:run-phase phase + (make-requires+provides #f) + #:who 'require))) + +(define (wrap-lifts-as-lifted-parsed-begin require-lifts + lifts + exp-s rebuild-s + #:adjust-form adjust-form) + (lifted-parsed-begin (append + (for/list ([req (in-list require-lifts)]) + (parsed-require req)) + (for/list ([ids+syms+rhs (in-list (get-lifts-as-lists lifts))]) + (define exp-rhs (adjust-form (caddr ids+syms+rhs))) + (define just-rhs (if (lifted-parsed-begin? exp-rhs) + (lifted-parsed-begin-last exp-rhs) + exp-rhs)) + (define dv + (parsed-define-values rebuild-s + (car ids+syms+rhs) + (cadr ids+syms+rhs) + just-rhs)) + (if (lifted-parsed-begin? exp-rhs) + (struct-copy lifted-parsed-begin exp-rhs + [last dv]) + dv))) + exp-s)) + +(define (log-top-lift-begin-before ctx require-lifts lifts exp-s ns) + (log-expand... + ctx + (lambda (obs) + (define new-s (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + (namespace-phase ns))) + (...log-expand obs ['lift-loop new-s]) + (log-top-begin-before ctx new-s)))) + +(define (log-top-begin-before ctx new-s) + (log-expand... + ctx + (lambda (obs) + (define-match m new-s '(begin e ...)) + (...log-expand obs + ['visit new-s] ['resolve (m 'begin)] + ['enter-prim new-s] ['prim-begin] + ['enter-list (datum->syntax #f (m 'e) new-s)])))) + +(define (log-top-begin-after ctx new-s) + (log-expand... + ctx + (lambda (obs) + (define-match m new-s '(begin e ...)) + (log-expand* ctx + ['exit-list (datum->syntax #f (m 'e) new-s)] + ['exit-prim new-s] + ['return new-s])))) diff -Nru racket-6.12+ppa1/src/expander/eval/module-cache.rkt racket-7.0+ppa1/src/expander/eval/module-cache.rkt --- racket-6.12+ppa1/src/expander/eval/module-cache.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/module-cache.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base + +;; The module cache lets us avoid reloading ".zo" files when +;; we have the relevant data handy in memory. The "eval/module.rkt" +;; module installs entries, and the default load handler in +;; "boot/load-handler.rkt" consults the cache. + +(provide make-module-cache-key + module-cache-set! + module-cache-ref) + +(define module-cache (make-weak-hasheq)) + +(define (make-module-cache-key hash-code) + ;; The result is preserved to retain the cache entry, and + ;; found in `module-cache-ref` by `equal?` comparsion. + ;; The current load-relative directory is part of the + ;; key because the bytecode form can have bulk bindings + ;; in syntax objects that refer to `require`s that are + ;; relative to the enclosing module, and that part of + ;; the syntax object is unmarshaled once and used for + ;; all instances of the module. + (and hash-code + ;; Encode as a symbol so we can use an eq?-based hash table + ;; (i.e., explot the low-level lock on the symbol table) + (string->symbol (format "~s" (list hash-code (current-load-relative-directory)))))) + +(define (module-cache-set! key proc) + (hash-set! module-cache key (make-ephemeron key proc))) + +(define (module-cache-ref key) + (define e (hash-ref module-cache key #f)) + (and e (ephemeron-value e))) diff -Nru racket-6.12+ppa1/src/expander/eval/module-read.rkt racket-7.0+ppa1/src/expander/eval/module-read.rkt --- racket-6.12+ppa1/src/expander/eval/module-read.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/module-read.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,67 @@ +#lang racket/base +(require "../syntax/api.rkt" + "main.rkt" + "reflect.rkt" + "../namespace/api.rkt" + "../read/primitive-parameter.rkt") + +(provide with-module-reading-parameterization + raise-wrong-module-name + check-module-form) + +(define (with-module-reading-parameterization thunk) + (parameterize ([read-accept-reader #t] + [read-accept-lang #t] + [read-accept-compiled #t] + ;; Would be set by `call-with-default-reading-parameterization`, + ;; but we need to set them in our own reader, not the host's: + [read-case-sensitive #t] + [read-square-bracket-as-paren #t] + [read-curly-brace-as-paren #t] + [read-square-bracket-with-tag #f] + [read-curly-brace-with-tag #f] + [read-accept-box #t] + [read-accept-bar-quote #t] + [read-accept-graph #t] + [read-decimal-as-inexact #t] + [read-cdot #f] + [read-accept-dot #t] + [read-accept-infix-dot #t] + [read-accept-quasiquote #t] + [current-readtable #f]) + (thunk))) + +(define (raise-wrong-module-name filename expected-name name) + (error 'load-handler + "expected a `module' declaration for `~a' in ~s, found: ~a" + expected-name filename name)) + +(define (check-module-form exp filename) + (cond [(or (eof-object? exp) (eof-object? (syntax-e exp))) + (and filename + (error 'load-handler + (string-append "expected a `module' declaration, but found end-of-file\n" + " file: ~a") + filename))] + [(compiled-module-expression? (syntax-e exp)) + ;; It's fine: + exp] + [(and (syntax? exp) + (pair? (syntax-e exp)) + (eq? 'module (syntax-e (car (syntax-e exp)))) + (let* ([r (cdr (syntax-e exp))] + [r (if (syntax? r) (syntax-e r) r)]) + (and (pair? r) + (identifier? (car r))))) + ;; It's ok; need to install a specific `module' binding: + (datum->syntax exp + (cons (namespace-module-identifier) + (cdr (syntax-e exp))) + exp + exp)] + [else + (and filename + (error 'default-load-handler + (string-append "expected a `module' declaration, but found something else\n" + " file: ~a") + filename))])) diff -Nru racket-6.12+ppa1/src/expander/eval/module.rkt racket-7.0+ppa1/src/expander/eval/module.rkt --- racket-6.12+ppa1/src/expander/eval/module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,401 @@ +#lang racket/base +(require racket/promise + "../common/performance.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/inspector.rkt" + "../common/phase.rkt" + "../compile/module-use.rkt" + "../compile/reserved-symbol.rkt" + "../common/module-path.rkt" + "../compile/serialize.rkt" + "../host/linklet.rkt" + "../compile/instance.rkt" + "../compile/compiled-in-memory.rkt" + "../expand/context.rkt" + "../expand/root-expand-context.rkt" + "root-context.rkt" + "protect.rkt" + "module-cache.rkt") + +;; Run a representation of top-level code as produced by `compile-module`; +;; see "compile/main.rkt" and "compile/module.rkt" + +(provide eval-module + compiled-module->declaration-instance + compiled-module->h+declaration-instance + compiled-module->h + current-module-declare-as-predefined) + +;; Modules that are defined via `embedded-load` can be "predefined", +;; because they can be defined in every place as the embedded load +;; is replayed in each place +(define current-module-declare-as-predefined (make-parameter #f)) + +(define (eval-module c + #:namespace [ns (current-namespace)] + #:with-submodules? [with-submodules? #t] + #:supermodule-name [supermodule-name #f]) ; for submodules declared with module + (performance-region + ['eval 'module] + + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + + (define syntax-literals-data-instance + (if (compiled-in-memory? c) + (make-syntax-literal-data-instance-from-compiled-in-memory c) + (let ([l (hash-ref h 'stx-data #f)]) + (cond + [l (instantiate-linklet (eval-linklet l) + (list deserialize-instance + data-instance))] + [(eq? (hash-ref h 'module->namespace #f) 'empty) + empty-syntax-literals-instance/empty-namespace] + [else + empty-syntax-literals-data-instance])))) + + (define (decl key) + (instance-variable-value declaration-instance key)) + + (define pre-submodule-names (hash-ref h 'pre null)) + (define post-submodule-names (hash-ref h 'post null)) + (define default-name (hash-ref h 'name 'module)) + + (define cache-key (make-module-cache-key + (and + ;; We expect a hash code only for a module + ;; loaded independently from its submodules: + (null? pre-submodule-names) + (null? post-submodule-names) + (hash-ref h 'hash-code #f)))) + + (define cross-phase-persistent? (hash-ref h 'cross-phase-persistent? #f)) + (define min-phase (hash-ref h 'min-phase 0)) + (define max-phase (hash-ref h 'max-phase 0)) + (define language-info (hash-ref h 'language-info #f)) + + ;; Evaluate linklets, so that they're JITted just once (on demand). + ;; Also, filter the bundle hash to just the phase-specific linklets, so that + ;; we don't retain other info --- especially the syntax-literals linklet. + (define phases-h (for*/hash ([phase-level (in-range min-phase (add1 max-phase))] + [v (in-value (hash-ref h phase-level #f))] + #:when v) + (values phase-level (eval-linklet v)))) + (define syntax-literals-linklet (let ([l (hash-ref h 'stx #f)]) + (and l (eval-linklet l)))) + + (define extra-inspector (and (compiled-in-memory? c) + (compiled-in-memory-compile-time-inspector c))) + (define phase-to-link-extra-inspectorsss + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-extra-inspectorsss c) + #hasheqv())) + + (define requires (decl 'requires)) + (define provides (decl 'provides)) + (define original-self (decl 'self-mpi)) + (define phase-to-link-modules (decl 'phase-to-link-modules)) + + (define create-root-expand-context-from-module ; might be used to create root-expand-context + (make-create-root-expand-context-from-module requires phases-h)) + + (define declare-submodules + ;; If there's no `dh`, then it's important not to retain a reference to + ;; `c`, which could cause the serialized form of syntax objects to + ;; be retained after deserialization and reachable from the module cache; + ;; if it's there's a `dh`, though, then we won't be in the module cache + (if dh + ;; Callback to declare submodules: + (lambda (ns names declare-name pre?) + (if (compiled-in-memory? c) + (for ([c (in-list (if pre? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c)))]) + (eval-module c #:namespace ns #:supermodule-name declare-name)) + (for ([name (in-list names)]) + (define sm-cd (hash-ref dh name #f)) + (unless sm-cd (error "missing submodule declaration:" name)) + (eval-module sm-cd #:namespace ns #:supermodule-name declare-name)))) + ;; Dummy callback to avoid retaining anything: + void)) + + ;; At this point, we've prepared everything anout the module that we + ;; can while staying independent of a specific declaration or + ;; specific instance. If we have a hash key for this module, we can + ;; stash `declare-this-module` for potential reuse later. + (define declare-this-module + (lambda (ns) ; namespace for declaration + (define m (make-module #:source-name (current-module-declare-source) + #:self original-self + #:requires requires + #:provides provides + #:language-info language-info + #:min-phase-level min-phase + #:max-phase-level max-phase + #:cross-phase-persistent? cross-phase-persistent? + #:predefined? (current-module-declare-as-predefined) + #:submodule-names (append pre-submodule-names post-submodule-names) + #:supermodule-name supermodule-name + #:get-all-variables (lambda () (get-all-variables phases-h)) + #:phase-level-linklet-info-callback + (lambda (phase-level ns insp) + (module-linklet-info (hash-ref phases-h phase-level #f) + (hash-ref phase-to-link-modules phase-level #f) + original-self + insp + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase-level #f))) + #:force-bulk-binding-callback + (lambda (bulk-binding-registry) + ;; Avoids a leak of some namespace's bulk-binding registry into the + ;; deserialized syntax of the module, but module caching can still allow + ;; a namespace's bulk-binding registry to get saved by the module's + ;; deserialized syntax. + (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry)) + #:prepare-instance-callback + (lambda (data-box ns phase-shift self bulk-binding-registry insp) + (unless (unbox data-box) + (init-instance-data! data-box cache-key ns + syntax-literals-linklet data-instance syntax-literals-data-instance + phase-shift original-self self bulk-binding-registry insp + create-root-expand-context-from-module))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (performance-region + ['eval 'instantiate] + (define syntax-literals-instance (instance-data-syntax-literals-instance + (unbox data-box))) + (define phase-linklet (hash-ref phases-h phase-level #f)) + + (when phase-linklet + (define module-uses (hash-ref phase-to-link-modules phase-level)) + (define-values (import-module-instances import-instances) + (for/lists (mis is) ([mu (in-list module-uses)]) + (namespace-module-use->module+linklet-instances + ns mu + #:shift-from original-self + #:shift-to self + #:phase-shift + (phase+ (phase- phase-level (module-use-phase mu)) + phase-shift)))) + + (check-require-access phase-linklet #:skip-imports 2 + module-uses import-module-instances insp + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase-level #f)) + + (define module-body-instance-instance + (make-module-body-instance-instance + #:set-transformer! (lambda (name val) + (namespace-set-transformer! ns (sub1 phase-level) name val)))) + + (define (instantiate-body) + (instantiate-linklet phase-linklet + (list* syntax-literals-instance + module-body-instance-instance + import-instances) + (namespace->instance ns phase-level))) + + (cond + [(zero-phase? phase-level) + (cond + [(zero-phase? phase-shift) + (instantiate-body)] + [else + ;; Need to set the current namespace so that it has the + ;; right phase + (parameterize ([current-namespace ns]) + (instantiate-body))])] + [else + ;; For phase level 1 and up, set the expansion context + ;; to point back to the module's info: + (define ns-1 (namespace->namespace-at-phase ns (phase+ phase-shift (sub1 phase-level)))) + (parameterize ([current-expand-context (delay (make-expand-context ns-1))] + [current-namespace ns] + [current-module-code-inspector insp]) + (instantiate-body))])))))) + + (define declare-name (substitute-module-declare-name default-name)) + + (when with-submodules? + (declare-submodules ns pre-submodule-names declare-name #t)) + + (declare-module! ns + m + declare-name + #:with-submodules? with-submodules?) + + (when with-submodules? + (declare-submodules ns post-submodule-names declare-name #f)))) + + ;; ---------------------------------------- + + ;; If we have a hash code, save the prepare module in the cache + ;; so it can be found by that hash code: + (when cache-key + (module-cache-set! cache-key declare-this-module)) + + (declare-this-module ns))) + +;; ---------------------------------------- + +;; Value in a declaration's `data-box`: +(struct instance-data (syntax-literals-instance cache-key)) + +(define (init-instance-data! data-box cache-key ns + syntax-literals-linklet data-instance syntax-literals-data-instance + phase-shift original-self self bulk-binding-registry insp + create-root-expand-context-from-module) + (when (not (load-on-demand-enabled)) + (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry)) + + (define inst + (make-instance-instance + #:namespace ns + #:phase-shift phase-shift + #:self self + #:inspector insp + #:bulk-binding-registry bulk-binding-registry + #:set-transformer! (lambda (name val) (error "shouldn't get here for the root-ctx linklet")))) + + (define syntax-literals-instance + (if syntax-literals-linklet + (instantiate-linklet syntax-literals-linklet + (list deserialize-instance + data-instance + syntax-literals-data-instance + inst)) + empty-syntax-literals-instance)) + + (set-box! data-box (instance-data syntax-literals-instance cache-key)) + + (define get-encoded-root-expand-ctx + (instance-variable-value syntax-literals-instance 'get-encoded-root-expand-ctx)) + + (cond + [(eq? get-encoded-root-expand-ctx 'empty) + ;; A `#:empty-namespace` declaration requested a namespace with no initial bindings + (namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context + (make-root-expand-context #:self-mpi self))))] + [(procedure? get-encoded-root-expand-ctx) + ;; Root expand context has been preserved; deserialize it on demand + (namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context + (root-expand-context-decode-for-module + (get-encoded-root-expand-ctx) + self))))] + [else + ;; Root expand context has not been preserved, because it can be reconstructed + ;; from module metadata; do that on demand + (namespace-set-root-expand-ctx! ns (delay (shift-to-inside-root-context + (create-root-expand-context-from-module + ns phase-shift original-self self))))])) + +;; ---------------------------------------- + +(define (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry) + (unless (or (eq? syntax-literals-data-instance empty-syntax-literals-data-instance) + (eq? syntax-literals-data-instance empty-syntax-literals-instance/empty-namespace)) + ;; Since on-demand loading is disabled, force deserialization + (let ([deserialize-syntax (instance-variable-value syntax-literals-data-instance deserialize-syntax-id)]) + ;; We need to make sure there's something to deserialize; if it's already done + ;; `deserialize-syntax` has been set to #f + (when deserialize-syntax + (deserialize-syntax bulk-binding-registry))))) + +;; ---------------------------------------- + +;; Returns: +;; +;; dh - hash from linklet directory to access submodules, or #f if +;; no submodules +;; +;; h - hash from the module's linklet bundle +;; +(define (compiled-module->dh+h c) + (define ld/h (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (define dh (cond + [(linklet-directory? ld/h) + ;; has submodules + (linklet-directory->hash ld/h)] + [else + ;; no submodules + #f])) + (define h (linklet-bundle->hash (if dh + (hash-ref dh #f) + ld/h))) + + (values dh h)) + +(define (compiled-module->h c) + (define-values (dh h) + (compiled-module->dh+h c)) + h) + +;; Additionally returns: +;; +;; data-instance - provides data, either extracted from +;; compiled-in-memory or instantiated from the bundle +;; +;; declaration-instance - provides metadata, extracted from the +;; bundle and linked with `data-instance` +(define (compiled-module->dh+h+data-instance+declaration-instance c) + (define-values (dh h) (compiled-module->dh+h c)) + + (define data-instance + (if (compiled-in-memory? c) + (make-data-instance-from-compiled-in-memory c) + (instantiate-linklet (eval-linklet (hash-ref h 'data)) + (list deserialize-instance)))) + + (define declaration-instance + (if (and (compiled-in-memory? c) + (compiled-in-memory-original-self c)) + (make-declaration-instance-from-compiled-in-memory c) + (instantiate-linklet (eval-linklet (hash-ref h 'decl)) + (list deserialize-instance + data-instance)))) + + (values dh h data-instance declaration-instance)) + +(define (compiled-module->declaration-instance c) + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + declaration-instance) + +(define (compiled-module->h+declaration-instance c) + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + (values h declaration-instance)) + +;; ---------------------------------------- + +(define (make-data-instance-from-compiled-in-memory cim) + (make-instance 'data #f 'constant + mpi-vector-id (compiled-in-memory-mpis cim))) + +(define (make-declaration-instance-from-compiled-in-memory cim) + (make-instance 'decl #f 'constant + 'self-mpi (compiled-in-memory-original-self cim) + 'requires (compiled-in-memory-requires cim) + 'provides (compiled-in-memory-provides cim) + 'phase-to-link-modules (compiled-in-memory-phase-to-link-module-uses cim))) + +(define (make-syntax-literal-data-instance-from-compiled-in-memory cim) + (make-instance 'syntax-literal-data #f #f + deserialize-syntax-id void + deserialized-syntax-vector-id (compiled-in-memory-syntax-literals cim))) + +(define empty-syntax-literals-instance/empty-namespace + (make-instance 'empty-stx/empty-ns #f 'constant + get-syntax-literal!-id (lambda (pos) #f) + 'get-encoded-root-expand-ctx 'empty)) + +;; ---------------------------------------- + +(define (get-all-variables phases-h) + (for/hash ([(phase linklet) (in-hash phases-h)]) + (values phase + (linklet-export-variables linklet)))) diff -Nru racket-6.12+ppa1/src/expander/eval/multi-top.rkt racket-7.0+ppa1/src/expander/eval/multi-top.rkt --- racket-6.12+ppa1/src/expander/eval/multi-top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/multi-top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,96 @@ +#lang racket/base +(require "../namespace/namespace.rkt" + "../compile/compiled-in-memory.rkt" + "../compile/serialize.rkt" + "../compile/eager-instance.rkt" + "../compile/reserved-symbol.rkt" + "../compile/namespace-scope.rkt" + "../compile/multi-top.rkt" + "../host/linklet.rkt") + +(provide create-compiled-in-memorys-using-shared-data) + +(define (create-compiled-in-memorys-using-shared-data tops data-linklet ns) + (define data-instance + (instantiate-linklet data-linklet + (list deserialize-instance + (make-eager-instance-instance + #:namespace ns + #:dest-phase (namespace-phase ns) + #:self (namespace-mpi ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:inspector (current-code-inspector))))) + + (define (data key) (instance-variable-value data-instance key)) + + (define mpi-vector (data mpi-vector-id)) + (define mpi-vector-trees (data 'mpi-vector-trees)) + (define phase-to-link-modules-vector (data 'phase-to-link-modules-vector)) + (define phase-to-link-modules-trees (data 'phase-to-link-modules-trees)) + (define syntax-literals (data 'syntax-literals)) + (define syntax-literals-trees (data 'syntax-literals-trees)) + + (define namespace-scopes (extract-namespace-scopes ns)) + + (define (construct-compiled-in-memory ld + mpi-vector-tree + phase-to-link-modules-tree + syntax-literals-tree) + (define is-module? (or (linklet-bundle? ld) + (let ([b (hash-ref (linklet-directory->hash ld) #f #f)]) + (and b (hash-ref (linklet-bundle->hash b) 'decl #f))))) + (define mpi-pos-vec (vector-ref mpi-vector-tree 0)) + (define syntax-literals-spec (vector-ref syntax-literals-tree 0)) + (define pres (if is-module? + (extract-submodules ld 'pre) + (compiled-top->compiled-tops ld))) + (define posts (if is-module? + (extract-submodules ld 'post) + null)) + (define (map-construct-compiled-in-memory l vec-pos) + (for/list ([sub-ld (in-list l)] + [mpi-vector-tree (in-list (vector-ref mpi-vector-tree vec-pos))] + [phase-to-link-modules-tree (in-list (vector-ref phase-to-link-modules-tree vec-pos))] + [syntax-literals-tree (in-list (vector-ref syntax-literals-tree vec-pos))]) + (construct-compiled-in-memory sub-ld + mpi-vector-tree + phase-to-link-modules-tree + syntax-literals-tree))) + (compiled-in-memory ld + #f ; self + #f ; requires + #f ; provides + (vector-ref phase-to-link-modules-vector (vector-ref phase-to-link-modules-tree 0)) + #f ; compile-time-inspector + #hasheqv() ; phase-to-link-extra-inspectorsss + (for/vector #:length (vector-length mpi-pos-vec) ([pos (in-vector mpi-pos-vec)]) + (vector-ref mpi-vector pos)) + (for/vector #:length (cdr syntax-literals-spec) ([i (in-range (cdr syntax-literals-spec))]) + (and syntax-literals + (vector-ref syntax-literals (+ (car syntax-literals-spec) i)))) + (map-construct-compiled-in-memory pres 1) + (map-construct-compiled-in-memory posts 2) + namespace-scopes + #f)) + + (map construct-compiled-in-memory + tops + mpi-vector-trees + phase-to-link-modules-trees + syntax-literals-trees)) + +;; ---------------------------------------- + +(define (extract-submodules ld names-key) + (cond + [(linklet-bundle? ld) + ;; no submodules + null] + [else + (define h (linklet-directory->hash ld)) + (define mod (hash-ref h #f #f)) + (unless mod (error "missing main module")) + (define mh (linklet-bundle->hash mod)) + (define names (hash-ref mh names-key null)) + (for/list ([name (in-list names)]) + (hash-ref h name (lambda () (error "missing submodule declaration:" name))))])) diff -Nru racket-6.12+ppa1/src/expander/eval/parameter.rkt racket-7.0+ppa1/src/expander/eval/parameter.rkt --- racket-6.12+ppa1/src/expander/eval/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,133 @@ +#lang racket/base +(require racket/private/check + "../common/module-path.rkt") + +(provide current-eval + current-compile + current-load + current-load/use-compiled + + current-library-collection-paths + current-library-collection-links + + use-compiled-file-paths + current-compiled-file-roots + use-compiled-file-check + use-collection-link-paths + use-user-specific-search-paths) + +(define (replace-me who) + (lambda args + (error who "this stub must be replaced"))) + +(define/who current-eval + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-compile + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-load + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-load/use-compiled + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-library-collection-paths + (make-parameter null + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap complete-path-string? l))) + #:contract "(listof (and/c path-string? complete-path?))" + l) + (map to-path l)))) + +(define/who current-library-collection-links + (make-parameter null + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap (lambda (p) + (or (not p) + (complete-path-string? p) + (and (hash? p) + (for/and ([(k v) (in-hash p)]) + (and (or (not k) + (and (symbol? k) (module-path? k))) + (list? v) + (andmap complete-path-string? v)))))) + l))) + + #:contract (string-append + "(listof (or/c #f\n" + " (and/c path-string? complete-path?)\n" + " (hash/c (or/c (and/c symbol? module-path?) #f)\n" + " (listof (and/c path-string? complete-path?)))))") + l) + (map (lambda (p) + (cond + [(not p) #f] + [(path? p) p] + [(string? p) (string->path p)] + [else + (for/hash ([(k v) (in-hash p)]) + (values k (to-path v)))])) + l)))) + +(define/who use-compiled-file-paths + (make-parameter (list (string->path "compiled")) + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap relative-path-string? l))) + #:contract "(listof (and/c path-string? relative-path?))" + l) + (map to-path l)))) + +(define/who current-compiled-file-roots + (make-parameter '(same) + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap (lambda (p) + (or (path-string? p) + (eq? p 'same))) + l))) + #:contract "(listof (or/c path-string? 'same))" + l) + (map to-path l)))) + +(define/who use-compiled-file-check + (make-parameter 'modify-seconds + (lambda (v) + (check who (lambda (v) (or (eq? v 'modify-seconds) (eq? v 'exists))) + #:contract "(or/c 'modify-seconds 'exists)" + v) + v))) + +(define use-collection-link-paths + (make-parameter #t (lambda (v) (and v #t)))) + +(define use-user-specific-search-paths + (make-parameter #t (lambda (v) (and v #t)))) + +(define (complete-path-string? p) + (and (path-string? p) (complete-path? p))) + +(define (relative-path-string? p) + (and (path-string? p) (relative-path? p))) + +(define (to-path p) + (if (string? p) (string->path p) p)) diff -Nru racket-6.12+ppa1/src/expander/eval/protect.rkt racket-7.0+ppa1/src/expander/eval/protect.rkt --- racket-6.12+ppa1/src/expander/eval/protect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/protect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,81 @@ +#lang racket/base +(require "../common/set.rkt" + "../host/linklet.rkt" + "../compile/module-use.rkt" + "../common/module-path.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../compile/extra-inspector.rkt") + +;; Inspectors guarded access to protected values at expansion time. We +;; run code that references portentially protected values, we have to +;; check again, in case the compiled form was synthesized or compiled +;; in a namespace with different protections. + +;; When programs are compiled and run in memory (i.e., without going +;; through serialization), we can trust the protections checked by the +;; expander --- and the access enabled by compiling from source may be +;; greater than enabled by serialized bytecode, because inspectors can +;; be tracked as values and changed at a finer granularity. In that +;; case, a `compiled-in-memory` record holds extra-inspector +;; information that is propagated to here. + +(provide check-require-access + check-single-require-access) + +(define (check-require-access linklet #:skip-imports skip-num-imports + import-module-uses import-module-instances insp + extra-inspector ; from declaration time + extra-inspectorsss) ; per imported variable; from compilation + (for ([import-syms (in-list (list-tail (linklet-import-variables linklet) skip-num-imports))] + [mu (in-list import-module-uses)] + [mi (in-list import-module-instances)] + [extra-inspectorss (in-list (or extra-inspectorsss + ;; Use `import-module-uses` just to have the right shape + import-module-uses))]) + (define m (module-instance-module mi)) + (unless (module-no-protected? m) + (define access (or (module-access m) (module-compute-access! m))) + (for ([import-sym (in-list import-syms)]) + (define a (hash-ref (hash-ref access (module-use-phase mu) #hasheq()) + import-sym + 'unexported)) + (when (or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (define guard-insp (namespace-inspector (module-instance-namespace mi))) + (unless (or + ;; Allowed at declaration time? + (inspector-superior? insp guard-insp) + ;; Allowed back at compile time? + (and extra-inspector (inspector-superior? extra-inspector guard-insp)) + ;; Allowed by inspectors attached to each referencing syntax object? + (and extra-inspectorsss + extra-inspectorss + (extra-inspectors-allow? (hash-ref extra-inspectorss import-sym #f) + guard-insp))) + (error 'link + (string-append "access disallowed by code inspector to ~a variable\n" + " variable: ~s\n" + " from module: ~a") + a + import-sym + (module-path-index-resolve (namespace-mpi (module-instance-namespace mi)))))))))) + +(define (check-single-require-access mi phase sym insp) + (define m (module-instance-module mi)) + (cond + [(module-no-protected? m) #t] + [else + (define access (or (module-access m) (module-compute-access! m))) + (define a + (hash-ref (hash-ref access phase #hasheq()) + sym + 'unexported)) + (cond + [(or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (define guard-insp (namespace-inspector (module-instance-namespace mi))) + (or (and insp + (inspector-superior? insp guard-insp)) + (inspector-superior? (current-code-inspector) guard-insp))] + [else #t])])) diff -Nru racket-6.12+ppa1/src/expander/eval/reflect-name.rkt racket-7.0+ppa1/src/expander/eval/reflect-name.rkt --- racket-6.12+ppa1/src/expander/eval/reflect-name.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/reflect-name.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,85 @@ +#lang racket/base +(require "../compile/compiled-in-memory.rkt" + "../host/linklet.rkt") + +(provide module-compiled-current-name + change-module-name + module-compiled-immediate-name + rebuild-linklet-directory + compiled->linklet-directory-or-bundle) + +(define (compiled->linklet-directory-or-bundle c) + (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + +(define (module-compiled-current-name c) + (define ld (compiled->linklet-directory-or-bundle c)) + (define b (if (linklet-bundle? ld) + ld + (hash-ref (linklet-directory->hash ld) #f))) + (hash-ref (linklet-bundle->hash b) 'name)) + +(define (module-compiled-immediate-name c) + (define n (module-compiled-current-name c)) + (if (pair? n) + (car (reverse n)) + n)) + +(define (change-module-name c name prefix) + (define full-name (if (null? prefix) name (append prefix (list name)))) + (define next-prefix (if (null? prefix) (list name) full-name)) + (define (recur sub-c name) + (if (equal? (module-compiled-current-name sub-c) (append next-prefix (list name))) + sub-c + (change-module-name sub-c name next-prefix))) + (cond + [(compiled-in-memory? c) + (define (change-submodule-name sub-c) + (recur sub-c (module-compiled-immediate-name sub-c))) + (define pre-compiled-in-memorys (map change-submodule-name + (compiled-in-memory-pre-compiled-in-memorys c))) + (define post-compiled-in-memorys (map change-submodule-name + (compiled-in-memory-post-compiled-in-memorys c))) + (struct-copy compiled-in-memory c + [pre-compiled-in-memorys pre-compiled-in-memorys] + [post-compiled-in-memorys post-compiled-in-memorys] + [linklet-directory (rebuild-linklet-directory + (update-one-name + (let ([ld (compiled->linklet-directory-or-bundle c)]) + (if (linklet-bundle? ld) + ld + (hash-ref (linklet-directory->hash ld) #f))) + full-name) + #:bundle-ok? (symbol? full-name) + (append pre-compiled-in-memorys + post-compiled-in-memorys))])] + [(linklet-directory? c) + (hash->linklet-directory + (for/hasheq ([(key val) (in-hash (linklet-directory->hash c))]) + (values key + (if (not key) + (update-one-name val full-name) + (recur val key)))))] + [else + ;; linklet bundle + (update-one-name c full-name)])) + +(define (update-one-name lb name) + (hash->linklet-bundle (hash-set (linklet-bundle->hash lb) 'name name))) + +(define (rebuild-linklet-directory main submods #:bundle-ok? [bundle-ok? #f]) + (if (and (null? submods) bundle-ok?) + main + (hash->linklet-directory + (hash-set (for/fold ([ht #hasheq()]) ([submod (in-list submods)]) + (define name (module-compiled-immediate-name submod)) + (cond + [(hash-ref ht name #f) + (raise-arguments-error 'module-compiled-submodules + "change would result in duplicate submodule name" + "name" name)] + [else + (hash-set ht name (compiled->linklet-directory-or-bundle submod))])) + #f + main)))) diff -Nru racket-6.12+ppa1/src/expander/eval/reflect.rkt racket-7.0+ppa1/src/expander/eval/reflect.rkt --- racket-6.12+ppa1/src/expander/eval/reflect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/reflect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,200 @@ +#lang racket/base +(require "../compile/compiled-in-memory.rkt" + "../host/linklet.rkt" + "../common/contract.rkt" + "module.rkt" + "../namespace/provided.rkt" + "../namespace/provide-for-api.rkt" + "reflect-name.rkt") + +(provide compiled-expression? + + compiled-module-expression? + module-compiled-name + module-compiled-submodules + module-compiled-language-info + module-compiled-imports + module-compiled-exports + module-compiled-indirect-exports + module-compiled-cross-phase-persistent?) + +;; The representation of a module with its submodules is designed to +;; make reading an individual submodule (with its submodule path +;; intact) fast and convenient --- but it makes adjusting the name +;; inconvenient, because each linklet bundle for a module encodes its +;; full submodule path. The extra layer of `compiled-in-memory` +;; support for sharing and fast compile-then-eval cycles is another +;; layer of inconvenience. + +(define (compiled-expression? c) + (or (compiled-in-memory? c) + (linklet-directory? c) + (linklet-bundle? c))) + +(define (compiled-module-expression? c) + (define ld (compiled->linklet-directory-or-bundle c)) + (or (and (linklet-directory? ld) + (let ([b (hash-ref (linklet-directory->hash ld) #f #f)]) + (and b (hash-ref (linklet-bundle->hash b) 'decl #f))) + #t) + (and (linklet-bundle? ld) + (hash-ref (linklet-bundle->hash ld) 'decl #f) + #t))) + +(define/who module-compiled-name + (case-lambda + [(c) + (check who compiled-module-expression? c) + (module-compiled-current-name c)] + [(c name) + (check who compiled-module-expression? c) + (unless (or (symbol? name) + (and (pair? name) + (list? name) + (andmap symbol? name))) + (raise-argument-error who + "(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))" + name)) + (define-values (i-name prefix) + (if (symbol? name) + (values name null) + (let ([r (reverse name)]) + (values (car r) (reverse (cdr r)))))) + (change-module-name c i-name prefix)])) + +(define/who module-compiled-submodules + (case-lambda + [(c non-star?) + (check who compiled-module-expression? c) + (cond + [(compiled-in-memory? c) + ;; We have a convenient `compiled-in-memory` structure + (if non-star? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c))] + [else + ;; We have a raw linklet directory or bundle, which is designed + ;; more for loading code than easy manipulation... + (cond + [(linklet-directory? c) + (define ht (linklet-directory->hash c)) + (define bh (linklet-bundle->hash (hash-ref ht #f))) + (define names (hash-ref bh (if non-star? 'pre 'post) null)) + (for/list ([name (in-list names)]) + (hash-ref ht name))] + [else + ;; a linklet bundle represents a module with no submodules + null])])] + [(c non-star? submods) + (check who compiled-module-expression? c) + (unless (and (list? submods) + (andmap compiled-module-expression? submods)) + (raise-argument-error who "(listof compiled-module-expression?)" submods)) + (cond + [(and (null? submods) + (or (linklet-bundle? (compiled->linklet-directory-or-bundle c)) + (and (compiled-in-memory? c) + (null? (if non-star? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c)))))) + ;; No change to a module without submodules + c] + [(and (compiled-in-memory? c) + (andmap compiled-in-memory? submods)) + ;; All compiled-in-memory structures, so preserve them + (define pre-compiled-in-memorys (if non-star? + submods + (compiled-in-memory-pre-compiled-in-memorys c))) + (define post-compiled-in-memorys (if non-star? + (compiled-in-memory-post-compiled-in-memorys c) + submods)) + (define n-c (normalize-to-linklet-directory c)) + (fixup-submodule-names + (struct-copy compiled-in-memory n-c + [pre-compiled-in-memorys pre-compiled-in-memorys] + [post-compiled-in-memorys post-compiled-in-memorys] + [linklet-directory (rebuild-linklet-directory + (reset-submodule-names + (hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f) + non-star? + submods) + #:bundle-ok? (symbol? (module-compiled-current-name c)) + (append pre-compiled-in-memorys + post-compiled-in-memorys))]))] + [else + ;; Not all compiled-in-memory structures, so forget whatever ones we have + (define n-c (normalize-to-linklet-directory c)) + (fixup-submodule-names + (rebuild-linklet-directory + (reset-submodule-names + (hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f) + non-star? + submods) + (map compiled->linklet-directory-or-bundle + (append (if non-star? submods (module-compiled-submodules c #t)) + (if non-star? (module-compiled-submodules c #f) submods)))))])])) + +(define/who (module-compiled-language-info c) + (check who compiled-module-expression? c) + (define h (compiled-module->h c)) + (hash-ref h 'language-info #f)) + +(define/who (module-compiled-imports c) + (check who compiled-module-expression? c) + (define inst (compiled-module->declaration-instance c)) + (instance-variable-value inst 'requires)) + +(define/who (module-compiled-exports c) + (check who compiled-module-expression? c) + (define inst (compiled-module->declaration-instance c)) + (provides->api-provides (instance-variable-value inst 'provides) + (instance-variable-value inst 'self-mpi))) + +(define/who (module-compiled-indirect-exports c) + (check who compiled-module-expression? c) + (define-values (h inst) (compiled-module->h+declaration-instance c)) + (define min-phase (hash-ref h 'min-phase 0)) + (define max-phase (hash-ref h 'max-phase 0)) + (variables->api-nonprovides (instance-variable-value inst 'provides) + (for/hash ([phase-level (in-range min-phase (add1 max-phase))]) + (define linklet (hash-ref h phase-level #f)) + (values phase-level + (if linklet + (linklet-export-variables linklet) + null))))) + +(define/who (module-compiled-cross-phase-persistent? c) + (check who compiled-module-expression? c) + (define h (compiled-module->h c)) + (hash-ref h 'cross-phase-persistent? #f)) + +;; ---------------------------------------- + +;; Normalize a compiled module that may have no submodules and is +;; represented directy by a linklet bundle to a representation that +;; uses a linklet directory +(define (normalize-to-linklet-directory c) + (cond + [(linklet-directory? (compiled->linklet-directory-or-bundle c)) + ;; already in linklet-directory form: + c] + [(linklet-bundle? c) + (hash->linklet-directory (hasheq #f c))] + [else + (struct-copy compiled-in-memory c + [linklet-directory (normalize-to-linklet-directory + (compiled-in-memory-linklet-directory c))])])) + +;; ---------------------------------------- + +(define (fixup-submodule-names c) + ;; Although this looks like a no-op, it forces a reset on submodule + ;; names, except where the names already match (short-circuited in + ;; `change-module-name`). + (module-compiled-name c (module-compiled-name c))) + +(define (reset-submodule-names b pre? submods) + (hash->linklet-bundle + (hash-set (linklet-bundle->hash b) + (if pre? 'pre 'post) + (map module-compiled-immediate-name submods)))) diff -Nru racket-6.12+ppa1/src/expander/eval/root-context.rkt racket-7.0+ppa1/src/expander/eval/root-context.rkt --- racket-6.12+ppa1/src/expander/eval/root-context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/root-context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,76 @@ +#lang racket/base +(require "../expand/root-expand-context.rkt" + "../expand/require.rkt" + "../expand/def-id.rkt" + "../expand/env.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "../common/module-path.rkt" + "../common/phase.rkt" + "../common/struct-star.rkt" + "../namespace/namespace.rkt" + "../host/linklet.rkt") + +(provide make-create-root-expand-context-from-module + shift-to-inside-root-context) + +;; Reconstructs a `root-expand-context` for a module based on its +;; metadata, specifically its requires and the exports of its +;; linklets. Reconstructing that way works as long as there are no +;; transformer definitions, since transformer definitions are not +;; visible outside a linklet. Typically, also, we can only do this +;; when the module contained no syntax literals, which would likely +;; contain information that is inconsistent with this reconstruction. +(define (make-create-root-expand-context-from-module requires evaled-ld-h) + (lambda (ns phase-shift original-self self) + (define root-ctx (make-root-expand-context #:self-mpi (namespace-mpi ns))) + (define s (add-scopes empty-syntax (root-expand-context-module-scopes root-ctx))) + + ;; Add bindings for `require`s + (for ([(phase+reqs) (in-list requires)]) + (define phase (car phase+reqs)) + (for ([req (in-list (cdr phase+reqs))]) + (define mpi (module-path-index-shift req original-self self)) + (perform-require! mpi s self + s ns + #:phase-shift (phase+ phase phase-shift) + #:run-phase phase-shift + #:who 'module))) + + ;; Add bindings for `define`s, including registering symbols used + ;; by those definitions (some of which might be macro-introduced) + (define defined-syms (root-expand-context-defined-syms root-ctx)) + (for ([(phase linklet) (in-hash evaled-ld-h)]) + (for ([sym (in-list (linklet-export-variables linklet))]) + ;; Note that sym might be an unreadable symbol, in which case + ;; the binding should be unreachable, but we need to reserve + ;; the symbol to avoid conflicts + (define id (datum->syntax s sym)) + (add-binding! id (make-module-binding self phase sym) phase) + (add-defined-sym! defined-syms phase sym id))) + + root-ctx)) + +;; ---------------------------------------- + +;; Shift `all-scopes-stx` so that the module path index reported for +;; bindings within the module are relative to a "self" MPI (with #f +;; for the path and base) instead of the MPI that is suitable for +;; viewing bindings from outside the module. This shift makes +;; interactive evaluation better approximate the original expansion of +;; the module, but it means that that the MPI on syntax objects within +;; the module is different from the MPI on syntax objects created +;; interactively (i.e., the interactive ones look more like bindings +;; before the module has been fully compiled and instantiated). +(define (shift-to-inside-root-context root-context) + (define outside-mpi (root-expand-context-self-mpi root-context)) + (define inside-mpi (make-self-module-path-index (module-path-index-resolved outside-mpi))) + (struct*-copy root-expand-context root-context + [self-mpi inside-mpi] + [all-scopes-stx + (syntax-module-path-index-shift + (root-expand-context-all-scopes-stx root-context) + outside-mpi + inside-mpi)])) diff -Nru racket-6.12+ppa1/src/expander/eval/top-level-instance.rkt racket-7.0+ppa1/src/expander/eval/top-level-instance.rkt --- racket-6.12+ppa1/src/expander/eval/top-level-instance.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/top-level-instance.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,49 @@ +#lang racket/base +(require "../syntax/to-list.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt" + "../compile/reserved-symbol.rkt" + "../syntax/module-binding.rkt" + "../host/linklet.rkt" + "../expand/env.rkt" + "../expand/require.rkt" + "../expand/require+provide.rkt") + +;; Run-time support for evaluating top-level forms +(provide top-level-instance) + +(define top-level-instance + (make-instance + 'top-level #f 'constant + + top-level-bind!-id + (lambda (id mpi orig-phase phase-shift ns sym trans? trans-val) + (define phase (phase+ orig-phase phase-shift)) + (define b (make-module-binding mpi phase sym + #:frame-id (root-expand-context-frame-id + (namespace-get-root-expand-ctx ns)))) + (add-binding! id b phase) + (cond + [trans? + (when trans-val + (maybe-install-free=id! trans-val id phase))] + [else + (namespace-unset-transformer! ns phase sym)])) + + top-level-require!-id + (lambda (stx ns) + (define reqs (cdr (syntax->list stx))) + (parse-and-perform-requires! #:run? #t + #:visit? #f + reqs + #f ; no syntax errors should happen + ns + (namespace-phase ns) + (make-requires+provides #f) + #:who 'require + ;; We don't need to check for conflicts + ;; or adjust the requires+provides: + #:initial-require? #t)))) diff -Nru racket-6.12+ppa1/src/expander/eval/top.rkt racket-7.0+ppa1/src/expander/eval/top.rkt --- racket-6.12+ppa1/src/expander/eval/top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/eval/top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,198 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/phase.rkt" + "../common/performance.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../compile/module-use.rkt" + "../compile/reserved-symbol.rkt" + "../host/linklet.rkt" + "../compile/serialize.rkt" + "../compile/instance.rkt" + "../compile/eager-instance.rkt" + "../compile/compiled-in-memory.rkt" + "../compile/multi-top.rkt" + "../compile/namespace-scope.rkt" + "../expand/context.rkt" + "top-level-instance.rkt" + "multi-top.rkt" + "protect.rkt") + +;; Run a representation of top-level code as produced by `compile-top`; +;; see "compile/main.rkt", "compile/top.rkt", and "compile/multi-top.rkt" + +(provide eval-top + eval-single-top + + compiled-multiple-top?) + +(define (eval-single-top c ns) + (eval-one-top c ns #:single-expression? #t)) + +(define (compiled-multiple-top? c) + (define ld (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (and (linklet-directory? ld) + (not (hash-ref (linklet-directory->hash ld) #f #f)))) + +(define (eval-top c ns [eval-compiled eval-top] [as-tail? #t]) + (if (compiled-multiple-top? c) + (eval-multiple-tops c ns eval-compiled as-tail?) + (eval-one-top c ns as-tail?))) + +(define (eval-multiple-tops c ns eval-compiled as-tail?) + (define (eval-compiled-parts l) + (let loop ([l l]) + (cond + [(null? l) void] + [(null? (cdr l)) + ;; Tail call: + (eval-compiled (car l) ns as-tail?)] + [else + (eval-compiled (car l) ns #f) + (loop (cdr l))]))) + + (cond + [(compiled-in-memory? c) + (eval-compiled-parts (compiled-in-memory-pre-compiled-in-memorys c))] + [(hash-ref (linklet-directory->hash c) 'data #f) + => (lambda (data-ld) + (eval-compiled-parts + (create-compiled-in-memorys-using-shared-data + (compiled-top->compiled-tops c) + ;; extract data linklet: + (hash-ref (linklet-bundle->hash (hash-ref (linklet-directory->hash data-ld) #f)) 0) + ns)))] + [else + ;; No shared data? Strage, but we can carry on, anyway: + (eval-compiled-parts (compiled-top->compiled-tops c))])) + +(define (eval-one-top c ns [as-tail? #t] + #:single-expression? [single-expression? #f]) + (performance-region + ['eval (if single-expression? 'transformer 'top)] + + (define ld (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (define h (linklet-bundle->hash (hash-ref (linklet-directory->hash ld) #f))) + (define link-instance + (if (compiled-in-memory? c) + (link-instance-from-compiled-in-memory c (and (not single-expression?) ns)) + (instantiate-linklet (hash-ref h 'link) + (list deserialize-instance + (make-eager-instance-instance + #:namespace ns + #:dest-phase (namespace-phase ns) + #:self (namespace-mpi ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:inspector (current-code-inspector)))))) + + (define orig-phase (hash-ref h 'original-phase)) + (define max-phase (hash-ref h 'max-phase)) + (define phase-shift (phase- (namespace-phase ns) orig-phase)) + + (define extra-inspector (and (compiled-in-memory? c) + (compiled-in-memory-compile-time-inspector c))) + (define phase-to-link-extra-inspectorsss + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-extra-inspectorsss c) + #hasheqv())) + + (define phase-to-link-modules + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-module-uses c) + (instance-variable-value link-instance 'phase-to-link-modules))) + + ;; Get last thunk to call in tail position: + (define thunk + (for/fold ([prev-thunk void]) ([phase (in-range max-phase (sub1 orig-phase) -1)]) + (prev-thunk #f) ;; call a not-last thunk before proceeding with the next phase + + (define module-uses (hash-ref phase-to-link-modules phase null)) + (define-values (import-module-instances import-instances) + (for/lists (mis is) ([mu (in-list module-uses)]) + (namespace-module-use->module+linklet-instances + ns mu #:phase-shift (phase- (phase+ phase phase-shift) + (module-use-phase mu))))) + + (define phase-ns (namespace->namespace-at-phase ns (phase+ phase phase-shift))) + + (define inst (if single-expression? + ;; Instance is ignored, so anything will do: + link-instance + ;; Instance is used: + (make-instance-instance + #:namespace phase-ns + #:phase-shift phase-shift + #:self (namespace-mpi ns) + #:inspector (namespace-inspector ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:set-transformer! (lambda (name val) + (namespace-set-transformer! ns + (phase+ (sub1 phase) phase-shift) + name + val))))) + + (define linklet (hash-ref h phase #f)) + + (cond + [linklet + (check-require-access linklet #:skip-imports 3 + module-uses import-module-instances (current-code-inspector) + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase #f)) + (define (instantiate tail?) + ;; Providing a target instance to `instantiate-linklet` means that we get + ;; the body's results instead of the instance as a result + (instantiate-linklet linklet + (list* top-level-instance + link-instance + inst + import-instances) + ;; Instantiation merges with the namespace's current instance: + (namespace->instance ns (phase- (phase+ phase phase-shift) + (namespace-0-phase ns))) + ;; No prompt in tail position: + (not tail?))) + ;; Return `instantiate` as the next thunk + (cond + [(zero-phase? phase) + instantiate] + [single-expression? + (lambda (tail?) + (parameterize ([current-namespace phase-ns]) + (instantiate tail?)))] + [else + (define ns-1 (namespace->namespace-at-phase phase-ns (sub1 phase))) + (lambda (tail?) + (parameterize ([current-expand-context (make-expand-context ns-1)] + [current-namespace phase-ns]) + (instantiate tail?)))])] + [else void]))) + + ;; Call last thunk tail position --- maybe, since using a prompt if not `as-tail?` + (thunk as-tail?))) + +(define (link-instance-from-compiled-in-memory cim to-ns) + ;; If the compilation namespace doesn't match the evaluation + ;; namespace, then we need to adjust syntax object literals to work + ;; in the new namespace --- the same shifting that happens otherwise + ;; through deserialization + (define orig-syntax-literals (compiled-in-memory-syntax-literals cim)) + (define syntax-literals + (cond + [(not to-ns) orig-syntax-literals] + [(namespace-scopes=? (compiled-in-memory-namespace-scopes cim) + (extract-namespace-scopes to-ns)) + orig-syntax-literals] + [else + (for/vector #:length (vector-length orig-syntax-literals) ([s (in-vector orig-syntax-literals)]) + (swap-top-level-scopes s + (compiled-in-memory-namespace-scopes cim) + to-ns))])) + ;; Create the instance: + (make-instance 'link #f 'constant + mpi-vector-id (compiled-in-memory-mpis cim) + syntax-literals-id syntax-literals)) diff -Nru racket-6.12+ppa1/src/expander/expand/allowed-context.rkt racket-7.0+ppa1/src/expander/expand/allowed-context.rkt --- racket-6.12+ppa1/src/expander/expand/allowed-context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/allowed-context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,55 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/binding.rkt" + "../syntax/scope.rkt" + "../namespace/core.rkt" + "context.rkt" + "../syntax/error.rkt") + +(provide prop:expansion-contexts + + not-in-this-expand-context? + avoid-current-expand-context) + +(define-values (prop:expansion-contexts expansion-contexts? expansion-contexts-ref) + (make-struct-type-property 'expansion-contexts + (lambda (v info) + (unless (and (list? v) + (for/and ([s (in-list v)]) + (memq s '(expression top-level module module-begin definition-context)))) + (raise-argument-error 'guard-for-prop:expansion-contexts + "(listof (or/c 'expression 'top-level 'module 'module-begin 'definition-context))" + v)) + v))) + + + +(define (not-in-this-expand-context? t ctx) + (and (expansion-contexts? t) + (not (memq (context->symbol (expand-context-context ctx)) + (expansion-contexts-ref t))))) + +(define (context->symbol context) + (if (symbol? context) + context + 'definition-context)) + +(define (avoid-current-expand-context s t ctx) + (define (wrap sym) + (datum->syntax #f (list (syntax-shift-phase-level + (datum->syntax core-stx sym) + (expand-context-phase ctx)) + s))) + (define (fail) + (raise-syntax-error + #f + (format "not allowed in context\n expansion context: ~a" + (context->symbol (expand-context-context ctx))) + s)) + (case (context->symbol (expand-context-context ctx)) + [(module-begin) (wrap 'begin)] + [(module top-level definition-context) + (if (memq 'expression (expansion-contexts-ref t)) + (wrap '#%expression) + (fail))] + [else (fail)])) diff -Nru racket-6.12+ppa1/src/expander/expand/already-expanded.rkt racket-7.0+ppa1/src/expander/expand/already-expanded.rkt --- racket-6.12+ppa1/src/expander/expand/already-expanded.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/already-expanded.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base + +;; Defines a struct type for an expression that has been +;; expanded already by `local-expand-expression` + +(provide (struct-out already-expanded)) + +(struct already-expanded (s binding-layer) + #:reflection-name 'expanded-syntax) diff -Nru racket-6.12+ppa1/src/expander/expand/append.rkt racket-7.0+ppa1/src/expander/expand/append.rkt --- racket-6.12+ppa1/src/expander/expand/append.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/append.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,10 @@ +#lang racket/base + +(provide append/tail-on-null) + +(define-syntax-rule (append/tail-on-null e0 ... e) + (let ([finish (lambda () e)]) + (define l (append e0 ...)) + (if (null? l) + (finish) + (append l (finish))))) diff -Nru racket-6.12+ppa1/src/expander/expand/binding-for-transformer.rkt racket-7.0+ppa1/src/expander/expand/binding-for-transformer.rkt --- racket-6.12+ppa1/src/expander/expand/binding-for-transformer.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/binding-for-transformer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require "env.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt") + +(provide binding-for-transformer?) + +;; Determine whether `b`, which is the binding of `id` at `at-phase`, +;; refers to a variable or transformer binding; also, check taints +;; (for bindings other than for-label) +(define (binding-for-transformer? b id at-phase ns) + (cond + [(not at-phase) + ;; The binding must be imported; determine whether it's syntax by + ;; consulting the exporting module + (define m (namespace->module ns (module-path-index-resolve + (module-binding-nominal-module b)))) + (define b/p (hash-ref (hash-ref (module-provides m) (module-binding-nominal-phase b) #hasheq()) + (module-binding-nominal-sym b) + #f)) + (provided-as-transformer? b/p)] + [else + ;; Use `binding-lookup` to both check for taints and determine whether the + ;; binding is a transformer or variable binding + (define-values (val primitive? insp protected?) + (binding-lookup b empty-env null ns at-phase id)) + (not (variable? val))])) diff -Nru racket-6.12+ppa1/src/expander/expand/binding-to-module.rkt racket-7.0+ppa1/src/expander/expand/binding-to-module.rkt --- racket-6.12+ppa1/src/expander/expand/binding-to-module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/binding-to-module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,43 @@ +#lang racket/base +(require "../syntax/module-binding.rkt" + "../syntax/error.rkt" + "../common/phase.rkt" + "../common/module-path.rkt" + "../namespace/module.rkt") + +(provide binding->module-instance) + +;; Locate a module instance for a binding +(define (binding->module-instance b ns phase id) + (define at-phase (phase- phase (module-binding-phase b))) + (define mi + (namespace->module-instance ns + (module-path-index-resolve (module-binding-module b)) + at-phase + #:check-available-at-phase-level (module-binding-phase b) + #:unavailable-callback (lambda (mi) 'unavailable))) + (when (eq? mi 'unavailable) + (raise-syntax-error + #f + (format (string-append "module mismatch;\n" + " attempted to use a module that is not available\n" + " possible cause:\n" + " using (dynamic-require .... #f)\n" + " but need (dynamic-require .... 0)\n" + " module: ~s\n" + " phase: ~s") + (module-binding-module b) + (phase+ at-phase (module-binding-phase b))) + id)) + (unless mi + (error 'expand + (string-append "namespace mismatch; cannot locate module instance\n" + " module: ~s\n" + " use phase: ~a\n" + " definition phase: ~a\n" + " for identifier: ~s") + (module-binding-module b) + phase + (module-binding-phase b) + id)) + mi) diff -Nru racket-6.12+ppa1/src/expander/expand/bind-top.rkt racket-7.0+ppa1/src/expander/expand/bind-top.rkt --- racket-6.12+ppa1/src/expander/expand/bind-top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/bind-top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "root-expand-context.rkt" + "context.rkt" + "def-id.rkt" + "dup-check.rkt" + "use-site.rkt") + +;; When compiling `(define-values (x) ...)` at the top level, we'd +;; like to bind `x` so that a reference in the "..." will point back +;; to the definition, as opposed to being whatever `x` was before. +;; (The top level is hopeless, but this bit of early binding helps.) +;; We don't want that binding to take effect outside of evaluation, +;; however; the permanent binding should happen when the +;; `define-values` for is evaluated. So, we use a distinct scope that +;; effectively hides the binding from tasks other than expansion. +;; +;; See also "expand-def-id.rkt". + +(provide as-expand-time-top-level-bindings) + +(define (as-expand-time-top-level-bindings ids s ctx) + (define top-level-bind-scope (root-expand-context-top-level-bind-scope ctx)) + (define tl-ids + (for/list ([id (in-list ids)]) + (remove-use-site-scopes id ctx))) + (check-no-duplicate-ids tl-ids (expand-context-phase ctx) s) + (define tmp-bind-ids + (for/list ([id (in-list tl-ids)]) + (add-scope id top-level-bind-scope))) + (values tl-ids + (select-defined-syms-and-bind!/ctx tmp-bind-ids ctx))) diff -Nru racket-6.12+ppa1/src/expander/expand/body.rkt racket-7.0+ppa1/src/expander/expand/body.rkt --- racket-6.12+ppa1/src/expander/expand/body.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/body.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,451 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "../expand/parsed.rkt" + "dup-check.rkt" + "use-site.rkt" + "../namespace/core.rkt" + "../boot/runtime-primitive.rkt" + "context.rkt" + "liberal-def-ctx.rkt" + "reference-record.rkt" + "prepare.rkt" + "log.rkt" + "main.rkt") + +(provide expand-body + expand-and-split-bindings-by-reference) + +;; Expand a sequence of body forms in a definition context; returns a +;; list of body forms +(define (expand-body bodys ctx + #:source s + #:stratified? [stratified? #f]) + (log-expand ctx 'enter-block (datum->syntax #f bodys)) + ;; In principle, we have an outside-edge scope that identifies the + ;; original content of the definition context --- but a body always + ;; exists inside some binding form, so that form's scope will do; + ;; the inside-edge scope identifies any form that appears (perhaps + ;; through macro expansion) in the definition context + (define inside-sc (new-scope 'intdef)) + (define init-bodys + (for/list ([body (in-list bodys)]) + (add-scope body inside-sc))) + (log-expand ctx 'block-renames (datum->syntax #f init-bodys) (datum->syntax #f bodys)) + (define phase (expand-context-phase ctx)) + (define frame-id (make-reference-record)) ; accumulates info on referenced variables + (define def-ctx-scopes (box null)) + ;; Create an expansion context for expanding only immediate macros; + ;; this partial-expansion phase uncovers macro- and variable + ;; definitions in the definition context + (define body-ctx (struct*-copy expand-context ctx + [context (list (make-liberal-define-context))] + [name #f] + [only-immediate? #t] + [def-ctx-scopes def-ctx-scopes] + [post-expansion #:parent root-expand-context + (lambda (s) (add-scope s inside-sc))] + [scopes (cons inside-sc + (expand-context-scopes ctx))] + [use-site-scopes #:parent root-expand-context (box null)] + [frame-id #:parent root-expand-context frame-id] + [reference-records (cons frame-id + (expand-context-reference-records ctx))])) + ;; Increment the binding layer relative to `ctx` when we encounter a binding + (define (maybe-increment-binding-layer ids body-ctx) + (if (eq? (expand-context-binding-layer body-ctx) + (expand-context-binding-layer ctx)) + (increment-binding-layer ids body-ctx inside-sc) + (expand-context-binding-layer body-ctx))) + ;; Save the name for the last form + (define name (expand-context-name ctx)) + ;; Loop through the body forms for partial expansion + (let loop ([body-ctx body-ctx] + [bodys init-bodys] + [done-bodys null] ; accumulated expressions + [val-idss null] ; accumulated binding identifiers + [val-keyss null] ; accumulated binding keys + [val-rhss null] ; accumulated binding right-hand sides + [track-stxs null] ; accumulated syntax for tracking + [trans-idss null] ; accumulated `define-syntaxes` identifiers that have disappeared + [stx-clauses null] ; accumulated syntax-binding clauses, used when observing + [dups (make-check-no-duplicate-table)]) + (cond + [(null? bodys) + ;; Partial expansion is complete, so finish by rewriting to + ;; `letrec-values` + (finish-expanding-body body-ctx frame-id def-ctx-scopes + (reverse val-idss) (reverse val-keyss) (reverse val-rhss) (reverse track-stxs) + (reverse stx-clauses) (reverse done-bodys) + #:source s + #:stratified? stratified? + #:name name + #:disappeared-transformer-bindings (reverse trans-idss))] + [else + (define rest-bodys (cdr bodys)) + (log-expand body-ctx 'next) + (define exp-body (expand (car bodys) (if (and name (null? (cdr bodys))) + (struct*-copy expand-context body-ctx + [name name]) + body-ctx))) + (define disarmed-exp-body (syntax-disarm exp-body)) + (case (core-form-sym disarmed-exp-body phase) + [(begin) + ;; Splice a `begin` form + (log-expand body-ctx 'prim-begin) + (define-match m disarmed-exp-body '(begin e ...)) + (define (track e) (syntax-track-origin e exp-body)) + (define splice-bodys (append (map track (m 'e)) rest-bodys)) + (log-expand body-ctx 'splice splice-bodys) + (loop body-ctx + splice-bodys + done-bodys + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)] + [(define-values) + ;; Found a variable definition; add bindings, extend the + ;; environment, and continue + (log-expand body-ctx 'prim-define-values) + (define-match m disarmed-exp-body '(define-values (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) body-ctx)) + (log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs)))) + (define new-dups (check-no-duplicate-ids ids phase exp-body dups)) + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in exp-body))) + (define extended-env (for/fold ([env (expand-context-env body-ctx)]) ([key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (loop (struct*-copy expand-context body-ctx + [env extended-env] + [binding-layer (maybe-increment-binding-layer ids body-ctx)]) + rest-bodys + null + ;; If we had accumulated some expressions, we + ;; need to turn each into the equivalent of + ;; (defined-values () (begin (values))) + ;; form so it can be kept with definitions to + ;; preserve order + (cons ids (append + (for/list ([done-body (in-list done-bodys)]) + null) + val-idss)) + (cons keys (append + (for/list ([done-body (in-list done-bodys)]) + null) + val-keyss)) + (cons (m 'rhs) (append + (for/list ([done-body (in-list done-bodys)]) + (no-binds done-body s phase)) + val-rhss)) + (cons exp-body (append + (for/list ([done-body (in-list done-bodys)]) + #f) + track-stxs)) + trans-idss + stx-clauses + new-dups)] + [(define-syntaxes) + ;; Found a macro definition; add bindings, evaluate the + ;; compile-time right-hand side, install the compile-time + ;; values in the environment, and continue + (log-expand body-ctx 'prim-define-syntaxes) + (define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) body-ctx)) + (log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs)))) + (define new-dups (check-no-duplicate-ids ids phase exp-body dups)) + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in exp-body))) + (log-expand body-ctx 'prepare-env) + (prepare-next-phase-namespace ctx) + (log-expand body-ctx 'enter-bind) + (define vals (eval-for-syntaxes-binding 'define-syntaxes (m 'rhs) ids body-ctx)) + (define extended-env (for/fold ([env (expand-context-env body-ctx)]) ([key (in-list keys)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase body-ctx) + (env-extend env key val))) + (log-expand body-ctx 'exit-bind) + (loop (struct*-copy expand-context body-ctx + [env extended-env] + [binding-layer (maybe-increment-binding-layer ids body-ctx)]) + rest-bodys + done-bodys + val-idss + val-keyss + val-rhss + track-stxs + (cons ids trans-idss) + (cons (datum->syntax #f (list ids (m 'rhs)) exp-body) stx-clauses) + new-dups)] + [else + (cond + [stratified? + ;; Found an expression, so no more definitions are allowed + (unless (null? done-bodys) (error "internal error: accumulated expressions not empty")) + (loop body-ctx + null + (if (and (null? val-idss) (null? trans-idss)) + (reverse (cons exp-body rest-bodys)) + (list (datum->syntax #f (cons (core-id '#%stratified-body phase) + (cons exp-body rest-bodys))))) + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)] + [else + ;; Found an expression; accumulate it and continue + (loop body-ctx + rest-bodys + (cons exp-body done-bodys) + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)])])]))) + +;; Partial expansion is complete, so assumble the result as a +;; `letrec-values` form and continue expanding +(define (finish-expanding-body body-ctx frame-id def-ctx-scopes + val-idss val-keyss val-rhss track-stxs + stx-clauses done-bodys + #:source s + #:stratified? stratified? + #:name name + #:disappeared-transformer-bindings disappeared-transformer-bindings) + (when (null? done-bodys) + (raise-syntax-error #f "no expression after a sequence of internal definitions" s)) + ;; As we finish expanding, we're no longer in a definition context + (define finish-ctx (struct*-copy expand-context (accumulate-def-ctx-scopes body-ctx def-ctx-scopes) + [context 'expression] + [use-site-scopes #:parent root-expand-context (box null)] + [scopes (append + (unbox (root-expand-context-use-site-scopes body-ctx)) + (expand-context-scopes body-ctx))] + [only-immediate? #f] + [def-ctx-scopes #f] + [post-expansion #:parent root-expand-context #f])) + ;; Helper to expand and wrap the ending expressions in `begin`, if needed: + (define (finish-bodys) + (define block->list? (null? val-idss)) + (unless block->list? (log-expand body-ctx 'next-group)) ; to go with 'block->letrec + (define last-i (sub1 (length done-bodys))) + (log-expand body-ctx 'enter-list (datum->syntax #f done-bodys)) + (define exp-bodys + (for/list ([done-body (in-list done-bodys)] + [i (in-naturals)]) + (log-expand body-ctx 'next) + (expand done-body (if (and name (= i last-i)) + (struct*-copy expand-context finish-ctx + [name name]) + finish-ctx)))) + (log-expand body-ctx 'exit-list (datum->syntax #f exp-bodys)) + (reference-record-clear! frame-id) + exp-bodys) + (cond + [(and (null? val-idss) + (null? disappeared-transformer-bindings)) + ;; No definitions, so just return the body list + (log-expand finish-ctx 'block->list (datum->syntax s done-bodys)) + (finish-bodys)] + [else + (log-expand... finish-ctx (lambda (obs) + ;; Simulate old expansion steps + (log-letrec-values obs finish-ctx s val-idss val-rhss track-stxs + stx-clauses done-bodys))) + ;; Roughly, finish expanding the right-hand sides, finish the body + ;; expression, then add a `letrec-values` wrapper: + (define exp-s (expand-and-split-bindings-by-reference + val-idss val-keyss val-rhss track-stxs + #:split? (not stratified?) + #:frame-id frame-id #:ctx finish-ctx + #:source s #:had-stxes? (pair? stx-clauses) + #:get-body finish-bodys #:track? #f)) + (log-expand* body-ctx ['exit-prim exp-s] ['return exp-s]) + (if (expand-context-to-parsed? body-ctx) + (list exp-s) + (list (attach-disappeared-transformer-bindings + exp-s + disappeared-transformer-bindings)))])) + +;; Roughly, create a `letrec-values` for for the given ids, right-hand sides, and +;; body. While expanding right-hand sides, though, keep track of whether any +;; forward references appear, and if not, generate a `let-values` form, instead, +;; at each binding clause. Similar, end a `letrec-values` form and start a new +;; one if there were forward references up to the clause but not beyond. +;; Returns a single form. +(define (expand-and-split-bindings-by-reference idss keyss rhss track-stxs + #:split? split? + #:frame-id frame-id #:ctx ctx + #:source s #:had-stxes? had-stxes? + #:get-body get-body #:track? track?) + (define phase (expand-context-phase ctx)) + (let loop ([idss idss] [keyss keyss] [rhss rhss] [track-stxs track-stxs] + [accum-idss null] [accum-keyss null] [accum-rhss null] [accum-track-stxs null] + [track? track?] [get-list? #f] [can-log? #t]) + (cond + [(null? idss) + (cond + [(and (null? accum-idss) + get-list?) + (get-body)] + [else + (define exp-body (get-body)) + (define result-s + (if (expand-context-to-parsed? ctx) + (if (null? accum-idss) + (parsed-let-values (keep-properties-only s) null null exp-body) + (parsed-letrec-values (keep-properties-only s) + (reverse accum-idss) + (reverse (map list accum-keyss accum-rhss)) + exp-body)) + (rebuild + #:track? track? + s + `(,(if (null? accum-idss) + (core-id 'let-values phase) + (core-id 'letrec-values phase)) + ,(build-clauses accum-idss accum-rhss accum-track-stxs) + ,@exp-body)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)])] + [else + (log-expand ctx 'next) + (define ids (car idss)) + (define expanded-rhs (expand (car rhss) (as-named-context ctx ids))) + (define track-stx (car track-stxs)) + + (define local-or-forward-references? (reference-record-forward-references? frame-id)) + (reference-record-bound! frame-id (car keyss)) + (define forward-references? (reference-record-forward-references? frame-id)) + + (cond + [(and (not local-or-forward-references?) + split?) + (unless (null? accum-idss) (error "internal error: accumulated ids not empty")) + (define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + null null null null + #f #t #f)) + (define result-s + (if (expand-context-to-parsed? ctx) + (parsed-let-values (keep-properties-only s) + (list ids) + (list (list (car keyss) expanded-rhs)) + exp-rest) + (rebuild + #:track? track? + s + `(,(core-id 'let-values phase) + (,(build-clause ids expanded-rhs track-stx)) + ,@exp-rest)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)] + [(and (not forward-references?) + (or split? (null? (cdr idss)))) + (define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + null null null null + #f #t #f)) + (define result-s + (if (expand-context-to-parsed? ctx) + (parsed-letrec-values (keep-properties-only s) + (reverse (cons ids accum-idss)) + (reverse + (cons (list (car keyss) expanded-rhs) + (map list accum-keyss accum-rhss))) + exp-rest) + (rebuild + #:track? track? + s + `(,(core-id 'letrec-values phase) + ,(build-clauses (cons ids accum-idss) + (cons expanded-rhs accum-rhss) + (cons track-stx accum-track-stxs)) + ,@exp-rest)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)] + [else + (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + (cons ids accum-idss) (cons (car keyss) accum-keyss) + (cons expanded-rhs accum-rhss) (cons track-stx accum-track-stxs) + track? get-list? can-log?)])]))) + +(define (build-clauses accum-idss accum-rhss accum-track-stxs) + (map build-clause + (reverse accum-idss) + (reverse accum-rhss) + (reverse accum-track-stxs))) + +(define (build-clause ids rhs track-stx) + (define clause (datum->syntax #f `[,ids ,rhs])) + (if track-stx + (syntax-track-origin clause track-stx) + clause)) + +;; Helper to turn an expression into a binding clause with zero +;; bindings +(define (no-binds expr s phase) + (define s-runtime-stx (syntax-shift-phase-level runtime-stx phase)) + (datum->syntax (core-id '#%app phase) ; for `values` application + `(,(core-id 'begin phase) + ,expr + (,(datum->syntax s-runtime-stx 'values))) + s)) + +(define (log-tag? had-stxes? ctx) + (and had-stxes? + (not (expand-context-only-immediate? ctx)))) + +;; Generate observer actions that simulate the old expander +;; going back through `letrec-values`: +(define (log-letrec-values obs ctx s val-idss val-rhss track-stxs + stx-clauses done-bodys) + (define phase (expand-context-phase ctx)) + (define clauses (for/list ([val-ids (in-list val-idss)] + [val-rhs (in-list val-rhss)] + [track-stx (in-list track-stxs)]) + (datum->syntax #f `[,val-ids ,val-rhs] track-stx))) + (define had-stxes? (not (null? stx-clauses))) + (define lv-id (core-id (if had-stxes? 'letrec-syntaxes+values 'letrec-values) phase)) + (define lv-s (datum->syntax #f (if had-stxes? + `(,lv-id ,stx-clauses ,clauses ,@done-bodys) + `(,lv-id ,clauses ,@done-bodys)) + s)) + (...log-expand obs + ['block->letrec (list lv-s)] + ['visit lv-s] + ['resolve lv-id] + ['enter-prim lv-s]) + (cond + [had-stxes? + (...log-expand obs + ['prim-letrec-syntaxes+values] + ['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)] + ['prepare-env] + ['next-group]) + (unless (null? val-idss) + (...log-expand obs + ['prim-letrec-values] + ['let-renames clauses (datum->syntax #f done-bodys s)]))] + [else + (...log-expand obs + ['prim-letrec-values] + ['let-renames clauses (datum->syntax #f done-bodys s)])])) diff -Nru racket-6.12+ppa1/src/expander/expand/context.rkt racket-7.0+ppa1/src/expander/expand/context.rkt --- racket-6.12+ppa1/src/expander/expand/context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,204 @@ +#lang racket/base +(require racket/promise + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "free-id-set.rkt" + "../namespace/namespace.rkt" + "root-expand-context.rkt" + "lift-key.rkt") + +(provide (struct*-out expand-context) + (all-from-out "root-expand-context.rkt") + make-expand-context + copy-root-expand-context + current-expand-context + get-current-expand-context + + current-expand-observe + + as-expression-context + as-begin-expression-context + as-tail-context + as-named-context + as-to-parsed-context) + +;; An `expand-context` controls the process and result of expansion. +;; +;; If `to-parsed?` is true, the result is a `parsed` record instead of +;; an expanded syntax objects. That mode is effectively a fusion of +;; expansion and parsing, which is useful in the common case that +;; expanded code is being sent directly the the compiler. +;; +;; If only-immediate?` is set, then only immediate macro uses are +;; expanded. That mode overrides `to-parsed?`, since it's common to +;; partially expand forms on the way to a parsed result. + +(struct* expand-context root-expand-context + (to-parsed? ; #t => "expand" to a parsed form; #f => normal expand + * context ; 'expression, 'module, or 'top-level + phase ; current expansion phase; must match phase of `namespace` + namespace ; namespace for modules and evaluation + * env ; environment for local bindings + * scopes ; list of scopes that should be pruned by `quote-syntax` + * def-ctx-scopes ; #f or box of list of scopes; transformer-created def-ctxes + * binding-layer ; changed when a binding is nested; to check already-expanded + * reference-records ; list of reference records for enclosing + * only-immediate? ; #t => stop at core forms; #t => `def-ctx-scopes` is a box + just-once? ; #t => stop (a given subform) after any expansion + module-begin-k ; expander for `#%module-begin` in a 'module-begin context + * need-eventually-defined ; phase(>=1) -> variables expanded before binding + allow-unbound? ; allow reference to unbound identifiers as variables + in-local-expand? ; #t via `local-expand` + keep-#%expression? ; if `in-local-expand?`, keep `#%expression` forms + stops ; free-id-set; non-empty => `def-ctx-scopes` is a box + * current-introduction-scopes ; scopes for current macro expansion + * current-use-scopes ; scopes for current macro expansion + declared-submodule-names ; mutable hash table: symbol -> 'module or 'module* + lifts ; #f or lift-context, which contains a list of lifteds + lift-envs ; list of box of env for lifts to locals + module-lifts ; lifted `module`s + require-lifts ; lifted `require`s + to-module-lifts ; lifted `provide` and end declarations + requires+provides ; enclosing module's requires+provides during `provide` + * name ; #f or identifier to name the expression + observer ; logging observer (for the macro debugger) + for-serializable? ; accumulate submodules as serializable? + should-not-encounter-macros?)) ; #t when "expanding" to parse + +(define (make-expand-context ns + #:to-parsed? [to-parsed? #f] + #:for-serializable? [for-serializable? #f] + #:observer [observer #f]) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (expand-context (root-expand-context-self-mpi root-ctx) + (root-expand-context-module-scopes root-ctx) + (root-expand-context-post-expansion root-ctx) + (root-expand-context-top-level-bind-scope root-ctx) + (root-expand-context-all-scopes-stx root-ctx) + (root-expand-context-use-site-scopes root-ctx) + (root-expand-context-defined-syms root-ctx) + (root-expand-context-frame-id root-ctx) + (root-expand-context-counter root-ctx) + (root-expand-context-lift-key root-ctx) + to-parsed? + 'top-level + (namespace-phase ns) + ns + empty-env + null ; scopes + #f ; def-ctx-scopes [=> don't record scopes to be stipped for `quote-syntax`] + (root-expand-context-frame-id root-ctx) ; binding-layer + null ; reference-records + #f ; only-immediate? + #f ; just-once? + #f ; module-begin-k + #f ; need-eventually-defined + #t ; allow-unbound? + #f ; in-local-expand? + #f ; keep-#%expression? + empty-free-id-set ; stops + null ; current-introduction-scopes + null ; current-use-scopes + #hasheq() ; declared-submodule-names + #f ; lifts + '() ; lift-envs + #f ; module-lifts + #f ; require-lifts + #f ; to-module-lifts + #f ; requires+provides + #f ; name + observer + for-serializable? + #f)) + +(define (copy-root-expand-context ctx root-ctx) + (struct*-copy expand-context ctx + [self-mpi #:parent root-expand-context (root-expand-context-self-mpi root-ctx)] + [module-scopes #:parent root-expand-context (root-expand-context-module-scopes root-ctx)] + [post-expansion #:parent root-expand-context (root-expand-context-post-expansion root-ctx)] + [top-level-bind-scope #:parent root-expand-context (root-expand-context-top-level-bind-scope root-ctx)] + [all-scopes-stx #:parent root-expand-context (root-expand-context-all-scopes-stx root-ctx)] + [use-site-scopes #:parent root-expand-context (root-expand-context-use-site-scopes root-ctx)] + [defined-syms #:parent root-expand-context (root-expand-context-defined-syms root-ctx)] + [frame-id #:parent root-expand-context (root-expand-context-frame-id root-ctx)] + [counter #:parent root-expand-context (root-expand-context-counter root-ctx)] + [lift-key #:parent root-expand-context (root-expand-context-lift-key root-ctx)] + [binding-layer (root-expand-context-frame-id root-ctx)])) + +;; An expand-context or a delayed expand context (so use `force`): +(define current-expand-context (make-parameter #f)) + +(define (get-current-expand-context [who 'unexpected] + #:fail-ok? [fail-ok? #f]) + (or (force (current-expand-context)) + (if fail-ok? + #f + (raise-arguments-error who "not currently expanding")))) + +;; ---------------------------------------- + +;; For macro debugging. This parameter is only used by the expander +;; entry points in "../eval/main.rkt" to set the expand-context +;; observer. Other expander code uses "log.rkt" to send expansion +;; events to the observer. +(define current-expand-observe (make-parameter #f + (lambda (v) + (unless (or (not v) + (and (procedure? v) + (procedure-arity-includes? v 2))) + (raise-argument-error 'current-expand-observe + "(or/c (procedure-arity-includes/c 2) #f)" + v)) + v))) + +;; ---------------------------------------- + +;; Adjusts `ctx` to make it suitable for a subexpression of the +;; current context +(define (as-expression-context ctx) + (cond + [(and (eq? 'expression (expand-context-context ctx)) + (not (expand-context-name ctx))) + ctx] + [else (struct*-copy expand-context ctx + [context 'expression] + [name #f] + [post-expansion #:parent root-expand-context #f])])) + +;; Adjusts `ctx` to make it suitable for a non-tail position +;; in an `begin` form, possibly in a 'top-level or 'module context +;; (so don't force it to 'expression mode) +(define (as-begin-expression-context ctx) + (cond + [(not (expand-context-name ctx)) + ctx] + [else (struct*-copy expand-context ctx + [name #f])])) + +;; Adjusts `ctx` (which should be an expression context) to make it +;; suitable for a subexpression in tail position +(define (as-tail-context ctx #:wrt wrt-ctx) + (cond + [(expand-context-name wrt-ctx) + (struct*-copy expand-context ctx + [name (expand-context-name wrt-ctx)])] + [else ctx])) + +;; Adjust `ctx` to make it suitable for a context in the right-hand +;; side of a definition of `ids` +(define (as-named-context ctx ids) + (cond + [(and (pair? ids) (null? (cdr ids))) + (struct*-copy expand-context ctx + [name (car ids)])] + [else ctx])) + +;; Adjust `ctx` to to generate a parsed result +(define (as-to-parsed-context ctx) + (struct*-copy expand-context ctx + [to-parsed? #t] + [observer #f] + [should-not-encounter-macros? #t])) diff -Nru racket-6.12+ppa1/src/expander/expand/cross-phase.rkt racket-7.0+ppa1/src/expander/expand/cross-phase.rkt --- racket-6.12+ppa1/src/expander/expand/cross-phase.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/cross-phase.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,145 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/match.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../namespace/core.rkt" + "../common/module-path.rkt" + "../boot/runtime-primitive.rkt" + "parsed.rkt" + "expanded+parsed.rkt") + +;; Check whether a module fits the restricted grammar of a cross-phase +;; persistent module + +(provide check-cross-phase-persistent-form) + +(define (check-cross-phase-persistent-form bodys self-mpi) + + (define (check-body bodys) + (for ([body (in-list bodys)]) + (define p (if (expanded+parsed? body) + (expanded+parsed-parsed body) + body)) + (cond + [(parsed-define-values? p) + (check-expr (parsed-define-values-rhs p) (length (parsed-define-values-syms p)) p)] + [(or (parsed-#%declare? p) + (parsed-module? p) + (syntax? p)) ;; remaining unparsed forms, such as `#%require` and `#%provide`, are ok + (void)] + [else + (disallow p)]))) + + (define (check-expr e num-results enclosing) + (cond + [(parsed-lambda? e) + (check-count 1 num-results enclosing) + (check-no-disallowed-expr e)] + [(parsed-case-lambda? e) + (check-count 1 num-results enclosing) + (check-no-disallowed-expr e)] + [(parsed-quote? e) + (check-datum (parsed-quote-datum e) e) + (check-count 1 num-results enclosing)] + [(parsed-app? e) + (define rands (parsed-app-rands e)) + (for ([rand (in-list rands)]) + (check-expr rand 1 e)) + (case (cross-phase-primitive-name (parsed-app-rator e)) + [(cons list) + (check-count 1 num-results enclosing)] + [(make-struct-type) + (check-count 5 num-results enclosing)] + [(make-struct-type-property) + (check-count 3 num-results enclosing)] + [(gensym) + (unless (or (= 0 (length rands)) + (and (= 1 (length rands)) + (quoted-string? (car rands)))) + (disallow e))] + [(string->uninterned-symbol) + (unless (and (= 1 (length rands)) + (quoted-string? (car rands))) + (disallow e))] + [else (disallow e)])] + [else (check-no-disallowed-expr e)])) + + (define (check-no-disallowed-expr e) + (cond + [(parsed-lambda? e) + (check-body-no-disallowed-expr (parsed-lambda-body e))] + [(parsed-case-lambda? e) + (for ([clause (in-list (parsed-case-lambda-clauses e))]) + (check-body-no-disallowed-expr (cadr clause)))] + [(parsed-app? e) + (check-no-disallowed-expr (parsed-app-rator e)) + (for ([e (in-list (parsed-app-rands e))]) + (check-no-disallowed-expr e))] + [(parsed-if? e) + (check-no-disallowed-expr (parsed-if-tst e)) + (check-no-disallowed-expr (parsed-if-thn e)) + (check-no-disallowed-expr (parsed-if-els e))] + [(parsed-set!? e) + (define id (parsed-set!-id e)) + (define normal-b (parsed-id-binding id)) + (when (or (not normal-b) + (parsed-top-id? id) + (and (not (symbol? normal-b)) + (eq? (module-binding-module normal-b) self-mpi))) + (disallow e)) + (check-no-disallowed-expr (parsed-set!-rhs e))] + [(parsed-with-continuation-mark? e) + (check-no-disallowed-expr (parsed-with-continuation-mark-key e)) + (check-no-disallowed-expr (parsed-with-continuation-mark-val e)) + (check-no-disallowed-expr (parsed-with-continuation-mark-body e))] + [(parsed-begin? e) + (check-body-no-disallowed-expr (parsed-begin-body e))] + [(parsed-begin0? e) + (check-body-no-disallowed-expr (parsed-begin0-body e))] + [(parsed-let_-values? e) + (for ([clause (in-list (parsed-let_-values-clauses e))]) + (check-no-disallowed-expr (cadr clause))) + (check-body-no-disallowed-expr (parsed-let_-values-body e))] + [(or (parsed-quote-syntax? e) + (parsed-#%variable-reference? e)) + (disallow e)] + ;; Other forms have no subexpressions + [else (void)])) + + (define (check-body-no-disallowed-expr l) + (for ([e (in-list l)]) + (check-no-disallowed-expr e))) + + (check-body bodys)) + +(define (check-count is-num expected-num enclosing) + (unless (= is-num expected-num) + (disallow enclosing))) + +(define (check-datum d e) + (cond + [(or (number? d) (boolean? d) (symbol? d) (string? d) (bytes? d) (null? d)) + (void)] + [else (disallow e)])) + +(define (quoted-string? e) + (and (parsed-quote? e) + (string? (parsed-quote-datum e)))) + +(define (cross-phase-primitive-name id) + (cond + [(parsed-id? id) + (define b (parsed-id-binding id)) + (and (module-binding? b) + (eq? runtime-module-name (module-path-index-resolve (module-binding-module b))) + (module-binding-sym b))] + [else #f])) + +(define (disallow body) + (raise-syntax-error 'module + "not allowed in a cross-phase persistent module" + (if (parsed? body) + (datum->syntax #f body (parsed-s body)) + body))) diff -Nru racket-6.12+ppa1/src/expander/expand/def-id.rkt racket-7.0+ppa1/src/expander/expand/def-id.rkt --- racket-6.12+ppa1/src/expander/expand/def-id.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/def-id.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,103 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "require+provide.rkt" + "../namespace/namespace.rkt" + "context.rkt" + "root-expand-context.rkt" + "env.rkt") + +(provide select-defined-syms-and-bind! + select-defined-syms-and-bind!/ctx + add-defined-sym!) + +;; For each identifier that is defined in a module or at the top +;; level, we need to map the identifier to a symbol for a variable in +;; a linklet instance. (Since multiple definitions have identifiers +;; that wrap the same symbol in different scopes, we invent new +;; symbols as unreadable symbols.) A `module-binding` refers to this +;; linklet-level symbol. + +;; As a concession to top-level evaluation, reserve plain symbols for +;; identifers that have only the module's scopes. That way, if a +;; reference to an identifier is encountered before a definition, the +;; reference can still work in normal cases. + +;; One further twist is that top-level expansion uses a "top level +;; bind scope", which is used to create bindings while expanding so +;; that definitions and uses expanded to together work in the expected +;; way, but no binding is actually created until a definition is +;; evaluated. For the purposes of selecting a symbol, we need to treat +;; as equivalent identifiers with and without the top level bind +;; scope. + +(define (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:top-level-bind-scope [top-level-bind-scope #f] + #:requires+provides [requires+provides #f] + #:in [orig-s #f] + #:as-transformer? [as-transformer? #f]) + (define defined-syms-at-phase + (or (hash-ref defined-syms phase #f) (let ([ht (make-hasheq)]) + (hash-set! defined-syms phase ht) + ht))) + (for/list ([id (in-list ids)]) + (define sym (syntax-e id)) + (define defined-sym + (if (and (not (defined-as-other? (hash-ref defined-syms-at-phase sym #f) id phase top-level-bind-scope)) + ;; Only use `sym` directly if there are no + ;; extra scopes on the binding form... + (no-extra-scopes? id all-scopes-stx top-level-bind-scope phase) + ;; ... and if it's interned + (symbol-interned? sym)) + sym + (let loop ([pos 1]) + (define s (string->unreadable-symbol (format "~a.~a" sym pos))) + (if (defined-as-other? (hash-ref defined-syms-at-phase s #f) id phase top-level-bind-scope) + (loop (add1 pos)) + s)))) + (hash-set! defined-syms-at-phase defined-sym id) + (define b (make-module-binding self phase defined-sym #:frame-id frame-id + #:nominal-sym sym)) + (when requires+provides + (remove-required-id! requires+provides id phase #:unless-matches b)) + (add-binding! id b phase #:in orig-s) + (when requires+provides + (add-defined-or-required-id! requires+provides id phase b #:as-transformer? as-transformer?)) + defined-sym)) + +(define (no-extra-scopes? id all-scopes-stx top-level-bind-scope phase) + (define m-id (datum->syntax all-scopes-stx (syntax-e id))) + (or (bound-identifier=? id m-id phase) + (and top-level-bind-scope + (bound-identifier=? id (add-scope m-id top-level-bind-scope) phase)))) + +(define (defined-as-other? prev-id id phase top-level-bind-scope) + (and prev-id + (not (bound-identifier=? prev-id id phase)) + (or (not top-level-bind-scope) + (not (bound-identifier=? (remove-scope prev-id top-level-bind-scope) + (remove-scope id top-level-bind-scope) + phase))))) + +;; ------------------------------ + +(define (select-defined-syms-and-bind!/ctx tl-ids ctx) + (select-defined-syms-and-bind! tl-ids (root-expand-context-defined-syms ctx) + (root-expand-context-self-mpi ctx) + (expand-context-phase ctx) + (root-expand-context-all-scopes-stx ctx) + #:frame-id (root-expand-context-frame-id ctx) + #:top-level-bind-scope (root-expand-context-top-level-bind-scope ctx))) + +;; ---------------------------------------- + +(define (add-defined-sym! defined-syms phase sym id) + (define defined-syms-at-phase + (or (hash-ref defined-syms phase #f) (let ([ht (make-hasheq)]) + (hash-set! defined-syms phase ht) + ht))) + (hash-set! defined-syms-at-phase sym id)) diff -Nru racket-6.12+ppa1/src/expander/expand/definition-context.rkt racket-7.0+ppa1/src/expander/expand/definition-context.rkt --- racket-6.12+ppa1/src/expander/expand/definition-context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/definition-context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,299 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "use-site.rkt" + "context.rkt" + "main.rkt" + "log.rkt" + "free-id-set.rkt" + "stop-ids.rkt") + +(provide add-intdef-scopes + add-intdef-bindings + internal-definition-context-frame-id + + internal-definition-context? + syntax-local-make-definition-context + syntax-local-bind-syntaxes + internal-definition-context-binding-identifiers + internal-definition-context-introduce + internal-definition-context-seal + identifier-remove-from-definition-context + + make-local-expand-context + flip-introduction-scopes + flip-introduction-and-use-scopes + + intdefs? + intdefs?-string + intdefs-or-false? + intdefs-or-false?-string) + +(struct internal-definition-context (frame-id ; identifies the frame for use-site scopes + scope ; scope that represents the context + add-scope? ; whether the scope is auto-added for expansion + env-mixins ; bindings for this context: box of list of mix-binding + parent-ctx)) ; parent definition context or #f + +(struct env-mixin (id + sym + value + cache)) ; caches addition of binding to an existing environment + +;; syntax-local-make-definition-context +(define (syntax-local-make-definition-context [parent-ctx #f] [add-scope? #t]) + (unless (or (not parent-ctx) + (internal-definition-context? parent-ctx)) + (raise-argument-error 'syntax-local-make-definition-context "(or/c #f internal-definition-context?)" parent-ctx)) + (define ctx (get-current-expand-context 'syntax-local-make-definition-context)) + (define frame-id (or (root-expand-context-frame-id ctx) + (and parent-ctx (internal-definition-context-frame-id parent-ctx)) + (gensym))) + (define sc (new-scope 'intdef)) + (define def-ctx-scopes (expand-context-def-ctx-scopes ctx)) + (when def-ctx-scopes + (set-box! def-ctx-scopes (cons sc (unbox def-ctx-scopes)))) + (internal-definition-context frame-id sc add-scope? (box null) parent-ctx)) + +;; syntax-local-bind-syntaxes +(define (syntax-local-bind-syntaxes ids s intdef [extra-intdefs '()]) + (unless (and (list? ids) + (andmap identifier? ids)) + (raise-argument-error 'syntax-local-bind-syntaxes "(listof identifier?)" ids)) + (unless (or (not s) (syntax? s)) + (raise-argument-error 'syntax-local-bind-syntaxes "(or/c syntax? #f)" s)) + (unless (internal-definition-context? intdef) + (raise-argument-error 'syntax-local-bind-syntaxes "internal-definition-context?" intdef)) + (unless (intdefs? extra-intdefs) + (raise-argument-error 'syntax-local-bind-syntaxes intdefs?-string extra-intdefs)) + (define ctx (get-current-expand-context 'local-expand)) + (log-expand ctx 'local-bind ids) + (define phase (expand-context-phase ctx)) + (define all-intdefs (if (list? extra-intdefs) + (cons intdef extra-intdefs) + (list intdef extra-intdefs))) + (define intdef-ids (for/list ([id (in-list ids)]) + (define pre-id (remove-use-site-scopes (flip-introduction-scopes id ctx) + ctx)) + (add-intdef-scopes (add-intdef-scopes pre-id intdef #:always? #t) + extra-intdefs))) + (log-expand ctx 'rename-list intdef-ids) + (define syms (for/list ([intdef-id (in-list intdef-ids)]) + (add-local-binding! intdef-id phase (root-expand-context-counter ctx) + #:frame-id (internal-definition-context-frame-id intdef)))) + (define vals + (cond + [s + (define input-s (flip-introduction-scopes (add-intdef-scopes s all-intdefs) ctx)) + (define tmp-env (for/fold ([env (expand-context-env ctx)]) ([sym (in-list syms)] + [intdef-id (in-list intdef-ids)]) + (hash-set env sym (local-variable intdef-id)))) + (log-expand ctx 'enter-bind) + (define vals + (eval-for-syntaxes-binding 'syntax-local-bind-syntaxes + input-s ids + (make-local-expand-context (struct*-copy expand-context ctx + [env tmp-env]) + #:context 'expression + #:intdefs all-intdefs))) + (log-expand ctx 'exit-bind) + vals] + [else + (for/list ([intdef-id (in-list intdef-ids)]) (local-variable intdef-id))])) + (define env-mixins (internal-definition-context-env-mixins intdef)) + (set-box! env-mixins (append (for/list ([intdef-id (in-list intdef-ids)] + [sym (in-list syms)] + [val (in-list vals)]) + (maybe-install-free=id-in-context! val intdef-id phase ctx) + (env-mixin intdef-id sym val (make-weak-hasheq))) + (unbox env-mixins))) + (log-expand ctx 'exit-local-bind)) + +;; internal-definition-context-binding-identifiers +(define (internal-definition-context-binding-identifiers intdef) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-binding-identifiers "internal-definition-context?" intdef)) + (for/list ([env-mixin (in-list (unbox (internal-definition-context-env-mixins intdef)))]) + (env-mixin-id env-mixin))) + +;; internal-definition-context-introduce +(define (internal-definition-context-introduce intdef s [mode 'flip]) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-introduce "internal-definition-context?" intdef)) + (unless (syntax? s) + (raise-argument-error 'internal-definition-context-introduce "syntax?" s)) + (add-intdef-scopes s intdef + #:always? #t + #:action (case mode + [(add) add-scope] + [(remove) remove-scope] + [(flip) flip-scope] + [else (raise-argument-error + 'internal-definition-context-introduce + "(or/c 'add 'remove 'flip)" + mode)]))) + +;; internal-definition-context-seal +(define (internal-definition-context-seal intdef) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-seal "internal-definition-context?" intdef)) + (void)) + +;; identifier-remove-from-definition-context +(define (identifier-remove-from-definition-context id intdef) + (unless (identifier? id) + (raise-argument-error 'identifier-remove-from-definition-context "identifier?" id)) + (unless (or (internal-definition-context? intdef) + (and (list? intdef) + (andmap internal-definition-context? intdef))) + (raise-argument-error 'identifier-remove-from-definition-context + "(or/c internal-definition-context? (listof internal-definition-context?))" + intdef)) + (for/fold ([id id]) ([intdef (in-intdefs intdef)]) + (internal-definition-context-introduce intdef id 'remove))) + +;; For contract errors: +(define (intdefs? x) + (or (internal-definition-context? x) + (and (list? x) + (andmap internal-definition-context? x)))) +(define intdefs?-string + "(or/c internal-definition-context? (listof internal-definition-context?))") +(define (intdefs-or-false? x) + (or (not x) (intdefs? x))) +(define intdefs-or-false?-string + "(or/c internal-definition-context? (listof internal-definition-context?) #f)") + +;; Sequence for intdefs provided to `local-expand` +(define-sequence-syntax in-intdefs + (lambda (stx) (raise-syntax-error #f "only allowed in a `for` form" stx)) + (lambda (stx) + (syntax-case stx () + [[(d) (_ arg)] + #'[(d) + (:do-in + ([(x) (let ([a arg]) + (cond + [(list? a) (reverse a)] + [(not a) null] + [else (list a)]))]) + #t + ([a x]) + (pair? a) + ([(d) (car a)]) + #t + #t + ((cdr a)))]]))) + +(define (add-intdef-bindings env intdefs) + (for/fold ([env env]) ([intdef (in-intdefs intdefs)]) + (define parent-ctx (internal-definition-context-parent-ctx intdef)) + (define parent-env (if parent-ctx (add-intdef-bindings env parent-ctx) env)) + (define env-mixins (unbox (internal-definition-context-env-mixins intdef))) + (let loop ([env parent-env] [env-mixins env-mixins]) + (cond + [(null? env-mixins) env] + [else + (define env-mixin (car env-mixins)) + (or (hash-ref (env-mixin-cache env-mixin) env #f) + (let ([new-env (env-extend (loop env (cdr env-mixins)) + (env-mixin-sym env-mixin) + (env-mixin-value env-mixin))]) + (hash-set! (env-mixin-cache env-mixin) env new-env) + new-env))])))) + +(define (add-intdef-scopes s intdefs + #:always? [always? #f] + #:action [action add-scope]) + (for/fold ([s s]) ([intdef (in-intdefs intdefs)] + #:when (or always? + (internal-definition-context-add-scope? intdef))) + (action s (internal-definition-context-scope intdef)))) + +;; ---------------------------------------- + +(define (make-local-expand-context ctx + #:context context + #:phase [phase (expand-context-phase ctx)] + #:intdefs intdefs + #:stop-ids [stop-ids #f] + #:to-parsed-ok? [to-parsed-ok? #f] + #:track-to-be-defined? [track-to-be-defined? #f] + #:keep-#%expression? [keep-#%expression? #t]) + (define same-kind? (or (eq? context + (expand-context-context ctx)) + (and (list? context) + (list? (expand-context-context ctx))))) + (define all-stop-ids (and stop-ids (stop-ids->all-stop-ids stop-ids phase))) + (define def-ctx-scopes (if (expand-context-def-ctx-scopes ctx) + (unbox (expand-context-def-ctx-scopes ctx)) + null)) + (struct*-copy expand-context ctx + [context context] + [env (add-intdef-bindings (expand-context-env ctx) + intdefs)] + [use-site-scopes + #:parent root-expand-context + (and (or (eq? context 'module) + (eq? context 'module-begin) + (list? context)) + (or (root-expand-context-use-site-scopes ctx) + (box null)))] + [frame-id #:parent root-expand-context + ;; If there are multiple definition contexts in `intdefs` + ;; and if they have different frame IDs, then we conservatively + ;; turn on use-site scopes for all frame IDs + (for/fold ([frame-id (root-expand-context-frame-id ctx)]) ([intdef (in-intdefs intdefs)]) + (define i-frame-id (internal-definition-context-frame-id intdef)) + (cond + [(and frame-id i-frame-id (not (eq? frame-id i-frame-id))) + ;; Special ID 'all means "use-site scopes for all expansions" + 'all] + [else (or frame-id i-frame-id)]))] + [post-expansion #:parent root-expand-context + (let ([pe (and same-kind? + (or (pair? context) + (memq context '(module module-begin top-level))) + (root-expand-context-post-expansion ctx))]) + (cond + [(and intdefs (not (null? intdefs))) + (lambda (s) + (add-intdef-scopes (apply-post-expansion pe s) intdefs))] + [else pe]))] + [scopes + (append def-ctx-scopes + (expand-context-scopes ctx))] + [only-immediate? (not stop-ids)] ; def-ctx-scopes is set for the enclosing transformer call + [to-parsed? (if to-parsed-ok? + (expand-context-to-parsed? ctx) + #f)] + [just-once? #f] + [in-local-expand? #t] + [keep-#%expression? keep-#%expression?] + [stops (free-id-set phase (or all-stop-ids null))] + [current-introduction-scopes null] + [need-eventually-defined (let ([ht (expand-context-need-eventually-defined ctx)]) + (cond + [track-to-be-defined? + ;; maintain status quo and propagate tracking + ht] + [ht + ;; keep allowing unbound references, but don't track them + (make-hasheqv)] + [else + ;; keep disallowing unbound references + #f]))])) + +;; ---------------------------------------- + +(define (flip-introduction-scopes s ctx) + (flip-scopes s (expand-context-current-introduction-scopes ctx))) + +(define (flip-introduction-and-use-scopes s ctx) + (flip-scopes (flip-introduction-scopes s ctx) + (expand-context-current-use-scopes ctx))) diff -Nru racket-6.12+ppa1/src/expander/expand/dup-check.rkt racket-7.0+ppa1/src/expander/expand/dup-check.rkt --- racket-6.12+ppa1/src/expander/expand/dup-check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/dup-check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,28 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/error.rkt") + +(provide make-check-no-duplicate-table + check-no-duplicate-ids) + +(define (make-check-no-duplicate-table) #hasheq()) + +;; Check for duplicates, returning a table on success that can be +;; used for further checking. +;; The `ids` argument can be a single identifier, a list, a list of +;; lists, etc. +(define (check-no-duplicate-ids ids phase s [ht (make-check-no-duplicate-table)] + #:what [what "binding name"]) + (let loop ([v ids] [ht ht]) + (cond + [(identifier? v) + (define l (hash-ref ht (syntax-e v) null)) + (for ([id (in-list l)]) + (when (bound-identifier=? id v phase) + (raise-syntax-error #f (string-append "duplicate " what) s v))) + (hash-set ht (syntax-e v) (cons v l))] + [(pair? v) + (loop (cdr v) (loop (car v) ht))] + [else + ht]))) diff -Nru racket-6.12+ppa1/src/expander/expand/env.rkt racket-7.0+ppa1/src/expander/expand/env.rkt --- racket-6.12+ppa1/src/expander/expand/env.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/env.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,160 @@ +#lang racket/base +(require "../common/memo.rkt" + "../syntax/syntax.rkt" + "../syntax/error.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../common/phase.rkt" + "../syntax/binding.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "protect.rkt" + "binding-to-module.rkt" + "set-bang-trans.rkt" + "rename-trans.rkt" + "../common/module-path.rkt") + +(provide empty-env + env-extend + + variable + (struct-out core-form) + + transformer? transformer->procedure + variable? + + (struct-out local-variable) + substitute-variable + + add-binding! + add-bulk-binding! + add-local-binding! + + binding-lookup) + +;; ---------------------------------------- + +;; An expansion environment maps keys to either `variable` or a +;; compile-time value: +(define empty-env #hasheq()) +(define (env-extend env key val) + (hash-set env key val)) + +;; `variable` is a token to represent a binding to a run-time variable +(define variable (gensym 'variable)) +(define (variable? t) (or (eq? t variable) + (local-variable? t))) + +;; A `local-variable` records a binding identifier, so that a +;; reference can be replaced with the binding identifier +(struct local-variable (id) #:authentic) + +;; If a variable binding corresponds to a local binding, substitute +;; the binding identifier in place of the original reference +(define (substitute-variable id t #:no-stops? no-stops?) + (if (and no-stops? (local-variable? t)) + (let ([bind-id (local-variable-id t)]) + ;; Keep source locations and properties of original reference: + (syntax-rearm (datum->syntax (syntax-disarm bind-id) (syntax-e bind-id) id id) + id)) + id)) + +;; `missing` is a token to represent the absence of a binding; a +;; distinct token is needed so that it's distinct from all compile-time +;; values +(define missing (gensym 'missing)) +(define (missing? t) (eq? t missing)) + +;; A subset of compile-time values are macro transformers +(define (transformer? t) (or (procedure? t) + (set!-transformer? t) + (rename-transformer? t))) +(define (transformer->procedure t) + (cond + [(set!-transformer? t) (set!-transformer-procedure t)] + [(rename-transformer? t) (lambda (s) s)] ; "expansion" handled via #:alternate-id + [else t])) + +;; A subset of compile-time values are primitive forms +(struct core-form (expander name) #:transparent #:authentic) + +;; ---------------------------------------- + +(define (add-binding! id binding phase #:in [in-s #f] #:just-for-nominal? [just-for-nominal? #f]) + (check-id-taint id in-s) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) binding + #:just-for-nominal? just-for-nominal?)) + +(define (add-bulk-binding! s binding phase + #:in [in-s #f] + #:shadow-except [shadow-except #f]) + (when (syntax-tainted? s) + (raise-syntax-error #f "cannot bind from tainted syntax" in-s s)) + (add-bulk-binding-in-scopes! (syntax-scope-set s phase) binding + #:shadow-except shadow-except)) + +;; Helper for registering a local binding in a set of scopes: +(define (add-local-binding! id phase counter #:frame-id [frame-id #f] #:in [in-s #f]) + (check-id-taint id in-s) + (set-box! counter (add1 (unbox counter))) + (define key (string->uninterned-symbol (format "~a_~a" (syntax-e id) (unbox counter)))) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) (make-local-binding key #:frame-id frame-id)) + key) + +(define (check-id-taint id in-s) + (when (syntax-tainted? id) + (raise-syntax-error #f "cannot bind tainted identifier" in-s id))) + +;; ---------------------------------------- + +;; Returns: `variable` or a compile-time value +;; #f or #t indicating whether the binding is to a primitive +;; #f or (for a transformer) an inspector for the defining module +;; #f or #t for a protected binding +;; A binding provided to `binding-lookup` should be obtained either by +;; passing `#:immediate? #t` to `resolve+shift` or by using `resolve+shift/extra-inspector`, +;; where the latter checks protected access for `free-identifier=?` equivalence +;; chains to provide an inspector associated with the endpoint identifier; using +;; just `resolve+shift` may leave the access with a too-weak inspector. +(define (binding-lookup b env lift-envs ns phase id + #:in [in-s #f] + #:out-of-context-as-variable? [out-of-context-as-variable? #f]) + (cond + [(module-binding? b) + (define top-level? (top-level-module-path-index? (module-binding-module b))) + (define mi (and (not top-level?) (binding->module-instance b ns phase id))) + (define m (and mi (module-instance-module mi))) + (define primitive? (and m (module-primitive? m))) + (define m-ns (if top-level? ns (and mi (module-instance-namespace mi)))) + (check-taint id) + (define t (namespace-get-transformer m-ns (module-binding-phase b) (module-binding-sym b) + variable)) + (define protected? + (and mi (check-access b mi id in-s (if (variable? t) "variable" "transformer")))) + (define insp (and mi (module-instance-module mi) (module-inspector (module-instance-module mi)))) + (values t primitive? insp protected?)] + [(local-binding? b) + (define t (hash-ref env (local-binding-key b) missing)) + (cond + [(eq? t missing) + (values (or + ;; check in lift envs, if any + (for/or ([lift-env (in-list lift-envs)]) + (hash-ref (unbox lift-env) (local-binding-key b) #f)) + (if out-of-context-as-variable? + variable + (error "identifier used out of context:" id))) + #f + #f + #f)] + [else + (check-taint id) + (values t #f #f #f)])] + [else (error "internal error: unknown binding for lookup:" b)])) + +;; Check for taints on a variable reference +(define (check-taint id) + (when (syntax-tainted? id) + (raise-syntax-error #f + "cannot use identifier tainted by macro transformation" + id))) diff -Nru racket-6.12+ppa1/src/expander/expand/expanded+parsed.rkt racket-7.0+ppa1/src/expander/expand/expanded+parsed.rkt --- racket-6.12+ppa1/src/expander/expand/expanded+parsed.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/expanded+parsed.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,58 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "parsed.rkt" + "rebuild.rkt") + +(provide (struct-out expanded+parsed) + (struct-out semi-parsed-define-values) + (struct-out semi-parsed-begin-for-syntax) + extract-syntax + parsed-only + syntax-only) + +;; When expanding a module, we may need to compile and instantiate it, +;; too (as or for submodules), so keep both expanded and compiled +;; variants of a form together: +(struct expanded+parsed (s parsed) #:authentic) + +;; A `define-values` or `begin-for-syntax-form` is in limbo though +;; some passes. +(struct semi-parsed-define-values (s syms ids rhs) #:authentic) +(struct semi-parsed-begin-for-syntax (s body) #:authentic) + +(define (extract-syntax s) + (if (expanded+parsed? s) + (expanded+parsed-s s) + s)) + +(define (parsed-only l) + (for/list ([i (in-list l)] + #:when (or (parsed? i) + (expanded+parsed? i) + (semi-parsed-begin-for-syntax? i))) + (cond + [(expanded+parsed? i) + (expanded+parsed-parsed i)] + [(semi-parsed-begin-for-syntax? i) + (parsed-begin-for-syntax (semi-parsed-begin-for-syntax-s i) + (parsed-only (semi-parsed-begin-for-syntax-body i)))] + [else i]))) + +(define (syntax-only l) + (for/list ([i (in-list l)] + #:when (or (syntax? i) + (expanded+parsed? i) + (semi-parsed-begin-for-syntax? i))) + (cond + [(expanded+parsed? i) (expanded+parsed-s i)] + [(semi-parsed-begin-for-syntax? i) + ;; If `l` is after skipping `module*` expansion, then we may + ;; still have semi-parsed `begin-for-syntax` + (define s (semi-parsed-begin-for-syntax-s i)) + (define nested-bodys (semi-parsed-begin-for-syntax-body i)) + (let ([disarmed-s (syntax-disarm s)]) + (define-match m disarmed-s '(begin-for-syntax _ ...)) + (rebuild s `(,(m 'begin-for-syntax) ,@(syntax-only nested-bodys))))] + [else i]))) diff -Nru racket-6.12+ppa1/src/expander/expand/expr.rkt racket-7.0+ppa1/src/expander/expand/expr.rkt --- racket-6.12+ppa1/src/expander/expand/expr.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/expr.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,782 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../namespace/namespace.rkt" + "../common/module-path.rkt" + "../syntax/binding.rkt" + "env.rkt" + "free-id-set.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "syntax-id-error.rkt" + "dup-check.rkt" + "../namespace/core.rkt" + "context.rkt" + "allowed-context.rkt" + "main.rkt" + "body.rkt" + "set-bang-trans.rkt" + "rename-trans.rkt" + "reference-record.rkt" + "prepare.rkt" + "log.rkt" + "parsed.rkt") + +;; ---------------------------------------- + +;; Common expansion for `lambda` and `case-lambda` +(define (lambda-clause-expander s disarmed-s formals bodys ctx log-renames-tag) + (define sc (new-scope 'local)) + (define phase (expand-context-phase ctx)) + ;; Parse and check formal arguments: + (define ids (parse-and-flatten-formals formals sc disarmed-s)) + (check-no-duplicate-ids ids phase s #:what "argument name") + ;; Bind each argument and generate a corresponding key for the + ;; expand-time environment: + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:in s))) + (define body-env (for/fold ([env (expand-context-env ctx)]) ([key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (define sc-formals (add-scope formals sc)) + (define sc-bodys (for/list ([body (in-list bodys)]) (add-scope body sc))) + (log-expand ctx log-renames-tag sc-formals (datum->syntax #f sc-bodys)) + ;; Expand the function body: + (define body-ctx (struct*-copy expand-context ctx + [env body-env] + [scopes (cons sc (expand-context-scopes ctx))] + [binding-layer (increment-binding-layer ids ctx sc)] + [frame-id #:parent root-expand-context #f])) + (define exp-body (expand-body sc-bodys body-ctx #:source (keep-as-needed ctx s #:keep-for-error? #t))) + ;; Return formals (with new scope) and expanded body: + (values (if (expand-context-to-parsed? ctx) + (unflatten-like-formals keys formals) + sc-formals) + exp-body)) + +(add-core-form! + 'lambda + (lambda (s ctx) + (log-expand ctx 'prim-lambda) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(lambda formals body ...+)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) + (define-values (formals body) + (lambda-clause-expander s disarmed-s (m 'formals) (m 'body) ctx 'lambda-renames)) + (if (expand-context-to-parsed? ctx) + (parsed-lambda rebuild-s formals body) + (rebuild + rebuild-s + `(,(m 'lambda) ,formals ,@body))))) + +(add-core-form! + 'λ + ;; A macro: + (lambda (s) + (define-match m s '(lam-id formals _ ...+)) + (define ids (parse-and-flatten-formals (m 'formals) #f s)) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (define phase (if ctx + (expand-context-phase ctx) + 0)) + (check-no-duplicate-ids ids phase s #:what "argument name") + (datum->syntax + s + (cons (datum->syntax (syntax-shift-phase-level core-stx phase) + 'lambda + (m 'lam-id) + (m 'lam-id)) + (cdr (syntax-e s))) + s + s))) + +(add-core-form! + 'case-lambda + (lambda (s ctx) + (log-expand ctx 'prim-case-lambda) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(case-lambda [formals body ...+] ...)) + (define-match cm disarmed-s '(case-lambda clause ...)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) + (define clauses + (for/list ([formals (in-list (m 'formals))] + [body (in-list (m 'body))] + [clause (in-list (cm 'clause))]) + (log-expand ctx 'next) + (define rebuild-clause (keep-as-needed ctx clause)) + (define-values (exp-formals exp-body) + (lambda-clause-expander s disarmed-s formals body ctx 'lambda-renames)) + (if (expand-context-to-parsed? ctx) + (list exp-formals exp-body) + (rebuild rebuild-clause `[,exp-formals ,@exp-body])))) + (if (expand-context-to-parsed? ctx) + (parsed-case-lambda rebuild-s clauses) + (rebuild + rebuild-s + `(,(m 'case-lambda) ,@clauses))))) + +(define (parse-and-flatten-formals all-formals sc s) + (let loop ([formals all-formals]) + (cond + [(identifier? formals) (list (add-scope formals sc))] + [(syntax? formals) + (define p (syntax-e formals)) + (cond + [(pair? p) (loop p)] + [(null? p) null] + [else (raise-syntax-error #f "not an identifier" s p)])] + [(pair? formals) + (unless (identifier? (car formals)) + (raise-syntax-error #f "not an identifier" s (car formals))) + (cons (if sc + (add-scope (car formals) sc) + (car formals)) + (loop (cdr formals)))] + [(null? formals) + null] + [else + (raise-syntax-error "bad argument sequence" s all-formals)]))) + +(define (unflatten-like-formals keys formals) + (let loop ([keys keys] [formals formals]) + (cond + [(null? formals) null] + [(pair? formals) (cons (car keys) (loop (cdr keys) (cdr formals)))] + [(syntax? formals) (loop keys (syntax-e formals))] + [else (car keys)]))) + +;; ---------------------------------------- + +;; Common expansion for `let[rec]-[syntaxes+]values` +(define (make-let-values-form #:log-tag log-tag + #:syntaxes? [syntaxes? #f] + #:rec? [rec? #f] + #:split-by-reference? [split-by-reference? #f] + #:renames-log-tag [renames-log-tag 'let-renames]) + (lambda (s ctx) + (log-expand ctx log-tag) + (define disarmed-s (syntax-disarm s)) + (define-match stx-m disarmed-s #:when syntaxes? + '(letrec-syntaxes+values + ([(id:trans ...) trans-rhs] ...) + ([(id:val ...) val-rhs] ...) + body ...+)) + (define-match val-m disarmed-s #:unless syntaxes? + '(let-values ([(id:val ...) val-rhs] ...) + body ...+)) + (define sc (new-scope 'local)) + (define phase (expand-context-phase ctx)) + (define frame-id (and syntaxes? + (make-reference-record))) ; accumulates info on referenced variables + ;; Add the new scope to each binding identifier: + (define trans-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:trans) null))]) + (for/list ([id (in-list ids)]) + (add-scope id sc)))) + (define val-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:val) (val-m 'id:val)))]) + (for/list ([id (in-list ids)]) + (add-scope id sc)))) + (define val-rhss (if rec? + (for/list ([rhs (in-list (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))]) + (add-scope rhs sc)) + (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))) + (define val-clauses ; for syntax tracking + (cond + [syntaxes? + (define-match m disarmed-s '(_ _ (clause ...) . _)) + (m 'clause)] + [else + (define-match m disarmed-s '(_ (clause ...) . _)) + (m 'clause)])) + (check-no-duplicate-ids (list trans-idss val-idss) phase s) + ;; Bind each left-hand identifier and generate a corresponding key + ;; fo the expand-time environment: + (define counter (root-expand-context-counter ctx)) + (define trans-keyss (for/list ([ids (in-list trans-idss)]) + (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in s)))) + (define val-keyss (for/list ([ids (in-list val-idss)]) + (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in s)))) + ;; Add new scope to body: + (define bodys (for/list ([body (in-list (if syntaxes? (stx-m 'body) (val-m 'body)))]) + (add-scope body sc))) + (log-expand... ctx (lambda (obs) + (log-let-renames obs renames-log-tag val-idss val-rhss bodys + trans-idss (and syntaxes? (stx-m 'trans-rhs)) sc))) + ;; Evaluate compile-time expressions (if any): + (when syntaxes? + (log-expand ctx 'prepare-env) + (prepare-next-phase-namespace ctx)) + (define trans-valss (for/list ([rhs (in-list (if syntaxes? (stx-m 'trans-rhs) '()))] + [ids (in-list trans-idss)]) + (log-expand* ctx ['next] ['enter-bind]) + (define trans-val (eval-for-syntaxes-binding 'letrec-syntaxes+values + (add-scope rhs sc) ids ctx)) + (log-expand ctx 'exit-bind) + trans-val)) + ;; Fill expansion-time environment: + (define rec-val-env + (for/fold ([env (expand-context-env ctx)]) ([keys (in-list val-keyss)] + [ids (in-list val-idss)] + #:when #t + [key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (define rec-env (for/fold ([env rec-val-env]) ([keys (in-list trans-keyss)] + [vals (in-list trans-valss)] + [ids (in-list trans-idss)]) + (for/fold ([env env]) ([key (in-list keys)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase ctx) + (env-extend env key val)))) + ;; Expand right-hand sides and body + (define expr-ctx (as-expression-context ctx)) + (define orig-rrs (expand-context-reference-records expr-ctx)) + (define rec-ctx (struct*-copy expand-context expr-ctx + [env rec-env] + [scopes (cons sc (expand-context-scopes ctx))] + [reference-records (if split-by-reference? + (cons frame-id orig-rrs) + orig-rrs)] + [binding-layer (increment-binding-layer + (cons trans-idss val-idss) + ctx + sc)])) + (define letrec-values-id + (and (not (expand-context-to-parsed? ctx)) + (if syntaxes? + (core-id 'letrec-values phase) + (val-m 'let-values)))) + + (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) + (define val-name-idss (if (expand-context-to-parsed? ctx) + (for/list ([val-ids (in-list val-idss)]) + (for/list ([val-id (in-list val-ids)]) + (datum->syntax #f (syntax-e val-id) val-id val-id))) + val-idss)) + + (when syntaxes? + (log-expand... ctx (lambda (obs) (log-letrec-values obs val-idss val-rhss bodys)))) + + (define (get-body) + (log-expand* ctx #:unless (and syntaxes? (null? val-idss)) ['next-group]) + (define body-ctx (struct*-copy expand-context rec-ctx + [reference-records orig-rrs])) + (expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s)) + + (define result-s + (cond + [(not split-by-reference?) + (define clauses + (for/list ([ids (in-list val-name-idss)] + [keys (in-list val-keyss)] + [rhs (in-list val-rhss)] + [clause (in-list val-clauses)]) + (log-expand ctx 'next) + (define exp-rhs (expand rhs (if rec? + (as-named-context rec-ctx ids) + (as-named-context expr-ctx ids)))) + (if (expand-context-to-parsed? ctx) + (list keys exp-rhs) + (datum->syntax #f `[,ids ,exp-rhs] clause clause)))) + (define exp-body (get-body)) + (when frame-id + (reference-record-clear! frame-id)) + (if (expand-context-to-parsed? ctx) + (if rec? + (parsed-letrec-values rebuild-s val-name-idss clauses exp-body) + (parsed-let-values rebuild-s val-name-idss clauses exp-body)) + (rebuild + rebuild-s + `(,letrec-values-id ,clauses ,@exp-body)))] + [else + (expand-and-split-bindings-by-reference + val-idss val-keyss val-rhss val-clauses + #:split? #t + #:frame-id frame-id #:ctx rec-ctx + #:source rebuild-s #:had-stxes? syntaxes? + #:get-body get-body #:track? #t)])) + + (if (expand-context-to-parsed? ctx) + result-s + (attach-disappeared-transformer-bindings result-s trans-idss)))) + +(define (log-let-renames obs renames-log-tag val-idss val-rhss bodys + trans-idss trans-rhss sc) + (define vals+body (cons (for/list ([val-ids (in-list val-idss)] + [val-rhs (in-list val-rhss)]) + (datum->syntax #f `[,val-ids ,val-rhs])) + (datum->syntax #f bodys))) + (...log-expand obs [renames-log-tag (if (not trans-rhss) + vals+body + (cons + (for/list ([trans-ids (in-list trans-idss)] + [trans-rhs (in-list trans-rhss)]) + (datum->syntax #f `[,trans-ids ,(add-scope trans-rhs sc)])) + vals+body))])) + +(define (log-letrec-values obs val-idss val-rhss bodys) + (...log-expand obs ['next-group]) + (unless (null? val-idss) + (...log-expand obs ['prim-letrec-values]) + (log-let-renames obs 'let-renames val-idss val-rhss bodys + #f #f #f))) + +(add-core-form! + 'let-values + (make-let-values-form #:log-tag 'prim-let-values)) + +(add-core-form! + 'letrec-values + (make-let-values-form #:rec? #t #:log-tag 'prim-letrec-values)) + +(add-core-form! + 'letrec-syntaxes+values + (make-let-values-form #:syntaxes? #t #:rec? #t #:split-by-reference? #t + #:log-tag 'prim-letrec-syntaxes+values + #:renames-log-tag 'letrec-syntaxes-renames)) + +;; ---------------------------------------- + +(add-core-form! + '#%stratified-body + (lambda (s ctx) + (log-expand ctx 'prim-#%stratified) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%stratified-body body ...+)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) + (define exp-body (expand-body (m 'body) ctx #:stratified? #t #:source rebuild-s)) + (if (expand-context-to-parsed? ctx) + (parsed-begin rebuild-s exp-body) + (rebuild + rebuild-s + (if (null? (cdr exp-body)) + (car exp-body) + `(,(core-id 'begin (expand-context-phase ctx)) + ,@exp-body)))))) + +;; ---------------------------------------- + +(add-core-form! + '#%datum + (lambda (s ctx) + (log-expand ctx 'prim-#%datum) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%datum . datum)) + (define datum (m 'datum)) + (when (and (syntax? datum) + (keyword? (syntax-e datum))) + (raise-syntax-error '#%datum "keyword misused as an expression" #f datum)) + (define phase (expand-context-phase ctx)) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-quote (keep-properties-only~ s) (syntax->datum datum)) + (rebuild + s + (list (core-id 'quote phase) + datum))))) + +;; '#%kernel `#%app` treats an empty combination as a literal null +(add-core-form! + '#%app + (lambda (s ctx) + (log-expand ctx 'prim-#%app) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%app e ...)) + (define es (m 'e)) + (cond + [(null? es) + (define phase (expand-context-phase ctx)) + (if (expand-context-to-parsed? ctx) + (parsed-quote (keep-properties-only~ s) null) + (rebuild + s + (list (core-id 'quote phase) + null)))] + [else + (define keep-for-parsed? (eq? (system-type 'vm) 'chez-scheme)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? keep-for-parsed?)) + (define prefixless (cdr (syntax-e disarmed-s))) + (define rebuild-prefixless (and (syntax? prefixless) + (keep-as-needed ctx prefixless #:keep-for-parsed? keep-for-parsed?))) + (define expr-ctx (as-expression-context ctx)) + (log-expand* expr-ctx ['enter-list (datum->syntax #f es s)] ['next]) + (define rest-es (cdr es)) + (define exp-rator (expand (car es) expr-ctx)) + (define exp-es (for/list ([e (in-list rest-es)]) + (log-expand expr-ctx 'next) + (expand e expr-ctx))) + (cond + [(expand-context-to-parsed? ctx) + (parsed-app (or rebuild-prefixless rebuild-s) exp-rator exp-es)] + [else + (define es (let ([exp-es (cons exp-rator exp-es)]) + (if rebuild-prefixless + (rebuild rebuild-prefixless exp-es) + exp-es))) + (log-expand expr-ctx 'exit-list (datum->syntax #f es rebuild-s)) + (rebuild rebuild-s (cons (m '#%app) es))])]))) + + +(add-core-form! + 'quote + (lambda (s ctx) + (log-expand ctx 'prim-quote) + (define-match m (syntax-disarm s) '(quote datum)) + (if (expand-context-to-parsed? ctx) + (parsed-quote (keep-properties-only~ s) (syntax->datum (m 'datum))) + s))) + +(add-core-form! + 'quote-syntax + (lambda (s ctx) + (log-expand ctx 'prim-quote-syntax) + (define disarmed-s (syntax-disarm s)) + (define-match m-local disarmed-s #:try '(quote-syntax datum #:local)) + (define-match m disarmed-s #:unless (m-local) '(quote-syntax datum)) + (cond + [(m-local) + ;; #:local means don't prune, and it counts as a reference to + ;; all variables for letrec splitting + (reference-records-all-used! (expand-context-reference-records ctx)) + (define-match m-kw disarmed-s '(_ _ kw)) + (if (expand-context-to-parsed? ctx) + (parsed-quote-syntax (keep-properties-only~ s) (m-local 'datum)) + (rebuild + s + `(,(m-local 'quote-syntax) ,(m-local 'datum) ,(m-kw 'kw))))] + [else + ;; otherwise, prune scopes up to transformer boundary: + (define use-site-scopes (root-expand-context-use-site-scopes ctx)) + (define datum-s (remove-scopes (remove-scopes (m 'datum) (expand-context-scopes ctx)) + (if use-site-scopes (unbox use-site-scopes) '()))) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-quote-syntax (keep-properties-only~ s) datum-s) + (rebuild + s + `(,(m 'quote-syntax) + ,datum-s)))]))) + +(add-core-form! + 'if + (lambda (s ctx) + (log-expand ctx 'prim-if) + (define disarmed-s (syntax-disarm s)) + (define-match bad-m disarmed-s #:try '(_ _ _)) + (when (bad-m) (raise-syntax-error #f "missing an \"else\" expression" s)) + (define-match m disarmed-s '(if tst thn els)) + (define expr-ctx (as-expression-context ctx)) + (define tail-ctx (as-tail-context expr-ctx #:wrt ctx)) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-tst (expand (m 'tst) expr-ctx)) + (log-expand ctx 'next) + (define exp-thn (expand (m 'thn) tail-ctx)) + (log-expand ctx 'next) + (define exp-els (expand (m 'els) tail-ctx)) + (if (expand-context-to-parsed? ctx) + (parsed-if rebuild-s exp-tst exp-thn exp-els) + (rebuild + rebuild-s + (list (m 'if) exp-tst exp-thn exp-els))))) + +(add-core-form! + 'with-continuation-mark + (lambda (s ctx) + (log-expand ctx 'prim-with-continuation-mark) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(with-continuation-mark key val body)) + (define expr-ctx (as-expression-context ctx)) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-key (expand (m 'key) expr-ctx)) + (log-expand ctx 'next) + (define exp-val (expand (m 'val) expr-ctx)) + (log-expand ctx 'next) + (define exp-body (expand (m 'body) (as-tail-context expr-ctx #:wrt ctx))) + (if (expand-context-to-parsed? ctx) + (parsed-with-continuation-mark rebuild-s exp-key exp-val exp-body) + (rebuild + rebuild-s + (list (m 'with-continuation-mark) exp-key exp-val exp-body))))) + +(define (make-begin log-tag parsed-begin + #:list-start-index list-start-index + #:last-is-tail? last-is-tail?) + (lambda (s ctx) + (log-expand ctx log-tag) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(begin e ...+)) + (define expr-ctx (if last-is-tail? + (as-begin-expression-context ctx) + (as-expression-context ctx))) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-es + (let loop ([es (m 'e)] [index list-start-index]) + (when (zero? index) + (log-expand... ctx + (lambda (obs) + (unless (zero? list-start-index) + (...log-expand obs ['next])) + (...log-expand obs ['enter-list (datum->syntax #f es rebuild-s)])))) + (cond + [(null? es) null] + [else + (define rest-es (cdr es)) + (log-expand ctx 'next) + (cons (expand (car es) (if (and last-is-tail? (null? rest-es)) + (as-tail-context expr-ctx #:wrt ctx) + expr-ctx)) + (loop rest-es (sub1 index)))]))) + (log-expand ctx 'exit-list (datum->syntax #f (list-tail exp-es list-start-index) rebuild-s)) + (if (expand-context-to-parsed? ctx) + (parsed-begin rebuild-s exp-es) + (rebuild + rebuild-s + (cons (m 'begin) exp-es))))) + +(add-core-form! + 'begin + (let ([nonempty-begin (make-begin 'prim-begin parsed-begin #:list-start-index 0 #:last-is-tail? #t)]) + (lambda (s ctx) + ;; Empty `begin` allowed in 'top-level and 'module contexts, + ;; which might get here via `local-expand`: + (define context (expand-context-context ctx)) + (cond + [(or (eq? context 'top-level) (eq? context 'module)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s #:try '(begin)) + (if (m) + s + (nonempty-begin s ctx))] + [else + (nonempty-begin s ctx)])))) + +(add-core-form! + 'begin0 + (make-begin 'prim-begin0 parsed-begin0 #:list-start-index 1 #:last-is-tail? #f)) + +(define (register-eventual-variable!? id ctx) + (cond + [(and (expand-context-need-eventually-defined ctx) + ((expand-context-phase ctx) . >= . 1)) + ;; In top level or `begin-for-syntax`, encountered a reference to a + ;; variable that might be defined later; record it for later checking + (hash-update! (expand-context-need-eventually-defined ctx) + (expand-context-phase ctx) + (lambda (l) (cons id l)) + null) + #t] + [else #f])) + +(add-core-form! + '#%top + (lambda (s ctx [implicit-omitted? #f]) + (log-expand ctx 'prim-#%top) + (define disarmed-s (syntax-disarm s)) + (define id (cond + [implicit-omitted? + ;; As a special favor to `local-expand`, the expander + ;; has avoided making `#%top` explicit + s] + [else + (define-match m disarmed-s '(#%top . id)) + (m 'id)])) + (define b (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous)) + (cond + [(eq? b 'ambiguous) + (raise-ambiguous-error id ctx)] + [(and b + (module-binding? b) + (eq? (module-binding-module b) (root-expand-context-self-mpi ctx))) + ;; Allow `#%top` in a module or top-level where it refers to the same + ;; thing that the identifier by itself would refer to; in that case + ;; `#%top` can be stripped within a module + (if (expand-context-to-parsed? ctx) + (parsed-id id b #f) + (cond + [(top-level-module-path-index? (module-binding-module b)) s] + [else id]))] + [(register-eventual-variable!? id ctx) + ;; Must be in a module, and we'll check the binding later, so strip `#%top`: + (if (expand-context-to-parsed? ctx) + (parsed-id id b #f) + id)] + [else + (cond + [(not (expand-context-allow-unbound? ctx)) + ;; In a module, unbound or out of context: + (raise-unbound-syntax-error #f "unbound identifier" id #f null + (syntax-debug-info-string id ctx))] + [else + ;; At the top level: + (define tl-id (add-scope id (root-expand-context-top-level-bind-scope ctx))) + (define tl-b (resolve tl-id (expand-context-phase ctx))) + (cond + [tl-b + ;; Expand to a reference to a top-level variable, instead of + ;; a local or required variable; don't include the temporary + ;; binding scope in an expansion, though, in the same way that + ;; `define-values` expands without it + (if (expand-context-to-parsed? ctx) + (parsed-top-id tl-id tl-b #f) + (cond + [implicit-omitted? id] + [else + (define-match m disarmed-s '(#%top . id)) + (rebuild s (cons (m '#%top) id))]))] + [else (if (expand-context-to-parsed? ctx) + (parsed-top-id id b #f) + s)])])]))) + +(add-core-form! + 'set! + (lambda (s ctx) + (log-expand ctx 'prim-set!) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(set! id rhs)) + (define orig-id (m 'id)) + (let rename-loop ([id orig-id] [from-rename? #f]) + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (when (eq? binding 'ambiguous) + (raise-ambiguous-error id ctx)) + (define-values (t primitive? insp protected?) (if binding + (lookup binding ctx s) + (values #f #f #f #f))) + (log-expand ctx 'resolve id) + (cond + [(or (variable? t) + (and (not binding) + (or (register-eventual-variable!? id ctx) + (expand-context-allow-unbound? ctx)))) + (when (and (module-binding? binding) + (not (eq? (module-binding-module binding) + (root-expand-context-self-mpi ctx)))) + (raise-syntax-error #f "cannot mutate module-required identifier" s id)) + (log-expand ctx 'next) + (register-variable-referenced-if-local! binding) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-rhs (expand (m 'rhs) (as-expression-context ctx))) + (if (expand-context-to-parsed? ctx) + (parsed-set! rebuild-s (parsed-id id binding #f) exp-rhs) + (rebuild + rebuild-s + (list (m 'set!) + (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx))) + exp-rhs)))] + [(not binding) + (raise-unbound-syntax-error #f "unbound identifier" s id null + (syntax-debug-info-string id ctx))] + [(set!-transformer? t) + (cond + [(not-in-this-expand-context? t ctx) + (expand (avoid-current-expand-context (substitute-set!-rename s disarmed-s (m 'set!) (m 'rhs) id from-rename? ctx) t ctx) + ctx)] + [else + (define-values (exp-s re-ctx) + (apply-transformer t insp s orig-id ctx binding #:origin-id orig-id)) + (cond + [(expand-context-just-once? ctx) exp-s] + [else (expand exp-s re-ctx)])])] + [(rename-transformer? t) + (cond + [(not-in-this-expand-context? t ctx) + (expand (avoid-current-expand-context (substitute-set!-rename s disarmed-s (m 'set!) (m 'rhs) id from-rename? ctx t) t ctx) + ctx)] + [else (rename-loop (syntax-track-origin (rename-transformer-target-in-context t ctx) id id) #t)])] + [else + (raise-syntax-error #f "cannot mutate syntax identifier" s id)])))) + +(define (substitute-set!-rename s disarmed-s set!-id id rhs-s from-rename? ctx [t #f]) + (cond + [(or t from-rename?) + (define new-id (if t + (rename-transformer-target-in-context t ctx) + id)) + (syntax-rearm (datum->syntax disarmed-s (list set!-id new-id rhs-s) disarmed-s disarmed-s) + s)] + [else s])) + +(add-core-form! + '#%variable-reference + (lambda (s ctx) + (log-expand ctx 'prim-#%variable-reference) + (define disarmed-s (syntax-disarm s)) + (define-match id-m disarmed-s #:try '(#%variable-reference id)) + (define-match top-m disarmed-s #:unless (id-m) #:try '(#%variable-reference (#%top . id))) + (define-match empty-m disarmed-s #:unless (or (id-m) (top-m)) '(#%variable-reference)) + (cond + [(or (id-m) (top-m)) + (define var-id (if (id-m) (id-m 'id) (top-m 'id))) + (define binding (resolve+shift var-id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous)) + (when (eq? binding 'ambiguous) + (raise-ambiguous-error var-id ctx)) + (unless (or binding + (expand-context-allow-unbound? ctx)) + (raise-unbound-syntax-error #f "unbound identifier" s var-id null + (syntax-debug-info-string var-id ctx))) + (define-values (t primitive? insp-of-t protected?) + (if binding + (lookup binding ctx var-id + #:in s + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx)) + (values #f #f #f #f))) + (when (and t (not (variable? t))) + (raise-syntax-error #f "identifier does not refer to a variable" var-id s)) + (if (expand-context-to-parsed? ctx) + (parsed-#%variable-reference (keep-properties-only~ s) + ;; Intentionally not using `parsed-primitive-id`; + ;; see also `variable-reference->namespace` + (cond + [(top-m) (parsed-top-id var-id binding #f)] + [else (parsed-id var-id binding #f)])) + s)] + [else + (if (expand-context-to-parsed? ctx) + (parsed-#%variable-reference (keep-properties-only~ s) #f) + s)]))) + +(add-core-form! + '#%expression + (lambda (s ctx) + (log-expand ctx 'prim-#%expression) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%expression e)) + (define rebuild-s (keep-as-needed ctx s #:for-track? #t)) + (define exp-e (expand (m 'e) (as-tail-context (as-expression-context ctx) + #:wrt ctx))) + (if (expand-context-to-parsed? ctx) + exp-e + (cond + [(or (and (expand-context-in-local-expand? ctx) + (expand-context-keep-#%expression? ctx)) + (eq? 'top-level (expand-context-context ctx))) + (rebuild + rebuild-s + `(,(m '#%expression) ,exp-e))] + [else + (define result-s (syntax-track-origin exp-e rebuild-s)) + (log-expand ctx 'tag result-s) + result-s])))) + +;; ---------------------------------------- + +;; Historically in '#%kernel, should be moved out +(add-core-form! + 'unquote + (lambda (s ctx) + (raise-syntax-error #f "not in quasiquote" s))) +(add-core-form! + 'unquote-splicing + (lambda (s ctx) + (raise-syntax-error #f "not in quasiquote" s))) diff -Nru racket-6.12+ppa1/src/expander/expand/free-id-set.rkt racket-7.0+ppa1/src/expander/expand/free-id-set.rkt --- racket-6.12+ppa1/src/expander/expand/free-id-set.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/free-id-set.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base +(require "../common/list-ish.rkt" + "../syntax/syntax.rkt" + "../syntax/binding.rkt") + +(provide free-id-set + empty-free-id-set + free-id-set-empty? + free-id-set-member? + free-id-set-empty-or-just-module*?) + +;; A free-id-set is a hash: sym -> list of id + +(define (free-id-set phase ids) + (for/fold ([ht #hasheq()]) ([id (in-list ids)]) + (define sym (identifier-binding-symbol id phase)) + (hash-set ht sym (cons-ish id (hash-ref ht sym null))))) + +(define empty-free-id-set (free-id-set 0 null)) + +(define (free-id-set-empty? fs) + (eq? fs empty-free-id-set)) + +(define (free-id-set-member? fs phase given-id) + (if (free-id-set-empty? fs) + #f + (for/or ([id (in-list-ish (hash-ref fs + (identifier-binding-symbol given-id phase) + null))]) + (free-identifier=? id given-id phase phase)))) + +(define (free-id-set-empty-or-just-module*? fs) + (define c (hash-count fs)) + ;; If any identifier other than `module*` is present, then many + ;; identifiers are present + (c . <= . 1)) diff -Nru racket-6.12+ppa1/src/expander/expand/liberal-def-ctx.rkt racket-7.0+ppa1/src/expander/expand/liberal-def-ctx.rkt --- racket-6.12+ppa1/src/expander/expand/liberal-def-ctx.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/liberal-def-ctx.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +#lang racket/base + +(provide prop:liberal-define-context + (rename-out [has-liberal-define-context-property? liberal-define-context?]) + make-liberal-define-context) + +(define-values (prop:liberal-define-context has-liberal-define-context-property? liberal-define-context-value) + (make-struct-type-property 'liberal-define-context)) + +(struct liberal-define-context () + #:transparent + #:property prop:liberal-define-context #t + #:constructor-name make-liberal-define-context) + + + diff -Nru racket-6.12+ppa1/src/expander/expand/lift-context.rkt racket-7.0+ppa1/src/expander/expand/lift-context.rkt --- racket-6.12+ppa1/src/expander/expand/lift-context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/lift-context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,227 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../namespace/core.rkt" + "../namespace/namespace.rkt" + "root-expand-context.rkt" + "context.rkt" + "def-id.rkt") + +;; Helpers to implement the consumer side of `syntax-local-lift-expression`, +;; `syntax-local-lift-module`, etc. These structures are used by `syntax-local-...` +;; functions as communicated through the current expand context. + +(provide make-lift-context + add-lifted! + get-and-clear-lifts! + + make-local-lift + make-top-level-lift + wrap-lifts-as-let + wrap-lifts-as-begin + get-lifts-as-lists + + make-module-lift-context + get-and-clear-module-lifts! + add-lifted-module! + module-lift-context-wrt-phase + + make-require-lift-context + add-lifted-require! + get-and-clear-require-lifts! + require-lift-context-wrt-phase + + make-to-module-lift-context + make-shared-module-ends + to-module-lift-context-end-as-expressions? + get-and-clear-end-lifts! + get-and-clear-provide-lifts! + add-lifted-to-module-provide! + add-lifted-to-module-end! + to-module-lift-context-wrt-phase) + +;; ---------------------------------------- + +(define (box-cons! b v) + (set-box! b (cons v (unbox b)))) + +(define (box-clear! b) + (begin0 + (reverse (unbox b)) + (set-box! b null))) + +;; ---------------------------------------- + +(struct lift-context (convert ; takes a list of ids and rhs to produce a lifted-bind + lifts ; box of list of lifted-binds and maybe other forms + module*-ok?) ; if used to capture module lifts, allow `module*`? + #:authentic) +(struct lifted-bind (ids keys rhs) #:authentic) + +(define (make-lift-context convert #:module*-ok? [module*-ok? #f]) + (lift-context convert (box null) module*-ok?)) + +(define (add-lifted! lifts ids rhs phase) + (define-values (lifted-ids lifted) ((lift-context-convert lifts) ids rhs phase)) + (box-cons! (lift-context-lifts lifts) lifted) + lifted-ids) + +(define (get-and-clear-lifts! lifts) + (box-clear! (lift-context-lifts lifts))) + +(define (make-local-lift lift-env counter) + (lambda (ids rhs phase) + (define keys + (for/list ([id (in-list ids)]) + (define key (add-local-binding! id phase counter)) + (set-box! lift-env (hash-set (unbox lift-env) key variable)) + key)) + (values ids (lifted-bind ids keys rhs)))) + +(define (make-top-level-lift ctx) + (lambda (ids rhs phase) + ;; Add the namespace's post-expansion scope (i.e., the inside-edge + ;; scope) so that the binding has a specific phase: + (define post-scope + (post-expansion-scope + (root-expand-context-post-expansion + (namespace-get-root-expand-ctx + (expand-context-namespace ctx))))) + (define tl-ids (for/list ([id (in-list ids)]) + (add-scope id post-scope))) + ;; Bind the identifier: + (define syms (select-defined-syms-and-bind!/ctx tl-ids ctx)) + (values tl-ids (lifted-bind tl-ids syms rhs)))) + +(define (wrap-lifts-as-let lifts body phase) + (datum->syntax + #f + (for/fold ([body body]) ([lift (in-list (reverse lifts))]) + (unless (lifted-bind? lift) + (error "non-bindings in `lift-context`")) + (list (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'let-values) + (list (list (lifted-bind-ids lift) + (lifted-bind-rhs lift))) + body)))) + +(define (wrap-lifts-as-begin lifts body phase + #:adjust-form [adjust-form values] + #:adjust-body [adjust-body values]) + (datum->syntax + #f + (cons (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'begin) + (append + (for/list ([lift (in-list lifts)]) + (adjust-form + (cond + [(lifted-bind? lift) + (datum->syntax + #f + (list (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'define-values) + (lifted-bind-ids lift) + (lifted-bind-rhs lift)))] + [else lift]))) + (list (adjust-body body)))))) + +(define (get-lifts-as-lists lifts) + (for/list ([lift (in-list lifts)]) + (list (lifted-bind-ids lift) + (lifted-bind-keys lift) + (lifted-bind-rhs lift)))) + +;; ---------------------------------------- + +(struct module-lift-context (wrt-phase ; phase of target for lifts + lifts ; box of list of lifted + module*-ok?) ; whether `module*` is allowed + #:authentic) + +(define (make-module-lift-context phase module*-ok?) + (module-lift-context phase (box null) module*-ok?)) + +(define (get-and-clear-module-lifts! module-lifts) + (box-clear! (module-lift-context-lifts module-lifts))) + +(define (add-lifted-module! module-lifts s phase) + (unless (or (and (module-lift-context? module-lifts) + (module-lift-context-module*-ok? module-lifts)) + (and (lift-context? module-lifts) + (lift-context-module*-ok? module-lifts))) + (case (core-form-sym s phase) + [(module) (void)] + [(module*) + (raise-arguments-error 'syntax-local-lift-module + "cannot lift `module*' to a top-level context" + "syntax" s)] + [else + (raise-arguments-error 'syntax-local-lift-module + "not a `module' declaration" + "syntax" s)])) + (cond + [(module-lift-context? module-lifts) + (box-cons! (module-lift-context-lifts module-lifts) s)] + [(lift-context? module-lifts) + ;; Top-level expansion uses a `lift-context` for both, which keeps + ;; modules and other lifts in order + (box-cons! (lift-context-lifts module-lifts) s)] + [else + (error "internal error: unrecognized lift-context type for module lift")])) + +;; ---------------------------------------- + +(struct require-lift-context (do-require ; callback to process a lifted require + wrt-phase ; phase of target for lifts + requires) ; records lifted requires + #:authentic) + +(define (make-require-lift-context wrt-phase do-require) + (require-lift-context do-require wrt-phase (box null))) + +(define (get-and-clear-require-lifts! require-lifts) + (box-clear! (require-lift-context-requires require-lifts))) + +(define (add-lifted-require! require-lifts s phase) + ((require-lift-context-do-require require-lifts) s phase) + (box-cons! (require-lift-context-requires require-lifts) + s)) + +;; ---------------------------------------- + +(struct to-module-lift-context (wrt-phase ; phase of target for lifts + provides + end-as-expressions? + ends) + #:authentic) + +(define (make-to-module-lift-context phase + #:shared-module-ends ends + #:end-as-expressions? end-as-expressions?) + (to-module-lift-context phase + (box null) + end-as-expressions? + ends)) + +(define (make-shared-module-ends) + (box null)) + +(define (get-and-clear-end-lifts! to-module-lifts) + (box-clear! (to-module-lift-context-ends to-module-lifts))) + +(define (get-and-clear-provide-lifts! to-module-lifts) + (box-clear! (to-module-lift-context-provides to-module-lifts))) + +(define (add-lifted-to-module-provide! to-module-lifts s phase) + (box-cons! (to-module-lift-context-provides to-module-lifts) + s)) + +(define (add-lifted-to-module-end! to-module-lifts s phase) + (box-cons! (to-module-lift-context-ends to-module-lifts) + s)) diff -Nru racket-6.12+ppa1/src/expander/expand/lift-key.rkt racket-7.0+ppa1/src/expander/expand/lift-key.rkt --- racket-6.12+ppa1/src/expander/expand/lift-key.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/lift-key.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base + +;; A lift key represents a target for lifting, such as a particular +;; module body, a particular namespace, or a particular capture point + +(provide generate-lift-key) + +(define (generate-lift-key) + (gensym 'lift)) diff -Nru racket-6.12+ppa1/src/expander/expand/local-expand.rkt racket-7.0+ppa1/src/expander/expand/local-expand.rkt --- racket-6.12+ppa1/src/expander/expand/local-expand.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/local-expand.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,154 @@ +#lang racket/base +(require "../common/performance.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../namespace/core.rkt" + "../namespace/module.rkt" + "context.rkt" + "main.rkt" + "syntax-local.rkt" + "definition-context.rkt" + "already-expanded.rkt" + "lift-key.rkt" + "log.rkt" + "parsed.rkt") + +(provide local-expand + local-expand/capture-lifts + local-transformer-expand + local-transformer-expand/capture-lifts + syntax-local-expand-expression) + +(define (local-expand s context stop-ids [intdefs '()]) + (do-local-expand 'local-expand s context stop-ids intdefs)) + +(define (local-expand/capture-lifts s context stop-ids [intdefs '()] [lift-key (generate-lift-key)]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:capture-lifts? #t + #:lift-key lift-key)) + +(define (local-transformer-expand s context stop-ids [intdefs '()]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:as-transformer? #t)) + +(define (local-transformer-expand/capture-lifts s context stop-ids [intdefs '()] [lift-key (generate-lift-key)]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:as-transformer? #t + #:capture-lifts? #t + #:lift-key lift-key)) + +(define (syntax-local-expand-expression s [opaque-only? #f]) + (define exp-s (do-local-expand 'syntax-local-expand-expression s 'expression null #f + #:to-parsed-ok? opaque-only? + #:skip-log-exit? #t + #:track-to-be-defined? #t + #:keep-#%expression? #f)) + (define ctx (get-current-expand-context)) + ;; Move introduction scope from the already-expanded syntax object to + ;; its wrapper. The expander will later check that the wrapper ends up + ;; with an empty set of scopes, and then the already-expanded inside has + ;; the scopes suitably flipped + (define ae (flip-introduction-scopes + (datum->syntax #f (already-expanded + (if (parsed? exp-s) + exp-s + (flip-introduction-scopes exp-s ctx)) + (expand-context-binding-layer ctx))) + ctx)) + (log-expand ctx 'opaque-expr ae) + (log-expand ctx 'exit-local exp-s) + (values (and (not opaque-only?) exp-s) ae)) + +;; ---------------------------------------- + +(define (do-local-expand who s-or-s-exp context stop-ids [intdefs '()] + #:capture-lifts? [capture-lifts? #f] + #:as-transformer? [as-transformer? #f] + #:to-parsed-ok? [to-parsed-ok? #f] + #:keep-#%expression? [keep-#%expression? #t] + #:lift-key [lift-key (and (or capture-lifts? + as-transformer?) + (generate-lift-key))] + #:track-to-be-defined? [track-to-be-defined? #f] + #:skip-log-exit? [skip-log-exit? #f]) + (performance-region + ['expand 'local-expand] + + (define s (datum->syntax #f s-or-s-exp)) + (unless (or (list? context) + (memq context (if as-transformer? + '(expression top-level) + '(expression top-level module module-begin)))) + (raise-argument-error who + (if as-transformer? + "(or/c 'expression 'top-level list?)" + "(or/c 'expression 'top-level 'module 'module-begin list?)") + context)) + (unless (or (not stop-ids) + (and (list? stop-ids) + (andmap identifier? stop-ids))) + (raise-argument-error who "(or/c (listof identifier?) #f)" stop-ids)) + (unless (intdefs-or-false? intdefs) + (raise-argument-error who intdefs-or-false?-string intdefs)) + + (define ctx (get-current-expand-context who)) + (define phase (if as-transformer? + (add1 (expand-context-phase ctx)) + (expand-context-phase ctx))) + (define local-ctx (make-local-expand-context ctx + #:context context + #:phase phase + #:intdefs intdefs + #:stop-ids stop-ids + #:to-parsed-ok? to-parsed-ok? + #:keep-#%expression? (or keep-#%expression? + (and (expand-context-in-local-expand? ctx) + (expand-context-keep-#%expression? ctx))) + #:track-to-be-defined? track-to-be-defined?)) + + (namespace-visit-available-modules! (expand-context-namespace ctx) phase) + + (log-expand local-ctx 'enter-local s) + (define input-s (add-intdef-scopes (flip-introduction-scopes s ctx) intdefs)) + + (when as-transformer? (log-expand local-ctx 'phase-up)) + (log-expand local-ctx 'local-pre input-s) + (when stop-ids (log-expand local-ctx 'start)) + + (define output-s (cond + [(and as-transformer? capture-lifts?) + (expand-transformer input-s local-ctx + #:context context + #:expand-lifts? #f + #:begin-form? #t + #:lift-key lift-key + #:always-wrap? #t + #:keep-stops? #t)] + [as-transformer? + (expand-transformer input-s local-ctx + #:context context + #:expand-lifts? #f + #:begin-form? (eq? 'top-level context) + #:lift-key lift-key + #:keep-stops? #t)] + [capture-lifts? + (expand/capture-lifts input-s local-ctx + #:begin-form? #t + #:lift-key lift-key + #:always-wrap? #t)] + [else + (expand input-s local-ctx)])) + + (log-expand local-ctx 'local-post output-s) + + (define result-s (if (parsed? output-s) + output-s + (flip-introduction-scopes output-s ctx))) + + (unless skip-log-exit? + (log-expand local-ctx 'exit-local result-s)) + + result-s)) diff -Nru racket-6.12+ppa1/src/expander/expand/log.rkt racket-7.0+ppa1/src/expander/expand/log.rkt --- racket-6.12+ppa1/src/expander/expand/log.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/log.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,135 @@ +#lang racket/base +(require "context.rkt") + +(provide log-expand + log-expand* + log-expand... + ...log-expand) + +(define-syntax log-expand... + (syntax-rules (lambda) + [(_ ctx (lambda (obs) body ...)) + (let ([obs (expand-context-observer ctx)]) + (when obs + body ...))])) + +(define-syntax-rule (...log-expand obs [key arg ...] ...) + (begin + (call-expand-observe obs key arg ...) + ...)) + +(define-syntax log-expand* + (syntax-rules () + [(_ ctx #:when guard [key arg ...] ...) + (log-expand... ctx + (lambda (obs) + (when guard + (...log-expand obs [key arg ...] ...))))] + [(_ ctx #:unless guard [key arg ...] ...) + (log-expand* ctx #:when (not guard) [key arg ...] ...)] + [(_ ctx [key arg ...] ...) + (log-expand* ctx #:when #t [key arg ...] ...)])) + +(define-syntax-rule (log-expand ctx key arg ...) + (log-expand* ctx #:when #t [key arg ...])) + +(define (call-expand-observe obs key . args) + (cond + [(hash-ref key->arity key #f) + => (lambda (arity) + (unless (or (eq? arity 'any) (eqv? (length args) arity)) + (error 'call-expand-observe "wrong arity for ~s: ~e" key args)))] + [else (error 'call-expand-observe "bad key: ~s" key)]) + (obs key (cond + [(null? args) #f] + [else (apply list* args)]))) + +(define key->arity + ;; event-symbol => (U Nat 'any) + #hash(;; basic empty tokens + (start . 0) + (start-top . 0) + (next . 0) + (next-group . 0) + (phase-up . 0) + (enter-bind . 0) + (exit-bind . 0) + (exit-local-bind . 0) + (prepare-env . 0) + + ;; basic tokens + (visit . 1) + (resolve . 1) + (enter-macro . 1) + (macro-pre-x . 1) + (macro-post-x . 2) + (exit-macro . 1) + (enter-prim . 1) + (exit-prim . 1) + (return . 1) + (enter-block . 1) + (block->list . 1) + (block->letrec . 1) + (splice . 1) + (enter-list . 1) + (exit-list . 1) + (enter-check . 1) + (exit-check . 1) + (module-body . 1) + (lift-loop . 1) + (letlift-loop . 1) + (module-lift-loop . 1) + (module-lift-end-loop . 1) + (lift-expr . 2) + (lift-statement . 1) + (lift-require . 3) + (lift-provide . 1) + (enter-local . 1) + (local-pre . 1) + (local-post . 1) + (exit-local . 1) + (local-bind . 1) + (opaque-expr . 1) + (variable . 2) + (tag . 1) + (rename-one . 1) + (rename-list . 1) + (track-origin . 2) + (local-value . 1) + (local-value-result . 1) + + ;; renames tokens ** + (lambda-renames . 2) + (let-renames . any) ;; renames consed by expander... sometimes + (letrec-syntaxes-renames . any) ;; renames consed by expander... sometimes + (block-renames . 2) + + ;; prim tokens + (prim-stop . 0) + (prim-module . 0) + (prim-module-begin . 0) + (prim-define-syntaxes . 0) + (prim-define-values . 0) + (prim-if . 0) + (prim-with-continuation-mark . 0) + (prim-begin . 0) + (prim-begin0 . 0) + (prim-#%app . 0) + (prim-lambda . 0) + (prim-case-lambda . 0) + (prim-let-values . 0) + (prim-letrec-values . 0) + (prim-letrec-syntaxes+values . 0) + (prim-#%datum . 0) + (prim-#%top . 0) + (prim-quote . 0) + (prim-quote-syntax . 0) + (prim-require . 0) + (prim-provide . 0) + (prim-set! . 0) + (prim-#%expression . 0) + (prim-#%variable-reference . 0) + (prim-#%stratified . 0) + (prim-begin-for-syntax . 0) + (prim-submodule . 0) + (prim-submodule* . 0))) diff -Nru racket-6.12+ppa1/src/expander/expand/main.rkt racket-7.0+ppa1/src/expander/expand/main.rkt --- racket-6.12+ppa1/src/expander/expand/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,790 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/taint-dispatch.rkt" + "../syntax/match.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/inspector.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "syntax-id-error.rkt" + "syntax-implicit-error.rkt" + "free-id-set.rkt" + "dup-check.rkt" + "use-site.rkt" + "../compile/main.rkt" + "../eval/top.rkt" + "../eval/direct.rkt" + "../namespace/core.rkt" + "../boot/runtime-primitive.rkt" + "context.rkt" + "lift-context.rkt" + "already-expanded.rkt" + "liberal-def-ctx.rkt" + "rename-trans.rkt" + "allowed-context.rkt" + "lift-key.rkt" + "../syntax/debug.rkt" + "reference-record.rkt" + "log.rkt" + "../common/performance.rkt" + "rebuild.rkt" + "parsed.rkt" + "expanded+parsed.rkt") + +(provide expand + lookup + apply-transformer + + register-variable-referenced-if-local! + + expand/capture-lifts + expand-transformer + expand+eval-for-syntaxes-binding + context->transformer-context + eval-for-syntaxes-binding + eval-for-bindings + + keep-properties-only + keep-properties-only~ + keep-as-needed + rebuild + attach-disappeared-transformer-bindings + increment-binding-layer + accumulate-def-ctx-scopes + rename-transformer-target-in-context + maybe-install-free=id-in-context!) + +;; ---------------------------------------- + +;; Main expander dispatch +(define (expand s ctx + ;; Aplying a rename transformer substitutes + ;; an id without changing `s` + #:alternate-id [alternate-id #f] + #:skip-log? [skip-log? #f] + ;; For expanding an implicit implemented by a rename transformer: + #:fail-non-transformer [fail-non-transformer #f]) + (log-expand* ctx #:unless skip-log? [(if (expand-context-only-immediate? ctx) 'enter-check 'visit) s]) + (cond + [(syntax-identifier? s) + (expand-identifier s ctx alternate-id)] + [(and (pair? (syntax-content s)) + (syntax-identifier? (car (syntax-content s)))) + (expand-id-application-form s ctx alternate-id + #:fail-non-transformer fail-non-transformer)] + [(or (pair? (syntax-content s)) + (null? (syntax-content s))) + ;; An "application" form that doesn't start with an identifier, so + ;; use implicit `#%app` + (expand-implicit '#%app s ctx #f)] + [(already-expanded? (syntax-content s)) + (expand-already-expanded s ctx)] + [else + ;; Anything other than an identifier or parens triggers the + ;; implicit `#%datum` form + (expand-implicit '#%datum s ctx #f)])) + +;; An identifier by itself (i.e., not after an open parenthesis) +(define (expand-identifier s ctx alternate-id) + (define id (or alternate-id s)) + (guard-stop + id ctx s + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id]) + (cond + [(eq? binding 'ambiguous) + (raise-ambiguous-error id ctx)] + [(not binding) + ;; The implicit `#%top` form handles unbound identifiers + (expand-implicit '#%top (substitute-alternate-id s alternate-id) ctx s)] + [else + ;; Variable or form as identifier macro + (define-values (t primitive? insp-of-t protected?) + (lookup binding ctx id + #:in (and alternate-id s) + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) + (dispatch t insp-of-t s id ctx binding primitive? protected?)]))) + +;; An "application" form that starts with an identifier +(define (expand-id-application-form s ctx alternate-id + #:fail-non-transformer fail-non-transformer) + (define id (or alternate-id (car (syntax-e/no-taint s)))) + (guard-stop + id ctx s + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id]) + (cond + [(eq? binding 'ambiguous) + (when fail-non-transformer (fail-non-transformer)) + (raise-ambiguous-error id ctx)] + [(not binding) + (when fail-non-transformer (fail-non-transformer)) + ;; The `#%app` binding might do something with unbound ids + (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] + [else + ;; Find out whether it's bound as a variable, syntax, or core form + (define-values (t primitive? insp-of-t protected?) + (lookup binding ctx id + #:in (and alternate-id (car (syntax-e/no-taint s))) + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) + (cond + [(variable? t) + (when fail-non-transformer (fail-non-transformer)) + ;; Not as syntax or core form, so use implicit `#%app` + (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] + [else + ;; Syntax or core form as "application" + (dispatch t insp-of-t s id ctx binding primitive? protected? + #:fail-non-transformer fail-non-transformer)])]))) + +;; Handle an implicit: `#%app`, `#%top`, or `#%datum`; this is similar +;; to handling an id-application form, but there are several little +;; differences: the binding must be a core form or transformer, +;; an implicit `#%top` is handled specially, and so on +(define (expand-implicit sym s ctx trigger-id) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + s] + [else + (define disarmed-s (syntax-disarm s)) + (define id (datum->syntax disarmed-s sym)) + (guard-stop + id ctx s + (log-expand* ctx ['resolve id]) + (define b (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (cond + [(eq? b 'ambiguous) + (raise-ambiguous-error id ctx)] + [else + (define-values (t primitive? insp-of-t protected?) + (if b (lookup b ctx id) (values #f #f #f #f))) + (cond + [(transformer? t) + (define fail-non-transformer + ;; Make sure a rename transformer eventualy leads to syntax + (and (rename-transformer? t) + (lambda () + (raise-syntax-implicit-error s sym trigger-id ctx)))) + (dispatch-transformer t insp-of-t (make-explicit ctx sym s disarmed-s) id ctx b + #:fail-non-transformer fail-non-transformer)] + [(core-form? t) + (cond + [(and (eq? sym '#%top) + (eq? (core-form-name t) '#%top) + (expand-context-in-local-expand? ctx)) + (dispatch-implicit-#%top-core-form t s ctx)] + [else + (dispatch-core-form t (make-explicit ctx sym s disarmed-s) ctx)])] + [else + (define tl-id + (and (eq? sym '#%top) + (root-expand-context-top-level-bind-scope ctx) + (add-scope s (root-expand-context-top-level-bind-scope ctx)))) + (define tl-b (and tl-id (resolve tl-id (expand-context-phase ctx)))) + (cond + [tl-b + ;; Special case: the identifier is not bound and its scopes don't + ;; have a binding for `#%top`, but it's bound temporaily for compilation; + ;; treat the identifier as a variable reference + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-id tl-id tl-b #f) + tl-id)] + [else + (raise-syntax-implicit-error s sym trigger-id ctx)])])]))])) + +;; An expression that is already fully expanded via `local-expand-expression` +(define (expand-already-expanded s ctx) + (define ae (syntax-e s)) + (define exp-s (already-expanded-s ae)) + (when (or (syntax-any-macro-scopes? s) + (not (eq? (expand-context-binding-layer ctx) + (already-expanded-binding-layer ae))) + (and (parsed? exp-s) + (not (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx)))))) + (raise-syntax-error #f + (string-append "expanded syntax not in its original lexical context;\n" + " extra bindings or scopes in the current context") + (and (not (parsed? exp-s)) exp-s))) + (cond + [(expand-context-only-immediate? ctx) + s] + [(parsed? exp-s) exp-s] + [else + (define result-s (syntax-track-origin exp-s s)) + (log-expand ctx 'opaque-expr result-s) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (expand result-s ctx) ; fully expanded to compiled + result-s)])) + +(define (make-explicit ctx sym s disarmed-s) + (define new-s (syntax-rearm (datum->syntax disarmed-s (cons sym disarmed-s) s s) s)) + (log-expand ctx 'tag new-s) + new-s) + +;; ---------------------------------------- + +;; Expand `s` given that the value `t` of the relevant binding, +;; where `t` is either a core form, a macro transformer, some +;; other compile-time value (which is an error), or a token +;; indicating that the binding is a run-time variable; note that +;; `s` is not disarmed +(define (dispatch t insp-of-t s id ctx binding primitive? protected? + #:fail-non-transformer [fail-non-transformer #f]) + (cond + [(core-form? t) + (dispatch-core-form t s ctx)] + [(transformer? t) + (dispatch-transformer t insp-of-t s id ctx binding + #:fail-non-transformer fail-non-transformer)] + [(variable? t) + (dispatch-variable t s id ctx binding primitive? protected?)] + [else + ;; Some other compile-time value: + (raise-syntax-error #f "illegal use of syntax" s)])) + +;; Call a core-form expander (e.g., `lambda`) +(define (dispatch-core-form t s ctx) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + s] + [(expand-context-observer ctx) + (log-expand ctx 'enter-prim s) + (define result-s ((core-form-expander t) s ctx)) + (log-expand* ctx ['exit-prim (extract-syntax result-s)] ['return (extract-syntax result-s)]) + result-s] + [else + ;; As previous case, but as a tail call: + ((core-form-expander t) s ctx)])) + +;; Special favor to `local-expand` from `expand-implicit`: call +;; `#%top` form without making `#%top` explicit in the form +(define (dispatch-implicit-#%top-core-form t s ctx) + (log-expand ctx 'enter-prim s) + (define result-s ((core-form-expander t) s ctx #t)) + (log-expand* ctx ['exit-prim result-s] ['return result-s]) + result-s) + +;; Call a macro expander, taking into account whether it works +;; in the current context, whether to expand just once, etc. +(define (dispatch-transformer t insp-of-t s id ctx binding + #:fail-non-transformer fail-non-transformer) + (cond + [(not-in-this-expand-context? t ctx) + (log-expand ctx 'enter-macro s) + (define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx)) + (log-expand ctx 'exit-macro s) + (expand adj-s ctx)] + [(and (expand-context-should-not-encounter-macros? ctx) + ;; It's ok to have a rename transformer whose target + ;; is a primitive form, so if it's a rename transformer, + ;; delay the check for another step + (not (rename-transformer? t))) + (raise-syntax-error #f + "encountered a macro binding in form that should be fully expanded" + s)] + [else + (log-expand* ctx #:when (and (expand-context-only-immediate? ctx) + (not (rename-transformer? t))) + ;; The old expander would emit 'resolve for a rename transformer + ;; as long as it's not the first one encountered in immediate mode + ['visit s] ['resolve id]) + ;; Apply transformer and expand again + (define-values (exp-s re-ctx) + (if (rename-transformer? t) + (values s ctx) + (apply-transformer t insp-of-t s id ctx binding))) + (log-expand* ctx #:when (and (expand-context-only-immediate? ctx) + (not (rename-transformer? t))) + ['return exp-s]) + (cond + [(expand-context-just-once? ctx) exp-s] + [else (expand exp-s re-ctx + #:alternate-id (and (rename-transformer? t) + (syntax-track-origin (transfer-srcloc + (rename-transformer-target-in-context t ctx) + id) + id + id)) + #:skip-log? (or (expand-context-only-immediate? ctx) + (rename-transformer? t)) + #:fail-non-transformer (and (rename-transformer? t) fail-non-transformer))])])) + +;; Handle the expansion of a variable to itself +(define (dispatch-variable t s id ctx binding primitive? protected?) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + id] + [else + (log-expand ctx 'variable s id) + ;; A reference to a variable expands to itself + (register-variable-referenced-if-local! binding) + ;; If the variable is locally bound, replace the use's scopes with the binding's scopes + (define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))) + (cond + [(and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (define prop-s (keep-properties-only~ result-s)) + (define insp (syntax-inspector result-s)) + (if primitive? + (parsed-primitive-id prop-s binding insp) + (parsed-id prop-s binding insp))] + [else + (define protected-result-s (if protected? + (syntax-property result-s 'protected #t) + result-s)) + (log-expand ctx 'return protected-result-s) + protected-result-s])])) + +;; ---------------------------------------- + +;; Given a macro transformer `t`, apply it --- adding appropriate +;; scopes to represent the expansion step; the `insp-of-t` inspector +;; is the inspector of the module that defines `t`, which gives it +;; priviledge for `syntax-arm` and similar +(define (apply-transformer t insp-of-t s id ctx binding + #:origin-id [origin-id #f]) + (performance-region + ['expand '_ 'macro] + + (log-expand ctx 'enter-macro s) + (define disarmed-s (syntax-disarm s)) + (define intro-scope (new-scope 'macro)) + (define intro-s (flip-scope disarmed-s intro-scope)) + ;; In a definition context, we need use-site scopes + (define-values (use-s use-scopes) (maybe-add-use-site-scope intro-s ctx binding)) + ;; Avoid accidental transfer of taint-controlling properties: + (define cleaned-s (syntax-remove-taint-dispatch-properties use-s)) + ;; Prepare to accumulate definition contexts created by the transformer + (define def-ctx-scopes (box null)) + + ;; Call the transformer; the current expansion context may be needed + ;; for `syntax-local-....` functions, and we may accumulate scopes from + ;; definition contexts created by the transformer + (define transformed-s + (apply-transformer-in-context t cleaned-s ctx insp-of-t + intro-scope use-scopes def-ctx-scopes + id)) + + ;; Flip the introduction scope + (define result-s (flip-scope transformed-s intro-scope)) + ;; In a definition context, we need to add the inside-edge scope to + ;; any expansion result + (define post-s (maybe-add-post-expansion result-s ctx)) + ;; Track expansion: + (define tracked-s (syntax-track-origin post-s cleaned-s (or origin-id (if (syntax-identifier? s) s (car (syntax-e s)))))) + (define rearmed-s (taint-dispatch tracked-s (lambda (t-s) (syntax-rearm t-s s)) (expand-context-phase ctx))) + (log-expand ctx 'exit-macro rearmed-s) + (values rearmed-s + (accumulate-def-ctx-scopes ctx def-ctx-scopes)))) + +;; With all the pre-call scope work done and post-call scope work in +;; the continuation, actually call the transformer function in the +;; appropriate context +(define (apply-transformer-in-context t cleaned-s ctx insp-of-t + intro-scope use-scopes def-ctx-scopes + id) + (log-expand ctx 'macro-pre-x cleaned-s) + (define confine-def-ctx-scopes? + (not (or (expand-context-only-immediate? ctx) + (not (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))))) + (define accum-ctx + (if (and confine-def-ctx-scopes? + (expand-context-def-ctx-scopes ctx) + (not (null? (unbox (expand-context-def-ctx-scopes ctx))))) + (accumulate-def-ctx-scopes ctx (expand-context-def-ctx-scopes ctx)) + ctx)) + (define m-ctx (struct*-copy expand-context accum-ctx + [current-introduction-scopes (list intro-scope)] + [current-use-scopes use-scopes] + [def-ctx-scopes + (if confine-def-ctx-scopes? + ;; Can confine tracking to this call + def-ctx-scopes + ;; Keep old def-ctx-scopes box, so that we don't + ;; lose them at the point where expansion stops + (expand-context-def-ctx-scopes ctx))])) + (define transformed-s + (parameterize ([current-expand-context m-ctx] + [current-namespace (namespace->namespace-at-phase + (expand-context-namespace ctx) + (add1 (expand-context-phase ctx)))] + [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))]) + (call-with-continuation-barrier + (lambda () + ;; Call the transformer! + ((transformer->procedure t) cleaned-s))))) + (log-expand ctx 'macro-post-x transformed-s cleaned-s) + (unless (syntax? transformed-s) + (raise-arguments-error (syntax-e id) + "received value from syntax expander was not syntax" + "received" transformed-s)) + transformed-s) + +(define (maybe-add-use-site-scope s ctx binding) + (cond + [(and (root-expand-context-use-site-scopes ctx) + (matching-frame? (root-expand-context-frame-id ctx) + (binding-frame-id binding))) + ;; We're in a recursive definition context where use-site scopes + ;; are needed, so create one, record it, and add to the given + ;; syntax + (define sc (new-scope 'use-site)) + (define b (root-expand-context-use-site-scopes ctx)) + (set-box! b (cons sc (unbox b))) + (values (add-scope s sc) (list sc))] + [else (values s null)])) + +(define (matching-frame? current-frame-id bind-frame-id) + (and current-frame-id + (or (eq? current-frame-id bind-frame-id) + (eq? current-frame-id 'all)))) + +(define (maybe-add-post-expansion s ctx) + ;; We may be in a definition context where, say, an inside-edge scope + ;; needs to be added to any immediate macro expansion; that way, + ;; if the macro expands to a definition form, the binding will be + ;; in the definition context's scope. The sepcific action depends + ;; on the expansion context. + (apply-post-expansion (root-expand-context-post-expansion ctx) + s)) + +(define (accumulate-def-ctx-scopes ctx def-ctx-scopes) + ;; Move any accumulated definition-context scopes to the `scopes` + ;; list for further expansion: + (if (null? (unbox def-ctx-scopes)) + ctx + (struct*-copy expand-context ctx + [scopes (append (unbox def-ctx-scopes) + (expand-context-scopes ctx))]))) + +;; ---------------------------------------- + +;; Helper to lookup a binding in an expansion context +(define (lookup b ctx id + #:in [in-s #f] + #:out-of-context-as-variable? [out-of-context-as-variable? #f]) + (binding-lookup b + (expand-context-env ctx) + (expand-context-lift-envs ctx) + (expand-context-namespace ctx) + (expand-context-phase ctx) + id + #:in in-s + #:out-of-context-as-variable? out-of-context-as-variable?)) + +(define-syntax-rule (guard-stop id ctx s otherwise ...) + (cond + [(and (not (free-id-set-empty? (expand-context-stops ctx))) + (free-id-set-member? (expand-context-stops ctx) + (expand-context-phase ctx) + id)) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) + ['resolve id] ['enter-prim s] ['prim-stop] ['exit-prim s] ['return s]) + s] + [else + otherwise ...])) + +(define (substitute-alternate-id s alternate-id) + (cond + [(not alternate-id) s] + [(syntax-identifier? s) (syntax-rearm (syntax-track-origin alternate-id s) s)] + [else + (define disarmed-s (syntax-disarm s)) + (syntax-rearm (syntax-track-origin (datum->syntax + disarmed-s + (cons alternate-id + (cdr (syntax-e disarmed-s))) + s) + s) + s)])) + +(define (register-variable-referenced-if-local! binding) + ;; If the binding's frame has a reference record, then register + ;; the use for the purposes of `letrec` splitting + (when (and (local-binding? binding) + (reference-record? (binding-frame-id binding))) + (reference-record-used! (binding-frame-id binding) (local-binding-key binding)))) + +;; ---------------------------------------- + +;; Expand `s` as a compile-time expression relative to the current +;; expansion context +(define (expand/capture-lifts s ctx + #:expand-lifts? [expand-lifts? #f] + #:begin-form? [begin-form? #f] + #:lift-key [lift-key (generate-lift-key)] + #:always-wrap? [always-wrap? #f]) + (define context (expand-context-context ctx)) + (define phase (expand-context-phase ctx)) + (define local? (not begin-form?)) ;; see "[*]" below + ;; Expand `s`, but loop to handle lifted expressions + (let loop ([s s] [always-wrap? always-wrap?] [ctx ctx]) + (define lift-env (and local? (box empty-env))) + (define lift-ctx (make-lift-context + (if local? + (make-local-lift lift-env (root-expand-context-counter ctx)) + (make-top-level-lift ctx)) + #:module*-ok? (and (not local?) (eq? context 'module)))) + (define capture-ctx (struct*-copy expand-context ctx + [lift-key #:parent root-expand-context lift-key] + [lifts lift-ctx] + [lift-envs (if local? + (cons lift-env + (expand-context-lift-envs ctx)) + (expand-context-lift-envs ctx))] + [module-lifts (if (or local? + (not (memq context '(top-level module)))) + (expand-context-module-lifts ctx) + lift-ctx)])) + (define rebuild-s (keep-properties-only s)) + (define exp-s (expand s capture-ctx)) + (define lifts (get-and-clear-lifts! (expand-context-lifts capture-ctx))) + (define with-lifts-s + (cond + [(or (pair? lifts) always-wrap?) + (cond + [(expand-context-to-parsed? ctx) + (unless expand-lifts? (error "internal error: to-parsed mode without expanding lifts")) + (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx (lambda (rhs rhs-ctx) (loop rhs #f rhs-ctx)))] + [else + (if begin-form? + (wrap-lifts-as-begin lifts exp-s phase) + (wrap-lifts-as-let lifts exp-s phase))])] + [else exp-s])) + (cond + [(or (not expand-lifts?) (null? lifts) (expand-context-to-parsed? ctx)) + ;; Expansion is done + with-lifts-s] + [else + ;; Expand again... + (log-expand ctx 'letlift-loop with-lifts-s) + (loop with-lifts-s #f ctx)]))) + +;; [*] Although `(memq context '(top-level module))` makes more sense +;; than `(not begin-form?)`, the latter was used historically; the +;; implementation of `typed/require` currently depends on that +;; choice, because it expands in 'expression mode to obtain forms +;; that are splcied into a module context --- leading to an +;; out-of-context definition error if the historical choice is not +;; preserved. + +;; Expand `s` as a compile-time expression relative to the current +;; expansion context +(define (expand-transformer s ctx + #:context [context 'expression] + #:begin-form? [begin-form? #f] + #:expand-lifts? [expand-lifts? #t] + #:lift-key [lift-key (generate-lift-key)] + #:always-wrap? [always-wrap? #f] + #:keep-stops? [keep-stops? #f]) + (performance-region + ['expand 'transformer] + + (define trans-ctx (context->transformer-context ctx context + #:keep-stops? keep-stops?)) + (expand/capture-lifts s trans-ctx + #:expand-lifts? expand-lifts? + #:begin-form? begin-form? + #:lift-key lift-key + #:always-wrap? always-wrap?))) + +(define (context->transformer-context ctx [context 'expression] + #:keep-stops? [keep-stops? #f]) + (define phase (add1 (expand-context-phase ctx))) + (define ns (namespace->namespace-at-phase (expand-context-namespace ctx) + phase)) + (namespace-visit-available-modules! ns phase) ; redundant? + (struct*-copy expand-context ctx + [context context] + [scopes null] + [phase phase] + [namespace ns] + [env empty-env] + [only-immediate? (and keep-stops? (expand-context-only-immediate? ctx))] + [stops (if keep-stops? + (expand-context-stops ctx) + empty-free-id-set)] + [def-ctx-scopes #f] + [post-expansion #:parent root-expand-context #f])) + +;; Expand and evaluate `s` as a compile-time expression, ensuring that +;; the number of returned values matches the number of target +;; identifiers; return the expanded form as well as its values +(define (expand+eval-for-syntaxes-binding who rhs ids ctx + #:log-next? [log-next? #t]) + (define exp-rhs (expand-transformer rhs (as-named-context ctx ids))) + (define phase (add1 (expand-context-phase ctx))) + (define parsed-rhs (if (expand-context-to-parsed? ctx) + exp-rhs + (expand exp-rhs (context->transformer-context + (as-to-parsed-context ctx))))) + (when log-next? (log-expand ctx 'next)) + (values exp-rhs + parsed-rhs + (eval-for-bindings who + ids + parsed-rhs + phase + (namespace->namespace-at-phase + (expand-context-namespace ctx) + phase) + ctx))) + +;; Expand and evaluate `s` as a compile-time expression, returning +;; only the compile-time values +(define (eval-for-syntaxes-binding who rhs ids ctx) + (define-values (exp-rhs parsed-rhs vals) + (expand+eval-for-syntaxes-binding who rhs ids ctx)) + vals) + +;; Expand and evaluate `s` as an expression in the given phase; +;; ensuring that the number of returned values matches the number of +;; target identifiers; return the values +(define (eval-for-bindings who ids p phase ns ctx) + (define compiled (if (can-direct-eval? p ns (root-expand-context-self-mpi ctx)) + #f + (compile-single p (make-compile-context + #:namespace ns + #:phase phase)))) + (define vals + (call-with-values (lambda () + (parameterize ([current-expand-context ctx] + [current-namespace ns] + [eval-jit-enabled #f]) + (if compiled + (eval-single-top compiled ns) + (direct-eval p ns (root-expand-context-self-mpi ctx))))) + list)) + (unless (= (length vals) (length ids)) + (apply raise-result-arity-error + who + (length ids) + (cond + [(null? ids) ""] + [else (format "\n in: definition of ~a~a" (syntax-e (car ids)) (if (pair? (cdr ids)) " ..." ""))]) + vals)) + vals) + +;; ---------------------------------------- + +(define (keep-properties-only s) + (datum->syntax #f 'props s s)) + +;; For cases where we don't actually keep properties, because +;; the compiler doesn't currently use them: +(define (keep-properties-only~ s) + #f) + +;; Drop the `syntax-e` part of `s`, and also drop its scopes when +;; producing a parsed result, producing a result suitable for use with +;; `rebuild`, including in a `parsed` record, or to provide a form +;; name for error reporting. In fact, when producing a parsed value +;; and `keep-for-parsed?` and `keep-for-error?` are both false, then +;; keep nothing (because the compiler isn't going to use it). +;; Dropping references in this way helps the +;; GC not retain too much of an original syntax object in the process +;; of expanding it, which can matter for deeply nested expansions. +(define (keep-as-needed ctx s + #:for-track? [for-track? #f] + #:keep-for-parsed? [keep-for-parsed? #f] + #:keep-for-error? [keep-for-error? #f]) + (define d (syntax-e s)) + (define keep-e (cond + [(symbol? d) d] + [(and (pair? d) (syntax-identifier? (car d))) (syntax-e (car d))] + [else #f])) + (cond + [(expand-context-to-parsed? ctx) + (and (or keep-for-parsed? keep-for-error?) (datum->syntax #f keep-e s s))] + [else + (syntax-rearm (datum->syntax (syntax-disarm s) keep-e s s) + s)])) + +(define (attach-disappeared-transformer-bindings s trans-idss) + (cond + [(null? trans-idss) s] + [else + (syntax-property s + 'disappeared-binding + (append (apply append trans-idss) + (or (syntax-property s 'disappeared-binding) + null)))])) + +;; Generate a fresh binding-layer identity if `ids` contains any +;; identifiers +(define (increment-binding-layer ids ctx layer-val) + (if (let loop ([ids ids]) + (or (identifier? ids) + (and (pair? ids) + (or (loop (car ids)) (loop (cdr ids)))))) + layer-val + (expand-context-binding-layer ctx))) + +;; Wrap lifted forms in a `let` for a mode where we're generating a +;; parsed result. The body has already been parsed, and the left-hand +;; sides already have bindings. We need to parse the right-hand sides +;; as a series of nested `lets`. +(define (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx parse-rhs) + (define idss+keyss+rhss (get-lifts-as-lists lifts)) + (let lets-loop ([idss+keyss+rhss idss+keyss+rhss] [rhs-ctx ctx]) + (cond + [(null? idss+keyss+rhss) exp-s] + [else + (define ids (caar idss+keyss+rhss)) + (define keys (cadar idss+keyss+rhss)) + (define rhs (caddar idss+keyss+rhss)) + (define exp-rhs (parse-rhs rhs rhs-ctx)) + (parsed-let-values + rebuild-s + (list ids) + (list (list keys exp-rhs)) + (list + (lets-loop (cdr idss+keyss+rhss) + (struct*-copy expand-context rhs-ctx + [env (for/fold ([env (expand-context-env rhs-ctx)]) ([id (in-list ids)] + [key (in-list keys)]) + (env-extend env key (local-variable id)))]))))]))) + +;; A rename transformer can have a `prop:rename-transformer` property +;; as a function, and that fnuction might want to use +;; `syntax-local-value`, etc. +(define (rename-transformer-target-in-context t ctx) + (parameterize ([current-expand-context ctx]) + (rename-transformer-target t))) + +;; In case the rename-transformer has a callback, ensure that the +;; current expansion context is available while installing a +;; `free-identifier=?` equivalence +(define (maybe-install-free=id-in-context! val id phase ctx) + (when (rename-transformer? val) + (parameterize ([current-expand-context ctx]) + (maybe-install-free=id! val id phase)))) + +;; Transfer the original ID's source location, if any, when expanding +;; a reference to a rename transformer +(define (transfer-srcloc new-s old-s) + (define srcloc (syntax-srcloc old-s)) + (if srcloc + (struct-copy syntax new-s + [srcloc srcloc]) + new-s)) diff -Nru racket-6.12+ppa1/src/expander/expand/missing-module.rkt racket-7.0+ppa1/src/expander/expand/missing-module.rkt --- racket-6.12+ppa1/src/expander/expand/missing-module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/missing-module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,82 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/error.rkt" + "../common/module-path.rkt") + +(provide current-module-path-for-load + maybe-raise-missing-module + + prop:exn:missing-module + exn:missing-module? + exn:missing-module-accessor + + (struct-out exn:fail:filesystem:missing-module) + make-exn:fail:filesystem:missing-module + (struct-out exn:fail:syntax:missing-module) + make-exn:fail:syntax:missing-module) + +(define-values (prop:exn:missing-module exn:missing-module? exn:missing-module-accessor) + (make-struct-type-property 'missing-module + (lambda (v info) + (unless (and (procedure? v) + (procedure-arity-includes? v 1)) + (raise-argument-error 'guard-for-prop:exn:missing-module + "(procedure-arity-includes/c 1)" + v)) + v))) + +(struct exn:fail:filesystem:missing-module exn:fail:filesystem (path) + #:extra-constructor-name make-exn:fail:filesystem:missing-module + #:transparent + #:property prop:exn:missing-module (lambda (e) (exn:fail:filesystem:missing-module-path e))) +(struct exn:fail:syntax:missing-module exn:fail:syntax (path) + #:extra-constructor-name make-exn:fail:syntax:missing-module + #:transparent + #:property prop:exn:missing-module (lambda (e) (exn:fail:syntax:missing-module-path e))) + +(define current-module-path-for-load + (make-parameter #f + (lambda (v) + (unless (or (not v) + (module-path? v) + (and (syntax? v) + (module-path? (syntax->datum v)))) + (raise-argument-error + 'current-module-path-for-load + (string-append "(or/c module-path?" + " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))" + " #f)") + v)) + v))) + +(define (maybe-raise-missing-module name filename pre rel post errstr) + (define path (current-module-path-for-load)) + (when path + (when (syntax? path) + (raise + (exn:fail:syntax:missing-module + (format (string-append "~a: cannot open module file\n" + " module path: ~a\n" + " path: ~a~a~a~a\n" + " system error: ~a") + (if (syntax-srcloc path) + (srcloc->string (syntax-srcloc path)) + name) + (syntax->datum path) + filename pre rel post + errstr) + (current-continuation-marks) + (list path) + (syntax->datum path)))) + (raise + (exn:fail:filesystem:missing-module + (format (string-append "~a: cannot open module file\n" + " module path: ~a\n" + " path: ~a~a~a~a\n" + " system error: ~a") + name + path + filename pre rel post + errstr) + (current-continuation-marks) + path)))) diff -Nru racket-6.12+ppa1/src/expander/expand/module-path.rkt racket-7.0+ppa1/src/expander/expand/module-path.rkt --- racket-6.12+ppa1/src/expander/expand/module-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/module-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../namespace/namespace.rkt" + "context.rkt") + +(provide module-path->mpi + module-path->mpi/context) + +(define (module-path->mpi mod-path self + #:declared-submodule-names [declared-submodule-names #hasheq()]) + (cond + [(and (list? mod-path) + (= 2 (length mod-path)) + (eq? 'quote (car mod-path)) + (symbol? (cadr mod-path)) + (hash-ref declared-submodule-names (cadr mod-path) #f)) + (module-path-index-join `(submod "." ,(cadr mod-path)) self)] + [(and (list? mod-path) + (eq? 'submod (car mod-path)) + (let ([mod-path (cadr mod-path)]) + (and (list? mod-path) + (= 2 (length mod-path)) + (eq? 'quote (car mod-path)) + (symbol? (cadr mod-path)) + (hash-ref declared-submodule-names (cadr mod-path) #f)))) + (module-path-index-join `(submod "." ,(cadr (cadr mod-path)) ,@(cddr mod-path)) self)] + [else + (module-path-index-join mod-path self)])) + +(define (module-path->mpi/context mod-path ctx) + (module-path->mpi mod-path + (namespace-mpi (expand-context-namespace ctx)) + #:declared-submodule-names (expand-context-declared-submodule-names ctx))) diff -Nru racket-6.12+ppa1/src/expander/expand/module.rkt racket-7.0+ppa1/src/expander/expand/module.rkt --- racket-6.12+ppa1/src/expander/expand/module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1483 @@ +#lang racket/base +(require racket/promise + "../common/struct-star.rkt" + "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/debug.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../syntax/track.rkt" + "../common/phase.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "dup-check.rkt" + "free-id-set.rkt" + "stop-ids.rkt" + "require+provide.rkt" + "../common/module-path.rkt" + "lift-context.rkt" + "lift-key.rkt" + "../namespace/core.rkt" + "context.rkt" + "use-site.rkt" + "main.rkt" + "require.rkt" + "provide.rkt" + "def-id.rkt" + "prepare.rkt" + "log.rkt" + "syntax-id-error.rkt" + "../compile/main.rkt" + "../eval/top.rkt" + "../eval/module.rkt" + "cross-phase.rkt" + "parsed.rkt" + "expanded+parsed.rkt" + "append.rkt" + "save-and-restore.rkt") + +(add-core-form! + 'module + (lambda (s ctx) + (unless (eq? (expand-context-context ctx) 'top-level) + (log-expand ctx 'prim-module) + (raise-syntax-error #f "allowed only at the top level" s)) + (performance-region + ['expand 'module] + (expand-module s ctx #f)))) + +(add-core-form! + 'module* + (lambda (s ctx) + (log-expand ctx 'prim-module) + (raise-syntax-error #f "illegal use (not in a module top-level)" s))) + +(add-core-form! + '#%module-begin + (lambda (s ctx) + (log-expand ctx 'prim-module-begin) + (unless (eq? (expand-context-context ctx) 'module-begin) + (raise-syntax-error #f "not in a module-definition context" s)) + (unless (expand-context-module-begin-k ctx) + (raise-syntax-error #f "not currently transforming a module" s)) + ;; This `#%module-begin` must be in a `module`; the + ;; `module-begin-k` function continues that module's + ;; expansion + ((expand-context-module-begin-k ctx) + s + (struct*-copy expand-context ctx + [module-begin-k #f])))) + +(add-core-form! + '#%declare + (lambda (s ctx) + (log-expand ctx 'prim-declare) + ;; The `#%module-begin` expander handles `#%declare` + (raise-syntax-error #f "not allowed outside of a module body" s))) + +;; ---------------------------------------- + +(define (expand-module s init-ctx enclosing-self + #:always-produce-compiled? [always-produce-compiled? #f] + #:keep-enclosing-scope-at-phase [keep-enclosing-scope-at-phase #f] + #:enclosing-is-cross-phase-persistent? [enclosing-is-cross-phase-persistent? #f] + #:enclosing-requires+provides [enclosing-r+p #f] + #:mpis-for-enclosing-reset [mpis-for-enclosing-reset #f] + ;; For cross-linklet inlining among submodules compiled together: + #:modules-being-compiled [modules-being-compiled (make-hasheq)]) + (log-expand init-ctx 'prim-module) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(module id:module-name initial-require body ...)) + + (define rebuild-s (keep-as-needed init-ctx s #:keep-for-parsed? #t #:keep-for-error? #t)) + + (define initial-require (syntax->datum (m 'initial-require))) + (unless (or keep-enclosing-scope-at-phase + (module-path? initial-require)) + (raise-syntax-error #f "not a module path" s (m 'initial-require))) + + ;; All module bodies start at phase 0 + (define phase 0) + + (define module-name-sym (syntax-e (m 'id:module-name))) + + (define outside-scope (new-scope 'module)) + (define inside-scope (new-multi-scope module-name-sym)) + + (define self (make-self-module-path-index (if enclosing-self + module-name-sym + (string->uninterned-symbol + (symbol->string module-name-sym))) + enclosing-self)) + + (define enclosing-mod (and enclosing-self + (module-path-index-join '(submod "..") self))) + (when (and enclosing-mod mpis-for-enclosing-reset) + (set-box! mpis-for-enclosing-reset + (cons enclosing-mod (unbox mpis-for-enclosing-reset)))) + + (define apply-module-scopes + (make-apply-module-scopes outside-scope inside-scope + init-ctx keep-enclosing-scope-at-phase + self enclosing-self enclosing-mod)) + + ;; Initial require name provides the module's base scopes + (define initial-require-s (apply-module-scopes (m 'initial-require))) + (define all-scopes-s initial-require-s) + + (define root-ctx (make-root-expand-context + #:self-mpi self + #:initial-scopes (if keep-enclosing-scope-at-phase + (root-expand-context-module-scopes init-ctx) + null) + #:outside-scope outside-scope + #:post-expansion-scope inside-scope + #:all-scopes-stx all-scopes-s)) + + ;; Extract combined scopes + (define new-module-scopes (root-expand-context-module-scopes root-ctx)) + + ;; A frame-id is used to determine when use-site scopes are needed + (define frame-id (root-expand-context-frame-id root-ctx)) + + ;; Make a namespace for module expansion + (define (make-m-ns ns #:for-submodule? [for-submodule? (and enclosing-self #t)]) + (make-module-namespace ns + #:mpi self + #:root-expand-context root-ctx + #:for-submodule? for-submodule?)) + (define m-ns (make-m-ns (expand-context-namespace init-ctx))) + + ;; Initial context for all body expansions: + (define ctx (struct*-copy expand-context (copy-root-expand-context init-ctx root-ctx) + [allow-unbound? #f] + [namespace m-ns] + [post-expansion #:parent root-expand-context (lambda (s) (add-scope s inside-scope))] + [phase phase] + [just-once? #f])) + + ;; Add the module's scope to the body forms; use `disarmed-s` and + ;; re-match to extract the body forms, because that improves sharing + (define bodys (let ([scoped-s (apply-module-scopes disarmed-s)]) + (define-match m scoped-s '(_ _ _ body ...)) + (m 'body))) + + ;; To keep track of all requires and provides + (define requires+provides (make-requires+provides self)) + + ;; Table of symbols picked for each binding in this module: + (define defined-syms (root-expand-context-defined-syms root-ctx)) ; phase -> sym -> id + + ;; So that compilations of submodules can be preserved for + ;; inclusion in an overall compiled module: + (define compiled-submodules (make-hasheq)) + + ;; If we compile the module for use by `module*` submodules, keep that + ;; compiled form to possibly avoid compiling again. + (define compiled-module-box (box #f)) + + ;; Accumulate module path indexes used by submodules to refer to this module + (define mpis-to-reset (box null)) + + ;; Initial require + (define (initial-require! #:bind? bind?) + (cond + [(not keep-enclosing-scope-at-phase) + ;; Install the initial require + (perform-initial-require! initial-require self + all-scopes-s + m-ns + requires+provides + #:bind? bind? + #:who 'module)] + [else + ;; For `(module* name #f ....)`, just register the enclosing module + ;; as an import and visit it + (add-required-module! requires+provides + enclosing-mod + keep-enclosing-scope-at-phase + enclosing-is-cross-phase-persistent?) + (add-enclosing-module-defined-and-required! requires+provides + #:enclosing-requires+provides enclosing-r+p + enclosing-mod + keep-enclosing-scope-at-phase) + (namespace-module-visit! m-ns enclosing-mod + keep-enclosing-scope-at-phase)])) + (log-expand init-ctx 'prepare-env) + (initial-require! #:bind? #t) + + ;; To detect whether the body is expanded multiple times: + (define again? #f) + + ;; The primitive `#%module-body` form calls this function to expand the + ;; current module's body + (define (module-begin-k mb-s mb-init-ctx) + ;; In case the module body is expanded multiple times, we clear + ;; the requires, provides and definitions information each time. + ;; Don't discard accumulated requires, though, since those may be + ;; needed by pieces from a previous expansion. Also, be careful + ;; not to change the current bindings when re-establishing the + ;; requires. + (when again? + (requires+provides-reset! requires+provides) + (initial-require! #:bind? #f) + (hash-clear! compiled-submodules) + (set-box! compiled-module-box #f)) + (set! again? #t) + + ;; In case a nested `#%module-begin` expansion is forced, save + ;; and restore the module-expansion state: + (define ctx (struct*-copy expand-context mb-init-ctx + [module-begin-k + (lambda (s ctx) + (define new-requires+provides + ;; Copy old `require` dependencies, which allows a + ;; synthesized nested `#%module-begin` to use pieces + ;; that depend on bindings introduced outside the + ;; synthesized part --- a questionable practice, + ;; but support for backward compatibility, at least. + (make-requires+provides self + #:copy-requires requires+provides)) + (with-save-and-restore ([requires+provides new-requires+provides] + [compiled-submodules (make-hasheq)] + [compiled-module-box (box #f)] + [defined-syms (make-hasheq)]) + (module-begin-k s ctx)))] + ;; Also, force `post-expansion` to be right, in case 'module-begin + ;; module is triggered within some other mode; a correct value + ;; for `post-expansion` is important to getting scopes right. + [post-expansion #:parent root-expand-context + (lambda (s) (add-scope s inside-scope))])) + + ;; In case `#%module-begin` expansion is forced on syntax that + ;; that wasn't already introduced into the mdoule's inside scope, + ;; add it to all the given body forms + (define added-s (add-scope mb-s inside-scope)) + (log-expand ctx 'rename-one added-s) + + (define disarmed-mb-s (syntax-disarm added-s)) + (define-match mb-m disarmed-mb-s '(#%module-begin body ...)) + (define bodys (mb-m 'body)) + + (define rebuild-mb-s (keep-as-needed ctx mb-s)) + + ;; For variable repeferences before corresponding binding (phase >= 1) + (define need-eventually-defined (make-hasheqv)) ; phase -> list of id + + ;; For `syntax-local-lift-module-end-declaration`, which is accumulated + ;; across phases: + (define module-ends (make-shared-module-ends)) + + ;; Accumulate `#%declare` content + (define declared-keywords (make-hasheq)) + + ;; Accumulated declared submodule names for `syntax-local-submodules` + (define declared-submodule-names (make-hasheq)) + + ;; Module expansion always parses the module body along the way, + ;; even if `to-parsed?` in `ctx` is not true. The body is parsed + ;; so that the module can be declared for reference by + ;; submodules. So, if expansion is supposed to a syntax object + ;; instead of `module-parsed`, then we'll need to accumulate both + ;; parsed and expanded results; see "expanded+parsed.rkt". + + ;; The expansion of the module body happens in 4 passes: + ;; Pass 1: Partial expansion to determine imports and definitions + ;; Pass 2: Complete expansion of remaining expressions + ;; Pass 3: Parsing of provide forms + ;; Pass 4: Parsing of `module*` submodules + + ;; Passes 1 and 2 are nested via `begin-for-syntax`: + (define expression-expanded-bodys + (let pass-1-and-2-loop ([bodys bodys] [phase phase]) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 1: partially expand to discover all bindings and install all + ;; defined macro transformers + + ;; Need to accumulate definition contexts created during + ;; partial expansion: + (define def-ctx-scopes (box null)) + (define to-parsed? (expand-context-to-parsed? ctx)) + + (define partial-body-ctx (struct*-copy expand-context ctx + [context 'module] + [phase phase] + [namespace (namespace->namespace-at-phase m-ns phase)] + [stops (free-id-set phase (module-expand-stop-ids phase))] + [def-ctx-scopes def-ctx-scopes] + [need-eventually-defined need-eventually-defined] ; used only at phase 1 and up + [declared-submodule-names declared-submodule-names] + [lift-key #:parent root-expand-context (generate-lift-key)] + [lifts (make-lift-context + (make-wrap-as-definition self frame-id + inside-scope all-scopes-s + defined-syms requires+provides))] + [module-lifts (make-module-lift-context phase #t)] + [require-lifts (make-require-lift-context + phase + (make-parse-lifted-require m-ns self requires+provides + #:declared-submodule-names declared-submodule-names))] + [to-module-lifts (make-to-module-lift-context + phase + #:shared-module-ends module-ends + #:end-as-expressions? #f)])) + + ;; Result is mostly a list of S-expressions, but can also + ;; contain `compile-form` or `expanded+parsed` structures: + (define partially-expanded-bodys + (partially-expand-bodys bodys + #:phase phase + #:ctx partial-body-ctx + #:namespace m-ns + #:self self + #:frame-id frame-id + #:requires-and-provides requires+provides + #:need-eventually-defined need-eventually-defined + #:all-scopes-stx all-scopes-s + #:defined-syms defined-syms + #:declared-keywords declared-keywords + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset + #:loop pass-1-and-2-loop)) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 2: finish expanding expressions + + (log-expand partial-body-ctx 'next-group) + + (define body-ctx (struct*-copy expand-context (accumulate-def-ctx-scopes partial-body-ctx def-ctx-scopes) + [stops empty-free-id-set] + [def-ctx-scopes #f] + [post-expansion #:parent root-expand-context #f] + [to-module-lifts (make-to-module-lift-context phase + #:shared-module-ends module-ends + #:end-as-expressions? #t)])) + + (finish-expanding-body-expressons partially-expanded-bodys + #:phase phase + #:ctx body-ctx + #:self self + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset))) + + ;; Check that any tentatively allowed reference at phase >= 1 is ok + (check-defined-by-now need-eventually-defined self ctx requires+provides) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 3: resolve provides at all phases + + (log-expand ctx 'next-group) + + (define fully-expanded-bodys-except-post-submodules + (resolve-provides expression-expanded-bodys + #:requires-and-provides requires+provides + #:declared-submodule-names declared-submodule-names + #:namespace m-ns + #:phase phase + #:self self + #:ctx ctx)) + + ;; Validate any cross-phase persistence request + (define is-cross-phase-persistent? (hash-ref declared-keywords '#:cross-phase-persistent #f)) + (when is-cross-phase-persistent? + (unless (requires+provides-can-cross-phase-persistent? requires+provides) + (raise-syntax-error #f "cannot be cross-phase persistent due to required modules" + rebuild-s + (hash-ref declared-keywords '#:cross-phase-persistent))) + (check-cross-phase-persistent-form fully-expanded-bodys-except-post-submodules self)) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 4: expand `module*` submodules + + (log-expand ctx 'next) + + ;; Create a new namespace to avoid retaining the instance that + ;; was needed to expand this module body: + (define submod-m-ns (make-m-ns m-ns #:for-submodule? #t)) + + (define submod-ctx (struct*-copy expand-context ctx + [frame-id #:parent root-expand-context #f] + [post-expansion #:parent root-expand-context #f] + [namespace submod-m-ns])) + + (define declare-enclosing-module + ;; Ensure this module on demand for `module*` submodules that might use it + (delay (declare-module-for-expansion fully-expanded-bodys-except-post-submodules + #:module-name-id (m 'id:module-name) + #:rebuild-s rebuild-s + #:requires-and-provides requires+provides + #:namespace submod-m-ns + #:self self + #:enclosing enclosing-self + #:root-ctx root-ctx + #:ctx submod-ctx + #:modules-being-compiled modules-being-compiled + #:fill compiled-module-box))) + + (define fully-expanded-bodys + (cond + [(stop-at-module*? submod-ctx) + fully-expanded-bodys-except-post-submodules] + [else + (expand-post-submodules fully-expanded-bodys-except-post-submodules + #:declare-enclosing declare-enclosing-module + #:phase phase + #:self self + #:requires-and-provides requires+provides + #:enclosing-is-cross-phase-persistent? is-cross-phase-persistent? + #:all-scopes-s all-scopes-s + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:ctx submod-ctx)])) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Finish + + ;; Assemble the `#%module-begin` result: + (cond + [(expand-context-to-parsed? submod-ctx) + (parsed-#%module-begin rebuild-mb-s (parsed-only fully-expanded-bodys))] + [else + (define mb-result-s + (rebuild + rebuild-mb-s + `(,(mb-m '#%module-begin) ,@(syntax-only fully-expanded-bodys)))) + (cond + [(not (expand-context-in-local-expand? submod-ctx)) + (expanded+parsed mb-result-s + (parsed-#%module-begin rebuild-mb-s (parsed-only fully-expanded-bodys)))] + [else mb-result-s])])) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Actually expand the `#%module-body` form + + ;; The preceding function performs the expansion; here's where we + ;; trigger it + + (define mb-ctx + (struct*-copy expand-context ctx + [context 'module-begin] + [module-begin-k module-begin-k] + [in-local-expand? #f] + [lifts #f] + [module-lifts #f] + [to-module-lifts #f] + [require-lifts #f])) + + (define mb-scopes-s + (if keep-enclosing-scope-at-phase + ;; for `(module* name #f)`, use the `(module* ...)` form: + (apply-module-scopes disarmed-s) + ;; otherwise, use the initial require + all-scopes-s)) + + ;; Need to accumulate definition contexts created during + ;; expansion to `#%module-begin`: + (define mb-def-ctx-scopes (box null)) + + ;; Add `#%module-begin` around the body if it's not already present; + ;; also logs 'rename-one + (define mb + (ensure-module-begin bodys + #:module-name-sym module-name-sym + #:scopes-s mb-scopes-s + #:m-ns m-ns + #:ctx mb-ctx + #:def-ctx-scopes mb-def-ctx-scopes + #:phase phase + #:s s)) + + ;; Expand the body + (define expanded-mb (performance-region + ['expand 'module-begin] + (expand mb (struct*-copy expand-context (accumulate-def-ctx-scopes mb-ctx mb-def-ctx-scopes) + [def-ctx-scopes #f])))) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Assemble the `module` result + + (define-values (requires provides) (extract-requires-and-provides requires+provides self self)) + + (define result-form + (and (or (expand-context-to-parsed? init-ctx) + always-produce-compiled?) + (parsed-module rebuild-s + #f + (m 'id:module-name) + self + requires + provides + (requires+provides-all-bindings-simple? requires+provides) + (root-expand-context-encode-for-module root-ctx self self) + (parsed-#%module-begin-body + (if (expanded+parsed? expanded-mb) + (expanded+parsed-parsed expanded-mb) + expanded-mb)) + (unbox compiled-module-box) + compiled-submodules))) + + (define result-s + (cond + [(not (expand-context-to-parsed? init-ctx)) + ;; Shift the "self" reference that we have been using for expansion + ;; to a generic and constant (for a particular submodule path) + ;; "self", so that we can reocognize it for compilation or to shift + ;; back on any future re-expansion: + (define generic-self (make-generic-self-module-path-index self)) + + ;; Make `self` like `generic-self`; this hacky update plays the + ;; role of applying a shift to identifiers that are in syntax + ;; properties, such as the 'origin property + (imitate-generic-module-path-index! self) + (for ([mpi (in-list (unbox mpis-to-reset))]) + (imitate-generic-module-path-index! mpi)) + + (let* ([result-s + (rebuild + rebuild-s + `(,(m 'module) ,(m 'id:module-name) ,initial-require-s ,(expanded+parsed-s expanded-mb)))] + [result-s + (syntax-module-path-index-shift result-s self generic-self)] + [result-s (attach-root-expand-context-properties result-s root-ctx self generic-self)] + [result-s (if (requires+provides-all-bindings-simple? requires+provides) + (syntax-property result-s 'module-body-context-simple? #t) + result-s)]) + (log-expand init-ctx 'rename-one result-s) + result-s)])) + + (cond + [(expand-context-to-parsed? init-ctx) result-form] + [always-produce-compiled? + (expanded+parsed result-s result-form)] + [else result-s])) + +;; ---------------------------------------- + +;; Add `#%module-begin` to `bodys`, if needed, and otherwise +;; expand to a core `#%module-begin` form +(define (ensure-module-begin bodys + #:module-name-sym module-name-sym + #:scopes-s scopes-s + #:m-ns m-ns + #:ctx ctx + #:def-ctx-scopes def-ctx-scopes + #:phase phase + #:s s) + (define (make-mb-ctx) + (struct*-copy expand-context ctx + [context 'module-begin] + [only-immediate? #t] + [def-ctx-scopes def-ctx-scopes])) + (define mb + (cond + [(= 1 (length bodys)) + ;; Maybe it's already a `#%module-begin` form, or maybe it + ;; will expand to one + (log-expand ctx 'rename-one (car bodys)) + (cond + [(eq? '#%module-begin (core-form-sym (syntax-disarm (car bodys)) phase)) + ;; Done + (car bodys)] + [else + ;; A single body form might be a macro that expands to + ;; the primitive `#%module-begin` form: + (define partly-expanded-body + (performance-region + ['expand 'module-begin] + (expand (add-enclosing-name-property (car bodys) module-name-sym) + (make-mb-ctx)))) + (cond + [(eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-body) phase)) + ;; Yes, it expanded to `#%module-begin` + partly-expanded-body] + [else + ;; No, it didn't expand to `#%module-begin` + (add-module-begin (list partly-expanded-body) s scopes-s phase module-name-sym + (make-mb-ctx) + #:log-rename-one? #f)])])] + [else + ;; Multiple body forms definitely need a `#%module-begin` wrapper + (add-module-begin bodys s scopes-s phase module-name-sym + (make-mb-ctx))])) + (add-enclosing-name-property mb module-name-sym)) + +;; Add `#%module-begin`, because it's needed +(define (add-module-begin bodys s scopes-s phase module-name-sym mb-ctx + #:log-rename-one? [log-rename-one? #t]) + (define disarmed-scopes-s (syntax-disarm scopes-s)) + (define mb-id (datum->syntax disarmed-scopes-s '#%module-begin)) + ;; If `mb-id` is not bound, we'd like to give a clear error message + (unless (resolve mb-id phase) + (raise-syntax-error #f "no #%module-begin binding in the module's language" s)) + (define mb (datum->syntax disarmed-scopes-s `(,mb-id ,@bodys) s s)) + (log-expand mb-ctx 'tag mb) + (when log-rename-one? + (log-expand mb-ctx 'rename-one mb)) + (define partly-expanded-mb (performance-region + ['expand 'module-begin] + (expand (add-enclosing-name-property mb module-name-sym) + mb-ctx))) + (unless (eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-mb) phase)) + (raise-syntax-error #f "expansion of #%module-begin is not a #%plain-module-begin form" s + partly-expanded-mb)) + partly-expanded-mb) + +(define (add-enclosing-name-property stx module-name-sym) + (syntax-property stx 'enclosing-module-name module-name-sym)) + +;; ---------------------------------------- + +;; Make function to adjust syntax that appears in the original module body +(define (make-apply-module-scopes inside-scope outside-scope + init-ctx keep-enclosing-scope-at-phase + self enclosing-self enclosing-mod) + (lambda (s) + (performance-region + ['expand 'module 'scopes] + (define s-without-enclosing + (if keep-enclosing-scope-at-phase + ;; Keep enclosing module scopes for `(module* _ #f ....)` + s + ;; Remove the scopes of the top level or a module outside of + ;; this module, as well as any relevant use-site scopes + (remove-use-site-scopes + (remove-scopes s (root-expand-context-module-scopes init-ctx)) + init-ctx))) + ;; Add outside- and inside-edge scopes + (define s-with-edges + (add-scope (add-scope s-without-enclosing + outside-scope) + inside-scope)) + (define s-with-suitable-enclosing + (cond + [keep-enclosing-scope-at-phase + ;; Shift any references to the enclosing module to be relative to the + ;; submodule + (syntax-module-path-index-shift + s-with-edges + enclosing-self + enclosing-mod)] + [else s-with-edges])) + ;; In case we're expanding syntax that was previously expanded, + ;; shift the generic "self" to the "self" for the current expansion: + (syntax-module-path-index-shift + s-with-suitable-enclosing + (make-generic-self-module-path-index self) + self + ;; Also preserve the expansion-time code inspector + (current-code-inspector))))) + +;; ---------------------------------------- + +;; Pass 1 of `module` expansion, which uncovers definitions, +;; requires, and `module` submodules +(define (partially-expand-bodys bodys + #:phase phase + #:ctx partial-body-ctx + #:namespace m-ns + #:self self + #:frame-id frame-id + #:requires-and-provides requires+provides + #:need-eventually-defined need-eventually-defined + #:all-scopes-stx all-scopes-stx + #:defined-syms defined-syms + #:declared-keywords declared-keywords + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset + #:loop pass-1-and-2-loop) + (namespace-visit-available-modules! m-ns phase) + (let loop ([tail? #t] [bodys bodys]) + (cond + [(null? bodys) + (cond + [(and tail? (not (zero? phase))) + (log-expand partial-body-ctx 'module-lift-end-loop '()) + null] + [tail? + ;; Were at the very end of the module; if there are any lifted-to-end + ;; declarations, keep going + (define bodys + (append + (get-and-clear-end-lifts! (expand-context-to-module-lifts partial-body-ctx)) + (get-and-clear-provide-lifts! (expand-context-to-module-lifts partial-body-ctx)))) + (log-expand partial-body-ctx 'module-lift-end-loop bodys) + (cond + [(null? bodys) null] + [else (loop #t (add-post-expansion-scope bodys partial-body-ctx))])] + [else null])] + [else + (define rest-bodys (cdr bodys)) + (log-expand partial-body-ctx 'next) + (define exp-body (performance-region + ['expand 'form-in-module/1] + ;; --- expand to core form --- + (expand (car bodys) partial-body-ctx))) + (define disarmed-exp-body (syntax-disarm exp-body)) + (define lifted-defns (get-and-clear-lifts! (expand-context-lifts partial-body-ctx))) + (when (pair? lifted-defns) + (log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys)) + (log-expand partial-body-ctx 'rename-one exp-body) + (append/tail-on-null + ;; Save any requires lifted during partial expansion + (get-and-clear-require-lifts! (expand-context-require-lifts partial-body-ctx)) + ;; Ditto for expressions + lifted-defns + ;; Ditto for modules, which need to be processed + (loop #f (add-post-expansion-scope + (get-and-clear-module-lifts! (expand-context-module-lifts partial-body-ctx)) + partial-body-ctx)) + ;; Dispatch on form revealed by partial expansion + (case (core-form-sym disarmed-exp-body phase) + [(begin) + (define-match m disarmed-exp-body '(begin e ...)) + (define (track e) (syntax-track-origin e exp-body)) + (define spliced-bodys (append (map track (m 'e)) rest-bodys)) + (log-expand partial-body-ctx 'splice spliced-bodys) + (loop tail? spliced-bodys)] + [(begin-for-syntax) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-begin-for-syntax] ['prepare-env]) + (define ct-m-ns (namespace->namespace-at-phase m-ns (add1 phase))) + (prepare-next-phase-namespace partial-body-ctx) + (log-expand partial-body-ctx 'phase-up) + (define-match m disarmed-exp-body '(begin-for-syntax e ...)) + (define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase))) + (log-expand partial-body-ctx 'next-group) + (namespace-run-available-modules! m-ns (add1 phase)) ; to support running `begin-for-syntax` + (eval-nested-bodys nested-bodys (add1 phase) ct-m-ns self partial-body-ctx) + (namespace-visit-available-modules! m-ns phase) ; since we're shifting back a phase + (log-expand partial-body-ctx 'exit-prim + (let ([s-nested-bodys (for/list ([nested-body (in-list nested-bodys)]) + (extract-syntax nested-body))]) + (datum->syntax #f (cons (m 'begin-for-syntax) s-nested-bodys) exp-body))) + (cons + (semi-parsed-begin-for-syntax exp-body nested-bodys) + (loop tail? rest-bodys))] + [(define-values) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-values]) + (define-match m disarmed-exp-body '(define-values (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) partial-body-ctx)) + (check-no-duplicate-ids ids phase exp-body) + (check-ids-unbound ids phase requires+provides #:in exp-body) + (define syms (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides + #:in exp-body)) + (for ([sym (in-list syms)]) + ;; In case `local-expand` created a binding with `sym` to a transformer + (namespace-unset-transformer! m-ns phase sym)) + (add-defined-syms! requires+provides syms phase) + (log-expand partial-body-ctx 'exit-prim + (datum->syntax #f `(,(m 'define-values) ,ids ,(m 'rhs)) exp-body)) + (cons + (semi-parsed-define-values exp-body syms ids (m 'rhs)) + (loop tail? rest-bodys))] + [(define-syntaxes) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-syntaxes] ['prepare-env]) + (prepare-next-phase-namespace partial-body-ctx) + (log-expand partial-body-ctx 'phase-up) + (define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) partial-body-ctx)) + (check-no-duplicate-ids ids phase exp-body) + (check-ids-unbound ids phase requires+provides #:in exp-body) + (define syms (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides + #:in exp-body + #:as-transformer? #t)) + (add-defined-syms! requires+provides syms phase #:as-transformer? #t) + ;; Expand and evaluate RHS: + (define-values (exp-rhs parsed-rhs vals) + (expand+eval-for-syntaxes-binding 'define-syntaxes + (m 'rhs) ids + (struct*-copy expand-context partial-body-ctx + [lifts #f] + ;; require lifts ok, others disallowed + [module-lifts #f] + [to-module-lifts #f] + [need-eventually-defined need-eventually-defined]) + #:log-next? #f)) + ;; Install transformers in the namespace for expansion: + (for ([sym (in-list syms)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase partial-body-ctx) + (namespace-set-transformer! m-ns phase sym val)) + (log-expand partial-body-ctx 'exit-prim (datum->syntax #f `(,(m 'define-syntaxes) ,ids ,exp-rhs))) + (define parsed-body (parsed-define-syntaxes (keep-properties-only exp-body) ids syms parsed-rhs)) + (cons (if (expand-context-to-parsed? partial-body-ctx) + parsed-body + (expanded+parsed + (rebuild + exp-body + `(,(m 'define-syntaxes) ,ids ,exp-rhs)) + parsed-body)) + (loop tail? rest-bodys))] + [(#%require) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-require]) + (define ready-body (remove-use-site-scopes disarmed-exp-body partial-body-ctx)) + (define-match m ready-body '(#%require req ...)) + (parse-and-perform-requires! (m 'req) exp-body #:self self + m-ns phase #:run-phase phase + requires+provides + #:declared-submodule-names declared-submodule-names + #:who 'module) + (log-expand partial-body-ctx 'exit-prim ready-body) + (cons exp-body + (loop tail? rest-bodys))] + [(#%provide) + ;; save for last pass + (cons exp-body + (loop tail? rest-bodys))] + [(module) + ;; Submodule to parse immediately + (define ready-body (remove-use-site-scopes exp-body partial-body-ctx)) + (define submod + (expand-submodule ready-body self partial-body-ctx + #:is-star? #f + #:declared-submodule-names declared-submodule-names + #:mpis-to-reset mpis-to-reset + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (cons submod + (loop tail? rest-bodys))] + [(module*) + ;; Submodule to save for after this module + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-submodule*] + ['exit-prim exp-body]) + (cons exp-body + (loop tail? rest-bodys))] + [(#%declare) + (define-match m disarmed-exp-body '(#%declare kw ...)) + (for ([kw (in-list (m 'kw))]) + (unless (keyword? (syntax-e kw)) + (raise-syntax-error #f "expected a keyword" exp-body kw)) + (unless (memq (syntax-e kw) '(#:cross-phase-persistent #:empty-namespace)) + (raise-syntax-error #f "not an allowed declaration keyword" exp-body kw)) + (when (hash-ref declared-keywords (syntax-e kw) #f) + (raise-syntax-error #f "keyword declared multiple times" exp-body kw)) + (hash-set! declared-keywords (syntax-e kw) kw)) + (define parsed-body (parsed-#%declare exp-body)) + (cons (if (expand-context-to-parsed? partial-body-ctx) + parsed-body + (expanded+parsed exp-body parsed-body)) + (loop tail? rest-bodys))] + [else + ;; save expression for next pass + (cons exp-body + (loop tail? rest-bodys))]))]))) + +;; Convert lifted identifiers plus expression to a `define-values` form: +(define (make-wrap-as-definition self frame-id + inside-scope all-scopes-stx + defined-syms requires+provides) + (lambda (ids rhs phase) + (define scoped-ids (for/list ([id (in-list ids)]) + (add-scope id inside-scope))) + (define syms + (select-defined-syms-and-bind! scoped-ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides)) + (define s (add-scope (datum->syntax + #f + (list (datum->syntax (syntax-shift-phase-level core-stx phase) + 'define-values) + scoped-ids + rhs)) + inside-scope)) + (values scoped-ids + (semi-parsed-define-values s syms scoped-ids rhs)))) + +(define (add-post-expansion-scope bodys ctx) + (define pe (root-expand-context-post-expansion ctx)) + (if pe + (for/list ([body (in-list bodys)]) + (apply-post-expansion pe body)) + bodys)) + +;; ---------------------------------------- + +;; Pass 2 of `module` expansion, which expands all expressions +(define (finish-expanding-body-expressons partially-expanded-bodys + #:phase phase + #:ctx body-ctx + #:self self + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset) + (let loop ([tail? #t] [bodys partially-expanded-bodys]) + (cond + [(null? bodys) + (cond + [(and tail? (not (zero? phase))) + (log-expand body-ctx 'module-lift-end-loop '()) + null] + [tail? + ;; We're at the very end of the module, again, so check for lifted-to-end + ;; declarations + (define bodys + (append + (get-and-clear-end-lifts! (expand-context-to-module-lifts body-ctx)) + (get-and-clear-provide-lifts! (expand-context-to-module-lifts body-ctx)))) + (cond + [(null? bodys) + (log-expand body-ctx 'module-lift-end-loop '()) + null] + [else + (loop #t (add-post-expansion-scope bodys body-ctx))])] + [else null])] + [else + (log-expand body-ctx 'next) + (define body (car bodys)) + (define rest-bodys (cdr bodys)) + (define exp-body + (cond + [(or (parsed? body) + (expanded+parsed? body) + (semi-parsed-begin-for-syntax? body)) + ;; An already-parsed (enough for now) form + body] + [(semi-parsed-define-values? body) + (define ids (semi-parsed-define-values-ids body)) + (define rhs-ctx (as-named-context (as-expression-context body-ctx) ids)) + (define syms (semi-parsed-define-values-syms body)) + (define s (semi-parsed-define-values-s body)) + (define-match m (syntax-disarm s) #:unless (expand-context-to-parsed? rhs-ctx) + '(define-values _ _)) + (define rebuild-s (keep-as-needed rhs-ctx s #:keep-for-parsed? #t)) + (log-defn-enter body-ctx body) + (define exp-rhs (performance-region + ['expand 'form-in-module/2] + (expand (semi-parsed-define-values-rhs body) rhs-ctx))) + (log-defn-exit body-ctx body exp-rhs) + (define comp-form + (parsed-define-values rebuild-s ids syms + (if (expand-context-to-parsed? rhs-ctx) + ;; Have (and need only) parsed form + exp-rhs + ;; Expand rhs again to parse it + (expand exp-rhs (as-to-parsed-context rhs-ctx))))) + (if (expand-context-to-parsed? rhs-ctx) + comp-form + (expanded+parsed + (rebuild + rebuild-s + `(,(m 'define-values) ,ids ,exp-rhs)) + comp-form))] + [else + (define disarmed-body (syntax-disarm body)) + (case (core-form-sym disarmed-body phase) + [(#%require #%provide module*) + ;; handle earlier or later + body] + [else + (performance-region + ['expand 'form-in-module/2] + (define exp-body (expand body (as-expression-context body-ctx))) + (if (expand-context-to-parsed? body-ctx) + ;; Have (and need only) parsed form + exp-body + ;; Expand again to parse it + (expanded+parsed + exp-body + (expand exp-body (as-to-parsed-context body-ctx)))))])])) + (define lifted-defns (get-and-clear-lifts! (expand-context-lifts body-ctx))) + (define lifted-requires + ;; Get any requires and provides, keeping them as-is + (get-and-clear-require-lifts! (expand-context-require-lifts body-ctx))) + (define lifted-modules (get-and-clear-module-lifts! (expand-context-module-lifts body-ctx))) + (define no-lifts? (and (null? lifted-defns) (null? lifted-modules) (null? lifted-requires))) + (unless no-lifts? + (log-expand body-ctx 'module-lift-loop (append lifted-requires + (lifted-defns-extract-syntax lifted-defns) + (add-post-expansion-scope lifted-modules body-ctx)))) + (define exp-lifted-modules + ;; If there were any module lifts, the `module` forms need to + ;; be expanded + (expand-non-module*-submodules lifted-modules + phase + self + body-ctx + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (define exp-lifted-defns + ;; If there were any lifts, the right-hand sides need to be expanded + (loop #f lifted-defns)) + (unless no-lifts? (log-expand body-ctx 'next)) + (append + lifted-requires + exp-lifted-defns + exp-lifted-modules + (cons exp-body + (loop tail? rest-bodys)))]))) + +(define (check-defined-by-now need-eventually-defined self ctx requires+provides) + ;; If `need-eventually-defined` is not empty, report an error + (for ([(phase l) (in-hash need-eventually-defined)]) + (for ([id (in-list l)]) + (define b (resolve+shift id phase)) + (define bound-here? (and b + (module-binding? b) + (eq? (module-binding-sym b) (syntax-e id)) + (eq? (module-binding-module b) self))) + (define bound-kind (and bound-here? + (defined-sym-kind requires+provides (module-binding-sym b) phase))) + (unless (eq? bound-kind 'variable) + (raise-syntax-error #f + (string-append + (cond + [(not b) "reference to an unbound identifier"] + [(eq? bound-kind 'transformer) "identifier treated as a variable, but later defined as syntax"] + [else "identifier treated as a variable, but later bound differently"]) + (format "\n at phase: ~a" (case phase + [(1) "1; the transformer environment"] + [else phase]))) + id #f null + (syntax-debug-info-string id ctx)))))) + +;; ---------------------------------------- + +;; Pass 3 of `module` expansion, which parses `provide` forms and +;; matches them up with defintiions and requires +(define (resolve-provides expression-expanded-bodys + #:requires-and-provides requires+provides + #:declared-submodule-names declared-submodule-names + #:namespace m-ns + #:phase phase + #:self self + #:ctx ctx) + (performance-region + ['expand 'provide] + (let loop ([bodys expression-expanded-bodys] [phase phase]) + (cond + [(null? bodys) null] + [(or (parsed? (car bodys)) + (expanded+parsed? (car bodys))) + (cons (car bodys) + (loop (cdr bodys) phase))] + [(semi-parsed-begin-for-syntax? (car bodys)) + (define nested-bodys (loop (semi-parsed-begin-for-syntax-body (car bodys)) (add1 phase))) + ;; Stil semi-parsed; finished in pass 4 + (cons (struct-copy semi-parsed-begin-for-syntax (car bodys) + [body nested-bodys]) + (loop (cdr bodys) phase))] + [else + (define disarmed-body (syntax-disarm (car bodys))) + (case (core-form-sym disarmed-body phase) + [(#%provide) + (log-expand* ctx ['enter-prim (car bodys)] ['prim-provide]) + (define-match m disarmed-body '(#%provide spec ...)) + (define-values (track-stxes specs) + (parse-and-expand-provides! (m 'spec) (car bodys) + requires+provides self + phase (struct*-copy expand-context ctx + [context 'top-level] + [phase phase] + [namespace (namespace->namespace-at-phase m-ns phase)] + [requires+provides requires+provides] + [declared-submodule-names declared-submodule-names]))) + (cond + [(expand-context-to-parsed? ctx) + (loop (cdr bodys) phase)] + [else + (define new-s + (syntax-track-origin* + track-stxes + (rebuild + (car bodys) + `(,(m '#%provide) ,@specs)))) + (log-expand ctx 'exit-prim new-s) + (cons new-s + (loop (cdr bodys) phase))])] + [else + (cons (car bodys) + (loop (cdr bodys) phase))])])))) + +;; ---------------------------------------- + +;; In support of pass 4, declare a module (in a temporary namespace) +;; before any `module*` submodule is expanded +(define (declare-module-for-expansion fully-expanded-bodys-except-post-submodules + #:module-name-id module-name-id + #:rebuild-s rebuild-s + #:requires-and-provides requires+provides + #:namespace m-ns + #:self self + #:enclosing enclosing-self + #:root-ctx root-ctx + #:ctx ctx + #:modules-being-compiled modules-being-compiled + #:fill compiled-module-box) + + (define-values (requires provides) (extract-requires-and-provides requires+provides self self)) + + (define parsed-mod + (parsed-module rebuild-s + #f + module-name-id + self + requires + provides + (requires+provides-all-bindings-simple? requires+provides) + (root-expand-context-encode-for-module root-ctx self self) + (parsed-only fully-expanded-bodys-except-post-submodules) + #f + (hasheq))) + + (define module-name (module-path-index-resolve (or enclosing-self self))) + (define compiled-module + (compile-module parsed-mod + (make-compile-context #:namespace m-ns + #:module-self enclosing-self + #:full-module-name (and enclosing-self + (resolved-module-path-name module-name))) + #:serializable? (expand-context-for-serializable? ctx) + #:modules-being-compiled modules-being-compiled + #:need-compiled-submodule-rename? #f)) + (set-box! compiled-module-box compiled-module) + + (define root-module-name (resolved-module-path-root-name module-name)) + (parameterize ([current-namespace m-ns] + [current-module-declare-name (make-resolved-module-path root-module-name)]) + (eval-module compiled-module + #:with-submodules? #f))) + +(define (attach-root-expand-context-properties s root-ctx orig-self new-self) + ;; Original API: + (let* ([s (syntax-property s 'module-body-context (root-expand-context-all-scopes-stx root-ctx))] + [s (syntax-property s + 'module-body-inside-context + (apply-post-expansion (root-expand-context-post-expansion root-ctx) + empty-syntax))]) + s)) + +;; ---------------------------------------- + +;; Pass 4 of `module` expansion, which expands `module*` forms; +;; this pass muct happen after everything else for the module, since a +;; `module*` submodule can require from its enclosing module; in +;; addition to expanding `module*`, generate expanded `begin-for-syntax` +;; as needed and ensure that parsed `begin-for-syntax` has only parsed +;; forms +(define (expand-post-submodules fully-expanded-bodys-except-post-submodules + #:declare-enclosing declare-enclosing-module + #:phase phase + #:self self + #:requires-and-provides requires+provides + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:all-scopes-s all-scopes-s + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:ctx submod-ctx) + (let loop ([bodys fully-expanded-bodys-except-post-submodules] [phase phase]) + (cond + [(null? bodys) null] + [else + (define body (car bodys)) + (define rest-bodys (cdr bodys)) + (cond + [(semi-parsed-begin-for-syntax? body) + (define body-s (semi-parsed-begin-for-syntax-s body)) + (define-match m (syntax-disarm body-s) '(begin-for-syntax _ ...)) + (define rebuild-body-s (keep-as-needed submod-ctx body-s)) + (define nested-bodys (loop (semi-parsed-begin-for-syntax-body body) (add1 phase))) + (define parsed-bfs (parsed-begin-for-syntax rebuild-body-s (parsed-only nested-bodys))) + (cons + (if (expand-context-to-parsed? submod-ctx) + parsed-bfs + (expanded+parsed + (rebuild rebuild-body-s `(,(m 'begin-for-syntax) ,@(syntax-only nested-bodys))) + parsed-bfs)) + (loop rest-bodys phase))] + [(or (parsed? body) + (expanded+parsed? body)) + ;; We can skip any other parsed form + (cons body + (loop rest-bodys phase))] + [else + (define disarmed-body (syntax-disarm body)) + (case (core-form-sym disarmed-body phase) + [(module*) + ;; Ensure that the enclosing module is declared: + (force declare-enclosing-module) + (define ready-body (remove-use-site-scopes body submod-ctx)) + (define-match f-m disarmed-body #:try '(module* name #f . _)) + (define submod + (cond + [(f-m) + ;; Need to shift the submodule relative to the enclosing module: + (define neg-phase (phase- 0 phase)) + (define shifted-s (syntax-shift-phase-level ready-body neg-phase)) + (define submod + (expand-submodule shifted-s self submod-ctx + #:is-star? #t + #:keep-enclosing-scope-at-phase neg-phase + #:enclosing-requires+provides requires+provides + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (cond + [(parsed? submod) submod] + [(expanded+parsed? submod) + (struct-copy expanded+parsed submod + [s (syntax-shift-phase-level (expanded+parsed-s submod) phase)])] + [else (syntax-shift-phase-level submod phase)])] + [else + (expand-submodule ready-body self submod-ctx + #:is-star? #t + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)])) + (cons submod + (loop rest-bodys phase))] + [else + ;; We can skip any other unparsed form + (cons body + (loop rest-bodys phase))])])]))) + +(define (stop-at-module*? ctx) + (free-id-set-member? (expand-context-stops ctx) + (expand-context-phase ctx) + (syntax-shift-phase-level (datum->syntax core-stx 'module*) + (expand-context-phase ctx)))) + +;; ---------------------------------------- + +(define (check-ids-unbound ids phase requires+provides #:in s) + (for ([id (in-list ids)]) + (check-not-defined requires+provides id phase #:in s #:who 'module))) + +;; ---------------------------------------- + +(define (eval-nested-bodys bodys phase m-ns self ctx) + ;; The definitions and expression `bodys` are fully expanded and + ;; parsed; evaluate them + (for ([body (in-list bodys)]) + (define p (if (expanded+parsed? body) + (expanded+parsed-parsed body) + body)) + (cond + [(parsed-define-values? p) + (define ids (parsed-define-values-ids p)) + (define vals (eval-for-bindings 'define-values ids (parsed-define-values-rhs p) phase m-ns ctx)) + (for ([id (in-list ids)] + [sym (in-list (parsed-define-values-syms p))] + [val (in-list vals)]) + (namespace-set-variable! m-ns phase sym val))] + [(or (parsed-define-syntaxes? p) + (semi-parsed-begin-for-syntax? p)) + ;; already evaluated during expansion + (void)] + [(or (parsed-#%declare? p) + (syntax? p)) + ;; handled earlier or later + (void)] + [else + ;; an expression + (parameterize ([current-expand-context ctx] + [current-namespace m-ns]) + (eval-single-top + (compile-single p (make-compile-context + #:namespace m-ns + #:phase phase)) + m-ns))]))) + +;; ---------------------------------------- + +(define (expand-submodule s self ctx + #:is-star? is-star? + #:keep-enclosing-scope-at-phase [keep-enclosing-scope-at-phase #f] + #:enclosing-requires+provides [enclosing-r+p #f] + #:enclosing-is-cross-phase-persistent? [enclosing-is-cross-phase-persistent? #f] + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled) + (unless is-star? + (log-expand* ctx ['enter-prim s] [(if is-star? 'prim-submodule* 'prim-submodule)])) + + ;; Register name and check for duplicates + (define-match m s '(module name . _)) + (define name (syntax-e (m 'name))) + (when (hash-ref declared-submodule-names name #f) + (raise-syntax-error #f "submodule already declared with the same name" s name)) + (hash-set! declared-submodule-names name (syntax-e (m 'module))) + + (log-expand* ctx ['enter-prim s]) + + (define submod + (expand-module s + (struct*-copy expand-context ctx + [context 'module] + [stops empty-free-id-set] + [post-expansion #:parent root-expand-context #f]) + self + #:always-produce-compiled? #t + #:keep-enclosing-scope-at-phase keep-enclosing-scope-at-phase + #:enclosing-requires+provides enclosing-r+p + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:mpis-for-enclosing-reset mpis-to-reset + #:modules-being-compiled modules-being-compiled)) + + (log-expand* ctx ['exit-prim (extract-syntax submod)]) + + ;; Compile and declare the submodule for use by later forms + ;; in the enclosing module: + (define ns (expand-context-namespace ctx)) + (define module-name (module-path-index-resolve self)) + (define root-module-name (resolved-module-path-root-name module-name)) + (define compiled-submodule + (compile-module (if (expanded+parsed? submod) + (expanded+parsed-parsed submod) + submod) + (make-compile-context #:namespace ns + #:module-self self + #:full-module-name (resolved-module-path-name module-name)) + #:force-linklet-directory? #t + #:serializable? (expand-context-for-serializable? ctx) + #:modules-being-compiled modules-being-compiled + #:need-compiled-submodule-rename? #f)) + (hash-set! compiled-submodules name (cons is-star? compiled-submodule)) + (parameterize ([current-namespace ns] + [current-module-declare-name (make-resolved-module-path root-module-name)]) + (eval-module compiled-submodule + #:with-submodules? #f)) + + (unless is-star? + (log-expand ctx 'exit-prim (extract-syntax submod))) + + ;; Return the expanded submodule + (cond + [(not is-star?) + submod] + [(expanded+parsed? submod) + (struct-copy expanded+parsed submod + [parsed (struct-copy parsed-module (expanded+parsed-parsed submod) + [star? #t])])] + [else + (struct-copy parsed-module submod + [star? #t])])) + +;; Expand `module` forms, leave `module*` forms alone: +(define (expand-non-module*-submodules bodys phase self ctx + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled) + (for/list ([body (in-list bodys)]) + (case (core-form-sym (syntax-disarm body) phase) + [(module) + (expand-submodule body self ctx + #:is-star? #f + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)] + [else body]))) + +;; ---------------------------------------- + +(define (make-parse-lifted-require m-ns self requires+provides + #:declared-submodule-names declared-submodule-names) + (lambda (s phase) + (define-match m (syntax-disarm s) '(#%require req)) + (parse-and-perform-requires! (list (m 'req)) s #:self self + m-ns phase #:run-phase phase + requires+provides + #:declared-submodule-names declared-submodule-names + #:who 'require))) + +;; ---------------------------------------- + +(define (defn-extract-syntax defn) + (datum->syntax #f `(define-values ,(semi-parsed-define-values-ids defn) + ,(semi-parsed-define-values-rhs defn)) + (semi-parsed-define-values-s defn))) + +(define (lifted-defns-extract-syntax lifted-defns) + (for/list ([lifted-defn (in-list lifted-defns)]) + (defn-extract-syntax lifted-defn))) + +(define (log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys) + (log-expand... + partial-body-ctx + (lambda (obs) + (define s-lifted-defns (lifted-defns-extract-syntax lifted-defns)) + (...log-expand obs ['rename-list (cons exp-body rest-bodys)] ['module-lift-loop s-lifted-defns]) + ;; The old expander retried expanding the lifted definitions. + ;; We know that they immediately stop, so we don't do that here, + ;; but we simulate the observer events. + (for ([s-lifted-defn (in-list s-lifted-defns)]) + (define-match m s-lifted-defn '(define-values _ ...)) + (...log-expand obs + ['next] + ['visit s-lifted-defn] + ['resolve (m 'define-values)] + ['enter-prim s-lifted-defn] + ['prim-stop] + ['exit-prim s-lifted-defn] + ['return s-lifted-defn] + ['rename-one s-lifted-defn] + ['enter-prim s-lifted-defn] + ['prim-define-values] + ['exit-prim s-lifted-defn])) + ;; A 'next, etc., to simulate retrying the expression that + ;; generated the lifts --- which we know must be a stop form, + ;; but we need to simulate the trip back around the loop: + (define-match m exp-body '(form-id . _)) + (...log-expand obs + ['next] + ['visit exp-body] + ['resolve (m 'form-id)] + ['enter-prim exp-body] + ['prim-stop] + ['exit-prim exp-body] + ['return exp-body])))) + +(define (log-defn-enter ctx defn) + (log-expand... + ctx + (lambda (obs) + (define s-defn (defn-extract-syntax defn)) + (define-match m s-defn '(define-values _ ...)) + (...log-expand obs + ['visit s-defn] + ['resolve (m 'define-values)] + ['enter-prim s-defn] + ['prim-define-values])))) + +(define (log-defn-exit ctx defn exp-rhs) + (log-expand... + ctx + (lambda (obs) + (define s-defn + (datum->syntax #f `(define-values ,(semi-parsed-define-values-ids defn) + ,exp-rhs) + (semi-parsed-define-values-s defn))) + (...log-expand obs + ['exit-prim s-defn] + ['return s-defn])))) diff -Nru racket-6.12+ppa1/src/expander/expand/parsed.rkt racket-7.0+ppa1/src/expander/expand/parsed.rkt --- racket-6.12+ppa1/src/expander/expand/parsed.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/parsed.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,51 @@ +#lang racket/base + +(provide (all-defined-out)) + +;; A fully expanded form can be parsed into an AST. In principle, +;; parsing could be a pass separate from the expander. As an important +;; shortcut, however, we fuse the expander and parser; the +;; `to-parsed?` field in an `expand-context` indicates whether the +;; expander should produce a syntax object or a `parsed` structure. + +(struct parsed (s) #:authentic #:transparent) + +(struct parsed-id parsed (binding inspector) #:authentic) +(struct parsed-primitive-id parsed-id () #:authentic) +(struct parsed-top-id parsed-id () #:authentic) + +(struct parsed-lambda parsed (keys body) #:authentic) +(struct parsed-case-lambda parsed (clauses) #:authentic) +(struct parsed-app parsed (rator rands) #:authentic) +(struct parsed-if parsed (tst thn els) #:authentic) +(struct parsed-set! parsed (id rhs) #:authentic) +(struct parsed-with-continuation-mark parsed (key val body) #:authentic) +(struct parsed-#%variable-reference parsed (id) #:authentic) +(struct parsed-begin parsed (body) #:authentic) +(struct parsed-begin0 parsed (body) #:authentic) +(struct parsed-quote parsed (datum) #:authentic) +(struct parsed-quote-syntax parsed (datum) #:authentic) + +(struct parsed-let_-values parsed (idss clauses body) #:authentic) +(struct parsed-let-values parsed-let_-values () #:authentic) +(struct parsed-letrec-values parsed-let_-values () #:authentic) + +(struct parsed-define-values parsed (ids syms rhs) #:authentic) +(struct parsed-define-syntaxes parsed (ids syms rhs) #:authentic) +(struct parsed-begin-for-syntax parsed (body) #:authentic) + +(struct parsed-#%declare parsed () #:authentic) +(struct parsed-require parsed () #:authentic) + +(struct parsed-#%module-begin parsed (body) #:authentic) +(struct parsed-module parsed (star? + name-id + self + requires + provides + root-ctx-simple? + encoded-root-ctx + body + compiled-module ; #f or already-compiled module + compiled-submodules) ; already-compiled submodules + #:authentic) diff -Nru racket-6.12+ppa1/src/expander/expand/prepare.rkt racket-7.0+ppa1/src/expander/expand/prepare.rkt --- racket-6.12+ppa1/src/expander/expand/prepare.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/prepare.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang racket/base +(require "../namespace/namespace.rkt" + "../namespace/module.rkt" + "context.rkt") + +(provide prepare-next-phase-namespace) + +(define (prepare-next-phase-namespace ctx) + (define phase (add1 (expand-context-phase ctx))) + (define ns (namespace->namespace-at-phase (expand-context-namespace ctx) + phase)) + (namespace-visit-available-modules! ns phase)) diff -Nru racket-6.12+ppa1/src/expander/expand/protect.rkt racket-7.0+ppa1/src/expander/expand/protect.rkt --- racket-6.12+ppa1/src/expander/expand/protect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/protect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,76 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../common/module-path.rkt" + "binding-to-module.rkt") + +(provide resolve+shift/extra-inspector + check-access) + +;; Check inspector-based access to a module's definitions; a suitable inspector +;; might be provided by `id`, or the binding might carry an extra inspector +;; (put there via a provide of a rename transformer, where the extra inspector +;; was attached to the identifier in the rename transformer). Return #t if +;; the binding is protected. +(define (check-access b mi id in-s what) + (define m (module-instance-module mi)) + (cond + [(and m (not (module-no-protected? m))) + (define access (or (module-access m) (module-compute-access! m))) + (define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq()) + (module-binding-sym b) + 'unexported)) + (cond + [(or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector)) + (namespace-inspector (module-instance-namespace mi))) + (and (module-binding-extra-inspector b) + (inspector-superior? (module-binding-extra-inspector b) + (namespace-inspector (module-instance-namespace mi))))) + ;; In the error message, use the original expression `in-s` or + ;; the symbol protected or defined in the target module --- + ;; but only if that name is different from `id`, which we'll + ;; certainly include in the error + (define complain-id (let ([c-id (or in-s (module-binding-sym b))]) + (and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id) + (syntax-content id))) + c-id))) + (raise-syntax-error #f + (format "access disallowed by code inspector to ~a ~a\n from module: ~a" + a + what + (module-path-index-resolve (namespace-mpi (module-instance-namespace mi)))) + complain-id id null)) + #t] + [else #f])] + [else #f])) + +;; Like `resolve+shift`, but follow `free-identifier=?` chains to +;; attach an inspector at the last step in the chain to the +;; resulting binding. Also, check protected access along the way, +;; so that we don't expose an inspector that the reference is not +;; allowed to reach. +(define (resolve+shift/extra-inspector id phase ns) + (let loop ([id id] [in-s #f]) + (define b (resolve+shift id phase #:immediate? #t)) + (cond + [(binding-free=id b) + => (lambda (next-id) + (when (and (module-binding? b) + (not (top-level-module-path-index? (module-binding-module b)))) + (define mi (binding->module-instance b ns phase id)) + (check-access b mi id in-s "provided binding")) + (define next-b (loop next-id (or in-s id))) + (cond + [(not next-b) b] + [(and (module-binding? next-b) + (not (module-binding-extra-inspector next-b)) + (syntax-inspector id)) + (module-binding-update next-b + #:extra-inspector (syntax-inspector id))] + [else next-b]))] + [else b]))) diff -Nru racket-6.12+ppa1/src/expander/expand/provide.rkt racket-7.0+ppa1/src/expander/expand/provide.rkt --- racket-6.12+ppa1/src/expander/expand/provide.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/provide.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,276 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/taint.rkt" + "../syntax/track.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/match.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "require+provide.rkt" + "context.rkt" + "protect.rkt" + "module-path.rkt" + "binding-for-transformer.rkt" + "../namespace/core.rkt" + "../common/module-path.rkt" + "free-id-set.rkt" + "main.rkt") + +(provide parse-and-expand-provides!) + +(define layers '(raw phaseless id)) + +(define provide-form-name 'provide) ; complain as `provide` instead of `#%provide` + +(define (parse-and-expand-provides! specs orig-s + rp self + phase ctx) + ;; returns a list of expanded specs while registering provides in `rp` + (define ns (expand-context-namespace ctx)) + (let loop ([specs specs] + [at-phase phase] + [protected? #f] + [layer 'raw]) + (define-values (track-stxess exp-specss) + (for/lists (track-stxes exp-specs) ([spec (in-list specs)]) + (define disarmed-spec (syntax-disarm spec)) + (define fm (and (pair? (syntax-e disarmed-spec)) + (identifier? (car (syntax-e disarmed-spec))) + (syntax-e (car (syntax-e disarmed-spec))))) + (define (check-nested want-layer) + (unless (member want-layer (member layer layers)) + (raise-syntax-error provide-form-name (format "nested `~a' not allowed" fm) orig-s spec))) + (case fm + [(for-meta) + (check-nested 'raw) + (define-match m disarmed-spec '(for-meta phase-level spec ...)) + (define p (syntax-e (m 'phase-level))) + (unless (phase? p) + (raise-syntax-error provide-form-name "bad `for-meta' phase" orig-s spec)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + (phase+ p at-phase) + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-meta) ,(m 'phase-level) ,@exp-specs)))))] + [(for-syntax) + (check-nested 'raw) + (define-match m disarmed-spec '(for-syntax spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + (phase+ 1 at-phase) + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-syntax) ,@exp-specs)))))] + [(for-label) + (check-nested 'raw) + (define-match m disarmed-spec '(for-label spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + #f + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-label) ,@exp-specs)))))] + [(protect) + (check-nested 'phaseless) + (when protected? + (raise-syntax-error provide-form-name "nested `protect' not allowed" orig-s spec)) + (define-match m disarmed-spec '(protect p-spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'p-spec) + at-phase + #t + layer)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'protect) ,@exp-specs)))))] + [(rename) + (check-nested 'phaseless) + (define-match m disarmed-spec '(rename id:from id:to)) + (parse-identifier! (m 'id:from) orig-s (syntax-e (m 'id:to)) at-phase ns rp protected?) + (values null (list spec))] + [(struct) + (check-nested 'phaseless) + (define-match m disarmed-spec '(struct id:struct (id:field ...))) + (parse-struct! (m 'id:struct) orig-s (m 'id:field) at-phase ns rp protected?) + (values null (list spec))] + [(all-from) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-from mod-path)) + (parse-all-from (m 'mod-path) orig-s self null at-phase ns rp protected? ctx) + (values null (list spec))] + [(all-from-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-from-except mod-path id ...)) + (parse-all-from (m 'mod-path) orig-s self (m 'id) at-phase ns rp protected? ctx) + (values null (list spec))] + [(all-defined) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-defined)) + (parse-all-from-module self spec orig-s null #f at-phase ns rp protected?) + (values null (list spec))] + [(all-defined-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-defined-except id ...)) + (parse-all-from-module self spec orig-s (m 'id) #f at-phase ns rp protected?) + (values null (list spec))] + [(prefix-all-defined) + (check-nested 'phaseless) + (define-match m disarmed-spec '(prefix-all-defined id:prefix)) + (parse-all-from-module self spec orig-s null (syntax-e (m 'id:prefix)) at-phase ns rp protected?) + (values null (list spec))] + [(prefix-all-defined-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(prefix-all-defined-except id:prefix id ...)) + (parse-all-from-module self spec orig-s (m 'id) (syntax-e (m 'id:prefix)) at-phase ns rp protected?) + (values null (list spec))] + [(expand) + (define-match ex-m disarmed-spec '(expand (id . datum))) ; just check syntax + (define-match m disarmed-spec '(expand form)) ; get form to expand + (define exp-spec (expand (m 'form) (struct*-copy expand-context ctx + [stops (free-id-set at-phase (list (core-id 'begin at-phase)))] + ;; Discarding definition-context scopes is ok, + ;; because the scopes won't be captured by + ;; any `quote-syntax`: + [def-ctx-scopes #f]))) + (unless (and (pair? (syntax-e exp-spec)) + (identifier? (car (syntax-e exp-spec))) + (eq? 'begin (core-form-sym exp-spec at-phase))) + (raise-syntax-error provide-form-name "expansion was not a `begin' sequence" orig-s spec)) + (define-match e-m exp-spec '(begin spec ...)) + (define-values (track-stxes exp-specs) + (loop (e-m 'spec) + at-phase + protected? + layer)) + (values (list* spec exp-spec track-stxes) + exp-specs)] + [else + (cond + [(identifier? spec) + (parse-identifier! spec orig-s (syntax-e spec) at-phase ns rp protected?) + (values null (list spec))] + [else + (raise-syntax-error provide-form-name "bad syntax" orig-s spec)])]))) + (values (apply append track-stxess) + (apply append exp-specss)))) + +;; ---------------------------------------- + +(define (parse-identifier! spec orig-s sym at-phase ns rp protected?) + (define b (resolve+shift/extra-inspector spec at-phase ns)) + (unless b + (raise-syntax-error provide-form-name "provided identifier is not defined or required" orig-s spec)) + (define as-transformer? (binding-for-transformer? b spec at-phase ns)) + (define immed-b (resolve+shift spec at-phase #:immediate? #t)) + (add-provide! rp sym at-phase b immed-b spec orig-s + #:as-protected? protected? + #:as-transformer? as-transformer?)) + +(define (parse-struct! id:struct orig-s fields at-phase ns rp protected?) + (define (mk fmt) + (define sym (string->symbol (format fmt (syntax-e id:struct)))) + (datum->syntax id:struct sym id:struct)) + (define (mk2 fmt field-id) + (define sym (string->symbol (format fmt + (syntax-e id:struct) + (syntax-e field-id)))) + (datum->syntax id:struct sym id:struct)) + (for ([fmt (in-list (list "~a" + "make-~a" + "struct:~a" + "~a?"))]) + (define id (mk fmt)) + (parse-identifier! id orig-s (syntax-e id) at-phase ns rp protected?)) + (for ([field (in-list fields)]) + (define get-id (mk2 "~a-~a" field)) + (define set-id (mk2 "set-~a-~a!" field)) + (parse-identifier! get-id orig-s (syntax-e get-id) at-phase ns rp protected?) + (parse-identifier! set-id orig-s (syntax-e set-id) at-phase ns rp protected?))) + +(define (parse-all-from mod-path-stx orig-s self except-ids at-phase ns rp protected? ctx) + (define mod-path (syntax->datum mod-path-stx)) + (unless (module-path? mod-path) + (raise-syntax-error provide-form-name "not a module path" orig-s mod-path-stx)) + (define mpi (module-path->mpi/context mod-path ctx)) + (parse-all-from-module mpi #f orig-s except-ids #f at-phase ns rp protected?)) + +(define (parse-all-from-module mpi matching-stx orig-s except-ids prefix-sym at-phase ns rp protected?) + (define requireds (extract-module-requires rp mpi at-phase)) + + (define (phase-desc) (cond + [(zero-phase? at-phase) ""] + [(label-phase? at-phase) " for-label"] + [else (format " for phase ~a" at-phase)])) + (unless requireds + (raise-syntax-error provide-form-name + (format "cannot provide from a module without a matching require~a" + (phase-desc)) + orig-s matching-stx)) + + (define (add-prefix sym) + (if prefix-sym + (string->symbol (format "~a~a" prefix-sym sym)) + sym)) + + (define found (make-hasheq)) + + ;; Register all except excluded bindings: + (for ([i (in-list requireds)]) + (define id (required-id i)) + (define phase (required-phase i)) + (unless (or (and matching-stx + ;; For `(all-defined-out)`, phase and binding context must match: + (not (and (eqv? phase at-phase) + (free-identifier=? id + (datum->syntax matching-stx (syntax-e id)) + phase + phase)))) + (for/or ([except-id (in-list except-ids)]) + (and (free-identifier=? id except-id phase phase) + (hash-set! found except-id #t)))) + (define b (resolve+shift/extra-inspector id phase ns)) + (define immed-b (resolve+shift id phase #:immediate? #t)) + (add-provide! rp (add-prefix (syntax-e id)) phase b immed-b id orig-s + #:as-protected? protected? + #:as-transformer? (required-as-transformer? i)))) + + ;; Check that all exclusions matched something to exclude: + (unless (= (hash-count found) (length except-ids)) + (for ([except-id (in-list except-ids)]) + (unless (or (hash-ref found except-id #f) + (for/or ([i (in-list requireds)]) + (define id (required-id i)) + (define phase (required-phase i)) + (free-identifier=? id except-id phase phase))) + (raise-syntax-error provide-form-name + (format (if matching-stx + "excluded identifier was not defined or required in the module~a" + "excluded identifier was not required from the specified module~a") + (phase-desc)) + orig-s + except-id))))) diff -Nru racket-6.12+ppa1/src/expander/expand/rebuild.rkt racket-7.0+ppa1/src/expander/expand/rebuild.rkt --- racket-6.12+ppa1/src/expander/expand/rebuild.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/rebuild.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/taint.rkt") + +(provide rebuild) + +;; A helper for forms to reconstruct syntax while preserving source +;; locations, properties, and arming; if `track?` is #f, then don't keep +;; properties, because we've kept them in a surrounding form +(define (rebuild orig-s new + #:track? [track? #t]) + (syntax-rearm (datum->syntax (syntax-disarm orig-s) new orig-s (and track? orig-s)) + orig-s)) + diff -Nru racket-6.12+ppa1/src/expander/expand/reference-record.rkt racket-7.0+ppa1/src/expander/expand/reference-record.rkt --- racket-6.12+ppa1/src/expander/expand/reference-record.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/reference-record.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#lang racket/base +(require "../common/set.rkt") + +;; A reference record keeps tarck of which bindings in a frame are +;; being referenced and which have been already bound so that a +;; reference doesn't count as a forward reference. This information +;; is needed for expanding internal definitions to break them into +;; suitable `let` and `letrec` sets. + +(provide make-reference-record + reference-record? + reference-record-used! + reference-records-all-used! + reference-record-bound! + reference-record-forward-references? + reference-record-clear!) + +(struct reference-record ([already-bound #:mutable] + [reference-before-bound #:mutable] + [all-referenced? #:mutable]) + #:authentic + #:transparent) + +(define (make-reference-record) + (reference-record (seteq) (seteq) #f)) + +(define (reference-record-used! rr key) + (unless (set-member? (reference-record-already-bound rr) key) + (set-reference-record-reference-before-bound! + rr + (set-add (reference-record-reference-before-bound rr) key)))) + +(define (reference-records-all-used! rrs) + (for ([rr (in-list rrs)] + ;; If a reference record is already marked as all referenced, + ;; then later records must be already marked, too + #:break (reference-record-all-referenced? rr)) + (set-reference-record-all-referenced?! rr #t))) + +(define (reference-record-bound! rr keys) + (set-reference-record-already-bound! + rr + (for/fold ([ab (reference-record-already-bound rr)]) ([key (in-list keys)]) + (set-add ab key ))) + (set-reference-record-reference-before-bound! + rr + (for/fold ([rbb (reference-record-reference-before-bound rr)]) ([key (in-list keys)]) + (set-remove rbb key)))) + +(define (reference-record-forward-references? rr) + (or (reference-record-all-referenced? rr) + (positive? (set-count (reference-record-reference-before-bound rr))))) + +(define (reference-record-clear! rr) + (set-reference-record-already-bound! rr #f) + (set-reference-record-reference-before-bound! rr #f)) diff -Nru racket-6.12+ppa1/src/expander/expand/rename-trans.rkt racket-7.0+ppa1/src/expander/expand/rename-trans.rkt --- racket-6.12+ppa1/src/expander/expand/rename-trans.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/rename-trans.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,61 @@ +#lang racket/base +(require "../syntax/syntax.rkt") + +(provide rename-transformer? + prop:rename-transformer + make-rename-transformer + rename-transformer-target) + +(define-values (prop:rename-transformer rename-transformer? rename-transformer-value) + (make-struct-type-property 'rename-transformer + (lambda (v info) + (unless (or (exact-nonnegative-integer? v) + (identifier? v) + (and (procedure? v) + (procedure-arity-includes? v 1))) + (raise-argument-error + 'guard-for-prop:rename-transformer + (string-append "(or/c exact-nonnegative-integer?\n" + " identifier?\n" + " (procedure-arity-includes? proc 1))") + v)) + (when (exact-nonnegative-integer? v) + (unless (v . <= . (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:rename-transformer + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (member v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:rename-transformer + "field index not declared immutable" + "field index" v))) + (define ref (list-ref info 3)) + (cond + [(identifier? v) (lambda (t) v)] + [(integer? v) + (lambda (t) + (define val (ref t v)) + (if (identifier? val) + val + (datum->syntax #f '?)))] + [else (lambda (t) + (define id (call-with-continuation-prompt + (lambda () + (v t)))) + (unless (identifier? id) + (raise-arguments-error 'prop:rename-transformer + "contract violation for given value; expected an identifier" + "given" id)) + id)])))) + +(struct id-rename-transformer (id) + #:property prop:rename-transformer 0 + #:reflection-name 'rename-transformer) + +(define (make-rename-transformer id) + (unless (identifier? id) + (raise-argument-error 'make-rename-transformer "identifier?" id)) + (id-rename-transformer id)) + +(define (rename-transformer-target t) + ((rename-transformer-value t) t)) diff -Nru racket-6.12+ppa1/src/expander/expand/require+provide.rkt racket-7.0+ppa1/src/expander/expand/require+provide.rkt --- racket-6.12+ppa1/src/expander/expand/require+provide.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/require+provide.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,532 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/list-ish.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../syntax/bulk-binding.rkt" + "../syntax/mapped-name.rkt" + "../namespace/namespace.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../common/module-path-intern.rkt" + "env.rkt") + +(provide make-requires+provides + requires+provides-self + requires+provides-can-cross-phase-persistent? + + requires+provides-all-bindings-simple? + set-requires+provides-all-bindings-simple?! + + (struct-out required) + add-required-module! + add-defined-or-required-id! + add-bulk-required-ids! + add-enclosing-module-defined-and-required! + remove-required-id! + check-not-defined + add-defined-syms! + defined-sym-kind + extract-module-requires + extract-module-definitions + extract-all-module-requires + + requires+provides-reset! + add-provide! + + extract-requires-and-provides + + shift-provides-module-path-index) + +;; ---------------------------------------- + +(struct requires+provides (self ; module-path-index to recognize definitions among requires + require-mpis ; intern table + require-mpis-in-order ; require-phase -> list of module-path-index + requires ; mpi [interned] -> require-phase -> sym -> list-ish of [bulk-]required + provides ; phase -> sym -> binding or protected + phase-to-defined-syms ; phase -> sym -> (or/c 'variable 'transformer) + also-required ; sym -> binding + [can-cross-phase-persistent? #:mutable] + [all-bindings-simple? #:mutable]) ; tracks whether bindings are easily reconstructed + #:authentic) + +;; A `required` represents an identifier required into a module +(struct required (id phase can-be-shadowed? as-transformer?) #:authentic) + +;; A `nominal` supports a reverse mapping of bindings to nominal info +(struct nominal (module provide-phase require-phase sym) #:transparent #:authentic) + +;; A `bulk-required` can be converted into a `required` given the +;; module path, phase, and symbol that are mapped to it +(struct bulk-required (provides ; extract binding info based on the sym + prefix-len ; length of a prefix to remove + s ; combine with the sym to create an identifier + provide-phase-level ; phase of `provide` in immediately providing module + can-be-shadowed?) ; shadowed because, e.g., an initial import + #:authentic) + +(define (make-requires+provides self + #:copy-requires [copy-r+p #f]) + (requires+provides self + ;; require-mpis: + (if copy-r+p + (requires+provides-require-mpis copy-r+p) + (make-module-path-index-intern-table)) + ;; require-mpis-in-order: + (if copy-r+p + (hash-copy (requires+provides-require-mpis-in-order copy-r+p)) + (make-hasheqv)) + (make-hasheq) ; requires + (make-hasheqv) ; provides + (make-hasheqv) ; phase-to-defined-syms + (make-hasheq) ; also-required + #t + #t)) + +(define (requires+provides-reset! r+p) + ;; Don't clear `require-mpis-in-order`, since we want to accumulate + ;; all previously required modules + (hash-clear! (requires+provides-requires r+p)) + (hash-clear! (requires+provides-provides r+p)) + (hash-clear! (requires+provides-phase-to-defined-syms r+p)) + (hash-clear! (requires+provides-also-required r+p))) + +;; ---------------------------------------- + +(define (intern-mpi r+p mpi) + (intern-module-path-index! (requires+provides-require-mpis r+p) mpi)) + +;; ---------------------------------------- + +;; Register that a module is required at a given phase shift, and return a +;; locally interned module path index +(define (add-required-module! r+p mod-name phase-shift is-cross-phase-persistent?) + (define mpi (intern-mpi r+p mod-name)) + (unless (hash-ref (hash-ref (requires+provides-requires r+p) mpi #hasheqv()) phase-shift #f) + ;; Add to list of requires that are kept in order, so that order + ;; is preserved on instantiation + (hash-update! (requires+provides-require-mpis-in-order r+p) + phase-shift + (lambda (l) (cons mpi l)) + null) + ;; Init list of required identifiers: + (hash-set! (hash-ref! (requires+provides-requires r+p) mpi make-hasheqv) + phase-shift + (make-hasheq))) + (unless is-cross-phase-persistent? + (set-requires+provides-can-cross-phase-persistent?! r+p #f)) + mpi) + +;; Register a specific identifier that is required +(define (add-defined-or-required-id! r+p id phase binding + #:can-be-shadowed? [can-be-shadowed? #f] + #:as-transformer? as-transformer?) + ;; Register specific required identifier + (unless (equal? phase (phase+ (module-binding-nominal-phase binding) + (module-binding-nominal-require-phase binding))) + (error "internal error: binding phase does not match nominal info")) + (add-defined-or-required-id-at-nominal! r+p id phase + #:nominal-module (module-binding-nominal-module binding) + #:nominal-require-phase (module-binding-nominal-require-phase binding) + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?)) + + +;; The internals of `add-defined-or-required-id!` that consumes just +;; the needed part of the binding +(define (add-defined-or-required-id-at-nominal! r+p id phase + #:nominal-module nominal-module + #:nominal-require-phase nominal-require-phase + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?) + (define at-mod (hash-ref! (requires+provides-requires r+p) + (intern-mpi r+p nominal-module) + make-hasheqv)) + (define sym-to-reqds (hash-ref! at-mod nominal-require-phase make-hasheq)) + (define sym (syntax-e id)) + ;; Record that the identifier is required + (hash-set! sym-to-reqds sym (cons-ish (required id phase can-be-shadowed? as-transformer?) + (hash-ref sym-to-reqds sym null)))) + +;; Like `add-defined-or-required-id!`, but faster for bindings that +;; all have the same scope, etc.< +;; Return #t if any required id is already defined by a shaodwing definition. +(define (add-bulk-required-ids! r+p s self nominal-module phase-shift provides provide-phase-level + #:prefix bulk-prefix + #:excepts bulk-excepts + #:symbols-accum symbols-accum + #:in orig-s + #:can-be-shadowed? can-be-shadowed? + #:check-and-remove? check-and-remove? + #:accum-update-nominals accum-update-nominals + #:who who) + (define phase (phase+ provide-phase-level phase-shift)) + (define shortcut-table (and check-and-remove? + ((hash-count provides) . > . 64) + (syntax-mapped-names s phase))) + (define mpi (intern-mpi r+p nominal-module)) + (define at-mod (hash-ref! (requires+provides-requires r+p) mpi make-hasheqv)) + (define sym-to-reqds (hash-ref! at-mod phase-shift make-hasheq)) + (define prefix-len (if bulk-prefix (string-length (symbol->string bulk-prefix)) 0)) + (define br (bulk-required provides prefix-len s provide-phase-level can-be-shadowed?)) + (for/or ([(out-sym binding/p) (in-hash provides)] + #:unless (not (symbol-interned? out-sym))) + (when symbols-accum (hash-set! symbols-accum out-sym #t)) + (cond + [(hash-ref bulk-excepts out-sym #f) + #f] + [else + (define sym (cond + [(not bulk-prefix) out-sym] + [else (string->symbol (format "~a~a" bulk-prefix out-sym))])) + (define already-defined? + (cond + [(and check-and-remove? + (or (not shortcut-table) + (hash-ref shortcut-table sym #f))) + (check-not-defined #:check-not-required? #t + #:allow-defined? #t + r+p (datum->syntax s sym s) phase #:in orig-s + #:unless-matches + (lambda () + (provide-binding-to-require-binding binding/p + sym + #:self self + #:mpi mpi + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift)) + #:remove-shadowed!? #t + #:accum-update-nominals accum-update-nominals + #:who who)] + [else #f])) + (unless already-defined? + (hash-set! sym-to-reqds sym (cons-ish br (hash-ref sym-to-reqds sym null)))) + already-defined?]))) + +;; Convert a combination of a symbol and `bulk-required` to a +;; `required` on demand +(define (bulk-required->required br nominal-module phase sym) + (define prefix-len (bulk-required-prefix-len br)) + (define out-sym (if (zero? prefix-len) + sym + (string->symbol (substring (symbol->string sym) prefix-len)))) + (define binding/p (hash-ref (bulk-required-provides br) out-sym)) + (required (datum->syntax (bulk-required-s br) sym) + (phase+ phase (bulk-required-provide-phase-level br)) + (bulk-required-can-be-shadowed? br) + (provided-as-transformer? binding/p))) + +(define (normalize-required r mod-name phase sym) + (if (bulk-required? r) + (bulk-required->required r mod-name phase sym) + r)) + +;; Add bindings of an enclosing module +(define (add-enclosing-module-defined-and-required! r+p + #:enclosing-requires+provides enclosing-r+p + enclosing-mod + phase-shift) + (set-requires+provides-all-bindings-simple?! r+p #f) + (for ([(mod-name at-mod) (in-hash (requires+provides-requires enclosing-r+p))]) + (for* ([(phase at-phase) (in-hash at-mod)] + [(sym reqds) (in-hash at-phase)] + [reqd/maybe-bulk (in-list-ish reqds)]) + (define reqd (normalize-required reqd/maybe-bulk mod-name phase sym)) + (add-defined-or-required-id-at-nominal! r+p + (syntax-shift-phase-level + (syntax-module-path-index-shift + (required-id reqd) + (requires+provides-self enclosing-r+p) + enclosing-mod) + phase-shift) + (phase+ (required-phase reqd) phase-shift) + #:nominal-module enclosing-mod + #:nominal-require-phase phase-shift + #:can-be-shadowed? #t + #:as-transformer? (required-as-transformer? reqd))))) + +;; Removes a required identifier, in anticipation of it being defined. +;; The `check-not-defined` function below is similar, and it also includes +;; an option to remove shadowed bindings. +(define (remove-required-id! r+p id phase #:unless-matches binding) + (define b (resolve+shift id phase #:exactly? #t)) + (when b + (define mpi (intern-mpi r+p (module-binding-nominal-module b))) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (when at-mod + (define nominal-phase (module-binding-nominal-require-phase b)) + (define sym-to-reqds (hash-ref at-mod + nominal-phase + #f)) + (when sym-to-reqds + (define sym (syntax-e id)) + (define l (hash-ref sym-to-reqds sym null)) + (unless (null? l) + (unless (same-binding? b binding) + (hash-set! sym-to-reqds sym (remove-non-matching-requireds l id phase mpi nominal-phase sym)))))))) + +;; Prune a list of `required`s t remove any with a different binding +(define (remove-non-matching-requireds reqds id phase mpi nominal-phase sym) + ;; Ok to produce a list-ish instead of a list, but we don't have `for*/list-ish`: + (for*/list ([r (in-list-ish reqds)] + [r (in-value (normalize-required r mpi nominal-phase sym))] + #:unless (and (eqv? phase (required-phase r)) + (free-identifier=? (required-id r) id phase phase))) + r)) + +;; Check whether an identifier has a binding that is from a non-shadowable +;; require; if something is found but it will be replaced, then record that +;; bindings are not simple. Returns a boolean to dincate whether the binding +;; is defined already, since `allow-defined?` allows the result to be #t. +(define (check-not-defined #:check-not-required? [check-not-required? #f] + #:allow-defined? [allow-defined? #f] + r+p id phase #:in orig-s + #:unless-matches [ok-binding/delayed #f] ; binding or (-> binding) + #:remove-shadowed!? [remove-shadowed!? #f] + #:accum-update-nominals [accum-update-nominals #f] + #:who who) + (define b (resolve+shift id phase #:exactly? #t)) + (cond + [(not b) #f] + [(not (module-binding? b)) + (raise-syntax-error #f "identifier out of context" id)] + [else + (define defined? (and b (eq? (requires+provides-self r+p) + (module-binding-module b)))) + (cond + [(and defined? + ;; In case `#%module-begin` is expanded multiple times, check + ;; that the definition has been seen this particular expansion + (not (hash-ref (hash-ref (requires+provides-phase-to-defined-syms r+p) + phase + #hasheq()) + (module-binding-sym b) + #f))) + ;; Doesn't count as previously defined + #f] + [else + (define define-shadowing-require? (and (not defined?) (not check-not-required?))) + (define mpi (intern-mpi r+p (module-binding-nominal-module b))) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (define ok-binding (and (not define-shadowing-require?) + (if (procedure? ok-binding/delayed) + (ok-binding/delayed) + ok-binding/delayed))) + (define (raise-already-bound defined?) + (raise-syntax-error who + (string-append "identifier already " + (if defined? "defined" "required") + (cond + [(zero-phase? phase) ""] + [(label-phase? phase) " for label"] + [(= 1 phase) " for syntax"] + [else (format " for phase ~a" phase)])) + orig-s + id)) + (cond + [(and (not at-mod) + (not define-shadowing-require?)) + ;; Binding is from an enclosing context; if it's from an + ;; enclosing module, then we've already marked bindings + ;; a non-simple --- otherwise, we don't care + #f] + [(and ok-binding (same-binding? b ok-binding)) + ;; It's the same binding already, so overall binding hasn't + ;; become non-simple + (unless (same-binding-nominals? b ok-binding) + ;; Need to accumulate nominals + (define (update!) + (add-binding! + #:just-for-nominal? #t + id + (module-binding-update ok-binding + #:extra-nominal-bindings + (cons b + (module-binding-extra-nominal-bindings b))) + phase)) + (cond + [accum-update-nominals + ;; We can't reset now, because the caller is preparing for + ;; a bulk bind. Record that we need to merge nominals. + (set-box! accum-update-nominals (cons update! (unbox accum-update-nominals)))] + [else (update!)])) + defined?] + [(and defined? allow-defined?) + ;; A `require` doesn't conflict with a definition, even if we + ;; saw the definition earlier; but make sure there are not multiple + ;; `require`s (any one of which would be shadowed by the definition) + (define also-required (requires+provides-also-required r+p)) + (define prev-b (hash-ref also-required (module-binding-sym b) #f)) + (when (and prev-b (not (same-binding? ok-binding prev-b))) + (raise-already-bound #f)) + (hash-set! also-required (module-binding-sym b) ok-binding) + (set-requires+provides-all-bindings-simple?! r+p #f) + #t] + [else + (define nominal-phase (module-binding-nominal-require-phase b)) + (define sym-to-reqds (hash-ref at-mod nominal-phase #hasheq())) + (define reqds (hash-ref sym-to-reqds (syntax-e id) null)) + (define only-can-can-shadow-require? + (for/fold ([only-can-can-shadow-require? #t]) ([r (in-list-ish reqds)]) + (cond + [(if (bulk-required? r) + (bulk-required-can-be-shadowed? r) + (required-can-be-shadowed? r)) + ;; Shadowing --- ok, but non-simple + (set-requires+provides-all-bindings-simple?! r+p #f) + only-can-can-shadow-require?] + [define-shadowing-require? #f] + [else (raise-already-bound defined?)]))) + (cond + [define-shadowing-require? + ;; Not defined, but defining now (shadowing all requires); + ;; make sure we indicated that the binding is non-simple + (set-requires+provides-all-bindings-simple?! r+p #f) + (unless only-can-can-shadow-require? + ;; Record the `require` binding, if it's non-shadowable, + ;; in case we see another `require` for the same identifier + (hash-set! (requires+provides-also-required r+p) (module-binding-sym b) b))] + [else + (when (and remove-shadowed!? (not (null? reqds))) + ;; Same work as in `remove-required-id!` + (hash-set! sym-to-reqds (syntax-e id) + (remove-non-matching-requireds reqds id phase mpi nominal-phase (syntax-e id))))]) + #f])])])) + +(define (add-defined-syms! r+p syms phase #:as-transformer? [as-transformer? #f]) + (define phase-to-defined-syms (requires+provides-phase-to-defined-syms r+p)) + (define defined-syms (hash-ref phase-to-defined-syms phase #hasheq())) + (define new-defined-syms + (for/fold ([defined-syms defined-syms]) ([sym (in-list syms)]) + (hash-set defined-syms sym (if as-transformer? 'transformer 'variable)))) + (hash-set! phase-to-defined-syms phase new-defined-syms)) + +;; Returns 'variable, 'transformer, or #f +(define (defined-sym-kind r+p sym phase) + (define phase-to-defined-syms (requires+provides-phase-to-defined-syms r+p)) + (define defined-syms (hash-ref phase-to-defined-syms phase #hasheq())) + (hash-ref defined-syms sym #f)) + +;; Get all the bindings imported from a given module +(define (extract-module-requires r+p mod-name phase) + (define mpi (intern-mpi r+p mod-name)) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (and at-mod + (for*/list ([(sym reqds) (in-hash (hash-ref at-mod phase #hasheq()))] + [reqd (in-list-ish reqds)]) + (normalize-required reqd mpi phase sym)))) + +;; Get all the definitions +(define (extract-module-definitions r+p) + (or (extract-module-requires r+p (requires+provides-self r+p) 0) + null)) + +;; Like `extract-module-requires`, but merging modules and phases +(define (extract-all-module-requires r+p + mod-name ; or #f for "all" + phase) ; or 'all for "all" + (define self (requires+provides-self r+p)) + (define requires (requires+provides-requires r+p)) + (let/ec esc + (for*/list ([mod-name (in-list (if mod-name + (list (intern-mpi r+p mod-name)) + (hash-keys requires)))] + #:unless (eq? mod-name self) + [phase-to-requireds (in-value (hash-ref requires mod-name #hasheqv()))] + [phase (in-list (if (eq? phase 'all) + (hash-keys phase-to-requireds) + (list phase)))] + [(sym reqds) (in-hash + (hash-ref phase-to-requireds phase + ;; failure => not required at that phase + (lambda () (esc #f))))] + [reqd (in-list-ish reqds)]) + (normalize-required reqd mod-name phase sym)))) + +;; ---------------------------------------- + +;; Register that a binding is provided as a given symbol; report an +;; error if the provide is inconsistent with an earlier one +(define (add-provide! r+p sym phase binding immed-binding id orig-s + #:as-protected? as-protected? + #:as-transformer? as-transformer?) + (when (and as-protected? + (not (eq? (module-binding-module immed-binding) (requires+provides-self r+p)))) + (raise-syntax-error #f "cannot protect required identifier in re-provide" sym)) + (hash-update! (requires+provides-provides r+p) + phase + (lambda (at-phase) + (define b/p (hash-ref at-phase sym #f)) + (define b (provided-as-binding b/p)) + (cond + [(not b) + ;; Record this binding, but first strip away any `free-identifier=?` + ;; identifier that remains, which means that it doesn't have a binding. + ;; The serializer and deserializer won't be able to handle that, and + ;; it's not relevant to further comparisons. + (define plain-binding (if (binding-free=id binding) + (module-binding-update binding #:free=id #f) + binding)) + (hash-set at-phase sym (if (or as-protected? as-transformer?) + (provided plain-binding as-protected? as-transformer?) + plain-binding))] + [(same-binding? b binding) + at-phase] + [else + (raise-syntax-error #f + "identifier already provided (as a different binding)" + orig-s id)])) + #hasheq())) + +;; ---------------------------------------- + +(define (extract-requires-and-provides r+p old-self new-self) + (define (extract-requires) + ;; Extract from the in-order record, so that instantiation can use the original order + (define phase-to-mpis-in-order (requires+provides-require-mpis-in-order r+p)) + (define phases-in-order (sort (hash-keys phase-to-mpis-in-order) phasesym-set (m 'id))) + #f #f 'path)] + [(prefix) + (check-nested 'phaseless) + (define-match m req '(prefix id:prefix spec)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-prefix (syntax-e (m 'id:prefix))) + #f #f 'path)] + [(all-except) + (check-nested 'phaseless) + (define-match m req '(all-except spec id ...)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-all-except '|| (ids->sym-set (m 'id))) + #f #f 'path)] + [(prefix-all-except) + (check-nested 'phaseless) + (define-match m req '(prefix-all-except id:prefix spec id ...)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-all-except (syntax-e (m 'id:prefix)) (ids->sym-set (m 'id))) + #f #f 'path)] + [(rename) + (check-nested 'phaseless) + (define-match m req '(rename spec id:to id:from)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-rename (m 'id:to) (syntax-e (m 'id:from))) + #f #f 'path)] + [else + (define maybe-mp (syntax->datum req)) + (unless (or (module-path? maybe-mp) + (resolved-module-path? maybe-mp)) + (raise-syntax-error #f "bad require spec" orig-s req)) + (when (or adjust (not (eq? just-meta 'all))) + (set-requires+provides-all-bindings-simple?! requires+provides #f)) + (define mp (if (resolved-module-path? maybe-mp) + (resolved-module-path->module-path maybe-mp) + maybe-mp)) + (define mpi (module-path->mpi mp self + #:declared-submodule-names declared-submodule-names)) + (perform-require! mpi req self + (or req top-req) m-ns + #:phase-shift phase-shift + #:run-phase run-phase + #:just-meta just-meta + #:adjust adjust + #:requires+provides requires+provides + #:run? run? + #:visit? visit? + #:copy-variable-phase-level copy-variable-phase-level + #:copy-variable-as-constant? copy-variable-as-constant? + #:skip-variable-phase-level skip-variable-phase-level + #:initial-require? initial-require? + #:who who) + (set! initial-require? #f)])))) + +(define (ids->sym-set ids) + (for/set ([id (in-list ids)]) + (syntax-e id))) + +;; ---------------------------------------- + +(define (perform-initial-require! mod-path self + in-stx m-ns + requires+provides + #:bind? bind? + #:who who) + (perform-require! (module-path->mpi mod-path self) #f self + in-stx m-ns + #:phase-shift 0 + #:run-phase 0 + #:requires+provides requires+provides + #:can-be-shadowed? #t + #:initial-require? #t + #:bind? bind? + #:who who)) + +;; ---------------------------------------- + +(define (perform-require! mpi orig-s self + in-stx m-ns + #:phase-shift phase-shift + #:run-phase run-phase + #:just-meta [just-meta 'all] + #:adjust [adjust #f] + #:requires+provides [requires+provides #f] + #:visit? [visit? #t] + #:run? [run? #f] + #:can-be-shadowed? [can-be-shadowed? #f] + #:initial-require? [initial-require? #f] + ;; For `namespace-require/copy` and `namespace-require/constant`: + #:copy-variable-phase-level [copy-variable-phase-level #f] + #:copy-variable-as-constant? [copy-variable-as-constant? #f] + #:skip-variable-phase-level [skip-variable-phase-level #f] + #:bind? [bind? #t] + #:who who) + (performance-region + ['expand 'require] + (define module-name (module-path-index-resolve mpi #t)) + (define bind-in-stx (if (adjust-rename? adjust) + (adjust-rename-to-id adjust) + in-stx)) + (define done-syms (and adjust (make-hash))) + (define m (namespace->module m-ns module-name)) + (unless m (raise-unknown-module-error 'require module-name)) + (define interned-mpi + (if requires+provides + (add-required-module! requires+provides mpi phase-shift + (module-cross-phase-persistent? m)) + mpi)) + (when visit? + (namespace-module-visit! m-ns interned-mpi phase-shift #:visit-phase run-phase)) + (when run? + (namespace-module-instantiate! m-ns interned-mpi phase-shift #:run-phase run-phase)) + (when (not (or visit? run?)) + ;; make the module available: + (namespace-module-make-available! m-ns interned-mpi phase-shift #:visit-phase run-phase)) + (define can-bulk-bind? (and (or (not adjust) + (adjust-prefix? adjust) + (adjust-all-except? adjust)) + (not skip-variable-phase-level))) + (define bulk-prefix (cond + [(adjust-prefix? adjust) (adjust-prefix-sym adjust)] + [(adjust-all-except? adjust) (adjust-all-except-prefix-sym adjust)] + [else #f])) + (define bulk-excepts (cond + [(adjust-all-except? adjust) (adjust-all-except-syms adjust)] + [else #hasheq()])) + (define update-nominals-box (and can-bulk-bind? (box null))) + (bind-all-provides! + m + bind-in-stx phase-shift m-ns interned-mpi module-name + #:in orig-s + #:defines-mpi (and requires+provides (requires+provides-self requires+provides)) + #:only (cond + [(adjust-only? adjust) (set->list (adjust-only-syms adjust))] + [(adjust-rename? adjust) (list (adjust-rename-from-sym adjust))] + [else #f]) + #:just-meta just-meta + #:bind? bind? + #:can-bulk? can-bulk-bind? + #:bulk-prefix bulk-prefix + #:bulk-excepts bulk-excepts + #:bulk-callback (and + requires+provides + can-bulk-bind? + (lambda (provides provide-phase-level) + ;; Returns #t if any binding is already shadowed by a definition: + (add-bulk-required-ids! requires+provides + bind-in-stx + (module-self m) mpi phase-shift + provides + provide-phase-level + #:prefix bulk-prefix + #:excepts bulk-excepts + #:symbols-accum (and (positive? (hash-count bulk-excepts)) + done-syms) + #:can-be-shadowed? can-be-shadowed? + #:check-and-remove? (not initial-require?) + #:in orig-s + #:accum-update-nominals update-nominals-box + #:who who))) + #:filter (and + (or (not can-bulk-bind?) + copy-variable-phase-level) + (lambda (binding as-transformer?) + (define sym (module-binding-nominal-sym binding)) + (define provide-phase (module-binding-nominal-phase binding)) + (define adjusted-sym + (cond + [(not (symbol-interned? sym)) + ;; Don't `require` non-interned symbols + #f] + [(and skip-variable-phase-level + (not as-transformer?) + (equal? provide-phase skip-variable-phase-level)) + #f] + [(not adjust) sym] + [(adjust-only? adjust) + (and (set-member? (adjust-only-syms adjust) sym) + (hash-set! done-syms sym #t) + sym)] + [(adjust-prefix? adjust) + (string->symbol + (format "~a~a" (adjust-prefix-sym adjust) sym))] + [(adjust-all-except? adjust) + (and (not (and (set-member? (adjust-all-except-syms adjust) sym) + (hash-set! done-syms sym #t))) + (string->symbol + (format "~a~a" (adjust-all-except-prefix-sym adjust) sym)))] + [(adjust-rename? adjust) + (and (eq? sym (adjust-rename-from-sym adjust)) + (hash-set! done-syms sym #t) + (adjust-rename-to-id adjust))])) + (define skip-bind? + (cond + [(and adjusted-sym requires+provides) + (define s (datum->syntax bind-in-stx adjusted-sym)) + (define bind-phase (phase+ phase-shift provide-phase)) + (define skip-bind? + (cond + [initial-require? #f] + [else + (check-not-defined #:check-not-required? #t + #:allow-defined? #t ; `define` shadows `require` + requires+provides + s bind-phase + #:unless-matches binding + #:in orig-s + #:remove-shadowed!? #t + #:who who)])) + (unless skip-bind? + (add-defined-or-required-id! requires+provides + s bind-phase binding + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?)) + skip-bind?] + [else #f])) + (when (and copy-variable-phase-level + (not as-transformer?) + (equal? provide-phase copy-variable-phase-level)) + (copy-namespace-value m-ns sym binding copy-variable-phase-level phase-shift + copy-variable-as-constant?)) + (and (not skip-bind?) adjusted-sym)))) + ;; Now that a bulk binding is in place, update to merge nominals: + (when update-nominals-box + (for ([update! (in-list (unbox update-nominals-box))]) + (update!))) + ;; check that we covered all expected ids: + (define need-syms (cond + [(adjust-only? adjust) + (adjust-only-syms adjust)] + [(adjust-all-except? adjust) + (adjust-all-except-syms adjust)] + [(adjust-rename? adjust) + (set (adjust-rename-from-sym adjust))] + [else #f])) + (when (and need-syms + (not (= (set-count need-syms) (hash-count done-syms)))) + (for ([sym (in-set need-syms)]) + (unless (hash-ref done-syms sym #f) + (raise-syntax-error who "not in nested spec" orig-s sym)))))) + +;; ---------------------------------------- + +(define (bind-all-provides! m in-stx phase-shift ns mpi module-name + #:in orig-s + #:defines-mpi defines-mpi + #:only only-syms + #:just-meta just-meta + #:bind? bind? + #:can-bulk? can-bulk? + #:bulk-prefix bulk-prefix + #:bulk-excepts bulk-excepts + #:filter filter + #:bulk-callback bulk-callback) + (define self (module-self m)) + (for ([(provide-phase-level provides) (in-hash (module-provides m))] + #:when (or (eq? just-meta 'all) + (eqv? just-meta provide-phase-level))) + (define phase (phase+ phase-shift provide-phase-level)) + (define need-except? + (and bulk-callback + (bulk-callback provides provide-phase-level))) + (when bind? + (when filter + (for ([sym (in-list (or only-syms (hash-keys provides)))]) + (define binding/p (hash-ref provides sym #f)) + (when binding/p + (define b (provide-binding-to-require-binding binding/p sym + #:self self + #:mpi mpi + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift)) + (let-values ([(sym) (filter b (provided-as-transformer? binding/p))]) + (when (and sym + (not can-bulk?)) ;; bulk binding added later + ;; Add a non-bulk binding, since `filter` has checked/adjusted it + (add-binding! (datum->syntax in-stx sym) b phase)))))) + ;; Add bulk binding after all filtering + (when can-bulk? + (define bulk-binding-registry (namespace-bulk-binding-registry ns)) + (add-bulk-binding! in-stx + (bulk-binding (or (and (not bulk-prefix) + (zero? (hash-count bulk-excepts)) + provides) + ;; During expansion, the submodules aren't be registered in + ;; the bulk-binding registry for use by other submodules, + ;; so do the work to compute bulk provides now if the module + ;; isn't registered + (and (not (registered-bulk-provide? bulk-binding-registry + module-name)) + (bulk-provides-add-prefix-remove-exceptions + provides bulk-prefix bulk-excepts))) + bulk-prefix bulk-excepts + self mpi provide-phase-level phase-shift + bulk-binding-registry) + phase + #:in orig-s + #:shadow-except (and need-except? defines-mpi)))))) + +;; ---------------------------------------- + +;; In certain lifting cases, we'd like to just throw a `for-syntax` +;; around a `require` specification, but that's not supported by our +;; `#%require` grammar. Instead, we have to adjust whatever phase +;; shift is present. +(define (require-spec-shift-for-syntax req) + (define (rebuild-req req new-req) + (datum->syntax req new-req req req)) + (define ((loop shifted?) req) + (define fm (and (pair? (syntax-e req)) + (identifier? (car (syntax-e req))) + (syntax-e (car (syntax-e req))))) + (case fm + [(for-meta) + (define-match m req '(for-meta phase-level spec ...)) + (define p (syntax-e (m 'phase-level))) + (unless (phase? p) + (raise-syntax-error #f "bad phase" req)) + (rebuild-req req `(,(m 'for-meta) ,(phase+ p 1) ,@(map (loop #t) (m 'spec))))] + [(for-syntax) + (define-match m req '(for-syntax spec ...)) + (rebuild-req req `(for-meta 2 ,@(map (loop #t) (m 'spec))))] + [(for-template) + (define-match m req '(for-template spec ...)) + (rebuild-req req `(for-meta 0 ,@(map (loop #t) (m 'spec))))] + [(for-label) + (define-match m req '(for-label spec ...)) + (rebuild-req req `(,(m 'for-label) ,@(map (loop #t) (m 'spec))))] + [(just-meta) + (define-match m req '(just-meta phase-level spec ...)) + (rebuild-req req `(,(m 'just-meta) ,(m 'phase-level) ,@(map (loop #f) (m 'spec))))] + [else + (if shifted? + req + (datum->syntax #f `(for-syntax ,req)))])) + ((loop #f) req)) + +;; ---------------------------------------- + +(define (copy-namespace-value m-ns adjusted-sym binding phase-level phase-shift as-constant?) + (define i-ns (namespace->module-namespace m-ns + (module-path-index-resolve (module-binding-module binding)) + (phase- (module-binding-phase binding) phase-level) + #:complain-on-failure? #t)) + (define val (namespace-get-variable i-ns (module-binding-phase binding) (module-binding-sym binding) + (lambda () (error 'namespace-require/copy + (format + (string-append "namespace mismatch;\n" + " variable not found\n" + " module: ~a\n" + " variable name: ~s\n" + " phase level: ~s") + (module-binding-module binding) + (module-binding-sym binding) + (module-binding-phase binding)))))) + (namespace-set-variable! m-ns (phase+ phase-shift phase-level) adjusted-sym val as-constant?)) diff -Nru racket-6.12+ppa1/src/expander/expand/root-expand-context.rkt racket-7.0+ppa1/src/expander/expand/root-expand-context.rkt --- racket-6.12+ppa1/src/expander/expand/root-expand-context.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/root-expand-context.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,143 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/phase.rkt" + "lift-key.rkt") + +(provide (struct*-out root-expand-context) + make-root-expand-context + + apply-post-expansion + post-expansion-scope + + root-expand-context-encode-for-module + root-expand-context-decode-for-module) + +;; A `root-expand-context` is a subset of `expand-context` that is +;; preserved from a module's expansion for later use in a namespace +;; generated by `module->namespace` --- or preserved across different +;; expansions at the top level +(struct* root-expand-context + (self-mpi ; MPI for the enclosing module during compilation + module-scopes ; list of scopes for enclosing module or top level; includes next two fields + * post-expansion ; #f, a shifted multiscope to push to every expansion (often module's inside edge), + ; a pair of a sms and a list of shifts, or a procedure (when not at the actual + ; root, because an actual root needs to be marshalable) + top-level-bind-scope ; #f or a scope to constrain expansion bindings; see "expand-bind-top.rkt" + all-scopes-stx ; scopes like the initial import, which correspond to original forms + * use-site-scopes ; #f or boxed list: scopes that should be pruned from binders + defined-syms ; phase -> sym -> id; symbols picked for bindings + * frame-id ; #f or a gensym to identify a binding frame; 'all matches any for use-site scopes + counter ; box of an integer; used for generating names deterministically + lift-key ; identifies (via `syntax-local-lift-context`) a target for lifts + )) ; after adding a field, update `copy-module-context` in "context.rkt" + +(define (make-root-expand-context #:self-mpi self-mpi + #:initial-scopes [initial-scopes null] + #:outside-scope [outside-scope top-level-common-scope] + #:post-expansion-scope [post-expansion-scope (new-multi-scope 'top-level)] + #:all-scopes-stx [all-scopes-stx #f]) + (define module-scopes (list* post-expansion-scope + outside-scope + initial-scopes)) + (root-expand-context self-mpi + module-scopes + post-expansion-scope ; post-expansion + (new-scope 'module) ; top-level-bind-scope + (or all-scopes-stx + (add-scopes empty-syntax module-scopes)) + (box null) ; use-site-scopes + (make-hasheqv) ; defined-syms + (string->uninterned-symbol "root-frame") ; frame-id + (box 0) ; counter + (generate-lift-key))) + +;; ---------------------------------------- + +(define (apply-post-expansion pe s) + (cond + [(not pe) s] + [(shifted-multi-scope? pe) (push-scope s pe)] + [(pair? pe) (syntax-add-shifts (push-scope s (car pe)) (cdr pe))] + [else (pe s)])) + +(define (post-expansion-scope pe) + (cond + [(shifted-multi-scope? pe) pe] + [(pair? pe) (car pe)] + [else (error 'post-expansion-scope "internal error: cannot extract scope from ~s" pe)])) + +;; ---------------------------------------- + +;; Encode information in a syntax object that can be serialized and deserialized +(define (root-expand-context-encode-for-module ctx orig-self new-self) + (datum->syntax + #f + (vector (add-scopes empty-syntax (root-expand-context-module-scopes ctx)) + (apply-post-expansion (root-expand-context-post-expansion ctx) empty-syntax) + (syntax-module-path-index-shift (root-expand-context-all-scopes-stx ctx) orig-self new-self) + (add-scopes empty-syntax (unbox (root-expand-context-use-site-scopes ctx))) + (for/hasheqv ([(phase ht) (in-hash (root-expand-context-defined-syms ctx))]) ; make immutable + (values phase ht)) + (root-expand-context-frame-id ctx) + (unbox (root-expand-context-counter ctx))))) + +;; Decode the value produced by `root-expand-context-encode-for-module` +(define (root-expand-context-decode-for-module vec-s self) + (define vec (and (syntax? vec-s) (syntax-e vec-s))) + (unless (and (vector? vec) + (= (vector-length vec) 7) + (syntax? (vector-ref vec 0)) + (syntax-with-one-scope? (vector-ref vec 1)) + (syntax? (vector-ref vec 2)) + (syntax? (vector-ref vec 3)) + (defined-syms-hash? (syntax-e (vector-ref vec 4))) + (symbol? (syntax-e (vector-ref vec 5))) + (exact-nonnegative-integer? (syntax-e (vector-ref vec 6)))) + (error 'root-expand-context-decode-for-module + "bad encoding: ~s" + vec-s)) + (root-expand-context self + (extract-scope-list (vector-ref vec 0)) ; module-scopes + (cons (extract-scope (vector-ref vec 1)) + (extract-shifts (vector-ref vec 1))) ; post-expansion + (new-scope 'module) ; top-level-bind-scope + (vector-ref vec 2) ; all-scopes-stx + (box (extract-scope-list (vector-ref vec 3))) ; use-site-scopes + (unpack-defined-syms (vector-ref vec 4)) ; defined-syms + (syntax-e (vector-ref vec 5)) ; frame-id + (box (syntax-e (vector-ref vec 6))) ; counter + (generate-lift-key))) + +(define (defined-syms-hash? v) + (and (for/and ([(phase ht-s) (in-hash v)]) + (and (phase? phase) + (hash? (syntax-e ht-s)) + (for/and ([(sym id) (in-hash (syntax-e ht-s))]) + (and (symbol? sym) + (identifier? id))))))) + +(define (extract-scope-list stx) + (map generalize-scope (set->list (syntax-scope-set stx 0)))) + +(define (syntax-with-one-scope? stx) + (and (syntax? stx) + (= 1 (set-count (syntax-scope-set stx 0))))) + +(define (extract-scope stx) + (define s (syntax-scope-set stx 0)) + (generalize-scope (set-first s))) + +(define (extract-shifts stx) + (syntax-mpi-shifts stx)) + +(define (unpack-defined-syms v) + (hash-copy ; make mutable + (for/hasheqv ([(phase ht-s) (in-hash (syntax-e v))]) + (values phase + (hash-copy ; make mutable + (for/hash ([(sym id) (in-hash (syntax-e ht-s))]) + (values sym id))))))) diff -Nru racket-6.12+ppa1/src/expander/expand/save-and-restore.rkt racket-7.0+ppa1/src/expander/expand/save-and-restore.rkt --- racket-6.12+ppa1/src/expander/expand/save-and-restore.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/save-and-restore.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,18 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide with-save-and-restore) + +(define-syntax (with-save-and-restore stx) + (syntax-case stx () + [(_ ([id init-val] ...) body0 body ...) + (with-syntax ([(old-id ...) (generate-temporaries #'(id ...))] + [(new-id ...) (generate-temporaries #'(id ...))]) + #'(let ([old-id id] ... + [new-id init-val] ...) + (dynamic-wind + (lambda () (set! id new-id) ...) + (lambda () body0 body ...) + (lambda () (set! id old-id) ...))))])) + + diff -Nru racket-6.12+ppa1/src/expander/expand/set-bang-trans.rkt racket-7.0+ppa1/src/expander/expand/set-bang-trans.rkt --- racket-6.12+ppa1/src/expander/expand/set-bang-trans.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/set-bang-trans.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +#lang racket/base + +(provide set!-transformer? + prop:set!-transformer + make-set!-transformer + set!-transformer-procedure) + +(define-values (prop:set!-transformer set!-transformer? set!-transformer-value) + (make-struct-type-property 'set!-transformer + (lambda (v info) + (unless (or (and (procedure? v) + (or (procedure-arity-includes? v 1) + (procedure-arity-includes? v 2))) + (exact-nonnegative-integer? v)) + (raise-argument-error + 'guard-for-prop:set!-transformer + (string-append "(or/c (procedure-arity-includes? proc 1)\n" + " (procedure-arity-includes? proc 2)\n" + " exact-nonnegative-integer?)") + v)) + (when (exact-nonnegative-integer? v) + (unless (v . <= . (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:set!-transformer + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (member v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:set!-transformer + "field index not declared immutable" + "field index" v))) + (define ref (list-ref info 3)) + (cond + [(integer? v) (lambda (t) + (define p (ref t v)) + (if (and (procedure? p) + (procedure-arity-includes? p 1)) + p + (lambda (s) (error "bad syntax:" s))))] + [else (lambda (t) v)])))) + +(define make-set!-transformer + (let () + (struct set!-transformer (proc) + #:property prop:set!-transformer 0) + (lambda (proc) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 1)) + (raise-argument-error 'make-set!-transformer + "(procedure-arity-includes/c 1)" + proc)) + (set!-transformer proc)))) + +(define (set!-transformer-procedure t) + (define v ((set!-transformer-value t) t)) + (if (procedure-arity-includes? v 1) + v + (lambda (s) (v t s)))) diff -Nru racket-6.12+ppa1/src/expander/expand/stop-ids.rkt racket-7.0+ppa1/src/expander/expand/stop-ids.rkt --- racket-6.12+ppa1/src/expander/expand/stop-ids.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/stop-ids.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../namespace/core.rkt") + +(provide stop-ids->all-stop-ids + module-expand-stop-ids) + +;; ---------------------------------------- + +(define (stop-ids->all-stop-ids stop-ids phase) + (cond + [(null? stop-ids) stop-ids] + [else + (define p-core-stx (syntax-shift-phase-level core-stx phase)) + (cond + [(and (= 1 (length stop-ids)) + (free-identifier=? (car stop-ids) + (datum->syntax p-core-stx 'module*) + phase + phase)) + stop-ids] + [else (append stop-ids + (for/list ([sym (in-list auto-stop-syms)]) + (datum->syntax p-core-stx sym)))])])) + +(define auto-stop-syms '(begin quote set! lambda case-lambda let-values letrec-values + if begin0 with-continuation-mark letrec-syntaxes+values + #%app #%expression #%top #%variable-reference)) + +;; ---------------------------------------- + +(define (module-expand-stop-ids phase) + (define p-core-stx (syntax-shift-phase-level core-stx phase)) + (for/list ([sym (in-list module-stop-syms)]) + (datum->syntax p-core-stx sym))) + +(define module-stop-syms (append auto-stop-syms + '(define-values define-syntaxes begin-for-syntax + #%require #%provide module module* #%declare + #%stratified-body))) diff -Nru racket-6.12+ppa1/src/expander/expand/syntax-id-error.rkt racket-7.0+ppa1/src/expander/expand/syntax-id-error.rkt --- racket-6.12+ppa1/src/expander/expand/syntax-id-error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/syntax-id-error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,107 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/error.rkt" + "context.rkt" + "../syntax/debug.rkt") + +(provide raise-ambiguous-error + syntax-debug-info-string) + +(define (raise-ambiguous-error id ctx) + (raise-syntax-error #f + "identifier's binding is ambiguous" + id #f null + (syntax-debug-info-string id ctx))) + +;; ---------------------------------------- + +(define (syntax-debug-info-string s ctx) + (define info (syntax-debug-info s (expand-context-phase ctx) #f)) + (cond + [(not (or (pair? (hash-ref info 'bindings null)) + (for*/or ([fb-info (in-list (hash-ref info 'fallbacks null))]) + (pair? (hash-ref fb-info 'bindings null))))) + ;; Don't show context if there's no binding to compare it to + ""] + [else + (define relevant-scope-sets + (let loop ([info info] [layer 0]) + (apply + append + (cons (hash-ref info 'context) + (for/list ([b (in-list (hash-ref info 'bindings null))]) + (hash-ref b 'context))) + (let ([fallbacks (hash-ref info 'fallbacks null)]) + (for/list ([fallback (in-list fallbacks)] + [layer (in-naturals (add1 layer))]) + (loop fallback layer)))))) + (define common-scopes + (if (null? relevant-scope-sets) + (set) + (for/fold ([s (list->set (car relevant-scope-sets))]) ([l (in-list relevant-scope-sets)]) + (set-intersect s (list->set l))))) + (string-append + (let loop ([info info] [layer 0]) + (string-append + "\n context" (layer->string layer) "...:" + (describe-context (hash-ref info 'context) common-scopes) + (apply string-append + (for/list ([b (in-list (sort (hash-ref info 'bindings null) + ;; Order matches before non-matches: + (lambda (a b) + (and (hash-ref a 'match? #f) + (not (hash-ref b 'match? #f))))))]) + (string-append + "\n " (if (hash-ref b 'match? #f) "matching" "other") " binding" (layer->string layer) "...:" + "\n " (if (hash-ref b 'local #f) + "local" + (format "~a" (hash-ref b 'module #f))) + (describe-context (hash-ref b 'context) common-scopes)))) + (let ([fallbacks (hash-ref info 'fallbacks null)]) + (apply + string-append + (for/list ([fallback (in-list fallbacks)] + [layer (in-naturals (add1 layer))]) + (loop fallback layer)))))) + (if (set-empty? common-scopes) + "" + (string-append + "\n common scopes...:" + ;; Get scopes from the original context to keep them in the right order + (describe-context (for/list ([s (in-list (hash-ref info 'context))] + #:when (set-member? common-scopes s)) + s) + (set)))))])) + +(define (describe-context scopes common-scopes) + (define strs + (let loop ([strs null] [scopes (if (set-empty? common-scopes) + scopes + (append + (for/list ([s (in-list scopes)] + #:when (not (set-member? common-scopes s))) + s) + (list "[common scopes]")))]) + (cond + [(null? scopes) (reverse strs)] + [else + (define str (format " ~a" (car scopes))) + (if (and (pair? strs) + ((+ (string-length str) (string-length (car strs))) . < . 72)) + (loop (cons (string-append (car strs) str) + (cdr strs)) + (cdr scopes)) + (loop (cons str strs) + (cdr scopes)))]))) + (cond + [(null? strs) "\n [empty]"] + [else + (apply string-append (for/list ([str (in-list strs)]) + (string-append "\n " str)))])) + +(define (layer->string layer) + (if (zero? layer) + "" + (format " at layer ~a" layer))) diff -Nru racket-6.12+ppa1/src/expander/expand/syntax-implicit-error.rkt racket-7.0+ppa1/src/expander/expand/syntax-implicit-error.rkt --- racket-6.12+ppa1/src/expander/expand/syntax-implicit-error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/syntax-implicit-error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base +(require "../syntax/error.rkt" + "../syntax/scope.rkt" + "context.rkt" + "syntax-id-error.rkt") + +(provide raise-syntax-implicit-error) + +(define (raise-syntax-implicit-error s sym trigger-id ctx) + (define phase (expand-context-phase ctx)) + (define what + (case sym + [(#%app) "function application"] + [(#%datum) "literal data"] + [(#%top) + (if (expand-context-allow-unbound? ctx) + "reference to a top-level identifier" + "reference to an unbound identifier")])) + (define unbound? (and trigger-id (not (resolve trigger-id phase)))) + (define unbound-form (and unbound? + (not (eq? (syntax-e s) (syntax-e trigger-id))) + s)) + (raise-syntax-error #f + (format (if unbound? + "unbound identifier;\n also, no ~a syntax transformer is bound~a" + (string-append what " is not allowed;\n no ~a syntax transformer is bound~a")) + sym + (case phase + [(0) ""] + [(1) " in the transformer phase"] + [else (format " at phase ~a" phase)])) + (and unbound? + (or unbound-form + trigger-id)) + (if unbound? + (and unbound-form trigger-id) + s) + null + (if unbound? (syntax-debug-info-string trigger-id ctx) ""))) diff -Nru racket-6.12+ppa1/src/expander/expand/syntax-local.rkt racket-7.0+ppa1/src/expander/expand/syntax-local.rkt --- racket-6.12+ppa1/src/expander/expand/syntax-local.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/syntax-local.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,438 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/taint.rkt" + "env.rkt" + "context.rkt" + "main.rkt" + "../namespace/core.rkt" + "use-site.rkt" + "rename-trans.rkt" + "lift-context.rkt" + "require.rkt" + "require+provide.rkt" + "protect.rkt" + "log.rkt" + "module-path.rkt" + "definition-context.rkt" + "../common/module-path.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../common/contract.rkt") + +(provide syntax-transforming? + syntax-transforming-with-lifts? + syntax-transforming-module-expression? + syntax-local-transforming-module-provides? + + syntax-local-context + syntax-local-introduce + syntax-local-identifier-as-binding + syntax-local-phase-level + syntax-local-name + + make-syntax-introducer + make-interned-syntax-introducer + make-syntax-delta-introducer + syntax-local-make-delta-introducer + + syntax-local-value + syntax-local-value/immediate + + syntax-local-lift-expression + syntax-local-lift-values-expression + syntax-local-lift-context + + syntax-local-lift-module + + syntax-local-lift-require + syntax-local-lift-provide + syntax-local-lift-module-end-declaration + + syntax-local-module-defined-identifiers + syntax-local-module-required-identifiers + syntax-local-module-exports + syntax-local-submodules + + syntax-local-get-shadower) + +;; ---------------------------------------- + +(define (syntax-transforming?) + (and (get-current-expand-context #:fail-ok? #t) #t)) + +(define (syntax-transforming-with-lifts?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-lifts ctx) + #t)) + +(define (syntax-transforming-module-expression?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-to-module-lifts ctx) + #t)) + +(define (syntax-local-transforming-module-provides?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-requires+provides ctx) + #t)) + +;; ---------------------------------------- + +(define (syntax-local-context) + (define ctx (get-current-expand-context 'syntax-local-context)) + (expand-context-context ctx)) + +(define/who (syntax-local-introduce s) + (check who syntax? s) + (define ctx (get-current-expand-context 'syntax-local-introduce)) + (flip-introduction-and-use-scopes s ctx)) + +(define/who (syntax-local-identifier-as-binding id) + (check who identifier? id) + (define ctx (get-current-expand-context 'syntax-local-identifier-as-binding)) + (remove-use-site-scopes id ctx)) + +(define (syntax-local-phase-level) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (if ctx + (expand-context-phase ctx) + 0)) + +(define/who (syntax-local-name) + (define ctx (get-current-expand-context who)) + (define id (expand-context-name ctx)) + (and id + ;; Strip lexical context, but keep source-location information + (datum->syntax #f (syntax-e id) id))) + +;; ---------------------------------------- + +(define (make-syntax-introducer [as-use-site? #f]) + (do-make-syntax-introducer (new-scope (if as-use-site? 'use-site 'macro)))) + +(define/who (make-interned-syntax-introducer sym-key) + (check who symbol? sym-key) + (do-make-syntax-introducer (make-interned-scope sym-key))) + +(define (do-make-syntax-introducer sc) + (lambda (s [mode 'flip]) + (check 'syntax-introducer syntax? s) + (case mode + [(add) (add-scope s sc)] + [(remove) (remove-scope s sc)] + [(flip) (flip-scope s sc)] + [else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)]))) + +(define/who (make-syntax-delta-introducer ext-s base-s [phase (syntax-local-phase-level)]) + (check who syntax? ext-s) + (check who syntax? #:or-false base-s) + (check who phase? #:contract phase?-string phase) + (define ext-scs (syntax-scope-set ext-s phase)) + (define base-scs (syntax-scope-set (or base-s empty-syntax) phase)) + (define use-base-scs (if (subset? base-scs ext-scs) + base-scs + (or (and (identifier? base-s) + (resolve base-s phase #:get-scopes? #t)) + (seteq)))) + (define delta-scs (set->list (set-subtract ext-scs use-base-scs))) + (define maybe-taint (if (syntax-clean? ext-s) values syntax-taint)) + (lambda (s [mode 'add]) + (maybe-taint + (case mode + [(add) (add-scopes s delta-scs)] + [(remove) (remove-scopes s delta-scs)] + [(flip) (flip-scopes s delta-scs)] + [else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))) + +(define/who (syntax-local-make-delta-introducer id-stx) + (check who identifier? id-stx) + (raise + (exn:fail:unsupported "syntax-local-make-delta-introducer: not supported anymore" + (current-continuation-marks)))) + +;; ---------------------------------------- + +(define (do-syntax-local-value who id intdefs failure-thunk + #:immediate? immediate?) + (check who identifier? id) + (check who #:or-false (procedure-arity-includes/c 0) failure-thunk) + (check who intdefs-or-false? #:contract intdefs-or-false?-string intdefs) + (define current-ctx (get-current-expand-context who)) + (define ctx (if intdefs + (struct*-copy expand-context current-ctx + [env (add-intdef-bindings (expand-context-env current-ctx) + intdefs)]) + current-ctx)) + (log-expand ctx 'local-value id) + (define phase (expand-context-phase ctx)) + (let loop ([id (flip-introduction-scopes id ctx)]) + (define b (if immediate? + (resolve+shift id phase #:immediate? #t) + (resolve+shift/extra-inspector id phase (expand-context-namespace ctx)))) + (log-expand ctx 'resolve id) + (cond + [(not b) + (log-expand ctx 'local-value-result #f) + (if failure-thunk + (failure-thunk) + (error who "unbound identifier: ~v" id))] + [else + (define-values (v primitive? insp protected?) + (lookup b ctx id #:out-of-context-as-variable? #t)) + (cond + [(or (variable? v) (core-form? v)) + (log-expand ctx 'local-value-result #f) + (if failure-thunk + (failure-thunk) + (error who "identifier is not bound to syntax: ~v" id))] + [else + (log-expand* ctx #:unless (and (rename-transformer? v) (not immediate?)) + ['local-value-result #t]) + (cond + [(rename-transformer? v) + (if immediate? + (values v (rename-transformer-target v)) + (loop (rename-transformer-target v)))] + [immediate? (values v #f)] + [else v])])]))) + +(define (syntax-local-value id [failure-thunk #f] [intdef #f]) + (do-syntax-local-value 'syntax-local-value #:immediate? #f id intdef failure-thunk)) + +(define (syntax-local-value/immediate id [failure-thunk #f] [intdef #f]) + (do-syntax-local-value 'syntax-local-value/immediate #:immediate? #t id intdef failure-thunk)) + +;; ---------------------------------------- + +(define (do-lift-values-expression who n s) + (check who syntax? s) + (check who exact-nonnegative-integer? n) + (define ctx (get-current-expand-context who)) + (define lifts (expand-context-lifts ctx)) + (unless lifts (raise-arguments-error who "no lift target")) + (define counter (root-expand-context-counter ctx)) + (define ids (for/list ([i (in-range n)]) + (set-box! counter (add1 (unbox counter))) + (define name (string->unreadable-symbol (format "lifted/~a" (unbox counter)))) + (add-scope (datum->syntax #f name) (new-scope 'macro)))) + (log-expand ctx 'lift-expr ids s) + (map (lambda (id) (flip-introduction-scopes id ctx)) + ;; returns converted ids: + (add-lifted! lifts + ids + (flip-introduction-scopes s ctx) + (expand-context-phase ctx)))) + +(define/who (syntax-local-lift-expression s) + (car (do-lift-values-expression who 1 s))) + +(define/who (syntax-local-lift-values-expression n s) + (do-lift-values-expression who n s)) + +(define/who (syntax-local-lift-context) + (define ctx (get-current-expand-context who)) + (root-expand-context-lift-key ctx)) + +;; ---------------------------------------- + +(define/who (syntax-local-lift-module s) + (check who syntax? s) + (define ctx (get-current-expand-context who)) + (define phase (expand-context-phase ctx)) + (case (core-form-sym s phase) + [(module module*) + (define lifts (expand-context-module-lifts ctx)) + (unless lifts + (raise-arguments-error who + "not currently transforming within a module declaration or top level" + "form to lift" s)) + (add-lifted-module! lifts (flip-introduction-scopes s ctx) phase)] + [else + (raise-arguments-error who "not a module form" + "given form" s)]) + (log-expand ctx 'lift-statement s)) + +;; ---------------------------------------- + +(define (do-local-lift-to-module who s + #:no-target-msg no-target-msg + #:intro? [intro? #t] + #:more-checks [more-checks void] + #:get-lift-ctx get-lift-ctx + #:add-lifted! add-lifted! + #:get-wrt-phase get-wrt-phase + #:pre-wrap [pre-wrap (lambda (s phase lift-ctx) s)] + #:shift-wrap [shift-wrap (lambda (s phase lift-ctx) s)] + #:post-wrap [post-wrap (lambda (s phase lift-ctx) s)]) + (check who syntax? s) + (more-checks) + (define ctx (get-current-expand-context who)) + (define lift-ctx (get-lift-ctx ctx)) + (unless lift-ctx (raise-arguments-error who no-target-msg + "form to lift" s)) + (define phase (expand-context-phase ctx)) ; we're currently at this phase + (define wrt-phase (get-wrt-phase lift-ctx)) ; lift context is at this phase + (define added-s (if intro? (flip-introduction-scopes s ctx) s)) + (define pre-s (pre-wrap added-s phase lift-ctx)) ; add pre-wrap at current phase + (define shift-s (for/fold ([s pre-s]) ([phase (in-range phase wrt-phase -1)]) ; shift from lift-context phase + (shift-wrap s (sub1 phase) lift-ctx))) + (define post-s (post-wrap shift-s wrt-phase lift-ctx)) ; post-wrap at lift-context phase + (add-lifted! lift-ctx post-s wrt-phase) ; record lift for the target phase + (values ctx post-s)) + +(define/who (syntax-local-lift-require s use-s) + (define sc (new-scope 'lifted-require)) + (define-values (ctx added-s) + (do-local-lift-to-module who + (datum->syntax #f s) + #:no-target-msg "could not find target context" + #:intro? #f + #:more-checks + (lambda () + (check who syntax? use-s)) + #:get-lift-ctx expand-context-require-lifts + #:get-wrt-phase require-lift-context-wrt-phase + #:add-lifted! add-lifted-require! + #:shift-wrap + (lambda (s phase require-lift-ctx) + (require-spec-shift-for-syntax s)) + #:post-wrap + (lambda (s phase require-lift-ctx) + (wrap-form '#%require (add-scope s sc) phase)))) + (namespace-visit-available-modules! (expand-context-namespace ctx) + (expand-context-phase ctx)) + (define result-s (add-scope use-s sc)) + (log-expand ctx 'lift-require added-s use-s result-s) + result-s) + +(define/who (syntax-local-lift-provide s) + (define-values (ctx result-s) + (do-local-lift-to-module who + s + #:no-target-msg "not expanding in a module run-time body" + #:get-lift-ctx expand-context-to-module-lifts + #:get-wrt-phase to-module-lift-context-wrt-phase + #:add-lifted! add-lifted-to-module-provide! + #:shift-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form 'for-syntax s #f)) + #:post-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form '#%provide s phase)))) + (log-expand ctx 'lift-provide result-s)) + +(define/who (syntax-local-lift-module-end-declaration s) + (define-values (ctx also-s) + (do-local-lift-to-module who + s + #:no-target-msg "not currently transforming an expression within a module declaration" + #:get-lift-ctx expand-context-to-module-lifts + #:get-wrt-phase (lambda (lift-ctx) 0) ; always relative to 0 + #:add-lifted! add-lifted-to-module-end! + #:pre-wrap + (lambda (orig-s phase to-module-lift-ctx) + (if (to-module-lift-context-end-as-expressions? to-module-lift-ctx) + (wrap-form '#%expression orig-s phase) + orig-s)) + #:shift-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form 'begin-for-syntax s phase)))) + (log-expand ctx 'lift-statement s)) + +(define (wrap-form sym s phase) + (datum->syntax + #f + (list (datum->syntax + (if phase + (syntax-shift-phase-level core-stx phase) + #f) + sym) + s))) + +;; ---------------------------------------- + +(define/who (syntax-local-module-defined-identifiers) + (unless (syntax-local-transforming-module-provides?) + (raise-arguments-error who "not currently transforming module provides")) + (define ctx (get-current-expand-context 'syntax-local-module-defined-identifiers)) + (requireds->phase-ht (extract-module-definitions (expand-context-requires+provides ctx)))) + + +(define/who (syntax-local-module-required-identifiers mod-path phase-level) + (unless (or (not mod-path) (module-path? mod-path)) + (raise-argument-error who "(or/c module-path? #f)" mod-path)) + (unless (or (eq? phase-level #t) (phase? phase-level)) + (raise-argument-error who (format "(or/c ~a #t)" phase?-string) phase-level)) + (unless (syntax-local-transforming-module-provides?) + (raise-arguments-error who "not currently transforming module provides")) + (define ctx (get-current-expand-context 'syntax-local-module-required-identifiers)) + (define requires+provides (expand-context-requires+provides ctx)) + (define mpi (and mod-path + (module-path->mpi/context mod-path ctx))) + (define requireds + (extract-all-module-requires requires+provides + mpi + (if (eq? phase-level #t) 'all phase-level))) + (and requireds + (for/list ([(phase ids) (in-hash (requireds->phase-ht requireds))]) + (cons phase ids)))) + +(define (requireds->phase-ht requireds) + (for/fold ([ht (hasheqv)]) ([r (in-list requireds)]) + (hash-update ht + (required-phase r) + (lambda (l) (cons (required-id r) l)) + null))) + +;; ---------------------------------------- + +(define/who (syntax-local-module-exports mod-path) + (unless (or (module-path? mod-path) + (and (syntax? mod-path) + (module-path? (syntax->datum mod-path)))) + (raise-argument-error who + (string-append + "(or/c module-path?\n" + " (and/c syntax?\n" + " (lambda (stx)\n" + " (module-path? (syntax->datum stx)))))") + mod-path)) + (define ctx (get-current-expand-context 'syntax-local-module-exports)) + (define ns (expand-context-namespace ctx)) + (define mod-name (module-path-index-resolve + (module-path->mpi/context (if (syntax? mod-path) + (syntax->datum mod-path) + mod-path) + ctx) + #t)) + (define m (namespace->module ns mod-name)) + (unless m (raise-unknown-module-error 'syntax-local-module-exports mod-name)) + (for/list ([(phase syms) (in-hash (module-provides m))]) + (cons phase + (for/list ([sym (in-hash-keys syms)]) + sym)))) + +(define/who (syntax-local-submodules) + (define ctx (get-current-expand-context who)) + (define submods (expand-context-declared-submodule-names ctx)) + (for/list ([(name kind) (in-hash submods)] + #:when (eq? kind 'module)) + name)) + +;; ---------------------------------------- + +;; Works well enough for some backward compatibility: +(define/who (syntax-local-get-shadower id [only-generated? #f]) + (check who identifier? id) + (define ctx (get-current-expand-context who)) + (define new-id (add-scopes id (expand-context-scopes ctx))) + (if (syntax-clean? id) + new-id + (syntax-taint new-id))) diff -Nru racket-6.12+ppa1/src/expander/expand/top.rkt racket-7.0+ppa1/src/expander/expand/top.rkt --- racket-6.12+ppa1/src/expander/expand/top.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/top.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,127 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../namespace/core.rkt" + "../syntax/match.rkt" + "../syntax/error.rkt" + "../syntax/module-binding.rkt" + "../namespace/namespace.rkt" + "require+provide.rkt" + "main.rkt" + "parsed.rkt" + "context.rkt" + "require.rkt" + "def-id.rkt" + "bind-top.rkt" + "lift-context.rkt" + "lift-key.rkt" + "log.rkt") + +(add-core-form! + 'define-values + (lambda (s ctx) + (log-expand ctx 'prim-define-values) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "not allowed in an expression position" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m s '(define-values (id ...) rhs)) + (define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx)) + (define exp-rhs (expand (m 'rhs) (as-named-context (as-expression-context ctx) ids))) + (if (expand-context-to-parsed? ctx) + (parsed-define-values s ids syms exp-rhs) + (rebuild + s + `(,(m 'define-values) ,ids ,exp-rhs))))) + +(add-core-form! + 'define-syntaxes + (lambda (s ctx) + (log-expand ctx 'prim-define-syntaxes) + (log-expand ctx 'prepare-env) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "not in a definition context" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(define-syntaxes (id ...) rhs)) + (define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx)) + (define exp-rhs (expand-transformer (m 'rhs) (as-named-context ctx ids))) + (if (expand-context-to-parsed? ctx) + (parsed-define-syntaxes s ids syms exp-rhs) + (rebuild + s + `(,(m 'define-syntaxes) ,ids ,exp-rhs))))) + +(add-core-form! + 'begin-for-syntax + (lambda (s ctx) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "not in a definition context" s)) + (define-match m s '(begin-for-syntax form ...)) + (log-expand ctx 'prim-begin-for-syntax) + (log-expand ctx 'prepare-env) + (define trans-ctx (context->transformer-context ctx 'top-level #:keep-stops? #t)) + (define lift-ctx (make-lift-context + (make-top-level-lift trans-ctx))) + (define capture-ctx (struct*-copy expand-context trans-ctx + [lift-key #:parent root-expand-context (generate-lift-key)] + [lifts lift-ctx])) + (define all-exp-forms + (let loop ([forms (m 'form)]) + (log-expand ctx 'enter-list (datum->syntax #f (m 'form) s)) + (define exp-forms + (let loop ([forms forms] [accum null]) + (cond + [(null? forms) + (define forms (reverse accum)) + (log-expand ctx 'exit-list (datum->syntax #f forms s)) + forms] + [else + (log-expand ctx 'next) + (define exp-form (expand (car forms) capture-ctx)) + (loop (cdr forms) (cons exp-form accum))]))) + (define lifts (get-and-clear-lifts! lift-ctx)) + (cond + [(null? lifts) + exp-forms] + [else + (log-expand ctx 'module-lift-loop lifts) + (define beg (wrap-lifts-as-begin lifts #f (expand-context-phase trans-ctx))) + (define exprs (reverse (cdr (reverse (cdr (syntax-e beg)))))) + (append (loop exprs) exp-forms)]))) + ;; We shouldn't be able to get here in to-parsed mode + (if (expand-context-to-parsed? ctx) + (parsed-begin-for-syntax s all-exp-forms) + (rebuild s (cons (m 'begin-for-syntax) all-exp-forms))))) + +(add-core-form! + '#%require + (lambda (s ctx) + (log-expand ctx 'prim-require) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "allowed only in a module or the top level" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%require req ...)) + (define sc (new-scope 'macro)) ; to hide bindings + ;; Check the `#%require` form syntax and trigger compile-time + ;; instanations + (parse-and-perform-requires! (for/list ([req (in-list (m 'req))]) + (add-scope req sc)) + s + #:visit? #f + (expand-context-namespace ctx) + (expand-context-phase ctx) + (make-requires+provides #f) + #:who 'require + ;; We don't need to check for conflicts: + #:initial-require? #t) + ;; Nothing to expand + (if (expand-context-to-parsed? ctx) + (parsed-require s) + s))) + +(add-core-form! + '#%provide + (lambda (s ctx) + (log-expand ctx 'prim-provide) + (raise-syntax-error #f "not allowed outside of a module body" s))) diff -Nru racket-6.12+ppa1/src/expander/expand/use-site.rkt racket-7.0+ppa1/src/expander/expand/use-site.rkt --- racket-6.12+ppa1/src/expander/expand/use-site.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/expand/use-site.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "root-expand-context.rkt") + +(provide remove-use-site-scopes) + +;; Helper to remove any created use-site scopes from the left-hand +;; side of a definition that was revealed by partial expansion in a +;; definition context; the `s` argument can be syntax of a list +;; of syntax +(define (remove-use-site-scopes s ctx) + (define use-sites (root-expand-context-use-site-scopes ctx)) + (if (and use-sites + (pair? (unbox use-sites))) + (if (syntax? s) + (remove-scopes s (unbox use-sites)) + (for/list ([id (in-list s)]) + (remove-scopes id (unbox use-sites)))) + s)) diff -Nru racket-6.12+ppa1/src/expander/extract/c-encode.rkt racket-7.0+ppa1/src/expander/extract/c-encode.rkt --- racket-6.12+ppa1/src/expander/extract/c-encode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/c-encode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,21 @@ +#lang racket/base + +(provide encode-to-c) + +;; Take a stream that has a single S-expression and converts it to C +;; code for a string that contains the S-expression + +(define (encode-to-c in out) + (fprintf out "#define EVAL_STARTUP EVAL_ONE_STR(startup_source)\n") + (fprintf out "static const char *startup_source =\n") + (for ([l (in-lines in)]) + (let* ([l (regexp-replace* #rx"\\\\" l "\\\\\\\\")] + [l (regexp-replace* #rx"\"" l "\\\\\"")] + [l (regexp-replace* #rx"\t" l " ")] + [l (if (regexp-match? #rx"\"" l) + ;; Has a string - can't safely delete more spaces + l + (let ([l (regexp-replace* #rx" +" l " ")]) + (regexp-replace* #rx" \\(" l "(")))]) + (fprintf out "\"~a\"\n" l))) + (fprintf out ";\n")) diff -Nru racket-6.12+ppa1/src/expander/extract/check-and-report.rkt racket-7.0+ppa1/src/expander/extract/check-and-report.rkt --- racket-6.12+ppa1/src/expander/extract/check-and-report.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/check-and-report.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,69 @@ +#lang racket/base +(require "../run/status.rkt" + "../boot/runtime-primitive.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt") + +(provide check-and-report!) + +;; Check for bootstrap obstacles and report the results +(define (check-and-report! #:compiled-modules compiled-modules + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:instance-knot-ties instance-knot-ties) + + (log-status "Traversed ~s modules" (hash-count compiled-modules)) + (log-status "Got ~s relevant linklets" (hash-count linklets)) + (log-status "Need ~s of those linklets" (hash-count needed)) + + (define code-bytes + (let ([o (open-output-bytes)]) + (for ([li (in-list (unbox linklets-in-order))]) + (write (linklet-info-linklet (hash-ref linklets li)) o)) + (get-output-bytes o))) + + (define source-mode? (linklets-are-source-mode? linklets)) + + (log-status "Code is ~s bytes~a" + (bytes-length code-bytes) + (if source-mode? " as source" "")) + (unless source-mode? + (log-status "Reading all code...") + (time (let ([i (open-input-bytes code-bytes)]) + (parameterize ([read-accept-compiled #t]) + (let loop () + (unless (eof-object? (read i)) + (loop))))))) + + ;; Check whether any needed linklet needs an instance of a + ;; pre-defined instance that is not part of the runtime system: + (define complained? #f) + (for ([lnk (in-list (unbox linklets-in-order))]) + (define needed-reason (hash-ref needed lnk #f)) + (when needed-reason + (define li (hash-ref linklets lnk)) + (define complained-this? #f) + (for ([in-lnk (in-list (linklet-info-imports li))] + [in-vars (in-list (linklet-info-in-variables li))]) + (define p (link-name in-lnk)) + (when (and (symbol? p) + (not (member p runtime-instances)) + (not (eq? p '#%linklet)) + (not (hash-ref instance-knot-ties p #f)) + (hash-ref needed in-lnk #t)) + (unless complained? + (log-status "~a\n~a" + "Unfortunately, some linklets depend on pre-defined host instances" + "that are not part of the runtime system:") + (set! complained? #t)) + (unless complained-this? + (log-status " - ~a at ~s" (link-name lnk) (link-phase lnk)) + (set! complained-this? #t)) + (log-status "~a" (lines (format " needs ~s:" p) in-vars)))) + (when complained-this? + (log-status " needed by ~s" needed-reason)))) + + (when complained? + (exit 1))) diff -Nru racket-6.12+ppa1/src/expander/extract/decompile.rkt racket-7.0+ppa1/src/expander/extract/decompile.rkt --- racket-6.12+ppa1/src/expander/extract/decompile.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/decompile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base +(require '#%linklet + racket/pretty + "../run/status.rkt") + +(provide compile-and-decompile) + +(define (compile-and-decompile linklet-expr print-extracted-to #:as-bytecode? as-bytecode?) + (unless compile-linklet + (error "Host Racket does not support linklet compilation")) + + (log-status "Compiling and decompiling linklet to ~a" print-extracted-to) + + (define linklet (compile-linklet linklet-expr)) + + (define out (open-output-bytes)) + (write (hash->linklet-bundle (hasheq 0 linklet)) out) + + (call-with-output-file* + print-extracted-to + #:exists 'truncate/replace + (lambda (o) + (if as-bytecode? + (write-bytes (get-output-bytes out) o) + (let* ([i (open-input-bytes (get-output-bytes out))] + ;; Dynamically load decompiler, so that it's not otherwise a + ;; dependency for running the expander-flattener + [zo ((dynamic-require 'compiler/zo-parse 'zo-parse) i)] + [decompiled-expr ((dynamic-require 'compiler/decompile 'decompile) zo)]) + (pretty-write decompiled-expr o)))))) + +(define compile-linklet + (hash-ref (primitive-table '#%linklet) 'compile-linklet #f)) + +(define hash->linklet-bundle + (hash-ref (primitive-table '#%linklet) 'hash->linklet-bundle #f)) diff -Nru racket-6.12+ppa1/src/expander/extract/defn-known.rkt racket-7.0+ppa1/src/expander/extract/defn-known.rkt --- racket-6.12+ppa1/src/expander/extract/defn-known.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/defn-known.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,140 @@ +#lang racket/base +(require racket/match + "../run/status.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt") +(provide add-defn-known!) + +(struct struct-shape (num-fields num-parent-fields op-types)) + +(define (add-defn-known! seen-defns syms rhs) + (for ([s (in-list syms)]) + (unless (hash-ref seen-defns s #f) + (hash-set! seen-defns s (known-defined)))) + (cond + ;; Recognize known-arity `lambda` and `case-lambda` + [(and (= 1 (length syms)) (lambda-arity rhs)) + => + (lambda (arity) + (hash-set! seen-defns + (car syms) + (known-function arity + (pure-lambda? (car syms) + rhs + seen-defns))))] + ;; Recognize structure declarations + [(expr-struct-shape rhs seen-defns) + => + (lambda (shape) + (when (= (length syms) (length (struct-shape-op-types shape))) + (for ([sym (in-list syms)] + [op-type (in-list (struct-shape-op-types shape))]) + (hash-set! seen-defns sym + (known-struct-op op-type + (case op-type + [(general-accessor general-mutator) + (- (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape))] + [else (struct-shape-num-fields shape)]))))))] + ;; Recognize structure-property declaration + [(and (= 3 (length syms)) (simple-property? rhs)) + (hash-set! seen-defns (list-ref syms 0) (known-property)) + (hash-set! seen-defns (list-ref syms 1) (known-function 1 #t)) + (hash-set! seen-defns (list-ref syms 2) (known-function 1 #t))])) + +(define (lambda-arity e) + (match e + [`(lambda (,args ...) ,_) (length args)] + [`(case-lambda [(,argss ...) ,_] ...) (map length argss)] + [_ #f])) + +(define (pure-lambda? self-id e seen-defns) + (match e + [`(lambda (,args ...) ,body) + (pure-body? self-id null args body seen-defns)] + [`(case-lambda [(,argss ...) ,bodys] ...) + (define arity (map length argss)) + (for/and ([args (in-list argss)] + [body (in-list bodys)]) + (pure-body? self-id arity args body seen-defns))] + [_ #f])) + +(define (pure-body? self-id self-arity args orig-body seen-defns) + (define locals + (for/hash ([arg (in-list args)]) + (values arg (known-defined)))) + (define body + ;; Strip away a `begin` that's there to record a function name: + (match orig-body + [`(begin (quote ,_) ,e) e] + [else orig-body])) + (cond + [(and (pair? body) + (eq? (car body) self-id) + ((sub1 (length body)) . > . (length args))) + ;; Allow a self-call as pure, as long as the number of arguments + ;; grows. We'll only conclude that the function is pure overall if + ;; that assumption now as justified, but we require the number of + ;; arguments to grow to disallow an infinite loop as pure. + (define num-args (length args)) + (not (any-side-effects? body 1 + #:known-defns seen-defns + #:known-locals (hash-set locals + self-id + (known-function + (for/list ([a (in-list self-arity)] + #:when (a . > . num-args)) + a) + #t))))] + [else + (not (any-side-effects? body 1 + #:known-defns seen-defns + #:known-locals locals))])) + +(define struct-general-op-types + '(struct-type constructor predicate general-accessor general-mutator)) + +(define (expr-struct-shape e defns) + (let loop ([e e]) + (match e + [`(let-values () ,e) (loop e)] + [`(make-struct-type ,_ #f ,n 0 #f . ,_) + (and (exact-nonnegative-integer? n) + (struct-shape n 0 struct-general-op-types))] + [`(make-struct-type ,_ ,s ,n 0 #f . ,_) + (define h (hash-ref defns s #f)) + (and (known-struct-op? h) + (exact-nonnegative-integer? n) + (eq? (known-struct-op-type h) 'struct-type) + (struct-shape (+ n (known-struct-op-field-count h)) + (known-struct-op-field-count h) + struct-general-op-types))] + [`(let-values (((,ty ,mk ,pred ,ref ,mut) ,mst)) + (values ,ty ,mk ,pred + (,make-struct-field-xs ,refs ,is ,_) ...)) + (define shape (expr-struct-shape mst defns)) + (and shape + (equal? (struct-shape-op-types shape) struct-general-op-types) + (let ([num-immediate-fields (- (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape))]) + (for/and ([make-struct-field-x (in-list make-struct-field-xs)] + [r (in-list refs)] + [i (in-list is)]) + (and (< i num-immediate-fields) + (if (eq? make-struct-field-x 'make-struct-field-accessor) + (eq? r ref) + (eq? r mut))))) + (struct-shape (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape) + (append '(struct-type constructor predicate) + (for/list ([make-struct-field-x (in-list make-struct-field-xs)]) + (if (eq? make-struct-field-x 'make-struct-field-accessor) + 'accessor + 'mutator)))))] + [_ #f]))) + +;; checks for properties without guards +(define (simple-property? e) + (match e + [`(make-struct-type-property ,_) #t] + [_ #f])) diff -Nru racket-6.12+ppa1/src/expander/extract/defn.rkt racket-7.0+ppa1/src/expander/extract/defn.rkt --- racket-6.12+ppa1/src/expander/extract/defn.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/defn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang racket/base + +(provide defn? + defn-syms + defn-rhs) + +(define (defn? e) + (and (pair? e) + (eq? (car e) 'define-values))) +(define defn-syms cadr) +(define defn-rhs caddr) + diff -Nru racket-6.12+ppa1/src/expander/extract/export.rkt racket-7.0+ppa1/src/expander/extract/export.rkt --- racket-6.12+ppa1/src/expander/extract/export.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/export.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,29 @@ +#lang racket/base +(require "module.rkt" + "../host/linklet.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../namespace/provided.rkt" + "link.rkt" + "variable.rkt") + +(provide get-module-export-variables) + +(define (get-module-export-variables lnk + #:compiled-modules compiled-modules + #:cache cache) + (define name (link-name lnk)) + (define phase (link-phase lnk)) + (define root-name (if (pair? name) (car name) name)) ; strip away submodule path + (define comp-mod + (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache)) + + (define provs (instance-variable-value (compiled-module-declaration comp-mod) 'provides)) + + (for/hash ([(sym binding/p) (in-hash (hash-ref provs 0 #hasheq()))]) + (define binding (provided-as-binding binding/p)) + (values sym (variable (link (module-path-index->module-name (module-binding-module binding) name) + (module-binding-phase binding)) + (module-binding-sym binding))))) diff -Nru racket-6.12+ppa1/src/expander/extract/flatten.rkt racket-7.0+ppa1/src/expander/extract/flatten.rkt --- racket-6.12+ppa1/src/expander/extract/flatten.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/flatten.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,186 @@ +#lang racket/base +(require "../common/set.rkt" + "../run/status.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "variable.rkt" + "symbol.rkt" + "primitive-table.rkt" + (prefix-in bootstrap: "../run/linklet.rkt")) + +(provide flatten!) + +(define (flatten! start-link + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:exports exports + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs) + (log-status "Flattening to a single linklet...") + (define needed-linklets-in-order + (for/list ([lnk (in-list (unbox linklets-in-order))] + #:when (hash-ref needed lnk #f)) + lnk)) + + (define variable-names (pick-variable-names + #:linklets linklets + #:needed-linklets-in-order needed-linklets-in-order + #:instance-knot-ties instance-knot-ties)) + + (for ([var (in-hash-keys variable-names)] + #:when (symbol? (link-name (variable-link var)))) + (error 'flatten "found a dependency on a non-primitive: ~s from ~s" + (variable-name var) + (link-name (variable-link var)))) + + `(linklet + ;; imports + () + ;; exports + ,(for/list ([ex-sym (in-list (sort (hash-keys exports) symbol set-of-symbol + (define all-variables null) ; domain of `variable-locals` in an order + (define otherwise-used-symbols (seteq)) + + (for ([lnk (in-list needed-linklets-in-order)]) + (define li (hash-ref linklets lnk)) + (define linklet (linklet-info-linklet li)) + (define importss+localss + (skip-abi-imports (bootstrap:s-expr-linklet-importss+localss linklet))) + (define exports+locals + (bootstrap:s-expr-linklet-exports+locals linklet)) + (define all-mentioned-symbols + (all-used-symbols (bootstrap:s-expr-linklet-body linklet))) + + (define (record! lnk external+local knot-ties) + (cond + [(find-knot-tying-alternate knot-ties lnk (car external+local) linklets) + => (lambda (alt-lnk) + (unless (eq? alt-lnk 'ignore) + (record! alt-lnk external+local knot-ties)))] + [else + (define var (variable lnk (car external+local))) + (unless (hash-ref variable-locals var #f) + (set! all-variables (cons var all-variables))) + (hash-update! variable-locals + var + (lambda (s) (set-add s (cdr external+local))) + (seteq))])) + + (for ([imports+locals (in-list importss+localss)] + [i-lnk (in-list (linklet-info-imports li))]) + (for ([import+local (in-list imports+locals)]) + (record! i-lnk import+local instance-knot-ties))) + + (for ([export+local (in-list exports+locals)]) + (record! lnk export+local #hasheq())) + + (define all-import-export-locals + (list->set + (apply append + (map cdr exports+locals) + (for/list ([imports+locals (in-list importss+localss)]) + (map cdr imports+locals))))) + (set! otherwise-used-symbols + (set-union otherwise-used-symbols + (set-subtract all-mentioned-symbols + all-import-export-locals)))) + + ;; For each variable name, use the obvious symbol if it won't + ;; collide, otherwise pick a symbol that's not mentioned anywhere. + ;; (If a variable was given an alternative name for all imports or + ;; exports, probably using the obvious symbol would cause a + ;; collision.) + (for/hash ([var (in-list (reverse all-variables))]) + (define current-syms (hash-ref variable-locals var)) + (define sym + (cond + [(and (= 1 (set-count current-syms)) + (not (set-member? otherwise-used-symbols (set-first current-syms)))) + (set-first current-syms)] + [(and (set-member? current-syms (variable-name var)) + (not (set-member? otherwise-used-symbols (variable-name var)))) + (variable-name var)] + [else (distinct-symbol (variable-name var) otherwise-used-symbols)])) + (set! otherwise-used-symbols (set-add otherwise-used-symbols sym)) + (values var sym))) + +(define (body-with-substituted-variable-names lnk li variable-names + #:linklets linklets + #:instance-knot-ties instance-knot-ties) + (define linklet (linklet-info-linklet li)) + (define importss+localss + (skip-abi-imports (bootstrap:s-expr-linklet-importss+localss linklet))) + (define exports+locals + (bootstrap:s-expr-linklet-exports+locals linklet)) + + (define substs (make-hasheq)) + + (define (add-subst! lnk external+local knot-ties) + (cond + [(find-knot-tying-alternate knot-ties lnk (car external+local) linklets) + => (lambda (alt-lnk) + (unless (eq? alt-lnk 'ignore) + (add-subst! alt-lnk external+local knot-ties)))] + [else + (hash-set! substs + (cdr external+local) + (hash-ref variable-names (variable lnk (car external+local))))])) + + (for ([imports+locals (in-list importss+localss)] + [i-lnk (in-list (linklet-info-imports li))]) + (for ([import+local (in-list imports+locals)]) + (add-subst! i-lnk import+local instance-knot-ties))) + + (for ([export+local (in-list exports+locals)]) + (add-subst! lnk export+local #hasheq())) + + (define orig-s (bootstrap:s-expr-linklet-body (linklet-info-linklet li))) + + (substitute-symbols orig-s substs)) + + +(define (find-knot-tying-alternate knot-ties lnk external linklets) + (cond + [(hash-ref knot-ties (link-name lnk) #f) + => (lambda (alt-paths) + (or (for/or ([alt-path (in-list alt-paths)]) + (cond + [(eq? alt-path 'ignore) + 'ignore] + [else + (define alt-lnk (link alt-path 0)) + (define li (hash-ref linklets alt-lnk)) + (define exports+locals (bootstrap:s-expr-linklet-exports+locals (linklet-info-linklet li))) + (for/or ([export+local (in-list exports+locals)]) + (and (eq? external (car export+local)) + alt-lnk))])) + (error 'flatten "could not find alternative export: ~s from ~s" + external + lnk)))] + [else #f])) diff -Nru racket-6.12+ppa1/src/expander/extract/gc-defn.rkt racket-7.0+ppa1/src/expander/extract/gc-defn.rkt --- racket-6.12+ppa1/src/expander/extract/gc-defn.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/gc-defn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,115 @@ +#lang racket/base +(require racket/list + "../host/correlate.rkt" + "../common/set.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "symbol.rkt" + "defn.rkt" + "defn-known.rkt" + "known-primitive.rkt") + +(provide garbage-collect-definitions) + +(define (garbage-collect-definitions linklet-expr) + (log-status "Removing unused definitions...") + + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define used-syms (make-hasheq)) + + ;; See "../compile/known.rkt" for the meaning of + ;; values in `seen-defns` + (define seen-defns (make-hasheq)) + (register-known-primitives! seen-defns) + + ;; Map symbols to definition right-hand sides + (define sym-to-rhs (make-hasheq)) + (for ([e (in-list body)]) + (cond + [(defn? e) + (for ([sym (in-list (defn-syms e))]) + (hash-set! sym-to-rhs sym (defn-rhs e)))])) + + ;; A "mark"-like traversal of an expression: + (define (set-all-used! e) + (for ([sym (in-set (all-used-symbols e))]) + (unless (hash-ref used-syms sym #f) + (hash-set! used-syms sym #t) + (set-all-used! (hash-ref sym-to-rhs sym #f))))) + + ;; Helper to check for side-effects at a definition + (define (defn-side-effects? e) + (any-side-effects? (defn-rhs e) + (length (defn-syms e)) + #:known-defns seen-defns)) + + ;; Mark each body form, delaying the righthand side of definitions + ;; if the definition has no side-effect + (let loop ([body body]) + (cond + [(null? body) (void)] + [(defn? (car body)) + (define defn (car body)) + (cond + [(defn-side-effects? defn) + ;; Right-hand side has an effect, so keep the + ;; definition and mark everything as used: + (for ([sym (in-list (defn-syms defn))]) + (unless (hash-ref used-syms sym #f) + (hash-set! used-syms sym #t))) + (set-all-used! (defn-rhs defn)) + ;; Afterward, these identifiers are defined. + ;; (It's ok if delayed types refer to these, + ;; because they're apparently used later if they're + ;; still delayed.) + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym (known-defined)))] + [else + ;; The definition itself doesn't have a side effect, so dont + ;; mark it as used right away, and delay analysis to make it + ;; independent of order within a group without side effects + (define thunk + (known-defined/delay + (lambda () + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym (known-defined))) + (add-defn-known! seen-defns + (defn-syms defn) + (defn-rhs defn))))) + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym thunk))]) + (loop (cdr body))] + [else + (set-all-used! (car body)) + (loop (cdr body))])) + + ;; Mark each export: + (for ([ex+sym (in-list (bootstrap:s-expr-linklet-exports+locals linklet-expr))]) + (set-all-used! (cdr ex+sym))) + + (define can-remove-count + (for/sum ([e (in-list body)]) + (cond + [(defn? e) + (if (for/or ([sym (in-list (defn-syms e))]) + (hash-ref used-syms sym #f)) + 0 + (length (defn-syms e)))] + [else 0]))) + (log-status "Can remove ~s of ~s defined names, keeping ~s" + can-remove-count + (hash-count sym-to-rhs) + (- (hash-count sym-to-rhs) can-remove-count)) + + (define new-body + (for/list ([e (in-list body)] + #:when (or (not (defn? e)) + (for/or ([sym (in-list (defn-syms e))]) + (hash-ref used-syms sym #f)))) + e)) + + (append (take linklet-expr 3) + new-body)) diff -Nru racket-6.12+ppa1/src/expander/extract/get-linklet.rkt racket-7.0+ppa1/src/expander/extract/get-linklet.rkt --- racket-6.12+ppa1/src/expander/extract/get-linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/get-linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,108 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/phase.rkt" + "../run/status.rkt" + "../host/linklet.rkt" + "../compile/module-use.rkt" + "../syntax/binding.rkt" + "../namespace/provided.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "module.rkt") + +(provide get-linklets!) + +(define (get-linklets! lnk + #:cache cache + #:compiled-modules compiled-modules + #:seen seen + #:linklets linklets + #:linklets-in-order linklets-in-order + #:side-effect-free-modules side-effect-free-modules) + (let get-linklets! ([lnk lnk] [first? #t]) + (define name (link-name lnk)) + (define phase (link-phase lnk)) + (define root-name (if (pair? name) (car name) name)) ; strip away submodule path + (unless (or (symbol? root-name) ; skip pre-defined modules + (hash-ref seen lnk #f)) + ;; Seeing this module+phase combination for the first time + (log-status "Getting ~s at ~s" name phase) + (define comp-mod (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache)) + + ;; Extract the relevant linklet (i.e., at a given phase) + ;; from the compiled module + (define h (compiled-module-phase-to-linklet comp-mod)) + (define linklet + (hash-ref h phase #f)) + + ;; Extract other metadata at the module level: + (define reqs (instance-variable-value (compiled-module-declaration comp-mod) 'requires)) + (define provs (instance-variable-value (compiled-module-declaration comp-mod) 'provides)) + + ;; Extract phase-specific (i.e., linklet-specific) info on variables: + (define vars (if linklet + (list->set (linklet-export-variables linklet)) + null)) + ;; Extract phase-specific info on imports (for reporting bootstrap issues): + (define in-vars (if linklet + (skip-abi-imports (linklet-import-variables linklet)) + null)) + ;; Extract phase-specific info on side effects: + (define side-effects? (and (not (hash-ref side-effect-free-modules name #f)) + (member phase (hash-ref h 'side-effects '())) + #t)) + ;; Extract phase-specific mapping of the linklet arguments to modules + (define uses + (hash-ref (instance-variable-value (compiled-module-declaration comp-mod) 'phase-to-link-modules) + phase + null)) + + (define dependencies + (for*/list ([phase+reqs (in-list reqs)] + [req (in-list (cdr phase+reqs))]) + ;; we want whatever required module will have at this module's `phase` + (define at-phase (phase- phase (car phase+reqs))) + (link (module-path-index->module-name req name) + at-phase))) + + ;; Get linklets implied by the module's `require` (although some + ;; of those may turn out to be dead code) + (for ([dependency (in-list dependencies)]) + (get-linklets! dependency #f)) + + ;; Imports are the subset of the transitive closure of `require` + ;; that are used by this linklet's implementation + (define imports + (for/list ([mu (in-list uses)]) + (link (module-path-index->module-name (module-use-module mu) name) + (module-use-phase mu)))) + (when (and (pair? imports) + (not linklet)) + (error "no implementation, but uses arguments?" name phase)) + + ;; Re-exports are the subset of the transitive closure of + ;; `require` that have variables that are re-exported from this + ;; linklet; relevant only for the starting point + (define re-exports + (and first? + (set->list + (for*/set ([(sym binding/p) (in-hash (hash-ref provs phase #hasheq()))] + [(binding) (in-value (provided-as-binding binding/p))] + [l (in-value + (link (module-path-index->module-name (module-binding-module binding) name) + (module-binding-phase binding)))] + [re-li (in-value (hash-ref linklets l #f))] + #:when (and re-li + (set-member? (linklet-info-variables re-li) (module-binding-sym binding)))) + l)))) + + (define li (linklet-info linklet imports re-exports vars in-vars side-effects?)) + + (hash-set! seen lnk li) + + (when linklet + (hash-set! linklets lnk li) + (set-box! linklets-in-order (cons lnk (unbox linklets-in-order))))))) diff -Nru racket-6.12+ppa1/src/expander/extract/known-primitive.rkt racket-7.0+ppa1/src/expander/extract/known-primitive.rkt --- racket-6.12+ppa1/src/expander/extract/known-primitive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/known-primitive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ +#lang racket/base +(require "../compile/known.rkt") + +(provide register-known-primitives!) + +(define (register-known-primitives! seen-defns) + ;; Register some core primitives that have specific properties: + (hash-set! seen-defns 'struct:exn:fail (known-struct-op 'struct-type 2)) + (hash-set! seen-defns 'make-thread-cell (known-struct-op 'constructor 1)) + (hash-set! seen-defns 'make-continuation-prompt-tag (known-struct-op 'constructor 1)) + (hash-set! seen-defns 'make-weak-hash (known-struct-op 'constructor 0)) + (hash-set! seen-defns 'gensym (known-struct-op 'constructor 0)) + (hash-set! seen-defns 'string (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'cons (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'eq? (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'not (known-predicate 'anything)) + (hash-set! seen-defns 'null? (known-predicate 'null)) + (hash-set! seen-defns 'integer? (known-predicate 'integer)) + (hash-set! seen-defns 'list? (known-predicate 'list)) + (hash-set! seen-defns 'length (known-function-of-satisfying '(list))) + (hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least)) + (hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least))) + (hash-set! seen-defns 'procedure? (known-predicate 'procedure)) + (hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))) diff -Nru racket-6.12+ppa1/src/expander/extract/linklet-info.rkt racket-7.0+ppa1/src/expander/extract/linklet-info.rkt --- racket-6.12+ppa1/src/expander/extract/linklet-info.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/linklet-info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base + +(provide (struct-out linklet-info)) + +;; A linklet-info is a phase-specific slice of a module --- mainly a +;; linklet, but we group the linklet together with metadata from the +;; module's declaration linklet +(struct linklet-info (linklet ; the implementation, or #f if the implementation is empty + imports ; list of links: import "arguments" + re-exports ; list of links: links whose variables are re-exported + variables ; set of symbols: defined in the implementation, for detecting re-exports + in-variables ; list of list of symbols: for each import, variables used from the import + side-effects?)) ; whether the implementaiton has side effects other than variable definition diff -Nru racket-6.12+ppa1/src/expander/extract/linklet.rkt racket-7.0+ppa1/src/expander/extract/linklet.rkt --- racket-6.12+ppa1/src/expander/extract/linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,21 @@ +#lang racket/base +(require "linklet-info.rkt" + "../host/linklet.rkt" + (prefix-in bootstrap: "../run/linklet.rkt")) + +(provide skip-abi-imports + linklets-are-source-mode?) + +;; Skip over syntax literals and instance: +(define (skip-abi-imports l) + (list-tail l 2)) + +;; Detect source mode, which enables final assembly +(define (linklets-are-source-mode? linklets) + (define bootstrap-mode? + (eq? bootstrap:compile-linklet compile-linklet)) + (and bootstrap-mode? + (not (zero? (hash-count linklets))) + (bootstrap:linklet-as-s-expr? + (linklet-info-linklet + (hash-iterate-value linklets (hash-iterate-first linklets)))))) diff -Nru racket-6.12+ppa1/src/expander/extract/link.rkt racket-7.0+ppa1/src/expander/extract/link.rkt --- racket-6.12+ppa1/src/expander/extract/link.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/link.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide (struct-out link)) + +;; A "link" represent a linklet reference, which is a name +;; (corresponds to a `resolved-module-path-name` result) plus a phase +(struct link (name phase) #:prefab) diff -Nru racket-6.12+ppa1/src/expander/extract/main.rkt racket-7.0+ppa1/src/expander/extract/main.rkt --- racket-6.12+ppa1/src/expander/extract/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,148 @@ +#lang racket/base +(require "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "get-linklet.rkt" + "needed.rkt" + "export.rkt" + "check-and-report.rkt" + "flatten.rkt" + "gc-defn.rkt" + "simplify-defn.rkt" + "prune-name.rkt" + "decompile.rkt" + "save-and-report.rkt" + "underscore.rkt" + racket/pretty) + +(provide extract) + +;; Gather all of the linklets need to run phase 0 of the specified +;; module while keeping the module's variables that are provided from +;; phase 0. In other words, keep enogh to produce any value or effect +;; that `dynamic-require` would produce. +(define (extract start-mod-path cache + #:print-extracted-to print-extracted-to + #:as-c? as-c? + #:as-decompiled? as-decompiled? + #:as-bytecode? as-bytecode? + ;; Table of symbol -> (listof knot-spec), + ;; to redirect a remaining import back to + ;; an implementation that is defined in the + ;; flattened code; a knot-spec as a module-path + ;; redirect to there, or as 'ignored avoids both + ;; a knot and complaining + #:instance-knot-ties instance-knot-ties + ;; Table of symbol -> string + ;; to replace (hash-ref (or (primitive-table ') ...) ' #f) + ;; with a direct reference to + #:primitive-table-directs primitive-table-directs + ;; Override linklet compiler's simple inference + ;; of side-effects to remove a module from the + ;; flattened form if it's not otherwise referenced: + #:side-effect-free-modules side-effect-free-modules) + ;; Located modules: + (define compiled-modules (make-hash)) + + ;; All linklets that find we based on module `requires` from the + ;; starting module + (define seen (make-hash)) ; link -> linklet-info + + ;; The subset of `seen` that have that non-empty linklets + (define linklets (make-hash)) ; link -> linklet-info + ;; The same linklets are referenced this list, but kept in reverse + ;; order of instantiation: + (define linklets-in-order (box null)) + + ;; Which linklets (as represented by a "link") are actually needed to run + ;; the code, which includes anything referenced by the starting + ;; point's exports and any imported linklet that has a side effect: + (define needed (make-hash)) ; link -> value for reason + + ;; Use the host Racket's module name resolver to normalize the + ;; starting module path: + (define start-name + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join start-mod-path #f)))) + + ;; We always start at phase 0 + (define start-link (link start-name 0)) + + ;; Start with the given link, and follow dependencies + (get-linklets! start-link + #:cache cache + #:compiled-modules compiled-modules + #:seen seen + #:linklets linklets + #:linklets-in-order linklets-in-order + #:side-effect-free-modules side-effect-free-modules) + + ;; Compute which linklets are actually used as imports + (needed! start-link 'start + #:seen seen + #:needed needed) + + ;; We also want the starting name's re-exports: + (for ([ex-lnk (in-list (linklet-info-re-exports (hash-ref seen start-link)))]) + (needed! ex-lnk `(re-export ,start-link) + #:seen seen + #:needed needed)) + + ;; Anything that shows up in `codes` with a side effect also counts + (for ([(lnk li) (in-hash linklets)]) + (when (linklet-info-side-effects? li) + (needed! lnk 'side-effect + #:seen seen + #:needed needed))) + + ;; Check for bootstrap obstacles, and report what we've found + (check-and-report! #:compiled-modules compiled-modules + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:instance-knot-ties instance-knot-ties) + + ;; If we're in source mode, we can generate a single linklet + ;; that combines all the ones we found + (when (linklets-are-source-mode? linklets) + ;; Get variables to be exported by a flattened linklet; all of the + ;; module provides must refer to instance variables + (define exports + (get-module-export-variables start-link + #:compiled-modules compiled-modules + #:cache cache)) + + ;; Generate the flattened linklet + (define flattened-linklet-expr + (flatten! start-link + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:exports exports + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs)) + + (define simplified-expr + (simplify-definitions flattened-linklet-expr)) + + ;; Remove unreferenced definitions + (define gced-linklet-expr + (garbage-collect-definitions simplified-expr)) + + ;; Avoid gratuitous differences due to names generated during + ;; expansion + (define re-renamed-linklet-expr + (simplify-underscore-numbers gced-linklet-expr)) + + ;; Prune any explicit function names (using a `quote` pattern in + ;; the body) when they still match a name that would be inferred + (define pruned-linklet-expr + (prune-names re-renamed-linklet-expr)) + + (cond + [(or as-decompiled? as-bytecode?) + (compile-and-decompile pruned-linklet-expr print-extracted-to #:as-bytecode? as-bytecode?)] + [else + (save-and-report-flattened! pruned-linklet-expr print-extracted-to + #:as-c? as-c?)]))) diff -Nru racket-6.12+ppa1/src/expander/extract/module.rkt racket-7.0+ppa1/src/expander/extract/module.rkt --- racket-6.12+ppa1/src/expander/extract/module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,72 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../run/cache.rkt" + "../compile/serialize.rkt" + "../compile/module-use.rkt" + (prefix-in new: "../common/module-path.rkt")) + +(provide (struct-out compiled-module) + get-compiled-module + module-path-index->module-name) + +;; We locate each module's declation and phase-specific +;; linklets once: +(struct compiled-module (declaration ; linklet instance + phase-to-linklet)) ; phase -> linklet + + +;; Get (possibly already-loaded) representation of a compiled module +;; from the cache +(define (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache) + (or (hash-ref compiled-modules name #f) + (let ([local-name name]) + ;: Seeing this module for the first time + (define cd (get-cached-compiled cache root-name void)) + (unless cd + (error "unavailable in cache:" name)) + ;; For submodules, recur into the compilation directory: + (define h (let loop ([cd cd] [name name]) + (cond + [(linklet-bundle? cd) + (linklet-bundle->hash cd)] + [else + (define h (linklet-directory->hash cd)) + (if (or (not (pair? name)) + (null? (cdr name))) + (linklet-bundle->hash (hash-ref h #f)) + (loop (hash-ref h (cadr name)) + (cdr name)))]))) + ;; Instantiate the declaration linklet + (define data-instance (instantiate-linklet (hash-ref h 'data) + (list deserialize-instance))) + (define decl (instantiate-linklet (hash-ref h 'decl) + (list deserialize-instance + data-instance))) + ;; Make a `compiled-module` structure to represent the compiled module + ;; and all its linklets (but not its submodules, although they're in `h`) + (define comp-mod (compiled-module decl h)) + (hash-set! compiled-modules name comp-mod) + comp-mod))) + +;; Convert a module path index implemented by our compiler to +;; a module path index in the host Racket: +(define (build-native-module-path-index mpi wrt-name) + (define-values (mod-path base) (new:module-path-index-split mpi)) + (cond + [(not mod-path) (make-resolved-module-path wrt-name)] + [else + (module-path-index-join mod-path + (and base + (build-native-module-path-index base wrt-name)))])) + +;; Convert one of our module path indexes and a name to +;; the referenced name +(define (module-path-index->module-name mod name) + (define p (build-native-module-path-index mod name)) + (resolved-module-path-name + (if (resolved-module-path? p) + p + (module-path-index-resolve p)))) + diff -Nru racket-6.12+ppa1/src/expander/extract/needed.rkt racket-7.0+ppa1/src/expander/extract/needed.rkt --- racket-6.12+ppa1/src/expander/extract/needed.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/needed.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require "link.rkt" + "linklet-info.rkt") + +(provide needed!) + +;; Compute which linklets are actually used as imports +(define (needed! lnk reason + #:seen seen + #:needed needed) + (let needed! ([lnk lnk] [reason reason]) + (unless (hash-ref needed lnk #f) + (define li (hash-ref seen lnk #f)) + (when li + (hash-set! needed lnk reason) + (for ([in-lnk (in-list (linklet-info-imports li))]) + (needed! in-lnk lnk)))))) diff -Nru racket-6.12+ppa1/src/expander/extract/primitive-table.rkt racket-7.0+ppa1/src/expander/extract/primitive-table.rkt --- racket-6.12+ppa1/src/expander/extract/primitive-table.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/primitive-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,73 @@ +#lang racket/base +(provide substitute-primitive-table-access) + +;; Replace +;; (hash-ref (or (primitive-table '
) ...) [default]) +;; with just if
is in `primitive-table-directs`. +(define (substitute-primitive-table-access s primitive-table-directs) + (let loop ([s s]) + (cond + [(primitive-table-lookup-match s) + => (lambda (tables+id) + (define prefix + (for/or ([t (in-list (car tables+id))]) + (hash-ref primitive-table-directs t #f))) + (cond + [prefix + (string->symbol (string-append prefix (symbol->string (cdr tables+id))))] + [else s]))] + [(pair? s) + (cons (loop (car s)) (loop (cdr s)))] + [else s]))) + +(define (primitive-table-lookup-match s) + (cond + [(and (pair? s) + (eq? (car s) 'hash-ref) + (list? s) + (<= 3 (length s) 4) + (let ([q-id (caddr s)]) + (and (list? q-id) + (= (length q-id) 2) + (eq? 'quote (car q-id)) + (symbol? (cadr q-id)) + (cadr q-id)))) + => (lambda (id) + (define tables (accessed-primitive-tables (cadr s))) + (and tables + (cons tables id)))] + [else #f])) + +;; Recognize expansion of +;; (or (primitive-table '
) ...) +(define (accessed-primitive-tables s) + (cond + [(and (list? s) + (= 2 (length s)) + (eq? 'primitive-table (car s)) + (let ([t (cadr s)]) + (and (list? t) + (= 2 (length t)) + (eq? 'quote (car t)) + (symbol? (cadr t)) + (cadr t)))) + => (lambda (table) + (list table))] + [(and (list? s) + (= 3 (length s)) + (eq? (car s) 'let-values) + (= 1 (length (cadr s))) + (= 1 (length (caar (cadr s)))) + (let ([id (car (caar (cadr s)))] + [c (caddr s)]) + (and (list? c) + (= (length c) 4) + (eq? (car c) 'if) + (eq? (cadr c) id) + (eq? (caddr c) id) + (accessed-primitive-tables (cadddr c))))) + => (lambda (tables) + (define pre-tables (accessed-primitive-tables (cadar (cadr s)))) + (and pre-tables + (append tables pre-tables)))] + [else #f])) diff -Nru racket-6.12+ppa1/src/expander/extract/prune-name.rkt racket-7.0+ppa1/src/expander/extract/prune-name.rkt --- racket-6.12+ppa1/src/expander/extract/prune-name.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/prune-name.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/list + racket/match + "../host/correlate.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "defn.rkt") + +(provide prune-names) + +;; Remove function names reported with `quote` when the +;; name is redundant after all transformations. +(define (prune-names linklet-expr) + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define new-body + (for/list ([e (in-list body)]) + (cond + [(defn? e) + (define ids (defn-syms e)) + `(define-values ,ids ,(prune (defn-rhs e) (get-single-id ids)))] + [else + (prune e #f)]))) + + (append (take linklet-expr 3) + new-body)) + +(define (prune e id) + (match e + [`(lambda ,args (begin (quote ,name-id) ,es ...)) + `(lambda ,args ,(if (eq? name-id id) + (prune `(begin . ,es) #f) + (prune `(begin (quote ,name-id) ,@es) #f)))] + [`(lambda ,args ,e) + `(lambda ,args ,(prune e #f))] + [`(case-lambda [,args (begin (quote ,name-id) ,es ...)] + [,argss ,bodys] ...) + `(case-lambda + [,args ,(if (eq? name-id id) + (prune `(begin . ,es) #f) + (prune `(begin (quote ,name-id) ,@es) #f))] + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + `[,args ,(prune body #f)]))] + [`(case-lambda [,argss ,bodys] ...) + `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + `[,args ,(prune body #f)]))] + [`(let-values ([,idss ,rhss] ...) ,e) + `(let-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(prune rhs (get-single-id ids))]) + ,(prune e id))] + [`(letrec-values ([,idss ,rhss] ...) ,e) + `(letrec-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(prune rhs (get-single-id ids))]) + ,(prune e id))] + [`(if ,tst ,thn ,els) + `(if ,(prune tst #f) ,(prune thn id) ,(prune els id))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(prune key #f) ,(prune val #f) ,(prune body id))] + [`(quote ,_) e] + [`(#%variable-reference . ,_) e] + [`(set! ,id ,e) + `(set! ,id ,(prune e id))] + [`(,rator ,rands ...) + (cons (prune rator #f) + (for/list ([rand (in-list rands)]) + (prune rand #f)))] + [else e])) + +(define (get-single-id ids) + (and (pair? ids) + (null? (cdr ids)) + (car ids))) diff -Nru racket-6.12+ppa1/src/expander/extract/save-and-report.rkt racket-7.0+ppa1/src/expander/extract/save-and-report.rkt --- racket-6.12+ppa1/src/expander/extract/save-and-report.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/save-and-report.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,45 @@ +#lang racket/base +(require racket/pretty + "../host/linklet.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "../run/status.rkt" + "c-encode.rkt") + +(provide save-and-report-flattened!) + +(define (save-and-report-flattened! flattened-linklet-expr + print-extracted-to + #:as-c? as-c?) + (when print-extracted-to + (log-status "Writing combined linklet to ~a" print-extracted-to) + (call-with-output-file + print-extracted-to + #:exists 'truncate + (lambda (o) + (unless as-c? + (displayln ";; This is not the original source code. Instead, this is the code after" o) + (displayln ";; fully expanding and flattening into a single linklet." o)) + (define s-expr-o (if as-c? + (open-output-bytes) + o)) + (parameterize ([pretty-print-columns 120]) + (pretty-write flattened-linklet-expr s-expr-o)) + (when as-c? + (encode-to-c (open-input-bytes (get-output-bytes s-expr-o)) o))))) + + ;; Tentatively compile and report size and time + (log-status "Compiling flattened, just as a sanity check...") + (define linklet + (parameterize ([bootstrap:linklet-compile-to-s-expr #f]) + (compile-linklet flattened-linklet-expr))) + + (define code-bytes + (let ([o (open-output-bytes)]) + (write linklet o) + (get-output-bytes o))) + + (log-status "Flattened code is ~s bytes" (bytes-length code-bytes)) + (log-status "Reading compiled code...") + (time (let ([i (open-input-bytes code-bytes)]) + (parameterize ([read-accept-compiled #t]) + (void (read i)))))) diff -Nru racket-6.12+ppa1/src/expander/extract/simplify-defn.rkt racket-7.0+ppa1/src/expander/extract/simplify-defn.rkt --- racket-6.12+ppa1/src/expander/extract/simplify-defn.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/simplify-defn.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,169 @@ +#lang racket/base +(require racket/list + racket/match + "../host/correlate.rkt" + "../common/set.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "symbol.rkt" + "defn.rkt" + "defn-known.rkt" + "known-primitive.rkt") + +(provide simplify-definitions + simplify-expr) + +(define (union-all . args) + (if (null? args) + (seteq) + (set-union (car args) (apply union-all (cdr args))))) + +;; compute the variables that are the target of a set! in e +(define (mutated-vars e) + (match e + [`(set! ,i ,e) (set-add (mutated-vars e) i)] + [`(let-values ,cl ,e) + (define cl* (map (lambda (c) (mutated-vars (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-union (apply union-all (map mutated-vars cl*)) (set-remove (mutated-vars e) binds))] + [`(letrec-values ,cl ,e) + ;; UNSOUND --- assume that variables are defined before use + ;; (i.e., no visible implicit assignment) + (define cl* (map (lambda (c) (mutated-vars (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-remove (set-union (mutated-vars e) (apply union-all (map mutated-vars cl*))) binds)] + [`(lambda ,args ,e) (mutated-vars e)] + [`(case-lambda [,args ,e] ...) (apply union-all (map mutated-vars e))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark if)) + (apply union-all (map mutated-vars e))] + [(? symbol? e) (seteq)] + [`(quote ,_) (seteq)] + [e #:when (or (boolean? e) (number? e) (string? e) (bytes? e)) + (seteq)] + [(list app ...) (apply union-all (map mutated-vars app))] + [(? hash?) (seteq)])) + +;; compute the free variables of e +(define (frees e) + (match e + [(? symbol?) (set e)] + [`(let-values ,cl ,e) + (define cl* (map (lambda (c) (frees (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-union (apply union-all cl*) (set-remove (frees e) binds))] + [`(letrec-values ,cl ,e) + (define cl* (map (lambda (c) (frees (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-remove (set-union (frees e) (apply union-all cl*)) binds)] + [`(lambda (,args ...) ,e) (set-remove (frees e) (apply seteq args))] + [`(lambda ,args ,e) (frees e)] + [`(case-lambda [,args ,e] ...) (apply union-all (map frees e))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark if set!)) + (apply union-all (map frees e))] + [`(quote ,_) (seteq)] + [e #:when (or (hash? e) (boolean? e) (number? e) (string? e) (bytes? e)) + (seteq)] + [(list app ...) (apply union-all (map frees app))])) + +(define (simplify-expr e ; expression to simplify + vars ; set of all mutated variables (for variable-reference-constant?) + safe-ref? ; predicate for whether referencing a variable is safe + seen-defns) ; known definitions + (define (simp e) (simplify-expr e vars safe-ref? seen-defns)) + (match e + [`(if ,e0 ,e1 ,e2) + (define e0* (simp e0)) + (case e0* + [(#t) (simp e1)] + [(#f) (simp e2)] + [else `(if ,e0* ,(simp e1) ,(simp e2))])] + [`(let-values ,cl ,e) + (define names (apply append (map car cl))) + (define simp-body (simplify-expr e vars (lambda (e) (or (memq e names) (safe-ref? e))) seen-defns)) + (define body-frees (frees simp-body)) + (define cl* (filter-map + (lambda (c) + (define vars (car c)) + (define rhs (simp (cadr c))) + (cond + [(and (for/and ([v (in-list vars)]) (not (set-member? body-frees v))) + (or + (not (any-side-effects? rhs (length vars) #:known-defns seen-defns + #:ready-variable? safe-ref?)) + ;; UNSOUND --- assume that variables are defined before use + (symbol? rhs))) + #f] + [else (list vars rhs)])) + cl)) + `(let-values ,cl* ,simp-body)] + [`(letrec-values ,cl ,e) + (define names (apply append (map car cl))) + (define cl* (map (lambda (c) (list (car c) (simp (cadr c)))) cl)) + `(letrec-values ,cl* ,(simplify-expr e vars (lambda (e) (or (memq e names) (safe-ref? e))) seen-defns))] + [`(lambda (,args ...) ,e) `(lambda ,args ,(simplify-expr e vars (lambda (e) (or (memq e args) (safe-ref? e))) seen-defns))] + [`(lambda ,args ,e) `(lambda ,args ,(simp e))] + [`(case-lambda ,cl ...) + (cons 'case-lambda (for/list ([c (in-list cl)]) + (list (car c) + (simp (cadr c)))))] + [`(variable-reference-constant? (#%variable-reference ,x)) + ;; UNSOUND --- assume that variables are defined before use + (not (hash-ref vars x #f))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark set!)) + `(,sym ,@(map simp e))] + [(? symbol? e) e] + [`(quote ,_) e] + [e #:when (or (boolean? e) (number? e) (string? e) (bytes? e)) + e] + [(list app ...) (map simp app)])) + +(define (simplify-definitions linklet-expr) + (log-status "Simplifying definitions...") + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define all-mutated-vars + (for/fold ([s (seteq)]) ([e (in-list body)]) + (cond [(defn? e) + (set-union s (mutated-vars (defn-rhs e)))] + [else (set-union s (mutated-vars e))]))) + + (define seen-defns (make-hasheq)) + (register-known-primitives! seen-defns) + + (define (safe-defn-or-expr? e) + (if (defn? e) + (not (any-side-effects? (defn-rhs e) (length (defn-syms e)) #:known-defns seen-defns)) + (not (any-side-effects? e #f #:known-defns seen-defns)))) + + (define (safe-ref? s) (hash-ref seen-defns s #f)) + + (define new-body + (let loop ([body body]) + (cond [(null? body) null] + [(defn? (car body)) + (for* ([d (in-list body)] + #:break (and (defn? d) + (hash-ref seen-defns (car (defn-syms d)) #f)) + #:break (not (safe-defn-or-expr? d)) + #:when (defn? d)) + (add-defn-known! seen-defns (defn-syms d) (defn-rhs d))) + (define e (car body)) + (define new-defn + (list 'define-values (defn-syms e) (simplify-expr (defn-rhs e) all-mutated-vars safe-ref? seen-defns))) + (add-defn-known! seen-defns (defn-syms e) (defn-rhs e)) + (cons new-defn (loop (cdr body)))] + [else + (define e + (simplify-expr (car body) all-mutated-vars safe-ref? seen-defns)) + (if (equal? e '(void)) + (loop (cdr body)) + (cons e + (loop (cdr body))))]))) + + (append (take linklet-expr 3) + new-body)) diff -Nru racket-6.12+ppa1/src/expander/extract/symbol.rkt racket-7.0+ppa1/src/expander/extract/symbol.rkt --- racket-6.12+ppa1/src/expander/extract/symbol.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/symbol.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +#lang racket +(require "../common/set.rkt") + +(provide all-used-symbols + distinct-symbol + substitute-symbols) + +;; We only have to consider symbols and pairs, because we're looking +;; of variables in a `linklet` form. Also, since there's no shadowing +;; of primitives, we can be especially simplistic about "parsing" to +;; detect `quote`. +(define (all-used-symbols s) + (let loop ([s s] [used (seteq)]) + (cond + [(symbol? s) (set-add used s)] + [(pair? s) + (if (eq? (car s) 'quote) + used + (loop (cdr s) (loop (car s) used)))] + [else used]))) + +;; Pick a symbol like `sym` that's not in the set `used` +(define (distinct-symbol sym used) + (let loop ([n 1]) + (define s (string->symbol (format "~a$~a" sym n))) + (if (set-member? used s) + (loop (add1 n)) + s))) + +(define (substitute-symbols s substs) + (let loop ([s s]) + (cond + [(symbol? s) (hash-ref substs s s)] + [(pair? s) + (if (eq? (car s) 'quote) + s + (cons (loop (car s)) (loop (cdr s))))] + [else s]))) diff -Nru racket-6.12+ppa1/src/expander/extract/underscore.rkt racket-7.0+ppa1/src/expander/extract/underscore.rkt --- racket-6.12+ppa1/src/expander/extract/underscore.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/underscore.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base + +(provide simplify-underscore-numbers) + +;; Small changes to the input code can trigger lots of renumberings +;; for local variables, where the expander adds "_" suffixes to +;; generate local-variable names, and the ""s count up across all +;; symbols. Renumber with symbol-specific counting to reduce +;; unneccessary changes to generated code. A simple strategy works +;; because no primitive or exported name has a "_" suffix. + +(define (simplify-underscore-numbers s) + (define replacements (make-hasheq)) + (define base-counts (make-hasheq)) + (let loop ([s s]) + (cond + [(symbol? s) + (cond + [(hash-ref replacements s #f) + => (lambda (r) r)] + [else + (define str (symbol->string s)) + (define m (regexp-match-positions #rx"_[0-9]+$" str)) + (cond + [(not m) + (hash-set! replacements s s) + s] + [else + (define base (substring str 0 (caar m))) + (define base-s (string->symbol base)) + (define n (hash-ref base-counts base-s 0)) + (hash-set! base-counts base-s (add1 n)) + (define r (string->symbol (format "~a_~a" base n))) + (hash-set! replacements s r) + r])])] + [(pair? s) + (if (eq? (car s) 'quote) + s + (cons (loop (car s)) (loop (cdr s))))] + [else s]))) diff -Nru racket-6.12+ppa1/src/expander/extract/variable.rkt racket-7.0+ppa1/src/expander/extract/variable.rkt --- racket-6.12+ppa1/src/expander/extract/variable.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/extract/variable.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ +#lang racket/base + +(provide (struct-out variable)) + +;; Represents a variable that is exported by a used linklet: +(struct variable (link ; link + name) ; symbol + #:prefab) diff -Nru racket-6.12+ppa1/src/expander/host/correlate.rkt racket-7.0+ppa1/src/expander/host/correlate.rkt --- racket-6.12+ppa1/src/expander/host/correlate.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/correlate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,111 @@ +#lang racket/base +(require "correlate-syntax.rkt" + "../syntax/datum-map.rkt" + "../common/make-match.rkt") + +;; A "correlated" is the host's notion of syntax objects for +;; `compile-linklet`, which is an S-expression with source locations +;; and properties (but no scopes). + +;; For historical reasons, the names here can be a bit confusing. The +;; host layer provides functions named `syntax?`, `datum->syntax`, +;; etc., but these are wrapped here by functions with the names +;; `correlated?`, `datum->correlated`, etc. Additionally, +;; `racket/linklet` obtains the names `syntax?` etc directly from the +;; `#%kernel` primitive table, and provides them under the name +;; `correlated?` etc. This expander defines other functions with the +;; names `syntax?` etc (see "../syntax/syntax.rkt") which are the +;; syntax objects used by this expander. + +;; When the expander is run as a regular Racket program, the host +;; notion of syntax is a full Racket syntax object, but the expander +;; ignores all but the contained datum, the properties, and the source +;; location. + +;; When the expander is used as the expander for Racket on the older, +;; C-based runtime, it uses a C-level implementation of syntax +;; objects, Scheme_Stx, which contains only the features needed +;; here. In that implementation, the names implemented are `syntax?`, +;; etc. + +;; When the expander is run as the Racket expander on the Chez +;; Scheme-based runtime, it uses a record named `correlated` which +;; provides only the features needed here. There, the implemented +;; operations are named `correlated?`, etc, but are provided to this +;; expander as `syntax?`, etc. + +(provide correlate + correlated? + datum->correlated + correlated-e + correlated-cadr + correlated-length + correlated->list + correlated->datum + correlated-property + correlated-property-symbol-keys + define-correlated-match + + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span) + +(define (correlate src-e s-exp) + (define e (datum->correlated s-exp src-e)) + (define maybe-n (syntax-property src-e 'inferred-name)) + (if maybe-n + (syntax-property e 'inferred-name maybe-n) + e)) + +(define (correlated? e) + (syntax? e)) + +(define (datum->correlated d [srcloc #f]) + (datum->syntax #f d srcloc)) + +(define (correlated-e e) + (if (syntax? e) + (syntax-e e) + e)) + +(define (correlated-cadr e) + (car (correlated-e (cdr (correlated-e e))))) + +(define (correlated-length e) + (define l (correlated-e e)) + (and (list? l) + (length l))) + +(define (correlated->list e) + (let loop ([e e]) + (cond + [(list? e) e] + [(pair? e) (cons (car e) (loop (cdr e)))] + [(null? e) null] + [(syntax? e) (loop (syntax-e e))] + [else (error 'correlated->list "not a list")]))) + +(define (correlated->datum e) + (datum-map e (lambda (tail? d) d) (lambda (tail? d) + (if (syntax? d) + (syntax->datum d) + d)))) + +(define (correlated-property-symbol-keys e) + (syntax-property-symbol-keys e)) + +(define correlated-property + (case-lambda + [(e k) (syntax-property e k)] + [(e k v) (syntax-property e k v)])) + +(define-define-match define-correlated-match + syntax? syntax-e (lambda (false str e) (error str))) + +(define (correlated-source s) (syntax-source s)) +(define (correlated-line s) (syntax-line s)) +(define (correlated-column s) (syntax-column s)) +(define (correlated-position s) (syntax-position s)) +(define (correlated-span s) (syntax-span s)) diff -Nru racket-6.12+ppa1/src/expander/host/correlate-syntax.rkt racket-7.0+ppa1/src/expander/host/correlate-syntax.rkt --- racket-6.12+ppa1/src/expander/host/correlate-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/correlate-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host notion of syntax for `compile-linklet`. + +;; This module uses `primitive-table` from '#%linklet instead of from +;; "linklet.rkt". When bootstrapping, the underlying values are +;; different. + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table #%kernel id ...))) + +(bounce datum->syntax syntax->datum syntax-property-symbol-keys + syntax-property syntax-span syntax-position syntax-column + syntax-line syntax-source syntax-e syntax?) diff -Nru racket-6.12+ppa1/src/expander/host/linklet.rkt racket-7.0+ppa1/src/expander/host/linklet.rkt --- racket-6.12+ppa1/src/expander/host/linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ +#lang racket/base +(require racket/private/primitive-table + "../run/linklet-operation.rkt") + +;; The `racket/private/primitive-table` module uses only +;; `primitive-table` directly, so that's the only function needed for +;; bootstrapping --- and generally so we can replace the linklet +;; implementation for bootstrapping. See also "../run/linklet.rkt". + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table + ;; As a hook for bootstrapping, first check for a replacement of + ;; the primitive '#%linklet module: + (#%bootstrap-linklet #%linklet) + id + ...))) + +(linklet-operations=> bounce) + +(void + (unless variable-reference-constant? + (error "broken '#%linklet primitive table; maybe you need to use \"bootstrap-run.rkt\""))) diff -Nru racket-6.12+ppa1/src/expander/host/reader-syntax.rkt racket-7.0+ppa1/src/expander/host/reader-syntax.rkt --- racket-6.12+ppa1/src/expander/host/reader-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/reader-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,19 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host notion of syntax for `datum->syntax`, etc. Bounce the +;; references to these operations through `primitive-table`, so that +;; the bootstrapping process doesn't complain about using them. + +;; Note that if the host has a `compile-linklet`, these syntax objects +;; may not be compatible with it. See "correlate-syntax.rkt" for +;; `compile-linklet`-compatible variants. + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table #%kernel id ...))) + +(bounce datum->syntax syntax->datum syntax-property-symbol-keys + syntax-property syntax-span syntax-position syntax-column + syntax-line syntax-source syntax-e syntax?) diff -Nru racket-6.12+ppa1/src/expander/host/reader-syntax-to-syntax.rkt racket-7.0+ppa1/src/expander/host/reader-syntax-to-syntax.rkt --- racket-6.12+ppa1/src/expander/host/reader-syntax-to-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/reader-syntax-to-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/original.rkt" + "../syntax/datum-map.rkt" + (prefix-in reader: + (only-in "reader-syntax.rkt" + syntax? syntax-e syntax-property + syntax-property-symbol-keys + syntax-source syntax-line syntax-column + syntax-position syntax-span))) + +(provide reader-syntax->syntax) + +(define (reader-syntax->syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(reader:syntax? v) + (define e (reader:syntax-e v)) + (cond + [(syntax? e) + ;; Readtable, #lang, and #reader callbacks can lead to a + ;; reader syntax wrapper on our syntax + e] + [else + (define s + (struct-copy syntax empty-syntax + [content (reader-syntax->syntax (reader:syntax-e v))] + [srcloc (srcloc (reader:syntax-source v) + (reader:syntax-line v) + (reader:syntax-column v) + (reader:syntax-position v) + (reader:syntax-span v))] + [props (case (reader:syntax-property v 'paren-shape) + [(#\[) original-square-props] + [(#\{) original-curly-props] + [else original-props])])) + (define keys (reader:syntax-property-symbol-keys v)) + (cond + [(null? keys) s] + [(and (null? (cdr keys)) (eq? (car keys) 'paren-shape)) s] + [else (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (reader:syntax-property v key) #t))])])] + [else v])))) + +(define original-props + (syntax-props (syntax-property empty-syntax original-property-sym #t))) +(define original-square-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\[))) +(define original-curly-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\{))) diff -Nru racket-6.12+ppa1/src/expander/host/string-to-number.rkt racket-7.0+ppa1/src/expander/host/string-to-number.rkt --- racket-6.12+ppa1/src/expander/host/string-to-number.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/string-to-number.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,11 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host implementation of `string->number` for very basic number +;; parsing. Going through `primitive-table` prevents the reference +;; from being tied back to out implementation here when flattening the +;; expander+reader. + +(provide string->number) + +(import-from-primitive-table #%kernel string->number) diff -Nru racket-6.12+ppa1/src/expander/host/syntax-to-reader-syntax.rkt racket-7.0+ppa1/src/expander/host/syntax-to-reader-syntax.rkt --- racket-6.12+ppa1/src/expander/host/syntax-to-reader-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/host/syntax-to-reader-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,28 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + (only-in "reader-syntax.rkt" + [datum->syntax reader:datum->syntax] + [syntax-property reader:syntax-property])) + +(provide syntax->reader-syntax + srcloc->vector) + +(define (syntax->reader-syntax v) + (syntax-map v + (lambda (tail? v) v) + (lambda (orig-s d) + (define s (reader:datum->syntax #f d (srcloc->vector (syntax-srcloc orig-s)))) + (define keys (syntax-property-symbol-keys orig-s)) + (for/fold ([s s]) ([key (in-list keys)]) + (reader:syntax-property s key (syntax-property orig-s key)))) + syntax-e)) + +(define (srcloc->vector s) + (and s + (vector (srcloc-source s) + (srcloc-line s) + (srcloc-column s) + (srcloc-position s) + (srcloc-span s)))) diff -Nru racket-6.12+ppa1/src/expander/info.rkt racket-7.0+ppa1/src/expander/info.rkt --- racket-6.12+ppa1/src/expander/info.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang info + +(define collection "expander") + +(define deps `(["base" #:version "6.6.0.2"] + "zo-lib" + "compiler-lib")) + +(define build-deps `("at-exp-lib")) + +(define pkg-desc "Racket's implementation of macros, modules, and top-level evaluation") + +(define pkg-authors '(mflatt)) diff -Nru racket-6.12+ppa1/src/expander/main.rkt racket-7.0+ppa1/src/expander/main.rkt --- racket-6.12+ppa1/src/expander/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,184 @@ +#lang racket/base +(require "common/set.rkt" + "common/module-path.rkt" + "namespace/namespace.rkt" + "eval/main.rkt" + (only-in "eval/api.rkt" + [eval eval-top-level]) + "eval/dynamic-require.rkt" + "eval/reflect.rkt" + "eval/load.rkt" + "eval/collection.rkt" + "eval/parameter.rkt" + "read/api.rkt" + "read/primitive-parameter.rkt" + "namespace/api.rkt" + "namespace/attach.rkt" + "namespace/api-module.rkt" + "namespace/core.rkt" + "namespace/primitive-module.rkt" + "expand/missing-module.rkt" + "boot/kernel.rkt" + "boot/read-primitive.rkt" + "boot/main-primitive.rkt" + "boot/utils-primitive.rkt" + "boot/expobs-primitive.rkt" + "boot/place-primitive.rkt" + "boot/linklet-primitive.rkt" + "boot/runtime-primitive.rkt" + "boot/handler.rkt" + "syntax/api.rkt" + (only-in racket/private/config find-main-config)) + +;; All bindings provided by this module must correspond to variables +;; (as opposed to syntax). Provided functions must not accept keyword +;; arguments, both because keyword support involves syntax bindings +;; and because an embedding context won't be able to supply keyword +;; arguments. + +(provide boot ; installs handlers: eval, module name resolver, etc. + seal + + ;; These are direct functions, not ones that use handlers: + expand + compile + eval + read + + ;; Uses handlers: + eval-top-level + + load + load/use-compiled + load-extension + + current-eval + current-compile + current-load + current-load/use-compiled + + find-library-collection-paths + find-library-collection-links + find-main-config + + current-library-collection-paths + current-library-collection-links + use-compiled-file-paths + current-compiled-file-roots + use-compiled-file-check + use-collection-link-paths + use-user-specific-search-paths + + compile-to-linklets + + syntax? + read-syntax + datum->syntax syntax->datum + identifier-binding + datum->kernel-syntax + maybe-syntax->datum ; for reader callbacks via a readtable, etc. + + make-namespace + current-namespace + namespace->instance + + namespace-syntax-introduce + namespace-datum-introduce + namespace-require + dynamic-require + module-declared? + module-predefined? + module->language-info + maybe-raise-missing-module + + namespace-module-identifier + namespace-attach-module + namespace-attach-module-declaration + namespace-mapped-symbols + + module-path-index? + module-path-index-join + resolved-module-path? + module-path? + + declare-primitive-module! ; to support "extensions" + + embedded-load ; for -k + + ;; This functions are provided for basic testing + ;; (such as "demo.rkt") + syntax? syntax-e + identifier? + syntax-property + syntax-debug-info + module-compiled-exports + module-compiled-indirect-exports + read-accept-compiled + + syntax-shift-phase-level + bound-identifier=?) + +;; ---------------------------------------- + +;; Register core forms: +(require "expand/expr.rkt" + "expand/module.rkt" + "expand/top.rkt") + +;; Register core primitives: +(require "boot/core-primitive.rkt") + +;; ---------------------------------------- +;; Initial namespace + +(define ns (make-namespace)) +(void + (begin + (declare-core-module! ns) + (declare-hash-based-module! '#%read read-primitives #:namespace ns) + (declare-hash-based-module! '#%main main-primitives #:namespace ns) + (declare-hash-based-module! '#%utils utils-primitives #:namespace ns) + (declare-hash-based-module! '#%place-struct place-struct-primitives #:namespace ns + ;; Treat place creation as "unsafe", since the new place starts with + ;; permissive guards that can access unsafe features that affect + ;; existing places + #:protected '(dynamic-place)) + (declare-hash-based-module! '#%boot boot-primitives #:namespace ns) + (let ([linklet-primitives + ;; Remove symbols that are in the '#%linklet primitive table + ;; but provided by `#%kernel`: + (hash-remove (hash-remove linklet-primitives + 'variable-reference?) + 'variable-reference-constant?)]) + (declare-hash-based-module! '#%linklet linklet-primitives #:namespace ns + #:primitive? #t + #:register-builtin? #t)) + (declare-hash-based-module! '#%expobs expobs-primitives #:namespace ns + #:protected? #t) + (declare-kernel-module! ns + #:eval eval + #:main-ids (for/set ([name (in-hash-keys main-primitives)]) + name) + #:read-ids (for/set ([name (in-hash-keys read-primitives)]) + name)) + (for ([name (in-list runtime-instances)] + #:unless (eq? name '#%kernel)) + (copy-runtime-module! name + #:namespace ns + #:protected? (or (eq? name '#%foreign) + (eq? name '#%futures) + (eq? name '#%unsafe)))) + (declare-reexporting-module! '#%builtin (list* '#%place-struct + '#%utils + '#%boot + '#%expobs + '#%linklet + runtime-instances) + #:namespace ns + #:reexport? #f) + (current-namespace ns) + + (dynamic-require ''#%kernel 0))) + +(define (datum->kernel-syntax s) + (datum->syntax core-stx s)) diff -Nru racket-6.12+ppa1/src/expander/Makefile racket-7.0+ppa1/src/expander/Makefile --- racket-6.12+ppa1/src/expander/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,85 @@ +# This makefile can be used directly, in which case it writes to a +# "compiled" subdirectory, or it can be driven by other makefiles that +# redirect to a different build dierctory by setting `BUILDDIR` and +# other variables. + +# Beware that this makefile is used both for GNU make and for nmake! + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Tree for collections: +TREE = ../.. + +# See "boot/read-primitive.rkt" for more info: +KNOT = ++knot read read/api.rkt \ + ++knot read read/primitive-parameter.rkt \ + ++knot read read/readtable-parameter.rkt \ + ++knot read read/readtable.rkt \ + ++knot read read/number.rkt + +# When flattening, replace a dynamic lookup from a primitive table to +# a direct use of the primitive name: +DIRECT = ++direct linklet ++direct kernel + +# The linklet compiler's simple inference cannot tell that this +# module's keyword-function declarations will have no side effect, but +# we promise that it's pure: +PURE = ++pure $(TREE)/collects/racket/private/collect.rkt + +# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty). +# Set `DEPENDSDIR` as the same sort of prefix in the generated +# makefile-dependency file (also defaults to empty). The `BUILDDIR` +# and `DEPENDSDIR` settings are different, because `BUILDDIR` is +# relative to here, while makefile dependencies may be needed relative +# to makefile driving the one. + +expander: + $(RACO) make bootstrap-run.rkt + $(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(PURE) -O $(TREE) + +expander-src: + $(RACO) make bootstrap-run.rkt + $(MAKE) expander-src-generate + +GENERATE_ARGS = -c $(BUILDDIR)compiled/cache-src \ + --check-depends $(BUILDDIR)compiled/expander-dep.rktd \ + ++depend-module bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/expander-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/expander.rktl $(BUILDDIR)compiled/expander.d \ + $(KNOT) $(DIRECT) $(PURE) -k $(TREE) -s -x \ + -o $(BUILDDIR)compiled/expander.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +expander-src-generate: + $(RACKET) bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +run: + $(RACO) make run.rkt + $(RACKET) $(RKT_ARGS) run.rkt -c compiled/cache $(ARGS) + +# Like `run`, but with source as compiled (as used for flattening) +run-src: + $(RACO) make bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) bootstrap-run.rkt -s -c compiled/cache-src $(ARGS) + +# Like `run`, but without using a cache for expanded and compiled linklets +run-no-cache: + $(RACO) make run.rkt + $(RACKET) $(RKT_ARGS) run.rkt $(ARGS) + +# Writes the extracted, compiled, decompiled expander to compiled/exp.rkt +decompile: + $(RACO) make bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(PURE) -s -x -D -o compiled/exp.rkt + +# Writes the extracted, compiled expander to compiled/exp.zo +bytecode: + $(RACO) make bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(PURE) -s -x -B -o compiled/exp.zo + +.PHONY: expander expander-src expander-src-generate demo run run-no-cache diff -Nru racket-6.12+ppa1/src/expander/namespace/api-module.rkt racket-7.0+ppa1/src/expander/namespace/api-module.rkt --- racket-6.12+ppa1/src/expander/namespace/api-module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/api-module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,131 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../expand/root-expand-context.rkt" + "namespace.rkt" + (submod "namespace.rkt" for-module) + "module.rkt" + "provide-for-api.rkt" + "provided.rkt" + (submod "module.rkt" for-module-reflect) + "../common/contract.rkt") + +(provide module-declared? + module-predefined? + module->language-info + module->imports + module->exports + module->indirect-exports + module-provide-protected? + module->namespace + namespace-unprotect-module) + +;; ---------------------------------------- + +(define/who (module-declared? mod [load? #f]) + (check who module-reference? #:contract module-reference-str mod) + (define ns (current-namespace)) + (define name (reference->resolved-module-path mod #:load? load?)) + (and (namespace->module ns name) #t)) + +(define/who (module-predefined? mod) + (check who module-reference? #:contract module-reference-str mod) + (define ns (current-namespace)) + (define name (reference->resolved-module-path mod #:load? #f)) + (define m (namespace->module ns name)) + (and m (module-is-predefined? m))) + +(define (module-> extract who mod [load? #f]) + (check who module-reference? #:contract module-reference-str mod) + (define m (namespace->module/complain who + (current-namespace) + (reference->resolved-module-path mod #:load? load?))) + (extract m)) + +(define/who (module->language-info mod [load? #f]) + (module-> module-language-info who mod load?)) + +(define/who (module->imports mod) + (module-> module-requires who mod)) + +(define (module->exports mod) + (define-values (provides self) + (module-> (lambda (m) (values (module-provides m) (module-self m))) 'module->exports mod)) + (provides->api-provides provides self)) + +(define (module->indirect-exports mod) + (module-> (lambda (m) + (variables->api-nonprovides (module-provides m) + ((module-get-all-variables m)))) + 'module->indirect-exports mod)) + +(define (module-provide-protected? mod sym) + (module-> (lambda (m) + (define b/p (hash-ref (module-provides m) sym #f)) + (or (not b/p) (provided-as-protected? b/p))) + 'module-provide-protected? mod)) + +(define/who (module->namespace mod [ns (current-namespace)]) + (check who module-reference? #:contract module-reference-str mod) + (check who namespace? ns) + (define name (reference->resolved-module-path mod #:load? #t)) + (define phase (namespace-phase ns)) + (define m-ns (namespace->module-namespace ns name phase)) + (unless m-ns + ;; Check for declaration: + (namespace->module/complain 'module->namespace ns name) + ;; Must be declared, but not instantiated + (raise-arguments-error who + "module not instantiated in the current namespace" + "name" name)) + (unless (inspector-superior? (current-code-inspector) (namespace-inspector m-ns)) + (raise-arguments-error who + "current code inspector cannot access namespace of module" + "module name" name)) + (unless (namespace-get-root-expand-ctx m-ns) + ;; Instantiating the module didn't install a context, so make one now + (namespace-set-root-expand-ctx! m-ns (make-root-expand-context + #:self-mpi (namespace-mpi m-ns)))) + ;; Ensure that the module is available + (namespace-module-make-available! ns (namespace-mpi m-ns) phase) + m-ns) + +(define/who (namespace-unprotect-module insp mod [ns (current-namespace)]) + (check who inspector? insp) + (check who module-path? mod) + (check who namespace? ns) + (define name (reference->resolved-module-path mod #:load? #f)) + (define phase (namespace-phase ns)) + (define m-ns (namespace->module-namespace ns name phase)) + (unless m-ns + (raise-arguments-error who + "module not instantiated" + "module name" name)) + (when (inspector-superior? insp (namespace-inspector m-ns)) + (set-namespace-inspector! m-ns (make-inspector (current-code-inspector))))) + +;; ---------------------------------------- + +(define (namespace->module/complain who ns name) + (or (namespace->module ns name) + (raise-arguments-error who + "unknown module in the current namespace" + "name" name))) + +;; ---------------------------------------- + +(define (module-reference? mod) + (or (module-path? mod) + (module-path-index? mod) + (resolved-module-path? mod))) + +(define module-reference-str + "(or/c module-path? module-path-index? resolved-module-path?)") + +(define (reference->resolved-module-path mod #:load? load?) + (cond + [(resolved-module-path? mod) mod] + [else + (define mpi (if (module-path-index? mod) + mod + (module-path-index-join mod #f))) + (module-path-index-resolve mpi load?)])) diff -Nru racket-6.12+ppa1/src/expander/namespace/api.rkt racket-7.0+ppa1/src/expander/namespace/api.rkt --- racket-6.12+ppa1/src/expander/namespace/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,258 @@ +#lang racket/base +(require (only-in "../syntax/syntax.rkt" syntax-mpi-shifts empty-syntax) + (only-in "../syntax/scope.rkt" add-scopes push-scope syntax-scope-set) + (only-in "../syntax/fallback.rkt" fallback-first) + (only-in "../syntax/binding.rkt" resolve+shift syntax-transfer-shifts) + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + "../syntax/error.rkt" + "../syntax/mapped-name.rkt" + "namespace.rkt" + "module.rkt" + "attach.rkt" + "core.rkt" + "../common/set.rkt" + "../common/phase.rkt" + "../expand/require+provide.rkt" + "../expand/context.rkt" + "../expand/require.rkt" + "../common/module-path.rkt" + "../common/contract.rkt" + "../expand/protect.rkt" + "../expand/env.rkt" + "../expand/binding-to-module.rkt" + "../host/linklet.rkt") + +(provide make-empty-namespace + + namespace-syntax-introduce + namespace-datum-introduce + namespace-module-identifier + namespace-symbol->identifier + + namespace-require + namespace-require/copy + namespace-require/constant + namespace-require/expansion-time + + namespace-variable-value + namespace-set-variable-value! + namespace-undefine-variable! + + namespace-mapped-symbols + + namespace-base-phase) + +(define (make-empty-namespace) + (define current-ns (current-namespace)) + (define phase (namespace-phase current-ns)) + (define ns (namespace->namespace-at-phase (make-namespace) + phase)) + ;; For historical reasons, an empty namespace isn't actually + ;; empty; we always carry '#%kernel along + (namespace-attach-module current-ns ''#%kernel ns) + (namespace-primitive-module-visit! ns '#%kernel) + ns) + +(define/who (namespace-syntax-introduce s [ns (current-namespace)]) + (check who syntax? s) + (check who namespace? ns) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (define post-scope (post-expansion-scope (root-expand-context-post-expansion root-ctx))) + (define other-namespace-scopes (for/list ([sc (in-set + ;; `all-scopes-stx` corresponds to the initial import + (syntax-scope-set (root-expand-context-all-scopes-stx root-ctx) + 0))] + #:unless (equal? sc post-scope)) + sc)) + (define (add-ns-scopes s) + (syntax-transfer-shifts (add-scopes (push-scope s post-scope) + other-namespace-scopes) + (root-expand-context-all-scopes-stx root-ctx) + (or (namespace-declaration-inspector ns) + (current-code-inspector)) + #:non-source? #t)) + (define maybe-module-id + (and (pair? (syntax-e s)) + (identifier? (car (syntax-e s))) + (add-ns-scopes (car (syntax-e s))))) + (cond + [(and maybe-module-id + (free-identifier=? maybe-module-id + (namespace-module-identifier ns) + (namespace-phase ns))) + ;; The given syntax object starts `module`, so only add scope to `module`: + (datum->syntax s (cons maybe-module-id (cdr (syntax-e s))) s s)] + [else + ;; Add scope everywhere: + (add-ns-scopes s)])) + +;; For use by the main Racket entry point: +(define (namespace-datum-introduce s) + (namespace-syntax-introduce (datum->syntax #f s))) + +(define/who (namespace-module-identifier [where (current-namespace)]) + (unless (or (namespace? where) + (phase? where)) + (raise-argument-error who + (string-append "(or/c namespace? " phase?-string ")") + where)) + (datum->syntax (syntax-shift-phase-level core-stx + (if (namespace? where) + (namespace-phase where) + where)) + 'module)) + +(define/who (namespace-symbol->identifier sym) + (check who symbol? sym) + (namespace-syntax-introduce (datum->syntax #f sym))) + +;; ---------------------------------------- + +(define (do-namespace-require #:run? [run? #t] #:visit? [visit? #f] + who req ns + #:copy-variable-phase-level [copy-variable-phase-level #f] + #:copy-variable-as-constant? [copy-variable-as-constant? #f] + #:skip-variable-phase-level [skip-variable-phase-level #f]) + (check who namespace? ns) + (define ctx-stx (add-scopes empty-syntax + (root-expand-context-module-scopes + (namespace-get-root-expand-ctx ns)))) + (cond + [(or (module-path-index? req) + (module-path? req)) + (perform-require! (if (module-path-index? req) + req + (module-path-index-join req #f)) + #f #f + ctx-stx ns + #:run? run? + #:visit? visit? + #:phase-shift (namespace-phase ns) + #:run-phase (namespace-phase ns) + #:copy-variable-phase-level copy-variable-phase-level + #:copy-variable-as-constant? copy-variable-as-constant? + #:skip-variable-phase-level skip-variable-phase-level + #:who who)] + [else + ;; Slow way -- to allow renaming, check for conflicts, etc. + (parse-and-perform-requires! #:run? run? + #:visit? visit? + (list (datum->syntax ctx-stx req)) + #f + ns + (namespace-phase ns) + (make-requires+provides #f) + #:skip-variable-phase-level skip-variable-phase-level + #:who who)])) + +(define/who (namespace-require req [ns (current-namespace)]) + (do-namespace-require who req ns)) + +(define/who (namespace-require/expansion-time req [ns (current-namespace)]) + (do-namespace-require #:run? #f #:visit? #t who req ns)) + +(define/who (namespace-require/constant req [ns (current-namespace)]) + (do-namespace-require who req ns + #:copy-variable-phase-level 0 + #:copy-variable-as-constant? #t)) + +(define/who (namespace-require/copy req [ns (current-namespace)]) + (do-namespace-require who req ns + #:copy-variable-phase-level 0 + #:skip-variable-phase-level 0)) + +;; ---------------------------------------- + +(define/who (namespace-variable-value sym + [use-mapping? #t] + [failure-thunk #f] + [ns (current-namespace)]) + (check who symbol? sym) + (unless (or (not failure-thunk) + (and (procedure? failure-thunk) + (procedure-arity-includes? failure-thunk 0))) + (raise-argument-error who + "(or/c #f (procedure-arity-includes/c 0))" + failure-thunk)) + (check who namespace? ns) + ((let/ec escape + (define-values (var-ns var-phase-level var-sym) + (cond + [use-mapping? + (define id (datum->syntax #f sym)) + (define b (resolve+shift/extra-inspector (namespace-syntax-introduce id ns) + (namespace-phase ns) + ns)) + (when b (namespace-visit-available-modules! ns)) + (define-values (v primitive? extra-inspector protected?) + (if b + (binding-lookup b empty-env null ns (namespace-phase ns) id) + (values variable #f #f #f))) + (unless (variable? v) + (escape + (or failure-thunk + (lambda () + (raise (exn:fail:syntax + (format (string-append "namespace-variable-value: bound to syntax\n" + " in: ~s") + sym) + (current-continuation-marks) + null)))))) + (if (module-binding? b) + (values (if (top-level-module-path-index? (module-binding-module b)) + ns + (module-instance-namespace (binding->module-instance b ns (namespace-phase ns) id))) + (module-binding-phase b) + (module-binding-sym b)) + (values ns (namespace-phase ns) sym))] + [else + (values ns (namespace-phase ns) sym)])) + (define val + (namespace-get-variable var-ns var-phase-level var-sym + (lambda () (escape + (or failure-thunk + (raise (exn:fail:contract:variable + (format (string-append + "namespace-variable-value: given name is not defined\n" + " name: ~s") + sym) + (current-continuation-marks) + sym))))))) + (lambda () val)))) + +(define/who (namespace-set-variable-value! sym + val + [map? #f] + [ns (current-namespace)] + [as-constant? #f]) + (check who symbol? sym) + (check who namespace? ns) + (namespace-set-variable! ns (namespace-phase ns) sym val as-constant?) + (when map? + (namespace-unset-transformer! ns (namespace-phase ns) sym) + (define id (datum->syntax #f sym)) + (add-binding! (namespace-syntax-introduce id ns) + (make-module-binding (namespace-mpi ns) + (namespace-phase ns) + sym) + (namespace-phase ns)))) + +(define/who (namespace-undefine-variable! sym + [ns (current-namespace)]) + (check who symbol? sym) + (check who namespace? ns) + (namespace-unset-variable! ns (namespace-phase ns) sym)) + +(define/who (namespace-mapped-symbols [ns (current-namespace)]) + (check who namespace? ns) + (set->list + (set-union + (syntax-mapped-names (root-expand-context-all-scopes-stx (namespace-get-root-expand-ctx ns)) + (namespace-phase ns)) + (list->set + (instance-variable-names (namespace->instance ns 0)))))) + +(define/who (namespace-base-phase [ns (current-namespace)]) + (check who namespace? ns) + (namespace-phase ns)) diff -Nru racket-6.12+ppa1/src/expander/namespace/attach.rkt racket-7.0+ppa1/src/expander/namespace/attach.rkt --- racket-6.12+ppa1/src/expander/namespace/attach.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/attach.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,152 @@ +#lang racket/base +(require "namespace.rkt" + "module.rkt" + "../common/module-path.rkt" + "../common/phase.rkt" + "../common/contract.rkt") + +(provide namespace-attach-module + namespace-attach-module-declaration) + +(define (namespace-attach-module src-namespace + mod-path + [dest-namespace (current-namespace)]) + (do-attach-module 'namespace-attach-module + src-namespace mod-path dest-namespace + #:attach-instances? #t)) + +(define (namespace-attach-module-declaration src-namespace + mod-path + [dest-namespace (current-namespace)]) + (do-attach-module 'namespace-attach-module-declaration + src-namespace mod-path dest-namespace + #:attach-instances? #f)) + +(define (do-attach-module who + src-namespace mod-path dest-namespace + #:attach-instances? [attach-instances? #f]) + (check who namespace? src-namespace) + (unless (or (module-path? mod-path) + (resolved-module-path? mod-path)) + (raise-argument-error who "(or/c module-path? resolved-module-path?)" mod-path)) + (check who namespace? dest-namespace) + + (define phase (namespace-phase src-namespace)) + (unless (eqv? phase (namespace-phase dest-namespace)) + (raise-arguments-error who + "source and destination namespace phases do not match" + "source phase" phase + "destination phase" (namespace-phase dest-namespace))) + + (define todo (make-hasheq)) ; module name -> phase -> namespace-or-#f + + (define missing (gensym 'missing)) + + ;; Loop to check and decide what to transfer + (let loop ([mpi (module-path-index-join + (if (resolved-module-path? mod-path) + (resolved-module-path->module-path mod-path) + mod-path) + #f)] + [phase phase] + [attach-instances? attach-instances?] + [attach-phase phase]) + (define mod-name (parameterize ([current-namespace src-namespace]) + (module-path-index-resolve mpi))) + + (define attach-this-instance? (and attach-instances? (eqv? phase attach-phase))) + (define m-ns (hash-ref (hash-ref todo mod-name #hasheqv()) phase missing)) + + (when (or (eq? missing m-ns) + (and attach-this-instance? (not m-ns))) + (define m (namespace->module src-namespace mod-name)) + (unless m + (raise-arguments-error who + "module not declared (in the source namespace)" + "module name" mod-name)) + + (cond + [(and (module-cross-phase-persistent? m) + (not (label-phase? phase)) + (not (zero-phase? phase))) + ;; Always handle a cross-phase persistent module at phase 0, which means + ;; that all phases will get the same instance if any instance is attached + (loop mpi 0 attach-instances? 0)] + [else + (define already-m (namespace->module dest-namespace mod-name)) + (when (and already-m (not (eq? already-m m))) + (raise-arguments-error who + "a different declaration is already in the destination namespace" + "module name" mod-name)) + + (define-values (m-ns already?) + (cond + [(or attach-this-instance? + (module-cross-phase-persistent? m)) + (define m-ns (namespace->module-namespace src-namespace mod-name phase)) + (unless m-ns + (raise-arguments-error who + "module not instantiated (in the source namespace)" + "module name" mod-name)) + + (define already-m-ns (and already-m + (namespace->module-namespace dest-namespace mod-name phase))) + (when (and already-m-ns + (not (eq? m-ns already-m-ns)) + (not (namespace-same-instance? m-ns already-m-ns))) + (raise-arguments-error who + "a different instance is already in the destination namespace" + "module name" mod-name)) + + (values m-ns (and already-m-ns #t))] + [else + (when (and (label-phase? phase) + (not (namespace->module-namespace src-namespace mod-name phase))) + ;; Force instantiation of for-label instance, which ensures that + ;; required modules are declared + (parameterize ([current-namespace src-namespace]) + (namespace-module-instantiate! src-namespace mpi phase))) + + (values #f (and already-m #t))])) + + (hash-update! todo mod-name (lambda (ht) (hash-set ht phase m-ns)) #hasheqv()) + + (unless already? + (for* ([phase+reqs (in-list (module-requires m))] + [req (in-list (cdr phase+reqs))]) + (loop (module-path-index-shift req + (module-self m) + mpi) + (phase+ phase (car phase+reqs)) + attach-instances? + attach-phase)) + (for ([submod-name (in-list (module-submodule-names m))]) + (loop (module-path-index-join `(submod "." ,submod-name) mpi) + ;; Attach submodules at phase #f, which allows + ;; dependencies to be loaded if they're not declared + ;; already, since the submodule has not necessarily + ;; been instantiated + #f + #f + attach-phase)) + (when (module-supermodule-name m) + ;; Associated supermodule is treated like an associated submodule + (loop (module-path-index-join `(submod "..") mpi) #f #f attach-phase)))]))) + + ;; Perform decided transfers + (for* ([(mod-name phases) (in-hash todo)] + [(phase m-ns) (in-hash phases)]) + (define m (namespace->module src-namespace mod-name)) + (module-force-bulk-binding! m src-namespace) + (parameterize ([current-namespace dest-namespace]) + (declare-module! dest-namespace m mod-name)) + (when m-ns + (namespace-record-module-instance-attached! src-namespace mod-name phase) + (or (namespace->module-namespace dest-namespace mod-name phase) + (namespace-install-module-namespace! dest-namespace mod-name phase m m-ns)))) + + ;; Send resolver notifications for attached declarations + (define mnr (current-module-name-resolver)) + (parameterize ([current-namespace dest-namespace]) + (for* ([mod-name (in-hash-keys todo)]) + (mnr mod-name src-namespace)))) diff -Nru racket-6.12+ppa1/src/expander/namespace/core.rkt racket-7.0+ppa1/src/expander/namespace/core.rkt --- racket-6.12+ppa1/src/expander/namespace/core.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/core.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,128 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../expand/env.rkt" + "../syntax/match.rkt" + "../common/module-path.rkt" + "provided.rkt" + "namespace.rkt" + "module.rkt") + +(provide core-stx + core-id + + add-core-form! + add-core-primitive! + + declare-core-module! + + core-module-name + core-mpi + core-form-sym) + +;; Accumulate all core bindings in `core-scope`, so we can +;; easily generate a reference to a core form using `core-stx`: +(define core-scope (new-multi-scope)) +(define core-stx (add-scope empty-syntax core-scope)) + +(define core-module-name (make-resolved-module-path '#%core)) +(define core-mpi (module-path-index-join ''#%core #f)) + +;; The expander needs to synthesize some core references + +(define id-cache-0 (make-hasheq)) +(define id-cache-1 (make-hasheq)) + +(define (core-id sym phase) + (cond + [(eqv? phase 0) + (or (hash-ref id-cache-0 sym #f) + (let ([s (datum->syntax core-stx sym)]) + (hash-set! id-cache-0 sym s) + s))] + [(eq? phase 1) + (or (hash-ref id-cache-1 sym #f) + (let ([s (datum->syntax (syntax-shift-phase-level core-stx 1) sym)]) + (hash-set! id-cache-1 sym s) + s))] + [else + (datum->syntax (syntax-shift-phase-level core-stx phase) sym)])) + +;; Core forms and primitives are added by `require`s in "expander.rkt" + +;; Accumulate added core forms and primitives: +(define core-forms #hasheq()) +(define core-primitives #hasheq()) + +(define-syntax-rule (add-core-form! sym proc) + ;; The `void` wrapper suppress a `print-values` wrapper: + (void (add-core-form!* sym proc))) + +(define (add-core-form!* sym proc) + (add-core-binding! sym) + (set! core-forms (hash-set core-forms + sym + proc))) + +(define (add-core-primitive! sym val) + (add-core-binding! sym) + (set! core-primitives (hash-set core-primitives + sym + val))) + +(define (add-core-binding! sym) + (add-binding! (datum->syntax core-stx sym) + (make-module-binding core-mpi 0 sym) + 0)) + +;; Used only after filling in all core forms and primitives: +(define (declare-core-module! ns) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:no-protected? #t + #:predefined? #t + #:self core-mpi + #:provides + (hasheqv 0 (for/hasheq ([syms (in-list (list core-primitives + core-forms))] + [syntax? (in-list '(#f #t))] + #:when #t + [sym (in-hash-keys syms)]) + (define b (make-module-binding core-mpi 0 sym)) + (values sym (if syntax? (provided b #f #t) b)))) + #:phase-level-linklet-info-callback + (lambda (phase-level ns insp) + (and (zero? phase-level) + (let ([ns (namespace->module-namespace ns core-module-name 0)]) + (and ns + (module-linklet-info (namespace->instance ns 0) + #f + core-mpi + #f + #f + #f))))) + #:instantiate-phase-callback + (lambda (data-box ns phase phase-level self bulk-binding-registry insp) + (case phase-level + [(0) + (for ([(sym val) (in-hash core-primitives)]) + (namespace-set-consistent! ns 0 sym val)) + (for ([(sym proc) (in-hash core-forms)]) + (namespace-set-transformer! ns 0 sym (if (procedure-arity-includes? proc 2) + ;; An actual core form: + (core-form proc sym) + ;; A macro: + proc)))]))) + core-module-name)) + +;; Helper for recognizing and dispatching on core forms: +(define (core-form-sym s phase) + (define-match m s #:try '(id . _)) + (and (m) + (let ([b (resolve+shift (m 'id) phase)]) + (and (module-binding? b) + (eq? core-module-name (module-path-index-resolve (module-binding-module b))) + (module-binding-sym b))))) diff -Nru racket-6.12+ppa1/src/expander/namespace/inspector.rkt racket-7.0+ppa1/src/expander/namespace/inspector.rkt --- racket-6.12+ppa1/src/expander/namespace/inspector.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/inspector.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(provide current-module-code-inspector) + +;; Parameter to select inspector for functions like `syntax-arm` +(define current-module-code-inspector (make-parameter #f)) diff -Nru racket-6.12+ppa1/src/expander/namespace/module.rkt racket-7.0+ppa1/src/expander/namespace/module.rkt --- racket-6.12+ppa1/src/expander/namespace/module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,560 @@ +#lang racket/base +(require "../common/phase.rkt" + "../common/small-hash.rkt" + "../common/performance.rkt" + "../syntax/bulk-binding.rkt" + "../syntax/module-binding.rkt" + "../common/module-path.rkt" + "../compile/module-use.rkt" + "../expand/root-expand-context.rkt" + "../host/linklet.rkt" + "namespace.rkt" + "provided.rkt" + "registry.rkt" + (submod "namespace.rkt" for-module)) + +(provide make-module-namespace + raise-unknown-module-error + + namespace->module-instance + namespace->module-namespace + namespace-install-module-namespace! + namespace-record-module-instance-attached! + module-force-bulk-binding! + + namespace->module-linklet-info + (struct-out module-linklet-info) + + make-module + declare-module! + module-self + module-requires + module-provides + module-primitive? + module-is-predefined? + module-cross-phase-persistent? + module-no-protected? + module-inspector + module-submodule-names + module-supermodule-name + module-get-all-variables + module-access + module-compute-access! + + module-instance-namespace + module-instance-module + + namespace-module-instantiate! + namespace-module-visit! + namespace-module-make-available! + namespace-primitive-module-visit! + namespace-visit-available-modules! + namespace-run-available-modules! + + namespace-module-use->module+linklet-instances) + +(module+ for-module-reflect + (provide (struct-out module))) + +;; ---------------------------------------- + +(struct module (source-name ; #f, symbol, or complete path + self ; module path index used for a self reference + requires ; list of (cons phase list-of-module-path-index) + provides ; phase-level -> sym -> binding or (provided binding bool bool); see [*] below + [access #:mutable] ; phase-level -> sym -> 'provided or 'protected; computed on demand from `provides` + language-info ; #f or vector + min-phase-level ; phase-level + max-phase-level ; phase-level + phase-level-linklet-info-callback ; phase-level namespace -> module-linklet-info-or-#f + force-bulk-binding ; bulk-binding-registry -> any + prepare-instance ; box namespace phase-shift bulk-binding-registry inspector -> any + instantiate-phase ; box namespace phase-shift phase-level bulk-binding-registry inspector -> any + primitive? ; inline variable values in compiled code? + is-predefined? ; always defined on startup? + cross-phase-persistent? + no-protected? ; short cut for checking protected access + inspector ; declaration-time inspector + submodule-names ; associated submodules (i.e, when declared together) + supermodule-name ; associated supermodule (i.e, when declared together) + get-all-variables) ; for `module->indirect-exports` + #:authentic) + +;; [*] Beware that tabels in `provides` may map non-interned symbols +;; to provided bindings, in case something like a lifted +;; identifier was provided. Since lifting generates a locally +;; deterministic unreadable symbol that is intended to be specific +;; to a particular module, `require`ing unreadable symbols can +;; create collisions. Still, the provided binding is supposed to +;; be accessible via `dynamic-require`. + +(struct module-linklet-info (linklet-or-instance ; #f, linklet, or instance supplied for cross-linking optimization + module-uses ; #f or vector for linklet's imports + self ; self modidx + inspector ; declaration-time inspector + extra-inspector ; optional extra inspector + extra-inspectorsss) ; optional extra inspector sets per variable per import + #:authentic + #:transparent) + +(define (make-module #:source-name [source-name #f] + #:self self + #:requires [requires null] + #:provides provides + #:min-phase-level [min-phase-level 0] + #:max-phase-level [max-phase-level 0] + #:instantiate-phase-callback instantiate-phase + #:force-bulk-binding-callback [force-bulk-binding void] + #:prepare-instance-callback [prepare-instance void] + #:phase-level-linklet-info-callback [phase-level-linklet-info-callback + (lambda (phase-level ns insp) #f)] + #:language-info [language-info #f] + #:primitive? [primitive? #f] + #:predefined? [predefined? #f] + #:cross-phase-persistent? [cross-phase-persistent? primitive?] + #:no-protected? [no-protected? #f] + #:submodule-names [submodule-names null] + #:supermodule-name [supermodule-name #f] + #:get-all-variables [get-all-variables (lambda () null)]) ; ok to omit exported + (module source-name + self + (unresolve-requires requires) + provides + #f ; access + language-info + min-phase-level max-phase-level + phase-level-linklet-info-callback + force-bulk-binding + prepare-instance + instantiate-phase + primitive? + predefined? + cross-phase-persistent? + no-protected? + (current-code-inspector) + submodule-names + supermodule-name + get-all-variables)) + +(struct module-instance (namespace + module ; can be #f for the module being expanded + [shifted-requires #:mutable] ; computed on demand; shifted from `module-requires` + phase-level-to-state ; phase-level -> #f, 'available, or 'started + [made-available? #:mutable] ; no #f in `phase-level-to-state`? + [attached? #:mutable] ; whether the instance has been attached elsewhere + data-box) ; for use by module implementation + #:authentic) + +(define (make-module-instance m-ns m) + (module-instance m-ns ; namespace + m ; module + #f ; shifted-requires (not yet computed) + (make-small-hasheqv) ; phase-level-to-state + #f ; made-available? + #f ; attached? + (box #f))) ; data-box + +;; ---------------------------------------- + +;; Create a namespace for expanding a module +(define (make-module-namespace ns + #:mpi name-mpi + #:root-expand-context root-expand-ctx + #:for-submodule? for-submodule?) + (define phase 0) ; always start at 0 when compiling a module + (define name (module-path-index-resolve name-mpi)) + (define m-ns + ;; Keeps all module declarations, but makes a fresh space of instances + (struct-copy namespace (new-namespace ns + #:root-expand-ctx root-expand-ctx + #:register? #f) + [mpi name-mpi] + [source-name (resolved-module-path-root-name name)] + [phase phase] + [0-phase phase] + [submodule-declarations (if for-submodule? + ;; Same set of submodules: + (namespace-submodule-declarations ns) + ;; Fresh set of submodules: + (make-small-hasheq))] + [available-module-instances (make-hasheqv)] + [module-instances (make-hasheqv)] + [declaration-inspector (current-code-inspector)])) + (small-hash-set! (namespace-phase-to-namespace m-ns) phase m-ns) + (define at-phase (make-hasheq)) + (hash-set! (namespace-module-instances m-ns) phase at-phase) + (hash-set! at-phase name (make-module-instance m-ns #f)) + m-ns) + +;; ---------------------------------------- + +(define (declare-module! ns m mod-name #:with-submodules? [with-submodules? #t]) + (define prior-m (and with-submodules? + (hash-ref (module-registry-declarations (namespace-module-registry ns)) + mod-name + #f))) + (define prior-mi (and prior-m + (not (eq? m prior-m)) + (namespace->module-instance ns mod-name (namespace-phase ns)))) + (when (and prior-m (not (eq? m prior-m))) + (check-redeclaration-ok prior-m prior-mi mod-name)) + (if with-submodules? + (hash-set! (module-registry-declarations (namespace-module-registry ns)) mod-name m) + (small-hash-set! (namespace-submodule-declarations ns) mod-name m)) + (when with-submodules? + ;; Register this module's exports for use in resolving bulk + ;; bindings, so that bulk bindings can be shared among other + ;; modules when unmarshaling; we don't do this without + ;; `with-submodules?` to avoid loeaking submodules being + ;; expanded, but see also `bind-all-provides!` + (register-bulk-provide! (namespace-bulk-binding-registry ns) + mod-name + (module-self m) + (module-provides m)) + ;; Tell resolver that the module is declared + ((current-module-name-resolver) mod-name #f)) + ;; If this module is already instantiated, re-instantiate it + (when prior-mi + (define m-ns (module-instance-namespace prior-mi)) + (define states (module-instance-phase-level-to-state prior-mi)) + (define phase (namespace-phase ns)) + (define visit? (eq? 'started (small-hash-ref states (add1 phase) #f))) + (define run? (eq? 'started (small-hash-ref states phase #f))) + + (define at-phase (hash-ref (namespace-module-instances ns) phase)) + (hash-set! at-phase mod-name (make-module-instance m-ns m)) + + (when visit? + (namespace-module-visit! ns (namespace-mpi m-ns) phase)) + (when run? + (namespace-module-instantiate! ns (namespace-mpi m-ns) phase)))) + +(define (check-redeclaration-ok prior-m prior-mi mod-name) + (when (module-cross-phase-persistent? prior-m) + (raise-arguments-error 'module + "cannot redeclare cross-phase persistent module" + "module name" mod-name)) + (when (and prior-mi + (or (module-instance-attached? prior-mi) + (not (inspector-superior? (current-code-inspector) + (namespace-inspector (module-instance-namespace prior-mi)))))) + (raise-arguments-error 'module + "current code inspector cannot redeclare module" + "module name" mod-name))) + +(define (raise-unknown-module-error who mod-name) + (raise-arguments-error who + "unknown module" + "module name" mod-name)) + +(define (namespace->module-linklet-info ns name phase-level) + (define m (namespace->module ns name)) + (and m + ((module-phase-level-linklet-info-callback m) phase-level ns (module-inspector m)))) + +;; ---------------------------------------- + +(define (namespace->module-instance ns name 0-phase + #:complain-on-failure? [complain-on-failure? #f] + #:check-available-at-phase-level [check-available-at-phase-level #f] + #:unavailable-callback [unavailable-callback void]) + (define mi + (or (hash-ref (hash-ref (namespace-module-instances ns) 0-phase #hasheq()) + name + #f) + (let ([c-ns (or (namespace-root-namespace ns) ns)]) + (hash-ref (namespace-module-instances c-ns) name #f)) + (and complain-on-failure? + (error "no module instance found:" name 0-phase)))) + (if (and mi check-available-at-phase-level) + (check-availablilty mi check-available-at-phase-level unavailable-callback) + mi)) + +(define (namespace-install-module-namespace! ns name 0-phase m existing-m-ns) + (define m-ns (struct-copy namespace ns + [mpi (namespace-mpi existing-m-ns)] + [source-name (namespace-source-name existing-m-ns)] + [root-expand-ctx (box (unbox (namespace-root-expand-ctx existing-m-ns)))] + [phase (namespace-phase existing-m-ns)] + [0-phase (namespace-0-phase existing-m-ns)] + [phase-to-namespace (make-small-hasheqv)] + [phase-level-to-definitions (if (module-cross-phase-persistent? m) + (namespace-phase-level-to-definitions existing-m-ns) + (make-small-hasheqv))] + [declaration-inspector (module-inspector m)] + [inspector (namespace-inspector existing-m-ns)])) + (define mi (make-module-instance m-ns m)) + (cond + [(module-cross-phase-persistent? m) + (small-hash-set! (namespace-phase-to-namespace m-ns) 0 m-ns) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 0 + (namespace->definitions existing-m-ns 0)) + (small-hash-set! (namespace-phase-to-namespace m-ns) 1 (namespace->namespace-at-phase m-ns 1)) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 1 + (namespace->definitions existing-m-ns 1)) + (hash-set! (namespace-module-instances (or (namespace-root-namespace ns) ns)) + name + mi) + (small-hash-set! (module-instance-phase-level-to-state mi) 0 'started)] + [else + (small-hash-set! (namespace-phase-to-namespace m-ns) 0-phase m-ns) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 0 + (namespace->definitions existing-m-ns 0)) + (small-hash-set! (module-instance-phase-level-to-state mi) 0 'started) + (define at-phase (or (hash-ref (namespace-module-instances ns) 0-phase #f) + (let ([at-phase (make-hasheq)]) + (hash-set! (namespace-module-instances ns) 0-phase at-phase) + at-phase))) + (hash-set! at-phase name mi)])) + +(define (namespace-create-module-instance! ns name 0-phase m mpi) + (define m-ns (struct-copy namespace ns + [mpi mpi] + [source-name (or (module-source-name m) + (resolved-module-path-root-name + (module-path-index-resolve mpi)))] + [root-expand-ctx (box #f)] ; maybe set to non-#f by running + [phase 0-phase] + [0-phase 0-phase] + [phase-to-namespace (make-small-hasheqv)] + [phase-level-to-definitions (make-small-hasheqv)] + [declaration-inspector (module-inspector m)] + [inspector (make-inspector (module-inspector m))])) + (small-hash-set! (namespace-phase-to-namespace m-ns) 0-phase m-ns) + (define mi (make-module-instance m-ns m)) + (if (module-cross-phase-persistent? m) + (hash-set! (namespace-module-instances ns) name mi) + (let ([at-phase (or (hash-ref (namespace-module-instances ns) 0-phase #f) + (let ([at-phase (make-hasheq)]) + (hash-set! (namespace-module-instances ns) 0-phase at-phase) + at-phase))]) + (hash-set! at-phase name mi))) + mi) + +(define (check-availablilty mi check-available-at-phase-level unavailable-callback) + (define m (module-instance-module mi)) + (if (and m + (<= (module-min-phase-level m) (add1 check-available-at-phase-level) (module-max-phase-level m)) + (not (small-hash-ref (module-instance-phase-level-to-state mi) (add1 check-available-at-phase-level) #f))) + (unavailable-callback mi) + mi)) + +(define (namespace->module-namespace ns name 0-phase + #:complain-on-failure? [complain-on-failure? #f] + #:check-available-at-phase-level [check-available-at-phase-level #f] + #:unavailable-callback [unavailable-callback void]) + (define mi (namespace->module-instance ns name 0-phase + #:complain-on-failure? complain-on-failure? + #:check-available-at-phase-level check-available-at-phase-level + #:unavailable-callback unavailable-callback)) + (and mi (module-instance-namespace mi))) + +(define (namespace-record-module-instance-attached! ns mod-name phase) + (define mi (namespace->module-instance ns mod-name phase)) + (set-module-instance-attached?! mi #t)) + +;; Before attaching amodule declaration to a new namespace, make sure +;; that its syntax deserialization is associated with the original +;; bulk-binding regsitry +(define (module-force-bulk-binding! m ns) + ((module-force-bulk-binding m) (namespace-bulk-binding-registry ns))) + +;; ---------------------------------------- + +;; Create a module instance as needed, and then run the specified phase; +;; see also `run-module-instance!`, below +(define (namespace-module-instantiate! ns mpi instance-phase #:run-phase [run-phase (namespace-phase ns)] + #:skip-run? [skip-run? #f] + #:otherwise-available? [otherwise-available? #t] + #:seen [seen #hasheq()]) + (unless (module-path-index? mpi) + (error "not a module path index:" mpi)) + (define name (module-path-index-resolve mpi #t)) + (define m (namespace->module ns name)) + (unless m (raise-unknown-module-error 'instantiate name)) + (define (instantiate! instance-phase run-phase ns) + ;; Get or create a namespace for the module+phase combination: + (define mi (or (namespace->module-instance ns name instance-phase) + (namespace-create-module-instance! ns name instance-phase m mpi))) + (run-module-instance! mi ns #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen seen)) + ;; If the module is cross-phase persistent, make sure it's instantiated + ;; at phase 0 and registered in `ns` as phaseless; otherwise + (cond + [(module-cross-phase-persistent? m) + (instantiate! 0 0 (or (namespace-root-namespace ns) ns))] + [else + (instantiate! instance-phase run-phase ns)])) + +(define (namespace-module-visit! ns mpi instance-phase #:visit-phase [visit-phase (namespace-phase ns)]) + (namespace-module-instantiate! ns mpi instance-phase #:run-phase (add1 visit-phase))) + +(define (namespace-module-make-available! ns mpi instance-phase #:visit-phase [visit-phase (namespace-phase ns)]) + (namespace-module-instantiate! ns mpi instance-phase #:run-phase (add1 visit-phase) #:skip-run? #t)) + +;; The `instance-phase` corresponds to the phase shift for the module +;; instances. The module may have content at different phase levels, +;; which are all consistently shifted. The `run-phase` is an absolute +;; phase that should be immediately run, unless `skip-run?` is true; +;; to put it another way, phase level `(phase- instance-phase +;; run-phase)` within the instance should be run immediately. +;; Normally, the instance is made available at all other non-negative +;; phases, but `#:otherwise-available?` controls that behavior. +(define (run-module-instance! mi ns #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen [seen #hasheq()]) + (performance-region + ['eval 'requires] + ;; Nothing to do if we've run this phase already and made the + ;; instance sufficiently available: + (define m-ns (module-instance-namespace mi)) + (define instance-phase (namespace-0-phase m-ns)) + (define run-phase-level (phase- run-phase instance-phase)) + (unless (and (or skip-run? + (eq? 'started (small-hash-ref (module-instance-phase-level-to-state mi) run-phase-level #f))) + (or (not otherwise-available?) + (module-instance-made-available? mi))) + ;; Something to do... + (define m (module-instance-module mi)) + (unless m + (error 'require "import cycle detected; trying to run module being expanded")) + (define mpi (namespace-mpi m-ns)) + (define phase-shift instance-phase) ; instance phase = phase shift + (define bulk-binding-registry (namespace-bulk-binding-registry m-ns)) + + (when (hash-ref seen mi #f) + (error 'require "import cycle detected during module instantiation")) + + ;; If we haven't shifted required mpis already, do that + (unless (module-instance-shifted-requires mi) + (set-module-instance-shifted-requires! + mi + (for/list ([phase+mpis (in-list (module-requires m))]) + (cons (car phase+mpis) + (for/list ([req-mpi (in-list (cdr phase+mpis))]) + (module-path-index-shift req-mpi + (module-self m) + mpi)))))) + + ;; Recur for required modules: + (for ([phase+mpis (in-list (module-instance-shifted-requires mi))]) + (define req-phase (car phase+mpis)) + (for ([req-mpi (in-list (cdr phase+mpis))]) + (namespace-module-instantiate! ns req-mpi (phase+ instance-phase req-phase) + #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen (hash-set seen mi #t)))) + + ;; Run or make available phases of the module body: + (unless (label-phase? instance-phase) + (for ([phase-level (in-range (module-max-phase-level m) (sub1 (module-min-phase-level m)) -1)]) + (define phase (phase+ phase-level phase-shift)) + (cond + [(and (not skip-run?) + (eqv? phase run-phase)) + ;; This is the phase to make sure that we've run + (unless (eq? 'started (small-hash-ref (module-instance-phase-level-to-state mi) phase-level #f)) + (small-hash-set! (module-instance-phase-level-to-state mi) phase-level 'started) + (void (namespace->definitions m-ns phase-level)) + (define p-ns (namespace->namespace-at-phase m-ns phase)) + (define insp (module-inspector m)) + (define data-box (module-instance-data-box mi)) + (define prep (module-prepare-instance m)) + (define go (module-instantiate-phase m)) + (prep data-box p-ns phase-shift mpi bulk-binding-registry insp) + (go data-box p-ns phase-shift phase-level mpi bulk-binding-registry insp))] + [(and otherwise-available? + (not (negative? run-phase)) + (not (small-hash-ref (module-instance-phase-level-to-state mi) phase-level #f))) + ;; This is a phase to merely make available + (hash-update! (namespace-available-module-instances ns) + phase + (lambda (l) (cons mi l)) + null) + (small-hash-set! (module-instance-phase-level-to-state mi) phase-level 'available)]))) + + (when otherwise-available? + (set-module-instance-made-available?! mi #t)) + + (unless skip-run? + ;; In case there's no such phase for this module instance, claim 'started + ;; to short-circuit future attempts: + (small-hash-set! (module-instance-phase-level-to-state mi) run-phase-level 'started))))) + +(define (namespace-visit-available-modules! ns [run-phase (namespace-phase ns)]) + (namespace-run-available-modules! ns (add1 run-phase))) + +(define (namespace-run-available-modules! ns [run-phase (namespace-phase ns)]) + (registry-call-with-lock + (namespace-module-registry ns) + (lambda () + (let loop () + (define mis (hash-ref (namespace-available-module-instances ns) run-phase null)) + (unless (null? mis) + (hash-set! (namespace-available-module-instances ns) run-phase null) + (for ([mi (in-list (reverse mis))]) + (run-module-instance! mi ns #:run-phase run-phase #:skip-run? #f #:otherwise-available? #f)) + ;; In case instantiation added more reflectively: + (loop)))))) + +(define (namespace-primitive-module-visit! ns name) + (define mi (hash-ref (namespace-module-instances ns) (make-resolved-module-path name))) + (run-module-instance! mi ns #:run-phase 1 #:skip-run? #f #:otherwise-available? #t)) + +;; ---------------------------------------- + +(define (namespace-module-use->module+linklet-instances ns mu + #:shift-from [shift-from #f] + #:shift-to [shift-to #f] + #:phase-shift phase-shift) + (define mod (module-use-module mu)) + (define mi + (namespace->module-instance ns + (module-path-index-resolve + (if shift-from + (module-path-index-shift mod shift-from shift-to) + mod)) + phase-shift + #:complain-on-failure? #t)) + (define m-ns (module-instance-namespace mi)) + (define d (small-hash-ref (namespace-phase-level-to-definitions m-ns) (module-use-phase mu) #f)) + (if d + (values mi (definitions-variables d)) + (error 'eval (string-append "namespace mismatch: phase level not found;\n" + " module: ~a\n" + " phase level: ~a\n" + " found phase levels: ~a") + mod + (module-use-phase mu) + (small-hash-keys (namespace-phase-level-to-definitions m-ns))))) + +;; ---------------------------------------- + +;; ensure that each module path index is unresolved, so that resolving +;; on instantiation will trigger module loads +(define (unresolve-requires requires) + (for/list ([phase+mpis (in-list requires)]) + (cons (car phase+mpis) + (for/list ([req-mpi (in-list (cdr phase+mpis))]) + (module-path-index-unresolve req-mpi))))) + +;; ---------------------------------------- + +(define (module-compute-access! m) + (define access + (for/hasheqv ([(phase at-phase) (in-hash (module-provides m))]) + (values phase + (for/hash ([(sym binding/p) (in-hash at-phase)]) + (values (module-binding-sym (provided-as-binding binding/p)) + (if (provided-as-protected? binding/p) + 'protected + 'provided)))))) + (set-module-access! m access) + access) diff -Nru racket-6.12+ppa1/src/expander/namespace/namespace.rkt racket-7.0+ppa1/src/expander/namespace/namespace.rkt --- racket-6.12+ppa1/src/expander/namespace/namespace.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/namespace.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,213 @@ +#lang racket/base +(require racket/promise + "../common/phase.rkt" + "../common/small-hash.rkt" + "../syntax/bulk-binding.rkt" + "../common/module-path.rkt" + "../expand/root-expand-context.rkt" + "../host/linklet.rkt" + "registry.rkt") + +(provide make-namespace + new-namespace + namespace? + current-namespace + namespace-module-registry + namespace-phase + namespace-0-phase + namespace-root-namespace + namespace-get-root-expand-ctx + namespace-set-root-expand-ctx! + namespace-self-mpi + namespace->namespace-at-phase + namespace->module + namespace-mpi + namespace-source-name + namespace-bulk-binding-registry + + namespace-set-variable! + namespace-set-consistent! + namespace-unset-variable! + namespace-set-transformer! + namespace-unset-transformer! + namespace-get-variable + namespace-get-transformer + + namespace-declaration-inspector + namespace-inspector + set-namespace-inspector! + + namespace->instance + namespace-same-instance?) + +(module+ for-module + (provide (struct-out namespace) + (struct-out module-registry) + (struct-out definitions) + namespace->definitions)) + +(struct namespace (mpi ; module path index (that's already resolved); instance-specific for a module + source-name ; #f (top-level) or symbol or complete path; user-facing alternative to the mpi + root-expand-ctx ; delay of box of context for top-level expansion; set by module instantiation + phase ; phase (not phase level!) of this namespace + 0-phase ; phase of module instance's phase-level 0 + phase-to-namespace ; phase -> namespace for same module [shared for the same module instance] + phase-level-to-definitions ; phase-level -> definitions [shared for the same module instance] + module-registry ; module-registry of (resolved-module-path -> module) [shared among modules] + bulk-binding-registry ; (resolved-module-path -> bulk-provide) for resolving bulk bindings on unmarshal + submodule-declarations ; resolved-module-path -> module [shared during a module compilation] + root-namespace ; #f or namespace for #lang, #reader, and persistent instances [shared among modules] + declaration-inspector ; declaration-time inspector + [inspector #:mutable] ; instantiation-time inspector + available-module-instances ; phase -> list of module-instance [shared among modules] + module-instances) ; union resolved-module-path -> module-instance [shared among modules] + ;; ; 0-phase -> resolved-module-path -> module-instance + ;; ; where the first option is for cross phase persistent modules + #:authentic + #:property prop:custom-write + (lambda (ns port mode) + (write-string "#name ns))) + (define 0-phase (namespace-0-phase ns)) + (define phase-level (phase- (namespace-phase ns) + 0-phase)) + (unless (zero-phase? phase-level) + (fprintf port ":~s" phase-level)) + (unless (zero-phase? 0-phase) + (fprintf port "~a~s" (if (positive? 0-phase) "+" "") 0-phase)) + (write-string ">" port))) + +(struct definitions (variables ; linklet instance + transformers) ; sym -> val + #:authentic) + +(define (make-namespace) + (new-namespace)) + +(define (new-namespace [share-from-ns #f] + #:root-expand-ctx [root-expand-ctx (make-root-expand-context + #:self-mpi top-level-module-path-index)] + #:register? [register? #t]) + (define phase (if share-from-ns + (namespace-phase share-from-ns) + 0)) + (define ns + (namespace top-level-module-path-index + #f + (box root-expand-ctx) + phase + phase + (make-small-hasheqv) ; phase-to-namespace + (make-small-hasheqv) ; phase-level-to-definitions + (if share-from-ns + (namespace-module-registry share-from-ns) + (make-module-registry)) + (if share-from-ns + (namespace-bulk-binding-registry share-from-ns) + (make-bulk-binding-registry)) + (make-small-hasheq) ; submodule-declarations + (and share-from-ns + (or (namespace-root-namespace share-from-ns) + share-from-ns)) + #f ; no declaration-time inspector for a top-level namespace + (make-inspector (current-code-inspector)) + (if share-from-ns + (namespace-available-module-instances share-from-ns) + (make-hasheqv)) + (if share-from-ns + (namespace-module-instances share-from-ns) + (make-hasheqv)))) + (when register? + (small-hash-set! (namespace-phase-to-namespace ns) phase ns)) + ns) + +(define current-namespace (make-parameter (make-namespace) + (lambda (v) + (unless (namespace? v) + (raise-argument-error 'current-namespace + "namespace?" + v)) + v))) + +(define (namespace-get-root-expand-ctx ns) + (force (unbox (namespace-root-expand-ctx ns)))) + +(define (namespace-set-root-expand-ctx! ns root-ctx) + (set-box! (namespace-root-expand-ctx ns) root-ctx)) + +(define (namespace-self-mpi ns) + (root-expand-context-self-mpi (namespace-get-root-expand-ctx ns))) + +(define (namespace->module ns name) + (or (small-hash-ref (namespace-submodule-declarations ns) name #f) + (hash-ref (module-registry-declarations (namespace-module-registry ns)) name #f))) + +(define (namespace->namespace-at-phase ns phase) + (or (small-hash-ref (namespace-phase-to-namespace ns) phase #f) + (let ([p-ns (struct-copy namespace ns + [phase phase])]) + (small-hash-set! (namespace-phase-to-namespace ns) phase p-ns) + p-ns))) + +(define (namespace->name ns) + (define n (namespace-source-name ns)) + (define s + (cond + [(not n) 'top-level] + [(symbol? n) (format "'~s" n)] + [else (string-append "\"" (path->string n) "\"")])) + (define r (resolved-module-path-name (module-path-index-resolve (namespace-mpi ns)))) + (if (pair? r) + (string-append "(submod " s " " (substring (format "~s" (cdr r)) 1)) + s)) + +(define (namespace->definitions ns phase-level) + (define d (small-hash-ref (namespace-phase-level-to-definitions ns) phase-level #f)) + (or d + (let () + (define p-ns (namespace->namespace-at-phase ns (phase+ (namespace-0-phase ns) + phase-level))) + (define d (definitions (make-instance (namespace->name p-ns) p-ns) (make-hasheq))) + (small-hash-set! (namespace-phase-level-to-definitions ns) phase-level d) + d))) + +(define (namespace-set-variable! ns phase-level name val [as-constant? #f]) + (define d (namespace->definitions ns phase-level)) + (instance-set-variable-value! (definitions-variables d) name val (and as-constant? 'constant))) + +(define (namespace-set-consistent! ns phase-level name val) + (define d (namespace->definitions ns phase-level)) + (instance-set-variable-value! (definitions-variables d) name val 'consistent)) + +(define (namespace-unset-variable! ns phase-level name) + (define d (namespace->definitions ns phase-level)) + (instance-unset-variable! (definitions-variables d) name)) + +(define (namespace-set-transformer! ns phase-level name val) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-set! (definitions-transformers d) name val)) + +(define (namespace-unset-transformer! ns phase-level name) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-remove! (definitions-transformers d) name)) + +(define (namespace-get-variable ns phase-level name fail-k) + (define d (namespace->definitions ns phase-level)) + (instance-variable-value (definitions-variables d) name fail-k)) + +(define (namespace-get-transformer ns phase-level name fail-k) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-ref (definitions-transformers d) name fail-k)) + +(define (namespace->instance ns phase-shift) + (definitions-variables (namespace->definitions ns phase-shift))) + +(define (namespace-same-instance? a-ns b-ns) + (eq? (small-hash-ref (namespace-phase-level-to-definitions a-ns) + 0 + 'no-a) + (small-hash-ref (namespace-phase-level-to-definitions b-ns) + 0 + 'no-b))) diff -Nru racket-6.12+ppa1/src/expander/namespace/primitive-module.rkt racket-7.0+ppa1/src/expander/namespace/primitive-module.rkt --- racket-6.12+ppa1/src/expander/namespace/primitive-module.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/primitive-module.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,35 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../host/linklet.rkt" + "namespace.rkt" + "module.rkt" + "provided.rkt") + +;; Used from the virtual machine to support C "extensions" that +;; declare modules + +(provide declare-primitive-module!) + +(define (declare-primitive-module! name inst in-ns protected cross-phase-persistent?) + (define mpi (module-path-index-join (list 'quote name) #f)) + (declare-module! + in-ns + (make-module #:source-name (current-module-declare-source) + #:cross-phase-persistent? cross-phase-persistent? + #:no-protected? (zero? (hash-count protected)) + #:self mpi + #:provides + (hasheqv 0 (for/hash ([sym (in-list (instance-variable-names inst))]) + (define binding (make-module-binding mpi 0 sym)) + (values sym + (if (hash-ref protected sym #f) + (provided binding #t #f) + binding)))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (when (= 0 phase-level) + (for ([sym (in-list (instance-variable-names inst))]) + (define val (instance-variable-value inst sym)) + (namespace-set-variable! ns 0 sym val))))) + (substitute-module-declare-name name))) diff -Nru racket-6.12+ppa1/src/expander/namespace/provided.rkt racket-7.0+ppa1/src/expander/namespace/provided.rkt --- racket-6.12+ppa1/src/expander/namespace/provided.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/provided.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require "../compile/serialize-property.rkt") + +(provide (struct-out provided) + provided-as-binding + provided-as-protected? + provided-as-transformer? + + deserialize-provided) + +;; Wrapper for provides that are protected or syntax +(struct provided (binding protected? syntax?) + #:authentic + #:transparent + #:property prop:serialize + (lambda (p ser-push! state) + (ser-push! 'tag '#:provided) + (ser-push! (provided-binding p)) + (ser-push! (provided-protected? p)) + (ser-push! (provided-syntax? p)))) + +(define (provided-as-binding v) + (if (provided? v) (provided-binding v) v)) +(define (provided-as-protected? v) + (and (provided? v) (provided-protected? v))) +(define (provided-as-transformer? v) + (and (provided? v) (provided-syntax? v))) + +(define (deserialize-provided binding protected? syntax?) + (provided binding protected? syntax?)) diff -Nru racket-6.12+ppa1/src/expander/namespace/provide-for-api.rkt racket-7.0+ppa1/src/expander/namespace/provide-for-api.rkt --- racket-6.12+ppa1/src/expander/namespace/provide-for-api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/provide-for-api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,53 @@ +#lang racket/base +(require "provided.rkt" + "../common/phase.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt") + +(provide provides->api-provides + variables->api-nonprovides) + +(define (provides->api-provides provides self) + (define (extract ok?) + (define result-l + (for*/list ([(phase at-phase) (in-hash provides)] + [l (in-value + (for/list ([(sym b/p) (in-hash at-phase)] + #:when (ok? b/p)) + (define b (provided-as-binding b/p)) + (list sym + (cond + [(eq? self (module-binding-module b)) + null] + [else + (for/list ([b (in-list (cons b (module-binding-extra-nominal-bindings b)))]) + (cond + [(and (eqv? (module-binding-nominal-phase b) + phase) + (eq? (module-binding-nominal-sym b) sym)) + (module-binding-nominal-module b)] + [else + (list (module-binding-nominal-module b) + (module-binding-phase b) + (module-binding-nominal-sym b) + (module-binding-nominal-phase b))]))]))))] + #:unless (null? l)) + (cons phase (sort l symbolapi-nonprovides provides all-vars) + ;; Filter provideded from list of all variables + (define result-l + (for/list ([(phase vars) (in-hash all-vars)] + #:when #t + [l (in-value + (let ([syms (hash-ref provides phase #hasheq())]) + (for/list ([var-sym (in-list vars)] + #:unless (hash-ref syms var-sym #f)) + var-sym)))] + #:unless (null? l)) + (cons phase (sort l symbol module + lock-box)) ; reentrant lock to guard registry for use by on-demand visits + +(define (make-module-registry) + (module-registry (make-hasheq) (box #f))) + +(define (registry-call-with-lock r proc) + (define lock-box (module-registry-lock-box r)) + (let loop () + (define v (unbox lock-box)) + (cond + [(or (not v) + (sync/timeout 0 (car v) (cdr v))) + (define sema (make-semaphore)) + (define lock (cons (semaphore-peek-evt sema) (current-thread))) + ((dynamic-wind + void + (lambda () + (cond + [(box-cas! lock-box v lock) + (proc) + void] + [else + ;; CAS failed; take it from the top + (lambda () (loop))])) + (lambda () + (semaphore-post sema))))] + [(eq? (current-thread) (cdr v)) + ;; This thread already holds the lock + (proc)] + [else + ; Wait and try again: + (sync (car v) (cdr v)) + (loop)]))) diff -Nru racket-6.12+ppa1/src/expander/namespace/variable-reference.rkt racket-7.0+ppa1/src/expander/namespace/variable-reference.rkt --- racket-6.12+ppa1/src/expander/namespace/variable-reference.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/namespace/variable-reference.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,86 @@ +#lang racket/base +(require "namespace.rkt" + "../common/contract.rkt" + "../common/module-path.rkt" + "../host/linklet.rkt" + "module.rkt" + "api-module.rkt") + +(provide variable-reference? ; provided by linklet layer, along with `#%variable-reference` + variable-reference-constant? ; provided by linklet layer + variable-reference-from-unsafe? ; provided by linklet layer + + variable-reference->empty-namespace + variable-reference->namespace + variable-reference->module-path-index + variable-reference->resolved-module-path + variable-reference->module-source + variable-reference->phase + variable-reference->module-base-phase + variable-reference->module-declaration-inspector) + +(define/who (variable-reference->empty-namespace vr) + (check who variable-reference? vr) + (new-namespace (variable-reference->namespace vr))) + +(define/who (variable-reference->namespace vr) + (check who variable-reference? vr) + (define ns (variable-reference->namespace* vr)) + (define mpi (namespace-mpi ns)) + (when (non-self-module-path-index? mpi) + ;; Ensure that the module is available + (parameterize ([current-namespace ns]) + (namespace-module-make-available! ns mpi (namespace-0-phase ns)))) + ns) + +(define (variable-reference->namespace* vr) + (define inst (variable-reference->instance vr)) + (cond + [(symbol? inst) + ;; This case happens for `(#%variable-reference id)` where `id` + ;; refers directly to a primitive. The expander doesn't currently + ;; generate that, but just in case... We get a namespace for a + ;; primitive instance; that might not be the same module as + ;; reorted by `identifier-binding`, but close enough. + (module->namespace `',inst (instance-data (variable-reference->instance vr #t)))] + [(not inst) + ;; Anonymous variable reference; use the referencing namespace + (instance-data (variable-reference->instance vr #t))] + [else + ;; Get the defining namespace for the referenced variable + (instance-data inst)])) + +(define/who (variable-reference->module-path-index vr) + (check who variable-reference? vr) + (define mpi (namespace-mpi (variable-reference->namespace* vr))) + (if (top-level-module-path-index? mpi) + #f + mpi)) + +(define/who (variable-reference->resolved-module-path vr) + (check who variable-reference? vr) + (define mpi (variable-reference->module-path-index vr)) + (and mpi (module-path-index-resolve mpi))) + +(define/who (variable-reference->module-source vr) + (check who variable-reference? vr) + (define ns (variable-reference->namespace* vr)) + (namespace-source-name ns)) + +(define/who (variable-reference->phase vr) + (check who variable-reference? vr) + (namespace-phase (variable-reference->namespace* vr))) + +(define/who (variable-reference->module-base-phase vr) + (check who variable-reference? vr) + (namespace-0-phase (variable-reference->namespace* vr))) + +(define/who (variable-reference->module-declaration-inspector vr) + (check who variable-reference? vr) + (when (variable-reference->instance vr) + (raise-arguments-error who + "variable reference does not refer to an anonymous module variable" + "variable reference" vr)) + (or (namespace-declaration-inspector (variable-reference->namespace* vr)) + (raise-arguments-error who + "given variable reference is not from a module"))) diff -Nru racket-6.12+ppa1/src/expander/read/accum-string.rkt racket-7.0+ppa1/src/expander/read/accum-string.rkt --- racket-6.12+ppa1/src/expander/read/accum-string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/accum-string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,84 @@ +#lang racket/base +(require "config.rkt") + +;; An `accum-string` is a buffer for accumulating characters. +;; We cache the buffer in the config record so that it can +;; be reused after the buffered results are extracted. + +(provide accum-string-init! + accum-string-add! + accum-string-convert! + accum-string-count + set-accum-string-count! + accum-string-get! + accum-string-get-bytes! + accum-string-abandon!) + +(struct accum-string ([pos #:mutable] + [str #:mutable])) + +(define (accum-string-init! config) + (define st (read-config-st config)) + (define a (read-config-state-accum-str st)) + (cond + [a + (set-read-config-state-accum-str! st #f) + (set-accum-string-pos! a 0) + a] + [else + (accum-string 0 (make-string 32))])) + +(define (accum-string-add! a c) + (define pos (accum-string-pos a)) + (define str (accum-string-str a)) + (define str2 + (cond + [(pos . < . (string-length str)) + str] + [else + (define str2 (make-string (* (string-length str) 2))) + (string-copy! str2 0 str) + (set-accum-string-str! a str2) + str2])) + (string-set! str2 pos c) + (set-accum-string-pos! a (add1 pos))) + +(define (accum-string-count a) + (accum-string-pos a)) + +(define (set-accum-string-count! a pos) + (set-accum-string-pos! a pos)) + +;; Replace `start-pos` up to `pos` with a converted +;; string. Case folding can change the string length. +(define (accum-string-convert! a convert start-pos) + (define str (accum-string-str a)) + (define s (convert + (substring str + start-pos + (accum-string-pos a)))) + (define len (string-length s)) + (unless ((+ len start-pos) . < . (string-length str)) + (define str2 (make-string (+ start-pos len))) + (string-copy! str2 0 str 0 start-pos) + (set-accum-string-str! a str2)) + (string-copy! (accum-string-str a) start-pos s) + (set-accum-string-pos! a (+ start-pos len))) + +(define (accum-string-get! a config #:start-pos [start-pos 0]) + (define s (substring (accum-string-str a) + start-pos + (accum-string-pos a))) + (accum-string-abandon! a config) + s) + +(define (accum-string-get-bytes! a config #:start-pos [start-pos 0]) + (define bstr (string->bytes/latin-1 (accum-string-str a) + #f + start-pos + (accum-string-pos a))) + (accum-string-abandon! a config) + bstr) + +(define (accum-string-abandon! a config) + (set-read-config-state-accum-str! (read-config-st config) a)) diff -Nru racket-6.12+ppa1/src/expander/read/api.rkt racket-7.0+ppa1/src/expander/read/api.rkt --- racket-6.12+ppa1/src/expander/read/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,53 @@ +#lang racket/base +(require "../common/contract.rkt" + "readtable.rkt" + (rename-in "../syntax/read-syntax.rkt" + [read-syntax raw:read-syntax] + [read-syntax/recursive raw:read-syntax/recursive] + [read raw:read] + [read/recursive raw:read/recursive] + [read-language raw:read-language])) + +(provide read-syntax + read-syntax/recursive + read + read/recursive + read-language) + +(define/who (read-syntax [src (object-name (current-input-port))] [in (current-input-port)]) + (check who input-port? in) + (raw:read-syntax src in)) + +(define/who (read-syntax/recursive [src (object-name (current-input-port))] + [in (current-input-port)] + [start #f] + [readtable (current-readtable)] + [graph? #t]) + (check who input-port? in) + (check who char? #:or-false start) + (check who readtable? #:or-false readtable) + (raw:read-syntax/recursive src in start readtable graph?)) + +(define/who (read [in (current-input-port)]) + (check who input-port? in) + (raw:read in)) + +(define/who (read/recursive [in (current-input-port)] + [start #f] + [readtable (current-readtable)] + [graph? #t]) + (check who input-port? in) + (check who char? #:or-false start) + (check who readtable? #:or-false readtable) + (raw:read/recursive in start readtable graph?)) + +(define/who (read-language [in (current-input-port)] + [fail-thunk read-language-fail-thunk]) + (check who input-port? in) + (check who (procedure-arity-includes/c 0) fail-thunk) + (raw:read-language in (if (eq? fail-thunk read-language-fail-thunk) + #f + fail-thunk))) + +;; Not actually called --- just used to recognize a default +(define (read-language-fail-thunk) (error "fail")) diff -Nru racket-6.12+ppa1/src/expander/read/box.rkt racket-7.0+ppa1/src/expander/read/box.rkt --- racket-6.12+ppa1/src/expander/read/box.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/box.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require "error.rkt" + "wrap.rkt" + "config.rkt" + "parameter.rkt") + +(provide read-box) + +(define (read-box read-one dispatch-c in config) + (unless (check-parameter read-accept-box config) + (reader-error in config + "`~a&` forms not enabled" + dispatch-c)) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define e (read-one #f in (next-readtable config))) + (when (eof-object? e) + (reader-error in config #:due-to e #:end-pos open-end-pos + "expected an element for `~a&` box, found end-of-file" + dispatch-c)) + (wrap (box e) in config #f)) diff -Nru racket-6.12+ppa1/src/expander/read/char.rkt racket-7.0+ppa1/src/expander/read/char.rkt --- racket-6.12+ppa1/src/expander/read/char.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/char.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,113 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "digit.rkt") + +(provide read-character) + +(define (read-character in config) + (define c (read-char/special in config)) + (define char + (cond + [(eof-object? c) + (reader-error in config #:due-to c + "expected a character after `#\\`")] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character after `#\\`")] + [(octal-digit? c) + ;; Maybe octal + (define c2 (peek-char/special in config)) + (cond + [(and (char? c2) (octal-digit? c2)) + ;; Octal -- must be 3 digits + (consume-char in c2) + (define c3 (read-char/special in config)) + (define v + (cond + [(and (char? c3) (octal-digit? c3)) + (+ (arithmetic-shift (digit->number c) 6) + (arithmetic-shift (digit->number c2) 3) + (digit->number c3))] + [else #f])) + (unless (and v (v . <= . 255)) + (reader-error in config #:due-to c3 + "bad character constant `#\\~a~a~a`" + c c2 (if (char? c3) c3 ""))) + (integer->char v)] + [else + ;; Not octal + c])] + [(or (char=? c #\u) + (char=? c #\U)) + ;; Maybe hex encoding + (define accum-str (accum-string-init! config)) + (define v (read-digits in config accum-str + #:base 16 + #:max-count (if (char=? c #\u) 4 8))) + (cond + [(integer? v) + ;; It's a hex encoding, but make sure it's in range + (cond + [(and (or (v . < . #xD800) (v . > . #xDFFF)) + (v . <= . #x10FFFF)) + (accum-string-abandon! accum-str config) + (integer->char v)] + [else + (reader-error in config + "bad character constant `#\\u~a`" + (accum-string-get! accum-str config))])] + [else + ;; Not a hex encoding + (accum-string-abandon! accum-str config) + c])] + [(char-alphabetic? c) + ;; Maybe a name + (define next-c (peek-char/special in config)) + (cond + [(and (char? next-c) + (char-alphabetic? next-c)) + ;; Must be a name + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str c) + (accum-string-add! accum-str next-c) + (consume-char in next-c) + (let loop () + (define next-c (peek-char/special in config)) + (when (and (char? next-c) + (char-alphabetic? next-c)) + (accum-string-add! accum-str next-c) + (consume-char in next-c) + (loop))) + (define name (string-foldcase + (accum-string-get! accum-str config))) + (case name + [("nul" "null") #\nul] + [("backspace") #\backspace] + [("tab") #\tab] + [("newline" "linefeed") #\newline] + [("vtab") #\vtab] + [("page") #\page] + [("return") #\return] + [("space") #\space] + [("rubout") #\rubout] + [else + (reader-error in config + "bad character constant `#\\~a`" + name)])] + [else + ;; Not a name + c])] + [else + ;; Any other character + c])) + + (wrap char + in + config + char)) diff -Nru racket-6.12+ppa1/src/expander/read/closer.rkt racket-7.0+ppa1/src/expander/read/closer.rkt --- racket-6.12+ppa1/src/expander/read/closer.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/closer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,64 @@ +#lang racket/base +(require "parameter.rkt" + "config.rkt" + "readtable.rkt") + +(provide char-closer? + closer-name + closer->opener + opener-name + dot-name + all-openers-str) + +(define (char-closer? ec config) + (and (not (eof-object? ec)) + (or (char=? ec #\)) + (char=? ec #\]) + (char=? ec #\})))) + +(define (closer-name c config) + (effective-char-names c config "closer")) + +(define (opener-name c config) + (effective-char-names c config "opener")) + +(define (effective-char-names c config fallback-str) + (define rt (read-config-readtable config)) + (cond + [(not rt) + (format "`~a`" c)] + [else + (define cs (readtable-equivalent-chars rt c)) + (cond + [(null? cs) fallback-str] + [(null? (cdr cs)) (format "`~a`" (car cs))] + [(null? (cddr cs)) (format "`~a` or `~a`" (car cs) (cadr cs))] + [else + (apply + string-append + (let loop ([cs cs]) + (cond + [(null? (cdr cs)) (list (format "or `~a`" (car cs)))] + [else (cons (format "`~a`, " (car cs)) + (loop (cdr cs)))])))])])) + +(define (closer->opener c) + (case c + [(#\)) #\(] + [(#\]) #\[] + [(#\}) #\{] + [else c])) + +(define (dot-name config) + "`.`") + +(define (all-openers-str config) + (define p (opener-name #\( config)) + (define s (and (check-parameter read-square-bracket-as-paren config) + (opener-name #\[ config))) + (define c (and (check-parameter read-curly-brace-as-paren config) + (opener-name #\{ config))) + (cond + [(and s c) (format "~a, ~a, or ~a" p s c)] + [(or s c) (format "~a or ~a" p (or s c))] + [else p])) diff -Nru racket-6.12+ppa1/src/expander/read/coerce-key.rkt racket-7.0+ppa1/src/expander/read/coerce-key.rkt --- racket-6.12+ppa1/src/expander/read/coerce-key.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/coerce-key.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,10 @@ +#lang racket/base +(require "config.rkt") + +(provide coerce-key) + +(define (coerce-key key config) + (define for-syntax? (read-config-for-syntax? config)) + ((read-config-coerce-key config) + for-syntax? + key)) diff -Nru racket-6.12+ppa1/src/expander/read/coerce.rkt racket-7.0+ppa1/src/expander/read/coerce.rkt --- racket-6.12+ppa1/src/expander/read/coerce.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/coerce.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,11 @@ +#lang racket/base +(require "config.rkt") + +(provide coerce) + +(define (coerce val in config) + (define for-syntax? (read-config-for-syntax? config)) + ((read-config-coerce config) + for-syntax? + val + (and for-syntax? (port+config->srcloc in config)))) diff -Nru racket-6.12+ppa1/src/expander/read/config.rkt racket-7.0+ppa1/src/expander/read/config.rkt --- racket-6.12+ppa1/src/expander/read/config.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/config.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,141 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "readtable-parameter.rkt") + +(provide (struct*-out read-config) + (struct-out read-config-state) + current-read-config + make-read-config + read-config-update + port+config->srcloc + reading-at + disable-wrapping + keep-comment + discard-comment + next-readtable) + +(struct* read-config (readtable + next-readtable ; readtable to use for recursive reads + for-syntax? ; impose restrictions on graphs, fxvectors, etc? + source + * wrap ; wrapper applied to each datum, intended for syntax objects + read-compiled ; for `#~`: input-port -> any/c + dynamic-require ; for reader extensions: module-path sym -> any + module-declared? ; for `#lang`: module-path -> any/c + coerce ; coerce for syntax or not: any boolean -> any + coerce-key ; coerce unwrapped key for hash + * line + * col + * pos + * indentations ; stack of `indentation` records + * keep-comment? ; make main dispatch return on comment + parameter-override ; mash of parameter -> value + parameter-cache ; hash of parameter -> value + st)) ; other shared mutable state + +(struct read-config-state ([accum-str #:mutable] ; string-buffer cache + [graph #:mutable])) ; #f or hash of number -> value + +(define current-read-config (make-parameter #f)) ; for `read/recursive` + +(define (make-read-config + #:source [source #f] + #:for-syntax? [for-syntax? #f] + #:readtable [readtable (current-readtable)] + #:next-readtable [next-readtable readtable] + #:wrap [wrap #f #;(lambda (s-exp srcloc) s-exp)] + #:read-compiled [read-compiled #f] + #:dynamic-require [dynamic-require #f] + #:module-declared? [module-declared? #f] + #:coerce [coerce #f] + #:coerce-key [coerce-key #f] + #:keep-comment? [keep-comment? #f]) + (read-config readtable + next-readtable + for-syntax? + source + wrap + (or read-compiled + (lambda (in) + (error 'read "no `read-compiled` provided"))) + (or dynamic-require + (lambda (mod-path sym failure-k) + (error 'read "no `dynamic-require` provided"))) + (or module-declared? + (lambda (mod-path) + (error 'read "no `module-declare?` provided"))) + (or coerce + (lambda (for-syntax? v srcloc) v)) + (or coerce-key + (lambda (for-syntax? v) v)) + #f ; line + #f ; col + #f ; pos + null ; indentations + keep-comment? + #hasheq() ; parameter-override + (make-hasheq) ; parameter-cache + (read-config-state #f ; accum-str + #f))) ; graph + +(define (read-config-update config + #:for-syntax? for-syntax? + #:wrap wrap + #:readtable readtable + #:next-readtable [next-readtable (read-config-readtable config)] + #:reset-graph? local-graph? + #:keep-comment? keep-comment?) + (struct*-copy read-config config + [for-syntax? for-syntax?] + [wrap wrap] + [readtable readtable] + [next-readtable next-readtable] + [keep-comment? keep-comment?] + [st (if local-graph? + (read-config-state #f #f) + (read-config-st config))])) + +(define (port+config->srcloc in config + #:end-pos [given-end-pos #f]) + (define end-pos + (or given-end-pos + (let-values ([(end-line end-col end-pos) (port-next-location in)]) + end-pos))) + (srcloc (or (read-config-source config) + (object-name in) + "UNKNOWN") + (read-config-line config) + (read-config-col config) + (read-config-pos config) + (and (read-config-pos config) end-pos (max 0 (- end-pos (read-config-pos config)))))) + +(define (reading-at config line col pos) + (struct*-copy read-config config + [line line] + [col col] + [pos pos])) + +(define (disable-wrapping config) + (struct*-copy read-config config + [wrap #f])) + +(define (keep-comment config) + (struct*-copy read-config config + [keep-comment? #t])) + +(define (discard-comment config) + (cond + [(not (read-config-keep-comment? config)) + config] + [else + (struct*-copy read-config config + [keep-comment? #f])])) + +(define (next-readtable config) + (cond + [(eq? (read-config-readtable config) + (read-config-next-readtable config)) + config] + [else + (struct*-copy read-config config + [readtable (read-config-next-readtable config)])])) diff -Nru racket-6.12+ppa1/src/expander/read/constant.rkt racket-7.0+ppa1/src/expander/read/constant.rkt --- racket-6.12+ppa1/src/expander/read/constant.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/constant.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +#lang racket/base +(require "special.rkt" + "delimiter.rkt" + "accum-string.rkt" + "error.rkt" + "consume.rkt" + "wrap.rkt") + +(provide read-delimited-constant) + +(define (read-delimited-constant init-c can-match? chars val in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + (let loop ([chars chars]) + (define c (peek-char/special in config)) + (cond + [(char-delimiter? c config) + (unless (null? chars) + (reader-error in config #:due-to c + "bad syntax `#~a`" (accum-string-get! accum-str config)))] + [(null? chars) + (accum-string-add! accum-str c) + (reader-error in config + "bad syntax `#~a`" (accum-string-get! accum-str config))] + [(and can-match? (char=? c (car chars))) + (consume-char in c) + (accum-string-add! accum-str c) + (loop (cdr chars))] + [else + (consume-char/special in config c) + (accum-string-add! accum-str c) + (reader-error in config + "bad syntax `#~a`" (accum-string-get! accum-str config))])) + (wrap val in config (accum-string-get! accum-str config))) diff -Nru racket-6.12+ppa1/src/expander/read/consume.rkt racket-7.0+ppa1/src/expander/read/consume.rkt --- racket-6.12+ppa1/src/expander/read/consume.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/consume.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +#lang racket/base +(require "special.rkt" + "config.rkt") + +(provide consume-char + consume-char/special) + +;; Consume a previously peek character. We could +;; double-check that the read character matches `c` +(define (consume-char in c) + (read-char in) + (void)) + +(define (consume-char/special in config c) + (read-char-or-special in special (read-config-source config)) + (void)) diff -Nru racket-6.12+ppa1/src/expander/read/delimiter.rkt racket-7.0+ppa1/src/expander/read/delimiter.rkt --- racket-6.12+ppa1/src/expander/read/delimiter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/delimiter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base +(require "config.rkt" + "readtable.rkt" + "parameter.rkt") + +(provide readtable-char-delimiter? + char-delimiter?) + +(define (readtable-char-delimiter? rt c config) + (define dc (or (and rt + (hash-ref (readtable-delimiter-ht rt) c #f)) ; #f => default for `c` + c)) + (cond + [(eq? dc 'no-delimit) #f] + [(not (char? dc)) #t] + [else + (or (char-whitespace? dc) + (char=? dc #\() + (char=? dc #\)) + (char=? dc #\[) + (char=? dc #\]) + (char=? dc #\{) + (char=? dc #\}) + (char=? dc #\') + (char=? dc #\`) + (char=? dc #\,) + (char=? dc #\;) + (char=? dc #\") + (and (char=? dc #\.) + (check-parameter read-cdot config)))])) + +(define (char-delimiter? c config) + (readtable-char-delimiter? (read-config-readtable config) c config)) diff -Nru racket-6.12+ppa1/src/expander/read/demo.rkt racket-7.0+ppa1/src/expander/read/demo.rkt --- racket-6.12+ppa1/src/expander/read/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,186 @@ +#lang at-exp racket/base +(require racket/flonum + (rename-in "main.rkt" + [read main:read] + [read-language main:read-language])) + +(define (s->p . strs) + (define p (open-input-string (apply string-append strs))) + (port-count-lines! p) + p) + +(define test-read + (case-lambda + [(in) (main:read in #:source "input")] + [(in expect) + (define v (test-read in)) + (unless (equal? v expect) + (error 'test "fail\n got: ~s\n expect: ~s" + v + expect)) + v])) + +(test-read (s->p "#:a") + '#:a) +(test-read (s->p "#\\a") + #\a) +(test-read (s->p "#\\110") + #\H) +(test-read (s->p "#\\u0001") + #\u1) +(test-read (s->p "#\\U3BB") + #\u3BB) +(test-read (s->p "#\\\u3BB") + #\u3BB) +(test-read (s->p "|ap ple|Pie") + '|ap plePie|) +(test-read (s->p "\\|\\|") + '\|\|) +(test-read (s->p "(a b #%c)") + '(a b #%c)) +(test-read (s->p "(a #;z b . c)") + '(a b . c)) +(parameterize ([read-cdot #t]) + (test-read (s->p "(a b . c)") + '(a (#%dot b c)))) +(parameterize ([read-cdot #t]) + (test-read (s->p "a.b.c.d|.|f") + '(#%dot (#%dot (#%dot a b) c) d.f))) +(test-read (s->p "(b . a . c)") + '(a b c)) +(test-read (s->p "(b . a #| a |# . c)") + '(a b c)) +(test-read (s->p "(a 1.0 ; comment\n c)") + '(a 1.0 c)) +(test-read (s->p "(a \"1.0\" c)") + '(a "1.0" c)) +(test-read (s->p "'('a `b ,c ,@d ,@ e #'f #`g #,h #,@i)") + ''('a `b ,c ,@d ,@e #'f #`g #,h #,@i)) +(test-read (s->p "(#t)") + '(#t)) +(test-read (s->p "#f") + '#f) +(test-read (s->p "(#true)") + '(#t)) +(test-read (s->p "#ci (#false)") + '(#f)) +(test-read (s->p "#005(fAl Se)") + '#(fAl Se Se Se Se)) +(test-read (s->p "#fl6(1.5 0.33 0.3)") + (flvector 1.5 0.33 0.3 0.3 0.3 0.3)) +(let ([ht (test-read (s->p "#1=#hasheq((#1# . #1#))"))]) + (unless (eq? (hash-ref ht ht) ht) + (error 'test "fail for cyclic hash table"))) +(test-read (s->p "#hash{(fAl . Se) (7 . 9)}") + #hash{(fAl . Se) (7 . 9)}) +(test-read (s->p "#hasheq()") + #hasheq()) +(test-read (s->p "#s(fAl Se)") + #s(fAl Se)) +(test-read (s->p "#&fox") + #&fox) +(test-read @s->p{#px#"fox"} + #px#"fox") +(test-read (s->p "{fAl Se}") + '(fAl Se)) +(test-read (s->p "#{fAl Se}") + '#(fAl Se)) +(test-read (s->p "#! ok \\\n more\n 8") + 8) +(test-read @s->p{"apple\n\"\x30\7\07\u3BB\U1F600\uD83D\uDE00"} + "apple\n\"\x30\7\07\u3BB\U1F600\U1F600") +(test-read @s->p{#"apple\n\"\x30\7\07"} + #"apple\n\"0\a\a") +(test-read @s->p{#<p "{fAl Se}") + '(#%braces fAl Se))) +(parameterize ([read-case-sensitive #f]) + (test-read (s->p "Case\\InSens") + 'caseInsens)) +(with-handlers ([exn:fail:read? exn-message]) + (test-read (s->p "{ fAl\n Se)"))) + +(parameterize ([current-readtable (make-readtable #f + #\$ #\( #f + #\% #\) #f)]) + (test-read (s->p "$inside%") + '(inside))) +(parameterize ([current-readtable (make-readtable #f + #\t 'terminating-macro + (lambda (a b c d e f) 'TEE) + #\u 'non-terminating-macro + (lambda (a b c d e f) 'YOO))]) + (test-read (s->p "(1t2u3)") + '(1 TEE 2u3))) +(parameterize ([current-readtable (make-readtable #f + #\t 'dispatch-macro + (lambda (a b c d e f) 'TEE))]) + (test-read (s->p "(1 #t 2)") + '(1 TEE 2))) +(parameterize ([current-readtable (make-readtable #f + #\t 'dispatch-macro + (lambda (c in src long col pos) + (unless (equal? c #\t) + (error "not the expected character")) + (main:read in + #:recursive? #t + #:readtable #f)))]) + (test-read (s->p "(#1=(a) #t #1# #t#t)") + '((a) (a) #t))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#readerok") #:dynamic-require (lambda (lib sym) + (lambda (in src line col pos) + 'OK)))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#lang ok ?") + #:dynamic-require (lambda (lib sym) + (lambda (in src line col pos) + 'LANG-OK)) + #:module-declared? (lambda (mp) #f))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#!ok ?") + #:dynamic-require (lambda (lib sym) + (lambda (in) + '|#!-OK|)) + #:module-declared? (lambda (mp) #t))) + +(main:read-language (s->p "#lang racket/base") (lambda () (error "fail")) + #:dynamic-require (lambda (lib sym fail-k) + (lambda (in src line col pos) + (lambda (x y) 'LANG-INFO))) + #:module-declared? (lambda (mp) #f)) + +(parameterize ([current-readtable (make-readtable #f + #\# #\a #f)]) + (test-read (s->p "#ab#") + '|#ab#|)) + +(with-handlers ([exn:fail:read? exn-message]) + (parameterize ([current-readtable (make-readtable #f + #\* #\) #f + #\! #\) #f)]) + (main:read (s->p "(x")))) + +(define s (let ([o (open-output-bytes)]) + (display "(" o) + (for ([i 100000]) (display " " o) (display i o)) + (display ")" o) + (get-output-string o))) +(collect-garbage) +(require "accum-string.rkt" + "config.rkt") +(void (time (let ([p (s->p s)]) + ;; Sortof a baseline measurement: + (define accum-str (accum-string-init! (make-read-config))) + (let loop ([v #f]) + (unless (eof-object? (peek-char-or-special p)) + (loop (accum-string-add! accum-str (read-char-or-special p)))))))) +(void (time (test-read (s->p s)))) +(void (time (read (s->p s)))) diff -Nru racket-6.12+ppa1/src/expander/read/digit.rkt racket-7.0+ppa1/src/expander/read/digit.rkt --- racket-6.12+ppa1/src/expander/read/digit.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/digit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,63 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "consume.rkt" + "accum-string.rkt") + +(provide read-digits + digit? + decimal-digit? + octal-digit? + hex-digit? + digit->number) + +(define (read-digits in config [accum-str #f] + #:base base #:max-count max-count + #:init [init-v 0] + #:zero-digits-result [zero-digits-result #f]) + (define c (peek-char/special in config)) + (cond + [(digit? c base) + (consume-char in c) + (when accum-str (accum-string-add! accum-str c)) + (let loop ([v (+ (digit->number c) (* init-v base))] + [max-count (sub1 max-count)]) + (cond + [(zero? max-count) v] + [else + (define c (peek-char/special in config)) + (cond + [(digit? c base) + (consume-char in c) + (when accum-str (accum-string-add! accum-str c)) + (loop (+ (digit->number c) (* v base)) (sub1 max-count))] + [else v])]))] + [zero-digits-result zero-digits-result] + [else c])) + +(define (digit? c base) + (cond + [(not (char? c)) #f] + [(= base 8) (octal-digit? c)] + [(= base 16) (hex-digit? c)] + [else (decimal-digit? c)])) + +(define (decimal-digit? c) + (and (char>=? c #\0) (char<=? c #\9))) + +(define (octal-digit? c) + (and (char>=? c #\0) (char<=? c #\7))) + +(define (hex-digit? c) + (or (and (char>=? c #\0) (char<=? c #\9)) + (and (char>=? c #\A) (char<=? c #\F)) + (and (char>=? c #\a) (char<=? c #\f)))) + +(define (digit->number c) + (cond + [(and (char>=? c #\0) (char<=? c #\9)) + (- (char->integer c) (char->integer #\0))] + [(and (char>=? c #\A) (char<=? c #\F)) + (- (char->integer c) (- (char->integer #\A) 10))] + [else + (- (char->integer c) (- (char->integer #\a) 10))])) diff -Nru racket-6.12+ppa1/src/expander/read/error.rkt racket-7.0+ppa1/src/expander/read/error.rkt --- racket-6.12+ppa1/src/expander/read/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,49 @@ +#lang racket/base +(require "config.rkt") + +(provide reader-error + bad-syntax-error + catch-and-reraise-as-reader) + +(define (reader-error in config + #:continuation-marks [continuation-marks (current-continuation-marks)] + #:due-to [due-to #\x] + #:who [who (if (read-config-for-syntax? config) + 'read-syntax + 'read)] + #:end-pos [end-pos #f] + str . args) + (define msg (format "~a: ~a" who (apply format str args))) + (define srcloc (and in (port+config->srcloc in config + #:end-pos end-pos))) + (raise + ((cond + [(eof-object? due-to) exn:fail:read:eof] + [(not (char? due-to)) exn:fail:read:non-char] + [else exn:fail:read]) + (let ([s (and (error-print-source-location) + srcloc + (srcloc->string srcloc))]) + (if s + (string-append s ": " msg) + msg)) + continuation-marks + (if srcloc + (list srcloc) + null)))) + +(define (bad-syntax-error in config str #:due-to [due-to #\x]) + (reader-error in config #:due-to due-to "bad syntax `~a`" str)) + + +(define-syntax-rule (catch-and-reraise-as-reader in config expr) + (catch-and-reraise-as-reader/proc in config (lambda () expr))) + +(define (catch-and-reraise-as-reader/proc in config thunk) + (with-handlers ([exn:fail? (lambda (exn) + (reader-error in config + "~a" + (let ([s (exn-message exn)]) + (regexp-replace "^[a-z-]*: " s "")) + #:continuation-marks (exn-continuation-marks exn)))]) + (thunk))) diff -Nru racket-6.12+ppa1/src/expander/read/extension.rkt racket-7.0+ppa1/src/expander/read/extension.rkt --- racket-6.12+ppa1/src/expander/read/extension.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/extension.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,241 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "consume.rkt" + "error.rkt" + "accum-string.rkt" + "parameter.rkt" + "wrap.rkt" + "coerce.rkt" + "special-comment.rkt") + +(provide read-extension-reader + read-extension-lang + read-extension-#!) + +(define (read-extension-reader read-one read-recur dispatch-c in config) + (define extend-str (read-extension-prefix (cons dispatch-c '(#\r #\e)) + '(#\a #\d #\e #\r) + in + config)) + (unless (check-parameter read-accept-reader config) + (reader-error in config + "`~a` not enabled" + extend-str)) + + (define mod-path-wrapped (read-one #f in (next-readtable config))) + (when (eof-object? mod-path-wrapped) + (reader-error in config #:due-to mod-path-wrapped + "expected a datum after `~a`, found end-of-file" + extend-str)) + + (read-extension ((read-config-coerce config) #f mod-path-wrapped #f) + read-recur in config + #:mod-path-wrapped mod-path-wrapped)) + +;; ---------------------------------------- + +(define (read-extension-lang read-recur dispatch-c in config + #:get-info? [get-info? #f]) + (define extend-str (read-extension-prefix (cons dispatch-c '(#\l)) + '(#\a #\n #\g) + in + config)) + (define c (read-char/special in config)) + (unless (char=? c #\space) + (reader-error in config + "expected a single space after `~a`" + extend-str)) + + (read-lang extend-str read-recur in config + #:who '|#lang| + #:get-info? get-info?)) + +(define (read-extension-#! read-recur dispatch-c in config + #:get-info? [get-info? #f]) + (define c (read-char/special in config)) + (unless (char-lang-nonsep? c) + (bad-syntax-error in config (if (char? c) + (string dispatch-c #\! c) + (string dispatch-c #\!)))) + (read-lang (string dispatch-c #\!) read-recur in config + #:init-c c + #:who '|#!| + #:get-info? get-info?)) + +;; ---------------------------------------- + +(define (read-lang extend-str read-recur in config + #:init-c [init-c #f] + #:get-info? [get-info? #f] + #:who who) + (unless (and (check-parameter read-accept-reader config) + (check-parameter read-accept-lang config)) + (reader-error in config + "`~a` not enabled" + extend-str)) + + (define-values (line col pos) (port-next-location in)) + + (define accum-str (accum-string-init! config)) + (when init-c + (accum-string-add! accum-str init-c)) + (let loop () + (define c (peek-char/special in config)) + (cond + [(eof-object? c) (void)] + [(not (char? c)) + (consume-char/special in config c) + (reader-error in config #:due-to c + "found non-character while reading `#~a`" + extend-str)] + [(char-whitespace? c) (void)] + [(or (char-lang-nonsep? c) + (char=? #\/ c)) + (consume-char in c) + (accum-string-add! accum-str c) + (loop)] + [else + (consume-char in c) + (reader-error in config + (string-append "expected only alphanumeric, `-`, `+`, `_`, or `/`" + " characters for `~a`, found `~a`") + extend-str + c)])) + + (define lang-str (accum-string-get! accum-str config)) + (when (equal? lang-str "") + (reader-error in config + "expected a non-empty sequence of alphanumeric, `-`, `+`, `_`, or `/` after `~a`" + extend-str)) + + (when (char=? #\/ (string-ref lang-str 0)) + (reader-error in config + "expected a name that does not start `/` after `~a`" + extend-str)) + + (when (char=? #\/ (string-ref lang-str (sub1 (string-length lang-str)))) + (reader-error in config + "expected a name that does not end `/` after `~a`" + extend-str)) + + (define submod-path `(submod ,(string->symbol lang-str) reader)) + (define reader-path (string->symbol (string-append lang-str "/lang/reader"))) + + (read-extension #:try-first-mod-path submod-path + reader-path read-recur in (reading-at config line col pos) + #:get-info? get-info? + #:who who)) + +(define (char-lang-nonsep? c) + (and ((char->integer c) . < . 128) + (or (char-alphabetic? c) + (char-numeric? c) + (char=? #\- c) + (char=? #\+ c) + (char=? #\_ c)))) + +;; ---------------------------------------- + +(define (read-extension-prefix already wanted in config) + (define accum-str (accum-string-init! config)) + (for ([c (in-list already)]) + (accum-string-add! accum-str c)) + (let loop ([wanted wanted]) + (unless (null? wanted) + (define c (read-char/special in config)) + (when (char? c) + (accum-string-add! accum-str c)) + (unless (eqv? c (car wanted)) + (bad-syntax-error in config (accum-string-get! accum-str config) + #:due-to c)) + (loop (cdr wanted)))) + (accum-string-get! accum-str config)) + +;; ---------------------------------------- + +(define (read-extension #:try-first-mod-path [try-first-mod-path #f] + mod-path-datum read-recur in config + #:mod-path-wrapped [mod-path-wrapped + ((read-config-coerce config) + #t + mod-path-datum + (port+config->srcloc in config))] + #:get-info? [get-info? #f] + #:who [who '|#reader|]) + (force-parameters! config) + (define guard (current-reader-guard)) + (define mod-path + (or (and try-first-mod-path + (let ([mod-path (guard try-first-mod-path)]) + (and ((read-config-module-declared? config) try-first-mod-path) + mod-path))) + (guard mod-path-datum))) + + (define for-syntax? (read-config-for-syntax? config)) + + (define dynamic-require (read-config-dynamic-require config)) + + (define no-value (gensym)) + + (define extension + (cond + [get-info? + (dynamic-require mod-path 'get-info (lambda () no-value))] + [else + (dynamic-require mod-path (if for-syntax? 'read-syntax 'read))])) + + (cond + [(eq? extension no-value) + ;; Only for `get-info?` mode: + #f] + [else + (define result-v + (cond + [(and for-syntax? (not get-info?)) + (cond + [(procedure-arity-includes? extension 6) + (parameterize ([current-read-config config]) + (extension (read-config-source config) + in + mod-path-wrapped + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [(procedure-arity-includes? extension 2) + (parameterize ([current-read-config config]) + (extension (read-config-source config) in))] + [else + (raise-argument-error who + "(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))" + extension)])] + [else + (cond + [(procedure-arity-includes? extension 5) + (parameterize ([current-read-config config]) + (extension in + mod-path-wrapped + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [get-info? + (raise-argument-error who + "(procedure-arity-includes?/c 5)" + extension)] + [(procedure-arity-includes? extension 1) + (parameterize ([current-read-config config]) + (extension in))] + [else + (raise-argument-error who + "(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))" + extension)])])) + + (cond + [get-info? + (unless (and (procedure? result-v) (procedure-arity-includes? result-v 2)) + (raise-result-error 'read-language "(procedure-arity-includes?/c 2)" result-v)) + result-v] + [(special-comment? result-v) + (read-recur #f in config)] + [else + (coerce result-v in config)])])) diff -Nru racket-6.12+ppa1/src/expander/read/fixnum-flonum.rkt racket-7.0+ppa1/src/expander/read/fixnum-flonum.rkt --- racket-6.12+ppa1/src/expander/read/fixnum-flonum.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/fixnum-flonum.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +#lang racket/base +(require "config.rkt" + "error.rkt" + "whitespace.rkt" + "location.rkt" + "special.rkt" + "symbol-or-number.rkt") + +(provide read-fixnum + read-flonum) + +(define (read-fixnum read-one init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (define v (read-number-literal c in config "#e")) + (cond + [(fixnum? v) v] + [(eof-object? v) v] + [else + (reader-error in (reading-at config line col pos) + "expected a fixnum, found ~a" + v)])) + +(define (read-flonum read-one init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (define v (read-number-literal c in config "#i")) + (cond + [(flonum? v) v] + [(eof-object? v) v] + [else + (reader-error in (reading-at config line col pos) + "expected a flonum, found ~a" + v)])) + +;; ---------------------------------------- + +(define (read-number-literal c in config mode) + (cond + [(not (char? c)) c] + [else + (read-symbol-or-number c in config #:mode mode)])) diff -Nru racket-6.12+ppa1/src/expander/read/graph.rkt racket-7.0+ppa1/src/expander/read/graph.rkt --- racket-6.12+ppa1/src/expander/read/graph.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/graph.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,108 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "readtable.rkt" + "accum-string.rkt" + "parameter.rkt" + "error.rkt" + "digit.rkt" + "vector.rkt") + +(provide read-vector-or-graph + get-graph-hash) + +(define (read-vector-or-graph read-one dispatch-c init-c in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + + (define init-v (digit->number init-c)) + + (define v (read-digits in config accum-str + #:base 10 #:max-count +inf.0 + #:init init-v + #:zero-digits-result init-v)) + (define-values (post-line post-col post-pos) (port-next-location in)) + + (define (get-accum c) + (format "~a~a~a" dispatch-c (accum-string-get! accum-str config) c)) + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (get-accum c))])) + + (define c (read-char/special in config)) + (define ec (effective-char c config)) + (case ec + [(#\() + (accum-string-abandon! accum-str config) + (read-vector read-one c #\( #\) in config #:length v)] + [(#\[) + (accum-string-abandon! accum-str config) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (get-accum c) + (read-vector read-one c #\[ #\] in config #:length v))] + [(#\{) + (accum-string-abandon! accum-str config) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (get-accum c) + (read-vector read-one c #\{ #\} in config #:length v))] + [else + (case c + [(#\= #\#) + (when (or (read-config-for-syntax? config) + (not (check-parameter read-accept-graph config))) + (reader-error in config + "`#...~a` forms not ~a" + c + (if (read-config-for-syntax? config) + "enabled" + "allowed in `read-syntax` mode"))) + (unless ((accum-string-count accum-str) . <= . 8) + (reader-error in config + "graph ID too long in `~a~a~a`" + dispatch-c (accum-string-get! accum-str config) c)) + (case c + [(#\=) + (define ph (make-placeholder 'placeholder)) + (define ht (get-graph-hash config)) + (when (hash-ref ht v #f) + (reader-error in config + "multiple `~a~a~a` tags" + dispatch-c (accum-string-get! accum-str config) c)) + (hash-set! ht v ph) + (define result-v (read-one #f in (next-readtable config))) + (when (eof-object? result-v) + (reader-error in config #:due-to result-v + "expected an element for graph after `~a~a~a`, found end-of-file" + dispatch-c (accum-string-get! accum-str config) c)) + (accum-string-abandon! accum-str config) + (placeholder-set! ph result-v) + ph] + [(#\#) + (begin0 + (hash-ref + (or (read-config-state-graph (read-config-st config)) + #hash()) + v + (lambda () + (reader-error in config + "no preceding `~a~a=` for `~a~a~a`" + dispatch-c v + dispatch-c (accum-string-get! accum-str config) c))) + (accum-string-abandon! accum-str config))])] + [else + (reader-error in config + #:due-to c + "bad syntax `~a`" + (get-accum c))])])) + +;; ---------------------------------------- + +(define (get-graph-hash config) + (define st (read-config-st config)) + (or (read-config-state-graph st) + (let ([ht (make-hasheqv)]) + (set-read-config-state-graph! st ht) + ht))) diff -Nru racket-6.12+ppa1/src/expander/read/hash.rkt racket-7.0+ppa1/src/expander/read/hash.rkt --- racket-6.12+ppa1/src/expander/read/hash.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/hash.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,183 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "consume.rkt" + "location.rkt" + "error.rkt" + "accum-string.rkt" + "indentation.rkt" + "closer.rkt" + "parameter.rkt" + "coerce-key.rkt" + "wrap.rkt" + "sequence.rkt" + "special-comment.rkt") + +(provide read-hash) + +;; `#` and `h` or `H` have been read +(define (read-hash read-one dispatch-c init-c in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str init-c) + + (define (get-next! expect-c expect-alt-c) + (define c (read-char/special in config)) + (unless (or (eqv? c expect-c) (eqv? c expect-alt-c)) + (reader-error in config #:due-to c + "expected `~a` after `~a`" + expect-c (accum-string-get! accum-str config))) + (accum-string-add! accum-str c)) + + (get-next! #\a #\A) + (get-next! #\s #\S) + (get-next! #\h #\H) + + (define-values (content opener mode) + (let loop ([mode 'equal]) + (define c (read-char/special in config)) + (define ec (effective-char c config)) + (case ec + [(#\() + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define read-one-key+value (make-read-one-key+value read-one c #\) open-end-pos)) + (values (read-unwrapped-sequence read-one-key+value c #\( #\) in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [(#\[) + (cond + [(check-parameter read-square-bracket-as-paren config) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define read-one-key+value (make-read-one-key+value read-one c #\] open-end-pos)) + (values (read-unwrapped-sequence read-one-key+value c #\[ #\] in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [else + (reader-error in config "illegal use of `~a`" c)])] + [(#\{) + (cond + [(check-parameter read-curly-brace-as-paren config) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define read-one-key+value (make-read-one-key+value read-one c #\} open-end-pos)) + (values (read-unwrapped-sequence read-one-key+value c #\{ #\} in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [else + (reader-error in config "illegal use of `~a`" c)])] + [(#\e #\E) + (accum-string-add! accum-str c) + (get-next! #\q #\Q) + (loop 'eq)] + [(#\v #\V) + (accum-string-add! accum-str c) + (if (eq? mode 'eq) + (loop 'eqv) + (reader-error in config + "bad syntax `~a`" + (accum-string-get! accum-str config)))] + [else + (when (char? c) + (accum-string-add! accum-str c)) + (reader-error in config #:due-to c + "bad syntax `~a`" + (accum-string-get! accum-str config))]))) + + (define graph? (and (read-config-state-graph + (read-config-st config)) + #t)) + + (wrap (case mode + [(equal) + (if graph? + (make-hash-placeholder content) + (make-immutable-hash content))] + [(eq) + (if graph? + (make-hasheq-placeholder content) + (make-immutable-hasheq content))] + [(eqv) + (if graph? + (make-hasheqv-placeholder content) + (make-immutable-hasheqv content))]) + in + config + opener)) + +;; ---------------------------------------- + +(define ((make-read-one-key+value read-one overall-opener-c overall-closer-ec prefix-end-pos) init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (open-line open-col open-pos) (port-next-location* in c)) + (define ec (effective-char c config)) + (define elem-config (next-readtable config)) + + (define closer + (case ec + [(#\() #\)] + [(#\[) (and (check-parameter read-square-bracket-as-paren config) + #\])] + [(#\{) (and (check-parameter read-curly-brace-as-paren config) + #\})] + [else #f])) + + (cond + [(not closer) + (cond + [(eof-object? c) + (reader-error in config + #:due-to c #:end-pos prefix-end-pos + "expected ~a to close `~a`" + (closer-name overall-closer-ec config) overall-opener-c)] + [(char-closer? ec config) + (reader-error in (reading-at config open-line open-col open-pos) + "~a" + (indentation-unexpected-closer-message ec c config))] + [else + ;; If it's a special or we have a readtable, we need to read ahead + ;; to make sure that it's not a comment. For consistency, always + ;; read ahead. + (define v (read-one c in (keep-comment elem-config))) + (cond + [(special-comment? v) + ;; Try again + ((make-read-one-key+value read-one overall-opener-c overall-closer-ec prefix-end-pos) #f in config)] + [else + (reader-error in (reading-at config open-line open-col open-pos) + "expected ~a to start a hash pair" + (all-openers-str config))])])] + [else + (define k (read-one #f in (disable-wrapping elem-config))) + + (define dot-c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (dot-line dot-col dot-pos) (port-next-location* in dot-c)) + (define dot-ec (effective-char dot-c config)) + + (unless (and (eqv? dot-ec #\.) + (char-delimiter? (peek-char/special in config) config)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to dot-c + "expected ~a and value for hash" + (dot-name config))) + + (define v (read-one #f in elem-config)) + + (define closer-c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (closer-line closer-col closer-pos) (port-next-location* in closer-c)) + (define closer-ec (effective-char closer-c config)) + + (unless (eqv? closer-ec closer) + (reader-error in (reading-at config closer-line closer-col closer-pos) + #:due-to closer-c + "expected ~a after value within a hash" + (closer-name closer config))) + + (cons (coerce-key k elem-config) v)])) diff -Nru racket-6.12+ppa1/src/expander/read/indentation.rkt racket-7.0+ppa1/src/expander/read/indentation.rkt --- racket-6.12+ppa1/src/expander/read/indentation.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/indentation.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,97 @@ +#lang racket/base +(require "config.rkt" + "closer.rkt") + +(provide make-indentation + track-indentation! + indentation-possible-cause + indentation-unexpected-closer-message) + +(struct indentation + (closer ; expected close paren, bracket, etc. + [suspicious-closer #:mutable] ; expected closer when suspicious line found + [multiline? #:mutable] ; set to #f if the match attempt spans a line + start-line ; opener's line + [last-line #:mutable] ; current line, already checked the identation + [suspicious-line #:mutable] ; non-#f => first suspicious line since opener + [max-indent #:mutable] ; max indentation encountered since opener, not counting brackets by a more neseted opener + [suspicious-quote #:mutable])) ; non-#f => first suspicious quote whose closer is on a different line + + +(define (make-indentation closer in config) + (define-values (line col pos) (port-next-location in)) + (indentation closer + #f ; suspicious-closer + #f ; multiline? + line ; start-line + line ; last-line + #f ; suspicious-line + (and col (add1 col)) ; max-indent + #f)) ; suspicious-quote + +(define (track-indentation! config line col) + (define indts (read-config-indentations config)) + (define indt (and (pair? indts) (car indts))) + (when (and indt + line + (indentation-last-line indt) + ;; Already checked this line? + (line . > . (indentation-last-line indt))) + (set-indentation-last-line! indt line) + (set-indentation-multiline?! indt #t) + ;; At least as indented as before? + (cond + [(col . >= . (indentation-max-indent indt)) + (set-indentation-max-indent! indt col)] + [else + (unless (indentation-suspicious-line indt) + ;; Not as indented, and no suspicious line found already. + ;; Suspect that the closer should have appeared earlier. + (set-indentation-suspicious-closer! indt (indentation-closer indt)) + (set-indentation-suspicious-line! indt line))]))) + +(define (indentation-possible-cause config) + (define indt (car (read-config-indentations config))) + (cond + [(indentation-suspicious-line indt) + (format "\n possible cause: indentation suggests a missing ~a before line ~a" + (closer-name (indentation-suspicious-closer indt) config) + (indentation-suspicious-line indt))] + [else ""])) + +(define (indentation-unexpected-closer-message ec c config) + (define indts (read-config-indentations config)) + (cond + [(null? indts) + (format "unexpected `~a`" c)] + [else + (define indt (car indts)) + (string-append + ;; Base message: + (cond + [(char=? ec (indentation-closer indt)) + ;; If this closer is the expected on, why did we get an error? + (format "unexpected `~a`" c)] + [else + ;; If we're expecting this closer later, then it's not so much + ;; "unexpected" as we expected something else... + (define missing + (or (for/or ([indt (in-list (cdr indts))]) + (and (char=? ec (indentation-closer indt)) + "missing")) + "expected")) + (define opener-str + (opener-name (closer->opener (indentation-closer indt)) config)) + (format "~a ~a to close ~a, found instead `~a`" + missing + (closer-name (indentation-closer indt) config) + (cond + [(indentation-multiline? indt) + (format "~a on line ~a" + opener-str + (indentation-start-line indt))] + [else + (format "preceding ~a" opener-str)]) + c)]) + ;; Possibly add a cause based on indentation: + (indentation-possible-cause config))])) diff -Nru racket-6.12+ppa1/src/expander/read/language.rkt racket-7.0+ppa1/src/expander/read/language.rkt --- racket-6.12+ppa1/src/expander/read/language.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/language.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,52 @@ +#lang racket/base +(require "config.rkt" + "whitespace.rkt" + "consume.rkt" + "parameter.rkt" + "special.rkt" + "error.rkt" + "location.rkt" + "extension.rkt") + +(provide read-language/get-info) + +(define (read-language/get-info read-one in config fail-k) + (define c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + + (define l-config (override-parameter read-accept-reader + (reading-at config line col pos) + #t)) + + (cond + [(not (eqv? c #\#)) + (if fail-k + (fail-k) + (lang-error in l-config "" c))] + [else + (define c2 (read-char/special in l-config)) + (cond + [(eqv? c2 #\l) + (read-extension-lang read-one c in l-config #:get-info? #t)] + [(eqv? c2 #\!) + (read-extension-#! read-one c in l-config #:get-info? #t)] + [else + (if fail-k + (fail-k) + (lang-error in l-config (string c) c2))])])) + + +(define (lang-error in config prefix c) + (define (add-prefix s) + (if (string=? prefix "") + (format "`~a` followed by ~a" prefix s) + s)) + (reader-error in config + #:due-to c + #:who 'read-language + (string-append "expected (after whitespace and comments) `#lang ` or `#!` followed" + " immediately by a language name, found ~a") + (cond + [(eof-object? c) (add-prefix "end-of-file")] + [(not (char? c)) (add-prefix "non-character")] + [else (format "`~a~a`" prefix c)]))) diff -Nru racket-6.12+ppa1/src/expander/read/location.rkt racket-7.0+ppa1/src/expander/read/location.rkt --- racket-6.12+ppa1/src/expander/read/location.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/location.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base + +(provide port-next-location*) + +(define (port-next-location* in init-c) + ;; If we've already read `init-c`, then back up by one column and + ;; position; we assume that `init-c` is not a newline character + (cond + [(not init-c) (port-next-location in)] + [else + (define-values (line col pos) (port-next-location in)) + (values line + (and col (max 0 (sub1 col))) + (and pos (max 1 (sub1 pos))))])) diff -Nru racket-6.12+ppa1/src/expander/read/main.rkt racket-7.0+ppa1/src/expander/read/main.rkt --- racket-6.12+ppa1/src/expander/read/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,408 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "coerce.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "closer.rkt" + "consume.rkt" + "location.rkt" + "accum-string.rkt" + "error.rkt" + "indentation.rkt" + "parameter.rkt" + "primitive-parameter.rkt" + "special-comment.rkt" + "sequence.rkt" + "vector.rkt" + "struct.rkt" + "graph.rkt" + "hash.rkt" + "symbol-or-number.rkt" + "string.rkt" + "char.rkt" + "quote.rkt" + "constant.rkt" + "box.rkt" + "regexp.rkt" + "extension.rkt" + "language.rkt" + "number.rkt") + +(provide read + read-language + + current-readtable + make-readtable + readtable? + readtable-mapping + + string->number + + (all-from-out "primitive-parameter.rkt") + (all-from-out "special-comment.rkt")) + +;; This is not the `read` to be exposed from `racket/base`, but a +;; general entry to point implement `read` and variants like +;; `read-syntax` and `read/recursive`. To support syntax objects, the +;; caller should provide the `dynamic-require`, `read-compiled`, +;; `module-declared?`, and `corece` functions, even when implementing +;; a plain `read`, since those might be needed by a +;; `read-syntax/recursive`. +(define (read in + #:wrap [wrap #f] + #:init-c [init-c #f] + #:next-readtable [next-readtable (current-readtable)] + #:readtable [readtable next-readtable] + #:recursive? [recursive? #f] + #:local-graph? [local-graph? #f] ; ignored unless `recursive?` + #:source [source #f] + #:for-syntax? [for-syntax? #f] + #:read-compiled [read-compiled #f] ; see "config.rkt" + #:dynamic-require [dynamic-require #f] ; see "config.rkt" + #:module-declared? [module-declared? #f] ; see "config.rkt" + #:coerce [coerce #f] ; see "config.rkt" + #:coerce-key [coerce-key #f] ; see "config.rkt" + #:keep-comment? [keep-comment? recursive?]) + (define config + (cond + [(and recursive? + (current-read-config)) + => (lambda (config) + (read-config-update config + #:for-syntax? for-syntax? + #:wrap wrap + #:readtable readtable + #:next-readtable next-readtable + #:reset-graph? local-graph? + #:keep-comment? keep-comment?))] + [else + (make-read-config #:readtable readtable + #:next-readtable next-readtable + #:source source + #:for-syntax? for-syntax? + #:wrap wrap + #:read-compiled read-compiled + #:dynamic-require dynamic-require + #:module-declared? module-declared? + #:coerce coerce + #:coerce-key coerce-key + #:keep-comment? keep-comment?)])) + (define v (read-one init-c in config)) + (cond + [(and (or (not recursive?) local-graph?) + (read-config-state-graph (read-config-st config))) + (catch-and-reraise-as-reader + #f config + (make-reader-graph v))] + [(and recursive? + (not local-graph?) + (not for-syntax?) + (not (eof-object? v)) + (not (special-comment? v))) + (get-graph-hash config) ; to trigger placeholder resolution + v] + [else v])) + +(define (read-language in fail-k + #:for-syntax? [for-syntax? #f] + #:wrap [wrap #f] + #:read-compiled [read-compiled #f] + #:dynamic-require [dynamic-require #f] + #:module-declared? [module-declared? #f] + #:coerce [coerce #f] + #:coerce-key [coerce-key #f]) + (define config (make-read-config #:readtable #f + #:next-readtable #f + #:for-syntax? for-syntax? + #:wrap wrap + #:read-compiled read-compiled + #:dynamic-require dynamic-require + #:module-declared? module-declared? + #:coerce coerce + #:coerce-key coerce-key)) + (define l-config (override-parameter read-accept-reader config #f)) + (read-language/get-info read-undotted in config fail-k)) + +;; ---------------------------------------- +;; The top-level reading layer that takes care of parsing into +;; `#%cdot`. + +(define (read-one init-c in config) + (cond + [(not (check-parameter read-cdot config)) + ;; No parsing of `.` as `#%dot` + (read-undotted init-c in config)] + [(check-parameter read-cdot config) + ;; Look for ` . ` + (define-values (line col pos) (port-next-location in)) + (define v (read-undotted init-c in config)) + (cond + [(special-comment? v) v] + [else + (let loop ([v v]) + (define c (peek-char/special in config)) + (define ec (effective-char c config)) + (cond + [(not (char? ec)) v] + [(char-whitespace? ec) + (consume-char in c) + (loop v)] + [(char=? ec #\.) + (define-values (dot-line dot-col dot-pos) (port-next-location in)) + (consume-char in c) + (define pos-config (reading-at config dot-line dot-col dot-pos)) + (define cdot (wrap '#%dot in pos-config #\.)) + (define post-v (read-undotted #f in config)) + (when (eof-object? post-v) + (reader-error in pos-config #:due-to eof "expected a datum after cdot, found end-of-file")) + (loop (wrap (list cdot v post-v) in (reading-at config line col pos) #\.))] + [else v]))])])) + +;; ---------------------------------------- +;; The top-level reading layer within `#%dot` handling --- which is +;; the reader's main dispatch layer. + +(define (read-undotted init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (cond + [(eof-object? c) eof] + [(not (char? c)) + (define v (special-value c)) + (cond + [(special-comment? v) + (if (read-config-keep-comment? config) + v + (read-undotted #f in config))] + [else (coerce v in (reading-at config line col pos))])] + [(readtable-handler config c) + => (lambda (handler) + (define v (readtable-apply handler c in config line col pos)) + (retry-special-comment v in config))] + [else + ;; Map character via readtable: + (define ec (effective-char c config)) + + ;; Track indentation, unless it's a spurious closer: + (when (not (char-closer? ec config)) + (track-indentation! config line col)) + (define r-config (reading-at (discard-comment config) line col pos)) + + (define-syntax-rule (guard-legal e body ...) + (cond + [e body ...] + [else (reader-error in r-config "illegal use of `~a`" c)])) + + ;; Dispatch on character: + (case ec + [(#\#) + (read-dispatch c in r-config config)] + [(#\') + (read-quote read-one 'quote "quoting \"'\"" c in r-config)] + [(#\`) + (guard-legal + (check-parameter read-accept-quasiquote config) + (read-quote read-one 'quasiquote "quasiquoting \"`\"" c in r-config))] + [(#\,) + (guard-legal + (check-parameter read-accept-quasiquote config) + (define c2 (peek-char/special in config)) + (if (eqv? c2 #\@) + (begin + (consume-char in c2) + (read-quote read-one 'unquote-splicing "unquoting `,@`" c in r-config)) + (read-quote read-one 'unquote "unquoting `,`" c in r-config)))] + [(#\() + (wrap (read-unwrapped-sequence read-one ec #\( #\) in r-config #:shape-tag? #t) in r-config ec)] + [(#\)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config))] + [(#\[) + (guard-legal + (or (check-parameter read-square-bracket-as-paren config) + (check-parameter read-square-bracket-with-tag config)) + (wrap (read-unwrapped-sequence read-one ec #\[ #\] in r-config #:shape-tag? #t) in r-config ec))] + [(#\]) + (guard-legal + (or (check-parameter read-square-bracket-as-paren config) + (check-parameter read-square-bracket-with-tag config)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config)))] + [(#\{) + (guard-legal + (or (check-parameter read-curly-brace-as-paren config) + (check-parameter read-curly-brace-with-tag config)) + (wrap (read-unwrapped-sequence read-one ec #\{ #\} in r-config #:shape-tag? #t) in r-config ec))] + [(#\}) + (guard-legal + (or (check-parameter read-curly-brace-as-paren config) + (check-parameter read-curly-brace-with-tag config)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config)))] + [(#\") + (read-string in r-config)] + [(#\|) + (read-symbol-or-number c in r-config #:mode 'symbol)] + [else + (define v + (read-symbol-or-number c in r-config + ;; Don't read as a number if the effective char + ;; is non-numeric: + #:mode (if (or (eq? c ec) + (and ((char->integer ec) . < . 128) + (char-numeric? ec))) + 'symbol-or-number + 'symbol/indirect))) + (retry-special-comment v in config)])])) + +;; Dispatch on `#` character +(define (read-dispatch dispatch-c in config orig-config) + (define c (read-char/special in config)) + (cond + [(eof-object? c) + (reader-error in config #:due-to c "bad syntax `~a`" dispatch-c)] + [(not (char? c)) + (reader-error in config #:due-to c "bad syntax `~a`" dispatch-c)] + [(readtable-dispatch-handler orig-config c) + => (lambda (handler) + (define line (read-config-line config)) + (define col (read-config-col config)) + (define pos (read-config-pos config)) + (define v (readtable-apply handler c in config line col pos)) + (retry-special-comment v in orig-config))] + [else + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~a~a" dispatch-c c))])) + (case c + [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + ;; Vector, graph definition, or graph reference + (read-vector-or-graph read-one dispatch-c c in config)] + [(#\() + (read-vector read-one #\( #\( #\) in config)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + c + (read-vector read-one #\[ #\[ #\] in config))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + c + (read-vector read-one #\{ #\{ #\} in config))] + [(#\s) + (read-struct read-one dispatch-c in config)] + [(#\&) + (read-box read-one dispatch-c in config)] + [(#\') + (read-quote read-one 'syntax "quoting #'" c in config)] + [(#\`) + (read-quote read-one 'quasisyntax "quasiquoting #`" c in config)] + [(#\,) + (define c2 (peek-char/special in config)) + (if (eqv? c2 #\@) + (begin + (consume-char in c2) + (read-quote read-one 'unsyntax-splicing "unquoting #,@" c in config)) + (read-quote read-one 'unsyntax "unquoting #," c in config))] + [(#\\) + (read-character in config)] + [(#\") + (read-string in config #:mode '|byte string|)] + [(#\<) + (define c2 (peek-char/special in config)) + (cond + [(eqv? #\< c2) + (consume-char in #\<) + (read-here-string in config)] + [else + (reader-error in config #:due-to c2 "bad syntax `~a<`" dispatch-c)])] + [(#\%) + (read-symbol-or-number c in config #:extra-prefix dispatch-c #:mode 'symbol)] + [(#\:) + (read-symbol-or-number #f in config #:mode 'keyword)] + [(#\t #\T) + (define c2 (peek-char/special in config)) + (cond + [(char-delimiter? c2 config) (wrap #t in config c)] + [else (read-delimited-constant c (char=? c #\t) '(#\r #\u #\e) #t in config)])] + [(#\f #\F) + (define c2 (peek-char/special in config)) + (cond + [(char-delimiter? c2 config) (wrap #f in config c)] + [(or (char=? c2 #\x) (char=? c2 #\l)) + (read-fixnum-or-flonum-vector read-one dispatch-c c c2 in config)] + [else (read-delimited-constant c (char=? c #\f) '(#\a #\l #\s #\e) #f in config)])] + [(#\e) (read-symbol-or-number #f in config #:mode "#e")] + [(#\E) (read-symbol-or-number #f in config #:mode "#E")] + [(#\i) (read-symbol-or-number #f in config #:mode "#i")] + [(#\I) (read-symbol-or-number #f in config #:mode "#I")] + [(#\d) (read-symbol-or-number #f in config #:mode "#d")] + [(#\B) (read-symbol-or-number #f in config #:mode "#B")] + [(#\o) (read-symbol-or-number #f in config #:mode "#o")] + [(#\O) (read-symbol-or-number #f in config #:mode "#O")] + [(#\D) (read-symbol-or-number #f in config #:mode "#D")] + [(#\b) (read-symbol-or-number #f in config #:mode "#b")] + [(#\x) (read-symbol-or-number #f in config #:mode "#x")] + [(#\X) (read-symbol-or-number #f in config #:mode "#X")] + [(#\c #\C) + (define c2 (read-char/special in config)) + (case c2 + [(#\s #\S) (read-one #f in (override-parameter read-case-sensitive config #t))] + [(#\i #\I) (read-one #f in (override-parameter read-case-sensitive config #f))] + [else + (reader-error in config #:due-to c2 + "expected `s', `S`, `i`, or `I` after `~a~a`" + dispatch-c c)])] + [(#\h #\H) (read-hash read-one dispatch-c c in config)] + [(#\r) + ;; Maybe regexp or `#reader` + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str c) + (define c2 (read-char/special in config)) + (when (char? c2) (accum-string-add! accum-str c2)) + (case c2 + [(#\x) (read-regexp c accum-str in config)] + [(#\e) (read-extension-reader read-one read-undotted dispatch-c in config)] + [else + (bad-syntax-error in config + #:due-to c2 + (accum-string-get! accum-str config))])] + [(#\p) + ;; Maybe pregexp + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str c) + (define c2 (read-char/special in config)) + (when (char? c2) (accum-string-add! accum-str c2)) + (case c2 + [(#\x) (read-regexp c accum-str in config)] + [else (bad-syntax-error in config #:due-to c2 + (accum-string-get! accum-str config))])] + [(#\l) + ;; Maybe `#lang` + (read-extension-lang read-undotted dispatch-c in config)] + [(#\!) + ;; Maybe `#lang` + (read-extension-#! read-undotted dispatch-c in config)] + [(#\~) + ;; Compiled code + (cond + [(check-parameter read-accept-compiled config) + (wrap ((read-config-read-compiled config) in) in config c)] + [else + (reader-error in config + "`~a~~` compiled expressions not enabled" + dispatch-c)])] + [else + (reader-error in config "bad syntax `~a~a`" dispatch-c c)])])) + +(define (retry-special-comment v in config) + (cond + [(special-comment? v) + (if (read-config-keep-comment? config) + v + (read-undotted #f in config))] + [else v])) diff -Nru racket-6.12+ppa1/src/expander/read/number.rkt racket-7.0+ppa1/src/expander/read/number.rkt --- racket-6.12+ppa1/src/expander/read/number.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/number.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,829 @@ +#lang racket/base +(require racket/private/check + racket/extflonum + ;; Call the host `string->number` function only + ;; on valid fixnum, bignum, {single-,double-,ext}flonum + ;; representations that contain digits, possibly a + ;; leading sign, possibly a `.`, and possibly an + ;; exponent marker + (prefix-in host: "../host/string-to-number.rkt") + "parameter.rkt") + +(provide string->number) + +;; The `string->number` parser is responsible for handling Racket's +;; elaborate number syntax (mostly inherited from Scheme). It relies +;; on a host-system `string->number` that can handle well-formed +;; fixnum, bignum, and {double-,single-,extfl}flonum strings for a +;; given radix in the range [2,16]. Otherwise, the parser here +;; performs all checking that reader needs. + +(define/who (string->number s + [radix 10] + [convert-mode 'number-or-false] + [decimal-mode (if (read-decimal-as-inexact) + 'decimal-as-inexact + 'decimal-as-exact)]) + (check who string? s) + (check who (lambda (p) (and (exact-integer? radix) + (<= 2 radix 16))) + #:contract "(integer-in 2 16)" + radix) + (check who (lambda (p) (or (eq? p 'number-or-false) + (eq? p 'read))) + #:contract "(or/c 'number-or-false 'read)" + convert-mode) + (check who (lambda (p) (or (eq? p 'decimal-as-inexact) + (eq? p 'decimal-as-exact))) + #:contract "(or/c 'decimal-as-inexact decimal-as-exact)" + decimal-mode) + + (do-string->number s 0 (string-length s) + radix #:radix-set? #f + decimal-mode + convert-mode)) + +;; When parsing fails, either return an error string or #f. An error +;; string is reported only in 'read mode and when if we're somehow +;; onligated to parse as a number, such as after `#i`. +(define-syntax-rule (fail mode msg arg ...) + (cond + [(eq? mode 'must-read) + (format msg arg ...)] + [else #f])) + +;; The `convert-mode` argument here can be 'number-or-false, 'read, or +;; 'must-read, where 'must-read reports an error on parsing failure +;; instead of returning #f. At this level, we mostly detect the +;; special numbers `+inf.0` in combinations, and otherwise dispatch +;; to parsing a complex number, fraction, or exponential. +(define (do-string->number s start end + radix #:radix-set? radix-set? + exactness ; 'inexact, 'exact, 'decimal-as-inexact, or 'decimal-as-exact + #:in-complex [in-complex #f] ; #f, 'i, or '@ + convert-mode) + (cond + [(= start end) + (fail convert-mode "no digits")] + [else + (define c (string-ref s start)) + (cond + ;; `#e`, `#x`, etc. + [(char=? #\# c) + (define next (add1 start)) + (cond + [(= next end) + (fail convert-mode "no character after `#` indicator in `~.a`" s)] + [else + (define i (string-ref s next)) + (case i + [(#\e #\E #\i #\I) + (cond + [(or (exactness-set? exactness) in-complex) + (fail convert-mode "misplaced exactness specification at `~.a`" (substring s start end))] + [else + (do-string->number s (add1 next) end + radix #:radix-set? radix-set? + (if (or (char=? i #\e) (char=? i #\E)) 'exact 'inexact) + (if (eq? convert-mode 'read) 'must-read convert-mode))])] + [(#\b #\B #\o #\O #\d #\D #\x #\X) + (cond + [(or radix-set? in-complex) + (fail convert-mode "misplaced radix specification at `~.a`" (substring s start end))] + [else + (define radix + (case i + [(#\b #\B) 2] + [(#\o #\O) 8] + [(#\d #\D) 10] + [else 16])) + (do-string->number s (add1 next) end + radix #:radix-set? #t + exactness + (if (eq? convert-mode 'read) 'must-read convert-mode))])] + [else + ;; The reader always complains about a bad leading `#` + (fail (read-complains convert-mode) "bad `#` indicator `~a` at `~.a`" i (substring s start end))])])] + ;; +inf.0, etc. + [(and (char-sign? c) + (read-special-number s start end convert-mode)) + => + (lambda (v) + (cond + [(eq? exactness 'exact) + (fail convert-mode "no exact representation for `~a`" v)] + [else v]))] + ;; +inf.0+...i, etc. + [(and (char-sign? c) + (not in-complex) + ((- end start) . > . 7) + (char=? #\i (string-ref s (sub1 end))) + (char-sign? (string-ref s 6)) + (read-special-number s start (+ start 6) convert-mode)) + => + (lambda (v) + (read-for-special-compound s (+ start 6) (sub1 end) + radix + exactness + convert-mode + #:in-complex 'i + v (lambda (v v2) + (make-rectangular v v2))))] + ;; ...+inf.0i, etc. + [(and (not in-complex) + ((- end start) . >= . 7) ; allow `+inf.0i` + (char=? #\i (string-ref s (sub1 end))) + (char-sign? (string-ref s (- end 7))) + (read-special-number s (- end 7) (sub1 end) convert-mode)) + => + (lambda (v2) + (cond + [(and (= start (- end 7)) + (not (extflonum? v2))) + (make-rectangular 0 v2)] + [else + (read-for-special-compound s start (- end 7) + radix + exactness + convert-mode + #:in-complex 'i + #:reading-first? #t + v2 (lambda (v2 v) + (make-rectangular v v2)))]))] + ;; +inf.0@..., etc. + [(and (char-sign? c) + (not in-complex) + ((- end start) . > . 7) + (char=? #\@ (string-ref s (+ start 6))) + (read-special-number s start (+ start 6) convert-mode)) + => + (lambda (v) + (read-for-special-compound s (+ start 7) end + radix + exactness + convert-mode + #:in-complex '@ + v (lambda (v v2) + (make-polar v v2))))] + ;; ...@+inf.0, etc. + [(and (not in-complex) + ((- end start) . > . 7) + (char=? #\@ (string-ref s (- end 7))) + (read-special-number s (- end 6) end convert-mode)) + => + (lambda (v2) + (read-for-special-compound s start (- end 7) + radix + exactness + convert-mode + #:in-complex '@ + #:reading-first? #t + v2 (lambda (v2 v) + (make-polar v v2))))] + [else + (do-string->non-special-number s start end + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])])) + +(define (do-string->non-special-number s start end + radix #:radix-set? radix-set? + exactness + #:in-complex [in-complex #f] + convert-mode) + ;; Look for `@`, `i`, `+`/`-`, and exponent markers like `e`. + ;; Some of those can be used together, but we detect impossible + ;; combinations here and complain. For example `+` that's not + ;; after an exponential marker cannot appear twice, unless the + ;; the two are separated by `@` or the second eventually supports + ;; an ending `i`. Sometimes we can complain right away, and other + ;; times we collect positions to complain at the end, which as + ;; when an extra sign appears after a `.` or `/`. + (let loop ([i start] [any-digits? #f] [any-hashes? #f] [i-pos #f] [@-pos #f] + [sign-pos #f] [dot-pos #f] [slash-pos #f] [exp-pos #f] + [must-i? #f]) + (cond + [(= i end) + ;; We've finished looking, so dispatch on the kind of number parsing + ;; based on found `@`, etc. + ;; If we saw `@`, then we discarded other positions at that point. + ;; If we saw `i` at the end, then we discarded other positions except `sign-pos`. + ;; If we saw `.`, then we discarded earlier `slash-pos` and `exp-pos` or complained. + ;; If we saw `/`, then we discarded earlier `dot-pos` and `exp-pos` or complained. + ;; If we saw `+` or `-`, then we discarded earlier `exp-pos`. + (cond + [(and (not any-digits?) + ;; A number like `+i` can work with no digits + (not i-pos)) + (fail convert-mode "no digits in `~.a`" (substring s start end))] + [(and must-i? (not i-pos)) + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [(and sign-pos + (or (and dot-pos (dot-pos . < . sign-pos)) + (and slash-pos (slash-pos . < . sign-pos)))) + (fail convert-mode "misplaced sign in `~.a`" (substring s start end))] + [i-pos + (string->complex-number s start sign-pos sign-pos (sub1 end) + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex 'i + convert-mode)] + [@-pos + (string->complex-number s start @-pos (add1 @-pos) end + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex '@ + convert-mode)] + [else + (string->real-number s start end + dot-pos slash-pos exp-pos + any-hashes? + radix + exactness + convert-mode)])] + [else + (define c (string-ref s i)) + (cond + [(digit? c radix) + (loop (add1 i) #t any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos exp-pos + must-i?)] + [(char=? c #\#) ; treat like a digit + (loop (add1 i) #t #t i-pos @-pos + sign-pos dot-pos slash-pos exp-pos + must-i?)] + [(char-sign? c) + (cond + [(and sign-pos must-i?) + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + i dot-pos slash-pos #f + ;; must be complex if sign isn't at start + (and (> i start) (or (not @-pos) (> i (add1 @-pos)))))])] + [(char=? c #\.) + (cond + [(or (and exp-pos (or (not sign-pos) (exp-pos . > . sign-pos))) + (and dot-pos (or (not sign-pos) (dot-pos . > . sign-pos)))) + (fail convert-mode "misplaced `.` in `~.a`" (substring s start end))] + [(and slash-pos (or (not sign-pos) (slash-pos . > . sign-pos))) + (fail convert-mode "decimal points and fractions annot be mixed `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + sign-pos i #f #f + must-i?)])] + [(char=? c #\/) + (cond + [(and dot-pos (or (not sign-pos) (dot-pos . > . sign-pos))) + (fail convert-mode "decimal points and fractions annot be mixed `~.a`" (substring s start end))] + [(or (and exp-pos (or (not sign-pos) (exp-pos . > . sign-pos))) + (and slash-pos (or (not sign-pos) (slash-pos . > . sign-pos)))) + (fail convert-mode "misplaced `/` in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + sign-pos #f i #f + must-i?)])] + [(or (char=? c #\e) (char=? c #\E) + (char=? c #\f) (char=? c #\F) + (char=? c #\d) (char=? c #\D) + (char=? c #\s) (char=? c #\S) + (char=? c #\l) (char=? c #\L) + (char=? c #\t) (char=? c #\T)) + (cond + [exp-pos + (fail convert-mode "misplaced `~a` in `~.a`" c (substring s start end))] + ;; Dont count a sign in something like 1e+2 as `sign-pos` + [(and ((add1 i) . < . end) + (char-sign? (string-ref s (add1 i)))) + (loop (+ i 2) any-digits? any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos (or exp-pos i) + must-i?)] + [else + (loop (+ i 1) any-digits? any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos (or exp-pos i) + must-i?)])] + [(char=? c #\@) + (cond + [(eq? in-complex 'i) + (fail convert-mode "cannot mix `@` and `i` in `~.a`" (substring s start end))] + [(or @-pos (eq? in-complex '@)) + (fail convert-mode "too many `@`s in `~.a`" (substring s start end))] + [(= i start) + (fail convert-mode "`@` cannot be at start in `~.a`" (substring s start end))] + [must-i? + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos i + #f #f #f #f + must-i?)])] + [(and (or (char=? c #\i) (char=? c #\I)) + sign-pos) + (cond + [(or @-pos (eq? in-complex '@)) + (fail convert-mode "cannot mix `@` and `i` in `~.a`" (substring s start end))] + [(or ((add1 i) . < . end) (eq? in-complex 'i)) + (fail convert-mode "`i` must be at the end in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i @-pos + sign-pos #f #f #f + #f)])] + [else + (cond + [(char=? c #\nul) + (fail convert-mode "nul character in `~.a`" s)] + [else + (fail convert-mode "bad digit `~a`" c)])])]))) + +;; Parse and combine the halves of an impginary number, either +;; in `[+-]i` form or `@` form as +;; indicated by `in-complex` +(define (string->complex-number s start1 end1 start2 end2 + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex ; 'i or '@ + convert-mode) + (define v1 (cond + [(= start1 end1) + ;; The input was "[+-]i", so the real part + ;; is implicitly "0" + (if (eq? exactness 'inexact) + 0.0 + 0)] + [else + (do-string->number s start1 end1 + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])) + (define v2 (cond + [(and (eq? in-complex 'i) + (= (- end2 start2) 1)) + ;; The input ends "[+-]i", so the number is implicitly + ;; "1" + (define neg? (char=? (string-ref s start2) #\-)) + (cond + [(eq? exactness 'inexact) + (if neg? -1.0 1.0)] + [else + (if neg? -1 1)])] + [else + (do-string->number s start2 end2 + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])) + (cond + [(or (not v1) (not v2)) + #f] + [(and (or (extflonum? v1) (extflonum? v2)) + (not (eq? convert-mode 'must-read))) + ;; If no 'must-read, then an extflonum-combination + ;; failure hides even a divide-by-zero error + (fail-extflonum convert-mode v1)] + [(string? v1) v1] + [(extflonum? v1) + (fail-extflonum convert-mode v1)] + [(string? v2) v2] + [(extflonum? v2) + (fail-extflonum convert-mode v2)] + [(eq? in-complex 'i) + (make-rectangular v1 v2)] + [else + (define p (make-polar v1 v2)) + (if (eq? exactness 'exact) + (inexact->exact p) + p)])) + +;; Parse a real number that might be a faction, have `.`, or have `#`s +(define (string->real-number s start end + dot-pos slash-pos exp-pos + any-hashes? ; can be false-positive + radix + exactness + convert-mode) + ;; Try shortcut of using primitive `string->number`, which should + ;; work on real numbers and extflonums + (define (extfl-mark?) (char=? (char-downcase (string-ref s exp-pos)) #\t)) + (define simple? + (and (not slash-pos) + (or (eq? exactness 'inexact) + (eq? exactness 'decimal-as-inexact) + (and (not dot-pos) (not exp-pos))) + (or (not exp-pos) + (not (eq? convert-mode 'number-or-false)) + (not (extfl-mark?))) + (not (and any-hashes? (hashes? s start end))))) + (define has-sign? (and (end . > . start) (char-sign? (string-ref s start)))) + (cond + [(= (- end start) (+ (if dot-pos 1 0) (if exp-pos 1 0) (if has-sign? 1 0))) + (if (= end start) + (fail convert-mode "missing digits") + (fail convert-mode "missing digits in `~.a`" (substring s start end)))] + [simple? + (cond + [(and exp-pos (= (- exp-pos start) + (+ (if (and dot-pos (< dot-pos exp-pos)) 1 0) + (if has-sign? 1 0)))) + (fail convert-mode "missing digits before exponent marker in `~.a`" (substring s start end))] + [(and exp-pos + (or (= exp-pos (sub1 end)) + (and (= exp-pos (- end 2)) + (char-sign? (string-ref s (sub1 end)))))) + (fail convert-mode "missing digits after exponent marker in `~.a`" (substring s start end))] + [else + (define n (host:string->number (maybe-substring s start end) radix + ;; Use 'read mode as needed to enable extflonum results + (if (or (eq? convert-mode 'number-or-false) + (not exp-pos) + (not (extfl-mark?))) + 'number-or-false + 'read))) + (cond + [(or (not n) (string? n)) + (error 'string->number "host `string->number` failed on ~s" (substring s start end))] + [(eq? exactness 'inexact) + (cond + [(extflonum? n) + (fail convert-mode "cannot convert extflonum `~.a` to inexact" (substring s start end))] + [(and (eqv? n 0) + (char=? (string-ref s start) #\-)) + -0.0] + [else + (exact->inexact n)])] + [else n])])] + [exp-pos + (define m-v (string->real-number s start exp-pos + dot-pos slash-pos #f + any-hashes? + radix + 'exact + convert-mode)) + (define e-v (string->exact-integer-number s (+ exp-pos 1) end + radix + convert-mode)) + (define (real->precision-inexact r) + (case (string-ref s exp-pos) + [(#\s #\S #\f #\F) (real->single-flonum r)] + [(#\t #\T) + (if (extflonum-available?) + (real->extfl r) + ;; The host `string->number` can make a string-based + ;; representation to preserve the content, if not compute + ;; with it + (host:string->number (replace-hashes s start end) radix 'read))] + [else (real->double-flonum r)])) + (define get-extfl? (extfl-mark?)) + (cond + [(or (not m-v) (not e-v)) #f] + [(string? m-v) m-v] + [(string? e-v) e-v] + [(and (eq? convert-mode 'number-or-false) get-extfl?) + #f] + [(and (or (eq? exactness 'inexact) (eq? exactness 'decimal-as-inexact)) + ((abs e-v) . > . (if get-extfl? 6000 400))) + ;; Don't calculate a huge exponential to return a float: + (real->precision-inexact + (cond + [(eqv? m-v 0) (if (char=? (string-ref s start) #\-) + -0.0 + 0.0)] + [(positive? m-v) (if (positive? e-v) + +inf.0 + +0.0)] + [else (if (positive? e-v) + -inf.0 + -0.0)]))] + [(and (exactness-set? exactness) get-extfl?) + (fail convert-mode "cannot convert extflonum `~.a` to ~a" (substring s start end) exactness)] + [else + ;; This calculation would lose precision for floating-point + ;; numbers, but we don't get here for inexact `m-v`: + (define n (* m-v (expt radix e-v))) + (cond + [(and (not get-extfl?) + (or (eq? exactness 'exact) (eq? exactness 'decimal-as-exact))) + n] + [(and (eqv? n 0) + (char=? (string-ref s start) #\-)) + (real->precision-inexact -0.0)] + [else + (real->precision-inexact n)])])] + [slash-pos + ;; the numerator or demoniator doesn't have a decimal + ;; place or exponent marker, but it may have `#`s + (define n-v (string->real-number s start slash-pos + #f #f #f + any-hashes? + radix + 'exact + convert-mode)) + (define d-v (string->real-number s (add1 slash-pos) end + #f #f #f + any-hashes? + radix + 'exact + convert-mode)) + (define (get-inexact? from-pos) + (or (eq? exactness 'inexact) + ;; For historical reasons, `#`s in a fraction trigger an + ;; inexact result, even if `exactness` is 'decimal-as-exact + (and (not (eq? exactness 'exact)) + (hashes? s from-pos end)))) + (cond + [(or (not n-v) (not d-v)) #f] + [(string? n-v) n-v] + [(string? d-v) d-v] + [(eqv? d-v 0) + (cond + [(get-inexact? (add1 slash-pos)) + (if (negative? n-v) + -inf.0 + +inf.0)] + [else + ;; The reader always complains about divide-by-zero + (fail (read-complains convert-mode) "division by zero in `~.a`" (substring s start end))])] + [else + (define n (/ n-v d-v)) + (if (get-inexact? start) + (exact->inexact n) + n)])] + ;; We get this far only if the input has `#` or if the input has a + ;; `.` and we want exact + [else + (string->decimal-number s start end + dot-pos + radix + exactness + convert-mode)])) + +;; Parse a number that might have `.` and/or `#` in additon to digits +;; and possibiliy a leading `+` or `-` +(define (string->decimal-number s start end + dot-pos + radix + exactness + convert-mode) + (define get-exact? (or (eq? exactness 'exact) (eq? exactness 'decimal-as-exact))) + (define new-str (make-string (- end start (if (and dot-pos get-exact?) 1 0)))) + (let loop ([i (sub1 end)] [j (sub1 (string-length new-str))] [hashes-pos end]) + (cond + [(i . < . start) + ;; Convert `new-str` to an integer and finish up + (cond + [(= hashes-pos start) + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))] + [else + (define n (host:string->number new-str radix)) + (cond + [(not n) + (fail-bad-number convert-mode s start end)] + [(not get-exact?) + (if (and (eqv? n 0) + (char=? (string-ref s start) #\-)) + -0.0 + (exact->inexact n))] + [(and dot-pos get-exact?) + (/ n (expt 10 (- end dot-pos 1)))] + [else n])])] + [else + (define c (string-ref s i)) + (cond + [(char=? c #\.) + (cond + [get-exact? + (loop (sub1 i) j (if (= hashes-pos (add1 i)) i hashes-pos))] + [else + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) (if (= hashes-pos (add1 i)) i hashes-pos))])] + [(or (char=? c #\-) (char=? c #\+)) + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) (if (= hashes-pos (add1 i)) i hashes-pos))] + [(char=? c #\#) + (cond + [(= hashes-pos (add1 i)) + (string-set! new-str j #\0) + (loop (sub1 i) (sub1 j) i)] + [else + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))])] + [else + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) hashes-pos)])]))) + +;; Parse an integer that might have `#` and a leading `+` or `-`, but +;; no other non-digit characters +(define (string->exact-integer-number s start end + radix + convert-mode) + (cond + [(hashes? s start end) + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))] + [else + (define n (host:string->number (maybe-substring s start end) radix)) + (cond + [(not n) + (fail convert-mode "bad exponent `~.a`" (substring s start end))] + [else n])])) + +;; Try to read as `+inf.0`, etc. +(define (read-special-number s start end convert-mode) + (and + (= (- end start) 6) + (or (char=? (string-ref s start) #\+) + (char=? (string-ref s start) #\-)) + (or + (and (char=? (char-downcase (string-ref s (+ start 1))) #\i) + (char=? (char-downcase (string-ref s (+ start 2))) #\n) + (char=? (char-downcase (string-ref s (+ start 3))) #\f) + (char=? (char-downcase (string-ref s (+ start 4))) #\.) + (or + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\0) + (if (char=? (string-ref s start) #\+) + +inf.0 + -inf.0)) + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\f) + (if (char=? (string-ref s start) #\+) + +inf.f + -inf.f)) + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\t) + (not (eq? convert-mode 'number-or-false)) + (if (char=? (string-ref s start) #\+) + +inf.t + -inf.t)))) + (and (char=? (char-downcase (string-ref s (+ start 1))) #\n) + (char=? (char-downcase (string-ref s (+ start 2))) #\a) + (char=? (char-downcase (string-ref s (+ start 3))) #\n) + (char=? (char-downcase (string-ref s (+ start 4))) #\.) + (or (and (char=? (char-downcase (string-ref s (+ start 5))) #\0) + +nan.0) + (and (char=? (char-downcase (string-ref s (+ start 5))) #\f) + +nan.f) + (and (char=? (char-downcase (string-ref s (+ start 5))) #\t) + (not (eq? convert-mode 'number-or-false)) + +nan.t)))))) + +(define (fail-extflonum convert-mode v) + (fail convert-mode "cannot combine extflonum `~a` into complex number" v)) + +;; Read the other half of something like `+inf.0+...i` or `...@-inf.0` +(define (read-for-special-compound s start end + radix + exactness + convert-mode + #:in-complex in-complex + #:reading-first? [reading-first? #f] + v combine) + (cond + [(eq? exactness 'exact) + (fail convert-mode "no exact representation for `~a`" v)] + [(and (extflonum? v) (or (not reading-first?) + ;; If no 'must-read, then an extflonum-combination + ;; failure hides even a divide-by-zero error + (not (eq? convert-mode 'must-read)))) + (fail-extflonum convert-mode v)] + [else + (define v2 + (do-string->number s start end + radix #:radix-set? #t + exactness + #:in-complex in-complex + convert-mode)) + (cond + [(string? v2) v2] + [(not v2) v2] + [(extflonum? v) + (fail-extflonum convert-mode v)] + [else (combine v v2)])])) + +(define (hashes? s start end) + (for/or ([c (in-string s start end)]) + (char=? c #\#))) + +(define (replace-hashes s start end) + (define new-s (make-string (- end start))) + (for ([c (in-string s start end)] + [i (in-naturals)]) + (if (char=? c #\#) + (string-set! new-s i #\0) + (string-set! new-s i c))) + new-s) + +(define (maybe-substring s start end) + (if (and (= 0 start) + (= end (string-length s))) + s + (substring s start end))) + +(define (exactness-set? exactness) + (or (eq? exactness 'exact) (eq? exactness 'inexact))) + +(define (char-sign? c) + (or (char=? c #\-) (char=? c #\+))) + +(define (digit? c radix) + (define v (char->integer c)) + (or (and (v . >= . (char->integer #\0)) + ((- v (char->integer #\0)) . < . radix)) + (and (radix . > . 10) + (or (and + (v . >= . (char->integer #\a)) + ((- v (- (char->integer #\a) 10)) . < . radix)) + (and + (v . >= . (char->integer #\A)) + ((- v (- (char->integer #\A) 10)) . < . radix)))))) + +(define (fail-bad-number convert-mode s start end) + (fail convert-mode "bad number `~.a`" (substring s start end))) + +(define (read-complains convert-mode) + (if (eq? convert-mode 'read) 'must-read convert-mode)) + +;; ---------------------------------------- + +(module+ test + (define (try s) + (define expect (host:string->number s 10 'read 'decimal-as-inexact)) + (define got (string->number s 10 'read 'decimal-as-inexact)) + (unless (equal? expect got) + (error 'fail "~e\n expect: ~e\n got: ~e" s expect got))) + + (try "#i+inf.0") + (try "-inf.0") + (try "10") + (try "10.1") + (try "1+2i") + (try "#e10.1") + (try "1#.#") + (try "#e1#.#") + (try "1/2") + (try "#x+e#s+e") + (try "#e#x+e#s+e") + (try "-e#l-e") + (try "#e-e#l-e") + (try "#e#x+e#s+e@-e#l-e") + (try "#e+@1") + (try "3.1415926535897932385t0") + (try "+nan.0+1i") + (try "3.0t0") + (try "+i") + (try "-i") + (try "#i3") + (try "#i3+i") + (try "1/2+i") + (try "1.2+i") + (try "1/2+3") + (try "1.2+3") + (try "#i-0") + (try "#i0") + (try "-0#") + (try "#i1-0i") + (try "1#e500") + (try "1#e10000000000000000000000000000000") + (try "1#e-10000000000000000000000000000000") + (try "-0#e10") + (try "-0#e10000000000000000000000000000000") + (try "1/2@0") + (try "#i+8#i") + (try "1#/3") + (try "+inf.0@1") + (try "+inf.0@1/1") + (try "1/0#") + (try "1#/0") + (try "-1/0#") + (try "#e1/2#e10") + (try "1/0") + (try "1@+inf.0") + (try "1/1@+inf.0") + (try "#d1/0+3.0i") + (try "3.0t0+1/0i") + (try "1/0+3.0t0i") + (try "+inf.t0+1/0i") + (try "1/0+inf.t0i") + (try "3.#t0") + (try "-1-2i") + (try "-4.242154731064108e-5-6.865001427422244e-5i") + (try "1e300+1e300i") + (try "#x8f0767e50d4d0c07563bd81f530d36") + (try "t") + (try "s2") + (try "#ds2") + (try "2e") + (try ".e1") + (try "+.e1") + (try "#e1") + (try "1e#") + (try "1e+") + (try "1e+-") + (try ".#e1") + (try "1/") + (try "/2") + (try "#/2") + (try "1//2") + (try "2..") + (try "2+1")) diff -Nru racket-6.12+ppa1/src/expander/read/parameter.rkt racket-7.0+ppa1/src/expander/read/parameter.rkt --- racket-6.12+ppa1/src/expander/read/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,55 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "primitive-parameter.rkt") + +(provide check-parameter + override-parameter + force-parameters! + (all-from-out "primitive-parameter.rkt")) + +(define unknown (gensym 'unknown)) + +;; Speed up parameter checking and protect against changes +;; by caching parameter values +(define (check-parameter param config) + (define cache (read-config-parameter-cache config)) + (define v (hash-ref (read-config-parameter-override config) + param + (hash-ref cache param unknown))) + (cond + [(eq? v unknown) + (define v (param)) + (hash-set! cache param v) + v] + [else v])) + +(define (override-parameter param config v) + (struct*-copy read-config config + [parameter-override (hash-set + (read-config-parameter-override config) + param + v)])) + +;; Protect against callbacks that can change parameters +;; by caching all parameters at current values: +(define (force-parameters! config) + (define cache (read-config-parameter-cache config)) + (unless (hash-ref cache 'all-forced #f) + (hash-set! cache 'all-forced #t) + (check-parameter read-case-sensitive config) + (check-parameter read-square-bracket-as-paren config) + (check-parameter read-curly-brace-as-paren config) + (check-parameter read-square-bracket-with-tag config) + (check-parameter read-curly-brace-with-tag config) + (check-parameter read-cdot config) + (check-parameter read-accept-graph config) + (check-parameter read-accept-compiled config) + (check-parameter read-accept-box config) + (check-parameter read-accept-bar-quote config) + (check-parameter read-decimal-as-inexact config) + (check-parameter read-accept-dot config) + (check-parameter read-accept-infix-dot config) + (check-parameter read-accept-quasiquote config) + (check-parameter read-accept-reader config) + (check-parameter read-accept-lang config))) diff -Nru racket-6.12+ppa1/src/expander/read/primitive-parameter.rkt racket-7.0+ppa1/src/expander/read/primitive-parameter.rkt --- racket-6.12+ppa1/src/expander/read/primitive-parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/primitive-parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base + +(define (default-reader-guard v) v) + +(provide current-reader-guard) +(define current-reader-guard + (make-parameter default-reader-guard + (lambda (v) + (unless (and (procedure? v) + (procedure-arity-includes? v 1)) + (raise-argument-error 'current-reader-guard + "(procedure-arity-includes/c 1)" + v)) + v))) + +(define-syntax-rule (define-boolean-parameter id val) + (begin + (provide id) + (define id (make-parameter val (lambda (v) (and v #t)))))) + +;; (define-boolean-parameter read-case-sensitive #t) - shared with printer +(define-boolean-parameter read-square-bracket-as-paren #t) +(define-boolean-parameter read-curly-brace-as-paren #t) +(define-boolean-parameter read-square-bracket-with-tag #f) +(define-boolean-parameter read-curly-brace-with-tag #f) +(define-boolean-parameter read-cdot #f) +(define-boolean-parameter read-accept-graph #t) +(define-boolean-parameter read-accept-compiled #f) +(define-boolean-parameter read-accept-box #t) +;; (define-boolean-parameter read-accept-bar-quote #t) - shared with printer +(define-boolean-parameter read-decimal-as-inexact #t) +(define-boolean-parameter read-accept-dot #t) +(define-boolean-parameter read-accept-infix-dot #t) +(define-boolean-parameter read-accept-quasiquote #t) +(define-boolean-parameter read-accept-reader #f) +(define-boolean-parameter read-accept-lang #t) diff -Nru racket-6.12+ppa1/src/expander/read/quote.rkt racket-7.0+ppa1/src/expander/read/quote.rkt --- racket-6.12+ppa1/src/expander/read/quote.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/quote.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,15 @@ +#lang racket/base +(require "error.rkt" + "wrap.rkt") + +(provide read-quote) + +(define (read-quote read-one sym desc c in config) + (define wrapped-sym (wrap sym in config c)) + (define-values (end-line end-col end-pos) (port-next-location in)) + (define e (read-one #f in config)) + (when (eof-object? e) + (reader-error in config #:due-to e #:end-pos end-pos + "expected an element for ~a, found end-of-file" + desc)) + (wrap (list wrapped-sym e) in config #f)) diff -Nru racket-6.12+ppa1/src/expander/read/readtable-parameter.rkt racket-7.0+ppa1/src/expander/read/readtable-parameter.rkt --- racket-6.12+ppa1/src/expander/read/readtable-parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/readtable-parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base +(require "../common/contract.rkt") + +(provide current-readtable + prop:readtable prop:readtable?) + +(define-values (prop:readtable prop:readtable? prop:readtable-ref) + (make-struct-type-property 'readtable)) + +(define/who current-readtable (make-parameter #f + (lambda (v) + (check who prop:readtable? #:or-false v) + v))) diff -Nru racket-6.12+ppa1/src/expander/read/readtable.rkt racket-7.0+ppa1/src/expander/read/readtable.rkt --- racket-6.12+ppa1/src/expander/read/readtable.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/readtable.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,199 @@ +#lang racket/base +(require "../common/inline.rkt" + "config.rkt" + "coerce.rkt" + "parameter.rkt" + "readtable-parameter.rkt" + "special-comment.rkt") + +(provide readtable-delimiter-ht + make-readtable + readtable? + readtable-mapping + current-readtable + readtable-effective-char + effective-char + readtable-handler + readtable-dispatch-handler + readtable-apply + readtable-symbol-parser + readtable-equivalent-chars) + +(struct readtable (symbol-parser ; parser for default token handling: symbol-or-number + ;; The character table maps characters to either a + ;; parsing function or another character whose + ;; default to use + char-ht + ;; The dispatch table maps character for `#` dispatch + dispatch-ht + ;; The delimter table maps a character to 'delimit, + ;; 'no-delimit, or a character whose default to use; + ;; absence of a mapping is the default for that character + delimiter-ht) + #:property prop:readtable #t) + +(define (make-readtable rt . args) + (unless (or (not rt) (readtable? rt)) + (raise-argument-error 'make-readtable "(or/c readtable? #f)" rt)) + (let loop ([args args] + [symbol-parser (and rt (readtable-symbol-parser rt))] + [char-ht (if rt (readtable-char-ht rt) #hasheqv())] + [dispatch-ht (if rt (readtable-dispatch-ht rt) #hasheqv())] + [delimiter-ht (if rt (readtable-delimiter-ht rt) #hasheqv())]) + (cond + [(null? args) (readtable symbol-parser char-ht dispatch-ht delimiter-ht)] + [else + ;; Key is a character or #f + (define key (car args)) + (unless (or (not key) (char? key)) + (raise-argument-error 'make-readtable "(or/c char? #f)" key)) + + ;; Mode determines how the key is mapped + (when (null? args) + (cond + [key (raise-arguments-error 'make-readtable + (string-append "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro," + " or character argument after character argument") + "character" key)] + [else (raise-arguments-error 'make-readtable + "expected 'non-terminating-macro after #f")])) + (define mode (cadr args)) + (cond + [key + (unless (or (eq? mode 'terminating-macro) + (eq? mode 'non-terminating-macro) + (eq? mode 'dispatch-macro) + (char? mode)) + (raise-argument-error 'make-readtable + "(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)" + mode))] + [else + (unless (eq? mode 'non-terminating-macro) + (raise-arguments-error 'make-readtable + "expected 'non-terminating-macro after #f"))]) + + ;; Target is what the key is mapped to + (when (null? (cddr args)) + (raise-arguments-error 'make-readtable + (if key + "expected readtable or #f argument after character argument" + "expected procedure argument after symbol argument") + "given" mode)) + (define target (caddr args)) + + ;; Update the readtable + (define rest-args (cdddr args)) + (cond + [(not key) + ;; Update symbol parser + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (loop rest-args target char-ht dispatch-ht delimiter-ht)] + [(eq? mode 'dispatch-macro) + ;; Update `#`-triggered dispatch table + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (loop rest-args symbol-parser char-ht (hash-set dispatch-ht key target) delimiter-ht)] + [(char? mode) + ;; Update main character table with a character alias + (unless (or (not target) (readtable? target)) + (raise-argument-error 'make-readtable "(or/c readtable? #f)" target)) + (define actual-target (or (and target (hash-ref (readtable-char-ht target) mode #f)) + mode)) + (define new-char-ht (if actual-target + (hash-set char-ht key actual-target) + (hash-remove char-ht key))) + (define new-delimiter-ht (hash-set delimiter-ht + key + (if target + (hash-ref (readtable-delimiter-ht target) mode mode) + mode))) + (loop rest-args symbol-parser new-char-ht dispatch-ht new-delimiter-ht)] + [else + ;; Update main character table with a new handler + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (define new-char-ht (hash-set char-ht key target)) + (define new-delimiter-ht (hash-set delimiter-ht key (if (eq? mode 'terminating-macro) + 'delimit + 'no-delimit))) + (loop rest-args symbol-parser new-char-ht dispatch-ht new-delimiter-ht)])]))) + +;; Map a character to another character (if any) whose default +;; treatment should be used; be sure to map non-characters like +;; EOF to themselves. +(define-inline (readtable-effective-char rt c) + (cond + [(or (not rt) (not (char? c))) c] + [else (*readtable-effective-char rt c)])) + +(define (*readtable-effective-char rt c) + (define target (hash-ref (readtable-char-ht rt) c #f)) + (cond + [(not target) c] + [(char? target) target] + [else #\x])) ; return some non-special character + +(define (effective-char c config) + (readtable-effective-char (read-config-readtable config) c)) + +;; Map a character to a handler, if any: +(define (readtable-handler config c) + (define rt (read-config-readtable config)) + (and rt + (let ([target (hash-ref (readtable-char-ht rt) c #f)]) + (and target + (not (char? target)) + target)))) + +;; Map a character after `#` to a handler, if any: +(define (readtable-dispatch-handler config c) + (force-parameters! config) + (define rt (read-config-readtable config)) + (and rt + (hash-ref (readtable-dispatch-ht rt) c #f))) + +(define (readtable-apply handler c in config line col pos) + (define for-syntax? (read-config-for-syntax? config)) + (define v + (cond + [(not for-syntax?) + (parameterize ([current-read-config config]) + (if (procedure-arity-includes? handler 2) + (handler c in) + (handler c in #f line col pos)))] + [else + (parameterize ([current-read-config config]) + (handler c in (read-config-source config) line col pos))])) + (if (special-comment? v) + v + (coerce v in config))) + +;; Part of the public API: +(define (readtable-mapping rt c) + (unless (readtable? rt) + (raise-argument-error 'readtable-mapping "readtable?" rt)) + (unless (char? c) + (raise-argument-error 'readtable-mapping "char?" c)) + (define handler (hash-ref (readtable-char-ht rt) c #f)) + (values (or (and handler + (cond + [(char? handler) handler] + [(eq? 'delimit (hash-ref (readtable-delimiter-ht rt) c #f)) + 'terminating-macro] + [else + 'non-terminating-macro])) + c) + (if (char? handler) #f handler) + (hash-ref (readtable-dispatch-ht rt) c #f))) + +;; Return a list of characters mapped to `c`: +(define (readtable-equivalent-chars rt c) + (define ht (readtable-char-ht rt)) + (append + (if (hash-ref ht c #f) + null + (list c)) + (for/list ([(k v) (in-hash ht)] + #:when (eqv? v c)) + k))) diff -Nru racket-6.12+ppa1/src/expander/read/regexp.rkt racket-7.0+ppa1/src/expander/read/regexp.rkt --- racket-6.12+ppa1/src/expander/read/regexp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/regexp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,48 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "string.rkt") + +(provide read-regexp) + +(define (read-regexp mode-c accum-str in config) + (define c3 (read-char/special in config)) + (define no-wrap-config (disable-wrapping config)) + + (define rx + (case c3 + [(#\") + (accum-string-abandon! accum-str config) + (define str (read-string in no-wrap-config)) + (catch-and-reraise-as-reader + in config + ((if (char=? mode-c #\r) regexp pregexp) str))] + [(#\#) + (accum-string-add! accum-str c3) + (define c4 (read-char/special in config)) + (case c4 + [(#\") + (accum-string-abandon! accum-str config) + (define bstr + (read-string in no-wrap-config #:mode '|byte string|)) + (catch-and-reraise-as-reader + in config + ((if (char=? mode-c #\r) byte-regexp byte-pregexp) bstr))] + [else + (reader-error in config #:due-to c4 + "expected `\"` after `~a`" + (accum-string-get! accum-str config))])] + [else + (reader-error in config #:due-to c3 + "expected `\"` or `#` after `~a`" + (accum-string-get! accum-str config))])) + + (wrap rx + in + config + #f)) diff -Nru racket-6.12+ppa1/src/expander/read/sequence.rkt racket-7.0+ppa1/src/expander/read/sequence.rkt --- racket-6.12+ppa1/src/expander/read/sequence.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/sequence.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,132 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "special.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "consume.rkt" + "closer.rkt" + "error.rkt" + "indentation.rkt" + "parameter.rkt" + "wrap.rkt" + "location.rkt" + "special-comment.rkt") + +(provide read-unwrapped-sequence) + +(define (read-unwrapped-sequence read-one opener-c opener closer in seq-config + #:elem-config [elem-config (next-readtable seq-config)] + #:dot-mode [dot-mode 'all] + #:shape-tag? [shape-tag? #f] + #:whitespace-read-one [whitespace-read-one read-one] + #:first-read-one [first-read-one read-one]) + (define head #f) + (define indentation (make-indentation closer in seq-config)) + (define config (struct*-copy read-config elem-config + [indentations (cons indentation + (read-config-indentations seq-config))])) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + + (define config/keep-comment (keep-comment config)) + + (define (read-one/not-eof init-c read-one config) + (define e (read-one init-c in config)) + (when (eof-object? e) + (reader-error in seq-config #:due-to e #:end-pos open-end-pos + "expected a ~a to close `~a`~a" + (closer-name closer config) + opener-c + (indentation-possible-cause config))) + e) + + (define seq + (let loop ([depth 0] [accum null] [init-c #f] [first? #t] [first-read-one first-read-one]) + (define c (read-char/skip-whitespace-and-comments init-c whitespace-read-one in seq-config)) + (define ec (effective-char c seq-config)) + (cond + [(eqv? ec closer) + (if (null? accum) + null + (reverse accum))] + [(and (not first?) + (eqv? ec #\.) + (check-parameter read-accept-dot config) + (char-delimiter? (peek-char/special in config) seq-config)) + ;; Found a `.`: maybe improper or maybe infix + (define-values (dot-line dot-col dot-pos) (port-next-location* in c)) + (track-indentation! config dot-line dot-col) + + (unless (and dot-mode + ;; don't allow another `.` if we've seen an infix + (not head)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + "illegal use of `.`")) + + ;; Read one item for improper list or for infix: + (define v (read-one/not-eof #f first-read-one config)) + + ;; Check for infix or list termination: + (define rest-c (read-char/skip-whitespace-and-comments #f whitespace-read-one in seq-config)) + (define rest-ec (effective-char rest-c seq-config)) + + (cond + [(eqv? rest-ec closer) + ;; Improper list + (if (null? accum) + v + (append (reverse accum) v))] + [(and (eqv? rest-ec #\.) + (check-parameter read-accept-dot config) + (check-parameter read-accept-infix-dot config) + (char-delimiter? (peek-char/special in config) seq-config)) + ;; Infix mode + (set! head (box v)) + + (define-values (dot2-line dot2-col dot2-pos) (port-next-location in)) + (track-indentation! config dot2-line dot2-col) + + ;; Check for a closer right after the second dot: + (define post-c (read-char/skip-whitespace-and-comments #f whitespace-read-one in seq-config)) + (define post-ec (effective-char post-c seq-config)) + (when (or (eof-object? post-ec) + (eqv? post-ec closer)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to post-ec + "illegal use of `.`")) + + ;; No closer => another item or EOF + (loop depth accum post-c #f read-one)] + [else + ;; Something else after a single element after a single dot + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to rest-c + "illegal use of `.`")])] + [else + (define v (read-one/not-eof c first-read-one config/keep-comment)) + (cond + [(special-comment? v) (loop depth accum #f #f read-one)] + [(depth . > . 1024) + ;; At some large depth, it's better to accumlate than recur + (loop depth (cons v accum) #f #f read-one)] + [else + (cons v (loop (add1 depth) null #f #f read-one))])]))) + (define full-seq (if head + (cons (unbox head) seq) + seq)) + (if shape-tag? + (add-shape-tag opener in config full-seq) + full-seq)) + +;; ---------------------------------------- + +(define (add-shape-tag opener in config seq) + (define tag + (case opener + [(#\[) (and (check-parameter read-square-bracket-with-tag config) '#%brackets)] + [(#\{) (and (check-parameter read-curly-brace-with-tag config) '#%braces)] + [else #f])) + (if tag + (cons (wrap tag in config #f) seq) + seq)) diff -Nru racket-6.12+ppa1/src/expander/read/special-comment.rkt racket-7.0+ppa1/src/expander/read/special-comment.rkt --- racket-6.12+ppa1/src/expander/read/special-comment.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/special-comment.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base + +(provide special-comment? + make-special-comment + special-comment-value) + +(struct special-comment (value) + #:authentic + #:constructor-name make-special-comment) diff -Nru racket-6.12+ppa1/src/expander/read/special.rkt racket-7.0+ppa1/src/expander/read/special.rkt --- racket-6.12+ppa1/src/expander/read/special.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/special.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ +#lang racket/base +(require "../common/inline.rkt" + "config.rkt") + +;; The reader should never use `read-char` or `peek-char`. Instead, +;; use `read-char/special` or `peek-char/special`, so that special +;; values are never treated as characters, and so that `read-syntax` +;; mode provides the source name. + +(provide (struct-out special) + read-char/special + peek-char/special) + +(struct special (value)) + +(define-inline (read-char/special in config [source (read-config-source config)]) + (read-char-or-special in special source)) + +;; Returns `(special 'special)` for any special value: +(define-inline (peek-char/special in config [skip-count 0] [source (read-config-source config)]) + (define c (peek-char-or-special in skip-count 'special source)) + (if (eq? c 'special) + (special 'special) + c)) diff -Nru racket-6.12+ppa1/src/expander/read/string.rkt racket-7.0+ppa1/src/expander/read/string.rkt --- racket-6.12+ppa1/src/expander/read/string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,235 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "digit.rkt") + +(provide read-string + read-here-string) + +(define (read-string in config #:mode [mode 'string]) + (define source (read-config-source config)) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define accum-str (accum-string-init! config)) + (define (bad-end c) + (cond + [(eof-object? c) + (reader-error in config #:due-to c #:end-pos open-end-pos "expected a closing `\"`")] + [else + (reader-error in config #:due-to c + "found non-character while reading a ~a" + mode)])) + (let loop () + (define c (read-char/special in config source)) + ;; Note: readtable is not used for a closing " or other string decisions + (cond + [(not (char? c)) + (bad-end c)] + [(char=? #\\ c) + (define escaping-c c) + (define escaped-c (read-char/special in config source)) + (when (not (char? escaped-c)) + (bad-end escaped-c)) + (define (unknown-error) + (reader-error in config + "unknown escape sequence `~a~a` in ~a" + escaping-c escaped-c + mode)) + (case escaped-c + [(#\\ #\" #\') + (accum-string-add! accum-str escaped-c)] + [(#\a) (accum-string-add! accum-str #\u7)] + [(#\b) (accum-string-add! accum-str #\backspace)] + [(#\t) (accum-string-add! accum-str #\tab)] + [(#\n) (accum-string-add! accum-str #\newline)] + [(#\v) (accum-string-add! accum-str #\vtab)] + [(#\f) (accum-string-add! accum-str #\page)] + [(#\r) (accum-string-add! accum-str #\return)] + [(#\e) (accum-string-add! accum-str #\u1B)] + [(#\newline) (void)] + [(#\return) + (define maybe-newline-c (peek-char/special in config 0 source)) + (when (eqv? maybe-newline-c #\newline) + (consume-char in maybe-newline-c)) + (void)] + [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) + ;; Octal (valid if <= 255) + (define pos (accum-string-count accum-str)) + (accum-string-add! accum-str escaped-c) + (define init-v (digit->number escaped-c)) + (define v (read-digits in config accum-str #:base 8 #:max-count 2 + #:init init-v + #:zero-digits-result init-v)) + (unless (v . <= . 255) + (reader-error in config + "escape sequence `~a~a` is out of range in ~a" + escaping-c (accum-string-get! accum-str config #:start-pos pos) + mode)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [(#\x) + ;; Hex, two characters (always valid) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 2)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [(#\u) + ;; Hex, four characters (valid if not surrogate or if surrogate pair) + (unless (eq? mode 'string) (unknown-error)) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 4)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (cond + [(or (v . < . #xD800) (v . > . #xDFFF)) + ;; Normal \u escape + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [else + ;; Maybe a surrogate-pair encoding + (define (next!) + (define next-c (read-char/special in config source)) + (when (char? next-c) + (accum-string-add! accum-str next-c)) + next-c) + (define v2 + (let ([next-c (next!)]) + (cond + [(char=? next-c #\\) + (define next-c (next!)) + (cond + [(char=? next-c #\u) + (define v2 (read-digits in config accum-str #:base 16 #:max-count 4)) + (cond + [(integer? v2) + (and (v2 . >= . #xDC00) + (v2 . <= . #xDFFF) + v2)] + [else v2])] ; maybe EOF + [else next-c])] ; maybe EOF + [else next-c]))) ; maybe EOF + (cond + [(integer? v2) + (define combined-v (+ (arithmetic-shift (- v #xD800) 10) + (- v2 #xDC00) + #x10000)) + (cond + [(combined-v . > . #x10FFFF) + (reader-error in config + "escape sequence `~au~a` is out of range in string" + escaping-c (accum-string-get! accum-str config #:start-pos pos))] + [else + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char combined-v))])] + [else + (reader-error in config + #:due-to v2 + "bad or incomplete surrogate-style encoding at `~au~a`" + escaping-c (accum-string-get! accum-str config #:start-pos pos))])])] + [(#\U) + (unless (eq? mode 'string) (unknown-error)) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 8)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (cond + [(and (or (v . < . #xD800) (v . > . #xDFFF)) + (v . <= . #x10FFFF)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [else + (reader-error in config + "escape sequence `~aU~a` is out of range in string" + escaping-c (accum-string-get! accum-str config #:start-pos pos))])] + [else (unknown-error)]) + (loop)] + [(char=? #\" c) + null] + [else + (when (eq? mode '|byte string|) + (unless (byte? (char->integer c)) + (reader-error in config + "character `~a` is out of range in byte string" + c))) + (accum-string-add! accum-str c) + (loop)])) + (define str (if (eq? mode '|byte string|) + (accum-string-get-bytes! accum-str config) + (accum-string-get! accum-str config))) + (wrap str + in + config + str)) + +;; ---------------------------------------- + +(define (read-here-string in config) + (define source (read-config-source config)) + (define-values (open-end-line open-end-col open-end-pos) (port-next-location in)) + (define accum-str (accum-string-init! config)) + + ;; Parse terminator + (define full-terminator + (cons + #\newline ;; assumption below that this character is first + (let loop () + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (reader-error in config #:due-to c + "found end-of-file after `#<<` and before a newline")] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character while reading `#<<`")] + [(char=? c #\newline) null] + [else (cons c (loop))])))) + + ;; Get string content. + ;; We just saw a newline that could be considered the start of an + ;; immediate `full-terminator`. + (let loop ([terminator (cdr full-terminator)] [terminator-accum null]) + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (unless (null? terminator) + (reader-error in config #:due-to c #:end-pos open-end-pos + "found end-of-file before terminating `~a`" + (list->string (cdr full-terminator))))] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character while reading `#<<`")] + [(and (pair? terminator) + (char=? c (car terminator))) + (loop (cdr terminator) (cons (car terminator) terminator-accum))] + [(and (null? terminator) + (char=? c #\newline)) + (void)] + [else + (unless (null? terminator-accum) + (for ([c (in-list (reverse terminator-accum))]) + (accum-string-add! accum-str c))) + (cond + [(char=? c #\newline) + ;; assume `full-terminator` starts with #\newline + (loop (cdr full-terminator) (list #\newline))] + [else + (accum-string-add! accum-str c) + (loop full-terminator null)])])) + + ;; Done + (define str (accum-string-get! accum-str config)) + (wrap str + in + config + str)) + +;; ---------------------------------------- + +(define (no-hex-digits in config c escaping-c escaped-c) + (reader-error in config + #:due-to c + "no hex digit following `~a~a`" + escaping-c escaped-c)) diff -Nru racket-6.12+ppa1/src/expander/read/struct.rkt racket-7.0+ppa1/src/expander/read/struct.rkt --- racket-6.12+ppa1/src/expander/read/struct.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/struct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,75 @@ +#lang racket/base +(require "../common/prefab.rkt" + "readtable.rkt" + "config.rkt" + "special.rkt" + "parameter.rkt" + "error.rkt" + "wrap.rkt" + "closer.rkt" + "sequence.rkt") + +(provide read-struct) + +(define (read-struct read-one dispatch-c in config) + (define c (read-char/special in config)) + + (define-syntax-rule (guard-legal e body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~as~a" dispatch-c c))])) + + (define ec (effective-char c config)) + (define seq + (case ec + [(#\() + (read-struct-sequence read-one c #\( #\) in config)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (read-struct-sequence read-one c #\[ #\] in config))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (read-struct-sequence read-one c #\{ #\} in config))] + [else + (reader-error in config + "expected ~a after `~as`" + (all-openers-str config) + dispatch-c)])) + + (when (null? seq) + (reader-error in config + "missing structure description in `~as` form" + dispatch-c)) + + (unless (prefab-key? (car seq)) + (reader-error in config + "invalid structure description in `~as` form" + dispatch-c)) + + (define st (with-handlers ([exn:fail? (lambda (exn) #f)]) + (prefab-key->struct-type (car seq) (length (cdr seq))))) + (unless st + (reader-error in config + (string-append "mismatch between structure description" + " and number of provided field values in `~as` form") + dispatch-c)) + + (when (read-config-for-syntax? config) + (unless (all-fields-immutable? (car seq)) + (reader-error in config + "cannot read mutable `~as` form as syntax" + dispatch-c))) + + (wrap (apply make-prefab-struct seq) + in + config + ec)) + +;; ---------------------------------------- + +(define (read-struct-sequence read-one opener-c opener closer in config) + (read-unwrapped-sequence read-one opener-c opener closer in config + #:first-read-one (lambda (init-c in config) + (read-one init-c in (disable-wrapping config))))) diff -Nru racket-6.12+ppa1/src/expander/read/symbol-or-number.rkt racket-7.0+ppa1/src/expander/read/symbol-or-number.rkt --- racket-6.12+ppa1/src/expander/read/symbol-or-number.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/symbol-or-number.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,140 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "delimiter.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "parameter.rkt" + "number.rkt") + +(provide read-symbol-or-number) + +(define (read-symbol-or-number init-c in orig-config + ;; `mode` can be 'symbol-or-number, + ;; 'symbol, 'symbol/indirect, 'keyword, + ;; or a number prefix string like "#e"; + ;; only the 'symbol-or-number and + ;; 'symbol modes use a readtable's + ;; symbol handler + #:mode [mode 'symbol-or-number] + #:extra-prefix [extra-prefix #f]) + (define config (if (string? mode) + (override-parameter read-cdot orig-config #f) + orig-config)) + (define rt (read-config-readtable config)) + (cond + [(and rt + (or (eq? mode 'symbol-or-number) + (eq? mode 'symbol/indirect)) + (readtable-symbol-parser rt)) + => (lambda (handler) + (readtable-apply handler init-c in + config + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [else + (define accum-str (accum-string-init! config)) + (define quoted-ever? #f) + (define case-sens? (check-parameter read-case-sensitive config)) + (when extra-prefix + (accum-string-add! accum-str extra-prefix)) + (define source (read-config-source config)) + + ;; If we encounter an EOF or special in the wrong place: + (define (unexpected-quoted c after-c) + (reader-error in config + #:due-to c + "~a following `~a` in ~a" + (if (eof-object? c) "end-of-file" "non-character") + after-c (cond + [(eq? mode 'keyword) "keyword"] + [(string? mode) "number"] + [else "symbol"]))) + + (let loop ([init-c init-c] + [pipe-quote-c #f] ; currently quoting? + [foldcase-from 0]) ; keep track of range to foldcase for case-insens + (define c (or init-c (peek-char/special in config 0 source))) + (define ec (readtable-effective-char rt c)) + (cond + [(and pipe-quote-c + (not (char? ec))) + ;; Interrupted while in quoting mode + (unless init-c (consume-char/special in config c)) + (unexpected-quoted c pipe-quote-c)] + [(and (not pipe-quote-c) + (readtable-char-delimiter? rt c config)) + ;; EOF or other delimiter - done! + (unless case-sens? + (accum-string-convert! accum-str string-foldcase foldcase-from))] + [(and pipe-quote-c + (char=? c pipe-quote-c)) ; note: `pipe-quote-c` determines close, not readtable + ;; End quoting mode + (unless init-c (consume-char in c)) + (loop #f #f (accum-string-count accum-str))] + [(and (char=? ec #\|) + (check-parameter read-accept-bar-quote config)) + ;; Start quoting mode + (unless init-c (consume-char in c)) + (set! quoted-ever? #t) + (unless case-sens? + (accum-string-convert! accum-str string-foldcase foldcase-from)) + (loop #f c (accum-string-count accum-str))] + [(and (char=? ec #\\) + (not pipe-quote-c)) + ;; Single-character quoting + (unless init-c (consume-char in c)) + (define next-c (read-char/special in config source)) + (unless (char? next-c) + (unexpected-quoted next-c c)) + (unless (or pipe-quote-c case-sens?) + (accum-string-convert! accum-str string-foldcase foldcase-from)) + (accum-string-add! accum-str next-c) + (set! quoted-ever? #t) + (loop #f #f (accum-string-count accum-str))] + [else + ;; Everything else + (unless init-c (consume-char in c)) + (accum-string-add! accum-str c) + (loop #f pipe-quote-c foldcase-from)])) + + (define str (accum-string-get! accum-str config)) + + ;; Disallow "." as a symbol + (when (and (= 1 (string-length str)) + (not quoted-ever?) + (char=? #\. (effective-char (string-ref str 0) config))) + (reader-error in config "illegal use of `.`")) + + (define num + (and (or (eq? mode 'symbol-or-number) + (string? mode)) + (not quoted-ever?) + (string->number (if (string? mode) + (string-append mode str) + str) + 10 + 'read + (if (check-parameter read-decimal-as-inexact config) + 'decimal-as-inexact + 'decimal-as-exact)))) + (when (string? num) + (reader-error in config "~a" num)) + + (when (and (not num) + (string? mode)) + (reader-error in config + "bad number: `~a`" + (string-append mode str))) + + (wrap (or num + (and (eq? mode 'keyword) + (string->keyword str)) + (string->symbol str)) + in + config + str)])) diff -Nru racket-6.12+ppa1/src/expander/read/vector.rkt racket-7.0+ppa1/src/expander/read/vector.rkt --- racket-6.12+ppa1/src/expander/read/vector.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/vector.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,134 @@ +#lang racket/base +(require racket/fixnum + racket/flonum + "config.rkt" + "special.rkt" + "sequence.rkt" + "wrap.rkt" + "error.rkt" + "consume.rkt" + "digit.rkt" + "parameter.rkt" + "accum-string.rkt" + "fixnum-flonum.rkt") + +(provide read-vector + read-fixnum-or-flonum-vector) + +(define (read-vector read-one opener-c opener closer in config + #:mode [vector-mode 'any] + #:length [expected-len #f]) + (define read-one-element + (case vector-mode + [(any) read-one] + [(fixnum) (lambda (init-c in config) (read-fixnum read-one init-c in config))] + [(flonum) (lambda (init-c in config) (read-flonum read-one init-c in config))])) + + (define seq (read-unwrapped-sequence read-one-element + opener-c opener closer in config + #:whitespace-read-one read-one + #:dot-mode #f)) + + ;; Extend `seq` as needed to match the declared length + (define vec + (cond + [(not expected-len) + (case vector-mode + [(any) (list->vector seq)] + [(fixnum) (for/fxvector #:length (length seq) ([e (in-list seq)]) e)] + [(flonum) (for/flvector #:length (length seq) ([e (in-list seq)]) e)])] + [else + (define len (length seq)) + (cond + [(= expected-len len) (list->vector seq)] + [(expected-len . < . len) + (reader-error in config + "~avector length ~a is too small, ~a values provided" + (case vector-mode + [(any) ""] + [(fixnum) "fx"] + [(flonum) "fl"]) + expected-len len)] + [else + (define (last-or v) + (if (null? seq) + (wrap v in config #f) + (let loop ([seq seq]) + (if (null? (cdr seq)) (car seq) (loop (cdr seq)))))) + (when ((integer-length expected-len) . >= . 48) + ;; implausibly large + (raise (exn:fail:out-of-memory "out of memory" (current-continuation-marks)))) + (define vec + (case vector-mode + [(any) (make-vector expected-len (last-or 0))] + [(fixnum) (make-fxvector expected-len (last-or 0))] + [(flonum) (make-flvector expected-len (last-or 0.0))])) + (case vector-mode + [(any) (for ([e (in-list seq)] + [i (in-naturals)]) + (vector-set! vec i e))] + [(fixnum) (for ([e (in-list seq)] + [i (in-naturals)]) + (fxvector-set! vec i e))] + [(flonum) (for ([e (in-list seq)] + [i (in-naturals)]) + (flvector-set! vec i e))]) + vec])])) + + (wrap vec + in + config + opener)) + +;; ---------------------------------------- + +(define (read-fixnum-or-flonum-vector read-one dispatch-c c c2 in config) + (define vector-mode (if (char=? c2 #\x) 'fixnum 'flonum)) + (consume-char in c2) + (when (read-config-for-syntax? config) + (reader-error in config "literal f~avectors not allowed" c2)) + + (define c3 (read-char/special in config)) + (define-values (vector-len len-str c4) + (cond + [(decimal-digit? c3) (read-simple-number in config c3)] + [else (values #f "" c3)])) + + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~a~a" dispatch-c c))])) + + (case c4 + [(#\() + (read-vector read-one #\( #\( #\) in config #:mode vector-mode #:length vector-len)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (format "~a~a" c c2) + (read-vector read-one #\[ #\[ #\] in config #:mode vector-mode #:length vector-len))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (format "~a~a" c c2) + (read-vector read-one #\{ #\{ #\} in config #:mode vector-mode #:length vector-len))] + [else + (reader-error in config #:due-to c4 + "expected `(`, `[`, or `{` after `#~a~a~a`" + c c2 len-str)])) + + +(define (read-simple-number in config init-c) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + (define init-v (digit->number init-c)) + (define v (read-digits in config accum-str + #:base 10 #:max-count +inf.0 + #:init init-v + #:zero-digits-result init-v)) + (values v + (accum-string-get! accum-str config) + ;; We could avoid some peeks vising init-c + ;; and having `read-digit` return its peek + ;; result, but we don't for now + (read-char/special in config))) diff -Nru racket-6.12+ppa1/src/expander/read/whitespace.rkt racket-7.0+ppa1/src/expander/read/whitespace.rkt --- racket-6.12+ppa1/src/expander/read/whitespace.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/whitespace.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,112 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "special.rkt" + "readtable.rkt" + "consume.rkt" + "error.rkt" + "location.rkt" + "special.rkt" + "special-comment.rkt") + +(provide read-char/skip-whitespace-and-comments) + +;; Skip whitespace, including non-character values that are +;; `special-comment?`s --- but return a special comment (always +;; `special`-wrapped) if `(read-config-keep-comment? config)`. The +;; result is a character that has been consumed. +(define (read-char/skip-whitespace-and-comments init-c read-one in config) + (define rt (read-config-readtable config)) + (define source (read-config-source config)) + (let skip-loop ([init-c init-c]) + (define c (or init-c + (read-char/special in config source))) + (define ec (readtable-effective-char rt c)) + (cond + [(eof-object? ec) c] + [(not (char? ec)) + (define v (special-value c)) + (cond + [(and (special-comment? v) + (not (read-config-keep-comment? config))) + (skip-loop #f)] + [else c])] + [(char-whitespace? ec) + (skip-loop #f)] + [(char=? #\; ec) + (let loop () + (define c (read-char/special in config source)) + (unless (or (eof-object? c) + (eqv? #\newline (effective-char c config))) + (loop))) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\| (peek-char/special in config 0 source))) + (skip-pipe-comment! c in config) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\! (peek-char/special in config 0 source)) + (let ([c3 (peek-char/special in config 1 source)]) + (or (eqv? #\space c3) + (eqv? #\/ c3)))) + (skip-unix-line-comment! in config) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\; (peek-char/special in config 0 source))) + (consume-char in #\;) + (define v (read-one #f in config)) + (when (eof-object? v) + (reader-error in config + #:due-to v + "expected a commented-out element for `~a;`, but found end-of-file" + ec)) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [else c]))) + +;; For returning a comment as a result: +(define (result-special-comment) + (special (make-special-comment #f))) + +;; Skips balanced pipe comments +(define (skip-pipe-comment! init-c in config) + (define source (read-config-source config)) + (define-values (line col pos) (port-next-location in)) + (consume-char in #\|) + (let loop ([prev-c #f] [depth 0]) + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (reader-error in (reading-at config line col pos) + #:due-to c + "end of file in `#|` comment")] + [(not (char? c)) + (loop #f depth)] + [(and (char=? #\| c) (eqv? prev-c #\#)) + (loop #f (add1 depth))] + [(and (char=? #\# c) (eqv? prev-c #\|)) + (when (positive? depth) + (loop #f (sub1 depth)))] + [else (loop c depth)]))) + +;; Skips a comment that starts #! and runs to the end of the line, but +;; can be continued with `\` at the end of the line +(define (skip-unix-line-comment! in config) + (let loop ([backslash? #f]) + (define c (read-char/special in config)) + (cond + [(eof-object? c) (void)] + [(not (char? c)) (loop #f)] + [(char=? c #\newline) + (when backslash? + (loop #f))] + [(char=? c #\\) + (loop #t)] + [else (loop #f)]))) diff -Nru racket-6.12+ppa1/src/expander/read/wrap.rkt racket-7.0+ppa1/src/expander/read/wrap.rkt --- racket-6.12+ppa1/src/expander/read/wrap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/read/wrap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,10 @@ +#lang racket/base +(require "config.rkt") + +(provide wrap) + +(define (wrap s-exp in config rep) + (define wrap (read-config-wrap config)) + (if wrap + (wrap s-exp (port+config->srcloc in config) rep) + s-exp)) diff -Nru racket-6.12+ppa1/src/expander/README.txt racket-7.0+ppa1/src/expander/README.txt --- racket-6.12+ppa1/src/expander/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,250 @@ +This package contains the implementation of Racket's front-end: macro +expander, reader, and module systems. A copy of this implementation is +extracted and built into the Racket executable, so normally this +package's modules are not run directly. The expander or reader can be +run separately, however, and the Racket expander is updated by +modifying this package as it exists in the main Racket Git repository. + +Running: + + % racket demo.rkt + or + % racket bootstrap-demo.rkt + + Runs the examples/tests in "demo.rkt". The tests are not remotely + complete, but they're a quick and useful sanity check. The + "demo.rkt" module uses the somewhat internal interface exported by + `main`, where the expansion, compilation, and evaluation are less + overloaded and more controllable. + + Use the "bootstrap-demo.rkt" when running in an older version of + Racket that is not built with this expander (but that version of + Racket must be new enough to provide a primitive '#%linklet module + as a bootstrapping hook). + + % racket run.rkt -c + or + % racket bootstrap-run.rkt -c + + Runs the expander to load itself from source. Expanded and compiled + modules are stored in , somewhat like bytecode files. + Dependency tracking doesn't take into account the expander itself, + so throw away if the expander changes in a way that you want + reflected in compilation results. + + % racket run.rkt -c -l + % racket run.rkt -c -t + + Runs the expander to load the specified module (instead of the + default module, which is the expander itself). + + When running with a new enough version of Racket that "run.rkt" + works (as opposed to "bootstrap-run.rkt"), the performance of the + expander in this mode should be close to the performance when the + expander is built into the Racket executable. Beware, however, that + "run.rkt" implements just enough of the module loader protocol to + work as a bridge, so module loading and caching can have very + different performance than in an embedding build. + + Beware also that the flags above cause bytecode for the target + module to be cached, so running a second time will not test the + expander a second time. Prime the cache directory with modules that + don't change, and then use `-r` to load a module with a read-only + cache. + + % racket run.rkt -c -f + + Loads the given file as a sequence of top-level forms. + + % racket run.rkt -c -e -l + + Expands the given file, instead of compiling and running it. + + % racket run.rkt -c --linklets -l + + Compiles the given file to a set of linklets in S-expression form, + instead of compiling and running it. + + % racket run.rkt -c -x + + Checks possibility of converting a module to a stand-alone linklet + with no imports --- used mainly to extract the expander itself. + + % racket bootstrap-run.rkt -c -sx -t -o + + Expands and extracts as a single linklet to + . + + % racket bootstrap-run.rkt -c -sx -D -t -o + + Expands and extracts as a single linklet, compiles and + decompiles it, then writes the s-expression into . + + % racket bootstrap-run.rkt -c -sx -B -t -o + + Expands and extracts as a single linklet, compiles it + and then writes the bytecode into . + + % racket bootstrap-run.rkt -c -O /racket + + Compiles the expander to source files in --- note that + "bootstrap-run.rkt" must be used to get source compiles --- and + writes the flattened linklet to "startup.inc" in a Git checkout of + a linklet-based Racket. Be sure to increment the target Racket + version if you change the serialization of syntax objects or the + linklet protocol. + + When you `make`, then "startup.inc" will be automatically compiled + to bytecode for for embedding into the Racket executable. If you + change the expander in a way that makes existing compiled files + invalid, be sure to update "schvers.h". (Updating "schvers.h" is + important both for bytecode files and the makefile/preprocessor + dance that generates the bytecode version of the expander itself.) + + % make + + A shortcut for the above: When this package resides in an existing + in-place build from the main Racket repo, then the makefile uses + that copy of Racket to build the expander and drop a replacement + into the "src" directory. Re-making the Racket tree will then use + the updated expander. You may have to manually discard + "compiled/cache-src" when things change. + + % make demo + % make run ARGS=" ..." + + More shortcuts. Use `make run ARGS=" ..."` as a shorthand for `racket + run.rkt -c compiled/cache ...`. + + See "Makefile" for more information and other shortcuts. + +---------------------------------------- + +Roadmap to the implementation: + + read/ - the readers + demo.rkt - simple examples/tests for the reader + + syntax/ - syntax-object and binding representation + syntax.rkt - syntax-object structure + scope.rkt - scope sets and binding + binding.rkt - binding representations + binding-table.rkt - managing sets of bindings + + namespace/ - namespaces and module instances + + expand/ - expander loop and core forms + + common/ - utilities + module-path.rkt - [resolved] module path [indexes] + performance.rkt - performance instrumentation; enable statistic + gathering and reporting by changing this module + + compile/ - from expanded to S-expression linklet + main.rkt - compiler functions called from "eval/main.rkt" + + eval/ - evaluation + main.rkt - top-level evaluation, with top-level `module` forms as + an important special case; the `compile-to-linklets` + function compiles to a set of S-expression linklets + api.rkt - wrappers that implement `eval`, `compile`, and `expand` + for `racket/base` + + boot/ - internal initialization + handler.rkt - implements the default module name resolver, eval + handler, and compiler handler + ...-primitive.rkt - export built-in functions as modules + + run/ - helpers to drive the expander; not part of the resulting + expander's implementation + linklet.rkt - a bootstrapping implementation of `linklet` by + compilation into `lambda` plus primitives + + extract/ - extracts a module and its dependencies to a single + linklet, especially for extracting the compiler itself + (via "run.rkt"); not part of the resulting expander's + implementation + + main.rkt - installs eval handler, etc.; entry point for directly + running the expander/compiler/evaluator, and the provided + variables of this module become the entry points for the + embedded expander + + demo.rkt - exercises the expander and compiler (uses "main.rkt") + + run.rkt - starts a Racket replacement (uses "main.rkt") + + bootstrap-run.rkt - like "run.rkt", but for a host Racket that + does not include linklet support + + bootstrap-demo.rkt - like "demo.rkt", but for a host Racket that + does not include linklet support + +Beware that names are routinely shadowed when they are provided by +`racket/base` but replaced by the expander's implementation. For +example, `syntax?` is shadowed, and any part of the expander that +needs `syntax?` must import "syntax/syntax.rkt" or +"syntax/checked-syntax.rkt". + +---------------------------------------- + +Implementation guidelines: + + * Do not rely on more than `racket/base` for code that will be + extracted as the compiler implementation. (Relying on more in + "run/" or "extract/" is allowed.) + + * The runtime implementation of the expander must not itself use any + syntax objects or syntax function as provided by the Racket + implementation used to compile the expander. That means, for + example, that the contract system cannot be used in the + implementation of the expander, since the contract system manages + some information with syntax objects at run time. The + expander-extraction process double-checks that the expander is + independent of its host in this way. + + * The runtime implementation of the expander can refer (via + `#%kernel`) to reader primitives that are to be implemented by the + reader that is bundled with the expander. The extraction process + simply redirects those references to the implemented variants. + Beware that adjusting parameters from `#%kernel` will not change + the behavior of the bundled reader during bootrstapping of the + expander (i.e., for bootstrapping, always refer to the parameters + from the implementation in the "read" directory). + +---------------------------------------- + +Some naming conventions: + + s or stx - a syntax object + + sc - a scope + + scs - a set or list of scopes + + id - an identifier (obviously) + + b - a binding; sometimes spelled out as `binding` + + m - a result of syntax matching + + m - a module + + ns - a namespace + + ctx - an expansion context (including the expand-time environment) + + cctx - a compilation context (including a compile-time environment) + + insp - an inspector + + mpi - a module path index + + mod-name - a resolved module path, usually; sometimes used for other + forms of module reference + + c and ec - character and "effective" character (after readtable + mapping) in the reader + + - - like , but specifically one for + ; for example, `m-ns` is a namespace for some module diff -Nru racket-6.12+ppa1/src/expander/run/bootstrap.rkt racket-7.0+ppa1/src/expander/run/bootstrap.rkt --- racket-6.12+ppa1/src/expander/run/bootstrap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/bootstrap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang racket/base +(require "linklet.rkt" + (prefix-in host: '#%linklet) + "linklet-operation.rkt" + "../common/reflect-hash.rkt") + +;; Run this module before "../host/linklet.rkt" to substitute the +;; implementation in "linklet.rkt" + +(define bootstrap-linklet-instance + (host:primitive-table '#%bootstrap-linklet + (linklet-operations=> reflect-hash))) diff -Nru racket-6.12+ppa1/src/expander/run/cache.rkt racket-7.0+ppa1/src/expander/run/cache.rkt --- racket-6.12+ppa1/src/expander/run/cache.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/cache.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,128 @@ +#lang racket/base +(require racket/file + file/sha1) + +(provide make-cache + get-cached-compiled + cache-compiled! + register-dependency! + + current-cache-layer + make-cache-layer + + cache->used-paths) + +(struct cache (dir + [table #:mutable] ; filename -> entry [used for a cache file] + used ; to track dependencies + in-memory)) ; key -> code [when no cache filed is in use] + +(struct entry (key ; sha1 of filename + content ; sha1 of file content + dependencies) ; list of key + #:prefab) + +(define current-cache-layer (make-parameter #f)) + +;; A cache later collects immediate dependencies +;; for a module as it is compiled +(define (make-cache-layer) (box null)) + +(define (cache-dir->file cache-dir) + (build-path cache-dir "cache.rktd")) + +(define (make-cache cache-dir out-of-date-callback) + (define cache-file (and cache-dir + (cache-dir->file cache-dir))) + (define table + (if (and cache-file + (file-exists? cache-file)) + (only-up-to-date (call-with-input-file* cache-file read) + cache-dir + out-of-date-callback) + #hash())) + (cache cache-dir table (make-hash) (make-hash))) + +(define (only-up-to-date table cache-dir out-of-date-callback) + ;; Build a new table imperatively (as a kind of memoization) + (define new-table (make-hash)) + (define reported (make-hash)) + (define (up-to-date? path e) + (or (hash-ref new-table path #f) + (and (file-exists? path) + (file-exists? (build-path cache-dir (entry-key e))) + (equal? (call-with-input-file* path sha1) + (entry-content e)) + (for/and ([path (in-list (entry-dependencies e))]) + (define e (hash-ref table path #f)) + (and e (up-to-date? path e))) + (begin + (hash-set! new-table path e) + #t)) + (begin + (unless (hash-ref reported path #f) + (hash-set! reported path #t) + (out-of-date-callback path)) + #f))) + ;; Check all file content and dependencies: + (for ([(k e) (in-hash table)]) + (up-to-date? k e)) + ;; Convert back to immutable: + (for/hash ([(k e) (in-hash new-table)]) + (values k e))) + +(define (get-cached-compiled cache path [notify-success void]) + (hash-set! (cache-used cache) path #t) + (define e (hash-ref (cache-table cache) + (path->string path) + #f)) + (define cached-file (and e + (cache-dir cache) + (build-path (cache-dir cache) + (entry-key e)))) + (cond + [(and cached-file + (file-exists? cached-file)) + (notify-success) + (parameterize ([read-accept-compiled #t]) + (call-with-input-file* cached-file read))] + [(and e + (hash-ref (cache-in-memory cache) (entry-key e) #f)) + => (lambda (c) + (notify-success) + c)] + [else #f])) + +(define (register-dependency! cache path) + (define l (current-cache-layer)) + (when l + (define deps (unbox l)) + (define s (path->string path)) + (unless (member s deps) + (set-box! l (cons s deps))))) + +(define (cache-compiled! cache path c layer) + (define key (sha1 (open-input-bytes (path->bytes path)))) + (define file-content (call-with-input-file* path sha1)) + (define new-table (hash-set (cache-table cache) (path->string path) + (entry key + file-content + (unbox layer)))) + (set-cache-table! cache new-table) + (cond + [(cache-dir cache) + (define cache-file (cache-dir->file (cache-dir cache))) + (make-directory* (cache-dir cache)) + (call-with-output-file* + #:exists 'truncate + (build-path (cache-dir cache) key) + (lambda (o) (write c o))) + (call-with-atomic-output-file + cache-file + (lambda (o path) (writeln new-table o)))] + [else + (hash-set! (cache-in-memory cache) key c)])) + + +(define (cache->used-paths cache) + (hash-keys (cache-used cache))) diff -Nru racket-6.12+ppa1/src/expander/run/correlated-to-host-syntax.rkt racket-7.0+ppa1/src/expander/run/correlated-to-host-syntax.rkt --- racket-6.12+ppa1/src/expander/run/correlated-to-host-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/correlated-to-host-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,26 @@ +#lang racket/base +(require "../syntax/datum-map.rkt" + "../host/correlate.rkt") + +;; Convert from `compile-linklet`-compatible representation to a +;; `compile`-compatible representation. + +(provide correlated->host-syntax) + +(define (correlated->host-syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(correlated? v) + (define e (correlated->host-syntax (correlated-e v))) + (define s (datum->syntax #f + e + (vector (correlated-source v) + (correlated-line v) + (correlated-column v) + (correlated-position v) + (correlated-span v)))) + (define keys (correlated-property-symbol-keys v)) + (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (correlated-property v key)))] + [else v])))) diff -Nru racket-6.12+ppa1/src/expander/run/host-syntax-to-syntax.rkt racket-7.0+ppa1/src/expander/run/host-syntax-to-syntax.rkt --- racket-6.12+ppa1/src/expander/run/host-syntax-to-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/host-syntax-to-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/datum-map.rkt" + (prefix-in host: racket/base)) + +;; Just like `reader-syntax->syntax`, but for the host notion of +;; syntax (which can be different if `racket/base` provides a +;; different notion of syntax as its `read-syntax` than then runtime +;; system's reader) + +(provide host-syntax->syntax) + +(define (host-syntax->syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(host:syntax? v) + (define e (host:syntax-e v)) + (cond + [(syntax? e) + ;; Readtable, #lang, and #reader callbacks can lead to a + ;; reader syntax wrapper on our syntax + e] + [else + (define s + (struct-copy syntax empty-syntax + [content (host-syntax->syntax (host:syntax-e v))] + [srcloc (srcloc (host:syntax-source v) + (host:syntax-line v) + (host:syntax-column v) + (host:syntax-position v) + (host:syntax-span v))])) + (define keys (host:syntax-property-symbol-keys v)) + (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (host:syntax-property v key) #t))])] + [else v])))) diff -Nru racket-6.12+ppa1/src/expander/run/linklet-operation.rkt racket-7.0+ppa1/src/expander/run/linklet-operation.rkt --- racket-6.12+ppa1/src/expander/run/linklet-operation.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/linklet-operation.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,47 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide linklet-operations=>) + +(define-syntax (linklet-operations=> stx) + (syntax-case stx () + [(_ form) + (datum->syntax + #'form + (cons #'form + '(primitive-table + primitive->compiled-position + compiled-position->primitive + primitive-in-category? + + linklet? + compile-linklet ; result is serializable + recompile-linklet + eval-linklet ; optional; result is not serializable + read-compiled-linklet + instantiate-linklet ; fills in an instance given linket an argument instances + + linklet-import-variables + linklet-export-variables + + instance? + make-instance + instance-name ; just for debugging and similar + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + linklet-directory? ; maps symbol lists to linklet bundles + hash->linklet-directory ; converts a hash table to a ld + linklet-directory->hash ; the other way + + linklet-bundle? ; maps symbols and fixnums to values + hash->linklet-bundle + linklet-bundle->hash + + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe?)))])) diff -Nru racket-6.12+ppa1/src/expander/run/linklet.rkt racket-7.0+ppa1/src/expander/run/linklet.rkt --- racket-6.12+ppa1/src/expander/run/linklet.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/linklet.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,521 @@ +#lang racket/base +(require racket/unsafe/undefined + "../common/set.rkt" + "../syntax/datum-map.rkt" + "../host/correlate.rkt" + "../common/reflect-hash.rkt" + "../boot/runtime-primitive.rkt" + "correlated-to-host-syntax.rkt" + "linklet-operation.rkt") + +;; A "linklet" is the primitive form of separate (not necessarily +;; independent) compilation and linking. A `linklet` is serializable +;; linklet, and instantiation of a linklet produces an "instance" +;; given other instances to satisfy its imports. An instance, which +;; essentially just maps symbols to values, can also be created +;; directly, so it serves as the bridge between the worlds of values +;; and compiled objects. + +;; A "linklet bundle" is similarly a primitive construct that is +;; essentially a mapping of symbols and fixnums to linklets, symbols, +;; and symbol lists. A bundle is used, for example, to implement a +;; module (which is a collection of linklets plus some static +;; metadata). + +;; Finally, a "linklet directory" is a primitive construct that is a +;; mapping of #f to a bundle and symbols to linklet directories. The +;; intent is that individual linklet bundles can be efficiently +;; extracted from the marshaled form of a linklet directory --- the +;; primitive form of accessing an indvidual submodule. + +;; For bootstrapping, we can implement linklets here by compiling +;; `linklet` to `lambda`. If the host Racket supports linklets, then +;; this is not necessary, except to the degree that `compile-linklet` +;; needs to be replaced with a variant that "compiles" to source. + +(define (variable-reference-from-unsafe? x) #f) + +;; See "linklet-operation.rkt": +(linklet-operations=> provide) + +;; Helpers for "extract.rkt" +(provide linklet-compile-to-s-expr ; a parameter; whether to "compile" to a source form + linklet-as-s-expr? + + s-expr-linklet-importss+localss + s-expr-linklet-exports+locals + s-expr-linklet-body) + +(struct linklet (compiled-proc ; takes self instance plus instance arguments to run the linklet body + importss ; list [length is 1 less than proc arity] of list of symbols + exports) ; list of symbols + #:prefab) + +(struct instance (name ; for debugging, typically a module name + phase + data ; any value (e.g., a namespace) + variables)) ; symbol -> value + +(define (make-instance name [data #f] [mode #f] . content) + (define i (instance name data (make-hasheq))) + (let loop ([content content]) + (cond + [(null? content) (void)] + [else + (unless (symbol? (car content)) + (raise-argument-error 'make-instance + "symbol?" + (car content))) + (when (null? (cdr content)) + (raise-arguments-error 'make-instance + "missing variable value" + "variable" (car content))) + (instance-set-variable-value! i (car content) (cadr content) mode) + (loop (cddr content))])) + i) + +(define (instance-variable-names i) + (hash-keys (instance-variables i))) + +(define (instance-variable-box i sym can-create?) + (or (hash-ref (instance-variables i) sym #f) + (if can-create? + (let ([b (box undefined)]) + (hash-set! (instance-variables i) sym b) + b) + (error 'link "missing binding: ~s" sym)))) + +(define (instance-set-variable-value! i sym val [constant? #f]) + (set-box! (instance-variable-box i sym #t) val)) + +(define (instance-unset-variable! i sym) + (set-box! (instance-variable-box i sym #t) undefined)) + +(define (instance-variable-value i sym [fail-k (lambda () (error "instance variable not found:" sym))]) + (define b (hash-ref (instance-variables i) sym #f)) + (cond + [(and b + (not (eq? (unbox b) undefined))) + (unbox b)] + [(procedure? fail-k) (fail-k)] + [else fail-k])) + +;; ---------------------------------------- + +(define undefined (gensym 'undefined)) + +(define (check-not-undefined val sym) + (if (eq? val undefined) + (check-not-unsafe-undefined unsafe-undefined sym) + val)) + +;; ---------------------------------------- + +(define (primitive-table name) + (cond + [(eq? name '#%bootstrap-linklet) #f] + [(eq? name '#%linklet) (linklet-operations=> reflect-hash)] + [else + (define mod-name `(quote ,name)) + (define-values (vars trans) (module->exports mod-name)) + (for/hasheq ([sym (in-list (map car (cdr (assv 0 vars))))]) + (values sym + (dynamic-require mod-name sym)))])) + +;; Bootstrap implementation doesn't support bytecode: +(define (primitive->compiled-position v) #f) +(define (compiled-position->primitive pos) #f) +(define (primitive-in-category? name cat-sym) #f) + +;; ---------------------------------------- + +(struct variable-reference (instance primitive-varref)) + +(define (variable-reference->instance vr [ref-site? #f]) + (and (or ref-site? + ;; It would be better to have a `variable-reference-anonymous?` predicate: + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (variable-reference->module-declaration-inspector + (variable-reference-primitive-varref vr)))) + ;; Always returning ref-site instance; that's good enough to + ;; bootstrap: + (variable-reference-instance vr))) + +(define variable-reference-constant?* + (let ([variable-reference-constant? + (lambda (vr) + (variable-reference-constant? (variable-reference-primitive-varref vr)))]) + variable-reference-constant?)) + + +(define variable-reference-from-unsafe?* + (let ([variable-reference-from-unsafe? + (lambda (vr) + (variable-reference-from-unsafe? (variable-reference-primitive-varref vr)))]) + variable-reference-from-unsafe?)) + +;; ---------------------------------------- + +(define cu-namespace (make-empty-namespace)) +(namespace-attach-module (current-namespace) ''#%builtin cu-namespace) +(parameterize ([current-namespace cu-namespace]) + (for ([name (in-list runtime-instances)]) + (namespace-require `',name)) + (namespace-require ''#%linklet) + (namespace-set-variable-value! 'check-not-undefined check-not-undefined) + (namespace-set-variable-value! 'instance-variable-box instance-variable-box) + (namespace-set-variable-value! 'variable-reference variable-reference) + (namespace-set-variable-value! 'variable-reference? variable-reference? #t) + (namespace-set-variable-value! 'variable-reference->instance variable-reference->instance #t) + (namespace-set-variable-value! 'variable-reference-constant? variable-reference-constant?* #t) + (namespace-set-variable-value! 'variable-reference-from-unsafe? variable-reference-from-unsafe?* #t)) + +;; ---------------------------------------- + +;; Compile a `linklet` to a plain `lambda`. Also, convert from the +;; notion of correlated that works for `compile-linklet` to the notion +;; of host syntax objects that works for `compile`. +(define (desugar-linklet c) + (define imports (list-ref c 1)) + (define exports (list-ref c 2)) + (define bodys (list-tail c 3)) + (define inst-names (for/list ([import (in-list imports)] + [i (in-naturals)]) + (string->symbol (format "in_~a" i)))) + (define import-box-bindings + (for/list ([inst-imports (in-list imports)] + [inst (in-list inst-names)] + #:when #t + [name (in-list inst-imports)]) + (define ext (if (symbol? name) name (car name))) + (define int (if (symbol? name) name (cadr name))) + `[(,int) (instance-variable-box ,inst ',ext #f)])) + (define export-box-bindings + (for/list ([name (in-list exports)]) + (define int (if (symbol? name) name (car name))) + (define ext (if (symbol? name) name (cadr name))) + `[(,int) (instance-variable-box self-inst ',ext #t)])) + (define box-bindings (append import-box-bindings export-box-bindings)) + (define import-box-syms (apply seteq (map caar import-box-bindings))) + (define box-syms (set-union import-box-syms + (apply seteq (map caar export-box-bindings)))) + (define (desugar e) + (cond + [(correlated? e) + (correlate e (desugar (correlated-e e)))] + [(symbol? e) (if (set-member? box-syms e) + (if (set-member? import-box-syms e) + `(unbox ,e) + `(check-not-undefined (unbox ,e) ',e)) + e)] + [(pair? e) + (case (correlated-e (car e)) + [(quote) e] + [(set!) + (define-correlated-match m e '(set! var rhs)) + (if (set-member? box-syms (correlated-e (m 'var))) + `(set-box! ,(m 'var) ,(desugar (m 'rhs))) + `(set! ,(m 'var) ,(desugar (m 'rhs))))] + [(define-values) + (define-correlated-match m e '(define-values (id ...) rhs)) + (define ids (m 'id)) + (define tmps (map gensym (map correlated-e ids))) + `(define-values ,(for/list ([id (in-list ids)] + #:when (not (set-member? box-syms (correlated-e id)))) + id) + (let-values ([,tmps (let-values ([,ids ,(desugar (m 'rhs))]) + (values ,@ids))]) + (begin + ,@(for/list ([id (in-list ids)] + [tmp (in-list tmps)] + #:when (set-member? box-syms (correlated-e id))) + `(set-box! ,id ,tmp)) + (values ,@(for/list ([id (in-list ids)] + [tmp (in-list tmps)] + #:when (not (set-member? box-syms (correlated-e id)))) + tmp)))))] + [(lambda) + (define-correlated-match m e '(lambda formals body)) + `(lambda ,(m 'formals) ,(desugar (m 'body)))] + [(case-lambda) + (define-correlated-match m e '(case-lambda [formals body] ...)) + `(case-lambda ,@(for/list ([formals (in-list (m 'formals))] + [body (in-list (m 'body))]) + `[,formals ,(desugar body)]))] + [(#%variable-reference) + (if (and (pair? (correlated-e (cdr (correlated-e e)))) + (set-member? box-syms (correlated-e (correlated-cadr e)))) + ;; Using a plain `#%variable-reference` (for now) means + ;; that all imported and exported variables count as + ;; mutable: + '(variable-reference self-inst (#%variable-reference)) + ;; Preserve info about a local identifier: + `(variable-reference self-inst ,e))] + [else (map desugar (correlated->list e))])] + [else e])) + (define (last-is-definition? bodys) + (define p (car (reverse bodys))) + (and (pair? p) (eq? (correlated-e (car p)) 'define-values))) + (correlated->host-syntax + `(lambda (self-inst ,@inst-names) + (let-values ,box-bindings + ,(cond + [(null? bodys) '(void)] + [else + `(begin + ,@(for/list ([body (in-list bodys)]) + (desugar body)) + ,@(if (last-is-definition? bodys) + '((void)) + null))]))))) + +;; #:pairs? #f -> list of list of symbols +;; #:pairs? #t -> list of list of (cons ext-symbol int-symbol) +(define (extract-import-variables-from-expression c #:pairs? pairs?) + (for/list ([is (in-list (unmarshal (list-ref c 1)))]) + (for/list ([i (in-list is)]) + (cond + [pairs? (if (symbol? i) + (cons i i) + (cons (car i) (cadr i)))] + [else (if (symbol? i) + i + (car i))])))) + +;; #:pairs? #f -> list of symbols +;; #:pairs? #t -> list of (cons ext-symbol int-symbol) +(define (extract-export-variables-from-expression c #:pairs? pairs?) + (for/list ([e (in-list (unmarshal (list-ref c 2)))]) + (cond + [pairs? (if (symbol? e) + (cons e e) + (cons (cadr e) (car e)))] + [else (if (symbol? e) + e + (cadr e))]))) + +;; ---------------------------------------- + +(define orig-eval (current-eval)) +(define orig-compile (current-compile)) + +(define linklet-compile-to-s-expr (make-parameter #f)) + +;; Compile to a serializable form +(define (compile-linklet c [name #f] [import-keys #f] [get-import (lambda (key) (values #f #f))] [options '(serializable)]) + (define l + (cond + [(linklet-compile-to-s-expr) + (marshal (correlated->datum/lambda-name c))] + [else + (define plain-c (desugar-linklet c)) + (parameterize ([current-namespace cu-namespace] + [current-eval orig-eval] + [current-compile orig-compile]) + ;; Use a vector to list the exported variables + ;; with the compiled bytecode + (linklet (compile plain-c) + (marshal (extract-import-variables-from-expression c #:pairs? #f)) + (marshal (extract-export-variables-from-expression c #:pairs? #f))))])) + (if import-keys + (values l import-keys) ; no imports added or removed + l)) + +;; For re-optimizing: +(define (recompile-linklet linklet name [import-keys #f] [get-import (lambda (key) (values #f #f))]) + (if import-keys + (values linklet import-keys) + linklet)) + +;; Intended for JIT preparation +;; (and we could compile to a function here) +(define (eval-linklet c) + c) + +(define (read-compiled-linklet in) + (read in)) + +;; Convert linklet to a procedure +(define (really-eval-linklet cl) + (parameterize ([current-namespace cu-namespace] + [current-eval orig-eval] + [current-compile orig-compile]) + (if (linklet? cl) + ;; Normal mode: compiled to struct + (eval (linklet-compiled-proc cl)) + ;; Assume previously "compiled" to source: + (or (hash-ref eval-cache cl #f) + (let ([proc (eval (desugar-linklet (unmarshal cl)))]) + (hash-set! eval-cache cl proc) + proc))))) +(define eval-cache (make-weak-hasheq)) + +;; Check whether we previously compiled a linket to source +(define (linklet-as-s-expr? cl) + (not (linklet? cl))) + +;; Instantiate +(define (instantiate-linklet linklet import-instances [target-instance #f] [use-prompt? #t]) + (cond + [(not target-instance) + ;; return newly created instance + (define target-instance (make-instance 'anonymous)) + (instantiate-linklet linklet import-instances target-instance) + target-instance] + [else + ;; return results via tail call + (apply (really-eval-linklet linklet) target-instance import-instances)])) + +;; ---------------------------------------- + +(define (linklet-import-variables linklet) + (if (linklet? linklet) + ;; Compiled to a prefab that includes metadata + (linklet-importss linklet) + ;; Previously "compiled" to source + (extract-import-variables-from-expression linklet #:pairs? #f))) + +(define (linklet-export-variables linklet) + (if (linklet? linklet) + ;; Compiled to a prefab that includes metadata + (linklet-exports linklet) + ;; Previously "compiled" to source + (extract-export-variables-from-expression linklet #:pairs? #f))) + +(define (s-expr-linklet-importss+localss linklet) + (extract-import-variables-from-expression linklet #:pairs? #t)) + +(define (s-expr-linklet-exports+locals linklet) + (extract-export-variables-from-expression linklet #:pairs? #t)) + +(define (s-expr-linklet-body linklet) + (unmarshal (list-tail linklet 3))) + +;; ---------------------------------------- + +(struct linklet-directory (table) + #:prefab) + +(define (hash->linklet-directory ht) + (linklet-directory ht)) + +(define (linklet-directory->hash ld) + (linklet-directory-table ld)) + +;; ---------------------------------------- + +(struct linklet-bundle (table) + #:prefab) + +(define (hash->linklet-bundle ht) + (linklet-bundle ht)) + +(define (linklet-bundle->hash ld) + (linklet-bundle-table ld)) + +;; ---------------------------------------- + +(struct path-bytes (bstr) #:prefab) +(struct unreadable (str) #:prefab) +(struct void-value () #:prefab) +(struct srcloc-parts (source line column position span) #:prefab) + +(define (marshal c) + (datum-map c (lambda (tail? c) + (cond + [(path? c) (path-bytes (path->bytes c))] + [(and (symbol? c) (symbol-unreadable? c)) (unreadable (symbol->string c))] + [(void? c) (void-value)] + [(srcloc? c) (srcloc-parts (marshal (srcloc-source c)) + (marshal (srcloc-line c)) + (marshal (srcloc-column c)) + (marshal (srcloc-position c)) + (marshal (srcloc-span c)))] + [else c])))) + +(define (unmarshal c) + (datum-map c + (lambda (tail? c) + (cond + [(path-bytes? c) (bytes->path (path-bytes-bstr c))] + [(unreadable? c) (string->unreadable-symbol (unreadable-str c))] + [(void-value? c) (void)] + [(srcloc-parts? c) (srcloc (marshal (srcloc-parts-source c)) + (marshal (srcloc-parts-line c)) + (marshal (srcloc-parts-column c)) + (marshal (srcloc-parts-position c)) + (marshal (srcloc-parts-span c)))] + [else c])))) + +;; Like `correlated->datum`, but preserves 'inferred-name information +;; by encoding it as a symbol in a `lambda` or `case-lambda` body. +;; Remove any existing symbol in the name position that might +;; otherwise be confused for the name. This conversion avoids parsing +;; expressions in general by relying on the fact that bindings are +;; renamed to avoid shadowing, `lambda`, `case-lambda`, or `quote`. +(define (correlated->datum/lambda-name c) + (define (strip-potential-name-from-body body) + (define-correlated-match m body #:try '(begin (quote _) body bodys ...)) + (cond + [(and (m) + (eq? 'begin (m 'begin)) + (eq? 'quote (m 'quote))) + (strip-potential-name-from-body + (if (null? (m 'bodys)) + (m 'body) + `(begin ,@(m 'bodys))))] + [else body])) + (let correlated->datum/lambda-name ([c c]) + (cond + [(and (pair? c) + (eq? (car c) 'lambda)) + (define-correlated-match m c '(lambda args body)) + `(lambda ,(correlated->datum (m 'args)) + ,(correlated->datum/lambda-name + (strip-potential-name-from-body (m 'body))))] + [(and (pair? c) + (eq? (car c) 'case-lambda)) + (define-correlated-match m c '(case-lambda [argss bodys] ...)) + `(case-lambda + ,@(for/list ([args (in-list (m 'argss))] + [body (in-list (m 'bodys))]) + `[,(correlated->datum args) + ,(correlated->datum/lambda-name + (strip-potential-name-from-body body))]))] + [(and (pair? c) + (eq? (car c) 'quote)) + (correlated->datum c)] + [(pair? c) + (cons (correlated->datum/lambda-name (car c)) + (correlated->datum/lambda-name (cdr c)))] + [(and (correlated? c) + (let ([e (correlated-e c)]) + (and (pair? e) + (or (eq? 'lambda (car e)) + (eq? 'case-lambda (car e))))) + (correlated-property c 'inferred-name)) + => (lambda (name) + (cond + [(void? name) + ;; Don't try to hide the name after all + (correlated->datum/lambda-name (correlated-e c))] + [else + ;; Encode `name` as a symbol in the function body: + (define lam (correlated->datum/lambda-name (correlated-e c))) + (cond + [(eq? 'lambda (car lam)) + (define-correlated-match m lam '(lambda args body)) + `(lambda ,(m 'args) (begin (quote ,name) ,(m 'body)))] + [else + (define-correlated-match m lam '(case-lambda [argss bodys] ...)) + (cond + [(null? (m 'argss)) + ;; give up on naming an empty `case-lambda` + lam] + [else + `(case-lambda + [,(car (m 'argss)) (begin (quote ,name) ,(car (m 'bodys)))] + ,@(cddr lam))])])]))] + [(correlated? c) + (correlated->datum/lambda-name (correlated-e c))] + [else + (correlated->datum c)]))) diff -Nru racket-6.12+ppa1/src/expander/run/status.rkt racket-7.0+ppa1/src/expander/run/status.rkt --- racket-6.12+ppa1/src/expander/run/status.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/status.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,28 @@ +#lang racket/base + +(provide log-status + lines) + +(define stderr (current-error-port)) + +(define (log-status fmt . args) + (apply fprintf stderr (string-append fmt "\n") args)) + +(define (lines prefix vals) + (apply + string-append + prefix + (let loop ([col (string-length prefix)] [vals vals]) + (cond + [(null? vals) null] + [else + (define s (format " ~a" (car vals))) + (define slen (string-length s)) + (define new-col (+ col slen)) + (cond + [(new-col . < . 80) + (cons s (loop new-col (cdr vals)))] + [else + (list* "\n" (make-string (string-length prefix) #\space) s + (loop (+ (string-length prefix) slen) + (cdr vals)))])])))) diff -Nru racket-6.12+ppa1/src/expander/run/submodule.rkt racket-7.0+ppa1/src/expander/run/submodule.rkt --- racket-6.12+ppa1/src/expander/run/submodule.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run/submodule.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(require "../eval/reflect.rkt") + +(provide extract-requested-submodule) + +(define (extract-requested-submodule m expected-module) + (define (drop-submodules m) + (module-compiled-submodules (module-compiled-submodules m #f null) + #t + null)) + (cond + [(symbol? expected-module) + (drop-submodules m)] + [else + (let loop ([m m] + [expected-module (cdr expected-module)] + [pos 1]) + (cond + [(null? expected-module) + (drop-submodules m)] + [else + (define new-m + (for/or ([m (in-list + (append + (module-compiled-submodules m #f) + (module-compiled-submodules m #t)))]) + (and (eq? (car expected-module) + (list-ref (module-compiled-name m) pos)) + m))) + (and new-m + (loop new-m (cdr expected-module) (add1 pos)))]))])) diff -Nru racket-6.12+ppa1/src/expander/run.rkt racket-7.0+ppa1/src/expander/run.rkt --- racket-6.12+ppa1/src/expander/run.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/run.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,356 @@ +#lang racket/base +(require racket/cmdline + racket/pretty + racket/runtime-path + (only-in racket/base + [eval host:eval] + [namespace-require host:namespace-require] + [current-library-collection-paths host:current-library-collection-paths] + [current-library-collection-links host:current-library-collection-links]) + compiler/depend + "common/set.rkt" + "main.rkt" + "namespace/namespace.rkt" + "common/module-path.rkt" + "eval/module-read.rkt" + "boot/kernel.rkt" + "run/cache.rkt" + "boot/runtime-primitive.rkt" + "host/linklet.rkt" + "run/status.rkt" + "run/submodule.rkt" + "host/correlate.rkt" + "extract/main.rkt" + (only-in "run/linklet.rkt" linklet-compile-to-s-expr)) + +(define-runtime-path main.rkt "main.rkt") + +;; Record all files that contribute to the result +(define dependencies (make-hash)) +(define extra-module-dependencies null) + +(define extract? #f) +(define expand? #f) +(define linklets? #f) +(define checkout-directory #f) +(define cache-dir #f) +(define cache-read-only? #f) +(define cache-save-only #f) +(define cache-skip-first? #f) +(define time-expand? #f) +(define print-extracted-to #f) +(define check-dependencies #f) +(define dependencies-file #f) +(define makefile-dependencies-target #f) +(define makefile-dependencies-file #f) +(define extract-to-c? #f) +(define extract-to-decompiled? #f) +(define extract-to-bytecode? #f) +(define instance-knot-ties (make-hasheq)) +(define primitive-table-directs (make-hasheq)) +(define side-effect-free-modules (make-hash)) +(define quiet-load? #f) +(define startup-module main.rkt) +(define submod-name #f) +(define load-file #f) +(define args + (command-line + #:once-any + [("-x" "--extract") "Extract bootstrap linklet" + (set! extract? #t)] + [("-e" "--expand") "Expand instead of running" + (set! expand? #t)] + [("--linklets") "Compile to linklets instead of running" + (set! linklets? #t)] + [("-O") dir "Use and write bootstrap linklet to Racket checkout at " + (set! checkout-directory (path->complete-path dir)) + (set! extract? #t) + (set! extract-to-c? #t) + (linklet-compile-to-s-expr #t) + (set! print-extracted-to (build-path checkout-directory "src" "racket" "src" "startup.inc"))] + #:once-each + [("-k") dir "Use Racket checkout at " + (set! checkout-directory (path->complete-path dir))] + [("-c" "--cache") dir "Save and load from " + (set! cache-dir (path->complete-path dir))] + [("-r" "--read-only") "Use cache in read-only mode" + (set! cache-read-only? #t)] + [("-y" "--cache-only") file "Cache only for sources listed in " + (set! cache-save-only (call-with-input-file* file read))] + [("-i" "--skip-initial") "Don't use cache for the initial load" + (set! cache-skip-first? #t)] + [("-s" "--s-expr") "Compile to S-expression instead of bytecode" + (linklet-compile-to-s-expr #t)] + [("-q" "--quiet") "Quiet load status" + (set! quiet-load? #t)] + [("--time") "Time re-expansion" + (set! time-expand? #t)] + [("-o" "--output") file "Print extracted bootstrap linklet to " + (when print-extracted-to (raise-user-error 'run "the `-O` flag implies `-o`, so don't use both")) + (set! print-extracted-to file)] + [("--check-depends") file "Skip if dependencies in unchanged" + (set! check-dependencies file)] + [("--depends") file "Record dependencies in " + (set! dependencies-file file)] + [("--makefile-depends") target file "Record makefile dependencies for in " + (set! makefile-dependencies-target target) + (set! makefile-dependencies-file file)] + #:multi + [("++depend") file "Record as a dependency" + (hash-set! dependencies (simplify-path (path->complete-path file)) #t)] + [("++depend-module") mod-file "Add and transitive as dependencies" + (set! extra-module-dependencies (cons mod-file extra-module-dependencies))] + #:once-any + [("-C") "Print extracted bootstrap as a C encoding" + (set! extract-to-c? #t)] + [("-D") "Print extracted bootstrap as a decompiled" + (set! extract-to-decompiled? #t)] + [("-B") "Print extracted bootstrap as bytecode" + (set! extract-to-bytecode? #t)] + #:multi + [("++knot") sym path "Redirect imports from to flattened from " + (hash-update! instance-knot-ties + (string->symbol (format "#%~a" sym)) + (lambda (l) (cons (if (equal? path "-") + 'ignore + (path->complete-path (normal-case-path path))) + l)) + null)] + [("++direct") primitive-table "Redirect imports from #% to direct references" + (hash-set! primitive-table-directs + (string->symbol (string-append "#%" primitive-table)) + "")] + [("++direct-prefixed") primitive-table "Like ++direct, but prefixes with :" + (hash-set! primitive-table-directs + (string->symbol (string-append "#%" primitive-table)) + (string-append primitive-table ":"))] + [("++pure") path "Insist that is a module without side-effects" + (hash-set! side-effect-free-modules (simplify-path (path->complete-path path)) #t)] + #:once-any + [("-t") file "Load specified file" + (set! startup-module (path->complete-path file))] + [("-l") lib "Load specified library" + (set! startup-module `(lib ,lib))] + [("-f") file "Load non-module file in `racket/base` namespace" + (set! startup-module 'racket/base) + (set! load-file file)] + #:once-each + [("--submod") name "Load specified submodule" + (set! submod-name (string->symbol name))] + #:args args args)) + +;; ---------------------------------------- + +;; If any `--check-depends` is specified, exit as soon as possible if +;; nothing's newer + +(define (read-dependencies-from-file file) + (and (file-exists? file) + (with-handlers ([exn:fail:filesystem? (lambda (exn) + (log-error (exn-message exn)) + #f)]) + (let ([l (call-with-input-file file read)]) + (and (list? l) + (andmap bytes? l) + (map bytes->path l)))))) + +(when check-dependencies + (unless print-extracted-to + (raise-user-error 'run "cannot check dependencies without a specific output file")) + (define ts (file-or-directory-modify-seconds print-extracted-to #f (lambda () #f))) + (when (and + ts + (let ([l (read-dependencies-from-file check-dependencies)]) + (and l + (for/and ([dep (in-list l)]) + (<= (file-or-directory-modify-seconds dep #f (lambda () +inf.0)) + ts))))) + (log-status "No dependencies are newer") + (exit 0))) + +;; ---------------------------------------- + +(define cache + (and (or cache-dir extract?) + (make-cache cache-dir (lambda (path) + (log-status "changed: ~a" path))))) + +(when checkout-directory + ;; After booting, we're going to change the way module paths + ;; resolve. That's not generally ok, but as long we trigger visits + ;; of available modules here, it turns out that it won't cause + ;; trouble. + (host:namespace-require ''#%kernel) + (host:eval '(void))) + +;; Install handlers: +(boot) + +;; Avoid use of ".zo" files: +(use-compiled-file-paths null) + +;; Redirect module search to another installation: +(when checkout-directory + (let ([l (list (build-path checkout-directory "collects"))]) + (host:current-library-collection-paths l)) + (let ([l (list #f + (build-path checkout-directory "share" "links.rktd"))]) + (host:current-library-collection-links l))) + +(current-library-collection-paths (host:current-library-collection-paths)) +(current-library-collection-links (host:current-library-collection-links)) + +;; Replace the load handler to stash compiled modules in the cache +;; and/or load them from the cache +(define orig-load (current-load)) +(current-load (lambda (path expected-module) + (cond + [expected-module + (let loop () + (cond + [(and cache + (not cache-skip-first?) + (get-cached-compiled cache path + (lambda () + (when cache-dir + (unless quiet-load? + (log-status "cached: ~a" path)))))) + => (lambda (m) + ;; Since we've set `use-compiled-file-paths` to null, + ;; the load/use-compiled handler thinks that we're + ;; always loading from source, so don't find the + ;; expected submodule with + ;; `(extract-requested-submodule m expected-module)` + (eval m))] + [(and (pair? expected-module) + (not (car expected-module))) + ;; shouldn't load from source when `expected-module` starts with #f + (void)] + [else + (unless quiet-load? + (log-status "compile: ~a" path)) + (set! cache-skip-first? #f) + (with-handlers ([exn:fail? (lambda (exn) + (unless quiet-load? + (log-status "...during ~a..." path)) + (raise exn))]) + (define s + (call-with-input-file* + path + (lambda (i) + (port-count-lines! i) + (with-module-reading-parameterization + (lambda () + (check-module-form + (read-syntax (object-name i) i) + path)))))) + (cond + [(not cache) + (eval s)] + [else + (define cache-layer (make-cache-layer)) + (define c + (parameterize ([current-cache-layer cache-layer]) + (compile s))) + (when time-expand? + ;; Re-expanding avoids timing load of required modules + (time (expand s))) + (cond + [(and cache + (not cache-read-only?) + (or (not cache-save-only) + (hash-ref cache-save-only (path->string path) #f))) + (cache-compiled! cache path c cache-layer) + (loop)] + [else (eval c)])]))]))] + [else (orig-load path #f)]))) + +(define orig-resolver (current-module-name-resolver)) +(current-module-name-resolver + (case-lambda + [(r ns) (orig-resolver r ns)] + [(r wrt src load?) + (define p (orig-resolver r wrt src load?)) + (define n (resolved-module-path-name p)) + (when (and (path? n) cache) + (register-dependency! cache n)) + p])) + +(define (apply-to-module proc mod-path) + (define path (resolved-module-path-name + (resolve-module-path mod-path #f))) + (define-values (dir file dir?) (split-path path)) + (parameterize ([current-load-relative-directory dir]) + (proc (call-with-input-file* + path + (lambda (i) + (port-count-lines! i) + (with-module-reading-parameterization + (lambda () + (check-module-form + (read-syntax (object-name i) i) + path)))))))) + +(cond + [expand? + (pretty-write (syntax->datum (apply-to-module expand startup-module)))] + [linklets? + (pretty-write (correlated->datum + (datum->correlated + (apply-to-module compile-to-linklets startup-module) #f)))] + [else + ;; Load and run the requested module + (parameterize ([current-command-line-arguments (list->vector args)]) + (namespace-require (if submod-name + `(submod ,startup-module ,submod-name) + startup-module)))]) + +(when extract? + ;; Extract a bootstrapping slice of the requested module + (extract startup-module cache + #:print-extracted-to print-extracted-to + #:as-c? extract-to-c? + #:as-decompiled? extract-to-decompiled? + #:as-bytecode? extract-to-bytecode? + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs + #:side-effect-free-modules side-effect-free-modules)) + +(when load-file + (load load-file)) + +;; ---------------------------------------- + +(when (or dependencies-file + makefile-dependencies-file) + (for ([mod-file (in-list extra-module-dependencies)]) + (define deps (cons mod-file + (module-recorded-dependencies mod-file))) + (for ([dep (in-list deps)]) + (hash-set! dependencies (simplify-path (path->complete-path dep)) #t))) + ;; Note: `cache` currently misses external dependencies, such as + ;; `include`d files. + (for ([dep (in-list (cache->used-paths cache))]) + (hash-set! dependencies (simplify-path dep) #t))) + +(when dependencies-file + (call-with-output-file* + dependencies-file + #:exists 'truncate/replace + (lambda (o) + (writeln (for/list ([dep (in-hash-keys dependencies)]) + (path->bytes dep)) + o)))) + +(when makefile-dependencies-file + (define (quote-if-space s) (if (regexp-match? #rx" " s) (format "\"~a\"" s) s)) + (call-with-output-file* + makefile-dependencies-file + #:exists 'truncate/replace + (lambda (o) + (fprintf o "~a:" (quote-if-space makefile-dependencies-target)) + (for ([dep (in-hash-keys dependencies)]) + (fprintf o " \\\n ~a" (quote-if-space dep))) + (newline o) + (for ([dep (in-hash-keys dependencies)]) + (fprintf o "\n~a:\n" (quote-if-space dep)))))) diff -Nru racket-6.12+ppa1/src/expander/syntax/api.rkt racket-7.0+ppa1/src/expander/syntax/api.rkt --- racket-6.12+ppa1/src/expander/syntax/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,182 @@ +#lang racket/base +(require "../common/phase.rkt" + (rename-in "syntax.rkt" + [syntax->datum raw:syntax->datum] + [datum->syntax raw:datum->syntax]) + "property.rkt" + "original.rkt" + (rename-in "to-list.rkt" + [syntax->list raw:syntax->list]) + (rename-in "scope.rkt" + [syntax-e raw:syntax-e] + [bound-identifier=? raw:bound-identifier=?] + [syntax-shift-phase-level raw:syntax-shift-phase-level]) + (rename-in "binding.rkt" + [free-identifier=? raw:free-identifier=?] + [identifier-binding raw:identifier-binding] + [identifier-binding-symbol raw:identifier-binding-symbol]) + (rename-in "track.rkt" + [syntax-track-origin raw:syntax-track-origin]) + "../expand/syntax-local.rkt" + "srcloc.rkt" + "../common/contract.rkt" + (rename-in "debug.rkt" + [syntax-debug-info raw:syntax-debug-info]) + (only-in "../expand/context.rkt" get-current-expand-context) + "../expand/log.rkt") + +;; Provides public versions of syntax functions (with contract checks, +;; for example); see also "taint-api.rkt" + +(provide syntax? + syntax-e + syntax-property + syntax-property-remove + syntax-property-preserved? + syntax-property-symbol-keys + syntax-original? + syntax->datum + maybe-syntax->datum + datum->syntax + syntax->list + identifier? + bound-identifier=? + free-identifier=? + free-transformer-identifier=? + free-template-identifier=? + free-label-identifier=? + identifier-binding + identifier-transformer-binding + identifier-template-binding + identifier-label-binding + identifier-binding-symbol + identifier-prune-lexical-context + syntax-shift-phase-level + syntax-track-origin + syntax-debug-info) + +(define/who (syntax-e s) + (check who syntax? s) + (raw:syntax-e s)) + +(define/who (syntax->datum s) + (check who syntax? s) + (raw:syntax->datum s)) + +(define (maybe-syntax->datum s) + (if (syntax? s) + (raw:syntax->datum s) + s)) + +(define/who (datum->syntax stx-c s [stx-l #f] [stx-p #f] [ignored #f]) + (unless (or (not stx-c) (syntax? stx-c)) + (raise-argument-error who "(or #f syntax?)" stx-c)) + (unless (or (not stx-l) + (syntax? stx-l) + (encoded-srcloc? stx-l)) + (raise-argument-error who + (string-append "(or #f syntax?\n" + " (list/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f))\n" + " (vector/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)))") + stx-l)) + (unless (or (not stx-p) (syntax? stx-p)) + (raise-argument-error who "(or #f syntax?)" stx-p)) + (raw:datum->syntax stx-c s (to-srcloc-stx stx-l) stx-p)) + +(define/who (syntax->list s) + (check who syntax? s) + (raw:syntax->list s)) + +(define/who (syntax-original? s) + (check who syntax? s) + (and (syntax-property s original-property-sym) + (not (syntax-any-macro-scopes? s)))) + +(define/who (bound-identifier=? a b [phase (syntax-local-phase-level)]) + (check who identifier? a) + (check who identifier? b) + (check who phase? #:contract phase?-string phase) + (raw:bound-identifier=? a b phase)) + +(define/who (free-identifier=? a b + [a-phase (syntax-local-phase-level)] + [b-phase a-phase]) + (check who identifier? a) + (check who identifier? b) + (check who phase? #:contract phase?-string a-phase) + (check who phase? #:contract phase?-string b-phase) + (raw:free-identifier=? a b a-phase b-phase)) + +(define/who (free-transformer-identifier=? a b) + (check who identifier? a) + (check who identifier? b) + (define phase (add1 (syntax-local-phase-level))) + (raw:free-identifier=? a b phase phase)) + +(define/who (free-template-identifier=? a b) + (check who identifier? a) + (check who identifier? b) + (define phase (sub1 (syntax-local-phase-level))) + (raw:free-identifier=? a b phase phase)) + +(define/who (free-label-identifier=? a b) + (check who identifier? a) + (check who identifier? b) + (raw:free-identifier=? a b #f #f)) + +(define/who (identifier-binding id [phase (syntax-local-phase-level)] [top-level-symbol? #f]) + (check who identifier? id) + (check who phase? #:contract phase?-string phase) + (raw:identifier-binding id phase top-level-symbol?)) + +(define/who (identifier-transformer-binding id [phase (syntax-local-phase-level)]) + (check who identifier? id) + (raw:identifier-binding id (and phase (add1 phase)))) + +(define/who (identifier-template-binding id) + (check who identifier? id) + (raw:identifier-binding id (sub1 (syntax-local-phase-level)))) + +(define/who (identifier-label-binding id) + (check who identifier? id) + (raw:identifier-binding id #f)) + +(define/who (identifier-binding-symbol id [phase (syntax-local-phase-level)]) + (check who identifier? id) + (check who phase? #:contract phase?-string phase) + (raw:identifier-binding-symbol id phase)) + +(define/who (identifier-prune-lexical-context id [syms null]) + (check who identifier? id) + (unless (and (list? syms) + (andmap symbol? syms)) + (raise-argument-error who "(listof symbol?)" syms)) + ;; It's a no-op in the Racket v6.5 expander + id) + +(define/who (syntax-debug-info s [phase (syntax-local-phase-level)] [all-bindings? #f]) + (check who syntax? s) + (check who phase? #:contract phase?-string phase) + (raw:syntax-debug-info s phase all-bindings?)) + +(define/who (syntax-shift-phase-level s phase) + (check who syntax? s) + (check who phase? #:contract phase?-string phase) + (raw:syntax-shift-phase-level s phase)) + +(define/who (syntax-track-origin new-stx old-stx id) + (check who syntax? new-stx) + (check who syntax? old-stx) + (check who identifier? id) + (define s (raw:syntax-track-origin new-stx old-stx id)) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (when ctx (log-expand ctx 'track-origin new-stx s)) + s) diff -Nru racket-6.12+ppa1/src/expander/syntax/api-taint.rkt racket-7.0+ppa1/src/expander/syntax/api-taint.rkt --- racket-6.12+ppa1/src/expander/syntax/api-taint.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/api-taint.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,72 @@ +#lang racket/base +(require "syntax.rkt" + "to-list.rkt" + "scope.rkt" + "taint-dispatch.rkt" + (rename-in "taint.rkt" + [syntax-tainted? raw:syntax-tainted?] + [syntax-arm raw:syntax-arm] + [syntax-disarm raw:syntax-disarm] + [syntax-rearm raw:syntax-rearm] + [syntax-taint raw:syntax-taint]) + (only-in "../expand/syntax-local.rkt" syntax-local-phase-level) + "../namespace/core.rkt" + "../namespace/inspector.rkt" + "../common/contract.rkt") + +;; Provides public versions of taint-related syntax functions + +(provide syntax-tainted? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint) + +(define/who (syntax-tainted? s) + (check who syntax? s) + (raw:syntax-tainted? s)) + +(define/who (syntax-arm s [maybe-insp #f] [use-mode? #f]) + (check who syntax? s) + (unless (or (not maybe-insp) + (inspector? maybe-insp)) + (raise-argument-error who "(or/c inspector? #f)" maybe-insp)) + (define insp (inspector-for-taint maybe-insp)) + (cond + [use-mode? + (taint-dispatch + s + (lambda (s) (raw:syntax-arm s insp)) + (syntax-local-phase-level))] + [else + (raw:syntax-arm s insp)])) + +(define/who (syntax-disarm s maybe-insp) + (check who syntax? s) + (unless (or (not maybe-insp) + (inspector? maybe-insp)) + (raise-argument-error who "(or/c inspector? #f)" maybe-insp)) + (define insp (inspector-for-taint maybe-insp)) + (raw:syntax-disarm s insp)) + +(define/who (syntax-rearm s from-s [use-mode? #f]) + (check who syntax? s) + (check who syntax? from-s) + (cond + [use-mode? (taint-dispatch + s + (lambda (s) (raw:syntax-rearm s from-s)) + (syntax-local-phase-level))] + [else + (raw:syntax-rearm s from-s)])) + +(define/who (syntax-taint s) + (check who syntax? s) + (raw:syntax-taint s)) + +;; ---------------------------------------- + +(define (inspector-for-taint maybe-insp) + (or maybe-insp + (current-module-code-inspector) + (current-code-inspector))) diff -Nru racket-6.12+ppa1/src/expander/syntax/binding.rkt racket-7.0+ppa1/src/expander/syntax/binding.rkt --- racket-6.12+ppa1/src/expander/syntax/binding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/binding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,349 @@ +#lang racket/base +(require "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/memo.rkt" + "syntax.rkt" + "property.rkt" + "scope.rkt" + "../common/phase.rkt" + "full-binding.rkt" + "module-binding.rkt" + "local-binding.rkt" + "datum-map.rkt" + "../expand/rename-trans.rkt" + "../common/module-path.rkt" + "cache.rkt") + +(provide + binding-frame-id + binding-free=id + (all-from-out "module-binding.rkt") + (all-from-out "local-binding.rkt") + + free-identifier=? + same-binding? + same-binding-nominals? + identifier-binding + identifier-binding-symbol + + maybe-install-free=id! + binding-set-free=id + + resolve+shift + syntax-module-path-index-shift + + apply-syntax-shifts + syntax-apply-shifts + binding-module-path-index-shift + syntax-transfer-shifts + syntax-add-shifts + + syntax-source-module + identifier-prune-to-source-module) + +;; ---------------------------------------- + +(define (free-identifier=? a b a-phase b-phase) + (define ab (toplevel-as-symbol (resolve+shift a a-phase #:unbound-sym? #t))) + (define bb (toplevel-as-symbol (resolve+shift b b-phase #:unbound-sym? #t))) + (cond + [(or (symbol? ab) (symbol? bb)) + (eq? ab bb)] + [else + (same-binding? ab bb)])) + +;; By tradition, equate "unbound" with "bound at the top level" +(define (toplevel-as-symbol b) + (if (and (module-binding? b) + (top-level-module-path-index? (module-binding-module b))) + (module-binding-sym b) + b)) + +(define (same-binding? ab bb) + (cond + [(module-binding? ab) + (and (module-binding? bb) + (eq? (module-binding-sym ab) + (module-binding-sym bb)) + (eqv? (module-binding-phase ab) + (module-binding-phase bb)) + (eq? (module-path-index-resolve (module-binding-module ab)) + (module-path-index-resolve (module-binding-module bb))))] + [(local-binding? ab) + (and (local-binding? bb) + (eq? (local-binding-key ab) + (local-binding-key bb)))] + [else (error "bad binding" ab)])) + +;; Check whether two bindings that are `same-binding?` also provide +;; the same nominal info (i.e., claim to be required through the same +;; immediate path): +(define (same-binding-nominals? ab bb) + (and (eq? (module-path-index-resolve (module-binding-nominal-module ab)) + (module-path-index-resolve (module-binding-nominal-module bb))) + (eqv? (module-binding-nominal-require-phase ab) + (module-binding-nominal-require-phase bb)) + (eqv? (module-binding-nominal-sym ab) + (module-binding-nominal-sym bb)))) + +(define (identifier-binding-symbol id phase) + (define b (resolve+shift id phase #:unbound-sym? #t)) + (cond + [(symbol? b) b] + [(module-binding? b) + (module-binding-sym b)] + [(local-binding? b) + (local-binding-key b)] + [else (syntax-e id)])) + +(define (identifier-binding id phase [top-level-symbol? #f]) + (define b (resolve+shift id phase)) + (cond + [(module-binding? b) + (if (top-level-module-path-index? (module-binding-module b)) + (if top-level-symbol? + (list (module-binding-nominal-sym b)) + #f) + (list (module-binding-module b) + (module-binding-sym b) + (module-binding-nominal-module b) + (module-binding-nominal-sym b) + (module-binding-phase b) + (module-binding-nominal-require-phase b) + (module-binding-nominal-phase b)))] + [(local-binding? b) + 'lexical] + [else #f])) + +;; ---------------------------------------- + +(define (maybe-install-free=id! val id phase) + (when (rename-transformer? val) + (define free=id (rename-transformer-target val)) + (unless (syntax-property free=id 'not-free-identifier=?) + (define b (resolve+shift id phase #:exactly? #t #:immediate? #t)) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) (binding-set-free=id b free=id))))) + +;; Helper to add a `free-identifier=?` equivance to a binding +(define (binding-set-free=id b free=id) + (cond + [(module-binding? b) (module-binding-update b #:free=id free=id)] + [(local-binding? b) (local-binding-update b #:free=id free=id)] + [else (error "bad binding for free=id:" b)])) + +; ---------------------------------------- + +;; To tag shifts that should not count as a module source +;; in the sense of `syntax-source-module`: +(struct non-source-shift (from to) #:prefab) +(define (shift-from s) + (if (pair? s) (car s) (non-source-shift-from s))) +(define (shift-to s) + (if (pair? s) (cdr s) (non-source-shift-to s))) + +;; Adjust `s` (recursively) so that if `resolve+shift` would +;; report `form-mpi`, the same operation on the result will +;; report `to-mpi`. A non-#f `inspector` is provided when shifting +;; syntax literals in a module to match the module's declaration-time +;; inspector. +(define (syntax-module-path-index-shift s from-mpi to-mpi [inspector #f] + #:non-source? [non-source? #f]) + (cond + [(eq? from-mpi to-mpi) + (if inspector + (syntax-set-inspector s inspector) + s)] + [else + (define shift (if non-source? + (non-source-shift from-mpi to-mpi) + (cons from-mpi to-mpi))) + (struct-copy syntax s + [mpi-shifts (shift-cons shift (syntax-mpi-shifts s))] + [inspector (or (syntax-inspector s) + inspector)] + [scope-propagations+tamper (if (datum-has-elements? (syntax-content s)) + (propagation-mpi-shift (syntax-scope-propagations+tamper s) + (lambda (s) (shift-cons shift s)) + inspector + (syntax-scopes s) + (syntax-shifted-multi-scopes s) + (syntax-mpi-shifts s)) + (syntax-scope-propagations+tamper s))])])) + +(define (shift-cons shift shifts) + (cond + [(and (pair? shifts) + (eq? (shift-from shift) (shift-from (car shifts)))) + ;; Adding `shift` is not useful + shifts] + [else (cons shift shifts)])) + +;; Use `resolve+shift` instead of `resolve` when the module of a +;; module binding is relevant or when `free-identifier=?` equivalences +;; (as installed by a binding to a rename transfomer) are relevant; +;; module path index shifts attached to `s` are taken into account in +;; the result +(define (resolve+shift s phase + #:ambiguous-value [ambiguous-value #f] + #:exactly? [exactly? #f] + #:immediate? [immediate? exactly?] + #:unbound-sym? [unbound-sym? #f] + ;; For resolving bulk bindings in `free-identifier=?` chains: + #:extra-shifts [extra-shifts null]) + (define can-cache? (and (not exactly?) (not immediate?) (null? extra-shifts))) + (cond + [(and can-cache? + (resolve+shift-cache-get s phase)) + => (lambda (b) + (if (eq? b '#:none) + (and unbound-sym? (syntax-content s)) + b))] + [else + (define immediate-b (resolve s phase + #:ambiguous-value ambiguous-value + #:exactly? exactly? + #:extra-shifts extra-shifts)) + (define b (if (and immediate-b + (not immediate?) + (binding-free=id immediate-b)) + (resolve+shift (binding-free=id immediate-b) phase + #:extra-shifts (append extra-shifts (syntax-mpi-shifts s)) + #:ambiguous-value ambiguous-value + #:exactly? exactly? + #:unbound-sym? unbound-sym?) + immediate-b)) + (cond + [(module-binding? b) + (define mpi-shifts (syntax-mpi-shifts s)) + (cond + [(null? mpi-shifts) + b] + [else + (define mod (module-binding-module b)) + (define shifted-mod (apply-syntax-shifts mod mpi-shifts)) + (define nominal-mod (module-binding-nominal-module b)) + (define shifted-nominal-mod (if (eq? mod nominal-mod) + shifted-mod + (apply-syntax-shifts nominal-mod mpi-shifts))) + (define result-b + (if (and (eq? mod shifted-mod) + (eq? nominal-mod shifted-nominal-mod) + (not (binding-free=id b)) + (null? (module-binding-extra-nominal-bindings b))) + b + (module-binding-update b + #:module shifted-mod + #:nominal-module shifted-nominal-mod + #:free=id (and (binding-free=id b) + (syntax-transfer-shifts (binding-free=id b) s)) + #:extra-nominal-bindings + (for/list ([b (in-list (module-binding-extra-nominal-bindings b))]) + (apply-syntax-shifts-to-binding b mpi-shifts))))) + (when can-cache? + (resolve+shift-cache-set! s phase result-b)) + result-b])] + [else + (when can-cache? + (resolve+shift-cache-set! s phase (or b '#:none))) + (or b + (and unbound-sym? + (syntax-content s)))])])) + +;; Apply accumulated module path index shifts +(define (apply-syntax-shifts mpi shifts) + (cond + [(null? shifts) mpi] + [else + (define shifted-mpi (apply-syntax-shifts mpi (cdr shifts))) + (define shift (car shifts)) + (module-path-index-shift shifted-mpi (shift-from shift) (shift-to shift))])) + +;; Apply accumulated module path index shifts to a module binding +(define (apply-syntax-shifts-to-binding b shifts) + (cond + [(null? shifts) b] + [else + (define shifted-b (apply-syntax-shifts-to-binding b (cdr shifts))) + (define shift (car shifts)) + (binding-module-path-index-shift shifted-b (shift-from shift) (shift-to shift))])) + + +;; Apply a syntax object's shifts to a given module path index +(define (syntax-apply-shifts s mpi) + (apply-syntax-shifts mpi (syntax-mpi-shifts s))) + +;; Apply a single shift to a single binding +(define (binding-module-path-index-shift b from-mpi to-mpi) + (cond + [(module-binding? b) + (module-binding-update b + #:module (module-path-index-shift (module-binding-module b) + from-mpi + to-mpi) + #:nominal-module (module-path-index-shift (module-binding-nominal-module b) + from-mpi + to-mpi) + #:extra-nominal-bindings (for/list ([b (in-list (module-binding-extra-nominal-bindings b))]) + (binding-module-path-index-shift b from-mpi to-mpi)))] + [else b])) + +(define (syntax-transfer-shifts to-s from-s [inspector #f] #:non-source? [non-source? #f]) + (syntax-add-shifts to-s (syntax-mpi-shifts from-s) inspector #:non-source? non-source?)) + +(define (syntax-add-shifts to-s shifts [inspector #f] #:non-source? [non-source? #f]) + (cond + [(and (null? shifts) inspector) + (syntax-set-inspector to-s inspector)] + [else + (for/fold ([s to-s]) ([shift (in-list (reverse shifts))] + [i (in-naturals)]) + (syntax-module-path-index-shift s (shift-from shift) (shift-to shift) (and (zero? i) inspector) + #:non-source? non-source?))])) + +(define (syntax-set-inspector s insp) + ;; This inspector merging is also implemented via propagations in "syntax.rkt" + (struct-copy syntax s + [inspector (or (syntax-inspector s) + insp)] + [scope-propagations+tamper (if (datum-has-elements? (syntax-content s)) + (propagation-mpi-shift (syntax-scope-propagations+tamper s) + #f + insp + (syntax-scopes s) + (syntax-shifted-multi-scopes s) + (syntax-mpi-shifts s)) + (syntax-scope-propagations+tamper s))])) + +;; ---------------------------------------- + +;; We can imagine that a syntax object's source module is determined +;; by adding a module's path index as it is expanded to everything +;; that starts out in the module. It turns out that we're already +;; adding a module path index like that in the form of a shift. So, we +;; infer a source module from the module-path-index shifts that are +;; attached to the syntax object by starting with the initial shift +;; and working our way back. +;; +;; Shifts added for a `module->namespace` context shouldn't count +;; toward a module source, so those are added as `non-source-shift` +;; records, and we skip them here. +(define (syntax-source-module s [source? #f]) + (unless (syntax? s) + (raise-argument-error 'syntax-track-origin "syntax?" s)) + (for/or ([shift (in-list (reverse (syntax-mpi-shifts s)))] + #:unless (non-source-shift? shift)) + (define from-mpi (car shift)) + (define-values (path base) (module-path-index-split from-mpi)) + (and (not path) + (module-path-index-resolved from-mpi) + (let ([mpi (apply-syntax-shifts from-mpi (syntax-mpi-shifts s))]) + (if source? + (resolved-module-path-name (module-path-index-resolve mpi #f)) + mpi))))) + +(define (identifier-prune-to-source-module id) + (unless (identifier? id) + (raise-argument-error 'identifier-prune-to-source-module "identifier?" id)) + (struct-copy syntax (datum->syntax #f (syntax-e id) id id) + [mpi-shifts (syntax-mpi-shifts id)])) diff -Nru racket-6.12+ppa1/src/expander/syntax/binding-table.rkt racket-7.0+ppa1/src/expander/syntax/binding-table.rkt --- racket-6.12+ppa1/src/expander/syntax/binding-table.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/binding-table.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,386 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "syntax.rkt" + "module-binding.rkt") + +;; A binding table within a scope maps symbol plus scope set +;; combinations (where the scope binding the binding table is always +;; included in the set). +;; +;; A binding table is one of +;; +;; - hash of sym -> scope-set -> binding +;; +;; - (table-with-bulk-bindings hash[as above] list-of-bulk-binding-at) +;; +;; In the latter case, the symbol-keyed hash table overrides bindings +;; supplied (for the same scope sets) in the bulk bindings. + +(provide empty-binding-table + binding-table-add + binding-table-add-bulk + binding-table-empty? + + in-binding-table + in-full-non-bulk-binding-table + + binding-table-symbols + + prop:bulk-binding + (struct-out bulk-binding-class) + + binding-table-prune-to-reachable + binding-table-register-reachable + prop:implicitly-reachable + + deserialize-table-with-bulk-bindings + deserialize-bulk-binding-at) + +(define empty-binding-table #hasheq()) + +(struct table-with-bulk-bindings (syms + syms/serialize ; copy of `syms`, but maybe with less nominal info + bulk-bindings) + #:property prop:serialize + (lambda (twbb ser-push! state) + (ser-push! 'tag '#:table-with-bulk-bindings) + (ser-push! (table-with-bulk-bindings-syms/serialize twbb)) + (ser-push! (table-with-bulk-bindings-bulk-bindings twbb))) + #:authentic) + +(define (deserialize-table-with-bulk-bindings syms bulk-bindings) + (table-with-bulk-bindings syms syms bulk-bindings)) + +;; ---------------------------------------- + +(struct bulk-binding-at (scopes ; scope set + bulk) ; bulk-binding + #:property prop:serialize + (lambda (bba ser-push! state) + ;; Data that is interpreted by the deserializer: + (ser-push! 'tag '#:bulk-binding-at) + (ser-push! (bulk-binding-at-scopes bba)) + (ser-push! (bulk-binding-at-bulk bba))) + #:property prop:reach-scopes + (lambda (sms reach) + ;; bulk bindings are pruned depending on whether all scopes + ;; in `scopes` are reachable, and we shouldn't get here + ;; when looking for scopes + (error "shouldn't get here")) + #:authentic) + +(define (deserialize-bulk-binding-at scopes bulk) + (bulk-binding-at scopes bulk)) + +;; Bulk bindings are represented by a property, so that the implementation +;; can be separate and manage serialization: +(define-values (prop:bulk-binding bulk-binding? bulk-binding-ref) + (make-struct-type-property 'bulk-binding)) + +;; Value of `prop:bulk-binding` +(struct bulk-binding-class (get-symbols ; bulk-binding list-of-shift -> sym -> binding-info + create)) ; bul-binding -> binding-info sym -> binding +(define (bulk-binding-symbols b s extra-shifts) + ;; Providing the identifier `s` supports its shifts + ((bulk-binding-class-get-symbols (bulk-binding-ref b)) + b + (append extra-shifts (if s (syntax-mpi-shifts s) null)))) +(define (bulk-binding-create b) + (bulk-binding-class-create (bulk-binding-ref b))) + +;; ---------------------------------------- + +(define (binding-table-empty? bt) + (and (hash? bt) (zero? (hash-count bt)))) + +;; Adding a binding for a single symbol +(define (binding-table-add bt scopes sym binding just-for-nominal?) + (cond + [(hash? bt) + (hash-set bt sym (hash-set (hash-ref bt sym #hash()) scopes binding))] + [else + (define new-syms + (binding-table-add (table-with-bulk-bindings-syms bt) + scopes + sym + binding + just-for-nominal?)) + ;; Keep `syms/serialize` in sync with `syms`, except for bindings + ;; that are just to extend the set of nominal imports. We keep those + ;; separate --- and don't serialize them --- because they interfere + ;; with bulk representations of binding and they're used only to + ;; commuincate to `provide`. + (define new-syms/serialize + (cond + [just-for-nominal? (table-with-bulk-bindings-syms/serialize bt)] + [(eq? (table-with-bulk-bindings-syms bt) + (table-with-bulk-bindings-syms/serialize bt)) + new-syms] + [else (binding-table-add (table-with-bulk-bindings-syms/serialize bt) + scopes + sym + binding + #f)])) + (struct-copy table-with-bulk-bindings bt + [syms new-syms] + [syms/serialize new-syms/serialize])])) + +(define-values (prop:implicitly-reachable implicitly-reachable? implicitly-reachable-ref) + (make-struct-type-property 'implicitly-reachable)) + +;; Adding a binding for a computed-on-demand set of symbols +(define (binding-table-add-bulk bt scopes bulk + #:shadow-except [shadow-except #f]) + (cond + [(table-with-bulk-bindings? bt) + (define new-syms (remove-matching-bindings (table-with-bulk-bindings-syms bt) + scopes + bulk + #:except shadow-except)) + (define new-syms/serialize (if (eq? (table-with-bulk-bindings-syms bt) + (table-with-bulk-bindings-syms/serialize bt)) + new-syms + (remove-matching-bindings (table-with-bulk-bindings-syms/serialize bt) + scopes + bulk + #:except shadow-except))) + (table-with-bulk-bindings new-syms + new-syms/serialize + (cons (bulk-binding-at scopes bulk) + (table-with-bulk-bindings-bulk-bindings bt)))] + [else + (binding-table-add-bulk (table-with-bulk-bindings bt bt null) scopes bulk)])) + +;; The bindings of `bulk` at `scopes` should shadow any existing +;; mappings in `sym-bindings`, except one for `except` +(define (remove-matching-bindings syms scopes bulk #:except except) + (define bulk-symbols (bulk-binding-symbols bulk #f null)) + (cond + [((hash-count syms) . < . (hash-count bulk-symbols)) + ;; Faster to consider each sym in `syms` + (for/fold ([syms syms]) ([(sym sym-bindings) (in-immutable-hash syms)]) + (if (hash-ref bulk-symbols sym #f) + (remove-matching-binding syms sym sym-bindings scopes #:except except) + syms))] + [else + ;; Faster to consider each sym in `bulk-symbols` + (for/fold ([syms syms]) ([sym (in-immutable-hash-keys bulk-symbols)]) + (define sym-bindings (hash-ref syms sym #f)) + (if sym-bindings + (remove-matching-binding syms sym sym-bindings scopes #:except except) + syms))])) + +;; Update an individual symbol's bindings to remove a mapping +;; for a given set of scopes +(define (remove-matching-binding syms sym sym-bindings scopes #:except except) + (cond + [(and except + (let ([b (hash-ref sym-bindings scopes #f)]) + (and (module-binding? b) + (eq? except (module-binding-module b))))) + ;; Don't replace a shadowing definition + syms] + [else + (hash-set syms sym (hash-remove sym-bindings scopes))])) + +;; ---------------------------------------- + +;; Iterate through all scope+binding combinations for a given symbol; +;; the syntax object and extra shifts expressions may be used for +;; loading bulk bindings. +(define-sequence-syntax in-binding-table + (lambda () #'do-not-use-in-binding-table-as-an-expression) + (lambda (stx) + (syntax-case stx () + [[(scopes-id binding-id) (_ sym table-expr s-expr extra-shifts-expr)] + (identifier? #'sym) + #'[(scopes-id binding-id) + (:do-in + ([(ht bulk-bindings) + (let ([table table-expr]) + (if (hash? table) + (values (hash-ref table sym #hash()) null) + (values (hash-ref (table-with-bulk-bindings-syms table) sym #hash()) + (table-with-bulk-bindings-bulk-bindings table))))] + [(s) s-expr] + [(extra-shifts) extra-shifts-expr]) + #t + ;; The current index is either a number index for a hash table + ;; (extracted from the symbol-keyed hash table) or it is a pair + ;; for walking down the list of bulk bindings + ([i (or (hash-iterate-first ht) + bulk-bindings)]) + ;; We're done when we've moved on to the bulk-binding part + ;; and none are left: + (not (null? i)) + ;; At each step, extract the current scope set and binding; + ;; either can be #f, in which case the consumer of the + ;; sequence should move on the the next result + ([(scopes-id) (cond + [(pair? i) (bulk-binding-at-scopes (car i))] + [else (hash-iterate-key ht i)])] + [(binding-id) (cond + [(pair? i) + (define bulk (bulk-binding-at-bulk (car i))) + (define b-info (and (symbol-interned? sym) ; don't `require` non-interned + (hash-ref (bulk-binding-symbols bulk s extra-shifts) sym #f))) + (and b-info + ((bulk-binding-create bulk) bulk b-info sym))] + [else (hash-iterate-value ht i)])]) + #t + #t + ;; Next value for the index `i`: + [(cond + [(pair? i) (cdr i)] + [else (or (hash-iterate-next ht i) + bulk-bindings)])])]]))) + +;; ---------------------------------------- + +;; Iterate through all non-bulk symbol+scope+binding combinations. +;; This iterator allocates; its intended for use in situations +;; that don't need a tight loop, which should generally be the +;; case for somethign that's inspecting all bindings. +(define-sequence-syntax in-full-non-bulk-binding-table + (lambda () #'do-not-use-in-full-non-bulk-binding-table-as-an-expression) + (lambda (stx) + (syntax-case stx () + [[(sym-id scopes-id binding-id) (_ table-expr)] + #'[(scopes-id binding-id) + (:do-in + ([(sym-ht) + (let ([table table-expr]) + (if (hash? table) + table + (table-with-bulk-bindings-syms table)))]) + #t + ([state (let loop ([sym-i (hash-iterate-first sym-ht)]) + (if sym-i + (next-state-in-full-binding-table sym-ht sym-i) + '(#f . #f)))]) + (car state) + ;; At each step, extract the current scope set and binding; + ;; either can be #f, in which case the consumer of the + ;; sequence should move on the the next result + ([(sym-id) (vector-ref (car state) 1)] + [(scopes-id) (hash-iterate-key (vector-ref (car state) 2) (cdr state))] + [(binding-id) (hash-iterate-value (vector-ref (car state) 2) (cdr state))]) + #t + #t + [(let* ([ht (vector-ref (car state) 2)] + [i (hash-iterate-next ht (cdr state))]) + (if i + (cons (car state) i) + (next-state-in-full-binding-table sym-ht + (hash-iterate-next sym-ht (vector-ref (car state) 0)))))])]]))) + +(define (next-state-in-full-binding-table sym-ht sym-i) + (if sym-i + (let* ([ht (hash-iterate-value sym-ht sym-i)] + [i (hash-iterate-first ht)]) + (if i + (cons (vector sym-i + (hash-iterate-key sym-ht sym-i) ; symbol + ht) + i) + (next-state-in-full-binding-table (hash-iterate-next sym-ht sym-i)))) + '(#f . #f))) + +;; ---------------------------------------- + +;; Return a set of symbols that have bindings for a given scope set +(define (binding-table-symbols table scs s extra-shifts) + (define-values (ht bulk-bindings) + (if (hash? table) + (values table null) + (values (table-with-bulk-bindings-syms table) + (table-with-bulk-bindings-bulk-bindings table)))) + (set-union + (for/seteq ([(sym at-sym) (in-hash ht)] + #:when (for/or ([an-scs (in-hash-keys at-sym)]) + (subset? an-scs scs))) + sym) + (for*/seteq ([bba (in-list bulk-bindings)] + #:when (subset? (bulk-binding-at-scopes bba) scs) + [sym (in-hash-keys + (bulk-binding-symbols (bulk-binding-at-bulk bba) s extra-shifts))]) + sym))) + +;; ---------------------------------------- +;; Pruning functions are called by scope serialization + +(define (binding-table-prune-to-reachable bt state) + (or (hash-ref (serialize-state-bindings-intern state) bt #f) + (let ([reachable-scopes (serialize-state-reachable-scopes state)]) + (define new-syms + (for*/hasheq ([(sym bindings-for-sym) (in-immutable-hash + (if (hash? bt) + bt + (table-with-bulk-bindings-syms/serialize bt)))] + [new-bindings-for-sym + (in-value + (for/hash ([(scopes binding) (in-immutable-hash bindings-for-sym)] + #:when (subset? scopes reachable-scopes)) + (values (intern-scopes scopes state) binding)))] + #:when (positive? (hash-count new-bindings-for-sym))) + (values sym new-bindings-for-sym))) + (define new-bulk-bindings + (if (hash? bt) + null + (for/list ([bba (in-list (table-with-bulk-bindings-bulk-bindings bt))] + #:when (subset? (bulk-binding-at-scopes bba) reachable-scopes)) + (struct-copy bulk-binding-at bba + [scopes (intern-scopes (bulk-binding-at-scopes bba) state)])))) + (define new-bt + (if (pair? new-bulk-bindings) + (table-with-bulk-bindings new-syms new-syms new-bulk-bindings) + new-syms)) + (hash-set! (serialize-state-bulk-bindings-intern state) bt new-bt) + new-bt))) + +(define (binding-table-register-reachable bt get-reachable-scopes reach register-trigger) + ;; Check symbol-specific scopes for both `free-id=?` reachability and + ;; for implicitly reachable scopes + (for* ([(sym bindings-for-sym) (in-immutable-hash (if (hash? bt) + bt + (table-with-bulk-bindings-syms/serialize bt)))] + [(scopes binding) (in-immutable-hash bindings-for-sym)]) + (define v (and (binding-reach-scopes? binding) + ((binding-reach-scopes-ref binding) binding))) + (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger)) + ;; Need to check bulk-binding scopes for implicitly reachable + (when (table-with-bulk-bindings? bt) + (for ([bba (in-list (table-with-bulk-bindings-bulk-bindings bt))]) + (scopes-register-reachable (bulk-binding-at-scopes bba) #f get-reachable-scopes reach register-trigger)))) + +(define (scopes-register-reachable scopes v get-reachable-scopes reach register-trigger) + (define reachable-scopes (get-reachable-scopes)) + (cond + [(subset? scopes reachable-scopes) + (reach v)] + [else + ;; There may be implicitly reachable scopes (i.e., multi-scope + ;; representatives that should only be reachable if they + ;; participate in a binding) + (define pending-scopes + (for/seteq ([sc (in-set scopes)] + #:unless (or (set-member? reachable-scopes sc) + (implicitly-reachable? sc))) + sc)) + (define (check-trigger reach) + (when (zero? (hash-count pending-scopes)) + ;; All scopes became reachable, so make the value reachable, + ;; and declare implcitily reachables as explicitly reachable + (reach v) + (for ([sc (in-set scopes)]) + (when (implicitly-reachable? sc) + (reach sc))))) + (for ([sc (in-set pending-scopes)]) + (register-trigger sc (lambda (reach) + (set! pending-scopes (hash-remove pending-scopes sc)) + (check-trigger reach)))) + ;; In case there were only implicitly reachable scopes: + (check-trigger reach)])) diff -Nru racket-6.12+ppa1/src/expander/syntax/bulk-binding.rkt racket-7.0+ppa1/src/expander/syntax/bulk-binding.rkt --- racket-6.12+ppa1/src/expander/syntax/bulk-binding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/bulk-binding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,177 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "binding-table.rkt" ; defines `prop:bulk-binding` + "binding.rkt" + "../common/module-path.rkt" + "../namespace/provided.rkt") + +(provide provide-binding-to-require-binding + + make-bulk-binding-registry + register-bulk-provide! + registered-bulk-provide? + + bulk-binding + + bulk-provides-add-prefix-remove-exceptions + deserialize-bulk-binding) + +;; When a require is something like `(require racket/base)`, then +;; we'd like to import the many bindings from `racket/base` in one +;; fast step, and we'd like to share the information in syntax objects +;; from many different modules that all import `racket/base`. A +;; "bulk binding" implements that fast binding and sharing. + +;; The difficult part is restoring sharing when a syntax object is +;; unmarshaled, and also leaving the binding information in the +;; providing moduling instead of the requiring module. Keeping the +;; information with the providing module should be ok, because +;; resolving a chain of module imports should ensure that the relevant +;; module is loaded before a syntax object with a bulk binding is used. +;; Still, we have to communicate information from the loading process +;; down the binding-resolving process. + +;; A bulk-binding registry manages that connection. The registry is +;; similar to the module registry, in that it maps a resolved module +;; name to provide information. But it has only the provide +;; information, and not the rest of the module's implementation. + +;; ---------------------------------------- + +;; Helper for both regular imports and bulk bindings, which converts a +;; providing module's view of a binding to a requiring mdoule's view. +(define (provide-binding-to-require-binding binding/p ; the provided binding + sym ; the symbolic name of the provide + #:self self ; the providing module's view of itself + #:mpi mpi ; the requiring module's view + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift) + (define binding (provided-as-binding binding/p)) + (define from-mod (module-binding-module binding)) + (module-binding-update binding + #:module (module-path-index-shift from-mod self mpi) + #:nominal-module mpi + #:nominal-phase provide-phase-level + #:nominal-sym sym + #:nominal-require-phase phase-shift + #:frame-id #f + #:extra-inspector (and (not (provided-as-protected? binding/p)) ; see [*] below + (module-binding-extra-inspector binding)) + #:extra-nominal-bindings null)) + +;; [*] If a binding has an extra inspector, it's because the binding +;; was provided as a rename transformer with a module (and the rename +;; transformer doesn't have 'not-free-identifier=?). But if we're +;; protecting the rename-transformer output, then the inspector on the +;; providing module should guard the use of the inspector attached to +;; the binding. For now, we approximate(!) that conditional use by +;; just dropping the extra inspector, which means that the original +;; binding (bounding by te rename transformer) is accessible only if +;; the end user has access to the original binding directly. + +;; ---------------------------------------- + +(struct bulk-binding ([provides #:mutable] ; mutable so table can be found lazily on unmarshal + prefix ; #f or a prefix for the import + excepts ; hash table of excluded symbols (before adding prefix) + [self #:mutable] ; the providing module's self + mpi ; this binding's view of the providing module + provide-phase-level ; providing module's import phase + phase-shift ; providing module's instantiation phase + bulk-binding-registry) ; a registry for finding bulk bindings lazily + #:property prop:bulk-binding + (bulk-binding-class + (lambda (b mpi-shifts) + (or (bulk-binding-provides b) + ;; Here's where we find provided bindings for unmarshaled syntax + (let ([mod-name (module-path-index-resolve + (apply-syntax-shifts + (bulk-binding-mpi b) + mpi-shifts))]) + (unless (bulk-binding-bulk-binding-registry b) + (error "namespace mismatch: no bulk-binding registry available:" + mod-name)) + (define table (bulk-binding-registry-table (bulk-binding-bulk-binding-registry b))) + (define bulk-provide (hash-ref table mod-name #f)) + (unless bulk-provide + (error "namespace mismatch: bulk bindings not found in registry for module:" + mod-name)) + ;; Reset `provide` and `self` to the discovered information + (set-bulk-binding-self! b (bulk-provide-self bulk-provide)) + (define provides (hash-ref (bulk-provide-provides bulk-provide) + (bulk-binding-provide-phase-level b))) + ;; Remove exceptions and add prefix + (define excepts (bulk-binding-excepts b)) + (define prefix (bulk-binding-prefix b)) + (define adjusted-provides + (cond + [(or prefix (positive? (hash-count excepts))) + (bulk-provides-add-prefix-remove-exceptions provides prefix excepts)] + [else provides])) + ;; Record the adjusted `provides` table for quick future access: + (set-bulk-binding-provides! b adjusted-provides) + adjusted-provides))) + (lambda (b binding sym) + ;; Convert the provided binding to a required binding on + ;; demand during binding resolution + (provide-binding-to-require-binding + binding (if (bulk-binding-prefix b) + (string->symbol + (substring (symbol->string sym) + (string-length (symbol->string (bulk-binding-prefix b))))) + sym) + #:self (bulk-binding-self b) + #:mpi (bulk-binding-mpi b) + #:provide-phase-level (bulk-binding-provide-phase-level b) + #:phase-shift (bulk-binding-phase-shift b)))) + #:property prop:serialize + ;; Serialization drops the `provides` table and the providing module's `self` + (lambda (b ser-push! reachable-scopes) + (ser-push! 'tag '#:bulk-binding) + (ser-push! (bulk-binding-prefix b)) + (ser-push! (bulk-binding-excepts b)) + (ser-push! (bulk-binding-mpi b)) + (ser-push! (bulk-binding-provide-phase-level b)) + (ser-push! (bulk-binding-phase-shift b)) + (ser-push! 'tag '#:bulk-binding-registry))) + +(define (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry) + (bulk-binding #f prefix excepts #f mpi provide-phase-level phase-shift bulk-binding-registry)) + +(define (bulk-provides-add-prefix-remove-exceptions provides prefix excepts) + (for/hash ([(sym val) (in-hash provides)] + #:unless (hash-ref excepts sym #f) + ;; Don't `require` non-interned + #:when (symbol-interned? sym)) + (values (if prefix + (string->symbol (format "~a~a" prefix sym)) + sym) + val))) + +;; ---------------------------------------- + +;; A blk binding registry has just the provde part of a module, for +;; use in resolving bulk bindings on unmarshal +(struct bulk-provide (self provides)) + +;; A bulk-binding-registry object is attached to every syntax object +;; in an instantiated module, so that binding resolution on the +;; module's syntax literals can find tables of provided variables +;; based on module names +(struct bulk-binding-registry (table)) ; resolve-module-name -> bulk-provide + +(define (make-bulk-binding-registry) + (bulk-binding-registry (make-hasheq))) + +;; Called when a module is instantiated to register its provides: +(define (register-bulk-provide! bulk-binding-registry mod-name self provides) + (hash-set! (bulk-binding-registry-table bulk-binding-registry) + mod-name + (bulk-provide self provides))) + +;; Called when a module is imported to make sure that it's in the +;; registry (as opposed to a temporary module instance during +;; expansion): +(define (registered-bulk-provide? bulk-binding-registry mod-name) + (and (hash-ref (bulk-binding-registry-table bulk-binding-registry) mod-name #f) + #t)) diff -Nru racket-6.12+ppa1/src/expander/syntax/cache.rkt racket-7.0+ppa1/src/expander/syntax/cache.rkt --- racket-6.12+ppa1/src/expander/syntax/cache.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/cache.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,135 @@ +#lang racket/base +(require racket/fixnum + "../common/set.rkt") + +(provide clear-resolve-cache! + resolve-cache-get + resolve-cache-set! + + resolve+shift-cache-get + resolve+shift-cache-set! + + cache-or-reuse-set + cache-or-reuse-hash) + +;; ---------------------------------------- + +;; Cache bindings resolutions with a fairly weak +;; cache keyed on a symbol, phase, and scope sets. + +(define cache (box (make-weak-box #f))) + +(define clear-resolve-cache! + (case-lambda + [(sym) + (define c (weak-box-value (unbox* cache))) + (when c + (hash-remove! c sym)) + (set-box*! shifted-cache #f)] + [() + (define c (weak-box-value (unbox* cache))) + (when c + (hash-clear! c)) + (set-box*! shifted-cache #f)])) + +(struct entry (scs smss phase binding) + #:authentic) + +(define (resolve-cache-get sym phase scs smss) + (define c (weak-box-value (unbox* cache))) + (and c + (let ([v (hash-ref c sym #f)]) + (and v + (eqv? phase (entry-phase v)) + (set=? scs (entry-scs v)) + (set=? smss (entry-smss v)) + (entry-binding v))))) + +(define (resolve-cache-set! sym phase scs smss b) + (define wb (unbox* cache)) + (define c (weak-box-value wb)) + (cond + [(not c) + (box-cas! cache wb (make-weak-box (make-hasheq))) + (resolve-cache-set! sym phase scs smss b)] + [else + (hash-set! c sym (entry scs smss phase b))])) + +;; ---------------------------------------- + +;; Cache binding resolutions keyed on an identifier and +;; phase; this is a very small cache that is consulted +;; before the more general one above; it's even cheaper +;; to check, and it avoids re-shifting module bindings +;; when it hits. It can be especially effective when +;; comparing one identifier to a sequence of other +;; identifiers. + +(define SHIFTED-CACHE-SIZE 16) ; power of 2 + +;; Cache box contains #f or a weak box of a vector: +(define shifted-cache (box #f)) +(define shifted-cache-pos 0) + +(struct shifted-entry (s phase binding) + #:authentic) + +(define (shifted-cache-vector) + (define wb (unbox* shifted-cache)) + (cond + [(and wb (weak-box-value wb)) + => (lambda (vec) vec)] + [else + (define vec (make-vector SHIFTED-CACHE-SIZE #f)) + (set-box*! shifted-cache (make-weak-box vec)) + vec])) + +(define (resolve+shift-cache-get s phase) + (define vec (shifted-cache-vector)) + (for/or ([e (in-vector vec)]) + (and e + (eq? s (shifted-entry-s e)) + (eqv? phase (shifted-entry-phase e)) + (shifted-entry-binding e)))) + +(define (resolve+shift-cache-set! s phase b) + (define vec (shifted-cache-vector)) + (define p shifted-cache-pos) + (vector*-set! vec p (shifted-entry s phase b)) + (set! shifted-cache-pos (fxand (fx+ 1 p) (fx- SHIFTED-CACHE-SIZE 1)))) + +;; ---------------------------------------- + +;; For scope sets and propagation hashes, we don't intern, but we +;; approximate interning by checking against a small set of recently +;; allocated scope sets or propagation hashes. That's good enough to +;; find sharing for a deeply nested sequence of `let`s from a +;; many-argument `or`, for example, where the interleaving of original +;; an macro-introduced syntax prevents the usual +;; child-is-same-as-parent sharing detecting from working well enough. + +(define NUM-CACHE-SLOTS 8) ; power of 2 + +(define cached-sets (make-weak-box (make-vector NUM-CACHE-SLOTS #f))) +(define cached-sets-pos 0) + +(define cached-hashes (make-weak-box (make-vector NUM-CACHE-SLOTS #f))) +(define cached-hashes-pos 0) + +(define-syntax-rule (define-cache-or-reuse cache-or-reuse cached cached-pos same?) + (define (cache-or-reuse s) + (define vec (or (weak-box-value cached) + (let ([vec (make-vector NUM-CACHE-SLOTS #f)]) + (set! cached (make-weak-box vec)) + vec))) + (or (for/or ([s2 (in-vector vec)]) + (and s2 + (same? s s2) + s2)) + (begin + (vector*-set! vec cached-pos s) + (set! cached-pos (fxand (fx+ 1 cached-pos) (fx- NUM-CACHE-SLOTS 1))) + s)))) + +(define-cache-or-reuse cache-or-reuse-set cached-sets cached-sets-pos set=?) +(define-cache-or-reuse cache-or-reuse-hash cached-hashes cached-hashes-pos equal?) diff -Nru racket-6.12+ppa1/src/expander/syntax/datum-map.rkt racket-7.0+ppa1/src/expander/syntax/datum-map.rkt --- racket-6.12+ppa1/src/expander/syntax/datum-map.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/datum-map.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,96 @@ +#lang racket/base +(require "../common/prefab.rkt" + "../common/inline.rkt" + racket/fixnum) + +(provide datum-map + datum-has-elements?) + +;; `(datum-map v f)` walks over `v`, traversing objects that +;; `datum->syntax` traverses to convert content to syntax objects. +;; +;; `(f tail? d)` is called on each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example +;; +;; `gf` is like `f`, but `gf` is used when the argument might be +;; syntax; if `gf` is provided, `f` can assume that its argument +;; is not syntax +;; +;; If a `seen` argument is provided, then it should be an `eq?`-based +;; hash table, and cycle checking is enabled; when a cycle is +;; discovered, the procedure attached to 'cycle-fail in the initial +;; table is called + +;; The inline version uses `f` only in an application position to +;; help avoid allocating a closure. It also covers only the most common +;; cases, defering to the general (not inlined) function for other cases. +(define-inline (datum-map s f [gf f] [seen #f]) + (let loop ([tail? #f] [s s] [prev-depth 0]) + (define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases + (cond + [(and seen (depth . fx> . 32)) + (datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen)] + [(null? s) (f tail? s)] + [(pair? s) + (f tail? (cons (loop #f (car s) depth) + (loop #t (cdr s) depth)))] + [(symbol? s) (f #f s)] + [(boolean? s) (f #f s)] + [(number? s) (f #f s)] + [(or (vector? s) (box? s) (prefab-struct-key s) (hash? s)) + (datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen)] + [else (gf #f s)]))) + +(define (datum-map-slow tail? s f seen) + (let loop ([tail? tail?] [s s] [prev-seen seen]) + (define seen + (cond + [(and prev-seen (datum-has-elements? s)) + (cond + [(hash-ref prev-seen s #f) + ((hash-ref prev-seen 'cycle-fail) s)] + [else (hash-set prev-seen s #t)])] + [else prev-seen])) + (cond + [(null? s) (f tail? s)] + [(pair? s) + (f tail? (cons (loop #f (car s) seen) + (loop #t (cdr s) seen)))] + [(or (symbol? s) (boolean? s) (number? s)) + (f #f s)] + [(vector? s) + (f #f (vector->immutable-vector + (for/vector #:length (vector-length s) ([e (in-vector s)]) + (loop #f e seen))))] + [(box? s) + (f #f (box-immutable (loop #f (unbox s) seen)))] + [(immutable-prefab-struct-key s) + => (lambda (key) + (f #f + (apply make-prefab-struct + key + (for/list ([e (in-vector (struct->vector s) 1)]) + (loop #f e seen)))))] + [(and (hash? s) (immutable? s)) + (cond + [(hash-eq? s) + (f #f + (for/hasheq ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [(hash-eqv? s) + (f #f + (for/hasheqv ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [else + (f #f + (for/hash ([(k v) (in-hash s)]) + (values k (loop #f v seen))))])] + [else (f #f s)]))) + +(define (datum-has-elements? d) + (or (pair? d) + (vector? d) + (box? d) + (immutable-prefab-struct-key d) + (and (hash? d) (immutable? d) (positive? (hash-count d))))) diff -Nru racket-6.12+ppa1/src/expander/syntax/debug.rkt racket-7.0+ppa1/src/expander/syntax/debug.rkt --- racket-6.12+ppa1/src/expander/syntax/debug.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/debug.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,90 @@ +#lang racket/base +(require "../common/set.rkt" + "syntax.rkt" + "scope.rkt" + "fallback.rkt" + "binding-table.rkt" + (submod "scope.rkt" for-debug) + "binding.rkt" + "module-binding.rkt") + +(provide syntax-debug-info) + +(define (syntax-debug-info s phase all-bindings?) + (define hts + (for/list ([smss (in-list (fallback->list (syntax-shifted-multi-scopes s)))]) + (define init-ht (if (identifier? s) + (hasheq 'name (syntax-e s)) + #hasheq())) + (define s-scs (scope-set-at-fallback s smss phase)) + (define context (scope-set->context s-scs)) + (define context-ht (hash-set init-ht 'context context)) + (define sym (syntax-e s)) + (define (classify-binding b) + (if (local-binding? b) + 'local + 'module)) + (define (extract-binding b) + (if (local-binding? b) + (local-binding-key b) + (vector (module-binding-sym b) + (module-binding-module b) + (module-binding-phase b)))) + (define bindings + (append + ;; Bindings based on the identifier `s` + (cond + [(identifier? s) + (define-values (bindings covered-scopess) + (for*/fold ([bindings null] [covered-scope-sets (set)]) + ([sc (in-set s-scs)] + [(scs b) (in-binding-table sym (scope-binding-table sc) s null)] + #:when (and scs b + ;; Skip overidden: + (not (set-member? covered-scope-sets scs)))) + (values + (cons + (hasheq 'name (syntax-e s) + 'context (scope-set->context scs) + 'match? (subset? scs s-scs) + (classify-binding b) (extract-binding b)) + bindings) + (set-add covered-scope-sets scs)))) + bindings] + [else null]) + ;; All other bindings (but not other bulk bindings, currently) + (cond + [all-bindings? + (for*/list ([sc (in-set s-scs)] + [(o-sym scs b) (in-full-non-bulk-binding-table (scope-binding-table sc))] + #:unless (eq? o-sym sym)) + (hasheq 'name o-sym + 'context (scope-set->context scs) + 'match? #f + (classify-binding b) (extract-binding b)))] + [else null]))) + (if (null? bindings) + context-ht + (hash-set context-ht 'bindings bindings)))) + (define ht (car hts)) + (if (null? (cdr hts)) + ht + (hash-set ht 'fallbacks (cdr hts)))) + +(define (scope-set->context scs) + (sort + (for/list ([sc (in-set scs)]) + (cond + [(interned-scope? sc) + (vector (scope-id sc) + (scope-kind sc) + (interned-scope-key sc))] + [(representative-scope? sc) + (vector (scope-id sc) + (scope-kind sc) + (multi-scope-name (representative-scope-owner sc)))] + [else + (vector (scope-id sc) + (scope-kind sc))])) + < + #:key (lambda (v) (vector-ref v 0)))) diff -Nru racket-6.12+ppa1/src/expander/syntax/error.rkt racket-7.0+ppa1/src/expander/syntax/error.rkt --- racket-6.12+ppa1/src/expander/syntax/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,107 @@ +#lang racket/base +(require "../common/contract.rkt" + "syntax.rkt" + "scope.rkt" + "taint.rkt") + +(provide (struct-out exn:fail:syntax) + make-exn:fail:syntax + (struct-out exn:fail:syntax:unbound) + make-exn:fail:syntax:unbound + + raise-syntax-error + raise-unbound-syntax-error) + +(struct exn:fail:syntax exn:fail (exprs) + #:extra-constructor-name make-exn:fail:syntax + #:transparent + #:property prop:exn:srclocs (lambda (e) (filter values (map syntax-srcloc (exn:fail:syntax-exprs e)))) + #:guard (lambda (str cm exprs info) + (unless (and (list? exprs) + (andmap syntax? exprs)) + (raise-argument-error 'exn:fail:syntax "(listof syntax?)" exprs)) + (values str cm exprs))) +(struct exn:fail:syntax:unbound exn:fail:syntax () + #:extra-constructor-name make-exn:fail:syntax:unbound + #:transparent) + +(define/who (raise-syntax-error given-name message + [expr #f] [sub-expr #f] + [extra-sources null] + [message-suffix ""]) + (do-raise-syntax-error who exn:fail:syntax given-name message + expr sub-expr + extra-sources + message-suffix)) + +(define/who (raise-unbound-syntax-error given-name message + [expr #f] [sub-expr #f] + [extra-sources null] + [message-suffix ""]) + (do-raise-syntax-error who exn:fail:syntax:unbound given-name message + expr sub-expr + extra-sources + message-suffix)) + +(define (do-raise-syntax-error who exn:fail:syntax given-name message + expr sub-expr + extra-sources + message-suffix) + (check who symbol? #:or-false given-name) + (check who string? message) + (unless (and (list? extra-sources) + (andmap syntax? extra-sources)) + (raise-argument-error who "(listof syntax?)" extra-sources)) + (check who string? message-suffix) + (define name + (format "~a" (or given-name + (extract-form-name expr) + '?))) + (define at-message + (or (and sub-expr + (error-print-source-location) + (format "\n at: ~.s" (syntax->datum (datum->syntax #f sub-expr)))) + "")) + (define in-message + (or (and expr + (error-print-source-location) + (format "\n in: ~.s" (syntax->datum (datum->syntax #f expr)))) + "")) + (define src-loc-str + (or (and (error-print-source-location) + (or (extract-source-location sub-expr) + (extract-source-location expr))) + "")) + (raise (exn:fail:syntax + (string-append src-loc-str + name ": " + message + at-message + in-message + message-suffix) + (current-continuation-marks) + (map syntax-taint + (if (or sub-expr expr) + (cons (datum->syntax #f (or sub-expr expr)) + extra-sources) + extra-sources))))) + +(define (extract-form-name s) + (cond + [(syntax? s) + (define e (syntax-e s)) + (cond + [(symbol? e) e] + [(and (pair? e) + (identifier? (car e))) + (syntax-e (car e))] + [else #f])] + [else #f])) + +(define (extract-source-location s) + (and (syntax? s) + (syntax-srcloc s) + (let ([str (srcloc->string (syntax-srcloc s))]) + (and str + (string-append str ": "))))) + diff -Nru racket-6.12+ppa1/src/expander/syntax/fallback.rkt racket-7.0+ppa1/src/expander/syntax/fallback.rkt --- racket-6.12+ppa1/src/expander/syntax/fallback.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/fallback.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,64 @@ +#lang racket/base + +(provide fallback? + fallback-first + fallback-rest + fallback-push + fallback-update-first + fallback-map + fallback->list) + +;; When a syntax object is expanded in namespace A and then +;; re-expanded in namespace B, then the scopes of B are added to rhe +;; syntax object, but a failed binding search will fall back to the +;; scope set that doesn't include the additional scope for B. This +;; fallback makes it easier to work across namespaces (including +;; moving from the top level to a module body or vice versa), and it +;; accomodates existing Racket programs. +;; +;; A syntax object contains a fallback search list only if +;; `push-scope` has been used. The fallback chain is in the +;; `shifted-multi-scopes` part of a syntax object (since the relevant +;; namespace scope is always a multi scope). +;; +;; A fallback is created by `push-scope`, which creates a new fallback +;; layer if the given multi-scope is not in the current set of scopes. + +(struct fallback (search-list) + ;; Can appear in serialized: + #:prefab) + +(define (fallback-first smss) + (if (fallback? smss) + (car (fallback-search-list smss)) + smss)) + +(define (fallback-rest smss) + (define l (cdr (fallback-search-list smss))) + (if (null? (cdr l)) + (car l) + (fallback l))) + +(define (fallback-push smss smss/maybe-fallback) + (fallback + (cons smss + (if (fallback? smss/maybe-fallback) + (fallback-search-list smss/maybe-fallback) + (list smss/maybe-fallback))))) + +(define (fallback-update-first smss f) + (if (fallback? smss) + (let ([l (fallback-search-list smss)]) + (fallback (cons (f (car l)) (cdr l)))) + (f smss))) + +(define (fallback-map smss f) + (if (fallback? smss) + (fallback (for/list ([smss (in-list (fallback-search-list smss))]) + (f smss))) + (f smss))) + +(define (fallback->list smss) + (if (fallback? smss) + (fallback-search-list smss) + (list smss))) diff -Nru racket-6.12+ppa1/src/expander/syntax/full-binding.rkt racket-7.0+ppa1/src/expander/syntax/full-binding.rkt --- racket-6.12+ppa1/src/expander/syntax/full-binding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/full-binding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base +(require "../compile/serialize-property.rkt") + +(provide (struct-out full-binding) + binding-frame-id + binding-free=id) + +;; A base struct for bindings with a frame identity or +;; `free-identifier=?` equivalence +(struct full-binding (frame-id ; used to trigger use-site scopes + free=id) ; `free-identifier=?` equivalence via a rename-transformer binding + #:authentic + #:property prop:binding-reach-scopes + (lambda (b) + (binding-free=id b))) + +(define (binding-frame-id b) + (and (full-binding? b) + (full-binding-frame-id b))) + +(define (binding-free=id b) + (and (full-binding? b) + (full-binding-free=id b))) diff -Nru racket-6.12+ppa1/src/expander/syntax/local-binding.rkt racket-7.0+ppa1/src/expander/syntax/local-binding.rkt --- racket-6.12+ppa1/src/expander/syntax/local-binding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/local-binding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +#lang racket/base +(require "full-binding.rkt" + "../compile/serialize-property.rkt") + +(provide make-local-binding + local-binding-update + local-binding? + + local-binding-key + + deserialize-full-local-binding) + +(define (local-binding? b) + ;; must not overlap with `module-binding?` + (or (full-local-binding? b) + (symbol? b))) + +;; Represent a local binding with a key, where the value of +;; the key is kept in a separate environment. That indirection +;; ensures that a fuly expanded program doesn't reference +;; compile-time values from local bindings, but it records that +;; the binding was local. The `frame-id` field is used to +;; trigger use-site scopes as needed +(struct full-local-binding full-binding (key) + #:authentic + #:property prop:serialize + (lambda (b ser-push! state) + ;; Data that is interpreted by the deserializer: + (ser-push! 'tag '#:local-binding) + (ser-push! (full-local-binding-key b)) + (ser-push! (full-binding-free=id b)))) + +(define (deserialize-full-local-binding key free=id) + (full-local-binding #f free=id key)) + +(define (make-local-binding key + #:frame-id [frame-id #f] + #:free=id [free=id #f]) + (cond + [(and (not frame-id) + (not free=id)) + key] + [else + (full-local-binding frame-id free=id key)])) + +(define (local-binding-update b + #:key [key (local-binding-key b)] + #:frame-id [frame-id (binding-frame-id b)] + #:free=id [free=id (binding-free=id b)]) + (make-local-binding key + #:frame-id frame-id + #:free=id free=id)) + +(define (local-binding-key b) + (if (full-local-binding? b) + (full-local-binding-key b) + b)) diff -Nru racket-6.12+ppa1/src/expander/syntax/mapped-name.rkt racket-7.0+ppa1/src/expander/syntax/mapped-name.rkt --- racket-6.12+ppa1/src/expander/syntax/mapped-name.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/mapped-name.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base +(require "../common/set.rkt" + "syntax.rkt" + "scope.rkt" + (submod "scope.rkt" for-debug) + "binding-table.rkt") + +(provide syntax-mapped-names) + +(define (syntax-mapped-names s phase) + (define s-scs (syntax-scope-set s phase)) + (for/fold ([syms (seteq)]) ([sc (in-set s-scs)]) + (set-union syms + (binding-table-symbols (scope-binding-table sc) s-scs s null)))) diff -Nru racket-6.12+ppa1/src/expander/syntax/match.rkt racket-7.0+ppa1/src/expander/syntax/match.rkt --- racket-6.12+ppa1/src/expander/syntax/match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base +(require "../common/make-match.rkt" + "syntax.rkt" + "scope.rkt" + "error.rkt") + +(provide define-match) + +;; See "../common/make-match.rkt" for information on using +;; `define-match` + +(define-define-match define-match + syntax? syntax-e raise-syntax-error) diff -Nru racket-6.12+ppa1/src/expander/syntax/module-binding.rkt racket-7.0+ppa1/src/expander/syntax/module-binding.rkt --- racket-6.12+ppa1/src/expander/syntax/module-binding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/module-binding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,188 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "full-binding.rkt") + +(provide make-module-binding + module-binding-update + module-binding? + + module-binding-module + module-binding-phase + module-binding-sym + module-binding-nominal-module + module-binding-nominal-phase + module-binding-nominal-sym + module-binding-nominal-require-phase + module-binding-extra-inspector + module-binding-extra-nominal-bindings + + deserialize-full-module-binding + deserialize-simple-module-binding) + +;; ---------------------------------------- + +(define (make-module-binding module phase sym + #:wrt [wrt-sym sym] + #:nominal-module [nominal-module module] + #:nominal-phase [nominal-phase phase] + #:nominal-sym [nominal-sym sym] + #:nominal-require-phase [nominal-require-phase 0] + #:frame-id [frame-id #f] + #:free=id [free=id #f] + #:extra-inspector [extra-inspector #f] + #:extra-nominal-bindings [extra-nominal-bindings null]) + (cond + [(or frame-id + free=id + extra-inspector + (not (and (eqv? nominal-phase phase) + (eq? nominal-sym sym) + (eqv? nominal-require-phase 0) + (null? extra-nominal-bindings)))) + (full-module-binding frame-id + free=id + module phase sym + nominal-module nominal-phase nominal-sym + nominal-require-phase + extra-inspector + extra-nominal-bindings)] + [else + (simple-module-binding module phase sym nominal-module)])) + +(define (module-binding-update b + #:module [module (module-binding-module b)] + #:phase [phase (module-binding-phase b)] + #:sym [sym (module-binding-sym b)] + #:nominal-module [nominal-module (module-binding-nominal-module b)] + #:nominal-phase [nominal-phase (module-binding-nominal-phase b)] + #:nominal-sym [nominal-sym (module-binding-nominal-sym b)] + #:nominal-require-phase [nominal-require-phase (module-binding-nominal-require-phase b)] + #:frame-id [frame-id (binding-frame-id b)] + #:free=id [free=id (binding-free=id b)] + #:extra-inspector [extra-inspector (module-binding-extra-inspector b)] + #:extra-nominal-bindings [extra-nominal-bindings (module-binding-extra-nominal-bindings b)]) + (make-module-binding module phase sym + #:nominal-module nominal-module + #:nominal-phase nominal-phase + #:nominal-sym nominal-sym + #:nominal-require-phase nominal-require-phase + #:frame-id frame-id + #:free=id free=id + #:extra-inspector extra-inspector + #:extra-nominal-bindings extra-nominal-bindings)) + +(define (module-binding? b) + ;; must not overlap with `local-binding?` + (or (simple-module-binding? b) + (full-module-binding? b))) + +;; See `identifier-binding` docs for information about these fields: +(struct full-module-binding full-binding (module phase sym + nominal-module nominal-phase nominal-sym + nominal-require-phase + extra-inspector ; preserves access to protected definitions + extra-nominal-bindings) + #:authentic + #:transparent + #:property prop:serialize + (lambda (b ser-push! state) + ;; Dropping the frame id may simplify the representation: + (define simplified-b + (if (full-binding-frame-id b) + (module-binding-update b #:frame-id #f) + b)) + (cond + [(full-module-binding? simplified-b) + (ser-push! 'tag '#:module-binding) + (ser-push! (full-module-binding-module b)) + (ser-push! (full-module-binding-sym b)) + (ser-push! (full-module-binding-phase b)) + (ser-push! (full-module-binding-nominal-module b)) + (ser-push! (full-module-binding-nominal-phase b)) + (ser-push! (full-module-binding-nominal-sym b)) + (ser-push! (full-module-binding-nominal-require-phase b)) + (ser-push! (full-binding-free=id b)) + (if (full-module-binding-extra-inspector b) + (ser-push! 'tag '#:inspector) + (ser-push! #f)) + (ser-push! (full-module-binding-extra-nominal-bindings b))] + [else + (ser-push! simplified-b)]))) + +(struct simple-module-binding (module phase sym nominal-module) + #:authentic + #:transparent + #:property prop:serialize + (lambda (b ser-push! state) + (ser-push! 'tag '#:simple-module-binding) + (ser-push! (simple-module-binding-module b)) + (ser-push! (simple-module-binding-sym b)) + (ser-push! (simple-module-binding-phase b)) + (ser-push! (simple-module-binding-nominal-module b)))) + +(define (deserialize-full-module-binding module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings) + (make-module-binding module phase sym + #:nominal-module nominal-module + #:nominal-phase nominal-phase + #:nominal-sym nominal-sym + #:nominal-require-phase nominal-require-phase + #:free=id free=id + #:extra-inspector extra-inspector + #:extra-nominal-bindings extra-nominal-bindings)) + +(define (deserialize-simple-module-binding module sym phase nominal-module) + (simple-module-binding module phase sym nominal-module)) + +;; ---------------------------------------- + +(define (module-binding-module b) + (if (simple-module-binding? b) + (simple-module-binding-module b) + (full-module-binding-module b))) + +(define (module-binding-phase b) + (if (simple-module-binding? b) + (simple-module-binding-phase b) + (full-module-binding-phase b))) + +(define (module-binding-sym b) + (if (simple-module-binding? b) + (simple-module-binding-sym b) + (full-module-binding-sym b))) + +(define (module-binding-nominal-module b) + (if (simple-module-binding? b) + (simple-module-binding-nominal-module b) + (full-module-binding-nominal-module b))) + +(define (module-binding-nominal-phase b) + (if (simple-module-binding? b) + (simple-module-binding-phase b) + (full-module-binding-nominal-phase b))) + +(define (module-binding-nominal-sym b) + (if (simple-module-binding? b) + (simple-module-binding-sym b) + (full-module-binding-nominal-sym b))) + +(define (module-binding-nominal-require-phase b) + (if (simple-module-binding? b) + 0 + (full-module-binding-nominal-require-phase b))) + +(define (module-binding-extra-inspector b) + (if (simple-module-binding? b) + #f + (full-module-binding-extra-inspector b))) + +(define (module-binding-extra-nominal-bindings b) + (if (simple-module-binding? b) + null + (full-module-binding-extra-nominal-bindings b))) diff -Nru racket-6.12+ppa1/src/expander/syntax/original.rkt racket-7.0+ppa1/src/expander/syntax/original.rkt --- racket-6.12+ppa1/src/expander/syntax/original.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/original.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide original-property-sym) + +(define original-property-sym + (gensym 'original)) + diff -Nru racket-6.12+ppa1/src/expander/syntax/preserved.rkt racket-7.0+ppa1/src/expander/syntax/preserved.rkt --- racket-6.12+ppa1/src/expander/syntax/preserved.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/preserved.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base +(require "datum-map.rkt" + "../common/prefab.rkt") + +(provide preserved-property-value? + preserved-property-value + plain-property-value + + check-value-to-preserve) + +(struct preserved-property-value (content)) + +(define (plain-property-value v) + (if (preserved-property-value? v) + (preserved-property-value-content v) + v)) + +(define (deserialize-preserved-property-value v) + (preserved-property-value v)) + +(define (check-value-to-preserve v syntax?) + (define (check-preserve tail? v) + (unless (or (null? v) (boolean? v) (symbol? v) (number? v) + (char? v) (string? v) (bytes? v) (regexp? v) + (syntax? v) + (pair? v) (vector? v) (box? v) (hash? v) + (immutable-prefab-struct-key v)) + (raise-arguments-error 'write + "disallowed value in preserved syntax property" + "value" v)) + v) + (datum-map v check-preserve check-preserve disallow-cycles)) + +(define disallow-cycles + (hash 'cycle-fail + (lambda (v) + (raise-arguments-error 'write + "disallowed cycle in preserved syntax property" + "at" v)))) diff -Nru racket-6.12+ppa1/src/expander/syntax/property.rkt racket-7.0+ppa1/src/expander/syntax/property.rkt --- racket-6.12+ppa1/src/expander/syntax/property.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/property.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,58 @@ +#lang racket/base +(require "syntax.rkt" + "preserved.rkt" + "../common/contract.rkt") + +(provide syntax-property + syntax-property-preserved? + syntax-property-symbol-keys + syntax-property-remove) + +;; ---------------------------------------- + +(define/who syntax-property + (case-lambda + [(s key) + (check who syntax? s) + (define v (hash-ref (syntax-props s) key #f)) + (plain-property-value v)] + [(s key val) + (check who syntax? s) + (define pval (if (eq? key 'paren-shape) + (preserved-property-value val) + val)) + (struct-copy syntax s + [props (hash-set (syntax-props s) key pval)])] + [(s key val preserved?) + (check who syntax? s) + (when preserved? + (unless (and (symbol? key) (symbol-interned? key)) + (raise-arguments-error who + "key for a perserved property must be an interned symbol" + "given key" key + "given value" val))) + (define pval (if preserved? + (preserved-property-value val) + val)) + (struct-copy syntax s + [props (hash-set (syntax-props s) key pval)])])) + +(define/who (syntax-property-preserved? s key) + (check who syntax? s) + (unless (and (symbol? key) (symbol-interned? key)) + (raise-argument-error who "(and/c symbol? symbol-interned?)" key)) + (preserved-property-value? (hash-ref (syntax-props s) key #f))) + +(define/who (syntax-property-symbol-keys s) + (unless (syntax? s) + (raise-argument-error who "syntax" s)) + (for/list ([(k v) (in-immutable-hash (syntax-props s))] + #:when (and (symbol? k) (symbol-interned? k))) + k)) + +(define/who (syntax-property-remove s key) + (check who syntax? s) + (if (hash-ref (syntax-props s) key #f) + (struct-copy syntax s + [props (hash-remove (syntax-props s) key)]) + s)) diff -Nru racket-6.12+ppa1/src/expander/syntax/read-syntax.rkt racket-7.0+ppa1/src/expander/syntax/read-syntax.rkt --- racket-6.12+ppa1/src/expander/syntax/read-syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/read-syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,172 @@ +#lang racket/base +(require "../common/performance.rkt" + (rename-in "../read/main.rkt" + [read main:read] + [read-language main:read-language]) + "syntax.rkt" + "property.rkt" + "original.rkt" + "../eval/dynamic-require.rkt" + "../namespace/api-module.rkt" + "../namespace/namespace.rkt" + "srcloc.rkt" + "../host/linklet.rkt") + +(provide read + read/recursive + read-syntax + read-syntax/recursive + read-language) + +(define (read-syntax src in) + (cond + [(default-read-handler? in) + (maybe-flush-stdout in) + (read* in + #:for-syntax? #t + #:source src)] + [else + ;; `values` forces a single result value: + (values ((port-read-handler in) in src))])) + +(define (read-syntax/recursive src in start readtable graph?) + (read* in + #:for-syntax? #t + #:recursive? #t + #:source src + #:init-c start + #:readtable readtable + #:local-graph? (not graph?))) + +(define (read in) + (cond + [(default-read-handler? in) + (maybe-flush-stdout in) + (read* in + #:for-syntax? #f)] + [else + ;; `values` forces a single result value: + (values ((port-read-handler in) in))])) + +(define (read/recursive in start readtable graph?) + (read* in + #:for-syntax? #f + #:recursive? #t + #:init-c start + #:readtable readtable + #:local-graph? (not graph?))) + +(define (read* in + #:for-syntax? for-syntax? + #:recursive? [recursive? #f] + #:source [source #f] + #:init-c [init-c #f] + #:readtable [readtable (current-readtable)] + #:local-graph? [local-graph? #f]) + (performance-region + ['read] + (main:read in + #:for-syntax? for-syntax? + #:recursive? recursive? + #:source source + #:wrap (and for-syntax? + read-to-syntax) + #:init-c init-c + #:readtable readtable + #:local-graph? local-graph? + #:read-compiled read-compiled-linklet + #:dynamic-require dynamic-require-reader + #:module-declared? read-module-declared? + #:coerce read-coerce + #:coerce-key read-coerce-key))) + +(define (read-language in fail-thunk) + (main:read-language in fail-thunk + #:for-syntax? #t + #:wrap read-to-syntax + #:read-compiled read-compiled-linklet + #:dynamic-require dynamic-require-reader + #:module-declared? read-module-declared? + #:coerce read-coerce + #:coerce-key read-coerce-key)) + +(define (read-to-syntax s-exp srcloc rep) + (struct-copy syntax empty-syntax + [content (datum-intern-literal s-exp)] + [srcloc srcloc] + [props (case rep + [(#\[) original-square-props] + [(#\{) original-curly-props] + [else original-props])])) + +(define original-props + (syntax-props (syntax-property empty-syntax original-property-sym #t))) +(define original-square-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\[))) +(define original-curly-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\{))) + +(define (read-module-declared? mod-path) + (module-declared? mod-path #t)) + +(define (read-coerce for-syntax? v srcloc) + (cond + [(not for-syntax?) + (cond + [(syntax? v) (syntax->datum v)] + [else v])] + [(syntax? v) v] + [(list? v) + (read-to-syntax (for/list ([e (in-list v)]) + (read-coerce #t e srcloc)) + srcloc + #f)] + [(pair? v) + (read-to-syntax (cons (read-coerce #t (car v) srcloc) + (read-coerce #t (cdr v) srcloc)) + srcloc + #f)] + [else + (read-to-syntax v srcloc #f)])) + +(define (read-coerce-key for-syntax? k) + (cond + [for-syntax? (datum-intern-literal k)] + [else k])) + +;; ---------------------------------------- + +;; Initialized on first port that we read from, on the +;; assuption that we have to read some file before a +;; read handler can possibly be set: +(define default-read-handler #f) + +(define (default-read-handler? in) + (cond + [(not default-read-handler) + (set! default-read-handler (port-read-handler in)) + #t] + [else + (eq? default-read-handler (port-read-handler in))])) + +(define orig-input-port (current-input-port)) +(define orig-output-port (current-output-port)) +(define orig-error-port (current-error-port)) + +(define (maybe-flush-stdout in) + (when (eq? in orig-input-port) + (flush-output orig-output-port) + (flush-output orig-error-port))) + +;; ---------------------------------------- + +(define (dynamic-require-reader mod-path sym [fail-thunk default-dynamic-require-fail-thunk]) + (define root-ns (namespace-root-namespace (current-namespace))) + (if root-ns + ;; Switch to the root namespace: + (parameterize ([current-namespace root-ns]) + (dynamic-require mod-path sym fail-thunk)) + ;; Current namespace is a root namespace: + (dynamic-require mod-path sym fail-thunk))) diff -Nru racket-6.12+ppa1/src/expander/syntax/scope.rkt racket-7.0+ppa1/src/expander/syntax/scope.rkt --- racket-6.12+ppa1/src/expander/syntax/scope.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/scope.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,925 @@ +#lang racket/base +(require ffi/unsafe/atomic + "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/memo.rkt" + "../common/inline.rkt" + "syntax.rkt" + "binding-table.rkt" + "tamper.rkt" + "taint.rkt" + "../common/phase.rkt" + "fallback.rkt" + "datum-map.rkt" + "cache.rkt") + +(provide new-scope + make-interned-scope + new-multi-scope + add-scope + add-scopes + remove-scope + remove-scopes + flip-scope + flip-scopes + push-scope + + syntax-e ; handles lazy scope and taint propagation + syntax-e/no-taint ; like `syntax-e`, but doesn't explode a dye pack + + syntax-scope-set + syntax-any-scopes? + syntax-any-macro-scopes? + + syntax-shift-phase-level + + syntax-swap-scopes + + add-binding-in-scopes! + add-bulk-binding-in-scopes! + + propagation-mpi-shift ; for use by "binding.rkt" + + resolve + + bound-identifier=? + + top-level-common-scope + + deserialize-scope + deserialize-scope-fill! + deserialize-representative-scope + deserialize-representative-scope-fill! + deserialize-multi-scope + deserialize-shifted-multi-scope + + generalize-scope + + scope? + scope" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (unless (set-member? (serialize-state-reachable-scopes state) s) + (error "internal error: found supposedly unreachable scope")) + (cond + [(eq? s top-level-common-scope) + (ser-push! 'tag '#:scope)] + [else + (ser-push! 'tag '#:scope+kind) + (ser-push! (scope-kind s))])) + #:property prop:serialize-fill! + (lambda (s ser-push! state) + (cond + [(binding-table-empty? (scope-binding-table s)) + (ser-push! 'tag #f)] + [else + (ser-push! 'tag '#:scope-fill!) + (ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))])) + #:property prop:reach-scopes + (lambda (s reach) + ;; the `bindings` field is handled via `prop:scope-with-bindings` + (void)) + #:property prop:scope-with-bindings + (lambda (s get-reachable-scopes reach register-trigger) + (binding-table-register-reachable (scope-binding-table s) + get-reachable-scopes + reach + register-trigger))) + +(define deserialize-scope + (case-lambda + [() top-level-common-scope] + [(kind) + (scope (new-deserialize-scope-id!) kind empty-binding-table)])) + +(define (deserialize-scope-fill! s bt) + (set-scope-binding-table! s bt)) + +;; An "interned scope" is a scope identified by an interned symbol that is +;; consistent across both module instantiations and bytecode unmarshalling. +;; Creating an interned scope with the same symbol will always produce the +;; same scope. +(struct interned-scope scope (key) ; symbolic key used for interning + #:authentic + #:property prop:custom-write + (lambda (sc port mode) + (write-string "#" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (unless (set-member? (serialize-state-reachable-scopes state) s) + (error "internal error: found supposedly unreachable scope")) + (ser-push! 'tag '#:interned-scope) + (ser-push! (interned-scope-key s)))) + +;; A "multi-scope" represents a group of scopes, each of which exists +;; only at a specific phase, and each in a distinct phase. This +;; infinite group of scopes is realized on demand. A multi-scope is +;; used to represent the inside of a module, where bindings in +;; different phases are distinguished by the different scopes within +;; the module's multi-scope. +;; +;; To compute a syntax's set of scopes at a given phase, the +;; phase-specific representative of the multi scope is combined with +;; the phase-independent scopes. Since a multi-scope corresponds to +;; a module, the number of multi-scopes in a syntax is expected to +;; be small. +(struct multi-scope (id ; identity + name ; for debugging + scopes ; phase -> representative-scope + shifted ; box of table: interned shifted-multi-scopes for non-label phases + label-shifted) ; box of table: interned shifted-multi-scopes for label phases + #:authentic + #:property prop:serialize + (lambda (ms ser-push! state) + (ser-push! 'tag '#:multi-scope) + (ser-push! (multi-scope-name ms)) + ;; Prune to reachable representative scopes + (define multi-scope-tables (serialize-state-multi-scope-tables state)) + (ser-push! (or (hash-ref multi-scope-tables (multi-scope-scopes ms) #f) + (let ([ht (make-hasheqv)]) + (for ([(phase sc) (in-hash (multi-scope-scopes ms))]) + (when (set-member? (serialize-state-reachable-scopes state) sc) + (hash-set! ht phase sc))) + (hash-set! multi-scope-tables (multi-scope-scopes ms) ht) + ht)))) + #:property prop:reach-scopes + (lambda (s reach) + ;; the `scopes` field is handled via `prop:scope-with-bindings` + (void)) + #:property prop:scope-with-bindings + (lambda (ms get-reachable-scopes reach register-trigger) + ;; This scope is reachable via its multi-scope, but it only + ;; matters if it's reachable through a binding (otherwise it + ;; can be re-generated later). We don't want to keep a scope + ;; that can be re-generated, because pruning it makes + ;; compilation more deterministic relative to other + ;; compilations that involve a shared module. If the scope + ;; itself has any bindings, then we count it as reachable + ;; through a binding (which is an approxmation, because + ;; other scopes in the binding may be unreachable, but it + ;; seems good enough for determinism). + ;; To make that work, `binding-table-register-reachable` + ;; needs to recognize representative scopes and treat + ;; them differently, hence `prop:implicitly-reachable`. + (for ([sc (in-hash-values (multi-scope-scopes ms))]) + (unless (binding-table-empty? (scope-binding-table sc)) + (reach sc))))) + +(define (deserialize-multi-scope name scopes) + (multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash)))) + +(struct representative-scope scope (owner ; a multi-scope for which this one is a phase-specific identity + phase) ; phase of this scope + #:authentic + #:mutable ; to support serialization + #:property prop:custom-write + (lambda (sc port mode) + (write-string "#" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (ser-push! 'tag '#:representative-scope) + (ser-push! (scope-kind s)) + (ser-push! (representative-scope-phase s))) + #:property prop:serialize-fill! + (lambda (s ser-push! state) + (ser-push! 'tag '#:representative-scope-fill!) + (ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state)) + (ser-push! (representative-scope-owner s))) + #:property prop:reach-scopes + (lambda (s reach) + ;; the inherited `bindings` field is handled via `prop:scope-with-bindings` + (reach (representative-scope-owner s))) + ;; Used by `binding-table-register-reachable`: + #:property prop:implicitly-reachable #t) + +(define (deserialize-representative-scope kind phase) + (define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase)) + v) + +(define (deserialize-representative-scope-fill! s bt owner) + (deserialize-scope-fill! s bt) + (set-representative-scope-owner! s owner)) + +(struct shifted-multi-scope (phase ; non-label phase shift or shifted-to-label-phase + multi-scope) ; a multi-scope + #:authentic + #:property prop:custom-write + (lambda (sms port mode) + (write-string "#" port)) + #:property prop:serialize + (lambda (sms ser-push! state) + (ser-push! 'tag '#:shifted-multi-scope) + (ser-push! (shifted-multi-scope-phase sms)) + (ser-push! (shifted-multi-scope-multi-scope sms))) + #:property prop:reach-scopes + (lambda (sms reach) + (reach (shifted-multi-scope-multi-scope sms)))) + +(define (deserialize-shifted-multi-scope phase multi-scope) + (intern-shifted-multi-scope phase multi-scope)) + +(define (intern-shifted-multi-scope phase multi-scope) + (define (transaction-loop boxed-table key make) + (or (hash-ref (unbox boxed-table) phase #f) + (let* ([val (make)] + [current (unbox boxed-table)] + [next (hash-set current key val)]) + (if (box-cas! boxed-table current next) + val + (transaction-loop boxed-table key make))))) + (cond + [(phase? phase) + ;; `eqv?`-hashed by phase + (or (hash-ref (unbox (multi-scope-shifted multi-scope)) phase #f) + (transaction-loop (multi-scope-shifted multi-scope) + phase + (lambda () (shifted-multi-scope phase multi-scope))))] + [else + ;; `equal?`-hashed by shifted-to-label-phase + (or (hash-ref (unbox (multi-scope-label-shifted multi-scope)) phase #f) + (transaction-loop (multi-scope-label-shifted multi-scope) + phase + (lambda () (shifted-multi-scope phase multi-scope))))])) + +;; A `shifted-to-label-phase` record in the `phase` field of a +;; `shifted-multi-scope` makes the shift reversible; when we're +;; looking up the label phase, then use the representative scope at +;; phase `from`; when we're looking up a non-label phase, there is no +;; corresponding representative scope +(struct shifted-to-label-phase (from) #:prefab) + +;; Each new scope increments the counter, so we can check whether one +;; scope is newer than another. +(define id-counter 0) +(define (new-scope-id!) + (set! id-counter (add1 id-counter)) + id-counter) + +(define (new-deserialize-scope-id!) + ;; negative scope ensures that new scopes are recognized as such by + ;; having a larger id + (- (new-scope-id!))) + +(define (deserialized-scope-id? scope-id) + (negative? scope-id)) + +;; A shared "outside-edge" scope for all top-level contexts +(define top-level-common-scope (scope 0 'module empty-binding-table)) + +(define (new-scope kind) + (scope (new-scope-id!) kind empty-binding-table)) + +;; The intern table used for interned scopes. Access to the table must be +;; atomic so that the table is not left locked if the expansion thread is +;; killed. +(define interned-scopes-table (make-weak-hasheq)) + +(define (make-interned-scope sym) + (define (make) + ;; since interned scopes are reused by unmarshalled code, and because they’re generally unlikely + ;; to be a good target for bindings, always create them with a negative id + (make-ephemeron sym (interned-scope (- (new-scope-id!)) 'interned empty-binding-table sym))) + (call-as-atomic + (lambda () + (or (ephemeron-value + (hash-ref! interned-scopes-table sym make)) + (let ([new (make)]) + (hash-set! interned-scopes-table sym new) + (ephemeron-value new)))))) + +(define (new-multi-scope [name #f]) + (intern-shifted-multi-scope 0 (multi-scope (new-scope-id!) name (make-hasheqv) (box (hasheqv)) (box (hash))))) + +(define (multi-scope-to-scope-at-phase ms phase) + ;; Get the identity of `ms` at phase` + (or (hash-ref (multi-scope-scopes ms) phase #f) + (let ([s (representative-scope (if (deserialized-scope-id? (multi-scope-id ms)) + (new-deserialize-scope-id!) + (new-scope-id!)) + 'module + empty-binding-table + ms phase)]) + (hash-set! (multi-scope-scopes ms) phase s) + s))) + +(define (scope>? sc1 sc2) + ((scope-id sc1) . > . (scope-id sc2))) +(define (scope (or/c 'add 'remove 'flip) + ;; mpi-shifts and inspectors are mostly + ;; implemented at the "binding.rkt" layer, + ;; but we accomodate them here + prev-mss ; owner's mpi-shifts before adds + add-mpi-shifts ; #f or (mpi-shifts -> mpi-shifts) + inspector ; #f or inspector + tamper) ; see "tamper.rkt" + #:authentic + #:property prop:propagation syntax-e + #:property prop:propagation-tamper (lambda (p) (propagation-tamper p)) + #:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v))) + +(define (propagation-add prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [scope-ops (hash-set (propagation-scope-ops prop) + sc + 'add)]) + (propagation prev-scs prev-smss (hasheq sc 'add) + prev-mss #f #f + prop))) + +(define (propagation-remove prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [scope-ops (hash-set (propagation-scope-ops prop) + sc + 'remove)]) + (propagation prev-scs prev-smss (hasheq sc 'remove) + prev-mss #f #f + prop))) + +(define (propagation-flip prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (let* ([ops (propagation-scope-ops prop)] + [current-op (hash-ref ops sc #f)]) + (cond + [(and (eq? current-op 'flip) + (= 1 (hash-count ops)) + (not (propagation-inspector prop)) + (not (propagation-add-mpi-shifts prop))) + ;; Nothing left to propagate + #f] + [else + (struct-copy propagation prop + [scope-ops + (if (eq? current-op 'flip) + (hash-remove ops sc) + (hash-set ops sc (case current-op + [(add) 'remove] + [(remove) 'add] + [else 'flip])))])])) + (propagation prev-scs prev-smss (hasheq sc 'flip) + prev-mss #f #f + prop))) + +(define (propagation-mpi-shift prop add inspector prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [add-mpi-shifts (let ([base-add (propagation-add-mpi-shifts prop)]) + (if (and add base-add) + (lambda (mss) (add (base-add mss))) + (or add base-add)))] + [inspector (or (propagation-inspector prop) + inspector)]) + (propagation prev-scs prev-smss #hasheq() + prev-mss add inspector + prop))) + +(define (propagation-apply prop scs parent-s) + (cond + [(eq? (propagation-prev-scs prop) scs) + (syntax-scopes parent-s)] + [else + (define new-scs + (for/fold ([scs scs]) ([(sc op) (in-immutable-hash (propagation-scope-ops prop))] + #:when (not (shifted-multi-scope? sc))) + (case op + [(add) (set-add scs sc)] + [(remove) (set-remove scs sc)] + [else (set-flip scs sc)]))) + ;; Improve sharing if the result matches the parent: + (if (set=? new-scs (syntax-scopes parent-s)) + (syntax-scopes parent-s) + (cache-or-reuse-set new-scs))])) + +(define (propagation-apply-shifted prop smss parent-s) + (cond + [(eq? (propagation-prev-smss prop) smss) + (syntax-shifted-multi-scopes parent-s)] + [else + (define new-smss + (for/fold ([smss smss]) ([(sms op) (in-immutable-hash (propagation-scope-ops prop))] + #:when (shifted-multi-scope? sms)) + (fallback-update-first + smss + (lambda (smss) + (case op + [(add) (set-add smss sms)] + [(remove) (set-remove smss sms)] + [else (set-flip smss sms)]))))) + ;; Improve sharing if the result clearly matches the parent: + (define parent-smss (syntax-shifted-multi-scopes parent-s)) + (if (and (set? new-smss) + (set? parent-smss) + (set=? new-smss parent-smss)) + parent-smss + (cache-or-reuse-hash new-smss))])) + +(define (propagation-apply-mpi-shifts prop mss parent-s) + (cond + [(eq? (propagation-prev-mss prop) mss) + (syntax-mpi-shifts parent-s)] + [else + (define add (propagation-add-mpi-shifts prop)) + (if add + (add mss) + mss)])) + +(define (propagation-apply-inspector prop i) + (or i (propagation-inspector prop))) + +(define (propagation-set-tamper prop t) + (if (propagation? prop) + (struct-copy propagation prop + [tamper t]) + t)) + +(define (propagation-merge content prop base-prop prev-scs prev-smss prev-mss) + (cond + [(not (datum-has-elements? content)) + (if (tamper-tainted? (propagation-tamper prop)) + 'tainted + base-prop)] + [(not (propagation? base-prop)) + (cond + [(and (eq? (propagation-prev-scs prop) prev-scs) + (eq? (propagation-prev-smss prop) prev-smss) + (eq? (propagation-prev-mss prop) prev-mss) + (eq? (propagation-tamper prop) base-prop)) + prop] + [else + (propagation prev-scs + prev-smss + (propagation-scope-ops prop) + prev-mss + (propagation-add-mpi-shifts prop) + (propagation-inspector prop) + (if (tamper-tainted? (propagation-tamper prop)) + 'tainted/need-propagate + base-prop))])] + [else + (define new-ops + ;; [could call `cache-or-reuse-hash` here (or a copy for propagations), + ;; but that doesn't seem to same time or space overall] + (for/fold ([ops (propagation-scope-ops base-prop)]) ([(sc op) (in-immutable-hash (propagation-scope-ops prop))]) + (case op + [(add) (hash-set ops sc 'add)] + [(remove) (hash-set ops sc 'remove)] + [else ; flip + (define current-op (hash-ref ops sc #f)) + (case current-op + [(add) (hash-set ops sc 'remove)] + [(remove) (hash-set ops sc 'add)] + [(flip) (hash-remove ops sc)] + [else (hash-set ops sc 'flip)])]))) + (define add (propagation-add-mpi-shifts prop)) + (define base-add (propagation-add-mpi-shifts base-prop)) + (define new-tamper + (if (or (tamper-tainted? (propagation-tamper prop)) + (tamper-tainted? (propagation-tamper base-prop))) + 'tainted/need-propagate + (propagation-tamper base-prop))) + (if (and (zero? (hash-count new-ops)) + (not add) + (not base-add) + (not (propagation-inspector prop)) + (not (propagation-inspector base-prop))) + new-tamper + (struct-copy propagation base-prop + [scope-ops new-ops] + [add-mpi-shifts (if (and add base-add) + (lambda (mss) (add (base-add mss))) + (or add base-add))] + [inspector (or (propagation-inspector base-prop) + (propagation-inspector prop))] + [tamper new-tamper]))])) + +;; ---------------------------------------- + +;; To shift a syntax's phase, we only have to shift the phase +;; of any phase-specific scopes. The bindings attached to a +;; scope must be represented in such a way that the binding +;; shift is implicit via the phase in which the binding +;; is resolved. +(define (shift-multi-scope sms delta) + (cond + [(zero-phase? delta) + ;; No-op shift + sms] + [(label-phase? delta) + (cond + [(shifted-to-label-phase? (shifted-multi-scope-phase sms)) + ;; Shifting to the label phase moves only phase 0, so + ;; drop a scope that is already collapsed to phase #f + #f] + [else + ;; Move the current phase 0 to the label phase, which + ;; means recording the negation of the current phase + (intern-shifted-multi-scope (shifted-to-label-phase (phase- 0 (shifted-multi-scope-phase sms))) + (shifted-multi-scope-multi-scope sms))])] + [(shifted-to-label-phase? (shifted-multi-scope-phase sms)) + ;; Numeric shift has no effect on bindings in phase #f + sms] + [else + ;; Numeric shift added to an existing numeric shift + (intern-shifted-multi-scope (phase+ delta (shifted-multi-scope-phase sms)) + (shifted-multi-scope-multi-scope sms))])) + +;; Since we tend to shift rarely and only for whole modules, it's +;; probably not worth making this lazy +(define (syntax-shift-phase-level s phase) + (if (eqv? phase 0) + s + (let () + (define-memo-lite (shift-all smss) + (fallback-map + smss + (lambda (smss) + (for*/seteq ([sms (in-set smss)] + [new-sms (in-value (shift-multi-scope sms phase))] + #:when new-sms) + new-sms)))) + (syntax-map s + (lambda (tail? d) d) + (lambda (s d) + (struct-copy syntax s + [content d] + [shifted-multi-scopes + (shift-all (syntax-shifted-multi-scopes s))])) + syntax-e/no-taint)))) + +;; ---------------------------------------- + +;; Scope swapping is used to make top-level compilation relative to +;; the top level. Each top-level environment has a set of scopes that +;; identify the environment; usually, it's a common outside-edge scope +;; and a namespace-specific inside-edge scope, but there can be +;; additional scopes due to `module->namespace` on a module that was +;; expanded multiple times (where each expansion adds scopes). +(define (syntax-swap-scopes s src-scopes dest-scopes) + (if (equal? src-scopes dest-scopes) + s + (let-values ([(src-smss src-scs) + (set-partition (for/seteq ([sc (in-set src-scopes)]) + (generalize-scope sc)) + shifted-multi-scope? + (seteq) + (seteq))] + [(dest-smss dest-scs) + (set-partition (for/seteq ([sc (in-set dest-scopes)]) + (generalize-scope sc)) + shifted-multi-scope? + (seteq) + (seteq))]) + (define-memo-lite (swap-scs scs) + (if (subset? src-scs scs) + (set-union (set-subtract scs src-scs) dest-scs) + scs)) + (define-memo-lite (swap-smss smss) + (fallback-update-first + smss + (lambda (smss) + (if (subset? src-smss smss) + (set-union (set-subtract smss src-smss) dest-smss) + smss)))) + (syntax-map s + (lambda (tail? d) d) + (lambda (s d) + (struct-copy syntax s + [content d] + [scopes (swap-scs (syntax-scopes s))] + [shifted-multi-scopes + (swap-smss (syntax-shifted-multi-scopes s))])) + syntax-e/no-taint)))) + +;; ---------------------------------------- + +;; Assemble the complete set of scopes at a given phase by extracting +;; a phase-specific representative from each multi-scope. +(define (syntax-scope-set s phase) + (scope-set-at-fallback s (fallback-first (syntax-shifted-multi-scopes s)) phase)) + +(define (scope-set-at-fallback s smss phase) + (for*/fold ([scopes (syntax-scopes s)]) ([sms (in-set smss)] + #:when (or (label-phase? phase) + (not (shifted-to-label-phase? (shifted-multi-scope-phase sms))))) + (set-add scopes (multi-scope-to-scope-at-phase (shifted-multi-scope-multi-scope sms) + (let ([ph (shifted-multi-scope-phase sms)]) + (if (shifted-to-label-phase? ph) + (shifted-to-label-phase-from ph) + (phase- ph phase))))))) + +(define (find-max-scope scopes) + (when (set-empty? scopes) + (error "cannot bind in empty scope set")) + (for/fold ([max-sc (set-first scopes)]) ([sc (in-set scopes)]) + (if (scope>? sc max-sc) + sc + max-sc))) + +(define (add-binding-in-scopes! scopes sym binding #:just-for-nominal? [just-for-nominal? #f]) + (define max-sc (find-max-scope scopes)) + (define bt (binding-table-add (scope-binding-table max-sc) scopes sym binding just-for-nominal?)) + (set-scope-binding-table! max-sc bt) + (clear-resolve-cache! sym)) + +(define (add-bulk-binding-in-scopes! scopes bulk-binding + #:shadow-except [shadow-except #f]) + (define max-sc (find-max-scope scopes)) + (define bt (binding-table-add-bulk (scope-binding-table max-sc) scopes bulk-binding + #:shadow-except shadow-except)) + (set-scope-binding-table! max-sc bt) + (clear-resolve-cache!)) + +(define (syntax-any-scopes? s) + (not (set-empty? (syntax-scopes s)))) + +(define (syntax-any-macro-scopes? s) + (for/or ([sc (in-set (syntax-scopes s))]) + (eq? (scope-kind sc) 'macro))) + +;; ---------------------------------------- + +;; Result is #f for no binding, `ambiguous-value` for an ambiguous binding, +;; or binding value +(define (resolve s phase + #:ambiguous-value [ambiguous-value #f] + #:exactly? [exactly? #f] + #:get-scopes? [get-scopes? #f] ; gets scope set instead of binding + ;; For resolving bulk bindings in `free-identifier=?` chains: + #:extra-shifts [extra-shifts null]) + (define sym (syntax-content s)) + (let fallback-loop ([smss (syntax-shifted-multi-scopes s)]) + (cond + [(and (not exactly?) + (not get-scopes?) + (resolve-cache-get sym phase (syntax-scopes s) (fallback-first smss))) + => (lambda (b) + (cond + [(eq? b '#:none) + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + #f)] + [else b]))] + [else + (define scopes (scope-set-at-fallback s (fallback-first smss) phase)) + ;; As we look through all scopes, if we find two where neither + ;; is a subset of the other, accumulate them into a list; maybe + ;; we find a superset of both, later; if we end with a list, + ;; then the binding is ambiguous. We expect that creating a list + ;; of ambiguous scopes is rare relative to eventual success. + (define-values (best-scopes best-binding) + (for*/fold ([best-scopes #f] [best-binding #f]) + ([sc (in-set scopes)] + [(b-scopes binding) (in-binding-table sym (scope-binding-table sc) s extra-shifts)] + #:when (and b-scopes binding (subset? b-scopes scopes))) + (cond + [(pair? best-scopes) + ;; We have a list of scopes where none is a superset of the others + (cond + [(for/and ([amb-scopes (in-list best-scopes)]) + (subset? amb-scopes b-scopes)) + ;; Found a superset of all + (values b-scopes binding)] + [else + ;; Accumulate another ambiguous set + (values (cons b-scopes best-scopes) #f)])] + [(not best-scopes) + (values b-scopes binding)] + [(subset? b-scopes best-scopes) ; can be `set=?` if binding is overridden + (values best-scopes best-binding)] + [(subset? best-scopes b-scopes) + (values b-scopes binding)] + [else + ;; Switch to ambiguous mode + (values (list best-scopes b-scopes) #f)]))) + (cond + [(pair? best-scopes) ; => ambiguous + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + ambiguous-value)] + [best-scopes + (resolve-cache-set! sym phase (syntax-scopes s) (fallback-first smss) best-binding) + (and (or (not exactly?) + (eqv? (set-count scopes) + (set-count best-scopes))) + (if get-scopes? + best-scopes + best-binding))] + [else + (resolve-cache-set! sym phase (syntax-scopes s) (fallback-first smss) '#:none) + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + #f)])]))) + +;; ---------------------------------------- + +(define (bound-identifier=? a b phase) + (and (eq? (syntax-e a) + (syntax-e b)) + (equal? (syntax-scope-set a phase) + (syntax-scope-set b phase)))) diff -Nru racket-6.12+ppa1/src/expander/syntax/srcloc.rkt racket-7.0+ppa1/src/expander/syntax/srcloc.rkt --- racket-6.12+ppa1/src/expander/syntax/srcloc.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/srcloc.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +#lang racket/base +(require "syntax.rkt") + +(provide syntax-source + syntax-line + syntax-column + syntax-position + syntax-span + + encoded-srcloc? + to-srcloc-stx) + +(define (syntax-source-accessor who srcloc-accessor) + (lambda (s) + (unless (syntax? s) + (raise-argument-error who "syntax?" s)) + (define srcloc (syntax-srcloc s)) + (and srcloc + (srcloc-accessor srcloc)))) + +(define syntax-source (syntax-source-accessor 'syntax-source srcloc-source)) +(define syntax-line (syntax-source-accessor 'syntax-line srcloc-line)) +(define syntax-column (syntax-source-accessor 'syntax-column srcloc-column)) +(define syntax-position (syntax-source-accessor 'syntax-position srcloc-position)) +(define syntax-span (syntax-source-accessor 'syntax-span srcloc-span)) + +(define (encoded-srcloc? v) + (or (and (list? v) + (= (length v) 5) + (srcloc-vector? (list->vector v))) + (and (vector? v) + (= (vector-length v) 5) + (srcloc-vector? v)))) + +(define (srcloc-vector? v) + (and (or (not (vector-ref v 1)) + (exact-positive-integer? (vector-ref v 1))) + (or (not (vector-ref v 2)) + (exact-nonnegative-integer? (vector-ref v 2))) + (or (not (vector-ref v 3)) + (exact-positive-integer? (vector-ref v 3))) + (or (not (vector-ref v 4)) + (exact-nonnegative-integer? (vector-ref v 4))))) + +(define (to-srcloc-stx v) + (cond + [(srcloc? v) (struct-copy syntax empty-syntax + [srcloc v])] + [(pair? v) (to-srcloc-stx (list->vector v))] + [(vector? v) + (struct-copy syntax empty-syntax + [srcloc (srcloc (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3) + (vector-ref v 4))])] + [else v])) diff -Nru racket-6.12+ppa1/src/expander/syntax/syntax.rkt racket-7.0+ppa1/src/expander/syntax/syntax.rkt --- racket-6.12+ppa1/src/expander/syntax/syntax.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/syntax.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,303 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/set.rkt" + "../common/inline.rkt" + "preserved.rkt" + "tamper.rkt" + "datum-map.rkt") + +(provide + (struct-out syntax) ; includes `syntax?` + syntax-tamper + empty-syntax + identifier? + syntax-identifier? + + syntax->datum + datum->syntax + + syntax-map + non-syntax-map + + prop:propagation + prop:propagation-tamper + prop:propagation-set-tamper + propagation-set-tamper? + propagation-set-tamper-ref + + deserialize-syntax + deserialize-datum->syntax + current-arm-inspectors) + +(struct syntax ([content #:mutable] ; datum and nested syntax objects; mutated for lazy propagation + scopes ; scopes that apply at all phases + shifted-multi-scopes ; scopes with a distinct identity at each phase; maybe a fallback search + [scope-propagations+tamper #:mutable] ; lazy propagation info and/or tamper state + mpi-shifts ; chain of module-path-index substitutions + srcloc ; source location + props ; properties + inspector) ; inspector for access to protected bindings + #:authentic + ;; Custom printer: + #:property prop:custom-write + (lambda (s port mode) + (write-string "#string srcloc)) + (when srcloc-str + (fprintf port ":~a" srcloc-str))) + (fprintf port " ~.s" (syntax->datum s)) + (write-string ">" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (define prop (syntax-scope-propagations+tamper s)) + (define content + (if (propagation? prop) + ((propagation-ref prop) s) + (syntax-content s))) + (define properties + (intern-properties + (syntax-props s) + (lambda () + (for/hasheq ([(k v) (in-hash (syntax-props s))] + #:when (preserved-property-value? v)) + (values k (check-value-to-preserve (plain-property-value v) syntax?)))) + state)) + (define tamper + (serialize-tamper (syntax-tamper s))) + (define context-triple + (intern-context-triple (intern-scopes (syntax-scopes s) state) + (intern-shifted-multi-scopes (syntax-shifted-multi-scopes s) state) + (intern-mpi-shifts (syntax-mpi-shifts s) state) + state)) + (define stx-state (get-syntax-context state)) + (cond + [(or properties tamper) + (ser-push! 'tag '#:syntax+props) + (push-syntax-context! state #f) + (ser-push! content) + (pop-syntax-context! state) + (ser-push! 'reference context-triple) + (ser-push! 'reference (syntax-srcloc s)) + (ser-push! properties) + (ser-push! tamper) + (when stx-state (set-syntax-state-all-sharing?! stx-state #f))] + [else + ;; We rely on two passes to reach a fixpoint on sharing: + (define sharing-mode (hash-ref (serialize-state-sharing-syntaxes state) s 'unknown)) + (cond + [(eq? sharing-mode 'share) + (ser-push! 'tag '#:datum->syntax) + (ser-push! (syntax->datum s))] + [(eq? sharing-mode 'unknown) + (ser-push! 'tag '#:syntax) + ;; Communicate to nested syntax objects the info that they might share + (define this-state (and (no-pair-syntax-in-cdr? content) + (syntax-state #t context-triple (syntax-srcloc s)))) + (push-syntax-context! state this-state) + ;; Serialize content + (ser-push! content) + ;; Check whether we're sharing for all nested syntax objects + (pop-syntax-context! state) + (define new-sharing-mode + (if (and this-state + (syntax-state-all-sharing? this-state)) + 'share + 'none)) + (hash-set! (serialize-state-sharing-syntaxes state) + s + ;; If the syntax object has only simple content, + ;; it doesn't need any sharing support by itself + (if (datum-has-elements? content) + new-sharing-mode + 'none)) + (when (and stx-state (eq? new-sharing-mode 'none)) + (set-syntax-state-all-sharing?! stx-state #f))] + [else + (ser-push! 'tag '#:syntax) + (push-syntax-context! state #f) + (ser-push! content) + (pop-syntax-context! state)]) + ;; Finish up + (ser-push! 'reference context-triple) + (ser-push! 'reference (syntax-srcloc s)) + (when stx-state + (unless (and (eq? context-triple (syntax-state-context-triple stx-state)) + (equal? (syntax-srcloc s) (syntax-state-srcloc stx-state))) + (set-syntax-state-all-sharing?! stx-state #f)))])) + #:property prop:reach-scopes + (lambda (s reach) + (define prop (syntax-scope-propagations+tamper s)) + (reach (if (propagation? prop) + ((propagation-ref prop) s) + (syntax-content s))) + (reach (syntax-scopes s)) + (reach (syntax-shifted-multi-scopes s)) + (for ([(k v) (in-immutable-hash (syntax-props s))] + #:when (preserved-property-value? v)) + (reach (plain-property-value v))) + (reach (syntax-srcloc s)))) + +;; Property to abstract over handling of propagation for +;; serialization; property value takes a syntax object and +;; returns its content +(define-values (prop:propagation propagation? propagation-ref) + (make-struct-type-property 'propagation)) + +;; Property to abstract over extraction of tamper from propagation +(define-values (prop:propagation-tamper propagation-tamper? propagation-tamper-ref) + (make-struct-type-property 'propagation-tamper)) +(define-values (prop:propagation-set-tamper propagation-set-tamper? propagation-set-tamper-ref) + (make-struct-type-property 'propagation-set-tamper)) + +(define (syntax-tamper s) + (define v (syntax-scope-propagations+tamper s)) + (if (tamper? v) + v + ((propagation-tamper-ref v) v))) + +;; ---------------------------------------- + +(define empty-scopes (seteq)) +(define empty-shifted-multi-scopes (seteq)) +(define empty-mpi-shifts null) +(define empty-props #hasheq()) + +(define empty-syntax + (syntax #f + empty-scopes + empty-shifted-multi-scopes + #f ; scope-propogations+tamper (clean) + empty-mpi-shifts + #f ; srcloc + empty-props + #f)) ; inspector + +(define (identifier? s) + (and (syntax? s) (symbol? (syntax-content s)))) + +(define (syntax-identifier? s) ; assumes that `s` is syntax + (symbol? (syntax-content s))) + +(define (syntax->datum s) + (syntax-map s (lambda (tail? x) x) (lambda (s d) d) syntax-content)) + +(define (datum->syntax stx-c s [stx-l #f] [stx-p #f]) + (cond + [(syntax? s) s] + [else + (define (wrap content) + (syntax content + (if stx-c + (syntax-scopes stx-c) + empty-scopes) + (if stx-c + (syntax-shifted-multi-scopes stx-c) + empty-shifted-multi-scopes) + (and stx-c + (syntax-tamper stx-c) + (tamper-tainted-for-content content)) + (if stx-c + (syntax-mpi-shifts stx-c) + empty-mpi-shifts) + (and stx-l (syntax-srcloc stx-l)) + empty-props + (and stx-c + (syntax-inspector stx-c)))) + (define result-s + (non-syntax-map s + (lambda (tail? x) (if tail? x (wrap x))) + (lambda (s) s) + disallow-cycles)) + (if (and stx-p (not (eq? (syntax-props stx-p) empty-props))) + (struct-copy syntax result-s + [props (syntax-props stx-p)]) + result-s)])) + +;; `(syntax-map s f d->s)` walks over `s`: +;; +;; * `(f tail? d)` is called to each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example +;; +;; * `(d->s orig-s d)` is called for each syntax object, +;; and the second argument is result of traversing its datum +;; +;; * the `s-e` function extracts content of a syntax object +;; +;; The optional `seen` argument is an `eq?`-based immutable hash table +;; to detect and reject cycles. See `datum-map`. + +(define-inline (syntax-map s f d->s s-e [seen #f]) + (let loop ([s s]) + (datum-map s + f + (lambda (tail? v) + (cond + [(syntax? v) (d->s v (loop (s-e v)))] + [else (f tail? v)])) + seen))) + +;; `(non-syntax-map s f s->)` is like `(syntax-map s f d->s)`, except that +;; when a syntax object is found, it is just passed to `s->` --- so there's +;; no `d->s` or `s-e`, since they would not be called + +(define-inline (non-syntax-map s f [s-> (lambda (x) x)] [seen #f]) + (datum-map s + f + (lambda (tail? v) + (cond + [(syntax? v) (s-> v)] + [else (f tail? v)])) + seen)) + +(define disallow-cycles + (hasheq 'cycle-fail + (lambda (s) + (raise-arguments-error 'datum->syntax + "cannot create syntax from cyclic datum" + "datum" s)))) + +;; ---------------------------------------- + +;; When serializing syntax objects, let nested objects know the +;; content of an enclosing syntax object, so sharing is enabled if the +;; nested syntax objects have the same context and source location. +(struct syntax-state ([all-sharing? #:mutable] context-triple srcloc)) + +;; When sharing syntax information in serialization, we have to be +;; careful not to lose syntax objects that wrap a pair in a `cdr` (and +;; therefore would not be restored by `datum->syntax`). +(define (no-pair-syntax-in-cdr? content) + (cond + [(pair? content) (let loop ([content (cdr content)]) + (cond + [(and (syntax? content) + (pair? (syntax-content content))) + #f] + [(pair? content) (loop (cdr content))] + [else #t]))] + [else #t])) + +;; ---------------------------------------- + +;; Called by the deserializer + +(define (deserialize-syntax content context-triple srcloc props tamper inspector) + (syntax content + (vector*-ref context-triple 0) + (vector*-ref context-triple 1) + (deserialize-tamper tamper) + (vector*-ref context-triple 2) + srcloc + (if props + (for/hasheq ([(k v) (in-immutable-hash props)]) + (values k (preserved-property-value v))) + empty-props) + inspector)) + +(define (deserialize-datum->syntax content context-triple srcloc inspector) + (define s (deserialize-syntax #f context-triple srcloc #f #f inspector)) + (datum->syntax s content s s)) diff -Nru racket-6.12+ppa1/src/expander/syntax/taint-dispatch.rkt racket-7.0+ppa1/src/expander/syntax/taint-dispatch.rkt --- racket-6.12+ppa1/src/expander/syntax/taint-dispatch.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/taint-dispatch.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,67 @@ +#lang racket/base +(require "syntax.rkt" + "property.rkt" + "to-list.rkt" + "scope.rkt" + "../namespace/core.rkt" + "original.rkt") + +;; The `taint-dispatch` function recognizes syntax properties and +;; bindings that adjust the way that a syntax object is armed. + +(provide taint-dispatch + syntax-remove-taint-dispatch-properties) + +(define (taint-dispatch s proc phase) + (let loop ([s s] [mode (syntax-taint-mode-property s)]) + (case mode + [(none) s] + [(opaque) (proc s)] + [(transparent) + (define c (non-syntax-map (or (syntax->list s) + (syntax-e s)) + (lambda (tail? d) d) + (lambda (s) (loop s (syntax-taint-mode-property s))))) + (datum->syntax #f c s (if (syntax-any-macro-scopes? s) + (syntax-property-remove s original-property-sym) + s))] + [(transparent-binding) + (define c (syntax-e s)) + (cond + [(pair? c) + (define cd (cdr c)) + (cond + [(or (pair? cd) + (and (syntax? cd) (pair? (syntax-e cd)))) + (define d (if (syntax? cd) (syntax-e cd) cd)) + (datum->syntax #f + (cons (loop (car c) (syntax-taint-mode-property (car c))) + (cons (loop (car d) 'transparent) + (non-syntax-map (or (syntax->list (cdr d)) + (cdr d)) + (lambda (tail? d) d) + (lambda (s) (loop s (syntax-taint-mode-property s)))))) + s + (if (syntax-any-macro-scopes? s) + (syntax-property-remove s original-property-sym) + s))] + [else (loop s 'transparent)])] + [else (loop s 'transparent)])] + [else + (define c (syntax-e s)) + (case (core-form-sym c phase) + [(begin begin-for-syntax #%module-begin) + (loop s 'transparent)] + [(define-values define-syntaxes) + (loop s 'transparent-binding)] + [else + (loop s 'opaque)])]))) + +;; ---------------------------------------- + +(define (syntax-taint-mode-property s) + (or (syntax-property s 'taint-mode) + (syntax-property s 'certify-mode))) + +(define (syntax-remove-taint-dispatch-properties s) + (syntax-property-remove (syntax-property-remove s 'taint-mode) 'certify-mode)) diff -Nru racket-6.12+ppa1/src/expander/syntax/taint.rkt racket-7.0+ppa1/src/expander/syntax/taint.rkt --- racket-6.12+ppa1/src/expander/syntax/taint.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/taint.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,119 @@ +#lang racket/base +(require "syntax.rkt" + "tamper.rkt" + "../common/set.rkt") + +(provide taint-content + + syntax-tainted? + syntax-clean? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint + + struct-copy/t) + +(define-syntax struct-copy/t + (syntax-rules (syntax tamper) + [(struct-copy/t syntax s [tamper v]) + (let ([stx s]) + (struct-copy syntax stx + [scope-propagations+tamper + (let ([t v] + [p (syntax-scope-propagations+tamper stx)]) + (if (tamper? p) + t + ((propagation-set-tamper-ref p) p t)))]))])) + +(define (taint-content d) + (non-syntax-map d + (lambda (tail? x) x) + (lambda (sub-s) + (cond + [(tamper-tainted? (syntax-tamper sub-s)) sub-s] + [else (struct-copy/t syntax sub-s + [tamper + (tamper-tainted-for-content (syntax-content sub-s))])])))) + +(define (syntax-tainted? s) + (tamper-tainted? (syntax-tamper s))) + +(define (syntax-clean? s) + (tamper-clean? (syntax-tamper s))) + +(define (syntax-arm s insp) + (define t (syntax-tamper s)) + (cond + [(tamper-tainted? t) s] + [(and t + (or (set-member? t insp) + (for/or ([already-insp (in-set t)]) + (inspector-superior-or-same? already-insp insp)))) + s] + [else + (struct-copy/t syntax s + [tamper (set-add + (if t + (remove-inferior t insp) + (seteq)) + insp)])])) + + +(define (remove-inferior t insp) + (for/seteq ([already-insp (in-set t)] + #:unless (inspector-superior-or-same? insp already-insp)) + already-insp)) + +(define (syntax-disarm s + [insp #f]) ; #f => superior to all inspectors + (define t (syntax-tamper s)) + (cond + [(not (tamper-armed? t)) s] + [(not insp) + (struct-copy/t syntax s + [tamper #f])] + [else + (define new-t (remove-inferior t insp)) + (struct-copy/t syntax s + [tamper (and (not (set-empty? new-t)) + new-t)])])) + +(define (syntax-rearm s from-s) + (define t (syntax-tamper s)) + (cond + [(tamper-tainted? t) s] + [else + (define from-t (syntax-tamper from-s)) + (cond + [(tamper-clean? from-t) s] + [(tamper-tainted? from-t) + (struct-copy/t syntax s + [tamper (tamper-tainted-for-content (syntax-content s))])] + [(tamper-clean? t) + (struct-copy/t syntax s + [tamper from-t])] + [else + (struct-copy/t syntax s + [tamper (for/fold ([t t]) ([from-i (in-set from-t)]) + (cond + [(set-member? t from-i) t] + [(any-superior? t from-i) t] + [else (set-add (remove-inferior t from-i) + from-i)]))])])])) + +(define (syntax-taint s) + (if (tamper-tainted? (syntax-tamper s)) + s + (struct-copy/t syntax s + [tamper (tamper-tainted-for-content (syntax-content s))]))) + +;; ---------------------------------------- + +(define (any-superior? t from-i) + (for/or ([i (in-set t)]) + (inspector-superior-or-same? i from-i))) + +(define (inspector-superior-or-same? sup-i i) + (or (eq? sup-i i) + (inspector-superior? sup-i i))) diff -Nru racket-6.12+ppa1/src/expander/syntax/tamper.rkt racket-7.0+ppa1/src/expander/syntax/tamper.rkt --- racket-6.12+ppa1/src/expander/syntax/tamper.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/tamper.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,60 @@ +#lang racket/base +(require "../common/set.rkt" + "datum-map.rkt") + +(provide tamper? + tamper-tainted? + tamper-armed? + tamper-clean? + tamper-tainted-for-content + tamper-needs-propagate? + tamper-propagated + + serialize-tamper + deserialize-tamper + current-arm-inspectors) + +;; A tamper status is either +;; * #f - clean +;; * 'tainted - tainted +;; * 'tainted/need-propagate - tainted, and taint needs to be propagated to children +;; * a set of inspectors - armed with a dye pack that is removable with those inspectors + +(define (tamper? v) + (or (not v) (symbol? v) (set? v))) + +(define (tamper-tainted? v) + (symbol? v)) + +(define (tamper-armed? v) + (set? v)) + +(define (tamper-clean? v) + (not v)) + +(define (tamper-tainted-for-content v) + (if (datum-has-elements? v) + 'tainted/need-propagate + 'tainted)) + +(define (tamper-needs-propagate? t) + (eq? t 'tainted/need-propagate)) + +(define (tamper-propagated t) + (if (eq? t 'tainted/need-propagate) + 'tainted + t)) + +;; ---------------------------------------- + +(define (serialize-tamper t) + ;; We can't serialize inspectors; any set of inspectors is replaced + ;; with the current inspector at deserialization time (which + ;; matches declaration time for a module) + (if (tamper-armed? t) 'armed t)) + +;; Set during deserialize to select a code inspector: +(define current-arm-inspectors (make-parameter (seteq))) + +(define (deserialize-tamper t) + (if (eq? t 'armed) (current-arm-inspectors) t)) diff -Nru racket-6.12+ppa1/src/expander/syntax/to-list.rkt racket-7.0+ppa1/src/expander/syntax/to-list.rkt --- racket-6.12+ppa1/src/expander/syntax/to-list.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/to-list.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,15 @@ +#lang racket/base +(require "syntax.rkt" + "scope.rkt") + +(provide syntax->list) + +(define (syntax->list s) + (define l + (let loop ([s s]) + (cond + [(pair? s) (cons (car s) (loop (cdr s)))] + [(syntax? s) (loop (syntax-e s))] + [else s]))) + (and (list? l) + l)) diff -Nru racket-6.12+ppa1/src/expander/syntax/track.rkt racket-7.0+ppa1/src/expander/syntax/track.rkt --- racket-6.12+ppa1/src/expander/syntax/track.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/expander/syntax/track.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,111 @@ +#lang racket/base +(require "syntax.rkt" + "scope.rkt" + "property.rkt" + "preserved.rkt") + +(provide syntax-track-origin + syntax-track-origin*) + +(define missing (gensym)) + +(define (syntax-track-origin new-stx old-stx [id (if (identifier? old-stx) + old-stx + (let ([v (syntax-e/no-taint old-stx)]) + (and (pair? v) + (car v))))]) + (define old-props (syntax-props old-stx)) + (cond + [(zero? (hash-count old-props)) + (if id + (syntax-property new-stx + 'origin + (cons id (hash-ref (syntax-props new-stx) 'origin null))) + new-stx)] + [else + (define new-props (syntax-props new-stx)) + (cond + [(zero? (hash-count new-props)) + (cond + [id + (define old-origin (plain-property-value + (hash-ref old-props 'origin missing))) + (define origin (if (eq? old-origin missing) + (list id) + (cons id old-origin))) + (struct-copy syntax new-stx + [props (hash-set old-props 'origin origin)])] + [else + (struct-copy syntax new-stx + [props old-props])])] + [else + ;; Merge properties + (define old-props-with-origin + (if id + (hash-set old-props 'origin (cons id (hash-ref old-props 'origin null))) + old-props)) + (define updated-props + (cond + [((hash-count old-props-with-origin) . < . (hash-count new-props)) + (for/fold ([new-props new-props]) ([(k v) (in-immutable-hash old-props-with-origin)]) + (define new-v (hash-ref new-props k missing)) + (hash-set new-props k (if (eq? new-v missing) + v + (cons/preserve new-v v))))] + [else + (for/fold ([old-props old-props-with-origin]) ([(k v) (in-immutable-hash new-props)]) + (define old-v (hash-ref old-props k missing)) + (hash-set old-props k (if (eq? old-v missing) + v + (cons/preserve v old-v))))])) + (struct-copy syntax new-stx + [props updated-props])])])) + +(define (cons/preserve a b) + (if (or (preserved-property-value? a) + (preserved-property-value? b)) + (preserved-property-value (cons (plain-property-value a) + (plain-property-value b))) + (cons a b))) + +(define (syntax-track-origin* old-stxes new-stx) + (for/fold ([new-stx new-stx]) ([old-stx (in-list old-stxes)]) + (syntax-track-origin new-stx old-stx))) + +(module+ test + (define (check-track new-props old-props expected-props-except-origin) + (define old-id (datum->syntax #f 'old)) + (define result-props (syntax-props + (syntax-track-origin + (struct-copy syntax (datum->syntax #f 'new) + [props new-props]) + (struct-copy syntax (datum->syntax #f (list old-id)) + [props old-props])))) + (unless (equal? result-props + (hash-update expected-props-except-origin 'origin + (lambda (v) + (if v + (cons (list old-id) v) + (list old-id))) + #f)) + (error "failed" new-props old-props result-props))) + + (check-track (hasheq 'a 1 'b 2) + (hasheq) + (hasheq 'a 1 'b 2)) + + (check-track (hasheq) + (hasheq 'a 3) + (hasheq 'a 3)) + + (check-track (hasheq 'a 1 'b 2) + (hasheq 'a 3) + (hasheq 'a (cons 1 3) 'b 2)) + + (check-track (hasheq 'a 3) + (hasheq 'a 1 'b 2) + (hasheq 'a (cons 3 1) 'b 2)) + + (check-track (hasheq 'a 3) + (hasheq 'a 1 'b 2) + (hasheq 'a (cons 3 1) 'b 2))) diff -Nru racket-6.12+ppa1/src/foreign/foreign.c racket-7.0+ppa1/src/foreign/foreign.c --- racket-6.12+ppa1/src/foreign/foreign.c 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/foreign/foreign.c 2018-07-27 22:12:02.000000000 +0000 @@ -1107,7 +1107,7 @@ static Scheme_Object *stdcall_sym; static Scheme_Object *sysv_sym; -static ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +static ffi_abi sym_to_abi(const char *who, Scheme_Object *sym) { if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) return FFI_DEFAULT_ABI; @@ -1539,7 +1539,7 @@ return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct)); } END_XFORM_SKIP; -#endif +#endif /* pointer to another ffi-callback for a curried callback */ /* The sync field: * NULL => non-atomic mode @@ -3481,13 +3481,18 @@ /* data := {name, c-function, itypes, otype, cif} */ { Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); const char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); - void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]); + void *c_func = (curried + ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1] + : (void*)(SCHEME_VEC_ELS(data)[1])); Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2]; Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = (curried + ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2]) + : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; #ifdef MZ_USE_PLACES @@ -3644,13 +3649,44 @@ static Scheme_Object *ffi_name = NULL; -/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ -/* the real work is done by ffi_do_call above */ -#define MYNAME "ffi-call" -static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) +static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) { - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[3], *name, *itypes, *obj, *cp; + intptr_t ooff; + int nargs; + + cp = unwrap_cpointer_property(argv[0]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv); + + name = SCHEME_VEC_ELS(data)[0]; + if (SCHEME_FFIOBJP(cp)) + name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); + + itypes = SCHEME_VEC_ELS(data)[2]; + + nargs = scheme_proper_list_length(itypes); + + a[0] = data; + a[1] = obj; + a[2] = scheme_make_integer_value(ooff); + + return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check, + 3, a, + SCHEME_BYTE_STR_VAL(name), + nargs, nargs); + +} + +static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1]; ffi_abi abi; intptr_t ooff; @@ -3664,57 +3700,63 @@ # else /* MZ_USE_PLACES undefined */ # define FFI_CALL_VEC_SIZE 8 # endif /* MZ_USE_PLACES */ - cp = unwrap_cpointer_property(argv[0]); - if (!SCHEME_FFIANYPTRP(cp)) - scheme_wrong_contract(MYNAME, "(or/c ffi-obj? cpointer?)", 0, argc, argv); - obj = SCHEME_FFIANYPTR_VAL(cp); - ooff = SCHEME_FFIANYPTR_OFFSET(cp); - if ((obj == NULL) && (ooff == 0)) - scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv); + if (!curry) { + cp = unwrap_cpointer_property(argv[ARGPOS(0)]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv); + } else { + cp = NULL; + obj = NULL; + ooff = 0; + } nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - if (argc > 4) { + abi = GET_ABI(who, ARGPOS(3)); + if (argc > ARGPOS(4)) { save_errno = -1; - if (SCHEME_FALSEP(argv[4])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[4]) - && !SCHEME_SYM_WEIRDP(argv[4])) { - if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(MYNAME, "(or/c 'posix 'windows #f)", 4, argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; # if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) - if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; # endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */ - if (argc > 6) { - if (!SCHEME_FALSEP(argv[6])) { - if (!SCHEME_CHAR_STRINGP(argv[6])) - scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } - if (SCHEME_FFIOBJP(cp)) + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else name = ffi_name; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i (in-types -> out-value) */ +/* the real work is done by ffi_do_call above */ +#define MYNAME "ffi-call" +static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) +{ + return ffi_call_or_curry(MYNAME, 0, argc, argv); +} +#undef MYNAME + +/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ +/* Curried version of `ffi-call` */ +#define MYNAME "ffi-call-maker" +static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[]) +{ + return ffi_call_or_curry(MYNAME, 1, argc, argv); } #undef MYNAME @@ -3755,11 +3823,11 @@ { void *tmp; tmp = *((void**)userdata); - data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp)); + data = (ffi_callback_struct *)SCHEME_WEAK_BOX_VAL(tmp); if (data == NULL) scheme_signal_error("callback lost"); } #else - data = (ffi_callback_struct*)userdata; + data = (ffi_callback_struct *)userdata; #endif return data; @@ -4016,15 +4084,12 @@ } #endif -/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ -/* the treatment of in-types and out-types is similar to that in ffi-call */ -/* the real work is done by ffi_do_callback above */ -#define MYNAME "ffi-callback" -static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) -{ +/* In `curry` mode, just check arguments */ +static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) ffi_callback_struct *data; - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *sync; Scheme_Object *p, *base; ffi_abi abi; @@ -4071,22 +4136,28 @@ int constant_reply_size = 0; # endif /* MZ_USE_MZRT */ - if (!SCHEME_PROCP(argv[0])) - scheme_wrong_contract(MYNAME, "procedure?", 0, argc, argv); + if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)])) + scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4])); + abi = GET_ABI(who, ARGPOS(3)); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); sync = (is_atomic ? scheme_true : NULL); - if ((argc > 5) - && !SCHEME_BOXP(argv[5]) - && !scheme_check_proc_arity2(NULL, 1, 5, argc, argv, 1)) - scheme_wrong_contract(MYNAME, "(or/c #f (procedure-arity-includes/c 0) box?)", 5, argc, argv); - if (((argc > 5) && SCHEME_TRUEP(argv[5]))) { + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + + if (curry) { + /* all checks are done */ + return NULL; + } + + if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) { # ifdef MZ_USE_MZRT if (!ffi_sync_queue) { mzrt_os_thread_id tid; @@ -4100,20 +4171,20 @@ ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - if (SCHEME_BOXP(argv[5])) { + if (SCHEME_BOXP(argv[ARGPOS(5)])) { /* when called in a foreign thread, return a constant */ constant_reply_size = ctype_sizeof(otype); - if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[5]))) { + if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) { /* void result */ constant_reply = scheme_malloc_atomic(1); } else { /* non-void result */ constant_reply = scheme_malloc_atomic(constant_reply_size); - SCHEME2C(MYNAME, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[5]), NULL, NULL, 0); + SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0); } } else { /* when called in a foreign thread, queue a reply back here */ - sync = argv[5]; + sync = argv[ARGPOS(5)]; if (is_atomic) sync = scheme_box(sync); constant_reply = NULL; constant_reply_size = 0; @@ -4131,9 +4202,9 @@ atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); for (i=0, p=itypes; iso.type = ffi_callback_tag; data->callback = (cl_cif_args); - data->proc = (argv[0]); - data->itypes = (argv[1]); - data->otype = (argv[2]); + data->proc = ((curry ? NULL : argv[ARGPOS(0)])); + data->itypes = (argv[ARGPOS(1)]); + data->otype = (argv[ARGPOS(2)]); data->sync = (sync); # ifdef MZ_PRECISE_GC { @@ -4186,7 +4257,56 @@ else # endif /* MZ_USE_MZRT */ scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); + return (Scheme_Object*)data; +#undef ARGPOS +} + +/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ +/* the treatment of in-types and out-types is similar to that in ffi-call */ +/* the real work is done by ffi_do_callback above */ +#define MYNAME "ffi-callback" +static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) +{ + return ffi_callback_or_curry(MYNAME, 0, argc, argv); +} +#undef MYNAME + +static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[6]; + int c = SCHEME_VEC_SIZE(vec), i; + + for (i = 0; i < c; i++) { + a[i+1] = SCHEME_VEC_ELS(vec)[i]; + } + a[0] = argv[0]; + + return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a); +} + +/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */ +/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything + otherwise until a function is available. */ +#define MYNAME "ffi-callback-maker" +static Scheme_Object *foreign_ffi_callback_maker(int argc, Scheme_Object *argv[]) +{ + int i; + Scheme_Object *vec, *a[1]; + + (void)ffi_callback_or_curry(MYNAME, 1, argc, argv); + + vec = scheme_make_vector(argc, NULL); + for (i = 0; i < argc; i++) { + SCHEME_VEC_ELS(vec)[i] = argv[i]; + } + a[0] = vec; + + return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried, + 1, a, + "make-ffi-callback", + 1, 1); } #undef MYNAME @@ -4638,8 +4758,6 @@ /*****************************************************************************/ /* Initialization */ -static Scheme_Env *ffi_env = NULL; - /* types need to be initialized before places can spawn * types become entries in the GC mark and fixup tables * this function should initialize read-only globals that can be @@ -4734,120 +4852,123 @@ Scheme_Object *scheme_int64_ctype; Scheme_Object *scheme_uint64_ctype; -void scheme_init_foreign(Scheme_Env *env) +void scheme_init_foreign(Scheme_Startup_Env *env) { - Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - scheme_add_global_constant("ffi-lib?", - scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv); - scheme_add_global_constant("ffi-lib", - scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), menv); - scheme_add_global_constant("ffi-lib-name", - scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv); - scheme_add_global_constant("ffi-obj?", - scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv); - scheme_add_global_constant("ffi-obj", - scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), menv); - scheme_add_global_constant("ffi-obj-lib", - scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv); - scheme_add_global_constant("ffi-obj-name", - scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv); - scheme_add_global_constant("ctype?", - scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), menv); - scheme_add_global_constant("ctype-basetype", - scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv); - scheme_add_global_constant("ctype-scheme->c", - scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv); - scheme_add_global_constant("ctype-c->scheme", - scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv); - scheme_add_global_constant("make-ctype", - scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), menv); - scheme_add_global_constant("make-cstruct-type", - scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), menv); - scheme_add_global_constant("make-array-type", - scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), menv); - scheme_add_global_constant("make-union-type", - scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), menv); - scheme_add_global_constant("ffi-callback?", - scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); - scheme_add_global_constant("cpointer?", - scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), menv); - scheme_add_global_constant("cpointer-tag", - scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv); - scheme_add_global_constant("set-cpointer-tag!", - scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv); - scheme_add_global_constant("cpointer-gcable?", - scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), menv); - scheme_add_global_constant("ctype-sizeof", - scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv); - scheme_add_global_constant("ctype-alignof", - scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv); - scheme_add_global_constant("compiler-sizeof", - scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv); - scheme_add_global_constant("malloc", - scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), menv); - scheme_add_global_constant("end-stubborn-change", - scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv); - scheme_add_global_constant("free", - scheme_make_noncm_prim(foreign_free, "free", 1, 1), menv); - scheme_add_global_constant("malloc-immobile-cell", - scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv); - scheme_add_global_constant("free-immobile-cell", - scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv); - scheme_add_global_constant("ptr-add", - scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), menv); - scheme_add_global_constant("ptr-add!", - scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv); - scheme_add_global_constant("offset-ptr?", - scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv); - scheme_add_global_constant("ptr-offset", - scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), menv); - scheme_add_global_constant("set-ptr-offset!", - scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv); - scheme_add_global_constant("vector->cpointer", - scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv); - scheme_add_global_constant("flvector->cpointer", - scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv); - scheme_add_global_constant("extflvector->cpointer", - scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), menv); - scheme_add_global_constant("memset", - scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), menv); - scheme_add_global_constant("memmove", - scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), menv); - scheme_add_global_constant("memcpy", - scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv); - scheme_add_global_constant("ptr-ref", - scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), menv); - scheme_add_global_constant("ptr-set!", - scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv); - scheme_add_global_constant("ptr-equal?", - scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv); - scheme_add_global_constant("make-sized-byte-string", - scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); - scheme_add_global_constant("ffi-call", - scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 7), menv); - scheme_add_global_constant("ffi-callback", - scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), menv); - scheme_add_global_constant("saved-errno", - scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), menv); - scheme_add_global_constant("lookup-errno", - scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), menv); - scheme_add_global_constant("make-stubborn-will-executor", - scheme_make_immed_prim(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); - scheme_add_global_constant("make-late-weak-box", - scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv); - scheme_add_global_constant("make-late-weak-hasheq", - scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), menv); + scheme_switch_prim_instance(env, "#%foreign"); + scheme_addto_prim_instance("ffi-lib?", + scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), env); + scheme_addto_prim_instance("ffi-lib", + scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), env); + scheme_addto_prim_instance("ffi-lib-name", + scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), env); + scheme_addto_prim_instance("ffi-obj?", + scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), env); + scheme_addto_prim_instance("ffi-obj", + scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), env); + scheme_addto_prim_instance("ffi-obj-lib", + scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), env); + scheme_addto_prim_instance("ffi-obj-name", + scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), env); + scheme_addto_prim_instance("ctype?", + scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), env); + scheme_addto_prim_instance("ctype-basetype", + scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), env); + scheme_addto_prim_instance("ctype-scheme->c", + scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), env); + scheme_addto_prim_instance("ctype-c->scheme", + scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), env); + scheme_addto_prim_instance("make-ctype", + scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), env); + scheme_addto_prim_instance("make-cstruct-type", + scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), env); + scheme_addto_prim_instance("make-array-type", + scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), env); + scheme_addto_prim_instance("make-union-type", + scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), env); + scheme_addto_prim_instance("ffi-callback?", + scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), env); + scheme_addto_prim_instance("cpointer?", + scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), env); + scheme_addto_prim_instance("cpointer-tag", + scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), env); + scheme_addto_prim_instance("set-cpointer-tag!", + scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), env); + scheme_addto_prim_instance("cpointer-gcable?", + scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), env); + scheme_addto_prim_instance("ctype-sizeof", + scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), env); + scheme_addto_prim_instance("ctype-alignof", + scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), env); + scheme_addto_prim_instance("compiler-sizeof", + scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env); + scheme_addto_prim_instance("malloc", + scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), env); + scheme_addto_prim_instance("end-stubborn-change", + scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), env); + scheme_addto_prim_instance("free", + scheme_make_noncm_prim(foreign_free, "free", 1, 1), env); + scheme_addto_prim_instance("malloc-immobile-cell", + scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), env); + scheme_addto_prim_instance("free-immobile-cell", + scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), env); + scheme_addto_prim_instance("ptr-add", + scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), env); + scheme_addto_prim_instance("ptr-add!", + scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), env); + scheme_addto_prim_instance("offset-ptr?", + scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), env); + scheme_addto_prim_instance("ptr-offset", + scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), env); + scheme_addto_prim_instance("set-ptr-offset!", + scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), env); + scheme_addto_prim_instance("vector->cpointer", + scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), env); + scheme_addto_prim_instance("flvector->cpointer", + scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), env); + scheme_addto_prim_instance("extflvector->cpointer", + scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), env); + scheme_addto_prim_instance("memset", + scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), env); + scheme_addto_prim_instance("memmove", + scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), env); + scheme_addto_prim_instance("memcpy", + scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), env); + scheme_addto_prim_instance("ptr-ref", + scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), env); + scheme_addto_prim_instance("ptr-set!", + scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), env); + scheme_addto_prim_instance("ptr-equal?", + scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), env); + scheme_addto_prim_instance("make-sized-byte-string", + scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env); + scheme_addto_prim_instance("ffi-call", + scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 8), env); + scheme_addto_prim_instance("ffi-call-maker", + scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 7), env); + scheme_addto_prim_instance("ffi-callback", + scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env); + scheme_addto_prim_instance("ffi-callback-maker", + scheme_make_noncm_prim(foreign_ffi_callback_maker, "ffi-callback-maker", 2, 5), env); + scheme_addto_prim_instance("saved-errno", + scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), env); + scheme_addto_prim_instance("lookup-errno", + scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), env); + scheme_addto_prim_instance("make-stubborn-will-executor", + scheme_make_immed_prim(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), env); + scheme_addto_prim_instance("make-late-weak-box", + scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), env); + scheme_addto_prim_instance("make-late-weak-hasheq", + scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), env); s = scheme_intern_symbol("void"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_void); - scheme_add_global_constant("_void", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_void", (Scheme_Object*)t, env); s = scheme_intern_symbol("int8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4856,7 +4977,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); REGISTER_SO(scheme_int8_ctype); scheme_int8_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int8", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int8", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4865,7 +4986,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8); REGISTER_SO(scheme_uint8_ctype); scheme_uint8_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint8", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint8", (Scheme_Object*)t, env); s = scheme_intern_symbol("int16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4874,7 +4995,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); REGISTER_SO(scheme_int16_ctype); scheme_int16_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int16", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4883,7 +5004,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16); REGISTER_SO(scheme_uint16_ctype); scheme_uint16_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint16", (Scheme_Object*)t, env); s = scheme_intern_symbol("int32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4892,7 +5013,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); REGISTER_SO(scheme_int32_ctype); scheme_int32_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int32", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int32", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4901,7 +5022,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32); REGISTER_SO(scheme_uint32_ctype); scheme_uint32_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint32", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint32", (Scheme_Object*)t, env); s = scheme_intern_symbol("int64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4910,7 +5031,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); REGISTER_SO(scheme_int64_ctype); scheme_int64_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int64", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int64", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4919,35 +5040,35 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64); REGISTER_SO(scheme_uint64_ctype); scheme_uint64_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint64", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint64", (Scheme_Object*)t, env); s = scheme_intern_symbol("fixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint); - scheme_add_global_constant("_fixint", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_fixint", (Scheme_Object*)t, env); s = scheme_intern_symbol("ufixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint); - scheme_add_global_constant("_ufixint", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_ufixint", (Scheme_Object*)t, env); s = scheme_intern_symbol("fixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzintptr)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum); - scheme_add_global_constant("_fixnum", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_fixnum", (Scheme_Object*)t, env); s = scheme_intern_symbol("ufixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzintptr)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum); - scheme_add_global_constant("_ufixnum", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_ufixnum", (Scheme_Object*)t, env); s = scheme_intern_symbol("float"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4956,7 +5077,7 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_float); REGISTER_SO(scheme_float_ctype); scheme_float_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_float", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_float", (Scheme_Object*)t, env); s = scheme_intern_symbol("double"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4965,70 +5086,70 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_double); REGISTER_SO(scheme_double_ctype); scheme_double_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_double", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_double", (Scheme_Object*)t, env); s = scheme_intern_symbol("longdouble"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_slongdouble)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_longdouble); - scheme_add_global_constant("_longdouble", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_longdouble", (Scheme_Object*)t, env); s = scheme_intern_symbol("double*"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS); - scheme_add_global_constant("_double*", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_double*", (Scheme_Object*)t, env); s = scheme_intern_symbol("bool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool); - scheme_add_global_constant("_bool", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_bool", (Scheme_Object*)t, env); s = scheme_intern_symbol("stdbool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_stdbool)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_stdbool); - scheme_add_global_constant("_stdbool", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_stdbool", (Scheme_Object*)t, env); s = scheme_intern_symbol("string/ucs-4"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); - scheme_add_global_constant("_string/ucs-4", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_string/ucs-4", (Scheme_Object*)t, env); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); - scheme_add_global_constant("_string/utf-16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_string/utf-16", (Scheme_Object*)t, env); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); - scheme_add_global_constant("_bytes", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_bytes", (Scheme_Object*)t, env); s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); - scheme_add_global_constant("_path", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_path", (Scheme_Object*)t, env); s = scheme_intern_symbol("symbol"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol); - scheme_add_global_constant("_symbol", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_symbol", (Scheme_Object*)t, env); s = scheme_intern_symbol("pointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -5037,45 +5158,36 @@ t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); REGISTER_SO(scheme_pointer_ctype); scheme_pointer_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_pointer", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_pointer", (Scheme_Object*)t, env); s = scheme_intern_symbol("gcpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer); - scheme_add_global_constant("_gcpointer", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_gcpointer", (Scheme_Object*)t, env); s = scheme_intern_symbol("scheme"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); - scheme_add_global_constant("_scheme", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_scheme", (Scheme_Object*)t, env); s = scheme_intern_symbol("fpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); - scheme_add_global_constant("_fpointer", (Scheme_Object*)t, menv); - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_addto_prim_instance("_fpointer", (Scheme_Object*)t, env); + scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } /*****************************************************************************/ #else /* DONT_USE_FOREIGN */ -static Scheme_Env *ffi_env = NULL; - int scheme_is_cpointer(Scheme_Object *cp) { return (SCHEME_FALSEP(cp) @@ -5110,145 +5222,141 @@ void scheme_init_foreign(Scheme_Env *env) { /* Create a dummy module. */ - Scheme_Env *menv; - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - scheme_add_global_constant("ffi-lib?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), menv); - scheme_add_global_constant("ffi-lib", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), menv); - scheme_add_global_constant("ffi-lib-name", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), menv); - scheme_add_global_constant("ffi-obj?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), menv); - scheme_add_global_constant("ffi-obj", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), menv); - scheme_add_global_constant("ffi-obj-lib", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), menv); - scheme_add_global_constant("ffi-obj-name", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), menv); - scheme_add_global_constant("ctype?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), menv); - scheme_add_global_constant("ctype-basetype", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), menv); - scheme_add_global_constant("ctype-scheme->c", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), menv); - scheme_add_global_constant("ctype-c->scheme", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), menv); - scheme_add_global_constant("make-ctype", - scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv); - scheme_add_global_constant("make-cstruct-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv); - scheme_add_global_constant("make-array-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv); - scheme_add_global_constant("make-union-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv); - scheme_add_global_constant("ffi-callback?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv); - scheme_add_global_constant("cpointer?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv); - scheme_add_global_constant("cpointer-tag", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv); - scheme_add_global_constant("set-cpointer-tag!", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv); - scheme_add_global_constant("cpointer-gcable?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv); - scheme_add_global_constant("ctype-sizeof", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv); - scheme_add_global_constant("ctype-alignof", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), menv); - scheme_add_global_constant("compiler-sizeof", - scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv); - scheme_add_global_constant("malloc", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), menv); - scheme_add_global_constant("end-stubborn-change", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), menv); - scheme_add_global_constant("free", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), menv); - scheme_add_global_constant("malloc-immobile-cell", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), menv); - scheme_add_global_constant("free-immobile-cell", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), menv); - scheme_add_global_constant("ptr-add", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), menv); - scheme_add_global_constant("ptr-add!", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), menv); - scheme_add_global_constant("offset-ptr?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), menv); - scheme_add_global_constant("ptr-offset", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), menv); - scheme_add_global_constant("set-ptr-offset!", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), menv); - scheme_add_global_constant("vector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv); - scheme_add_global_constant("flvector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv); - scheme_add_global_constant("extflvector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), menv); - scheme_add_global_constant("memset", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), menv); - scheme_add_global_constant("memmove", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), menv); - scheme_add_global_constant("memcpy", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv); - scheme_add_global_constant("ptr-ref", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv); - scheme_add_global_constant("ptr-set!", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv); - scheme_add_global_constant("ptr-equal?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv); - scheme_add_global_constant("make-sized-byte-string", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); - scheme_add_global_constant("ffi-call", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 7), menv); - scheme_add_global_constant("ffi-callback", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); - scheme_add_global_constant("saved-errno", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), menv); - scheme_add_global_constant("lookup-errno", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv); - scheme_add_global_constant("make-stubborn-will-executor", - scheme_make_immed_prim((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); - scheme_add_global_constant("make-late-weak-box", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv); - scheme_add_global_constant("make-late-weak-hasheq", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), menv); - scheme_add_global_constant("_void", scheme_false, menv); - scheme_add_global_constant("_int8", scheme_false, menv); - scheme_add_global_constant("_uint8", scheme_false, menv); - scheme_add_global_constant("_int16", scheme_false, menv); - scheme_add_global_constant("_uint16", scheme_false, menv); - scheme_add_global_constant("_int32", scheme_false, menv); - scheme_add_global_constant("_uint32", scheme_false, menv); - scheme_add_global_constant("_int64", scheme_false, menv); - scheme_add_global_constant("_uint64", scheme_false, menv); - scheme_add_global_constant("_fixint", scheme_false, menv); - scheme_add_global_constant("_ufixint", scheme_false, menv); - scheme_add_global_constant("_fixnum", scheme_false, menv); - scheme_add_global_constant("_ufixnum", scheme_false, menv); - scheme_add_global_constant("_float", scheme_false, menv); - scheme_add_global_constant("_double", scheme_false, menv); - scheme_add_global_constant("_longdouble", scheme_false, menv); - scheme_add_global_constant("_double*", scheme_false, menv); - scheme_add_global_constant("_bool", scheme_false, menv); - scheme_add_global_constant("_stdbool", scheme_false, menv); - scheme_add_global_constant("_string/ucs-4", scheme_false, menv); - scheme_add_global_constant("_string/utf-16", scheme_false, menv); - scheme_add_global_constant("_bytes", scheme_false, menv); - scheme_add_global_constant("_path", scheme_false, menv); - scheme_add_global_constant("_symbol", scheme_false, menv); - scheme_add_global_constant("_pointer", scheme_false, menv); - scheme_add_global_constant("_gcpointer", scheme_false, menv); - scheme_add_global_constant("_scheme", scheme_false, menv); - scheme_add_global_constant("_fpointer", scheme_false, menv); - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_switch_prim_instance(env, "#%foreign"); + scheme_addto_primitive_instance("ffi-lib?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), env); + scheme_addto_primitive_instance("ffi-lib", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), env); + scheme_addto_primitive_instance("ffi-lib-name", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), env); + scheme_addto_primitive_instance("ffi-obj-lib", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj-name", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), env); + scheme_addto_primitive_instance("ctype?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), env); + scheme_addto_primitive_instance("ctype-basetype", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), env); + scheme_addto_primitive_instance("ctype-scheme->c", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), env); + scheme_addto_primitive_instance("ctype-c->scheme", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), env); + scheme_addto_primitive_instance("make-ctype", + scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), env); + scheme_addto_primitive_instance("make-cstruct-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), env); + scheme_addto_primitive_instance("make-array-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), env); + scheme_addto_primitive_instance("make-union-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), env); + scheme_addto_primitive_instance("ffi-callback?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), env); + scheme_addto_primitive_instance("cpointer?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), env); + scheme_addto_primitive_instance("cpointer-tag", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), env); + scheme_addto_primitive_instance("set-cpointer-tag!", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), env); + scheme_addto_primitive_instance("cpointer-gcable?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), env); + scheme_addto_primitive_instance("ctype-sizeof", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), env); + scheme_addto_primitive_instance("ctype-alignof", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), env); + scheme_addto_primitive_instance("compiler-sizeof", + scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env); + scheme_addto_primitive_instance("malloc", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), env); + scheme_addto_primitive_instance("end-stubborn-change", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), env); + scheme_addto_primitive_instance("free", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), env); + scheme_addto_primitive_instance("malloc-immobile-cell", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), env); + scheme_addto_primitive_instance("free-immobile-cell", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), env); + scheme_addto_primitive_instance("ptr-add", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), env); + scheme_addto_primitive_instance("ptr-add!", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), env); + scheme_addto_primitive_instance("offset-ptr?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), env); + scheme_addto_primitive_instance("ptr-offset", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), env); + scheme_addto_primitive_instance("set-ptr-offset!", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), env); + scheme_addto_primitive_instance("vector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("flvector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("extflvector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("memset", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), env); + scheme_addto_primitive_instance("memmove", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), env); + scheme_addto_primitive_instance("memcpy", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), env); + scheme_addto_primitive_instance("ptr-ref", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), env); + scheme_addto_primitive_instance("ptr-set!", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), env); + scheme_addto_primitive_instance("ptr-equal?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), env); + scheme_addto_primitive_instance("make-sized-byte-string", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env); + scheme_addto_primitive_instance("ffi-call", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 8), env); + scheme_addto_primitive_instance("ffi-call-maker", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 7), env); + scheme_addto_primitive_instance("ffi-callback", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env); + scheme_addto_primitive_instance("ffi-callback-maker", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback-maker", 2, 5), env); + scheme_addto_primitive_instance("saved-errno", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), env); + scheme_addto_primitive_instance("lookup-errno", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), env); + scheme_addto_primitive_instance("make-stubborn-will-executor", + scheme_make_immed_prim((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), env); + scheme_addto_primitive_instance("make-late-weak-box", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), env); + scheme_addto_primitive_instance("make-late-weak-hasheq", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), env); + scheme_add_global_constant("_void", scheme_false, env); + scheme_add_global_constant("_int8", scheme_false, env); + scheme_add_global_constant("_uint8", scheme_false, env); + scheme_add_global_constant("_int16", scheme_false, env); + scheme_add_global_constant("_uint16", scheme_false, env); + scheme_add_global_constant("_int32", scheme_false, env); + scheme_add_global_constant("_uint32", scheme_false, env); + scheme_add_global_constant("_int64", scheme_false, env); + scheme_add_global_constant("_uint64", scheme_false, env); + scheme_add_global_constant("_fixint", scheme_false, env); + scheme_add_global_constant("_ufixint", scheme_false, env); + scheme_add_global_constant("_fixnum", scheme_false, env); + scheme_add_global_constant("_ufixnum", scheme_false, env); + scheme_add_global_constant("_float", scheme_false, env); + scheme_add_global_constant("_double", scheme_false, env); + scheme_add_global_constant("_longdouble", scheme_false, env); + scheme_add_global_constant("_double*", scheme_false, env); + scheme_add_global_constant("_bool", scheme_false, env); + scheme_add_global_constant("_stdbool", scheme_false, env); + scheme_add_global_constant("_string/ucs-4", scheme_false, env); + scheme_add_global_constant("_string/utf-16", scheme_false, env); + scheme_add_global_constant("_bytes", scheme_false, env); + scheme_add_global_constant("_path", scheme_false, env); + scheme_add_global_constant("_symbol", scheme_false, env); + scheme_add_global_constant("_pointer", scheme_false, env); + scheme_add_global_constant("_gcpointer", scheme_false, env); + scheme_add_global_constant("_scheme", scheme_false, env); + scheme_add_global_constant("_fpointer", scheme_false, env); + scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } #endif diff -Nru racket-6.12+ppa1/src/foreign/foreign.rktc racket-7.0+ppa1/src/foreign/foreign.rktc --- racket-6.12+ppa1/src/foreign/foreign.rktc 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/foreign/foreign.rktc 2018-07-27 22:12:02.000000000 +0000 @@ -936,7 +936,7 @@ @defsymbols[default stdcall sysv] -static ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +static ffi_abi sym_to_abi(const char *who, Scheme_Object *sym) { if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) return FFI_DEFAULT_ABI; @@ -1316,9 +1316,9 @@ @cdefstruct[ffi-callback [] [callback "NON_GCBALE_PTR(void)"] [proc "Scheme_Object*"] - [itypes "Scheme_Object*"] - [otype "Scheme_Object*"] - [sync "Scheme_Object*"]] + [itypes "Scheme_Object*"] ;; NULL for a curried callback + [otype "Scheme_Object*"] ;;NULL for a curried callback */ + [sync "Scheme_Object*"]] /* pointer to another ffi-callback for a curried callback */ /* The sync field: * NULL => non-atomic mode @@ -2652,13 +2652,18 @@ /* data := {name, c-function, itypes, otype, cif} */ { Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); const char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); - void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]); + void *c_func = (curried + ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1] + : (void*)(SCHEME_VEC_ELS(data)[1])); Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2]; Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = (curried + ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2]) + : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; #ifdef MZ_USE_PLACES @@ -2815,11 +2820,44 @@ static Scheme_Object *ffi_name = NULL; -/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ -/* the real work is done by ffi_do_call above */ -@cdefine[ffi-call 3 7]{ - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; +static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[3], *name, *itypes, *obj, *cp; + intptr_t ooff; + int nargs; + + cp = unwrap_cpointer_property(argv[0]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv); + + name = SCHEME_VEC_ELS(data)[0]; + if (SCHEME_FFIOBJP(cp)) + name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); + + itypes = SCHEME_VEC_ELS(data)[2]; + + nargs = scheme_proper_list_length(itypes); + + a[0] = data; + a[1] = obj; + a[2] = scheme_make_integer_value(ooff); + + return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check, + 3, a, + SCHEME_BYTE_STR_VAL(name), + nargs, nargs); + +} + +static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1]; ffi_abi abi; intptr_t ooff; @@ -2833,57 +2871,63 @@ }{ @DEFINE{FFI_CALL_VEC_SIZE 8} } - cp = unwrap_cpointer_property(argv[0]); - if (!SCHEME_FFIANYPTRP(cp)) - scheme_wrong_contract(MYNAME, "(or/c ffi-obj? cpointer?)", 0, argc, argv); - obj = SCHEME_FFIANYPTR_VAL(cp); - ooff = SCHEME_FFIANYPTR_OFFSET(cp); - if ((obj == NULL) && (ooff == 0)) - scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv); + if (!curry) { + cp = unwrap_cpointer_property(argv[ARGPOS(0)]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv); + } else { + cp = NULL; + obj = NULL; + ooff = 0; + } nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - if (argc > 4) { + abi = GET_ABI(who, ARGPOS(3)); + if (argc > ARGPOS(4)) { save_errno = -1; - if (SCHEME_FALSEP(argv[4])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[4]) - && !SCHEME_SYM_WEIRDP(argv[4])) { - if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(MYNAME, "(or/c 'posix 'windows #f)", 4, argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; @@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{ - if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; } - if (argc > 6) { - if (!SCHEME_FALSEP(argv[6])) { - if (!SCHEME_CHAR_STRINGP(argv[6])) - scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } - if (SCHEME_FFIOBJP(cp)) + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else name = ffi_name; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i (in-types -> out-value) */ +/* the real work is done by ffi_do_call above */ +@cdefine[ffi-call 3 8]{ + return ffi_call_or_curry(MYNAME, 0, argc, argv); +} + +/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ +/* Curried version of `ffi-call` */ +@cdefine[ffi-call-maker 2 7]{ + return ffi_call_or_curry(MYNAME, 1, argc, argv); } /*****************************************************************************/ @@ -2923,11 +2988,11 @@ { void *tmp; tmp = *((void**)userdata); - data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp)); + data = (ffi_callback_struct *)SCHEME_WEAK_BOX_VAL(tmp); if (data == NULL) scheme_signal_error("callback lost"); } #else - data = (ffi_callback_struct*)userdata; + data = (ffi_callback_struct *)userdata; #endif return data; @@ -3180,13 +3245,12 @@ } #endif -/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ -/* the treatment of in-types and out-types is similar to that in ffi-call */ -/* the real work is done by ffi_do_callback above */ -@cdefine[ffi-callback 3 6]{ +/* In `curry` mode, just check arguments */ +static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) ffi_callback_struct *data; - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *sync; Scheme_Object *p, *base; ffi_abi abi; @@ -3233,22 +3297,28 @@ int constant_reply_size = 0; } - if (!SCHEME_PROCP(argv[0])) - scheme_wrong_contract(MYNAME, "procedure?", 0, argc, argv); + if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)])) + scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4])); + abi = GET_ABI(who, ARGPOS(3)); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); sync = (is_atomic ? scheme_true : NULL); - if ((argc > 5) - && !SCHEME_BOXP(argv[5]) - && !scheme_check_proc_arity2(NULL, 1, 5, argc, argv, 1)) - scheme_wrong_contract(MYNAME, "(or/c #f (procedure-arity-includes/c 0) box?)", 5, argc, argv); - if (((argc > 5) && SCHEME_TRUEP(argv[5]))) { + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + + if (curry) { + /* all checks are done */ + return NULL; + } + + if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) { @@IFDEF{MZ_USE_MZRT}{ if (!ffi_sync_queue) { mzrt_os_thread_id tid; @@ -3262,20 +3332,20 @@ ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - if (SCHEME_BOXP(argv[5])) { + if (SCHEME_BOXP(argv[ARGPOS(5)])) { /* when called in a foreign thread, return a constant */ constant_reply_size = ctype_sizeof(otype); - if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[5]))) { + if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) { /* void result */ constant_reply = scheme_malloc_atomic(1); } else { /* non-void result */ constant_reply = scheme_malloc_atomic(constant_reply_size); - SCHEME2C(MYNAME, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[5]), NULL, NULL, 0); + SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0); } } else { /* when called in a foreign thread, queue a reply back here */ - sync = argv[5]; + sync = argv[ARGPOS(5)]; if (is_atomic) sync = scheme_box(sync); constant_reply = NULL; constant_reply_size = 0; @@ -3293,15 +3363,15 @@ atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); for (i=0, p=itypes; i ffi-callback */ +/* the treatment of in-types and out-types is similar to that in ffi-call */ +/* the real work is done by ffi_do_callback above */ +@cdefine[ffi-callback 3 6]{ + return ffi_callback_or_curry(MYNAME, 0, argc, argv); +} + +static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[6]; + int c = SCHEME_VEC_SIZE(vec), i; + + for (i = 0; i < c; i++) { + a[i+1] = SCHEME_VEC_ELS(vec)[i]; + } + a[0] = argv[0]; + + return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a); +} + +/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */ +/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything + otherwise until a function is available. */ +@cdefine[ffi-callback-maker 2 5]{ + int i; + Scheme_Object *vec, *a[1]; + + (void)ffi_callback_or_curry(MYNAME, 1, argc, argv); + + vec = scheme_make_vector(argc, NULL); + for (i = 0; i < argc; i++) { + SCHEME_VEC_ELS(vec)[i] = argv[i]; + } + a[0] = vec; + + return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried, + 1, a, + "make-ffi-callback", + 1, 1); } /*****************************************************************************/ @@ -3552,8 +3666,6 @@ /*****************************************************************************/ /* Initialization */ -static Scheme_Env *ffi_env = NULL; - /* types need to be initialized before places can spawn * types become entries in the GC mark and fixup tables * this function should initialize read-only globals that can be @@ -3625,18 +3737,17 @@ @list{Scheme_Object *scheme_@|exported|_ctype}) exported-types) -void scheme_init_foreign(Scheme_Env *env) +void scheme_init_foreign(Scheme_Startup_Env *env) { - Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); + scheme_switch_prim_instance(env, "#%foreign"); @(maplines (lambda (x) (define-values (sname cfun min max kind) (apply values x)) - @list{scheme_add_global_constant("@sname", - scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), menv)}) + @list{scheme_addto_prim_instance("@sname", + scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), env)}) (reverse (cfunctions))) @(map-types ;; no need for these, at least for now: @@ -3652,24 +3763,15 @@ scheme_@|stype|_ctype = (Scheme_Object *)t;} '("\n")) null)@; - scheme_add_global_constant("_@stype", (Scheme_Object*)t, menv)}) - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_addto_prim_instance("_@stype", (Scheme_Object*)t, env)}) + scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } /*****************************************************************************/ #else /* DONT_USE_FOREIGN */ -static Scheme_Env *ffi_env = NULL; - int scheme_is_cpointer(Scheme_Object *cp) { return (SCHEME_FALSEP(cp) @@ -3711,25 +3813,17 @@ void scheme_init_foreign(Scheme_Env *env) { /* Create a dummy module. */ - Scheme_Env *menv; - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); + scheme_switch_prim_instance(env, "#%foreign"); @(maplines (lambda (x) (define-values (sname cfun min max kind) (apply values x)) - @list{scheme_add_global_constant("@sname", - scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), menv)}) + @list{scheme_addto_primitive_instance("@sname", + scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), env)}) (reverse (cfunctions))) @(map-types - @list{scheme_add_global_constant("_@stype", scheme_false, menv)}) - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + @list{scheme_add_global_constant("_@stype", scheme_false, env)}) + scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } #endif diff -Nru racket-6.12+ppa1/src/gracket/gc2/Makefile.in racket-7.0+ppa1/src/gracket/gc2/Makefile.in --- racket-6.12+ppa1/src/gracket/gc2/Makefile.in 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/gracket/gc2/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -56,11 +56,13 @@ MZMMM_wx_mac = @RUN_RACKET_MMM@ MZMMM = $(MZMMM_@WXVARIANT@) -XFORM_CMD = $(MZMMM) $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../../racket/gc2/xform.rkt --setup ../../racket/gc2 +SETUP_BOOT = -O "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../../setup-go.rkt ../../compiled + +XFORM_CMD = $(MZMMM) $(SELF_RACKET_FLAGS) $(SETUP_BOOT) --tag ++out $(srcdir)/../../racket/gc2/xform-mod.rkt XFORM_CPP_ARGS = -I$(srcdir)/../../racket/gc2 $(NOGCINC) $(OPTIONS) @PREFLAGS@ $(XFORM_INC_@WXVARIANT@) -XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o -XFORMDEP = $(srcdir)/../../racket/gc2/xform.rkt $(srcdir)/../../racket/gc2/xform-mod.rkt $(srcdir)/../../racket/gc2/gc2.h +XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o ++out +XFORMDEP = $(srcdir)/../../racket/gc2/xform-mod.rkt $(srcdir)/../../racket/gc2/gc2.h GRACKETLDFLAGS = $(LDFLAGS) -L../../racket @@ -72,6 +74,7 @@ xsrc/grmain.c: $(srcdir)/../grmain.c $(XFORMDEP) $(XFORMWP) xsrc/grmain.c $(DEF_C_DIRS) $(srcdir)/../grmain.c +@INCLUDEDEP@ grmain.d GCPREINC = -include $(srcdir)/../../racket/gc2/gc2.h POSTFLAGS = $(OPTIONS) @@ -102,8 +105,8 @@ ../gracket@MMM@@NOT_OSX@@NOT_MINGW@: grmain.@LTO@ ../../racket/libracket3m.@LIBSFX@ $(LIBRKTIO_@LIBSFX@) $(GRACKETLINKER) $(GRACKETLDFLAGS) -o ../gracket@MMM@ grmain.@LTO@ ../../racket/libracket3m.@LIBSFX@ $(GRACKETMZOBJS_@LIBSFX@) $(GRACKETLIBS_@LIBSFX@) -../gracket@MMM@@MINGW@: grmain.@LTO@ ../../racket/gc2/libracket3m.dll.a ../gres.o - $(GRACKETLINKER) -mwindows $(GRACKETLDFLAGS) -o ../gracket@MMM@ grmain.@LTO@ ../gres.o ../../racket/gc2/libracket3m.dll.a $(GRACKETMZOBJS_@LIBSFX@) $(GRACKETLIBS_@LIBSFX@) -l delayimp -static-libgcc +../gracket@MMM@@MINGW@: grmain.@LTO@ ../../racket/MemoryModule.@LTO@ ../../racket/gc2/libracket3m.dll.a ../gres.o + $(GRACKETLINKER) -mwindows $(GRACKETLDFLAGS) -o ../gracket@MMM@ grmain.@LTO@ ../../racket/MemoryModule.@LTO@ ../gres.o ../../racket/gc2/libracket3m.dll.a $(GRACKETMZOBJS_@LIBSFX@) $(GRACKETLIBS_@LIBSFX@) -l delayimp -static-libgcc MZFW = ../../racket/Racket.framework/Versions/$(FWVERSION)_3m/Racket MRAPPSKEL = ../GRacket@MMM@.app/Contents/Info.plist @@ -116,7 +119,8 @@ $(GRACKETLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../racket/libracket3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o wx_file_dialog.o $(MRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../racket/src/schvers.h $(srcdir)/../../mac/icon/GRacket.icns - env BUILDBASE=../.. BUILDING_3M=yes @RUN_RACKET_MMM@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "@MMM@" + env BUILDBASE=../.. BUILDING_3M=yes @RUN_RACKET_MMM@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) $(MRAPPSKEL) mrappskel.d $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "@MMM@" +@INCLUDEDEP@ mrappskel.d ../gracket@MMM@@OSX@ : $(MAKE) ../GRacket@MMM@.app/Contents/MacOS/GRacket@MMM@ diff -Nru racket-6.12+ppa1/src/gracket/grmain.c racket-7.0+ppa1/src/gracket/grmain.c --- racket-6.12+ppa1/src/gracket/grmain.c 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/src/gracket/grmain.c 2018-07-27 22:12:02.000000000 +0000 @@ -32,8 +32,7 @@ #endif #define UNIX_INIT_FILENAME "~/.gracketrc" -#define WINDOWS_INIT_FILENAME "%%HOMEDIRVE%%\\%%HOMEPATH%%\\gracketrc.rktl" -#define MACOS9_INIT_FILENAME "PREFERENCES:gracketrc.rktl" +#define WINDOWS_INIT_FILENAME "\\gracketrc.rktl" #define INIT_FILENAME_CONF_SYM "gui-interactive-file" #define DEFAULT_INIT_MODULE "racket/gui/interactive" #define USER_INIT_MODULE "gui-interactive.rkt" @@ -637,110 +636,4 @@ #endif -/***********************************************************************/ -/* X11 flag handling */ -/***********************************************************************/ - -#ifdef wx_xt - -typedef struct { - char *flag; - int arg_count; -} X_flag_entry; - -#define SINGLE_INSTANCE "-singleInstance" - -X_flag_entry X_flags[] = { - { "-display", 1 }, - { "-geometry", 1 }, - { "-bg", 1 }, - { "-background", 1 }, - { "-fg", 1 }, - { "-foreground", 1 }, - { "-fn", 1 }, - { "-font", 1 }, - { "-iconic", 0 }, - { "-name", 1 }, - { "-rv", 0 }, - { "-reverse", 0 }, - { "+rv", 0 }, - { "-selectionTimeout", 1 }, - { "-synchronous", 0 }, - { "-title", 1 }, - { "-xnllanguage", 1 }, - { "-xrm", 1 }, - { SINGLE_INSTANCE, 0}, - { NULL, 0 } -}; - -static int filter_x_readable(char **argv, int argc) - XFORM_SKIP_PROC -{ - int pos = 1, i; - - while (pos < argc) { - for (i = 0; X_flags[i].flag; i++) { - if (!strcmp(X_flags[i].flag, argv[pos])) - break; - } - - if (!X_flags[i].flag) - return pos; - else { - int newpos = pos + X_flags[i].arg_count + 1; - if (newpos > argc) { - printf("%s: X Window System flag \"%s\" expects %d arguments, %d provided\n", - argv[0], argv[pos], X_flags[i].arg_count, argc - pos - 1); - exit(-1); - } - pos = newpos; - } - } - - return pos; -} - -static void pre_filter_cmdline_arguments(int *argc, char ***argv) - XFORM_SKIP_PROC -{ - int pos; - char **naya; - - pos = filter_x_readable(*argv, *argc); - if (pos > 1) { - scheme_register_process_global("PLT_X11_ARGUMENT_COUNT", (void *)(intptr_t)pos); - scheme_register_process_global("PLT_X11_ARGUMENTS", *argv); - naya = malloc((*argc - (pos - 1)) * sizeof(char *)); - memcpy(naya, *argv + (pos - 1), (*argc - (pos - 1)) * sizeof(char *)); - naya[0] = (*argv)[0]; - *argv = naya; - *argc -= (pos - 1); - } -} - -#endif - -/***********************************************************************/ -/* Mac OS X flag handling */ -/***********************************************************************/ - -#ifdef wx_mac - -static void pre_filter_cmdline_arguments(int *argc, char ***argv) - XFORM_SKIP_PROC -{ - if ((*argc > 1) && !strncmp((*argv)[1], "-psn_", 5)) { - /* Finder adds "-psn_" when you double-click on the application. - Drop it. */ - char **new_argv; - new_argv = (char **)malloc(((*argc) - 1) * sizeof(char *)); - new_argv[0] = (*argv)[0]; - memcpy(new_argv + 1, (*argv) + 2, ((*argc) - 2) * sizeof(char *)); - (*argc)--; - *argv = new_argv; - } - scheme_register_process_global("PLT_IS_FOREGROUND_APP", (void *)(intptr_t)0x1); -} - -#endif - +#include "../start/gui_filter.inc" diff -Nru racket-6.12+ppa1/src/gracket/Makefile.in racket-7.0+ppa1/src/gracket/Makefile.in --- racket-6.12+ppa1/src/gracket/Makefile.in 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/gracket/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -69,8 +69,8 @@ GRACKETRES@NOT_MINGW@ = GRACKETRESDEP@NOT_MINGW@ = -GRACKETRES@MINGW@ = -mwindows gres.o -GRACKETRESDEP@MINGW@ = gres.o +GRACKETRES@MINGW@ = -mwindows gres.o ../racket/MemoryModule.@LTO@ +GRACKETRESDEP@MINGW@ = gres.o ../racket/MemoryModule.@LTO@ LOCALFLAGS_wx_xt = @WX_MMD_FLAG@ LOCALFLAGS_wx_mac = -I$(srcdir)/../mac/racket -MMD -DWX_CARBON @@ -89,6 +89,8 @@ LINKRESULT_wx_mac = GRacket@CGC@.app/Contents/MacOS/GRacket@CGC@ LINKRESULT = $(LINKRESULT_@WXVARIANT@) +SETUP_BOOT = -O "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../setup-go.rkt ../compiled + # Incremented each time the binaries change: DOWNLOAD_BIN_VERSION = 1 @@ -126,7 +128,8 @@ /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)/Racket" "@executable_path/../../../../racket/Racket.framework/Versions/$(FWVERSION)/Racket" GRacket@CGC@.app/Contents/MacOS/GRacket@CGC@ $(MRAPPSKEL): $(srcdir)/../mac/osx_appl.rkt $(srcdir)/../racket/src/schvers.h $(srcdir)/../mac/icon/GRacket.icns - env BUILDBASE=.. @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../mac/osx_appl.rkt $(srcdir)/.. "@CGC@" + env BUILDBASE=.. @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) $(MRAPPSKEL) mrappskel.d $(srcdir)/../mac/osx_appl.rkt $(srcdir)/.. "@CGC@" +@INCLUDEDEP@ mrappskel.d ee-app: gracket grmain_ee.@LTO@ if [ "$(EEAPP)" = '' ] ; then echo "ERROR: You must specify EEAPP" ; else $(GRACKETLINKER) $(GRACKETLDFLAGS) $(MRSTATIC) -o $(EEAPP) grmain_ee.@LTO@ $(EEOBJECTS) $(GRACKETLDLIBS) $(MRSTATIC_STUB) ; fi diff -Nru racket-6.12+ppa1/src/io/bootstrap-main.rkt racket-7.0+ppa1/src/io/bootstrap-main.rkt --- racket-6.12+ppa1/src/io/bootstrap-main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/bootstrap-main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,5 @@ +#lang racket/base +(require "host/bootstrap.rkt" ; must be before "main.rkt" + "main.rkt") + +(provide (all-from-out "main.rkt")) diff -Nru racket-6.12+ppa1/src/io/bootstrap-thread-main.rkt racket-7.0+ppa1/src/io/bootstrap-thread-main.rkt --- racket-6.12+ppa1/src/io/bootstrap-thread-main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/bootstrap-thread-main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base +(require "host/bootstrap-thread.rkt" ; must be before "main.rkt" + "main.rkt" + "../thread/main.rkt") + +(provide (all-from-out "main.rkt") + (all-from-out "../thread/main.rkt")) diff -Nru racket-6.12+ppa1/src/io/common/bytes-no-nuls.rkt racket-7.0+ppa1/src/io/common/bytes-no-nuls.rkt --- racket-6.12+ppa1/src/io/common/bytes-no-nuls.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/common/bytes-no-nuls.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ +#lang racket/base + +(provide bytes-no-nuls?) + +(define (bytes-no-nuls? s) + (and (bytes? s) + (not (for/or ([c (in-bytes s)]) + (= c 0))))) diff -Nru racket-6.12+ppa1/src/io/common/check.rkt racket-7.0+ppa1/src/io/common/check.rkt --- racket-6.12+ppa1/src/io/common/check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/common/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +#lang racket/base +(require "../../common/check.rkt" + (for-syntax racket/base)) + +(provide (all-from-out "../../common/check.rkt") + check-range + check-immutable-field) + +(define (check-range who start-pos end-pos max-end in-value) + (when (start-pos . > . max-end) + (raise-range-error who + "byte string" + "starting " + start-pos + in-value + 0 + max-end + #f)) + (when (or (end-pos . < . start-pos) + (end-pos . > . max-end)) + (raise-range-error who + "byte string" + "starting " + end-pos + in-value + 0 + max-end + start-pos))) + +(define (check-immutable-field who v sti) + (when (exact-integer? v) + (unless (memv v (list-ref sti 5)) + (raise-arguments-error who "field index not declared immutable" + "field index" v)))) diff -Nru racket-6.12+ppa1/src/io/common/internal-error.rkt racket-7.0+ppa1/src/io/common/internal-error.rkt --- racket-6.12+ppa1/src/io/common/internal-error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/common/internal-error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide internal-error) + +(define (internal-error msg) + (raise (exn:fail (string-append "internal error: " msg) + (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/src/io/common/resource.rkt racket-7.0+ppa1/src/io/common/resource.rkt --- racket-6.12+ppa1/src/io/common/resource.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/common/resource.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,43 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt") + +(provide call-with-resource) + +;; in atomic mode +;; +;; Calls `handle` in atomic mode, but expects any escape to be out of +;; atomic mode. +;; +;; The `destroy` function is called in atomic mode only if `handle` +;; hasn't returned by the time of an escape or thread kill and only if +;; the resource `r` is not a rktio error or a boxed rktio error. So, +;; at the point where `r` is destoyed by `handle`, `handle` must +;; return still in atomic mode to ensure that `destroy` is note +;; triggered. +;; +(define (call-with-resource r destroy handle) + (cond + [(or (rktio-error? r) + (and (box? r) + (rktio-error? (unbox r)))) + (handle r)] + [else + (define completed? #f) + (define (do-destroy) + (unless completed? + (destroy r))) + (thread-push-kill-callback! do-destroy) + (dynamic-wind + void + (lambda () + (begin0 + (handle r) + (set! completed? #t))) + (lambda () + ;; In case of an escape out of the body, we + ;; may not be in atomic mode: + (start-atomic) + (thread-pop-kill-callback!) + (do-destroy) + (end-atomic)))])) diff -Nru racket-6.12+ppa1/src/io/common/set-two.rkt racket-7.0+ppa1/src/io/common/set-two.rkt --- racket-6.12+ppa1/src/io/common/set-two.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/common/set-two.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base + +(provide bytes-set-two!) + +(define big-endian? (system-big-endian?)) + +(define (bytes-set-two! out-bstr j hi lo) + (cond + [big-endian? + (bytes-set! out-bstr j hi) + (bytes-set! out-bstr (+ j 1) lo)] + [else + (bytes-set! out-bstr j lo) + (bytes-set! out-bstr (+ j 1) hi)])) diff -Nru racket-6.12+ppa1/src/io/converter/encoding.rkt racket-7.0+ppa1/src/io/converter/encoding.rkt --- racket-6.12+ppa1/src/io/converter/encoding.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/converter/encoding.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/convert.rkt" + "../locale/parameter.rkt") + +(provide encoding->bytes + locale-encoding-is-utf-8?) + +;; in atomic mode +(define (encoding->bytes who str) + (cond + [(equal? str "") + (locale-string-encoding/bytes)] + [else + (string->bytes/utf-8 str (char->integer #\?))])) diff -Nru racket-6.12+ppa1/src/io/converter/main.rkt racket-7.0+ppa1/src/io/converter/main.rkt --- racket-6.12+ppa1/src/io/converter/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/converter/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,230 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "encoding.rkt" + "utf-8.rkt") + +(provide bytes-converter? + bytes-open-converter + bytes-close-converter + bytes-convert + bytes-convert-end) + +(struct bytes-converter ([c #:mutable] + [custodian-reference #:mutable])) + +;; The "-ish" variants allow unparied surrogates and the surrogates +;; encoded in the obvious extension of UTF-8. Those variants are +;; intended for converting to and from arbitrary 16-byte sequences, +;; which is useful for encoding Windows paths. +(define windows? (eq? 'windows (system-type))) +(define platform-utf-8 (if windows? 'utf-8-ish 'utf-8)) +(define platform-utf-8-permissive (if windows? 'utf-8-ish-permissive 'utf-8-permissive)) +(define platform-utf-16 (if windows? 'utf-16-ish 'utf-16)) + +(define/who (bytes-open-converter from-str to-str) + (check who string? from-str) + (check who string? to-str) + (cond + [(and (string=? from-str "UTF-8") (string=? to-str "UTF-8")) + (bytes-converter (utf-8-converter 'utf-8 'utf-8) + #f)] + [(and (string=? from-str "UTF-8-permissive") (string=? to-str "UTF-8")) + (bytes-converter (utf-8-converter 'utf-8-permissive 'utf-8) + #f)] + [(and (string=? from-str "platform-UTF-8") (string=? to-str "platform-UTF-16")) + (bytes-converter (utf-8-converter platform-utf-8 platform-utf-16) + #f)] + [(and (string=? from-str "platform-UTF-8-permissive") (string=? to-str "platform-UTF-16")) + (bytes-converter (utf-8-converter platform-utf-8-permissive platform-utf-16) + #f)] + [(and (string=? from-str "platform-UTF-16") (string=? to-str "platform-UTF-8")) + (bytes-converter (utf-8-converter platform-utf-16 platform-utf-8) + #f)] + ;; "UTF-8-ish" is also known as "WTF-8". + ;; "UTF-16-ish" is similar to UTF-16, but allows unpaired surrogates --- which is still + ;; different from UCS-2, since paired surrogates are decoded as in UTF-16. + [(and (string=? from-str "UTF-8-ish") (string=? to-str "UTF-16-ish")) + (bytes-converter (utf-8-converter 'utf-8-ish 'utf-16-ish) + #f)] + [(and (string=? from-str "UTF-8-ish-permissive") (string=? to-str "UTF-16-ish")) + (bytes-converter (utf-8-converter 'utf-8-ish-permissive 'utf-16-ish) + #f)] + [(and (string=? from-str "UTF-16-ish") (string=? to-str "UTF-8-ish")) + (bytes-converter (utf-8-converter 'utf-16-ish 'utf-8-ish) + #f)] + [(and (or (and (string=? from-str "UTF-8") (string=? to-str "")) + (and (string=? from-str "") (string=? to-str "UTF-8"))) + (locale-encoding-is-utf-8?)) + (bytes-converter (utf-8-converter 'utf-8 'utf-8) + #f)] + [else + (define props (rktio_convert_properties rktio)) + (cond + [(zero? (bitwise-and props RKTIO_CONVERTER_SUPPORTED)) + #f] + [else + (start-atomic) + (check-current-custodian who) + (define c (rktio_converter_open rktio + (encoding->bytes who to-str) + (encoding->bytes who from-str))) + (cond + [(rktio-error? c) + (end-atomic) + #; + (raise-rktio-error who c "failed") + #f] + [else + (define converter (bytes-converter c #f)) + (define cref (unsafe-custodian-register (current-custodian) converter close-converter #f #f)) + (set-bytes-converter-custodian-reference! converter cref) + (end-atomic) + converter])])])) + +;; ---------------------------------------- + +;; in atomic mode +(define (close-converter converter) + (define c (bytes-converter-c converter)) + (when c + (cond + [(utf-8-converter? c) (void)] + [else + (rktio_converter_close rktio c) + (unsafe-custodian-unregister converter (bytes-converter-custodian-reference converter))]) + (set-bytes-converter-c! converter #f))) + +(define/who (bytes-close-converter converter) + (check who bytes-converter? converter) + (atomically + (close-converter converter))) + +;; ---------------------------------------- + +(define/who (bytes-convert converter + src-bstr + [src-start-pos 0] + [src-end-pos (and (bytes? src-bstr) (bytes-length src-bstr))] + [dest-bstr #f] + [dest-start-pos 0] + [dest-end-pos (and (bytes? dest-bstr) (bytes-length dest-bstr))]) + (check who bytes-converter? converter) + (check who bytes? src-bstr) + (check who exact-nonnegative-integer? src-start-pos) + (check who exact-nonnegative-integer? src-end-pos) + (check who #:or-false bytes? dest-bstr) + (check who exact-nonnegative-integer? dest-start-pos) + (check who #:or-false exact-nonnegative-integer? dest-end-pos) + (check-range who src-start-pos src-end-pos (bytes-length src-bstr) src-bstr) + (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (do-convert who converter + src-bstr src-start-pos src-end-pos + dest-bstr dest-start-pos dest-end-pos + (if (not dest-bstr) + ;; guess at needed length + (max 1 (- src-end-pos src-start-pos)) + 1))) + +(define/who (bytes-convert-end converter + [dest-bstr #f] + [dest-start-pos 0] + [dest-end-pos (and (bytes? dest-bstr) (bytes-length dest-bstr))]) + (check who bytes-converter? converter) + (check who #:or-false bytes? dest-bstr) + (check who exact-nonnegative-integer? dest-start-pos) + (check who #:or-false exact-nonnegative-integer? dest-end-pos) + (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (define-values (bstr used status) + (do-convert who converter + #f 0 0 + dest-bstr dest-start-pos dest-end-pos + ;; guess at needed length + 6)) + (values bstr status)) + +(define (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (cond + [dest-bstr + (define len (bytes-length dest-bstr)) + (check-range who dest-start-pos (or dest-end-pos len) len dest-bstr)] + [dest-end-pos + (unless (dest-start-pos . <= . dest-end-pos) + (raise-arguments-error who "ending index is less than the starting index" + "staring index" dest-start-pos + "ending index" dest-end-pos))])) + +;; ---------------------------------------- + +(define (do-convert who converter + src-bstr src-start-pos src-end-pos + dest-bstr dest-start-pos dest-end-pos + guess-dest-size) + (start-atomic) + (define c (bytes-converter-c converter)) + (unless c + (end-atomic) + (raise-argument-error who "converter is closed" + "converter" converter)) + (define use-dest-bstr (or dest-bstr + (make-bytes (if dest-end-pos + (- dest-end-pos dest-start-pos) + guess-dest-size)))) + ;; Loop for the case that `dest-bstr` and `dest-end-pos` are #f, + ;; since we must grow output bytes as needed to consume all input + (let loop ([use-dest-bstr use-dest-bstr] + [src-start-pos src-start-pos] + [use-dest-start-pos (if dest-bstr dest-start-pos 0)] + [use-dest-end-pos (or (and dest-bstr dest-end-pos) (bytes-length use-dest-bstr))] + [in-already-consumed 0] + [out-already-produced 0]) + ;; Call the iconv-based converter or a utf-8-based converter: + (define-values (in-consumed out-produced err) + (convert-in c + src-bstr src-start-pos src-end-pos + use-dest-bstr use-dest-start-pos use-dest-end-pos)) + (cond + [(and (eqv? err RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) + (not dest-bstr) + (not dest-end-pos)) + ;; grow the output vector and try to decode more + (define all-out-produced (+ out-produced out-already-produced)) + (define new-dest-bstr (make-bytes (* 2 (bytes-length use-dest-bstr)))) + (bytes-copy! new-dest-bstr 0 use-dest-bstr 0 all-out-produced) + (loop new-dest-bstr + (+ src-start-pos in-consumed) + all-out-produced + (bytes-length new-dest-bstr) + (+ in-consumed in-already-consumed) + all-out-produced)] + [else + ;; report results + (define all-out-produced (+ out-produced out-already-produced)) + (end-atomic) + (values (if dest-bstr + all-out-produced + (subbytes use-dest-bstr 0 all-out-produced)) + (+ in-already-consumed in-consumed) + (cond + [(eqv? err RKTIO_ERROR_CONVERT_BAD_SEQUENCE) 'error] + [(eqv? err RKTIO_ERROR_CONVERT_PREMATURE_END) 'aborts] + [(eqv? err RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) 'continues] + [else 'complete]))]))) + +;; in atomic mode +(define (convert-in c src src-start src-end dest dest-start dest-end) + (cond + [(utf-8-converter? c) + (utf-8-convert-in c src src-start src-end dest dest-start dest-end)] + [else + (define r (rktio_convert_in rktio c src src-start src-end dest dest-start dest-end)) + (define v (rktio_convert_result_to_vector r)) + (rktio_free r) + (define in-consumed (vector-ref v 0)) + (define out-produced (vector-ref v 1)) + (define converted (vector-ref v 2)) + (define err (and (= converted RKTIO_CONVERT_ERROR) + (rktio_get_last_error rktio))) + (values in-consumed out-produced err)])) diff -Nru racket-6.12+ppa1/src/io/converter/utf-8.rkt racket-7.0+ppa1/src/io/converter/utf-8.rkt --- racket-6.12+ppa1/src/io/converter/utf-8.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/converter/utf-8.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,307 @@ +#lang racket/base +(require (only-in "../host/rktio.rkt" + RKTIO_ERROR_CONVERT_BAD_SEQUENCE + RKTIO_ERROR_CONVERT_PREMATURE_END + RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) + "../string/utf-8-encode.rkt" + "../common/set-two.rkt") + +(provide utf-8-converter + utf-8-converter? + utf-8-convert-in) + +(struct utf-8-converter (from to)) + +(define big-endian? (system-big-endian?)) + +(define (utf-8-convert-in c src src-start src-end dest dest-start dest-end) + (define from (utf-8-converter-from c)) + (define to (utf-8-converter-to c)) + (define-values (in-consumed out-produced status) + (if (or (eq? from 'utf-16) + (eq? from 'utf-16-ish)) + (utf-16-ish-reencode! src src-start src-end + dest dest-start dest-end + #:from-utf-16-ish? (eq? from 'utf-16-ish)) + (utf-8-ish-reencode! src src-start src-end + dest dest-start dest-end + #:permissive? (or (eq? from 'utf-8-permissive) + (eq? from 'utf-8-ish-permissive)) + #:from-utf-8-ish? (or (eq? from 'utf-8-ish) + (eq? from 'utf-8-ish-permissive)) + #:to-utf-16? (or (eq? to 'utf-16) + (eq? to 'utf-16-ish))))) + (values in-consumed + out-produced + (case status + [(error) RKTIO_ERROR_CONVERT_BAD_SEQUENCE] + [(aborts) RKTIO_ERROR_CONVERT_PREMATURE_END] + [(continues) RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE] + [else #f]))) + +;; Similar to `utf-8-decode` in "../string/utf-8-decode.rkt", but +;; "decodes" back to a byte string either as UTF-8 or UTF-16, and also +;; supports a "utf-8-ish" encoding that allows unpaired surrogates. +;; +;; There's a lot of similarly to the implementation of `utf-8-decode`, +;; but with enough differences to make abstraction difficult. +(define (utf-8-ish-reencode! in-bstr in-start in-end + out-bstr out-start out-end + #:permissive? permissive? + #:from-utf-8-ish? from-utf-8-ish? + #:to-utf-16? to-utf-16?) + (let loop ([i in-start] [j out-start] [base-i in-start] [accum 0] [remaining 0]) + + ;; Shared handling for encoding failures: + (define (encoding-failure) + (cond + [permissive? + ;; Try to write #\uFFFD, which is #"\357\277\275" in UTF-8 + (define (continue-after-permissive next-j) + (define next-i (add1 base-i)) + (cond + [(= next-j out-end) + (values (- next-i in-start) + (- next-j out-start) + 'continues)] + [else + (loop next-i next-j next-i 0 0)])) + (cond + [(and (not to-utf-16?) ((+ j 3) . <= . out-end)) + (bytes-set! out-bstr j #o357) + (bytes-set! out-bstr (+ j 1) #o277) + (bytes-set! out-bstr (+ j 2) #o275) + (continue-after-permissive (+ j 3))] + [(and to-utf-16? ((+ j 2) . <= . out-end)) + (bytes-set-two! out-bstr j #xFF #xFD) + (continue-after-permissive (+ j 2))] + [else + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + (values (- base-i in-start) + (- j out-start) + 'error)])) + + ;; Shared handling for decoding success: + (define (continue next-j) + (define next-i (add1 i)) + (cond + [(= next-j out-end) + (values (- next-i in-start) + (- next-j out-start) + (if (= next-i in-end) + 'complete + 'continues))] + [else + (loop next-i next-j next-i 0 0)])) + + ;; Dispatch on byte: + (cond + [(= i in-end) + ;; End of input + (cond + [(zero? remaining) + (values (- base-i in-start) + (- j out-start) + 'complete)] + [else + (values (- base-i in-start) + (- j out-start) + 'aborts)])] + [else + (define b (bytes-ref in-bstr i)) + (cond + [(b . < . 128) + (cond + [(zero? remaining) + ;; Found ASCII + (cond + [(and (not to-utf-16?) + (j . < . out-end)) + (bytes-set! out-bstr j b) + (continue (add1 j))] + [((add1 j) . < . out-end) + (bytes-set-two! out-bstr j 0 b) + (continue (+ j 2))] + [else + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + ;; We were accumulating bytes for an encoding, and + ;; the encoding didn't complete + (encoding-failure)])] + [else + ;; An encoding... + (cond + [(= #b10000000 (bitwise-and b #b11000000)) + ;; A continuation byte + (cond + [(zero? remaining) + ;; We weren't continuing + (encoding-failure)] + [else + (define next (bitwise-and b #b00111111)) + (define next-accum (+ (arithmetic-shift accum 6) next)) + (cond + [(= 1 remaining) + ;; This continuation byte finishes an encoding + (define v next-accum) + (define next-i (add1 i)) + (cond + [(v . < . 128) + ;; A shorter byte sequence would work + (encoding-failure)] + [(or from-utf-8-ish? + (not (or (v . > . #x10FFFF) + (and (v . >= . #xD800) + (v . <= . #xDFFF))))) + ;; A character to write, either in UTF-16 output for UTF-8 + (cond + [to-utf-16? + ;; Write one character in UTF-16 + (cond + [(and (v . < . #x10000) + ((+ j 2) . <= . out-end)) + ;; No need for a surrogate pair (so, 2 bytes) + (bytes-set-two! out-bstr j (arithmetic-shift v -8) (bitwise-and v #xFF)) + (continue (+ j 2))] + [((+ j 4) . <= . out-end) + ;; Write surrogate pair (as 4 bytes) + (define av (- v #x10000)) + (define hi (bitwise-ior #xD800 (bitwise-and (arithmetic-shift av -10) #x3FF))) + (define lo (bitwise-ior #xDC00 (bitwise-and av #x3FF))) + (bytes-set-two! out-bstr j (arithmetic-shift hi -8) (bitwise-and hi #xFF)) + (bytes-set-two! out-bstr (+ j 2) (arithmetic-shift lo -8) (bitwise-and lo #xFF)) + (continue (+ j 4))] + [else + ;; Not enought space for UTF-16 encoding + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + ;; From UTF-8-to-UTF-8 with no "-ish" corrections, we can just copy + ;; the input encoding bytes to the output bytes + (let loop ([from-i base-i] [to-j j]) + (cond + [(= from-i next-i) + (continue to-j)] + [(= to-j out-end) + (values (- base-i in-start) + (- j out-start) + 'continues)] + [else + (bytes-set! out-bstr to-j (bytes-ref in-bstr from-i)) + (loop (add1 from-i) (add1 to-j))]))])] + [else + ;; Not a valid character --- an unpaired surrogate + ;; or too-large value in normal UTF-8 decoding (not UTF-8-ish) + (encoding-failure)])] + [(and (= 2 remaining) + (next-accum . <= . #b11111)) + ;; A shorter byte sequence would work + (encoding-failure)] + [(and (= 3 remaining) + (next-accum . <= . #b1111)) + ;; A shorter byte sequence would work + (encoding-failure)] + ;; We could check here for 3 remaining and `next-accum` + ;; >= #b100010000, which implies a result above #x10FFFF. + ;; The old decoder doesn't do that, and we'll stick to the + ;; old behavior for now + [else + ;; An encoding continues... + (loop (add1 i) j base-i next-accum (sub1 remaining))])])] + [(not (zero? remaining)) + ;; Trying to start a new encoding while one is in + ;; progress + (encoding-failure)] + [(= #b11000000 (bitwise-and b #b11100000)) + ;; Start a two-byte encoding + (define accum (bitwise-and b #b11111)) + ;; If `accum` is zero, that's an encoding mistake + (cond + [(zero? accum) (encoding-failure)] + [else (loop (add1 i) j i accum 1)])] + [(= #b11100000 (bitwise-and b #b11110000)) + ;; Start a three-byte encoding + (define accum (bitwise-and b #b1111)) + (loop (add1 i) j i accum 2)] + [(= #b11110000 (bitwise-and b #b11111000)) + ;; Start a four-byte encoding + (define accum (bitwise-and b #b111)) + (cond + [(accum . > . 4) + ;; Will be greater than #x10FFFF + (encoding-failure)] + [else + (loop (add1 i) j i accum 3)])] + [else + ;; Five- or six-byte encodings don't produce valid + ;; characters + (encoding-failure)])])]))) + +;; Converts UTF-16 into UTF-8 +(define (utf-16-ish-reencode! in-bstr in-start in-end + out-bstr out-start out-end + #:from-utf-16-ish? from-utf-16-ish?) + (let loop ([i in-start] [j out-start]) + (define (done status) + (values (- i in-start) + (- j out-start) + status)) + + (cond + [(= i in-end) + (done 'complete)] + [((+ i 2) . > . in-end) + (done 'aborts)] + [else + (define a (bytes-ref in-bstr i)) + (define b (bytes-ref in-bstr (add1 i))) + (define v (if big-endian? + (+ (arithmetic-shift a 8) b) + (+ (arithmetic-shift b 8) a))) + (define (continue v next-i) + (define (continue next-j) (loop next-i next-j)) + (utf-8-encode-dispatch v + in-start i + out-bstr out-start out-end j + continue)) + (cond + [(and (v . >= . #xD800) + (v . <= . #xDFFF)) + (cond + [(v . <= . #xDBFF) + ;; Look for surrogate pair + (cond + [((+ i 4) . > . in-end) + (done 'aborts)] + [else + (define a (bytes-ref in-bstr (+ i 2))) + (define b (bytes-ref in-bstr (+ i 3))) + (define v2 (if big-endian? + (+ (arithmetic-shift a 8) b) + (+ (arithmetic-shift b 8) a))) + (cond + [(and (v2 . >= . #xDC00) + (v2 . <= . #xDFFF)) + (define v3 (+ #x10000 + (bitwise-ior (arithmetic-shift (bitwise-and v #x3FF) 10) + (bitwise-and v2 #x3FF)))) + (continue v3 (+ i 4))] + [from-utf-16-ish? + ;; continue anyway as as unpaired surrogate + (continue v (+ i 2))] + [else + (done 'error)])])] + [else + ;; unpaired surrogate + (cond + [from-utf-16-ish? + ;; continue anyway + (continue v (+ i 2))] + [else (done 'aborts)])])] + [else (continue v (+ i 2))])]))) diff -Nru racket-6.12+ppa1/src/io/demo2.rkt racket-7.0+ppa1/src/io/demo2.rkt --- racket-6.12+ppa1/src/io/demo2.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/demo2.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,49 @@ +#lang racket/base + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (port-count-lines! p) + (let loop () + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +'read-line +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (host:open-input-file "compiled/io.rktl")) + (let loop () + (unless (eof-object? (host:read-line p)) + (loop))) + (host:close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (let loop () + (unless (eof-object? (read-line p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) diff -Nru racket-6.12+ppa1/src/io/demo.rkt racket-7.0+ppa1/src/io/demo.rkt --- racket-6.12+ppa1/src/io/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,814 @@ +#lang racket/base +(require "bootstrap-main.rkt" + (only-in racket/base + [string->bytes/utf-8 host:string->bytes/utf-8] + [bytes->string/utf-8 host:bytes->string/utf-8] + [open-input-file host:open-input-file] + [close-input-port host:close-input-port] + [read-line host:read-line] + [read-byte host:read-byte] + [file-stream-buffer-mode host:file-stream-buffer-mode] + [port-count-lines! host:port-count-lines!] + [current-directory host:current-directory] + [path->string host:path->string])) + +(current-directory (host:path->string (host:current-directory))) +(set-string->number?! string->number) + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(test #f (bytes-utf-8-ref #"\364\220\200\200" 0)) + +(test #t (file-exists? "demo.rkt")) +(test #f (file-exists? "compiled")) +(test #f (file-exists? "compiled/demo-file")) + +(test #t (directory-exists? "compiled")) +(test #f (directory-exists? "compiled/demo-dir")) + +(test #f (link-exists? "compiled")) +(test #f (link-exists? "compiled/demo-dir")) + +(call-with-output-file "compiled/demo-file" void) +(call-with-output-file "compiled/demo-file" void 'replace) +(let ([now (current-seconds)] + [f-now (file-or-directory-modify-seconds "compiled/demo-file")]) + (test #t (<= (- now 10) f-now now)) + (file-or-directory-modify-seconds "compiled/demo-file" (- now 5)) + (test (- now 5) (file-or-directory-modify-seconds "compiled/demo-file"))) +(rename-file-or-directory "compiled/demo-file" "compiled/demo-file2") +(delete-file "compiled/demo-file2") + +(test 88 (file-or-directory-modify-seconds "compiled/bad" #f (lambda () 88))) +(test 89 (file-or-directory-modify-seconds "compiled/bad" (current-seconds) (lambda () 89))) + +(test #t (and (memq 'read (file-or-directory-permissions "demo.rkt")) #t)) +(test #t (and (memq 'read (file-or-directory-permissions "compiled")) #t)) + +(printf "~s\n" (filesystem-root-list)) +(printf "~s\n" (directory-list)) +(make-directory "compiled/demo-dir") +(delete-directory "compiled/demo-dir") + +(printf "demo.rkt = ~s\n" (file-or-directory-identity "demo.rkt")) +(test (file-or-directory-identity "demo.rkt") (file-or-directory-identity "demo.rkt")) +(test #f (= (file-or-directory-identity "compiled") (file-or-directory-identity "demo.rkt"))) + +(test (call-with-input-file "demo.rkt" + (lambda (i) + (let loop ([n 0]) + (if (eof-object? (read-byte i)) + n + (loop (add1 n)))))) + (file-size "demo.rkt")) + +(copy-file "demo.rkt" "compiled/demo-copy" #t) +(test (file-size "demo.rkt") + (file-size "compiled/demo-copy")) +(test (file-or-directory-permissions "demo.rkt" 'bits) + (file-or-directory-permissions "compiled/demo-copy" 'bits)) +(delete-file "compiled/demo-copy") + +(make-file-or-directory-link "../demo.rkt" "compiled/also-demo.rkt") +(test #t (link-exists? "compiled/also-demo.rkt")) +(test (string->path "../demo.rkt") (resolve-path "compiled/also-demo.rkt")) +(delete-file "compiled/also-demo.rkt") +(test #f (link-exists? "compiled/also-demo.rkt")) + +(printf "~s\n" (expand-user-path "~/at-home")) + +(struct animal (name weight) + #:property prop:custom-write (lambda (v o mode) + (fprintf o "<~a>" (animal-name v)))) + +(test "1\n\rx0!\"hi\"" (format "1~%~ \n \rx~ ~o~c~s" 0 #\! "hi")) + +(test "*(1 2 3 apple\t\u0001 end file 1\"2\"3 #hash((a . 1) (b . 2)))*" + (format "*~a*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) ,(string->path "file") #"1\"2\"3" #hash((b . 2) (a . 1))))) +(test "*'(1 2 3 \"apple\\t\\u0001\" end #\"1\\\"2\\\"3\\t\\0010\")*" + (format "*~.v*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) #"1\"2\"3\t\0010"))) + +(fprintf (current-output-port) "*~v*" '!!!) +(newline) + +(test "no: hi 10" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s" 10))) + +(test "error: format string requires 1 arguments, given 3" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s" 1 2 3))) +(test "error: format string requires 2 arguments, given 1" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s ~s" 8))) + +(define infinite-ones + (make-input-port 'ones + (lambda (s) + (bytes-set! s 0 (char->integer #\1)) + 1) + #f + void)) + +(test 49 (read-byte infinite-ones)) +(test #\1 (read-char infinite-ones)) +(test #"11111" (read-bytes 5 infinite-ones)) +(test #"11111" (peek-bytes 5 3 infinite-ones)) +(test #"11111" (read-bytes 5 infinite-ones)) +(test "11111" (read-string 5 infinite-ones)) + +(define fancy-infinite-ones + (make-input-port 'fancy-ones + (lambda (s) + (bytes-set! s 0 (char->integer #\1)) + 1) + (lambda (s skip progress-evt) + (bytes-set! s 0 (char->integer #\1)) + 1) + (lambda () (void)) + (lambda () (make-semaphore)) + (lambda (amt evt ext-evt) (make-bytes amt (char->integer #\1))) + (lambda () (values 7 42 1024)) + (lambda () (void)) + (lambda () 99) + (case-lambda + [() 'block] + [(m) (void)]))) +(test #"11111" (read-bytes 5 fancy-infinite-ones)) +(test #t (evt? (port-progress-evt fancy-infinite-ones))) +(test #t (port-commit-peeked 5 (port-progress-evt fancy-infinite-ones) always-evt fancy-infinite-ones)) +(test '(#f #f 99) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list)) +(port-count-lines! fancy-infinite-ones) +(test '(7 42 1024) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list)) +(test 98 (file-position fancy-infinite-ones)) +(test 'block (file-stream-buffer-mode fancy-infinite-ones)) +(test (void) (file-stream-buffer-mode fancy-infinite-ones 'none)) + +(define mod3-peeked? #f) +(define mod3-cycle/one-thread + (let* ([n 2] + [mod! (lambda (s delta) + (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3))) + 1)]) + (make-input-port + 'mod3-cycle/not-thread-safe + (lambda (s) + (set! n (modulo (add1 n) 3)) + (mod! s 0)) + (lambda (s skip progress-evt) + (set! mod3-peeked? #t) + (mod! s (add1 skip))) + void))) +(test "01201" (read-string 5 mod3-cycle/one-thread)) +(test #f mod3-peeked?) +(test "01201" (peek-string 5 (expt 2 5000) mod3-cycle/one-thread)) + +(let-values ([(r w) (make-pipe)]) + (write-byte 200 w) + (test #t (byte-ready? r)) + (test #f (char-ready? r))) + +(let () + (define-values (r w) (make-pipe)) + (define ch (make-channel)) + (display "hi" w) + (peek-byte r) + (let ([t (thread (lambda () + (port-commit-peeked 1 (port-progress-evt r) ch r)))]) + (sync (system-idle-evt)) + (let ([t2 + (thread (lambda () + (port-commit-peeked 1 (port-progress-evt r) ch r)))]) + (sync (system-idle-evt)) + (test #t (thread-running? t)) + (test #t (thread-running? t2)) + (thread-suspend t2) + (break-thread t2) + (kill-thread t) + (thread-resume t2) + (sleep))) + (test (char->integer #\h) (peek-byte r))) + +(let () + (define i (open-input-bytes #"apple")) + (test (char->integer #\a) (peek-byte i)) + (define threads + (for/list ([n (in-range 100)]) + (thread (lambda () (test #f (port-commit-peeked 1 (port-progress-evt i) (make-semaphore) i)))))) + (sync (system-idle-evt)) + (test #t (andmap thread-running? threads)) + (test (char->integer #\a) (read-byte i)) + (sync (system-idle-evt)) + (test #f (andmap thread-running? threads))) + +(define accum-list '()) +(define accum-sema (make-semaphore 1)) +(define (accum-ready?) (and (sync/timeout 0 (semaphore-peek-evt accum-sema)) #t)) +(define (maybe-accum-evt) + (if (zero? (random 2)) + (wrap-evt (semaphore-peek-evt accum-sema) (lambda (v) #f)) + #f)) +(define accum-o + (make-output-port 'accum + (semaphore-peek-evt accum-sema) + (lambda (bstr start end no-buffer/block? enable-break?) + (cond + [(accum-ready?) + (set! accum-list (cons (subbytes bstr start end) accum-list)) + (- end start)] + [else + (maybe-accum-evt)])) + void + (lambda (v no-buffer/block? enable-break?) + (cond + [(accum-ready?) + (set! accum-list (cons v accum-list)) + #t] + [else + (maybe-accum-evt)])) + (lambda (bstr start end) + (wrap-evt (semaphore-peek-evt accum-sema) + (lambda (a) + (set! accum-list (cons (subbytes bstr start end) accum-list)) + (- end start)))) + (lambda (v) + (wrap-evt (semaphore-peek-evt accum-sema) + (lambda (a) + (set! accum-list (cons v accum-list)) + #t))))) + +(test 5 (write-bytes #"hello" accum-o)) +(test '(#"hello") accum-list) +(test 0 (write-bytes #"" accum-o)) +(test '(#"hello") accum-list) +(test (void) (flush-output accum-o)) +(test '(#"" #"hello") accum-list) +(test 4 (sync (write-bytes-avail-evt #"hola!!" accum-o 0 4))) +(test '(#"hola" #"" #"hello") accum-list) +(test #t (port-writes-special? accum-o)) +(test #t (write-special 'howdy accum-o)) +(test '(howdy #"hola" #"" #"hello") accum-list) + +(set! accum-list '()) +(semaphore-wait accum-sema) +(test #f (sync/timeout 0 accum-o)) +(test 0 (write-bytes-avail* #"hello" accum-o)) +(test accum-list '()) +(semaphore-post accum-sema) +(test accum-o (sync/timeout 0 accum-o)) +(test 5 (write-bytes-avail* #"hello" accum-o)) +(test accum-list '(#"hello")) + +(define specialist + (let ([special + (lambda (source line col pos) + (list 'special source line col pos))]) + (make-input-port 'ones + (lambda (s) special) + (lambda (bstr skip-k p-evt) special) + void))) +(port-count-lines! specialist) + +(test '(special #f #f #f #f) (read-byte-or-special specialist)) +(test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src)) +(test '(special #f #f #f #f) (peek-byte-or-special specialist)) +(test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src)) +(test 'special (peek-byte-or-special specialist 0 #f 'special 'src)) +(test 'special (peek-char-or-special specialist 0 'special 'src)) + +(let-values ([(i o) (make-pipe)]) + (struct my-i (i) #:property prop:input-port 0) + (struct my-o (o) #:property prop:output-port 0) + (define c-i (let ([i (my-i i)]) + (make-input-port 'c-i i i void))) + (define c-o (let ([o (my-o o)]) + (make-output-port 'c-o o o void))) + (write-bytes #"hello" c-o) + (test #"hello" (read-bytes 5 c-i))) + +(test "apλple" (bytes->string/utf-8 (string->bytes/utf-8 "!!ap\u3BBple__" #f 2) #f 0 7)) +(test "ap?ple" (bytes->string/latin-1 (string->bytes/latin-1 "ap\u3BBple" (char->integer #\?)))) +(test "apλp\uF7F8\U00101234le" (bytes->string/utf-8 (string->bytes/utf-8 "ap\u3BBp\uF7F8\U101234le"))) +(test (string (integer->char #x10400)) (bytes->string/utf-8 #"\360\220\220\200")) + +(define apple (string->bytes/utf-8 "ap\u3BBple")) +(define elppa (list->bytes (reverse (bytes->list (string->bytes/utf-8 "ap\u3BBple"))))) + +(let () + (define-values (i o) (make-pipe)) + (for ([n 3]) + (write-bytes (make-bytes 4096 (char->integer #\a)) o) + (for ([j (in-range 4096)]) + (read-byte i)) + (unless (zero? (pipe-content-length i)) + (error "pipe loop failed\n")))) + +(define p (open-input-bytes apple)) +(define-values (i o) (make-pipe)) + +(void (write-bytes #"x" o)) +(test + 256 + (let loop ([x 1] [content '(#"x")] [accum null]) + (cond + [(= x 256) x] + [(null? content) + (loop x (reverse accum) null)] + [else + (define bstr (list->bytes + (for/list ([j (in-range x)]) + (modulo j 256)))) + (write-bytes bstr o) + (write-bytes bstr o) + (unless (equal? (read-bytes (bytes-length (car content)) i) + (car content)) + (error)) + (loop (add1 x) (cdr content) (list* bstr bstr accum))]))) + + +(let () + (define path (build-path "compiled" "demo-out")) + (define o (open-output-file path 'truncate)) + ;; We expect this to be buffered: + (test 12 (write-bytes #"abcdefghijkl" o)) + (test 12 (file-position o)) + (test (void) (file-position o 6)) + (test 3 (write-bytes #"xyz" o)) + (test (void) (file-position o eof)) + (test 1 (write-bytes #"!" o)) + (close-output-port o) + + (test 13 (file-size path)) + + (define i (open-input-file path)) + (test #"abcdefxyzjkl!" (read-bytes 20 i)) + (test (void) (file-position i 0)) + (test #"abcdef" (read-bytes 6 i)) + (test (void) (file-position i 9)) + (test #"jkl!" (read-bytes 6 i)) + (close-input-port i)) + +(let () + (define in (open-input-bytes #"hello")) + (test 0 (file-position in)) + (test #"hel" (read-bytes 3 in)) + (test 3 (file-position in)) + (test (void) (file-position in 2)) + (test #"llo" (read-bytes 3 in)) + (test 5 (file-position in)) + (test eof (read-bytes 3 in)) + (test 5 (file-position in)) + (test (void) (file-position in eof)) + (test 5 (file-position in)) + (test (void) (file-position in 100)) + (test 100 (file-position in))) + +(let () + (define out (open-output-bytes)) + (test 0 (file-position out)) + (write-bytes #"hello" out) + (test 5 (file-position out)) + (test (void) (file-position out 1)) + (test 1 (file-position out)) + (write-bytes #"ola" out) + (test 4 (file-position out)) + (test #"holao" (get-output-bytes out)) + (write-bytes #"!!" out) + (test 6 (file-position out)) + (test #"hola!!" (get-output-bytes out)) + (test (void) (file-position out 10)) + (test #"hola!!\0\0\0\0" (get-output-bytes out))) + +(let () + (define-values (i o) (make-pipe)) + (port-count-lines! i) + (port-count-lines! o) + (define (next-location p) + (define-values (line col pos) (port-next-location p)) + (list line col pos)) + (test '(1 0 1) (next-location i)) + (test '(1 0 1) (next-location o)) + + (write-bytes #"a\n b" o) + (test '(2 2 5) (next-location o)) + + (test #"a" (read-bytes 1 i)) + (test '(1 1 2) (next-location i)) + (test #"\n" (read-bytes 1 i)) + (test '(2 0 3) (next-location i)) + (test #" b" (read-bytes 2 i)) + (test '(2 2 5) (next-location i)) + + (write-bytes #"x\r" o) + (test '(3 0 7) (next-location o)) + (write-bytes #"\n" o) + (test '(3 0 7) (next-location o)) + (write-bytes #"!" o) + (test '(3 1 8) (next-location o)) + + (test #"x\r" (read-bytes 2 i)) + (test '(3 0 7) (next-location i)) + (test #"\n!" (read-bytes 2 i)) + (test '(3 1 8) (next-location i))) + +;; ---------------------------------------- + +(let ([c (bytes-open-converter "latin1" "UTF-8")]) + (test '(#"A\302\200" 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + (define bstr (make-bytes 3)) + (test '(3 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 bstr)) list)) + (test #"A\302\200" bstr) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 2)) list)) + (test '(#"A\302\200" 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 1 #f 0 2)) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8" "latin1")]) + (test '(#"A\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 2)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8" "UTF-8")]) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test '(#"A" 1 error) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list)) + (test '(#"A" 1 error) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 2)) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 1)) list)) + (test '(#"\360\220\220\200" 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list)) + (test '(#"A\357\277\275" 2 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 4)) list)) + (test '(#"A\357\277\275" 2 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 5)) list)) + (test '(#"A\357\277\275" 2 continues) + (call-with-values (lambda () (bytes-convert c #"A\302x" 0 3 #f 0 4)) list)) + (test (void) (bytes-close-converter c))) + +(define (reorder little) + (if (system-big-endian?) + (let* ([len (bytes-length little)] + [bstr (make-bytes len)]) + (for ([i (in-range len)]) + (bytes-set! bstr i (bytes-ref little (bitwise-xor i 1))))) + little)) + +(let ([c (bytes-open-converter "platform-UTF-8" "platform-UTF-16")]) + (test `(,(reorder #"A\0\200\0") 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test `(,(reorder #"A\0") 1 error) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + ;; unpaired high surrogate + (test `(#"" 0 error) + (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list)) + ;; unpaired low surrogate + (test `(#"" 0 error) + (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list)) + (test `(,(reorder #"\1\330\0\334") 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8-ish" "UTF-16-ish")]) + (test `(,(reorder #"A\0\200\0") 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test `(,(reorder #"A\0") 1 error) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + ;; unpaired high surrogate + (test `(,(reorder #"\0\330") 3 complete) + (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list)) + ;; unpaired low surrogate + (test `(,(reorder #"\1\334") 3 complete) + (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list)) + ;; surrogate pair where each is separately encoded + (test `(,(reorder #"\0\330\1\334") 6 complete) + (call-with-values (lambda () (bytes-convert c #"\355\240\200\355\260\201")) list)) + (test `(,(reorder #"\1\330\0\334") 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-16-ish" "UTF-8-ish")]) + (test `(#"A\302\200" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"A\0\200\0"))) list)) + ;; unpaired high surrogate + (test `(#"" 0 aborts) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330"))) list)) + (test `(#"\355\240\200X" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330X\0"))) list)) + ;; unpaired low surrogate + (test `(#"\355\260\201" 2 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\1\334"))) list)) + (test `(#"\355\260\201X" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\1\334X\0"))) list)) + ;; surrogate pair + (test `(#"\360\220\200\201" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330\1\334"))) list)) + (test (void) (bytes-close-converter c))) + +;; ---------------------------------------- + +(parameterize ([current-locale "C"]) + (test #"A*Z" (string->bytes/locale "A\u3BBZ" 42))) + +;; Latin-1 +(parameterize ([current-locale "en_US.ISO8859-1"]) + (test #"!\xD6!" (string->bytes/locale "!\uD6!")) + (test "!\uD6!" (bytes->string/locale #"!\xD6!"))) + +(parameterize ([current-locale "en_US.UTF-8"]) + (test #f (string? "apple" "applex")) + +(test #t (string-locale? "apple\0x" "apple\0y")) + +(test #t (string-locale-ci=? "apple" "AppLE")) +(test #f (string-locale-ci=? "apple" "AppLEx")) + +(test #t (boolean? (string-localestring/utf-8 (string->bytes/utf-8 "ap\u3BBple")))) +(time + (for/fold ([v #f]) ([i (in-range 1000000)]) + (host:bytes->string/utf-8 (host:string->bytes/utf-8 "ap\u3BBple")))) + +(test "a" (read-line (open-input-string "a"))) +(test "a" (read-line (open-input-string "a\nb"))) +(test "a" (read-line (open-input-string "a\r\nb") 'any)) +(test "a" (read-line (open-input-string "a\rb") 'any)) + +(test #\l (bytes-utf-8-ref #"apple" 3)) +(test #\λ (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 2)) +(test #\p (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3)) +(test #\l (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3 #\? 1)) +(test #f (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 6)) + +(test 3 (bytes-utf-8-index #"apple" 3)) +(test 4 (bytes-utf-8-index (string->bytes/utf-8 "apλple") 3)) diff -Nru racket-6.12+ppa1/src/io/demo-thread.rkt racket-7.0+ppa1/src/io/demo-thread.rkt --- racket-6.12+ppa1/src/io/demo-thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/demo-thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,235 @@ +#lang racket/base +(require "bootstrap-thread-main.rkt" + (only-in racket/base + [current-directory host:current-directory] + [path->string host:path->string])) + +;; Don't use exceptions here; see "../thread/demo.rkt" + +(current-directory (host:path->string (host:current-directory))) + +(define done? #f) + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(call-in-main-thread + (lambda () + + ;; Make `N` threads trying to write `P` copies + ;; of each possible byte into a limited pipe, and + ;; make `N` other threads try to read those bytes. + (let () + (define N 8) + (define M (/ 256 N)) + (define P 1) + (define-values (in out) (make-pipe N)) + (test #f (byte-ready? in)) + (test out (sync/timeout #f out)) + (test N (write-bytes (make-bytes N 42) out)) + (test #t (byte-ready? in)) + (test #f (sync/timeout 0 out)) + (test 42 (read-byte in)) + (test #t (byte-ready? in)) + (test out (sync/timeout #f out)) + (write-byte 42 out) + (test #f (sync/timeout 0 out)) + (test (make-bytes N 42) (read-bytes N in)) + (test #f (byte-ready? in)) + (test out (sync/timeout #f out)) + (define vec (make-vector 256)) + (define lock-vec (for/vector ([i 256]) (make-semaphore 1))) + (define out-ths + (for/list ([i N]) + (thread (lambda () + (for ([k P]) + (for ([j M]) + (write-byte (+ j (* i M)) out))))))) + (define in-ths + (for/list ([i N]) + (thread (lambda () + (for ([k P]) + (for ([j M]) + (define v (read-byte in)) + (semaphore-wait (vector-ref lock-vec v)) + (vector-set! vec v (add1 (vector-ref vec v))) + (semaphore-post (vector-ref lock-vec v)))))))) + (map sync out-ths) + (map sync in-ths) + (for ([count (in-vector vec)]) + (unless (= count P) + (error "contended-pipe test failed")))) + + ;; Peeking effectively extends the buffer: + (let-values ([(in out) (make-pipe 3)]) + (test 3 (write-bytes-avail #"12345" out)) + (test #f (sync/timeout 0 out)) + (test #\1 (peek-char in)) + (test out (sync/timeout 0 out)) + (test 1 (write-bytes-avail #"12345" out)) + (test #f (sync/timeout 0 out)) + (test #\1 (peek-char in)) + (test 0 (write-bytes-avail* #"12345" out)) + (test #\2 (peek-char in 1)) + (test 1 (write-bytes-avail* #"12345" out)) + (let ([s (make-bytes 6 (char->integer #\-))]) + (test 5 (read-bytes-avail! s in)) + (test #"12311-" s)) + (test 3 (let loop ([n 0]) + (define v (write-bytes-avail* #"1234" out)) + (if (zero? v) + n + (loop (+ n v)))))) + + ;; Further test of peeking in a limited pipe (shouldn't get stuck): + (let-values ([(i o) (make-pipe 50)] + [(s) (make-semaphore)]) + (define t + (thread (lambda () + (peek-bytes 100 0 i) + (semaphore-wait s) + (peek-bytes 200 0 i)))) + (display (make-bytes 100 65) o) + (sync (system-idle-evt)) + (semaphore-post s) + (display (make-bytes 100 66) o) + (sync t)) + + ;; Check progress events + (define (check-progress-on-port make-in) + (define (check-progress dest-evt fail-dest-evt) + (define in (make-in)) ; content = #"hello" + (test #"he" (peek-bytes 2 0 in)) + (test #"hello" (peek-bytes 5 0 in)) + (test #"hel" (peek-bytes 3 0 in)) + (define progress1 (port-progress-evt in)) + ;(test #t (evt? progress1)) + (test #f (sync/timeout 0 progress1)) + (test #"hel" (peek-bytes 3 0 in)) + (test #f (sync/timeout 0 progress1)) + (test #f (port-commit-peeked 3 progress1 fail-dest-evt in)) + (test #"hel" (peek-bytes 3 0 in)) + (test #f (sync/timeout 0 progress1)) + (test #t (port-commit-peeked 3 progress1 dest-evt in)) + (test #"lo" (peek-bytes 2 0 in)) + (test progress1 (sync/timeout #f progress1)) + (test #f (port-commit-peeked 1 progress1 always-evt in)) + (close-input-port in)) + (check-progress always-evt never-evt) + (check-progress (make-semaphore 1) (make-semaphore 0)) + (check-progress (semaphore-peek-evt (make-semaphore 1)) (semaphore-peek-evt (make-semaphore 0))) + (let () + (define ch1 (make-channel)) + (define ch2 (make-channel)) + (thread (lambda () (channel-put ch1 'ok))) + (thread (lambda () (channel-get ch2))) + (sync (system-idle-evt)) + (check-progress ch1 ch2) + (check-progress (channel-put-evt ch2 'ok) (channel-put-evt ch1 'ok)))) + (check-progress-on-port + (lambda () + (define-values (in out) (make-pipe)) + (write-bytes #"hello" out) + in)) + (check-progress-on-port + (lambda () + (open-input-bytes #"hello"))) + (call-with-output-file "compiled/hello.txt" + (lambda (o) (write-bytes #"hello" o)) + 'truncate) + (check-progress-on-port + (lambda () + (open-input-file "compiled/hello.txt"))) + + (define (check-out-evt make-out [block #f] [unblock #f]) + (define o (make-out)) + (test #t (port-writes-atomic? o)) + (define evt (write-bytes-avail-evt #"hello" o)) + (test 5 (sync evt)) + (when block + (block o) + (define evt (write-bytes-avail-evt #"hello" o)) + (test #f (sync/timeout 0 evt)) + (test #f (sync/timeout 0.1 evt)) + (unblock) + (test #t (and (memq (sync evt) '(1 2 3 4 5)) #t))) + (close-output-port o)) + (let ([i #f]) + (check-out-evt (lambda () + (define-values (in out) (make-pipe 10)) + (set! i in) + out) + (lambda (o) + (write-bytes #"01234" o)) + (lambda () + (read-bytes 6 i)))) + (check-out-evt (lambda () + (open-output-bytes))) + (check-out-evt (lambda () + (open-output-file "compiled/hello.txt" 'truncate))) + + ;; Custodian shutdown closes port => don't run out of file descriptors + (for ([i 512]) + (define c (make-custodian)) + (parameterize ([current-custodian c]) + (for ([j 10]) + (open-input-file "compiled/hello.txt"))) + (custodian-shutdown-all c)) + + ;; TCP and accept evts + (parameterize ([current-custodian (make-custodian)]) + (define l (tcp-listen 59078 5 #t)) + (test #t (tcp-listener? l)) + + (define acc-evt (tcp-accept-evt l)) + (test #f (sync/timeout 0 acc-evt)) + + (define-values (ti to) (tcp-connect "localhost" 59078)) + + (define-values (tai tao) (apply values (sync acc-evt))) + + (test 6 (write-string "hello\n" to)) + (flush-output to) + (test "hello" (read-line tai)) + + (custodian-shutdown-all (current-custodian))) + + ;; UDP and evts + (define u1 (udp-open-socket)) + (test (void) (udp-bind! u1 #f 10768)) + + (define u2 (udp-open-socket)) + + (define bstr (make-bytes 10)) + (define r1-evt (udp-receive!-evt u1 bstr)) + + (test #f (sync/timeout 0 r1-evt)) + + (test (void) (sync (udp-send-to-evt u2 "localhost" 10768 #"hello"))) + + (let ([l (sync r1-evt)]) + (test 5 (car l)) + (test #"hello" (subbytes bstr 0 5))) + + (test #f (sync/timeout 0 r1-evt)) + (udp-close u1) + (udp-close u2) + + ;; Check some expected errors: + (printf "[two expected errors coming up...]\n") + (sync (thread (lambda () (sync r1-evt)))) + (sync (thread (lambda () (sync (udp-send-to-evt u2 "localhost" 10768 #""))))) + (printf "[two error messages about a UDP socket being closed were expected]\n") + + ;; ---------------------------------------- + + (printf "Enter to continue after confirming process sleeps...\n") + (read-line) + + (set! done? #t))) + +(unless done? + (error "main thread stopped running due to deadlock?")) diff -Nru racket-6.12+ppa1/src/io/envvar/main.rkt racket-7.0+ppa1/src/io/envvar/main.rkt --- racket-6.12+ppa1/src/io/envvar/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/envvar/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,125 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "../host/error.rkt" + "string.rkt") + +(provide environment-variables? + make-environment-variables + environment-variables-ref + current-environment-variables + environment-variables-set! + environment-variables-copy + environment-variables-names) + +(struct environment-variables ([ht #:mutable]) ; #f => use OS-level environment variables + #:authentic) + +(define/who current-environment-variables + (make-parameter (environment-variables #f) + (lambda (v) + (check who environment-variables? v) + v))) + +(define/who (make-environment-variables . args) + (let loop ([args args] [ht #hash()]) + (cond + [(null? args) (environment-variables ht)] + [else + (define key0 (car args)) + (define key (if (bytes? key0) + (bytes->immutable-bytes key0) + key0)) + (check who bytes-environment-variable-name? key) + (cond + [(null? args) + (raise-arguments-error who + "key does not have a value (i.e., an odd number of arguments were provided)" + "key" (car args))] + [else + (define val0 (cadr args)) + (define val (and (bytes? val0) + (bytes->immutable-bytes val0) + val0)) + (check who bytes-no-nuls? val) + (loop (cddr args) (hash-set ht (normalize-key key) val))])]))) + +(define/who (environment-variables-ref e k) + (check who environment-variables? e) + (check who bytes-environment-variable-name? k) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (start-atomic) + (define v (rktio_getenv rktio k)) + (define s (and (not (rktio-error? v)) + (begin0 + (rktio_to_bytes v) + (rktio_free v)))) + (end-atomic) + s] + [else + (hash-ref ht (normalize-key k) #f)])) + +(define none (gensym 'none)) + +(define/who (environment-variables-set! e k0 v0 [fail none]) + (check who environment-variables? e) + (define k (if (bytes? k0) (bytes->immutable-bytes k0) k0)) + (check who bytes-environment-variable-name? k) + (define v (if (bytes? v0) (bytes->immutable-bytes v0) v0)) + (check who bytes-no-nuls? #:or-false v) + (unless (eq? fail none) + (check who (procedure-arity-includes/c 0) fail)) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (define r (rktio_setenv rktio k v)) + (when (rktio-error? r) + (cond + [(eq? fail none) + (raise-rktio-error who r "change failed")] + [else (fail)]))] + [else + (define nk (normalize-key k)) + (set-environment-variables-ht! e (if v (hash-set ht nk v) (hash-remove ht nk)))])) + +(define/who (environment-variables-copy e) + (check who environment-variables? e) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + ;; Make a copy of current OS-level environment variables + (start-atomic) + (define ev (rktio_envvars rktio)) + (define ht + (cond + [(rktio-error? ev) #hash()] + [else + (begin0 + (for/hash ([i (in-range (rktio_envvars_count rktio ev))]) + (define k (rktio_envvars_name_ref rktio ev i)) + (define v (rktio_envvars_value_ref rktio ev i)) + (values + (begin0 + (bytes->immutable-bytes (rktio_to_bytes k)) + (rktio_free k)) + (begin0 + (bytes->immutable-bytes (rktio_to_bytes v)) + (rktio_free v)))) + (rktio_envvars_free rktio ev))])) + (end-atomic) + (environment-variables ht)] + [else + ;; Copy wrapper around immutable `ht`: + (environment-variables ht)])) + +(define/who (environment-variables-names e) + (check who environment-variables? e) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (environment-variables-names (environment-variables-copy e))] + [else + (hash-keys ht)])) diff -Nru racket-6.12+ppa1/src/io/envvar/string.rkt racket-7.0+ppa1/src/io/envvar/string.rkt --- racket-6.12+ppa1/src/io/envvar/string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/envvar/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +#lang racket/base +(require "../common/bytes-no-nuls.rkt" + "../host/rktio.rkt") + +(provide bytes-no-nuls? + bytes-environment-variable-name? + normalize-key) + +(define (bytes-environment-variable-name? k) + (and (bytes-no-nuls? k) + (rktio_is_ok_envvar_name rktio k))) + +(define (normalize-key k) + (if (rktio_are_envvar_names_case_insensitive rktio) + (string->immutable-string (string-foldcase k)) + k)) diff -Nru racket-6.12+ppa1/src/io/error/main.rkt racket-7.0+ppa1/src/io/error/main.rkt --- racket-6.12+ppa1/src/io/error/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/error/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,63 @@ +#lang racket/base +(require "../port/string-port.rkt" + (submod "../print/main.rkt" internal) + "../format/printf.rkt") + +(provide error + raise-user-error + error-print-source-location) + +(define (error init . args) + (do-error 'error exn:fail init args)) + +(define (raise-user-error init . args) + (do-error 'raise-user-error exn:fail:user init args)) + +(define (do-error who exn:fail init args) + (cond + [(and (symbol? init) + (null? args)) + (raise + (exn:fail + (format "error: ~a" init) + (current-continuation-marks)))] + [(symbol? init) + (unless (string? (car args)) + (raise-argument-error who "string?" (car args))) + (define o (open-output-string)) + (do-printf who o (car args) (cdr args)) + (raise + (exn:fail + (string-append (symbol->string init) + ": " + (get-output-string o)) + (current-continuation-marks)))] + [(string? init) + (raise + (exn:fail + (apply string-append + init + (for/list ([arg (in-list args)]) + (string-append " " + ((error-value->string-handler) + arg + (error-print-width))))) + (current-continuation-marks)))] + [else + (raise-argument-error who "(or/c symbol? string?)" init)])) + +(define error-print-source-location + (make-parameter #t (lambda (v) (and v #t)))) + +;; Install the default error-value->string handler, +;; replacing the non-working primitive placeholder +(void + (error-value->string-handler + (lambda (v len) + (unless (exact-nonnegative-integer? len) + (raise-argument-error 'default-error-value->string-handler + "exact-nonnegative-integer?" + len)) + (define o (open-output-string)) + (do-global-print 'default-error-value->string-handler v o 0 len) + (get-output-string o)))) diff -Nru racket-6.12+ppa1/src/io/file/error.rkt racket-7.0+ppa1/src/io/file/error.rkt --- racket-6.12+ppa1/src/io/file/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/file/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,72 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt") + +(provide raise-filesystem-error + copy-file-step-string + + maybe-raise-missing-module + set-maybe-raise-missing-module!) + +(define (raise-filesystem-error who orig-err base-msg) + (define err (cond + [(racket-error? orig-err RKTIO_ERROR_EXISTS) + orig-err] + [else + (remap-rktio-error orig-err)])) + (define msg (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + ;; don't add "system error", because it + ;; will be redundant + (if who + (string-append (symbol->string who) ": " base-msg) + base-msg)] + [else + (format-rktio-message who err base-msg)])) + (raise + (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + (exn:fail:filesystem:exists + msg + (current-continuation-marks))] + [(not (eq? (rktio-errkind err) RKTIO_ERROR_KIND_RACKET)) + (exn:fail:filesystem:errno + msg + (current-continuation-marks) + (cons (rktio-errno err) + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) 'posix] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) 'windows] + [(eqv? kind RKTIO_ERROR_KIND_GAI) 'gai] + [else (error 'raise-filesystem-error "confused about rktio error")]))))] + [else + (exn:fail:filesystem + msg + (current-continuation-marks))]))) + +(define (copy-file-step-string err) + (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + "destination exists"] + [else + (define step (vector-ref err 2)) + (cond + [(eqv? step RKTIO_COPY_STEP_OPEN_SRC) + "cannot open source file"] + [(eqv? step RKTIO_COPY_STEP_OPEN_DEST) + "cannot open destination file"] + [(eqv? step RKTIO_COPY_STEP_READ_SRC_DATA) + "error reading source file"] + [(eqv? step RKTIO_COPY_STEP_WRITE_DEST_DATA) + "error writing destination file"] + [(eqv? step RKTIO_COPY_STEP_READ_SRC_METADATA) + "error reading source-file metadata"] + [(eqv? step RKTIO_COPY_STEP_WRITE_DEST_METADATA) + "error writing destination-file metadata"] + [else "copy failed"])])) + +(define maybe-raise-missing-module void) + +(define (set-maybe-raise-missing-module! proc) + (set! maybe-raise-missing-module proc)) diff -Nru racket-6.12+ppa1/src/io/file/host.rkt racket-7.0+ppa1/src/io/file/host.rkt --- racket-6.12+ppa1/src/io/file/host.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/file/host.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base +(require "../path/path.rkt" + "../path/complete.rkt" + "../path/parameter.rkt" + "../path/cleanse.rkt" + "../host/rktio.rkt" + "../security/main.rkt") + +(provide ->host + ->host/as-is + host->) + +;; Note: `(host-> (->host x who flags))` is not the same as `x`, since +;; it normalizes `x`. That's why `(host-> (->host x))` is generally +;; used in error reporting. + +(define (->host p who guards) + (let ([p (->path p)]) + (when who + (security-guard-check-file who p guards)) + (path-bytes (cleanse-path (path->complete-path p (current-directory)))))) + +(define (->host/as-is p who src) + (let ([p (->path p)]) + (when who + (if src + (security-guard-check-file-link who src p) + (security-guard-check-file who p '(exists)))) + (path-bytes p))) + +(define (host-> s) + (path (bytes->immutable-bytes s) + (system-path-convention-type))) diff -Nru racket-6.12+ppa1/src/io/file/identity.rkt racket-7.0+ppa1/src/io/file/identity.rkt --- racket-6.12+ppa1/src/io/file/identity.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/file/identity.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "host.rkt" + "error.rkt") + +(provide path-or-fd-identity) + +;; In atomic mode; returns out of atomic mode +(define (path-or-fd-identity who + #:host-path [host-path #f] + #:as-link? [as-link? #f] ; used only if `host-path` + #:fd [fd #f] + #:port [port #f]) ; for errors, and non-#f if `fd` provided + (define r0 (if host-path + (rktio_path_identity rktio host-path (not as-link?)) + (rktio_fd_identity rktio fd))) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_identity_to_vector r0) + (rktio_free r0)))) + (end-atomic) + (when (rktio-error? r0) + (raise-filesystem-error who + r + (if host-path + (format (string-append + "error obtaining identity for path\n" + " path: ~a") + (host-> host-path)) + (format (string-append + "error obtaining identity for port\n" + " port: ~v") + port)))) + (+ (vector-ref r 0) + (arithmetic-shift (vector-ref r 1) + (vector-ref r 3)) + (arithmetic-shift (vector-ref r 2) + (+ (vector-ref r 3) (vector-ref r 4))))) diff -Nru racket-6.12+ppa1/src/io/file/main.rkt racket-7.0+ppa1/src/io/file/main.rkt --- racket-6.12+ppa1/src/io/file/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/file/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,390 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/resource.rkt" + "../path/path.rkt" + "../path/parameter.rkt" + "../path/directory-path.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "../host/error.rkt" + "../format/main.rkt" + "../security/main.rkt" + "parameter.rkt" + "host.rkt" + "identity.rkt" + "error.rkt" + (only-in "error.rkt" + set-maybe-raise-missing-module!)) + +(provide directory-exists? + file-exists? + link-exists? + make-directory + directory-list + current-force-delete-permissions + delete-file + delete-directory + rename-file-or-directory + file-or-directory-modify-seconds + file-or-directory-permissions + file-or-directory-identity + file-size + copy-file + make-file-or-directory-link + resolve-path + expand-user-path + filesystem-root-list + + ;; For the expander to register `maybe-raise-missing-module`: + set-maybe-raise-missing-module!) + +(define/who (directory-exists? p) + (check who path-string? p) + (rktio_directory_exists rktio (->host p who '(exists)))) + +(define/who (file-exists? p) + (check who path-string? p) + (rktio_file_exists rktio (->host p who '(exists)))) + +(define/who (link-exists? p) + (check who path-string? p) + (rktio_link_exists rktio (->host p who '(exists)))) + +(define/who (make-directory p) + (check who path-string? p) + (define host-path (->host p who '(write))) + (define r (rktio_make_directory rktio host-path)) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot make directory~a\n" + " path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the path already exists" + "") + (host-> host-path))))) + +(define/who (directory-list [p (current-directory)]) + (check who path-string? p) + (define host-path (->host p who '(read))) + (atomically + (call-with-resource + (rktio_directory_list_start rktio host-path) + ;; in atomic mode + (lambda (dl) (rktio_directory_list_stop rktio dl)) + ;; in atomic mode + (lambda (dl) + (cond + [(rktio-error? dl) + (end-atomic) + (raise-filesystem-error who + dl + (format (string-append + "could not open directory\n" + " path: ~a") + (host-> host-path)))] + [else + (end-atomic) + (let loop ([accum null]) + (start-atomic) + (define fnp (rktio_directory_list_step rktio dl)) + (define fn (if (rktio-error? fnp) + fnp + (rktio_to_bytes fnp))) + (cond + [(rktio-error? fn) + (end-atomic) + (check-rktio-error fn "error reading directory")] + [(equal? fn #"") + ;; `dl` is no longer valid; need to return still in + ;; atomic mode, so that `dl` is not destroyed again + accum] + [else + (rktio_free fnp) + (end-atomic) + (loop (cons (host-> fn) accum))]))]))))) + +(define/who (delete-file p) + (check who path-string? p) + (define host-path (->host p who '(delete))) + (define r (rktio_delete_file rktio + host-path + (current-force-delete-permissions))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot delete file\n" + " path: ~a") + (host-> host-path))))) + +(define/who (delete-directory p) + (check who path-string? p) + (define host-path (->host p who '(delete))) + (define r (rktio_delete_directory rktio + host-path + (->host (current-directory) #f #f) + (current-force-delete-permissions))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot delete directory\n" + " path: ~a") + (host-> host-path))))) + +(define/who (rename-file-or-directory old new [exists-ok? #f]) + (check who path-string? old) + (check who path-string? new) + (define host-old (->host old who '(read))) + (define host-new (->host new who '(write))) + (define r (rktio_rename_file rktio host-new host-old exists-ok?)) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot rename file or directory~a\n" + " source path: ~a\n" + " dest path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the destination path already exists" + "") + (host-> host-old) + (host-> host-new))))) + +(define/who file-or-directory-modify-seconds + (case-lambda + [(p) + (check who path-string? p) + (do-file-or-directory-modify-seconds who p #f #f)] + [(p secs) + (check who path-string? p) + (check who exact-integer? secs) + (do-file-or-directory-modify-seconds who p secs #f)] + [(p secs fail) + (check who path-string? p) + (check who #:or-false exact-integer? secs) + (check who (procedure-arity-includes/c 0) fail) + (do-file-or-directory-modify-seconds who p secs fail)])) + +(define (do-file-or-directory-modify-seconds who p secs fail) + (when secs + (unless (rktio_is_timestamp secs) + (raise-arguments-error who + "integer value is out-of-range" + "value" secs))) + (define host-path (->host p who (if secs '(write) '(read)))) + (start-atomic) + (define r0 (if secs + (rktio_set_file_modify_seconds rktio host-path secs) + (rktio_get_file_modify_seconds rktio host-path))) + (define r (if (and (not secs) (not (rktio-error? r0))) + (rktio_timestamp_ref r0) + r0)) + (end-atomic) + (cond + [(rktio-error? r) + (if fail + (fail) + (raise-filesystem-error who + r + (format (string-append + "error ~a file/directory time\n" + " path: ~a") + (if secs "setting" "getting") + (host-> host-path))))] + [else r])) + +(define/who (file-or-directory-permissions p [mode #f]) + (check who path-string? p) + (check who (lambda (m) + (or (not m) + (eq? m 'bits) + (and (exact-integer? m) + (<= 0 m 65535)))) + #:contract "(or/c #f 'bits (integer-in 0 65535))" + mode) + (define host-path (->host p who (if (integer? mode) '(write) '(read)))) + (define r + (if (integer? mode) + (rktio_set_file_or_directory_permissions rktio host-path mode) + (rktio_get_file_or_directory_permissions rktio host-path (eq? mode 'bits)))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "~a failed~a\n" + " path: ~a~a") + (if (integer? mode) "update" "access") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n unsupported bit combination" + "") + (host-> host-path) + (if (racket-error? r RKTIO_ERROR_EXISTS) + (format "\n permission value: ~a" mode) + "")))) + (cond + [(integer? mode) (void)] + [(eq? 'bits mode) r] + [else + (define (set? n) (eqv? n (bitwise-and r n))) + (let* ([l '()] + [l (if (set? RKTIO_PERMISSION_READ) + (cons 'read l) + l)] + [l (if (set? RKTIO_PERMISSION_WRITE) + (cons 'write l) + l)] + [l (if (set? RKTIO_PERMISSION_EXEC) + (cons 'execute l) + l)]) + l)])) + +(define/who (file-or-directory-identity p [as-link? #f]) + (check who path-string? p) + (define host-path (->host p who '(exists))) + (start-atomic) + (path-or-fd-identity who #:host-path host-path #:as-link? as-link?)) + +(define/who (file-size p) + (check who path-string? p) + (define host-path (->host p who '(read))) + (start-atomic) + (define r0 (rktio_file_size rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_filesize_ref r0) + (rktio_free r0)))) + (end-atomic) + (cond + [(rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot get size\n" + " path: ~a") + (host-> host-path)))] + [else r])) + +(define/who (copy-file src dest [exists-ok? #f]) + (check who path-string? src) + (check who path-string? dest) + (define src-host (->host src who '(read))) + (define dest-host (->host dest who '(write delete))) + (define (report-error r) + (raise-filesystem-error who + r + (format (string-append + "~a\n" + " source path: ~a\n" + " destination path: ~a") + (copy-file-step-string r) + (host-> src-host) + (host-> dest-host)))) + (start-atomic) + (let ([cp (rktio_copy_file_start rktio dest-host src-host exists-ok?)]) + (cond + [(rktio-error? cp) + (end-atomic) + (report-error cp)] + [else + (thread-push-kill-callback! + (lambda () (rktio_copy_file_stop rktio cp))) + (dynamic-wind + void + (lambda () + (end-atomic) + (let loop () + (cond + [(rktio_copy_file_is_done rktio cp) + (define r (rktio_copy_file_finish_permissions rktio cp)) + (when (rktio-error? r) (report-error r))] + [else + (define r (rktio_copy_file_step rktio cp)) + (when (rktio-error? r) (report-error r)) + (loop)]))) + (lambda () + (start-atomic) + (rktio_copy_file_stop rktio cp) + (thread-pop-kill-callback!) + (end-atomic)))]))) + +(define/who (make-file-or-directory-link to path) + (check who path-string? to) + (check who path-string? path) + (define to-path (->path to)) + (define path-host (->host path who '(write))) + (define to-host (->host/as-is to-path who (host-> path-host))) + (define r (rktio_make_link rktio path-host to-host (directory-path? to-path))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot make link~a\n" + " path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the path already exists" + "") + (host-> path-host))))) + +(define/who (resolve-path p) + (check who path-string? p) + (define host-path (->host (path->path-without-trailing-separator (->path p)) who '(exists))) + (start-atomic) + (define r0 (rktio_readlink rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_to_bytes r0) + (rktio_free r0)))) + (end-atomic) + (cond + [(rktio-error? r) + ;; Errors are not reported, but are treated like non-links + (define new-path (host-> host-path)) + ;; If cleansing didn't change p, then return an `eq?` path + (cond + [(equal? new-path p) p] + [else new-path])] + [else (host-> r)])) + +(define/who (expand-user-path p) + (check who path-string? p) + (define path (->path p)) + (define bstr (path-bytes path)) + (cond + [(and (positive? (bytes-length bstr)) + (eqv? (bytes-ref bstr 0) (char->integer #\~))) + (define host-path (->host/as-is path who #f)) + (start-atomic) + (define r0 (rktio_expand_user_tilde rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_to_bytes r0) + (rktio_free r0)))) + (end-atomic) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "bad username in path\n" + " path: ~a") + (host-> host-path)))) + (host-> r)] + [else path])) + +(define/who (filesystem-root-list) + (security-guard-check-file who #f '(exists)) + (start-atomic) + (define r0 (rktio_filesystem_roots rktio)) + (define r (if (rktio-error? r0) + r0 + (rktio_to_bytes_list r0))) + (end-atomic) + (when (rktio-error? r) + (raise-filesystem-error who r "cannot get roots")) + (for/list ([p (in-list r)]) + (host-> p))) diff -Nru racket-6.12+ppa1/src/io/file/parameter.rkt racket-7.0+ppa1/src/io/file/parameter.rkt --- racket-6.12+ppa1/src/io/file/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/file/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide current-force-delete-permissions) + +(define current-force-delete-permissions + (make-parameter #t (lambda (v) (and v #t)))) + diff -Nru racket-6.12+ppa1/src/io/filesystem-change-evt/main.rkt racket-7.0+ppa1/src/io/filesystem-change-evt/main.rkt --- racket-6.12+ppa1/src/io/filesystem-change-evt/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/filesystem-change-evt/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide filesystem-change-evt? + filesystem-change-evt + filesystem-change-evt-cancel) + +(define (filesystem-change-evt? v) #f) + +(define filesystem-change-evt + (case-lambda + [(p) (error 'filesystem-change-evt "unsupported")] + [(p fail) (fail)])) + +(define/who (filesystem-change-evt-cancel e) + (check who filesystem-change-evt? e) + (void)) diff -Nru racket-6.12+ppa1/src/io/foreign/main.rkt racket-7.0+ppa1/src/io/foreign/main.rkt --- racket-6.12+ppa1/src/io/foreign/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/foreign/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,101 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../path/path.rkt" + "../file/host.rkt" + "../file/error.rkt" + "../string/convert.rkt" + "../locale/string.rkt") + +(provide ffi-get-lib + ffi-get-obj + current-load-extension) + +;; The FFI is mostly implemented in "cs/core/foreign.ss" +;; and `ffi/unsafe`, but rktio provides the implementation +;; of loading and searching shared libraries. + +(define (ffi-get-lib who path as-global? fail-as-false? success-k) + (check who path-string? #:or-false path) + (check who (procedure-arity-includes/c 1) success-k) + (define bstr (and path (->host/as-is path #f #f))) + (start-atomic) + (define dll (rktio_dll_open rktio bstr as-global?)) + (define err-str (dll-get-error dll)) + (end-atomic) + (cond + [(rktio-error? dll) + (cond + [fail-as-false? #f] + [else + (define msg (string-append "could not load foreign library" + "\n path: " (if bstr (bytes->string/locale bstr #\?) "[all opened]"))) + (cond + [err-str + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": " msg + "\n system error: " (->string err-str)) + (current-continuation-marks)))] + [else + (raise-filesystem-error who dll msg)])])] + [else (success-k dll)])) + +(define (ffi-get-obj who dll dll-name name success-k) + (check who path-string? #:or-false dll-name) + (check who bytes? name) + (check who (procedure-arity-includes/c 1) success-k) + (start-atomic) + (define obj (rktio_dll_find_object rktio dll name)) + (define err-str (dll-get-error obj)) + (end-atomic) + (cond + [(rktio-error? obj) + (define msg (string-append "could not find export from foreign library" + "\n name: " (bytes->string/utf-8 name #\?) + "\n library: " (if dll-name (bytes->string/locale (path-bytes (->path dll-name)) #\?) "[all opened]"))) + (cond + [err-str + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": " msg + "\n system error: " (->string err-str)) + (current-continuation-marks)))] + [else + (raise-filesystem-error who dll msg)])] + [else (success-k obj)])) + +;; in atomic mode +(define (dll-get-error v) + (and (rktio-error? v) + (let ([p (rktio_dll_get_error rktio)]) + (cond + [(rktio-error? p) + (format-rktio-system-error-message v)] + [else + (begin0 + (rktio_to_bytes p) + (rktio_free p))])))) + +(define (->string s) + (if (bytes? s) + (bytes->string/utf-8 s #\?) + s)) + +; ---------------------------------------- + +(define/who (default-load-extension path sym) + (check who path-string? path) + (check who symbol? sym) + (raise (exn:fail:unsupported + "default-load-extension: extensions are not supported" + (current-continuation-marks)))) + + +(define/who current-load-extension + (make-parameter default-load-extension + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) diff -Nru racket-6.12+ppa1/src/io/format/main.rkt racket-7.0+ppa1/src/io/format/main.rkt --- racket-6.12+ppa1/src/io/format/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/format/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base +(require "../common/check.rkt" + "../port/parameter.rkt" + "../port/output-port.rkt" + "../port/string-port.rkt" + "printf.rkt") + +(provide format + fprintf + printf + eprintf) + +(define/who (format fmt . args) + (check who string? fmt) + (define o (open-output-string)) + (do-printf 'printf o fmt args) + (get-output-string o)) + +(define/who (fprintf o fmt . args) + (check who output-port? o) + (check who string? fmt) + (do-printf who o fmt args)) + +(define/who (printf fmt . args) + (check who string? fmt) + (do-printf who (current-output-port) fmt args)) + +(define/who (eprintf fmt . args) + (check who string? fmt) + (do-printf who (current-error-port) fmt args)) diff -Nru racket-6.12+ppa1/src/io/format/printf.rkt racket-7.0+ppa1/src/io/format/printf.rkt --- racket-6.12+ppa1/src/io/format/printf.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/format/printf.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,196 @@ +#lang racket/base +(require "../print/main.rkt" + (submod "../print/main.rkt" internal) + "../port/string-output.rkt") + +(provide do-printf) + +;; Since this module implements formatting, it can't use the usual +;; error functions or other formatting functions. + +(define (do-printf who o fmt all-args) + (define len (string-length fmt)) + + ;; First pass: check format and argument consistency + (define (next args) (and (pair? args) (cdr args))) + (let loop ([i 0] [expected-count 0] [args all-args] [error-thunk #f]) + (cond + [(= i len) + (check-conclusions who expected-count args error-thunk fmt all-args)] + [else + (case (string-ref fmt i) + [(#\~) + (let ([i (add1 i)]) + (when (= i len) + (ill-formed-error who "cannot end in `~`" fmt all-args)) + (case (string-ref fmt i) + [(#\~ #\% #\n #\N) + (loop (add1 i) expected-count args error-thunk)] + [(#\a #\A #\s #\S #\v #\V #\e #\E) + (loop (add1 i) (add1 expected-count) (next args) error-thunk)] + [(#\.) + (let ([i (add1 i)]) + (define (bad-dot) + (ill-formed-error who "tag `~.` not followed by `a`, `s`, or `v`" fmt all-args)) + (when (= i len) + (bad-dot)) + (case (string-ref fmt i) + [(#\a #\A #\s #\S #\v #\V) + (loop (add1 i) (add1 expected-count) (next args) error-thunk)] + [else (bad-dot)]))] + [(#\x #\X #\o #\O #\b #\B) + (define new-error-thunk (and (not error-thunk) + (pair? args) + (let ([a (car args)]) + (or (not (number? a)) + (not (exact? a)))) + (lambda () + (arg-type-error who "exact integer" (car args) fmt args)))) + (loop (add1 i) (add1 expected-count) (next args) new-error-thunk)] + [(#\c #\C) + (define new-error-thunk (and (not error-thunk) + (pair? args) + (not (char? (car args))) + (lambda () + (arg-type-error who "character" (car args) fmt args)))) + (loop (add1 i) (add1 expected-count) (next args) new-error-thunk)] + [else + (cond + [(char-whitespace? (string-ref fmt i)) + (loop (add1 i) expected-count args error-thunk)] + [else + (ill-formed-error who + (string-append "tag `~" (substring fmt i (add1 i)) "` not allowed") + fmt + all-args)])]))] + [else (loop (add1 i) expected-count args error-thunk)])])) + + ;; Second pass: output + (let loop ([start-i 0] [i 0] [args all-args]) + (cond + [(= i len) + (write-string fmt o start-i i)] + [else + (case (string-ref fmt i) + [(#\~) + (define (next i args) (let ([i (add1 i)]) + (loop i i args))) + (write-string fmt o start-i i) + (let ([i (add1 i)]) + (define c (string-ref fmt i)) + (case c + [(#\~) + (write-string "~" o) + (next i args)] + [(#\% #\n #\N) + (write-string "\n" o) + (next i args)] + [(#\a #\A) + (do-display who (car args) o) + (next i (cdr args))] + [(#\s #\S) + (do-write who (car args) o) + (next i (cdr args))] + [(#\v #\V) + (do-global-print who (car args) o) + (next i (cdr args))] + [(#\e #\E) + (write-string ((error-value->string-handler) + (car args) + (error-print-width)) + o) + (next i (cdr args))] + [(#\.) + (let ([i (add1 i)]) + (case (string-ref fmt i) + [(#\a #\A) + (do-display who (car args) o (error-print-width)) + (next i (cdr args))] + [(#\s #\S) + (do-write who (car args) o (error-print-width)) + (next i (cdr args))] + [(#\v #\V) + ;; Intentionally using `do-print` instead of + ;; `do-global-print`: + (do-print who (car args) o 0 (error-print-width)) + (next i (cdr args))]))] + [(#\x #\X) + (write-string (number->string (car args) 16) o) + (next i (cdr args))] + [(#\o #\O) + (write-string (number->string (car args) 8) o) + (next i (cdr args))] + [(#\b #\B) + (write-string (number->string (car args) 2) o) + (next i (cdr args))] + [(#\c #\C) + (write-string (string (car args)) o) + (next i (cdr args))] + [else + (cond + [(char-whitespace? c) + ;; Skip whitespace, but no more than one newline/return: + (let ws-loop ([i i] [saw-newline? #f]) + (cond + [(= i len) (loop i i args)] + [else + (define c (string-ref fmt i)) + (case c + [(#\newline) + (if saw-newline? + (loop i i args) + (ws-loop (add1 i) #t))] + [(#\return) + (if saw-newline? + (loop i i args) + (ws-loop (if (and ((add1 i) . < . len) + (char=? #\newline (string-ref fmt (add1 i)))) + (+ i 2) + (add1 i)) + #t))] + [else (if (char-whitespace? c) + (ws-loop (add1 i) saw-newline?) + (loop i i args))])]))])]))] + [else + (loop start-i (add1 i) args)])])) + + (void)) + +;; ---------------------------------------- + +(define (raise-error str) + (raise (exn:fail:contract str (current-continuation-marks)))) + +(define (check-conclusions who expected-count args error-thunk fmt all-args) + (unless (null? args) + (raise-error (string-append + (symbol->string who) + ": " + "format string requires " + (number->string expected-count) + " arguments, given " + (number->string (length all-args)) + (arguments->string (cons fmt all-args))))) + (when error-thunk (error-thunk))) + +(define (ill-formed-error who explanation fmt args) + (raise-error (string-append + (symbol->string who) + ": " + "ill-formed pattern string\n" + " explanation: " explanation + (arguments->string (cons fmt args))))) + +(define (arg-type-error who what val fmt args) + (raise-error (string-append + (symbol->string who) + ": " + "format string requires a " what ", given something else\n" + " bad argument: " (value->string val) + (arguments->string (cons fmt args))))) + +(define (value->string v) + ((error-value->string-handler) v (error-print-width))) + +(define (arguments->string args) + "") diff -Nru racket-6.12+ppa1/src/io/host/bootstrap.rkt racket-7.0+ppa1/src/io/host/bootstrap.rkt --- racket-6.12+ppa1/src/io/host/bootstrap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/bootstrap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,114 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table) + (only-in '#%unsafe + unsafe-custodian-register + unsafe-custodian-unregister) + "../../thread/sandman.rkt" + ffi/unsafe/atomic + "bootstrap-rktio.rkt") + +;; Approximate scheduler cooperation where `async-evt` can be used +;; within the dynamic extent of a `poller` callback to mean that the +;; poller is selected. Since `nack` propagation is based on a thread, +;; this approximation won't work right if an event is actually +;; contended. Also, `prop:secondary-evt` is just `prop:evt`, so +;; `prop:evt` cannot be mixed with `prop:input-port` or +;; `prop:output-port`. + +(struct poller (proc) + #:property prop:procedure + (lambda (p s) + (define async-sema (make-semaphore)) + (poll-guard-evt + (lambda (poll?) + (parameterize ([current-async-semaphore async-sema]) + (define-values (results new-evt) + ((poller-proc p) (if poll? never-evt s) (poll-ctx poll? (lambda () (semaphore-post async-sema))))) + (if results + (wrap-evt always-evt (lambda (v) (apply values results))) + new-evt)))))) + +(define (poller-evt v) + (struct poller-evt () + #:property prop:evt (lambda (self) (v self))) + (poller-evt)) + +(struct poll-ctx (poll? select-proc)) + +(define (poll-ctx-sched-info ctx) #f) + +(struct control-state-evt (evt interrupt abandon retry) + #:property prop:evt (lambda (cse) + (nack-guard-evt + (lambda (nack) + (thread (lambda () (sync nack) ((control-state-evt-abandon cse)))) + (control-state-evt-evt cse))))) + +(define current-async-semaphore (make-parameter #f)) + +(define (async-evt) + (or (current-async-semaphore) + (error 'async-evt "not in a `poller` callback"))) + +(define current-kill-callbacks (make-parameter '())) + +(define (thread-push-kill-callback! p) + (current-kill-callbacks (cons p (current-kill-callbacks)))) + +(define (thread-pop-kill-callback!) + (current-kill-callbacks (cdr (current-kill-callbacks)))) + +(define schedule-info-current-exts + (case-lambda + [() #f] + [(v) (void)])) + +(define (sync-atomic-poll-evt? evt) + (or (channel-put-evt? evt) + (channel? evt) + (semaphore? evt) + (semaphore-peek-evt? evt) + (eq? always-evt evt) + (eq? never-evt evt))) + +(primitive-table '#%thread + (hasheq 'make-semaphore make-semaphore + 'semaphore-post semaphore-post + 'semaphore-wait semaphore-wait + 'semaphore-peek-evt semaphore-peek-evt + 'wrap-evt wrap-evt + 'always-evt always-evt + 'choice-evt (lambda (l) (apply choice-evt l)) + 'sync sync + 'sync/timeout sync/timeout + 'sync-atomic-poll-evt? sync-atomic-poll-evt? + 'evt? evt? + 'prop:evt prop:evt + 'prop:secondary-evt prop:evt + 'poller poller + 'poller-evt poller-evt + 'poll-ctx-poll? poll-ctx-poll? + 'poll-ctx-select-proc poll-ctx-select-proc + 'poll-ctx-sched-info poll-ctx-sched-info + 'set-poll-ctx-incomplete?! void + 'schedule-info-did-work! void + 'control-state-evt control-state-evt + 'async-evt async-evt + 'schedule-info-current-exts schedule-info-current-exts + 'current-sandman current-sandman + 'start-atomic start-atomic + 'end-atomic end-atomic + 'start-atomic/no-interrupts start-atomic + 'end-atomic/no-interrupts end-atomic + 'current-custodian current-custodian + 'custodian-shut-down? (lambda (c) + (define v (box 1)) + (define ref (unsafe-custodian-register c v void #f #f)) + (cond + [ref (unsafe-custodian-unregister v ref) #f] + [else #t])) + 'unsafe-custodian-register unsafe-custodian-register + 'unsafe-custodian-unregister unsafe-custodian-unregister + 'thread-push-kill-callback! thread-push-kill-callback! + 'thread-pop-kill-callback! thread-pop-kill-callback! + 'set-get-subprocesses-time! void)) diff -Nru racket-6.12+ppa1/src/io/host/bootstrap-rktio.rkt racket-7.0+ppa1/src/io/host/bootstrap-rktio.rkt --- racket-6.12+ppa1/src/io/host/bootstrap-rktio.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/bootstrap-rktio.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,218 @@ +#lang racket/base +(require racket/include + (only-in '#%linklet primitive-table) + ffi/unsafe + ffi/unsafe/atomic + (for-syntax racket/base) + (only-in racket/base + [void racket:void])) + +(define librktio (ffi-lib "librktio")) + +(define << arithmetic-shift) + +(define void _void) +(define char _byte) +(define int _int) +(define unsigned-short _ushort) +(define intptr_t _intptr) +(define uintptr_t _uintptr) +(define rktio_int64_t _int64) +(define float _float) +(define double _double) +(define NULL #f) + +(define-syntax-rule (define-constant n v) (define n v)) + +(define-syntax (define-type stx) + (syntax-case stx (rktio_bool_t rktio_ok_t) + [(_ rktio_bool_t _) + (with-syntax ([(_ rktio_bool_t _) stx]) + #'(define rktio_bool_t _bool))] + [(_ rktio_ok_t _) + (with-syntax ([(_ rktio_ok_t _) stx]) + #'(define rktio_ok_t _bool))] + [(_ n t) #'(define n t)])) + +(define-syntax (define-struct-type stx) + (syntax-case stx () + [(_ n ([type name] ...)) + (with-syntax ([_n (datum->syntax #'n + (string->symbol (format "_R~a" (syntax-e #'n))))] + [_n-pointer (datum->syntax #'n + (string->symbol (format "_R~a-pointer" (syntax-e #'n))))]) + #'(begin + (define-cstruct _n ([name type] ...)) + (define n _n-pointer)))])) + +(define-syntax-rule (ref t) _pointer) +(define-syntax-rule (*ref t) _pointer) + +(define-syntax-rule (define-function flags ret-type name ([arg-type arg-name] ...)) + (define name + (get-ffi-obj 'name librktio (_fun arg-type ... -> ret-type)))) + +(define-syntax-rule (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + err-expr) + (begin + (define proc + (get-ffi-obj 'name librktio (_fun rktio-type arg-type ... -> ret-type))) + (define (name rktio-name arg-name ...) + (begin + (start-atomic) + (begin0 + (let ([v (proc rktio-name arg-name ...)]) + (if (eqv? v err-v) + err-expr + v)) + (end-atomic)))))) + +(define-syntax-rule (define-function/errno err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...)) + (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + (vector (rktio_get_last_error_kind rktio-name) + (rktio_get_last_error rktio-name)))) + +(define-syntax-rule (define-function/errno+step err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...)) + (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + (vector (rktio_get_last_error_kind rktio-name) + (rktio_get_last_error rktio-name) + (rktio_get_last_error_step rktio-name)))) + +(include "../../rktio/rktio.rktl") + +(define rktio_NULL #f) + +(define (rktio_filesize_ref fs) + (ptr-ref fs rktio_filesize_t)) +(define (rktio_timestamp_ref fs) + (ptr-ref fs rktio_timestamp_t)) +(define (rktio_is_timestamp v) + (let ([radix (arithmetic-shift 1 (sub1 (* 8 (ctype-sizeof rktio_timestamp_t))))]) + (<= (- radix) v (sub1 radix)))) + +(define (rktio_recv_length_ref p) + (Rrktio_length_and_addrinfo_t-len (cast p _pointer rktio_length_and_addrinfo_t))) + +(define (rktio_recv_address_ref p) + (Rrktio_length_and_addrinfo_t-address (cast p _pointer rktio_length_and_addrinfo_t))) + +(define (rktio_identity_to_vector p) + (let ([p (cast p _pointer _Rrktio_identity_t-pointer)]) + (vector + (Rrktio_identity_t-a p) + (Rrktio_identity_t-b p) + (Rrktio_identity_t-c p) + (Rrktio_identity_t-a_bits p) + (Rrktio_identity_t-b_bits p) + (Rrktio_identity_t-c_bits p)))) + +(define (rktio_convert_result_to_vector p) + (let ([p (cast p _pointer _Rrktio_convert_result_t-pointer)]) + (vector + (Rrktio_convert_result_t-in_consumed p) + (Rrktio_convert_result_t-out_produced p) + (Rrktio_convert_result_t-converted p)))) + +(define (rktio_to_bytes fs) + (bytes-copy (cast fs _pointer _bytes))) + +(define (rktio_to_shorts fs) + (let loop ([len 0]) + (cond + [(zero? (ptr-ref fs _short len)) + (define bstr (make-bytes (* len 2))) + (memcpy bstr fs (* len 2)) + bstr] + [else + (loop (add1 len))]))) + +;; Unlike `rktio_to_bytes`, frees the array and strings +(define (rktio_to_bytes_list lls [len #f]) + (begin0 + (let loop ([i 0]) + (cond + [(and len (= i len)) + null] + [else + (define bs (ptr-ref lls _bytes i)) + (if bs + (cons (begin0 + (bytes-copy bs) + (rktio_free bs)) + (loop (add1 i))) + null)])) + (rktio_free lls))) + +(define (rktio_from_bytes_list bstrs) + (cast bstrs (_list i _bytes) _gcpointer)) + +(define (rktio_free_bytes_list lls len) + (racket:void)) + +(define (rktio_process_result_stdin_fd r) + (Rrktio_process_result_t-stdin_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_stdout_fd r) + (Rrktio_process_result_t-stdout_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_stderr_fd r) + (Rrktio_process_result_t-stderr_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_process r) + (Rrktio_process_result_t-process (cast r _pointer _Rrktio_process_result_t-pointer))) + +(define (rktio_status_running r) + (Rrktio_status_t-running (cast r _pointer _Rrktio_status_t-pointer))) +(define (rktio_status_result r) + (Rrktio_status_t-result (cast r _pointer _Rrktio_status_t-pointer))) + +(define (rktio_do_install_os_signal_handler rktio) + (racket:void)) +(define (rktio_get_ctl_c_handler) + (lambda (k) + (racket:void))) + +(primitive-table '#%rktio + (let () + (define-syntax extract-functions + (syntax-rules (define-constant + define-type + define-struct-type + define-function + define-function/errno + define-function/errno+step) + [(_ accum) (hasheq . accum)] + [(_ accum (define-constant . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-struct-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-function _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno+step _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)])) + (define-syntax-rule (begin form ...) + (extract-functions [#;(begin) + 'rktio_NULL rktio_NULL + 'rktio_filesize_ref rktio_filesize_ref + 'rktio_timestamp_ref rktio_timestamp_ref + 'rktio_is_timestamp rktio_is_timestamp + 'rktio_recv_length_ref rktio_recv_length_ref + 'rktio_recv_address_ref rktio_recv_address_ref + 'rktio_identity_to_vector rktio_identity_to_vector + 'rktio_convert_result_to_vector rktio_convert_result_to_vector + 'rktio_to_bytes rktio_to_bytes + 'rktio_to_bytes_list rktio_to_bytes_list + 'rktio_to_shorts rktio_to_shorts + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd + 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd + 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd + 'rktio_process_result_process rktio_process_result_process + 'rktio_status_running rktio_status_running + 'rktio_status_result rktio_status_result + 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler + 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] + form ...)) + (include "../../rktio/rktio.rktl"))) diff -Nru racket-6.12+ppa1/src/io/host/bootstrap-thread.rkt racket-7.0+ppa1/src/io/host/bootstrap-thread.rkt --- racket-6.12+ppa1/src/io/host/bootstrap-thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/bootstrap-thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table) + "../../thread/bootstrap-main.rkt" + "bootstrap-rktio.rkt") + +;; Use the "thread" layer implementation in combination with +;; with the rktio bootstrap bindings. + +(primitive-table '#%thread #%thread-instance) diff -Nru racket-6.12+ppa1/src/io/host/error.rkt racket-7.0+ppa1/src/io/host/error.rkt --- racket-6.12+ppa1/src/io/host/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,62 @@ +#lang racket/base +(require "../string/convert.rkt" + "rktio.rkt" + "thread.rkt") + +(provide remap-rktio-error + format-rktio-message + format-rktio-system-error-message + raise-rktio-error + check-rktio-error + check-rktio-error*) + +(define (remap-rktio-error err) + (start-atomic) + (rktio_set_last_error rktio + (rktio-errkind err) + (rktio-errno err)) + (rktio_remap_last_error rktio) + (define errno (rktio_get_last_error rktio)) + (define errkind (rktio_get_last_error_kind rktio)) + (end-atomic) + (vector errkind errno)) + +(define (format-rktio-message who err base-msg) + (string-append (if who (symbol->string who) "") + (if who ": " "") + base-msg + "\n system error: " + (format-rktio-system-error-message err))) + +(define (format-rktio-system-error-message err) + (start-atomic) + (define p (rktio_get_error_string rktio + (rktio-errkind err) + (rktio-errno err))) + (define system-msg (rktio_to_bytes p)) + (end-atomic) + (string-append (bytes->string/utf-8 system-msg #\?) + "; " + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) "errno"] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) "win_err"] + [(eqv? kind RKTIO_ERROR_KIND_GAI) "gai_err"] + [else "rkt_err"])) + "=" + (number->string (rktio-errno err)))) + +(define (raise-rktio-error who err base-msg) + (raise + (exn:fail + (format-rktio-message who err base-msg) + (current-continuation-marks)))) + +(define (check-rktio-error v base-msg) + (when (rktio-error? v) + (raise-rktio-error #f v base-msg)) + v) + +(define (check-rktio-error* v base-msg) + (check-rktio-error v base-msg) + (void)) diff -Nru racket-6.12+ppa1/src/io/host/rktio.rkt racket-7.0+ppa1/src/io/host/rktio.rkt --- racket-6.12+ppa1/src/io/host/rktio.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/rktio.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/include + (for-syntax racket/base) + (only-in '#%linklet primitive-table)) + +(provide rktio + rktio-error? + rktio-errkind + rktio-errno + rktio-errstep + racket-error?) +;; More `provide`s added by macros below + +(define rktio-table + (or (primitive-table '#%rktio) + (error '#%rktio "rktio not supported by host"))) + +(define (lookup n) + (hash-ref rktio-table n)) + +(define << arithmetic-shift) + +(define-syntax-rule (define-constant n v) + (begin + (define n v) + (provide n))) + +(define-syntax-rule (define-type . _) (void)) +(define-syntax-rule (define-struct-type . _) (void)) + +(define-syntax-rule (define-function _ _ name . _) + (begin + (define name (lookup 'name)) + (provide name))) + +(define-syntax-rule (define-function/errno _ _ _ name . _) + (define-function () #f name)) +(define-syntax-rule (define-function/errno+step _ _ _ name . _) + (define-function () #f name)) + +(include "../../rktio/rktio.rktl") + +(define-function () #f rktio_filesize_ref) +(define-function () #f rktio_timestamp_ref) +(define-function () #f rktio_is_timestamp) +(define-function () #f rktio_recv_length_ref) +(define-function () #f rktio_recv_address_ref) +(define-function () #f rktio_identity_to_vector) +(define-function () #f rktio_convert_result_to_vector) +(define-function () #f rktio_to_bytes) +(define-function () #f rktio_to_bytes_list) +(define-function () #f rktio_to_shorts) +(define-function () #f rktio_NULL) +(define-function () #f rktio_do_install_os_signal_handler) +(define-function () #f rktio_get_ctl_c_handler) +(define-function () #f rktio_from_bytes_list) +(define-function () #f rktio_free_bytes_list) +(define-function () #f rktio_process_result_stdin_fd) +(define-function () #f rktio_process_result_stdout_fd) +(define-function () #f rktio_process_result_stderr_fd) +(define-function () #f rktio_process_result_process) +(define-function () #f rktio_status_running) +(define-function () #f rktio_status_result) + +;; Error results are represented as vectors: +(define rktio-error? vector?) +(define (rktio-errkind v) (vector-ref v 0)) +(define (rktio-errno v) (vector-ref v 1)) +(define (rktio-errstep v) (vector-ref v 2)) + +(define (racket-error? v errno) + (and (eqv? (rktio-errkind v) RKTIO_ERROR_KIND_RACKET) + (eqv? (rktio-errno v) errno))) + +(define rktio (rktio_init)) + +(void (rktio_do_install_os_signal_handler rktio)) diff -Nru racket-6.12+ppa1/src/io/host/thread.rkt racket-7.0+ppa1/src/io/host/thread.rkt --- racket-6.12+ppa1/src/io/host/thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/host/thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,86 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table)) + +(provide atomically + non-atomically + atomically/no-interrupts + check-current-custodian) + +(define table + (or (primitive-table '#%thread) + (error '#%thread "scheduler cooperation not supported by host"))) + +(define-syntax bounce + (syntax-rules () + [(_ id) + (begin + (provide id) + (define id (hash-ref table 'id)))] + [(_ id ...) + (begin (bounce id) ...)])) + +(bounce make-semaphore + semaphore-post + semaphore-wait + semaphore-peek-evt + wrap-evt + always-evt + choice-evt ; raw variant that takes a list of evts + sync + sync/timeout + evt? + sync-atomic-poll-evt? + prop:evt + prop:secondary-evt + poller + poller-evt + poll-ctx-poll? + poll-ctx-select-proc + poll-ctx-sched-info + set-poll-ctx-incomplete?! + schedule-info-did-work! + control-state-evt + async-evt + schedule-info-current-exts + current-sandman + start-atomic + end-atomic + start-atomic/no-interrupts ; => disable GC, too, if GC can call back + end-atomic/no-interrupts + current-custodian + unsafe-custodian-register + unsafe-custodian-unregister + thread-push-kill-callback! + thread-pop-kill-callback! + set-get-subprocesses-time!) + +(define-syntax-rule (atomically e ...) + (begin + (start-atomic) + (begin0 + (let () e ...) + (end-atomic)))) + +(define-syntax-rule (non-atomically e ...) + (begin + (end-atomic) + (begin0 + (let () e ...) + (start-atomic)))) + +;; Cannot be exited with `non-atomically`: +(define-syntax-rule (atomically/no-interrupts e ...) + (begin + (start-atomic/no-interrupts) + (begin0 + (let () e ...) + (end-atomic/no-interrupts)))) + +;; in atomic mode +(define (check-current-custodian who) + (when (custodian-shut-down? (current-custodian)) + (end-atomic) + (raise + (exn:fail + (string-append (symbol->string who) ": the current custodian has been shut down") + (current-continuation-marks))))) diff -Nru racket-6.12+ppa1/src/io/locale/collate.rkt racket-7.0+ppa1/src/io/locale/collate.rkt --- racket-6.12+ppa1/src/io/locale/collate.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/collate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,158 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/utf-16-encode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "string.rkt" + "recase.rkt" + "nul-char.rkt" + "ucs-4.rkt") + +(provide string-locale? + string-locale-ci?) + +(define (make-string-comparsion who cmp portable-cmp ci?) + (lambda (arg . args) + (check who string? arg) + (for ([arg (in-list args)]) + (check who string? arg)) + (define locale-on? (current-locale)) + (let loop ([prev arg] [args args]) + (cond + [(null? args) #t] + [(if locale-on? + (cmp (collate prev (car args) ci?) 0) + (portable-cmp prev (car args))) + (loop (car args) (cdr args))] + [else #f])))) + +(define/who string-locale? + (make-string-comparsion who > string>? #f)) + +(define/who string-locale-ci? + (make-string-comparsion who > string-ci>? #t)) + +;; The rktio-provided string-comparison functions don't handle strings +;; that contain the nul character, and locale-specific conversion also +;; may not support nul characters. So, we handle nul ourselves, +;; imposing the rule that a string is greater than any prefix of the +;; string. +(define (collate s1 s2 ci?) + (define l1 (string-length s1)) + (define l2 (string-length s2)) + (let loop ([i1 0] [i2 0]) + (define t-l1 (+ i1 (string-length-up-to-nul s1 i1 l1))) + (define t-l2 (+ i2 (string-length-up-to-nul s2 i2 l2))) + (cond + [(and (= l1 t-l1) + (= l2 t-l2)) + (collate/no-nul (maybe-substring s1 i1 l1) (maybe-substring s2 i2 l2) ci?)] + [else + (define v (collate/no-nul (substring s1 i1 t-l1) + (substring s2 i2 t-l2) + ci?)) + (cond + [(not (zero? v)) v] + [(= l1 t-l1) (if (= l2 t-l2) 0 -1)] + [(= l2 t-l2) 1] + [else + ;; Both strings have more content, so skip nuls and check more + (loop (+ t-l1 1) (+ t-l2 1))])]))) + +;; Compare two strings that do not include the nul character +(define (collate/no-nul s1 s2 ci?) + (cond + [(and (equal? (current-locale) "") + (not (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERT_STRCOLL_UTF16)))) + ;; The OS provides a UTF-16-based collation function, so use that + (define s1-16 (utf-16-encode s1)) + (define s2-16 (utf-16-encode s2)) + (rktio_strcoll_utf16 rktio + s1-16 (arithmetic-shift (bytes-length s1-16) -1) + s2-16 (arithmetic-shift (bytes-length s2-16) -1) + ci?)] + [else + ;; We don't just convert to a locale encoding and compare, + ;; because there might be an encoding error, and we want + ;; to treat unencodable as strictly greater than encodable. + (define c1 #f) + (define c2 #f) + (define in-bstr1 (string->bytes/ucs-4 s1 0 (string-length s1))) + (define in-bstr2 (string->bytes/ucs-4 s2 0 (string-length s2))) + (dynamic-wind + (lambda () + (set! c1 (bytes-open-converter ucs-4-encoding (locale-string-encoding))) + (set! c2 (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (let loop ([pos1 0] [pos2 0] [end1 (bytes-length in-bstr1)] [end2 (bytes-length in-bstr2)]) + (define-values (bstr1 in-used1 status1) + (bytes-convert c1 in-bstr1 pos1 end1)) + (define-values (bstr2 in-used2 status2) + (bytes-convert c2 in-bstr2 pos2 end2)) + (define new-pos1 (+ in-used1 pos1)) + (define new-pos2 (+ in-used2 pos2)) + (define done1? (= new-pos1 end1)) + (define done2? (= new-pos2 end2)) + (define (check-one-byte) + (define ch1 (string-ref s1 (arithmetic-shift new-pos1 -2))) + (define ch2 (string-ref s2 (arithmetic-shift new-pos2 -2))) + (cond + [(charstring/locale + string->bytes/locale + + string-locale? + string-locale-ci? + + string-locale-downcase + string-locale-upcase) + diff -Nru racket-6.12+ppa1/src/io/locale/nul-char.rkt racket-7.0+ppa1/src/io/locale/nul-char.rkt --- racket-6.12+ppa1/src/io/locale/nul-char.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/nul-char.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,18 @@ +#lang racket/base + +(provide string-length-up-to-nul + maybe-substring) + +;; Get the number of characters available before a nul character +(define (string-length-up-to-nul s i l) + (let loop ([j i]) + (cond + [(= j l) (- j i)] + [(eqv? (string-ref s j) #\nul) (- j i)] + [else (loop (add1 j))]))) + + +(define (maybe-substring s i l) + (if (zero? i) + s + (substring s i l))) diff -Nru racket-6.12+ppa1/src/io/locale/parameter.rkt racket-7.0+ppa1/src/io/locale/parameter.rkt --- racket-6.12+ppa1/src/io/locale/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,71 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/convert.rkt") + +(provide current-locale + locale-string-encoding + system-language+country + + locale-encoding-is-utf-8? + locale-string-encoding/bytes + sync-locale!) + +(define current-locale + (make-parameter (string->immutable-string "") + (lambda (v) + (unless (or (not v) (string? v)) + (raise-argument-error 'current-locale "(or/c #f string?)" v)) + (and v (string->immutable-string v))))) + +(define installed-locale #f) + +;; in atomic mode +;; Any rktio function that depends on the locale should be called in +;; an atomic region that includes an earlier `(sync-locale!)` +(define (sync-locale!) + (define loc (current-locale)) + (unless (or (not loc) + (equal? installed-locale loc)) + (set! installed-locale (current-locale)) + (rktio_set_locale rktio (string->bytes/utf-8 installed-locale)))) + +(define (locale-encoding-is-utf-8?) + (define t (system-type)) + (define loc (current-locale)) + (or (not loc) + (and (or (eq? t 'macosx) + (eq? t 'windows)) + (equal? loc "")) + (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERTER_SUPPORTED)))) + +;; in atomic mode +(define (locale-string-encoding/bytes) + (sync-locale!) + (define e (rktio_locale_encoding rktio)) + (cond + [(rktio-error? e) + (end-atomic) + (raise-rktio-error 'locale-string-encoding e "error getting locale encoding")] + [else + (begin0 + (rktio_to_bytes e) + (rktio_free e))])) + +(define (locale-string-encoding) + (bytes->string/utf-8 (atomically (locale-string-encoding/bytes)) #\?)) + +(define/who (system-language+country) + (start-atomic) + (define c (rktio_system_language_country rktio)) + (cond + [(rktio-error? c) + (end-atomic) + (raise-rktio-error who c "error getting language and country information")] + [else + (begin0 + (rktio_to_bytes c) + (rktio_free c) + (end-atomic))])) diff -Nru racket-6.12+ppa1/src/io/locale/recase.rkt racket-7.0+ppa1/src/io/locale/recase.rkt --- racket-6.12+ppa1/src/io/locale/recase.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/recase.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,105 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/utf-16-encode.rkt" + "../string/utf-16-decode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "string.rkt" + "nul-char.rkt" + "ucs-4.rkt") + +(provide string-locale-upcase + string-locale-downcase + + locale-recase) + +(define/who (string-locale-upcase s) + (check who string? s) + (recase s #:up? #t)) + +(define/who (string-locale-downcase s) + (check who string? s) + (recase s #:up? #f)) + +(define (recase s #:up? up?) + ;; Primitive functions don't work with nul characters, so we handle + ;; those directly + (define len (string-length s)) + (let loop ([pos 0]) + (define i-len (+ pos (string-length-up-to-nul s pos len))) + (cond + [(= i-len len) + (define new-s (recase/no-nul (maybe-substring s pos len) up?)) + (if (eqv? pos 0) + new-s + (list new-s))] + [else + (define new-s (recase/no-nul (substring s pos i-len) up?)) + (define r (loop (+ i-len 1))) + (if (eqv? pos 0) + (apply string-append new-s (string #\nul) r) + (cons new-s (cons (string #\nul) r)))]))) + +(define (recase/no-nul s up?) + (cond + [(and (equal? (current-locale) "") + (not (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERT_RECASE_UTF16)))) + ;; The OS provides a UTF-16-based function, so use that + (define s-16 (utf-16-encode s)) + (start-atomic) + (define r (rktio_recase_utf16 rktio + up? + s-16 (arithmetic-shift (bytes-length s-16) -1) + #f)) + (define sr (rktio_to_shorts r)) + (rktio_free r) + (end-atomic) + (utf-16-decode sr)] + [else + ;; We don't just convert to a locale encoding and recase, + ;; because there might be an encoding error; we'll leave + ;; encoding-error bytes alone. + (define c #f) + (define in-bstr (string->bytes/ucs-4 s 0 (string-length s))) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (let loop ([pos 0]) + (cond + [(= pos (bytes-length in-bstr)) + (if (eqv? pos 0) + "" + '(""))] + [else + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (start-atomic) + (sync-locale!) + (define sr (locale-recase #:up? up? bstr)) + (end-atomic) + (define ls (bytes->string/locale sr)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + ls + (list ls))] + [else + (define r (loop (+ pos in-used 4))) + (define err-s (string (string-ref s (arithmetic-shift (+ pos in-used) -2)))) + (if (eqv? pos 0) + (apply string-append ls err-s r) + (list* ls err-s r))])]))) + (lambda () + (bytes-close-converter c)))])) + +;; in atomic mode +;; Assumes that the locale is sync'ed +(define (locale-recase #:up? up? s) + (define p (rktio_locale_recase rktio up? s)) + (define r (rktio_to_bytes p)) + (rktio_free p) + r) diff -Nru racket-6.12+ppa1/src/io/locale/string.rkt racket-7.0+ppa1/src/io/locale/string.rkt --- racket-6.12+ppa1/src/io/locale/string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,98 @@ +#lang racket/base +(require "../common/check.rkt" + "../string/convert.rkt" + "../string/utf-8-decode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "ucs-4.rkt") + +(provide string->bytes/locale + bytes->string/locale) + +(define/who (string->bytes/locale str [err-byte #f] [start 0] [end (and (string? str) (string-length str))]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (cond + [(locale-encoding-is-utf-8?) + (string->bytes/utf-8 str err-byte start end)] + [else + (define c #f) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (define in-bstr (string->bytes/ucs-4 str start end)) + (let loop ([pos 0]) + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + bstr + (list bstr))] + [(not err-byte) + (raise-arguments-error who "string cannot be encoded for the current locale" + "string" str)] + [else + (define err-bstr (bytes err-byte)) + (cond + [(eq? status 'aborts) + (if (eqv? pos 0) + (bytes-append bstr err-bstr) + (list bstr err-bstr))] + [else + ;; Skip the next character; we're assuming that + ;; `in-used` is a multiple of 4 + (define r (loop (+ pos in-used 4))) + (if (eqv? pos 0) + (apply bytes-append (cons bstr (cons err-bstr r))) + (cons bstr (cons err-bstr r)))])]))) + (lambda () + (bytes-close-converter c)))])) + +(define/who (bytes->string/locale in-bstr [err-char #f] [start 0] [end (and (bytes? in-bstr) + (bytes-length in-bstr))]) + (check who bytes? in-bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length in-bstr) in-bstr) + (cond + [(locale-encoding-is-utf-8?) + (bytes->string/utf-8 in-bstr err-char start end)] + [else + (define c #f) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter (locale-string-encoding) "UTF-8"))) + (lambda () + (let loop ([pos 0]) + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + (bytes->string/utf-8 bstr) + (list bstr))] + [(not err-char) + (raise-arguments-error who "byte string is not a valid encoding for the current locale" + "byte string" in-bstr)] + [else + + (define err-bstr (string->bytes/utf-8 (string err-char))) + (cond + [(eq? status 'aborts) + (if (eqv? pos 0) + (bytes->string/utf-8 (bytes-append bstr err-bstr)) + (list bstr err-bstr))] + [else + ;; Skip the byte and try again + (define r (loop (+ pos in-used 1))) + (if (eqv? pos 0) + (bytes->string/utf-8 (apply bytes-append (cons bstr (cons err-bstr r)))) + (cons bstr (cons err-bstr r)))])]))) + (lambda () + (bytes-close-converter c)))])) diff -Nru racket-6.12+ppa1/src/io/locale/ucs-4.rkt racket-7.0+ppa1/src/io/locale/ucs-4.rkt --- racket-6.12+ppa1/src/io/locale/ucs-4.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/locale/ucs-4.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,29 @@ +#lang racket/base + +(provide ucs-4-encoding + string->bytes/ucs-4) + +(define ucs-4-encoding + (if (system-big-endian?) + "UCS-4BE" + "UCS-4LE")) + +(define (string->bytes/ucs-4 str start end) + (define len (* 4 (- end start))) + (define bstr (make-bytes len)) + (if (system-big-endian?) + (for ([c (in-string str start end)] + [i (in-range 0 len 4)]) + (define n (char->integer c)) + (bytes-set! bstr i (arithmetic-shift n -24)) + (bytes-set! bstr (+ i 1) (bitwise-and 255 (arithmetic-shift n -16))) + (bytes-set! bstr (+ i 2) (bitwise-and 255 (arithmetic-shift n -8))) + (bytes-set! bstr (+ i 3) (bitwise-and 255 n))) + (for ([c (in-string str start end)] + [i (in-range 0 len 4)]) + (define n (char->integer c)) + (bytes-set! bstr (+ i 3) (arithmetic-shift n -24)) + (bytes-set! bstr (+ i 2) (bitwise-and 255 (arithmetic-shift n -16))) + (bytes-set! bstr (+ i 1) (bitwise-and 255 (arithmetic-shift n -8))) + (bytes-set! bstr i (bitwise-and 255 n)))) + bstr) diff -Nru racket-6.12+ppa1/src/io/logger/demo.rkt racket-7.0+ppa1/src/io/logger/demo.rkt --- racket-6.12+ppa1/src/io/logger/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base +(require "../host/bootstrap.rkt" + "main.rkt") + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(define root-logger (make-logger)) + +(test 'none (log-max-level root-logger)) +(add-stderr-log-receiver! root-logger 'warning) + +(test 'warning (log-max-level root-logger)) + +(log-message root-logger 'error "this should print to stderr" 5) + +(define demo1-logger (make-logger 'demo1 root-logger)) +(define demo2-logger (make-logger 'demo2 root-logger 'fatal)) + +(log-message demo1-logger 'error "this should print to stderr, too" 5) +(log-message demo2-logger 'error "this should not print to stderr" 5) + +(test 'warning (log-max-level demo1-logger)) +(test 'fatal (log-max-level demo2-logger)) + +(define lr1 (make-log-receiver root-logger 'info 'cats)) + +(test 'info (log-max-level demo1-logger)) +(test 'fatal (log-max-level demo2-logger)) + +(test 'info (log-max-level demo1-logger 'cats)) +(test 'fatal (log-max-level demo2-logger 'cats)) + +(test 'warning (log-max-level demo1-logger 'dogs)) +(test 'fatal (log-max-level demo2-logger 'dogs)) + +(test #t (log-level? demo1-logger 'info 'cats)) +(test #f (log-level? demo1-logger 'debug 'cats)) +(test #f (log-level? demo1-logger 'info 'dogs)) + +(define msg1 #f) +(define th1 (thread (lambda () (set! msg1 (sync lr1))))) +(sync (system-idle-evt)) +(test #f msg1) + +(log-message demo1-logger 'info 'cats "hello" 7) +(sync (system-idle-evt)) +(test '#(info "cats: hello" 7 cats) msg1) + +(log-message demo1-logger 'info 'cats "goodbye" 9) +(test '#(info "cats: goodbye" 9 cats) (sync lr1)) diff -Nru racket-6.12+ppa1/src/io/logger/level.rkt racket-7.0+ppa1/src/io/logger/level.rkt --- racket-6.12+ppa1/src/io/logger/level.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/level.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide check-level + level>=? + level-max + level-min + parse-filters + filters-level-for-topic + filters-max-level) + +;; A filter set is represented as an improper list of pairs ending +;; with a (non-pair) level symbol. The ending symbol is the level that +;; applies if a name match is not found for any of the preceding +;; elements of the list. + +(define (level->value lvl) + (case lvl + [(none) 0] + [(fatal) 1] + [(error) 2] + [(warning) 3] + [(info) 4] + [(debug) 5] + [else #f])) + +(define (level>=? a b) + ((level->value a) . >= . (level->value b))) + +(define (level-max a b) + (if ((level->value a) . < . (level->value b)) + b + a)) + +(define (level-min a b) + (if ((level->value a) . < . (level->value b)) + a + b)) + +(define (check-level who v) + (unless (level->value v) + (raise-argument-error who + "(or/c 'none 'fatal 'error 'warning 'info 'debug)" + v))) + +;; ---------------------------------------- + +(define (parse-filters who l #:default-level default-level) + (let loop ([l l] [accum null] [default-level default-level]) + (cond + [(null? l) + (append accum default-level)] + [else + (define level (car l)) + (check-level who level) + (cond + [(null? (cdr l)) + (append accum level)] + [else + (define topic (cadr l)) + (unless (or (not topic) (symbol? topic)) + (raise-argument-error who "(or/c #f symbol?)" topic)) + (if (not topic) + (loop (cddr l) accum level) + (loop (cddr l) + (cons (cons topic level) accum) + default-level))])]))) + +(define (filters-level-for-topic filters topic) + (let loop ([filters filters]) + (cond + [(pair? filters) + (cond + [(eq? (caar filters) topic) + (cdar filters)] + [else + (loop (cdr filters))])] + [else + ;; default: + filters]))) + +(define (filters-max-level filters) + (let loop ([filters filters] [best-level 'none]) + (cond + [(pair? filters) + (loop (cdr filters) + (level-max best-level (cdar filters)))] + [else + (level-max best-level filters)]))) diff -Nru racket-6.12+ppa1/src/io/logger/logger.rkt racket-7.0+ppa1/src/io/logger/logger.rkt --- racket-6.12+ppa1/src/io/logger/logger.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/logger.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,46 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide (struct-out logger) + logger-name + create-logger + logger-receivers) + +(struct logger (topic ; symbol or #f + parent ; logger or #f + propagate-filters + [receiver-boxes #:mutable] ; list of weak boxes + [prune-counter #:mutable] ; number of adds before checking empied boxes + [permanent-receivers #:mutable] ; receivers to retain strongly + [max-receiver-level #:mutable] ; up-to-date if `local-level-timestamp` = `(unbox root-level-timestamp-box)` + topic-level-cache ; topic -> level cache + [local-level-timestamp #:mutable] ; integer + root-level-timestamp-box ; box of integer + [level-sema #:mutable])) ; to report when a receiver is added + +(define/who (logger-name logger) + (check who logger? logger) + (logger-topic logger)) + +(define (create-logger #:topic topic #:parent parent #:propagate-filters propagate-filters) + (logger topic + parent + propagate-filters + null ; receiver-boxes + 8 ; prune-counter + null ; permanent-receivers + 'none ; max-receiver-level + (make-vector 16) ; topic-level-cache + -1 ; local-level-timestamp + (if parent + (logger-root-level-timestamp-box parent) + (box 0)) + #f)) ; level-sema + +;; Get log receivers, dropping any boxes made empty due to a weak +;; reference: +(define (logger-receivers logger) + (for*/list ([rb (in-list (logger-receiver-boxes logger))] + [b (in-value (weak-box-value rb))] + #:when b) + b)) diff -Nru racket-6.12+ppa1/src/io/logger/main.rkt racket-7.0+ppa1/src/io/logger/main.rkt --- racket-6.12+ppa1/src/io/logger/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,124 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "logger.rkt" + "level.rkt" + "wanted.rkt" + "receiver.rkt") + +(provide logger? + logger-name + current-logger + make-logger + log-level? ; ok to call in host-Scheme interrupt handler + log-max-level + log-all-levels + log-level-evt + log-message ; ok to call in host-Scheme interrupt handler + log-receiver? + make-log-receiver + add-stderr-log-receiver! + add-stdout-log-receiver!) + +(define root-logger + (create-logger #:topic #f #:parent #f #:propagate-filters 'none)) + +(define current-logger + (make-parameter root-logger + (lambda (l) + (unless (logger? l) + (raise-argument-error 'current-logger "logger?" l)) + l))) + +(define (make-logger [topic #f] [parent #f] . filters) + (unless (or (not topic) (symbol? topic)) + (raise-argument-error 'make-logger "(or/c symbol? #f)" topic)) + (unless (or (not parent) (logger? parent)) + (raise-argument-error 'make-logger "(or/c logger? #f)" parent)) + (create-logger #:topic topic + #:parent parent + #:propagate-filters (parse-filters 'make-logger filters #:default-level 'debug))) + +;; Can be called in any host Scheme thread, including in an interrupt +;; handler (where "interrupt" is a host-Scheme concept, such as a GC +;; handler). If it's not the thread that runs Racket, then it's in +;; atomic, non-interrupt mode and we assume that the argument checks +;; will pass. +(define/who (log-level? logger level [topic #f]) + (check who logger? logger) + (check-level who level) + (check who #:or-false symbol? topic) + (level>=? (logger-wanted-level logger topic) level)) + +(define/who (log-max-level logger [topic #f]) + (check who logger? logger) + (check who #:or-false symbol? topic) + (logger-wanted-level logger topic)) + +(define/who (log-all-levels logger) + (check who logger? logger) + (logger-all-levels logger)) + +(define/who (log-level-evt logger) + (check who logger? logger) + (define s + (atomically + (cond + [(logger-level-sema logger) + => (lambda (s) s)] + [else + (define s (make-semaphore)) + (set-logger-level-sema! logger s)]))) + (semaphore-peek-evt s)) + +;; Can be called in any host Scheme thread and in interrupt handler, +;; like `log-level?`: +(define/who log-message + ;; Complex dispatch based on number and whether third is a string: + (case-lambda + [(logger level message data) + (define topic (and (logger? logger) (logger-name logger))) + (do-log-message who logger level topic message data #t)] + [(logger level topic/message message/data data/prefix?) + (cond + [(string? topic/message) + (define topic (and (logger? logger) (logger-name logger))) + (do-log-message who logger level topic topic/message message/data data/prefix?)] + [(symbol? topic/message) + (do-log-message who logger level topic/message message/data data/prefix? #t)] + [else + (check who logger? logger) + (check-level who level) + (raise-argument-error who "(or/c string? symbol?)" topic/message)])] + [(logger level topic message data prefix?) + (do-log-message who logger level topic message data prefix?)])) + +;; Can be called in any host Scheme thread and in interrupt handler, +;; like `log-level?`: +(define (do-log-message who logger level topic message data prefix?) + (check who logger? logger) + (check-level who level) + (check who #:or-false symbol? topic) + (check who string? message) + (define msg #f) + (atomically/no-interrupts + (when ((logger-max-wanted-level logger) . level>=? . level) + (let loop ([logger logger]) + (for ([r (in-list (logger-receivers logger))]) + (when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level) + (unless msg + (set! msg (vector-immutable + level + (string->immutable-string + (if (and prefix? topic) + (string-append (symbol->string topic) + ": " + message) + message)) + data + topic))) + (log-receiver-send! r msg))) + (let ([parent (logger-parent logger)]) + (when (and parent + ((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level)) + (loop parent))))))) diff -Nru racket-6.12+ppa1/src/io/logger/receiver.rkt racket-7.0+ppa1/src/io/logger/receiver.rkt --- racket-6.12+ppa1/src/io/logger/receiver.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/receiver.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,134 @@ +#lang racket/base +(require "../common/check.rkt" + "../../common/queue.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/convert.rkt" + "level.rkt" + "logger.rkt") + +(provide (struct-out log-receiver) + make-log-receiver + add-stderr-log-receiver! + add-stdout-log-receiver! + log-receiver-send!) + +(struct log-receiver (filters)) + +(define-values (prop:receiver-send receiver-send? receiver-send-ref) + (make-struct-type-property 'receiver-send)) + +;; ---------------------------------------- + +(struct queue-log-receiver log-receiver (msgs ; queue of messages ready for `sync` [if `waiters` is null] + waiters) ; queue of (box callback) to receive ready messages [if `msgs` is null] + #:reflection-name 'log-receiver + #:property + prop:receiver-send + (lambda (lr msg) + ;; called in atomic mode and possibly in host interrupt handler, + ;; so anything we touch here should only be modified with + ;; interrupts disabled + (atomically/no-interrupts + (define b (queue-remove! (queue-log-receiver-waiters lr))) + (cond + [b + (define select! (unbox b)) + (set-box! b msg) + (select!)] + [else + (queue-add! (queue-log-receiver-msgs lr) msg)]))) + #:property + prop:evt + (poller (lambda (lr ctx) + (define msg (atomically/no-interrupts (queue-remove! (queue-log-receiver-msgs lr)))) + (cond + [msg + (values (list msg) #f)] + [else + (define b (box (poll-ctx-select-proc ctx))) + (define n (atomically/no-interrupts (queue-add! (queue-log-receiver-waiters lr) b))) + (values #f (control-state-evt + (wrap-evt async-evt (lambda (e) (unbox b))) + (lambda () (atomically/no-interrupts (queue-remove-node! (queue-log-receiver-waiters lr) n))) + void + (lambda () + (atomically/no-interrupts + (define msg (queue-remove! (queue-log-receiver-msgs lr))) + (cond + [msg + (set-box! b msg) + (values msg #t)] + [else + (set! n (queue-add! (queue-log-receiver-waiters lr) b)) + (values #f #f)])))))])))) + +(define/who (make-log-receiver logger level . args) + (check who logger? logger) + (define lr (queue-log-receiver (parse-filters 'make-log-receiver (cons level args) #:default-level 'none) + (make-queue) + (make-queue))) + (add-log-receiver! logger lr) + lr) + +;; ---------------------------------------- + +(struct stdio-log-receiver log-receiver (which) + #:property + prop:receiver-send + (lambda (lr msg) + ;; called in atomic mode and possibly in host interrupt handler + (define fd (rktio_std_fd rktio (stdio-log-receiver-which lr))) + (define bstr (bytes-append (string->bytes/utf-8 (vector-ref msg 1)) #"\n")) + (define len (bytes-length bstr)) + (let loop ([i 0]) + (define v (rktio_write_in rktio fd bstr i len)) + (unless (rktio-error? v) + (let ([i (+ i v)]) + (unless (= i len) + (loop i))))) + (rktio_forget rktio fd))) + +(define (add-stdio-log-receiver! who logger args parse-who which) + (check who logger? logger) + (define lr (stdio-log-receiver (parse-filters parse-who args #:default-level 'none) + which)) + (atomically + (add-log-receiver! logger lr) + (set-logger-permanent-receivers! logger (cons lr (logger-permanent-receivers logger))))) + +(define/who (add-stderr-log-receiver! logger . args) + (add-stdio-log-receiver! who logger args 'make-stderr-log-receiver RKTIO_STDERR)) + +(define/who (add-stdout-log-receiver! logger . args) + (add-stdio-log-receiver! who logger args 'make-stdio-log-receiver RKTIO_STDOUT)) + +;; ---------------------------------------- + +(define (add-log-receiver! logger lr) + (atomically/no-interrupts + ;; Add receiver to the logger's list, purning empty boxes + ;; every time the list length doubles (roughly): + (cond + [(zero? (logger-prune-counter logger)) + (set-logger-receiver-boxes! logger (cons (make-weak-box lr) + (for/list ([b (in-list (logger-receiver-boxes logger))] + #:when (weak-box-value b)) + b))) + (set-logger-prune-counter! logger (max 8 (length (logger-receiver-boxes logger))))] + [else + (set-logger-receiver-boxes! logger (cons (make-weak-box lr) (logger-receiver-boxes logger))) + (set-logger-prune-counter! logger (sub1 (logger-prune-counter logger)))]) + ;; Increment the timestamp, so that wanted levels will be + ;; recomputed on demand: + (define ts-box (logger-root-level-timestamp-box logger)) + (set-box! ts-box (add1 (unbox ts-box))) + ;; Post a semaphore to report that wanted levels may have + ;; changed: + (when (logger-level-sema logger) + (semaphore-post (logger-level-sema logger)) + (set-logger-level-sema! logger #f)))) + +;; Called in atomic mode and with interrupts disabled +(define (log-receiver-send! r msg) + ((receiver-send-ref r) r msg)) diff -Nru racket-6.12+ppa1/src/io/logger/wanted.rkt racket-7.0+ppa1/src/io/logger/wanted.rkt --- racket-6.12+ppa1/src/io/logger/wanted.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/logger/wanted.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,96 @@ +#lang racket/base +(require "../host/thread.rkt" + "logger.rkt" + "receiver.rkt" + "level.rkt") + +(provide logger-wanted-level + logger-max-wanted-level + logger-all-levels) + +(define (logger-wanted-level logger topic) + (atomically/no-interrupts + (cond + [(not topic) (logger-max-wanted-level logger)] + [else + (cond + [((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + ;; Cache is up-to-date, so search it + (define cache (logger-topic-level-cache logger)) + (or (for/or ([i (in-range 0 (vector-length cache) 2)]) + (and (eq? (vector-ref cache i) topic) + (vector-ref cache (add1 i)))) + ;; Didn't find in cache, so update the cache + (begin + (update-logger-wanted-level! logger topic) + (logger-wanted-level logger topic)))] + [else + ;; Update the cache and retry: + (update-logger-wanted-level! logger topic) + (logger-wanted-level logger topic)])]))) + +(define (logger-max-wanted-level logger) + (atomically/no-interrupts + (cond + [((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + ;; Ccahed value is up-to-date + (logger-max-receiver-level logger)] + [else + ;; Traverse to set cache: + (update-logger-wanted-level! logger #f) + (logger-max-receiver-level logger)]))) + +(define (update-logger-wanted-level! logger topic) + (unless ((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + (define cache (logger-topic-level-cache logger)) + (for/or ([i (in-range 0 (vector-length cache) 2)]) + (vector-set! cache i #f)) + (set-logger-local-level-timestamp! logger (unbox (logger-root-level-timestamp-box logger)))) + ;; As we traverse the parent chain, keep track of the "ceiling" + ;; level as the maximum level that would be propagated; for any + ;; receiver, clip the wanted levels to that ceiling. + (let loop ([parent logger] [ceiling-level 'debug] [old-max-level 'none] [old-topic-max-level 'none]) + (define-values (max-level topic-max-level) + (for/fold ([max-level old-max-level] [topic-max-level old-topic-max-level]) + ([r (in-list (logger-receivers parent))] + #:break (and (max-level . level>=? . ceiling-level) + (or (not topic) + (topic-max-level . level>=? . ceiling-level)))) + (values (level-max max-level + (level-min (filters-max-level (log-receiver-filters r)) + ceiling-level)) + (and topic + (level-max topic-max-level + (level-min (filters-level-for-topic (log-receiver-filters r) topic) + ceiling-level)))))) + (cond + [(and (or (ceiling-level . level>=? . max-level) + (and topic (ceiling-level . level>=? . topic-max-level))) + (logger-parent parent)) + => (lambda (next-parent) + (let ([ceiling-level (level-min ceiling-level (filters-max-level (logger-propagate-filters parent)))]) + (loop next-parent ceiling-level max-level topic-max-level)))] + [else + ;; No more parents, so save the result + (set-logger-max-receiver-level! logger max-level) + (when topic + (define cache (logger-topic-level-cache logger)) + (or + ;; Look for empty cache slot: + (for/or ([i (in-range 0 (vector-length cache) 2)]) + (and (not (vector-ref cache i)) + (begin + (vector-set! cache i topic) + (vector-set! cache (add1 i) topic-max-level)) + #t)) + ;; Rotate cache and put new value at start + (begin + (for ([i (in-range 0 (- (vector-length cache) 2) 2)]) + (vector-set! cache (+ i 2) (vector-ref cache i)) + (vector-set! cache (+ i 3) (vector-ref cache (+ i 1)))) + (vector-set! cache 0 topic) + (vector-set! cache 1 topic-max-level))))]))) + + +(define (logger-all-levels logger) + '(none #f)) diff -Nru racket-6.12+ppa1/src/io/main.rkt racket-7.0+ppa1/src/io/main.rkt --- racket-6.12+ppa1/src/io/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,43 @@ +#lang racket/base +(require "sandman/main.rkt" + "port/main.rkt" + "path/main.rkt" + "string/main.rkt" + "converter/main.rkt" + "locale/main.rkt" + "format/main.rkt" + "print/main.rkt" + "error/main.rkt" + "srcloc/main.rkt" + "logger/main.rkt" + "file/main.rkt" + "filesystem-change-evt/main.rkt" + "security/main.rkt" + "envvar/main.rkt" + "subprocess/main.rkt" + "network/main.rkt" + "foreign/main.rkt" + "unsafe/main.rkt" + "run/main.rkt") + +(provide (all-from-out "port/main.rkt") + (all-from-out "path/main.rkt") + (all-from-out "string/main.rkt") + (all-from-out "converter/main.rkt") + (all-from-out "locale/main.rkt") + (all-from-out "format/main.rkt") + (all-from-out "print/main.rkt") + (all-from-out "error/main.rkt") + (all-from-out "srcloc/main.rkt") + (all-from-out "logger/main.rkt") + (all-from-out "file/main.rkt") + (all-from-out "filesystem-change-evt/main.rkt") + (all-from-out "security/main.rkt") + (all-from-out "envvar/main.rkt") + (all-from-out "subprocess/main.rkt") + (all-from-out "network/main.rkt") + (all-from-out "foreign/main.rkt") + (all-from-out "unsafe/main.rkt") + (all-from-out "run/main.rkt")) + +(module main racket/base) diff -Nru racket-6.12+ppa1/src/io/Makefile racket-7.0+ppa1/src/io/Makefile --- racket-6.12+ppa1/src/io/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,51 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++pure ../../collects/racket/private/collect.rkt + +# Can be set to empty to avoid building rktio +RKTIO_DEP=../build/so-rktio/Makefile + +io-src: $(RKTIO_DEP) + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) io-src-generate + +GENERATE_ARGS = -t main.rkt --submod main \ + --check-depends $(BUILDDIR)compiled/io-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + ++depend ../rktio/rktio.rktl \ + --depends $(BUILDDIR)compiled/io-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/io.rktl $(BUILDDIR)compiled/io.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/io.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +io-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: $(RKTIO_DEP) + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +demo-thread: $(RKTIO_DEP) + $(RACO) make demo-thread.rkt + $(RACKET) demo-thread.rkt + + +../build/so-rktio/Makefile: ../rktio/configure ../rktio/Makefile.in ../rktio/rktio_config.h.in + mkdir -p ../build/so-rktio + $(MAKE) build-rktio RACKET="`$(RACKET) ../cs/absify.rkt --exec $(RACKET)`" PREFIX="`$(RACKET) ../cs/absify.rkt ../..`" + +build-rktio: + cd ../build/so-rktio; ../../rktio/configure --enable-standalone --prefix=$(PREFIX) + cd ../build/so-rktio; make install-shared-object + + +.PHONY: io-src io-src-generate demo rktio build-rktio diff -Nru racket-6.12+ppa1/src/io/network/address.rkt racket-7.0+ppa1/src/io/network/address.rkt --- racket-6.12+ppa1/src/io/network/address.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/address.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,93 @@ +#lang racket/base +(require "../common/resource.rkt" + "../string/convert.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "evt.rkt" + "error.rkt") + +(provide call-with-resolved-address + register-address-finalizer) + +;; in atomic mode +(define (call-with-resolved-address hostname port-no proc + #:who [who #f] ; not #f => report errors + #:which [which ""] ; for error reporting, including trailing space + #:port-number-on-error? [port-number-on-error? #t] + #:enable-break? [enable-break? #f] + #:family [family RKTIO_FAMILY_ANY] + #:passive? [passive? #f] + #:tcp? [tcp? #t] + #:retain-address? [retain-address? #f]) + (poll-address-finalizations) + (cond + [(and (not hostname) + (not port-no)) + (proc #f)] + [else + (call-with-resource + (box (rktio_start_addrinfo_lookup rktio + (and hostname (string->bytes/utf-8 hostname)) + (or port-no 0) + family passive? tcp?)) + ;; in atomic mode + (lambda (lookup-box) + (define lookup (unbox lookup-box)) + (when lookup + (rktio_addrinfo_lookup_stop lookup))) + ;; in atomic mode + (lambda (lookup-box) + (define lookup (unbox lookup-box)) + (let loop () + (cond + [(and (not (rktio-error? lookup)) + (eqv? (rktio_poll_addrinfo_lookup_ready rktio lookup) + RKTIO_POLL_NOT_READY)) + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (not (eqv? (rktio_poll_addrinfo_lookup_ready rktio lookup) + RKTIO_POLL_NOT_READY))) + (lambda (ps) + (rktio_poll_add_addrinfo_lookup rktio lookup ps)))) + (start-atomic) + (loop)] + [else + (set-box! lookup-box #f) ; receiving result implies `lookup` is destroyed + (call-with-resource + (if (rktio-error? lookup) + lookup + (rktio_addrinfo_lookup_get rktio lookup)) + ;; in atomic mode + (lambda (addr) (rktio_addrinfo_free rktio addr)) + ;; in atomic mode + (lambda (addr) + (cond + [(and who (rktio-error? addr)) + (raise-network-error who addr (string-append + "can't resolve " which "address" + "\n address: " (or hostname "") + (if (and port-number-on-error? port-no) + (string-append "\n port number: " (number->string port-no)) + "")))] + [else + ;; `addr` may be an error; if so, let `proc` handle it + (begin0 + (proc addr) + (unless retain-address? + (rktio_addrinfo_free rktio addr)))])))]))))])) + +;; ---------------------------------------- + +(define address-will-executor (make-will-executor)) + +(define (register-address-finalizer addr) + (will-register address-will-executor + addr + (lambda (addr) + (rktio_addrinfo_free rktio addr) + #t))) + +(define (poll-address-finalizations) + (when (will-try-execute address-will-executor) + (poll-address-finalizations))) diff -Nru racket-6.12+ppa1/src/io/network/check.rkt racket-7.0+ppa1/src/io/network/check.rkt --- racket-6.12+ppa1/src/io/network/check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide check-bstr) + +(define (check-bstr who bstr start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (define len (bytes-length bstr)) + (unless (<= 0 start len) + (raise-range-error who "byte string" "starting " start bstr 0 len #f)) + (unless (<= start end len) + (raise-range-error who "byte string" "ending " end bstr 0 len start))) diff -Nru racket-6.12+ppa1/src/io/network/error.rkt racket-7.0+ppa1/src/io/network/error.rkt --- racket-6.12+ppa1/src/io/network/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt") + +(provide raise-network-error + raise-network-arguments-error) + +(define (raise-network-error who orig-err base-msg) + (define err (remap-rktio-error orig-err)) + (define msg (format-rktio-message who err base-msg)) + (raise + (cond + [(not (eq? (rktio-errkind err) RKTIO_ERROR_KIND_RACKET)) + (exn:fail:network:errno + msg + (current-continuation-marks) + (cons (rktio-errno err) + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) 'posix] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) 'windows] + [(eqv? kind RKTIO_ERROR_KIND_GAI) 'gai] + [else (error 'raise-network-error "confused about rktio error")]))))] + [else + (exn:fail:network + msg + (current-continuation-marks))]))) + +(define (raise-network-arguments-error who msg socket-str u) + (unless (equal? socket-str "socket") + (raise-argument-error 'raise-network-arguments-error + "\"socket\"" + socket-str)) + (raise + (exn:fail:network + (string-append (symbol->string who) ": " msg + "\n socket: " + ((error-value->string-handler) u (error-print-width))) + (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/src/io/network/evt.rkt racket-7.0+ppa1/src/io/network/evt.rkt --- racket-6.12+ppa1/src/io/network/evt.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/evt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,26 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/thread.rkt" + "../sandman/main.rkt") + +(provide rktio-evt) + +(struct rktio-evt (poll add-to-poll-set) + #:property + prop:evt + (poller + (lambda (self poll-ctx) + (cond + [((rktio-evt-poll self)) + (values (list self) #f)] + [else + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + ;; Cooperate with the sandman by registering a function that + ;; takes a poll set and adds to it: + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + (rktio-evt-add-to-poll-set self)))) + (values #f self)]))) + #:authentic) diff -Nru racket-6.12+ppa1/src/io/network/main.rkt racket-7.0+ppa1/src/io/network/main.rkt --- racket-6.12+ppa1/src/io/network/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require "tcp.rkt" + "udp.rkt") + +(provide (all-from-out "tcp.rkt") + (all-from-out "udp.rkt")) diff -Nru racket-6.12+ppa1/src/io/network/port-number.rkt racket-7.0+ppa1/src/io/network/port-number.rkt --- racket-6.12+ppa1/src/io/network/port-number.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/port-number.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang racket/base + +(provide port-number? + listen-port-number?) + +(define (port-number? v) + (and (fixnum? v) + (<= 1 v 65535))) + +(define (listen-port-number? v) + (and (fixnum? v) + (<= 0 v 65535))) diff -Nru racket-6.12+ppa1/src/io/network/tcp-accept.rkt racket-7.0+ppa1/src/io/network/tcp-accept.rkt --- racket-6.12+ppa1/src/io/network/tcp-accept.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp-accept.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,128 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "tcp-listen.rkt" + "tcp-port.rkt" + "evt.rkt" + "error.rkt") + +(provide tcp-accept + tcp-accept/enable-break + tcp-accept-evt + tcp-accept-ready?) + +(define/who (tcp-accept listener) + (do-tcp-accept who listener)) + +(define/who (tcp-accept/enable-break listener) + (do-tcp-accept who #:enable-break? #t listener)) + +(define (do-tcp-accept who listener + #:enable-break? [enable-break? #f]) + (check who tcp-listener? listener) + (let loop () + (start-atomic) + (cond + [(tcp-listener-closed? listener) + (closed-error who listener)] + [(accept-ready? listener) + (check-current-custodian who) + (define fd (rktio_accept rktio (tcp-listener-lnr listener))) + (cond + [(rktio-error? fd) + (end-atomic) + (raise-network-error who fd "accept from listener failed")] + [else + (begin0 + (open-input-output-accetped-tcp fd) + (end-atomic))])] + [else + (end-atomic) + (sync (rktio-evt + ;; in atomic mode + (lambda () + (or (tcp-listener-closed? listener) + (accept-ready? listener))) + ;; in atomic mode + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr listener) ps)))) + (loop)]))) + +(define/who (tcp-accept-ready? listener) + (check who tcp-listener? listener) + (start-atomic) + (cond + [(tcp-listener-closed? listener) + (closed-error who listener)] + [else (accept-ready? listener)])) + +;; ---------------------------------------- + +(define/who (tcp-accept-evt listener) + (check who tcp-listener? listener) + (accept-evt listener)) + +(struct accept-evt (listener) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define listener (accept-evt-listener self)) + (cond + [(tcp-listener-closed? listener) + (error-result (lambda () + (start-atomic) + (closed-error 'tcp-accept-evt listener)))] + [(custodian-shut-down? (current-custodian)) + (let ([c (current-custodian)]) + (error-result (lambda () + (start-atomic) + (parameterize ([current-custodian c]) + (check-current-custodian 'tcp-accept-evt)))))] + [(accept-ready? listener) + (define fd (rktio_accept rktio (tcp-listener-lnr listener))) + (cond + [(rktio-error? fd) + (end-atomic) + (error-result (lambda () + (raise-network-error 'tcp-accept-evt fd "accept from listener failed")))] + [else + (values (list (call-with-values (lambda () (open-input-output-accetped-tcp fd)) + list)) + #f)])] + [else + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr listener) ps))))) + (values #f self)]))) + #:reflection-name 'tcp-accept-evt) + +(define (error-result thunk) + (values #f + (wrap-evt always-evt (lambda (v) (thunk))))) + +;; ---------------------------------------- + +;; in atomic mode +;; assumes that listener is not closed +(define (accept-ready? listener) + (not (eqv? (rktio_poll_accept_ready rktio (tcp-listener-lnr listener)) + RKTIO_POLL_NOT_READY))) + +;; in atomic mode +(define (closed-error who listener) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" listener)) + +;; in atomic mode +(define (open-input-output-accetped-tcp fd) + (open-input-output-tcp fd "tcp-accepted")) diff -Nru racket-6.12+ppa1/src/io/network/tcp-address.rkt racket-7.0+ppa1/src/io/network/tcp-address.rkt --- racket-6.12+ppa1/src/io/network/tcp-address.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp-address.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/check.rkt" + "../string/convert.rkt" + "../string/integer.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../port/close.rkt" + "../port/fd-port.rkt" + "tcp-port.rkt" + "tcp-listen.rkt" + "udp-socket.rkt" + "error.rkt") + +(provide tcp-addresses) + +(define/who (tcp-addresses p [port-numbers? #f]) + (check who (lambda (p) (or (tcp-port? p) (tcp-listener? p) (udp? p))) + #:contract "(or/c tcp-port? tcp-listener? udp?)" + p) + (start-atomic) + (define-values (local-address peer-address) + (cond + [(tcp-listener? p) + (cond + [(tcp-listener-closed? p) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" p)] + [else + (values (rktio_listener_address rktio (tcp-listener-lnr p)) + #f)])] + [else + (define fd + (cond + [(udp? p) + (check-udp-closed who p) + (udp-s p)] + [(port-closed? p) + (end-atomic) + (raise-arguments-error who + "port is closed" + "port" p)] + [else (fd-port-fd p)])) + (values (rktio_socket_address rktio fd) + (rktio_socket_peer_address rktio fd))])) + (define local-address-bytes (and (not (rktio-error? local-address)) + (rktio_to_bytes_list local-address 2))) + (define peer-address-bytes (and peer-address + (not (rktio-error? peer-address)) + (rktio_to_bytes_list peer-address 2))) + (end-atomic) + + (when (rktio-error? local-address) + (raise-network-error who local-address "could not get address")) + (when (and (rktio-error? peer-address) + ;; It's ok for the peer-address request to fail for UDP sockets + (not (udp? p))) + (raise-network-error who peer-address "could not get peer address")) + + (define (convert bstr) (bytes->string/utf-8 bstr #\?)) + (define local-hostname (convert (car local-address-bytes))) + (define peer-hostname (if peer-address-bytes + (convert (car peer-address-bytes)) + "0.0.0.0")) + + (cond + [port-numbers? + (values local-hostname + (string->integer (convert (cadr local-address-bytes))) + peer-hostname + (if peer-address-bytes + (string->integer (convert (cadr peer-address-bytes))) + 0))] + [else + (values local-hostname peer-hostname)])) diff -Nru racket-6.12+ppa1/src/io/network/tcp-connect.rkt racket-7.0+ppa1/src/io/network/tcp-connect.rkt --- racket-6.12+ppa1/src/io/network/tcp-connect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp-connect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,109 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/resource.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../security/main.rkt" + "../format/main.rkt" + "tcp-port.rkt" + "port-number.rkt" + "address.rkt" + "evt.rkt" + "error.rkt") + +(provide tcp-connect + tcp-connect/enable-break) + +(define/who (tcp-connect hostname port-no [local-hostname #f] [local-port-no #f]) + (do-tcp-connect who hostname port-no local-hostname local-port-no)) + +(define/who (tcp-connect/enable-break hostname port-no [local-hostname #f] [local-port-no #f]) + (do-tcp-connect who #:enable-break? #t hostname port-no local-hostname local-port-no)) + +(define (do-tcp-connect who hostname port-no [local-hostname #f] [local-port-no #f] + #:enable-break? [enable-break? #f]) + (check who string? hostname) + (check who port-number? port-no) + (check who string? #:or-false local-hostname) + (check who port-number? #:or-false local-port-no) + (when (and local-hostname (not local-port-no)) + (raise-arguments-error who + "no local port number supplied when local hostname was supplied" + "hostname" local-hostname)) + ;; in atomic mode (but exits atomic mode to raise an exception) + (define (raise-connect-error err + [what "connection failed"] + [hostname hostname] + [port-no port-no]) + (end-atomic) + (raise-network-error who err + (string-append what + (if hostname + (format "\n hostname: ~a" hostname) + "") + (if port-no + (format "\n port number: ~a" port-no) + "")))) + (security-guard-check-network who hostname port-no #t) + (atomically + (call-with-resolved-address + hostname port-no + #:enable-break? enable-break? + ;; in atomic mode + (lambda (remote-addr) + (cond + [(rktio-error? remote-addr) + (raise-connect-error remote-addr "host not found")] + [else + (call-with-resolved-address + local-hostname local-port-no + #:enable-break? enable-break? + ;; in atomic mode + (lambda (local-addr) + (cond + [(rktio-error? local-addr) + (raise-connect-error local-addr "local host not found" local-hostname local-port-no)] + [else + (call-with-resource + (box (rktio_start_connect rktio remote-addr local-addr)) + ;; in atomic mode + (lambda (conn-box) + (define conn (unbox conn-box)) + (when conn + (rktio_connect_stop rktio conn))) + ;; in atomic mode + (lambda (conn-box) + (define conn (unbox conn-box)) + (cond + [(rktio-error? conn) + (raise-connect-error conn)] + [else + (let loop () + (cond + [(eqv? (rktio_poll_connect_ready rktio conn) + RKTIO_POLL_NOT_READY) + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (not (eqv? (rktio_poll_connect_ready rktio conn) + RKTIO_POLL_NOT_READY))) + (lambda (ps) + (rktio_poll_add_connect rktio conn ps)))) + (start-atomic) + (loop)] + [else + (check-current-custodian who) + (define fd (rktio_connect_finish rktio conn)) + (cond + [(rktio-error? fd) + (cond + [(racket-error? fd RKTIO_ERROR_CONNECT_TRYING_NEXT) + (loop)] + [else + ;; other errors imply that `conn` is destroyed + (set-box! conn-box #f) + (raise-connect-error fd)])] + [else + (define name (string->immutable-string hostname)) + (open-input-output-tcp fd name)])]))])))])))]))))) diff -Nru racket-6.12+ppa1/src/io/network/tcp-listen.rkt racket-7.0+ppa1/src/io/network/tcp-listen.rkt --- racket-6.12+ppa1/src/io/network/tcp-listen.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp-listen.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,110 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../security/main.rkt" + "../sandman/main.rkt" + "port-number.rkt" + "address.rkt" + "error.rkt") + +(provide tcp-listen + tcp-listener? + tcp-close + + tcp-listener-lnr + tcp-listener-closed?) + +(struct tcp-listener (lnr + closed ; boxed boolean + custodian-reference) + #:authentic + #:property prop:evt (poller (lambda (l ctx) (poll-listener l ctx)))) + +(define/who (tcp-listen port-no [max-allow-wait 4] [reuse? #f] [hostname #f]) + (check who listen-port-number? port-no) + (check who exact-nonnegative-integer? max-allow-wait) + (check who string? #:or-false hostname) + (define (raise-listen-error what err) + (end-atomic) + (raise-network-error who err + (string-append what + (if hostname + (format "\n hostname: ~a" hostname) + "") + (format "\n port number: ~a" port-no)))) + (security-guard-check-network who hostname port-no #f) + (let loop ([family RKTIO_FAMILY_ANY]) + ((atomically + ;; Result is a thunk that might call `loop` + ;; or might return a listener + (call-with-resolved-address + hostname port-no + ;; in atomic mode + (lambda (addr) + (cond + [(rktio-error? addr) + (raise-listen-error "address-resolution error" addr)] + [else + (check-current-custodian who) + (define lnr (rktio_listen rktio addr (min max-allow-wait 10000) reuse?)) + (cond + [(rktio-error? lnr) + (cond + [(racket-error? lnr RKTIO_ERROR_TRY_AGAIN_WITH_IPV4) + (lambda () (loop (rktio_get_ipv4_family rktio)))] + [else + (raise-listen-error "listen failed" lnr)])] + [else + (define closed (box #f)) + (define custodian-reference + (unsafe-custodian-register (current-custodian) + lnr + ;; in atomic mode + (lambda (fd) (do-tcp-close lnr closed)) + #f + #f)) + (lambda () + (tcp-listener lnr closed custodian-reference))])]))))))) + +; in atomic mode +(define (do-tcp-close lnr closed) + (rktio_listen_stop rktio lnr) + (set-box! closed #t)) + +(define/who (tcp-close listener) + (check who tcp-listener? listener) + (define closed (tcp-listener-closed listener)) + (start-atomic) + (cond + [(unbox closed) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" listener)] + [else + (define lnr (tcp-listener-lnr listener)) + (do-tcp-close lnr closed) + (unsafe-custodian-unregister lnr (tcp-listener-custodian-reference listener)) + (end-atomic)])) + +;; in atomic mode +(define (tcp-listener-closed? listener) + (unbox (tcp-listener-closed listener))) + +;; ---------------------------------------- + +;; in atomic mode +(define (poll-listener l ctx) + (cond + [(unbox (tcp-listener-closed l)) + (values (list l) #f)] + [(eqv? (rktio_poll_accept_ready rktio (tcp-listener-lnr l)) + RKTIO_POLL_READY) + (values (list l) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + ctx + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr l) ps))) + (values #f l)])) diff -Nru racket-6.12+ppa1/src/io/network/tcp-port.rkt racket-7.0+ppa1/src/io/network/tcp-port.rkt --- racket-6.12+ppa1/src/io/network/tcp-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,59 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/rktio.rkt" + "../port/port.rkt" + "../port/input-port.rkt" + "../port/output-port.rkt" + "../port/fd-port.rkt") + +(provide open-input-output-tcp + tcp-port? + tcp-abandon-port) + +(struct tcp-data (abandon-in? abandon-out?) + #:mutable + #:authentic) + +(define (open-input-output-tcp fd name #:close? [close? #t]) + (define refcount (box (if close? 2 3))) + (define extra-data (tcp-data #f #f)) + (values + (open-input-fd fd name + #:extra-data extra-data + #:on-close + ;; in atomic mode + (lambda () + (unless (tcp-data-abandon-in? extra-data) + (rktio_socket_shutdown rktio fd RKTIO_SHUTDOWN_READ))) + #:fd-refcount refcount) + (open-output-fd fd name + #:extra-data extra-data + #:on-close + ;; in atomic mode + (lambda () + (unless (tcp-data-abandon-out? extra-data) + (rktio_socket_shutdown rktio fd RKTIO_SHUTDOWN_WRITE))) + #:fd-refcount refcount + #:buffer-mode 'block))) + +(define (port-tcp-data p) + (maybe-fd-data-extra + (cond + [(input-port? p) + (core-port-data + (->core-input-port p))] + [(output-port? p) + (core-port-data + (->core-output-port p))] + [else #f]))) + +(define/who (tcp-port? p) + (tcp-data? (port-tcp-data p))) + +(define/who (tcp-abandon-port p) + (define data (port-tcp-data p)) + (unless (tcp-data? data) + (raise-argument-error who "tcp-port?" p)) + (if (input-port? p) + (set-tcp-data-abandon-in?! data #t) + (set-tcp-data-abandon-out?! data #t))) diff -Nru racket-6.12+ppa1/src/io/network/tcp.rkt racket-7.0+ppa1/src/io/network/tcp.rkt --- racket-6.12+ppa1/src/io/network/tcp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/tcp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base +(require "tcp-port.rkt" + "tcp-connect.rkt" + "tcp-listen.rkt" + "tcp-accept.rkt" + "tcp-address.rkt") + +(provide tcp-port? + tcp-abandon-port + + tcp-connect + tcp-connect/enable-break + + tcp-listen + tcp-listener? + tcp-close + + tcp-accept + tcp-accept-evt + tcp-accept-ready? + tcp-accept/enable-break + + tcp-addresses) diff -Nru racket-6.12+ppa1/src/io/network/udp-multicast.rkt racket-7.0+ppa1/src/io/network/udp-multicast.rkt --- racket-6.12+ppa1/src/io/network/udp-multicast.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/udp-multicast.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,143 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/convert.rkt" + "udp-socket.rkt" + "address.rkt" + "error.rkt") + +(provide udp-multicast-join-group! + udp-multicast-leave-group! + + udp-multicast-interface + udp-multicast-set-interface! + + udp-multicast-loopback? + udp-multicast-set-loopback! + + udp-multicast-ttl + udp-multicast-set-ttl!) + +;; ---------------------------------------- + +(define/who (udp-multicast-join-group! u + multicast-hostname + hostname) + (do-udp-multicast-join-or-leave-group! who + RKTIO_ADD_MEMBERSHIP + u + multicast-hostname + hostname)) + +(define/who (udp-multicast-leave-group! u + multicast-hostname + hostname) + (do-udp-multicast-join-or-leave-group! who + RKTIO_DROP_MEMBERSHIP + u + multicast-hostname + hostname)) + +(define (do-udp-multicast-join-or-leave-group! who action u multicast-hostname hostname) + (check who udp? u) + (check who string? multicast-hostname) + (check who string? #:or-false hostname) + (atomically + (call-with-resolved-address + #:who who + #:which "multicast " + #:port-number-on-error? #f + multicast-hostname -1 + #:family (udp-default-family) + #:tcp? #f + (lambda (multicast-addr) + (call-with-resolved-address + #:who who + #:which "interface " + #:port-number-on-error? #f + hostname (and hostname -1) + #:family (udp-default-family) + #:tcp? #f + (lambda (intf-addr) + (check-udp-closed who u) + (define v (rktio_udp_change_multicast_group rktio (udp-s u) multicast-addr intf-addr action)) + (when (rktio-error? v) + (raise-option-error who "set" v)))))))) + +(define (raise-option-error who mode v) + (end-atomic) + (raise-network-error who v (string-append mode "sockopt failed"))) + +;; ---------------------------------------- + +(define/who (udp-multicast-interface u) + (check who udp? u) + (start-atomic) + (check-udp-closed who u) + (define v (rktio_udp_multicast_interface rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else + (define bstr (rktio_to_bytes v)) + (rktio_free v) + (end-atomic) + (bytes->string/utf-8 bstr)])) + +(define/who (udp-multicast-set-interface! u hostname) + (check who udp? u) + (check who string? #:or-false hostname) + (atomically + (call-with-resolved-address + #:who who + #:port-number-on-error? #f + hostname (and hostname -1) + #:family (udp-default-family) + #:tcp? #f + (lambda (addr) + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_interface rktio (udp-s u) addr)) + (when (rktio-error? r) + (raise-option-error who "set" r)))))) + +;; ---------------------------------------- + +(define/who (udp-multicast-loopback? u) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define v (rktio_udp_get_multicast_loopback rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else (not (zero? v))]))) + +(define/who (udp-multicast-set-loopback! u loopback?) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_loopback rktio (udp-s u) loopback?)) + (when (rktio-error? r) + (raise-option-error who "set" r)))) + +;; ---------------------------------------- + +(define/who (udp-multicast-ttl u) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define v (rktio_udp_get_multicast_ttl rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else v]))) + +(define/who (udp-multicast-set-ttl! u ttl) + (check who udp? u) + (check who byte? ttl) + (atomically + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_ttl rktio (udp-s u) ttl)) + (when (rktio-error? r) + (raise-option-error who "set" r)))) diff -Nru racket-6.12+ppa1/src/io/network/udp-receive.rkt racket-7.0+ppa1/src/io/network/udp-receive.rkt --- racket-6.12+ppa1/src/io/network/udp-receive.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/udp-receive.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,155 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "../string/convert.rkt" + "../string/integer.rkt" + "port-number.rkt" + "check.rkt" + "address.rkt" + "udp-socket.rkt" + "error.rkt" + "evt.rkt") + +(provide udp-receive! + udp-receive!* + udp-receive!/enable-break + + udp-receive!-evt + udp-receive-ready-evt) + +(define/who (udp-receive! u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who u bstr start end)) + +(define/who (udp-receive!* u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who #:wait? #f u bstr start end)) + +(define/who (udp-receive!/enable-break u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who #:enable-break? #t u bstr start end)) + +(define (do-udp-receive! who u bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f]) + (check-receive! who u bstr start end) + (atomically + (do-udp-maybe-receive! who u bstr start end + #:wait? wait? + #:enable-break? enable-break?))) + +(define/who (udp-receive!-evt u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-receive! who u bstr start end) + (udp-receiving-evt + u + ;; in atomic mode: + (lambda () + (do-udp-maybe-receive! who u bstr start end + #:wait? #f + #:handle-error (lambda (thunk) thunk))))) + +(define/who (udp-receive-ready-evt u) + (check who udp? u) + (udp-receiving-ready-evt + (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_read_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_READ)))) + +(define (check-receive! who u bstr start end) + (check who udp? u) + (check-bstr who bstr start end)) + +;; ---------------------------------------- + +;; in atomic mode +(define (do-udp-maybe-receive! who u bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f] + #:handle-error [handle-error handle-error-immediately]) + (let loop () + ;; re-check closed on every iteration, in case the state changes + ;; while we block + (check-udp-closed + who u + #:handle-error handle-error + #:continue + (lambda () + (cond + [(not (udp-bound? u)) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is not bound" + "socket" u)))] + [else + (define r (rktio_udp_recvfrom_in rktio (udp-s u) bstr start end)) + (cond + [(rktio-error? r) + (cond + [(or (racket-error? r RKTIO_ERROR_TRY_AGAIN) + (racket-error? r RKTIO_ERROR_INFO_TRY_AGAIN)) + (cond + [wait? + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_read_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_READ)))) + (start-atomic) + (loop)] + [else (values #f #f #f)])] + [else + (handle-error + (lambda () + (raise-network-error who r "receive failed")))])] + [else + (define len (rktio_recv_length_ref r)) + (define address (rktio_to_bytes_list (rktio_recv_address_ref r) 2)) + (rktio_free r) + (values len + (if (bytes=? (car address) cached-address-bytes) + cached-address-string + (begin + (set! cached-address-bytes (car address)) + (set! cached-address-string (string->immutable-string + (bytes->string/utf-8 cached-address-bytes #\?))) + cached-address-string)) + (string->integer (bytes->string/utf-8 (cadr address))))])]))))) + +(define cached-address-bytes #"") +(define cached-address-string "") + +;; ---------------------------------------- + +(struct udp-receiving-evt (u try) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define try (udp-receiving-evt-try self)) + (call-with-values try + (case-lambda + [(thunk) + ;; `thunk` that raises an exception + (values #f (wrap-evt always-evt (lambda (v) (thunk))))] + [(r hostname port-no) + (cond + [r + (values (list (list r hostname port-no)) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + poll-ctx + (lambda (ps) + (rktio_poll_add rktio (udp-s (udp-receiving-evt-u self)) ps RKTIO_POLL_WRITE))) + (values #f self)])])))) + #:reflection-name 'udp-receive-evt + #:authentic) + +(struct udp-receiving-ready-evt rktio-evt () + #:reflection-name 'udp-receive-ready-evt + #:authentic) diff -Nru racket-6.12+ppa1/src/io/network/udp.rkt racket-7.0+ppa1/src/io/network/udp.rkt --- racket-6.12+ppa1/src/io/network/udp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/udp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +#lang racket/base +(require "udp-socket.rkt" + "udp-send.rkt" + "udp-receive.rkt" + "udp-multicast.rkt") + +(provide udp-open-socket + udp-close + udp? + udp-bound? + udp-connected? + udp-bind! + udp-connect! + + udp-send + udp-send* + udp-send-to/enable-break + udp-send-to + udp-send-to* + udp-send/enable-break + udp-send-evt + udp-send-to-evt + udp-send-ready-evt + + udp-receive! + udp-receive!* + udp-receive!/enable-break + udp-receive!-evt + udp-receive-ready-evt + + udp-multicast-join-group! + udp-multicast-leave-group! + udp-multicast-interface + udp-multicast-set-interface! + udp-multicast-loopback? + udp-multicast-set-loopback! + udp-multicast-ttl + udp-multicast-set-ttl!) diff -Nru racket-6.12+ppa1/src/io/network/udp-send.rkt racket-7.0+ppa1/src/io/network/udp-send.rkt --- racket-6.12+ppa1/src/io/network/udp-send.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/udp-send.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,199 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "../security/main.rkt" + "port-number.rkt" + "check.rkt" + "address.rkt" + "udp-socket.rkt" + "error.rkt" + "evt.rkt") + +(provide udp-send + udp-send* + udp-send-to/enable-break + + udp-send-to + udp-send-to* + udp-send/enable-break + + udp-send-evt + udp-send-to-evt + udp-send-ready-evt) + +(define/who (udp-send u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who u #f #f bstr start end)) + +(define/who (udp-send* u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who #:wait? #f u #f #f bstr start end)) + +(define/who (udp-send/enable-break u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who #:enable-break? #t u #f #f bstr start end)) + +(define/who (udp-send-to u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who u hostname port-no bstr start end)) + +(define/who (udp-send-to* u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who #:wait? #f u hostname port-no bstr start end)) + +(define/who (udp-send-to/enable-break u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who #:enable-break? #t u hostname port-no bstr start end)) + +(define/who (udp-send-evt u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to-evt who u #f #f bstr start end)) + +(define/who (udp-send-to-evt u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to-evt who u hostname port-no bstr start end)) + +(define/who (udp-send-ready-evt u) + (check who udp? u) + (udp-sending-ready-evt + (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_write_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_WRITE)))) + +;; ---------------------------------------- + +(define (check-send who u bstr start end) + (check who udp? u) + (check-bstr who bstr start end)) + +(define (check-send-to who u hostname port-no bstr start end) + (check who udp? u) + (check who string? hostname) + (check who port-number? port-no) + (check-bstr who bstr start end) + (security-guard-check-network who hostname port-no #t)) + +;; ---------------------------------------- + +(define (do-udp-send-to who u hostname port-no bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f]) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + (lambda (addr) + (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? wait? + #:enable-break? enable-break?))))) + +(define (do-udp-send-to-evt who u hostname port-no bstr start end) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + #:retain-address? #t + (lambda (addr) + ;; FIXME: need to finalize `addr` + (udp-sending-evt + u + ;; in atomic mode: + (lambda () + (when addr (register-address-finalizer addr)) + (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? #f + #:handle-error (lambda (thunk) thunk)))))))) + +; in atomic mode +(define (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f] + #:handle-error [handle-error handle-error-immediately]) + (let loop () + ;; re-check closed, connected, etc., on every iteration, + ;; in case the state changes while we block + (check-udp-closed + who u + #:handle-error handle-error + #:continue + (lambda () + (cond + [(and addr (udp-connected? u)) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is connected" + "socket" u)))] + [(and (not addr) (not (udp-connected? u))) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is not connected" + "socket" u)))] + [else + ;; if the socket is not bound already, send[to] binds it + (set-udp-bound?! u #t) + (define r (rktio_udp_sendto_in rktio (udp-s u) addr bstr start end)) + (cond + [(rktio-error? r) + (handle-error + (lambda () + (raise-network-error who r "send failed")))] + [(eqv? r 0) + (cond + [(not wait?) #f] + [else + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_write_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_WRITE)))) + (start-atomic) + (loop)])] + [(= r (- end start)) (if wait? (void) #t)] + [else + (handle-error + (lambda () + (raise + (exn:fail:network + (string-append (symbol->string who) ": didn't send enough" + "\n requested bytes: " (number->string (- end start)) + "\n sent bytes: " r) + (current-continuation-marks)))))])]))))) + +;; ---------------------------------------- + +(struct udp-sending-evt (u try) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define try (udp-sending-evt-try self)) + (define r (try)) + (cond + [(procedure? r) + ;; `r` is a thunk that raises an exception + (values #f (wrap-evt always-evt (lambda (v) (r))))] + [r + (values (list (void)) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + poll-ctx + (lambda (ps) + (rktio_poll_add rktio (udp-s (udp-sending-evt-u self)) ps RKTIO_POLL_READ))) + (values #f self)]))) + #:reflection-name 'udp-send-evt + #:authentic) + +(struct udp-sending-ready-evt rktio-evt () + #:reflection-name 'udp-send-ready-evt + #:authentic) diff -Nru racket-6.12+ppa1/src/io/network/udp-socket.rkt racket-7.0+ppa1/src/io/network/udp-socket.rkt --- racket-6.12+ppa1/src/io/network/udp-socket.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/network/udp-socket.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,145 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../security/main.rkt" + "port-number.rkt" + "address.rkt" + "error.rkt") + +(provide udp? + udp-open-socket + udp-close + + udp-bound? + udp-connected? + + udp-bind! + udp-connect! + + check-udp-closed + handle-error-immediately + udp-default-family + + udp-s + set-udp-bound?! + set-udp-connected?!) + +(struct udp (s bound? connected?) + #:mutable + #:authentic) + +(define/who (udp-open-socket [family-hostname #f] [family-port-no #f]) + (check who string? #:or-false family-hostname) + (check who port-number? #:or-false family-port-no) + (security-guard-check-network who family-hostname family-port-no #f) + (atomically + (call-with-resolved-address + #:who who + family-hostname family-port-no + #:tcp? #f + (lambda (addr) + (define s (rktio_udp_open rktio addr (udp-default-family))) + (cond + [(rktio-error? s) + (end-atomic) + (raise-network-error who s "creation failed")] + [else + (udp s #f #f)]))))) + +(define/who (udp-close u) + (check who udp? u) + (atomically + (cond + [(udp-s u) + (rktio_close rktio (udp-s u)) + (set-udp-s! u #f)] + [else + (end-atomic) + (raise-network-arguments-error who "udp socket was already closed" + "socket" u)]))) + +;; ---------------------------------------- + +(define/who (udp-bind! u hostname port-no [reuse? #f]) + (check who udp? u) + (check who string? #:or-false hostname) + (check who listen-port-number? port-no) + (security-guard-check-network who hostname port-no #f) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + #:passive? #t + (lambda (addr) + (check-udp-closed who u) + (when (udp-bound? u) + (end-atomic) + (raise-arguments-error who "udp socket is already bound" + "socket" u)) + (define b (rktio_udp_bind rktio (udp-s u) addr reuse?)) + (when (rktio-error? b) + (end-atomic) + (raise-network-error who b + (string-append "can't bind" (if reuse? " as reusable" "") + "\n address: " (or hostname "") + "\n port number: " (number->string port-no)))) + (set-udp-bound?! u #t))))) + +(define/who (udp-connect! u hostname port-no) + (check who udp? u) + (check who string? #:or-false hostname) + (check who port-number? #:or-false port-no) + (unless (eq? (not hostname) (not port-no)) + (raise-arguments-error who + "last second and third arguments must be both #f or both non-#f" + "second argument" hostname + "third argument" port-no)) + (security-guard-check-network who hostname port-no #t) + (atomically + (cond + [(not hostname) + (check-udp-closed who u) + (when (udp-connected? u) + (define d (rktio_udp_disconnect rktio (udp-s u))) + (when (rktio-error? d) + (end-atomic) + (raise-network-error who d "can't disconnect")) + (set-udp-connected?! u #f))] + [else + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + (lambda (addr) + (check-udp-closed who u) + (define c (rktio_udp_connect rktio (udp-s u) addr)) + (when (rktio-error? c) + (end-atomic) + (raise-network-error who c + (string-append "can't connect" + "\n address: " hostname + "\n port number: " (number->string port-no)))) + (set-udp-connected?! u #t)))]))) + +;; ---------------------------------------- + +;; in atomic mode +(define (check-udp-closed who u + #:handle-error [handle-error handle-error-immediately] + #:continue [continue void]) + (cond + [(udp-s u) (continue)] + [else + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is closed" + "socket" u)))])) + +(define (handle-error-immediately thunk) + (end-atomic) + (thunk)) + +(define (udp-default-family) + (rktio_get_ipv4_family rktio)) diff -Nru racket-6.12+ppa1/src/io/path/api.rkt racket-7.0+ppa1/src/io/path/api.rkt --- racket-6.12+ppa1/src/io/path/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,53 @@ +#lang racket/base +(require "../common/check.rkt" + "../security/main.rkt" + "../file/host.rkt" + (prefix-in raw: "parameter.rkt") + (rename-in "complete.rkt" + [path->complete-path raw:path->complete-path]) + (only-in '#%kernel + ;; get `chaperone-procedure` that doesn't support keyword arguments: + chaperone-procedure) + "path.rkt") + +(provide path->complete-path + current-drive + + current-directory + current-directory-for-user + current-load-relative-directory) + +(define path->complete-path + (case-lambda + [(p) + ;; Supplying `current-directory` (as opposed to `raw:current-directory`) + ;; triggers an appropriate security-guard check if needed: + (raw:path->complete-path p current-directory #:wrt-given? #f)] + [(p wrt) (raw:path->complete-path p wrt #:wrt-given? #t)])) + +(define/who (current-drive) + (security-guard-check-file who #f '(exists)) + (if (eq? (system-path-convention-type) 'unix) + (string->path "/") + (error who "not yet ready"))) + +;; ---------------------------------------- + +(define (make-guard-paths who) + (case-lambda + [() + (security-guard-check-file who #f '(exists)) + (values)] + [(path) + (when (path-string? path) + (->host path who '(exists))) + path])) + +(define/who current-directory + (chaperone-procedure raw:current-directory (make-guard-paths who))) + +(define/who current-directory-for-user + (chaperone-procedure raw:current-directory-for-user (make-guard-paths who))) + +(define/who current-load-relative-directory + (chaperone-procedure raw:current-load-relative-directory (make-guard-paths who))) diff -Nru racket-6.12+ppa1/src/io/path/build.rkt racket-7.0+ppa1/src/io/path/build.rkt --- racket-6.12+ppa1/src/io/path/build.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/build.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,445 @@ +#lang racket/base +(require "../locale/string.rkt" + "../format/main.rkt" + "check.rkt" + "path.rkt" + "sep.rkt" + "windows.rkt") + +(provide build-path + build-path/convention-type) + +(define (build-path base . subs) + (build 'build-path #f base subs)) + +(define (build-path/convention-type convention base . subs) + (build 'build-path/convention-type convention base subs)) + +(define (build who init-convention base subs) + (check-build-path-arg who base) + (define convention + (let loop ([convention (argument->convention base init-convention who #:first? #t)] + [subs subs]) + (cond + [(null? subs) convention] + [else + (define sub (car subs)) + (check-build-path-arg who sub) + (loop (argument->convention sub convention who #:first? #f) + (cdr subs))]))) + (define final-convention (or convention (system-path-convention-type))) + (path (append-path-parts final-convention who base subs) + final-convention)) + +;; ---------------------------------------- + +(define (check-build-path-arg who p) + (check who + (lambda (p) (or (path-string? p) + (path-for-some-system? p) + (eq? p 'up) + (eq? p 'same))) + #:contract "(or/c path-string? path-for-some-system? 'up 'same)" + p)) + +(define (argument->convention p convention who #:first? first?) + (define (check c) + (when (and convention (not (eq? c convention))) + (raise-arguments-error who + (format + (if first? + "specified convention incompatible with ~a path element" + "preceding path's convention incompatible with ~a path element") + (if (string? p) + "string" + "given")) + "path element" p + (if first? "convention" "preceding path's convention") + convention)) + c) + (cond + [(path? p) (check (path-convention p))] + [(string? p) (check (system-path-convention-type))] + [else convention])) + +;; ---------------------------------------- + +(define (append-path-parts convention who base subs) + (define result-is-backslash-backslash-questionmark? + (and (eq? convention 'windows) + (for/or ([sub (in-list (cons base subs))]) + (backslash-backslash-questionmark? (as-bytes sub))))) + (define base-accum + (let ([bstr (as-bytes base)]) + (cond + [(eq? convention 'windows) + (if result-is-backslash-backslash-questionmark? + (convert-to-initial-backslash-backslash-questionmark bstr) + (list (strip-trailing-spaces bstr)))] + [else (list bstr)]))) + (define unc-result? + (and (eq? convention 'windows) + (not result-is-backslash-backslash-questionmark?) + (parse-unc (car base-accum) 0))) + ;; The `accum` list accumulates byte strings in reverse order to be + ;; appended. On Windows in \\?\ mode, each byte string corresponds + ;; to a single path element with a leading backslash, except that + ;; the last item is a starting-point; otherwise, the byte strings can + ;; be a mixture of compound path elements and separators + (let loop ([accum base-accum] [subs subs] [first? #t]) + (cond + [(null? subs) + (define elems (reverse accum)) + (combine-build-elements elems unc-result?)] + [else + (define sub (car subs)) + (define bstr (as-bytes sub)) + (case convention + [(unix) + ;; Unix is fairly straightforward + (when (is-sep? (bytes-ref bstr 0) 'unix) + (raise-arguments-error who + "absolute path cannot be added to a path" + "absolute path" sub)) + (define prev (car accum)) + (cond + [(is-sep? (bytes-ref prev (sub1 (bytes-length prev))) 'unix) + (loop (cons bstr accum) (cdr subs) #f)] + [else + (loop (list* bstr #"/" accum) (cdr subs) #f)])] + [(windows) + ;; For Windows, the implementation immediately here is + ;; mostly error checking, and actual combining work is in + ;; `combine-windows-path` + (define len (bytes-length bstr)) + (define (combine is-rel? is-complete? is-drive?) + (when (or is-complete? + (and (not is-rel?) + (not first?) + (not (and (null? (cdr accum)) + (drive? (car accum)))))) + (define what (if is-drive? "drive" "absolute path")) + (raise-arguments-error who + (string-append what " cannot be added to a base path") + what sub + "base path" (path (combine-build-elements (reverse accum) unc-result?) + 'windows))) + (loop (combine-windows-path (if (and (null? subs) + ;; because \\?\ mode does its own stripping: + (not result-is-backslash-backslash-questionmark?)) + bstr + (strip-trailing-spaces bstr)) + accum + result-is-backslash-backslash-questionmark? + (null? (cdr subs))) + (cdr subs) + #f)) + (cond + [(is-sep? (bytes-ref bstr 0) 'windows) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (define abs? (or (eq? kind 'abs) (eq? kind 'unc))) + (combine (eq? kind 'rel) + abs? + (and abs? + (just-backslashes-after? bstr drive-len)))] + [(parse-unc bstr 0) + => (lambda (drive-len) + (combine #t #t (just-separators-after? bstr drive-len)))] + [else + (combine #f #f #f)])] + [(letter-drive-start? bstr len) + (combine #f #t (just-separators-after? bstr 2))] + [else + (combine #t #f #f)])])]))) + +(define (combine-windows-path bstr accum result-is-backslash-backslash-questionmark? is-last?) + (cond + [result-is-backslash-backslash-questionmark? + ;; Split `bstr` into pieces, and handle the pieces one-by-one + (let loop ([elems (windows-split-into-path-elements bstr is-last?)] [accum accum] [to-dir? #f]) + (cond + [(null? elems) + (if (and is-last? to-dir? (pair? (cdr accum))) + (cons (bytes-append (car accum) #"\\") (cdr accum)) + accum)] + [else + (define sub (car elems)) + (cond + [(eq? 'same sub) + ;; Ignore 'same for \\?\ mode + (loop (cdr elems) accum #t)] + [(eq? 'up sub) + ;; Drop previous element for 'up in \\?\ mode + (loop (cdr elems) + (if (null? (cdr accum)) + (list (starting-point-add-up (car accum))) + (cdr accum)) + #t)] + [else + (loop (cdr elems) (cons sub accum) #f)])]))] + [else + ;; Not in \\?\ mode, so `bstr` must not be a \\?\ path. + ;; In case `accum` is drive-relative, start by dropping any + ;; leading slashes. + (define len (bytes-length bstr)) + (define sub (let loop ([i 0]) + (cond + [(= i len) #""] + [(is-sep? (bytes-ref bstr i) 'windows) + (loop (add1 i))] + [(zero? i) bstr] + [else (subbytes bstr i)]))) + ;; Now, relatively simple: add a slash if needed between the parts + (define prev-bstr (car accum)) + (define new-accum (if (is-sep? (bytes-ref prev-bstr (sub1 (bytes-length prev-bstr))) 'windows) + accum + (cons #"\\" accum))) + (if (equal? sub #"") ; in case the argument was just "/" + new-accum + (cons sub new-accum))])) + +(define (windows-split-into-path-elements bstr keep-trailing-separator?) + (cond + [(backslash-backslash-questionmark? bstr) + ;; It must be REL or RED (with only a drive to build on) + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (append (extract-dot-ups bstr 8 (or dots-end 8)) + (extract-separate-parts bstr literal-start + #:bbq-mode? #t + #:keep-trailing-separator? keep-trailing-separator?))] + [else + (extract-separate-parts bstr 0 #:keep-trailing-separator? keep-trailing-separator?)])) + +(define (as-bytes p) + (cond + [(eq? p 'up) #".."] + [(eq? p 'same) #"."] + [(path? p) (path-bytes p)] + [else (string->bytes/locale p (char->integer #\?))])) + +(define (just-separators-after? bstr drive-len) + (for/and ([b (in-bytes bstr drive-len)]) + (is-sep? b 'windows))) + +(define (just-backslashes-after? bstr drive-len) + (for/and ([b (in-bytes bstr drive-len)]) + (eqv? b (char->integer #\\)))) + +;; Check whether `s`, a byte string or a `starting-point`, +;; is just a drive, in which case we can add a non-complete +;; absolute path +(define (drive? s) + (cond + [(starting-point? s) (starting-point-drive? s)] + ;; must be a byte string + [(parse-unc s 0) + => (lambda (drive-len) (just-separators-after? s drive-len))] + [(letter-drive-start? s (bytes-length s)) + (just-separators-after? s 2)])) + +(struct starting-point (kind ; 'rel, 'red, 'unc, or 'abs + bstr ; byte string that contains the starting path + len ; number of bytes to use when adding more element + orig-len ; number of bytes to use when not adding more elements + extra-sep ; extra separator before first added element + add-ups? ; whether to add `up`s to the base string, as opposed to dropping them + drive?)) ; is bstr an absolute root? + +(define (make-starting-point kind + bstr + len + #:orig-len [orig-len len] + #:extra-sep [extra-sep #""] + #:add-ups? [add-ups? #f] + #:drive? [drive? #t]) + (list + (starting-point kind bstr len orig-len extra-sep add-ups? drive?))) + +(define (combine-build-elements elems unc-result?) + (cond + [(starting-point? (car elems)) + ;; in \\?\ mode for Windows + (define s (car elems)) + (cond + [(null? (cdr elems)) + (let ([bstr (subbytes (starting-point-bstr s) + 0 + (starting-point-orig-len s))]) + (cond + [(equal? bstr #"\\\\?\\REL") + #"."] + [(equal? bstr #"\\\\?\\RED") + #"\\"] + [else + (case (starting-point-kind s) + [(rel unc) + ;; Canonical form of \\?\REL\..[\..[etc.]] or \\?\UNC\[etc.] ends in slash: + (if (eqv? (bytes-ref bstr (sub1 (bytes-length bstr))) (char->integer #\\)) + bstr + (bytes-append bstr #"\\"))] + [else bstr])]))] + [else + (define init-bstr (subbytes (starting-point-bstr s) + 0 + (starting-point-len s))) + (apply bytes-append + init-bstr + (case (starting-point-kind s) + [(rel red) #"\\"] + [else #""]) + (starting-point-extra-sep s) + (cdr elems))])] + [else + ;; simple case... + (define bstr (apply bytes-append elems)) + ;; ... unless we've accidentally constructed something that + ;; looks like a \\?\ path or a UNC path, in which case we can + ;; correct by dropping a leading [back]slash + (cond + [(backslash-backslash-questionmark? bstr) + (subbytes bstr 1)] + [(and (not unc-result?) + (parse-unc bstr 0)) + (subbytes bstr 1)] + [else bstr])])) + +(define (convert-to-initial-backslash-backslash-questionmark bstr) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep) + (parse-backslash-backslash-questionmark bstr)) + (case kind + [(abs unc) + (append (reverse (extract-separate-parts bstr drive-len #:bbq-mode? #t)) + (if (equal? add-sep #"") + ;; drop implicit terminator in drive: + (make-starting-point kind bstr (sub1 drive-len) #:orig-len orig-drive-len) + (make-starting-point kind bstr drive-len #:orig-len orig-drive-len #:extra-sep (subbytes add-sep 1))))] + [else + ;; We can't back up over any dots before `dots-end`, + ;; so keep those toegether with \\?\REL + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (append (reverse (extract-separate-parts bstr literal-start #:bbq-mode? #t)) + (make-starting-point kind bstr (or dots-end 7) #:add-ups? (eq? kind 'rel) #:drive? #f))])] + [(parse-unc bstr 0) + => (lambda (root-len) + (define-values (machine volume) + (let ([l (extract-separate-parts (subbytes bstr 0 root-len) 0)]) + (values (car l) (cadr l)))) + (append (reverse (simplify-dots (extract-separate-parts bstr root-len) #:drop-leading? #t)) + (let* ([unc-bstr (bytes-append #"\\\\?\\UNC" machine volume)] + [unc-len (bytes-length unc-bstr)]) + (make-starting-point 'unc unc-bstr unc-len))))] + [(bytes=? #"." bstr) + (make-starting-point 'rel #"\\\\?\\REL" 7 #:add-ups? #t #:drive? #f)] + [(bytes=? #".." bstr) + (make-starting-point 'rel #"\\\\?\\REL\\.." 10 #:add-ups? #t #:drive? #f)] + [(is-sep? (bytes-ref bstr 0) 'windows) + (append (reverse (extract-separate-parts bstr 0)) + (make-starting-point 'red #"\\\\?\\RED" 7 #:drive? #f))] + [(and ((bytes-length bstr) . >= . 2) + (drive-letter? (bytes-ref bstr 0)) + (eqv? (bytes-ref bstr 1) (char->integer #\:))) + (append (reverse (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #t)) + (let ([drive-bstr (bytes-append #"\\\\?\\" (subbytes bstr 0 2) #"\\")]) + (make-starting-point 'abs drive-bstr 6 #:orig-len 7)))] + [else + ;; Create \\?\REL, combinding any leading dots into the \\?\REL part: + (define elems (simplify-dots (extract-separate-parts bstr 0) #:drop-leading? #f)) + (let loop ([dots null] [elems elems]) + (cond + [(or (null? elems) + (not (equal? (car elems) 'up))) + (append (reverse elems) + (let* ([rel-bstr (apply bytes-append #"\\\\?\\REL" dots)] + [rel-len (bytes-length rel-bstr)]) + (make-starting-point 'rel rel-bstr rel-len #:add-ups? #t #:drive? #f)))] + [else + (loop (cons (car elems) dots) (cdr elems))]))])) + +;; Split on separators, removing trailing whitespace from the last +;; element, and prefix each extracted element with a backslash: +(define (extract-separate-parts bstr pos + #:bbq-mode? [bbq-mode? #f] + #:keep-trailing-separator? [keep-trailing-separator? #f]) + (define (is-a-sep? b) + (if bbq-mode? + (eqv? b (char->integer #\\)) + (is-sep? b 'windows))) + (define len (bytes-length bstr)) + (let loop ([pos pos]) + (cond + [(= pos len) null] + [(is-a-sep? (bytes-ref bstr pos)) + (loop (add1 pos))] + [else + (let e-loop ([end-pos (add1 pos)]) + (cond + [(or (= end-pos len) + (is-a-sep? (bytes-ref bstr end-pos))) + (define rest (loop end-pos)) + (define elem-bstr (subbytes bstr pos end-pos)) + (define new-bstr (if (and (null? rest) + (not bbq-mode?)) + (strip-trailing-spaces elem-bstr) + elem-bstr)) + (define new-sub (cond + [(and (not bbq-mode?) + (bytes=? new-bstr #".")) + 'same] + [(and (not bbq-mode?) + (bytes=? new-bstr #"..")) + 'up] + [else + (if (and keep-trailing-separator? + (null? rest) + (end-pos . < . len)) + (bytes-append #"\\" new-bstr #"\\") + (bytes-append #"\\" new-bstr))])) + (cons new-sub rest)] + [else (e-loop (add1 end-pos))]))]))) + +;; Create a list containing one 'up for each ".." in the range: +(define (extract-dot-ups bstr start dots-end) + (if (= start dots-end) + '() + (let loop ([i (add1 start)]) + (cond + [(i . >= . dots-end) '()] + [(and (eqv? (bytes-ref bstr i) (char->integer #\.)) + (eqv? (bytes-ref bstr (sub1 i)) (char->integer #\.))) + (cons 'up (loop (add1 i)))] + [else (loop (add1 i))])))) + +;; For \\?\REL paths, add an 'up at the start to the initial path. +;; Otherwise, at a root, just drop an 'up. +(define (starting-point-add-up s) + (cond + [(starting-point-add-ups? s) + (define bstr (bytes-append (subbytes (starting-point-bstr s) + 0 + (starting-point-len s)) + #"\\..")) + (define len (bytes-length bstr)) + (struct-copy starting-point s + [bstr bstr] + [len len] + [orig-len len])] + [else s])) + +(define (simplify-dots bstrs #:drop-leading? [drop-leading? #t]) + (let loop ([bstrs bstrs] [accum null]) + (cond + [(null? bstrs) (reverse accum)] + [(eq? 'same (car bstrs)) (loop (cdr bstrs) accum)] + [(eq? 'up (car bstrs)) (if (null? accum) + (if drop-leading? + (loop (cdr bstrs) accum) + (loop (cdr bstrs) (cons (car bstrs) accum))) + (loop (cdr bstrs) (cdr accum)))] + [else (loop (cdr bstrs) (cons (car bstrs) accum))]))) diff -Nru racket-6.12+ppa1/src/io/path/check-path.rkt racket-7.0+ppa1/src/io/path/check-path.rkt --- racket-6.12+ppa1/src/io/path/check-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/check-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,10 @@ +#lang racket/base +(require "check.rkt" + "path.rkt") + +(provide check-path-argument) + +(define (check-path-argument who p) + (check who (lambda (p) (or (path-string? p) (path-for-some-system? p))) + #:contract "(or/c path-string? path-for-some-system?)" + p)) diff -Nru racket-6.12+ppa1/src/io/path/check.rkt racket-7.0+ppa1/src/io/path/check.rkt --- racket-6.12+ppa1/src/io/path/check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,29 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/check.rkt") + +(provide (all-from-out "../common/check.rkt") + check-convention + check-path-string + check-path-bytes) + +(define (check-convention who c) + (check who (lambda (c) (or (eq? c 'windows) (eq? c 'unix))) + #:contract "(or/c 'windows 'unix)" + c)) + +(define (check-path-string who s) + (when (zero? (string-length s)) + (raise-arguments-error who "path string is empty")) + (for ([c (in-string s)]) + (when (char=? c #\nul) + (raise-arguments-error who "path string contains a nul character" + "path string" s)))) + +(define (check-path-bytes who s) + (when (zero? (bytes-length s)) + (raise-arguments-error who "byte string is empty")) + (for ([c (in-bytes s)]) + (when (zero? c) + (raise-arguments-error who "byte string contains a nul character" + "byte string" s)))) diff -Nru racket-6.12+ppa1/src/io/path/cleanse.rkt racket-7.0+ppa1/src/io/path/cleanse.rkt --- racket-6.12+ppa1/src/io/path/cleanse.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/cleanse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,118 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/internal-error.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "windows.rkt") + +(provide cleanse-path + clean-double-slashes) + +(define/who (cleanse-path p-in) + (check-path-argument who p-in) + (define p (->path p-in)) + (define convention (path-convention p)) + (define (return bstr) + (if (eq? bstr (path-bytes p)) + p + (path bstr convention))) + (define bstr (path-bytes p)) + (case convention + [(unix) + (return (clean-double-slashes bstr 'unix 0))] + [(windows) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr) + (parse-backslash-backslash-questionmark (path-bytes p))) + (cond + [clean-start-pos + (return (clean-double-slashes bstr 'windows clean-start-pos + #:only-backslash? #t))] + [else + ;; Must be \\?\REL or \\?\RED + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (define new-bstr (clean-double-slashes bstr 'windows literal-start + #:only-backslash? #t)) + (define has-extra-backslash? + (and (eqv? (bytes-ref bstr (- literal-start 1)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- literal-start 2)) (char->integer #\\)))) + (cond + [has-extra-backslash? (return new-bstr)] + [(= literal-start (bytes-length new-bstr)) (return new-bstr)] + [else + (return (bytes-append (subbytes new-bstr 0 literal-start) + #"\\" + (subbytes new-bstr literal-start)))])])] + [(parse-unc bstr 0) + => (lambda (drive-len) + (return (clean-double-slashes bstr 'windows (sub1 drive-len) + #:to-backslash-from 0)))] + [(letter-drive-start? bstr (bytes-length bstr)) + (cond + [(and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 2) 'windows)) + (return (clean-double-slashes bstr 'windows 2 + #:to-backslash-from 2))] + [else + (return (bytes-append (subbytes bstr 0 2) + #"\\" + (clean-double-slashes (subbytes bstr 2) 'windows 0 + #:to-backslash-from 0)))])] + [else + (return (clean-double-slashes bstr 'windows 0 + #:to-backslash-from 0))])])) + +;; ---------------------------------------- + +(define (clean-double-slashes bstr convention allow-double-before + #:only-backslash? [only-backslash? #f] + #:to-backslash-from [to-backslash-from #f]) + (define (is-a-sep? b) + (if only-backslash? + (eqv? b (char->integer #\\)) + (is-sep? b convention))) + (define extra-count + (let loop ([i (sub1 (bytes-length bstr))]) + (cond + [(i . <= . allow-double-before) 0] + [(and (is-a-sep? (bytes-ref bstr i)) + (is-a-sep? (bytes-ref bstr (sub1 i)))) + (add1 (loop (sub1 i)))] + [else (loop (sub1 i))]))) + (cond + [(and (zero? extra-count) + (or (not to-backslash-from) + (not (for/or ([b (in-bytes bstr to-backslash-from)]) + (eq? b (char->integer #\/)))))) + bstr] + [else + (define new-bstr (make-bytes (- (bytes-length bstr) extra-count))) + (let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))]) + (unless (i . <= . allow-double-before) + (cond + [(is-a-sep? (bytes-ref bstr i)) + (cond + [(is-a-sep? (bytes-ref bstr (sub1 i))) + (loop (sub1 i) j)] + [else + (if to-backslash-from + (bytes-set! new-bstr j (char->integer #\\)) + (bytes-set! new-bstr j (bytes-ref bstr i))) + (loop (sub1 i) (sub1 j))])] + [else + (bytes-set! new-bstr j (bytes-ref bstr i)) + (loop (sub1 i) (sub1 j))]))) + (cond + [to-backslash-from + (bytes-copy! new-bstr 0 bstr 0 to-backslash-from) + (for ([i (in-range to-backslash-from (add1 allow-double-before))]) + (define b (bytes-ref bstr i)) + (if (eqv? b (char->integer #\/)) + (bytes-set! new-bstr i (char->integer #\\)) + (bytes-set! new-bstr i b)))] + [else + (bytes-copy! new-bstr 0 bstr 0 (add1 allow-double-before))]) + new-bstr])) diff -Nru racket-6.12+ppa1/src/io/path/complete.rkt racket-7.0+ppa1/src/io/path/complete.rkt --- racket-6.12+ppa1/src/io/path/complete.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/complete.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,47 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "path.rkt" + "check.rkt" + "check-path.rkt" + "relativity.rkt" + "build.rkt" + "windows.rkt") + +(provide path->complete-path) + +;; If `wrt-given?` is #f, then `wrt` can be a thunk to get a path, +;; so that any security checks associated with the thunk are delayed +(define/who (path->complete-path p-in wrt #:wrt-given? [wrt-given? #t]) + (check-path-argument who p-in) + (when wrt-given? + (check who (lambda (p) (and (or (path-string? p) (path-for-some-system? p)) + (complete-path? p))) + #:contract "(and/c (or/c path-string? path-for-some-system?) complete-path?)" + wrt)) + (unless (eq? (convention-of-path p-in) + (if (procedure? wrt) + (system-path-convention-type) + (convention-of-path wrt))) + (if wrt-given? + (raise-arguments-error who + "convention of first path incompatible with convention of second path" + "first path" p-in + "second path" wrt) + (raise-arguments-error who + "no second path supplied, and given path is not for the current platform" + "given path" p-in))) + (define p (->path p-in)) + (cond + [(complete-path? p) p] + [(relative-path? p) + (build-path (if (procedure? wrt) (wrt) wrt) p)] + [else + ;; non-complete, non-relative path on Windows, so fill in the drive + (define wrt-path (->path (if (procedure? wrt) (wrt) wrt))) + (define drive (split-drive (path-bytes wrt-path))) + (build-path (path drive 'windows) p)])) + +(define (convention-of-path p) + (if (path? p) + (path-convention p) + (system-path-convention-type))) diff -Nru racket-6.12+ppa1/src/io/path/directory-path.rkt racket-7.0+ppa1/src/io/path/directory-path.rkt --- racket-6.12+ppa1/src/io/path/directory-path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/directory-path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,78 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "windows.rkt") + +(provide directory-path? + path->directory-path + path->path-without-trailing-separator) + +(define/who (path->directory-path p-in) + (check-path-argument who p-in) + (define p (->path p-in)) + (cond + [(directory-path? p #:require-sep? #t) p] + [else + (case (path-convention p) + [(unix) + (path (bytes-append (path-bytes p) #"/") 'unix)] + [(windows) + (path (bytes-append (path-bytes p) #"\\") 'windows)])])) + +(define (directory-path? p #:require-sep? [require-sep? #f]) + (define bstr (path-bytes p)) + (define len (bytes-length bstr)) + (define convention (path-convention p)) + (define (unixish-path-directory-path?) + (or (is-sep? (bytes-ref bstr (sub1 len)) convention) + (and (not require-sep?) + (or (and (len . >= . 2) + (eq? (bytes-ref bstr (sub1 len)) (char->integer #\.)) + (eq? (bytes-ref bstr (- len 2)) (char->integer #\.)) + (or (len . = . 2) + (is-sep? (bytes-ref bstr (- len 3)) convention))) + (and (len . >= . 1) + (eq? (bytes-ref bstr (sub1 len)) (char->integer #\.)) + (or (len . = . 1) + (is-sep? (bytes-ref bstr (- len 2)) convention))))))) + + (case convention + [(unix) (unixish-path-directory-path?)] + [(windows) + (cond + [(backslash-backslash-questionmark? bstr) + ;; Dots are literal in a ".." path, except as a sequence at + ;; the start of a \\?\REL\.. path (with a single backslash) + (or (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (and (not require-sep?) + (eq? 'rel (backslash-backslash-questionmark-kind bstr)) + (eqv? len + (let-values ([(dots-end literal-start) (backslash-backslash-questionmark-dot-ups-end bstr len)]) + dots-end))))] + [else (unixish-path-directory-path?)])])) + +(define (path->path-without-trailing-separator p) + (define bstr (path-bytes p)) + (define orig-len (bytes-length bstr)) + (cond + [(= orig-len 1) p] + [(and (eq? (path-convention p) 'windows) + (backslash-backslash-questionmark? bstr)) + ;; \\?\ is more complicated. Do we need to do anything, + ;; considering that the use for this function is `resolve-path`? + p] + [else + (define len + (let loop ([len orig-len]) + (cond + [(zero? len) 0] + [else + (define c (bytes-ref bstr (sub1 len))) + (if (is-sep? c (path-convention p)) + (loop (sub1 len)) + len)]))) + (cond + [(< len orig-len) (path (subbytes bstr 0 len) (path-convention p))] + [else p])])) diff -Nru racket-6.12+ppa1/src/io/path/ffi.rkt racket-7.0+ppa1/src/io/path/ffi.rkt --- racket-6.12+ppa1/src/io/path/ffi.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/ffi.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,15 @@ +#lang racket/base +(require '#%foreign + "../common/check.rkt" + "../file/host.rkt" + "path.rkt") + +(provide _path) + +(define/who _path + (make-ctype _bytes + (lambda (p) + (check who path-string? #:or-false p) + (and p (bytes-append (->host p #f '()) #"\0"))) + (lambda (bstr) (and bstr (path (bytes->immutable-bytes bstr) + (system-path-convention-type)))))) diff -Nru racket-6.12+ppa1/src/io/path/main.rkt racket-7.0+ppa1/src/io/path/main.rkt --- racket-6.12+ppa1/src/io/path/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,178 @@ +#lang racket/base +(require "../locale/string.rkt" + (rename-in "path.rkt" + [string->path raw:string->path]) + "check.rkt" + "sep.rkt" + "build.rkt" + "string.rkt" + "split.rkt" + "protect.rkt" + "relativity.rkt" + "cleanse.rkt" + "simplify.rkt" + "directory-path.rkt" + "system.rkt" + "api.rkt" + "ffi.rkt" + "windows.rkt") + +(provide (rename-out [is-path? path?]) + path-for-some-system? + + string->path + path->string + bytes->path + path->bytes + + string->path-element + bytes->path-element + path-element->string + path-element->bytes + + pathcomplete-path + path->directory-path + + cleanse-path + simplify-path + + find-system-path + set-exec-file! + set-run-file! + set-collects-dir! + set-config-dir! + + _path) + + +(define/who (bytes->path bstr [convention (system-path-convention-type)]) + (check who bytes? bstr) + (check-convention who convention) + (check-path-bytes who bstr) + (path (bytes->immutable-bytes bstr) convention)) + +(define/who (path->bytes p) + (check who path? #:contract "path-for-some-system?" p) + (bytes-copy (path-bytes p))) + +(define/who (string->path-element s) + (check who string? s) + (check-path-string who s) + (do-bytes->path-element (string->path-bytes s) + (system-path-convention-type) + who + s)) + +(define/who (bytes->path-element bstr [convention (system-path-convention-type)]) + (check who bytes? bstr) + (check-convention who convention) + (check-path-bytes who bstr) + (do-bytes->path-element bstr convention who bstr)) + +(define (path-element-clean p) + (cond + [(path? p) + (define bstr (path-bytes p)) + (define convention (path-convention p)) + (and + ;; Quick pre-check: any separators that are not at the end? + (or (not (eq? convention 'unix)) + (not (for/or ([c (in-bytes bstr 0 (let loop ([end (bytes-length bstr)]) + (cond + [(zero? end) 0] + [(is-sep? (bytes-ref bstr (sub1 end)) convention) + (loop (sub1 end))] + [else end])))] + [i (in-naturals)]) + (and (is-sep? c convention) + i)))) + (let-values ([(base name dir?) (split-path p)]) + (and (symbol? base) + (path? name) + name)))] + [else #f])) + +(define (path-element? p) + (and (path-element-clean p) #t)) + +(define (do-bytes->path-element bstr convention who orig-arg) + (define (bad-element) + (raise-arguments-error who + "cannot be converted to a path element" + "path" orig-arg + "explanation" "path can be split, is not relative, or names a special element")) + (when (eq? 'windows convention) + ;; Make sure we don't call `protect-path-element` on a + ;; byte string that contains a "\": + (when (for/or ([b (in-bytes bstr)]) + (eqv? b (char->integer #\\))) + (bad-element))) + (define len (bytes-length bstr)) + (define p (path (protect-path-element (bytes->immutable-bytes bstr) convention) + convention)) + (unless (path-element? p) + (bad-element)) + p) + +(define/who (path-element->string p) + (define clean-p (path-element-clean p)) + (unless clean-p + (check who path-element? p)) + (bytes->string/locale (strip-//?/rel clean-p) #\?)) + +(define/who (path-element->bytes p) + (define clean-p (path-element-clean p)) + (unless clean-p + (check who path-element? p)) + (bytes-copy (strip-//?/rel clean-p))) + +(define (strip-//?/rel elem-p) + (define bstr (path-bytes elem-p)) + (cond + [(eq? (path-convention elem-p) 'windows) + (strip-backslash-backslash-rel bstr)] + [else bstr])) + +(define/who pathcomplete-path v (current-directory)))))) + +(define (check-directory-path who v) + (check who path-string? v) + (path->complete-path v (current-directory))) diff -Nru racket-6.12+ppa1/src/io/path/path.rkt racket-7.0+ppa1/src/io/path/path.rkt --- racket-6.12+ppa1/src/io/path/path.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/path.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,68 @@ +#lang racket/base +(require "../print/custom-write.rkt" + "../port/string-output.rkt" + "../locale/string.rkt") + +(provide (struct-out path) + is-path? + path-for-some-system? + path-string? + string-no-nuls? + string->path + string->path-bytes + ->path) + +(struct path (bytes convention) + #:property prop:custom-write + (lambda (p port mode) + (when mode + (if (eq? (path-convention p) (system-path-convention-type)) + (write-string "#string (path-convention p)) port) + (write-string "-path:" port)))) + (write-string (bytes->string/locale (path-bytes p)) port) + (when mode + (write-string ">" port))) + #:property prop:equal+hash + (list + (lambda (p1 p2 eql?) + (eql? (path-bytes p1) (path-bytes p2))) + (lambda (p hc) + (hc (path-bytes p))) + (lambda (p hc) + (hc (path-bytes p))))) + +(define is-path? + (let ([path? (lambda (p) + (and (path? p) + (eq? (path-convention p) + (system-path-convention-type))))]) + path?)) + +(define (path-for-some-system? p) + (path? p)) + +(define (path-string? p) + (or (is-path? p) + (and (string? p) + (positive? (string-length p)) + (string-no-nuls? p)))) + +(define (string-no-nuls? s) + (and (string? s) + (for/and ([c (in-string s)]) + (not (char=? c #\nul))))) + +(define (string->path s) + (path (string->path-bytes s) + (system-path-convention-type))) + +(define (string->path-bytes s) + (string->bytes/locale s (char->integer #\?))) + +(define (->path p) + (if (string? p) + (string->path p) + p)) diff -Nru racket-6.12+ppa1/src/io/path/protect.rkt racket-7.0+ppa1/src/io/path/protect.rkt --- racket-6.12+ppa1/src/io/path/protect.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/protect.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,48 @@ +#lang racket/base +(require "windows.rkt") + +(provide protect-path-element) + +(define (protect-path-element bstr convention) + (cond + [(eq? convention 'windows) + (if (needs-protect? bstr) + (bytes-append #"\\\\?\\REL\\\\" bstr) + bstr)] + [else + bstr])) + +(define (needs-protect? bstr) + (define len (bytes-length bstr)) + (cond + [(and (eqv? len 1) + (eqv? (bytes-ref bstr 0) (char->integer #\.))) + ;; would also be covered by loop below + #t] + [(and (eqv? len 2) + (eqv? (bytes-ref bstr 0) (char->integer #\.)) + (eqv? (bytes-ref bstr 1) (char->integer #\.))) + ;; would also be covered by loop below + #t] + [(special-filename? bstr) + #t] + [else + (let loop ([i+1 len] [at-end? #t]) + (cond + [(zero? i+1) #f] + [else + (define i (sub1 i+1)) + (define b (bytes-ref bstr i)) + (cond + [(and at-end? + (or (eqv? b (char->integer #\.)) + (eqv? b (char->integer #\space)))) + #t] + [(or (eqv? b (char->integer #\/)) + (eqv? b (char->integer #\")) + (eqv? b (char->integer #\|)) + (eqv? b (char->integer #\:)) + (eqv? b (char->integer #\<)) + (eqv? b (char->integer #\>))) + #t] + [else (loop i #f)])]))])) diff -Nru racket-6.12+ppa1/src/io/path/relativity.rkt racket-7.0+ppa1/src/io/path/relativity.rkt --- racket-6.12+ppa1/src/io/path/relativity.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/relativity.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "sep.rkt" + "windows.rkt") + +(provide relative-path? + absolute-path? + complete-path?) + +(define-syntax-rule (define-...-path? id + unix-bstr-check unix-str-check + windows-bstr-check) + (define (id p) + (check-path-test-argument 'id p) + (cond + [(path? p) + (case (path-convention p) + [(unix) + (define bstr (path-bytes p)) + (unix-bstr-check bstr)] + [(windows) + (windows-bstr-check (path-bytes p))])] + [(string? p) + (and (string-no-nuls? p) + (positive? (string-length p)) + (case (system-path-convention-type) + [(unix) + (unix-str-check p)] + [(windows) + (windows-bstr-check (string->path-bytes p))]))]))) + +(define (check-path-test-argument who p) + (check who (lambda (p) (or (path? p) (string? p) (path-for-some-system? p))) + #:contract "(or/c path? string? path-for-some-system?)" + p)) + +(define-...-path? relative-path? + (lambda (p) + (not (is-sep? (bytes-ref p 0) 'unix))) + (lambda (p) + (not (is-sep? (char->integer (string-ref p 0)) 'unix))) + (lambda (p) + (windows-relative-path-bytes? p))) + +(define (windows-relative-path-bytes? p) + (let ([bbq (backslash-backslash-questionmark-kind p)]) + (cond + [(eq? bbq 'rel) #t] + [bbq #f] + [(is-sep? (bytes-ref p 0) 'windows) #f] + [(letter-drive-start? p (bytes-length p)) #f] + [else #t]))) + +(define-...-path? absolute-path? + (lambda (p) + (is-sep? (bytes-ref p 0) 'unix)) + (lambda (p) + (is-sep? (char->integer (string-ref p 0)) 'unix)) + (lambda (p) + (not (windows-relative-path-bytes? p)))) + +(define-...-path? complete-path? + (lambda (p) + (is-sep? (bytes-ref p 0) 'unix)) + (lambda (p) + (is-sep? (char->integer (string-ref p 0)) 'unix)) + (lambda (p) + (let ([bbq (backslash-backslash-questionmark-kind p)]) + (cond + [bbq + (and (not (eq? bbq 'red)) + (not (eq? bbq 'rel)))] + [else + (or (letter-drive-start? p (bytes-length p)) + (and (parse-unc p 0) #t))])))) diff -Nru racket-6.12+ppa1/src/io/path/sep.rkt racket-7.0+ppa1/src/io/path/sep.rkt --- racket-6.12+ppa1/src/io/path/sep.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/sep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base +(provide is-sep?) + +(define (is-sep? c convention) + (or (eq? c (char->integer #\/)) + (and (eq? convention 'windows) + (eq? c (char->integer #\\))))) diff -Nru racket-6.12+ppa1/src/io/path/simplify.rkt racket-7.0+ppa1/src/io/path/simplify.rkt --- racket-6.12+ppa1/src/io/path/simplify.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/simplify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,255 @@ +#lang racket/base +(require "../file/main.rkt" + "path.rkt" + "check.rkt" + "check-path.rkt" + "sep.rkt" + "relativity.rkt" + "split.rkt" + "build.rkt" + "cleanse.rkt" + "directory-path.rkt" + "complete.rkt" + "parameter.rkt" + "windows.rkt") + +(provide simplify-path) + +(define/who (simplify-path p-in [use-filesystem? #t]) + (check-path-argument who p-in) + (define p (->path p-in)) + (define convention (path-convention p)) + (when use-filesystem? + (unless (eq? convention (system-path-convention-type)) + (raise-arguments-error who + "in use-filesystem mode, path is not for the current platform" + "path" p))) + (cond + [(simple? p convention) p] + [else + (define clean-p (cleanse-path p)) + (cond + [(simple? clean-p convention) clean-p] + [else + (define l (explode-path clean-p)) + (define simple-p + (cond + [use-filesystem? + ;; Use the filesystem, which requires building + ;; a full path + (define (combine base accum) + (if (null? accum) + base + (apply build-path base (reverse accum)))) + (let loop ([l (if (path? (car l)) (cdr l) l)] + [base (if (path? (car l)) + ;; convert starting point absolute as needed + (path->complete-path (car l) (current-directory)) + ;; original must be relative + (current-directory))] + [accum '()] + [seen #hash()]) + (cond + [(null? l) (combine base accum)] + [(eq? 'same (car l)) + (loop (cdr l) base accum seen)] + [(eq? 'up (car l)) + (define new-base (combine base accum)) + (define target (resolve-path new-base)) + (define-values (from-base new-seen) + (cond + [(eq? target new-base) (values new-base seen)] + [else + (define from-base + (cond + [(complete-path? target) target] + [else + (define-values (base-dir name dir?) (split-path new-base)) + (path->complete-path target base-dir)])) + (when (hash-ref seen from-base #f) + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": cycle detected at link" + "\n link path: " (path->string new-base)) + (current-continuation-marks)))) + (values from-base (hash-set seen from-base #t))])) + (define-values (next-base name dir?) (split-path from-base)) + (cond + [(not next-base) + ;; discard ".." after a root + (loop (cdr l) from-base '() new-seen)] + [else + (loop (cdr l) next-base '() new-seen)])] + [else (loop (cdr l) base (cons (car l) accum) seen)]))] + [else + ;; Don't use the filesystem, so just remove + ;; "." and ".." syntactically + (define simpler-l + (let loop ([l l] [accum null]) + (cond + [(null? l) (reverse accum)] + [(eq? 'same (car l)) (loop (cdr l) accum)] + [(eq? 'up (car l)) + (cond + [(pair? accum) + (loop (cdr l) (cdr accum))] + [else + (cons 'up (loop (cdr l) null))])] + [else (loop (cdr l) (cons (car l) accum))]))) + (apply build-path/convention-type convention (if (null? simpler-l) '(same) simpler-l))])) + (define simpler-p (if (eq? convention 'windows) + (simplify-backslash-backslash-questionmark simple-p) + simple-p)) + (if (or (directory-path? p) + (and (eq? convention 'windows) + (unc-without-trailing-separator? simpler-p))) + (path->directory-path simpler-p) + simpler-p)])])) + +;; ---------------------------------------- + +;; Quick check for whether the path is already simple: +(define (simple? p convention) + (define bstr (path-bytes p)) + (define len (bytes-length bstr)) + (define (is-a-sep? b) + (if (eq? convention 'windows) + (eqv? b (char->integer #\\)) + (is-sep? b convention))) + (cond + [(and (eq? convention 'windows) + (cond + [(and + (= len 2) + (letter-drive-start? bstr 2)) + ;; Letter drive without trailing separator + #t] + [(non-normal-backslash-backslash-questionmark? bstr) + #t] + [else #f])) + #f] + [else + (let loop ([i 0]) + (cond + [(= i len) #t] + [(is-a-sep? (bytes-ref bstr i)) + (cond + [(= (add1 i) len) #t] + [(is-a-sep? (bytes-ref bstr (add1 i))) + #f] + [(and (eqv? (bytes-ref bstr (add1 i)) (char->integer #\.)) + (or (= (+ i 2) len) + (is-a-sep? (bytes-ref bstr (+ i 2))) + (and (eqv? (bytes-ref bstr (+ i 2)) (char->integer #\.)) + (or (= (+ i 3) len) + (is-a-sep? (bytes-ref bstr (+ i 3))))))) + #f] + [else (loop (add1 i))])] + [(and (zero? i) + (eqv? (bytes-ref bstr 0) (char->integer #\.)) + (or (= 1 len) + (is-sep? (bytes-ref bstr 1) convention) + (and (eqv? (bytes-ref bstr 1) (char->integer #\.)) + (or (= 2 len) + (is-sep? (bytes-ref bstr 2) convention))))) + #f] + [(and (eq? convention 'windows) + (eqv? (bytes-ref bstr i) (char->integer #\/))) + #f] + [else (loop (add1 i))]))])) + +(define (non-normal-backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr) + (parse-backslash-backslash-questionmark bstr)) + ;; We could try harder to recognize normal forms, but for now + ;; we assume that some normalization is needed in a \\?\ path. + kind) + +;; ---------------------------------------- + +(define (unc-without-trailing-separator? p) + (define bstr (path-bytes p)) + (eqv? (parse-unc bstr 0) (bytes-length bstr))) + +;; Strip away "\\?\" when possible from an otherwise simplified `p` +(define (simplify-backslash-backslash-questionmark p) + (define bstr (path-bytes p)) + (define len (bytes-length bstr)) + (define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr) + (parse-backslash-backslash-questionmark bstr)) + (define (special-element? elem-start i at-end?) + (and (elem-start . < . i) + (or (let ([b (bytes-ref bstr (sub1 i))]) + (or (and (eqv? b (char->integer #\.)) + (or at-end? + (= elem-start (- i 1)) + (and (= elem-start (- i 2)) + (eqv? (bytes-ref bstr elem-start) (char->integer #\.))))) + (and at-end? + (eqv? b (char->integer #\space))))) + (special-filename? (subbytes bstr elem-start i))))) + (define (no-special-in-content? start-pos #:len [len len]) + (let loop ([i start-pos] [elem-start start-pos]) + (cond + [(= i len) (not (special-element? elem-start i #t))] + [else + (define b (bytes-ref bstr i)) + (cond + [(eqv? b (char->integer #\\)) + (cond + [(special-element? elem-start i #f) #f] + [else (loop (add1 i) (add1 i))])] + [(or (eqv? b (char->integer #\/)) + (eqv? b (char->integer #\:)) + (eqv? b (char->integer #\")) + (eqv? b (char->integer #\|)) + (eqv? b (char->integer #\<)) + (eqv? b (char->integer #\>))) + #f] + [else (loop (add1 i) elem-start)])]))) + (case kind + [(abs) + (cond + [(and (= drive-len 7) + (drive-letter? (bytes-ref bstr 4)) + (eqv? (bytes-ref bstr 5) (char->integer #\:)) + (no-special-in-content? orig-drive-len)) + (path (subbytes bstr 4) 'windows)] + [else p])] + [(unc) + (define norm-bstr (normalize-backslash-backslash-unc bstr)) + (cond + [(no-special-in-content? 4 ; check UNC machine and drive, too + #:len (if (= orig-drive-len len) + (sub1 len) ; stop before ending "\\" + len)) + (path (bytes-append #"\\" (subbytes norm-bstr 7)) 'windows)] + [(eq? norm-bstr bstr) p] + [else (path norm-bstr 'windows)])] + [(red) + (cond + [(no-special-in-content? 9) + (path (subbytes bstr 8) 'windows)] + [else p])] + [(rel) + (define-values (dots-end literal-start) (backslash-backslash-questionmark-dot-ups-end bstr len)) + (cond + [(no-special-in-content? literal-start) + ;; Remove any extra backslash for `dots-end` + (path (bytes-append (if dots-end (subbytes bstr 8 (add1 dots-end)) #"") + (subbytes bstr literal-start)) + 'windows)] + [else p])] + [else p])) + +(define (normalize-backslash-backslash-unc bstr) + ;; Normalize "UNC" case and single \ after \\? + (cond + [(and (eqv? (bytes-ref bstr 4) (char->integer #\U)) + (eqv? (bytes-ref bstr 5) (char->integer #\N)) + (eqv? (bytes-ref bstr 6) (char->integer #\C))) + bstr] + [(eqv? (bytes-ref bstr 4) (char->integer #\\)) + (bytes-append #"\\\\?\\UNC" (subbytes bstr 8))] + [else + (bytes-append #"\\\\?\\UNC" (subbytes bstr 7))])) diff -Nru racket-6.12+ppa1/src/io/path/split.rkt racket-7.0+ppa1/src/io/path/split.rkt --- racket-6.12+ppa1/src/io/path/split.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/split.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,312 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "cleanse.rkt" + "windows.rkt" + "protect.rkt") + +(provide split-path + explode-path) + +(define/who (split-path p) + (check-path-argument who p) + (split (->path p))) + +(define/who (explode-path p) + (check-path-argument who p) + (reverse (split (->path p) #:explode? #t))) + +;; ---------------------------------------- + +(define (split p #:explode? [explode? #f]) + (cond + [(not (eq? (path-convention p) 'windows)) + (split-after-drive p #:explode? explode?)] + [else + ;; Look for a Windows drive spec, then (usually) continue + ;; to `split-after-drive`: + (define bstr (path-bytes p)) + (cond + [(and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 0) 'windows) + (is-sep? (bytes-ref bstr 1) 'windows)) + (define-values (//?-kind //?-drive-end //?-orig-drive-end) (parse-//?-drive bstr)) + (cond + [//?-kind + (define allow-double-before //?-drive-end) + (cond + [(or (eq? //?-kind 'rel) + (eq? //?-kind 'red)) + ;; `\\?\REL\` or `\\?\RED\` path. Handle it directly as a special case + (split-reld bstr #:explode? explode?)] + [else + (split-after-drive p + #:drive-end //?-orig-drive-end + #:keep-drive-end (if (eq? //?-kind 'unc) + //?-orig-drive-end + //?-drive-end) + #:allow-double-before //?-orig-drive-end + #:no-slash-sep? #t + #:no-up? #t + #:explode? explode?)])] + [else + (define //-drive-end (parse-//-drive bstr)) + (cond + [//-drive-end + (split-after-drive p + #:drive-end (cond + [(and (//-drive-end . < . (bytes-length bstr)) + (is-sep? (bytes-ref bstr //-drive-end) 'windows)) + (add1 //-drive-end)] + [else //-drive-end]) + #:allow-double-before 1 + #:explode? explode?)] + [else + (split-after-drive p #:explode? explode?)])])] + [(and ((bytes-length bstr) . > . 2) + (drive-letter? (bytes-ref bstr 0)) + (eq? (bytes-ref bstr 1) (char->integer #\:))) + (split-after-drive p + #:drive-end (cond + [(and (2 . < . (bytes-length bstr)) + (is-sep? (bytes-ref bstr 2) 'windows)) + 3] + [else 2]) + #:explode? explode?)] + [else (split-after-drive p #:explode? explode?)])])) + +;; ---------------------------------------- + +;; Find a separator to split on, avoiding the Windows drive portion of +;; a path +(define (split-after-drive p + #:len [in-len #f] + #:drive-end [drive-end 0] + #:keep-drive-end [keep-drive-end drive-end] + #:no-slash-sep? [no-slash-sep? #f] + #:no-up? [no-up? #f] + #:allow-double-before [allow-double-before 0] + #:explode? explode?) + (define convention (path-convention p)) + ;; Consecutive slashes can cause all sorts of mischief, both for + ;; finding a separtor and making an unintended result after splitting, + ;; so clean them up as a first step + (define bstr (if in-len + (path-bytes p) + (clean-double-slashes (path-bytes p) convention allow-double-before))) + (define len (or in-len (bytes-length bstr))) + + (define-values (split-pos ends-sep?) + (let loop ([i (sub1 len)] [ends-sep? #f]) + (cond + [(i . < . drive-end) + (if (and (positive? i) + (i . < . (sub1 len))) + (values i ends-sep?) + (values #f ends-sep?))] + [else + (define sep? + (cond + [no-slash-sep? (eq? (bytes-ref bstr i) (char->integer #\\))] + [else (is-sep? (bytes-ref bstr i) convention)])) + (cond + [sep? + (if (i . < . (sub1 len)) + (values i ends-sep?) + (loop (sub1 i) #t))] + [else + (loop (sub1 i) ends-sep?)])]))) + ;; The `split-pos` argument is #f or less than `(sub1 len)` + + (cond + [(not split-pos) + ;; No splitting available: relative or exactly a root + (cond + [(or (is-sep? (bytes-ref bstr 0) convention) + (positive? drive-end)) + ;; root + (define new-p (path (subbytes bstr 0 len) convention)) + (if explode? + (list new-p) + (values #f new-p #t))] + [else + ;; relative + (define-values (name is-dir?) (split-tail bstr len 0 + convention + #:ends-sep? ends-sep? + #:no-up? no-up?)) + (if explode? + (list name) + (values 'relative name is-dir?))])] + [else + ;; Split at the discovered separator + (define-values (name is-dir?) (split-tail bstr len (add1 split-pos) + convention + #:ends-sep? ends-sep? + #:no-up? no-up?)) + (cond + [(zero? split-pos) + (define base (if (eq? (bytes-ref bstr 0) #\/) + (path #"/" convention) + (path (subbytes bstr 0 1) convention))) + (cond + [explode? + (list name base)] + [else + (values base name is-dir?)])] + [else + ;; Is it possible that by removing the last path element, we'll + ;; leave a directory path that needs conversion to \\?\ on + ;; Windows? No: even if the remaining path ends in spaces and + ;; "."s, the path separator will stay in place to make the + ;; trailing spaces and "."s significant. + (define-values (exposed-bstr exposed-len) (values bstr + (let ([len (add1 split-pos)]) + (if (= len drive-end) + keep-drive-end + len)))) + (cond + [explode? + (cons name + (split-after-drive (path exposed-bstr convention) + #:explode? #t + #:len exposed-len + #:drive-end drive-end + #:keep-drive-end keep-drive-end + #:no-slash-sep? no-slash-sep? + #:no-up? no-up? + #:allow-double-before allow-double-before))] + [else + (define base (path (subbytes exposed-bstr 0 exposed-len) convention)) + (values base name is-dir?)])])])) + +;; ---------------------------------------- + +;; Extract a name and `is-dir?` result from the end of a path: +(define (split-tail bstr len start-pos + convention + #:ends-sep? ends-sep? + #:no-up? no-up?) + (cond + ;; check for 'up + [(and (not no-up?) + ((+ start-pos 2) . <= . len) + (eq? (bytes-ref bstr start-pos) (char->integer #\.)) + (eq? (bytes-ref bstr (+ start-pos 1)) (char->integer #\.)) + (or ((+ start-pos 2) . = . len) + (and ((+ start-pos 3) . = . len) + ends-sep?))) + (values 'up #t)] + ;; check for 'same + [(and (not no-up?) + ((+ start-pos 1) . <= . len) + (eq? (bytes-ref bstr start-pos) (char->integer #\.)) + (or ((+ start-pos 1) . = . len) + (and ((+ start-pos 2) . = . len) + ends-sep?))) + (values 'same #t)] + ;; other relative + [else + (define new-bstr (cond + [ends-sep? + (subbytes bstr start-pos (sub1 len))] + [(zero? start-pos) + (bytes->immutable-bytes bstr)] + [else + (subbytes bstr start-pos)])) + (define prot-bstr (if (or no-up? ends-sep?) + (protect-path-element new-bstr convention) + new-bstr)) + (values (path prot-bstr convention) + ends-sep?)])) + +;; ---------------------------------------- + +(define (parse-//?-drive bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (values kind drive-len orig-drive-len)) + +(define (parse-//-drive bstr) + (parse-unc bstr 0)) + +;; Splits a \\?\REL or \\?\RED path +(define (split-reld bstr #:explode? explode?) + (let explode-loop ([bstr bstr]) + (define-values (len is-dir?) + (let ([len (bytes-length bstr)]) + (cond + [(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (values (sub1 len) #t)] + [else + (values len #f)]))) + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr len)) + (cond + [(literal-start . < . len) + ;; There's at least one literal path + (let loop ([p (sub1 len)]) + (cond + [(p . < . (if dots-end (sub1 literal-start) literal-start)) + ;; One one element and no dots + (cond + [(eqv? (bytes-ref bstr 6) (char->integer #\L)) + ;; keep \\?\REL\ on path, and report 'relative as base */ + (define elem (path (if is-dir? (subbytes bstr 0 len) bstr) 'windows)) + (cond + [explode? (list elem)] + [else (values 'relative + elem + is-dir?)])] + [else + ;; Switch "D" to "L", and simplify base to just "\\" + (define base (path #"\\" 'windows)) + (define elem (path + (bytes-append #"\\\\?\\REL\\" + (if (eqv? (bytes-ref bstr 8) (char->integer #\\)) + #"" + #"\\") + (subbytes bstr 8)) + 'windows)) + (cond + [explode? (list elem base)] + [else (values base elem is-dir?)])])] + [(eqv? (bytes-ref bstr p) (char->integer #\\)) + ;; Prefix path element with \\?\REL\\ + (define elem-bstr + (bytes-append #"\\\\?\\REL\\\\" + (subbytes bstr (add1 p) len))) + (define nsep + (cond + [(or (eqv? dots-end p) (eqv? dots-end (sub1 p))) + ;; stripping the only element: drop reundant separator(s) after .. + (if (eqv? dots-end p) 0 -1)] + [(eqv? (bytes-ref bstr 6) (char->integer #\L)) + ;; preserve separator + 1] + ;; preserve one separator, but not two + [(eqv? (bytes-ref bstr (sub1 p)) (char->integer #\\)) + 0] + [else 1])) + (define base-bstr (subbytes bstr 0 (+ p nsep))) + (define elem (path elem-bstr 'windows)) + (cond + [explode? (cons elem (explode-loop base-bstr))] + [else (values (path base-bstr 'windows) elem is-dir?)])] + [else (loop (sub1 p))]))] + [else + ;; There are no literals --- just dots + (cond + [explode? + (let loop ([dots-end dots-end]) + (cond + [(dots-end . > . 9) (cons 'up (loop (- dots-end 3)))] + [else '()]))] + [((- dots-end 3) . > . 8) + (values (path (subbytes bstr 0 (- dots-end 3)) 'windows) + 'up + #t)] + [else + (values 'relative 'up #t)])]))) diff -Nru racket-6.12+ppa1/src/io/path/string.rkt racket-7.0+ppa1/src/io/path/string.rkt --- racket-6.12+ppa1/src/io/path/string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require "../locale/string.rkt" + (rename-in "path.rkt" + [string->path raw:string->path]) + "check.rkt") + +(provide string->path + path->string) + +(define/who (string->path s) + (check who string? s) + (check-path-string who s) + (raw:string->path s)) + +(define/who (path->string p) + (check who is-path? #:contract "path?" p) + (bytes->string/locale (path-bytes p) #\?)) diff -Nru racket-6.12+ppa1/src/io/path/system.rkt racket-7.0+ppa1/src/io/path/system.rkt --- racket-6.12+ppa1/src/io/path/system.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/system.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,70 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../security/main.rkt" + "path.rkt") + +(provide find-system-path + set-exec-file! + set-run-file! + set-collects-dir! + set-config-dir!) + +(define/who (find-system-path key) + (begin0 + (case key + [(exec-file) (or exec-file + (string->path "/usr/local/bin/racket"))] + [(run-file) (or run-file + (find-system-path 'exec-file))] + [(config-dir host-config-dir) (or config-dir + (string->path "../etc"))] + [(collects-dir host-collects-dir) (or collects-dir + (string->path "../collects"))] + [(orig-dir) (string->path (|#%app| current-directory))] + [(temp-dir) (rktio-system-path who RKTIO_PATH_TEMP_DIR)] + [(sys-dir) (rktio-system-path who RKTIO_PATH_SYS_DIR)] + [(pref-dir) (rktio-system-path who RKTIO_PATH_PREF_DIR)] + [(pref-file) (rktio-system-path who RKTIO_PATH_PREF_FILE)] + [(addon-dir) (rktio-system-path who RKTIO_PATH_ADDON_DIR)] + [(home-dir) (rktio-system-path who RKTIO_PATH_HOME_DIR)] + [(desk-dir) (rktio-system-path who RKTIO_PATH_DESK_DIR)] + [(doc-dir) (rktio-system-path who RKTIO_PATH_DOC_DIR)] + [(init-dir) (rktio-system-path who RKTIO_PATH_INIT_DIR)] + [(init-file) (rktio-system-path who RKTIO_PATH_INIT_FILE)] + [else (raise-argument-error who + (string-append + "(or/c 'home-dir 'pref-dir 'pref-file 'temp-dir\n" + " 'init-dir 'init-file 'addon-dir\n" + " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" + " 'collects-dir 'config-dir 'orig-dir\n" + " 'host-collects-dir 'host-config-dir)") + key)]) + (security-guard-check-file who #f '(exists)))) + +(define exec-file #f) +(define (set-exec-file! p) (set! exec-file p)) + +(define run-file #f) +(define (set-run-file! p) (set! run-file p)) + +(define collects-dir #f) +(define (set-collects-dir! p) (set! collects-dir p)) + +(define config-dir #f) +(define (set-config-dir! p) (set! config-dir p)) + +(define (rktio-system-path who key) + (start-atomic) + (define s (rktio_system_path rktio key)) + (cond + [(rktio-error? s) + (end-atomic) + (raise-rktio-error who s "path lookup failed")] + [else + (define bstr (rktio_to_bytes s)) + (rktio_free s) + (end-atomic) + (path bstr (system-path-convention-type))])) diff -Nru racket-6.12+ppa1/src/io/path/windows.rkt racket-7.0+ppa1/src/io/path/windows.rkt --- racket-6.12+ppa1/src/io/path/windows.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/path/windows.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,434 @@ +#lang racket/base +(require "sep.rkt") + +(provide special-filename? + drive-letter? + letter-drive-start? + backslash-backslash-questionmark? + backslash-backslash-questionmark-kind + parse-backslash-backslash-questionmark + parse-unc + backslash-backslash-questionmark-dot-ups-end + split-drive + strip-trailing-spaces + strip-backslash-backslash-rel) + +(define special-filenames + ;; and "CLOCK$" on NT --- but not traditionally detected by Racket + '("NUL" "CON" "PRN" "AUX" + "COM1" "COM2" "COM3" "COM4" "COM5" + "COM6" "COM7" "COM8" "COM9" + "LPT1" "LPT2" "LPT3" "LPT4" "LPT5" + "LPT6" "LPT7" "LPT8" "LPT9")) + +(define (special-filename? in-bstr #:immediate? [immediate? #t]) + (define bstr (cond + [immediate? in-bstr] + [(backslash-backslash-questionmark? in-bstr) #""] + [else + ;; Extract bytes after last sep or after drive letter: + (define len (bytes-length in-bstr)) + (let loop ([i+1 len]) + (cond + [(zero? i+1) + (if (letter-drive-start? bstr len) + (subbytes in-bstr 2) + in-bstr)] + [else + (define i (sub1 i+1)) + (if (is-sep? (bytes-ref in-bstr i) 'windows) + (subbytes in-bstr i+1) + (loop i))]))])) + (define len (bytes-length bstr)) + (cond + [(zero? len) #f] + [(backslash-backslash-questionmark? bstr) #f] + [else + (for/or ([fn (in-list special-filenames)]) + ;; check for case-insensitive `fn` match followed by + ;; '.' or ':' or (whitespace|'.')* + (define fn-len (string-length fn)) + (and (len . >= . fn-len) + (for/and ([c (in-string fn)] + [b (in-bytes bstr)]) + (or (eqv? (char->integer c) b) + (eqv? (char->integer (char-downcase c)) b))) + (or (= len fn-len) + (eqv? (bytes-ref bstr fn-len) (char->integer #\.)) + (eqv? (bytes-ref bstr fn-len) (char->integer #\:)) + (for/and ([b (in-bytes bstr fn-len)]) + (or (eqv? b (char->integer #\space)) + (eqv? b (char->integer #\.)))))))])) + +(define (drive-letter? c) + (or (<= (char->integer #\a) c (char->integer #\z)) + (<= (char->integer #\A) c (char->integer #\Z)))) + +(define (letter-drive-start? bstr len) + (and (len . >= . 2) + (drive-letter? (bytes-ref bstr 0)) + (eqv? (bytes-ref bstr 1) (char->integer #\:)))) + +(define (backslash-backslash-questionmark? bstr) + (define len (bytes-length bstr)) + (and (len . >= . 4) + (eqv? (bytes-ref bstr 0) (char->integer #\\)) + (eqv? (bytes-ref bstr 1) (char->integer #\\)) + (eqv? (bytes-ref bstr 2) (char->integer #\?)) + (eqv? (bytes-ref bstr 3) (char->integer #\\)))) + +;; Returns #f, 'rel, 'red, 'unc, or 'abs +(define (backslash-backslash-questionmark-kind bstr) + (define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + kind) + +;; Returns (values kind drive-len orig-drive-len clean-start-pos sep-bstr) +;; where `kind` is #f, 'rel, 'red, or 'abs +;; +;; For 'abs, then `drive-len` is set to the length of the root +;; specification. For example, if the drive is terminated by \\\ (a +;; weird "root"), then `drive-len` is after the third \. If the drive +;; is \\?\C:\, then `drive-len` is after the last slash. In the case +;; of \\?\UNC\..., `drive-len` is after the UNC part as in +;; `parse-unc` (so it doesn't include a slash after the volume name). +;; +;; The `orig-drive-len` result is almost the same as `drive-len`, +;; but maybe longer. It preserves an artifact of the given specification: +;; a backslash after a \\?\UNC\\ drive, an extra +;; backslash after a \\?\:\ drive, etc. +;; +;; For 'abs, `clean-start-pos` is the position where it's ok to start +;; removing extra slashes. It's usually the same as `drive-len`. In +;; the case of a \\?\UNC\ path, `clean-start` is 7 (i.e., just after +;; that prefix). In the case of a \\?\REL\ or \\?\RED\ path, +;; `clean-start-pos` is the end of the string. +;; +;; For 'abs, the sep-bstr result is a byte string to insert after +;; the root to add further elements. +(define (parse-backslash-backslash-questionmark bstr) + (cond + [(not (backslash-backslash-questionmark? bstr)) + (values #f #f #f #f #f)] + [else + (define len (bytes-length bstr)) + ;; Allow one extra "\": + (define base + (if (and (len . >= . 5) + (eqv? (bytes-ref bstr 4) (char->integer #\\))) + 5 + 4)) + ;; If there are two backslashes in a row at the end, count everything + ;; as the drive; there are two exceptions: two backslashes are ok + ;; at the end in the form \\?\C:\\, and \\?\\\ is \\?\ + (define two-backslashes? + (and (len . > . 5) + (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- len 2)) (char->integer #\\)))) + (cond + [(and two-backslashes? + (= len 6)) + ;; \\?\ is the root + (values 'abs 4 4 3 #"\\\\")] + [(and two-backslashes? + (or (not (= len (+ base 4))) + (not (and (len . > . base) + (drive-letter? (bytes-ref bstr base)))) + (not (and (len . > . (add1 base)) + (eqv? (bytes-ref bstr (add1 base)) (char->integer #\:)))))) + ;; Not the special case \\?\C:\\ + (values 'abs len len len + ;; If not already three \s, preserve this root when + ;; adding more: + (if (not (eqv? (bytes-ref bstr (- len 3)) (char->integer #\\))) + #"\\" + #""))] + ;; If there are three backslashes in a row, count everything + ;; up to the slashes as the drive + [(and (len . > . 6) + (let loop ([i+1 len]) + (cond + [(= i+1 6) #f] + [else + (define i (sub1 i+1)) + (if (and (eqv? (bytes-ref bstr i) (char->integer #\\)) + (eqv? (bytes-ref bstr (- i 1)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- i 2)) (char->integer #\\))) + i + (loop i))]))) + => (lambda (i) + (define i+1 (add1 i)) + (values 'abs i i+1 i+1 #""))] + ;; Check for drive-letter case + [(and (len . > . 6) + (drive-letter? (bytes-ref bstr base)) + (eqv? (bytes-ref bstr (add1 base)) (char->integer #\:)) + (len . > . (+ 2 base)) + (eqv? (bytes-ref bstr (+ 2 base)) (char->integer #\\))) + (define drive-len (+ base 3)) + (define orig-drive-len (if (and (len . > . drive-len) + (eqv? (bytes-ref bstr drive-len) (char->integer #\\))) + (add1 drive-len) + drive-len)) + (values 'abs drive-len orig-drive-len (+ base 2) #"")] + ;; Check for UNC + [(and (len . > . (+ base 3)) + (let ([b (bytes-ref bstr base)]) + (or (eqv? b (char->integer #\U)) (eqv? b (char->integer #\u)))) + (let ([b (bytes-ref bstr (add1 base))]) + (or (eqv? b (char->integer #\N)) (eqv? b (char->integer #\n)))) + (let ([b (bytes-ref bstr (+ base 2))]) + (or (eqv? b (char->integer #\C)) (eqv? b (char->integer #\c)))) + (eqv? (bytes-ref bstr (+ 3 base)) (char->integer #\\)) + (parse-unc bstr #:no-forward-slash? #t + (if (and (len . > . (+ base 4)) + (eqv? (bytes-ref bstr (+ 4 base)) (char->integer #\\))) + (+ base 5) + (+ base 4)))) + => (lambda (drive-len) + (define orig-drive-len + (if (and (len . > . drive-len) + (eqv? (bytes-ref bstr drive-len) (char->integer #\\))) + (add1 drive-len) + drive-len)) + (values 'unc drive-len orig-drive-len (+ base 3) #"\\"))] + ;; Check for REL and RED + [(and (= base 4) + (len . > . 8) + (eqv? (bytes-ref bstr 4) (char->integer #\R)) + (eqv? (bytes-ref bstr 5) (char->integer #\E)) + (let ([b (bytes-ref bstr 6)]) + (or (eqv? b (char->integer #\L)) + (eqv? b (char->integer #\D)))) + (eqv? (bytes-ref bstr 7) (char->integer #\\)) + (or (not (eqv? (bytes-ref bstr 8) (char->integer #\\))) + (len . > . 9))) + (values (if (eqv? (bytes-ref bstr 6) (char->integer #\L)) + 'rel + 'red) + #f + #f + #f + #f)] + ;; Otherwise, \\?\ is the (non-existent) drive + [else + ;; Can have up to two separators between the drive and first element + (define orig-drive-len (if (and (len . > . 4) + (eqv? (bytes-ref bstr 4) (char->integer #\\))) + (if (and (len . > . 5) + (eqv? (bytes-ref bstr 5) (char->integer #\\))) + 6 + 5) + 4)) + (define clean-start-pos + (if (or (and (= len 5) + (eqv? (bytes-ref bstr 4) (char->integer #\\))) + (and (= len 6) + (eqv? (bytes-ref bstr 4) (char->integer #\\)) + (eqv? (bytes-ref bstr 5) (char->integer #\\)))) + 3 + orig-drive-len)) + (values 'abs 4 orig-drive-len clean-start-pos #"\\\\")])])) + +;; Returns an integer if this path is a UNC path, #f otherwise. +;; If `delta` is non-0, then `delta` is after a leading \\. +;; (It starts by checking for \\?\ paths, so they won't be +;; treated as UNC. Unless delta is non-0, in which case the +;; check isn't necessary, presumably because the original +;; `next' already started with \\?\UNC\.) +;; An integer result is set to the length (including offset) of +;; the \\server\vol part; which means that it's either the length of +;; the given byte string or a position that has a separator. +;; If `exact?`, then an integer is returned only if `bstr' is just the +;; drive; that is, only if only slashes are +;; in `bstr' starting with the result integer. +;; If `no-forward-slash?', then only backslashes are recognized. +(define (parse-unc bstr delta + #:exact? [exact? #f] + #:no-forward-slash? [no-forward-slash? #f]) + (cond + [(and (zero? delta) + (backslash-backslash-questionmark? bstr)) + #f] + ;; Bail out fast on an easy non-match: + [(and (zero? delta) + (not + (and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 0) 'windows) + (is-sep? (bytes-ref bstr 1) 'windows)))) + #f] + [else + ;; Check for a drive form: //x/y + (define (is-a-sep? c) (if no-forward-slash? + (eqv? c (char->integer #\\)) + (is-sep? c 'windows))) + (define len (bytes-length bstr)) + (define j (if (zero? delta) 2 delta)) + (and + (not (and (len . > . j) + (is-a-sep? (bytes-ref bstr j)))) + ;; Found non-sep; skip over more + (let loop ([j j]) + (cond + [(= j len) + ;; Didn't find a sep, so not //x/ + #f] + [(not (is-a-sep? (bytes-ref bstr j))) + (cond + [(and no-forward-slash? + (eqv? (bytes-ref bstr j) (char->integer #\/))) + ;; Found / when only \ is allowed as separator + #f] + [else + ;; Keep looking + (loop (add1 j))])] + [else + ;; Found sep again, so we have //x/: + (let* ([j (add1 j)] + [j (if (and no-forward-slash? + (j . < . len) + (is-a-sep? (bytes-ref bstr j))) + ;; two backslashes ok in \\?\UNC mode + (add1 j) + j)]) + (cond + [(and (= j (if (zero? delta) 4 (+ delta 2))) + (eqv? (bytes-ref bstr (- j 2)) (char->integer #\?))) + ;; We have //?/, with up to 2 backslashes. + ;; This doesn't count as UNC, to avoid confusion with \\?\. + #f] + [(and (not no-forward-slash?) + (j . < . len) + (is-a-sep? (bytes-ref bstr j))) + ;; Extra backslash not allowed after /// when not in \\?\ mode + #f] + [else + (let loop ([j j]) + (cond + [(= j len) + ;; Didn't find a non-sep, so not UNC + #f] + [(is-a-sep? (bytes-ref bstr j)) + ;; Keep looking for non-sep + (loop (add1 j))] + [else + ;; Found non-sep again; this is UNC + (let loop ([j j]) + (cond + [(= j len) + ;; Whole string is drive + len] + [(is-a-sep? (bytes-ref bstr j)) + ;; Found sep that ends UNC drive + (and (or (not exact?) + ;; Make sure there are no more separators: + (for/and ([b (in-bytes bstr (add1 j))]) + (not (is-a-sep? b)))) + j)] + [else (loop (add1 j))]))]))]))])))])) + +;; Assumes `bstr` is of the form \\?\REL or \\?\RED and returns +;; (values dots-end literal-start) +;; If `bstr` is \\?\REL\..\..\.., the `dots-end` result is the index just +;; past the last "\..". This might be the first "\" of a "\\" +;; separator, the "\" before a non-".." element, or the end of the +;; string. For a \\?\RED\ path, it's as if there are no ".."s +;; (because ".." is not special in "RED" paths). Otherwise, `dots-end` +;; is #f. +;; The `literal-start` result is the starting index of the literal part of +;; the path (i.e., after one or two slashes, possibly after dots). +(define (backslash-backslash-questionmark-dot-ups-end bstr len) + (define pos + (and (eqv? (bytes-ref bstr 6) (char->integer #\L)) + (let loop ([pos #f] + [j 7]) ;; \\?\REL\ + (cond + [((+ j 3) . > . len) + pos] + [(and (eqv? (bytes-ref bstr j) (char->integer #\\)) + (eqv? (bytes-ref bstr (+ j 1)) (char->integer #\.)) + (eqv? (bytes-ref bstr (+ j 2)) (char->integer #\.)) + (or (= len (+ j 3)) + (eqv? (bytes-ref bstr (+ j 3)) (char->integer #\\)))) + (define j+3 (+ j 3)) + (loop j+3 j+3)] + [else pos])))) + (cond + [pos + (cond + [(= pos len) + (values pos len)] + [(and ((+ pos 2) . < . len) + (eqv? (bytes-ref bstr (add1 pos)) (char->integer #\\))) + (values pos (+ pos 2))] + [else + (values pos (+ pos 1))])] + [(len . > . 8) + (cond + [(eqv? (bytes-ref bstr 8) (char->integer #\\)) + (values #f 9)] + [else + (values #f 8)])] + [else + (values #f 8)])) + +(define (split-drive bstr) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (subbytes bstr 0 drive-len)] + [(parse-unc bstr 0) + => (lambda (pos) (subbytes bstr 0 pos))] + [else + (subbytes bstr 0 (min 3 (bytes-length bstr)))])) + + +(define (strip-trailing-spaces bstr) + (cond + [(backslash-backslash-questionmark? bstr) + ;; all spaces are significant, so don't strip them + bstr] + [else + (define len (bytes-length bstr)) + ;; ignore/keep trailing separators + (define len-before-seps + (let loop ([i+1 len]) + (define i (sub1 i+1)) + (cond + [(is-sep? (bytes-ref bstr i) 'windows) + (if (zero? i) + 0 + (loop i))] + [else i+1]))) + (let loop ([i+1 len-before-seps]) + (cond + [(zero? i+1) + ;; A path element that's all spaces; don't trim + bstr] + [else + (define i (sub1 i+1)) + (define b (bytes-ref bstr i)) + (cond + [(is-sep? b 'windows) + ;; A path element that's all spaces; don't trim + bstr] + [(or (eqv? b (char->integer #\.)) + (eqv? b (char->integer #\space))) + (loop i)] + [(= i+1 len-before-seps) + ;; Nothing to trim + bstr] + [else + ;; Trim + (bytes-append (subbytes bstr 0 i+1) + (subbytes bstr len-before-seps len))])]))])) + +(define (strip-backslash-backslash-rel bstr) + (define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (case kind + [(rel) (subbytes bstr (if (eqv? (bytes-ref bstr 8) (char->integer #\\)) + 9 + 8))] + [else bstr])) diff -Nru racket-6.12+ppa1/src/io/port/buffer-mode.rkt racket-7.0+ppa1/src/io/port/buffer-mode.rkt --- racket-6.12+ppa1/src/io/port/buffer-mode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/buffer-mode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,55 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt") + +(provide file-stream-buffer-mode) + +(define/who file-stream-buffer-mode + (case-lambda + [(p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'file-stream-buffer-mode "port?" p)])]) + (define buffer-mode (core-port-buffer-mode p)) + (atomically + (check-not-closed who p) + (and buffer-mode + (buffer-mode))))] + [(p mode) + (unless (or (input-port? p) (output-port? p)) + (raise-argument-error who "port?" p)) + (unless (or (eq? mode 'none) (eq? mode 'line) (eq? mode 'block)) + (raise-argument-error who "(or/c 'none 'line 'block)" mode)) + (when (and (eq? mode 'line) (not (output-port? p))) + (raise-arguments-error who + "'line buffering not supported for an input port" + "port" p)) + (define (set-buffer-mode p) + (atomically + (check-not-closed who p) + (define buffer-mode (core-port-buffer-mode p)) + (cond + [buffer-mode + (buffer-mode mode) + #t] + [else #f]))) + (cond + [(input-port? p) + (or (set-buffer-mode (->core-input-port p)) + (raise-arguments-error 'file-stream-buffer-mode + "buffering not supported for input port" + "mode" mode + "input port" p))] + [else + (or (set-buffer-mode (->core-output-port p)) + (raise-arguments-error 'file-stream-buffer-mode + "buffering not supported for output port" + "mode" mode + "output port" p))]) + (void)])) diff -Nru racket-6.12+ppa1/src/io/port/bytes-input.rkt racket-7.0+ppa1/src/io/port/bytes-input.rkt --- racket-6.12+ppa1/src/io/port/bytes-input.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/bytes-input.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,198 @@ +#lang racket/base +(require "../common/check.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "input-port.rkt" + "progress-evt.rkt" + "flush-output.rkt") + +(provide read-byte + read-bytes + read-bytes! + read-bytes-avail! + read-bytes-avail!* + read-bytes-avail!/enable-break + + peek-byte + peek-bytes + peek-bytes! + peek-bytes-avail! + peek-bytes-avail!* + peek-bytes-avail!/enable-break) + +(module+ internal + (provide do-read-bytes!)) + +;; ---------------------------------------- + +;; Read `(- end start)` bytes, stopping early only if an EOF is found +(define (do-read-bytes! who in bstr start end) + (define amt (- end start)) + (define v (read-some-bytes! who in bstr start end)) + (cond + [(not (exact-integer? v)) v] + [(= v amt) v] + [else + (let loop ([got v]) + (define v (read-some-bytes! who in bstr got amt #:keep-eof? #t #:special-ok? #f)) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got)])]))])) + +;; ---------------------------------------- + +(define/who (read-byte [orig-in (current-input-port)]) + (check who input-port? orig-in) + (let ([in (->core-input-port orig-in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [read-byte (do-read-byte who read-byte in)] + [else (read-byte-via-bytes in #:special-ok? #f)]))) + +(define/who (read-bytes amt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-bytes amt)) + (define v (do-read-bytes! 'read-bytes in bstr 0 amt)) + (if (exact-integer? v) + (if (= v amt) + bstr + (subbytes bstr 0 v)) + v))) + +(define/who (read-bytes! bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-read-bytes! who in bstr start-pos end-pos))) + +(define (do-read-bytes-avail! who bstr in start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (read-some-bytes! who in bstr start-pos end-pos #:zero-ok? zero-ok? #:enable-break? enable-break?))) + +(define/who (read-bytes-avail! bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos)) + +(define/who (read-bytes-avail!* bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos #:zero-ok? #t)) + +(define/who (read-bytes-avail!/enable-break bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos #:enable-break? #t)) + +;; ---------------------------------------- + +;; Peek `(- end start)` bytes, stopping early only if an EOF is found +(define (do-peek-bytes! who in bstr start end skip) + (define amt (- end start)) + (define v (peek-some-bytes! who in bstr start end skip)) + (if (exact-integer? v) + (cond + [(= v amt) v] + [else + (let loop ([got v]) + (define v (peek-some-bytes! who in bstr got amt (+ got skip) #:copy-bstr? #f #:special-ok? #f)) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got)])]))]) + v)) + +(define/who (peek-byte [orig-in (current-input-port)] [skip-k 0]) + (check who input-port? orig-in) + (check who exact-nonnegative-integer? skip-k) + (let ([in (->core-input-port orig-in)]) + (define peek-byte (and (zero? skip-k) + (core-input-port-peek-byte in))) + (cond + [peek-byte (do-peek-byte who peek-byte in orig-in)] + [else (peek-byte-via-bytes in skip-k #:special-ok? #f)]))) + +(define/who (peek-bytes amt skip-k [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-bytes amt)) + (define v (do-peek-bytes! 'read-bytes in bstr 0 amt skip-k)) + (if (exact-integer? v) + (if (= v amt) + bstr + (subbytes bstr 0 v)) + v))) + +(define/who (peek-bytes! bstr skip-k [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-peek-bytes! who in bstr start-pos end-pos skip-k))) + +(define (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip-k) + (check who (lambda (e) (or (not e) (progress-evt? e))) + #:contract "(or/c #f progress-evt?)" progress-evt) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (when progress-evt + (check-progress-evt who progress-evt in)) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (peek-some-bytes! who in bstr start-pos end-pos skip-k + #:progress-evt (unwrap-progress-evt progress-evt) + #:zero-ok? zero-ok? + #:enable-break? enable-break?))) + +(define/who (peek-bytes-avail! bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos)) + +(define/who (peek-bytes-avail!* bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:zero-ok? #t)) + +(define/who (peek-bytes-avail!/enable-break bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:enable-break? #t)) diff -Nru racket-6.12+ppa1/src/io/port/bytes-output.rkt racket-7.0+ppa1/src/io/port/bytes-output.rkt --- racket-6.12+ppa1/src/io/port/bytes-output.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/bytes-output.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "parameter.rkt" + "write.rkt" + "check.rkt") + +(provide write-byte + write-bytes + write-bytes-avail + write-bytes-avail* + write-bytes-avail/enable-break + write-bytes-avail-evt + port-writes-atomic?) + +(module+ internal + (provide do-write-bytes)) + +(define/who (write-byte b [out (current-output-port)]) + (check who byte? b) + (check who output-port? out) + (let ([out (->core-output-port out)]) + (write-some-bytes 'write-byte out (bytes b) 0 1 #:buffer-ok? #t #:copy-bstr? #f)) + (void)) + +(define (do-write-bytes who out bstr start end) + (let loop ([i start]) + (cond + [(= i end) (- i start)] + [else + (define n (write-some-bytes who out bstr i end #:buffer-ok? #t)) + (loop (+ n i))]))) + +(define/who (write-bytes bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (do-write-bytes who out bstr start-pos end-pos))) + +(define (do-write-bytes-avail who bstr out start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (write-some-bytes who out bstr start-pos end-pos #:zero-ok? zero-ok? #:enable-break? enable-break?))) + +(define/who (write-bytes-avail bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos)) + +(define/who (write-bytes-avail* bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos #:zero-ok? #t)) + +(define/who (write-bytes-avail/enable-break bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos #:enable-break? #t)) + +(define/who (write-bytes-avail-evt bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (atomically + (check-not-closed who out) + (define get-write-evt (core-output-port-get-write-evt out)) + (unless get-write-evt + (end-atomic) + (raise-arguments-error who + "port does not support output events" + "port" out)) + (get-write-evt bstr start-pos end-pos)))) + +(define/who (port-writes-atomic? out) + (check who output-port? out) + (let ([out (->core-output-port out)]) + (and (core-output-port-get-write-evt out) #t))) diff -Nru racket-6.12+ppa1/src/io/port/bytes-port.rkt racket-7.0+ppa1/src/io/port/bytes-port.rkt --- racket-6.12+ppa1/src/io/port/bytes-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/bytes-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,227 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "pipe.rkt" + "bytes-input.rkt" + "count.rkt" + "commit-manager.rkt") + +(provide open-input-bytes + open-output-bytes + get-output-bytes + string-port?) + +(struct input-bytes-data ()) + +(define/who (open-input-bytes bstr [name 'string]) + (check who bytes? bstr) + (define i 0) + (define alt-pos #f) + (define len (bytes-length bstr)) + + (define progress-sema #f) + (define (progress!) + (when progress-sema + (semaphore-post progress-sema) + (set! progress-sema #f))) + + (define commit-manager #f) + + ;; in atomic mode [can leave atomic mode temporarily] + ;; After this function returns, complete any commit-changing work + ;; before leaving atomic mode again. + (define (pause-waiting-commit) + (when commit-manager + (commit-manager-pause commit-manager))) + ;; in atomic mode [can leave atomic mode temporarily] + (define (wait-commit progress-evt ext-evt finish) + (cond + [(and (not commit-manager) + ;; Try shortcut: + (not (sync/timeout 0 progress-evt)) + (sync/timeout 0 ext-evt)) + (finish) + #t] + [else + ;; General case to support blocking and potentially multiple + ;; commiting threads: + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait commit-manager progress-evt ext-evt finish)])) + + (define p + (make-core-input-port + #:name name + #:data (input-bytes-data) + + #:prepare-change + (lambda () + (pause-waiting-commit)) + + #:read-byte + (lambda () + (let ([pos i]) + (if (pos . < . len) + (begin + (set! i (add1 pos)) + (progress!) + (bytes-ref bstr pos)) + eof))) + + #:read-in + (lambda (dest-bstr start end copy?) + (define pos i) + (cond + [(pos . < . len) + (define amt (min (- end start) (- len pos))) + (set! i (+ pos amt)) + (bytes-copy! dest-bstr start bstr pos (+ pos amt)) + (progress!) + amt] + [else eof])) + + #:peek-byte + (lambda () + (let ([pos i]) + (if (pos . < . len) + (bytes-ref bstr pos) + eof))) + + #:peek-in + (lambda (dest-bstr start end skip progress-evt copy?) + (define pos (+ i skip)) + (cond + [(and progress-evt (sync/timeout 0 progress-evt)) + #f] + [(pos . < . len) + (define amt (min (- end start) (- len pos))) + (bytes-copy! dest-bstr start bstr pos (+ pos amt)) + amt] + [else eof])) + + #:byte-ready + (lambda (work-done!) + (i . < . len)) + + #:close + (lambda () + (set! commit-manager #f) ; to indicate closed + (progress!)) + + #:get-progress-evt + (lambda () + (unless progress-sema + (set! progress-sema (make-semaphore))) + (semaphore-peek-evt progress-sema)) + + #:commit + (lambda (amt progress-evt ext-evt finish) + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait + commit-manager + progress-evt ext-evt + ;; in atomic mode, maybe in a different thread: + (lambda () + (let ([amt (min amt (- len i))]) + (define dest-bstr (make-bytes amt)) + (bytes-copy! dest-bstr 0 bstr i (+ i amt)) + (set! i (+ i amt)) + (progress!) + (finish dest-bstr))))) + + #:file-position + (case-lambda + [() (or alt-pos i)] + [(new-pos) + (set! i (if (eof-object? new-pos) + len + (min len new-pos))) + (set! alt-pos + (and new-pos + (not (eof-object? new-pos)) + (new-pos . > . i) + new-pos))]))) + + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +;; ---------------------------------------- + +(struct output-bytes-data (i reset)) + +(define (open-output-bytes [name 'string]) + (define-values (i o) (make-pipe)) + (define p + (make-core-output-port + #:name name + #:data (output-bytes-data i (lambda () (pipe-discard-all i))) + #:evt o + #:write-out (core-output-port-write-out o) + #:close (core-port-close o) + #:get-write-evt (core-output-port-get-write-evt o) + #:get-location (core-port-get-location o) + #:count-lines! (core-port-count-lines! o) + #:file-position + (case-lambda + [() (pipe-write-position o)] + [(new-pos) + (define len (pipe-content-length i)) + (cond + [(eof-object? new-pos) + (pipe-write-position o len)] + [(new-pos . > . len) + (when (new-pos . >= . (expt 2 48)) + ;; implausibly large + (end-atomic) + (raise-arguments-error 'file-position + "new position is too large" + "port" p + "position" new-pos)) + (pipe-write-position o len) + (define amt (- new-pos len)) + ((core-output-port-write-out o) (make-bytes amt 0) 0 amt #f #f #f) + (void)] + [else + (pipe-write-position o new-pos)])]))) + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +(define/who (get-output-bytes o [reset? #f] [start-pos 0] [end-pos #f]) + (check who (lambda (v) (and (output-port? o) (string-port? o))) + #:contract "(and/c output-port? string-port?)" + o) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? #:or-false end-pos) + (let ([o (->core-output-port o)]) + (define i (output-bytes-data-i (core-port-data o))) + (define len (pipe-content-length i)) + (when (start-pos . > . len) + (raise-range-error who "port content" "starting " start-pos o 0 len #f)) + (when end-pos + (unless (<= start-pos end-pos len) + (raise-range-error who "port content" "ending " end-pos o 0 len start-pos))) + (define amt (- (min len (or end-pos len)) start-pos)) + (define bstr (make-bytes amt)) + (peek-bytes! bstr start-pos i) + (when reset? + ((output-bytes-data-reset (core-port-data o)))) + bstr)) + +;; ---------------------------------------- + +(define (string-port? p) + (cond + [(input-port? p) + (let ([p (->core-input-port p)]) + (input-bytes-data? (core-port-data p)))] + [(output-port? p) + (let ([p (->core-output-port p)]) + (output-bytes-data? (core-port-data p)))] + [else + (raise-argument-error 'string-port? "port?" p)])) diff -Nru racket-6.12+ppa1/src/io/port/check.rkt racket-7.0+ppa1/src/io/port/check.rkt --- racket-6.12+ppa1/src/io/port/check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,25 @@ +#lang racket/base +(require "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "close.rkt") + +(provide check-not-closed) + +;; in atomic mode +;; Atomic mode is required on entry because an operation +;; that is prefixed when a port-closed check normally needs +;; to happen atomically with respect to the check. +(define (check-not-closed who cp) + (when (closed-state-closed? (core-port-closed cp)) + (end-atomic) + (define input? (core-input-port? cp)) + (raise-arguments-error who + (if input? + "input port is closed" + "output port is closed") + (if input? + "input port" + "output port") + cp))) diff -Nru racket-6.12+ppa1/src/io/port/close.rkt racket-7.0+ppa1/src/io/port/close.rkt --- racket-6.12+ppa1/src/io/port/close.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/close.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,64 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt") + +(provide port-closed? + close-input-port + close-output-port + port-closed-evt + + close-port + set-closed-state!) + +(define (port-closed? p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'close-input-port "port?" p)])]) + (closed-state-closed? (core-port-closed p)))) + +;; maybe in atomic mode via custodian shutdown: +(define (close-port p) + (define closed (core-port-closed p)) + (unless (closed-state-closed? closed) + (atomically + ((core-port-close p)) + (set-closed-state! closed)))) + +;; in atomic mode +(define (set-closed-state! closed) + (unless (closed-state-closed? closed) + (set-closed-state-closed?! closed #t) + (let ([s (closed-state-closed-sema closed)]) + (when s (semaphore-post s))))) + +(define/who (close-input-port p) + (check who input-port? p) + (close-port (->core-input-port p))) + +(define/who (close-output-port p) + (check who output-port? p) + (close-port (->core-output-port p))) + +(define (port-closed-evt p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'port-closed-evt "port?" p)])]) + (define closed (core-port-closed p)) + (define sema + (atomically + (or (closed-state-closed-sema closed) + (let ([s (make-semaphore)]) + (set-closed-state-closed-sema! closed s) + (when (closed-state-closed? closed) + (semaphore-post s)) + s)))) + (define self (wrap-evt (semaphore-peek-evt sema) + (lambda (v) self))) + self)) diff -Nru racket-6.12+ppa1/src/io/port/commit-manager.rkt racket-7.0+ppa1/src/io/port/commit-manager.rkt --- racket-6.12+ppa1/src/io/port/commit-manager.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/commit-manager.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,139 @@ +#lang racket/base +(require "../host/thread.rkt") + +;; A commit manager orchestrates attempts to commit peeked +;; bytes in potentially many threads + +(provide make-commit-manager + commit-manager-pause + commit-manager-wait) + +(struct commit-manager (pause-channel commit-channel thread)) + +(struct commit-request (ext-evt progress-evt abandon-evt finish result-ch)) +(struct commit-response (abandon-evt result-put-evt)) + +(define (make-commit-manager) + (define pause-ch (make-channel)) + (define commit-ch (make-channel)) + (commit-manager + pause-ch + commit-ch + (thread + (lambda () + (let loop ([reqs '()] [resps '()]) + ;; Poll progress and abandon evts: + (define-values (live-reqs new-resps) + (poll-commit-liveness reqs resps)) + ;; Drop abandoned responses, too: + (define live-resps + (drop-abandoned new-resps)) + (apply + sync + (handle-evt pause-ch + (lambda (evt) + ;; The port's state can change in other + ;; threads only while the manager thread is + ;; right here, before the `sync` completes: + (sync evt) + (loop live-reqs live-resps))) + (handle-evt commit-ch + (lambda (req) + (loop (cons req live-reqs) live-resps))) + (append + (for/list ([req (in-list live-reqs)]) + (handle-evt (commit-request-ext-evt req) + (lambda (v) + ;; commit request succeeds + (atomically + ((commit-request-finish req))) + (loop (remq req live-reqs) + (cons (commit-response + (commit-request-abandon-evt req) + (channel-put-evt + (commit-request-result-ch req) + #t)) + live-resps))))) + (for/list ([resp (in-list live-resps)]) + (handle-evt (commit-response-result-put-evt resp) + (lambda (ignored) + ;; response delivered + (loop live-reqs + (remq resp live-resps)))))))))))) + +(define (poll-commit-liveness reqs resps) + (let loop ([reqs reqs] [live-reqs '()] [resps resps]) + (cond + [(null? reqs) (values live-reqs resps)] + [(sync/timeout 0 (commit-request-progress-evt (car reqs))) + ;; commit fails + (loop (cdr reqs) + live-reqs + (cons (commit-response + (commit-request-abandon-evt (car reqs)) + (channel-put-evt + (commit-request-result-ch (car reqs)) + #f)) + resps))] + [(sync/timeout 0 (commit-request-abandon-evt (car reqs))) + ;; request abandoned + (loop (cdr reqs) live-reqs resps)] + [else + (loop (cdr reqs) (cons (car reqs) live-reqs) resps)]))) + +(define (drop-abandoned resps) + (for/list ([resp (in-list resps)] + #:unless (sync/timeout 0 (commit-response-abandon-evt resp))) + resp)) + +;; in atomic mode; can leave it and return +;; After this function returns, the committing thread +;; is definitely not trying to sync to complete +;; a commit, but it can resume as soon as we go back +;; out of atomic mode +(define (commit-manager-pause mgr) + (define lock (make-semaphore)) + (define suspend-evt (thread-suspend-evt (current-thread))) + (dynamic-wind + void + (lambda () + (non-atomically + ;; the manager thread, just in case: + (thread-resume (commit-manager-thread mgr) (current-thread)) + ;; ask the manager to pause; syncing on the channel means that + ;; it has stopped trying a commit sync; we let the manager + ;; thread resume by posting to th elock --- but beware that + ;; *this* thread might get suspended or killed + (sync + (channel-put-evt (commit-manager-pause-channel mgr) + (choice-evt (list lock + suspend-evt + (thread-dead-evt (current-thread)))))))) + (lambda () + ;; Either back in atomic mode or escaping, so it's ok for the + ;; waiting thread to try again when it eventually gets to run + (semaphore-post lock))) + ;; If this thread was suspended during `pause-waiting-commit`, we + ;; may have let the committing thread go, so try again + (when (sync/timeout 0 suspend-evt) + (commit-manager-pause mgr))) + +;; in atmomic mode; can leave it and return +(define (commit-manager-wait mgr progress-evt ext-evt finish) + (define result-ch (make-channel)) + (define abandon-evt (make-semaphore)) + (dynamic-wind + void + (lambda () + (non-atomically + (sync + (channel-put-evt (commit-manager-commit-channel mgr) + (commit-request ext-evt + progress-evt + (choice-evt (list abandon-evt + (thread-dead-evt (current-thread)))) + finish + result-ch))) + (sync result-ch))) + (lambda () + (semaphore-post abandon-evt)))) diff -Nru racket-6.12+ppa1/src/io/port/count.rkt racket-7.0+ppa1/src/io/port/count.rkt --- racket-6.12+ppa1/src/io/port/count.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/count.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,210 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt" + "file-position.rkt" + "../string/utf-8-decode.rkt") + +(provide port-count-lines-enabled + + port-count-lines! + port-counts-lines? + port-next-location + set-port-next-location! + + port-count! + port-count-byte! + + port-count-all! + port-count-byte-all!) + +(define port-count-lines-enabled + (make-parameter #f (lambda (v) (and v #t)))) + +(define/who (port-count-lines! p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else (check who #:test #f #:contract "port?" p)])]) + (atomically + (check-not-closed who p) + (unless (core-port-count? p) + (set-core-port-count?! p #t) + (set-core-port-line! p 1) + (set-core-port-column! p 0) + (set-core-port-position! p (add1 (or (core-port-offset p) 0))) + (define count-lines! (core-port-count-lines! p)) + (when count-lines! + (count-lines!)))))) + +(define/who (port-counts-lines? p) + (core-port-count? + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (check who #:test #f #:contract "port?" p)]))) + +(define/who (port-next-location p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (check who #:test #f #:contract "port?" p)])]) + (cond + [(core-port-count? p) + (atomically + (check-not-closed who p) + (define get-location (core-port-get-location p)) + (cond + [get-location + (get-location)] + [else + (values (core-port-line p) + (core-port-column p) + (core-port-position p))]))] + [(core-port-file-position p) + (define offset (do-simple-file-position who p (lambda () #f))) + (values #f #f (and offset (add1 offset)))] + [else + (define offset (core-port-offset p)) + (values #f #f (and offset (add1 offset)))]))) + +(define/who (set-port-next-location! p line col pos) + (check who (lambda (p) (or (input-port? p) (output-port? p))) + #:contract "port?" + p) + (check who #:or-false exact-positive-integer? line) + (check who #:or-false exact-nonnegative-integer? col) + (check who #:or-false exact-positive-integer? pos) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])]) + (atomically + (when (and (core-port-count? p) + (not (core-port-count-lines! p))) + (set-core-port-line! p line) + (set-core-port-column! p col) + (set-core-port-position! p pos))))) + +;; in atomic mode +;; When line counting is enabled, increment line, column, etc. counts +;; --- which involves UTF-8 decoding. To make column and position counting +;; interact well with decoding errors, the column and position are advanced +;; while accumulating decoding information, and then the column and position +;; can go backwards when the decoding completes. +(define (port-count! in amt bstr start) + (increment-offset! in amt) + (when (core-port-count? in) + (define end (+ start amt)) + (let loop ([i start] + [span 0] ; number of previous bytes still to send to UTF-8 decoding + [line (core-port-line in)] + [column (core-port-column in)] + [position (core-port-position in)] + [state (core-port-state in)] + [cr-state (core-port-cr-state in)]) ; #t => previous char was #\return + (define (finish-utf-8 i abort-mode) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr (- i span) i + #f 0 #f + #:error-char #\? + #:abort-mode abort-mode + #:state state)) + (define delta-chars (- got-chars + ;; Correct for earlier increment of position + ;; and column based on not-yet-decoded bytes, + ;; leaving counts for still-not-decoded bytes + ;; in place: + (+ span + (- (if (utf-8-state? state) + (utf-8-state-pending-amt state) + 0) + (if (utf-8-state? new-state) + (utf-8-state-pending-amt new-state) + 0))))) + (define (keep-aborts s) (if (eq? s 'complete) #f s)) + (loop i 0 line (and column (+ column delta-chars)) (and position (+ position delta-chars)) + (keep-aborts new-state) #f)) + (cond + [(= i end) + (cond + [(zero? span) + (set-core-port-line! in line) + (set-core-port-column! in column) + (set-core-port-position! in position) + (set-core-port-state! in state) + (set-core-port-cr-state! in cr-state)] + [else + ;; span doesn't include CR, LF, or tab + (finish-utf-8 end 'state)])] + [else + (define b (bytes-ref bstr i)) + (define (end-utf-8) ; => next byte is ASCII, so we can terminate a UTF-8 sequence + (finish-utf-8 i 'error)) + (cond + [(eq? b (char->integer #\newline)) + (cond + [(or state (not (zero? span))) (end-utf-8)] + [cr-state + ;; "\r\n" combination counts as a single position + (loop (add1 i) 0 line column position #f #f)] + [else + (loop (add1 i) 0 (and line (add1 line)) (and column 0) (and position (add1 position)) #f #f)])] + [(eq? b (char->integer #\return)) + (if (and (zero? span)(not state)) + (loop (add1 i) 0 (and line (add1 line)) (and column 0) (and position (add1 position)) #f #t) + (end-utf-8))] + [(eq? b (char->integer #\tab)) + (if (and (zero? span) (not state)) + (loop (add1 i) 0 line (and column (+ (bitwise-and column -8) 8)) (and position (add1 position)) #f #f) + (end-utf-8))] + [(b . < . 128) + (if (and (zero? span) (not state)) + (loop (add1 i) 0 line (and column (add1 column)) (and position (add1 position)) #f #f) + (loop (add1 i) (add1 span) line (and column (add1 column)) (and position (add1 position)) state #f))] + [else + ;; This is where we tentatively increment the column and position, to be + ;; reverted later if decoding collapses multiple bytes: + (loop (add1 i) (add1 span) line (and column (add1 column)) (and position (add1 position)) state #f)])])))) + +;; in atomic mode +(define (port-count-all! in extra-ins amt bstr start) + (port-count! in amt bstr start) + (for ([in (in-list extra-ins)]) + (port-count! in amt bstr start))) + +;; in atomic mode +;; If `b` is not a byte, it is treated like +;; a non-whitespace byte. +(define (port-count-byte! in b) + (increment-offset! in 1) + (when (core-port-count? in) + (cond + [(or (core-port-state in) + (core-port-cr-state in) + (and (fixnum? b) (b . > . 127)) + (eq? b (char->integer #\return)) + (eq? b (char->integer #\newline)) + (eq? b (char->integer #\tab))) + (port-count! in 1 (bytes b) 0)] + [else + (let ([column (core-port-column in)] + [position (core-port-position in)]) + (when position (set-core-port-position! in (add1 position))) + (when column (set-core-port-column! in (add1 column))))]))) + +;; in atomic mode +(define (port-count-byte-all! in extra-ins b) + (port-count-byte! in b) + (for ([in (in-list extra-ins)]) + (port-count-byte! in b))) + +;; in atomic mode +(define (increment-offset! in amt) + (define old-offset (core-port-offset in)) + (when old-offset + (set-core-port-offset! in (+ amt old-offset)))) diff -Nru racket-6.12+ppa1/src/io/port/custom-input-port.rkt racket-7.0+ppa1/src/io/port/custom-input-port.rkt --- racket-6.12+ppa1/src/io/port/custom-input-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/custom-input-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,295 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "input-port.rkt" + "custom-port.rkt" + "pipe.rkt" + "peek-via-read-port.rkt") + +(provide make-input-port) + +(define/who (make-input-port name + user-read-in + user-peek-in + user-close + [user-get-progress-evt #f] + [user-commit #f] + [user-get-location #f] + [user-count-lines! void] + [user-init-position 1] + [user-buffer-mode #f]) + (check who + (lambda (p) (or (input-port? p) (and (procedure? p) (procedure-arity-includes? p 1)))) + #:contract "(or/c (procedure-arity-includes/c 1) input-port?)" + user-read-in) + (check who + (lambda (p) (or (not p) (input-port? p) (and (procedure? p) (procedure-arity-includes? p 3)))) + #:contract "(or/c (procedure-arity-includes/c 3) input-port? #f)" + user-peek-in) + (check who (procedure-arity-includes/c 0) user-close) + (check who (procedure-arity-includes/c 0) #:or-false user-get-progress-evt) + (check who (procedure-arity-includes/c 3) #:or-false user-commit) + (check who (procedure-arity-includes/c 0) #:or-false user-get-location) + (check who (procedure-arity-includes/c 0) #:or-false user-count-lines!) + (check-init-position who user-init-position) + (check-buffer-mode who user-buffer-mode) + + (when (not (eqv? (input-port? user-read-in) (input-port? user-peek-in))) + (raise-arguments-error who (if (input-port? user-read-in) + "read argument is an input port, but peek argument is not a port" + "read argument is not an input port, but peek argument is a port") + "read argument" user-read-in + "peek argument" user-peek-in)) + + (when (and (not user-peek-in) user-get-progress-evt) + (raise-arguments-error who "peek argument is #f, but progress-evt argument is not" + "progress-evt argument" user-get-progress-evt)) + + (when (and (not user-get-progress-evt) user-commit) + (raise-arguments-error who "progress-evt argument is #f, but commit argument is not" + "commit argument" user-commit)) + (when (and (not user-commit) user-get-progress-evt) + (raise-arguments-error who "commit argument is #f, but progress-evt argument is not" + "progress-evt argument" user-get-progress-evt)) + + (define input-pipe #f) ; `user-read-in` can redirect input + + (define (protect-in dest-bstr dest-start dest-end copy? read-in) + ;; We don't trust `read-in` to refrain from modifying its + ;; byte-string argument after it returns, and the `read-in` + ;; interface doesn't deal with start and end positions, so copy` + ;; dest-bstr` if needed + (define len (- dest-end dest-start)) + (define user-bstr + (if (or copy? + (not (zero? dest-start)) + (not (= len dest-end))) + (make-bytes len) + dest-bstr)) + (define n (read-in user-bstr)) + (cond + [(eq? user-bstr dest-bstr) + n] + [(evt? n) + (wrap-evt n + (lambda (n) + (when (exact-positive-integer? n) + (bytes-copy! dest-bstr dest-start user-bstr 0 n)) + n))] + [else + (when (exact-positive-integer? n) + (bytes-copy! dest-bstr dest-start user-bstr 0 n)) + n])) + + ;; in atomic mode + (define (check-read-result who r dest-start dest-end #:peek? [peek? #f] #:ok-false? [ok-false? #f]) + (cond + [(exact-nonnegative-integer? r) + (unless (r . <= . (- dest-end dest-start)) + (end-atomic) + (raise-arguments-error who "result integer is larger than the supplied byte string" + "result" r + "byte-string length" (- dest-end dest-start)))] + [(eof-object? r) (void)] + [(and (procedure? r) (procedure-arity-includes? r 4)) + (unless user-peek-in + (end-atomic) + (raise-arguments-error who + (string-append "the port has no specific peek procedure, so" + " a special read result is not allowed") + "special result" r))] + [(pipe-input-port? r) + (set! input-pipe r)] + [(evt? r) r] + [(and peek? (not r)) + (unless ok-false? + (end-atomic) + (raise-arguments-error who "returned #f when no progress evt was supplied"))] + [else + (end-atomic) + (raise-result-error who + (string-append + "(or/c exact-nonnegative-integer? eof-object? evt? pipe-input-port?" + (if (and peek? ok-false?) + " #f" + "") + (if user-peek-in + " (procedure-arity-includes/c 4)" + "") + ")") + r)])) + + ;; possibly in atomic mode + (define (wrap-check-read-evt-result who evt dest-start dest-end peek? ok-false?) + (wrap-evt evt (lambda (r) + (start-atomic) + (check-read-result who r dest-start dest-end #:peek? peek? #:ok-false? ok-false?) + (end-atomic) + (cond + [(pipe-input-port? r) 0] + [(evt? r) + (wrap-check-read-evt-result who r dest-start dest-end peek? ok-false?)] + [else r])))) + + ;; possibly in atomic mode + (define (wrap-procedure-result r) + (define called? #f) + (define (called!) + (when called? + (raise-arguments-error 'read-special "cannot be called a second time")) + (set! called? #t)) + (define (four-args a b c d) + (called!) + (check 'read-special exact-positive-integer? #:or-false b) + (check 'read-special exact-nonnegative-integer? #:or-false c) + (check 'read-special exact-positive-integer? #:or-false d) + (r a b c d)) + (cond + [(procedure-arity-includes? r 0) + (case-lambda + [() (called!) (r)] + [(a b c d) (four-args a b c d)])] + [else + four-args])) + + ;; in atomic mode + (define (read-in dest-bstr dest-start dest-end copy?) + (cond + [input-pipe + (cond + [(zero? (pipe-content-length input-pipe)) + (set! input-pipe #f) + (read-in dest-bstr dest-start dest-end copy?)] + [else + ((core-input-port-read-in input-pipe) dest-bstr dest-start dest-end copy?)])] + [else + (define r + (parameterize-break #f + (non-atomically + (protect-in dest-bstr dest-start dest-end copy? user-read-in)))) + (check-read-result '|user port read| r dest-start dest-end) + (cond + [(pipe-input-port? r) + (read-in dest-bstr dest-start dest-end copy?)] + [(evt? r) + (wrap-check-read-evt-result '|user port read| r dest-start dest-end #f #f)] + [(procedure? r) + (wrap-procedure-result r)] + [else r])])) + + ;; in atomic mode + ;; Used only if `user-peek-in` is a function: + (define (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?) + (cond + [input-pipe + (cond + [((pipe-content-length input-pipe) . <= . skip-k) + (set! input-pipe #f) + (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?)] + [else + ((core-input-port-peek-in input-pipe) dest-bstr dest-start dest-end skip-k progress-evt copy?)])] + [else + (define r + (parameterize-break #f + (non-atomically + (protect-in dest-bstr dest-start dest-end copy? + (lambda (user-bstr) (user-peek-in user-bstr skip-k progress-evt)))))) + (check-read-result '|user port peek| r dest-start dest-end #:peek? #t #:ok-false? progress-evt) + (cond + [(pipe-input-port? r) + (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?)] + [(evt? r) + (wrap-check-read-evt-result '|user port peek| r dest-start dest-end #t progress-evt)] + [(procedure? r) + (wrap-procedure-result r)] + [else r])])) + + ;; in atomic mode + ;; Used only if `user-peek-in` is a function: + (define (byte-ready work-done!) + (cond + [(and input-pipe + (positive? (pipe-content-length input-pipe))) + #t] + [else + (define bstr (make-bytes 1)) + (define v (peek-in bstr 0 1 0 #f #f)) + (work-done!) + (cond + [(evt? v) v] + [else (not (eqv? v 0))])])) + + ;; in atomic mode + (define (close) + (end-atomic) + (user-close) + (start-atomic)) + + (define (get-progress-evt) + (define r (user-get-progress-evt)) + (unless (evt? r) + (raise-result-error '|user port progress-evt| "evt?" r)) + r) + + ;; in atomic mode + (define (commit amt evt ext-evt finish) + (define r + (parameterize-break #f + (non-atomically + (user-commit amt evt ext-evt)))) + (cond + [(not r) #f] + [(bytes? r) (finish r) #t] + [else (finish (make-bytes amt (char->integer #\x))) #t])) + + (define get-location + (and user-get-location + (make-get-location user-get-location))) + + (define count-lines! + (and user-count-lines! + (lambda () (end-atomic) (user-count-lines!) (start-atomic)))) + + (define-values (init-offset file-position) + (make-init-offset+file-position user-init-position)) + + (define buffer-mode + (and user-buffer-mode + (make-buffer-mode user-buffer-mode))) + + (cond + [user-peek-in + (make-core-input-port + #:name name + #:read-in + (if (input-port? user-read-in) + user-read-in + read-in) + #:peek-in + (if (input-port? user-peek-in) + user-peek-in + peek-in) + #:byte-ready + (if (input-port? user-peek-in) + user-peek-in + byte-ready) + #:close close + #:get-progress-evt (and user-get-progress-evt get-progress-evt) + #:commit (and user-commit commit) + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode buffer-mode)] + [else + (define-values (port buffer-flusher) + (open-input-peek-via-read + #:name name + #:read-in read-in + #:close close + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:alt-buffer-mode buffer-mode)) + port])) diff -Nru racket-6.12+ppa1/src/io/port/custom-output-port.rkt racket-7.0+ppa1/src/io/port/custom-output-port.rkt --- racket-6.12+ppa1/src/io/port/custom-output-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/custom-output-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,186 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "custom-port.rkt" + "pipe.rkt") + +(provide make-output-port) + +(define/who (make-output-port name + evt + user-write-out + user-close + [user-write-out-special #f] + [user-get-write-evt #f] + [user-get-write-special-evt #f] + [user-get-location #f] + [user-count-lines! void] + [user-init-position 1] + [user-buffer-mode #f]) + (check who evt? evt) + (check who (lambda (p) (or (output-port? p) + (and (procedure? p) + (procedure-arity-includes? p 5)))) + #:contract "(or/c output-port? (procedure-arity-includes/c 5))" + user-write-out) + (check who (procedure-arity-includes/c 0) user-close) + (check who (lambda (p) (or (not p) + (output-port? p) + (and (procedure? p) + (procedure-arity-includes? p 3)))) + #:contract "(or/c #f output-port? (procedure-arity-includes/c 3))" + user-write-out-special) + (check who #:or-false (procedure-arity-includes/c 3) user-get-write-evt) + (check who #:or-false (procedure-arity-includes/c 1) user-get-write-special-evt) + (check who #:or-false (procedure-arity-includes/c 0) user-get-location) + (check who (procedure-arity-includes/c 0) user-count-lines!) + (check-init-position who user-init-position) + (check-buffer-mode who user-buffer-mode) + + (when (and (not user-write-out-special) user-get-write-special-evt) + (raise-arguments-error who "write-special argument is #f, but get-write-special-evt argument is not" + "get-write-special-evt argument" user-get-write-special-evt)) + + (when (and (not user-get-write-evt) user-get-write-special-evt) + (raise-arguments-error who "get-write-evt argument is #f, but get-write-special-evt argument is not" + "get-write-special-evt argument" user-get-write-special-evt)) + + (when (and (not user-get-write-special-evt) user-get-write-evt user-write-out-special) + (raise-arguments-error who + "get-write-special-evt argument is #f, but get-write-evt argument is not, and write-special argument is not" + "get-write-evt argument" user-get-write-evt + "get-write-special-evt argument" user-get-write-special-evt)) + + (define output-pipe #f) + + ;; in atomic mode + (define (check-write-result who r start end non-block/buffer? #:as-evt? [as-evt? #f]) + (cond + [(exact-nonnegative-integer? r) + (if (eqv? r 0) + (unless (= start end) + (end-atomic) + (raise-arguments-error who (string-append + "bad result for non-flush write" + (if as-evt? " event" "")) + "result" r)) + (unless (r . <= . (- end start)) + (end-atomic) + (raise-arguments-error who "result integer is larger than the supplied byte string" + "result" r + "byte string length" (- end start))))] + [(not r) r] + [(pipe-output-port? r) + (when (= start end) + (end-atomic) + (raise-arguments-error who "bad result for a flushing write" + "result" r)) + (when non-block/buffer? + (end-atomic) + (raise-arguments-error who "bad result for a non-blocking write" + "result" r)) + (set! output-pipe r)] + [(evt? r) + (void)] + [else + (end-atomic) + (raise-result-error who "(or/c exact-nonnegative-integer? #f evt?)" r)])) + + + ;; possibly in atomic mode + (define (wrap-check-write-evt-result who evt start end non-block/buffer?) + (wrap-evt evt (lambda (r) + (start-atomic) + (check-write-result who r start end non-block/buffer? #:as-evt? #t) + (end-atomic) + (cond + [(pipe-output-port? r) 0] + [(evt? r) + (wrap-check-write-evt-result who r start end non-block/buffer?)] + [else r])))) + + ;; in atomic mode + (define (write-out bstr start end non-block/buffer? enable-break? copy?) + (cond + [output-pipe + (cond + [(or non-block/buffer? + (= start end) + (not (sync/timeout 0 output-pipe))) + (set! output-pipe #f) + (write-out bstr start end non-block/buffer? enable-break? copy?)] + [else + ((core-output-port-write-out output-pipe) bstr start end non-block/buffer? enable-break? copy?)])] + [else + (define r + ;; Always tell user port to re-enable breaks if it blocks, since + ;; we always disable breaks: + (let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) + (parameterize-break #f + (non-atomically + (if copy? + (user-write-out (subbytes bstr start end) 0 (- end start) non-block/buffer? enable-break?) + (user-write-out bstr start end non-block/buffer? enable-break?)))))) + (check-write-result '|user port write| r start end non-block/buffer?) + (cond + [(pipe-output-port? r) + (write-out bstr start end non-block/buffer? enable-break? copy?)] + [(evt? r) + (wrap-check-write-evt-result '|user port write| r start end non-block/buffer?)] + [else r])])) + + (define (get-write-evt bstr start end) + (end-atomic) + (define r (user-get-write-evt bstr start end)) + (unless (evt? r) + (raise-result-error '|user port get-write-evt| "evt?" r)) + (start-atomic) + (wrap-check-write-evt-result '|user port write-evt| r start end #t)) + + (define (write-out-special v non-block/buffer? enable-break?) + (let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) + (parameterize-break #f + (non-atomically + (user-write-out-special v non-block/buffer? enable-break?))))) + + (define get-location + (and user-get-location + (make-get-location user-get-location))) + + (define count-lines! + (and user-count-lines! + (lambda () (end-atomic) (user-count-lines!) (start-atomic)))) + + (define-values (init-offset file-position) + (make-init-offset+file-position user-init-position)) + + (define buffer-mode + (and user-buffer-mode + (make-buffer-mode user-buffer-mode #:output? #t))) + + ;; in atomic mode + (define (close) + (end-atomic) + (user-close) + (start-atomic)) + + (make-core-output-port + #:name name + #:evt evt + #:write-out + (if (output-port? user-write-out) + user-write-out + write-out) + #:close close + #:write-out-special + (if (output-port? user-write-out-special) + user-write-out-special + (and user-write-out-special write-out-special)) + #:get-write-evt (and user-get-write-evt get-write-evt) + #:get-write-special-evt user-get-write-special-evt + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode buffer-mode)) diff -Nru racket-6.12+ppa1/src/io/port/custom-port.rkt racket-7.0+ppa1/src/io/port/custom-port.rkt --- racket-6.12+ppa1/src/io/port/custom-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/custom-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,96 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "input-port.rkt" + "output-port.rkt") + +;; Common functionality for "custom-input-port.rkt" and +;; "custom-output-port.rkt" + +(provide make-get-location + + check-init-position + make-init-offset+file-position + + check-buffer-mode + make-buffer-mode) + + +;; in atomic mode +(define (make-get-location user-get-location) + (lambda () + (end-atomic) + (call-with-values + (lambda () (user-get-location)) + (case-lambda + [(line col pos) + (unless (or (not line) (exact-positive-integer? line)) + (raise-result-error '|user port get-location| "(or/c #f exact-positive-integer?)" line)) + (unless (or (not line) (exact-nonnegative-integer? col)) + (raise-result-error '|user port get-location| "(or/c #f exact-nonnegative-integer?)" col)) + (unless (or (not line) (exact-positive-integer? pos)) + (raise-result-error '|user port get-location| "(or/c #f exact-positive-integer?)" pos)) + (start-atomic) + (values line col pos)] + [args + (apply raise-arity-error '|user port get-location return| 3 args)])))) + +(define (check-init-position who user-init-position) + (check who (lambda (p) (or (exact-positive-integer? p) + (input-port? p) + (output-port? p) + (not p) + (and (procedure? p) (procedure-arity-includes? p 0)))) + #:contract "(or/c exact-positive-integer? port? #f (procedure-arity-includes/c 0))" + user-init-position)) + +(define (make-init-offset+file-position user-init-position) + (define init-offset + (if (or (procedure? user-init-position) + (input-port? user-init-position) + (output-port? user-init-position) + (not user-init-position)) + #f + (sub1 user-init-position))) + + (define file-position + (cond + [(input-port? user-init-position) user-init-position] + [(output-port? user-init-position) user-init-position] + [(procedure? user-init-position) + (lambda () + (define pos (user-init-position)) + (unless (or (not pos) (exact-positive-integer? pos)) + (raise-result-error '|user port init-position| "(or/c exact-positive-integer? #f)" pos)) + (and pos (sub1 pos)))] + [else #f])) + + (values init-offset file-position)) + +(define (check-buffer-mode who user-buffer-mode) + (check who (lambda (p) (or (not p) + (and (procedure? p) + (procedure-arity-includes? p 0) + (procedure-arity-includes? p 1)))) + #:contract (string-append "(or/c #f (and/c (procedure-arity-includes/c 0)\n" + " (procedure-arity-includes/c 1)))") + user-buffer-mode)) + +(define (make-buffer-mode user-buffer-mode #:output? [output? #f]) + (case-lambda + [() + (end-atomic) + (define m (user-buffer-mode)) + (cond + [(or (not m) (eq? m 'block) (eq? m 'none) (and output? (eq? m 'line))) + (start-atomic) + m] + [else + (raise-result-error '|user port buffer-mode| + (if output? + "(or/c 'block 'line 'none #f)" + "(or/c 'block 'none #f)") + m)])] + [(m) + (non-atomically + (user-buffer-mode m))])) diff -Nru racket-6.12+ppa1/src/io/port/evt.rkt racket-7.0+ppa1/src/io/port/evt.rkt --- racket-6.12+ppa1/src/io/port/evt.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/evt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,35 @@ +#lang racket/base +(require "../host/thread.rkt") + +;; To make a port act like an event, the `prop:secondary-evt` property +;; must be mapped to `port->evt` --- both for the `core-port` +;; structure type and implied by `prop:input-port` and +;; `prop:output-port`. As the name suggests, `prop:secondary-evt` is +;; used only when a structure doesn't have `prop:evt`, so `prop:input-port` +;; and `prop:output-port` can be mixed with `prop:evt`. + +;; A structue with `prop:secondary-evt` mapped to `port->evt` should +;; also have `prop:input-port-evt` or `prop:input-port-evt`. Those +;; properties provide an indirection to avoid a dependency cycle between +;; this module and the implement of input and output ports. + +(provide port->evt + prop:input-port-evt input-port-evt? input-port-evt-ref + prop:output-port-evt output-port-evt? output-port-evt-ref) + +(define-values (prop:input-port-evt input-port-evt? input-port-evt-ref) + (make-struct-type-property 'input-port-evt)) + +(define-values (prop:output-port-evt output-port-evt? output-port-evt-ref) + (make-struct-type-property 'output-port-evt)) + +(define (port->evt p) + ;; A structure can be both an input port and an output + ;; port, and the input nature take precedence + (cond + [(input-port-evt? p) + (wrap-evt ((input-port-evt-ref p) p) + (lambda (v) p))] + [else + (wrap-evt ((output-port-evt-ref p) p) + (lambda (v) p))])) diff -Nru racket-6.12+ppa1/src/io/port/fd-port.rkt racket-7.0+ppa1/src/io/port/fd-port.rkt --- racket-6.12+ppa1/src/io/port/fd-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/fd-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,335 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt" + "../host/thread.rkt" + "../sandman/main.rkt" + "../file/error.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "peek-via-read-port.rkt" + "file-stream.rkt" + "file-truncate.rkt" + "buffer-mode.rkt" + "close.rkt" + "count.rkt" + "check.rkt") + +(provide open-input-fd + open-output-fd + terminal-port? + fd-port-fd + maybe-fd-data-extra) + +(struct fd-data (fd extra) + #:property prop:file-stream (lambda (fdd) (fd-data-fd fdd)) + #:property prop:file-truncate (case-lambda + [(fdd pos) + (check-rktio-error* + (rktio_set_file_size rktio + (fd-data-fd fdd) + pos) + "error setting file size")])) + +(define (maybe-fd-data-extra data) + (and (fd-data? data) + (fd-data-extra data))) + +;; in atomic mode +(define (fd-close fd fd-refcount) + (set-box! fd-refcount (sub1 (unbox fd-refcount))) + (when (zero? (unbox fd-refcount)) + (define v (rktio_close rktio fd)) + (when (rktio-error? v) + (end-atomic) + (raise-rktio-error #f v "error closing stream port")))) + +;; ---------------------------------------- + +;; in atomic mode +;; Current custodian must not be shut down. +(define (open-input-fd fd name + #:extra-data [extra-data #f] + #:on-close [on-close void] + #:fd-refcount [fd-refcount (box 1)]) + (define-values (port buffer-control) + (open-input-peek-via-read + #:name name + #:data (fd-data fd extra-data) + #:read-in + ;; in atomic mode + (lambda (dest-bstr start end copy?) + (define n (rktio_read_in rktio fd dest-bstr start end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error reading from stream port")] + [(eqv? n RKTIO_READ_EOF) eof] + [(eqv? n 0) (wrap-evt (fd-evt fd RKTIO_POLL_READ (core-port-closed port)) + (lambda (v) 0))] + [else n])) + #:read-is-atomic? #t + #:close + ;; in atomic mode + (lambda () + (on-close) + (fd-close fd fd-refcount) + (unsafe-custodian-unregister fd custodian-reference)) + #:file-position (make-file-position + fd + (case-lambda + [() (buffer-control)] + [(pos) (buffer-control pos)])))) + (define custodian-reference + (register-fd-close (current-custodian) fd fd-refcount port)) + port) + +;; ---------------------------------------- + +;; in atomic mode +;; Current custodian must not be shut down. +(define (open-output-fd fd name + #:extra-data [extra-data #f] + #:buffer-mode [buffer-mode 'infer] + #:fd-refcount [fd-refcount (box 1)] + #:on-close [on-close void]) + (define buffer (make-bytes 4096)) + (define buffer-start 0) + (define buffer-end 0) + (define flush-handle + (plumber-add-flush! (current-plumber) + (lambda (h) + (flush-buffer-fully #f) + (plumber-flush-handle-remove! h)))) + + (when (eq? buffer-mode 'infer) + (if (rktio_fd_is_terminal rktio fd) + (set! buffer-mode 'line) + (set! buffer-mode 'block))) + + (define evt (fd-evt fd RKTIO_POLL_WRITE #f)) + + ;; in atomic mode + ;; Returns `#t` if the buffer is already or successfully flushed + (define (flush-buffer) + (cond + [(not (= buffer-start buffer-end)) + (define n (rktio_write_in rktio fd buffer buffer-start buffer-end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error writing to stream port")] + [(zero? n) + #f] + [else + (define new-buffer-start (+ buffer-start n)) + (cond + [(= new-buffer-start buffer-end) + (set! buffer-start 0) + (set! buffer-end 0) + #t] + [else + (set! buffer-start new-buffer-start) + #f])])] + [else #t])) + + ;; in atomic mode + (define (flush-buffer-fully enable-break?) + (let loop () + (unless (flush-buffer) + (end-atomic) + (if enable-break? + (sync/enable-break evt) + (sync evt)) + (start-atomic) + (when buffer ; in case it was closed + (loop))))) + + ;; in atomic mode + (define (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?) + (for ([b (in-bytes src-bstr src-start src-end)]) + (define newline? (or (eqv? b (char->integer #\newline)) + (eqv? b (char->integer #\return)))) + (when newline? (flush-buffer-fully enable-break?)) + #:break newline? + (void))) + + (define port + (make-core-output-port + #:name name + #:data (fd-data fd extra-data) + + #:evt evt + + #:write-out + ;; in atomic mode + (lambda (src-bstr src-start src-end nonbuffer/nonblock? enable-break? copy?) + (cond + [(= src-start src-end) + ;; Flush request + (and (flush-buffer) 0)] + [(and (not (eq? buffer-mode 'none)) + (not nonbuffer/nonblock?) + (< buffer-end (bytes-length buffer))) + (define amt (min (- src-end src-start) (- (bytes-length buffer) buffer-end))) + (bytes-copy! buffer buffer-end src-bstr src-start (+ src-start amt)) + (set! buffer-end (+ buffer-end amt)) + (unless nonbuffer/nonblock? + (when (eq? buffer-mode 'line) + ;; can temporarily leave atomic mode: + (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?))) + amt] + [(not (flush-buffer)) ; <- can temporarily leave atomic mode + #f] + [else + (define n (rktio_write_in rktio fd src-bstr src-start src-end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error writing to stream port")] + [(zero? n) (wrap-evt evt (lambda (v) #f))] + [else n])])) + + #:count-write-evt-via-write-out + (lambda (v bstr start) + (port-count! port v bstr start)) + + #:close + ;; in atomic mode + (lambda () + (flush-buffer-fully #f) ; can temporarily leave atomic mode + (when buffer ; <- in case a concurrent close succeeded + (on-close) + (plumber-flush-handle-remove! flush-handle) + (set! buffer #f) + (fd-close fd fd-refcount) + (unsafe-custodian-unregister fd custodian-reference))) + + #:file-position (make-file-position + fd + ;; in atomic mode + (case-lambda + [() + (flush-buffer-fully #f) + ;; flushing can leave atomic mode, so make sure the + ;; port is still open before continuing + (unless buffer + (check-not-closed 'file-position port))] + [(pos) + (+ pos (- buffer-end buffer-start))])) + #:buffer-mode (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)]))) + + (define custodian-reference + (register-fd-close (current-custodian) fd fd-refcount port)) + + (set-fd-evt-closed! evt (core-port-closed port)) + + port) + +;; ---------------------------------------- + +(define (terminal-port? p) + (define data + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'terminal-port? "port?" p)]))) + (and (fd-data? data) + (rktio_fd_is_terminal rktio (fd-data-fd data)))) + +(define (fd-port-fd p) + (define data + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)]))) + (and (fd-data? data) + (fd-data-fd data))) + +;; ---------------------------------------- + +(define (make-file-position fd buffer-control) + ;; in atomic mode + (case-lambda + [() + (define ppos (rktio_get_file_position rktio fd)) + (cond + [(rktio-error? ppos) + ;; #f => not supported, so use port's own counter, instead + #f] + [else + (define pos (rktio_filesize_ref ppos)) + (rktio_free ppos) + (buffer-control pos)])] + [(pos) + (buffer-control) + (define r + (rktio_set_file_position rktio + fd + (if (eof-object? pos) + 0 + pos) + (if (eof-object? pos) + RKTIO_POSITION_FROM_END + RKTIO_POSITION_FROM_START))) + (when (rktio-error? r) + (end-atomic) + (raise-rktio-error 'file-position r "error setting stream position"))])) + +;; ---------------------------------------- + +(struct fd-evt (fd mode [closed #:mutable]) + #:property + prop:evt + (poller + ;; This function is called by the scheduler for `sync` to check + ;; whether the file descriptor has data available: + (lambda (fde ctx) + (cond + [(closed-state-closed? (fd-evt-closed fde)) + (values (list fde) #f)] + [else + (define mode (fd-evt-mode fde)) + (define ready? + (or + (and (eqv? RKTIO_POLL_READ (bitwise-and mode RKTIO_POLL_READ)) + (eqv? (rktio_poll_read_ready rktio (fd-evt-fd fde)) + RKTIO_POLL_READY)) + (and (eqv? RKTIO_POLL_WRITE (bitwise-and mode RKTIO_POLL_WRITE)) + (eqv? (rktio_poll_write_ready rktio (fd-evt-fd fde)) + RKTIO_POLL_READY)))) + (cond + [ready? + (values (list fde) #f)] + [else + ;; If `sched-info` in `poll-ctx` is not #f, then we can register this file + ;; descriptor so that if no thread is able to make progress, + ;; the Racket process will sleep, but it will wake up when + ;; input is available. The implementation of external events + ;; is from the current sandman, which will in turn be the + ;; one (or build on the one) in "../sandman". + (sandman-poll-ctx-add-poll-set-adder! + ctx + ;; Cooperate with the sandman by registering + ;; a function that takes a poll set and + ;; adds to it: + (lambda (ps) + (rktio_poll_add rktio (fd-evt-fd fde) ps mode))) + (values #f fde)])])))) + +;; ---------------------------------------- + +(define (register-fd-close custodian fd fd-refcount port) + (define closed (core-port-closed port)) + (unsafe-custodian-register custodian + fd + ;; in atomic mode + (lambda (fd) + (fd-close fd fd-refcount) + (set-closed-state! closed)) + #f + #f)) diff -Nru racket-6.12+ppa1/src/io/port/file-identity.rkt racket-7.0+ppa1/src/io/port/file-identity.rkt --- racket-6.12+ppa1/src/io/port/file-identity.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-identity.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../file/identity.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "file-stream.rkt" + "check.rkt") + +(provide port-file-identity) + +(define/who (port-file-identity p) + (check who file-stream-port? p) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (path-or-fd-identity who #:fd fd #:port p)) diff -Nru racket-6.12+ppa1/src/io/port/file-lock.rkt racket-7.0+ppa1/src/io/port/file-lock.rkt --- racket-6.12+ppa1/src/io/port/file-lock.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-lock.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "file-stream.rkt" + "check.rkt") + +(provide port-try-file-lock? + port-file-unlock) + +(define/who (port-try-file-lock? p mode) + (check who file-stream-port? p) + (check who (lambda (m) (or (eq? m 'shared) (eq? m 'exclusive))) + #:contract "(or/c 'shared 'exclusive)" + mode) + (define exclusive? (eq? mode 'exclusive)) + (when (and exclusive? (not (output-port? p))) + (raise-arguments-error who "port for 'exclusive locking is not an output port" + "port" p)) + (when (and (not exclusive?) (not (input-port? p))) + (raise-arguments-error who "port for 'shared locking is not an input port" + "port" p)) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (define r (rktio_file_lock_try rktio fd exclusive?)) + (end-atomic) + (when (rktio-error? r) + (raise-rktio-error who + r + (string-append "error getting file " + (if exclusive? "exclusive" "shared") + " lock"))) + (eqv? r RKTIO_LOCK_ACQUIRED)) + +(define/who (port-file-unlock p) + (check who file-stream-port? p) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (define r (rktio_file_unlock rktio fd)) + (end-atomic) + (when (rktio-error? r) + (raise-rktio-error who r "error unlocking file"))) diff -Nru racket-6.12+ppa1/src/io/port/file-port.rkt racket-7.0+ppa1/src/io/port/file-port.rkt --- racket-6.12+ppa1/src/io/port/file-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,180 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../path/path.rkt" + "../file/parameter.rkt" + "../file/host.rkt" + "../file/error.rkt" + "../format/main.rkt" + "fd-port.rkt" + "close.rkt" + "parameter.rkt" + "count.rkt") + +(provide open-input-file + open-output-file + open-input-output-file + call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file) + +(define none (gensym)) + +(define/who (open-input-file path [mode1 none] [mode2 none]) + (check who path-string? path) + (define (mode->flags mode) + (case mode + [(text) RKTIO_OPEN_TEXT] + [else 0])) + (define host-path (->host path who '(read))) + (start-atomic) + (check-current-custodian who) + (define fd (rktio_open rktio + host-path + (+ RKTIO_OPEN_READ + (mode->flags mode1) + (mode->flags mode2)))) + (when (rktio-error? fd) + (end-atomic) + (when (or (eq? mode1 'module) (eq? mode2 'module)) + (maybe-raise-missing-module who (host-> host-path) "" "" "" + (format-rktio-system-error-message fd))) + (raise-filesystem-error who + fd + (format (string-append + "cannot open input file\n" + " path: ~a") + (host-> host-path)))) + (define p (open-input-fd fd (host-> host-path))) + (end-atomic) + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +(define (do-open-output-file #:plus-input? [plus-input? #f] who path mode1 mode2) + (check who path-string? path) + (define (mode->flags mode) + (case mode + [(test) RKTIO_OPEN_TEXT] + [(truncate truncate/replace) (+ RKTIO_OPEN_TRUNCATE + RKTIO_OPEN_CAN_EXIST)] + [(must-truncate) (+ RKTIO_OPEN_TRUNCATE + RKTIO_OPEN_MUST_EXIST)] + [(update) RKTIO_OPEN_CAN_EXIST] + [(must-update) RKTIO_OPEN_MUST_EXIST] + [(append) RKTIO_OPEN_APPEND] + [else 0])) + (define (mode? v) + (or (eq? mode1 v) (eq? mode2 v))) + (define host-path (->host path who (append '(write) + (if (or (mode? 'replace) + (mode? 'truncate/replace)) + '(delete) + '()) + (if (or (mode? 'append) + (mode? 'update) + (mode? 'must-update)) + '(read) + '())))) + (start-atomic) + (check-current-custodian who) + (define flags + (+ RKTIO_OPEN_WRITE + (if plus-input? RKTIO_OPEN_READ 0) + (mode->flags mode1) + (mode->flags mode2))) + (define fd0 + (rktio_open rktio host-path flags)) + (define fd + (cond + [(not (rktio-error? fd0)) fd0] + [(and (or (racket-error? fd0 RKTIO_ERROR_EXISTS) + (racket-error? fd0 RKTIO_ERROR_ACCESS_DENIED)) + (or (mode? 'replace) (mode? 'truncate/replace))) + (define r (rktio_delete_file rktio + host-path + (current-force-delete-permissions))) + (when (rktio-error? r) + (end-atomic) + (raise-filesystem-error who + r + (format (string-append + "error deleting file\n" + " path: ~a") + (host-> host-path)))) + (rktio_open rktio host-path flags)] + [else fd0])) + (when (rktio-error? fd) + (end-atomic) + (raise-filesystem-error who + fd + (format (string-append + "~a\n" + " path: ~a") + (cond + [(racket-error? fd0 RKTIO_ERROR_EXISTS) + "file exists"] + [(racket-error? fd0 RKTIO_ERROR_IS_A_DIRECTORY) + "path is a directory"] + [else "error opening file"]) + (host-> host-path)))) + (define opened-path (host-> host-path)) + (define refcount (box (if plus-input? 2 1))) + (define op (open-output-fd fd opened-path #:fd-refcount refcount)) + (define ip (and plus-input? + (open-input-fd fd opened-path #:fd-refcount refcount))) + (end-atomic) + (when (port-count-lines-enabled) + (port-count-lines! op) + (when plus-input? + (port-count-lines! ip))) + (if plus-input? + (values ip op) + op)) + +(define/who (open-output-file path [mode1 none] [mode2 none]) + (do-open-output-file who path mode1 mode2)) + +(define/who (open-input-output-file path [mode1 none] [mode2 none]) + (do-open-output-file #:plus-input? #t who path mode1 mode2)) + +(define/who (call-with-input-file path proc [mode none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 1) proc) + (define i (open-input-file path mode)) + (begin0 + (proc i) + (close-input-port i))) + +(define/who (call-with-output-file path proc [mode1 none] [mode2 none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 1) proc) + (define o (open-output-file path mode1 mode2)) + (begin0 + (proc o) + (close-output-port o))) + +(define/who (with-input-from-file path proc [mode none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 0) proc) + (define i (open-input-file path mode)) + (parameterize ([current-input-port i]) + (dynamic-wind + void + proc + (lambda () + (close-input-port i))))) + +(define/who (with-output-to-file path proc [mode1 none] [mode2 none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 0) proc) + (define o (open-output-file path mode1 mode2)) + (parameterize ([current-output-port o]) + (dynamic-wind + void + proc + (lambda () + (close-output-port o))))) diff -Nru racket-6.12+ppa1/src/io/port/file-position.rkt racket-7.0+ppa1/src/io/port/file-position.rkt --- racket-6.12+ppa1/src/io/port/file-position.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-position.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,68 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt") + +(provide file-position + file-position* + + do-simple-file-position) + +(define/who file-position + (case-lambda + [(p) + (do-simple-file-position who p + (lambda () + (raise + (exn:fail:filesystem + (string-append + "file-position: the port's current position is not known\n port: " + ((error-value->string-handler) p (error-print-width))) + (current-continuation-marks)))))] + [(p pos) + (unless (or (input-port? p) (output-port? p)) + (raise-argument-error who "port?" p)) + (check who + (lambda (p) (or (exact-nonnegative-integer? p) (eof-object? p))) + #:contract "(or/c exact-nonnegative-integer? eof-object?)" + pos) + (let ([cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])]) + (define file-position (core-port-file-position cp)) + (cond + [(and (procedure? file-position) (procedure-arity-includes? file-position 1)) + (atomically + (check-not-closed who cp) + (file-position pos))] + [else + (raise-arguments-error who + "setting position allowed for file-stream and string ports only" + "port" p + "position" pos)]))])) + +(define/who (file-position* p) + (do-simple-file-position who p (lambda () #f))) + +(define (do-simple-file-position who orig-p fail-k) + (let ([p (cond + [(input-port? orig-p) (->core-input-port orig-p)] + [(output-port? orig-p) (->core-output-port orig-p)] + [else (raise-argument-error who "port?" orig-p)])]) + (start-atomic) + (check-not-closed who p) + (define file-position (core-port-file-position p)) + (cond + [(or (input-port? file-position) + (output-port? file-position)) + (end-atomic) + (do-simple-file-position who file-position fail-k)] + [else + (define pos (or (and file-position + (file-position)) + (core-port-offset p))) + (end-atomic) + (or pos (fail-k))]))) diff -Nru racket-6.12+ppa1/src/io/port/file-stream.rkt racket-7.0+ppa1/src/io/port/file-stream.rkt --- racket-6.12+ppa1/src/io/port/file-stream.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-stream.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +#lang racket/base +(require "port.rkt" + "input-port.rkt" + "output-port.rkt") + +(provide prop:file-stream + file-stream-ref + file-stream-port?) + +;; Property value should be a funciton that returns a file descriptor +(define-values (prop:file-stream file-stream? file-stream-ref) + (make-struct-type-property 'file-stream)) + +(define (file-stream-port? p) + (file-stream? + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'file-stream-port? + "port?" + p)])))) diff -Nru racket-6.12+ppa1/src/io/port/file-truncate.rkt racket-7.0+ppa1/src/io/port/file-truncate.rkt --- racket-6.12+ppa1/src/io/port/file-truncate.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/file-truncate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require "../common/check.rkt" + "port.rkt" + "output-port.rkt" + "file-stream.rkt") + +(provide prop:file-truncate + file-truncate) + +(define-values (prop:file-truncate file-truncate? file-truncate-ref) + (make-struct-type-property 'file-truncate)) + +(define (file-truncate p pos) + (unless (and (output-port? p) + (file-stream-port? p)) + (raise-argument-error 'file-truncate "(and/c output-port? file-stream-port?)" p)) + (check 'file-truncate exact-nonnegative-integer? pos) + (let ([p (->core-output-port p)]) + (define data (core-port-data p)) + ((file-truncate-ref data) data pos))) diff -Nru racket-6.12+ppa1/src/io/port/flush-output.rkt racket-7.0+ppa1/src/io/port/flush-output.rkt --- racket-6.12+ppa1/src/io/port/flush-output.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/flush-output.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "output-port.rkt" + "pipe.rkt") + +(provide flush-output + maybe-flush-stdout) + +(define/who (flush-output [p (current-output-port)]) + (check who output-port? p) + (let ([p (->core-output-port p)]) + (let loop () + (define r (atomically + ((core-output-port-write-out p) #"" 0 0 #f #f #f))) + (let r-loop ([r r]) + (cond + [(eq? r 0) (void)] + [(not r) (loop)] + [(evt? r) (r-loop (sync r))] + [else (error 'flush-output "weird result")]))))) + +;; ---------------------------------------- + +(define orig-input-port (current-input-port)) +(define orig-output-port (current-output-port)) +(define orig-error-port (current-error-port)) + +(define (maybe-flush-stdout in) + (when (eq? in orig-input-port) + (flush-output orig-output-port) + (flush-output orig-error-port))) diff -Nru racket-6.12+ppa1/src/io/port/handler.rkt racket-7.0+ppa1/src/io/port/handler.rkt --- racket-6.12+ppa1/src/io/port/handler.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/handler.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,148 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "output-port.rkt" + "flush-output.rkt" + (submod "../print/main.rkt" internal)) + +(provide port-read-handler + port-write-handler + port-display-handler + port-print-handler + + global-port-print-handler + default-global-port-print-handler + + install-reader! + installed-read-syntax + installed-read-accept-reader + installed-read-accept-lang) + +(define/who port-read-handler + (case-lambda + [(i) + (check who input-port? i) + (let ([i (->core-input-port i)]) + (or (core-input-port-read-handler i) + default-port-read-handler))] + [(i h) + (check who input-port? i) + (check who (lambda (p) + (and (procedure? p) + (procedure-arity-includes? p 1) + (procedure-arity-includes? p 2))) + #:contract "(and/c (procedure-arity-includes/c 1) (procedure-arity-includes/c 2))" + h) + (let ([i (->core-input-port i)]) + (set-core-input-port-read-handler! i h))])) + +(define/who default-port-read-handler + (case-lambda + [(i) + (check who input-port? i) + (maybe-flush-stdout i) + (installed-read i)] + [(i src) + (check who input-port? i) + (maybe-flush-stdout i) + (installed-read-syntax src i)])) + +(define installed-read #f) +(define installed-read-syntax #f) +(define installed-read-accept-reader #f) +(define installed-read-accept-lang #f) + +(define (install-reader! read read-syntax read-accept-reader read-accept-lang) + (set! installed-read read) + (set! installed-read-syntax read-syntax) + (set! installed-read-accept-reader installed-read-accept-reader) + (set! installed-read-accept-lang read-accept-lang)) + +;; ---------------------------------------- + +(define/who port-write-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-write-handler o) + default-port-write-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-write-handler! o (if (eq? h default-port-write-handler) + #f + h)))])) + +(define/who (default-port-write-handler v o) + (check who output-port? o) + (do-write 'write v o)) + +(define/who port-display-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-display-handler o) + default-port-display-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-display-handler! o (if (eq? h default-port-display-handler) + #f + h)))])) + +(define/who (default-port-display-handler v o) + (check who output-port? o) + (do-display 'display v o)) + +(define/who port-print-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-print-handler o) + default-port-print-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-print-handler! o (cond + [(eq? h default-port-print-handler) + #f] + [(procedure-arity-includes? h 3) + h] + [else + (lambda (v o [w #f]) (h v o))])))])) + +(define/who (default-port-print-handler v o [quote-depth 0]) + (check who output-port? o) + (check who (lambda (d) (or (eq? d 0) (eq? d 1))) + #:contract "(or/c 0 1)" + quote-depth) + ((global-port-print-handler) v o quote-depth)) + +(define/who (default-global-port-print-handler v o [quote-depth 0]) + (check who output-port? o) + (check who (lambda (d) (or (eq? d 0) (eq? d 1))) + #:contract "(or/c 0 1)" + quote-depth) + (do-print 'print v o quote-depth)) + +(define/who global-port-print-handler + (make-parameter default-global-port-print-handler + (lambda (p) + (check who + (procedure-arity-includes/c 2) + #:contract (string-append + "(or/c (->* (any/c output-port?) ((or/c 0 1)) any)\n" + " (any/c output-port? . -> . any))") + p) + (if (procedure-arity-includes? p 3) + p + (lambda (v o [quote-depth 0]) (p v o)))))) + +(void (install-do-global-print! global-port-print-handler + default-global-port-print-handler)) diff -Nru racket-6.12+ppa1/src/io/port/input-port.rkt racket-7.0+ppa1/src/io/port/input-port.rkt --- racket-6.12+ppa1/src/io/port/input-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/input-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,203 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "evt.rkt") + +(provide prop:input-port + input-port? + ->core-input-port + (struct-out core-input-port) + make-core-input-port) + +(define-values (prop:input-port input-port-via-property? input-port-ref) + (make-struct-type-property 'input-port + (lambda (v sti) + (check 'prop:input-port (lambda (v) (or (exact-nonnegative-integer? v) + (input-port? v))) + #:contract "(or/c input-port? exact-nonnegative-integer?)" + v) + (check-immutable-field 'prop:input-port v sti) + (if (exact-nonnegative-integer? v) + (make-struct-field-accessor (list-ref sti 3) v) + v)) + (list (cons prop:secondary-evt + (lambda (v) port->evt)) + (cons prop:input-port-evt + (lambda (i) + (input-port-evt-ref (->core-input-port i))))))) + +(define (input-port? p) + (or (core-input-port? p) + (input-port-via-property? p))) + +;; This function should not be called in atomic mode, +;; since it can invoke an artitrary function +(define (->core-input-port v) + (cond + [(core-input-port? v) v] + [(input-port? v) + (let ([p (input-port-ref v)]) + (cond + [(struct-accessor-procedure? p) + (->core-input-port (p v))] + [else + (->core-input-port p)]))] + [else + empty-input-port])) + +(struct core-input-port core-port + ( + ;; Various functions below are called in atomic mode. The intent of + ;; atomic mode is to ensure that the completion and return of the + ;; function is atomic with respect to some further activity, such + ;; as position and line counting. Also, a guard against operations + ;; on a closed port precedes most operations. Any of the functions + ;; is free to exit and re-enter atomic mode, but they may take on + ;; the burden of re-checking for a closed port. Leave atomic mode + ;; explicitly before raising an exception. + + prepare-change ; #f or (-> void) + ;; Called in atomic mode + ;; May leave atomic mode temporarily, but on return, + ;; ensures that other atomic operations are ok to + ;; change the port. The main use of `prepare-change` + ;; is to pause and `port-commit-peeked` attempts to + ;; not succeed while a potential change is in + ;; progress, where the commit attempts can resume after + ;; atomic mode is left. The `close` operation + ;; is *not* guarded by a call to `prepare-change`. + + read-byte ; #f or (-> (or/c byte? eof-object? evt?)) + ;; Called in atomic mode. + ;; This shortcut is optional. + ;; Non-blocking byte read, where an event must be + ;; returned if no byte is available. The event's result + ;; is ignored, so it should not consume a byte. + + read-in ; port or (bytes start-k end-k copy? -> (or/c integer? ...)) + ;; Called in atomic mode. + ;; A port value redirects to the port. Otherwise, the function + ;; never blocks, and can assume `(- end-k start-k)` is non-zero. + ;; The `copy?` flag indicates that the given byte string should + ;; not be exposed to untrusted code, and instead of should be + ;; copied if necessary. The return values are the same as + ;; documented for `make-input-port`, except that a pipe result + ;; is not allowed (or, more precisely, it's treated as an event). + + peek-byte ; #f or (-> (or/c byte? eof-object? evt?)) + ;; Called in atomic mode. + ;; This shortcut is optional. + ;; Non-blocking byte read, where an event must be + ;; returned if no byte is available. The event's result + ;; is ignored. + + peek-in ; port or (bytes start-k end-k skip-k progress-evt copy? -> (or/c integer? ...)) + ;; Called in atomic mode. + ;; A port value redirects to the port. Otherwise, the function + ;; never blocks, and it can assume that `(- end-k start-k)` is non-zero. + ;; The `copy?` flag is the same as for `read-in`. The return values + ;; are the same as documented for `make-input-port`. + + byte-ready ; port or ((->) -> (or/c boolean? evt)) + ;; Called in atomic mode. + ;; A port value makes sense when `peek-in` has a port value. + ;; Otherwise, check whether a peek on one byte would succeed + ;; without blocking and return a boolean, or return an event + ;; that effectively does the same. The event's value doesn't + ;; matter, because it will be wrapped to return some original + ;; port. When `byte-ready` is a function, it should call the + ;; given funciton (for its side effect) when work has been + ;; done that might unblock this port or some other port. + + get-progress-evt ; #f or (-> evt?) + ;; *Not* called in atomic mode. + ;; Optional support for progress events, and may be + ;; called on a closed port. + + commit ; (amt-k progress-evt? evt? (bytes? -> any) -> boolean) + ;; Called in atomic mode. + ;; Goes with `get-progress-evt`. The final `evt?` + ;; argument is constrained to a few kinds of events; + ;; see docs for `port-commit-peeked` for more information. + ;; On success, a completion function is called in atomic mode, + ;; but possibly in a different thread, with the committed bytes. + ;; The result is a boolean indicating success or failure. + + [pending-eof? #:mutable] + [read-handler #:mutable]) + #:authentic + #:property prop:input-port-evt (lambda (i) + (cond + [(closed-state-closed? (core-port-closed i)) + always-evt] + [else + (define byte-ready (core-input-port-byte-ready i)) + (cond + [(input-port? byte-ready) + byte-ready] + [else + (poller-evt + (poller + (lambda (self poll-ctx) + (define v (byte-ready (lambda () + (schedule-info-did-work! (poll-ctx-sched-info poll-ctx))))) + (cond + [(evt? v) + (values #f v)] + [(eq? v #t) + (values (list #t) #f)] + [else + (values #f self)]))))])]))) + +(define (make-core-input-port #:name name + #:data [data #f] + #:prepare-change [prepare-change #f] + #:read-byte [read-byte #f] + #:read-in read-in + #:peek-byte [peek-byte #f] + #:peek-in peek-in + #:byte-ready byte-ready + #:close close + #:get-progress-evt [get-progress-evt #f] + #:commit [commit #f] + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:init-offset [init-offset 0] + #:file-position [file-position #f] + #:buffer-mode [buffer-mode #f]) + (core-input-port name + data + + close + count-lines! + get-location + file-position + buffer-mode + + (closed-state #f #f) + init-offset ; offset + #f ; count? + #f ; state + #f ; cr-state + #f ; line + #f ; column + #f ; position + + prepare-change + read-byte + read-in + peek-byte + peek-in + byte-ready + get-progress-evt + commit + #f ; pending-eof? + #f)) ; read-handler + +(define empty-input-port + (make-core-input-port #:name 'empty + #:read-in (lambda (bstr start-k end-k copy?) eof) + #:peek-in (lambda (bstr start-k end-k skip-k copy?) eof) + #:byte-ready (lambda (did-work!) #f) + #:close void)) diff -Nru racket-6.12+ppa1/src/io/port/line-input.rkt racket-7.0+ppa1/src/io/port/line-input.rkt --- racket-6.12+ppa1/src/io/port/line-input.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/line-input.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,69 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "bytes-input.rkt" + "string-input.rkt" + "parameter.rkt" + "flush-output.rkt") + +(provide read-bytes-line + read-line) + +(define (ok-mode? v) + (memq v '(linefeed return return-linefeed any any-one))) +(define ok-mode-str "(or/c 'linefeed 'return 'return-linefeed 'any 'any-one)") + +(define-syntax-rule (define-read-line read-line + make-string string-length string-set! + string-copy! substring + read-char peek-char + as-char) + (define/who (read-line [in (current-input-port)] [mode 'linefeed]) + (check who input-port? in) + (check who ok-mode? #:contract ok-mode-str mode) + (maybe-flush-stdout in) + (define cr? (memq mode '(return any any-one))) + (define lf? (memq mode '(linefeed any any-one))) + (define crlf? (memq mode '(return-linefeed any))) + (let loop ([str (make-string 32)] [pos 0]) + (define ch (read-char in)) + (define (keep-char) + (if (pos . < . (string-length str)) + (begin + (string-set! str pos ch) + (loop str (add1 pos))) + (let ([new-str (make-string (* (string-length str) 2))]) + (string-copy! new-str 0 str 0) + (string-set! new-str pos ch) + (loop new-str (add1 pos))))) + (cond + [(eof-object? ch) + (if (zero? pos) + eof + (substring str 0 pos))] + [(and (or cr? crlf?) + (eqv? ch (as-char #\return))) + (cond + [(and crlf? + (eqv? (peek-char in) (as-char #\linefeed))) + (read-char in) + (substring str 0 pos)] + [cr? + (substring str 0 pos)] + [else (keep-char)])] + [(and lf? + (eqv? ch (as-char #\newline))) + (substring str 0 pos)] + [else (keep-char)])))) + +(define-read-line read-line + make-string string-length string-set! + string-copy! substring + read-char peek-char + values) + + (define-read-line read-bytes-line + make-bytes bytes-length bytes-set! + bytes-copy! subbytes + read-byte peek-byte + char->integer) diff -Nru racket-6.12+ppa1/src/io/port/main.rkt racket-7.0+ppa1/src/io/port/main.rkt --- racket-6.12+ppa1/src/io/port/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,154 @@ +#lang racket/base +(require (only-in "input-port.rkt" + input-port? + prop:input-port) + (only-in "output-port.rkt" + output-port? + prop:output-port) + "bytes-input.rkt" + "string-input.rkt" + "special-input.rkt" + "progress-evt.rkt" + "bytes-output.rkt" + "string-output.rkt" + "special-output.rkt" + "line-input.rkt" + "file-port.rkt" + "file-stream.rkt" + (only-in "fd-port.rkt" + terminal-port?) + "file-identity.rkt" + "file-lock.rkt" + "bytes-port.rkt" + "string-port.rkt" + "custom-input-port.rkt" + "custom-output-port.rkt" + "handler.rkt" + "pipe.rkt" + "close.rkt" + "count.rkt" + "buffer-mode.rkt" + "file-position.rkt" + "file-truncate.rkt" + "flush-output.rkt" + "parameter.rkt" + "ready.rkt") + +(provide read-byte + read-bytes + read-bytes! + read-bytes-avail! + read-bytes-avail!* + read-bytes-avail!/enable-break + + peek-byte + peek-bytes + peek-bytes! + peek-bytes-avail! + peek-bytes-avail!* + peek-bytes-avail!/enable-break + + read-byte-or-special + peek-byte-or-special + read-char-or-special + peek-char-or-special + + port-provides-progress-evts? + progress-evt? + port-progress-evt + port-commit-peeked + + read-char + read-string + read-string! + + peek-char + peek-string + peek-string! + + byte-ready? + char-ready? + + write-byte + write-bytes + write-bytes-avail + write-bytes-avail* + write-bytes-avail/enable-break + write-bytes-avail-evt + write-char + write-string + port-writes-atomic? + + write-special + write-special-avail* + write-special-evt + port-writes-special? + + read-line + read-bytes-line + + make-input-port + make-output-port + + port-read-handler + port-write-handler + port-display-handler + port-print-handler + install-reader! + global-port-print-handler + + prop:input-port + prop:output-port + input-port? + output-port? + + open-input-file + open-output-file + open-input-output-file + call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file + + file-stream-port? + terminal-port? + + open-input-bytes + open-output-bytes + get-output-bytes + open-input-string + open-output-string + get-output-string + string-port? + + make-pipe + pipe-input-port? + pipe-output-port? + pipe-content-length + + port-closed? + close-input-port + close-output-port + port-closed-evt + + file-stream-buffer-mode + + port-file-identity + port-try-file-lock? + port-file-unlock + + file-position + file-position* + file-truncate + + port-count-lines! + port-counts-lines? + port-next-location + set-port-next-location! + port-count-lines-enabled + + current-input-port + current-output-port + current-error-port + + flush-output) diff -Nru racket-6.12+ppa1/src/io/port/nowhere.rkt racket-7.0+ppa1/src/io/port/nowhere.rkt --- racket-6.12+ppa1/src/io/port/nowhere.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/nowhere.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base +(require "output-port.rkt") + +(provide open-output-nowhere) + +(define (open-output-nowhere) + (make-core-output-port #:name 'nowhere + #:evt always-evt + #:write-out (lambda (bstr start-k end-k no-block/buffer? enable-break? copy?) + (- end-k start-k)) + #:close void + #:write-out-special (lambda (any no-block/buffer? enable-break?) + #t))) diff -Nru racket-6.12+ppa1/src/io/port/output-port.rkt racket-7.0+ppa1/src/io/port/output-port.rkt --- racket-6.12+ppa1/src/io/port/output-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/output-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,159 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "evt.rkt") + +(provide prop:output-port + output-port? + ->core-output-port + (struct-out core-output-port) + make-core-output-port) + +(define-values (prop:output-port output-port-via-property? output-port-ref) + (make-struct-type-property 'output-port + (lambda (v sti) + (check 'prop:output-port (lambda (v) (or (exact-nonnegative-integer? v) + (output-port? v))) + #:contract "(or/c output-port? exact-nonnegative-integer?)" + v) + (check-immutable-field 'prop:output-port v sti) + (if (exact-nonnegative-integer? v) + (make-struct-field-accessor (list-ref sti 3) v) + v)) + (list (cons prop:secondary-evt + (lambda (v) port->evt)) + (cons prop:output-port-evt + (lambda (o) + (output-port-evt-ref (->core-output-port o))))))) + +(define (output-port? p) + (or (core-output-port? p) + (output-port-via-property? p))) + +;; This function should not be called in atomic mode, +;; since it can invoke an artitrary function +(define (->core-output-port v) + (cond + [(core-output-port? v) v] + [(output-port? v) + (let ([p (output-port-ref v)]) + (cond + [(struct-accessor-procedure? p) + (->core-output-port (p v))] + [else + (->core-output-port p)]))] + [else + empty-output-port])) + +(struct core-output-port core-port + ( + ;; Various functions below are called in atomic mode; see + ;; `core-input-port` for more information on atomicity. + + evt ; An evt that is ready when writing a byte won't block + + write-out ; (bstr start-k end-k no-block/buffer? enable-break? copy? -> ...) + ;; Called in atomic mode. + ;; Doesn't block if `no-block/buffer?` is true. + ;; Does enable breaks while blocking if `enable-break?` is true. + ;; The `copy?` flag indicates that the given byte string should + ;; not be exposed to untrusted code, and instead of should be + ;; copied if necessary. The return values are the same as + ;; documented for `make-output-port`. + + write-out-special ; (any no-block/buffer? enable-break? -> boolean?) + ;; Called in atomic mode. + + get-write-evt ; (bstr start-k end-k -> evt?) + ;; Called in atomic mode. + ;; The given bstr should not be exposed to untrusted code. + + get-write-special-evt ; (-> evt?) + ;; *Not* called in atomic mode. + + [write-handler #:mutable] + [print-handler #:mutable] + [display-handler #:mutable]) + #:authentic + #:property prop:output-port-evt (lambda (o) + (choice-evt + (list + (poller-evt + (poller + (lambda (self sched-info) + (cond + [(closed-state-closed? (core-port-closed o)) + (values '(#t) #f)] + [else (values #f self)])))) + (core-output-port-evt o))))) + +(struct write-evt (proc) + #:property prop:evt (poller + (lambda (self sched-info) + ((write-evt-proc self) self)))) + +(define (make-core-output-port #:name name + #:data [data #f] + #:evt evt + #:write-out write-out + #:close close + #:write-out-special [write-out-special #f] + #:get-write-evt [get-write-evt #f] + #:count-write-evt-via-write-out [count-write-evt-via-write-out #f] + #:get-write-special-evt [get-write-special-evt #f] + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:file-position [file-position #f] + #:init-offset [init-offset 0] + #:buffer-mode [buffer-mode #f]) + (core-output-port name + data + + close + count-lines! + get-location + file-position + buffer-mode + + (closed-state #f #f) + init-offset ; offset + #f ; count? + #f ; state + #f ; cr-state + #f ; line + #f ; column + #f ; position + + evt + write-out + write-out-special + (or get-write-evt + (and count-write-evt-via-write-out + ;; If `write-out` is always atomic (in no-block, no-buffer mode), + ;; then an event can poll `write-out`: + (lambda (src-bstr src-start src-end) + (write-evt + ;; in atomic mode: + (lambda (self) + (define v (write-out src-bstr src-start src-end #f #f #t)) + (when (exact-integer? v) + (count-write-evt-via-write-out v src-bstr src-start)) + (if (evt? v) + ;; FIXME: should be `(replace-evt v self)` + (values #f self) + (values (list v) #f))))))) + get-write-special-evt + + #f ; write-handler + #f ; display-handler + #f)) ; print-handler + +(define empty-output-port + (make-core-output-port #:name 'empty + #:evt always-evt + #:write-out (lambda (bstr start end no-buffer? enable-break?) + (- end start)) + #:write-out-special (lambda (v no-buffer? enable-break?) + #t) + #:close void)) diff -Nru racket-6.12+ppa1/src/io/port/parameter.rkt racket-7.0+ppa1/src/io/port/parameter.rkt --- racket-6.12+ppa1/src/io/port/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,48 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt" + "output-port.rkt" + "input-port.rkt" + "fd-port.rkt") + +(provide current-input-port + current-output-port + current-error-port) + +(define current-input-port + (make-parameter (open-input-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDIN) + "error initializing stdin") + 'stdin) + (lambda (v) + (unless (input-port? v) + (raise-argument-error 'current-input-port + "input-port?" + v)) + v))) + +(define current-output-port + (make-parameter (open-output-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDOUT) + "error initializing stdout") + 'stdout + #:buffer-mode 'infer) + (lambda (v) + (unless (output-port? v) + (raise-argument-error 'current-output-port + "output-port?" + v)) + v))) + +(define current-error-port + (make-parameter (open-output-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDERR) + "error initializing stderr") + 'stderr + #:buffer-mode 'none) + (lambda (v) + (unless (output-port? v) + (raise-argument-error 'current-error-port + "output-port?" + v)) + v))) diff -Nru racket-6.12+ppa1/src/io/port/peek-via-read-port.rkt racket-7.0+ppa1/src/io/port/peek-via-read-port.rkt --- racket-6.12+ppa1/src/io/port/peek-via-read-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/peek-via-read-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,193 @@ +#lang racket/base +(require "../host/thread.rkt" + "input-port.rkt" + "output-port.rkt" + "pipe.rkt") + +(provide open-input-peek-via-read) + +(define (open-input-peek-via-read #:name name + #:data [data #f] + #:read-in read-in + #:read-is-atomic? [read-is-atomic? #f] ; => can implement progress evts + #:close close + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:init-offset [init-offset 0] + #:file-position [file-position #f] + #:alt-buffer-mode [alt-buffer-mode #f]) + (define-values (peek-pipe-i peek-pipe-o) (make-pipe)) + (define peeked-eof? #f) + (define buf (make-bytes 4096)) + (define buffer-mode 'block) + + ;; in atomic mode + (define (prepare-change) + ((core-input-port-prepare-change peek-pipe-i))) + + ;; in atomic mode + (define (pull-some-bytes [amt (bytes-length buf)] #:keep-eof? [keep-eof? #t]) + (define v (read-in buf 0 amt #f)) + (cond + [(eof-object? v) + (when keep-eof? + (set! peeked-eof? #t)) + eof] + [(evt? v) v] + [(eqv? v 0) 0] + [else + (let loop ([wrote 0]) + (define just-wrote ((core-output-port-write-out peek-pipe-o) buf wrote v #t #f #f)) + (define next-wrote (+ wrote just-wrote)) + (unless (= v next-wrote) + (loop next-wrote))) + v])) + + (define (retry-pull? v) + (and (integer? v) (not (eqv? v 0)))) + + ;; in atomic mode + (define (do-read-in dest-bstr start end copy?) + (let try-again () + (cond + [(positive? (pipe-content-length peek-pipe-i)) + ((core-input-port-read-in peek-pipe-i) dest-bstr start end copy?)] + [peeked-eof? + (set! peeked-eof? #f) + ;; an EOF doesn't count as progress + eof] + [else + (cond + [(and (< (- end start) (bytes-length buf)) + (eq? 'block buffer-mode)) + (define v (pull-some-bytes)) + (cond + [(or (eqv? v 0) (evt? v)) v] + [else (try-again)])] + [else + (define v (read-in dest-bstr start end copy?)) + (unless (eq? v 0) + (progress!)) + v])]))) + + ;; in atomic mode + (define (read-byte) + (define b ((core-input-port-read-byte peek-pipe-i))) + (cond + [(not (evt? b)) + b] + [peeked-eof? + (set! peeked-eof? #f) + ;; an EOF doesn't count as progress + eof] + [else + (define v (pull-some-bytes #:keep-eof? #f)) + (cond + [(retry-pull? v) (read-byte)] + [else + (progress!) + v])])) + + ;; in atomic mode + (define (do-peek-in dest-bstr start end skip progress-evt copy?) + (let try-again () + (define peeked-amt (if peek-pipe-i + (pipe-content-length peek-pipe-i) + 0)) + (cond + [(and progress-evt + (sync/timeout 0 progress-evt)) + #f] + [(and peek-pipe-i + (peeked-amt . > . skip)) + ((core-input-port-peek-in peek-pipe-i) dest-bstr start end skip progress-evt copy?)] + [peeked-eof? + eof] + [else + (define v (pull-some-bytes)) + (if (retry-pull? v) + (try-again) + v)]))) + + ;; in atomic mode + (define (peek-byte) + (cond + [(positive? (pipe-content-length peek-pipe-i)) + ((core-input-port-peek-byte peek-pipe-i))] + [peeked-eof? + eof] + [else + (define v (pull-some-bytes)) + (if (retry-pull? v) + (peek-byte) + v)])) + + ;; in atomic mode + (define (do-byte-ready work-done!) + (cond + [(positive? (pipe-content-length peek-pipe-i)) + #t] + [peeked-eof? + #t] + [else + (define v (pull-some-bytes)) + (work-done!) + (cond + [(retry-pull? v) + (do-byte-ready void)] + [(evt? v) v] + [else + (not (eqv? v 0))])])) + + ;; in atomic mode + (define (purge-buffer) + (set!-values (peek-pipe-i peek-pipe-o) (make-pipe)) + (set! peeked-eof? #f)) + + ;; in atomic mode + (define (get-progress-evt) + ((core-input-port-get-progress-evt peek-pipe-i))) + + ;; in atomic mode + (define (progress!) + ;; Relies on support for `0 #f #f` arguments in pipe implementation: + ((core-input-port-commit peek-pipe-i) 0 #f #f void)) + + (define (commit amt evt ext-evt finish) + ((core-input-port-commit peek-pipe-i) amt evt ext-evt finish)) + + (define do-buffer-mode + (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)])) + + (values (make-core-input-port + #:name name + #:data data + + #:prepare-change prepare-change + + #:read-byte read-byte + #:read-in do-read-in + #:peek-byte peek-byte + #:peek-in do-peek-in + #:byte-ready do-byte-ready + + #:get-progress-evt (and read-is-atomic? + get-progress-evt) + #:commit commit + + #:close (lambda () + (close) + (purge-buffer)) + + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode (or alt-buffer-mode do-buffer-mode)) + + ;; in atomic mode: + (case-lambda + [() (purge-buffer)] + [(pos) (- pos (pipe-content-length peek-pipe-i))]))) diff -Nru racket-6.12+ppa1/src/io/port/pipe.rkt racket-7.0+ppa1/src/io/port/pipe.rkt --- racket-6.12+ppa1/src/io/port/pipe.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/pipe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,424 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "count.rkt" + "commit-manager.rkt") + +(provide make-pipe + pipe-input-port? + pipe-output-port? + pipe-content-length + pipe-write-position + pipe-discard-all) + +(define (min+1 a b) (if a (min (add1 a) b) b)) + +(struct pipe-data (get-content-length + write-position + discard-all)) + +(define (pipe-input-port? p) + (and (input-port? p) + (pipe-data? (core-port-data (->core-input-port p))))) + +(define (pipe-output-port? p) + (and (output-port? p) + (pipe-data? (core-port-data (->core-output-port p))))) + +(define (pipe-content-length p) + ((pipe-data-get-content-length + (core-port-data + (cond + [(pipe-input-port? p) (->core-input-port p)] + [(pipe-output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'pipe-contact-length "(or/c pipe-input-port? pipe-output-port?)" p)]))))) + +(define pipe-write-position + (case-lambda + [(p) ((pipe-data-write-position (core-port-data p)))] + [(p pos) ((pipe-data-write-position (core-port-data p)) pos)])) + +(define (pipe-discard-all p) + ((pipe-data-discard-all (core-port-data p)))) + +(define/who (make-pipe [limit #f] [input-name 'pipe] [output-name 'pipe]) + (check who #:or-false exact-positive-integer? limit) + (define bstr (make-bytes (min+1 limit 16))) + (define len (bytes-length bstr)) + (define peeked-amt 0) ; peeked but not yet read effectively extends `limit` + (define start 0) + (define end 0) + (define write-pos #f) ; to adjust the write position via `file-position` on a string port + (define input-closed? #f) + (define output-closed? #f) + + (define (content-length) + (if (start . <= . end) + (- end start) + (+ end (- len start)))) + (define (input-empty?) (= start end)) + (define (output-full?) + (and limit + ((content-length) . >= . (+ limit peeked-amt)))) + + (define data + (pipe-data + ;; get-content-length + (lambda () + (atomically (content-length))) + ;; write-position + (case-lambda + [() (or write-pos end)] + [(pos) + ;; `pos` must be between `start` and `end` + (if (= pos end) + (set! write-pos #f) + (set! write-pos pos))]) + ;; discard-all + (lambda () + (set! peeked-amt 0) + (set! start 0) + (set! end 0) + (set! write-pos #f)))) + + (define read-ready-sema (make-semaphore)) + (define write-ready-sema (and limit (make-semaphore 1))) + (define more-read-ready-sema #f) ; for lookahead peeks + (define read-ready-evt (wrap-evt (semaphore-peek-evt read-ready-sema) + (lambda (v) 0))) + (define write-ready-evt (if limit + (semaphore-peek-evt write-ready-sema) + always-evt)) + (define progress-sema #f) + + ;; Used before/after read: + (define (check-output-unblocking) + (when (output-full?) (semaphore-post write-ready-sema))) + (define (check-input-blocking) + (when (input-empty?) (semaphore-wait read-ready-sema))) + + ;; Used before/after write: + (define (check-input-unblocking) + (when (and (input-empty?) (not output-closed?)) (semaphore-post read-ready-sema)) + (when more-read-ready-sema + (semaphore-post more-read-ready-sema) + (set! more-read-ready-sema #f))) + (define (check-output-blocking) + (when (output-full?) (semaphore-wait write-ready-sema))) + + ;; Used after peeking: + (define (peeked! amt) + (when (amt . > . peeked-amt) + (check-output-unblocking) + (set! peeked-amt amt))) + + (define (progress!) + (when progress-sema + (semaphore-post progress-sema) + (set! progress-sema #f))) + + (define commit-manager #f) + + ;; in atomic mode [can leave atomic mode temporarily] + ;; After this function returns, complete any commit-changing work + ;; before leaving atomic mode again. + (define (pause-waiting-commit) + (when commit-manager + (commit-manager-pause commit-manager))) + + ;; in atomic mode [can leave atomic mode temporarily] + (define (wait-commit progress-evt ext-evt finish) + (cond + [(and (not commit-manager) + ;; Try shortcut: + (not (sync/timeout 0 progress-evt)) + (sync/timeout 0 ext-evt)) + (finish) + #t] + [else + ;; General case to support blocking and potentially multiple + ;; commiting threads: + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait commit-manager progress-evt ext-evt finish)])) + + ;; input ---------------------------------------- + (define ip + (make-core-input-port + #:name input-name + #:data data + + #:prepare-change + (lambda () + (pause-waiting-commit)) + + #:read-byte + (lambda () + (cond + [(input-empty?) + (if output-closed? + eof + ;; event's synchronization value is ignored: + read-ready-evt)] + [else + (define pos start) + (check-output-unblocking) + (set! start (add1 pos)) + (set! peeked-amt (max 0 (sub1 peeked-amt))) + (when (= start len) + (set! start 0)) + (check-input-blocking) + (progress!) + (bytes-ref bstr pos)])) + + #:read-in + (lambda (dest-bstr dest-start dest-end copy?) + (cond + [(input-empty?) + (if output-closed? + eof + read-ready-evt)] + [else + (check-output-unblocking) + (begin0 + (cond + [(start . < . end) + (define amt (min (- dest-end dest-start) + (- end start))) + (bytes-copy! dest-bstr dest-start bstr start (+ start amt)) + (set! start (+ start amt)) + (set! peeked-amt (max 0 (- peeked-amt amt))) + amt] + [else + (define amt (min (- dest-end dest-start) + (- len start))) + (bytes-copy! dest-bstr dest-start bstr start (+ start amt)) + (set! start (modulo (+ start amt) len)) + (set! peeked-amt (max 0 (- peeked-amt amt))) + amt]) + (check-input-blocking) + (progress!))])) + + #:peek-byte + (lambda () + (cond + [(input-empty?) + (if output-closed? + eof + read-ready-evt)] + [else + (peeked! 1) + (bytes-ref bstr start)])) + + #:peek-in + (lambda (dest-bstr dest-start dest-end skip progress-evt copy?) + (define content-amt (content-length)) + (cond + [(and progress-evt + (sync/timeout 0 progress-evt)) + #f] + [(content-amt . <= . skip) + (cond + [output-closed? eof] + [else + (unless (or (zero? skip) more-read-ready-sema) + (set! more-read-ready-sema (make-semaphore))) + (define evt (if (zero? skip) + read-ready-evt + (wrap-evt (semaphore-peek-evt more-read-ready-sema) + (lambda (v) 0)))) + evt])] + [else + (define peek-start (modulo (+ start skip) len)) + (cond + [(peek-start . < . end) + (define amt (min (- dest-end dest-start) + (- end peek-start))) + (bytes-copy! dest-bstr dest-start bstr peek-start (+ peek-start amt)) + (peeked! (+ skip amt)) + amt] + [else + (define amt (min (- dest-end dest-start) + (- len peek-start))) + (bytes-copy! dest-bstr dest-start bstr peek-start (+ peek-start amt)) + (peeked! (+ skip amt)) + amt])])) + + #:byte-ready + (lambda (work-done!) + (or output-closed? + (not (zero? (content-length))))) + + #:close + (lambda () + (unless input-closed? + (set! input-closed? #t) + (progress!))) + + #:get-progress-evt + (lambda () + (atomically + (cond + [input-closed? always-evt] + [else + (unless progress-sema + (set! progress-sema (make-semaphore))) + (semaphore-peek-evt progress-sema)]))) + + #:commit + ;; Allows `amt` to be zero and #f for other arguments, + ;; which is helpful for `open-input-peek-via-read`. + (lambda (amt progress-evt ext-evt finish) + ;; `progress-evt` is a `semepahore-peek-evt`, and `ext-evt` + ;; is constrained; we can send them over to different threads + (cond + [(zero? amt) + (progress!)] + [else + (wait-commit + progress-evt ext-evt + ;; in atomic mode, maybe in a different thread: + (lambda () + (let ([amt (min amt (content-length))]) + (cond + [(zero? amt) + ;; There was nothing to commit; claim success for 0 bytes + (finish #"")] + [else + (define dest-bstr (make-bytes amt)) + (cond + [(start . < . end) + (bytes-copy! dest-bstr 0 bstr start (+ start amt))] + [else + (define amt1 (min (- len start) amt)) + (bytes-copy! dest-bstr 0 bstr start (+ start amt1)) + (when (amt1 . < . amt) + (bytes-copy! dest-bstr amt1 bstr 0 (- amt amt1)))]) + (set! start (modulo (+ start amt) len)) + (progress!) + (check-input-blocking) + (finish dest-bstr)]))))])))) + + ;; out ---------------------------------------- + (define op + (make-core-output-port + #:name output-name + #:data data + + #:evt write-ready-evt + + #:write-out + ;; in atomic mode + (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (let try-again () + (define top-pos (if (zero? start) + (sub1 len) + len)) + (define (maybe-grow) + (cond + [(or (not limit) + ((+ limit peeked-amt) . > . (sub1 len))) + ;; grow pipe size + (define new-bstr (make-bytes (min+1 (and limit (+ limit peeked-amt)) (* len 2)))) + (cond + [(zero? start) + (bytes-copy! new-bstr 0 bstr 0 (sub1 len))] + [else + (bytes-copy! new-bstr 0 bstr start len) + (bytes-copy! new-bstr (- len start) bstr 0 end) + (set! start 0) + (set! end (sub1 len))]) + (set! bstr new-bstr) + (set! len (bytes-length new-bstr)) + (try-again)] + [else (pipe-is-full)])) + (define (pipe-is-full) + (wrap-evt write-ready-evt (lambda (v) #f))) + (define (apply-limit amt) + (if limit + (min amt (- (+ limit peeked-amt) (content-length))) + amt)) + (cond + [(= src-start src-end) ;; => flush + 0] + [write-pos ; set by `file-position` on a bytes port + (define amt (apply-limit (min (- end write-pos) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr write-pos src-bstr src-start (+ src-start amt)) + (let ([new-write-pos (+ write-pos amt)]) + (if (= new-write-pos end) + (set! write-pos #f) ; back to normal mode + (set! write-pos new-write-pos))) + (check-output-blocking) + amt])] + [(and (end . >= . start) + (end . < . top-pos)) + (define amt (apply-limit (min (- top-pos end) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr end src-bstr src-start (+ src-start amt)) + (let ([new-end (+ end amt)]) + (set! end (if (= new-end len) 0 new-end))) + (check-output-blocking) + amt])] + [(= end top-pos) + (cond + [(zero? start) + (maybe-grow)] + [else + (define amt (min (sub1 start) + (- src-end src-start))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr 0 src-bstr src-start (+ src-start amt)) + (set! end amt) + (check-output-blocking) + amt])])] + [(end . < . (sub1 start)) + (define amt (apply-limit (min (- (sub1 start) end) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr end src-bstr src-start (+ src-start amt)) + (set! end (+ end amt)) + (check-output-blocking) + amt])] + [else + (maybe-grow)]))) + + #:count-write-evt-via-write-out + (lambda (v bstr start) + (port-count! op v bstr start)) + + #:close + ;; in atomic mode + (lambda () + (unless output-closed? + (set! output-closed? #t) + (when write-ready-sema + (semaphore-post write-ready-sema)) + (when more-read-ready-sema + (semaphore-post more-read-ready-sema)) + (semaphore-post read-ready-sema))))) + + ;; Results ---------------------------------------- + (when (port-count-lines-enabled) + (port-count-lines! ip) + (port-count-lines! op)) + + (values ip op)) diff -Nru racket-6.12+ppa1/src/io/port/port.rkt racket-7.0+ppa1/src/io/port/port.rkt --- racket-6.12+ppa1/src/io/port/port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +#lang racket/base +(require "../host/thread.rkt" + "evt.rkt") + +(provide (struct-out core-port) + (struct-out closed-state)) + +(struct core-port (name ; anything, reported as `object-name` for the port + data ; anything, effectively a subtype indicator + + close ; -> (void) + ;; Called in atomic mode. + + count-lines! ; #f or procedure called in atomic mode + get-location ; #f or procedure called in atomic mode + file-position ; #f, port, or procedure called in atomic mode + buffer-mode ; #f or procedure in atomic mode + + closed ; `closed-state` + + [offset #:mutable] ; count plain bytes + [count? #:mutable] ; whether line counting is enabled + [state #:mutable] ; state of UTF-8 decoding + [cr-state #:mutable] ; state of CRLF counting as a single LF + [line #:mutable] ; count newlines + [column #:mutable] ; count UTF-8 characters in line + [position #:mutable]) ; count UTF-8 characters + #:authentic + #:property prop:object-name (struct-field-index name) + #:property prop:secondary-evt port->evt) + +(struct closed-state ([closed? #:mutable] + [closed-sema #:mutable]) ; #f or a semaphore posed on close + #:authentic) diff -Nru racket-6.12+ppa1/src/io/port/prepare-change.rkt racket-7.0+ppa1/src/io/port/prepare-change.rkt --- racket-6.12+ppa1/src/io/port/prepare-change.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/prepare-change.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,11 @@ +#lang racket/base +(require "input-port.rkt") + +(provide prepare-change) + +;; in atomic mode +;; ... but may leave and return to atomic mode +(define (prepare-change in) + (define prepare-change (core-input-port-prepare-change in)) + (when prepare-change + (prepare-change))) diff -Nru racket-6.12+ppa1/src/io/port/progress-evt.rkt racket-7.0+ppa1/src/io/port/progress-evt.rkt --- racket-6.12+ppa1/src/io/port/progress-evt.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/progress-evt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,74 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "input-port.rkt" + "count.rkt" + "check.rkt") + +(provide (rename-out [progress-evt?* progress-evt?]) + port-provides-progress-evts? + port-progress-evt + port-commit-peeked + + check-progress-evt + unwrap-progress-evt) + +(struct progress-evt (port evt) + #:property prop:evt (lambda (pe) + (wrap-evt (progress-evt-evt pe) + (lambda args pe)))) + +(define progress-evt?* + (let ([progress-evt? + (case-lambda + [(v) (progress-evt? v)] + [(v port) + (and (progress-evt? v) + (eq? port (progress-evt-port v)))])]) + progress-evt?)) + +;; ---------------------------------------- + +(define/who (port-provides-progress-evts? in) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (and (core-input-port-get-progress-evt in) #t))) + +(define/who (port-progress-evt orig-in) + (check who input-port? orig-in) + (let ([in (->core-input-port orig-in)]) + (define get-progress-evt (core-input-port-get-progress-evt in)) + (if get-progress-evt + (progress-evt orig-in (get-progress-evt)) + (raise-arguments-error 'port-progress-evt + "port does not provide progress evts" + "port" orig-in)))) + +(define/who (port-commit-peeked amt progress-evt evt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who progress-evt? progress-evt) + (check who sync-atomic-poll-evt? + #:contract "(or/c channel-put-evt? channel? semaphore? semaphore-peek-evt? always-evt never-evt)" + evt) + (check who input-port? in) + (check-progress-evt who progress-evt in) + (let ([in (->core-input-port in)]) + (define commit (core-input-port-commit in)) + (atomically + ;; We specially skip a check on whether the port is closed, + ;; since that's handled as the progress evt becoming ready + (commit amt (progress-evt-evt progress-evt) evt + ;; in atomic mode (but maybe leaves atomic mode in between) + (lambda (bstr) + (port-count! in (bytes-length bstr) bstr 0)))))) + +(define (check-progress-evt who progress-evt in) + (unless (progress-evt?* progress-evt in) + (raise-arguments-error who "evt is not a progress evt for the given port" + "evt" progress-evt + "port" in))) + +(define (unwrap-progress-evt progress-evt) + (and progress-evt + (progress-evt-evt progress-evt))) diff -Nru racket-6.12+ppa1/src/io/port/read-and-peek.rkt racket-7.0+ppa1/src/io/port/read-and-peek.rkt --- racket-6.12+ppa1/src/io/port/read-and-peek.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/read-and-peek.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,241 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "count.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide read-some-bytes! + peek-some-bytes! + + do-read-byte + read-byte-via-bytes + do-peek-byte + peek-byte-via-bytes) + +;; Read up to `(- end start)` bytes, producing at least a +;; single by unless `zero-ok?` is true. The result is +;; EOF or the number of bytes read. +(define (read-some-bytes! who orig-in bstr start end + ;; Zero is ok for `read-bytes!*`: + #:zero-ok? [zero-ok? #f] + ;; Enable breaks while blocking? + #:enable-break? [enable-break? #f] + ;; When calling an externally implemented + ;; port, we normally make a fresh byte + ;; string, because we don't trust the + ;; reading proc to not retain the byte + ;; string and change it later. We can skip + ;; the copy if the bstr is the right length + ;; and won't be exposed, though. + #:copy-bstr? [copy-bstr? #t] + ;; If `keep-eof?`, don't consume an EOF + #:keep-eof? [keep-eof? #f] + ;; If not `special-ok?` and a special value is + ;; received, raise an exception + #:special-ok? [special-ok? #t] + ;; For a special result, limit the procedure + ;; to 4 unless `read-byte-or-special`, etc., + ;; need access to a 0-argument version + #:limit-special-arity? [limit-special-arity? #t]) + (let loop ([in orig-in] [extra-count-ins null]) + (start-atomic) + (prepare-change in) + (cond + [(= start end) ; intentionally before the port-closed check + (end-atomic) + 0] + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + ;; previously detected EOF? + [(core-input-port-pending-eof? in) + (unless keep-eof? + (set-core-input-port-pending-eof?! in #f)) + (end-atomic) + eof] + [else + ;; normal mode... + (define read-in (core-input-port-read-in in)) + (cond + [(procedure? read-in) + (define v (read-in bstr start end copy-bstr?)) + (let result-loop ([v v]) + (cond + [(and (integer? v) (not (eq? v 0))) + (port-count-all! in extra-count-ins v bstr start)] + [(procedure? v) + (port-count-byte-all! in extra-count-ins #f)]) + (end-atomic) + (cond + [(exact-nonnegative-integer? v) + (cond + [(zero? v) + (if zero-ok? + 0 + (loop in extra-count-ins))] + [(v . <= . (- end start)) v] + [else + (raise-arguments-error who + "result integer is larger than the supplied byte string" + "result" v + "byte-string length" (- end start))])] + [(eof-object? v) eof] + [(evt? v) + ;; If `zero-ok?`, we should at least poll the event + (define timeout (if zero-ok? (lambda () 0) #f)) + (define next-v (if enable-break? + (sync/timeout/enable-break timeout v) + (sync/timeout timeout v))) + (cond + [(and zero-ok? (evt? next-v)) + ;; Avoid looping on events + 0] + [else + (start-atomic) + (result-loop next-v)])] + [(procedure? v) + (if special-ok? + (if limit-special-arity? + (lambda (a b c d) (v a b c d)) + v) + (raise-arguments-error who + "non-character in an unsupported context" + "port" orig-in))] + [else + (internal-error (format "weird read-bytes result ~s" v))]))] + [else + (end-atomic) + (loop (->core-input-port read-in) (cons in extra-count-ins))])]))) + +;; Like `read-some-bytes!`, but merely peeks +(define (peek-some-bytes! who orig-in bstr start end skip + #:progress-evt [progress-evt #f] + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f] + #:copy-bstr? [copy-bstr? #t] + #:special-ok? [special-ok? #t] + #:limit-special-arity? [limit-special-arity? #t]) + (let loop ([in orig-in]) + (start-atomic) + (prepare-change in) + (cond + [(= start end) + (end-atomic) + 0] + ;; check progress evt before continuing with other possibilities + [(and progress-evt + (sync/timeout 0 progress-evt)) + (end-atomic) + 0] + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + ;; previously detected EOF? (never skip past it) + [(core-input-port-pending-eof? in) + (end-atomic) + + eof] + [else + (define peek-in (core-input-port-peek-in in)) + (cond + [(procedure? peek-in) + (define v (peek-in bstr start end skip progress-evt copy-bstr?)) + (end-atomic) + (let result-loop ([v v]) + (cond + [(exact-nonnegative-integer? v) + (cond + [(zero? v) + (if zero-ok? + 0 + (loop in))] + [(v . <= . (- end start)) v] + [else + (raise-arguments-error who + "result integer is larger than the supplied byte string" + "result" v + "byte-string length" (- end start))])] + [(eof-object? v) eof] + [(evt? v) + (cond + [zero-ok? 0] + [else (result-loop (if enable-break? + (sync/enable-break v) + (sync v)))])] + [(procedure? v) + (if special-ok? + (if limit-special-arity? + (lambda (a b c d) (v a b c d)) + v) + (raise-arguments-error who + "non-character in an unsupported context" + "port" orig-in))] + [else + (internal-error (format "weird peek-bytes result ~s" v))]))] + [else + (end-atomic) + (loop (->core-input-port peek-in))])]))) + + +;; Use a `read-byte` shortcut +(define (do-read-byte who read-byte in) + (let loop () + (start-atomic) + (prepare-change in) + (cond + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + [else + (define b (read-byte)) + (cond + [(eof-object? b) + (end-atomic) + b] + [(evt? b) + (end-atomic) + (sync b) + (loop)] + [else + (port-count-byte! in b) + (end-atomic) + b])]))) + +;; Use the general path; may return a procedure for a special +(define (read-byte-via-bytes in #:special-ok? [special-ok? #t]) + (define bstr (make-bytes 1)) + (define v (read-some-bytes! 'read-byte in bstr 0 1 + #:copy-bstr? #f + #:special-ok? special-ok? + #:limit-special-arity? #f)) + (if (eq? v 1) + (bytes-ref bstr 0) + v)) + +;; Use a `peek-byte` shortcut +(define (do-peek-byte who peek-byte in orig-in) + (let loop () + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define b (peek-byte)) + (end-atomic) + (cond + [(evt? b) + (sync b) + (loop)] + [else b]))) + +;; Use the general path; may return a procedure for a special +(define (peek-byte-via-bytes in skip-k + #:special-ok? [special-ok? #t] + #:progress-evt [progress-evt #f]) + (define bstr (make-bytes 1)) + (define v (peek-some-bytes! 'peek-byte in bstr 0 1 skip-k + #:copy-bstr? #f + #:special-ok? special-ok? + #:limit-special-arity? #f + #:progress-evt progress-evt)) + (if (eq? v 1) + (bytes-ref bstr 0) + v)) diff -Nru racket-6.12+ppa1/src/io/port/ready.rkt racket-7.0+ppa1/src/io/port/ready.rkt --- racket-6.12+ppa1/src/io/port/ready.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/ready.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../string/utf-8-decode.rkt" + "port.rkt" + "input-port.rkt" + "bytes-input.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide byte-ready? + char-ready?) + +(define/who (byte-ready? in) + (check who input-port? in) + (let loop ([in (->core-input-port in)]) + (define byte-ready (core-input-port-byte-ready in)) + (cond + [(input-port? byte-ready) (loop (->core-input-port byte-ready))] + [else + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define r (byte-ready void)) + (end-atomic) + (eq? #t r)]))) + +(define/who (char-ready? in) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (cond + [(byte-ready? in) + (define peek-byte (core-input-port-peek-byte in)) + (define b (and peek-byte (peek-byte))) + (cond + [(and b + (or (eof-object? b) + (b . < . 128))) + ;; Shortcut worked + #t] + [else + (define bstr (make-bytes 1)) + (let loop ([offset 0] [state #f]) + (cond + [(eq? 1 (peek-bytes-avail!* bstr offset #f in)) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr 0 1 + #f 0 #f + #:error-char #\? + #:abort-mode 'state + #:state state)) + (cond + [(utf-8-state? new-state) + (loop (add1 offset) new-state)] + [else #t])] + [else #f]))])] + [else #f]))) diff -Nru racket-6.12+ppa1/src/io/port/special-input.rkt racket-7.0+ppa1/src/io/port/special-input.rkt --- racket-6.12+ppa1/src/io/port/special-input.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/special-input.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,106 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "string-input.rkt" + "progress-evt.rkt" + "count.rkt") + +(provide read-byte-or-special + peek-byte-or-special + read-char-or-special + peek-char-or-special) + +(define/who (read-byte-or-special [orig-in (current-input-port)] + [special-wrap #f] + [source-name #f]) + (check who input-port? orig-in) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (let ([in (->core-input-port orig-in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [read-byte (do-read-byte who read-byte in)] + [else + (extract-special-value (read-byte-via-bytes in) + in source-name -1 + special-wrap)]))) + + +(define/who (peek-byte-or-special [orig-in (current-input-port)] + [skip-k 0] + [progress-evt #f] + [special-wrap #f] + [source-name #f]) + (check who input-port? orig-in) + (check who exact-nonnegative-integer? skip-k) + (check who #:or-false evt? progress-evt) + (check who special-wrap-for-peek? #:contract special-wrap-for-peek/c-str special-wrap) + (when progress-evt + (check-progress-evt who progress-evt orig-in)) + (let ([in (->core-input-port orig-in)]) + (define peek-byte (core-input-port-read-byte in)) + (cond + [peek-byte (do-peek-byte who peek-byte in orig-in)] + [else + (extract-special-value (peek-byte-via-bytes in skip-k #:progress-evt progress-evt) + in source-name skip-k + special-wrap)]))) + +;; ---------------------------------------- + +(define/who (read-char-or-special [in (current-input-port)] + [special-wrap #f] + [source-name #f]) + (check who input-port? in) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (extract-special-value (do-read-char who in #:special-ok? #t) + in source-name -1 + special-wrap)) + +(define/who (peek-char-or-special [in (current-input-port)] + [skip-k 0] + [special-wrap #f] + [source-name #f]) + (check who input-port? in) + (check who exact-nonnegative-integer? skip-k) + (check who special-wrap-for-peek? #:contract special-wrap-for-peek/c-str special-wrap) + (extract-special-value (do-peek-char who in skip-k #:special-ok? #t) + in source-name skip-k + special-wrap)) + +;; ---------------------------------------- + +(define (extract-special-value v in source-name delta special-wrap) + (cond + [(procedure? v) + (cond + [(eq? special-wrap 'special) + 'special] + [else + (define special + (cond + [(not source-name) + (cond + [(procedure-arity-includes? v 0) + (v)] + [else + (v #f #f #f #f)])] + [else + (define-values (line col pos) (port-next-location in)) + (v source-name + line + (and col (+ col delta)) + (and pos (+ pos delta)))])) + (if special-wrap + (special-wrap special) + special)])] + [else v])) + +(define (special-wrap-for-peek? w) + (or (not w) (eq? w 'special) (and (procedure? w) + (procedure-arity-includes? w 1)))) + +(define special-wrap-for-peek/c-str + "(or/c (any/c -> any/c) #f 'special)") + diff -Nru racket-6.12+ppa1/src/io/port/special-output.rkt racket-7.0+ppa1/src/io/port/special-output.rkt --- racket-6.12+ppa1/src/io/port/special-output.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/special-output.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,64 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "parameter.rkt" + "count.rkt") + +(provide write-special + write-special-avail* + write-special-evt + port-writes-special?) + +(define/who (port-writes-special? o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (and (core-output-port-write-out-special o) #t))) + +(define (do-write-special who v orig-o #:retry? retry?) + (check who output-port? orig-o) + (let port-loop ([o orig-o] [extra-count-os null]) + (let ([o (->core-output-port o)]) + (define write-out-special (core-output-port-write-out-special o)) + (unless write-out-special + (raise-arguments-error who + "port does not support special values" + "port" orig-o)) + (cond + [(output-port? write-out-special) + (port-loop write-out-special (cons o extra-count-os))] + [else + (let loop () + (start-atomic) + (define r (write-out-special v (not retry?) #f)) + (let result-loop ([r r]) + (cond + [(not r) + (end-atomic) + (if retry? + (loop) + #f)] + [(evt? r) + (end-atomic) + (and retry? + (result-loop (sync r)))] + [else + (port-count-all! o extra-count-os 1 #"x" 0) + (end-atomic) + #t])))])))) + +(define/who (write-special v [o (current-output-port)]) + (do-write-special who #:retry? #t v o)) + +(define/who (write-special-avail* v [o (current-output-port)]) + (do-write-special who #:retry? #f v o)) + +(define/who (write-special-evt v [o (current-output-port)]) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (define get-write-special-evt (core-output-port-get-write-special-evt o)) + (unless get-write-special-evt + (raise-arguments-error who + "port does not support special-value events" + "port" o)) + (get-write-special-evt v))) diff -Nru racket-6.12+ppa1/src/io/port/string-input.rkt racket-7.0+ppa1/src/io/port/string-input.rkt --- racket-6.12+ppa1/src/io/port/string-input.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/string-input.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,361 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "input-port.rkt" + (submod "bytes-input.rkt" internal) + "../string/utf-8-decode.rkt" + "count.rkt" + "flush-output.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide read-char + read-string + read-string! + + peek-char + peek-string + peek-string! + + do-read-char + do-peek-char) + +;; ---------------------------------------- + +;; Read up to `(- end start)` characters by UTF-8 decoding of bytes, +;; producing at least one character unless `zero-ok?`, but it's +;; possible that fewer that `(- end start)` characters are read. The +;; result is two values: either EOF or the number of read characters, +;; and the number of converted bytes +(define (read-some-chars! who orig-in str start end + #:zero-ok? [zero-ok? #f] + #:extra-bytes-amt [extra-bytes-amt 0] + #:keep-eof? [keep-eof? #f] + #:just-peek? [just-peek? #f] + #:skip [skip-k 0] ; must be 0 if `(not just-peek?)` + #:special-ok? [special-ok? #f]) + (define amt (- end start)) + (define bstr (make-bytes amt)) + ;; We're allowed to read up to `amt` characters, which means at + ;; least `amt` bytes. + (define consumed-v + (cond + [just-peek? 0] + [else + (read-some-bytes! who orig-in bstr 0 amt + #:zero-ok? zero-ok? + #:copy-bstr? #f + #:keep-eof? keep-eof? + #:special-ok? special-ok?)])) + (define v + (cond + [just-peek? + (peek-some-bytes! who orig-in + bstr consumed-v amt skip-k + #:copy-bstr? #f + #:zero-ok? zero-ok?)] + [else consumed-v])) + ;; At this point, `v` is the number of bytes that we have ready, and + ;; the first `consumed-v` of those are read (as opposed to just + ;; peeked) from the port. [Currently, `consumed-v` is either 0 or `v`.] + (cond + [(not (exact-integer? v)) (values v 0)] + [(zero? v) (values 0 0)] + [else + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr 0 v + str start (+ start amt) + #:error-char #\uFFFD + #:abort-mode 'state)) + ;; Includes consumed bytes: + (define actually-used-bytes (- used-bytes + (if (utf-8-state? state) + (utf-8-state-pending-amt state) + 0))) + ;; The `state` result can't be 'continues, because N + ;; bytes will never produce > N chars; it can't be + ;; 'error, because we provide an error character; it + ;; can't be 'aborts, because we request an abort state + (cond + [(or (zero? got-chars) + (actually-used-bytes . < . consumed-v)) + ;; The state must be an abort state. + ;; We need to try harder to get a character; even if + ;; `zero-ok?` is true, we may need to try asking + ;; for more bytes to make any progress for a polling + ;; request + (let loop ([skip-k (+ skip-k (- v consumed-v))] + [total-used-bytes used-bytes] + [state state] + [total-chars got-chars] + [start (+ start got-chars)] + [amt (- amt got-chars)]) + (define v (peek-some-bytes! who orig-in bstr 0 1 skip-k + #:zero-ok? zero-ok? + #:special-ok? special-ok?)) + (cond + [(and (eq? v 0) + (zero? consumed-v)) + ;; `zero-ok?` must be true, and we haven't + ;; consumed any bytes, so give up + (values 0 0)] + [else + ;; Try to convert with the additional byte; v can be + ;; `eof` or a special-value procedure, in which case the + ;; abort mode should be 'error to trigger decodings as + ;; errors + (define-values (used-bytes got-chars new-state) + (if (eq? v 0) + (values 0 0 state) + (utf-8-decode! bstr 0 (if (integer? v) v 0) + str start (+ start amt) + #:error-char #\uFFFD + #:state (and (utf-8-state? state) state) + #:abort-mode (if (integer? v) + 'state + 'error)))) + (cond + [(zero? got-chars) + ;; Try even harder; we shouldn't get here if v was `eof` + ;; or a special-value procedure + (loop (+ skip-k v) (+ total-used-bytes used-bytes) new-state total-chars start amt)] + [else + ;; At this point `used-bytes` by itself can be negative, since + ;; conversion may not have used all the bytes that + ;; we peeked to try to complete a decoding. Those unused bytes + ;; count again `skip-k`. Meanwhile, an error state might + ;; report that some other bytes aren't actually consumed, yet. + ;; Does not include consumed bytes: + (define actually-used-bytes (- (+ total-used-bytes + used-bytes) + (if (utf-8-state? new-state) + (utf-8-state-pending-amt new-state) + 0))) + (cond + [(actually-used-bytes . < . consumed-v) + ;; We need to inspect at least one more byte to + ;; consume the bytes that we have already consumed from + ;; the point + (loop (+ skip-k v) (+ total-used-bytes used-bytes) new-state + (+ total-chars got-chars) (+ start got-chars) (- amt got-chars))] + [else + (unless just-peek? + (let ([discard-bytes (- actually-used-bytes consumed-v)]) + (define finish-bstr (if (discard-bytes . <= . (bytes-length bstr)) + bstr + (make-bytes discard-bytes))) + (do-read-bytes! who orig-in finish-bstr 0 discard-bytes))) + (values (+ total-chars got-chars) + actually-used-bytes)])])]))] + [else + ;; Conversion succeeded for at least 1 character. Since we used + ;; all bytes that we consumed from the port, if more characters are needed, + ;; another call to `read-some-chars!` can deal with it. + (unless (or just-peek? + (= actually-used-bytes consumed-v)) + (do-read-bytes! who orig-in bstr 0 (- actually-used-bytes consumed-v))) + (values got-chars actually-used-bytes)])])) + +;; ---------------------------------------- + +;; Read `(- end start)` chars, stopping early only if an EOF is found +(define (do-read-string! who in str start end + #:just-peek? [just-peek? #f] + #:skip [skip-k 0] + #:special-ok? [special-ok? #f]) + (define amt (- end start)) + (define-values (v used-bytes) (read-some-chars! who in str start end + #:just-peek? just-peek? + #:skip skip-k + #:special-ok? special-ok?)) + (cond + [(not (exact-integer? v)) v] + [(= v amt) v] + [else + (let loop ([got v] [total-used-bytes used-bytes]) + (define-values (v used-bytes) (read-some-chars! who in str (+ start got) end + #:keep-eof? #t + #:just-peek? just-peek? + #:skip (if just-peek? + (+ skip-k total-used-bytes) + 0))) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got (+ total-used-bytes used-bytes))])]))])) + +;; ---------------------------------------- + +;; A shortcut to implement `read-char` in terms of a port-specific +;; `read-byte`: +(define (read-char-via-read-byte who in read-byte #:special-ok? [special-ok? #t]) + (define b + (let loop () + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define b (read-byte)) + (cond + [(evt? b) + (end-atomic) + (sync b) + (loop)] + [else + (unless (eof-object? b) + (port-count-byte! in b)) + (end-atomic) + b]))) + (cond + [(eof-object? b) b] + [else + (cond + [(b . < . 128) (integer->char b)] + [else + ;; UTF-8 decoding... May need to peek bytes to discover + ;; whether the decoding will work (in which case this wasn't + ;; much of a shortcut) + (define bstr (bytes b)) + (define str (make-string 1)) + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr 0 1 + #f 0 #f + #:abort-mode 'state)) + (cond + [(eq? state 'error) + ;; This happens if the byte is a UTF-8 continuation byte + #\uFFFD] + [else + ;; Need to peek ahead + (let loop ([skip-k 0] [state state]) + (define v (peek-some-bytes! who in bstr 0 1 skip-k #:copy-bstr? #f #:special-ok? special-ok?)) + (cond + [(or (eof-object? v) + (procedure? v)) + ;; Already-consumed byte is an error byte + #\uFFFD] + [else + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr 0 1 + str 0 1 + #:state state + #:error-char #\uFFFD + #:abort-mode 'state)) + (cond + [(= got-chars 1) + (define actually-used-bytes (+ skip-k used-bytes)) + (unless (zero? actually-used-bytes) + (define finish-bstr (if (actually-used-bytes . <= . (bytes-length bstr)) + bstr + (make-bytes actually-used-bytes))) + (do-read-bytes! who in finish-bstr 0 actually-used-bytes)) + (string-ref str 0)] + [else + (loop (add1 skip-k) new-state)])]))])])])) + +;; ---------------------------------------- + +;; If `special-ok?`, can return a special-value procedure +(define (do-read-char who in #:special-ok? [special-ok? #f]) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [(not read-byte) + (define str (make-string 1)) + (define-values (v used-bytes) (read-some-chars! who in str 0 1 #:special-ok? special-ok?)) + (if (eq? v 1) + (string-ref str 0) + v)] + [else + ;; Byte-level shortcut is available, so try it as a char shortcut + (read-char-via-read-byte who in read-byte #:special-ok? special-ok?)]))) + +(define/who (read-char [in (current-input-port)]) + (check who input-port? in) + (do-read-char who in)) + +(define/who (read-string amt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-string amt)) + (define v (do-read-string! 'read-string in bstr 0 amt)) + (if (exact-integer? v) + (if (= v amt) + bstr + (substring bstr 0 v)) + v))) + +(define/who (read-string! str [in (current-input-port)] [start-pos 0] [end-pos (and (string? str) + (string-length str))]) + (check who string? str) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (string-length str) str) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-read-string! who in str start-pos end-pos))) + +;; ---------------------------------------- + +(define (do-peek-string! who in str start end skip #:special-ok? [special-ok? #f]) + (do-read-string! who in str start end #:skip skip #:just-peek? #t #:special-ok? special-ok?)) + +(define (do-peek-char who in skip-k #:special-ok? [special-ok? #f]) + (let ([in (->core-input-port in)]) + (define peek-byte (and (zero? skip-k) + (core-input-port-peek-byte in))) + (define b (and peek-byte (peek-byte))) + (cond + [(and b + (or (eof-object? b) + (and (byte? b) + (b . < . 128)))) + ;; Shortcut worked + (if (eof-object? b) b (integer->char b))] + [else + ;; General mode + (define bstr (make-string 1)) + (define v (do-peek-string! who in bstr 0 1 skip-k #:special-ok? special-ok?)) + (if (eq? v 1) + (string-ref bstr 0) + v)]))) + +(define/who (peek-char [in (current-input-port)] [skip-k 0]) + (check who input-port? in) + (check who exact-nonnegative-integer? skip-k) + (do-peek-char who in skip-k #:special-ok? #f)) + +(define/who (peek-string amt skip-k [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-string amt)) + (define v (do-peek-string! who in bstr 0 amt skip-k)) + (if (exact-integer? v) + (if (= v amt) + bstr + (substring bstr 0 v)) + v))) + +(define/who (peek-string! str skip-k [in (current-input-port)] [start-pos 0] [end-pos (and (string? str) + (string-length str))]) + (check who string? str) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (string-length str) str) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-peek-string! who str in start-pos end-pos skip-k))) diff -Nru racket-6.12+ppa1/src/io/port/string-output.rkt racket-7.0+ppa1/src/io/port/string-output.rkt --- racket-6.12+ppa1/src/io/port/string-output.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/string-output.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(require "../common/check.rkt" + "parameter.rkt" + "output-port.rkt" + "../string/convert.rkt" + (submod "bytes-output.rkt" internal)) + +(provide write-char + write-string) + +(define/who (write-char ch [out (current-output-port)]) + (check who char? ch) + (check who output-port? out) + (write-string (string ch) out 0 1)) + +(define/who (write-string str [out (current-output-port)] [start 0] [end (and (string? str) + (string-length str))]) + (check who string? str) + (check who output-port? out) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (let ([out (->core-output-port out)]) + (let loop ([i start]) + (cond + [(= i end) (- i start)] + [else + (define next-i (min end (+ i 4096))) + (define bstr (string->bytes/utf-8 str 0 i next-i)) + (do-write-bytes who out bstr 0 (bytes-length bstr)) + (loop next-i)])))) diff -Nru racket-6.12+ppa1/src/io/port/string-port.rkt racket-7.0+ppa1/src/io/port/string-port.rkt --- racket-6.12+ppa1/src/io/port/string-port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/string-port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +#lang racket/base +(require "../common/check.rkt" + "output-port.rkt" + "bytes-port.rkt" + "../string/convert.rkt") + +(provide open-input-string + open-output-string + get-output-string) + +(define/who (open-input-string str [name 'string]) + (check who string? str) + (open-input-bytes (string->bytes/utf-8 str) name)) + +(define (open-output-string [name 'string]) + (open-output-bytes name)) + +(define/who (get-output-string o) + (check who (lambda (v) (and (output-port? o) (string-port? o))) + #:contract "(and/c output-port? string-port?)" + o) + (bytes->string/utf-8 (get-output-bytes o) #\?)) diff -Nru racket-6.12+ppa1/src/io/port/write.rkt racket-7.0+ppa1/src/io/port/write.rkt --- racket-6.12+ppa1/src/io/port/write.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/port/write.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "../host/thread.rkt" + "port.rkt" + "output-port.rkt" + "count.rkt" + "check.rkt") + +(provide write-some-bytes) + +(define (write-some-bytes who out bstr start end + #:copy-bstr? [copy-bstr? #t] + #:buffer-ok? [buffer-ok? #f] + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (let try-again ([out out] [extra-count-outs null]) + (start-atomic) + (check-not-closed who out) + (cond + [(= start end) + (end-atomic) + 0] + [else + (define write-out (core-output-port-write-out out)) + (cond + [(procedure? write-out) + (define v (write-out bstr start end (not buffer-ok?) enable-break? copy-bstr?)) + (let result-loop ([v v]) + (cond + [(not v) + (end-atomic) + (if zero-ok? + 0 + (try-again out extra-count-outs))] + [(evt? v) + (end-atomic) + (cond + [zero-ok? 0] + [else + (define new-v (if enable-break? + (sync/enable-break v) + (sync v))) + (start-atomic) + (result-loop new-v)])] + [(exact-positive-integer? v) + (port-count-all! out extra-count-outs v bstr start) + (end-atomic) + v] + [else + (end-atomic) + (internal-error (format "write-some-bytes: weird result ~s for ~s ~s ~s at ~s" v bstr start end out))]))] + [else + (end-atomic) + (try-again (->core-output-port write-out) (cons out extra-count-outs))])]))) diff -Nru racket-6.12+ppa1/src/io/print/bytes.rkt racket-7.0+ppa1/src/io/print/bytes.rkt --- racket-6.12+ppa1/src/io/print/bytes.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/bytes.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,81 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-bytes) + +(define (print-bytes bstr o max-length) + (let ([max-length (write-bytes/max #"#\"" o max-length)]) + (define len (bytes-length bstr)) + (let loop ([start-i 0] [i 0] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(or (= i len) + (and max-length ((- i start-i) . > . max-length))) + (let ([max-length (write-bytes/max bstr o max-length start-i i)]) + (write-bytes/max #"\"" o max-length))] + [else + (define b (bytes-ref bstr i)) + (cond + [(and (b . < . 128) + (let ([c (integer->char b)]) + (and (or (char-blank? c) + (char-graphic? c)) + (not (char=? c #\tab)) + (not (char=? c #\")) + (not (char=? c #\\))))) + (loop start-i (add1 i) max-length)] + [else + (let* ([max-length (write-bytes/max bstr o max-length start-i i)]) + (define escaped + (case (and (b . < . 128) (integer->char b)) + [(#\") #"\\\""] + [(#\\) #"\\\\"] + [(#\u7) #"\\a"] + [(#\backspace) #"\\b"] + [(#\u1B) #"\\e"] + [(#\page) #"\\f"] + [(#\newline) #"\\n"] + [(#\return) #"\\r"] + [(#\tab) #"\\t"] + [(#\vtab) #"\\v"] + [else #f])) + (cond + [escaped + (let ([max-length (write-bytes/max escaped o max-length)] + [i (add1 i)]) + (loop i i max-length))] + [else + (let ([i (add1 i)]) + (define next-b (or (and (i . < . len) + (bytes-ref bstr i)) + 0)) + (cond + [(or (b . >= . 64) + (and (>= next-b (char->integer #\0)) + (<= next-b (char->integer #\7)))) + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit (arithmetic-shift b -6)) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 (arithmetic-shift b -3))) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 b)) o max-length)]) + (loop i i max-length))] + [(b . >= . 8) + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 (arithmetic-shift b -3))) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 b)) o max-length)]) + (loop i i max-length))] + [else + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit b) o max-length)]) + (loop i i max-length))]))]))])])))) + +(define (digit v) + (case v + [(0) #"0"] + [(1) #"1"] + [(2) #"2"] + [(3) #"3"] + [(4) #"4"] + [(5) #"5"] + [(6) #"6"] + [(7) #"7"])) diff -Nru racket-6.12+ppa1/src/io/print/char.rkt racket-7.0+ppa1/src/io/print/char.rkt --- racket-6.12+ppa1/src/io/print/char.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/char.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../port/bytes-output.rkt" + "write-with-max.rkt") + +(provide print-char) + +(define (print-char c o max-length) + (define esc-str + (case c + [(#\nul) "#\\nul"] + [(#\backspace) "#\\backspace"] + [(#\tab) "#\\tab"] + [(#\page) "#\\page"] + [(#\newline) "#\\newline"] + [(#\return) "#\\return"] + [(#\vtab) "#\\vtab"] + [(#\space) "#\\space"] + [(#\rubout) "#\\rubout"] + [else #f])) + (cond + [esc-str + (write-string/max esc-str o max-length)] + [(char-graphic? c) + (let ([max-length (write-string/max "#\\" o max-length)]) + (write-string/max (string c) o max-length))] + [else + (define n (char->integer c)) + (define (pad n s) + (define len (string-length s)) + (if (len . < . n) + (string-append (make-string (- n len) #\0) s) + s)) + (cond + [(n . <= . #xFFFF) + (let ([max-length (write-string/max "#\\u" o max-length)]) + (write-string/max (pad 4 (number->string n 16)) o max-length))] + [else + (let ([max-length (write-string/max "#\\U" o max-length)]) + (write-string/max (pad 8 (number->string n 16)) o max-length))])])) diff -Nru racket-6.12+ppa1/src/io/print/config.rkt racket-7.0+ppa1/src/io/print/config.rkt --- racket-6.12+ppa1/src/io/print/config.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/config.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,15 @@ +#lang racket/base + +(provide make-print-config + config-get) + +;; Make a container for looking up parameters on-demand: +(define (make-print-config) + (make-hasheq)) + +(define (config-get config param) + (hash-ref config param (lambda () + (define v (param)) + (hash-set! config param v) + v))) + diff -Nru racket-6.12+ppa1/src/io/print/custom-write.rkt racket-7.0+ppa1/src/io/print/custom-write.rkt --- racket-6.12+ppa1/src/io/print/custom-write.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/custom-write.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,30 @@ +#lang racket/base + +(provide prop:custom-write + custom-write? + custom-write-accessor + + prop:custom-print-quotable + custom-print-quotable? + custom-print-quotable-accessor) + +(define-values (prop:custom-write custom-write? custom-write-accessor) + (make-struct-type-property 'custom-write + (lambda (v info) + (unless (and (procedure? v) + (procedure-arity-includes? v 3)) + (raise-argument-error + 'guard-for-prop:custom-write + "(procedure-arity-includes?/c 3)" + v)) + v))) + +(define-values (prop:custom-print-quotable custom-print-quotable? custom-print-quotable-accessor) + (make-struct-type-property 'custom-print-quotable + (lambda (v info) + (unless (or (eq? v 'self) (eq? v 'never) (eq? v 'maybe) (eq? v 'always)) + (raise-argument-error + 'guard-for-prop:custom-print-quotable + "(or/c 'self 'never 'maybe 'always)" + v)) + v))) diff -Nru racket-6.12+ppa1/src/io/print/graph.rkt racket-7.0+ppa1/src/io/print/graph.rkt --- racket-6.12+ppa1/src/io/print/graph.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/graph.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,211 @@ +#lang racket/base +(require "../port/nowhere.rkt" + "../port/output-port.rkt" + "parameter.rkt" + "custom-write.rkt" + "mode.rkt" + "config.rkt" + "recur-handler.rkt") + +(provide detect-graph + (struct-out as-constructor)) + +(define (detect-graph v mode config) + (define print-graph? (print-graph)) + (cond + [(quick-no-graph? v 100 mode print-graph? config) #f] + [else + (define ht (make-hasheq)) + (build-graph v ht print-graph? mode config)])) + +;; ---------------------------------------- + +;; Returns a true value if `v` can print without graph annotations and +;; without a constructor form (as opposed to quoted form) in `print` +;; mode +(define (quick-no-graph? v fuel mode print-graph? config) + (let quick-no-graph? ([v v] [fuel fuel]) + (cond + [(or (not fuel) (zero? fuel)) #f] + [(pair? v) + (and (not print-graph?) + (quick-no-graph? (cdr v) (quick-no-graph? (car v) (sub1 fuel))))] + [(vector? v) + (and (not print-graph?) + (for/fold ([fuel (sub1 fuel)]) ([e (in-vector v)] + #:break (not fuel)) + (quick-no-graph? e fuel)))] + [(and (box? v) + (config-get config print-box)) + (and (not print-graph?) + (quick-no-graph? (unbox v) (sub1 fuel)))] + [(and (hash? v) + (not (hash-weak? v)) + (config-get config print-hash-table)) + (and (not print-graph?) + (for/fold ([fuel (sub1 fuel)]) ([(k v) (in-hash v)] + #:break (not fuel)) + (quick-no-graph? v (quick-no-graph? k fuel))))] + [(mpair? v) + (and (not print-graph?) + (not (eq? mode PRINT-MODE/UNQUOTED)) + (quick-no-graph? (mcdr v) (quick-no-graph? (mcar v) (sub1 fuel))))] + [(custom-write? v) + #f] + [(and (struct? v) + (config-get config print-struct)) + (and (not print-graph?) + (or (not (eq? mode PRINT-MODE/UNQUOTED)) + (prefab-struct-key v)) ; can quote a prefab in `print` mode + (quick-no-graph? (struct->vector v) (sub1 fuel)))] + [else fuel]))) + +;; ---------------------------------------- + +(struct as-constructor (tag)) ; `tag` is #f or a number for graph printing + +;; Create a hash table that maps some values to a number, +;; which indicates that that the value should be printed with +;; a `#=` prefix and referenced with `##` thereafter. +;; The hash table records the to be used as a number, +;; and the printer mutates the table to turn that into `#=` +;; after the first reference. +;; +;; In addition, the table indicates whether an item needs +;; to be printed in constructor form, as opposed to quoted +;; form. Printing in constructor form is indicated by +;; mapping to a wrapped `as-constructor` wapper on an integer +;; or `#f`. +;; +;; During `build-graph`, the table maps a value to one of +;; - 'checking: currently checking, so finding again +;; implies a cycle +;; - 'checked: finished checking, but might be referenced +;; again, which is relevant if graph printing is one of +;; we go into graph-printing mode +;; - number: graph-rereference detected, and assigned +;; the number via `counter` +;; - (as-constructor #f): like 'checked, but should be printed in +;; constructor mode, as opposed to quoted +;; - (as-constructor number): graph-rereference detected, and +;; initial reference print in construcor mode +;; If no cycle is detected and `(print-graph)` is false, then +;; values other than `as-constructor` are removed. All +;; 'checked entries will be cleared out before the hash table +;; is returned. +(define (build-graph v ht print-graph? mode config) + (define counter 0) + (define cycle? #f) + (define constructor? #f) + (define checking-port #f) + (define (checking! v) + (hash-set! ht v 'checking)) + (define (done! v unquoted?) + (when (eq? 'checking (hash-ref ht v #f)) + (hash-set! ht v 'checked)) + (when unquoted? + (define c (hash-ref ht v #f)) + (hash-set! ht v (as-constructor (and (integer? c) c))) + (set! constructor? #t)) + unquoted?) + ;; Returns #t if `v` needs to be unquoted + (let build-graph ([v v] [mode mode]) + (cond + [(not v) #f] + [(hash-ref ht v #f) + => (lambda (g) + (when (or (eq? g 'checking) + (eq? g 'checked) + (and (as-constructor? g) + (not (as-constructor-tag g)))) + (hash-set! ht v (if (as-constructor? g) + (as-constructor counter) + counter)) + (set! counter (add1 counter)) + (when (eq? g 'checking) + (set! cycle? #t))) + #f)] + [(pair? v) + (checking! v) + (define car-unquoted? (build-graph (car v) mode)) + (define unquoted? + (or (build-graph (cdr v) mode) + car-unquoted?)) + (done! v unquoted?)] + [(vector? v) + (checking! v) + (define unquoted? + (for/fold ([unquoted? #f]) ([e (in-vector v)]) + (or (build-graph e mode) + unquoted?))) + (done! v unquoted?)] + [(and (box? v) + (config-get config print-box)) + (checking! v) + (define unquoted? (build-graph (unbox v) mode)) + (done! v unquoted?)] + [(and (hash? v) + (not (hash-weak? v)) + (config-get config print-hash-table)) + (checking! v) + (define unquoted? + (for/fold ([unquoted? #f]) ([(k v) (in-hash v)]) + (define k-unquoted? (build-graph k mode)) + (or (build-graph v mode) + k-unquoted? + unquoted?))) + (done! v unquoted?)] + [(mpair? v) + (checking! v) + (build-graph (mcar v) mode) + (build-graph (mcdr v) mode) + (done! v (eq? mode PRINT-MODE/UNQUOTED))] + [(custom-write? v) + (define print-quotable (if (eq? mode PRINT-MODE/UNQUOTED) + (custom-print-quotable-accessor v 'self) + 'self)) + (define unquoted? (eq? print-quotable 'never)) + (unless checking-port + (set! checking-port (open-output-nowhere)) + (set-port-handlers-to-recur! + checking-port + (lambda (e p mode) + (cond + [(or (eq? mode PRINT-MODE/QUOTED) + (eq? mode PRINT-MODE/UNQUOTED)) + (define e-unquoted? (build-graph e mode)) + (unless (eq? print-quotable 'always) + (set! unquoted? (or e-unquoted? unquoted?)))] + [else (build-graph e mode)])))) + (checking! v) + ((custom-write-accessor v) v checking-port mode) + (done! v unquoted?)] + [(struct? v) + (checking! v) + (define unquoted? + (or (for/fold ([unquoted? #f]) ([e (in-vector (struct->vector v))]) + (or (build-graph e mode) + unquoted?)) + (and (eq? mode PRINT-MODE/UNQUOTED) + (not (prefab-struct-key v))))) + (done! v unquoted?)] + [else #f])) + ;; Clean out unwanted entries + (cond + [(and (not cycle?) (not constructor?) (not print-graph?)) + ;; No table needed after all + #f] + [(and (not cycle?) (not print-graph?)) + (for ([k (in-list (hash-keys ht))]) + (define v (hash-ref ht k)) + (cond + [(not (as-constructor? v)) + (hash-remove! ht k)] + [(as-constructor-tag v) + (hash-set! ht k (as-constructor #f))])) + ht] + [else + (for ([k (in-list (hash-keys ht))]) + (when (eq? 'checked (hash-ref ht k)) + (hash-remove! ht k))) + ht])) diff -Nru racket-6.12+ppa1/src/io/print/hash.rkt racket-7.0+ppa1/src/io/print/hash.rkt --- racket-6.12+ppa1/src/io/print/hash.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/hash.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,57 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-hash) + +(define (print-hash v o max-length p who mode graph config) + (define tag (cond + [(hash-eq? v) "#hasheq("] + [(hash-eqv? v) "#hasheqv("] + [else "#hash("])) + (define keys (try-sort (hash-keys v))) + (let loop ([keys keys] [max-length (write-string/max tag o max-length)] [first? #t]) + (cond + [(eq? max-length 'full) 'full] + [(null? keys) + (write-string/max ")" o max-length)] + [else + (define key (car keys)) + (define val (hash-ref v key none)) + (cond + [(eq? val none) + ;; hash table changed, or maybe an impersonator does strange things to the table + (loop (cdr keys) max-length first?)] + [else + (let* ([max-length (write-string/max (if first? "(" " (") o max-length)] + [max-length (p who key mode o max-length graph config)] + [max-length (write-string/max " . " o max-length)] + [max-length (p who val mode o max-length graph config)]) + (loop (cdr keys) (write-string/max ")" o max-length) #f))])]))) + +(define none (gensym 'none)) + +(define (try-sort keys) + (cond + [(null? keys) null] + [(real? (car keys)) + (if (andmap real? (cdr keys)) + (sort keys <) + keys)] + [(symbol? (car keys)) + (if (andmap symbol? (cdr keys)) + (sort keys symbolcore-output-port o)]) + (define display-handler (core-output-port-display-handler co)) + (if display-handler + (display-handler v o) + (do-display who v co)) + (void))) + +(define (do-display who v o [max-length #f]) + (define config (make-print-config)) + (dots (p who v DISPLAY-MODE o (sub3 max-length) (detect-graph v DISPLAY-MODE config) config) o) + (void)) + +(define/who (write v [o (current-output-port)]) + (check who output-port? o) + (let ([co (->core-output-port o)]) + (define write-handler (core-output-port-write-handler co)) + (if write-handler + (write-handler v o) + (do-write who v co)) + (void))) + +(define (do-write who v o [max-length #f]) + (define config (make-print-config)) + (dots (p who v WRITE-MODE o (sub3 max-length) (detect-graph v WRITE-MODE config) config) o) + (void)) + +(define/who (print v [o (current-output-port)] [quote-depth PRINT-MODE/UNQUOTED]) + (check who output-port? o) + (check who print-mode? #:contract "(or/c 0 1)" quote-depth) + (let ([co (->core-output-port o)]) + (define print-handler (core-output-port-print-handler co)) + (if print-handler + (print-handler v o quote-depth) + (do-global-print who v co quote-depth)) + (void))) + +(define (do-print who v o [quote-depth PRINT-MODE/UNQUOTED] [max-length #f]) + (define config (make-print-config)) + (dots (p who v quote-depth o (sub3 max-length) (detect-graph v quote-depth config) config) o) + (void)) + +(define do-global-print void) + +(define (install-do-global-print! param default-value) + (set! do-global-print + (lambda (who v o [quote-depth PRINT-MODE/UNQUOTED] [max-length #f]) + (define global-print (param)) + (cond + [(eq? global-print default-value) + (do-print who v o quote-depth max-length)] + [(not max-length) + (global-print v o quote-depth)] + [else + ;; There's currently no way to communicate `max-length` + ;; to the `global-print` function, but we should only get + ;; here when `o` is a string port for errors, so write to + ;; a fresh string port and truncate as needed. + (define o2 (open-output-bytes)) + (global-print v o2 quote-depth) + (define bstr (get-output-bytes o2)) + (if ((bytes-length bstr) . <= . max-length) + (write-bytes bstr o) + (begin + (write-bytes (subbytes bstr 0 (sub3 max-length)) o) + (write-bytes #"..." o)))]) + (void)))) + +(define/who (newline [o (current-output-port)]) + (check who output-port? o) + (write-bytes #"\n" o) + (void)) + +;; ---------------------------------------- + +(define (max-length? v) + (or (not v) + (and (exact-nonnegative-integer? v) + (v . >= . 3)))) + +(define max-length-contract "(or/c #f (and/c exact-integer? (>=/c 3)))") + +(define (sub3 n) (and n (- n 3))) + +(define (dots max-length o) + (when (eq? max-length 'full) + (write-string "..." o))) + +;; ---------------------------------------- + +;; Returns the max length that is still available +(define (p who v mode o max-length graph config) + (cond + [(and graph (hash-ref graph v #f)) + => (lambda (g) + (cond + [(and (as-constructor? g) + (not (as-constructor-tag g))) + (p/no-graph-no-quote who v mode o max-length graph config)] + [(string? g) + (let* ([max-length (write-string/max "#" o max-length)] + [max-length (write-string/max g o max-length)]) + (write-string/max "#" o max-length))] + [else + (let* ([gs (number->string (if (as-constructor? g) + (as-constructor-tag g) + g))] + [max-length (write-string/max "#" o max-length)] + [max-length (write-string/max gs o max-length)] + [max-length (write-string/max "=" o max-length)]) + (hash-set! graph v gs) + (p/no-graph who v mode o max-length graph config))]))] + [else + (p/no-graph who v mode o max-length graph config)])) + +(define (p/no-graph who v mode o max-length graph config) + (cond + [(and (eq? mode PRINT-MODE/UNQUOTED) + (or (null? v) + (symbol? v) + (keyword? v) + (pair? v) + (vector? v) + (box? v) + (hash? v) + (prefab-struct-key v))) + ;; Since this value is not marked for constructor mode, + ;; transition to quote mode: + (let ([max-length (write-string/max "'" o max-length)]) + (p/no-graph-no-quote who v PRINT-MODE/QUOTED o max-length graph config))] + [else + (p/no-graph-no-quote who v mode o max-length graph config)])) + +(define (p/no-graph-no-quote who v mode o max-length graph config) + (cond + [(eq? max-length 'full) 'full] + [(null? v) + (write-string/max "()" o max-length)] + [(number? v) + (write-string/max (number->string v) o max-length)] + [(string? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max v o max-length)] + [else (print-string v o max-length)])] + [(bytes? v) + (cond + [(eq? mode DISPLAY-MODE) (write-bytes/max v o max-length)] + [else (print-bytes v o max-length)])] + [(symbol? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (symbol->string v) o max-length)] + [else (print-symbol v o max-length config)])] + [(keyword? v) + (let ([max-length (write-string/max "#:" o max-length)]) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (keyword->string v) o max-length)] + [else + (print-symbol (string->symbol (keyword->string v)) o max-length config + #:for-keyword? #t)]))] + [(char? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (string v) o max-length)] + [else (print-char v o max-length)])] + [(not v) + (write-string/max "#f" o max-length)] + [(eq? v #t) + (write-string/max "#t" o max-length)] + [(pair? v) + (print-list p who v mode o max-length graph config #f #f)] + [(vector? v) + (print-list p who (vector->list v) mode o max-length graph config "#(" "(vector")] + [(flvector? v) + (define l (for/list ([e (in-flvector v)]) e)) + (print-list p who l mode o max-length graph config "#fl(" "(flvector")] + [(fxvector? v) + (define l (for/list ([e (in-fxvector v)]) e)) + (print-list p who l mode o max-length graph config "#fx(" "(fxvector")] + [(box? v) + (if (config-get config print-box) + (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config) + (write-string/max "#" o max-length))] + [(hash? v) + (if (and (config-get config print-hash-table) + (not (hash-weak? v))) + (print-hash v o max-length p who mode graph config) + (write-string/max "#" o max-length))] + [(mpair? v) + (print-mlist p who v mode o max-length graph config)] + [(custom-write? v) + (let ([o (make-output-port/max o max-length)]) + (set-port-handlers-to-recur! + o + (lambda (v o mode) + (p who v mode o (output-port/max-max-length o max-length) graph config))) + ((custom-write-accessor v) v o mode) + (output-port/max-max-length o max-length))] + [(struct? v) + (cond + [(eq? mode PRINT-MODE/UNQUOTED) + (define l (vector->list (struct->vector v))) + (define alt-list-constructor + ;; strip "struct:" from the first element of `l`: + (string-append "(" (substring (symbol->string (car l)) 7))) + (print-list p who (cdr l) mode o max-length graph config #f alt-list-constructor)] + [(prefab-struct-key v) + => (lambda (key) + (define l (cons key (cdr (vector->list (struct->vector v))))) + (print-list p who l mode o max-length graph config "#s(" #f))] + [else + (p who (struct->vector v) mode o max-length graph config)])] + [(procedure? v) + (print-named "procedure" v mode o max-length)] + [(struct-type? v) + (print-named "struct-type" v mode o max-length)] + [(struct-type-property? v) + (print-named "struct-type-property" v mode o max-length)] + [(eof-object? v) + (write-string/max "#" o max-length)] + [(core-input-port? v) + (print-named "input-port" v mode o max-length)] + [(core-output-port? v) + (print-named "output-port" v mode o max-length)] + [else + ;; As a last resort, fall back to the host `format`: + (write-string/max (format "~s" v) o max-length)])) diff -Nru racket-6.12+ppa1/src/io/print/mlist.rkt racket-7.0+ppa1/src/io/print/mlist.rkt --- racket-6.12+ppa1/src/io/print/mlist.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/mlist.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(require "write-with-max.rkt" + "mode.rkt") + +(provide print-mlist) + +(define (print-mlist p who v mode o max-length graph config) + (define unquoted? (eq? mode PRINT-MODE/UNQUOTED)) + (let ([max-length + (cond + [unquoted? (write-string/max "(mcons " o max-length)] + [else (write-string/max "{" o max-length)])]) + (let loop ([v v] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(and (null? (mcdr v)) + (not unquoted?)) + (let ([max-length (p who (mcar v) mode o max-length graph config)]) + (write-string/max "}" o max-length))] + [(and (mpair? (mcdr v)) + (or (not graph) (not (hash-ref graph (mcdr v) #f))) + (not unquoted?)) + (let ([max-length (p who (mcar v) mode o max-length graph config)]) + (loop (mcdr v) (write-string/max " " o max-length)))] + [else + (let* ([max-length (p who (mcar v) mode o max-length graph config)] + [max-length (if unquoted? + (write-string/max " " o max-length) + (write-string/max " . " o max-length))] + [max-length (p who (mcdr v) mode o max-length graph config)]) + (write-string/max (if unquoted? ")" "}") o max-length))])))) diff -Nru racket-6.12+ppa1/src/io/print/mode.rkt racket-7.0+ppa1/src/io/print/mode.rkt --- racket-6.12+ppa1/src/io/print/mode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/mode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,18 @@ +#lang racket/base + +(provide DISPLAY-MODE + WRITE-MODE + PRINT-MODE/UNQUOTED + PRINT-MODE/QUOTED + + print-mode?) + +;; These are fixed by the `prop:custom-write` and `print` APIs: +(define DISPLAY-MODE #f) +(define WRITE-MODE #t) +(define PRINT-MODE/UNQUOTED 0) +(define PRINT-MODE/QUOTED 1) + +(define (print-mode? mode) + (or (eq? mode PRINT-MODE/UNQUOTED) + (eq? mode PRINT-MODE/QUOTED))) diff -Nru racket-6.12+ppa1/src/io/print/named.rkt racket-7.0+ppa1/src/io/print/named.rkt --- racket-6.12+ppa1/src/io/print/named.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/named.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,27 @@ +#lang racket/base +(require "../port/string-output.rkt" + (only-in "../path/path.rkt" path?) + (only-in "../path/string.rkt" path->string) + "write-with-max.rkt" + "symbol.rkt") + +(provide print-named) + +(define (print-named what v mode o max-length) + (define name (object-name v)) + (let* ([max-length (write-string/max "#<" o max-length)] + [max-length (write-string/max what o max-length)] + [name-str + (cond + [(symbol? name) + (symbol->print-string name #:for-type? #t)] + [(path? name) ; especially for input & output ports + (path->string name)] + [else #f])]) + (cond + [name-str + (let* ([max-length (write-string/max ":" o max-length)] + [max-length (write-string/max name-str o max-length)]) + (write-string/max ">" o max-length))] + [else + (write-string/max ">" o max-length)]))) diff -Nru racket-6.12+ppa1/src/io/print/parameter.rkt racket-7.0+ppa1/src/io/print/parameter.rkt --- racket-6.12+ppa1/src/io/print/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,61 @@ +#lang racket/base +(require "../common/check.rkt" + "../path/path.rkt" + "../path/relativity.rkt") + +(provide current-write-relative-directory + print-syntax-width) + +(define-syntax-rule (define-boolean-parameter print-x init-val) + (begin + (provide print-x) + (define print-x (make-parameter init-val (lambda (v) (and v #t)))))) + +(define-boolean-parameter print-graph #f) +(define-boolean-parameter print-struct #t) +(define-boolean-parameter print-box #t) +(define-boolean-parameter print-unreadable #t) +(define-boolean-parameter print-hash-table #t) +(define-boolean-parameter print-as-expression #f) +(define-boolean-parameter print-vector-length #f) +(define-boolean-parameter print-pair-curly-braces #f) +(define-boolean-parameter print-mpair-curly-braces #t) +(define-boolean-parameter print-boolean-long-form #f) +(define-boolean-parameter print-reader-abbreviations #t) + +(define-boolean-parameter read-accept-bar-quote #t) +(define-boolean-parameter read-case-sensitive #t) + +(define/who current-write-relative-directory + (make-parameter #f (lambda (v) + (check who (lambda (v) + (or (not v) + (and (path-string? v) + (complete-path? v)) + (and (pair? v) + (path-string? (car v)) + (complete-path? (car v)) + (path-string? (cdr v)) + (complete-path? (cdr v))))) + #:contract (string-append + "(or/c (and/c path-string? complete-path?)\n" + " (cons/c (and/c path-string? complete-path?)\n" + " (and/c path-string? complete-path?))" + " #f)") + v) + (cond + [(string? v) (->path v)] + [(pair? v) (cons (->path (car v)) (->path (cdr v)))] + [else v])))) + +(define print-syntax-width + (make-parameter 32 (lambda (v) + (unless (or (eqv? v +inf.0) + (and (exact-integer? v) + (v . >= . 3))) + (raise-argument-error 'print-syntax-width + "(or/c +inf.0 0 (and/c exact-integer? (>/c 3)))" + v)) + v))) + + diff -Nru racket-6.12+ppa1/src/io/print/recur-handler.rkt racket-7.0+ppa1/src/io/print/recur-handler.rkt --- racket-6.12+ppa1/src/io/print/recur-handler.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/recur-handler.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +#lang racket/base +(require "../port/output-port.rkt" + "mode.rkt") + +(provide set-port-handlers-to-recur!) + +(define (set-port-handlers-to-recur! port handle) + (set-core-output-port-print-handler! port + (lambda (e p [mode 0]) + (handle e p mode))) + (set-core-output-port-write-handler! port + (lambda (e p) + (handle e p WRITE-MODE))) + (set-core-output-port-display-handler! port + (lambda (e p) + (handle e p DISPLAY-MODE)))) diff -Nru racket-6.12+ppa1/src/io/print/string.rkt racket-7.0+ppa1/src/io/print/string.rkt --- racket-6.12+ppa1/src/io/print/string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,58 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-string) + +(define (print-string str o max-length) + (let ([max-length (write-bytes/max #"\"" o max-length)]) + (define len (string-length str)) + (let loop ([start-i 0] [i 0] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(or (= i len) + (and max-length ((- i start-i) . > . max-length))) + (let ([max-length (write-string/max str o max-length start-i i)]) + (write-bytes/max #"\"" o max-length))] + [else + (define c (string-ref str i)) + (define escaped + (case c + [(#\") #"\\\""] + [(#\\) #"\\\\"] + [(#\u7) #"\\a"] + [(#\backspace) #"\\b"] + [(#\u1B) #"\\e"] + [(#\page) #"\\f"] + [(#\newline) #"\\n"] + [(#\return) #"\\r"] + [(#\tab) #"\\t"] + [(#\vtab) #"\\v"] + [else #f])) + (cond + [escaped + (let* ([max-length (write-string/max str o max-length start-i i)] + [max-length (write-bytes/max escaped o max-length)] + [i (add1 i)]) + (loop i i max-length))] + [(or (char-graphic? c) + (char-blank? c)) + (loop start-i (add1 i) max-length)] + [else + (define n (char->integer c)) + (define (pad n s) + (define len (string-length s)) + (if (len . < . n) + (string-append (make-string (- n len) #\0) s) + s)) + (let* ([max-length (write-string/max str o max-length start-i i)] + [max-length + (cond + [(n . <= . #xFFFF) + (let ([max-length (write-bytes/max #"\\u" o max-length)]) + (write-string/max (pad 4 (number->string n 16)) o max-length))] + [else + (let ([max-length (write-bytes/max #"\\U" o max-length)]) + (write-string/max (pad 8 (number->string n 16)) o max-length))])] + [i (add1 i)]) + (loop i i max-length))])])))) diff -Nru racket-6.12+ppa1/src/io/print/symbol.rkt racket-7.0+ppa1/src/io/print/symbol.rkt --- racket-6.12+ppa1/src/io/print/symbol.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/symbol.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,85 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../string/number.rkt" + "write-with-max.rkt" + "parameter.rkt" + "config.rkt") + +(provide print-symbol + symbol->print-string) + +(define (print-symbol sym o max-length config + #:for-keyword? [for-keyword? #f]) + (define str (symbol->print-string sym #:config config #:for-keyword? for-keyword?)) + (write-string/max str o max-length)) + +(define (symbol->print-string sym + #:config [config #f] + #:for-type? [for-type? #f] + #:case-sensitive? [case-sensitive? (if config + (config-get config read-case-sensitive) + #t)] + #:for-keyword? [for-keyword? #f]) + (define str (symbol->string sym)) + (define (is-simple? ch i) + (not (or (char=? ch #\() + (char=? ch #\[) + (char=? ch #\{) + (char=? ch #\)) + (char=? ch #\]) + (char=? ch #\}) + (char=? ch #\") + (char=? ch #\\) + (char=? ch #\') + (char=? ch #\,) + (and (char=? ch #\|) + (or (not config) (config-get config read-accept-bar-quote))) + (and for-type? + (or (char=? ch #\<) + (char=? ch #\>))) + (and (char-whitespace? ch) + (or (not for-type?) + (not (char=? ch #\space)))) + (and (char=? ch #\#) + (zero? i) + (or ((string-length str) . < . 2) + (not (char=? (string-ref str 1) #\%)))) + (and (char=? ch #\.) + (zero? i) + (= (string-length str) 1)) + (and (not case-sensitive?) + (not (char=? ch (char-foldcase ch))))))) + (cond + [(for/and ([ch (in-string str)] + [i (in-naturals)]) + (is-simple? ch i)) + (cond + [(or for-keyword? + for-type? + (not (string->number? str))) + str] + ;; Remaining two cases add some form of quoting to + ;; protect against a symbol looking like a number + [(and config (not (config-get config read-accept-bar-quote))) + (string-append "\\" str)] + [else + (string-append "|" str "|")])] + [(or (and config (not (config-get config read-accept-bar-quote))) + (for/or ([ch (in-string str)]) + (char=? ch #\|))) + ;; Need to use backslashes for quoting + (define len (string-length str)) + (apply + string-append + (let loop ([start 0] [i 0]) + (cond + [(= i len) (list (substring str start len))] + [(is-simple? (string-ref str i) i) (loop start (add1 i))] + [else + (list* (substring str start i) + "\\" + (substring str i (add1 i)) + (loop (add1 i) (add1 i)))])))] + [else + ;; Can use bars for quoting: + (string-append "|" str "|")])) diff -Nru racket-6.12+ppa1/src/io/print/write-with-max.rkt racket-7.0+ppa1/src/io/print/write-with-max.rkt --- racket-6.12+ppa1/src/io/print/write-with-max.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/print/write-with-max.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,69 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../port/bytes-output.rkt" + "../port/port.rkt" + "../port/output-port.rkt") + +(provide write-string/max + write-bytes/max + + make-output-port/max + output-port/max-max-length) + +(define (write-string/max str o max-length [start 0] [end (string-length str)]) + (cond + [(eq? max-length 'full) 'full] + [(not max-length) + (write-string str o start end) + #f] + [else + (define len (- end start)) + (cond + [(len . < . max-length) + (write-string str o start end) + (- max-length len)] + [else + (write-string str o start (+ start max-length)) + 'full])])) + +;; For measuring purposes, just treat bytes as characters: +(define (write-bytes/max bstr o max-length [start 0] [end (bytes-length bstr)]) + (cond + [(eq? max-length 'full) 'full] + [(not max-length) + (write-bytes bstr o start end) + #f] + [else + (define len (- end start)) + (cond + [(len . < . max-length) + (write-bytes bstr o start end) + (- max-length len)] + [else + (write-bytes bstr o start (+ start max-length)) + 'full])])) + +(define (make-output-port/max o max-length) + (make-core-output-port + #:name (object-name o) + #:data (lambda () max-length) + #:evt o + #:write-out + (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (cond + [max-length + (define len (- src-end src-start)) + (unless (eq? max-length 'full) + (define write-len (min len max-length)) + (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len))) + (if (= max-length wrote-len) + (set! max-length 'full) + (set! max-length (- max-length wrote-len)))) + len] + [else + (write-bytes src-bstr o src-start src-end)])) + #:close void)) + +(define (output-port/max-max-length o max-length) + (and max-length + ((core-port-data o)))) diff -Nru racket-6.12+ppa1/src/io/README.txt racket-7.0+ppa1/src/io/README.txt --- racket-6.12+ppa1/src/io/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +This directory implements the port, path, encoding, printing, and +formatting layer. It can be run in a host Racket with `make demo`, +which is useful for development and debugging, but it's meant to be +compiled for use in Racket on Chez Scheme; see "../cs/README.txt". + +Core error support must be provided as a more primitive layer, +including the exception structures and error functions that do not +involve formatting, such as `raise-argument-error`. The more primitive +layer should provide a `error-value->string-handler` paramemeter, but +this layer sets that parameter (so the primitive error function slike +`raise-argument-error` won't work right until this layer is loaded). + +Thread and event support is similarly provided as a more primitive +layer. Running `make demo` doesn't rely on that, while running `make +demo-thread` uses the thread implementation in "../thread" to +demonstrate cooperation between the layers. diff -Nru racket-6.12+ppa1/src/io/run/main.rkt racket-7.0+ppa1/src/io/run/main.rkt --- racket-6.12+ppa1/src/io/run/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/run/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,71 @@ +#lang racket/base +(require "../common/check.rkt" + "../print/main.rkt" + "../error/main.rkt" + "../port/parameter.rkt" + "../port/handler.rkt") + +(provide executable-yield-handler + current-command-line-arguments + current-print + current-read-interaction + current-prompt-read + current-get-interaction-input-port + cache-configuration) + +(define/who executable-yield-handler + (make-parameter void (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-command-line-arguments + (make-parameter '#() (lambda (v) + (define l (and (vector? v) + (vector->list v))) + (unless (and (vector? v) + (andmap string? l)) + (raise-argument-error who "(vectorof string?)" l)) + (list->vector (map string->immutable-string l))))) + +(define/who current-print + (make-parameter (lambda (v) + (unless (void? v) + (print v) + (newline))) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-read-interaction + (make-parameter (lambda (src in) + (parameterize ([installed-read-accept-reader #t] + [installed-read-accept-lang #f]) + (installed-read-syntax src in))) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-prompt-read + (make-parameter (lambda () + (display "> ") + (let ([in ((current-get-interaction-input-port))]) + ((current-read-interaction) (object-name in) in))) + (lambda (p) + (check who (procedure-arity-includes/c 0) p) + p))) + +(define/who current-get-interaction-input-port + (make-parameter (lambda () (current-input-port)) + (lambda (p) + (check who (procedure-arity-includes/c 0) p) + p))) + +;; ---------------------------------------- + +(define cached-values (make-hasheq)) +(define (cache-configuration index thunk) + (hash-ref cached-values index + (lambda () + (let ([v (thunk)]) + (hash-set! cached-values index v) + v)))) diff -Nru racket-6.12+ppa1/src/io/sandman/lock.rkt racket-7.0+ppa1/src/io/sandman/lock.rkt --- racket-6.12+ppa1/src/io/sandman/lock.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/sandman/lock.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require "../common/internal-error.rkt") + +;; Simple lock for sandman + +(provide make-lock + lock-acquire + lock-release) + +(define (make-lock) + (box 0)) + +(define (lock-acquire box) + (let loop () + (unless (and (= 0 (unbox box)) (box-cas! box 0 1)) + (loop)))) + +(define (lock-release box) + (unless (box-cas! box 1 0) + (internal-error "failed to release lock"))) diff -Nru racket-6.12+ppa1/src/io/sandman/main.rkt racket-7.0+ppa1/src/io/sandman/main.rkt --- racket-6.12+ppa1/src/io/sandman/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/sandman/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,182 @@ +#lang racket/base +(require "../../thread/sandman-struct.rkt" + "../common/internal-error.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "lock.rkt") + +;; Create an extended sandman that can sleep with a rktio poll set. An +;; external-event set might be naturally implemented with a poll set, +;; except that poll sets are single-use values. So, an external-event +;; set is instead implemented as a tree of callbacks to registers with +;; a (fresh) poll set each time. + +;; This sandman builds on the default one to handles timeouts. While +;; it might make sense to all threads to sleep on pollable external +;; events, we don't implement that, and it's probably simpler to +;; connect events to semaphores through a long-term poll set... + +(provide sandman-add-poll-set-adder + sandman-poll-ctx-add-poll-set-adder! + sandman-poll-ctx-merge-timeout + sandman-set-background-sleep!) + +(struct exts (timeout-at fd-adders)) + +(define (sandman-add-poll-set-adder old-exts adder) + (exts (and old-exts (exts-timeout-at old-exts)) + (cons adder (and old-exts (exts-fd-adders old-exts))))) + +(define (sandman-poll-ctx-add-poll-set-adder! poll-ctx adder) + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + adder)))) + +(define (sandman-poll-ctx-merge-timeout poll-ctx timeout) + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + ((sandman-do-merge-timeout (current-sandman)) + (schedule-info-current-exts sched-info) + timeout)))) + + +(define background-sleep #f) +(define background-sleep-fd #f) + +(define (sandman-set-background-sleep! sleep fd) + (set! background-sleep sleep) + (set! background-sleep-fd fd)) + +(void + (current-sandman + (let ([timeout-sandman (current-sandman)] + [lock (make-lock)] + [waiting-threads '()] + [awoken-threads '()]) + (sandman + ;; sleep + (lambda (exts) + (define timeout-at (and exts (exts-timeout-at exts))) + (define fd-adders (and exts (exts-fd-adders exts))) + (define ps (rktio_make_poll_set rktio)) + (let loop ([fd-adders fd-adders]) + (cond + [(not fd-adders) (void)] + [(pair? fd-adders) + (loop (car fd-adders)) + (loop (cdr fd-adders))] + [else + (fd-adders ps)])) + (define sleep-secs (and timeout-at + (/ (- timeout-at (current-inexact-milliseconds)) 1000.0))) + (unless (and sleep-secs (sleep-secs . <= . 0.0)) + (cond + [background-sleep + (rktio_start_sleep rktio (or sleep-secs 0.0) ps rktio_NULL background-sleep-fd) + (background-sleep) + (rktio_end_sleep rktio)] + [else + (rktio_sleep rktio + (or sleep-secs 0.0) + ps + rktio_NULL)])) + (rktio_poll_set_forget rktio ps)) + + ;; poll + (lambda (mode wakeup) + (let check-signals () + (define v (rktio_poll_os_signal rktio)) + (unless (eqv? v RKTIO_OS_SIGNAL_NONE) + ((rktio_get_ctl_c_handler) (cond + [(eqv? v RKTIO_OS_SIGNAL_HUP) 'hang-up] + [(eqv? v RKTIO_OS_SIGNAL_TERM) 'terminate] + [else 'break])) + (check-signals))) + ((sandman-do-poll timeout-sandman) mode wakeup)) + + ;; any-sleepers? + (lambda () + ((sandman-do-any-sleepers? timeout-sandman))) + + ;; sleepers-external-events + (lambda () + (define timeout-at ((sandman-do-sleepers-external-events timeout-sandman))) + (and timeout-at + (exts timeout-at #f))) + + ;; add-thread! + (lambda (t exts) + (define fd-adders (exts-fd-adders exts)) + (unless (or (not fd-adders) + (null? fd-adders)) + (internal-error "cannot sleep on fds")) + ((sandman-do-add-thread! timeout-sandman) t (exts-timeout-at exts))) + + ;; remove-thread! + (lambda (t timeout-handle) + ((sandman-do-remove-thread! timeout-sandman) t timeout-handle)) + + ;; merge-exts + (lambda (a-exts b-exts) + (if (and a-exts b-exts) + (exts ((sandman-do-merge-external-event-sets + timeout-sandman) + (exts-timeout-at a-exts) + (exts-timeout-at b-exts)) + (if (and (exts-fd-adders a-exts) + (exts-fd-adders b-exts)) + (cons (exts-fd-adders a-exts) + (exts-fd-adders b-exts)) + (or (exts-fd-adders a-exts) + (exts-fd-adders b-exts)))) + (or a-exts b-exts))) + + ;; merge-timeout + (lambda (old-exts timeout-at) + (exts ((sandman-do-merge-timeout timeout-sandman) + (and old-exts + (exts-timeout-at old-exts)) + timeout-at) + (and old-exts + (exts-fd-adders old-exts)))) + + ;; extract-timeout + (lambda (exts) + (exts-timeout-at exts)) + + ;; condition-wait + (lambda (t) + (lock-acquire lock) + (set! waiting-threads (cons t waiting-threads)) + (lock-release lock) + ;; awoken callback. for when thread is awoken + (lambda () + (lock-acquire lock) + (if (memq t waiting-threads) + (begin + (set! waiting-threads (remove t waiting-threads eq?)) + (set! awoken-threads (cons t awoken-threads)) + (rktio_signal_received_at (rktio_get_signal_handle rktio))) ;; wakeup main thread if sleeping + (internal-error "thread is not a member of waiting-threads\n")) + (lock-release lock))) + + ;; condition-poll + (lambda (mode wakeup) + (lock-acquire lock) + (define at awoken-threads) + (set! awoken-threads '()) + (lock-release lock) + (for-each (lambda (t) + (wakeup t)) at)) + + ;; any-waiters? + (lambda () + (or (not (null? waiting-threads)) (not (null? awoken-threads)))) + + + ;; lock + lock)))) diff -Nru racket-6.12+ppa1/src/io/security/main.rkt racket-7.0+ppa1/src/io/security/main.rkt --- racket-6.12+ppa1/src/io/security/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/security/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt" + "../path/path.rkt" + "../path/relativity.rkt" + "../network/port-number.rkt") + +(provide make-security-guard + security-guard? + current-security-guard + + security-guard-check-file + security-guard-check-file-link + security-guard-check-network + + unsafe-make-security-guard-at-root) + +(struct security-guard (parent + file-guard + network-guard + link-guard)) + +(define root-security-guard + (security-guard #f void void void)) + +(define/who current-security-guard + (make-parameter root-security-guard + (lambda (v) + (check who security-guard? v) + v))) + +(define/who (make-security-guard parent + file-guard + network-guard + [link-guard void]) + (check who security-guard? parent) + (check who (procedure-arity-includes/c 3) file-guard) + (check who (procedure-arity-includes/c 4) network-guard) + (check who #:or-false (procedure-arity-includes/c 3) link-guard) + (security-guard parent file-guard network-guard (or link-guard void))) + +(define/who (unsafe-make-security-guard-at-root [file-guard void] + [network-guard void] + [link-guard void]) + (check who (procedure-arity-includes/c 3) file-guard) + (check who (procedure-arity-includes/c 4) network-guard) + (check who (procedure-arity-includes/c 3) link-guard) + (security-guard #f file-guard network-guard link-guard)) + +(define/who (security-guard-check-file check-who given-path guards) + (check who symbol? check-who) + (check who path-string? #:or-false given-path) + (check who (lambda (l) + (and (list? l) + (for/and ([s (in-list l)]) + (or (eq? s 'read) + (eq? s 'write) + (eq? s 'execute) + (eq? s 'delete) + (eq? s 'exists))))) + #:contract "(or/c 'read 'write 'execute 'delete 'exists)" + guards) + (define path (->path given-path)) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-file-guard sg) check-who path guards) + (loop (security-guard-parent sg))))) + +(define/who (security-guard-check-file-link check-who given-path given-dest) + (check who symbol? check-who) + (check who (lambda (p) (and (path-string? p) (complete-path? p))) + #:contract "(and/c path? complete-path?)" + given-path) + (check who path-string? given-dest) + (define path (->path given-path)) + (define dest (->path given-dest)) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-link-guard sg) check-who path dest) + (loop (security-guard-parent sg))))) + +(define/who (security-guard-check-network check-who given-host port client?) + (check who symbol? check-who) + (check who string? #:or-false given-host) + (check who listen-port-number? #:or-false port) + (define host (and given-host (string->immutable-string given-host))) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-network-guard sg) check-who host port (if client? 'client 'server)) + (loop (security-guard-parent sg))))) diff -Nru racket-6.12+ppa1/src/io/srcloc/main.rkt racket-7.0+ppa1/src/io/srcloc/main.rkt --- racket-6.12+ppa1/src/io/srcloc/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/srcloc/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,26 @@ +#lang racket/base +(require "../common/check.rkt" + "../format/main.rkt" + "../path/parameter.rkt") + +(provide srcloc->string) + +(define/who (srcloc->string s) + (check who srcloc? s) + (and (srcloc-source s) + (cond + [(and (srcloc-line s) + (srcloc-column s)) + (format "~a:~s:~s" + (adjust-path (srcloc-source s)) + (srcloc-line s) + (srcloc-column s))] + [else + (format "~a::~s" + (adjust-path (srcloc-source s)) + (srcloc-position s))]))) + +(define (adjust-path p) + (define dir (current-directory-for-user)) + ;; FIXME + p) diff -Nru racket-6.12+ppa1/src/io/string/convert.rkt racket-7.0+ppa1/src/io/string/convert.rkt --- racket-6.12+ppa1/src/io/string/convert.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/convert.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,189 @@ +#lang racket/base +(require "utf-8-decode.rkt" + "utf-8-encode.rkt" + "../common/check.rkt") + +(provide bytes->string/latin-1 + bytes->string/utf-8 + bytes-utf-8-length + + bytes-utf-8-index + bytes-utf-8-ref + + string->bytes/latin-1 + string->bytes/utf-8 + string-utf-8-length + + char-utf-8-length) + +;; ---------------------------------------- + +(define/who (bytes->string/latin-1 bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + (define len (- end start)) + (define s (make-string len)) + (let loop ([i len]) + (unless (zero? i) + (let ([i (sub1 i)]) + (string-set! s i (integer->char (bytes-ref bstr (+ i start)))) + (loop i)))) + s) + +(define (do-bytes->string/utf-8 who bstr err-char start end #:just-length? [just-length? #f]) + (check who bytes? bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + ;; Measure result string: + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr start end + #f 0 #f + #:error-char err-char + #:abort-mode 'error)) + (cond + [(eq? state 'error) (if just-length? + #f + (raise-encoding-error who bstr start end))] + [just-length? got-chars] + [else + ;; Create result string: + (define str (make-string got-chars)) + (utf-8-decode! bstr start end + str 0 #f + #:error-char err-char + #:abort-mode 'error) + str])) + +(define/who (bytes->string/utf-8 bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes->string/utf-8 who bstr err-char start end)) + +(define/who (bytes-utf-8-length bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes->string/utf-8 who bstr err-char start end #:just-length? #t)) + +(define (raise-encoding-error who bstr start end) + (raise-arguments-error who "byte string is not a well-formed UTF-8 encoding" + "byte string" (subbytes bstr start end))) + +;; ---------------------------------------- + +(define (do-bytes-utf-8-ref who bstr skip err-char start end + #:get-index? [get-index? #f]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip) + (check who (lambda (c) (or (not c) (char? c))) + #:contract "(or/c char? #f)" + err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + ;; First, decode `skip` items: + (define-values (initial-used-bytes initial-got-chars state) + (if (zero? skip) + (values 0 0 (if (= start end) 'complete 'continues)) + (utf-8-decode! bstr start end + #f 0 skip + #:error-char err-char + #:abort-mode 'error))) + (cond + [(eq? state 'error) + #f] + [(eq? state 'continues) + (cond + [(and get-index? ((+ start initial-used-bytes) . < . end)) + initial-used-bytes] + [else + ;; Get one more byte + (define str (and (not get-index?) (make-string 1))) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr (+ start initial-used-bytes) end + str 0 1 + #:error-char err-char)) + (cond + [(eq? new-state 'error) + #f] + [(or (eq? state 'continues) + (or (and (eq? state 'complete) + (= got-chars 1)))) + (if get-index? + initial-used-bytes + (string-ref str 0))] + [else #f])])] + [else #f])) + +(define/who (bytes-utf-8-ref bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes-utf-8-ref who bstr skip err-char start end)) + +(define/who (bytes-utf-8-index bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes-utf-8-ref who bstr skip err-char start end #:get-index? #t)) + +;; ---------------------------------------- + +(define/who (string->bytes/latin-1 str [err-byte #f] [start 0] [end (and (string? str) + (string-length str))]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (define len (- end start)) + (define bstr (make-bytes len)) + (let loop ([i len]) + (unless (zero? i) + (let ([i (sub1 i)]) + (define b (char->integer (string-ref str (+ i start)))) + (cond + [(byte? b) (bytes-set! bstr i b)] + [err-byte (bytes-set! bstr i err-byte)] + [else (raise-arguments-error who + "string cannot be encoded in Latin-1" + "string" str)]) + (loop i)))) + bstr) + +(define (do-string->bytes/utf-8 who str err-byte start end #:just-length? [just-length? #f]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + ;; Measure result byte string: + (define-values (used-chars got-bytes status) + (utf-8-encode! str start end + #f 0 #f)) + (cond + [just-length? got-bytes] + [else + ;; Create result byte string: + (define bstr (make-bytes got-bytes)) + (utf-8-encode! str start end + bstr 0 #f) + bstr])) + +(define/who (string->bytes/utf-8 str [err-byte #f] [start 0] [end (and (string? str) + (string-length str))]) + (do-string->bytes/utf-8 who str err-byte start end)) + +(define/who (string-utf-8-length str [start 0] [end (and (string? str) + (string-length str))]) + (do-string->bytes/utf-8 who str #f start end #:just-length? #t)) + +;; ---------------------------------------- + +(define (char-utf-8-length c) + (check 'char-utf-8-length char? c) + (define n (char->integer c)) + (cond + [(n . <= . #x7F) 1] + [(n . <= . #x7FF) 2] + [(n . <= . #xFFFF) 3] + [else 4])) diff -Nru racket-6.12+ppa1/src/io/string/integer.rkt racket-7.0+ppa1/src/io/string/integer.rkt --- racket-6.12+ppa1/src/io/string/integer.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/integer.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,10 @@ +#lang racket/base + +;; Simple string->number conversion, since the geenral one is +;; implemented at the expander level + +(provide string->integer) + +(define (string->integer s) + (for/fold ([v 0]) ([c (in-string s)]) + (+ (* v 10) (- (char->integer c) (char->integer #\0))))) diff -Nru racket-6.12+ppa1/src/io/string/main.rkt racket-7.0+ppa1/src/io/string/main.rkt --- racket-6.12+ppa1/src/io/string/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require "convert.rkt" + "number.rkt") + +(provide (all-from-out "convert.rkt") + set-string->number?!) diff -Nru racket-6.12+ppa1/src/io/string/number.rkt racket-7.0+ppa1/src/io/string/number.rkt --- racket-6.12+ppa1/src/io/string/number.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/number.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,13 @@ +#lang racket/base + +;; The `string->number` function is implemented at the reader+expander +;; level, but the printer needs `string->number` for checking whether +;; to quote a symbol. Tie the knot with `set-string->number?!`. + +(provide string->number? + set-string->number?!) + +(define string->number? (lambda (str) #f)) + +(define (set-string->number?! proc) + (set! string->number? proc)) diff -Nru racket-6.12+ppa1/src/io/string/utf-16-decode.rkt racket-7.0+ppa1/src/io/string/utf-16-decode.rkt --- racket-6.12+ppa1/src/io/string/utf-16-decode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/utf-16-decode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base +(require "../common/set-two.rkt") + +(provide utf-16-decode) + +(define big-endian? (system-big-endian?)) + +(define (utf-16-decode bstr) + (define len (bytes-length bstr)) + (define surrogate-count + (for/fold ([n 0]) ([b (in-bytes bstr (if big-endian? 0 1) len 2)]) + (if (= (bitwise-and b #xDC) #xD8) + (add1 n) + n))) + (define str (make-string (- (arithmetic-shift len -1) surrogate-count))) + (let loop ([i 0] [pos 0]) + (unless (= i len) + (define a (bytes-ref bstr i)) + (define b (bytes-ref bstr (add1 i))) + (define v (if big-endian? + (bitwise-ior (arithmetic-shift a 8) b) + (bitwise-ior (arithmetic-shift b 8) a))) + (cond + [(= (bitwise-and v #xDC00) #xDC00) + ;; surrogate pair + (define a (bytes-ref bstr (+ i 2))) + (define b (bytes-ref bstr (+ i 3))) + (define v2 (if big-endian? + (bitwise-ior (arithmetic-shift a 8) b) + (bitwise-ior (arithmetic-shift b 8) a))) + (define all-v (+ #x10000 + (bitwise-ior (arithmetic-shift (bitwise-and v #x3FF) 10) + (bitwise-and v2 #x3FF)))) + (string-set! str pos (integer->char all-v)) + (loop (+ i 4) (add1 pos))] + [else + (string-set! str pos (integer->char v)) + (loop (+ i 2) (add1 pos))]))) + str) diff -Nru racket-6.12+ppa1/src/io/string/utf-16-encode.rkt racket-7.0+ppa1/src/io/string/utf-16-encode.rkt --- racket-6.12+ppa1/src/io/string/utf-16-encode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/utf-16-encode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,26 @@ +#lang racket/base +(require "../common/set-two.rkt") + +(provide utf-16-encode) + +(define (utf-16-encode s) + (define surrogate-count + (for/fold ([n 0]) ([c (in-string s)]) + (if ((char->integer c) . >= . #x10000) + (add1 n) + n))) + (define bstr (make-bytes (* 2 (+ (string-length s) surrogate-count)))) + (for/fold ([pos 0]) ([c (in-string s)]) + (define v (char->integer c)) + (cond + [(v . >= . #x10000) + (define av (- v #x10000)) + (define hi (bitwise-ior #xD800 (bitwise-and (arithmetic-shift av -10) #x3FF))) + (define lo (bitwise-ior #xDC00 (bitwise-and av #x3FF))) + (bytes-set-two! bstr pos (arithmetic-shift hi -8) (bitwise-and hi #xFF)) + (bytes-set-two! bstr pos (arithmetic-shift lo -8) (bitwise-and lo #xFF)) + (+ pos 4)] + [else + (bytes-set-two! bstr pos (arithmetic-shift v -8) (bitwise-and v #xFF)) + (+ pos 2)])) + bstr) diff -Nru racket-6.12+ppa1/src/io/string/utf-8-decode.rkt racket-7.0+ppa1/src/io/string/utf-8-decode.rkt --- racket-6.12+ppa1/src/io/string/utf-8-decode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/utf-8-decode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,188 @@ +#lang racket/base + +(provide utf-8-decode! + utf-8-max-aborts-amt + + utf-8-state? + utf-8-state-pending-amt) + +;; The maximum number of characters that might not be consumed +;; by a conversion at the tail of a byte string, assuming that +;; additional bytes could be added to the tail: +(define utf-8-max-aborts-amt 3) + +(struct utf-8-state (accum ; accumulated value for a partial decoding + remaining ; number of bytes expected to finidh decoding + pending-amt)) ; number of bytes contributing to `accum` + +;; Returns (values bytes-used chars-written (or/c 'complete 'continues 'aborts 'error state-for-aborts)), +;; where the number of bytes used can go negative if a previous abort state is provided +;; and further decoding reveals that earlier bytes were in error. +;; +;; The `abort-mode` argument determines what to do when reaching the end of the input +;; and an encoding needs more ytes: +;; * 'error : treat the bytes as encoding errors +;; * 'aborts : report 'aborts +;; * 'state : return a value that encapsulates the state, so another call can continue +;; +;; The result state is +;; * 'complete : all input read, all output written +;; * 'continues : output full, and input contains more +;; * 'aborts : see `abort-mode` above +;; * 'error : encoding error, but only when `error-ch` is #f +;; * state-for-aborts : see `abort-mode` above +;; +;; Beware that there is a similar copy of this code in "../converter/utf-8.rkt", +;; but that one is different enough to make abstraction difficult. +;; +(define (utf-8-decode! in-bstr in-start in-end + out-str out-start out-end ; `out-str` and `out-end` can be #f no string result needed + #:error-char [error-ch #f] ; replaces an encoding error if non-#f + #:abort-mode [abort-mode 'error] ; 'error, 'aborts, or 'state + #:state [state #f]) ; state that was returned in place of a previous 'aborts result + (define base-i ; start of current encoding sequence + (if state + (- in-start (utf-8-state-pending-amt state)) + in-start)) + (define accum ; accumulated value for encoding + (if state + (utf-8-state-accum state) + 0)) + (define remaining ; number of bytes still needed for the encoding + (if state + (utf-8-state-remaining state) + 0)) + + ;; Iterate through the given byte string + (let loop ([i in-start] [j out-start] [base-i base-i] [accum accum] [remaining remaining]) + + ;; Shared handling for encoding failures: + (define (encoding-failure) + (cond + [error-ch + (when out-str (string-set! out-str j error-ch)) + (define next-j (add1 j)) + (define next-i (add1 base-i)) + (cond + [(and out-end (= next-j out-end)) + (values (- next-i in-start) + (- next-j out-start) + 'continues)] + [else + (loop next-i next-j next-i 0 0)])] + [else + (values (- base-i in-start) + (- j out-start) + 'error)])) + + ;; Shared handling for decoding success: + (define (continue) + (define next-j (add1 j)) + (define next-i (add1 i)) + (cond + [(and out-end (= next-j out-end)) + (values (- next-i in-start) + (- next-j out-start) + (if (= next-i in-end) + 'complete + 'continues))] + [else + (loop next-i next-j next-i 0 0)])) + + ;; Dispatch on byte: + (cond + [(= i in-end) + ;; End of input + (cond + [(zero? remaining) + (values (- base-i in-start) + (- j out-start) + 'complete)] + [(eq? abort-mode 'error) + (encoding-failure)] + [(eq? abort-mode 'state) + (values (- i in-start) ; all bytes used + (- j out-start) + (utf-8-state accum remaining (- i base-i)))] + [else + (values (- base-i in-start) + (- j out-start) + 'aborts)])] + [(i . < . in-start) + ;; Happens only if we resume decoding with some state + ;; and hit a decoding error; treat the byte as another + ;; encoding error + (encoding-failure)] + [else + (define b (bytes-ref in-bstr i)) + (cond + [(b . < . 128) + (cond + [(zero? remaining) + ;; Found ASCII + (when out-str (string-set! out-str j (integer->char b))) + (continue)] + [else + ;; We were accumulating bytes for an encoding, and + ;; the encoding didn't complete + (encoding-failure)])] + [else + ;; Encoding... + (cond + [(= #b10000000 (bitwise-and b #b11000000)) + ;; A continuation byte + (cond + [(zero? remaining) + ;; We weren't continuing + (encoding-failure)] + [else + (define next (bitwise-and b #b00111111)) + (define next-accum (bitwise-ior (arithmetic-shift accum 6) next)) + (cond + [(= 1 remaining) + (cond + [(and (next-accum . > . 127) + (next-accum . <= . #x10FFFF) + (not (and (next-accum . >= . #xD800) + (next-accum . <= . #xDFFF)))) + (when out-str (string-set! out-str j (integer->char next-accum))) + (continue)] + [else + ;; Not a valid character + (encoding-failure)])] + [(and (= 2 remaining) + (next-accum . <= . #b11111)) + ;; A shorter byte sequence would work, so this is an + ;; encoding mistae. + (encoding-failure)] + [(and (= 3 remaining) + (next-accum . <= . #b1111)) + ;; A shorter byte sequence would work + (encoding-failure)] + [else + ;; Continue an encoding. + (loop (add1 i) j base-i next-accum (sub1 remaining))])])] + [(not (zero? remaining)) + ;; Trying to start a new encoding while one is in + ;; progress + (encoding-failure)] + [(= #b11000000 (bitwise-and b #b11100000)) + ;; Start a two-byte encoding + (define accum (bitwise-and b #b11111)) + ;; If `accum` is zero, that's an encoding mistake, + ;; because a shorted byte sequence would work. + (cond + [(zero? accum) (encoding-failure)] + [else (loop (add1 i) j i accum 1)])] + [(= #b11100000 (bitwise-and b #b11110000)) + ;; Start a three-byte encoding + (define accum (bitwise-and b #b1111)) + (loop (add1 i) j i accum 2)] + [(= #b11110000 (bitwise-and b #b11111000)) + ;; Start a four-byte encoding + (define accum (bitwise-and b #b111)) + (loop (add1 i) j i accum 3)] + [else + ;; Five- or six-byte encodings don't produce valid + ;; characters + (encoding-failure)])])]))) diff -Nru racket-6.12+ppa1/src/io/string/utf-8-encode.rkt racket-7.0+ppa1/src/io/string/utf-8-encode.rkt --- racket-6.12+ppa1/src/io/string/utf-8-encode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/string/utf-8-encode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,69 @@ +#lang racket/base + +(provide utf-8-encode! + + utf-8-encode-dispatch) + +;; Returns (values chars-used bytes-written (or/c 'complete 'continues)) +;; where 'continues is the result when the result byte string doesn't +;; have enough room +(define (utf-8-encode! in-str in-start in-end + out-bstr out-start out-end) ; `out-bstr` and `out-end` can be #f no bytes result needed + ;; Iterate through the given string + (let loop ([i in-start] [j out-start]) + (cond + [(= i in-end) + (values (- in-end in-start) (- j out-start) 'complete)] + [else + (define b (char->integer (string-ref in-str i))) + (define (continue next-j) (loop (add1 i) next-j)) + (utf-8-encode-dispatch b + in-start i + out-bstr out-start out-end j + continue)]))) + +(define-syntax-rule (utf-8-encode-dispatch b + in-start i + out-bstr out-start out-end j + continue) + (cond + [(b . <= . #x7F) + (cond + [(and out-end (= j out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr (bytes-set! out-bstr j b)) + (continue (add1 j))])] + [(b . <= . #x7FF) + (cond + [(and out-end ((add1 j) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11000000 (arithmetic-shift b -6))) + (bytes-set! out-bstr (add1 j) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 2))])] + [(b . <= . #xFFFF) + (cond + [(and out-end ((+ j 2) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11100000 (arithmetic-shift b -12))) + (bytes-set! out-bstr (+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6) + #b111111))) + (bytes-set! out-bstr (+ j 2) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 3))])] + [else + (cond + [(and out-end ((+ j 3) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11110000 (arithmetic-shift b -18))) + (bytes-set! out-bstr (+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -12) + #b111111))) + (bytes-set! out-bstr (+ j 2) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6) + #b111111))) + (bytes-set! out-bstr (+ j 3) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 4))])])) diff -Nru racket-6.12+ppa1/src/io/subprocess/main.rkt racket-7.0+ppa1/src/io/subprocess/main.rkt --- racket-6.12+ppa1/src/io/subprocess/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/subprocess/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,279 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/bytes-no-nuls.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../host/thread.rkt" + "../path/path.rkt" + "../path/parameter.rkt" + "../port/output-port.rkt" + "../port/input-port.rkt" + "../port/fd-port.rkt" + "../port/file-stream.rkt" + "../file/host.rkt" + "../string/convert.rkt" + "../locale/string.rkt" + "../envvar/main.rkt") + +(provide (rename-out [do-subprocess subprocess]) + subprocess? + subprocess-wait + subprocess-status + subprocess-kill + subprocess-pid + current-subprocess-custodian-mode + subprocess-group-enabled + shell-execute) + +(struct subprocess ([process #:mutable] + [cust-ref #:mutable] + is-group?) + #:constructor-name make-subprocess + #:property + prop:evt + (poller (lambda (sp ctx) + (define v (rktio_poll_process_done rktio (subprocess-process sp))) + (if (eqv? v 0) + (values #f sp) + (values (list sp) #f))))) + +(define do-subprocess + (let () + (define/who (subprocess stdout stdin stderr group/command . command/args) + (check who + (lambda (p) (or (not p) (and (output-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c output-port? file-stream-port?) #f)" + stdout) + (check who + (lambda (p) (or (not p) (and (input-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c input-port? file-stream-port?) #f)" + stdin) + (check who + (lambda (p) (or (not p) (eq? p 'stdout) (and (output-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c output-port? file-stream-port?) #f 'stdout)" + stderr) + (define-values (group command exact/args) + (cond + [(path-string? group/command) + (values (and (subprocess-group-enabled) 'new) group/command command/args)] + [(null? command/args) + (raise-argument-error who "path-string?" command)] + [(or (not group/command) + (eq? group/command 'new) + (subprocess? group/command)) + (define command (cadr command/args)) + (check who path-string? command) + (values group/command command (cdr command/args))] + [else + (raise-argument-error who "(or/c path-string? #f 'new subprocess?)" group/command)])) + (define-values (exact? args) + (cond + [(and (pair? exact/args) + (eq? 'exact (car exact/args))) + (values #t (cdr exact/args))] + [else + (values #f exact/args)])) + (for ([arg (in-list args)] + [i (in-naturals)]) + (check who + (lambda (p) (or (path? p) (string-no-nuls? p) (bytes-no-nuls? p))) + #:contract (if (and (not exact?) + (= i 0) + (= (length args) 2)) + "(or/c path? string-no-nuls? bytes-no-nuls? 'exact)" + "(or/c path? string-no-nuls? bytes-no-nuls?)") + arg)) + + (define cust-mode (current-subprocess-custodian-mode)) + (define env-vars (current-environment-variables)) + + (let* ([flags (if (eq? stderr 'stdout) + RKTIO_PROCESS_STDOUT_AS_STDERR + 0)] + [flags (if exact? + (bitwise-ior flags RKTIO_PROCESS_WINDOWS_EXACT_CMDLINE) + flags)] + [flags (if (eq? group 'new) + (bitwise-ior flags RKTIO_PROCESS_NEW_GROUP) + flags)] + [flags (if (and (eq? cust-mode 'kill) + (positive? (bitwise-and (rktio_process_allowed_flags rktio) + RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION))) + (bitwise-ior flags RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION) + flags)]) + + (define command-bstr (->host (->path command) who '(execute))) + + (start-atomic) + (poll-subprocess-finalizations) + (check-current-custodian who) + (define envvars (rktio_empty_envvars rktio)) + (for ([name (in-list (environment-variables-names env-vars))]) + (rktio_envvars_set rktio envvars name (environment-variables-ref env-vars name))) + + (define send-args (rktio_from_bytes_list + (cons command-bstr + (for/list ([arg (in-list args)]) + (cond + [(string? arg) + (string->bytes/locale arg (char->integer #\?))] + [(path? arg) + (path-bytes arg)] + [else arg]))))) + + (define r (rktio_process rktio command-bstr (add1 (length args)) send-args + (and stdout (fd-port-fd stdout)) + (and stdin (fd-port-fd stdin)) + (and stderr (not (eq? stderr 'stdout)) (fd-port-fd stderr)) + (and group (subprocess-process group)) + (->host (current-directory) #f null) + envvars flags)) + + (rktio_free_bytes_list send-args (length args)) + (when envvars + (rktio_envvars_free rktio envvars)) + + (when (rktio-error? r) + (end-atomic) + (raise-rktio-error who r "process creation failed")) + + (define in (let ([fd (rktio_process_result_stdout_fd r)]) + (and fd (open-input-fd fd 'subprocess-stdout)))) + (define out (let ([fd (rktio_process_result_stdin_fd r)]) + (and fd (open-output-fd fd 'subprocess-stdin)))) + (define err (let ([fd (rktio_process_result_stderr_fd r)]) + (and fd (open-input-fd fd 'subprocess-stderr)))) + (define sp (make-subprocess (rktio_process_result_process r) + #f + (eq? group 'new))) + + (register-subprocess-finalizer sp) + (when cust-mode + (let ([close (if (eq? cust-mode 'kill) kill-subprocess interrupt-subprocess)]) + (set-subprocess-cust-ref! sp (unsafe-custodian-register (current-custodian) sp close #t #f)))) + + (rktio_free r) + + (end-atomic) + (values sp in out err))) + subprocess)) + +;; ---------------------------------------- + +(define/who (subprocess-wait sp) + (check who subprocess? sp) + (void (sync sp))) + +;; ---------------------------------------- + +(define/who (subprocess-status sp) + (check who subprocess? sp) + (start-atomic) + (define r (rktio_process_status rktio (subprocess-process sp))) + (cond + [(rktio-error? r) + (end-atomic) + (raise-rktio-error who r "status access failed")] + [(rktio_status_running r) + (rktio_free r) + (end-atomic) + 'running] + [else + (define v (rktio_status_result r)) + (rktio_free r) + (end-atomic) + v])) + +(define/who (subprocess-pid sp) + (check who subprocess? sp) + (atomically + (rktio_process_pid rktio (subprocess-process sp)))) + +;; ---------------------------------------- + +;; in atomic mode +(define (kill-subprocess sp) + (define p (subprocess-process sp)) + (when p + (rktio_process_kill rktio p))) + +;; in atomic mode +(define (interrupt-subprocess sp) + (define p (subprocess-process sp)) + (when p + (rktio_process_interrupt rktio p))) + +(define/who (subprocess-kill sp force?) + (check who subprocess? sp) + (atomically (if force? + (interrupt-subprocess sp) + (kill-subprocess sp)))) + +;; ---------------------------------------- + +(define subprocess-will-executor (make-will-executor)) + +(define (register-subprocess-finalizer sp) + (will-register subprocess-will-executor + sp + (lambda (sp) + (when (subprocess-process sp) + (rktio_process_forget rktio (subprocess-process sp)) + (set-subprocess-process! sp #f)) + (when (subprocess-cust-ref sp) + (unsafe-custodian-unregister sp (subprocess-cust-ref sp)) + (set-subprocess-cust-ref! sp #f)) + #t))) + +(define (poll-subprocess-finalizations) + (when (will-try-execute subprocess-will-executor) + (poll-subprocess-finalizations))) + +;; ---------------------------------------- + +(define/who current-subprocess-custodian-mode + (make-parameter #f (lambda (v) + (unless (or (not v) (eq? v 'kill) (eq? v 'interrupt)) + (raise-argument-error who "(or/c #f 'kill 'interrupt)" v)) + v))) + +(define subprocess-group-enabled + (make-parameter #f (lambda (v) (and v #t)))) + +;; ---------------------------------------- + +(define/who (shell-execute verb target parameters dir show-mode) + (check who string? #:or-false verb) + (check who string? target) + (check who string? parameters) + (check who path-string? dir) + (define show_mode + (case show-mode + [(sw_hide SW_HIDE) RKTIO_SW_HIDE] + [(sw_maximize SW_MAXIMIZE) RKTIO_SW_MAXIMIZE] + [(sw_minimize SW_MINIMIZE) RKTIO_SW_MINIMIZE] + [(sw_restore SW_RESTORE) RKTIO_SW_RESTORE] + [(sw_show SW_SHOW) RKTIO_SW_SHOW] + [(sw_showdefault SW_SHOWDEFAULT) RKTIO_SW_SHOWDEFAULT] + [(sw_showmaximized SW_SHOWMAXIMIZED) RKTIO_SW_SHOWMAXIMIZED] + [(sw_showminimized SW_SHOWMINIMIZED) RKTIO_SW_SHOWMINIMIZED] + [(sw_showminnoactive SW_SHOWMINNOACTIVE) RKTIO_SW_SHOWMINNOACTIVE] + [(sw_showna SW_SHOWNA) RKTIO_SW_SHOWNA] + [(sw_shownoactivate SW_SHOWNOACTIVATE) RKTIO_SW_SHOWNOACTIVATE] + [(sw_shownormal SW_SHOWNORMAL) RKTIO_SW_SHOWNORMAL] + [else (raise-argument-error who "(or/c 'sw_hide ....)" show-mode)])) + (define r (rktio_shell_execute rktio + (and verb (string->bytes/utf-8 verb)) + (string->bytes/utf-8 target) + (string->bytes/utf-8 parameters) + (->host (->path dir) who '(exists)) + show_mode)) + (when (rktio-error? r) (raise-rktio-error 'who "failed" r)) + #f) + +;; ---------------------------------------- + +(void + (set-get-subprocesses-time! + (lambda () + (rktio_get_process_children_milliseconds rktio)))) diff -Nru racket-6.12+ppa1/src/io/unsafe/main.rkt racket-7.0+ppa1/src/io/unsafe/main.rkt --- racket-6.12+ppa1/src/io/unsafe/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/unsafe/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require "schedule.rkt" + "port.rkt") + +(provide (all-from-out "schedule.rkt") + (all-from-out "port.rkt")) diff -Nru racket-6.12+ppa1/src/io/unsafe/port.rkt racket-7.0+ppa1/src/io/unsafe/port.rkt --- racket-6.12+ppa1/src/io/unsafe/port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/unsafe/port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,51 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../string/convert.rkt" + "../port/fd-port.rkt" + "../network/tcp-port.rkt") + +(provide unsafe-file-descriptor->port + unsafe-port->file-descriptor + unsafe-file-descriptor->semaphore + + unsafe-socket->port + unsafe-port->socket + unsafe-socket->semaphore) + +(define (unsafe-file-descriptor->port system-fd name mode) + (define read? (memq 'read mode)) + (define write? (memq 'write mode)) + (define refcount (box (if (and read? write?) 2 1))) + (define fd (rktio_system_fd rktio system-fd + (bitwise-and + (if read? RKTIO_OPEN_READ 0) + (if write? RKTIO_OPEN_WRITE 0) + (if (memq 'test mode) RKTIO_OPEN_TEXT 0) + (if (memq 'regular-file mode) RKTIO_OPEN_REGFILE 0)))) + (define i (and read? + (open-input-fd fd name #:fd-refcount refcount))) + (define o (and write? + (open-output-fd fd name #:fd-refcount refcount))) + (if (and i o) + (values i o) + (or i o))) + +(define (unsafe-socket->port system-fd name mode) + (open-input-output-tcp system-fd (string->symbol (bytes->string/utf-8 name)) + #:close? (not (memq 'no-close mode)))) + + +(define (unsafe-port->file-descriptor p) + (define fd (fd-port-fd p)) + (and fd + (rktio_fd_system_fd rktio fd))) + +(define (unsafe-port->socket p) + (and (tcp-port? p) + (unsafe-port->file-descriptor p))) + +(define (unsafe-file-descriptor->semaphore system-fd mode) + #f) + +(define (unsafe-socket->semaphore system-fd mode) + #f) diff -Nru racket-6.12+ppa1/src/io/unsafe/schedule.rkt racket-7.0+ppa1/src/io/unsafe/schedule.rkt --- racket-6.12+ppa1/src/io/unsafe/schedule.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/io/unsafe/schedule.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,58 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt") + +(provide unsafe-poller + unsafe-poll-ctx-fd-wakeup + unsafe-poll-ctx-eventmask-wakeup + unsafe-poll-ctx-milliseconds-wakeup + unsafe-signal-received + unsafe-set-sleep-in-thread!) + +(define (unsafe-poller proc) + (poller (lambda (self poll-ctx) + (cond + [(poll-ctx-poll? poll-ctx) + (proc self #f)] + [else + (define-values (vals evt) (proc self #f)) + (cond + [vals (values vals #f)] + [(eq? evt self) + ;; Register wakeups: + (proc self poll-ctx) + (values #f self)] + [else + (values #f evt)])])))) + +(define (unsafe-poll-ctx-fd-wakeup poll-ctx fd mode) + (when poll-ctx + (sandman-poll-ctx-add-poll-set-adder! poll-ctx + (lambda (ps) + (atomically + (define rfd (rktio_system_fd rktio + fd + (case mode + [(read) RKTIO_OPEN_READ] + [else RKTIO_OPEN_WRITE]))) + (rktio_poll_add rktio rfd ps (case mode + [(read) RKTIO_POLL_READ] + [else RKTIO_POLL_WRITE])) + (rktio_forget rktio rfd)))))) + +(define (unsafe-poll-ctx-eventmask-wakeup poll-ctx event-mask) + (when poll-ctx + (sandman-poll-ctx-add-poll-set-adder! poll-ctx + (lambda (ps) + (rktio_poll_set_add_eventmask rktio ps event-mask))))) + +(define (unsafe-poll-ctx-milliseconds-wakeup poll-ctx msecs) + (when poll-ctx + (sandman-poll-ctx-merge-timeout poll-ctx msecs))) + +(define (unsafe-signal-received) + (rktio_signal_received rktio)) + +(define (unsafe-set-sleep-in-thread! do-sleep woke-fd) + (sandman-set-background-sleep! do-sleep woke-fd)) diff -Nru racket-6.12+ppa1/src/mac/osx_appl.rkt racket-7.0+ppa1/src/mac/osx_appl.rkt --- racket-6.12+ppa1/src/mac/osx_appl.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/mac/osx_appl.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -3,7 +3,7 @@ # OS X pre-make script # builds resource files, makes template Starter.app and GRacket.app # -# the script must be run from the gracket build directory, +# The script must be run from the gracket build directory, # and srcdir must be provided as the first argument |# diff -Nru racket-6.12+ppa1/src/mac/rename-app.rkt racket-7.0+ppa1/src/mac/rename-app.rkt --- racket-6.12+ppa1/src/mac/rename-app.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/mac/rename-app.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base -(current-directory (build-path 'up)) +(unless ((vector-length (current-command-line-arguments)) . > . 3) + (current-directory (build-path 'up))) (define app-path (vector-ref (current-command-line-arguments) 0)) (define old-name (vector-ref (current-command-line-arguments) 1)) diff -Nru racket-6.12+ppa1/src/Makefile.in racket-7.0+ppa1/src/Makefile.in --- racket-6.12+ppa1/src/Makefile.in 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -109,11 +109,10 @@ $(MAKE) plain-install-@MAIN_VARIANT@ install-common-first: - if [ "$(DESTDIR)" != "" ]; then \ - if [[ "$(DESTDIR)" != /* ]]; then \ - echo "expected an absolute path for DESTDIR; given: $(DESTDIR)"; exit 1; \ - fi; \ - fi + case "$(DESTDIR)" in \ + "" | /*) ;; \ + *) echo "expected an absolute path for DESTDIR; given: $(DESTDIR)"; exit 1;; \ + esac mkdir -p $(ALLDIRINFO) install-common-middle: @@ -248,6 +247,7 @@ clean: cd racket; $(MAKE) clean if [ -d gracket ]; then cd gracket; $(MAKE) clean; fi + rm -rf compiled rm -f TAGS # Reconfigure ---------------------------------------- diff -Nru racket-6.12+ppa1/src/mzcom/mzcom.cxx racket-7.0+ppa1/src/mzcom/mzcom.cxx --- racket-6.12+ppa1/src/mzcom/mzcom.cxx 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/mzcom/mzcom.cxx 2018-07-27 22:12:02.000000000 +0000 @@ -119,7 +119,7 @@ } #define DLL_RELATIVE_PATH L"." -#include "../racket/delayed.inc" +#include "../start/delayed.inc" #define ASSUME_ASCII_COMMAND_LINE #define GC_CAN_IGNORE diff -Nru racket-6.12+ppa1/src/native-libs/build-all.rkt racket-7.0+ppa1/src/native-libs/build-all.rkt --- racket-6.12+ppa1/src/native-libs/build-all.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/build-all.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -41,6 +41,9 @@ "libXrender" "freefont")] [else null]) + (cond + [win? null] + [else '("libuuid")]) '("libffi" "glib" "libpng" @@ -49,15 +52,16 @@ "pixman" "cairo" "harfbuzz" + "fribidi" "pango" "gmp" "mpfr" "jpeg" + "atk" "poppler") (cond [linux? '("gdk-pixbuf" - "atk" "gtk+")] [else null]))) diff -Nru racket-6.12+ppa1/src/native-libs/build.rkt racket-7.0+ppa1/src/native-libs/build.rkt --- racket-6.12+ppa1/src/native-libs/build.rkt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/build.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -113,12 +113,6 @@ ;; Fix a problem with glyph extents and clipped rendering: (define-runtime-path cairo-coretext-patch "patches/cairo-coretext.patch") -;; Avoid CGFontGetGlyphPath: -(define-runtime-path cairo-cgfontgetglpyh-patch "patches/cgfontgetglyph.patch") - -;; Patch to avoid writing to a global constant: -(define-runtime-path cairo-allclipmodifybug-patch "patches/allclipmodifybug.patch") - ;; Hack to workaround broken Courier New in Mac OS 10.{7.8}: (define-runtime-path courier-new-patch "patches/courier-new.patch") @@ -131,20 +125,27 @@ ;; Avoid crash when CTFontCollectionCreateMatchingFontDescriptors fails: (define-runtime-path coretext-nullarray "patches/coretext-nullarray.patch") +;; Define some functions that aren't in Mac OS 10.5 (for the 32-bit build) +(define-runtime-path pango-surrogate-patch "patches/pango-surrogate.patch") + ;; Enable "symbol" fonts, and fix off-by-one: (define-runtime-path win32text-patch "patches/win32text.patch") -;; Fix a problem with a surface connected to a clipped drawing context -(define-runtime-path win32cairofallback-patch "patches/win32cairofallback.patch") +;; Disable emoji-specific font, which intereferes with substitutions +;; (i.e., auto-find a suitable font) as implemented by `racket/draw` +(define-runtime-path pango-emoji-patch "patches/pango-emoji.patch") ;; Needed when building with old GCC, such as 4.0: (define-runtime-path gmp-weak-patch "patches/gmp-weak.patch") -;; XP doesn't have rand_s() as used by glib: -(define-runtime-path rand-patch "patches/rand.patch") +;; Upstream patch to fix Win32 build: +(define-runtime-path glib-win32-weekday-patch "patches/glib-win32-weekday.patch") -;; HarfBuzz makefile seems broken for MinGW as of 0.9.27: -(define-runtime-path fixdef-patch "patches/fixdef.patch") +;; strerror_s is not available in XP +(define-runtime-path glib-strerror-patch "patches/glib-strerror.patch") + +;; For now, disable glib functionality that depends on Mac OS 10.8: +(define-runtime-path gcocoanotify-patch "patches/gcocoanotify.patch") ;; Remove "-fno-check-new", which Clang does not recognize: (define-runtime-path nonochecknew-patch "patches/nonochecknew.patch") @@ -152,6 +153,9 @@ ;; 64-bit MinGW doesn't like this use of `__always_inline__`: (define-runtime-path noforceinline-patch "patches/noforceinline.patch") +;; `vector` syntax with old gcc +(define-runtime-path pixman-altivec-patch "patches/pixman-altivec.patch") + ;; Disable libtool's management of standard libs so that ;; MinGW's -static-libstdc++ works: (define-runtime-path libtool-link-patch "patches/libtool-link.patch") @@ -161,6 +165,23 @@ (define-runtime-path fcdirs-patch "patches/fcdirs.patch") (define-runtime-path fonts-conf "patches/fonts.conf") +;; Avoid problems compiling with an old version of g++ +(define-runtime-path harfbuzz-oldcompiler-patch "patches/harfbuzz-oldcompiler.patch") + +;; Adapt inline-function handling for an old gcc +(define-runtime-path gmp-inline-patch "patches/gmp-inline.patch") + +;; -------------------------------------------------- + +(define (replace-in-file file orig new) + (define rx (regexp-quote orig)) + (define-values (i o) (open-input-output-file file #:exists 'update)) + (define pos (caar (regexp-match-positions rx i))) + (file-position o pos) + (write-bytes new o) + (close-output-port o) + (close-input-port i)) + ;; -------------------------------------------------- ;; General environment and flag configuration: @@ -271,7 +292,8 @@ #:setup [setup null] #:patches [patches null] #:post-patches [post-patches null] - #:fixup [fixup #f]) + #:fixup [fixup #f] + #:fixup-proc [fixup-proc #f]) (for ([d (in-list (append (if (or (equal? package-name "pkg-config") (equal? package-name "sed")) '() @@ -281,7 +303,7 @@ deps))]) (unless (file-exists? (build-path dest "stamps" d)) (error 'build "prerequisite needed: ~a" d))) - (values env exe args make make-install setup patches post-patches fixup)) + (values env exe args make make-install setup patches post-patches fixup fixup-proc)) (define path-flags (list (list "CPPFLAGS" (~a "-I" dest "/include")) @@ -298,9 +320,9 @@ (define (linux-only) (unless linux? (error (format "build ~a only for Linux" package-name)))) - + (define-values (extra-env configure-exe extra-args make-command make-install-command - setup patches post-patches fixup) + setup patches post-patches fixup fixup-proc) (case package-name [("pkg-config") (config #:configure (list "--with-internal-glib"))] [("sed") (config)] @@ -318,7 +340,7 @@ (if linux? (~a "make SHARED_LDFLAGS=" "-Wl,-rpath," dest "/lib") "make")) - (config #:configure-exe (find-executable-path "sh") + (config #:configure-exe (find-executable-path "perl") #:configure (cond [win? (list "./Configure" @@ -340,7 +362,16 @@ "shared" "linux-x86_64")]) #:make make - #:make-install (~a make " install_sw"))] + #:make-install (~a make " install_sw") + #:fixup (and win? + (~a "cd " (build-path dest "bin") + " && mv libssl-1_1" (if m32? "" "-x64") ".dll ssleay32.dll" + " && mv libcrypto-1_1" (if m32? "" "-x64") ".dll libeay32.dll")) + #:fixup-proc (and win? + (lambda () + (replace-in-file (build-path dest "bin" "ssleay32.dll") + (bytes-append #"libcrypto-1_1" (if m32? #"" #"-x64") #".dll\0") + #"libeay32.dll\0"))))] [("expat") (config)] [("gettext") (config #:depends (if win? '("libiconv") '()) #:configure '("--enable-languages=c") @@ -371,8 +402,9 @@ #:env (append path-flags ld-library-path-flags))] [("atk") - (linux-only) - (config #:depends '("libX11") + (config #:depends (if linux? + '("libX11") + '()) #:env (append path-flags ld-library-path-flags))] [("gtk+") @@ -405,65 +437,102 @@ (~a "cp zlib1.dll " dest "/bin && cp libz.dll.a " dest "/lib")))] [("glib") (config #:depends (append '("libffi" "gettext") (if win? '("libiconv") '())) + #:configure (append '("--with-pcre=internal") + (if linux? '("--enable-libmount=no") '())) #:env (append path-flags ;; Disable Valgrind support, which particularly ;; goes wrong for 64-bit Windows builds. (list (list "CPPFLAGS" "-DNVALGRIND=1"))) - #:patches (if (and win? m32?) - (list rand-patch) - null))] + #:patches (cond + [win? (list glib-win32-weekday-patch + glib-strerror-patch)] + [mac? (list gcocoanotify-patch)] + [else null]))] [("libpng") (config #:depends (if (or win? linux?) '("zlib") '()) #:env (if (or linux? win?) - (append - path-flags - (if linux? - (list (list "LDFLAGS" (~a "-Wl,-rpath," dest "/lib"))) - null)) - null))] + (append + path-flags + (if linux? + (list (list "LDFLAGS" (~a "-Wl,-rpath," dest "/lib"))) + null)) + null))] + [("libuuid") (config)] [("freetype") (config #:depends '("libpng"))] - [("fontconfig") (config #:depends '("expat" "freetype") - #:configure '("--disable-docs") + [("fontconfig") (config #:depends (append '("expat" "freetype") + (if win? '() '("libuuid"))) + #:configure (append '("--disable-docs") + (if win? + `("--without-libiconv-prefix" + "--without-libintl-prefix") + '())) #:patches (list fcdirs-patch))] - [("pixman") (config #:patches (if (and win? (not m32?)) - (list noforceinline-patch) - null))] - [("cairo") (config #:depends (append '("pixman" "fontconfig" "freetype" "libpng") - (if linux? - '("libX11" "libXrender") - null)) - #:env path-flags - #:configure (if (not linux?) - '("--enable-xlib=no") - null) - #:patches (list cairo-coretext-patch - cairo-cgfontgetglpyh-patch - cairo-allclipmodifybug-patch - courier-new-patch - win32cairofallback-patch))] + [("pixman") (config #:patches (cond + [(and win? (not m32?)) (list noforceinline-patch)] + [ppc? (list pixman-altivec-patch)] + [else null]))] + [("cairo") + (when mac? + (define zlib.pc (build-path dest "lib" "pkgconfig" "zlib.pc")) + (unless (file-exists? zlib.pc) + (call-with-output-file* + zlib.pc + (lambda (o) (write-string "Name: zlib\nDescription: zlib\nVersion: 1.0\nLibs: -lz\nLibs.private:\nCflags:\n" o))))) + (config #:depends (append '("pixman" "fontconfig" "freetype" "libpng") + (if linux? + '("libX11" "libXrender") + null)) + #:env path-flags + #:configure (append + (if (not linux?) + '("--enable-xlib=no") + null) + '("png_REQUIRES=libpng16") + (if mac? + '("CFLAGS=-include Kernel/uuid/uuid.h") + '())) + #:patches (list cairo-coretext-patch + courier-new-patch))] [("harfbuzz") (config #:depends '("fontconfig" "freetype" "cairo") #:configure '("--without-icu") - #:patches (if win? - (list fixdef-patch) - null) - #:env cxx-env)] - [("pango") (config #:depends '("cairo" "harfbuzz") + #:env cxx-env + #:patches (if ppc? + (list harfbuzz-oldcompiler-patch) + null))] + [("fribidi") (config #:configure '("--disable-docs"))] + [("pango") (config #:depends '("cairo" "harfbuzz" "fribidi") #:env (if win? path-flags null) #:configure (append (if (not linux?) '("--without-x") null) '("--with-included-modules=yes" - "--with-dynamic-modules=no")) - #:patches (list coretext-patch - coretext-fontreg-patch - coretext-nullarray - win32text-patch))] + "--with-dynamic-modules=no") + (if mac? + '("CFLAGS=-include Kernel/uuid/uuid.h") + '())) + #:patches (append + (list coretext-patch + coretext-fontreg-patch + coretext-nullarray + win32text-patch) + (if (and mac? m32?) + (list pango-surrogate-patch) + null) + (if (or mac? win?) + (list pango-emoji-patch) + null)))] [("gmp") (config #:patches (if gcc-4.0? (list gmp-weak-patch) null) #:configure (append '("--enable-shared" "--disable-static") + (if (and mac? (not ppc?)) + '("--build=corei-apple-darwin") + null) (if (and m32? mac?) (list "ABI=32") - null)))] + null)) + #:post-patches (if (and mac? ppc?) + (list gmp-inline-patch) + null))] [("mpfr") (config #:configure (append (if win? '("--enable-thread-safe") null) '("--enable-shared" "--disable-static")) #:depends '("gmp") @@ -526,5 +595,7 @@ (system/show make-install-command) (when fixup (system/show fixup)) + (when fixup-proc + (fixup-proc)) (stamp package-name) (displayln "Success!")) diff -Nru racket-6.12+ppa1/src/native-libs/install.rkt racket-7.0+ppa1/src/native-libs/install.rkt --- racket-6.12+ppa1/src/native-libs/install.rkt 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/install.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -13,11 +13,13 @@ "libgthread-2.0.0" "libglib-2.0.0" "libgobject-2.0.0" - "libintl.8" + "libintl.9" "libharfbuzz.0" + "libfribidi.0" "libpango-1.0.0" "libpangocairo-1.0.0" "libpangoft2-1.0.0" + "libatk-1.0.0" "libexpat.1" "libfontconfig.1" "libfreetype.6" @@ -39,9 +41,20 @@ "zlib1" "libpangowin32-1.0.0")) +(define mac-libs + '("PSMTabBarControl.framework")) + +(define mac64-libs + '("MMTabBarView.framework")) + (define nonwin-libs - '("libcrypto.1.0.0" - "libssl.1.0.0")) + '("libcrypto.1.1" + "libssl.1.1" + "libuuid.1")) + +(define no-copy-libs + '("PSMTabBarControl.framework" + "MMTabBarView.framework")) (define linux-libs (append @@ -57,18 +70,18 @@ "libsqlite3.0") '("libgtk-x11-2.0.0" "libgdk-x11-2.0.0" - "libatk-1.0.0" "libgdk_pixbuf-2.0.0"))) (define linux-remove-libs - '("libintl.8")) + '("libintl.9")) (define package-mapping `(["draw" ; pkg name - "-2" ; pkg suffix (increment after "-" when library versions change) + "-3" ; pkg suffix (increment after "-" when library versions change) "racket/draw" ; subdir "" ; extra for "LICENSE.txt" #t ; dynamic libraries (as opposed to shared files) #f ; for-pkg name (e.g., "base"), of #f if the same as the pkg name + #f ; version (["libffi" "libffi - Copyright (c) 1996-2014 Anthony Green, Red Hat, Inc and others."] ["libglib" "GLib is released under the GNU Library General Public License (GNU LGPL)."] "libgio" @@ -77,11 +90,13 @@ "libgthread" ["libintl" "libintl is released under the GNU Library General Public License (GNU LGPL)."] ["libharfbuzz" "HarfBuzz is relased under a MIT license."] + ["libfribidi" "FriBidi is released under the GNU Library General Public License (GNU LGPL)."] ["libpango" "Pango is released under the GNU Library General Public License (GNU LGPL)."] "libpangocairo" "libpangoft2" "libpangowin32" "libexpat" + ["libuuid" "libuuid is relased under a Modified BSD license."] ["libfontconfig" ,(~a "FontConfig:\n" " Copyright © 2000,2001,2002,2003,2004,2006,2007 Keith Packard\n" " Copyright © 2005 Patrick Lam\n" @@ -97,11 +112,12 @@ ["zlib1" "zlib is by Jean-loup Gailly and Mark Adler."] ["libz" "zlib is by Jean-loup Gailly and Mark Adler."])] ["racket" - "-2" + "-3" "racket" "" #t #f + #f (["libeay32" ,(~a "This product includes software developed by the OpenSSL Project for\n" "use in the OpenSSL Toolkit (http://www.openssl.org/).\n" "\n" @@ -120,6 +136,7 @@ "" #t #f + #f (["libgmp" "GNU MP is released under the GNU Lesser General Public License (GNU LGPL)."] ["libmpfr" "MPFR is released under the GNU Lesser General Public License (GNU LGPL)."])] @@ -129,6 +146,7 @@ "" #t "draw" + #f (["libX11.6" "libX11 is released under the X.Org Foundation license."] ["libXau.6" "libXau - Copyright 1988, 1993, 1994, 1998 The Open Group"] ["libxcb-shm.0" "libxcb - Copyright (C) 2001-2006 Bart Massey, Jamey Sharp, and Josh Triplett."] @@ -142,6 +160,7 @@ "" #f "draw" + #f (["fonts" ,(~a "Fonts:\n" " Copyright © 2000,2001,2002,2003,2004,2006,2007 Keith Packard\n" " Copyright © 2005 Patrick Lam\n" @@ -156,10 +175,13 @@ "" #t #f + "1.2" ; version (["libgtk-x11-2.0.0" "GTK+ is released under the GNU Library General Public License (GNU LGPL)."] - ["libatk-1.0.0" "ATK is released under the GNU Library General Public License (GNU LGPL)."] + ["libatk" "ATK is released under the GNU Library General Public License (GNU LGPL)."] "libgdk-x11-2.0.0" - "libgdk_pixbuf-2.0.0")] + "libgdk_pixbuf-2.0.0" + ["PSMTabBarControl.framework" "PSMTabBarControl is BSD licensed.\nSee: http://www.positivespinmedia.com/dev/PSMTabBarControl.html"] + ["MMTabBarView.framework" "MMTabBarView is BSD licensed.\nSee: http://mimo42.github.io/MMTabBarView/"])] ["db" "" @@ -167,6 +189,7 @@ "" #t "base" + #f (["libsqlite3.0" "SQLite3 is in the public domain."] ["sqlite3" "SQLite3 is in the public domain."])] @@ -176,14 +199,19 @@ "" #t "racket-poppler" + #f (["libpoppler" ;; Note: Poppler is GPL and *not* in the main Racket distribution (which is LGPL) "Poppler is released under the GNU General Public License (GNU GPL)."])])) -(define (libs-of-pkg p) (list-ref p 6)) +(define (libs-of-pkg p) (list-ref p 7)) + +(define (framework? p) + (regexp-match? #rx"[.]framework" p)) (define (plain-path? p) - (equal? p "fonts")) + (or (equal? p "fonts") + (framework? p))) (define dest-dir (build-command-line @@ -212,7 +240,7 @@ (error 'install "cannot find package for library: ~e" lib)) (apply values pkg)) -(define (gen-info platform i-platform for-pkg pkg-name subdir libs lics lic-end lib?) +(define (gen-info platform i-platform for-pkg pkg-name subdir libs lics lic-end lib? vers) (define dest (build-path dest-dir pkg-name)) (define lib-path (build-path dest subdir "info.rkt")) (define top-path (build-path dest "info.rkt")) @@ -227,7 +255,8 @@ (quote ,libs)) o) (define dirs (filter (lambda (lib) - (directory-exists? (build-path dest subdir lib))) + (or (framework? lib) + (directory-exists? (build-path dest subdir lib)))) libs)) (unless (null? dirs) (newline o) @@ -239,7 +268,10 @@ (newline o) (pretty-write `(define pkg-desc ,(format "native libraries for \"~a\" package" for-pkg)) o) (newline o) - (pretty-write `(define pkg-authors '(mflatt)) o)) + (pretty-write `(define pkg-authors '(mflatt)) o) + (when vers + (newline o) + (pretty-write `(define version ,vers) o))) (unless same? (printf "Write ~a\n" lib-path) (call-with-output-file* @@ -293,14 +325,16 @@ (~a pkg "-" platform suffix) subdir)) (define dest (build-path dir p)) - (make-directory* dir) - (cond - [(file-exists? dest) (delete-file dest)] - [(directory-exists? dest) (delete-directory/files dest)]) - (define src (build-path from p)) - (if (directory-exists? src) - (copy-directory/files src dest) - (copy-file src dest)) + (let-values ([(base name dir?) (split-path dest)]) + (make-directory* base)) + (unless (member p no-copy-libs) + (cond + [(file-exists? dest) (delete-file dest)] + [(directory-exists? dest) (delete-directory/files dest)]) + (define src (build-path from p)) + (if (directory-exists? src) + (copy-directory/files src dest) + (copy-file src dest))) (unless (plain-path? p) (fixup p dest)) @@ -320,28 +354,30 @@ libs (reverse (hash-ref pkgs-lic pkg null)) (list-ref a 3) - (list-ref a 4)))) + (list-ref a 4) + (list-ref a 6)))) (define (install-mac) (define (fixup p p-new) - (printf "Fixing ~s\n" p-new) - (unless (memq 'write (file-or-directory-permissions p-new)) - (file-or-directory-permissions p-new #o744)) - (system (format "install_name_tool -id ~a ~a" (file-name-from-path p-new) p-new)) - (for-each (lambda (s) - (system (format "install_name_tool -change ~a @loader_path/~a ~a" - (format "~a/~a.dylib" from s) - (format "~a.dylib" s) - p-new))) - (append libs nonwin-libs)) - (system (format "strip -S ~a" p-new))) + (unless (framework? p) + (printf "Fixing ~s\n" p-new) + (unless (memq 'write (file-or-directory-permissions p-new)) + (file-or-directory-permissions p-new #o744)) + (system (format "install_name_tool -id ~a ~a" (file-name-from-path p-new) p-new)) + (for-each (lambda (s) + (system (format "install_name_tool -change ~a @loader_path/~a ~a" + (format "~a/~a.dylib" from s) + (format "~a.dylib" s) + p-new))) + (append libs nonwin-libs)) + (system (format "strip -S ~a" p-new)))) (define platform (~a (if m32? (if ppc? "ppc" "i386") "x86_64") "-macosx")) - - (install platform platform "dylib" fixup (append libs nonwin-libs))) + + (install platform platform "dylib" fixup (append libs mac-libs (if m32? '() mac64-libs) nonwin-libs))) (define (install-win) (define exe-prefix (if m32? @@ -356,8 +392,8 @@ (environment-variables-copy (current-environment-variables))]) (putenv "PATH" (~a (if m32? - "/usr/mw32/bin:" - "/usr/mw64/bin:") + "/usr/local/mw32/bin:/usr/mw32/bin:" + "/usr/local/mw64/bin:/usr/mw64/bin:") (getenv "PATH"))) (install (~a "win32-" (if m32? "i386" "x86_64")) diff -Nru racket-6.12+ppa1/src/native-libs/patches/allclipmodifybug.patch racket-7.0+ppa1/src/native-libs/patches/allclipmodifybug.patch --- racket-6.12+ppa1/src/native-libs/patches/allclipmodifybug.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/allclipmodifybug.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -diff -u -r old/cairo-1.12.16/src/cairo-clip-boxes.c new/cairo-1.12.16/src/cairo-clip-boxes.c ---- old/cairo-1.12.16/src/cairo-clip-boxes.c 2015-11-06 15:46:30.000000000 -0700 -+++ new/cairo-1.12.16/src/cairo-clip-boxes.c 2015-11-06 15:47:36.000000000 -0700 -@@ -172,8 +172,11 @@ - if (clip->path == NULL) { - clip->extents = *r; - } else { -- if (! _cairo_rectangle_intersect (&clip->extents, r)) -+ if (! _cairo_rectangle_intersect (&clip->extents, r)) { - clip = _cairo_clip_set_all_clipped (clip); -+ /* return so that there's no attempt to modify `clip`: */ -+ return clip; -+ } - } - if (clip->path == NULL) - clip->is_region = _cairo_box_is_pixel_aligned (box); -Only in new/cairo-1.12.16/src: cairo-clip-boxes.c~ diff -Nru racket-6.12+ppa1/src/native-libs/patches/cgfontgetglyph.patch racket-7.0+ppa1/src/native-libs/patches/cgfontgetglyph.patch --- racket-6.12+ppa1/src/native-libs/patches/cgfontgetglyph.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/cgfontgetglyph.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -diff -r -u old/cairo-1.12.16/src/cairo-quartz-font.c new/cairo-1.12.16/src/cairo-quartz-font.c ---- old/cairo-1.12.16/src/cairo-quartz-font.c 2015-11-04 15:21:19.000000000 -0700 -+++ new/cairo-1.12.16/src/cairo-quartz-font.c 2015-11-04 15:21:37.000000000 -0700 -@@ -81,9 +81,6 @@ - static void (*CGContextSetAllowsFontSmoothingPtr) (CGContextRef, bool) = NULL; - static bool (*CGContextGetAllowsFontSmoothingPtr) (CGContextRef) = NULL; - --/* Not public in the least bit */ --static CGPathRef (*CGFontGetGlyphPathPtr) (CGFontRef fontRef, CGAffineTransform *textTransform, int unknown, CGGlyph glyph) = NULL; -- - /* CGFontGetHMetrics isn't public, but the other functions are public/present in 10.5 */ - typedef struct { - int ascent; -@@ -131,7 +128,6 @@ - /* These have the same name in 10.4 and 10.5 */ - CGFontGetUnitsPerEmPtr = dlsym(RTLD_DEFAULT, "CGFontGetUnitsPerEm"); - CGFontGetGlyphAdvancesPtr = dlsym(RTLD_DEFAULT, "CGFontGetGlyphAdvances"); -- CGFontGetGlyphPathPtr = dlsym(RTLD_DEFAULT, "CGFontGetGlyphPath"); - - CGFontGetHMetricsPtr = dlsym(RTLD_DEFAULT, "CGFontGetHMetrics"); - CGFontGetAscentPtr = dlsym(RTLD_DEFAULT, "CGFontGetAscent"); -@@ -148,7 +144,6 @@ - CGFontGetGlyphsForUnicharsPtr && - CGFontGetUnitsPerEmPtr && - CGFontGetGlyphAdvancesPtr && -- CGFontGetGlyphPathPtr && - (CGFontGetHMetricsPtr || (CGFontGetAscentPtr && CGFontGetDescentPtr && CGFontGetLeadingPtr))) - _cairo_quartz_font_symbols_present = TRUE; - -@@ -592,6 +587,8 @@ - CGGlyph glyph = _cairo_quartz_scaled_glyph_index (scaled_glyph); - CGAffineTransform textMatrix; - CGPathRef glyphPath; -+ CTFontRef ctFont; -+ int empty_path; - cairo_path_fixed_t *path; - - if (glyph == INVALID_GLYPH) { -@@ -606,19 +603,32 @@ - -font->base.scale.yy, - 0, 0); - -- glyphPath = CGFontGetGlyphPathPtr (font_face->cgFont, &textMatrix, 0, glyph); -- if (!glyphPath) -+ ctFont = CTFontCreateWithGraphicsFont (font_face->cgFont, 1.0, NULL, NULL); -+ glyphPath = CTFontCreatePathForGlyph (ctFont, glyph, &textMatrix); -+ empty_path = 0; -+ if (!glyphPath) { -+ /* an empty glyph path may just reflect whitespace; check bounding rects */ -+ CGRect r; -+ r = CTFontGetBoundingRectsForGlyphs(ctFont, kCTFontHorizontalOrientation, &glyph, NULL, 1); -+ if (memcmp(&CGRectNull, &r, sizeof(CGRect))) -+ empty_path = 1; -+ } -+ CFRelease (ctFont); -+ if (!glyphPath && !empty_path) - return CAIRO_INT_STATUS_UNSUPPORTED; - - path = _cairo_path_fixed_create (); - if (!path) { -- CGPathRelease (glyphPath); -+ if (glyphPath) -+ CGPathRelease (glyphPath); - return _cairo_error(CAIRO_STATUS_NO_MEMORY); - } - -- CGPathApply (glyphPath, path, _cairo_quartz_path_apply_func); -+ if (glyphPath) -+ CGPathApply (glyphPath, path, _cairo_quartz_path_apply_func); - -- CGPathRelease (glyphPath); -+ if (glyphPath) -+ CGPathRelease (glyphPath); - - _cairo_scaled_glyph_set_path (scaled_glyph, &font->base, path); - diff -Nru racket-6.12+ppa1/src/native-libs/patches/coretext.patch racket-7.0+ppa1/src/native-libs/patches/coretext.patch --- racket-6.12+ppa1/src/native-libs/patches/coretext.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/coretext.patch 2018-07-27 22:12:02.000000000 +0000 @@ -1,7 +1,23 @@ -diff -r -u old/pango-1.36.6/modules/basic/basic-coretext.c new/pango-1.36.6/modules/basic/basic-coretext.c ---- old/pango-1.36.6/modules/basic/basic-coretext.c 2014-08-16 07:15:21.000000000 -0600 -+++ new/pango-1.36.6/modules/basic/basic-coretext.c 2014-08-27 18:47:22.000000000 -0600 -@@ -56,7 +56,8 @@ +diff -u -r orig/pango-1.42.0/pango/pangocairo-coretextfont.c next/pango-1.42.0/pango/pangocairo-coretextfont.c +--- orig/pango-1.42.0/pango/pangocairo-coretextfont.c 2017-08-15 15:53:10.000000000 -0600 ++++ next/pango-1.42.0/pango/pangocairo-coretextfont.c 2018-03-28 21:15:02.000000000 -0600 +@@ -145,6 +145,12 @@ + metrics->strikethrough_position = metrics->ascent / 3; + metrics->strikethrough_thickness = CTFontGetUnderlineThickness (ctfont) * PANGO_SCALE; + ++ metrics->underline_position = -metrics->underline_position; ++ pango_quantize_line_geometry (&metrics->underline_thickness, ++ &metrics->underline_position); ++ metrics->underline_position = -(metrics->underline_position ++ + metrics->underline_thickness); ++ + layout = pango_layout_new (context); + font_desc = pango_font_describe_with_absolute_size ((PangoFont *) font); + pango_layout_set_font_description (layout, font_desc); +diff -u -r orig/pango-1.42.0/pango/pangocoretext-shape.c next/pango-1.42.0/pango/pangocoretext-shape.c +--- orig/pango-1.42.0/pango/pangocoretext-shape.c 2016-10-21 23:00:41.000000000 -0600 ++++ next/pango-1.42.0/pango/pangocoretext-shape.c 2018-03-28 21:22:58.000000000 -0600 +@@ -34,7 +34,8 @@ PangoGlyphString *glyphs, int i, int offset, @@ -11,7 +27,7 @@ { PangoRectangle logical_rect; -@@ -66,8 +67,13 @@ +@@ -44,8 +45,13 @@ glyphs->glyphs[i].geometry.y_offset = 0; glyphs->log_clusters[i] = offset; @@ -27,7 +43,7 @@ } -@@ -94,6 +100,8 @@ +@@ -74,6 +80,8 @@ CFIndex *current_indices; const CGGlyph *current_cgglyphs; CGGlyph *current_cgglyphs_buffer; @@ -36,7 +52,7 @@ CTRunStatus current_run_status; }; -@@ -106,6 +114,9 @@ +@@ -86,6 +94,9 @@ if (iter->current_cgglyphs_buffer) free (iter->current_cgglyphs_buffer); iter->current_cgglyphs_buffer = NULL; @@ -46,7 +62,7 @@ if (iter->current_indices) free (iter->current_indices); iter->current_indices = NULL; -@@ -133,6 +144,15 @@ +@@ -113,6 +124,15 @@ iter->current_cgglyphs = iter->current_cgglyphs_buffer; } @@ -62,26 +78,7 @@ iter->current_indices = malloc (sizeof (CFIndex) * ct_glyph_count); CTRunGetStringIndices (iter->current_run, CFRangeMake (0, ct_glyph_count), iter->current_indices); -@@ -179,7 +199,17 @@ - static gunichar - run_iterator_get_character (struct RunIterator *iter) - { -- return CFStringGetCharacterAtIndex (iter->cstr, iter->current_indices[iter->ct_i]); -+ gunichar c; -+ -+ c = CFStringGetCharacterAtIndex (iter->cstr, iter->current_indices[iter->ct_i]); -+ if ((c >= 0xD800) && (c <= 0xDFFF)) { -+ /* surrogate pair */ -+ gunichar c2; -+ c2 = CFStringGetCharacterAtIndex (iter->cstr, iter->current_indices[iter->ct_i]+1); -+ c = 0x10000 + (((c & 0x3FF) << 10) | (c2 & 0x3FF)); -+ } -+ -+ return c; - } - - static CGGlyph -@@ -188,6 +218,12 @@ +@@ -208,6 +228,12 @@ return iter->current_cgglyphs[iter->ct_i]; } @@ -94,15 +91,15 @@ static CFIndex run_iterator_get_index (struct RunIterator *iter) { -@@ -218,6 +254,7 @@ - iter->current_indices = NULL; +@@ -239,6 +265,7 @@ + iter->chr_idx_lut = NULL; iter->current_cgglyphs = NULL; iter->current_cgglyphs_buffer = NULL; + iter->current_cgadvs_buffer = NULL; /* Create CTLine */ attributes = CFDictionaryCreate (kCFAllocatorDefault, -@@ -311,6 +348,7 @@ +@@ -336,6 +363,7 @@ { CFIndex index; CGGlyph cgglyph; @@ -110,7 +107,7 @@ gunichar wc; }; -@@ -352,6 +390,7 @@ +@@ -377,6 +405,7 @@ gi = g_slice_new (struct GlyphInfo); gi->index = run_iterator_get_index (&riter); gi->cgglyph = run_iterator_get_cgglyph (&riter); @@ -118,16 +115,16 @@ gi->wc = run_iterator_get_character (&riter); glyph_list = g_slist_prepend (glyph_list, gi); -@@ -440,7 +479,7 @@ - if (gi == NULL || gi->index > gs_i) - { - /* gs_i is behind, insert empty glyph */ +@@ -466,7 +495,7 @@ + * up with the CoreText glyph list. This occurs for instance when + * CoreText inserts a ligature that covers two characters. + */ - set_glyph (font, glyphs, gs_i, p - text, PANGO_GLYPH_EMPTY); + set_glyph (font, glyphs, gs_i, p - text, PANGO_GLYPH_EMPTY, NULL); continue; } else if (gi->index < gs_i) -@@ -471,7 +510,7 @@ +@@ -502,7 +531,7 @@ if (result != PANGO_COVERAGE_NONE) { @@ -136,7 +133,7 @@ if (g_unichar_type (gi->wc) == G_UNICODE_NON_SPACING_MARK) { -@@ -494,7 +533,7 @@ +@@ -525,7 +554,7 @@ } } else @@ -145,64 +142,3 @@ glyph_iter = g_slist_next (glyph_iter); } -diff -r -u old/pango-1.36.6/pango/pangocairo-coretextfont.c new/pango-1.36.6/pango/pangocairo-coretextfont.c ---- old/pango-1.36.6/pango/pangocairo-coretextfont.c 2014-03-05 21:33:55.000000000 -0700 -+++ new/pango-1.36.6/pango/pangocairo-coretextfont.c 2014-08-27 18:13:16.000000000 -0600 -@@ -147,6 +147,12 @@ - metrics->strikethrough_position = metrics->ascent / 3; - metrics->strikethrough_thickness = CTFontGetUnderlineThickness (ctfont) * PANGO_SCALE; - -+ metrics->underline_position = -metrics->underline_position; -+ pango_quantize_line_geometry (&metrics->underline_thickness, -+ &metrics->underline_position); -+ metrics->underline_position = -(metrics->underline_position -+ + metrics->underline_thickness); -+ - layout = pango_layout_new (context); - font_desc = pango_font_describe_with_absolute_size ((PangoFont *) font); - pango_layout_set_font_description (layout, font_desc); -diff -r -u old/pango-1.36.6/pango/pangocairo-coretextfontmap.c new/pango-1.36.6/pango/pangocairo-coretextfontmap.c ---- old/pango-1.36.6/pango/pangocairo-coretextfontmap.c 2014-03-05 21:33:55.000000000 -0700 -+++ new/pango-1.36.6/pango/pangocairo-coretextfontmap.c 2014-08-27 18:13:16.000000000 -0600 -@@ -186,5 +186,5 @@ - pango_cairo_core_text_font_map_init (PangoCairoCoreTextFontMap *cafontmap) - { - cafontmap->serial = 1; -- cafontmap->dpi = 96.; -+ cafontmap->dpi = 72.; - } -diff -r -u old/pango-1.36.6/pango/pangocoretext-fontmap.c new/pango-1.36.6/pango/pangocoretext-fontmap.c ---- old/pango-1.36.6/pango/pangocoretext-fontmap.c 2014-08-01 00:49:36.000000000 -0600 -+++ new/pango-1.36.6/pango/pangocoretext-fontmap.c 2014-08-27 18:13:16.000000000 -0600 -@@ -298,7 +298,8 @@ - cf_number = (CFNumberRef)CFDictionaryGetValue (dict, - kCTFontWeightTrait); - -- if (CFNumberGetValue (cf_number, kCFNumberCGFloatType, &value)) -+ weight = PANGO_WEIGHT_NORMAL; -+ if (cf_number && CFNumberGetValue (cf_number, kCFNumberCGFloatType, &value)) - { - if (value < ct_weight_min || value > ct_weight_max) - { -@@ -317,8 +318,6 @@ - } - } - } -- else -- weight = PANGO_WEIGHT_NORMAL; - - CFRelease (dict); - -diff -r -u old/pango-1.36.6/pango/pangocoretext.c new/pango-1.36.6/pango/pangocoretext.c ---- old/pango-1.36.6/pango/pangocoretext.c 2014-03-05 21:33:55.000000000 -0700 -+++ new/pango-1.36.6/pango/pangocoretext.c 2014-08-27 18:13:16.000000000 -0600 -@@ -97,8 +97,7 @@ - bitmap = CFCharacterSetCreateBitmapRepresentation (kCFAllocatorDefault, - charset); - -- /* We only handle the BMP plane */ -- length = MIN (CFDataGetLength (bitmap), 8192); -+ length = CFDataGetLength (bitmap); - ptr = CFDataGetBytePtr (bitmap); - - /* FIXME: can and should this be done more efficiently? */ diff -Nru racket-6.12+ppa1/src/native-libs/patches/fcdirs.patch racket-7.0+ppa1/src/native-libs/patches/fcdirs.patch --- racket-6.12+ppa1/src/native-libs/patches/fcdirs.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/fcdirs.patch 2018-07-27 22:12:02.000000000 +0000 @@ -1,8 +1,8 @@ -diff -u -r old/fontconfig-2.11.1/fontconfig/fontconfig.h new/fontconfig-2.11.1/fontconfig/fontconfig.h ---- old/fontconfig-2.11.1/fontconfig/fontconfig.h 2014-10-07 06:54:53.000000000 -0600 -+++ new/fontconfig-2.11.1/fontconfig/fontconfig.h 2014-10-07 17:44:20.000000000 -0600 -@@ -342,6 +342,9 @@ - FcCacheCreateTagFile (const FcConfig *config); +diff -u -r orig/fontconfig-2.13.0/fontconfig/fontconfig.h next/fontconfig-2.13.0/fontconfig/fontconfig.h +--- orig/fontconfig-2.13.0/fontconfig/fontconfig.h 2018-03-05 20:31:12.000000000 -0700 ++++ next/fontconfig-2.13.0/fontconfig/fontconfig.h 2018-03-28 20:11:52.000000000 -0600 +@@ -377,6 +377,9 @@ + FcConfig *config); /* fccfg.c */ +FcPublic void @@ -11,7 +11,7 @@ FcPublic FcChar8 * FcConfigHome (void); -@@ -582,6 +585,9 @@ +@@ -635,6 +638,9 @@ FcPublic void FcFini (void); @@ -21,11 +21,11 @@ FcPublic int FcGetVersion (void); -Only in new/fontconfig-2.11.1/fontconfig: fontconfig.h~ -diff -u -r old/fontconfig-2.11.1/src/fccfg.c new/fontconfig-2.11.1/src/fccfg.c ---- old/fontconfig-2.11.1/src/fccfg.c 2014-10-07 06:54:53.000000000 -0600 -+++ new/fontconfig-2.11.1/src/fccfg.c 2014-10-07 17:44:11.000000000 -0600 -@@ -1834,6 +1834,22 @@ +Only in next/fontconfig-2.13.0/fontconfig: fontconfig.h.orig +diff -u -r orig/fontconfig-2.13.0/src/fccfg.c next/fontconfig-2.13.0/src/fccfg.c +--- orig/fontconfig-2.13.0/src/fccfg.c 2018-02-04 04:01:46.000000000 -0700 ++++ next/fontconfig-2.13.0/src/fccfg.c 2018-03-28 20:11:52.000000000 -0600 +@@ -1914,6 +1914,22 @@ #define FONTCONFIG_FILE "fonts.conf" #endif @@ -48,7 +48,7 @@ static FcChar8 * FcConfigFileExists (const FcChar8 *dir, const FcChar8 *file) { -@@ -1935,7 +1951,7 @@ +@@ -2015,7 +2031,7 @@ strcat ((char *) fontconfig_path, "\\fonts"); } #endif @@ -57,11 +57,11 @@ path[i] = malloc (strlen ((char *) dir) + 1); if (!path[i]) goto bail1; -Only in new/fontconfig-2.11.1/src: fccfg.c~ -diff -u -r old/fontconfig-2.11.1/src/fcinit.c new/fontconfig-2.11.1/src/fcinit.c ---- old/fontconfig-2.11.1/src/fcinit.c 2014-10-07 06:54:53.000000000 -0600 -+++ new/fontconfig-2.11.1/src/fcinit.c 2014-10-07 17:43:44.000000000 -0600 -@@ -35,6 +35,26 @@ +Only in next/fontconfig-2.13.0/src: fccfg.c.orig +diff -u -r orig/fontconfig-2.13.0/src/fcinit.c next/fontconfig-2.13.0/src/fcinit.c +--- orig/fontconfig-2.13.0/src/fcinit.c 2018-02-04 21:28:01.000000000 -0700 ++++ next/fontconfig-2.13.0/src/fcinit.c 2018-03-28 20:15:42.000000000 -0600 +@@ -35,25 +35,52 @@ #pragma message("To suppress these warnings, define FC_NO_MT.") #endif @@ -86,29 +86,43 @@ +} + static FcConfig * - FcInitFallbackConfig (void) + FcInitFallbackConfig (const FcChar8 *sysroot) { -@@ -43,9 +63,13 @@ + FcConfig *config; + const FcChar8 *fallback = (const FcChar8 *) "" \ + "" \ +- " " FC_DEFAULT_FONTS "" \ ++ " " "%s" "" \ + " fonts" \ +- " " FC_CACHEDIR "" \ ++ " " "%s" "" \ + " fontconfig" \ + " fontconfig/conf.d" \ + " fontconfig/fonts.conf" \ + ""; ++ const char *default_fonts, *cache_dir, *fallback_s; ++ ++ default_fonts = (fc_default_fonts ? fc_default_fonts : (const FcChar8 *)FC_DEFAULT_FONTS); ++ cache_dir = (fc_cachedir ? fc_cachedir : (const FcChar8 *)FC_CACHEDIR); ++ ++ fallback_s = malloc(strlen(fallback) + strlen(default_fonts) + strlen(cache_dir) + 1); ++ sprintf(fallback_s, fallback, default_fonts, cache_dir); + config = FcConfigCreate (); if (!config) goto bail0; -- if (!FcConfigAddDir (config, (FcChar8 *) FC_DEFAULT_FONTS)) -+ if (!FcConfigAddDir (config, (fc_default_fonts -+ ? fc_default_fonts -+ : (const FcChar8 *)FC_DEFAULT_FONTS))) + FcConfigSetSysRoot (config, sysroot); +- if (!FcConfigParseAndLoadFromMemory (config, fallback, FcFalse)) ++ if (!FcConfigParseAndLoadFromMemory (config, fallback_s, FcFalse)) goto bail1; -- if (!FcConfigAddCacheDir (config, (FcChar8 *) FC_CACHEDIR)) -+ if (!FcConfigAddCacheDir (config, (fc_cachedir -+ ? fc_cachedir -+ : (const FcChar8 *)FC_CACHEDIR))) - goto bail1; - return config; -Only in new/fontconfig-2.11.1/src: fcinit.c~ -diff -u -r old/fontconfig-2.11.1/src/fcint.h new/fontconfig-2.11.1/src/fcint.h ---- old/fontconfig-2.11.1/src/fcint.h 2014-10-07 06:54:53.000000000 -0600 -+++ new/fontconfig-2.11.1/src/fcint.h 2014-10-07 09:42:02.000000000 -0600 -@@ -605,6 +605,9 @@ + return config; +Only in next/fontconfig-2.13.0/src: fcinit.c.orig +Only in next/fontconfig-2.13.0/src: fcinit.c.rej +diff -u -r orig/fontconfig-2.13.0/src/fcint.h next/fontconfig-2.13.0/src/fcint.h +--- orig/fontconfig-2.13.0/src/fcint.h 2018-02-04 03:20:56.000000000 -0700 ++++ next/fontconfig-2.13.0/src/fcint.h 2018-03-28 20:11:52.000000000 -0600 +@@ -647,6 +647,9 @@ FcPrivate FcChar8 * FcConfigXdgDataHome (void); @@ -118,7 +132,7 @@ FcPrivate FcExpr * FcConfigAllocExpr (FcConfig *config); -@@ -806,6 +809,9 @@ +@@ -878,6 +881,9 @@ FcPrivate void FcDefaultFini (void); @@ -128,19 +142,24 @@ /* fcdir.c */ FcPrivate FcBool -Only in new/fontconfig-2.11.1/src: fcint.h~ -diff -u -r old/fontconfig-2.11.1/src/fcxml.c new/fontconfig-2.11.1/src/fcxml.c ---- old/fontconfig-2.11.1/src/fcxml.c 2014-10-07 06:54:53.000000000 -0600 -+++ new/fontconfig-2.11.1/src/fcxml.c 2014-10-07 09:42:42.000000000 -0600 -@@ -1997,6 +1997,10 @@ - attr = FcConfigGetAttribute (parse, "prefix"); - if (attr && FcStrCmp (attr, (const FcChar8 *)"xdg") == 0) - prefix = FcConfigXdgDataHome (); -+ if (attr && FcStrCmp (attr, (const FcChar8 *)"cfg") == 0) -+ prefix = FcConfigDir (); -+ if (attr && FcStrCmp (attr, (const FcChar8 *)"cache") == 0) -+ prefix = FcFallbackCacheDir (); +Only in next/fontconfig-2.13.0/src: fcint.h.orig +diff -u -r orig/fontconfig-2.13.0/src/fcxml.c next/fontconfig-2.13.0/src/fcxml.c +--- orig/fontconfig-2.13.0/src/fcxml.c 2018-02-04 04:01:55.000000000 -0700 ++++ next/fontconfig-2.13.0/src/fcxml.c 2018-03-28 20:16:52.000000000 -0600 +@@ -2080,6 +2080,14 @@ + if (!prefix) + goto bail; + } ++ if (attr && FcStrCmp (attr, (const FcChar8 *)"cfg") == 0) { ++ prefix = FcConfigDir (); ++ if (!prefix) goto bail; ++ } ++ if (attr && FcStrCmp (attr, (const FcChar8 *)"cache") == 0) { ++ prefix = FcFallbackCacheDir (); ++ if (!prefix) goto bail; ++ } data = FcStrBufDoneStatic (&parse->pstack->str); if (!data) { -Only in new/fontconfig-2.11.1/src: fcxml.c~ +Only in next/fontconfig-2.13.0/src: fcxml.c.orig +Only in next/fontconfig-2.13.0/src: fcxml.c.rej diff -Nru racket-6.12+ppa1/src/native-libs/patches/fixdef.patch racket-7.0+ppa1/src/native-libs/patches/fixdef.patch --- racket-6.12+ppa1/src/native-libs/patches/fixdef.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/fixdef.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -diff -r -u old/harfbuzz-0.9.27/src/Makefile.in new/harfbuzz-0.9.27/src/Makefile.in ---- old/harfbuzz-0.9.27/src/Makefile.in 2014-03-31 09:23:00.000000000 -0600 -+++ new/harfbuzz-0.9.27/src/Makefile.in 2014-03-31 09:23:27.000000000 -0600 -@@ -2234,7 +2234,7 @@ - "$<" \ - > "$@.tmp" && mv "$@.tmp" "$@" || ( $(RM) "$@.tmp"; false ) - harfbuzz.def: $(HBHEADERS) $(HBNODISTHEADERS) -- $(AM_V_GEN) (echo EXPORTS; \ -+ $(AM_V_GEN) ( \ - (cat $^ || echo 'hb_ERROR ()' ) | \ - $(EGREP) '^hb_.* \(' | \ - sed -e 's/ (.*//' | \ diff -Nru racket-6.12+ppa1/src/native-libs/patches/gcocoanotify.patch racket-7.0+ppa1/src/native-libs/patches/gcocoanotify.patch --- racket-6.12+ppa1/src/native-libs/patches/gcocoanotify.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/gcocoanotify.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,65 @@ +diff -u -r old/glib-2.56.0/gio/gcocoanotificationbackend.c new/glib-2.56.0/gio/gcocoanotificationbackend.c +--- old/glib-2.56.0/gio/gcocoanotificationbackend.c 2017-07-13 17:03:38.000000000 -0600 ++++ new/glib-2.56.0/gio/gcocoanotificationbackend.c 2018-03-28 18:57:37.000000000 -0600 +@@ -104,6 +104,7 @@ + } + } + ++#if 0 + @interface GNotificationCenterDelegate : NSObject @end + @implementation GNotificationCenterDelegate + +@@ -130,6 +131,7 @@ + @end + + static GNotificationCenterDelegate *cocoa_notification_delegate; ++#endif + + static gboolean + g_cocoa_notification_backend_is_supported (void) +@@ -143,6 +145,7 @@ + return TRUE; + } + ++#if 0 + static void + add_actions_to_notification (NSUserNotification *userNotification, + GNotification *notification) +@@ -196,12 +199,14 @@ + userNotification.userInfo = user_info; + [user_info release]; + } ++#endif + + static void + g_cocoa_notification_backend_send_notification (GNotificationBackend *backend, + const gchar *cstr_id, + GNotification *notification) + { ++#if 0 + NSString *str_title = nil, *str_text = nil, *str_id = nil; + NSImage *content = nil; + const char *cstr; +@@ -239,12 +244,14 @@ + [str_id release]; + [content release]; + [userNotification release]; ++#endif + } + + static void + g_cocoa_notification_backend_withdraw_notification (GNotificationBackend *backend, + const gchar *cstr_id) + { ++#if 0 + NSUserNotificationCenter *center = [NSUserNotificationCenter defaultUserNotificationCenter]; + NSArray *notifications = [center deliveredNotifications]; + NSString *str_id = nsstring_from_cstr (cstr_id); +@@ -260,6 +267,7 @@ + + [notifications release]; + [str_id release]; ++#endif + } + + static void diff -Nru racket-6.12+ppa1/src/native-libs/patches/glib-strerror.patch racket-7.0+ppa1/src/native-libs/patches/glib-strerror.patch --- racket-6.12+ppa1/src/native-libs/patches/glib-strerror.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/glib-strerror.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,50 @@ +diff -r -u orig/glib-2.56.0/glib/gstrfuncs.c next/glib-2.56.0/glib/gstrfuncs.c +--- orig/glib-2.56.0/glib/gstrfuncs.c 2018-01-08 13:34:19.000000000 -0800 ++++ next/glib-2.56.0/glib/gstrfuncs.c 2018-03-31 08:48:02.000000000 -0700 +@@ -1233,6 +1233,13 @@ + #endif + } + ++#if defined(G_OS_WIN32) ++# ifdef _WIN64 ++# define RKT_G_OS_WIN32 ++errno_t strerror_s(char *buffer, size_t numberOfElements, int errnum); ++# endif ++#endif ++ + /** + * g_strerror: + * @errnum: the system error number. See the standard C %errno +@@ -1282,7 +1289,7 @@ + gchar buf[1024]; + GError *error = NULL; + +-#if defined(G_OS_WIN32) ++#if defined(RKT_G_OS_WIN32) + strerror_s (buf, sizeof (buf), errnum); + msg = buf; + #elif defined(HAVE_STRERROR_R) +diff -r -u orig/glib-2.56.0/gmodule/gmodule-win32.c next/glib-2.56.0/gmodule/gmodule-win32.c +--- orig/glib-2.56.0/gmodule/gmodule-win32.c 2018-01-08 13:34:19.000000000 -0800 ++++ next/glib-2.56.0/gmodule/gmodule-win32.c 2018-03-31 08:57:49.000000000 -0700 +@@ -62,6 +62,20 @@ + g_free (error); + } + ++#ifdef _WIN64 ++BOOL SetThreadErrorMode(DWORD dwNewMode, LPDWORD lpOldMode); ++#else ++/* SetThreadErrorMode is not in XP */ ++# define SetThreadErrorMode rktSetThreadErrorMode ++static BOOL rktSetThreadErrorMode(DWORD dwNewMode, LPDWORD lpOldMode) ++{ ++ if (lpOldMode) ++ *lpOldMode = GetErrorMode(); ++ return SetErrorMode(dwNewMode); ++} ++#endif ++ ++ + /* --- functions --- */ + static gpointer + _g_module_open (const gchar *file_name, diff -Nru racket-6.12+ppa1/src/native-libs/patches/glib-win32-weekday.patch racket-7.0+ppa1/src/native-libs/patches/glib-win32-weekday.patch --- racket-6.12+ppa1/src/native-libs/patches/glib-win32-weekday.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/glib-win32-weekday.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +diff --git x/a/glib/gdatetime.c y/b/glib/gdatetime.c +index 2eda466..ba85038 100644 +--- x/a/glib/gdatetime.c ++++ y/b/glib/gdatetime.c +@@ -224,6 +224,7 @@ static const gint month_item[2][12] = + #define WEEKDAY_ABBR(d) (get_weekday_name_abbr (g_date_time_get_day_of_week (d))) + #define WEEKDAY_ABBR_IS_LOCALE FALSE + #define WEEKDAY_FULL(d) (get_weekday_name (g_date_time_get_day_of_week (d))) ++#define WEEKDAY_FULL_IS_LOCALE FALSE + /* We don't yet know if nl_langinfo (MON_n) returns standalone or complete-date + * format forms but if nl_langinfo (ALTMON_n) is not supported then we will + * have to use MONTH_FULL as standalone. The same if nl_langinfo () does not diff -Nru racket-6.12+ppa1/src/native-libs/patches/gmp-inline.patch racket-7.0+ppa1/src/native-libs/patches/gmp-inline.patch --- racket-6.12+ppa1/src/native-libs/patches/gmp-inline.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/gmp-inline.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,34 @@ +diff -r -u orig/gmp/gmp.h next/gmp/gmp.h +--- orig/gmp/gmp.h 2018-04-15 10:52:05.000000000 -0600 ++++ next/gmp/gmp.h 2018-04-15 10:50:19.000000000 -0600 +@@ -129,7 +129,6 @@ + #define __GMP_DECLSPEC + #endif + +- + #ifdef __GMP_SHORT_LIMB + typedef unsigned int mp_limb_t; + typedef int mp_limb_signed_t; +@@ -361,7 +360,7 @@ + || (defined __GNUC_GNU_INLINE__ && defined __cplusplus) + #define __GMP_EXTERN_INLINE extern __inline__ __attribute__ ((__gnu_inline__)) + #else +-#define __GMP_EXTERN_INLINE extern __inline__ ++#define __GMP_EXTERN_INLINE static inline + #endif + #define __GMP_INLINE_PROTOTYPES 1 + #endif +@@ -616,9 +615,12 @@ + #define mpz_realloc __gmpz_realloc + __GMP_DECLSPEC void *_mpz_realloc (mpz_ptr, mp_size_t); + ++#undef __GMP_INLINE_PROTOTYPES ++#define __GMP_INLINE_PROTOTYPES 0 ++ + #define mpz_abs __gmpz_abs + #if __GMP_INLINE_PROTOTYPES || defined (__GMP_FORCE_mpz_abs) +-__GMP_DECLSPEC void mpz_abs (mpz_ptr, mpz_srcptr); ++ __GMP_DECLSPEC void mpz_abs (mpz_ptr, mpz_srcptr); + #endif + + #define mpz_add __gmpz_add diff -Nru racket-6.12+ppa1/src/native-libs/patches/harfbuzz-oldcompiler.patch racket-7.0+ppa1/src/native-libs/patches/harfbuzz-oldcompiler.patch --- racket-6.12+ppa1/src/native-libs/patches/harfbuzz-oldcompiler.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/harfbuzz-oldcompiler.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,88 @@ +diff -u -r orig/harfbuzz-1.7.6/src/hb-ot-color-cbdt-table.hh next/harfbuzz-1.7.6/src/hb-ot-color-cbdt-table.hh +--- orig/harfbuzz-1.7.6/src/hb-ot-color-cbdt-table.hh 2018-03-07 01:25:16.000000000 -0700 ++++ next/harfbuzz-1.7.6/src/hb-ot-color-cbdt-table.hh 2018-04-15 08:12:47.000000000 -0600 +@@ -327,7 +327,7 @@ + sizeTables.sanitize (c, this)); + } + +- protected: ++ public: + const IndexSubtableRecord *find_table (hb_codepoint_t glyph, + unsigned int *x_ppem, unsigned int *y_ppem) const + { +diff -u -r orig/harfbuzz-1.7.6/src/hb-ot-font.cc next/harfbuzz-1.7.6/src/hb-ot-font.cc +--- orig/harfbuzz-1.7.6/src/hb-ot-font.cc 2018-03-07 01:25:16.000000000 -0700 ++++ next/harfbuzz-1.7.6/src/hb-ot-font.cc 2018-04-15 08:12:45.000000000 -0600 +@@ -38,6 +38,8 @@ + + #include "hb-ot-color-cbdt-table.hh" + ++const unsigned int OT::KernOT::SubTableWrapper::min_size; ++const unsigned int OT::KernAAT::SubTableWrapper::min_size; + + struct hb_ot_font_t + { +diff -u -r orig/harfbuzz-1.7.6/src/hb-ot-glyf-table.hh next/harfbuzz-1.7.6/src/hb-ot-glyf-table.hh +--- orig/harfbuzz-1.7.6/src/hb-ot-glyf-table.hh 2018-03-07 01:25:16.000000000 -0700 ++++ next/harfbuzz-1.7.6/src/hb-ot-glyf-table.hh 2018-04-15 08:12:47.000000000 -0600 +@@ -55,7 +55,7 @@ + return_trace (true); + } + +- protected: ++ public: + HBUINT8 dataX[VAR]; /* Location data. */ + DEFINE_SIZE_ARRAY (0, dataX); + }; +diff -u -r orig/harfbuzz-1.7.6/src/hb-private.hh next/harfbuzz-1.7.6/src/hb-private.hh +--- orig/harfbuzz-1.7.6/src/hb-private.hh 2018-02-18 12:36:12.000000000 -0700 ++++ next/harfbuzz-1.7.6/src/hb-private.hh 2018-04-15 08:12:47.000000000 -0600 +@@ -327,7 +327,7 @@ + static inline HB_CONST_FUNC unsigned int + _hb_popcount (T v) + { +-#if (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)) && defined(__OPTIMIZE__) ++#if 0 && (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)) && defined(__OPTIMIZE__) + if (sizeof (T) <= sizeof (unsigned int)) + return __builtin_popcount (v); + +@@ -414,7 +414,7 @@ + if (sizeof (T) <= 8) + { + /* "bithacks" */ +- const uint64_t b[] = {0x2, 0xC, 0xF0, 0xFF00, 0xFFFF0000, 0xFFFFFFFF00000000}; ++ const uint64_t b[] = {0x2, 0xC, 0xF0, 0xFF00, 0xFFFF0000, 0xFFFFFFFF00000000ULL}; + const unsigned int S[] = {1, 2, 4, 8, 16, 32}; + unsigned int r = 0; + for (int i = 5; i >= 0; i--) +@@ -489,12 +489,12 @@ + unsigned int c = 64; + v &= - (int64_t) (v); + if (v) c--; +- if (v & 0x00000000FFFFFFFF) c -= 32; +- if (v & 0x0000FFFF0000FFFF) c -= 16; +- if (v & 0x00FF00FF00FF00FF) c -= 8; +- if (v & 0x0F0F0F0F0F0F0F0F) c -= 4; +- if (v & 0x3333333333333333) c -= 2; +- if (v & 0x5555555555555555) c -= 1; ++ if (v & 0x00000000FFFFFFFFULL) c -= 32; ++ if (v & 0x0000FFFF0000FFFFULL) c -= 16; ++ if (v & 0x00FF00FF00FF00FFULL) c -= 8; ++ if (v & 0x0F0F0F0F0F0F0F0FULL) c -= 4; ++ if (v & 0x3333333333333333ULL) c -= 2; ++ if (v & 0x5555555555555555ULL) c -= 1; + return c; + } + if (sizeof (T) == 16) +diff -u -r orig/harfbuzz-1.7.6/src/hb-subset.cc next/harfbuzz-1.7.6/src/hb-subset.cc +--- orig/harfbuzz-1.7.6/src/hb-subset.cc 2018-02-27 11:50:36.000000000 -0700 ++++ next/harfbuzz-1.7.6/src/hb-subset.cc 2018-04-15 08:12:45.000000000 -0600 +@@ -42,6 +42,8 @@ + #include "hb-ot-maxp-table.hh" + #include "hb-ot-os2-table.hh" + ++const hb_tag_t OT::OpenTypeFontFile::CFFTag; ++const hb_tag_t OT::OpenTypeFontFile::TrueTypeTag; + + #ifndef HB_NO_VISIBILITY + const void * const OT::_hb_NullPool[HB_NULL_POOL_SIZE / sizeof (void *)] = {}; diff -Nru racket-6.12+ppa1/src/native-libs/patches/libtool64-link.patch racket-7.0+ppa1/src/native-libs/patches/libtool64-link.patch --- racket-6.12+ppa1/src/native-libs/patches/libtool64-link.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/libtool64-link.patch 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ -diff -r -u old/poppler-0.24.5/libtool new/poppler-0.24.5/libtool ---- old/poppler-0.24.5/libtool 2014-04-04 16:45:38.000000000 -0600 -+++ new/poppler-0.24.5/libtool 2014-04-04 16:46:07.000000000 -0600 +diff -r -u orig/poppler-0.24.5/libtool next/poppler-0.24.5/libtool +--- orig/poppler-0.24.5/libtool 2018-04-04 09:51:15.000000000 -0600 ++++ next/poppler-0.24.5/libtool 2018-04-04 09:53:17.000000000 -0600 @@ -10167,14 +10167,14 @@ old_archive_from_expsyms_cmds="" @@ -22,8 +22,8 @@ # Dependencies to place before and after the objects being linked to # create a shared library. --predep_objects="/usr/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/dllcrt2.o /usr/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/crtbegin.o" --postdep_objects="/usr/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/crtend.o" +-predep_objects="/usr/local/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/dllcrt2.o /usr/local/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/crtbegin.o" +-postdep_objects="/usr/local/mw64/bin/../lib/gcc/x86_64-w64-mingw32/4.9.0/../../../../x86_64-w64-mingw32/lib/../lib/crtend.o" +predep_objects="" +postdep_objects="" predeps="" diff -Nru racket-6.12+ppa1/src/native-libs/patches/libtool-link.patch racket-7.0+ppa1/src/native-libs/patches/libtool-link.patch --- racket-6.12+ppa1/src/native-libs/patches/libtool-link.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/libtool-link.patch 2018-07-27 22:12:02.000000000 +0000 @@ -22,8 +22,8 @@ # Dependencies to place before and after the objects being linked to # create a shared library. --predep_objects="/usr/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/../../../../i686-w64-mingw32/lib/../lib/dllcrt2.o /usr/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/crtbegin.o" --postdep_objects="/usr/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/crtend.o" +-predep_objects="/usr/local/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/../../../../i686-w64-mingw32/lib/../lib/dllcrt2.o /usr/local/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/crtbegin.o" +-postdep_objects="/usr/local/mw32/bin/../lib/gcc/i686-w64-mingw32/4.9.0/crtend.o" +predep_objects="" +postdep_objects="" predeps="" diff -Nru racket-6.12+ppa1/src/native-libs/patches/pango-emoji.patch racket-7.0+ppa1/src/native-libs/patches/pango-emoji.patch --- racket-6.12+ppa1/src/native-libs/patches/pango-emoji.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/pango-emoji.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +diff -u -r orig/pango-1.42.0/pango/pango-context.c next/pango-1.42.0/pango/pango-context.c +--- orig/pango-1.42.0/pango/pango-context.c 2017-08-12 17:40:19.000000000 -0500 ++++ next/pango-1.42.0/pango/pango-context.c 2018-04-04 19:24:05.000000000 -0500 +@@ -1388,7 +1388,7 @@ + + if (!state->current_fonts) + { +- gboolean is_emoji = state->emoji_iter.is_emoji; ++ gboolean is_emoji = 0; // state->emoji_iter.is_emoji; + if (is_emoji && !state->emoji_font_desc) + { + state->emoji_font_desc = pango_font_description_copy_static (state->font_desc); diff -Nru racket-6.12+ppa1/src/native-libs/patches/pango-surrogate.patch racket-7.0+ppa1/src/native-libs/patches/pango-surrogate.patch --- racket-6.12+ppa1/src/native-libs/patches/pango-surrogate.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/pango-surrogate.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,25 @@ +diff -r -u orig/pango-1.42.0/pango/pangocoretext-shape.c next/pango-1.42.0/pango/pangocoretext-shape.c +--- orig/pango-1.42.0/pango/pangocoretext-shape.c 2016-10-22 00:00:41.000000000 -0500 ++++ next/pango-1.42.0/pango/pangocoretext-shape.c 2018-04-04 20:07:01.000000000 -0500 +@@ -132,6 +132,21 @@ + return accumulator; + } + ++static gunichar CFStringGetLongCharacterForSurrogatePair(UniChar c, UniChar c2) ++{ ++ return 0x10000 + (((c & 0x3FF) << 10) | (c2 & 0x3FF)); ++} ++ ++static int CFStringIsSurrogateHighCharacter(UniChar c) ++{ ++ return ((c >= 0xD800) && (c <= 0xDBFF)); ++} ++ ++static int CFStringIsSurrogateLowCharacter(UniChar c) ++{ ++ return ((c >= 0xDC00) && (c <= 0xDFFF)); ++} ++ + /* This function generates a lookup table to match string indices of glyphs to + * actual unicode character indices. This also takes unicode characters into + * account that are encoded using 2 UTF16 code points in CFStrings. We use the diff -Nru racket-6.12+ppa1/src/native-libs/patches/pixman-altivec.patch racket-7.0+ppa1/src/native-libs/patches/pixman-altivec.patch --- racket-6.12+ppa1/src/native-libs/patches/pixman-altivec.patch 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/pixman-altivec.patch 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,18 @@ +diff -r -u orig/pixman-0.34.0/pixman/pixman-vmx.c next/pixman-0.34.0/pixman/pixman-vmx.c +--- orig/pixman-0.34.0/pixman/pixman-vmx.c 2016-01-04 02:13:54.000000000 -0700 ++++ next/pixman-0.34.0/pixman/pixman-vmx.c 2018-04-15 06:43:36.000000000 -0600 +@@ -2933,10 +2933,10 @@ + while (vx >= 0) + vx -= src_width_fixed; + +- tmp[0] = tmp1; +- tmp[1] = tmp2; +- tmp[2] = tmp3; +- tmp[3] = tmp4; ++ ((unsigned int *)&tmp)[0] = tmp1; ++ ((unsigned int *)&tmp)[1] = tmp2; ++ ((unsigned int *)&tmp)[2] = tmp3; ++ ((unsigned int *)&tmp)[3] = tmp4; + + vsrc = combine4 ((const uint32_t *) &tmp, pm); + diff -Nru racket-6.12+ppa1/src/native-libs/patches/rand.patch racket-7.0+ppa1/src/native-libs/patches/rand.patch --- racket-6.12+ppa1/src/native-libs/patches/rand.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/rand.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -diff -u -r old/glib-2.39.92/glib/grand.c new/glib-2.39.92/glib/grand.c ---- old/glib-2.39.92/glib/grand.c 2014-03-31 08:42:11.000000000 -0600 -+++ new/glib-2.39.92/glib/grand.c 2014-03-31 08:42:56.000000000 -0600 -@@ -264,7 +264,7 @@ - gint i; - - for (i = 0; i < G_N_ELEMENTS (seed); i++) -- rand_s (&seed[i]); -+ seed[i] = rand(); - #endif - - return g_rand_new_with_seed_array (seed, 4); - diff -Nru racket-6.12+ppa1/src/native-libs/patches/win32cairofallback.patch racket-7.0+ppa1/src/native-libs/patches/win32cairofallback.patch --- racket-6.12+ppa1/src/native-libs/patches/win32cairofallback.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/win32cairofallback.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -From 844455c14f8e9e4767fd661e475a9c6fdea9d22e Mon Sep 17 00:00:00 2001 -From: Massimo Valentini -Date: Wed, 11 Sep 2013 18:10:38 +0200 -Subject: [PATCH] Bug 53121 - My program runs successfully with... - -Cairo-1.10.2, but getting SIGSEGV with 1.12.2. ---- - src/win32/cairo-win32-display-surface.c | 8 ++++---- - 1 files changed, 4 insertions(+), 4 deletions(-) - -diff --git a/src/win32/cairo-win32-display-surface.c b/src/win32/cairo-win32-display-surface.c -index 5ecdbee..965f2c4 100644 ---- a/cairo/src/win32/cairo-win32-display-surface.c -+++ b/cairo/src/win32/cairo-win32-display-surface.c -@@ -455,17 +455,17 @@ _cairo_win32_display_surface_map_to_image (void *abstract_sur - surface->fallback = - _cairo_win32_display_surface_create_for_dc (surface->win32.dc, - surface->win32.format, -- surface->win32.extents.width, -- surface->win32.extents.height); -+ surface->win32.extents.x + surface->win32.extents.width, -+ surface->win32.extents.y + surface->win32.extents.height); - if (unlikely (status = surface->fallback->status)) - goto err; - - if (!BitBlt (to_win32_surface(surface->fallback)->dc, -- 0, 0, -+ surface->win32.extents.x, surface->win32.extents.y, - surface->win32.extents.width, - surface->win32.extents.height, - surface->win32.dc, -- 0, 0, -+ surface->win32.extents.x, surface->win32.extents.y, - SRCCOPY)) { - status = _cairo_error (CAIRO_STATUS_DEVICE_ERROR); - goto err; --- -1.7.6.5 diff -Nru racket-6.12+ppa1/src/native-libs/patches/win32text.patch racket-7.0+ppa1/src/native-libs/patches/win32text.patch --- racket-6.12+ppa1/src/native-libs/patches/win32text.patch 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/patches/win32text.patch 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,6 @@ -diff -r -u old/pango-1.36.3/modules/basic/basic-win32.c new/pango-1.36.3/modules/basic/basic-win32.c ---- old/pango-1.36.3/modules/basic/basic-win32.c 2014-04-01 09:45:50.000000000 -0600 -+++ new/pango-1.36.3/modules/basic/basic-win32.c 2014-04-01 09:49:32.000000000 -0600 +diff -r -u old/pango-1.36.3/pango/pangowin32-shape.c new/pango-1.36.3/pango/pangowin32-shape.c +--- old/pango-1.36.3/pango/pangowin32-shape.c 2014-04-01 09:45:50.000000000 -0600 ++++ new/pango-1.36.3/pango/pangowin32-shape.c 2014-04-01 09:49:32.000000000 -0600 @@ -468,7 +468,7 @@ g_print (G_STRLOC ": ScriptItemize: uDefaultLanguage:%04x uBidiLevel:%d\n", control.uDefaultLanguage, state.uBidiLevel); diff -Nru racket-6.12+ppa1/src/native-libs/README.txt racket-7.0+ppa1/src/native-libs/README.txt --- racket-6.12+ppa1/src/native-libs/README.txt 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/native-libs/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,4 @@ -The core `racket' executable has minimal library dependencies. In +The core `racket` executable has minimal library dependencies. In contrast, libraries implemented in various packages, such as the "draw" or "math" packages, rely on additional C-implemented libraries, such as Cairo, GMP, etc., all of which are loaded dynamically. On Unix @@ -16,26 +16,28 @@ Currently, we use the following external packages and versions: pkg-config-0.28 - sed-4.2 (Windows only, to avoid non-GNU `sed') - sqlite[-autoconf]-3210000 (Windows and Linux only) - openssl-1.0.2k (current PPC binaries are 1.0.1g) - libiconv-1.14 (Windows only) - zlib-1.2.8 (Windows and Linux only) - libffi-3.0.13 - expat-2.1.0 - gettext-0.18.3.2 - glib-2.39.92 - libpng-1.6.10 - pixman-0.32.4 - cairo-1.12.16 - jpegsrc.v9a - harfbuzz-0.9.27 - fontconfig-2.11.1 - freetype-2.5.3 - pango-1.36.6 (current PPC binaries are 1.36.3) + sed-4.2 (Windows only, to avoid non-GNU `sed`) + sqlite[-autoconf]-3220000 (Windows, Linux, and PPC Mac OS only) + openssl-1.1.0h + libiconv-1.15 (Windows only) + zlib-1.2.11 (Windows and Linux only) + libffi-3.2.1 + expat-2.2.5 + gettext-0.19.8 + glib-2.56.0 + libpng-1.6.34 + pixman-0.34.0 + cairo-1.14.12 + jpegsrc.v9c + harfbuzz-1.7.6 + fribidi-1.0.2 + fontconfig-2.13.0 + freetype-2.9 + pango-1.42.0 poppler-0.24.5 - mpfr-3.1.2 - gmp-5.1.3 + mpfr-3.1.6 + gmp-6.1.2 + atk-2.28.1 (Linux only:) xtrans-1.3.5 @@ -52,7 +54,6 @@ libXext-1.3.3 libXrender-0.9.8 freefont[-ttf]-20100919 - atk-2.12.0 gdk-pixbuf-2.30.8 gtk+-2.24.24 @@ -110,8 +111,8 @@ --archives where is the deirectory containing this file, - `--win' versus `--mac' selects a Windows versus Mac OS build, - and `--m32' versus `--m64' selects a 32-bit versus 64-bit build. + `--win` versus `--mac` selects a Windows versus Mac OS build, + and `--m32` versus `--m64` selects a 32-bit versus 64-bit build. * Run @@ -136,14 +137,14 @@ build platform, as opposed to the target platform. The resulting `pkg-config` is installed into "/dest/bin", which is included in the PATH environment variable when all other configuration -steps are run. If you used an installed `pkg-config', then you'd end +steps are run. If you used an installed `pkg-config`, then you'd end up linking to installed packages on the build machine, which would be confusing at best. More details for Windows: - * GNU `sed' is built to run on the build platform, just in case the - build platform's `sed' is BSD-style (as on Mac OS). + * GNU `sed` is built to run on the build platform, just in case the + build platform's `sed` is BSD-style (as on Mac OS). * The generated ".dll"s go to "dest/bin". @@ -151,7 +152,7 @@ symbols. * Beware of dynamic linking to libgcc or libstdc++. The build script - uses `-static-libgcc' and `-static-libstdc++' to statically link + uses `-static-libgcc` and `-static-libstdc++` to statically link those libraries. Use "depends.exe" to check DLL dependencies. More details for Mac OS: @@ -167,7 +168,7 @@ During the build, ".dylib"s in "/dest/lib" will contain full paths when they depend on other ".dylibs" in the same - directory. The "install.rkt" script uses `install_name_tool' to + directory. The "install.rkt" script uses `install_name_tool` to rewrite those paths to relative form using "@loader_path". You can use @@ -179,7 +180,7 @@ out for "/usr/opt/local" paths, which means that you have accidentally links to MacPorts libraries. - * All ".dylib"s should use two-level namespaces. Use `otool -vh' and + * All ".dylib"s should use two-level namespaces. Use `otool -vh` and look for "TWOLEVEL" in the output to double check that a library build uses two-level namespaces. @@ -203,7 +204,7 @@ * Update the library version in "install.rkt". - * Update the `ffi-lib' reference in the corresponding Racket wrapper + * Update the `ffi-lib` reference in the corresponding Racket wrapper libraries. * Update the "info.rkt" dependencies in the Racket packages that @@ -233,7 +234,8 @@ If You Have to Start Over Completely ------------------------------------ -See +The "build.rkt" script automates most everything we learned, but +for old build notes, see also * "racket/src/mac/README.txt" in a Racket v5.x source distirbution @@ -243,6 +245,3 @@ * Pre-built packages from www.gtk.org, specifically the "dev" archives. - -for old build notes. The "build.rkt" script automates most everything -we learned. diff -Nru racket-6.12+ppa1/src/racket/cmdline.inc racket-7.0+ppa1/src/racket/cmdline.inc --- racket-6.12+ppa1/src/racket/cmdline.inc 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/cmdline.inc 2018-07-27 22:12:02.000000000 +0000 @@ -2,255 +2,20 @@ /* This command-line parser is used by both Racket and GRacket. */ /****************************************************************/ -#pragma GCC diagnostic ignored "-Wwrite-strings" - -#define SDESC "Set! works on undefined identifiers" - -char * volatile scheme_cmdline_exe_hack = (char *) - ("[Replace me for EXE hack " - " ]"); - -#ifdef MZ_PRECISE_GC -# define GC_PRECISION_TYPE "3" -#else -# define GC_PRECISION_TYPE "c" -#endif -char * volatile scheme_binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE GC_PRECISION_TYPE; -/* The format of bINARy tYPe is e?[zr]i[3c]. - e indicates a starter executable - z/r indicates Racket or GRacket - i indicates ??? - 3/c indicates 3m or CGC */ - -#ifndef INITIAL_COLLECTS_DIRECTORY -# ifdef DOS_FILE_SYSTEM -# define INITIAL_COLLECTS_DIRECTORY "collects" -# else -# define INITIAL_COLLECTS_DIRECTORY "../collects" -# endif -#endif - -char * volatile scheme_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ - INITIAL_COLLECTS_DIRECTORY - "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _coldir_offset = 19; /* Skip permanent tag */ - -#ifndef INITIAL_CONFIG_DIRECTORY -# ifdef DOS_FILE_SYSTEM -# define INITIAL_CONFIG_DIRECTORY "etc" -# else -# define INITIAL_CONFIG_DIRECTORY "../etc" -# endif -#endif - -char * volatile scheme_configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ - INITIAL_CONFIG_DIRECTORY - "\0" - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _configdir_offset = 17; /* Skip permanent tag */ - - -#ifndef MZ_PRECISE_GC -# define XFORM_OK_PLUS + -#endif - -#ifdef OS_X -# include -# include -# include -#endif - -#ifdef DOS_FILE_SYSTEM -# include - -#ifndef DLL_RELATIVE_PATH -# define DLL_RELATIVE_PATH L"lib" -#endif -#include "delayed.inc" - #ifdef NEED_CONSOLE_PRINTF static void (*console_printf)(char *str, ...); # define PRINTF console_printf #endif -static void record_dll_path(void) -{ - if (_dlldir[_dlldir_offset] != '<') { - scheme_set_dll_path(_dlldir + _dlldir_offset); - } -} - -# ifdef MZ_PRECISE_GC -END_XFORM_SKIP; -# endif -#endif - -#ifdef OS_X -static long get_segment_offset() -{ -# if defined(__x86_64__) || defined(__arm64__) - const struct segment_command_64 *seg; -# else - const struct segment_command *seg; -#endif - seg = getsegbyname("__PLTSCHEME"); - if (seg) - return seg->fileoff; - else - return 0; -} -#endif +#include "../start/config.inc" #ifdef DOS_FILE_SYSTEM -wchar_t *get_self_executable_path() -{ - wchar_t *path; - DWORD r, sz = 1024; - - while (1) { - path = (wchar_t *)malloc(sz * sizeof(wchar_t)); - r = GetModuleFileNameW(NULL, path, sz); - if ((r == sz) - && (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { - free(path); - sz = 2 * sz; - } else - break; - } - - return path; -} - -static DWORD find_by_id(HANDLE fd, DWORD rsrcs, DWORD pos, int id) +static void record_dll_path(void) { - DWORD got, val; - WORD name_count, id_count; - - SetFilePointer(fd, pos + 12, 0, FILE_BEGIN); - ReadFile(fd, &name_count, 2, &got, NULL); - ReadFile(fd, &id_count, 2, &got, NULL); - - pos += 16 + (name_count * 8); - while (id_count--) { - ReadFile(fd, &val, 4, &got, NULL); - if (val == id) { - ReadFile(fd, &val, 4, &got, NULL); - return rsrcs + (val & 0x7FFFFFF); - } else { - ReadFile(fd, &val, 4, &got, NULL); - } - } - - return 0; -} - -static long get_segment_offset() -{ - /* Find the resource of type 257 */ - wchar_t *path; - HANDLE fd; - - path = get_self_executable_path(); - fd = CreateFileW(path, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL, - OPEN_EXISTING, - 0, - NULL); - free(path); - - if (fd == INVALID_HANDLE_VALUE) - return 0; - else { - DWORD val, got, sec_pos, virtual_addr, rsrcs, pos; - WORD num_sections, head_size; - char name[8]; - - SetFilePointer(fd, 60, 0, FILE_BEGIN); - ReadFile(fd, &val, 4, &got, NULL); - SetFilePointer(fd, val+4+2, 0, FILE_BEGIN); /* Skip "PE\0\0" tag and machine */ - ReadFile(fd, &num_sections, 2, &got, NULL); - SetFilePointer(fd, 12, 0, FILE_CURRENT); /* time stamp + symbol table */ - ReadFile(fd, &head_size, 2, &got, NULL); - - sec_pos = val+4+20+head_size; - while (num_sections--) { - SetFilePointer(fd, sec_pos, 0, FILE_BEGIN); - ReadFile(fd, &name, 8, &got, NULL); - if ((name[0] == '.') - && (name[1] == 'r') - && (name[2] == 's') - && (name[3] == 'r') - && (name[4] == 'c') - && (name[5] == 0)) { - SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip virtual size */ - ReadFile(fd, &virtual_addr, 4, &got, NULL); - SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip file size */ - ReadFile(fd, &rsrcs, 4, &got, NULL); - SetFilePointer(fd, rsrcs, 0, FILE_BEGIN); - - /* We're at the resource table; step through 3 layers */ - pos = find_by_id(fd, rsrcs, rsrcs, 257); - if (pos) { - pos = find_by_id(fd, rsrcs, pos, 1); - if (pos) { - pos = find_by_id(fd, rsrcs, pos, 1033); - - if (pos) { - /* pos is the reource data entry */ - SetFilePointer(fd, pos, 0, FILE_BEGIN); - ReadFile(fd, &val, 4, &got, NULL); - pos = val - virtual_addr + rsrcs; - - CloseHandle(fd); - - return pos; - } - } - } - - break; - } - sec_pos += 40; - } - - /* something went wrong */ - CloseHandle(fd); - return 0; - } + GC_CAN_IGNORE wchar_t *dlldir; + dlldir = extract_dlldir(); + if (dlldir) + scheme_set_dll_path(dlldir); } #endif @@ -385,7 +150,7 @@ submod = scheme_intern_symbol("submod"); cr = scheme_intern_symbol("configure-runtime"); - if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { + if (scheme_is_module_path_index(mod)) { mpij = scheme_builtin_value("module-path-index-join"); a[0] = scheme_make_pair(submod, scheme_make_pair(scheme_make_utf8_string("."), @@ -548,7 +313,7 @@ a[0], fa->evals_and_loads[i]); } - /* Use a module path index so that multiple resolutions are no unduly + /* Use a module path index so that multiple resolutions are not unduly sensitive to changes in the current directory or other configurations: */ mpi = scheme_make_modidx(a[0], scheme_make_false(), scheme_make_false()); if (!did_config) @@ -581,17 +346,12 @@ save = p->error_buf; p->error_buf = &newbuf; if (!scheme_setjmp(newbuf)) { - Scheme_Object *e, *a[2], *d2s, *nsi, *idb, *b, *cp; + Scheme_Object *e, *a[2], *ndi, *idb, *b, *cp; - d2s = scheme_builtin_value("datum->syntax"); - a[0] = scheme_make_false(); + ndi = scheme_builtin_value("namespace-datum-introduce"); e = scheme_intern_symbol("main"); - a[1] = e; - e = scheme_apply(d2s, 2, a); - - nsi = scheme_builtin_value("namespace-syntax-introduce"); a[0] = e; - e = scheme_apply(nsi, 1, a); + e = scheme_apply(ndi, 1, a); /* Check that `main' is imported and/or defined: */ idb = scheme_builtin_value("identifier-binding"); @@ -755,10 +515,6 @@ return r; } -#ifndef MZ_XFORM -# define GC_CAN_IGNORE /**/ -#endif - #include static Scheme_Object *get_log_level(char *prog, char *real_switch, const char *envvar, const char *what, GC_CAN_IGNORE char *str) @@ -859,10 +615,12 @@ { /* Setup path for "collects" collection directory: */ if (!collects_path) { - if (!scheme_coldir[_coldir_offset]) + GC_CAN_IGNORE char *coldir; + coldir = extract_coldir(); + if (!coldir[0]) collects_path = scheme_make_false(); else - collects_path = scheme_make_path(scheme_coldir XFORM_OK_PLUS _coldir_offset); + collects_path = scheme_make_path(coldir); } else if (!SAME_OBJ(collects_path, scheme_make_false())) collects_path = scheme_path_to_complete_path(collects_path, NULL); @@ -891,7 +649,7 @@ } if (!config_path) - config_path = scheme_make_path(scheme_configdir XFORM_OK_PLUS _configdir_offset); + config_path = scheme_make_path(extract_configdir()); else config_path = scheme_path_to_complete_path(config_path, NULL); @@ -966,7 +724,7 @@ int no_compiled = 0; int init_ns = 0, no_init_ns = 0; int cross_compile = 0; - Scheme_Object *syslog_level = NULL, *stderr_level = NULL; + Scheme_Object *syslog_level = NULL, *stderr_level = NULL, *stdout_level = NULL; FinishArgs *fa; FinishArgsAtoms *fa_a; @@ -982,181 +740,7 @@ console_printf = scheme_get_console_printf(); #endif -#ifdef DOS_FILE_SYSTEM - { - /* For consistency, strip trailing spaces and dots, and make sure the .exe - extension is present. */ - int l = strlen(prog); - if ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { - char *s; - while ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { - l--; - } - s = (char *)scheme_malloc_atomic(l + 1); - memcpy(s, prog, l); - s[l] = 0; - prog = s; - } - if (l <= 4 - || (prog[l - 4] != '.') - || (tolower(((unsigned char *)prog)[l - 3]) != 'e') - || (tolower(((unsigned char *)prog)[l - 2]) != 'x') - || (tolower(((unsigned char *)prog)[l - 1]) != 'e')) { - char *s; - s = (char *)scheme_malloc_atomic(l + 4 + 1); - memcpy(s, prog, l); - memcpy(s + l, ".exe", 5); - prog = s; - } - } -#endif - - /* If scheme_cmdline_exe_hack is changed, then we extract built-in - arguments. */ - if (scheme_cmdline_exe_hack[0] != '[') { - int n, i; - long d; - GC_CAN_IGNORE unsigned char *p; - GC_CAN_IGNORE unsigned char *orig_p; - char **argv2; - - p = NULL; -#ifdef DOS_FILE_SYSTEM - if ((scheme_cmdline_exe_hack[0] == '?') - || (scheme_cmdline_exe_hack[0] == '*')) { - /* This is how we make launchers in Windows. The cmdline is - added as a resource of type 257. The long integer at - scheme_cmdline_exe_hack[4] says where the command line starts - with the source, and scheme_cmdline_exe_hack[8] says how long - the cmdline string is. It might be relative to the - executable. */ - HANDLE fd; - wchar_t *path; - - path = get_self_executable_path(); - fd = CreateFileW(path, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL, - OPEN_EXISTING, - 0, - NULL); - if (fd == INVALID_HANDLE_VALUE) - p = (unsigned char *)"\0\0\0"; - else { - long start, len; - DWORD got; - start = *(long *)&scheme_cmdline_exe_hack[4]; - len = *(long *)&scheme_cmdline_exe_hack[8]; - start += get_segment_offset(); - p = (unsigned char *)malloc(len); - SetFilePointer(fd, start, 0, FILE_BEGIN); - ReadFile(fd, p, len, &got, NULL); - CloseHandle(fd); - if (got != len) - p = (unsigned char *)"\0\0\0"; - else if (scheme_cmdline_exe_hack[0] == '*') { - /* "*" means that the first item is argv[0] replacement: */ - sprog = prog; - prog = (char *)p + 4; - - if ((prog[0] == '\\') - || ((((prog[0] >= 'a') && (prog[0] <= 'z')) - || ((prog[0] >= 'A') && (prog[0] <= 'Z'))) - && (prog[1] == ':'))) { - /* Absolute path */ - } else { - /* Make it absolute, relative to this executable */ - int plen = strlen(prog); - int mlen, len; - char *s2, *p2; - - /* UTF-8 encode path: */ - for (len = 0; path[len]; len++) { } - mlen = scheme_utf8_encode((unsigned int *)path, 0, len, - NULL, 0, - 1 /* UTF-16 */); - p2 = (char *)malloc(mlen + 1); - mlen = scheme_utf8_encode((unsigned int *)path, 0, len, - (unsigned char *)p2, 0, - 1 /* UTF-16 */); - - while (mlen && (p2[mlen - 1] != '\\')) { - mlen--; - } - s2 = (char *)malloc(mlen + plen + 1); - memcpy(s2, p2, mlen); - memcpy(s2 + mlen, prog, plen + 1); - prog = s2; - } - - p += (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24) - + 4); - } - } - free(path); - } -#endif -#if defined(OS_X) - if (scheme_cmdline_exe_hack[0] == '?') { - long fileoff, cmdoff, cmdlen; - int fd; - fileoff = get_segment_offset(); - - p = (unsigned char *)scheme_cmdline_exe_hack + 4; - cmdoff = (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24)); - cmdlen = (p[4] - + (((long)p[5]) << 8) - + (((long)p[6]) << 16) - + (((long)p[7]) << 24)); - p = malloc(cmdlen); - - fd = open(_dyld_get_image_name(0), O_RDONLY); - lseek(fd, fileoff + cmdoff, 0); - read(fd, p, cmdlen); - close(fd); - } -#endif - - if (!p) - p = (unsigned char *)scheme_cmdline_exe_hack + 1; - - /* Command line is encoded as a sequence of pascal-style strings; - we use four whole bytes for the length, though, little-endian. */ - - orig_p = p; - - n = 0; - while (p[0] || p[1] || p[2] || p[3]) { - n++; - p += (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24) - + 4); - } - - argv2 = (char **)malloc(sizeof(char *) * (argc + n)); - p = orig_p; - for (i = 0; i < n; i++) { - d = (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24)); - argv2[i] = (char *)p + 4; - p += d + 4; - } - for (; i < n + argc; i++) { - argv2[i] = argv[i - n]; - } - argv = argv2; - argc += n; - } + extract_built_in_arguments(&prog, &sprog, &argc, &argv); #ifndef DONT_PARSE_COMMAND_LINE evals_and_loads = (char **)malloc(sizeof(char *) * argc); @@ -1524,6 +1108,14 @@ argv++; was_config_flag = 1; break; + case 'O': + stdout_level = get_arg_log_level(prog, real_switch, "stdout", argc, argv); + if (!stdout_level) + goto show_need_help; + --argc; + argv++; + was_config_flag = 1; + break; case 'L': syslog_level = get_arg_log_level(prog, real_switch, "syslog", argc, argv); if (!syslog_level) @@ -1600,6 +1192,13 @@ stderr_level = get_log_level(prog, NULL, "PLTSTDERR", "stderr", s); } } + if (!stdout_level) { + char *s; + s = getenv("PLTSTDOUT"); + if (s) { + stdout_level = get_log_level(prog, NULL, "PLTSTDOUT", "stdout", s); + } + } if (getenv("PLTDISABLEGC")) { scheme_enable_garbage_collection(0); } @@ -1638,7 +1237,7 @@ } } - scheme_set_logging_spec(syslog_level, stderr_level); + scheme_set_logging2_spec(syslog_level, stderr_level, stdout_level); collects_path = adjust_collects_path(collects_path, &skip_coll_dirs); scheme_set_collects_path(collects_path); @@ -1664,14 +1263,16 @@ { int len, offset; + GC_CAN_IGNORE char *coldir; collects_paths_l = scheme_make_null(); - offset = _coldir_offset; + coldir = extract_coldir(); + offset = 0; while (1) { - len = strlen(scheme_coldir XFORM_OK_PLUS offset); + len = strlen(coldir XFORM_OK_PLUS offset); offset += len + 1; - if (!scheme_coldir[offset]) + if (!coldir[offset]) break; - collects_paths_l = scheme_make_pair(scheme_make_path(scheme_coldir XFORM_OK_PLUS offset), + collects_paths_l = scheme_make_pair(scheme_make_path(coldir XFORM_OK_PLUS offset), collects_paths_l); } collects_paths_l = reverse_path_list(collects_paths_l, 0); @@ -1816,6 +1417,7 @@ " -d, --no-delay: Disable on-demand loading of syntax and code\n" " -b, --binary : Read stdin and write stdout/stderr in binary mode\n" " -W , --warn : Set stderr logging to \n" + " -O , --stdout : Set stdout logging to \n" " -L , --syslog : Set syslog logging to \n" " Meta options:\n" " -- : No argument following this switch is used as a switch\n" diff -Nru racket-6.12+ppa1/src/racket/configure.ac racket-7.0+ppa1/src/racket/configure.ac --- racket-6.12+ppa1/src/racket/configure.ac 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/configure.ac 2018-07-27 22:12:02.000000000 +0000 @@ -73,6 +73,8 @@ AC_ARG_ENABLE(sgcdebug,[ --enable-sgcdebug use Senora GC for debugging (expensive debug mode)]) AC_ARG_ENABLE(backtrace, [ --enable-backtrace 3m: support GC backtrace dumps (expensive debug mode)]) +AC_ARG_ENABLE(backtrace, [ --enable-cify compile startup code to C insteda of bytecode]) + AC_ARG_ENABLE(pthread, [ --enable-pthread link with pthreads (usually auto-enabled if needed)]) AC_ARG_ENABLE(stackup, [ --enable-stackup assume "up" if stack direction cannot be determined]) AC_ARG_ENABLE(bigendian, [ --enable-bigendian assume "big" if endianness cannot be determined]) @@ -323,6 +325,8 @@ show_explicitly_disabled "${enable_sgc}" SGC show_explicitly_enabled "${enable_sgcdebug}" "SGC debug mode" show_explicitly_enabled "${enable_backtrace}" "3m GC backtraces" "Note that this mode is not intended for normal Racket use" +show_explicitly_enabled "${enable_cify}" "Startup compiled to C" +show_explicitly_disabled "${enable_cify}" "Startup compiled to C" show_explicitly_disabled "${enable_float}" "Single-precision floats" show_explicitly_enabled "${enable_floatinstead}" "Single-precision default floats" "Note that this mode is NOT RECOMMENDED" @@ -470,6 +474,7 @@ STRIP_LIB_DEBUG=":" strip_debug_flags="" enable_strip_by_default=yes +strip_needs_dash_s=no use_flag_pthread=yes use_flag_posix_pthread=no @@ -478,6 +483,22 @@ check_page_size=yes try_no_nullability_completeness=no +if test "${enable_cify}" = "yes" ; then + STARTUP_AS_BYTECODE=_bytecode + STARTUP_AS_C= + STARTUP_AS_AUTO=_auto +else + if test "${enable_cify}" = "no" ; then + STARTUP_AS_BYTECODE= + STARTUP_AS_C=_c + STARTUP_AS_AUTO=_auto + else + STARTUP_AS_BYTECODE=_bytecode + STARTUP_AS_C=_c + STARTUP_AS_AUTO= + fi +fi + MAKE_LOCAL_RACKET=no-local-racket ###### OSKit stuff ####### @@ -940,6 +961,8 @@ fi else PREFLAGS="$PREFLAGS -DXONX " + LIBS="$LIBS -framework CoreFoundation" + strip_needs_dash_s=yes fi ;; nto-qnx*) @@ -1003,6 +1026,12 @@ # Used to add -S flag, but not all `strip' variants support it: STRIP_DEBUG="${STRIP}" if test "${INSTALL_LIBS_ENABLE}" = "install" ; then + check_strip_dash_s=yes + fi + if test "${strip_needs_dash_s}" = "yes" ; then + check_strip_dash_s=yes + fi + if test "${check_strip_dash_s}" = "yes" ; then # Can only support library stripping if something like "-S" is available: [ msg="for strip -S" ] AC_MSG_CHECKING($msg) @@ -1015,6 +1044,9 @@ fi fi AC_MSG_RESULT($set_strip_lib) + if test "${strip_needs_dash_s}" = "yes" ; then + STRIP_DEBUG="${STRIP_LIB_DEBUG}" + fi fi fi @@ -1560,11 +1592,13 @@ RUN_RACKET_MMM='$(RUN_THIS_RACKET_MMM)' RUN_RACKET_MAIN_VARIANT='$(RUN_THIS_RACKET_MAIN_VARIANT)' CGC_IF_NEEDED_FOR_MMM="cgc" + BOOT_MODE="--boot" else RUN_RACKET_CGC="${enable_racket}" RUN_RACKET_MMM="${enable_racket}" RUN_RACKET_MAIN_VARIANT="${enable_racket}" CGC_IF_NEEDED_FOR_MMM="no-cgc-needed" + BOOT_MODE="--chain" fi ############## libtool ################ @@ -1771,6 +1805,11 @@ AC_SUBST(RUN_RACKET_MMM) AC_SUBST(RUN_RACKET_MAIN_VARIANT) AC_SUBST(CGC_IF_NEEDED_FOR_MMM) +AC_SUBST(BOOT_MODE) + +AC_SUBST(STARTUP_AS_BYTECODE) +AC_SUBST(STARTUP_AS_C) +AC_SUBST(STARTUP_AS_AUTO) AC_SUBST(MAKE_LOCAL_RACKET) diff -Nru racket-6.12+ppa1/src/racket/delayed.inc racket-7.0+ppa1/src/racket/delayed.inc --- racket-6.12+ppa1/src/racket/delayed.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/delayed.inc 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ - -# ifdef MZ_PRECISE_GC -# define DLL_3M_SUFFIX "3m" -# else -# define DLL_3M_SUFFIX "" -# endif -static wchar_t *_dlldir = L"dLl dIRECTORy:" /* <- this tag stays, so we can find it again */ - DLL_RELATIVE_PATH L"\0" - /* Pad with 512 characters: */ - L"****************************************************************" - L"****************************************************************" - L"****************************************************************" - L"****************************************************************" - L"****************************************************************" - L"****************************************************************" - L"****************************************************************" - L"****************************************************************"; -static int _dlldir_offset = 14; /* Skip permanent tag */ - -# ifdef MZ_PRECISE_GC -START_XFORM_SKIP; -# endif - -static void load_delayed_dll(HINSTANCE me, const char *lib) -{ - /* Don't use the C library here! */ - const wchar_t *dlldir = _dlldir + _dlldir_offset; - - if (dlldir[0] != '<') { - if ((dlldir[0] == '\\') - || ((((dlldir[0] >= 'a') && (dlldir[0] <= 'z')) - || ((dlldir[0] >= 'A') && (dlldir[0] <= 'Z'))) - && (dlldir[1] == ':'))) { - /* Absolute path */ - } else { - /* Make it absolute, relative to this module */ - wchar_t *name, *s; - int j, i; - name = (wchar_t *)GlobalAlloc(GMEM_FIXED, 1024 * sizeof(wchar_t)); - GetModuleFileNameW(me, name, 1024); - name[1023] = 0; - s = (wchar_t *)GlobalAlloc(GMEM_FIXED, 2048 * sizeof(wchar_t)); - for (i = 0; name[i]; i++) { } - --i; - while (i && (name[i] != '\\')) { - --i; - } - name[i+1] = 0; - for (i = 0; name[i]; i++) { - s[i] = name[i]; - } - for (j = 0; dlldir[j]; j++, i++) { - s[i] = dlldir[j]; - } - s[i] = 0; - dlldir = s; - _dlldir = s; - _dlldir_offset = 0; - } - - { - wchar_t *t; - int j, i; - - t = (wchar_t *)GlobalAlloc(GMEM_FIXED, 2048 * sizeof(wchar_t)); - for (i = 0; dlldir[i]; i++) { - t[i] = dlldir[i]; - } - if (t[i-1] != '\\') - t[i++] = '\\'; - for (j = 0; lib[j]; j++, i++) { - t[i] = lib[j]; - } - t[i] = 0; - - if (!LoadLibraryW(t)) { - MessageBoxW(NULL, t, L"Failure: cannot load DLL", MB_OK); - ExitProcess(1); - } - } - } -} diff -Nru racket-6.12+ppa1/src/racket/dynsrc/Makefile.in racket-7.0+ppa1/src/racket/dynsrc/Makefile.in --- racket-6.12+ppa1/src/racket/dynsrc/Makefile.in 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/dynsrc/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -60,13 +60,13 @@ dynexmpl.o: $(srcdir)/dynexmpl.c $(HEADERS) $(PLAIN_CC) $(ALL_CFLAGS) -c $(srcdir)/dynexmpl.c -o dynexmpl.o -../starter@NOT_MINGW@@EXE_SUFFIX@: $(srcdir)/ustart.c - $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/ustart.c +../starter@NOT_MINGW@@EXE_SUFFIX@: $(srcdir)/../../start/ustart.c + $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/../../start/ustart.c -../starter@MINGW@@EXE_SUFFIX@: $(srcdir)/start.c ../mrstarter@EXE_SUFFIX@ sres.o - $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/start.c sres.o +../starter@MINGW@@EXE_SUFFIX@: $(srcdir)/../../start/start.c ../mrstarter@EXE_SUFFIX@ sres.o + $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/../../start/start.c sres.o ../mrstarter@EXE_SUFFIX@: smrres.o - $(PLAIN_CC) $(ALL_CFLAGS) -mwindows -DMRSTART -o ../mrstarter@EXE_SUFFIX@ $(srcdir)/start.c smrres.o + $(PLAIN_CC) $(ALL_CFLAGS) -mwindows -DMRSTART -o ../mrstarter@EXE_SUFFIX@ $(srcdir)/../../start/start.c smrres.o sres.o: @WINDRES@ -DMZSTART -i $(srcdir)/../../worksp/starters/start.rc -o sres.o diff -Nru racket-6.12+ppa1/src/racket/dynsrc/start.c racket-7.0+ppa1/src/racket/dynsrc/start.c --- racket-6.12+ppa1/src/racket/dynsrc/start.c 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/dynsrc/start.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,403 +0,0 @@ -/* Launcher program for Windows. */ -/* Builds a Racket starter if MZSTART is defined. */ -/* Builds a GRacket starter if MRSTART is defined. */ -/* If neither is defined, MZSTART is auto-defined. */ - -#include -#include -#include -#include -#include -#include -#include - -#ifndef MRSTART -# ifndef MZSTART -# define MZSTART -# endif -#endif - -#ifdef MRSTART -# define GOSUBDIR L"\\" -# define GOEXE L"gracket" -# define sGOEXE "gracket" -# define WAITTILDONE 0 -#endif - -#ifdef MZSTART -# define GOSUBDIR L"\\" -# define GOEXE L"racket" -# define sGOEXE "racket" -# define WAITTILDONE 1 -#endif - -#define MAXCOMMANDLEN 1024 -#define MAX_ARGS 100 - -#if defined(_MSC_VER) || defined(__MINGW32__) -# define MSC_IZE(x) _ ## x -#else -# define MSC_IZE(x) x -#endif -#define DUPLICATE_INPUT - -/* Win command lines limited to 1024 chars, so 1024 chars for - command tail is ample */ - -static wchar_t *input = - L""; - -/* Win long filenames limited to 255 chars, so 254 chars for - directory is ample */ - -static wchar_t *exedir = L""; - -static wchar_t *variant = L""; - -static int wc_strlen(const wchar_t *ws) -{ - int l; - for (l = 0; ws[l]; l++) { } - return l; -} - -static void wc_strcpy(wchar_t *dest, const wchar_t *src) -{ - while (*src) { - *dest = *src; - dest++; - src++; - } - *dest = 0; -} - -static void wc_strcat(wchar_t *dest, const wchar_t *src) -{ - while (*dest) - dest++; - wc_strcpy(dest, src); -} - -static wchar_t *protect(wchar_t *s) -{ - wchar_t *naya; - int has_space = 0, has_quote = 0, was_slash = 0; - - for (naya = s; *naya; naya++) { - if (((*naya < 128) && isspace(*naya)) || (*naya == '\'')) { - has_space = 1; - was_slash = 0; - } else if (*naya == '"') { - has_quote += 1 + (2 * was_slash); - was_slash = 0; - } else if (*naya == '\\') { - was_slash++; - } else - was_slash = 0; - } - - if (has_space || has_quote) { - wchar_t *p; - int wrote_slash = 0; - - naya = (wchar_t *)malloc((wc_strlen(s) + 3 + 3*has_quote) * sizeof(wchar_t)); - naya[0] = '"'; - for (p = naya + 1; *s; s++) { - if (*s == '"') { - while (wrote_slash--) - *(p++) = '\\'; - *(p++) = '"'; /* endquote */ - *(p++) = '\\'; - *(p++) = '"'; /* protected */ - *(p++) = '"'; /* start quote again */ - wrote_slash = 0; - } else if (*s == '\\') { - *(p++) = '\\'; - wrote_slash++; - } else { - *(p++) = *s; - wrote_slash = 0; - } - } - *(p++) = '"'; - *p = 0; - - return naya; - } - - return s; -} - -static int parse_command_line(int count, wchar_t **command, - wchar_t *buf, int maxargs, int skip) - -{ - wchar_t *parse, *created, *write; - int findquote = 0; - - parse = created = write = buf; - while (*parse) { - while (*parse && (*parse < 128) && isspace(*parse)) parse++; - while (*parse && ((*parse > 128) || !isspace(*parse) || findquote)) { - if (*parse== '"') { - findquote = !findquote; - } else if (*parse== '\\') { - wchar_t *next; - for (next = parse; *next == '\\'; next++); - if (*next == '"') { - /* Special handling: */ - int count = (next - parse), i; - for (i = 1; i < count; i += 2) - *(write++) = '\\'; - parse += (count - 1); - if (count & 0x1) { - *(write++) = '\"'; - parse++; - } - } else - *(write++) = *parse; - } else - *(write++) = *parse; - parse++; - } - if (*parse) - parse++; - *(write++) = 0; - - if (*created) { - if (skip) { - skip--; - } else { - command[count++] = created; - if (count == maxargs) - return count; - } - } - created = write; - } - - return count; -} - -static wchar_t *make_command_line(int argc, wchar_t **argv) -{ - int i, len = 0; - wchar_t *r; - - for (i = 0; i < argc; i++) { - len += wc_strlen(argv[i]) + 1; - } - r = (wchar_t *)malloc(len * sizeof(wchar_t)); - len = 0; - for (i = 0; i < argc; i++) { - int l = wc_strlen(argv[i]); - if (len) r[len++] = ' '; - memcpy(r + len, argv[i], l * sizeof(wchar_t)); - len += l; - } - - r[len] = 0; - return r; -} - -#ifdef MZSTART -void WriteStr(HANDLE h, const char *s) { - DWORD done; - WriteFile(h, s, strlen(s), &done, NULL); -} -#endif - -#ifdef DUPLICATE_INPUT -static wchar_t *copy_string(wchar_t *s) -{ - int l = wc_strlen(s); - wchar_t *d = (wchar_t *)malloc((l + 1) * sizeof(wchar_t)); - memcpy(d, s, (l + 1) * sizeof(wchar_t)); - return d; -} -#endif - -#if defined(MRSTART) || defined(__MINGW32__) -# define USE_WINMAIN -#endif - -#ifdef USE_WINMAIN -int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, - LPSTR m_lpCmdLine, int nCmdShow) -#else -int wmain(int argc_in, wchar_t **argv_in) -#endif -{ - wchar_t go[MAXCOMMANDLEN * 2]; - wchar_t *args[MAX_ARGS + 1]; - wchar_t *command_line; - int count, i, cl_len; - struct MSC_IZE(stat) st; - STARTUPINFOW si; - PROCESS_INFORMATION pi; -#ifdef MZSTART - HANDLE out; - - out = GetStdHandle(STD_OUTPUT_HANDLE); -#endif - -#ifdef DUPLICATE_INPUT - /* gcc: input is read-only */ - input = copy_string(input); - exedir = copy_string(exedir); -#endif - - count = 1; - count = parse_command_line(count, args, input, MAX_ARGS, 0); - - /* exedir can be relative to the current executable */ - if ((exedir[0] == '\\') - || ((((exedir[0] >= 'a') && (exedir[0] <= 'z')) - || ((exedir[0] >= 'A') && (exedir[0] <= 'Z'))) - && (exedir[1] == ':'))) { - /* Absolute path */ - } else { - /* Make it absolute, relative to this executable */ - int plen; - int mlen; - wchar_t *s2, *path; - - path = (wchar_t *)malloc(1024 * sizeof(wchar_t)); - GetModuleFileNameW(NULL, path, 1024); - - plen = wc_strlen(exedir); - mlen = wc_strlen(path); - - while (mlen && (path[mlen - 1] != '\\')) { - mlen--; - } - s2 = (wchar_t *)malloc((mlen + plen + 1) * sizeof(wchar_t)); - memcpy(s2, path, mlen * sizeof(wchar_t)); - memcpy(s2 + mlen, exedir, (plen + 1) * sizeof(wchar_t)); - exedir = s2; - } - - wc_strcpy(go, exedir); - wc_strcat(go, GOSUBDIR); - wc_strcat(go, GOEXE); - wc_strcat(go, variant); - wc_strcat(go, L".exe"); - - if (_wstat(go, &st)) { -#ifdef USE_WINMAIN - wchar_t errbuff[MAXCOMMANDLEN * 2]; - swprintf(errbuff,sizeof(errbuff),L"Can't find %s",go); - MessageBoxW(NULL,errbuff,L"Error",MB_OK); -#else - char errbuff[MAXCOMMANDLEN * 2]; - sprintf(errbuff,"Can't find %S\n",go); - WriteStr(out,errbuff); -#endif - exit(-1); - } - - args[0] = go; - -#ifdef USE_WINMAIN - { - wchar_t *buf; - LPWSTR m_lpCmdLine; - - m_lpCmdLine = GetCommandLineW(); - - buf = (wchar_t *)malloc((wc_strlen(m_lpCmdLine) + 1) * sizeof(wchar_t)); - memcpy(buf, m_lpCmdLine, (wc_strlen(m_lpCmdLine) + 1) * sizeof(wchar_t)); - count = parse_command_line(count, args, buf, MAX_ARGS, 1); - } -#else - { - int i; - for (i = 1; i < argc_in; i++) - args[count++] = argv_in[i]; - } -#endif - - args[count] = NULL; - - for (i = 0; i < count; i++) { - args[i] = protect(args[i]); - /* MessageBox(NULL, args[i], "Argument", MB_OK); */ - } - - memset(&si, 0, sizeof(si)); - si.cb = sizeof(si); - - command_line = make_command_line(count, args); - - cl_len = wc_strlen(command_line); - if (cl_len > MAXCOMMANDLEN) { -#ifdef MRSTART - wchar_t errbuff[MAXCOMMANDLEN * 2]; - swprintf(errbuff,sizeof(errbuff),L"Command line of %d characters exceeds %d characters: %.1024s", - cl_len, MAXCOMMANDLEN,command_line); - MessageBoxW(NULL,errbuff,L"Error",MB_OK); -#else - char errbuff[MAXCOMMANDLEN * 2]; - sprintf(errbuff,"Command line of %d characters exceeds %d characters: %.1024S\n", - cl_len, MAXCOMMANDLEN,command_line); - WriteStr(out,errbuff); -#endif - exit(-1); - } - - if (!CreateProcessW(go, - command_line, - NULL, NULL, TRUE, - 0, NULL, NULL, &si, &pi)) { - -#ifdef MRSTART - MessageBoxW(NULL, L"Can't start " GOEXE, L"Error", MB_OK); -#else - WriteStr(out, "Can't start " sGOEXE "\n"); -#endif - return -1; - } else { -#if WAITTILDONE - DWORD result; - WaitForSingleObject(pi.hProcess, INFINITE); - GetExitCodeProcess(pi.hProcess, &result); - return result; -#else - return 0; -#endif - } -} diff -Nru racket-6.12+ppa1/src/racket/dynsrc/ustart.c racket-7.0+ppa1/src/racket/dynsrc/ustart.c --- racket-6.12+ppa1/src/racket/dynsrc/ustart.c 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/dynsrc/ustart.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,576 +0,0 @@ - -/* "Embedding" program for Unix/X11, to be used as - an alternative to embedding in the actual Racket - or GRacket binary. */ - -#include -#include -#include -#include -#include -#include -#include -#include - -/* The config string after : is replaced with ! followed by a sequence - of little-endian 4-byte ints: - start - offset into the binary - prog_end - offset; start to prog_end is the program region - decl_end - offset; prog_end to decl_end is the module-command region - end - offset; prog_end to end is the complete command region - count - number of cmdline args in command region - x11? - non-zero => launches GRacket for X - - In the command region, the format is a sequence of NUL-terminated strings: - exe_path - program to start (relative is w.r.t. executable) - dll_path - DLL directory if non-empty (relative is w.r.t. executable) - cmdline_arg ... - - For ELF binaries, the absolute values of `start', `decl_end', `prog_end', - and `end' are ignored if a ".rackcmdl" (starter) or ".rackprog" - (embedding) section is found. The `start' value is set to match the - section offset, and `decl_end', `prog_end', and `end' are correspondingly - adjusted. Using a seciton offset allows linking tools (such as - `strip') to move the data in the executable. -*/ -char *config = "cOnFiG:[***************************"; - -char *binary_type_hack = "bINARy tYPe:ezic"; - -/* This path list is used instead of the one in the Racket/GRacket - binary. That way, the same Racket/GRacket binary can be shared - among embedding exectuables that have different collection - paths. */ -char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ - "../collects" - "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _coldir_offset = 19; /* Skip permanent tag */ - -char * volatile _configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ - "../etc" - "\0" - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _configdir_offset = 17; /* Skip permanent tag */ - -typedef struct { - char *flag; - int arg_count; -} X_flag_entry; - -static X_flag_entry X_flags[] = { - { "-display", 1 }, - { "-geometry", 1 }, - { "-bg", 1 }, - { "-background", 1 }, - { "-fg", 1 }, - { "-foreground", 1 }, - { "-fn", 1 }, - { "-font", 1 }, - { "-iconic", 0 }, - { "-name", 1 }, - { "-rv", 0 }, - { "-reverse", 0 }, - { "+rv", 0 }, - { "-selectionTimeout", 1 }, - { "-synchronous", 0 }, - { "-title", 1 }, - { "-xnllanguage", 1 }, - { "-xrm", 1 }, - { "-singleInstance", 0 }, - { NULL, 0 } -}; - -static int is_x_flag(char *s) -{ - X_flag_entry *x = X_flags; - - while (x->flag) { - if (!strcmp(x->flag, s)) - return x->arg_count + 1; - x++; - } - - return 0; -} - -static int write_str(int fd, char *s) -{ - return write(fd, s, strlen(s)); -} - -static char *num_to_string(int n) -{ - if (!n) - return "0"; - else { - char *d = (char *)malloc(20) + 19; - *d = 0; - while (n) { - d--; - *d = (n % 10) + '0'; - n = n / 10; - } - return d; - } -} - -static char *string_append(char *s1, char *s2) -{ - int l1, l2; - char *s; - - l1 = strlen(s1); - l2 = strlen(s2); - - s = (char *)malloc(l1 + l2 + 1); - - memcpy(s, s1, l1); - memcpy(s + l1, s2, l2); - s[l1 + l2] = 0; - - return s; -} - -static char *copy_string(char *s1) -{ - int l1; - char *s; - - if (!s1) return NULL; - - l1 = strlen(s1); - - s = (char *)malloc(l1 + 1); - - memcpy(s, s1, l1 + 1); - - return s; -} - -static char *do_path_append(char *s1, int l1, char *s2) -{ - int l2; - char *s; - - l2 = strlen(s2); - - s = (char *)malloc(l1 + l2 + 2); - - memcpy(s, s1, l1); - if (s[l1 - 1] != '/') { - s[l1++] = '/'; - } - - memcpy(s + l1, s2, l2); - s[l1 + l2] = 0; - - return s; -} - -static char *path_append(char *s1, char *s2) -{ - return do_path_append(s1, strlen(s1), s2); -} - -static int executable_exists(char *path) -{ - return (access(path, X_OK) == 0); -} - -static int as_int(char *_c) -{ - unsigned char *c = (unsigned char *)_c; - return c[0] | ((int)c[1] << 8) | ((int)c[2] << 16) | ((int)c[3] << 24); -} - -static int has_slash(char *s) -{ - while (*s) { - if (s[0] == '/') - return 1; - s++; - } - return 0; -} - -char *absolutize(char *p, char *d) -{ - int l1; - - if (!p[0]) - return p; - - if (p[0] == '/') - return p; - - /* Strip filename off d: */ - l1 = strlen(d); - while (l1 && (d[l1- 1] != '/')) { - l1--; - } - if (l1) - return do_path_append(d, l1, p); - else - return p; -} - -static char *next_string(char *s) -{ - return s + strlen(s) + 1; -} - -typedef unsigned short ELF__Half; -typedef unsigned int ELF__Word; -typedef unsigned long ELF__Xword; -typedef unsigned long ELF__Addr; -typedef unsigned long ELF__Off; - -typedef struct { - unsigned char e_ident[16]; - ELF__Half e_type; - ELF__Half e_machine; - ELF__Word e_version; - ELF__Addr e_entry; - ELF__Off e_phoff; - ELF__Off e_shoff; - ELF__Word e_flags; - ELF__Half e_ehsize; - ELF__Half e_phentsize; - ELF__Half e_phnum; - ELF__Half e_shentsize; - ELF__Half e_shnum; - ELF__Half e_shstrndx; -} ELF__Header; - -typedef struct -{ - ELF__Word sh_name; - ELF__Word sh_type; - ELF__Xword sh_flags; - ELF__Addr sh_addr; - ELF__Off sh_offset; - ELF__Xword sh_size; - ELF__Word sh_link; - ELF__Word sh_info; - ELF__Xword sh_addralign; - ELF__Xword sh_entsize; -} Elf__Shdr; - -static int try_elf_section(const char *me, int *_start, int *_decl_end, int *_prog_end, int *_end) -{ - int fd, i; - ELF__Header e; - Elf__Shdr s; - char *strs; - - fd = open(me, O_RDONLY, 0); - if (fd == -1) return 0; - - if (read(fd, &e, sizeof(e)) == sizeof(e)) { - if ((e.e_ident[0] == 0x7F) - && (e.e_ident[1] == 'E') - && (e.e_ident[2] == 'L') - && (e.e_ident[3] == 'F')) { - - lseek(fd, e.e_shoff + (e.e_shstrndx * e.e_shentsize), SEEK_SET); - if (read(fd, &s, sizeof(s)) != sizeof(s)) { - close(fd); - return 0; - } - - strs = (char *)malloc(s.sh_size); - lseek(fd, s.sh_offset, SEEK_SET); - if (read(fd, strs, s.sh_size) != s.sh_size) { - close(fd); - return 0; - } - - for (i = 0; i < e.e_shnum; i++) { - lseek(fd, e.e_shoff + (i * e.e_shentsize), SEEK_SET); - if (read(fd, &s, sizeof(s)) != sizeof(s)) { - close(fd); - return 0; - } - if (!strcmp(strs + s.sh_name, ".rackcmdl") - || !strcmp(strs + s.sh_name, ".rackprog")) { - *_decl_end = (*_decl_end - *_start) + s.sh_offset; - *_prog_end = (*_prog_end - *_start) + s.sh_offset; - *_start = s.sh_offset; - *_end = s.sh_offset + s.sh_size; - close(fd); - return !strcmp(strs + s.sh_name, ".rackprog"); - } - } - } - } - - close(fd); - return 0; -} - -int main(int argc, char **argv) -{ - char *me = argv[0], *data, **new_argv; - char *exe_path, *lib_path, *dll_path; - int start, decl_end, prog_end, end, count, fd, v, en, x11; - int argpos, inpos, collcount = 1, fix_argv; - - if (config[7] == '[') { - write_str(2, argv[0]); - write_str(2, ": this is an unconfigured starter\n"); - return 1; - } - - if (me[0] == '/') { - /* Absolute path */ - } else if (has_slash(me)) { - /* Relative path with a directory: */ - char *buf; - long buflen = 4096; - buf = (char *)malloc(buflen); - me = path_append(getcwd(buf, buflen), me); - } else { - /* We have to find the executable by searching PATH: */ - char *path = copy_string(getenv("PATH")), *p, *m; - int more; - - if (!path) { - path = ""; - } - - while (1) { - /* Try each element of path: */ - for (p = path; *p && (*p != ':'); p++) { } - if (*p) { - *p = 0; - more = 1; - } else - more = 0; - - if (!*path) - break; - - m = path_append(path, me); - - if (executable_exists(m)) { - if (m[0] != '/') - m = path_append(getcwd(NULL, 0), m); - me = m; - break; - } - free(m); - - if (more) - path = p + 1; - else - break; - } - } - - /* me is now an absolute path to the binary */ - - /* resolve soft links */ - while (1) { - int len, bufsize = 127; - char *buf; - buf = (char *)malloc(bufsize + 1); - len = readlink(me, buf, bufsize); - if (len < 0) { - if (errno == ENAMETOOLONG) { - /* Increase buffer size and try again: */ - bufsize *= 2; - buf = (char *)malloc(bufsize + 1); - } else - break; - } else { - /* Resolve buf relative to me: */ - buf[len] = 0; - buf = absolutize(buf, me); - me = buf; - buf = (char *)malloc(bufsize + 1); - } - } - - start = as_int(config + 8); - decl_end = as_int(config + 12); - prog_end = as_int(config + 16); - end = as_int(config + 20); - count = as_int(config + 24); - x11 = as_int(config + 28); - - fix_argv = try_elf_section(me, &start, &decl_end, &prog_end, &end); - - { - int offset, len; - offset = _coldir_offset; - while (1) { - len = strlen(_coldir + offset); - offset += len + 1; - if (!_coldir[offset]) - break; - collcount++; - } - } - - data = (char *)malloc(end - prog_end); - new_argv = (char **)malloc((count + argc + (2 * collcount) + 10) * sizeof(char*)); - - fd = open(me, O_RDONLY, 0); - lseek(fd, prog_end, SEEK_SET); - { - int expected_length = end - prog_end; - if (expected_length != read(fd, data, expected_length)) { - printf("read failed to read all %i bytes from file %s\n", expected_length, me); - abort(); - } - } - close(fd); - - exe_path = data; - data = next_string(data); - - lib_path = data; - data = next_string(data); - - exe_path = absolutize(exe_path, me); - lib_path = absolutize(lib_path, me); - -# ifdef OS_X -# define LD_LIB_PATH "DYLD_LIBRARY_PATH" -# else -# define LD_LIB_PATH "LD_LIBRARY_PATH" -# endif - - if (*lib_path) { - dll_path = getenv(LD_LIB_PATH); - if (!dll_path) { - dll_path = ""; - } - dll_path = string_append(dll_path, ":"); - dll_path = string_append(lib_path, dll_path); - dll_path = string_append(LD_LIB_PATH "=", dll_path); - putenv(dll_path); - } - - new_argv[0] = me; - - argpos = 1; - inpos = 1; - - /* Keep all X11 flags to the front: */ - if (x11) { - int n; - while (inpos < argc) { - n = is_x_flag(argv[inpos]); - if (!n) - break; - if (inpos + n > argc) { - write_str(2, argv[0]); - write_str(2, ": missing an argument for "); - write_str(2, argv[inpos]); - write_str(2, "\n"); - return 1; - } - while (n--) { - new_argv[argpos++] = argv[inpos++]; - } - } - } - - /* Add -X and -S flags */ - { - int offset, len; - offset = _coldir_offset; - new_argv[argpos++] = "-X"; - new_argv[argpos++] = absolutize(_coldir + offset, me); - while (1) { - len = strlen(_coldir + offset); - offset += len + 1; - if (!_coldir[offset]) - break; - new_argv[argpos++] = "-S"; - new_argv[argpos++] = absolutize(_coldir + offset, me); - } - } - - /* Add -G flag */ - new_argv[argpos++] = "-G"; - new_argv[argpos++] = absolutize(_configdir + _configdir_offset, me); - - if (fix_argv) { - /* next three args are "-k" and numbers; fix - the numbers to match start, decl_end, and prog_end */ - fix_argv = argpos + 1; - } - - /* Add built-in flags: */ - while (count--) { - new_argv[argpos++] = data; - data = next_string(data); - } - - /* Propagate new flags (after the X11 flags) */ - while (inpos < argc) { - new_argv[argpos++] = argv[inpos++]; - } - - new_argv[argpos] = NULL; - - if (fix_argv) { - new_argv[fix_argv] = num_to_string(start); - new_argv[fix_argv+1] = num_to_string(decl_end); - new_argv[fix_argv+2] = num_to_string(prog_end); - } - - /* Execute the original binary: */ - - v = execv(exe_path, new_argv); - en = errno; - - write_str(2, argv[0]); - write_str(2, ": failed to start "); - write_str(2, exe_path); - write_str(2, " ("); - write_str(2, strerror(en)); - write_str(2, ")\n"); - if (*lib_path) { - write_str(2, " used library path "); - write_str(2, lib_path); - write_str(2, "\n"); - } - - return v; -} diff -Nru racket-6.12+ppa1/src/racket/gc2/check-sdep.rkt racket-7.0+ppa1/src/racket/gc2/check-sdep.rkt --- racket-6.12+ppa1/src/racket/gc2/check-sdep.rkt 2016-07-07 20:46:09.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/check-sdep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,6 +1,5 @@ (module xform '#%kernel - (#%require '#%min-stx - '#%utils + (#%require '#%utils '#%paramz) (define-values (loop) @@ -8,35 +7,36 @@ (if (null? paths) (void) (let-values ([(path) (build-path "xsrc" (car paths))]) - (cond - [(regexp-match? #rx"[.][ch]$" path) - (define-values (ts) (file-or-directory-modify-seconds path)) - (define-values (sdep) (path-replace-extension path ".sdep")) - (call-with-escape-continuation - (lambda (esc) - (with-continuation-mark - exception-handler-key - (lambda (exn) - (if (exn:fail? exn) - (begin - (printf "~a\n removing ~a\n" - (exn-message exn) - path) - (delete-file path) - (esc)) - exn)) - (let-values () - (define-values (dloop) - (lambda (paths) - (if (null? paths) - (void) - (let-values () - (define-values (ts2) (file-or-directory-modify-seconds (bytes->path (car paths)))) - (if (ts2 . > . ts) - (error 'changed-dependency "~a" (car paths)) - (dloop (cdr paths))))))) - (dloop (call-with-input-file sdep read))))))]) - (loop (cdr paths)))))) + (if (regexp-match? #rx"[.][ch]$" path) + (let-values () + (define-values (ts) (file-or-directory-modify-seconds path)) + (define-values (sdep) (path-replace-extension path ".sdep")) + (call-with-escape-continuation + (lambda (esc) + (with-continuation-mark + exception-handler-key + (lambda (exn) + (if (exn:fail? exn) + (begin + (printf "~a\n removing ~a\n" + (exn-message exn) + path) + (delete-file path) + (esc)) + exn)) + (let-values () + (define-values (dloop) + (lambda (paths) + (if (null? paths) + (void) + (let-values () + (define-values (ts2) (file-or-directory-modify-seconds (bytes->path (car paths)))) + (if (ts2 . > . ts) + (error 'changed-dependency "~a" (car paths)) + (dloop (cdr paths))))))) + (dloop (call-with-input-file sdep read)))))) + (loop (cdr paths))) + (loop (cdr paths))))))) (if (directory-exists? "xsrc") (loop (directory-list "xsrc")) diff -Nru racket-6.12+ppa1/src/racket/gc2/gc2_dump.h racket-7.0+ppa1/src/racket/gc2/gc2_dump.h --- racket-6.12+ppa1/src/racket/gc2/gc2_dump.h 2017-01-07 13:34:14.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/gc2_dump.h 2018-07-27 22:12:02.000000000 +0000 @@ -8,6 +8,7 @@ typedef void (*GC_for_each_found_proc)(void *p); typedef void (*GC_for_each_struct_proc)(void *p, int sz); +typedef int (*GC_record_traced_filter_proc)(void *p); typedef void (*GC_print_tagged_value_proc)(const char *prefix, void *v, uintptr_t diff, int max_w, const char *suffix); @@ -17,6 +18,7 @@ GC_get_type_name_proc get_type_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, + GC_record_traced_filter_proc record_traced_filter, GC_print_traced_filter_proc print_traced_filter, GC_print_tagged_value_proc print_tagged_value, int path_length_limit, diff -Nru racket-6.12+ppa1/src/racket/gc2/Makefile.in racket-7.0+ppa1/src/racket/gc2/Makefile.in --- racket-6.12+ppa1/src/racket/gc2/Makefile.in 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -43,8 +43,9 @@ # typically redirects to RUN_THIS_RACKET_CGC: RUN_THIS_RACKET_CGC = ../racket@CGC@ -XFORM_SETUP = @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/xform.rkt --setup . --depends -XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o +SETUP_BOOT = -O "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../../setup-go.rkt ../../compiled +XFORM_SETUP = @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) --tag ++out $(srcdir)/xform-mod.rkt --depends +XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out XSRCDIR = xsrc XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP) SRCDIR = $(srcdir)/../src @@ -55,7 +56,6 @@ OBJS = salloc.@LTO@ \ bignum.@LTO@ \ bool.@LTO@ \ - builtin.@LTO@ \ char.@LTO@ \ compenv.@LTO@ \ compile.@LTO@ \ @@ -79,9 +79,9 @@ jitstack.@LTO@ \ jitstate.@LTO@ \ letrec_check.@LTO@ \ + linklet.@LTO@ \ list.@LTO@ \ marshal.@LTO@ \ - module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ numarith.@LTO@ \ @@ -100,6 +100,8 @@ sema.@LTO@ \ setjmpup.@LTO@ \ sfs.@LTO@ \ + sort.@LTO@ \ + startup.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ symbol.@LTO@ \ @@ -116,7 +118,6 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/bignum.c \ $(XSRCDIR)/bool.c \ - $(XSRCDIR)/builtin.c \ $(XSRCDIR)/char.c \ $(XSRCDIR)/compenv.c \ $(XSRCDIR)/compile.c \ @@ -139,9 +140,9 @@ $(XSRCDIR)/jitstack.c \ $(XSRCDIR)/jitstate.c \ $(XSRCDIR)/letrec_check.c \ + $(XSRCDIR)/linklet.c \ $(XSRCDIR)/list.c \ $(XSRCDIR)/marshal.c \ - $(XSRCDIR)/module.c \ $(XSRCDIR)/network.c \ $(XSRCDIR)/numarith.c \ $(XSRCDIR)/numcomp.c \ @@ -159,6 +160,8 @@ $(XSRCDIR)/sema.c \ $(XSRCDIR)/setjmpup.c \ $(XSRCDIR)/sfs.c \ + $(XSRCDIR)/sort.c \ + $(XSRCDIR)/startup.c \ $(XSRCDIR)/string.c \ $(XSRCDIR)/struct.c \ $(XSRCDIR)/symbol.c \ @@ -187,7 +190,7 @@ # picked up in ".sdep": QUIET_DEPS = $(srcdir)/../src/schvers.h $(srcdir)/../sconfig.h ../mzconfig.h -XFORMDEP_NOPRE = $(srcdir)/xform.rkt $(srcdir)/xform-mod.rkt $(QUIET_DEPS) +XFORMDEP_NOPRE = $(srcdir)/xform-mod.rkt $(QUIET_DEPS) XFORMDEP = $(XFORMDEP_NOPRE) $(XSRCDIR)/precomp.h MZRTDEP = $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \ @@ -208,8 +211,6 @@ $(XFORM) $(XSRCDIR)/bignum.c $(SRCDIR)/bignum.c $(XSRCDIR)/bool.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/bool.c $(SRCDIR)/bool.c -$(XSRCDIR)/builtin.c: $(XFORMDEP) - $(XFORM) $(XSRCDIR)/builtin.c $(SRCDIR)/builtin.c $(XSRCDIR)/char.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/char.c $(SRCDIR)/char.c $(XSRCDIR)/compenv.c: $(XFORMDEP) @@ -254,10 +255,10 @@ $(XFORM) $(XSRCDIR)/jitstate.c $(SRCDIR)/jitstate.c $(XSRCDIR)/marshal.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/marshal.c $(SRCDIR)/marshal.c -$(XSRCDIR)/module.c: $(XFORMDEP) - $(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c $(XSRCDIR)/letrec_check.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/letrec_check.c $(SRCDIR)/letrec_check.c +$(XSRCDIR)/linklet.c: $(XFORMDEP) + $(XFORM) $(XSRCDIR)/linklet.c $(SRCDIR)/linklet.c $(XSRCDIR)/list.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c $(XSRCDIR)/network.c: $(XFORMDEP) @@ -294,8 +295,12 @@ $(XFORM) $(XSRCDIR)/setjmpup.c $(SRCDIR)/setjmpup.c $(XSRCDIR)/sfs.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/sfs.c $(SRCDIR)/sfs.c +$(XSRCDIR)/sort.c: $(XFORMDEP) + $(XFORM) $(XSRCDIR)/sort.c $(SRCDIR)/sort.c +$(XSRCDIR)/startup.c: $(XFORMDEP) ../cstartup.inc $(SRCDIR)/startup-glue.inc + $(XFORM_SETUP) --cpp "$(CPP) -I.. -I$(SRCDIR)/../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out $(XSRCDIR)/startup.c $(SRCDIR)/startup.c $(XSRCDIR)/string.c: $(XFORMDEP) $(SRCDIR)/systype.inc - $(XFORM_SETUP) --cpp "$(CPP) -I../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o $(XSRCDIR)/string.c $(SRCDIR)/string.c + $(XFORM_SETUP) --cpp "$(CPP) -I../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out $(XSRCDIR)/string.c $(SRCDIR)/string.c $(XSRCDIR)/struct.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c $(XSRCDIR)/symbol.c: $(XFORMDEP) @@ -311,10 +316,70 @@ $(XSRCDIR)/vector.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/vector.c $(SRCDIR)/vector.c $(XSRCDIR)/foreign.c: $(XFORMDEP) - $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS) $(LIBFFI_INCLUDE_@OWN_LIBFFI@) -I${SRCDIR}/../../racket/src" @XFORMFLAGS@ -o $(XSRCDIR)/foreign.c $(SRCDIR)/../../foreign/foreign.c + $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS) $(LIBFFI_INCLUDE_@OWN_LIBFFI@) -I${SRCDIR}/../../racket/src" @XFORMFLAGS@ -o ++out $(XSRCDIR)/foreign.c $(SRCDIR)/../../foreign/foreign.c $(XSRCDIR)/main.c: $(XFORMDEP) $(XFORM_NOPRECOMP) $(XSRCDIR)/main.c $(DEF_C_DIRS) $(srcdir)/../main.c +@INCLUDEDEP@ salloc.d +@INCLUDEDEP@ bignum.d +@INCLUDEDEP@ bool.d +@INCLUDEDEP@ char.d +@INCLUDEDEP@ compenv.d +@INCLUDEDEP@ compile.d +@INCLUDEDEP@ complex.d +@INCLUDEDEP@ dynext.d +@INCLUDEDEP@ env.d +@INCLUDEDEP@ error.d +@INCLUDEDEP@ eval.d +@INCLUDEDEP@ file.d +@INCLUDEDEP@ fun.d +@INCLUDEDEP@ future.d +@INCLUDEDEP@ gmp.d +@INCLUDEDEP@ hash.d +@INCLUDEDEP@ jit.d +@INCLUDEDEP@ jitalloc.d +@INCLUDEDEP@ jitarith.d +@INCLUDEDEP@ jitcall.d +@INCLUDEDEP@ jitcommon.d +@INCLUDEDEP@ jitinline.d +@INCLUDEDEP@ jitprep.d +@INCLUDEDEP@ jitstack.d +@INCLUDEDEP@ jitstate.d +@INCLUDEDEP@ letrec_check.d +@INCLUDEDEP@ linklet.d +@INCLUDEDEP@ list.d +@INCLUDEDEP@ marshal.d +@INCLUDEDEP@ mzrt.d +@INCLUDEDEP@ network.d +@INCLUDEDEP@ numarith.d +@INCLUDEDEP@ number.d +@INCLUDEDEP@ numcomp.d +@INCLUDEDEP@ numstr.d +@INCLUDEDEP@ optimize.d +@INCLUDEDEP@ place.d +@INCLUDEDEP@ port.d +@INCLUDEDEP@ portfun.d +@INCLUDEDEP@ print.d +@INCLUDEDEP@ rational.d +@INCLUDEDEP@ read.d +@INCLUDEDEP@ regexp.d +@INCLUDEDEP@ resolve.d +@INCLUDEDEP@ sema.d +@INCLUDEDEP@ setjmpup.d +@INCLUDEDEP@ sfs.d +@INCLUDEDEP@ sort.d +@INCLUDEDEP@ startup.d +@INCLUDEDEP@ string.d +@INCLUDEDEP@ struct.d +@INCLUDEDEP@ symbol.d +@INCLUDEDEP@ syntax.d +@INCLUDEDEP@ thread.d +@INCLUDEDEP@ type.d +@INCLUDEDEP@ validate.d +@INCLUDEDEP@ vector.d +@INCLUDEDEP@ foreign.d +@INCLUDEDEP@ main.d + $(XSRCDIR)/mzobj.cxx: $(XFORMDEP) $(XFORM_NOPRECOMP) $(XSRCDIR)/mzobj.cxx $(DEF_C_DIRS) $(srcdir)/../../mzcom/mzobj.cxx @@ -324,8 +389,6 @@ $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/bignum.c -o bignum.@LTO@ bool.@LTO@: $(XSRCDIR)/bool.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/bool.c -o bool.@LTO@ -builtin.@LTO@: $(XSRCDIR)/builtin.c - $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/builtin.c -o builtin.@LTO@ char.@LTO@: $(XSRCDIR)/char.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/char.c -o char.@LTO@ compenv.@LTO@: $(XSRCDIR)/compenv.c @@ -373,12 +436,12 @@ $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/jitstate.c -o jitstate.@LTO@ letrec_check.@LTO@: $(XSRCDIR)/letrec_check.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/letrec_check.c -o letrec_check.@LTO@ +linklet.@LTO@: $(XSRCDIR)/linklet.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/linklet.c -o linklet.@LTO@ list.@LTO@: $(XSRCDIR)/list.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@ marshal.@LTO@: $(XSRCDIR)/marshal.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/marshal.c -o marshal.@LTO@ -module.@LTO@: $(XSRCDIR)/module.c - $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@ mzrt.@LTO@: $(SRCDIR)/mzrt.c $(XFORMDEP) $(MZRTDEP) $(CC) $(ALL_CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@ network.@LTO@: $(XSRCDIR)/network.c @@ -415,6 +478,10 @@ $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/setjmpup.c -o setjmpup.@LTO@ sfs.@LTO@: $(XSRCDIR)/sfs.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/sfs.c -o sfs.@LTO@ +sort.@LTO@: $(XSRCDIR)/sort.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/sort.c -o sort.@LTO@ +startup.@LTO@: $(XSRCDIR)/startup.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/startup.c -o startup.@LTO@ string.@LTO@: $(XSRCDIR)/string.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/string.c -o string.@LTO@ struct.@LTO@: $(XSRCDIR)/struct.c @@ -550,8 +617,8 @@ MW_RACKET_LIBS = gc2/libracket3m.dll.a @LDFLAGS@ @LIBS@ -ldelayimp -static-libgcc -../racket@MMM@@MINGW@: libracket3m.dll.a main.@LTO@ ../rres.o $(SPECIALIZINGOBJECTS) - cd ..; @MZLINKER@ -o racket@MMM@ gc2/main.@LTO@ rres.o $(SPECIALIZINGOBJECTS) $(MW_RACKET_LIBS) +../racket@MMM@@MINGW@: libracket3m.dll.a main.@LTO@ ../MemoryModule.@LTO@ ../rres.o $(SPECIALIZINGOBJECTS) + cd ..; @MZLINKER@ -o racket@MMM@ gc2/main.@LTO@ MemoryModule.@LTO@ rres.o $(SPECIALIZINGOBJECTS) $(MW_RACKET_LIBS) ../mzcom@MMM@@NOT_MINGW@: $(NOOP) @@ -561,9 +628,13 @@ clean: /bin/rm -f ../racket@MMM@ *.@LTO@ $(XSRCDIR)/* - /bin/rm -rf xform-collects /bin/rm -rf Racket.framework +# If "cstartup.inc" hasn't been built, yet, create it as +# a redirect to "startup.inc" +../cstartup.inc: + echo '#include "startup.inc"' > ../cstartup.inc + #-------------------------------------------------- test.@LTO@: $(srcdir)/test.c @@ -571,3 +642,4 @@ gct: test.@LTO@ gc2.@LTO@ $(CC) -o gct test.@LTO@ gc2.@LTO@ + diff -Nru racket-6.12+ppa1/src/racket/gc2/newgc.c racket-7.0+ppa1/src/racket/gc2/newgc.c --- racket-6.12+ppa1/src/racket/gc2/newgc.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/newgc.c 2018-07-27 22:12:02.000000000 +0000 @@ -24,7 +24,7 @@ #define NEWGC_BTC_ACCOUNT /* Configuration of the nursery (a.k.a. generation 0) */ -#define GEN0_INITIAL_SIZE (1 * 1024 * 1024) +#define GEN0_INITIAL_SIZE (4 * 1024 * 1024) #define GEN0_SIZE_FACTOR 0.5 #define GEN0_SIZE_ADDITION (512 * 1024) #define GEN0_MAX_SIZE (32 * 1024 * 1024) @@ -66,7 +66,7 @@ /* Conservatively force a major GC after a certain number minor GCs (except in incremental mode). It should be ok to set this value - arbitraily high, while experience suggests that 100 would be + arbitrarily high, while experience suggests that 100 would be excessively conservative. */ #define FORCE_MAJOR_AFTER_COUNT 1000 @@ -802,8 +802,8 @@ if (!inheritgc) { register_weak_traversers(gc); + initialize_signal_handler(gc); } - initialize_signal_handler(gc); GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1); GC_add_roots(&gc->park_fsave, (char *)&gc->park_fsave + sizeof(gc->park_fsave) + 1); GC_add_roots(&gc->park_isave, (char *)&gc->park_isave + sizeof(gc->park_isave) + 1); @@ -1508,6 +1508,10 @@ int scheme_gc_slow_path_started = 1; static int TAKE_SLOW_PATH() { +#ifdef MZ_USE_PLACES + if (!MASTERGC) return 0; +#endif + if (!scheme_gc_slow_path_started) return 0; stress_counter++; if (stress_counter > GC_TRIGGER_COUNT) @@ -6067,6 +6071,7 @@ GC_get_type_name_proc get_type_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, + GC_record_traced_filter_proc record_traced_filter, GC_print_traced_filter_proc print_traced_filter, GC_print_tagged_value_proc print_tagged_value, int path_length_limit, @@ -6106,7 +6111,8 @@ for_each_struct(obj_start, gcWORDS_TO_BYTES(info->size)); } if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { - register_traced_object(obj_start); + if (!record_traced_filter || record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6131,7 +6137,8 @@ } if (((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) || ((-tag >= min_trace_for_tag) && (-tag <= max_trace_for_tag))) { - register_traced_object(obj_start); + if (record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6159,7 +6166,8 @@ for_each_struct(obj_start, gcWORDS_TO_BYTES(info->size)); } if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { - register_traced_object(obj_start); + if (record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6313,7 +6321,7 @@ void GC_dump(void) { - GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, NULL, 0, NULL); + GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, NULL, NULL, 0, NULL); } #ifdef MZ_GC_BACKTRACE @@ -6330,7 +6338,11 @@ } #endif return page && ((page->page_type == PAGE_TAGGED) - || (page->page_type == PAGE_PAIR)); + || (page->page_type == PAGE_PAIR) + || ((page->page_type == PAGE_BIG) + && (BIG_PAGE_TO_OBJHEAD(page)->type == PAGE_TAGGED)) + || ((page->page_type == PAGE_MED_NONATOMIC) + && (MED_OBJHEAD(p, page->obj_size)->type == PAGE_TAGGED))); } int GC_is_tagged_start(void *p) diff -Nru racket-6.12+ppa1/src/racket/gc2/setup.rkt racket-7.0+ppa1/src/racket/gc2/setup.rkt --- racket-6.12+ppa1/src/racket/gc2/setup.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/setup.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ - -(when (directory-exists? "xform-collects") - (printf "Removing old xform-collects tree...\n") - (let loop ([dir "xform-collects"]) - (for-each (lambda (x) - (let ([x (build-path dir x)]) - (when (file-exists? x) - (delete-file x)) - (when (directory-exists? x) - (loop x)))) - (directory-list dir)))) - -(printf "Copying tree...\n") - -(use-compiled-file-paths null) - -(unless (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (collection-path "racket")) - (let ([p (build-path (current-load-relative-directory) - 'up - 'up - 'up - "lib" - "collects")]) - (printf "Setting collection path: ~s\n" p) - (current-library-collection-paths - (list p)))) - -(require syntax/moddep - compiler/cm) - -(define (go mod-path rel-to target) - (let* ([path (if target - mod-path - (if (module-path-index? mod-path) - (resolve-module-path-index mod-path rel-to) - (resolve-module-path mod-path rel-to)))]) - (unless (symbol? path) - ;; Copy file to here. The filename is from the resolved module - ;; path, so it is ".rkt" even if the source is ".ss". - (let* ([path (if (pair? path) - (cadr path) ; extra from submodule - path)] - [path (if (file-exists? path) - path - (if (regexp-match? #rx#"[.]rkt$" (if (path? path) - (path->bytes path) - path)) - (let ([p2 (path-replace-suffix path #".ss")]) - (if (file-exists? p2) - p2 - path)) - path))] - [target - (or target - (let-values ([(src-base rel-path) - (let loop ([path (simplify-path path)][accum null]) - (let-values ([(base name dir?) (split-path path)]) - (if (string=? (path->string name) "collects") - (values base (cons "xform-collects" accum)) - (loop base (cons name accum)))))]) - (let loop ([place (current-directory)][rel-path rel-path]) - (if (null? (cdr rel-path)) - (build-path place (car rel-path)) - (let ([next (build-path place (car rel-path))]) - (unless (directory-exists? next) - (make-directory next)) - (loop next (cdr rel-path)))))))]) - (unless (file-exists? target) - (printf "Copying ~a to ~a\n" path target) - (copy-file path target) - (let ([code (get-module-code path "no-such-dir")]) - (map (lambda (x) - (go x path #f)) - (apply append (map cdr (module-compiled-imports code)))))))))) - -(unless (directory-exists? "xform-collects") - (make-directory "xform-collects")) -(unless (directory-exists? "xform-collects/xform") - (make-directory "xform-collects/xform")) - -(go (build-path (current-load-relative-directory) "xform-mod.rkt") - #f - "xform-collects/xform/xform-mod.rkt") -;; Readers: -(map (lambda (r) (go r #f #f)) - '(s-exp/lang/reader - racket/base/lang/reader - racket/runtime-config)) - -(current-library-collection-paths - (list (build-path (current-directory) "xform-collects"))) - -(printf "Compiling xform support...\n") - -(let ([mk-cm make-compilation-manager-load/use-compiled-handler] - [old-namespace (current-namespace)]) - (parameterize ([current-namespace (make-empty-namespace)]) - (namespace-attach-module old-namespace ''#%builtin) - (parameterize ([use-compiled-file-paths (list "compiled")]) - (parameterize ([current-load/use-compiled (mk-cm)]) - (namespace-require 'racket/base) - - (dynamic-require 'xform/xform-mod (void)))))) - -(with-output-to-file "xform-collects/version.rkt" - (lambda () (write (version)))) - -(printf "Done making xform-collects.\n") diff -Nru racket-6.12+ppa1/src/racket/gc2/xform.rkt racket-7.0+ppa1/src/racket/gc2/xform.rkt --- racket-6.12+ppa1/src/racket/gc2/xform.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/gc2/xform.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -;; This program reads Racket/GRacket C/C++ source and transforms it -;; to work with precise garbage collection or(!) PalmOS. The source -;; is C-pre-processed first, then run though a `lex'-like lexer, -;; ctok.rkt. -;; -;; It probably won't work for other C/C++ code, because it -;; doesn't bother *parsing* the source. Instead, it relies on -;; various heuristics that work for Racket/GRacket code. -;; -;; There are also some input hacks, such as START_XFORM_SKIP. -;; -;; Notable assumptions: -;; No calls of the form (f)(...). -;; For arrays, records, and non-pointers, pass by address only. -;; No gc-triggering code in .h files. -;; No instance vars declared as function pointers without a typedef -;; for the func ptr type. -;; -;; BUGS: Doesn't check for pointer comparisons where one of the -;; comparees is a function call. This doesn't happen in -;; Racket/GRacket (or, because of this bug, shouldn't!). -;; -;; Passing the address of a pointer is dangerous; make sure -;; that the pointer is used afterward, otherwise it pointer -;; might not get updated during GC. -;; -;; A "return;" can get converted to "{ ; return; };", -;; which can break "if (...) return; else ...". - -;; To call for Precise GC: -;; racket -qr xform.rkt [--setup] [--precompile] [--precompiled ] [--notes] [--depends] [--cgc] -;; -;; Or: Set the XFORM_PRECOMP=yes environment variable to imply --precompile -;; Set the XFORM_USE_PRECOMP= to imply --precompiled -;; -;; To call for Palm: -;; racket -qr xform.rkt [--setup] [--notes] [--depends] --palm - -;; General code conventions: -;; e means a list of tokens, often ending in a '|;| token -;; -e means a reversed list of tokens - -(module xform '#%kernel - (#%require '#%min-stx) - - (define-values (rel-dir) - (if (string=? "--setup" (vector-ref (current-command-line-arguments) 0)) - (vector-ref (current-command-line-arguments) 1) - ".")) - - (define-values (here-dir) - (let-values ([(base name dir?) - (split-path - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module (quote-syntax here)))))]) - (build-path base rel-dir))) - - (if (string=? "--setup" - (vector-ref (current-command-line-arguments) 0)) - - ;; Setup an xform-collects tree for running xform. - ;; Delete existing xform-collects tree if it's for an old version - (let retry () - (parameterize ([current-directory rel-dir]) - (unless (and (file-exists? "xform-collects/version.rkt") - (equal? (version) - (with-input-from-file "xform-collects/version.rkt" read)) - (>= (file-or-directory-modify-seconds (build-path "xform-collects/xform/xform-mod.rkt")) - (file-or-directory-modify-seconds (build-path here-dir "xform-mod.rkt")))) - ;; In case multiple xforms run in parallel, use a lock file - ;; so that only one is building. - (let ([lock-file "XFORM-LOCK"]) - ((call-with-escape-continuation - (lambda (escape) - (parameterize ([uncaught-exception-handler - (lambda (exn) - (escape - (lambda () - (if (exn:fail:filesystem:exists? exn) - (begin - (printf "Lock file exists: ~a\n" - (path->complete-path lock-file)) - (printf " (If this isn't a parallel make, then delete it.)\n") - (printf " Waiting until the lock file disappears...\n") - (let loop () - (flush-output) - (sleep 0.1) - (if (file-exists? lock-file) - (loop) - (printf " ... continuing\n"))) - (retry)) - (raise exn)))))]) - (dynamic-wind - (lambda () - (close-output-port (open-output-file lock-file 'error))) - (lambda () - (namespace-require 'racket/base) - (load (build-path here-dir "setup.rkt")) - void) - (lambda () - (delete-file lock-file)))))))))) - - (use-compiled-file-paths '("compiled")) - - (current-library-collection-paths (list (build-path (build-path (current-directory) rel-dir) "xform-collects"))) - - (let ([ns (make-empty-namespace)]) - (dynamic-require ''#%builtin #f) - (namespace-attach-module (current-namespace) ''#%builtin ns) - (current-namespace ns)) - - (error-print-width 100) - - (dynamic-require 'xform/xform-mod #f)) - - ;; Otherwise, we assume that it's ok to use the collects - (dynamic-require (build-path here-dir - "xform-mod.rkt") - #f))) diff -Nru racket-6.12+ppa1/src/racket/include/mzwin3m.def racket-7.0+ppa1/src/racket/include/mzwin3m.def --- racket-6.12+ppa1/src/racket/include/mzwin3m.def 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/mzwin3m.def 2018-07-27 22:12:02.000000000 +0000 @@ -195,11 +195,6 @@ scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval - scheme_eval_compiled_stx_string - scheme_load_compiled_stx_string - scheme_compiled_stx_symbol - scheme_eval_compiled_sized_string - scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -548,21 +543,16 @@ scheme_make_envunbox scheme_lookup_global scheme_global_bucket - scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket - scheme_install_macro - scheme_save_initial_module_set - scheme_primitive_module - scheme_finish_primitive_module - scheme_set_primitive_module_phaseless - scheme_protect_primitive_provide scheme_make_modidx - scheme_apply_for_syntax_in_env scheme_dynamic_require + scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path + scheme_is_module_path_index + scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff -Nru racket-6.12+ppa1/src/racket/include/mzwin.def racket-7.0+ppa1/src/racket/include/mzwin.def --- racket-6.12+ppa1/src/racket/include/mzwin.def 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/mzwin.def 2018-07-27 22:12:02.000000000 +0000 @@ -195,11 +195,6 @@ scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval - scheme_eval_compiled_stx_string - scheme_load_compiled_stx_string - scheme_compiled_stx_symbol - scheme_eval_compiled_sized_string - scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array scheme_malloc_code scheme_malloc_permanent_code @@ -534,21 +529,16 @@ scheme_make_envunbox scheme_lookup_global scheme_global_bucket - scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket - scheme_install_macro - scheme_save_initial_module_set - scheme_primitive_module - scheme_finish_primitive_module - scheme_set_primitive_module_phaseless - scheme_protect_primitive_provide scheme_make_modidx - scheme_apply_for_syntax_in_env scheme_dynamic_require + scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path + scheme_is_module_path_index + scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff -Nru racket-6.12+ppa1/src/racket/include/racket3m.exp racket-7.0+ppa1/src/racket/include/racket3m.exp --- racket-6.12+ppa1/src/racket/include/racket3m.exp 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/racket3m.exp 2018-07-27 22:12:02.000000000 +0000 @@ -202,11 +202,6 @@ scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval -scheme_eval_compiled_stx_string -scheme_load_compiled_stx_string -scheme_compiled_stx_symbol -scheme_eval_compiled_sized_string -scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -555,21 +550,16 @@ scheme_make_envunbox scheme_lookup_global scheme_global_bucket -scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket -scheme_install_macro -scheme_save_initial_module_set -scheme_primitive_module -scheme_finish_primitive_module -scheme_set_primitive_module_phaseless -scheme_protect_primitive_provide scheme_make_modidx -scheme_apply_for_syntax_in_env scheme_dynamic_require +scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path +scheme_is_module_path_index +scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff -Nru racket-6.12+ppa1/src/racket/include/racket.exp racket-7.0+ppa1/src/racket/include/racket.exp --- racket-6.12+ppa1/src/racket/include/racket.exp 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/racket.exp 2018-07-27 22:12:02.000000000 +0000 @@ -202,11 +202,6 @@ scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval -scheme_eval_compiled_stx_string -scheme_load_compiled_stx_string -scheme_compiled_stx_symbol -scheme_eval_compiled_sized_string -scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -550,21 +545,16 @@ scheme_make_envunbox scheme_lookup_global scheme_global_bucket -scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket -scheme_install_macro -scheme_save_initial_module_set -scheme_primitive_module -scheme_finish_primitive_module -scheme_set_primitive_module_phaseless -scheme_protect_primitive_provide scheme_make_modidx -scheme_apply_for_syntax_in_env scheme_dynamic_require +scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path +scheme_is_module_path_index +scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff -Nru racket-6.12+ppa1/src/racket/include/scheme.h racket-7.0+ppa1/src/racket/include/scheme.h --- racket-6.12+ppa1/src/racket/include/scheme.h 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/scheme.h 2018-07-27 22:12:02.000000000 +0000 @@ -702,13 +702,19 @@ #define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch)) #define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)] -#define scheme_uchar_find(table, x) (table[(x >> 8) & 0x1FFF][x & 0xFF]) +#define SCHEME_UCHAR_FIND_SHIFT 8 +#define SCHEME_UCHAR_FIND_HI_MASK 0x1FFF +#define SCHEME_UCHAR_FIND_LO_MASK 0xFF + +#define scheme_uchar_find(table, x) (table[(x >> SCHEME_UCHAR_FIND_SHIFT) & SCHEME_UCHAR_FIND_HI_MASK][x & SCHEME_UCHAR_FIND_LO_MASK]) + +#define SCHEME_ISSPACE_BIT 0x10 #define scheme_isblank(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1) #define scheme_issymbol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2) #define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4) #define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8) -#define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x10) +#define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & SCHEME_ISSPACE_BIT) /* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */ #define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40) #define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80) @@ -1168,15 +1174,6 @@ struct Scheme_Overflow *overflow; - struct Scheme_Comp_Env *current_local_env; - Scheme_Object *current_local_scope; - Scheme_Object *current_local_use_scope; - Scheme_Object *current_local_name; - Scheme_Object *current_local_modidx; - Scheme_Env *current_local_menv; - Scheme_Object *current_local_bindings; - intptr_t current_phase_shift; - struct Scheme_Marshal_Tables *current_mt; struct Optimize_Info *constant_folding; /* compiler hack */ @@ -1328,31 +1325,14 @@ MZCONFIG_INIT_EXN_HANDLER, - MZCONFIG_EVAL_HANDLER, - MZCONFIG_COMPILE_HANDLER, - MZCONFIG_LOAD_HANDLER, - MZCONFIG_LOAD_COMPILED_HANDLER, - MZCONFIG_PRINT_HANDLER, MZCONFIG_PROMPT_READ_HANDLER, MZCONFIG_READ_HANDLER, MZCONFIG_READ_INPUT_PORT_HANDLER, - MZCONFIG_READTABLE, - MZCONFIG_READER_GUARD, - - MZCONFIG_CAN_READ_GRAPH, - MZCONFIG_CAN_READ_COMPILED, - MZCONFIG_CAN_READ_BOX, + MZCONFIG_CASE_SENS, MZCONFIG_CAN_READ_PIPE_QUOTE, - MZCONFIG_CAN_READ_DOT, - MZCONFIG_CAN_READ_INFIX_DOT, - MZCONFIG_CAN_READ_QUASI, - MZCONFIG_CAN_READ_READER, - MZCONFIG_CAN_READ_LANG, - MZCONFIG_READ_DECIMAL_INEXACT, - MZCONFIG_READ_CDOT, - + MZCONFIG_PRINT_GRAPH, MZCONFIG_PRINT_STRUCT, MZCONFIG_PRINT_BOX, @@ -1366,12 +1346,6 @@ MZCONFIG_PRINT_LONG_BOOLEAN, MZCONFIG_PRINT_AS_QQ, - MZCONFIG_CASE_SENS, - MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, - MZCONFIG_CURLY_BRACES_ARE_PARENS, - MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, - MZCONFIG_CURLY_BRACES_ARE_TAGGED, - MZCONFIG_ERROR_PRINT_WIDTH, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, @@ -1389,18 +1363,9 @@ MZCONFIG_CODE_INSPECTOR, MZCONFIG_PLUMBER, - MZCONFIG_USE_COMPILED_KIND, - MZCONFIG_USE_COMPILED_ROOTS, - MZCONFIG_USE_USER_PATHS, - MZCONFIG_USE_LINK_PATHS, - MZCONFIG_USE_COMPILED_FILE_CHECK, - MZCONFIG_LOAD_DIRECTORY, MZCONFIG_WRITE_DIRECTORY, - MZCONFIG_COLLECTION_PATHS, - MZCONFIG_COLLECTION_LINKS, - MZCONFIG_PORT_PRINT_HANDLER, MZCONFIG_LOAD_EXTENSION_HANDLER, @@ -1413,10 +1378,7 @@ MZCONFIG_RANDOM_STATE, - MZCONFIG_CURRENT_MODULE_RESOLVER, - MZCONFIG_CURRENT_MODULE_NAME, MZCONFIG_CURRENT_MODULE_SRC, - MZCONFIG_CURRENT_MODULE_LOAD_PATH, MZCONFIG_ERROR_PRINT_SRCLOC, @@ -1439,8 +1401,6 @@ MZCONFIG_LOAD_DELAY_ENABLED, MZCONFIG_DELAY_LOAD_INFO, - MZCONFIG_EXPAND_OBSERVE, - MZCONFIG_LOGGER, __MZCONFIG_BUILTIN_COUNT__ @@ -1589,13 +1549,6 @@ #define SCHEME_GUARD_FILE_EXISTS 0x10 /*========================================================================*/ -/* modules */ -/*========================================================================*/ - -typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, intptr_t phase_shift, - Scheme_Object *self_modidx, void *data); - -/*========================================================================*/ /* evaluation */ /*========================================================================*/ @@ -1895,6 +1848,8 @@ MZ_EXTERN void scheme_set_cross_compile_mode(int); MZ_EXTERN void scheme_set_logging(int syslog_level, int stderr_level); MZ_EXTERN void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level); +MZ_EXTERN void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level); +MZ_EXTERN void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level); MZ_EXTERN int scheme_get_allow_set_undefined(); @@ -1932,7 +1887,6 @@ MZ_EXTERN void (*scheme_notify_multithread)(int on); MZ_EXTERN void (*scheme_wakeup_on_input)(void *fds); MZ_EXTERN int (*scheme_check_for_break)(void); -MZ_EXTERN Scheme_Object *(*scheme_module_demand_hook)(int c, Scheme_Object **a); #ifdef MZ_PRECISE_GC MZ_EXTERN void *(*scheme_get_external_stack_val)(void); MZ_EXTERN void (*scheme_set_external_stack_val)(void *); @@ -1967,6 +1921,9 @@ MZ_EXTERN void scheme_set_compiled_file_roots(Scheme_Object *list); #ifdef DOS_FILE_SYSTEM MZ_EXTERN void scheme_set_dll_path(wchar_t *s); +typedef void *(*scheme_dll_open_proc)(const char *name, int as_global); +typedef void *(*scheme_dll_find_object_proc)(void *h, const char *name); +MZ_EXTERN void scheme_set_dll_procs(scheme_dll_open_proc, scheme_dll_find_object_proc); #endif MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs); diff -Nru racket-6.12+ppa1/src/racket/include/schthread.h racket-7.0+ppa1/src/racket/include/schthread.h --- racket-6.12+ppa1/src/racket/include/schthread.h 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/include/schthread.h 2018-07-27 22:12:02.000000000 +0000 @@ -35,6 +35,7 @@ # else # define THREAD_LOCAL __declspec(thread) # define MZ_THREAD_EXTERN extern +# define IMPLEMENT_THREAD_LOCAL_VIA_OFFSET # define IMPLEMENT_THREAD_LOCAL_EXTERNALLY_VIA_PROC # endif # else @@ -158,7 +159,6 @@ void *jit_buffer_cache_; intptr_t jit_buffer_cache_size_; int jit_buffer_cache_registered_; - struct Scheme_Object *quick_stx_; int scheme_continuation_application_count_; int scheme_cont_capture_count_; int scheme_prompt_capture_count_; @@ -167,8 +167,6 @@ struct Scheme_Prompt *available_regular_prompt_; struct Scheme_Dynamic_Wind *available_prompt_dw_; struct Scheme_Meta_Continuation *available_prompt_mc_; - struct Scheme_Object *cwv_stx_; - int cwv_stx_phase_; struct Scheme_Cont *offstack_cont_; struct Scheme_Overflow *offstack_overflow_; struct Scheme_Overflow_Jmp *scheme_overflow_jmp_; @@ -187,9 +185,6 @@ mz_long_double scheme_jit_save_extfp2_; #endif struct Scheme_Bucket_Table *starts_table_; - struct Scheme_Bucket_Table *submodule_empty_modidx_table_; - struct Scheme_Modidx *modidx_caching_chain_; - struct Scheme_Object *global_shift_cache_; struct mz_proc_thread *proc_thread_self_; struct Scheme_Object *scheme_orig_stdout_port_; struct Scheme_Object *scheme_orig_stderr_port_; @@ -233,15 +228,8 @@ void *stack_copy_cache_[STACK_COPY_CACHE_SIZE]; intptr_t stack_copy_size_cache_[STACK_COPY_CACHE_SIZE]; int scc_pos_; - mzlonglong scope_counter_; - struct Scheme_Object *last_phase_shift_; - struct Scheme_Object *nominal_ipair_cache_; - struct Scheme_Bucket_Table *taint_intern_table_; - struct Binding_Cache_Entry *binding_cache_table_; - intptr_t binding_cache_pos_; - intptr_t binding_cache_len_; - struct Scheme_Scope_Set *recent_scope_sets_[2][NUM_RECENT_SCOPE_SETS]; - int recent_scope_sets_pos_[2]; + struct Scheme_Instance *scheme_startup_instance_; + struct startup_instance_top_t *c_startup_instance_top_; struct Scheme_Thread *scheme_current_thread_; struct Scheme_Thread *scheme_main_thread_; struct Scheme_Thread *scheme_first_thread_; @@ -292,16 +280,12 @@ struct Scheme_Logger *scheme_gc_logger_; struct Scheme_Logger *scheme_future_logger_; struct Scheme_Logger *scheme_place_logger_; - int intdef_counter_; int scheme_overflow_count_; struct Scheme_Object *original_pwd_; void *file_path_wc_buffer_; intptr_t scheme_hash_request_count_; intptr_t scheme_hash_iteration_count_; - struct Scheme_Env *initial_modules_env_; - int num_initial_modules_; - struct Scheme_Object **initial_modules_; - int generate_lifts_count_; + struct Scheme_Bucket_Table *scheme_namespace_to_env_; int special_is_ok_; int scheme_force_port_closed_; int fd_reserved_; @@ -334,7 +318,6 @@ int gensym_counter_; struct Scheme_Object *dummy_input_port_; struct Scheme_Object *dummy_output_port_; - struct Scheme_Bucket_Table *place_local_modpath_table_; struct Scheme_Hash_Table *opened_libs_; struct mzrt_mutex *jit_lock_; struct free_list_entry *free_list_; @@ -355,8 +338,6 @@ struct Scheme_Place *all_child_places_; struct Scheme_Place_Bi_Channel_Link *place_channel_links_; struct Scheme_Object **reusable_ifs_stack_; - struct Scheme_Object *empty_self_shift_cache_; - struct Scheme_Bucket_Table *scheme_module_code_cache_; struct Scheme_Object *group_member_cache_; struct Scheme_Prefix *scheme_prefix_finalize_; struct Scheme_Prefix *scheme_inc_prefix_finalize_; @@ -373,17 +354,9 @@ struct Scheme_Object *configuration_callback_cache_[2]; struct FFI_Orig_Place_Call *cached_orig_place_todo_; struct Scheme_Hash_Table *ffi_lock_ht_; - struct Scheme_Object *scheme_sys_wraps0_; - struct Scheme_Object *scheme_sys_wraps1_; - struct Scheme_Object *scheme_module_stx_; - struct Scheme_Object *scheme_modulestar_stx_; - struct Scheme_Object *scheme_module_begin_stx_; - struct Scheme_Object *scheme_begin_stx_; - struct Scheme_Object *scheme_define_values_stx_; - struct Scheme_Object *scheme_define_syntaxes_stx_; - struct Scheme_Object *scheme_top_stx_; - struct Scheme_Object *scheme_begin_for_syntax_stx_; - struct Scheme_Object *more_constant_stxes_[NUM_MORE_CONSTANT_STXES]; + struct Scheme_Object *is_syntax_proc_; + struct Scheme_Object *expander_syntax_to_datum_proc_; + struct Scheme_Hash_Table *local_primitive_tables_; } Thread_Local_Variables; #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) @@ -391,6 +364,7 @@ # include MZ_EXTERN pthread_key_t scheme_thread_local_key; # if defined(__APPLE__) && defined(__MACH__) +# define PREFER_TO_CACHE_THREAD_LOCAL MZ_EXTERN int scheme_thread_local_offset; # endif # ifndef INLINE_GETSPECIFIC_ASSEMBLY_CODE @@ -513,6 +487,13 @@ END_XFORM_SKIP; XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION; # endif +# elif defined (IMPLEMENT_THREAD_LOCAL_VIA_OFFSET) +MZ_THREAD_EXTERN THREAD_LOCAL Thread_Local_Variables scheme_thread_locals_space; +extern int scheme_tls_delta; +# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)((char *)&scheme_thread_locals_space + scheme_tls_delta)) +# ifdef MZ_XFORM +XFORM_GC_VARIABLE_STACK_THROUGH_DELTA; +# endif # else MZ_THREAD_EXTERN THREAD_LOCAL Thread_Local_Variables scheme_thread_locals; # define scheme_get_thread_local_variables() (&scheme_thread_locals) @@ -554,7 +535,6 @@ #define jit_buffer_cache XOA (scheme_get_thread_local_variables()->jit_buffer_cache_) #define jit_buffer_cache_size XOA (scheme_get_thread_local_variables()->jit_buffer_cache_size_) #define jit_buffer_cache_registered XOA (scheme_get_thread_local_variables()->jit_buffer_cache_registered_) -#define quick_stx XOA (scheme_get_thread_local_variables()->quick_stx_) #define scheme_continuation_application_count XOA (scheme_get_thread_local_variables()->scheme_continuation_application_count_) #define scheme_cont_capture_count XOA (scheme_get_thread_local_variables()->scheme_cont_capture_count_) #define scheme_prompt_capture_count XOA (scheme_get_thread_local_variables()->scheme_prompt_capture_count_) @@ -563,8 +543,6 @@ #define available_regular_prompt XOA (scheme_get_thread_local_variables()->available_regular_prompt_) #define available_prompt_dw XOA (scheme_get_thread_local_variables()->available_prompt_dw_) #define available_prompt_mc XOA (scheme_get_thread_local_variables()->available_prompt_mc_) -#define cwv_stx XOA (scheme_get_thread_local_variables()->cwv_stx_) -#define cwv_stx_phase XOA (scheme_get_thread_local_variables()->cwv_stx_phase_) #define offstack_cont XOA (scheme_get_thread_local_variables()->offstack_cont_) #define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_) #define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_) @@ -584,9 +562,6 @@ #define scheme_jit_save_extfp2 XOA (scheme_get_thread_local_variables()->scheme_jit_save_extfp2_) #endif #define starts_table XOA (scheme_get_thread_local_variables()->starts_table_) -#define submodule_empty_modidx_table XOA (scheme_get_thread_local_variables()->submodule_empty_modidx_table_) -#define modidx_caching_chain XOA (scheme_get_thread_local_variables()->modidx_caching_chain_) -#define global_shift_cache XOA (scheme_get_thread_local_variables()->global_shift_cache_) #define proc_thread_self XOA (scheme_get_thread_local_variables()->proc_thread_self_) #define scheme_orig_stdout_port XOA (scheme_get_thread_local_variables()->scheme_orig_stdout_port_) #define scheme_orig_stderr_port XOA (scheme_get_thread_local_variables()->scheme_orig_stderr_port_) @@ -630,15 +605,8 @@ #define stack_copy_cache XOA (scheme_get_thread_local_variables()->stack_copy_cache_) #define stack_copy_size_cache XOA (scheme_get_thread_local_variables()->stack_copy_size_cache_) #define scc_pos XOA (scheme_get_thread_local_variables()->scc_pos_) -#define nominal_ipair_cache XOA (scheme_get_thread_local_variables()->nominal_ipair_cache_) -#define scope_counter XOA (scheme_get_thread_local_variables()->scope_counter_) -#define last_phase_shift XOA (scheme_get_thread_local_variables()->last_phase_shift_) -#define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_) -#define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_) -#define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_) -#define binding_cache_len XOA (scheme_get_thread_local_variables()->binding_cache_len_) -#define recent_scope_sets XOA (scheme_get_thread_local_variables()->recent_scope_sets_) -#define recent_scope_sets_pos XOA (scheme_get_thread_local_variables()->recent_scope_sets_pos_) +#define scheme_startup_instance XOA (scheme_get_thread_local_variables()->scheme_startup_instance_) +#define c_startup_instance_top XOA (scheme_get_thread_local_variables()->c_startup_instance_top_) #define scheme_current_thread XOA (scheme_get_thread_local_variables()->scheme_current_thread_) #define scheme_main_thread XOA (scheme_get_thread_local_variables()->scheme_main_thread_) #define scheme_first_thread XOA (scheme_get_thread_local_variables()->scheme_first_thread_) @@ -690,16 +658,12 @@ #define scheme_gc_logger XOA (scheme_get_thread_local_variables()->scheme_gc_logger_) #define scheme_future_logger XOA (scheme_get_thread_local_variables()->scheme_future_logger_) #define scheme_place_logger XOA (scheme_get_thread_local_variables()->scheme_place_logger_) -#define intdef_counter XOA (scheme_get_thread_local_variables()->intdef_counter_) #define scheme_overflow_count XOA (scheme_get_thread_local_variables()->scheme_overflow_count_) #define original_pwd XOA (scheme_get_thread_local_variables()->original_pwd_) #define file_path_wc_buffer XOA (scheme_get_thread_local_variables()->file_path_wc_buffer_) #define scheme_hash_request_count XOA (scheme_get_thread_local_variables()->scheme_hash_request_count_) #define scheme_hash_iteration_count XOA (scheme_get_thread_local_variables()->scheme_hash_iteration_count_) -#define initial_modules_env XOA (scheme_get_thread_local_variables()->initial_modules_env_) -#define num_initial_modules XOA (scheme_get_thread_local_variables()->num_initial_modules_) -#define initial_modules XOA (scheme_get_thread_local_variables()->initial_modules_) -#define generate_lifts_count XOA (scheme_get_thread_local_variables()->generate_lifts_count_) +#define scheme_namespace_to_env XOA (scheme_get_thread_local_variables()->scheme_namespace_to_env_) #define special_is_ok XOA (scheme_get_thread_local_variables()->special_is_ok_) #define scheme_force_port_closed XOA (scheme_get_thread_local_variables()->scheme_force_port_closed_) #define fd_reserved XOA (scheme_get_thread_local_variables()->fd_reserved_) @@ -732,7 +696,6 @@ #define gensym_counter XOA (scheme_get_thread_local_variables()->gensym_counter_) #define dummy_input_port XOA (scheme_get_thread_local_variables()->dummy_input_port_) #define dummy_output_port XOA (scheme_get_thread_local_variables()->dummy_output_port_) -#define place_local_modpath_table XOA (scheme_get_thread_local_variables()->place_local_modpath_table_) #define opened_libs XOA (scheme_get_thread_local_variables()->opened_libs_) #define jit_lock XOA (scheme_get_thread_local_variables()->jit_lock_) #define free_list XOA (scheme_get_thread_local_variables()->free_list_) @@ -753,8 +716,6 @@ #define all_child_places XOA (scheme_get_thread_local_variables()->all_child_places_) #define place_channel_links XOA (scheme_get_thread_local_variables()->place_channel_links_) #define reusable_ifs_stack XOA (scheme_get_thread_local_variables()->reusable_ifs_stack_) -#define empty_self_shift_cache XOA (scheme_get_thread_local_variables()->empty_self_shift_cache_) -#define scheme_module_code_cache XOA (scheme_get_thread_local_variables()->scheme_module_code_cache_) #define group_member_cache XOA (scheme_get_thread_local_variables()->group_member_cache_) #define scheme_prefix_finalize XOA (scheme_get_thread_local_variables()->scheme_prefix_finalize_) #define scheme_inc_prefix_finalize XOA (scheme_get_thread_local_variables()->scheme_inc_prefix_finalize_) @@ -771,17 +732,9 @@ #define configuration_callback_cache XOA (scheme_get_thread_local_variables()->configuration_callback_cache_) #define cached_orig_place_todo XOA (scheme_get_thread_local_variables()->cached_orig_place_todo_) #define ffi_lock_ht XOA (scheme_get_thread_local_variables()->ffi_lock_ht_) -#define scheme_sys_wraps0 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps0_) -#define scheme_sys_wraps1 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps1_) -#define scheme_module_stx XOA (scheme_get_thread_local_variables()->scheme_module_stx_) -#define scheme_modulestar_stx XOA (scheme_get_thread_local_variables()->scheme_modulestar_stx_) -#define scheme_module_begin_stx XOA (scheme_get_thread_local_variables()->scheme_module_begin_stx_) -#define scheme_begin_stx XOA (scheme_get_thread_local_variables()->scheme_begin_stx_) -#define scheme_define_values_stx XOA (scheme_get_thread_local_variables()->scheme_define_values_stx_) -#define scheme_define_syntaxes_stx XOA (scheme_get_thread_local_variables()->scheme_define_syntaxes_stx_) -#define scheme_top_stx XOA (scheme_get_thread_local_variables()->scheme_top_stx_) -#define scheme_begin_for_syntax_stx XOA (scheme_get_thread_local_variables()->scheme_begin_for_syntax_stx_) -#define more_constant_stxes XOA (scheme_get_thread_local_variables()->more_constant_stxes_) +#define is_syntax_proc XOA (scheme_get_thread_local_variables()->is_syntax_proc_) +#define expander_syntax_to_datum_proc XOA (scheme_get_thread_local_variables()->expander_syntax_to_datum_proc_) +#define local_primitive_tables XOA (scheme_get_thread_local_variables()->local_primitive_tables_) /* **************************************** */ diff -Nru racket-6.12+ppa1/src/racket/main.c racket-7.0+ppa1/src/racket/main.c --- racket-6.12+ppa1/src/racket/main.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/main.c 2018-07-27 22:12:02.000000000 +0000 @@ -172,8 +172,7 @@ #ifndef UNIX_INIT_FILENAME # define UNIX_INIT_FILENAME "~/.racketrc" -# define WINDOWS_INIT_FILENAME "%%HOMEDIRVE%%\\%%HOMEPATH%%\\racketrc.rktl" -# define MACOS9_INIT_FILENAME "PREFERENCES:racketrc.rktl" +# define WINDOWS_INIT_FILENAME "\\racketrc.rktl" # define INIT_FILENAME_CONF_SYM "interactive-file" # define DEFAULT_INIT_MODULE "racket/interactive" # define USER_INIT_MODULE "interactive.rkt" @@ -312,13 +311,22 @@ #ifdef DOS_FILE_SYSTEM # include "win_tls.inc" +# include "../start/embedded_dll.inc" #endif #ifdef DOS_FILE_SYSTEM +static int load_delayed_done; + void load_delayed() { + if (load_delayed_done) + return; + load_delayed_done = 1; + (void)SetErrorMode(SEM_FAILCRITICALERRORS); + parse_embedded_dlls(); + # ifndef MZ_NO_LIBRACKET_DLL /* Order matters: load dependencies first */ # ifndef MZ_PRECISE_GC @@ -328,6 +336,8 @@ # endif record_dll_path(); + register_embedded_dll_hooks(); + register_win_tls(); } #endif @@ -472,13 +482,13 @@ #ifdef GRAPHICAL_REPL if (!fa->a->alternate_rep) { - a[0] = scheme_intern_symbol("racket/gui/init"); + a[0] = scheme_intern_symbol("racket/gui/base"); a[1] = scheme_intern_symbol("graphical-read-eval-print-loop"); ending_newline = 0; } else #endif { - a[0] = scheme_intern_symbol("racket/base"); + a[0] = scheme_intern_symbol("racket/repl"); a[1] = scheme_intern_symbol("read-eval-print-loop"); } diff -Nru racket-6.12+ppa1/src/racket/make-configure racket-7.0+ppa1/src/racket/make-configure --- racket-6.12+ppa1/src/racket/make-configure 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/make-configure 2018-07-27 22:12:02.000000000 +0000 @@ -15,6 +15,11 @@ echo "Creating $tgt from $src" autoconf "$src" > "$tgt" chmod +x "$tgt" +src="../cs/c/configure.ac" +tgt="../cs/c/configure" +echo "Creating $tgt from $src" +autoconf "$src" > "$tgt" +chmod +x "$tgt" exit 0 |# #lang racket/base diff -Nru racket-6.12+ppa1/src/racket/Makefile.in racket-7.0+ppa1/src/racket/Makefile.in --- racket-6.12+ppa1/src/racket/Makefile.in 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -49,6 +49,8 @@ RUN_THIS_RACKET_CGC = ./racket@CGC@ RUN_THIS_RACKET_MMM = ./racket@MMM@ +SETUP_BOOT = -O "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../setup-go.rkt ../compiled + MZSRC = $(srcdir)/src FOREIGN_DIR = ../foreign @@ -97,10 +99,14 @@ $(MAKE) dynlib $(MAKE) mzlibrary $(MAKE) racket@CGC@ + $(MAKE) cstartup + $(MAKE) mzlibrary + $(MAKE) racket@CGC@ $(MAKE) mzcom@CGC@ 3m: $(MAKE) @CGC_IF_NEEDED_FOR_MMM@ + $(MAKE) cstartup cd gc2; $(MAKE) all cd dynsrc; $(MAKE) dynlib3m cd gc2; $(MAKE) ../racket@MMM@ @@ -137,7 +143,7 @@ cd @GCDIR@; $(MAKE) sproc.@LTO@ $(MAKE) sproc.@LTO@ -gc.@LIBSFX@: +gc.@LIBSFX@: $(NICEAR) $(AR) $(ARFLAGS) @GCDIR@/gc.@LIBSFX@ @GCDIR@/*.@LTO@ # Compilation of the foreign libraries (this compiles all of them) @@ -236,15 +242,18 @@ libmzgc.dll.a: lib/libmzgcxxxxxxx.dll @DLLTOOL@ --def libmzgc.def -D libmzgcxxxxxxx.dll --output-lib libmzgcxxxxxxx.lib --output-exp libmzgcxxxxxxx.lib --output-delaylib libmzgc.dll.a -rres.o : $(srcdir)/../worksp/racket/racket.rc +rres.o: $(srcdir)/../worksp/racket/racket.rc @WINDRES@ -i $(srcdir)/../worksp/racket/racket.rc -o rres.o MW_RACKET_LIBS = libracket.dll.a libmzgc.dll.a @LDFLAGS@ @LIBS@ -ldelayimp -static-libgcc -racket@CGC@@MINGW@: libracket.dll.a libmzgc.dll.a main.@LTO@ $(SPECIALIZINGOBJECTS) rres.o - @MZLINKER@ -o racket@CGC@ main.@LTO@ rres.o $(SPECIALIZINGOBJECTS) $(MW_RACKET_LIBS) +racket@CGC@@MINGW@: libracket.dll.a libmzgc.dll.a main.@LTO@ MemoryModule.@LTO@ $(SPECIALIZINGOBJECTS) rres.o + @MZLINKER@ -o racket@CGC@ main.@LTO@ MemoryModule.@LTO@ rres.o $(SPECIALIZINGOBJECTS) $(MW_RACKET_LIBS) -mingw-other@MINGW@: mzsj86g.o rres.o comres.o com_glue.@LTO@ +MemoryModule.@LTO@: $(srcdir)/../start/MemoryModule.c $(srcdir)/../start/MemoryModule.h + $(CC) -c -I $(srcdir)/../start -o MemoryModule.@LTO@ $(srcdir)/../start/MemoryModule.c + +mingw-other@MINGW@: mzsj86g.o MemoryModule.@LTO@ rres.o comres.o com_glue.@LTO@ $(NOOP) mingw-other@NOT_MINGW@: @@ -264,7 +273,8 @@ MAIN_HEADER_DEPS = $(srcdir)/include/scheme.h $(srcdir)/include/schthread.h $(srcdir)/sconfig.h \ $(srcdir)/src/stypes.h $(srcdir)/cmdline.inc $(srcdir)/parse_cmdl.inc \ - $(srcdir)/delayed.inc $(srcdir)/parse_cmdl.inc + $(srcdir)/../start/config.inc $(srcdir)/../start/delayed.inc $(srcdir)/parse_cmdl.inc \ + $(srcdir)/../start/embedded_dll.inc main.@LTO@: $(srcdir)/main.c $(MAIN_HEADER_DEPS) $(CC) -I$(builddir) -I$(srcdir)/include $(CFLAGS) $(CPPFLAGS) @OPTIONS@ @MZOPTIONS@ $(DEF_C_DIRS) -c $(srcdir)/main.c -o main.@LTO@ @@ -290,27 +300,11 @@ $(CC) -I$(builddir) -I$(srcdir)/include $(CFLAGS) $(CPPFLAGS) @OPTIONS@ @MZOPTIONS@ -c $(srcdir)/../mzcom/com_glue.c -o com_glue.@LTO@ exn: - $(MAKE) $(srcdir)/src/schexn.h - $(MAKE) $(collectsdir)/racket/private/kernstruct.rkt + $(RACKET) -um $(srcdir)/src/makeexn > $(srcdir)/src/schexn.h + $(RACKET) -um $(srcdir)/src/makeexn kernstruct $(collectsdir)/racket/private/kernstruct.rkt -STARTUPDEST = startup.inc CSTARTUPDEST = cstartup.inc -startup: - $(MAKE) $(srcdir)/src/$(STARTUPDEST) -cstartup: - $(MAKE) $(srcdir)/src/$(CSTARTUPDEST) - -total_startup: - awk '{ if (match($$0, "#define USE_COMPILED_STARTUP 1")) print "#define USE_COMPILED_STARTUP 0"; else print }' src/schminc.h > src/schminc.newh - mv src/schminc.newh src/schminc.h - $(MAKE) cgc - rm -rf $(srcdir)/src/$(CSTARTUPDEST) - $(MAKE) $(srcdir)/src/$(CSTARTUPDEST) - awk '{ if (match($$0, "#define USE_COMPILED_STARTUP 0")) print "#define USE_COMPILED_STARTUP 1"; else print }' src/schminc.h > src/schminc.newh - mv src/schminc.newh src/schminc.h - $(MAKE) cgc - MZCONFIGDIR@NOT_MINGW@ = . MZCONFIGDIR@MINGW@ = "$(srcdir)/../worksp" @@ -318,22 +312,41 @@ @RUN_RACKET_CGC@ -cqu $(srcdir)/mkincludes.rkt @DIRCVTPRE@"$(DESTDIR)$(includepltdir)"@DIRCVTPOST@ "$(srcdir)" $(MZCONFIGDIR) cd ..; cp racket/system.rktd "$(DESTDIR)$(libpltdir)/system.rktd" -$(srcdir)/src/schexn.h: $(srcdir)/src/makeexn - $(RACKET) -um $(srcdir)/src/makeexn > $(srcdir)/src/schexn.h -$(collectsdir)/racket/private/kernstruct.rkt: $(srcdir)/src/makeexn - $(RACKET) -um $(srcdir)/src/makeexn kernstruct $(collectsdir)/racket/private/kernstruct.rkt - -$(srcdir)/src/$(STARTUPDEST): $(srcdir)/src/startup.rktl $(srcdir)/src/sstoinct.rkt - $(RACKET) -cu $(srcdir)/src/sstoinct.rkt < $(srcdir)/src/startup.rktl > $(srcdir)/src/$(STARTUPDEST) -$(srcdir)/src/$(CSTARTUPDEST): $(srcdir)/src/startup.rktl $(srcdir)/src/schvers.h $(srcdir)/src/schminc.h - $(RUN_THIS_RACKET_CGC) -cu $(srcdir)/src/sstoinc.rkt $(CSTARTUPEXTRA) $(srcdir)/src/$(CSTARTUPDEST) < $(srcdir)/src/startup.rktl +# The `cstartup` target may update "cstartup.inc", either replacing a +# stub "cstartup.inc" that redirects to "startup.inc" or rebuilding +# because "startup.inc" or "schvers.h" changed; so, during a CGC +# build, we try again after building this target to potentially update +# the CGC build to a compiled-startup build. A particular `cstartup` +# target variant is selected by the `configure` script based on whether +# `--{en,dis}able-cify` is specified; for example `STARTUP_AS_AUTO` +# with be the empty string is neither is specified, in which case +# of the the other targets is selected by a recursive `$(MAKE)`. + +cstartup@STARTUP_AS_AUTO@: + $(MAKE) cstartup_`@RUN_RACKET_CGC@ -cu $(srcdir)/src/startup-select.rkt` + +# For compiling the startup code to bytecode +cstartup@STARTUP_AS_BYTECODE@: + @RUN_RACKET_CGC@ -cu $(srcdir)/src/compile-startup.rkt $(CSTARTUPDEST) cstartup.zo $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h + +# For compiling the startup code to C +cstartup@STARTUP_AS_C@: + @RUN_RACKET_CGC@ -cu $(srcdir)/src/cify-check.rkt $(CSTARTUPDEST) + $(MAKE) cstartup.inc + +cstartup_: + echo "Bad startup choice, probably an error running startup-select.rkt" + exit 1 + +# Running "cify-startup.rkt" through "$(SETUP_BOOT)" generates more +# dependencies in "cstartup.d" for `$(CSTARTUPDEST)` +$(CSTARTUPDEST): $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h + @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) cstartup.inc cstartup.d $(srcdir)/src/cify-startup.rkt $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h +@INCLUDEDEP@ cstartup.d mark: racket -cu $(srcdir)/src/mkmark.rkt $(srcdir)/src < $(srcdir)/src/mzmarksrc.c -cstartup.zo: - $(MAKE) startup CSTARTUPEXTRA='zo' CSTARTUPDEST="../cstartup.zo" - clean@NOT_OSX@: /bin/rm -rf tmp[123456789] tests/tmp[123456789] tests/sub[123] /bin/rm -f tests/*~ @@ -341,6 +354,7 @@ /bin/rm -f mzdyn.o libmzgc.@LIBSFX@ libracket.@LIBSFX@ libracket3m.@LIBSFX@ libdl.a racket racket.multiboot /bin/rm -f include/macosxpre /bin/rm -f include/macosxpre.p + /bin/rm -f $(CSTARTUPDEST) cd gc; $(MAKE) clean cd gc2; $(MAKE) clean cd sgc; $(MAKE) clean @@ -387,7 +401,7 @@ cd ..; rm -f "$(DESTDIR)@MZINSTALLBINDIR@/racket@CGC_INSTALLED@" cd ..; rm -f "$(DESTDIR)@MZINSTALLBINDIR@/racket@MMM_INSTALLED@" cd ..; cp racket/starter@EXE_SUFFIX@ "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" - cp $(srcdir)/dynsrc/starter-sh . + cp $(srcdir)/../start/starter-sh . cd ..; cp racket/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" cd ..; $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" @RUN_RACKET_CGC@ -cu "$(srcdir)/collects-path.rkt" "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" $(DESTDIR)@COLLECTS_PATH@ $(DESTDIR)@CONFIG_PATH@ diff -Nru racket-6.12+ppa1/src/racket/mksystem.rkt racket-7.0+ppa1/src/racket/mksystem.rkt --- racket-6.12+ppa1/src/racket/mksystem.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/mksystem.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,11 +1,11 @@ (module mkincludes '#%kernel - (#%require '#%min-stx) ;; Arguments are ;; [ <3m-exe-suffix> ] (define-values (args) (current-command-line-arguments)) (define-values (ht) - (if (or (= (vector-length args) 1) + (if (if (= (vector-length args) 1) + #t (equal? (vector-ref args (- (vector-length args) 1)) (vector-ref args (- (vector-length args) 2)))) ;; Not cross-compiling @@ -15,7 +15,8 @@ '3m ; GC mode for suffixless executables (if (string=? "" (vector-ref args 2)) '3m - 'cgc)) + 'cgc)) + 'vm (system-type 'vm) 'link (system-type 'link) 'machine (bytes->string/utf-8 (path->bytes (system-library-subpath #f))) 'so-suffix (system-type 'so-suffix) @@ -57,6 +58,7 @@ 'gc (if (string=? "" (vector-ref args 2)) '3m 'cgc) + 'vm 'racket 'link (get-symbol "system_type_link") 'machine library-subpath 'so-suffix (string->bytes/utf-8 (get-string "system_type_so_suffix")) diff -Nru racket-6.12+ppa1/src/racket/sconfig.h racket-7.0+ppa1/src/racket/sconfig.h --- racket-6.12+ppa1/src/racket/sconfig.h 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/sconfig.h 2018-07-27 22:12:02.000000000 +0000 @@ -224,9 +224,10 @@ # define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-openbsd" # elif defined(__sparc64__) # define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc64-openbsd" -/* ARMv7 is a WIP platform on OpenBSD, probably broken here and there */ # elif defined(__arm__) || defined(__thumb__) # define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm-openbsd" +# elif defined(__aarch64__) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "aarch64-openbsd" # elif defined(__hppa__) # define SCHEME_PLATFORM_LIBRARY_SUBPATH "hppa-openbsd" # else @@ -248,6 +249,7 @@ # define USE_IEEE_FP_PREDS # define USE_MAP_ANON +# define IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER # if defined(__x86_64__) # define MZ_USE_JIT_X86_64 diff -Nru racket-6.12+ppa1/src/racket/sgc/Makefile.in racket-7.0+ppa1/src/racket/sgc/Makefile.in --- racket-6.12+ppa1/src/racket/sgc/Makefile.in 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/sgc/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -36,7 +36,8 @@ gcobjects: $(OBJS) EXTRA_DEPS = $(srcdir)/autostat.inc $(srcdir)/collect.inc \ - $(srcdir)/../utils/splay.c $(srcdir)/../utils/schiptr.h + $(srcdir)/../utils/splay.c $(srcdir)/../utils/schiptr.h \ + $(srcdir)/../sconfig.h sgc.@LTO@: $(srcdir)/sgc.c $(EXTRA_DEPS) $(CC) $(CFLAGS) $(CPPFLAGS) @OPTIONS@ -DSGC_EXPORTS -I.. -c $(srcdir)/sgc.c -o sgc.@LTO@ diff -Nru racket-6.12+ppa1/src/racket/sgc/sgc.c racket-7.0+ppa1/src/racket/sgc/sgc.c --- racket-6.12+ppa1/src/racket/sgc/sgc.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/sgc/sgc.c 2018-07-27 22:12:02.000000000 +0000 @@ -832,6 +832,7 @@ return old; } +GC_register_as_executable_callback_Proc GC_register_as_executable_callback; static intptr_t roots_count; static intptr_t roots_size; @@ -961,6 +962,7 @@ { uintptr_t pre_extra; void *p; + int prot; #ifdef MAP_ANON int fd = -1; int flags = MAP_ANON; @@ -972,10 +974,16 @@ fd = open("/dev/zero", O_RDWR); #endif - p = mmap(NULL, (count + 1) << LOG_SECTOR_SEGMENT_SIZE, - PROT_READ | PROT_WRITE | (executable ? PROT_EXEC : 0), + prot = PROT_READ | PROT_WRITE | (executable ? PROT_EXEC : 0); + +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER + if (executable) + prot -= PROT_EXEC; +#endif + + p = mmap(NULL, (count + 1) << LOG_SECTOR_SEGMENT_SIZE, prot, MAP_PRIVATE | flags, fd, 0); - + pre_extra = (uintptr_t)p & (SECTOR_SEGMENT_SIZE - 1); if (pre_extra) pre_extra = SECTOR_SEGMENT_SIZE - pre_extra; @@ -985,12 +993,17 @@ munmap((char *)p + pre_extra + (count << LOG_SECTOR_SEGMENT_SIZE), SECTOR_SEGMENT_SIZE - pre_extra); + if (executable && GC_register_as_executable_callback) + GC_register_as_executable_callback((char *)p + pre_extra, count << LOG_SECTOR_SEGMENT_SIZE, 1); + return (char *)p + pre_extra; } static void munmap_sector(void *p, int count) { munmap(p, count << LOG_SECTOR_SEGMENT_SIZE); + if (GC_register_as_executable_callback) + GC_register_as_executable_callback((char *)p, count << LOG_SECTOR_SEGMENT_SIZE, 0); } static void *os_alloc_pages(size_t len) @@ -1375,7 +1388,7 @@ if (oldsize) memcpy(naya, v, oldsize); if (v) - munmap(v, (oldsize + SECTOR_SEGMENT_SIZE - 1) >> LOG_SECTOR_SEGMENT_SIZE); + free_plain_sector(v, (oldsize + SECTOR_SEGMENT_SIZE - 1) >> LOG_SECTOR_SEGMENT_SIZE, 0); return naya; #elif GET_MEM_VIA_VIRTUAL_ALLOC @@ -1408,7 +1421,7 @@ brk(save_brk); } #elif GET_MEM_VIA_MMAP - munmap(v, (oldsize + SECTOR_SEGMENT_SIZE - 1) >> LOG_SECTOR_SEGMENT_SIZE); + free_plain_sector(v, (oldsize + SECTOR_SEGMENT_SIZE - 1) >> LOG_SECTOR_SEGMENT_SIZE, 0); #elif GET_MEM_VIA_VIRTUAL_ALLOC VirtualFree(v, 0, MEM_RELEASE); #else diff -Nru racket-6.12+ppa1/src/racket/sgc/sgc.h racket-7.0+ppa1/src/racket/sgc/sgc.h --- racket-6.12+ppa1/src/racket/sgc/sgc.h 2016-10-07 19:56:35.000000000 +0000 +++ racket-7.0+ppa1/src/racket/sgc/sgc.h 2018-07-27 22:12:02.000000000 +0000 @@ -54,6 +54,9 @@ SGC_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc); SGC_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); +typedef void (*GC_register_as_executable_callback_Proc)(void *p, size_t sz, int can_exec); +SGC_EXTERN GC_register_as_executable_callback_Proc GC_register_as_executable_callback; + SGC_EXTERN void GC_free(void *); /* ... but only if it's turned on in sgc.c. */ struct GC_Set; diff -Nru racket-6.12+ppa1/src/racket/src/bool.c racket-7.0+ppa1/src/racket/src/bool.c --- racket-6.12+ppa1/src/racket/src/bool.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/bool.c 2018-07-27 22:12:02.000000000 +0000 @@ -64,7 +64,6 @@ Scheme_Object *next, *next_next; Scheme_Object *insp; intptr_t for_chaperone; /* 3 => for impersonator */ - intptr_t eq_for_modidx; } Equal_Info; static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); @@ -82,7 +81,7 @@ scheme_void->type = scheme_void_type; } -void scheme_init_bool (Scheme_Env *env) +void scheme_init_bool (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -96,59 +95,68 @@ p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1); scheme_not_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("not", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("not", p, env); p = scheme_make_folding_prim(true_object_p_prim, "true-object?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_true_object_p_proc = p; - scheme_add_global_constant("true-object?", p, env); + scheme_addto_prim_instance("true-object?", p, env); p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_boolean_p_proc = p; - scheme_add_global_constant("boolean?", p, env); + scheme_addto_prim_instance("boolean?", p, env); p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_eq_proc = p; - scheme_add_global_constant("eq?", p, env); + scheme_addto_prim_instance("eq?", p, env); p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_eqv_proc = p; - scheme_add_global_constant("eqv?", scheme_eqv_proc, env); + scheme_addto_prim_instance("eqv?", scheme_eqv_proc, env); p = scheme_make_noncm_prim(equal_prim, "equal?", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); scheme_equal_proc = p; - scheme_add_global_constant("equal?", scheme_equal_proc, env); + scheme_addto_prim_instance("equal?", scheme_equal_proc, env); - scheme_add_global_constant("equal?/recur", + scheme_addto_prim_instance("equal?/recur", scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3), env); p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("chaperone?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("chaperone?", p, env); p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("impersonator?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("impersonator?", p, env); p = scheme_make_immed_prim(procedure_impersonator_star_p, "procedure-impersonator*?", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("procedure-impersonator*?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure-impersonator*?", p, env); - scheme_add_global_constant("chaperone-of?", + scheme_addto_prim_instance("chaperone-of?", scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2), env); - scheme_add_global_constant("impersonator-of?", + scheme_addto_prim_instance("impersonator-of?", scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2), env); } @@ -193,7 +201,6 @@ eql->next_next = NULL; eql->insp = NULL; eql->for_chaperone = 0; - eql->eq_for_modidx = 0; } static Scheme_Object * @@ -342,7 +349,6 @@ return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2); case scheme_symbol_type: case scheme_keyword_type: - case scheme_scope_type: /* `eqv?` requires `eq?` */ return 0; default: @@ -451,7 +457,7 @@ return is_equal(obj1, obj2, &eql); } -int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) +int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) XFORM_ASSERT_NO_CONVERSION { int v; @@ -462,16 +468,6 @@ return is_slow_equal(obj1, obj2); } -int scheme_equal_modix_eq (Scheme_Object *obj1, Scheme_Object *obj2) -{ - Equal_Info eql; - - init_equal_info(&eql); - eql.eq_for_modidx = 1; - - return is_equal(obj1, obj2, &eql); -} - static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht) { Scheme_Object *v, *prev = obj1, *prev_prev = obj1; @@ -874,41 +870,6 @@ (Scheme_Bucket_Table *)obj2, orig_obj2, eql); } - case scheme_wrap_chunk_type: { - return vector_equal(obj1, obj1, obj2, obj2, eql); - } - case scheme_resolved_module_path_type: - { - obj1 = SCHEME_PTR_VAL(obj1); - obj2 = SCHEME_PTR_VAL(obj2); - goto top; - } - case scheme_module_index_type: - { - Scheme_Modidx *midx1, *midx2; -# include "mzeqchk.inc" - midx1 = (Scheme_Modidx *)obj1; - midx2 = (Scheme_Modidx *)obj2; - if (eql->eq_for_modidx - && (SCHEME_FALSEP(midx1->path) - || SCHEME_FALSEP(midx2->path))) - return 0; - else if (is_equal(midx1->path, midx2->path, eql)) { - obj1 = midx1->base; - obj2 = midx2->base; - goto top; - } - } - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1; - Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2; - if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql)) - return 0; - obj1 = mt1->multi_scopes; - obj2 = mt2->multi_scopes; - goto top; - } default: if (!eql->for_chaperone && ((t1 == scheme_chaperone_type) || (t1 == scheme_proc_chaperone_type))) { diff -Nru racket-6.12+ppa1/src/racket/src/builtin.c racket-7.0+ppa1/src/racket/src/builtin.c --- racket-6.12+ppa1/src/racket/src/builtin.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/builtin.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -/* - Racket - Copyright (c) 2004-2018 PLT Design Inc. - Copyright (c) 2000-2001 Matthew Flatt - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301 USA. - - libscheme - Copyright (c) 1994 Brent Benson - All rights reserved. -*/ - -#include "schpriv.h" -#include "schminc.h" - -/* On the Mac, 68K, store the built-in Racket code as pc-relative */ -#if defined(__MWERKS__) -#if !defined(__POWERPC__) -#pragma pcrelstrings on -#endif -#endif - -Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_sym, Scheme_Object *magic_val, - int multi_ok) -{ - Scheme_Object *port, *expr; - - port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */ - - if (!env) - env = scheme_get_env(NULL); - - expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL, - magic_sym, magic_val, - NULL); - - if (multi_ok) - return _scheme_eval_compiled_multi(expr, env); - else - return _scheme_eval_compiled(expr, env); -} - -Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env) -{ - return scheme_eval_compiled_sized_string_with_magic(str, len, env, NULL, NULL, 0); -} - -void scheme_add_embedded_builtins(Scheme_Env *env) -{ -#define EVAL_ONE_STR(str) scheme_eval_module_string(str, env) -#define EVAL_ONE_SIZED_STR(str, len) scheme_eval_compiled_sized_string(str, len, env) - -#if USE_COMPILED_STARTUP -# include "cstartup.inc" -#else -# include "startup.inc" -#endif -} - -#if defined(__MWERKS__) -#if !defined(__POWERPC__) -#pragma pcrelstrings reset -#endif -#endif diff -Nru racket-6.12+ppa1/src/racket/src/char.c racket-7.0+ppa1/src/racket/src/char.c --- racket-6.12+ppa1/src/racket/src/char.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/char.c 2018-07-27 22:12:02.000000000 +0000 @@ -98,63 +98,87 @@ } } -void scheme_init_char (Scheme_Env *env) +void scheme_init_char (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_char_p_proc); p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_char_p_proc = p; - scheme_add_global_constant("char?", p, env); + scheme_addto_prim_instance("char?", p, env); REGISTER_SO(scheme_interned_char_p_proc); p = scheme_make_folding_prim(interned_char_p, "interned-char?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_interned_char_p_proc = p; - scheme_add_global_constant("interned-char?", p, env); + scheme_addto_prim_instance("interned-char?", p, env); p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("char=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char=?", p, env); + + p = scheme_make_folding_prim(char_lt, "char?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char>?", p, env); + + p = scheme_make_folding_prim(char_lt_eq, "char<=?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char<=?", p, env); + + p = scheme_make_folding_prim(char_gt_eq, "char>=?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char>=?", p, env); + + ADD_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci?", char_gt_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char?", char_gt, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char<=?", char_lt_eq, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char>=?", char_gt_eq, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci?", char_gt_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-whitespace?", char_whitespace, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env); + p = scheme_make_folding_prim(char_whitespace, "char-whitespace?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char-whitespace?", p, env); + + ADD_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env); p = scheme_make_folding_prim(scheme_checked_char_to_integer, "char->integer", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("char->integer", p, env); + scheme_addto_prim_instance("char->integer", p, env); p = scheme_make_folding_prim(scheme_checked_integer_to_char, "integer->char", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("integer->char", p, env); + scheme_addto_prim_instance("integer->char", p, env); - GLOBAL_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env); + ADD_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env); + ADD_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env); } Scheme_Object *scheme_make_char(mzchar ch) diff -Nru racket-6.12+ppa1/src/racket/src/cify-check.rkt racket-7.0+ppa1/src/racket/src/cify-check.rkt --- racket-6.12+ppa1/src/racket/src/cify-check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/cify-check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +;; A fast-loading script to delete "cstartup.inc" if it's not cify output +(module compile-startup '#%kernel + (define-values (dest) (vector-ref (current-command-line-arguments) 0)) + (if (file-exists? dest) + (if (call-with-input-file dest (lambda (i) + (let-values ([(line) (read-line i)]) + (if (string? line) + (regexp-match? #rx"^/[*] version" line) + #f)))) + (void) + (delete-file dest)) + (void))) diff -Nru racket-6.12+ppa1/src/racket/src/cify-startup.rkt racket-7.0+ppa1/src/racket/src/cify-startup.rkt --- racket-6.12+ppa1/src/racket/src/cify-startup.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/cify-startup.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,98 @@ +#lang racket/base +(require (only-in '#%linklet + primitive-table + primitive-in-category?) + racket/cmdline + "../../schemify/schemify.rkt" + "../../schemify/serialize.rkt" + "../../schemify/known.rkt" + "../../schemify/lift.rkt" + "../../cify/main.rkt" + "help-startup.rkt") + +(define dest "cstartup.inc") +(define version-line (format "/* version: ~a */" (version))) + +(define debug? #f) + +(define-values (src vers deps) + (command-line + #:args (src-file vers-file . dep) + (values src-file vers-file dep))) + +(define content (get-linklet src)) +(define version-comparisons (get-version-comparisons vers)) + +(define l (cdddr content)) + +(define (arity->mask a) + (cond + [(exact-nonnegative-integer? a) + (arithmetic-shift 1 a)] + [(arity-at-least? a) + (bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))] + [(list? a) + (let loop ([mask 0] [l a]) + (cond + [(null? l) mask] + [else + (let ([a (car l)]) + (cond + [(or (exact-nonnegative-integer? a) + (arity-at-least? a)) + (loop (bitwise-ior mask (arity->mask a)) (cdr l))] + [else #f]))]))] + [else #f])) + +(define prim-knowns + (for*/hash ([table-name '(#%linklet #%kernel + #%paramz #%unsafe #%foreign + #%futures #%place + #%flfxnum #%extfl #%network)] + [(name v) (in-hash (primitive-table table-name))]) + (values name + (cond + [(procedure? v) + (define arity-mask (arity->mask (procedure-arity v))) + (cond + [(primitive-in-category? name 'omitable) + (known-procedure/succeeds arity-mask)] + [else + (known-procedure arity-mask)])] + [else + a-known-constant])))) + +(printf "Serializable...\n") +(define-values (bodys/constants-lifted lifted-constants) + (time (convert-for-serialize l #t))) + +(printf "Schemify...\n") +(define body + (time + (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() + ;; for cify: + #t + ;; unsafe mode: + #t))) + +(printf "Lift...\n") +(define lifted-body + (time + (lift-in-schemified-body body (lambda (old new) new)))) + +(define converted-body + (append (for/list ([p (in-list lifted-constants)]) + (cons 'define p)) + lifted-body)) + +(cify dest (caddr content) `(begin . ,converted-body) prim-knowns + #:debug? debug? + #:preamble (append (list version-line + (format "#if 0 ~a" version-comparisons) + "#include \"startup.inc\"" + "#else") + (if debug? + (list "# define c_VALIDATE_DEBUG") + (list)) + (list "# include \"startup-glue.inc\"")) + #:postamble (list (format "#endif"))) diff -Nru racket-6.12+ppa1/src/racket/src/compenv.c racket-7.0+ppa1/src/racket/src/compenv.c --- racket-6.12+ppa1/src/racket/src/compenv.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/compenv.c 2018-07-27 22:12:02.000000000 +0000 @@ -24,7 +24,6 @@ */ #include "schpriv.h" -#include "schexpobs.h" #define TABLE_CACHE_MAX_SIZE 2048 @@ -37,12 +36,9 @@ ROSYM static Scheme_Object *undefined_error_name_symbol; -/* If locked, these are probably sharable: */ THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht); THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]); -static void init_compile_data(Scheme_Comp_Env *env); - static void init_scheme_local(); static void init_toplevels(); @@ -83,678 +79,76 @@ } /*========================================================================*/ -/* compilation info management */ -/*========================================================================*/ - -void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec) -{ -} - -void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { - dest[i].comp = 1; - dest[i].dont_mark_local_use = src[drec].dont_mark_local_use; - dest[i].resolve_module_ids = src[drec].resolve_module_ids; - dest[i].pre_unwrapped = 0; - dest[i].testing_constantness = 0; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, - Scheme_Expand_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { - dest[i].comp = 0; - dest[i].depth = src[drec].depth; - dest[i].pre_unwrapped = 0; - dest[i].substitute_bindings = src[drec].substitute_bindings; - dest[i].testing_constantness = 0; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - /* Nothing to do anymore, since we moved max_let_depth to resolve phase */ -} - -void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ - lam[dlrec].comp = 1; - lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; - lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; - lam[dlrec].substitute_bindings = src[dlrec].substitute_bindings; - lam[dlrec].pre_unwrapped = 0; - lam[dlrec].testing_constantness = 0; - lam[dlrec].env_already = 0; - lam[dlrec].comp_flags = src[drec].comp_flags; -} - -void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ -} - -void scheme_compile_rec_done_local(Scheme_Compile_Info *rec, int drec) -{ -} - -/**********************************************************************/ -/* expansion observer */ -/**********************************************************************/ - -/* RMC - * - Defines #%expobs module - * - current-expand-observe - * - ??? (other syntax observations) - */ - -void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj) -{ - if (!SCHEME_PROCP(obs)) { - scheme_signal_error("internal error: expand-observer should never be non-procedure"); - } else { - Scheme_Object *buf[2]; - buf[0] = scheme_make_integer(tag); - if (obj) { - buf[1] = obj; - } else { - buf[1] = scheme_false; - } - scheme_apply(obs, 2, buf); - } -} - -static Scheme_Object * -current_expand_observe(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-expand-observe", - scheme_make_integer(MZCONFIG_EXPAND_OBSERVE), - argc, argv, - 2, NULL, NULL, 0); -} - -/* always returns either procedure or NULL */ -Scheme_Object *scheme_get_expand_observe() -{ - Scheme_Object *obs; - obs = scheme_get_param(scheme_current_config(), - MZCONFIG_EXPAND_OBSERVE); - if (SCHEME_PROCP(obs)) { - return obs; - } else { - return NULL; - } -} - -void scheme_init_expand_observe(Scheme_Env *env) -{ - Scheme_Env *newenv; - Scheme_Object *modname; - - modname = scheme_intern_symbol("#%expobs"); - newenv = scheme_primitive_module(modname, env); - - scheme_add_global_constant - ("current-expand-observe", - scheme_register_parameter(current_expand_observe, - "current-expand-observe", - MZCONFIG_EXPAND_OBSERVE), - newenv); - scheme_finish_primitive_module(newenv); -} - -/*========================================================================*/ /* compile-time env, constructors and simple queries */ /*========================================================================*/ -static void init_compile_data(Scheme_Comp_Env *env) -{ - env->max_use = -1; -} - -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Scheme_Object *scopes, Scheme_Comp_Env *base) -{ - Scheme_Comp_Env *frame; - int count; - - count = num_bindings; - - frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); -#ifdef MZTAG_REQUIRED - frame->type = scheme_rt_comp_env; -#endif - - frame->scopes = scopes; - - { - Scheme_Object **vals; - vals = MALLOC_N(Scheme_Object *, count); - frame->binders = vals; - vals = MALLOC_N(Scheme_Object *, count); - frame->bindings = vals; - } - - frame->num_bindings = num_bindings; - frame->flags = flags; - frame->next = base; - frame->genv = base->genv; - frame->insp = base->insp; - frame->prefix = base->prefix; - frame->in_modidx = base->in_modidx; - frame->observer = base->observer; - - if (base->next) - frame->skip_depth = base->skip_depth + 1; - else - frame->skip_depth = 0; - - init_compile_data(frame); - - if (flags & SCHEME_USE_SCOPES_TO_NEXT) { - if (base->use_scopes_next) - frame->use_scopes_next = base->use_scopes_next; - else - frame->use_scopes_next = base; - } - - return frame; -} - -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) -{ - Scheme_Comp_Env *e; - Comp_Prefix *cp; - - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); -#ifdef MZTAG_REQUIRED - e->type = scheme_rt_comp_env; -#endif - e->num_bindings = 0; - e->next = NULL; - e->genv = genv; - e->insp = insp; - e->flags = flags; - init_compile_data(e); - - cp = MALLOC_ONE_RT(Comp_Prefix); -#ifdef MZTAG_REQUIRED - cp->type = scheme_rt_comp_prefix; -#endif - - e->prefix = cp; - - e->scopes = scopes; - - return e; -} - -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) -{ - Scheme_Comp_Env *e; - - if (SAME_OBJ(scopes, scheme_true)) { - if (genv->stx_context) - scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL); - else - scopes = NULL; - } - - e = scheme_new_comp_env(genv, insp, scopes, flags); - e->prefix = NULL; - - return e; -} - -int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *se; - - for (se = stx_env; NOT_SAME_OBJ(se, env); se = se->next) { - if (!(se->flags & SCHEME_FOR_INTDEF)) - break; - } - return SAME_OBJ(se, env); -} - -void -scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame) -{ - Scheme_Object *binding; - - if ((index >= frame->num_bindings) || (index < 0)) - scheme_signal_error("internal error: scheme_add_binding: " - "index out of range: %d", index); - - if (frame->scopes) { - /* sometimes redundant: */ - val = scheme_stx_adjust_frame_bind_scopes(val, frame->scopes, scheme_env_phase(frame->genv), - SCHEME_STX_ADD); - } - - frame->binders[index] = val; - - if (!frame->bindings[index]) { - if (frame->flags & SCHEME_INTDEF_SHADOW) { - binding = scheme_stx_lookup(val, scheme_env_phase(frame->genv)); - } else { - binding = scheme_gensym(SCHEME_STX_VAL(val)); - scheme_add_local_binding(val, scheme_env_phase(frame->genv), binding); - } - - frame->bindings[index] = binding; - } - - frame->skip_table = NULL; -} - -void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, - Scheme_Object *end_stmts, Scheme_Object *context_key, - Scheme_Object *requires, Scheme_Object *provides, - Scheme_Object *module_lifts) -{ - Scheme_Lift_Capture_Proc *pp; - Scheme_Object *vec; - - pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc)); - *pp = cp; - - vec = scheme_make_vector(9, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_null; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; - SCHEME_VEC_ELS(vec)[2] = data; - SCHEME_VEC_ELS(vec)[3] = end_stmts; - SCHEME_VEC_ELS(vec)[4] = context_key; - SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false); - SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */ - SCHEME_VEC_ELS(vec)[7] = provides; - SCHEME_VEC_ELS(vec)[8] = module_lifts; /* #f => disallowed; #t or (void) => add to slot 0; (void) => `module*` allowed */ - - env->lifts = vec; -} - -void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) -{ - while (orig_env) { - if ((orig_env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(orig_env->lifts)[5])) - break; - orig_env = orig_env->next; - } - - if (orig_env) { - Scheme_Object *vec, *p; - - p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env); - - vec = scheme_make_vector(9, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_false; - SCHEME_VEC_ELS(vec)[1] = scheme_void; - SCHEME_VEC_ELS(vec)[2] = scheme_void; - SCHEME_VEC_ELS(vec)[3] = scheme_false; - SCHEME_VEC_ELS(vec)[4] = scheme_false; - SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */ - SCHEME_VEC_ELS(vec)[6] = scheme_null; - SCHEME_VEC_ELS(vec)[7] = scheme_false; - SCHEME_VEC_ELS(vec)[8] = scheme_false; - - env->lifts = vec; - } -} - -Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env) -{ - while (env && !env->lifts) { - env = env->next; - } - - return env; -} - -Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) -{ - return scheme_reverse(SCHEME_VEC_ELS(env->lifts)[0]); -} - -Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[3]; -} - -Scheme_Object *scheme_frame_get_modules(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[8]; -} - -Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[6]; -} - -Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[7]; -} - -void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) -{ - Scheme_Object **ns, **bs, **vs; - - if (cnt) { - ns = MALLOC_N(Scheme_Object *, cnt); - bs = MALLOC_N(Scheme_Object *, cnt); - vs = MALLOC_N(Scheme_Object *, cnt); - - env->num_bindings = cnt; - env->binders = ns; - env->bindings = bs; - env->vals = vs; - } -} - -void scheme_set_local_syntax(int pos, - Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env, - int replace_value) -{ - Scheme_Object *binding; - - if (!replace_value) { - if (env->flags & SCHEME_CAPTURE_WITHOUT_RENAME) { - binding = scheme_stx_lookup(name, scheme_env_phase(env->genv)); - } else { - if (env->scopes) - name = scheme_stx_adjust_frame_bind_scopes(name, env->scopes, scheme_env_phase(env->genv), - SCHEME_STX_ADD); - - binding = scheme_gensym(SCHEME_STX_VAL(name)); - - scheme_add_local_binding(name, scheme_env_phase(env->genv), binding); - } - - env->binders[pos] = name; - env->bindings[pos] = binding; - } - env->vals[pos] = val; - env->skip_table = NULL; -} - -Scheme_Comp_Env * -scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, Scheme_Comp_Env *env, int flags) -{ - Scheme_Comp_Env *frame; - int len, i, count; - - len = scheme_stx_list_length(vals); - count = len; - - frame = scheme_new_compilation_frame(count, flags, scope, env); - - for (i = 0; i < len ; i++) { - if (SCHEME_STX_SYMBOLP(vals)) { - scheme_add_compilation_binding(i, vals, frame); - } else { - Scheme_Object *a; - a = SCHEME_STX_CAR(vals); - scheme_add_compilation_binding(i, a, frame); - vals = SCHEME_STX_CDR(vals); - } - } - - init_compile_data(frame); - - return frame; -} - -void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *env, Scheme_Object *use_site_scope) -{ - while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { - env = env->next; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - scheme_module_context_add_use_site_scope(env->genv->stx_context, use_site_scope); - } else { - use_site_scope = scheme_add_frame_use_site_scope(env->scopes, use_site_scope); - env->scopes = use_site_scope; - } -} - -void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *env, Scheme_Object *scope) -{ - while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { - env = env->next; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - /* we keep intdef scopes, even in this case, for use by get-shadower */ - } - - scope = scheme_add_frame_intdef_scope(env->scopes, scope); - env->scopes = scope; -} - -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env) - || scheme_is_module_env(env) - || scheme_is_module_begin_env(env) - || (env->flags & SCHEME_INTDEF_FRAME)) - return scheme_new_compilation_frame(0, 0, NULL, env); - else - return env; -} - -int scheme_is_toplevel(Scheme_Comp_Env *env) -{ - return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME); -} - -int scheme_is_nested_module(Scheme_Comp_Env *env) -{ - return (env->flags & SCHEME_NESTED_MODULE_FRAME); -} - -int scheme_is_module_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_FRAME); -} - -int scheme_is_module_begin_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); -} - -Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env)) - return env; - else - return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, NULL, env); -} - -Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags) +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int flags) { Scheme_Toplevel *tl; Scheme_Object *v, *pr; - /* Important: non-resolved can't be cached, because the ISCONST - field is modified to track mutated module-level variables. But - the value for a specific toplevel is cached in the environment - layer. */ - - if (resolved) { - if ((depth < MAX_CONST_TOPLEVEL_DEPTH) - && (position < MAX_CONST_TOPLEVEL_POS)) - return toplevels[depth][position][flags]; - - if ((position < 0xFFFF) && (depth < 0xFF)) { - int ep = position | (depth << 16) | (flags << 24); - pr = scheme_make_integer(ep); - } else { - pr = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); - SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); - SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); - } - v = scheme_hash_get_atomic(toplevels_ht, pr); - if (v) - return v; - } else - pr = NULL; + if ((depth < MAX_CONST_TOPLEVEL_DEPTH) + && (position < MAX_CONST_TOPLEVEL_POS)) + return toplevels[depth][position][flags]; + + if ((position < 0xFFFF) && (depth < 0xFF)) { + int ep = position | (depth << 16) | (flags << 24); + pr = scheme_make_integer(ep); + } else { + pr = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); + SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); + SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); + } + v = scheme_hash_get_atomic(toplevels_ht, pr); + if (v) + return v; tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel)); - tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_ir_toplevel_type); - tl->depth = depth; + tl->iso.so.type = scheme_toplevel_type; + tl->u.depth = depth; tl->position = position; SCHEME_TOPLEVEL_FLAGS(tl) = flags | HIGH_BIT_TO_DISABLE_HASHING; - if (resolved) { - if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { - toplevels_ht = scheme_make_hash_table_equal(); - } - scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); + if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { + toplevels_ht = scheme_make_hash_table_equal(); } + scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); return (Scheme_Object *)tl; } -Scheme_Object *scheme_register_toplevel_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp, - int imported, Scheme_Object *inline_variant) -{ - Scheme_Hash_Table *ht; - Scheme_Object *o; - - ht = cp->toplevels; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->toplevels = ht; - } - - o = scheme_hash_get(ht, var); - if (o) - return o; - - o = scheme_make_toplevel(0, cp->num_toplevels, 0, - (imported - ? ((SCHEME_MODVAR_FLAGS(var) & SCHEME_MODVAR_CONST) - ? SCHEME_TOPLEVEL_CONST - : ((SCHEME_MODVAR_FLAGS(var) & SCHEME_MODVAR_FIXED) - ? SCHEME_TOPLEVEL_FIXED - : SCHEME_TOPLEVEL_READY)) - : 0)); - - scheme_hash_set(ht, var, o); - - if (inline_variant) { - ht = cp->inline_variants; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->inline_variants = ht; - } - scheme_hash_set(ht, scheme_make_integer(cp->num_toplevels), inline_variant); - } - - cp->num_toplevels++; - - return o; -} - -Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int imported, Scheme_Object *inline_variant) -{ - Comp_Prefix *cp = env->prefix; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - return scheme_make_toplevel(0, 0, 0, 0); - } - - return scheme_register_toplevel_in_comp_prefix(var, cp, imported, inline_variant); -} - -void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id) -{ - Comp_Prefix *cp = env->prefix; - - if (!cp->unbound) cp->unbound = scheme_null; - - id = scheme_make_pair(id, cp->unbound); - cp->unbound = id; -} - -void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env) -{ - if (exp_env->prefix->unbound && (env->genv->disallow_unbound < 0)) { - /* adding a list to env->prefix->unbound indicates a - phase-1 shift for the identifiers in the list: */ - scheme_register_unbound_toplevel(env, exp_env->prefix->unbound); - } -} - Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) { - Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl; - return scheme_make_toplevel(tl->depth, tl->position, 0, flags); + if (SAME_TYPE(SCHEME_TYPE(_tl), scheme_static_toplevel_type)) { + SCHEME_TOPLEVEL_FLAGS(_tl) |= flags; + return _tl; + } else { + Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl; + return scheme_make_toplevel(tl->u.depth, tl->position, flags); + } } -Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp) +Scheme_IR_Toplevel *scheme_make_ir_toplevel(int instance_pos, int variable_pos, int flags) { - Scheme_Local *l; - Scheme_Object *o; - int pos; - - if (!cp->stxes) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->stxes = ht; - } - - pos = cp->num_stxes; + Scheme_IR_Toplevel *tl; - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_ir_quote_syntax_type; - l->position = pos; + tl = MALLOC_ONE_TAGGED(Scheme_IR_Toplevel); + tl->iso.so.type = scheme_ir_toplevel_type; + SCHEME_TOPLEVEL_FLAGS(tl) = flags | HIGH_BIT_TO_DISABLE_HASHING; - cp->num_stxes++; - o = (Scheme_Object *)l; - - scheme_hash_set(cp->stxes, var, o); + tl->instance_pos = instance_pos; + tl->variable_pos = variable_pos; - return o; + return tl; } -Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +Scheme_Object *scheme_ir_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) { - Scheme_Local *l; - Comp_Prefix *cp = env->prefix; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_ir_quote_syntax_type; - l->position = 0; - - return (Scheme_Object *)l; - } - - return scheme_register_stx_in_comp_prefix(var, cp); + Scheme_IR_Toplevel *tl = (Scheme_IR_Toplevel *)_tl; + tl = scheme_make_ir_toplevel(tl->instance_pos, tl->variable_pos, + (SCHEME_TOPLEVEL_FLAGS(tl) & ~SCHEME_TOPLEVEL_FLAGS_MASK) | flags); + return (Scheme_Object *)tl; } /*========================================================================*/ @@ -830,7 +224,7 @@ v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel)); #endif v->iso.so.type = scheme_toplevel_type; - v->depth = i; + v->u.depth = i; v->position = k; SCHEME_TOPLEVEL_FLAGS(v) = cnst | HIGH_BIT_TO_DISABLE_HASHING; @@ -892,263 +286,13 @@ return v; } -static Scheme_Object *get_local_name(Scheme_Object *id) -{ - Scheme_Object *name; +/*********************************************************************/ - name = scheme_stx_property(id, undefined_error_name_symbol, NULL); - if (name && SCHEME_SYMBOLP(name)) - return name; - else - return SCHEME_STX_VAL(id); -} - -static Scheme_IR_Local *make_variable(Scheme_Object *id) -{ - Scheme_IR_Local *var; - - var = MALLOC_ONE_TAGGED(Scheme_IR_Local); - var->so.type = scheme_ir_local_type; - if (id) { - id = get_local_name(id); - var->name = id; - } - - return var; -} - -static Scheme_IR_Local *get_frame_loc(Scheme_Comp_Env *frame, - int i, int j, int p, int flags) -/* Generates a Scheme_IR_Local record as needed, and also - marks the variable as used for closures. */ -{ - if (!frame->vars) { - Scheme_IR_Local **vars; - vars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = vars; - } - - if (!frame->vars[i]) { - Scheme_IR_Local *var; - var = make_variable(frame->binders ? frame->binders[i] : NULL); - frame->vars[i] = var; - } - - if (frame->vars[i]->use_count < SCHEME_USE_COUNT_INF) - frame->vars[i]->use_count++; - if (flags & (SCHEME_SETTING | SCHEME_LINKING_REF)) - frame->vars[i]->mutated = 1; - if (!(flags & (SCHEME_APP_POS | SCHEME_SETTING))) - if (frame->vars[i]->non_app_count < SCHEME_USE_COUNT_INF) - frame->vars[i]->non_app_count++; - - if (i > frame->max_use) - frame->max_use = i; - frame->any_use = 1; - - return frame->vars[i]; -} - -void scheme_env_make_variables(Scheme_Comp_Env *frame) -{ - Scheme_IR_Local *var, **vars; - int i; - - if (!frame->num_bindings) - return; - - if (!frame->vars) { - vars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = vars; - } - - for (i = 0; i < frame->num_bindings; i++) { - if (!frame->vars[i]) { - var = make_variable(frame->binders ? frame->binders[i] : NULL); - frame->vars[i] = var; - } - } -} - -void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_IR_Local **vars, - int pos, int count) -{ - int i; - - MZ_ASSERT((pos + count) <= frame->num_bindings); - - if (!frame->vars) { - Scheme_IR_Local **fvars; - fvars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = fvars; - } - - for (i = 0; i < count; i++) { - MZ_ASSERT(!frame->vars[i+pos]); - frame->vars[i+pos] = vars[count - i - 1]; - } -} - -Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, - Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant, - Scheme_Object *shape) -/* is_constant == 2 => constant over all instantiations and phases */ -{ - Scheme_Object *val; - Scheme_Hash_Table *ht; - - if (!env->modvars) { - ht = scheme_make_hash_table_equal_modix_eq(); - env->modvars = ht; - } - - stxsym = SCHEME_STX_SYM(stxsym); - - ht = (Scheme_Hash_Table *)scheme_hash_get(env->modvars, modidx); - - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(env->modvars, modidx, (Scheme_Object *)ht); - } - - /* Loop for inspector-specific hash table, maybe: */ - while (1) { - - val = scheme_hash_get(ht, stxsym); - - if (!val) { - Module_Variable *mv; - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - - mv->modidx = modidx; - mv->sym = stxsym; - mv->insp = insp; - mv->pos = pos; - mv->mod_phase = (int)mod_phase; - mv->shape = shape; - - if (is_constant > 1) - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_CONST; - else if (is_constant) - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_FIXED; - - val = (Scheme_Object *)mv; - - scheme_hash_set(ht, stxsym, val); - - break; - } else { - /* Check that inspector is the same. */ - Module_Variable *mv = (Module_Variable *)val; - - if (!SAME_OBJ(mv->insp, insp)) { - /* Need binding for a different inspector. Try again. */ - val = scheme_hash_get(ht, insp); - if (!val) { - Scheme_Hash_Table *ht2; - /* Make a table for this specific inspector */ - ht2 = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, insp, (Scheme_Object *)ht2); - ht = ht2; - /* loop... */ - } else - ht = (Scheme_Hash_Table *)val; - } else - break; - } - } - - return val; -} - -/*********************************************************************/ - -#define IS_SKIPPING_DEPTH(n) (n && !(n & 31)) - -void create_skip_table(Scheme_Comp_Env *start_frame) -{ - Scheme_Comp_Env *end_frame, *frame, *other_frame; - int depth, dj = 0, dp = 0, i; - Scheme_Hash_Tree *table; - int stride = 0, past_binding_frame = 0, past_stops_frame = 0; - - i = start_frame->skip_depth; - depth = 0; - while (!(i & 1)) { - depth = (depth << 1) | 1; - i >>= 1; - } - - /* Find frames to be covered by the skip table. */ - for (end_frame = start_frame->next; - end_frame && (depth & end_frame->skip_depth); - end_frame = end_frame->next) { - stride++; - } - - table = NULL; - - for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (frame->skip_table) { - other_frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - if (other_frame == end_frame) { - end_frame = frame; - table = frame->skip_table; - dj = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(1))); - dp = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(2))); - past_binding_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(3))); - past_stops_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(4))); - break; - } - } - } - - if (!table) { - table = scheme_make_hash_tree(SCHEME_hashtr_eq); - table = scheme_hash_tree_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); - } - - for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (!(frame->flags & SCHEME_REC_BINDING_FRAME) - && frame->scopes) - past_binding_frame = 1; - if (frame->flags & SCHEME_FOR_STOPS) - past_stops_frame = 1; - if (frame->flags & SCHEME_LAMBDA_FRAME) - dj++; - if (!frame->vals) - dp += frame->num_bindings; - for (i = frame->num_bindings; i--; ) { - if (frame->bindings[i]) - table = scheme_hash_tree_set(table, frame->bindings[i], scheme_true); - if (frame->binders[i]) - table = scheme_hash_tree_set(table, SCHEME_STX_VAL(frame->binders[i]), scheme_true); - } - } - - table = scheme_hash_tree_set(table, scheme_make_integer(1), scheme_make_integer(dj)); - table = scheme_hash_tree_set(table, scheme_make_integer(2), scheme_make_integer(dp)); - table = scheme_hash_tree_set(table, scheme_make_integer(3), past_binding_frame ? scheme_true : scheme_false); - table = scheme_hash_tree_set(table, scheme_make_integer(4), past_stops_frame ? scheme_true : scheme_false); - - start_frame->skip_table = table; -} - -static void check_taint(Scheme_Object *find_id) -{ - if (scheme_stx_is_tainted(find_id)) - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "cannot use identifier tainted by macro transformation"); -} - -Scheme_Object *scheme_intern_struct_proc_shape(int shape) -{ - char buf[20]; - sprintf(buf, "struct%d", shape); - return scheme_intern_symbol(buf); +Scheme_Object *scheme_intern_struct_proc_shape(int shape) +{ + char buf[20]; + sprintf(buf, "struct%d", shape); + return scheme_intern_symbol(buf); } Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape) @@ -1158,1251 +302,157 @@ return scheme_intern_symbol(buf); } -void scheme_dump_env(Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *frame; - - printf("Environment:\n"); - - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - for (i = frame->num_bindings; i--; ) { - printf(" %s -> %s\n %s\n", - scheme_write_to_string(frame->binders[i], NULL), - scheme_write_to_string(frame->bindings[i], NULL), - scheme_write_to_string((Scheme_Object *)((Scheme_Stx *)frame->binders[i])->scopes, NULL)); - } - } -} - -static int same_binding(Scheme_Object *a, Scheme_Object *b) -{ - if (SCHEME_VECTORP(a) && SCHEME_VECTORP(b)) { - if (SAME_OBJ(SCHEME_VEC_ELS(a)[1], SCHEME_VEC_ELS(b)[1]) - && SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(b)[2]) - && (SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(b)[0]) - || (SCHEME_TRUEP(SCHEME_VEC_ELS(a)[0]) - && SCHEME_TRUEP(SCHEME_VEC_ELS(b)[0]) - && scheme_equal(scheme_module_resolve(SCHEME_VEC_ELS(a)[0], 0), - scheme_module_resolve(SCHEME_VEC_ELS(b)[0], 0))))) - return 1; - else - return 0; - } else - return scheme_equal(a, b); -} - -static void set_binder(Scheme_Object **_binder, Scheme_Object *ref, Scheme_Object *bind) -{ - if (SAME_OBJ(SCHEME_STX_VAL(ref), SCHEME_STX_VAL(bind))) - ref = scheme_datum_to_syntax(SCHEME_STX_VAL(ref), ref, bind, 0, 2); - else { - /* rename transformer => treat like an expansion */ - ref = scheme_stx_track(scheme_datum_to_syntax(SCHEME_STX_VAL(bind), ref, bind, 0, 2), - ref, - ref); - } - - *_binder = ref; -} - /*********************************************************************/ -/* - - scheme_compile_lookup() is the main resolver of lexical, module, - and top-level bindings. Depending on the value of `flags', it can - return a value whose type tag is: - - scheme_macro_type (id was bound to syntax), - - scheme_macro_set_type (id was bound to a set!-transformer), - - scheme_macro_id_type (id was bound to a rename-transformer), - - scheme_ir_local_type (id was lexical), - - scheme_variable_type (id is a global or module-bound variable), - or - - scheme_module_variable_type (id is a module-bound variable). - -*/ - -Scheme_Object * -scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, - Scheme_Object *in_modidx, - Scheme_Env **_menv, int *_protected, - Scheme_Object **_binder, int *_need_macro_scope, - Scheme_Object **_inline_variant) -{ - Scheme_Comp_Env *frame; - int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant, ambiguous; - Scheme_Bucket *b; - Scheme_Object *binding, *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *rename_insp = NULL, *mod_constant = NULL, *shape; - Scheme_Env *genv; - - if (_binder) *_binder = NULL; - if (_need_macro_scope) *_need_macro_scope = 1; - - binding = scheme_stx_lookup_w_nominal(find_id, scheme_env_phase(env->genv), - (flags & SCHEME_STOP_AT_FREE_EQ), - NULL, &ambiguous, NULL, - &rename_insp, - NULL, NULL, NULL, NULL); - -#if 0 - if (!strcmp("cons", SCHEME_SYM_VAL(SCHEME_STX_VAL(find_id)))) { - printf("%s\n", scheme_write_to_string(find_id, 0)); - scheme_stx_debug_print(find_id, scheme_env_phase(env->genv), 1); - printf("%s\n", scheme_write_to_string(binding, NULL)); - } -#endif - - if (ambiguous) { - if (SAME_OBJ(scheme_env_phase(env->genv), scheme_make_integer(0))) - scheme_wrong_syntax(NULL, NULL, find_id, - "identifier's binding is ambiguous%s", - scheme_stx_describe_context(find_id, scheme_make_integer(0), 1)); - else - scheme_wrong_syntax(NULL, NULL, find_id, - "identifier's binding is ambiguous\n" - " at phase: %V", - scheme_env_phase(env->genv), - scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); - return NULL; - } - - /* If binding is a symbol, then it must be in the environment, or else - the identifier is out of context. - If binding is a vector, then it most likely refers to a module-level - binding, but we may have a "fluid" binding for in the environment - to implement stops. */ - - if (SCHEME_SYMBOLP(binding)) { - /* Walk through the compilation frames */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - - while (1) { - if (frame->skip_table) { - if (!scheme_eq_hash_tree_get(frame->skip_table, binding)) { - /* Skip ahead. 0 maps to frame, 1 maps to j delta, 2 maps to p delta, - 3 maps to binding-frameness, and 4 maps to stops-or-not (unneeded here) */ - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(1)); - j += (int)SCHEME_INT_VAL(val); - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(2)); - p += (int)SCHEME_INT_VAL(val); - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(3)); - if (SCHEME_TRUEP(val)) - if (_need_macro_scope) - *_need_macro_scope = 0; - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again... */ - } else - break; - } - - if (!(env->flags & SCHEME_REC_BINDING_FRAME) && env->scopes) - if (_need_macro_scope) - *_need_macro_scope = 0; - - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; - - if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { - if (frame->flags & SCHEME_FOR_STOPS) - skip_stops = 1; - - for (i = frame->num_bindings; i--; ) { - if (frame->bindings[i] && SAME_OBJ(binding, frame->bindings[i])) { - /* Found a lambda-, let-, etc. bound variable: */ - check_taint(find_id); - if (_binder) - set_binder(_binder, find_id, frame->binders[i]); - - if (!frame->vals) { - if (flags & SCHEME_DONT_MARK_USE) - return (Scheme_Object *)make_variable(NULL); - else - return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); - } else { - val = frame->vals[i]; - - if (!val) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; - } - - if (SCHEME_FALSEP(val)) { - /* Corresponds to a run-time binding (but will be replaced later - through a renaming to a different binding) */ - if (flags & (SCHEME_OUT_OF_CONTEXT_LOCAL | SCHEME_SETTING)) - return (Scheme_Object *)make_variable(NULL); - return NULL; - } - - if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) - return val; - else - scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, - "local syntax identifier cannot be mutated"); - return NULL; - } - - return val; - } - } - } - } - - if (!frame->vals) - p += frame->num_bindings; - - if (!frame->next->next && frame->next->intdef_next) { - frame = frame->next->intdef_next; - continue; - } - } - - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context%s", - scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); - } - - if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) - return (Scheme_Object *)make_variable(NULL); - - return NULL; - } else { - /* First, check for a "stop" */ - for (frame = env; frame->next != NULL; frame = frame->next) { - while (1) { - if (frame->skip_table) { - /* skip if we won't jump over stops: */ - if (SCHEME_FALSEP(scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(4)))) - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again */ - } else - break; - } - - if (frame->flags & SCHEME_FOR_STOPS) { - int i; - for (i = frame->num_bindings; i--; ) { - if (same_binding(frame->bindings[i], binding) - && (SCHEME_TRUEP(binding) - || SAME_OBJ(SCHEME_STX_VAL(frame->binders[i]), - SCHEME_STX_VAL(find_id)))) { - check_taint(find_id); - - return frame->vals[i]; - } - } - /* ignore any further stop frames: */ - break; - } - } - - if (SCHEME_FALSEP(binding)) { - src_find_id = find_id; - modidx = NULL; - mod_defn_phase = NULL; - } else { - src_find_id = find_id; - modidx = SCHEME_VEC_ELS(binding)[0]; - if (SCHEME_FALSEP(modidx)) modidx = NULL; - find_id = SCHEME_VEC_ELS(binding)[1]; - mod_defn_phase = SCHEME_VEC_ELS(binding)[2]; - } - } - - if (modidx) { - /* If it's an access path, resolve it: */ - modname = scheme_module_resolve(modidx, 1); - - if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) { - modidx = NULL; - modname = NULL; - genv = env->genv; - /* So we can distinguish between unbound identifiers in a module - and references to top-level definitions: */ - module_self_reference = 1; - - if (_need_macro_scope) { - for (frame = env; frame->next != NULL; frame = frame->next) { - if (!(frame->flags & (SCHEME_TOPLEVEL_FRAME - | SCHEME_MODULE_FRAME)) - && frame->scopes) { - *_need_macro_scope = 0; - break; - } - } - } - } else { - if (_need_macro_scope) - *_need_macro_scope = 0; - - genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); - - if (!genv) { - scheme_wrong_syntax("require", NULL, src_find_id, - "namespace mismatch;\n" - " reference to a module that is not available\n" - " reference phase: %d\n" - " referenced module: %D\n" - " referenced phase level: %d", - env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase)); - } - } - } else { - genv = env->genv; - modname = NULL; - - if (genv->module && genv->disallow_unbound) { - if (genv->disallow_unbound > 0) { - /* Free identifier. Maybe don't continue. */ - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_unbound_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module", - scheme_stx_describe_context(src_find_id, scheme_env_phase(genv), 0)); - return NULL; - } - if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } else { - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_register_unbound_toplevel(env, src_find_id); - } - /* continue, for now */ - } - } - } - - if (_menv && genv->module) - *_menv = genv; - - if (SCHEME_STXP(find_id)) { - find_global_id = scheme_future_global_binding(find_id, env->genv); - if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)) - && SCHEME_FALSEP(binding)) { - /* Since we got a symbol back, there's at least a "temporary" - top-level binding for the identifier in the current namespace */ - binding = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(binding)[0] = find_global_id; - SCHEME_VEC_ELS(binding)[1] = (env->genv->module ? env->genv->module->modname : scheme_false); - SCHEME_VEC_ELS(binding)[2] = scheme_env_phase(env->genv); - } else if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } else - find_global_id = find_id; - - /* Try syntax table: */ - if (modname) { - val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); - if (val && !(flags & SCHEME_NO_CERT_CHECKS)) - scheme_check_accessible_in_module_instance(genv, - find_id, src_find_id, - env->insp, rename_insp, - -2, 0, - NULL, NULL, - env->genv, NULL, NULL); - } else { - /* Only try syntax table if there's not an explicit (later) - variable mapping: */ - if (genv->shadowed_syntax - && scheme_hash_get(genv->shadowed_syntax, find_global_id)) - val = NULL; - else - val = scheme_lookup_in_table(genv->syntax, (const char *)find_global_id); - } - - if (val) { - check_taint(src_find_id); - return val; - } - - if (modname) { - Scheme_Object *pos; - if (flags & SCHEME_NO_CERT_CHECKS) - pos = 0; - else - pos = scheme_check_accessible_in_module_instance(genv, - find_id, src_find_id, - env->insp, rename_insp, - -1, 1, - _protected, NULL, - env->genv, NULL, &mod_constant); - modpos = (int)SCHEME_INT_VAL(pos); - } else - modpos = -1; - - if (modname && (flags & SCHEME_SETTING)) { - if (SAME_OBJ(src_find_id, find_id) || SAME_OBJ(SCHEME_STX_SYM(src_find_id), find_id)) - find_id = NULL; - scheme_wrong_syntax(scheme_set_stx_string, find_id, src_find_id, "cannot mutate module-required identifier"); - return NULL; - } - - if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && (genv->module && (genv->disallow_unbound > 0))) { - /* Check for set! of unbound identifier: */ - if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) { - scheme_unbound_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module", - scheme_stx_describe_context(src_find_id, scheme_env_phase(genv), 0)); - return NULL; - } - } - - if (!modname && (flags & SCHEME_NULL_FOR_UNBOUND)) { - if (module_self_reference) { - /* Since the module has a rename for this id, it's certainly defined. */ - if (!(flags & SCHEME_RESOLVE_MODIDS)) { - /* This is the same thing as #%top handling in compile mode. But - for expand mode, it prevents wrapping the identifier with #%top. */ - /* Don't need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - check_taint(src_find_id); - return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, - genv->module->insp, - -1, genv->mod_phase, 0, - NULL); - } - } else if (SCHEME_VECTORP(binding) && !genv->module) { - /* The identifier is specifically bound as a top-level definition. */ - return (Scheme_Object *)scheme_global_bucket(find_global_id, genv); - } else - return NULL; - } - - check_taint(src_find_id); - - shape = NULL; - if (mod_constant) { - if (SAME_OBJ(mod_constant, scheme_constant_key)) - is_constant = 2; - else if (SAME_OBJ(mod_constant, scheme_fixed_key)) - is_constant = 1; - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_proc_shape_type)) { - is_constant = 2; - shape = SCHEME_PTR_VAL(mod_constant); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { - if (_inline_variant) - *_inline_variant = mod_constant; - is_constant = 2; - shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_prop_proc_shape_type)) { - if (_inline_variant) - *_inline_variant = mod_constant; - is_constant = 2; - shape = scheme_intern_struct_prop_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { - if (_inline_variant) { - /* In case the inline variant includes references to module - variables, we'll need to shift the references: */ - Scheme_Object *shiftable; - shiftable = scheme_make_vector(4, scheme_false); - SCHEME_VEC_ELS(shiftable)[0] = mod_constant; - SCHEME_VEC_ELS(shiftable)[1] = genv->module->me->src_modidx; - SCHEME_VEC_ELS(shiftable)[2] = modidx; - SCHEME_VEC_ELS(shiftable)[3] = mod_defn_phase; - *_inline_variant = shiftable; - } - is_constant = 2; - shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); - } else { - if (flags & SCHEME_ELIM_CONST) - return mod_constant; - is_constant = 2; - } - } else - is_constant = 0; - - /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad - idea, because it causes module instances to be preserved. */ - if (modname && !(flags & SCHEME_RESOLVE_MODIDS) - && (!(scheme_is_kernel_modname(modname) - || scheme_is_unsafe_modname(modname) - || scheme_is_flfxnum_modname(modname) - || scheme_is_extfl_modname(modname) - || scheme_is_futures_modname(modname) - || scheme_is_foreign_modname(modname)) - || (flags & SCHEME_REFERENCING))) { - /* Create a module variable reference, so that idx is preserved: */ - return scheme_hash_module_variable(env->genv, modidx, find_id, - (rename_insp ? rename_insp : genv->module->insp), - modpos, SCHEME_INT_VAL(mod_defn_phase), - is_constant, shape); - } - - if (!modname - && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && genv->module - && !(flags & SCHEME_RESOLVE_MODIDS)) { - /* Need to return a variable reference in this case, too. */ - return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, - genv->module->insp, - modpos, genv->mod_phase, - is_constant, shape); - } - - b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id); - - if ((flags & SCHEME_ELIM_CONST) && b && b->val - && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST) - && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE) - && (!modname || scheme_is_kernel_modname(modname))) - return (Scheme_Object *)b->val; - - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, genv); - - return (Scheme_Object *)b; -} -static Scheme_Comp_Env *find_first_relevant(Scheme_Object *stx, Scheme_Comp_Env *frame) +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Linklet *linklet, int flags) { - int i; - - for (; frame->next != NULL; frame = frame->next) { - while (1) { - if (frame->skip_table) { - if (!scheme_eq_hash_tree_get(frame->skip_table, SCHEME_STX_VAL(stx))) { - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again... */ - } else - break; - } + Scheme_Comp_Env *env; + Scheme_Hash_Tree *vars; - for (i = frame->num_bindings; i--; ) { - if (frame->binders[i] && SAME_OBJ(SCHEME_STX_VAL(stx), SCHEME_STX_VAL(frame->binders[i]))) - return frame; - } - } + env = MALLOC_ONE_RT(Scheme_Comp_Env); + SET_REQUIRED_TAG(env->type = scheme_rt_comp_env); + env->flags = flags; - return frame; -} + vars = scheme_make_hash_tree(0); + env->vars = vars; -static Scheme_Object *add_all_context(Scheme_Object *id, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *env2; + env->linklet = linklet; - for (env2 = env; env2; env2 = env2->next) { - if (env2->scopes) { - id = scheme_stx_adjust_frame_scopes(id, env2->scopes, scheme_env_phase(env2->genv), - SCHEME_STX_ADD); - } - } - - if (env->genv->module && env->genv->module->ii_src) - id = scheme_stx_binding_union(id, env->genv->module->ii_src, scheme_env_phase(env->genv)); - else - id = scheme_stx_add_module_context(id, env->genv->stx_context); - id = scheme_stx_adjust_module_use_site_context(id, env->genv->stx_context, SCHEME_STX_ADD); - - return id; + return env; } -static Scheme_Object *find_local_binder(Scheme_Object *sym, Scheme_Comp_Env *env) +Scheme_Comp_Env *scheme_extend_comp_env(Scheme_Comp_Env *env, Scheme_Object *id, Scheme_Object *var, + int mutate, int check_dups) { - Scheme_Comp_Env *frame; - Scheme_Object *id, **sds, *sd; + Scheme_Comp_Env *env2; + Scheme_Hash_Tree *vars; - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; + MZ_ASSERT(SCHEME_STX_SYMBOLP(id)); + id = SCHEME_STX_SYM(id); - for (i = frame->num_bindings; i--; ) { - id = frame->binders[i]; - if (id && SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->binders[i]))) { - if (!frame->shadower_deltas) { - sds = MALLOC_N(Scheme_Object*,frame->num_bindings); - frame->shadower_deltas = sds; - } - sd = frame->shadower_deltas[i]; - if (!sd) { - sd = add_all_context(scheme_datum_to_syntax(SCHEME_STX_VAL(id), scheme_false, scheme_false, 0, 0), - frame); - sd = scheme_stx_binding_subtract(id, sd, scheme_env_phase(env->genv)); - frame->shadower_deltas[i] = sd; - } - if (scheme_stx_could_bind(sd, sym, scheme_env_phase(env->genv))) - return id; - } - } + if (mutate) + env2 = env; + else { + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); } - return NULL; -} - -Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated) -{ - Scheme_Comp_Env *start_env; - Scheme_Object *binder, *orig_sym; - - orig_sym = sym; - - start_env = find_first_relevant(sym, env); - if (start_env->next) - binder = find_local_binder(sym, start_env); - else - binder = NULL; - - if (binder) - sym = scheme_stx_binding_union(binder, sym, scheme_env_phase(env->genv)); - else if (only_generated) - sym = scheme_stx_introduce_to_module_context(sym, env->genv->stx_context); - else if (env->genv->module && env->genv->module->ii_src) - sym = scheme_stx_binding_union(sym, env->genv->module->ii_src, scheme_env_phase(env->genv)); - else if (env->genv->stx_context) - sym = scheme_stx_add_module_context(sym, env->genv->stx_context); - - if (!scheme_stx_is_clean(orig_sym)) - sym = scheme_stx_taint(sym); - - return sym; -} - -Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env) -{ - Scheme_Hash_Table *binding_names; - - scheme_binding_names_from_module(env); - - if (env->binding_names - && SCHEME_HASHTRP(env->binding_names)) { - /* convert to a mutable hash table */ - binding_names = (Scheme_Hash_Table *)scheme_hash_tree_copy(env->binding_names); - env->binding_names = (Scheme_Object *)binding_names; - if (env->binding_names_need_shift) { - int i; - for (i = binding_names->size; i--; ) { - if (binding_names->vals[i]) { - Scheme_Object *id; - id = binding_names->vals[i]; - if (!SAME_OBJ(id, scheme_true)) - id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), - env->module->self_modidx, env->link_midx, - env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); - binding_names->vals[i] = id; - } - } - } + if (check_dups) { + if (scheme_hash_tree_get(env2->vars, id)) + return NULL; } - binding_names = (Scheme_Hash_Table *)env->binding_names; - if (!binding_names) { - binding_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->binding_names = (Scheme_Object *)binding_names; - env->binding_names_need_shift = 0; - } + vars = scheme_hash_tree_set(env2->vars, id, var); + env2->vars = vars; - return binding_names; + return env2; } -static int binding_name_available(Scheme_Hash_Table *binding_names, Scheme_Object *sym, - Scheme_Object *id, Scheme_Object *phase) +Scheme_Comp_Env *scheme_set_comp_env_flags(Scheme_Comp_Env *env, int flags) { - sym = scheme_eq_hash_get(binding_names, sym); - if (!sym || (SCHEME_STXP(sym) && scheme_stx_bound_eq(sym, id, phase))) - return 1; - return 0; -} + Scheme_Comp_Env *env2; -static Scheme_Object *select_binding_name(Scheme_Object *sym, Scheme_Env *env, - Scheme_Object *id, Scheme_Object *orig_id) -{ - int i; - char onstack[50], *buf; - intptr_t len; - Scheme_Hash_Table *binding_names; - - binding_names = scheme_get_binding_names_table(env); - - /* Use a plain symbol only if the binding has no extra scopes: */ - if (SCHEME_SYM_WEIRDP(sym) - || scheme_stx_equal_module_context(orig_id, ((env->module && env->module->ii_src) - ? env->module->ii_src - : env->stx_context))) { - if (binding_name_available(binding_names, sym, orig_id, scheme_env_phase(env))) { - scheme_hash_set(binding_names, sym, orig_id); - return sym; - } - } + if ((env->flags & flags) == flags) + return env; - len = SCHEME_SYM_LEN(sym); - if (len <= 35) - buf = onstack; - else - buf = scheme_malloc_atomic(len + 15); - memcpy(buf, SCHEME_SYM_VAL(sym), len); - - i = 0; - while (1) { - sprintf(buf XFORM_OK_PLUS len, ".%d", i); - sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - if (binding_name_available(binding_names, sym, id, scheme_env_phase(env))) { - scheme_hash_set(binding_names, sym, orig_id); - return sym; - } + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); + env2->flags |= flags; - i++; - } + return env2; } -static int binding_matches_env(Scheme_Object *binding, Scheme_Env *env, Scheme_Object *phase) +Scheme_Comp_Env *scheme_set_comp_env_name(Scheme_Comp_Env *env, Scheme_Object *name) { - return (SCHEME_VECTORP(binding) - && (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], - (env->module - ? env->module->self_modidx - : scheme_false)) - || SAME_OBJ(SCHEME_VEC_ELS(binding)[0], - env->link_midx)) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], phase)); -} - -Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env, int for_top_level) -{ - Scheme_Object *sym, *binding, *phase, *orig_id = id; - int exact_match; - - phase = scheme_env_phase(env); - - if (for_top_level) { - /* While compiling, we want to avoid binding in the top-level namespace. - Adding an extra scope avoids that while still letting us have some binding - to generate names for top-level definitions. */ - if (!env->tmp_bind_scope) { - sym = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - env->tmp_bind_scope = sym; - } - id = scheme_stx_add_scope(id, env->tmp_bind_scope, phase); - } - - binding = scheme_stx_lookup_stop_at_free_eq(id, phase, &exact_match); - - if (!SCHEME_FALSEP(binding)) { - if (exact_match) { - if (binding_matches_env(binding, env, phase)) { - sym = SCHEME_VEC_ELS(binding)[1]; - /* Make sure name is in binding_names and with a specific `id`: */ - scheme_hash_set(scheme_get_binding_names_table(env), sym, orig_id); - return sym; - } - /* Since the binding didn't match, we'll "shadow" the binding - by replacing it below. */ - } - } - - sym = select_binding_name(SCHEME_STX_VAL(id), env, id, orig_id); - - scheme_add_module_binding(id, phase, - (env->module ? env->module->self_modidx : scheme_false), - (env->module - ? (env->module->prefix - ? env->module->prefix->src_insp_desc - : env->module->insp) - : env->guard_insp), - sym, - phase); - - return sym; -} - -Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env) -/* The identifier id is being referenced before it has a binding. We - want to allow it, anyway, perhaps because it's outside of a module - context or because it's phase-1 code. So, we assume that it's going to - have no extra scopes and get the base name. - - Then again, if `id` has a binding after adding the environment's temporary - binding scope, then map the identifier to that temporary binding's name. - That special case allows compiling a `define` to create a binding that - can be referenced in the same compilation. */ -{ - if (env->tmp_bind_scope) { - Scheme_Object *binding, *phase; - - phase = scheme_env_phase(env); - id = scheme_stx_add_scope(id, env->tmp_bind_scope, phase); - binding = scheme_stx_lookup_stop_at_free_eq(id, phase, NULL); - - if (binding_matches_env(binding, env, phase)) - return SCHEME_VEC_ELS(binding)[1]; - } - - return SCHEME_STX_VAL(id); -} + Scheme_Comp_Env *env2; -int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env) -{ - if (env->genv->module) { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx)) - return 1; - } else - return 1; - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)var); - if (!SAME_OBJ(home, env->genv)) - return 1; - } else - return 1; - } - return 0; -} + if (SAME_OBJ(env->value_name, name)) + return env; -Scheme_Object *scheme_extract_unsafe(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_unsafe_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); + env2->value_name = name; -Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_flfxnum_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; + return env2; } -Scheme_Object *scheme_extract_extfl(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_extfl_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} +/*********************************************************************/ -Scheme_Object *scheme_extract_futures(Scheme_Object *o) +static Scheme_Object *get_local_name(Scheme_Object *id) { - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_futures_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} + Scheme_Object *name; -Scheme_Object *scheme_extract_foreign(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_foreign_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; + name = scheme_stx_property(id, undefined_error_name_symbol, NULL); + if (name && SCHEME_SYMBOLP(name)) + return name; else - return NULL; + return SCHEME_STX_SYM(id); } -int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) +Scheme_IR_Local *scheme_make_ir_local(Scheme_Object *id) { - int any_use; - - any_use = frame->any_use; - frame->any_use = 0; - - return any_use; -} - -int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos) -{ - return frame->max_use >= pos; -} - -void scheme_mark_all_use(Scheme_Comp_Env *frame) -{ - /* Mark all variables as used for the purposes of `letrec-syntaxes+values` - splitting */ - while (frame && (frame->max_use < frame->num_bindings)) { - frame->max_use = frame->num_bindings; - frame = frame->next; - } -} - -/*========================================================================*/ -/* macro hooks */ -/*========================================================================*/ - - -Scheme_Object * -scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env, *orig_env; - Scheme_Object *id, *ids, *rev_ids, *local_scope, *expr, *data, *vec, *id_sym; - Scheme_Lift_Capture_Proc cp; - Scheme_Object *orig_expr; - int count; - char buf[24]; - - if (stx_pos) { - if (SCHEME_INTP(argv[0])) { - count = (int)SCHEME_INT_VAL(argv[0]); - } else if (SCHEME_BIGNUMP(argv[0])) { - if (SCHEME_BIGPOS(argv[0])) - scheme_raise_out_of_memory(NULL, NULL); - count = -1; - } else - count = -1; - - if (count < 0) - scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, argc, argv); - } else - count = 1; - - expr = argv[stx_pos]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract(who, "syntax?", stx_pos, argc, argv); - - env = orig_env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - scheme_contract_error(who, - "not currently transforming", - NULL); - - env = scheme_get_env_for_lifts(env); - - if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) - env = NULL; - - if (!env) - scheme_contract_error("syntax-local-lift-expression", - "no lift target", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - - /* We don't really need a new symbol each time, since the scope - will generate new bindings, but things may work better or faster - when different bindings have different symbols. Use env->genv->id_counter - to help keep name generation deterministic within a module. */ - rev_ids = scheme_null; - while (count--) { - sprintf(buf, "lifted.%d", env->genv->id_counter++); - id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_scope(id, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env->genv)); - - if (env->genv->stx_context) - id = scheme_stx_introduce_to_module_context(id, env->genv->stx_context); - if (env->flags & SCHEME_TMP_TL_BIND_FRAME) { - /* When the lifetd definition is compiled, `tmp_bind_scope` will - be added to the defined name so that a fresh binding is not - created. We have added a fresh scope that would keep it - distinct, anyway, but add the tmp scope here to keep the - definition and reference in sync. */ - if (!env->genv->tmp_bind_scope) { - id_sym = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - env->genv->tmp_bind_scope = id_sym; - } - id = scheme_stx_add_scope(id, env->genv->tmp_bind_scope, scheme_env_phase(env->genv)); - } - - rev_ids = scheme_make_pair(id, rev_ids); - } - ids = scheme_reverse(rev_ids); - - vec = env->lifts; - cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1]; - data = SCHEME_VEC_ELS(vec)[2]; - - orig_expr = expr; - - expr = cp(data, &ids, expr, orig_env); - - expr = scheme_make_pair(expr, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = expr; - - SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), ids, orig_expr); + Scheme_IR_Local *var; - rev_ids = scheme_null; - for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - if (local_scope) - id = scheme_stx_flip_scope(id, local_scope, scheme_env_phase(env->genv)); - rev_ids = scheme_make_pair(id, rev_ids); + var = MALLOC_ONE_TAGGED(Scheme_IR_Local); + var->so.type = scheme_ir_local_type; + if (id) { + id = get_local_name(id); + var->name = id; } - ids = scheme_reverse(rev_ids); - - return ids; -} - -Scheme_Object * -scheme_local_lift_context(Scheme_Comp_Env *env) -{ - env = scheme_get_env_for_lifts(env); - if (!env) - return scheme_false; - - return SCHEME_VEC_ELS(env->lifts)[4]; + return var; } -Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env) +static void record_local_use(Scheme_IR_Local *var, int flags) { - while (env) { - if ((env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[3])) - break; - env = env->next; - } - - return env; -} + if (var->use_count < SCHEME_USE_COUNT_INF) + var->use_count++; + if (flags & SCHEME_SETTING) + var->mutated = 1; + if (!(flags & (SCHEME_APP_POS | SCHEME_SETTING))) + if (var->non_app_count < SCHEME_USE_COUNT_INF) + var->non_app_count++; -static Scheme_Comp_Env *get_lift_env_for_module(Scheme_Comp_Env *env) -{ - while (env) { - if ((env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[8])) - break; - env = env->next; + if (var->mode == SCHEME_VAR_MODE_COMPILE) { + if ((*var->compile.use_box) < var->compile.use_position) + (*var->compile.use_box) = var->compile.use_position; } - - return env; } Scheme_Object * -scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env) +scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags) { - Scheme_Object *pr; - Scheme_Object *orig_expr; - - env = scheme_get_module_lift_env(env); - - if (!env) - scheme_contract_error("syntax-local-lift-module-end-declaration", - "not currently transforming" - " an expression within a module declaration", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - orig_expr = expr; - - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[3]); - SCHEME_VEC_ELS(env->lifts)[3] = pr; - - SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); - - return scheme_void; -} - -Scheme_Object * -scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env) -{ - Scheme_Object *pr; - Scheme_Object *orig_expr; - int star_ok, slot; - - env = get_lift_env_for_module(env); - - if (!env) - scheme_contract_error("syntax-local-lift-module", - "not currently transforming within a module declaration or top level", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - orig_expr = expr; - - star_ok = !SAME_OBJ(scheme_true, SCHEME_VEC_ELS(env->lifts)[8]); - - if (SCHEME_STX_PAIRP(expr)) { - pr = SCHEME_STX_CAR(expr); - if (scheme_stx_free_eq3(pr, scheme_module_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) { - /* ok */ - } else if (scheme_stx_free_eq3(pr, scheme_modulestar_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) { - if (!star_ok) - scheme_contract_error("syntax-local-lift-module", - "cannot lift `module*' to a top-level context", - "syntax", 1, expr, - NULL); - /* otherwise, ok */ - } else - pr = NULL; - } else - pr = NULL; - - if (!pr) - scheme_contract_error("syntax-local-lift-module", - "not a module declaration", - "syntax", 1, expr, - NULL); - - /* Add to separate list or mingle with definitions? */ - if (SCHEME_NULLP(SCHEME_VEC_ELS(env->lifts)[8]) - || SCHEME_PAIRP(SCHEME_VEC_ELS(env->lifts)[8])) - slot = 8; - else - slot = 0; - - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[slot]); - SCHEME_VEC_ELS(env->lifts)[slot] = pr; - - SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); - - return scheme_void; -} + Scheme_Object *v; -Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *cenv) -{ - Scheme_Object *scope, *data, *pr; - Scheme_Object *req_form; - int need_prepare = 0; - Scheme_Comp_Env *env; + v = scheme_hash_tree_get(env->vars, SCHEME_STX_SYM(find_id)); - data = NULL; + if (!v) { + v = scheme_hash_get(scheme_startup_env->all_primitives_table, SCHEME_STX_SYM(find_id)); - env = cenv; - while (env) { - if (env->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[5])) { - data = SCHEME_VEC_ELS(env->lifts)[5]; - if (SCHEME_RPAIRP(data) - && !SCHEME_CAR(data)) { - env = (Scheme_Comp_Env *)SCHEME_CDR(data); - } else - break; - } else - env = env->next; + if (v && (flags & SCHEME_REFERENCING)) { + /* Which primitive table is it? */ + int i; + for (i = 0; i < scheme_startup_env->primitive_tables->size; i++) { + if (scheme_startup_env->primitive_tables->vals[i]) { + if (scheme_hash_get((Scheme_Hash_Table *)scheme_startup_env->primitive_tables->vals[i], SCHEME_STX_SYM(find_id))) + return scheme_startup_env->primitive_tables->keys[i]; /* symbol => kernel primitive */ + } + } + scheme_signal_error("internal error: could not find instance for a primitive"); + } } - if (!env) - scheme_contract_error("syntax-local-lift-requires", - "could not find target context", - NULL); - - - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - - if (SCHEME_RPAIRP(data)) - form = scheme_parse_lifted_require(form, phase, scope, SCHEME_CAR(data), &orig_form, cenv); - else { - form = scheme_toplevel_require_for_expand(form, phase, cenv, scope); - need_prepare = 1; + if (!v) { + if (flags & SCHEME_NULL_FOR_UNBOUND) + return NULL; + scheme_wrong_syntax(NULL, NULL, find_id, "free identifier found in linklet"); } - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[6]); - SCHEME_VEC_ELS(env->lifts)[6] = pr; - - req_form = form; - - form = orig_form; - form = scheme_stx_flip_scope(form, scope, scheme_env_phase(env->genv)); - - SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(scheme_get_expand_observe(), req_form, orig_form, form); - - /* In a top-level context, may need to force compile-time evaluation: */ - if (need_prepare) - scheme_prepare_compile_env(env->genv); - - return form; -} - -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, - Scheme_Comp_Env *env) -{ - Scheme_Object *pr; - while (env) { - if (env->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[7])) { - break; - } else - env = env->next; + if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { + if (!(env->flags & COMP_ENV_DONT_COUNT_AS_USE)) + record_local_use((Scheme_IR_Local *)v, flags); } - - if (!env) - scheme_contract_error("syntax-local-lift-provide", - "not expanding in a module run-time body", - NULL); - if (local_scope) - form = scheme_stx_flip_scope(form, local_scope, scheme_env_phase(env->genv)); - form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), - scheme_false, scheme_sys_wraps(env), - 0, 0), - scheme_make_pair(form, scheme_null)), - form, scheme_false, 0, 0); - - SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(scheme_get_expand_observe(), form); - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[7]); - SCHEME_VEC_ELS(env->lifts)[7] = pr; - - return scheme_void; -} - -Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, - Scheme_Object **_id, int *_use_map) -{ - Scheme_Object *id = NULL, *v; - Scheme_Comp_Env inlined_e; - - scheme_prepare_env_stx_context(genv); - scheme_prepare_compile_env(genv); - - id = scheme_datum_to_syntax(sym, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_module_context(id, genv->stx_context); - - inlined_e.num_bindings = 0; - inlined_e.next = NULL; - inlined_e.genv = genv; - inlined_e.flags = SCHEME_TOPLEVEL_FRAME; - init_compile_data(&inlined_e); - inlined_e.prefix = NULL; - - v = scheme_compile_lookup(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, - NULL, - NULL, NULL, - NULL, NULL, NULL); - if (v) { - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) { - *_use_map = -1; - v = NULL; - } else - v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; - } - - *_id = id; return v; } @@ -2411,8 +461,7 @@ /*========================================================================*/ void scheme_check_identifier(const char *formname, Scheme_Object *id, - const char *where, Scheme_Comp_Env *env, - Scheme_Object *form) + const char *where, Scheme_Object *form) { if (!where) where = ""; @@ -2421,16 +470,10 @@ scheme_wrong_syntax(formname, form ? id : NULL, form ? form : id, "not an identifier%s", where); - - if (scheme_stx_is_tainted(id)) - scheme_wrong_syntax(formname, form ? id : NULL, - form ? form : id, - "cannot bind identifier tainted by macro expansion%s", where); } -void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *env) +void scheme_begin_dup_symbol_check(DupCheckRecord *r) { - r->phase = env->genv->phase; r->count = 0; } @@ -2439,11 +482,10 @@ Scheme_Object *form) { int i; - Scheme_Object *l; if (r->count <= 5) { for (i = 0; i < r->count; i++) { - if (scheme_stx_bound_eq(symbol, r->syms[i], scheme_make_integer(r->phase))) + if (SAME_OBJ(SCHEME_STX_SYM(symbol), SCHEME_STX_SYM(r->syms[i]))) scheme_wrong_syntax(where, symbol, form, "duplicate %s name", what); } @@ -2456,27 +498,19 @@ ht = scheme_make_hash_table(SCHEME_hash_ptr); r->ht = ht; for (i = 0; i < r->count; i++) { - l = scheme_hash_get(ht, SCHEME_STX_VAL(r->syms[i])); - if (!l) l = scheme_null; - l = scheme_make_pair(r->syms[i], l); - scheme_hash_set(ht, SCHEME_STX_VAL(r->syms[i]), l); + scheme_hash_set(ht, SCHEME_STX_SYM(r->syms[i]), r->syms[i]); } r->count++; } } - l = scheme_hash_get(r->ht, SCHEME_STX_VAL(symbol)); - if (!l) l = scheme_null; - scheme_hash_set(r->ht, SCHEME_STX_VAL(symbol), scheme_make_pair(symbol, l)); - - while (!SCHEME_NULLP(l)) { - if (scheme_stx_bound_eq(symbol, SCHEME_CAR(l), scheme_make_integer(r->phase))) { - scheme_wrong_syntax(where, symbol, form, - "duplicate %s name", what); - return; - } - l = SCHEME_CDR(l); + if (scheme_hash_get(r->ht, SCHEME_STX_SYM(symbol))) { + scheme_wrong_syntax(where, symbol, form, + "duplicate %s name", what); + return; } + + scheme_hash_set(r->ht, SCHEME_STX_SYM(symbol), symbol); } diff -Nru racket-6.12+ppa1/src/racket/src/compile.c racket-7.0+ppa1/src/racket/src/compile.c --- racket-6.12+ppa1/src/racket/src/compile.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/compile.c 2018-07-27 22:12:02.000000000 +0000 @@ -34,121 +34,53 @@ #include "schpriv.h" #include "schmach.h" -#include "schexpobs.h" /* globals */ -READ_ONLY Scheme_Object *scheme_define_values_syntax; -READ_ONLY Scheme_Object *scheme_define_syntaxes_syntax; -READ_ONLY Scheme_Object *scheme_ref_syntax; -READ_ONLY Scheme_Object *scheme_begin_syntax; -READ_ONLY Scheme_Object *scheme_lambda_syntax; READ_ONLY Scheme_Object scheme_undefined[1]; -/* read-only globals */ -READ_ONLY static Scheme_Object *app_expander; -READ_ONLY static Scheme_Object *datum_expander; -READ_ONLY static Scheme_Object *top_expander; -READ_ONLY static Scheme_Object *stop_expander; - /* symbols */ ROSYM static Scheme_Object *lambda_symbol; -ROSYM static Scheme_Object *letrec_values_symbol; -ROSYM static Scheme_Object *let_star_values_symbol; +ROSYM static Scheme_Object *case_lambda_symbol; +ROSYM static Scheme_Object *ref_symbol; +ROSYM static Scheme_Object *quote_symbol; +ROSYM static Scheme_Object *if_symbol; +ROSYM static Scheme_Object *set_symbol; ROSYM static Scheme_Object *let_values_symbol; +ROSYM static Scheme_Object *letrec_values_symbol; ROSYM static Scheme_Object *begin_symbol; -ROSYM static Scheme_Object *disappeared_binding_symbol; +ROSYM static Scheme_Object *begin0_symbol; +ROSYM static Scheme_Object *with_cont_mark_symbol; +ROSYM static Scheme_Object *define_values_symbol; + ROSYM static Scheme_Object *compiler_inline_hint_symbol; -ROSYM static Scheme_Object *app_symbol; -ROSYM static Scheme_Object *expression_symbol; -ROSYM static Scheme_Object *datum_symbol; -ROSYM static Scheme_Object *top_symbol; ROSYM static Scheme_Object *protected_symbol; -ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *letrec_syntaxes_symbol; ROSYM static Scheme_Object *values_symbol; ROSYM static Scheme_Object *call_with_values_symbol; ROSYM static Scheme_Object *inferred_name_symbol; -ROSYM static Scheme_Object *local_keyword; -ROSYM static Scheme_Object *existing_variables_symbol; - -THREAD_LOCAL_DECL(static Scheme_Object *quick_stx); - -THREAD_LOCAL_DECL(struct Scheme_Object *cwv_stx); -THREAD_LOCAL_DECL(int cwv_stx_phase); +ROSYM static Scheme_Object *source_name_symbol; /* locals */ -static Scheme_Object *lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_values_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *ref_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *quote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *if_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stratified_body_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *stratified_body_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *expression_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *unquote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *quote_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *begin_for_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *app_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *datum_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *top_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stop_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); - -static Scheme_Object *compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position); - -static Scheme_Object *compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expand_block(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -static Scheme_Object *expand_stratified_block(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -static Scheme_Object *compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int as_intdef); -static Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); +static Scheme_Object *lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *case_lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *ref_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *quote_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *if_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *set_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env); + +static Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position); +static Scheme_Object *compile_list(Scheme_Object *form, + Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env, + int start_app_position); +static Scheme_Object *compile_app(Scheme_Object *form, Scheme_Comp_Env *env); + +static Scheme_Object *generate_defn_name(Scheme_Object *base_sym, + Scheme_Hash_Tree *used_names, + Scheme_Hash_Tree *also_used_names, + int search_start); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -161,204 +93,62 @@ /* initialization */ /**********************************************************************/ -void scheme_init_compile (Scheme_Env *env) +void scheme_init_compile (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); #endif - REGISTER_SO(scheme_define_values_syntax); - REGISTER_SO(scheme_define_syntaxes_syntax); - REGISTER_SO(scheme_lambda_syntax); - REGISTER_SO(scheme_begin_syntax); - REGISTER_SO(lambda_symbol); - REGISTER_SO(letrec_values_symbol); - REGISTER_SO(let_star_values_symbol); + REGISTER_SO(case_lambda_symbol); + REGISTER_SO(ref_symbol); + REGISTER_SO(quote_symbol); + REGISTER_SO(if_symbol); + REGISTER_SO(set_symbol); REGISTER_SO(let_values_symbol); + REGISTER_SO(letrec_values_symbol); REGISTER_SO(begin_symbol); - REGISTER_SO(disappeared_binding_symbol); - REGISTER_SO(compiler_inline_hint_symbol); - - REGISTER_SO(inferred_name_symbol); - - REGISTER_SO(local_keyword); + REGISTER_SO(begin0_symbol); + REGISTER_SO(with_cont_mark_symbol); + REGISTER_SO(define_values_symbol); - REGISTER_SO(existing_variables_symbol); - - scheme_undefined->type = scheme_undefined_type; - lambda_symbol = scheme_intern_symbol("lambda"); - - letrec_values_symbol = scheme_intern_symbol("letrec-values"); + case_lambda_symbol = scheme_intern_symbol("case-lambda"); + ref_symbol = scheme_intern_symbol("#%variable-reference"); + quote_symbol = scheme_intern_symbol("quote"); + if_symbol = scheme_intern_symbol("if"); + set_symbol = scheme_intern_symbol("set!"); let_values_symbol = scheme_intern_symbol("let-values"); - + letrec_values_symbol = scheme_intern_symbol("letrec-values"); begin_symbol = scheme_intern_symbol("begin"); + begin0_symbol = scheme_intern_symbol("begin0"); + with_cont_mark_symbol = scheme_intern_symbol("with-continuation-mark"); + define_values_symbol = scheme_intern_symbol("define-values"); + + REGISTER_SO(compiler_inline_hint_symbol); + REGISTER_SO(inferred_name_symbol); + REGISTER_SO(source_name_symbol); - disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding"); + scheme_undefined->type = scheme_undefined_type; + compiler_inline_hint_symbol = scheme_intern_symbol("compiler-hint:cross-module-inline"); inferred_name_symbol = scheme_intern_symbol("inferred-name"); + source_name_symbol = scheme_intern_symbol("source-name"); - local_keyword = scheme_intern_exact_keyword("local", 5); - - existing_variables_symbol = scheme_make_symbol("existing-variables"); - - scheme_define_values_syntax = scheme_make_primitive_syntax(define_values_compile, - define_values_expand); - scheme_define_syntaxes_syntax = scheme_make_primitive_syntax(define_syntaxes_compile, - define_syntaxes_expand); - scheme_lambda_syntax = scheme_make_primitive_syntax(lambda_compile, - lambda_expand); - scheme_begin_syntax = scheme_make_primitive_syntax(begin_compile, - begin_expand); - - scheme_add_global_keyword("lambda", - scheme_lambda_syntax, - env); - { - /* Greek lambda binding: */ - Scheme_Object *macro, *fn; - - fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1); - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = fn; - - scheme_add_global_keyword("\316\273", macro, env); - } - scheme_add_global_keyword("define-values", scheme_define_values_syntax, env); - scheme_add_global_keyword("quote", - scheme_make_primitive_syntax(quote_compile, - quote_expand), - env); - scheme_add_global_keyword("if", - scheme_make_primitive_syntax(if_compile, - if_expand), - env); - scheme_add_global_keyword("set!", - scheme_make_primitive_syntax(set_compile, - set_expand), - env); - scheme_add_global_keyword("#%variable-reference", - scheme_make_primitive_syntax(ref_compile, - ref_expand), - env); - - scheme_add_global_keyword("#%expression", - scheme_make_primitive_syntax(expression_compile, - expression_expand), - env); - - scheme_add_global_keyword("case-lambda", - scheme_make_primitive_syntax(case_lambda_compile, - case_lambda_expand), - env); - - scheme_add_global_keyword("let-values", - scheme_make_primitive_syntax(let_values_compile, - let_values_expand), - env); - scheme_add_global_keyword("letrec-values", - scheme_make_primitive_syntax(letrec_values_compile, - letrec_values_expand), - env); - - scheme_add_global_keyword("begin", - scheme_begin_syntax, - env); - scheme_add_global_keyword("#%stratified-body", - scheme_make_primitive_syntax(stratified_body_compile, - stratified_body_expand), - env); - - scheme_add_global_keyword("begin0", - scheme_make_primitive_syntax(begin0_compile, - begin0_expand), - env); - - scheme_add_global_keyword("unquote", - scheme_make_primitive_syntax(unquote_compile, - unquote_expand), - env); - scheme_add_global_keyword("unquote-splicing", - scheme_make_primitive_syntax(unquote_compile, - unquote_expand), - env); - - scheme_add_global_keyword("with-continuation-mark", - scheme_make_primitive_syntax(with_cont_mark_compile, - with_cont_mark_expand), - env); - - scheme_add_global_keyword("quote-syntax", - scheme_make_primitive_syntax(quote_syntax_compile, - quote_syntax_expand), - env); - scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); - scheme_add_global_keyword("begin-for-syntax", - scheme_make_primitive_syntax(begin_for_syntax_compile, - begin_for_syntax_expand), - env); - scheme_add_global_keyword("letrec-syntaxes+values", - scheme_make_primitive_syntax(letrec_syntaxes_compile, - letrec_syntaxes_expand), - env); - - REGISTER_SO(app_symbol); - REGISTER_SO(expression_symbol); - REGISTER_SO(datum_symbol); - REGISTER_SO(top_symbol); REGISTER_SO(protected_symbol); - REGISTER_SO(quote_symbol); - REGISTER_SO(letrec_syntaxes_symbol); REGISTER_SO(values_symbol); REGISTER_SO(call_with_values_symbol); - app_symbol = scheme_intern_symbol("#%app"); - expression_symbol = scheme_intern_symbol("#%expression"); - datum_symbol = scheme_intern_symbol("#%datum"); - top_symbol = scheme_intern_symbol("#%top"); protected_symbol = scheme_intern_symbol("protected"); - quote_symbol = scheme_intern_symbol("quote"); - letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); values_symbol = scheme_intern_symbol("values"); call_with_values_symbol = scheme_intern_symbol("call-with-values"); - REGISTER_SO(app_expander); - REGISTER_SO(datum_expander); - REGISTER_SO(top_expander); - REGISTER_SO(stop_expander); - - app_expander = scheme_make_primitive_syntax(app_compile, app_expand); - datum_expander = scheme_make_primitive_syntax(datum_compile, datum_expand); - top_expander = scheme_make_primitive_syntax(top_compile, top_expand); - stop_expander = scheme_make_primitive_syntax(stop_compile, stop_expand); - scheme_add_global_keyword("#%app", app_expander, env); - scheme_add_global_keyword("#%datum", datum_expander, env); - scheme_add_global_keyword("#%top", top_expander, env); - scheme_init_marshal(env); } void scheme_init_compile_places() { - REGISTER_SO(quick_stx); - REGISTER_SO(cwv_stx); -} - -Scheme_Object * -scheme_make_primitive_syntax(Scheme_Syntax *proc, - Scheme_Syntax_Expander *eproc) -{ - Scheme_Object *syntax; - - syntax = scheme_alloc_eternal_object(); - syntax->type = scheme_primitive_syntax_type; - SCHEME_SYNTAX(syntax) = (Scheme_Object *)proc; - SCHEME_SYNTAX_EXP(syntax) = (Scheme_Object *)eproc; - - return syntax; } /**********************************************************************/ @@ -387,53 +177,15 @@ l - 1, (l != 2) ? "s" : ""); } -static Scheme_Object *simplify_inferred_name(Scheme_Object *name); - -static Scheme_Object *simplify_inferred_name_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *name = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return (void *)simplify_inferred_name(name); -} - - -static Scheme_Object *simplify_inferred_name(Scheme_Object *name) -{ - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)name; - - return scheme_handle_stack_overflow(simplify_inferred_name_k); - } - } - - if (SCHEME_PAIRP(name)) { - Scheme_Object *name_car = SCHEME_CAR(name), *name_cdr = SCHEME_CDR(name); - name_car = simplify_inferred_name(name_car); - name_cdr = simplify_inferred_name(name_cdr); - if (SAME_OBJ(name_car, name_cdr)) - return name_car; - } - - return name; -} - -Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val) +static Scheme_Comp_Env *check_name_property(Scheme_Object *code, Scheme_Comp_Env *env) { Scheme_Object *name; name = scheme_stx_property(code, inferred_name_symbol, NULL); - name = simplify_inferred_name(name); if (name && SCHEME_SYMBOLP(name)) - return name; + return scheme_set_comp_env_name(env, name); else - return current_val; + return env; } /**********************************************************************/ @@ -442,14 +194,18 @@ static Scheme_Object *lambda_check(Scheme_Object *form) { - form = scheme_stx_taint_disarm(form, NULL); - if (SCHEME_STX_PAIRP(form) && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) { Scheme_Object *rest; rest = SCHEME_STX_CDR(form); - if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) + if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) { + int len; + len = check_form(form, form); + if (len != 3) + bad_form(form, len); + return form; + } } scheme_wrong_syntax(NULL, NULL, form, NULL); @@ -464,17 +220,17 @@ if (!SCHEME_STX_SYMBOLP(args)) { for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { a = SCHEME_STX_CAR(v); - scheme_check_identifier(NULL, a, NULL, env, form); + scheme_check_identifier(NULL, a, NULL, form); } if (!SCHEME_STX_NULLP(v)) { if (!SCHEME_STX_SYMBOLP(v)) { - scheme_check_identifier(NULL, v, NULL, env, form); + scheme_check_identifier(NULL, v, NULL, form); } } /* Check for duplicate names: */ - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { Scheme_Object *name; @@ -491,6 +247,10 @@ /* Makes up a procedure name when there's not a good one in the source */ { Scheme_Stx *cstx = (Scheme_Stx *)code; + + if (!SCHEME_STXP(code)) + return NULL; + if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) { char buf[50], src[20]; Scheme_Object *name, *bstr; @@ -548,6 +308,9 @@ { Scheme_Stx *cstx = (Scheme_Stx *)code; + if (!SCHEME_STXP(code)) + return name; + if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) && cstx->srcloc->src) { Scheme_Object *vec; @@ -582,7 +345,6 @@ Scheme_Object *name; name = scheme_stx_property(code, inferred_name_symbol, NULL); - name = simplify_inferred_name(name); if (name && SCHEME_SYMBOLP(name)) { name = combine_name_with_srcloc(name, code, 0); } else if (name && SCHEME_VOIDP(name)) { @@ -591,6 +353,8 @@ name = combine_name_with_srcloc(name, code, 1); } else { name = env->value_name; + if (name) + name = SCHEME_STX_SYM(name); if (!name || SCHEME_FALSEP(name)) { name = scheme_source_to_name(code); if (name) @@ -599,21 +363,32 @@ name = combine_name_with_srcloc(name, code, 0); } } + +#if RECORD_ALLOCATION_COUNTS + if (!name) { + /* Try harder to synthesize a name */ + char *s; + int len; + s = scheme_write_to_string(scheme_syntax_to_datum(code), + NULL); + len = strlen(s); + if (len > 100) s[100] = 0; + name = scheme_make_symbol(s); + } +#endif + return name; } -static Scheme_Object * -make_lambda(Scheme_Comp_Env *env, Scheme_Object *code, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *make_lambda(Scheme_Comp_Env *env, Scheme_Object *code) /* Compiles a `lambda' expression */ { - Scheme_Object *allparams, *params, *forms, *param, *name, *scope; + Scheme_Object *allparams, *params, *forms, *param, *name; Scheme_Lambda *lam; - Scheme_Compile_Info lrec; - Scheme_Comp_Env *frame; - int i; intptr_t num_params; + Scheme_IR_Local *var, **vars; Scheme_IR_Lambda_Info *cl; + int i; lam = MALLOC_ONE_TAGGED(Scheme_Lambda); @@ -639,56 +414,45 @@ forms = SCHEME_STX_CDR(code); forms = SCHEME_STX_CDR(forms); - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + env = check_name_property(code, env); + name = scheme_build_closure_name(code, env); + lam->name = name; + + env = scheme_set_comp_env_name(env, NULL); + + vars = MALLOC_N(Scheme_IR_Local*, num_params); - frame = scheme_new_compilation_frame(lam->num_params, SCHEME_LAMBDA_FRAME, scope, env); params = allparams; - for (i = 0; i < lam->num_params; i++) { + for (i = 0; i < num_params; i++) { if (!SCHEME_STX_PAIRP(params)) param = params; else param = SCHEME_STX_CAR(params); - scheme_add_compilation_binding(i, param, frame); + var = scheme_make_ir_local(param); + vars[i] = var; + env = scheme_extend_comp_env(env, param, (Scheme_Object *)var, i > 0, 0); if (SCHEME_STX_PAIRP(params)) params = SCHEME_STX_CDR (params); } - scheme_env_make_variables(frame); - if (SCHEME_STX_NULLP(forms)) scheme_wrong_syntax(NULL, NULL, code, "empty body not allowed"); - forms = scheme_datum_to_syntax(forms, code, code, 0, 0); - forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); - - name = scheme_build_closure_name(code, env); - lam->name = name; - - scheme_compile_rec_done_local(rec, drec); - - scheme_init_lambda_rec(rec, drec, &lrec, 0); - { Scheme_Object *body; - body = compile_sequence(forms, - scheme_no_defines(frame), - &lrec, 0, - 1); + body = compile_expr(SCHEME_STX_CAR(forms), env, 0); lam->body = body; } - scheme_merge_lambda_rec(rec, drec, &lrec, 0); - cl = MALLOC_ONE_RT(Scheme_IR_Lambda_Info); SET_REQUIRED_TAG(cl->type = scheme_rt_ir_lambda_info); - cl->vars = frame->vars; + cl->vars = vars; lam->ir_info = cl; return (Scheme_Object *)lam; } -static Scheme_Object * -lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *args; @@ -698,71 +462,7 @@ args = SCHEME_STX_CAR(args); lambda_check_args(args, form, env); - return make_lambda(env, form, rec, drec); -} - -static Scheme_Object * -lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *args, *body, *fn, *form, *scope; - Scheme_Comp_Env *newenv; - Scheme_Expand_Info erec1; - - SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(env->observer); - - form = lambda_check(orig_form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - - newenv = scheme_add_compilation_frame(args, scope, env, 0); - - body = SCHEME_STX_CDR(form); - body = SCHEME_STX_CDR(body); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); /* for re-expansion */ - - SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(env->observer, args, body); - - fn = SCHEME_STX_CAR(form); - - scheme_init_expand_recs(erec, drec, &erec1, 1); - - return scheme_datum_to_syntax(cons(fn, - cons(args, - expand_block(body, - newenv, - &erec1, - 0))), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv) -{ - Scheme_Object *form = argv[0], *args, *fn; - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - lambda_check(form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - fn = SCHEME_STX_CAR(form); - fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0); - - args = SCHEME_STX_CDR(form); - return scheme_datum_to_syntax(cons(fn, args), form, form, 0, 2); + return make_lambda(env, form); } Scheme_Object *scheme_clone_vector(Scheme_Object *lam, int skip, int set_type) @@ -782,216 +482,11 @@ return naya; } -Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, Scheme_Comp_Env *env) -{ - while (1) { - if (env->scopes) { - o = scheme_stx_adjust_frame_use_site_scopes(o, - env->scopes, - scheme_env_phase(env->genv), - SCHEME_STX_REMOVE); - } - if (env->flags & (SCHEME_FOR_INTDEF | SCHEME_INTDEF_FRAME | SCHEME_INTDEF_SHADOW)) { - if (env->use_scopes_next) - env = env->use_scopes_next; - else { - env = env->next; - if (!env) - break; - } - } else - break; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - o = scheme_stx_adjust_module_use_site_context(o, - env->genv->stx_context, - SCHEME_STX_REMOVE); - } - - return o; -} - -void scheme_define_parse(Scheme_Object *form, - Scheme_Object **var, Scheme_Object **_stk_val, - int defmacro, - Scheme_Comp_Env *env, - int no_toplevel_check) -{ - Scheme_Object *vars, *rest; - int len; - DupCheckRecord r; - - if (!no_toplevel_check && !scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a definition context"); - - len = check_form(form, form); - if (len != 3) - bad_form(form, len); - - rest = SCHEME_STX_CDR(form); - vars = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - *_stk_val = SCHEME_STX_CAR(rest); - - vars = scheme_revert_use_site_scopes(vars, env); - - *var = vars; - - scheme_begin_dup_symbol_check(&r, env); - - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name; - - name = SCHEME_STX_CAR(vars); - scheme_check_identifier(NULL, name, NULL, env, form); - - vars = SCHEME_STX_CDR(vars); - - scheme_dup_symbol_check(&r, NULL, name, "binding", form); - } - - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, *var, form, "bad variable list"); -} - -static Scheme_Object *global_binding(Scheme_Object *id, Scheme_Comp_Env *env) -{ - Scheme_Object *sym; - - sym = scheme_global_binding(id, env->genv, env->flags & SCHEME_TMP_TL_BIND_FRAME); - - if (env->binding_namess && !SAME_OBJ(sym, SCHEME_STX_VAL(id))) { - /* Record the new binding */ - Scheme_Hash_Tree *binds; - binds = (Scheme_Hash_Tree *)scheme_hash_get(env->binding_namess, scheme_env_phase(env->genv)); - if (!binds) - binds = scheme_make_hash_tree(SCHEME_hashtr_eq); - binds = scheme_hash_tree_set(binds, sym, id); - scheme_hash_set(env->binding_namess, scheme_env_phase(env->genv), (Scheme_Object *)binds); - } - - return sym; -} - -static Scheme_Object * -defn_targets_compile (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *first = scheme_null, *last = NULL; - - while (SCHEME_STX_PAIRP(var)) { - Scheme_Object *name, *pr, *bucket; - - name = SCHEME_STX_CAR(var); - name = global_binding(name, env); - - if (rec[drec].resolve_module_ids || !env->genv->module) { - bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); - } else { - /* Create a module variable reference, so that idx is preserved: */ - bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - name, env->genv->module->insp, - -1, env->genv->mod_phase, 0, - NULL); - } - /* Get indirection through the prefix: */ - bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0, NULL); - - pr = cons(bucket, scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - var = SCHEME_STX_CDR(var); - } - - return first; -} - -static Scheme_Object * -define_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *var, *val, *targets, *variables, *vec, *value_name; - - scheme_define_parse(form, &var, &val, 0, env, 0); - variables = var; - - targets = defn_targets_compile(var, env, rec, drec); - - scheme_compile_rec_done_local(rec, drec); - if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) { - var = SCHEME_STX_CAR(variables); - value_name = SCHEME_STX_SYM(var); - } else - value_name = NULL; - -#if 0 - if (env->scopes) - val = scheme_stx_adjust_frame_use_site_scopes(val, - env->scopes, - scheme_env_phase(env->genv), - SCHEME_STX_ADD); -#endif - - env = scheme_no_defines(env); - env->value_name = value_name; - - val = scheme_compile_expr(val, env, rec, drec); - - env->value_name = NULL; - - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = targets; - SCHEME_VEC_ELS(vec)[1] = val; - vec->type = scheme_define_values_type; - - if (SCHEME_TRUEP(scheme_stx_property(form, compiler_inline_hint_symbol, NULL))) { - /* use "immutable" bit to mark compiler-inline hint: */ - SCHEME_SET_IMMUTABLE(vec); - } - - return vec; -} - -static Scheme_Object * -define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *var, *val, *fn, *boundname; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer); - - scheme_define_parse(form, &var, &val, 0, env, 0); - - env = scheme_no_defines(env); - - if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var))) - boundname = SCHEME_STX_CAR(var); - else - boundname = scheme_false; - env->value_name = boundname; - - fn = SCHEME_STX_CAR(form); - form = scheme_datum_to_syntax(cons(fn, - cons(var, - cons(scheme_expand_expr(val, env, erec, drec), - scheme_null))), - form, - form, - 0, 2); - - env->value_name = NULL; - - return form; -} - /**********************************************************************/ /* quote */ /**********************************************************************/ -static Scheme_Object * -quote_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *quote_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *v, *rest; @@ -999,30 +494,9 @@ if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - v = SCHEME_STX_CAR(rest); - if (SCHEME_STXP(v)) - return scheme_syntax_to_datum(v, 0, NULL); - else - return v; -} - -static Scheme_Object * -quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest; - - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(env->observer); - - rest = SCHEME_STX_CDR(form); - - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - - return form; + return scheme_syntax_to_datum(v); } /**********************************************************************/ @@ -1041,9 +515,8 @@ } } -Scheme_Object * -scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, - Scheme_Object *elsep) +Scheme_Object *scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, + Scheme_Object *elsep) { Scheme_Branch_Rec *b; @@ -1064,23 +537,15 @@ return (Scheme_Object *)b; } -static Scheme_Object * -if_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *if_compile (Scheme_Object *form, Scheme_Comp_Env *env) { int len, opt; - Scheme_Object *test, *thenp, *elsep, *name, *rest; - Scheme_Compile_Info recs[3]; - - form = scheme_stx_taint_disarm(form, NULL); + Scheme_Object *test, *thenp, *elsep, *rest; len = check_form(form, form); check_if_len(form, len); - name = env->value_name; - env->value_name = NULL; - scheme_compile_rec_done_local(rec, drec); - - name = scheme_check_name_property(form, name); + env = check_name_property(form, env); rest = SCHEME_STX_CDR(form); test = SCHEME_STX_CAR(rest); @@ -1092,48 +557,33 @@ } else elsep = scheme_compiled_void(); - scheme_init_compile_recs(rec, drec, recs, 3); - - env = scheme_no_defines(env); - - test = scheme_compile_expr(test, env, recs, 0); + test = compile_expr(test, scheme_set_comp_env_name(env, NULL), 0); if (SCHEME_TYPE(test) > _scheme_ir_values_types_) { opt = 1; if (SCHEME_FALSEP(test)) { /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - env->value_name = name; - scheme_compile_expr(thenp, env, recs, 2); + compile_expr(thenp, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0); - if (len == 4) { - env->value_name = name; - test = scheme_compile_expr(elsep, env, recs, 1); - } else + if (len == 4) + test = compile_expr(elsep, env, 0); + else test = elsep; } else { if (len == 4) { /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - env->value_name = name; - scheme_compile_expr(elsep, env, recs, 2); + compile_expr(elsep, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0); } - env->value_name = name; - test = scheme_compile_expr(thenp, env, recs, 1); + test = compile_expr(thenp, env, 0); } } else { opt = 0; - env->value_name = name; - thenp = scheme_compile_expr(thenp, env, recs, 1); - if (len == 4) { - env->value_name = name; - elsep = scheme_compile_expr(elsep, env, recs, 2); - } + thenp = compile_expr(thenp, env, 0); + if (len == 4) + elsep = compile_expr(elsep, env, 0); } - - scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3); if (opt) return test; @@ -1141,102 +591,34 @@ return scheme_make_branch(test, thenp, elsep); } -static Scheme_Object * -if_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +/**********************************************************************/ +/* with-continuation-mark */ +/**********************************************************************/ + +static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env) { - Scheme_Object *form, *test, *rest, *thenp, *elsep, *fn, *boundname; + Scheme_Object *key, *val, *expr; + Scheme_Comp_Env *k_env; + Scheme_With_Continuation_Mark *wcm; int len; - Scheme_Expand_Info recs[3]; - SCHEME_EXPAND_OBSERVE_PRIM_IF(env->observer); + len = check_form(form, form); - form = scheme_stx_taint_disarm(orig_form, NULL); + if (len != 4) + bad_form(form, len); - len = check_form(form, form); + form = SCHEME_STX_CDR(form); + key = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + val = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + expr = SCHEME_STX_CAR(form); - check_if_len(form, len); + k_env = scheme_set_comp_env_name(env, NULL); - if (len == 3) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer); - } - - boundname = scheme_check_name_property(form, env->value_name); - - env = scheme_no_defines(env); - env->value_name = NULL; - - scheme_init_expand_recs(erec, drec, recs, 3); - - rest = SCHEME_STX_CDR(form); - test = SCHEME_STX_CAR(rest); - test = scheme_expand_expr(test, env, recs, 0); - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - rest = SCHEME_STX_CDR(rest); - thenp = SCHEME_STX_CAR(rest); - env->value_name = boundname; - thenp = scheme_expand_expr(thenp, env, recs, 1); - - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - elsep = SCHEME_STX_CAR(rest); - env->value_name = boundname; - elsep = scheme_expand_expr(elsep, env, recs, 2); - rest = cons(elsep, scheme_null); - } else { - rest = scheme_null; - } - - rest = cons(thenp, rest); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, cons(test, rest)), - orig_form, orig_form, - 0, 2); -} - -/**********************************************************************/ -/* with-continuation-mark */ -/**********************************************************************/ - -static Scheme_Object * -with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *key, *val, *expr, *value_name; - Scheme_Compile_Info recs[3]; - Scheme_With_Continuation_Mark *wcm; - int len; - - form = scheme_stx_taint_disarm(form, NULL); - - len = check_form(form, form); - - if (len != 4) - bad_form(form, len); - - value_name = env->value_name; - env = scheme_no_defines(env); - env->value_name = NULL; - - form = SCHEME_STX_CDR(form); - key = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - val = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - expr = SCHEME_STX_CAR(form); - - scheme_compile_rec_done_local(rec, drec); - - scheme_init_compile_recs(rec, drec, recs, 3); - - key = scheme_compile_expr(key, env, recs, 0); - val = scheme_compile_expr(val, env, recs, 1); - - env->value_name = value_name; - expr = scheme_compile_expr(expr, env, recs, 2); - - scheme_merge_compile_recs(rec, drec, recs, 3); + key = compile_expr(key, k_env, 0); + val = compile_expr(val, k_env, 0); + expr = compile_expr(expr, env, 0); wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); wcm->so.type = scheme_with_cont_mark_type; @@ -1247,67 +629,16 @@ return (Scheme_Object *)wcm; } -static Scheme_Object * -with_cont_mark_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *key, *val, *expr, *form, *fn, *boundname; - int len; - Scheme_Expand_Info recs[3]; - - SCHEME_EXPAND_OBSERVE_PRIM_WCM(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - len = check_form(form, form); - if (len != 4) - bad_form(form, len); - - fn = SCHEME_STX_CAR(form); - - boundname = scheme_check_name_property(form, env->value_name); - - env = scheme_no_defines(env); - env->value_name = NULL; - - scheme_init_expand_recs(erec, drec, recs, 3); - - form = SCHEME_STX_CDR(form); - key = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - val = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - expr = SCHEME_STX_CAR(form); - - key = scheme_expand_expr(key, env, recs, 0); - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - val = scheme_expand_expr(val, env, recs, 1); - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - env->value_name = boundname; - expr = scheme_expand_expr(expr, env, recs, 2); - - return scheme_datum_to_syntax(cons(fn, - cons(key, - cons(val, - cons(expr, scheme_null)))), - orig_form, - orig_form, - 0, 2); -} - /**********************************************************************/ /* set! */ /**********************************************************************/ -static Scheme_Object * -set_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *set_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Set_Bang *sb; - Scheme_Env *menv = NULL; - Scheme_Object *var, *val, *name, *body, *rest, *find_name; + Scheme_Object *var, *val, *name, *body, *rest; int l, set_undef; - form = scheme_stx_taint_disarm(form, NULL); - l = check_form(form, form); if (l != 3) bad_form(form, l); @@ -1317,65 +648,21 @@ rest = SCHEME_STX_CDR(rest); body = SCHEME_STX_CAR(rest); - scheme_check_identifier("set!", name, NULL, env, form); - - find_name = name; + scheme_check_identifier("set!", name, NULL, form); - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_SETTING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0), - env->in_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1, 0); - - return scheme_compile_expr(form, env, rec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - return NULL; - } + var = scheme_compile_lookup(name, env, SCHEME_SETTING); - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0, NULL); - if (env->genv->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - env->prefix->non_phaseless = 1; + if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) { + if (((Scheme_IR_Toplevel *)var)->instance_pos != -1) + scheme_wrong_syntax(NULL, form, name, "cannot mutate imported variable"); + SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_IR_TOPLEVEL_MUTATED; } + + env = scheme_set_comp_env_name(env, SCHEME_STX_SYM(name)); - scheme_compile_rec_done_local(rec, drec); - - env = scheme_no_defines(env); - env->value_name = SCHEME_STX_SYM(name); - - val = scheme_compile_expr(body, env, rec, drec); + val = compile_expr(body, env, 0); - env->value_name = NULL; - - set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED); + set_undef = (env->flags & COMP_ENV_ALLOW_SET_UNDEFINED); sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); sb->so.type = scheme_set_bang_type; @@ -1386,237 +673,64 @@ return (Scheme_Object *)sb; } -static Scheme_Object * -set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Env *menv = NULL; - Scheme_Object *name, *var, *fn, *rhs, *find_name, *form, *binding_id; - int l; - - SCHEME_EXPAND_OBSERVE_PRIM_SET(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - l = check_form(form, form); - if (l != 3) - bad_form(form, l); - - env = scheme_no_defines(env); - - name = SCHEME_STX_CDR(form); - name = SCHEME_STX_CAR(name); - - scheme_check_identifier("set!", name, NULL, env, form); - - find_name = name; - - while (1) { - /* Make sure it's mutable, and check for redirects: */ - var = scheme_compile_lookup(find_name, env, - SCHEME_SETTING + SCHEME_STOP_AT_FREE_EQ, - env->in_modidx, - &menv, NULL, - &binding_id, NULL, - NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - - if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form); - - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1, 0); - - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form); - - if (erec[drec].depth > 0) - erec[drec].depth--; - - env->value_name = name; - - return scheme_expand_expr(form, env, erec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - new_name = scheme_stx_track(new_name, find_name, find_name); - find_name = new_name; - menv = NULL; - } else - break; - } else { - if (binding_id) - find_name = binding_id; - break; - } - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - } - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - - - fn = SCHEME_STX_CAR(form); - rhs = SCHEME_STX_CDR(form); - rhs = SCHEME_STX_CDR(rhs); - rhs = SCHEME_STX_CAR(rhs); - - env->value_name = name; - - rhs = scheme_expand_expr(rhs, env, erec, drec); - - form = scheme_datum_to_syntax(cons(fn, - cons(find_name, - cons(rhs, scheme_null))), - orig_form, - orig_form, - 0, 2); - - env->value_name = NULL; - - return form; -} - /**********************************************************************/ /* #%variable-reference */ /**********************************************************************/ -static Scheme_Object * -ref_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *ref_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - Scheme_Env *menv = NULL; - Scheme_Object *var, *name, *rest, *dummy, *bind_id; + Scheme_Object *var, *name, *rest, *pseudo_var; int l, ok; - if (rec[drec].comp) - env->prefix->non_phaseless = 1; - - form = scheme_stx_taint_disarm(form, NULL); - l = check_form(form, form); - /* retaining `dummy' ensures that the environment stays + /* retaining `pseudo-var' ensures that the environment stays linked from the actual variable */ - if (rec[drec].comp && ((l == 1) || !rec[drec].testing_constantness)) - dummy = scheme_make_environment_dummy(env); - else - dummy = NULL; + if ((l == 1) || !(env->flags & COMP_ENV_CHECKING_CONSTANT)) + pseudo_var = (Scheme_Object *)scheme_make_ir_toplevel(-1, -1, 0); + else { + /* If the variable reference will be used only for + `variable-reference-constant?`, then we don't want a string + reference to the enclsoing instance. */ + pseudo_var = scheme_false; + } if (l == 1) { - if (rec[drec].comp) - var = dummy; - else - var = scheme_void; - bind_id = NULL; + var = scheme_false; } else { if (l != 2) bad_form(form, l); rest = SCHEME_STX_CDR(form); name = SCHEME_STX_CAR(rest); - name = scheme_stx_taint_disarm(name, NULL); - - if (SCHEME_STX_PAIRP(name)) { - rest = SCHEME_STX_CAR(name); - if (env->genv->phase == 0) { - var = scheme_top_stx; - } else { - var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0); - } - ok = scheme_stx_free_eq(rest, var, env->genv->phase); - } else - ok = SCHEME_STX_SYMBOLP(name); + ok = SCHEME_STX_SYMBOLP(name); if (!ok) { scheme_wrong_syntax("#%variable-reference", name, form, - "not an identifier or #%%top form"); + "not an identifier"); return NULL; } - if (SCHEME_STX_PAIRP(name)) { - /* FIXME: when using #%top, need to set mutated flag */ - env->value_name = NULL; - if (rec[drec].comp) - var = scheme_compile_expr(name, env, rec, drec); - else - var = scheme_expand_expr(name, env, rec, drec); - } else { - var = scheme_compile_lookup(name, env, - SCHEME_REFERENCING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - &bind_id, NULL, NULL); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - int imported = 0; - imported = scheme_is_imported(var, env); - - if (rec[drec].comp) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, imported, NULL); - if (!imported && env->genv->module && !rec[drec].testing_constantness) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - } - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { - /* ok */ - } else { - scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable"); - } + var = scheme_compile_lookup(name, env, SCHEME_REFERENCING); - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); + if (!SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type) + && !SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type) + && !SCHEME_SYMBOLP(var)) { /* symbol means primitive instance */ + scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable"); } } - if (rec[drec].comp) { + { Scheme_Object *o; o = scheme_alloc_object(); o->type = scheme_varref_form_type; - SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; - if (!dummy) dummy = scheme_false; - SCHEME_PTR2_VAL(o) = (Scheme_Object *)dummy; + SCHEME_PTR1_VAL(o) = var; + SCHEME_PTR2_VAL(o) = pseudo_var; return o; - } else { - if (bind_id) { - form = SCHEME_STX_CAR(form); - return scheme_make_pair(form, scheme_make_pair(bind_id, scheme_null)); - } - return NULL; } } -static Scheme_Object * -ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *naya; - - SCHEME_EXPAND_OBSERVE_PRIM_VARREF(env->observer); - - /* Error checking, and lexical variable update: */ - naya = ref_compile(form, env, erec, drec); - - if (!naya) - /* No change: */ - return form; - - return scheme_datum_to_syntax(naya, form, form, 0, 2); -} - /**********************************************************************/ /* case-lambda */ /**********************************************************************/ @@ -1682,19 +796,15 @@ SCHEME_STX_NULLP(body) ? "empty body not allowed" : IMPROPER_LIST_FORM); } -static Scheme_Object * -case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *list, *last, *c, *orig_form = form, *name; Scheme_Case_Lambda *cl; int i, count = 0; - Scheme_Compile_Info *recs; - form = scheme_stx_taint_disarm(form, NULL); - form = SCHEME_STX_CDR(form); + env = check_name_property(orig_form, env); name = scheme_build_closure_name(orig_form, env); if (SCHEME_STX_NULLP(form)) { @@ -1706,9 +816,6 @@ ((Scheme_Case_Lambda *)form)->count = 0; ((Scheme_Case_Lambda *)form)->name = name; - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - if (scheme_has_method_property(orig_form)) { /* See note in schpriv.h about the IS_METHOD hack */ if (!name) @@ -1727,15 +834,12 @@ case_lambda_check_line(c, orig_form, env); - c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - c); - c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2); + c = cons(lambda_symbol, c); + c = scheme_datum_to_syntax(c, orig_form, DTS_COPY_PROPS); - return lambda_compile(c, env, rec, drec); + return lambda_compile(c, env); } - scheme_compile_rec_done_local(rec, drec); - list = last = NULL; while (SCHEME_STX_PAIRP(form)) { Scheme_Object *clause; @@ -1744,7 +848,7 @@ c = cons(lambda_symbol, clause); - c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0); + c = scheme_datum_to_syntax(c, clause, 0); c = cons(c, scheme_null); @@ -1769,22 +873,16 @@ cl->count = count; cl->name = SCHEME_TRUEP(name) ? name : NULL; - scheme_compile_rec_done_local(rec, drec); - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, count); - scheme_init_compile_recs(rec, drec, recs, count); - - env->value_name = NULL; + env = scheme_set_comp_env_name(env, NULL); for (i = 0; i < count; i++) { Scheme_Object *ce; ce = SCHEME_CAR(list); - ce = scheme_compile_expr(ce, env, recs, i); + ce = compile_expr(ce, env, 0); cl->array[i] = ce; list = SCHEME_CDR(list); } - scheme_merge_compile_recs(rec, drec, recs, count); - if (scheme_has_method_property(orig_form)) { Scheme_Lambda *lam; /* Make sure no branch has 0 arguments: */ @@ -1802,65 +900,6 @@ return (Scheme_Object *)cl; } -static Scheme_Object * -case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first, *last, *args, *body, *c, *new_line, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - first = SCHEME_STX_CAR(form); - first = cons(first, scheme_null); - last = first; - form = SCHEME_STX_CDR(form); - - while (SCHEME_STX_PAIRP(form)) { - Scheme_Object *line_form, *scope; - Scheme_Comp_Env *newenv; - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - - line_form = SCHEME_STX_CAR(form); - - case_lambda_check_line(line_form, orig_form, env); - - body = SCHEME_STX_CDR(line_form); - args = SCHEME_STX_CAR(line_form); - - body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0); - - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - - newenv = scheme_add_compilation_frame(args, scope, env, 0); - - body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); - - SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(env->observer, args, body); - - { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, drec, &erec1, 1); - new_line = cons(args, expand_block(body, newenv, &erec1, 0)); - } - new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1); - - c = cons(new_line, scheme_null); - - SCHEME_CDR(last) = c; - last = c; - - form = SCHEME_STX_CDR(form); - } - - if (!SCHEME_STX_NULLP(form)) - scheme_wrong_syntax(NULL, form, orig_form, NULL); - - return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2); -} - /**********************************************************************/ /* let, let-values, letrec, etc. */ /**********************************************************************/ @@ -1880,174 +919,21 @@ return head; } -static Scheme_Object *force_traditional_letrec(Scheme_Object *result, Scheme_Comp_Env *env) -{ - /* Force `letrec'-style binding by adding a forward - reference to the last binding as a first binding: - (letrec-values+syntaxes ([() (if #f (#%app values))] ....) ....). - To avoid affecting performance, this hack is reverted in - the `letrec' compiler and expander. */ - Scheme_Object *sbh, *vbh, *vb, *v, *last_name = NULL, *values, *app; - - sbh = SCHEME_STX_CDR(result); - vbh = SCHEME_STX_CDR(sbh); - vb = SCHEME_STX_CAR(vbh); - - while (!SCHEME_STX_NULLP(vb)) { - v = SCHEME_STX_CAR(vb); - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_NULLP(v)) { - last_name = SCHEME_STX_CAR(v); - } - vb = SCHEME_STX_CDR(vb); - } - - if (last_name) { - vb = SCHEME_STX_CAR(vbh); - v = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, - scheme_sys_wraps(env), 0, 0); - app = scheme_datum_to_syntax(app_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - values = scheme_datum_to_syntax(values_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - vb = icons(icons(scheme_null, - icons(icons(v, - icons(scheme_false, - icons(last_name, - icons(icons(app, icons(values, scheme_null)), - scheme_null)))), - scheme_null)), - vb); - vbh = SCHEME_STX_CDR(vbh); - sbh = SCHEME_STX_CAR(sbh); - v = SCHEME_STX_CAR(result); - v = icons(v, icons(sbh, icons(vb, vbh))); - result = scheme_datum_to_syntax(v, result, result, 0, 2); - } - - return result; -} - -static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp_Env *env) -/* See force_traditional_letrec() */ +static Scheme_Object *do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, + int recursive) { - Scheme_Object *v, *v2, *v3, *id; - - v = SCHEME_STX_CDR(form); - v = SCHEME_STX_CAR(v); - if (SCHEME_STX_NULLP(v)) return form; - - v = SCHEME_STX_CAR(v); - /* is v `[() ...]' ? */ - v2 = SCHEME_STX_CAR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v2 = SCHEME_STX_CDR(v); - v2 = SCHEME_STX_CAR(v2); - - /* is v2 `(if #f ... (values))' ? */ - if (!SCHEME_STX_PAIRP(v2)) return form; - v = SCHEME_STX_CDR(v2); - if (!SCHEME_STX_PAIRP(v)) return form; - v = SCHEME_STX_CAR(v); - v = SCHEME_STX_VAL(v); - - if (!SCHEME_FALSEP(v)) { - /* try '#f: */ - if (!SCHEME_PAIRP(v)) return form; - v3 = SCHEME_CDR(v); - if (!SCHEME_STX_PAIRP(v3)) return form; - v3 = SCHEME_STX_CAR(v3); - v3 = SCHEME_STX_VAL(v3); - if (!SCHEME_FALSEP(v3)) return form; - - v3 = SCHEME_CDR(v); - v3 = SCHEME_STX_CDR(v3); - if (!SCHEME_STX_NULLP(v3)) return form; - } - - /* found #f; look for `if' and `(#%app values)': */ - v = SCHEME_STX_CAR(v2); - if (!SCHEME_STX_SYMBOLP(v)) return form; - - id = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; - - /* found `if'; look for `(#%app values)' */ - v = SCHEME_STX_CDR(v2); - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CDR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CAR(v); - if (!SCHEME_STX_SYMBOLP(v2)) return form; - id = scheme_datum_to_syntax(app_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v2, id, env->genv->phase)) return form; - - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CDR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_SYMBOLP(v)) return form; - id = scheme_datum_to_syntax(values_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; - - /* pattern matched; drop the first clause */ - v = SCHEME_STX_CDR(form); - v2 = SCHEME_STX_CAR(v); - v2 = SCHEME_STX_CDR(v2); - - v = SCHEME_STX_CDR(v); - v = scheme_datum_to_syntax(v, scheme_false, scheme_false, 0, 0); - v2 = icons(v2, v); - - v = SCHEME_STX_CAR(form); - v2 = icons(v, v2); - - return scheme_datum_to_syntax(v2, form, form, 0, 2); -} - -static Scheme_Object * -do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, - int recursive, int multi, Scheme_Compile_Info *rec, int drec, - Scheme_Comp_Env *frame_already) -{ - Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname, *scope; - int num_clauses, num_bindings, i, j, k, m, pre_k; - Scheme_Comp_Env *frame, *env, *rhs_env; - Scheme_Compile_Info *recs; - Scheme_Object *first = NULL, *existing_vars; + Scheme_Object *bindings, *l, *binding, *name, **names, *forms; + int num_clauses, num_bindings, i, k, m, pre_k, mutate_frame = 0, *use_box; + Scheme_Comp_Env *frame, *rhs_env; + Scheme_Object *first = NULL; Scheme_IR_Let_Value *last = NULL, *lv; + Scheme_IR_Local *var, **vars; DupCheckRecord r; - int rec_env_already = rec[drec].env_already, body_block; Scheme_IR_Let_Header *head; - form = scheme_stx_taint_disarm(form, NULL); - - if (rec_env_already >= 2) { - body_block = (rec_env_already > 2); - l = detect_traditional_letrec(form, origenv); - if (!SAME_OBJ(l, form)) { - rec_env_already = 1; - form = l; - } else - rec_env_already = 2; - } else - body_block = !rec_env_already; - - i = scheme_stx_proper_list_length(form); - if (i < 3) - scheme_wrong_syntax(NULL, NULL, form, (!i ? "empty body not allowed" : NULL)); + i = check_form(form, form); + if (i != 3) + bad_form(form, i); bindings = SCHEME_STX_CDR(form); bindings = SCHEME_STX_CAR(bindings); @@ -2059,94 +945,58 @@ /* forms ends up being the let body */ forms = SCHEME_STX_CDR(form); forms = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(forms, form, form, 0, 0); - - if (!num_clauses) { - if (!body_block) - scheme_signal_error("internal error: no local bindings, but body is not in a block"); - - /* Even though there are no bindings, we need a scope to - indicate a nested binding context */ - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - env = scheme_new_compilation_frame(0, 0, scope, origenv); - forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); + forms = SCHEME_STX_CAR(forms); - name = scheme_check_name_property(form, origenv->value_name); - env->value_name = name; + origenv = check_name_property(form, origenv); - return compile_sequence(forms, env, rec, drec, body_block); - } + if (!num_clauses) + return compile_expr(forms, origenv, 0); - if (multi) { - num_bindings = 0; - l = bindings; - while (!SCHEME_STX_NULLP(l)) { - Scheme_Object *clause, *names, *rest; - int num_names; + num_bindings = 0; + l = bindings; + while (!SCHEME_STX_NULLP(l)) { + Scheme_Object *clause, *names, *rest; + int num_names; - clause = SCHEME_STX_CAR(l); + clause = SCHEME_STX_CAR(l); - if (!SCHEME_STX_PAIRP(clause)) - rest = NULL; + if (!SCHEME_STX_PAIRP(clause)) + rest = NULL; + else { + rest = SCHEME_STX_CDR(clause); + if (!SCHEME_STX_PAIRP(rest)) + rest = NULL; else { - rest = SCHEME_STX_CDR(clause); - if (!SCHEME_STX_PAIRP(rest)) - rest = NULL; - else { - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - rest = NULL; - } + rest = SCHEME_STX_CDR(rest); + if (!SCHEME_STX_NULLP(rest)) + rest = NULL; } - if (!rest) - scheme_wrong_syntax(NULL, clause, form, NULL); + } + if (!rest) + scheme_wrong_syntax(NULL, clause, form, NULL); - names = SCHEME_STX_CAR(clause); + names = SCHEME_STX_CAR(clause); - num_names = scheme_stx_proper_list_length(names); - if (num_names < 0) - scheme_wrong_syntax(NULL, names, form, NULL); + num_names = scheme_stx_proper_list_length(names); + if (num_names < 0) + scheme_wrong_syntax(NULL, names, form, NULL); - num_bindings += num_names; + num_bindings += num_names; - l = SCHEME_STX_CDR(l); - } - } else - num_bindings = num_clauses; - - if (rec_env_already) - scope = NULL; - else - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + l = SCHEME_STX_CDR(l); + } names = MALLOC_N(Scheme_Object *, num_bindings); - if (frame_already) - frame = frame_already; - else { - frame = scheme_new_compilation_frame(num_bindings, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), - scope, - origenv); - if (rec_env_already) - frame_already = frame; - } - env = frame; - if (!recursive) - rhs_env = scheme_no_defines(origenv); - else - rhs_env = env; - - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, (num_clauses + 1)); - defname = origenv->value_name; - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, num_clauses + 1); + frame = scheme_set_comp_env_name(origenv, NULL); - defname = scheme_check_name_property(form, defname); + if (recursive) { + use_box = MALLOC_N_ATOMIC(int, 1); + *use_box = -1; + } else + use_box = 0; - if (!frame_already) { - scheme_begin_dup_symbol_check(&r, env); - } + scheme_begin_dup_symbol_check(&r); k = 0; @@ -2166,37 +1016,18 @@ pre_k = k; - existing_vars = scheme_stx_property(binding, existing_variables_symbol, NULL); - name = SCHEME_STX_CAR(binding); - if (multi) { - while (!SCHEME_STX_NULLP(name)) { - Scheme_Object *n; - n = SCHEME_STX_CAR(name); - names[k] = n; - scheme_check_identifier(NULL, names[k], NULL, env, form); - k++; - name = SCHEME_STX_CDR(name); - } - - for (j = pre_k; j < k; j++) { - for (m = j + 1; m < k; m++) { - if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase))) - scheme_wrong_syntax(NULL, NULL, form, - "multiple bindings of `%S' in the same clause", - SCHEME_STX_SYM(names[m])); - } - } - } else { - scheme_check_identifier(NULL, name, NULL, env, form); - names[k++] = name; - } - - if (!frame_already) { - for (m = pre_k; m < k; m++) { - scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); - } + while (!SCHEME_STX_NULLP(name)) { + Scheme_Object *n; + n = SCHEME_STX_CAR(name); + names[k] = n; + scheme_check_identifier(NULL, names[k], NULL, form); + scheme_dup_symbol_check(&r, NULL, names[k], "binding", form); + k++; + name = SCHEME_STX_CDR(name); } + + vars = MALLOC_N(Scheme_IR_Local*, k-pre_k); lv = MALLOC_ONE_TAGGED(Scheme_IR_Let_Value); lv->iso.so.type = scheme_ir_let_value_type; @@ -2206,62 +1037,38 @@ last->body = (Scheme_Object *)lv; last = lv; lv->count = (k - pre_k); + lv->vars = vars; - if (lv->count == 1) - rhs_env->value_name = SCHEME_STX_SYM(names[pre_k]); - - if (!recursive) { - Scheme_Object *ce, *rhs; - rhs = SCHEME_STX_CDR(binding); - rhs = SCHEME_STX_CAR(rhs); - ce = scheme_compile_expr(rhs, rhs_env, recs, i); - lv->value = ce; - } else { + { Scheme_Object *rhs; rhs = SCHEME_STX_CDR(binding); rhs = SCHEME_STX_CAR(rhs); - lv->value = rhs; - } - - rhs_env->value_name = NULL; - - if (recursive) { - for (m = pre_k; m < k; m++) { - scheme_add_compilation_binding(m, names[m], frame); + if (!recursive) { + if (lv->count == 1) + rhs_env = scheme_set_comp_env_name(origenv, names[pre_k]); + else + rhs_env = scheme_set_comp_env_name(origenv, NULL); + rhs = SCHEME_STX_CDR(binding); + rhs = SCHEME_STX_CAR(rhs); + rhs = compile_expr(rhs, rhs_env, 0); } + lv->value = rhs; } - if (SCHEME_TRUEP(existing_vars)) { - /* Install variables already generated by a lift: */ - scheme_set_compilation_variables(frame, (Scheme_IR_Local **)SCHEME_CDR(existing_vars), - pre_k, k - pre_k); + for (m = pre_k; m < k; m++) { + var = scheme_make_ir_local(names[m]); + if (recursive) { + var->mode = SCHEME_VAR_MODE_COMPILE; + var->compile.use_box = use_box; + var->compile.use_position = m; + } + vars[m-pre_k] = var; + frame = scheme_extend_comp_env(frame, names[m], (Scheme_Object *)var, mutate_frame, 0); + mutate_frame = 1; } bindings = SCHEME_STX_CDR(bindings); } - - if (!recursive) { - for (i = 0; i < num_bindings; i++) { - scheme_add_compilation_binding(i, names[i], frame); - } - } - - scheme_env_make_variables(env); - - k = 0; - lv = (Scheme_IR_Let_Value *)first; - for (i = 0; i < num_clauses; i++) { - Scheme_IR_Local **vars; - - vars = MALLOC_N(Scheme_IR_Local*, lv->count); - lv->vars = vars; - for (j = lv->count; j--; ) { - vars[j] = env->vars[k+j]; - } - - k += lv->count; - lv = (Scheme_IR_Let_Value *)lv->body; - } head = make_header(first, num_bindings, num_clauses, (recursive ? SCHEME_LET_RECURSIVE : 0)); @@ -2269,38 +1076,32 @@ if (recursive) { int prev_might_invoke = 0; int group_clauses = 0; + Scheme_Object *rhs; k = 0; lv = (Scheme_IR_Let_Value *)first; for (i = 0; i < num_clauses; i++, lv = (Scheme_IR_Let_Value *)lv->body) { - Scheme_Object *ce, *rhs; rhs = lv->value; - if (scope) - rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); if (lv->count == 1) - env->value_name = lv->vars[0]->name; + rhs_env = scheme_set_comp_env_name(frame, names[k]); else - env->value_name = NULL; - ce = scheme_compile_expr(rhs, env, recs, i); - env->value_name = NULL; - lv->value = ce; + rhs_env = scheme_set_comp_env_name(frame, NULL); + rhs = compile_expr(rhs, rhs_env, 0); + lv->value = rhs; - /* Record when this binding doesn't use any or later - bindings in the same set. In internal-definition mode, - always break bindings into smaller sets based on this - information; otherwise, we have to be more conservative as reflected - by scheme_might_invoke_call_cc(), so record with - SCHEME_IRLV_NO_GROUP_LATER_USES and check again at the end. */ - if ((rec_env_already == 2) /* int def: semantics is `let' */ - || (!prev_might_invoke - && !scheme_might_invoke_call_cc(ce))) { + /* Record when this binding doesn't use any or later bindings in + the same set. Break bindings into smaller sets based on this + information, we have to be conservative as reflected by + scheme_might_invoke_call_cc(). Implement splitting by + recording with SCHEME_IRLV_NO_GROUP_LATER_USES and check + again at the end. */ + if (!prev_might_invoke && !scheme_might_invoke_call_cc(rhs)) { group_clauses++; - if ((group_clauses == 1) - && !scheme_env_max_use_above(env, k)) { + if ((group_clauses == 1) && (*use_box < k)) { /* A clause that should be in its own `let' */ SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_USES; group_clauses = 0; - } else if (!scheme_env_max_use_above(env, k + lv->count)) { + } else if (*use_box < (k + lv->count)) { /* End a recursive `letrec' group */ SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_LATER_USES; group_clauses = 0; @@ -2347,350 +1148,44 @@ } } - env->value_name = defname ? SCHEME_STX_SYM(defname) : NULL; - { - Scheme_Object *cs; - if (scope) forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); - cs = compile_sequence(forms, env, recs, num_clauses, body_block); - last->body = cs; - } - env->value_name = NULL; + frame = scheme_set_comp_env_name(frame, origenv->value_name); - scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); + forms = compile_expr(forms, frame, 0); + last->body = forms; return (Scheme_Object *)head; } -static Scheme_Object * -do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, - const char *formname, int letrec, int multi, - Scheme_Comp_Env *env_already) -{ - Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *boundname, *form, *pre_set, *scope; - Scheme_Object *vlist_first, *vlist_last; - Scheme_Comp_Env *use_env, *env; - Scheme_Expand_Info erec1; - DupCheckRecord r; - int rec_env_already = erec[drec].env_already, forward_ref_boundary, body_block; - /* If env_already == 2, then it's not a true `letrec': - it's from `letrec-values+syntax' and should be - expanded into `let' plus `letrec'. */ - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec_env_already >= 2) { - body_block = (rec_env_already > 2); - rec_env_already = 2; - v = detect_traditional_letrec(form, origenv); - if (!SAME_OBJ(v, form)) { - rec_env_already = 1; - form = v; - } - } else - body_block = !rec_env_already; - - vars = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_PAIRP(vars)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - body = SCHEME_STX_CDR(vars); - vars = SCHEME_STX_CAR(vars); - - if (!SCHEME_STX_PAIRP(body)) - scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) - ? "empty body not allowed" - : NULL)); - - boundname = scheme_check_name_property(form, origenv->value_name); - - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r, origenv); - - vlist_first = scheme_null; - vlist_last = NULL; - vs = vars; - while (SCHEME_STX_PAIRP(vs)) { - Scheme_Object *v2; - v = SCHEME_STX_CAR(vs); - if (SCHEME_STX_PAIRP(v)) - v2 = SCHEME_STX_CDR(v); - else - v2 = scheme_false; - if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2))) - scheme_wrong_syntax(NULL, v, form, NULL); - - name = SCHEME_STX_CAR(v); - - { - DupCheckRecord r2; - Scheme_Object *names = name; - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r2, origenv); - while (SCHEME_STX_PAIRP(names)) { - name = SCHEME_STX_CAR(names); - - scheme_check_identifier(NULL, name, NULL, origenv, form); - - v = scheme_make_pair(name, scheme_null); - if (vlist_last) - SCHEME_CDR(vlist_last) = v; - else - vlist_first = v; - vlist_last = v; - - if (!env_already && !rec_env_already) { - scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); - scheme_dup_symbol_check(&r, NULL, name, "binding", form); - } - - names = SCHEME_STX_CDR(names); - } - if (!SCHEME_STX_NULLP(names)) - scheme_wrong_syntax(NULL, names, form, NULL); - } - - vs = SCHEME_STX_CDR(vs); - } - - if (!SCHEME_STX_NULLP(vs)) - scheme_wrong_syntax(NULL, vs, form, NULL); - - if (env_already) { - env = env_already; - scope = NULL; - } else { - if (rec_env_already) - scope = NULL; - else - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - env = scheme_add_compilation_frame(vlist_first, - scope, - origenv, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0)); - } - - if (letrec) - use_env = env; - else - use_env = scheme_no_defines(origenv); - - /* Pass 1: Rename */ - - first = last = NULL; - vs = vars; - forward_ref_boundary = 0; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs; - - v = SCHEME_STX_CAR(vars); - - /* Make sure names gets their own renames: */ - name = SCHEME_STX_CAR(v); - if (scope) name = scheme_stx_add_scope(name, scope, scheme_env_phase(env->genv)); - - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - if (scope && letrec) rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - vars = SCHEME_STX_CDR(vars); - } - if (!first) { - first = scheme_null; - } - vars = first; - - body = scheme_datum_to_syntax(body, form, form, 0, 0); - if (scope) body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LET_RENAMES(env->observer, vars, body); - } - - /* Pass 2: Expand */ - - first = last = NULL; - pre_set = scheme_null; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs, *rhs_name; - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - - v = SCHEME_STX_CAR(vars); - - name = SCHEME_STX_CAR(v); - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - - if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { - rhs_name = SCHEME_STX_CAR(name); - } else { - rhs_name = scheme_false; - } - - scheme_init_expand_recs(erec, drec, &erec1, 1); - use_env->value_name = rhs_name; - rhs = scheme_expand_expr(rhs, use_env, &erec1, 0); - use_env->value_name = NULL; - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - - if (rec_env_already == 2) { - /* Expansion for internal definitions: break into `let' and - `letrec' groups based on references among definitions: */ - int cnt; - cnt = scheme_stx_proper_list_length(name); - if (SCHEME_NULLP(SCHEME_CDR(first)) - && !scheme_env_max_use_above(use_env, forward_ref_boundary)) { - /* no self or forward references */ - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - pre_set = cons(cons(let_values_symbol, first), pre_set); - first = NULL; - } else if (!scheme_env_max_use_above(use_env, forward_ref_boundary + cnt)) { - /* no (further) forward references */ - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - pre_set = cons(cons(letrec_values_symbol, first), pre_set); - first = NULL; - } - forward_ref_boundary += cnt; - } - - vars = SCHEME_STX_CDR(vars); - } - - /* End Pass 2 */ - - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, vars, form, NULL); - - if (SCHEME_NULLP(pre_set) || first) { - if (!first) - first = scheme_null; - - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - } - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer); - } - scheme_init_expand_recs(erec, drec, &erec1, 1); - env->value_name = boundname; - if (!body_block) - body = expand_list(body, env, &erec1, 0); - else - body = expand_block(body, env, &erec1, 0); - env->value_name = NULL; - - if (SCHEME_PAIRP(pre_set)) { - if (first) - pre_set = cons(cons(letrec_values_symbol, first), pre_set); - - while (!SCHEME_NULLP(pre_set)) { - v = scheme_datum_to_syntax(SCHEME_CAR(SCHEME_CAR(pre_set)), orig_form, scheme_sys_wraps(origenv), 0, 0); - body = cons(v, cons(SCHEME_CDR(SCHEME_CAR(pre_set)), body)); - body = scheme_datum_to_syntax(body, orig_form, orig_form, 0, 2); - body = cons(body, scheme_null); - pre_set = SCHEME_CDR(pre_set); - } - - return SCHEME_CAR(body); - } else { - v = SCHEME_STX_CAR(form); - v = cons(v, cons(first, body)); - v = scheme_datum_to_syntax(v, orig_form, orig_form, 0, 2); - } - - return v; -} - -static Scheme_Object * -let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(env->observer); - return do_let_expand(form, env, erec, drec, "let-values", 0, 1, NULL); -} - -static Scheme_Object * -letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(env->observer); - return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, NULL); -} - - -static Scheme_Object * -let_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *let_values_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - return do_let_compile(form, env, "let-values", 0, 1, rec, drec, NULL); + return do_let_compile(form, env, "let-values", 0); } -static Scheme_Object * -letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - return do_let_compile(form, env, "letrec-values", 1, 1, rec, drec, NULL); + return do_let_compile(form, env, "letrec-values", 1); } /**********************************************************************/ /* begin, begin0, implicit begins */ /**********************************************************************/ -static Scheme_Object *compile_sequence(Scheme_Object *forms, - Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int as_intdef) -{ - if (scheme_stx_proper_list_length(forms) < 0) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, - scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), - IMPROPER_LIST_FORM); - return NULL; - } else { - Scheme_Object *body; - if (as_intdef) - body = compile_block(forms, env, rec, drec); - else - body = compile_list(forms, env, rec, drec); - return scheme_make_sequence_compilation(body, 1, 0); - } -} - Scheme_Object *scheme_compiled_void() { return scheme_void; } -static Scheme_Object * -do_begin_compile(char *name, - Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, - int zero) +static Scheme_Object *do_begin_compile(char *name, + Scheme_Object *form, Scheme_Comp_Env *env, + int zero) { - Scheme_Object *forms, *body, *vname; - - form = scheme_stx_taint_disarm(form, NULL); + Scheme_Comp_Env *nontail_env; + Scheme_Object *forms, *body; forms = SCHEME_STX_CDR(form); if (SCHEME_STX_NULLP(forms)) { - if (!zero && scheme_is_toplevel(env)) + if (!zero) return scheme_compiled_void(); scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed"); return NULL; @@ -2698,86 +1193,66 @@ check_form(form, form); - if (zero) { - vname = env->value_name; - env = scheme_no_defines(env); - env->value_name = vname; - } + env = check_name_property(form, env); + nontail_env = scheme_set_comp_env_name(env, NULL); - /* if the begin has only one expression inside, drop the begin - TODO: is this right */ + /* if the `begin` has only one expression inside, drop the `begin`; + this is allowed even for `begin0`, where the initial expression + is considered in tail position if it's syntactically the only + expression */ if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { forms = SCHEME_STX_CAR(forms); - return scheme_compile_expr(forms, env, rec, drec); + return compile_expr(forms, env, 0); } - if (!scheme_is_toplevel(env)) { - /* Not at top-level */ - if (zero) { - /* First expression is not part of the block: */ - Scheme_Compile_Info recs[2]; - Scheme_Object *first, *rest, *vname; - - vname = env->value_name; - scheme_compile_rec_done_local(rec, drec); - - vname = scheme_check_name_property(form, vname); - - scheme_init_compile_recs(rec, drec, recs, 2); - - first = SCHEME_STX_CAR(forms); - env->value_name = vname; - first = scheme_compile_expr(first, env, recs, 0); - env->value_name = NULL; - rest = SCHEME_STX_CDR(forms); - rest = compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - - body = cons(first, rest); - } else { - Scheme_Object *v; - v = scheme_check_name_property(form, env->value_name); - env->value_name = v; + if (zero) { + Scheme_Object *first, *rest; - body = compile_list(forms, env, rec, drec); + first = SCHEME_STX_CAR(forms); + first = compile_expr(first, env, 0); + rest = SCHEME_STX_CDR(forms); + rest = compile_list(rest, nontail_env, nontail_env, nontail_env, 0); - env->value_name = NULL; - } + body = cons(first, rest); } else { - /* Top level */ - body = compile_list(forms, env, rec, drec); + body = compile_list(forms, nontail_env, nontail_env, env, 0); } forms = scheme_make_sequence_compilation(body, zero ? -1 : 1, 0); - if (!zero - && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type) - && scheme_is_toplevel(env)) { - forms->type = scheme_splice_sequence_type; - return forms; - } - return forms; } -static Scheme_Object * -begin_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - return do_begin_compile("begin", form, env, rec, drec, 0); + return do_begin_compile("begin", form, env, 0); } -static Scheme_Object * -begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env) +{ + return do_begin_compile("begin0", form, env, 1); +} + +static Scheme_Sequence *malloc_big_sequence(int count) { - return do_begin_compile("begin0", form, env, rec, drec, 1); + intptr_t sz; + Scheme_Sequence *seq; + + sz = scheme_check_overflow((count - mzFLEX_DELTA), sizeof(Scheme_Object *), sizeof(Scheme_Sequence)); + seq = (Scheme_Sequence *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz); + if (!seq) scheme_signal_error("out of memory allocating sequence bytecode"); + + return seq; } -Scheme_Sequence *scheme_malloc_sequence(int count) +Scheme_Sequence *scheme_malloc_sequence(int count) XFORM_ASSERT_NO_CONVERSION { - return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) - + (count - mzFLEX_DELTA) - * sizeof(Scheme_Object *)); + if (count < 4096) + return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) + + (count - mzFLEX_DELTA) + * sizeof(Scheme_Object *)); + else + return malloc_big_sequence(count); } Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt, int resolved) @@ -2880,1174 +1355,113 @@ return (Scheme_Object *)o; } -static Scheme_Object * -stratified_body_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *body; - - check_form(form, form); +/*========================================================================*/ +/* applications */ +/*========================================================================*/ - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); +int scheme_get_eval_type(Scheme_Object *obj) + /* Categories for short-cutting recursive calls to the evaluator */ +{ + Scheme_Type type; - body = compile_stratified_block(body, env, rec, drec); + type = SCHEME_TYPE(obj); - if (SCHEME_NULLP(SCHEME_CDR(body))) - return SCHEME_CAR(body); + if (type > _scheme_values_types_) + return SCHEME_EVAL_CONSTANT; + else if (SAME_TYPE(type, scheme_ir_local_type) + || SAME_TYPE(type, scheme_local_type)) + return SCHEME_EVAL_LOCAL; + else if (SAME_TYPE(type, scheme_local_unbox_type)) + return SCHEME_EVAL_LOCAL_UNBOX; + else if (SAME_TYPE(type, scheme_toplevel_type)) + return SCHEME_EVAL_GLOBAL; else - return scheme_make_sequence_compilation(body, 1, 0); -} + return SCHEME_EVAL_GENERAL; +} -static Scheme_Object * -do_begin_expand(char *name, - Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int zero) +Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info) + /* Apply `f' to `args' and ignore failues --- used for constant + folding attempts */ { - Scheme_Object *form_name; - Scheme_Object *rest; - Scheme_Object *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - check_form(form, form); + Scheme_Object * volatile result; + Scheme_Object * volatile exn = NULL; + mz_jmp_buf *savebuf, newbuf; - form_name = SCHEME_STX_CAR(form); + scheme_current_thread->reading_delayed = NULL; + scheme_current_thread->constant_folding = (info ? info : (Optimize_Info *)scheme_false); + savebuf = scheme_current_thread->error_buf; + scheme_current_thread->error_buf = &newbuf; - rest = SCHEME_STX_CDR(form); + if (scheme_setjmp(newbuf)) { + result = NULL; + exn = scheme_current_thread->reading_delayed; + } else + result = _scheme_apply_to_list(f, args); + + scheme_current_thread->error_buf = savebuf; + scheme_current_thread->constant_folding = NULL; + scheme_current_thread->reading_delayed = NULL; - if (SCHEME_STX_NULLP(rest)) { - if (!zero && scheme_is_toplevel(env)) { - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - } - return orig_form; - } - scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed"); - return NULL; + if (scheme_current_thread->cjs.is_kill) { + scheme_longjmp(*scheme_current_thread->error_buf, 1); } - if (zero) - env = scheme_no_defines(env); - - if (!scheme_is_toplevel(env)) { - /* Not at top-level: */ - if (zero) { - Scheme_Object *fst, *boundname; - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, drec, &erec1, 1); - boundname = scheme_check_name_property(form, env->value_name); - fst = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - env->value_name = boundname; - fst = scheme_expand_expr(fst, env, &erec1, 0); - env->value_name = NULL; - rest = scheme_datum_to_syntax(rest, form, form, 0, 0); - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - rest = expand_list(rest, env, erec, drec); - - form = cons(fst, rest); - } else { - Scheme_Object *boundname; - boundname = scheme_check_name_property(form, env->value_name); - env->value_name = boundname; - - form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); -#if 0 - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) - return scheme_stx_taint_rearm(SCHEME_STX_CAR(form), orig_form); -#endif - } - } else { - /* Top level */ - form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); - } + if (exn) + scheme_raise(exn); - return scheme_datum_to_syntax(cons(form_name, form), - orig_form, orig_form, - 0, 2); + return result; } -static Scheme_Object * -begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +static int foldable_body(Scheme_Object *f) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - return do_begin_expand("begin", form, env, erec, drec, 0); -} + Scheme_Lambda *d; + + d = SCHEME_CLOSURE_CODE(f); -static Scheme_Object * -begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(env->observer); - return do_begin_expand("begin0", form, env, erec, drec, 1); + scheme_delay_load_closure(d); + + return (SCHEME_TYPE(d->body) > _scheme_values_types_); } -static Scheme_Object * -stratified_body_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +int scheme_is_foldable_prim(Scheme_Object *f) { - Scheme_Object *body, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); + if (SCHEME_PRIMP(f) + && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING)) + return 1; - check_form(form, form); + if (SCHEME_CLSD_PRIMP(f) + && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING)) + return 1; - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = expand_stratified_block(body, env, erec, drec); - - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(body))) { - body = SCHEME_STX_CAR(body); - return scheme_stx_taint_rearm(body, orig_form); - } else { - body = cons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - body); - return scheme_datum_to_syntax(body, orig_form, orig_form, 0, 0); - } + return 0; } -/**********************************************************************/ -/* #%non-module and #%expression */ -/**********************************************************************/ - -static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only) +Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info) { - Scheme_Object *rest; + Scheme_Object *o; + int i, nv; + volatile int n; - form = scheme_stx_taint_disarm(form, NULL); + o = v; + n = 0; + nv = 0; + while (!SCHEME_NULLP(o)) { + Scheme_Type type; + + n++; + type = SCHEME_TYPE(SCHEME_CAR(o)); + if (type < _scheme_ir_values_types_) + nv = 1; + o = SCHEME_CDR(o); + } - check_form(form, form); + if (!nv) { + /* They're all values. Applying folding prim or closure? */ + Scheme_Object *f; - rest = SCHEME_STX_CDR(form); - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - - if (top_only && !scheme_is_toplevel(top_only)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); - - return SCHEME_STX_CAR(rest); -} - -static Scheme_Object * -single_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only) -{ - return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec); -} - -static Scheme_Object * -single_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int top_only, int simplify) -{ - Scheme_Object *expr, *form_name, *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - expr = check_single(form, top_only ? env : NULL); - expr = scheme_expand_expr(expr, env, erec, drec); - - form_name = SCHEME_STX_CAR(form); - - if (simplify && (erec[drec].depth == -1)) { - expr = scheme_stx_track(expr, form, form_name); - SCHEME_EXPAND_OBSERVE_TAG(env->observer,expr); - return expr; - } - - return scheme_datum_to_syntax(cons(form_name, cons(expr, scheme_null)), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object *expression_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return single_compile(form, scheme_no_defines(env), rec, drec, 0); -} - -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(env->observer); - return single_expand(form, scheme_no_defines(env), erec, drec, 0, - !(env->flags & SCHEME_TOPLEVEL_FRAME)); -} - - -/**********************************************************************/ -/* unquote, unquote-splicing */ -/**********************************************************************/ - -static Scheme_Object * -unquote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len; - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if (len != 2) - bad_form(form, len); - - scheme_wrong_syntax(NULL, NULL, form, "not in quasiquote"); - return NULL; -} - -static Scheme_Object * -unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return unquote_compile(form, env, erec, drec); -} - -/**********************************************************************/ -/* quote-syntax */ -/**********************************************************************/ - -static Scheme_Object * -quote_syntax_compile(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len, local; - Scheme_Object *stx, *form; - Scheme_Comp_Env *frame; - - if (rec[drec].comp) - env->prefix->non_phaseless = 1; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if ((len != 2) && (len != 3)) - bad_form(form, len); - - if (len == 3) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CDR(stx); - stx = SCHEME_STX_CAR(stx); - if (!SAME_OBJ(SCHEME_STX_VAL(stx), local_keyword)) { - scheme_wrong_syntax(NULL, stx, form, "second subform is not `#:local'"); - return NULL; - } - local = 1; - if (!rec[drec].comp) { - /* A `(quote-syntax _ #:local)` counts as a reference at all levels */ - scheme_mark_all_use(env); - } - } else - local = 0; - - if (!local) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CAR(stx); - - /* Remove scopes for all enclosing local binding contexts. */ - for (frame = env; frame; frame = frame->next) { - if ((frame->scopes) && !(frame->flags & SCHEME_KEEP_SCOPES_FRAME)) { - stx = scheme_stx_adjust_frame_scopes(stx, frame->scopes, - scheme_env_phase(frame->genv), SCHEME_STX_REMOVE); - } - } - - if (rec[drec].comp) - return scheme_register_stx_in_prefix(stx, env, rec, drec); - else { - form = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(scheme_make_pair(form, - scheme_make_pair(stx, scheme_null)), - orig_form, orig_form, 0, 2); - } - } else { - if (rec[drec].comp) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CAR(stx); - return scheme_register_stx_in_prefix(stx, env, rec, drec); - } else - return orig_form; - } -} - -static Scheme_Object * -quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(env->observer); - return quote_syntax_compile(form, env, erec, drec); -} - - -/**********************************************************************/ -/* define-syntaxes */ -/**********************************************************************/ - -static void prep_exp_env_compile_rec(Scheme_Compile_Info *rec, int drec) -{ - rec[0].comp = 1; - rec[0].dont_mark_local_use = 0; - rec[0].resolve_module_ids = 0; - rec[0].substitute_bindings = 1; - rec[0].pre_unwrapped = 0; - rec[0].testing_constantness = 0; - rec[0].env_already = 0; - rec[0].comp_flags = rec[drec].comp_flags; -} - -static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) -{ - return global_binding(name, (Scheme_Comp_Env *)_env); -} - -static Scheme_Object * -do_define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *names, *code, *dummy; - Scheme_Object *val, *vec; - Scheme_Comp_Env *exp_env; - Scheme_Compile_Info rec1; - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - scheme_define_parse(form, &names, &code, 1, env, 0); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env); - - exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0); - exp_env->observer = env->observer; - - dummy = scheme_make_environment_dummy(env); - - prep_exp_env_compile_rec(&rec1, 0); - - if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - exp_env->value_name = SCHEME_STX_VAL(SCHEME_CAR(names)); - - val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)exp_env->prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - SCHEME_VEC_ELS(vec)[2] = names; - SCHEME_VEC_ELS(vec)[3] = val; - - vec->type = scheme_define_syntaxes_type; - - scheme_merge_undefineds(exp_env, env); - - return vec; -} - -static Scheme_Object * -define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_compile(form, env, rec, drec); -} - -static Scheme_Object * -define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *names, *code, *fpart, *fn, *form, *observer; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer); - - form = orig_form; - - scheme_define_parse(form, &names, &code, 1, env, 0); - - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - observer = env->observer; - - env = scheme_new_expand_env(env->genv->exp_env, env->insp, NULL, 0); - env->observer = observer; - - env->value_name = names; - fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec); - - code = cons(fpart, scheme_null); - code = cons(names, code); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, code), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object * -begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Scheme_Expand_Info *rec, int drec) -{ - Scheme_Expand_Info recs[1]; - Scheme_Object *form, *l, *fn, *vec, *dummy; - Scheme_Comp_Env *env; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(in_env->observer); - } - - form = orig_form; - - if (!scheme_is_toplevel(in_env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a definition context"); - - (void)check_form(form, form); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(in_env->observer); - } - - scheme_prepare_exp_env(in_env->genv); - scheme_prepare_compile_env(in_env->genv->exp_env); - - if (rec[drec].comp) { - env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, NULL, - (in_env->flags & SCHEME_TMP_TL_BIND_FRAME)); - env->bindings = in_env->bindings; - } else - env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, NULL, 0); - - env->observer = in_env->observer; - - if (rec[drec].comp) - dummy = scheme_make_environment_dummy(in_env); - else - dummy = NULL; - - l = SCHEME_STX_CDR(form); - form = scheme_null; - - while (1) { - scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), - scheme_false, scheme_top_level_lifts_key(env), scheme_null, - scheme_false, scheme_true); - - if (rec[drec].comp) { - scheme_init_compile_recs(rec, drec, recs, 1); - prep_exp_env_compile_rec(recs, 0); - l = compile_list(l, env, recs, 0); - } else { - scheme_init_expand_recs(rec, drec, recs, 1); - l = expand_list(l, env, recs, 0); - } - - if (SCHEME_NULLP(form)) - form = l; - else - form = scheme_append(l, form); - - l = scheme_frame_get_lifts(env); - if (SCHEME_NULLP(l)) { - /* No lifts */ - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, NULL, 1); /* fix this if merge changes to do something */ - break; - } else { - /* We have lifts: */ - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(env->observer, l); - } - } - - if (rec[drec].comp) { - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - SCHEME_VEC_ELS(vec)[2] = form; - vec->type = scheme_begin_for_syntax_type; - - return vec; - } else { - fn = SCHEME_STX_CAR(orig_form); - return scheme_datum_to_syntax(cons(fn, form), - orig_form, orig_form, - 0, 2); - } -} - -static Scheme_Object * -begin_for_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return begin_for_syntax_expand(form, env, rec, drec); -} - -Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) -{ - /* Get a prefixed-based accessor for a dummy top-level bucket. It's - used to "link" to the right environment at run time. The #f as - a toplevel is handled in the prefix linker specially. */ - return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0, 0, NULL); -} - -Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy) -{ - Scheme_Prefix *toplevels; - Scheme_Bucket *b; - - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(dummy)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(dummy)]; - return scheme_get_bucket_home(b); -} - -/**********************************************************************/ -/* letrec-syntaxes */ -/**********************************************************************/ - -static void *eval_letmacro_rhs_k(void); - -static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Env *genv, Scheme_Comp_Env *rhs_env, - int max_let_depth, Resolve_Prefix *rp, - int phase) -{ - Scheme_Object **save_runstack; - int depth; - - depth = max_let_depth + scheme_prefix_depth(rp); - if (!scheme_check_runstack(depth)) { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = a; - p->ku.k.p2 = rhs_env; - p->ku.k.p3 = rp; - p->ku.k.p4 = genv; - p->ku.k.i1 = max_let_depth; - p->ku.k.i2 = phase; - return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); - } - - save_runstack = scheme_push_prefix(genv, 1, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); - - if (scheme_omittable_expr(a, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) { - /* short cut */ - a = _scheme_eval_linked_expr_multi(a); - } else { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Dynamic_State dyn_state; - - scheme_prepare_exp_env(rhs_env->genv); - scheme_prepare_compile_env(rhs_env->genv->exp_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)rhs_env->genv->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - rhs_env->genv, rhs_env->genv->link_midx); - a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - scheme_pop_prefix(save_runstack); - - return a; -} - -static void *eval_letmacro_rhs_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *a; - Scheme_Comp_Env *rhs_env; - int max_let_depth, phase; - Resolve_Prefix *rp; - Scheme_Env *genv; - - a = (Scheme_Object *)p->ku.k.p1; - rhs_env = (Scheme_Comp_Env *)p->ku.k.p2; - rp = (Resolve_Prefix *)p->ku.k.p3; - genv = (Scheme_Env *)p->ku.k.p4; - max_let_depth = p->ku.k.i1; - phase = p->ku.k.i2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return (void *)eval_letmacro_rhs(a, genv, rhs_env, max_let_depth, rp, phase); -} - -void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, - Scheme_Env *exp_env, Scheme_Object *insp, - Scheme_Compile_Expand_Info *rec, int drec, Scheme_Object *observer, - Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib, - int replace_value) -{ - Scheme_Object **results, *l, *a_expr; - Scheme_Comp_Env *eenv; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - int vc, nc, j, i; - Scheme_Compile_Expand_Info mrec; - - eenv = scheme_new_comp_env(exp_env, insp, NULL, 0); - eenv->observer = observer; - - /* First expand for expansion-observation */ - if (!rec[drec].comp) { - scheme_init_expand_recs(rec, drec, &mrec, 1); - SCHEME_EXPAND_OBSERVE_ENTER_BIND(eenv->observer); - a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0); - } - - /* Then compile */ - mrec.comp = 1; - mrec.dont_mark_local_use = 0; - mrec.resolve_module_ids = 1; - mrec.substitute_bindings = 1; - mrec.pre_unwrapped = 0; - mrec.testing_constantness = 0; - mrec.env_already = 0; - mrec.comp_flags = rec[drec].comp_flags; - - if (SCHEME_STX_PAIRP(names)) { - l = SCHEME_STX_CDR(names); - if (SCHEME_STX_NULLP(l)) { - l = SCHEME_STX_CAR(names); - eenv->value_name = SCHEME_STX_VAL(l); - } - } - - a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0); - - a = scheme_letrec_check_expr(a); - - oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, insp, 1); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - a = scheme_optimize_expr(a, oi, 0); - - rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, insp); - - ri = scheme_resolve_info_create(rp); - a = scheme_resolve_expr(a, ri); - - rp = scheme_remap_prefix(rp, ri); - - /* To JIT: - if (ri->use_jit) a = scheme_jit_expr(a); - but it's not likely that a let-syntax-bound macro is going - to run lots of times, so JITting is probably not worth it. */ - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(eenv->observer); - } - - a_expr = a; - a = eval_letmacro_rhs(a_expr, eenv->genv, rhs_env, - scheme_resolve_info_max_let_depth(ri), - rp, eenv->genv->phase); - - if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { - vc = scheme_current_thread->ku.multiple.count; - results = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(results, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - } else { - vc = 1; - results = NULL; - } - - for (nc = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - nc++; - } - - if (vc != nc) { - Scheme_Object *name; - const char *symname; - - if (nc >= 1) { - name = SCHEME_STX_CAR(names); - name = SCHEME_STX_VAL(name); - } else - name = NULL; - symname = (name ? scheme_symbol_name(name) : ""); - - scheme_wrong_return_arity(where, - nc, vc, - (vc == 1) ? (Scheme_Object **)a : results, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((nc == 1) ? "\"" : "\", ...") : ""); - } - - i = *_pos; - for (j = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l), j++) { - Scheme_Object *name, *macro; - name = SCHEME_STX_CAR(l); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - if (vc == 1) - SCHEME_PTR_VAL(macro) = a; - else - SCHEME_PTR_VAL(macro) = results[j]; - - scheme_set_local_syntax(i++, name, macro, stx_env, replace_value); - - if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { - /* Rebind to the target identifier's binding */ - scheme_add_binding_copy(name, - scheme_rename_transformer_id(SCHEME_PTR_VAL(macro), rhs_env), - scheme_make_integer(stx_env->genv->phase)); - } - } - *_pos = i; - - scheme_merge_undefineds(eenv, rhs_env); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_BIND(observer); - } -} - -static Scheme_Object * -do_letrec_syntaxes(const char *where, - Scheme_Object *orig_forms, Scheme_Comp_Env *origenv, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *forms, *form, *bindings, *var_bindings, *body, *v, *scope; - Scheme_Object *names_to_disappear, *orig_vname; - Scheme_Comp_Env *stx_env, *var_env, *rhs_env; - int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already, restore; - DupCheckRecord r; - - forms = scheme_stx_taint_disarm(orig_forms, NULL); - - env_already = rec[drec].env_already; - - form = SCHEME_STX_CDR(forms); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - var_bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - body = scheme_datum_to_syntax(form, forms, forms, 0, 0); - - orig_vname = origenv->value_name; - - if (env_already) { - stx_env = origenv; - scope = NULL; - } else { - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - stx_env = scheme_new_compilation_frame(0, 0, scope, origenv); - } - - rhs_env = stx_env; - - if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) { - scheme_wrong_syntax(NULL, bindings, forms, "not a binding sequence"); - } else - check_form(bindings, forms); - if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) { - scheme_wrong_syntax(NULL, var_bindings, forms, "not a binding sequence"); - } else - check_form(var_bindings, forms); - - cnt = stx_cnt = var_cnt = 0; - saw_var = 0; - - depth = rec[drec].depth; - restore = (depth >= 0); - - if (!rec[drec].comp && !restore) - names_to_disappear = scheme_null; - else - names_to_disappear = NULL; - - if (!env_already) - scheme_begin_dup_symbol_check(&r, stx_env); - - /* Pass 1: Check and Rename */ - - for (i = 0; i < 2 ; i++) { - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - - a = SCHEME_STX_CAR(v); - if (!SCHEME_STX_PAIRP(a) - || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a))) - v = NULL; - else { - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) - break; - } - if (!SCHEME_STX_NULLP(l)) - v = NULL; - } - - if (v) { - Scheme_Object *rest; - rest = SCHEME_STX_CDR(a); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - v = NULL; - } - - if (!v) - scheme_wrong_syntax(NULL, a, forms, - "binding clause not an identifier sequence and expression"); - - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (!env_already) { - scheme_check_identifier(where, a, NULL, stx_env, forms); - scheme_dup_symbol_check(&r, where, a, "binding", forms); - } - cnt++; - } - if (i) - saw_var = 1; - } - - if (!i) - stx_cnt = cnt; - else - var_cnt = cnt - stx_cnt; - } - - if (!env_already) - scheme_add_local_syntax(stx_cnt, stx_env); - - if (saw_var) { - var_env = scheme_new_compilation_frame(var_cnt, - (env_already ? SCHEME_INTDEF_SHADOW : 0), - scope, - stx_env); - } else - var_env = NULL; - - for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) { - cnt = (i ? var_cnt : stx_cnt); - if (cnt > 0) { - /* Add new syntax/variable names to the environment: */ - j = 0; - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - a = SCHEME_STX_CAR(v); - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (i) { - /* In compile mode, this will get re-written by the letrec compiler. - But that's ok. We need it now for env_renames. */ - scheme_add_compilation_binding(j++, a, var_env); - } else - scheme_set_local_syntax(j++, a, NULL, stx_env, 0); - } - } - } - } - - if (scope) { - bindings = scheme_stx_add_scope(bindings, scope, scheme_env_phase(stx_env->genv)); - var_bindings = scheme_stx_add_scope(var_bindings, scope, scheme_env_phase(stx_env->genv)); - body = scheme_stx_add_scope(body, scope, scheme_env_phase(stx_env->genv)); - } - - if (names_to_disappear) { - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - while (!SCHEME_STX_NULLP(names)) { - a = SCHEME_STX_CAR(names); - names_to_disappear = cons(a, names_to_disappear); - names = SCHEME_STX_CDR(names); - } - } - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(stx_env->observer, bindings, var_bindings, body); - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(stx_env->observer); - } - scheme_prepare_exp_env(stx_env->genv); - scheme_prepare_compile_env(stx_env->genv->exp_env); - - if (!env_already) { - i = 0; - - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(stx_env->observer); - } - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - a = SCHEME_STX_CDR(a); - a = SCHEME_STX_CAR(a); - - scheme_bind_syntaxes(where, names, a, - stx_env->genv->exp_env, - stx_env->insp, - rec, drec, stx_env->observer, - stx_env, rhs_env, - &i, NULL, 1); - } - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(stx_env->observer); - } - - if (!env_already && names_to_disappear) { - /* Need to add renaming for disappeared bindings. If they - originated for internal definitions, then we need both - pre-renamed and renamed, since some might have been - expanded to determine definitions. */ - Scheme_Object *l, *a, *pf = NULL, *pl = NULL; - - if (origenv->flags & SCHEME_FOR_INTDEF) { - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = cons(a, scheme_null); - if (pl) - SCHEME_CDR(pl) = a; - else - pf = a; - pl = a; - } - } - - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (scope) a = scheme_stx_add_scope(a, scope, scheme_env_phase(stx_env->genv)); - SCHEME_CAR(l) = a; - } - - if (pf) { - SCHEME_CDR(pl) = names_to_disappear; - names_to_disappear = pf; - } - } - - if (!var_env) { - var_env = stx_env; - v = scheme_check_name_property(forms, orig_vname); - var_env->value_name = v; - if (rec[drec].comp) { - if (env_already) - v = compile_list(body, var_env, rec, drec); - else - v = compile_block(body, var_env, rec, drec); - v = scheme_make_sequence_compilation(v, 1, 0); - } else { - if (env_already) - v = expand_list(body, var_env, rec, drec); - else - v = expand_block(body, var_env, rec, drec); - if (restore) { - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = cons(formname, cons(bindings, cons(var_bindings, v))); - } else { - v = cons(let_values_symbol, cons(scheme_null, v)); - } - - if (SCHEME_PAIRP(v)) - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), - 0, 2); - else - v = scheme_stx_taint_rearm(v, orig_forms); - - if (!restore) { - SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */ - } - } - var_env->value_name = NULL; - } else { - /* Construct letrec-values expression: */ - v = cons(letrec_values_symbol, cons(var_bindings, body)); - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); - - if (!env_already) { /* i.e., not internal defn */ - /* We want non-`letrec' semantics for value bindings (i.e., sort - out the bindings into `letrec' and `let'), but also treat the - body as a block. */ - rec[drec].env_already = 3; - } - - if (rec[drec].comp) { - v = do_let_compile(v, stx_env, "letrec-values", 1, 1, rec, drec, var_env); - } else { - if (restore && (rec[drec].env_already == 2)) { - /* don't sort out after all, because we're keeping `letrec-values+syntaxes' */ - rec[drec].env_already = 1; - } - - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(stx_env->observer); /* in "expand" branch */ - v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, var_env); - - if (restore) { - /* Add back out the pieces we want: */ - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = scheme_stx_taint_disarm(v, NULL); - v = SCHEME_STX_CDR(v); - v = cons(formname, cons(bindings, v)); - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); - } else { - SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */ - } - } - } - - /* Add the 'disappeared-binding property */ - if (names_to_disappear) - v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear); - - return v; -} - -static Scheme_Object * -letrec_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, rec, drec); -} - -static Scheme_Object * -letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(env->observer); - - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec); -} - -/*========================================================================*/ -/* applications */ -/*========================================================================*/ - -int scheme_get_eval_type(Scheme_Object *obj) - /* Categories for short-cutting recursive calls to the evaluator */ -{ - Scheme_Type type; - - type = SCHEME_TYPE(obj); - - if (type > _scheme_values_types_) - return SCHEME_EVAL_CONSTANT; - else if (SAME_TYPE(type, scheme_ir_local_type) - || SAME_TYPE(type, scheme_local_type)) - return SCHEME_EVAL_LOCAL; - else if (SAME_TYPE(type, scheme_local_unbox_type)) - return SCHEME_EVAL_LOCAL_UNBOX; - else if (SAME_TYPE(type, scheme_toplevel_type)) - return SCHEME_EVAL_GLOBAL; - else - return SCHEME_EVAL_GENERAL; -} - -Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info) - /* Apply `f' to `args' and ignore failues --- used for constant - folding attempts */ -{ - Scheme_Object * volatile result; - Scheme_Object * volatile exn = NULL; - mz_jmp_buf *savebuf, newbuf; - - scheme_current_thread->reading_delayed = NULL; - scheme_current_thread->constant_folding = (info ? info : (Optimize_Info *)scheme_false); - savebuf = scheme_current_thread->error_buf; - scheme_current_thread->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - result = NULL; - exn = scheme_current_thread->reading_delayed; - } else - result = _scheme_apply_to_list(f, args); - - scheme_current_thread->error_buf = savebuf; - scheme_current_thread->constant_folding = NULL; - scheme_current_thread->reading_delayed = NULL; - - if (scheme_current_thread->cjs.is_kill) { - scheme_longjmp(*scheme_current_thread->error_buf, 1); - } - - if (exn) - scheme_raise(exn); - - return result; -} - -static int foldable_body(Scheme_Object *f) -{ - Scheme_Lambda *d; - - d = SCHEME_CLOSURE_CODE(f); - - scheme_delay_load_closure(d); - - return (SCHEME_TYPE(d->body) > _scheme_values_types_); -} - -int scheme_is_foldable_prim(Scheme_Object *f) -{ - if (SCHEME_PRIMP(f) - && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING)) - return 1; - - if (SCHEME_CLSD_PRIMP(f) - && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING)) - return 1; - - return 0; -} - -Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info) -{ - Scheme_Object *o; - int i, nv; - volatile int n; - - o = v; - n = 0; - nv = 0; - while (!SCHEME_NULLP(o)) { - Scheme_Type type; - - n++; - type = SCHEME_TYPE(SCHEME_CAR(o)); - if (type < _scheme_ir_values_types_) - nv = 1; - o = SCHEME_CDR(o); - } - - if (!nv) { - /* They're all values. Applying folding prim or closure? */ - Scheme_Object *f; - - f = SCHEME_CAR(v); + f = SCHEME_CAR(v); if (scheme_is_foldable_prim(f) || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type) @@ -4123,841 +1537,120 @@ app->num_args = n - 1; return app; -} - -void scheme_finish_application(Scheme_App_Rec *app) -{ - int i, devals, n; - - n = app->num_args + 1; - - devals = sizeof(Scheme_App_Rec) + ((app->num_args + 1 - mzFLEX_DELTA) * sizeof(Scheme_Object *)); - - for (i = 0; i < n; i++) { - char etype; - etype = scheme_get_eval_type(app->args[i]); - ((char *)app XFORM_OK_PLUS devals)[i] = etype; - } -} - -/*========================================================================*/ -/* compilation dispatcher */ -/*========================================================================*/ - -static Scheme_Object * -inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int start_app_position) -{ - int len; - - len = scheme_stx_proper_list_length(form); - - if (!len) { - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - return scheme_null; - } else if (len > 0) { - Scheme_Compile_Info *recs, quick[5]; - int i; - Scheme_Object *c, *p, *comp_first, *comp_last, *name, *first, *rest; - - name = env->value_name; - scheme_compile_rec_done_local(rec, drec); - - if (len <= 5) - recs = quick; - else - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, len); - scheme_init_compile_recs(rec, drec, recs, len); - - comp_first = comp_last = NULL; - - for (i = 0, rest = form; i < len; i++) { - first = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - - if (SCHEME_STX_NULLP(rest)) - env->value_name = name; - - c = compile_expand_expr(first, env, recs, i, - !i && start_app_position); - env->value_name = NULL; - - p = scheme_make_pair(c, scheme_null); - if (comp_last) - SCHEME_CDR(comp_last) = p; - else - comp_first = p; - comp_last = p; - - if (!i && start_app_position && (len == 2) - && SAME_OBJ(c, scheme_varref_const_p_proc)) { - recs[1].testing_constantness = 1; - } - } - - scheme_merge_compile_recs(rec, drec, recs, len); - - return comp_first; - } else { - scheme_signal_error("internal error: compile-list on non-list"); - return NULL; - } -} - -static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *result, *rator; - int len; - - form = scheme_stx_taint_disarm(form, NULL); - - len = scheme_stx_proper_list_length(form); - - if (len < 0) - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL); - - env->value_name = NULL; - - scheme_compile_rec_done_local(rec, drec); - form = inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); - - result = scheme_make_application(form, NULL); - - /* Record which application this is for a variable that is used only in - application positions. */ - if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type)) - rator = ((Scheme_App_Rec *)result)->args[0]; - else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type)) - rator = ((Scheme_App2_Rec *)result)->rator; - else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type)) - rator = ((Scheme_App3_Rec *)result)->rator; - else - rator = NULL; - if (rator) { - rator = scheme_optimize_extract_tail_inside(rator); - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type)) { - if (SCHEME_VAR(rator)->use_count < SCHEME_USE_COUNT_INF) { - if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type)) - SCHEME_APPN_FLAGS((Scheme_App_Rec *)result) |= SCHEME_VAR(rator)->use_count; - else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type)) - SCHEME_APPN_FLAGS((Scheme_App2_Rec *)result) |= SCHEME_VAR(rator)->use_count; - else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type)) - SCHEME_APPN_FLAGS((Scheme_App3_Rec *)result) |= SCHEME_VAR(rator)->use_count; - } - } - } - - return result; -} - -Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return inner_compile_list(form, env, rec, drec, 0); -} - -static Scheme_Object *adjust_for_other_context(Scheme_Object *form, Scheme_Object *var, Scheme_Comp_Env *env) -{ - /* Macro doesn't expand in this context. In a module-begin context, - just don't expand. If it's not an expression - context and expression context is ok, then wrap as an - expression. Otherwise, we just have to complain. */ - if (env->flags & SCHEME_MODULE_BEGIN_FRAME) { - /* wrap in `begin` to trigger `#%module-begin` wrapper */ - var = scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - var = scheme_make_pair(var, scheme_make_pair(form, scheme_null)); - form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0); - } else if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(0))) { - /* expression is ok, so we must not be in an expression context */ - var = scheme_datum_to_syntax(expression_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - var = scheme_make_pair(var, scheme_make_pair(form, scheme_null)); - form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0); - } else { - Scheme_Object *csym; - csym = scheme_frame_to_expansion_context_symbol(env->flags); - scheme_wrong_syntax(NULL, NULL, form, - "not allowed in context\n expansion context: %S", - csym); - return NULL; - } - - return form; -} - -static Scheme_Object *install_alt_from_rename(Scheme_Object *first, Scheme_Object *alt_first) -{ - if (alt_first) { - if (SCHEME_STX_PAIRP(first)) { - Scheme_Object *tail; - tail = scheme_stx_taint_disarm(first, NULL); - tail = SCHEME_STX_CDR(tail); - return scheme_datum_to_syntax(scheme_make_pair(alt_first, tail), - first, first, 0, 1); - } else - return alt_first; - } else - return first; -} - -Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, - Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object **current_val, - int keep_name) -{ - Scheme_Object *name, *val, *alt_first = NULL; - Scheme_Expand_Info erec1; - Scheme_Env *menv = NULL; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_CHECK(env->observer, first); - } - - while (1) { - *current_val = NULL; - - if (SCHEME_STX_PAIRP(first)) { - name = scheme_stx_taint_disarm(first, NULL); - name = SCHEME_STX_CAR(name); - } else { - name = first; - } - - if (!SCHEME_STX_SYMBOLP(name)) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } - - while (1) { - val = scheme_compile_lookup(name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - if (SCHEME_STX_PAIRP(first)) - *current_val = val; - - if (!val) { - first = install_alt_from_rename(first, alt_first); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(val), - scheme_frame_to_expansion_context_symbol(env->flags))) { - if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(val), env); - if (!rec[drec].comp) - new_name = scheme_stx_track(new_name, name, name); - name = scheme_transfer_srcloc(new_name, name); - alt_first = name; - menv = NULL; - SCHEME_USE_FUEL(1); - } else { - alt_first = NULL; - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = 1; - name = env->value_name; - if (!keep_name) - env->value_name = name; - first = scheme_expand_expr(first, env, &erec1, 0); - env->value_name = name; - break; /* break to outer loop */ - } - } else { - first = install_alt_from_rename(first, alt_first); - alt_first = NULL; - first = adjust_for_other_context(first, val, env); - break; /* break to outer loop */ - } - } else { - first = install_alt_from_rename(first, alt_first); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } - } - } -} - -static Scheme_Object * -compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, - Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int scope_macro_use) -{ - Scheme_Object *xformer, *boundname; - - xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); - - if (scheme_is_set_transformer(xformer)) { - /* scheme_apply_macro unwraps it */ - } else { - if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { - scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax"); - return NULL; - } - } - - boundname = env->value_name; - if (!boundname) - boundname = scheme_false; - - return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0, - scope_macro_use); - - /* caller expects rec[drec] to be used to compile the result... */ -} - -static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e) -{ - while (1) { - if (orig == e) - return 1; - if ((e && e->flags & SCHEME_FOR_STOPS) - || (!(e->flags & (~SCHEME_INTDEF_FRAME)) - && !e->num_bindings)) - e = e->next; - else - return 0; - } -} - -static Scheme_Object *compile_expand_expr_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return compile_expand_expr(form, - env, - rec, - p->ku.k.i3, - p->ku.k.i2); -} - -Scheme_Object * -compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position) -{ - Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL; - Scheme_Env *menv = NULL; - GC_CAN_IGNORE char *not_allowed; - int has_orig_unbound = 0, need_macro_scope = 0; - - top: - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); - - p->ku.k.p1 = (void *)form; - p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; - p->ku.k.i3 = 0; - p->ku.k.i2 = app_position; - - var = scheme_handle_stack_overflow(compile_expand_expr_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return var; - } - } -#endif - - DO_CHECK_FOR_BREAK(scheme_current_thread, ;); - - MZ_ASSERT(SCHEME_STXP(form)); - - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_VISIT(env->observer,form); /* in "expand" branch */ - } - - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) { - var = SCHEME_STX_VAL(form); - if (scheme_stx_has_empty_wraps(form, scheme_env_phase(env->genv)) - && same_effective_env(SCHEME_PTR2_VAL(var), env)) { - /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks. */ - form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, NULL); - if (!rec[drec].comp) { - /* Already fully expanded. */ - SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(env->observer, form); - return form; - } - } else { - scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), - "expanded syntax not in its original lexical context" - " (extra bindings or scopes in the current context)"); - } - } - - if (SCHEME_STX_NULLP(form)) { - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; - } else if (!SCHEME_STX_PAIRP(form)) { - if (SCHEME_STX_SYMBOLP(form)) { - Scheme_Object *find_name = form, *inline_variant, *bind_id; - int protected = 0; - - while (1) { - inline_variant = NULL; - var = scheme_compile_lookup(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + (app_position - ? SCHEME_APP_POS - : 0) - + ((rec[drec].comp && rec[drec].dont_mark_local_use) ? - SCHEME_DONT_MARK_USE - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, &protected, - &bind_id, &need_macro_scope, - &inline_variant); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer,find_name); - } - - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - protected = 0; - } else - break; - } else - break; - } - - if (!var) { - /* Top variable */ - stx = top_symbol; - if (env->genv->module) - not_allowed = "reference to an unbound identifier"; - else - not_allowed = "reference to a top-level identifier"; - normal = top_expander; - has_orig_unbound = 1; - form = find_name; /* in case it was re-mapped */ - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (var == stop_expander) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer,form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer,form); - } - return form; - } else { - scheme_wrong_syntax(NULL, NULL, form, "bad syntax"); - return NULL; - } - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - name = form; - goto macro; - } - - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { - if (scheme_extract_unsafe(var)) { - return scheme_extract_unsafe(var); - } else if (scheme_extract_flfxnum(var)) { - return scheme_extract_flfxnum(var); - } else if (scheme_extract_extfl(var)) { - return scheme_extract_extfl(var); - } else if (scheme_extract_futures(var)) { - return scheme_extract_futures(var); - } else if (scheme_extract_foreign(var)) { - return scheme_extract_foreign(var); - } - } - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) - return scheme_register_toplevel_in_prefix(var, env, rec, drec, - scheme_is_imported(var, env), - inline_variant); - else - return var; - } else { - SCHEME_EXPAND_OBSERVE_VARIABLE(env->observer, form, find_name); /* in "expand" branch */ - if (bind_id && rec[drec].substitute_bindings) - find_name = bind_id; - if (protected) { - /* Add a property to indicate that the name is protected */ - find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); - } - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, find_name); /* in "expand" branch */ - return find_name; /* which is usually == form */ - } - } - } else { - /* A hack for handling lifted expressions. See compile_expand_lift_to_let. */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) { - form = SCHEME_STX_VAL(form); - return SCHEME_IPTR_VAL(form); - } +} - stx = datum_symbol; - not_allowed = "literal data"; - normal = datum_expander; - } - } else { - name = scheme_stx_taint_disarm(form, NULL); - name = SCHEME_STX_CAR(name); - if (SCHEME_STX_SYMBOLP(name)) { - /* Check for macros: */ - Scheme_Object *find_name = name; - Scheme_Expand_Info erec1; - - /* While resolving name, we used to need taints from `form' */ - scheme_init_expand_recs(rec, drec, &erec1, 1); - - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_APP_POS - + SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + SCHEME_DONT_MARK_USE - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, &need_macro_scope, - NULL); +void scheme_finish_application(Scheme_App_Rec *app) +{ + int i, devals, n; - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - } - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - - if (!var) { - /* apply to global variable: compile it normally */ - orig_unbound_name = find_name; - has_orig_unbound = 1; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { - /* apply to local variable: compile it normally */ - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - goto macro; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; - } - } - - /* Else: unknown global - must be a function: compile as application */ - } + n = app->num_args + 1; - if (!SAME_OBJ(name, find_name)) { - /* the rator position was mapped */ - Scheme_Object *code; - code = scheme_stx_taint_disarm(form, NULL); - code = SCHEME_STX_CDR(code); - code = scheme_make_pair(find_name, code); - form = scheme_datum_to_syntax(code, form, form, 0, 2); - } - } + devals = sizeof(Scheme_App_Rec) + ((app->num_args + 1 - mzFLEX_DELTA) * sizeof(Scheme_Object *)); - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; + for (i = 0; i < n; i++) { + char etype; + etype = scheme_get_eval_type(app->args[i]); + ((char *)app XFORM_OK_PLUS devals)[i] = etype; } +} - /* Compile/expand as application, datum, or top: */ - if (scheme_stx_is_tainted(form)) { - stx = scheme_datum_to_syntax(stx, form, form, 0, 1); - stx = scheme_stx_taint_rearm(stx, form); - } else if (quick_stx && rec[drec].comp) { - scheme_stx_set(quick_stx, stx, form); - stx = quick_stx; - quick_stx = NULL; - } else - stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0); +/*========================================================================*/ +/* application */ +/*========================================================================*/ - if (rec[drec].comp) - can_recycle_stx = stx; +static Scheme_Object * +compile_list(Scheme_Object *form, + Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env, + int start_app_position) +{ + int len; - { - Scheme_Object *find_name = stx; + len = scheme_stx_proper_list_length(form); - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, &need_macro_scope, - NULL); + if (!len) { + return scheme_null; + } else if (len > 0) { + int i; + Scheme_Object *c, *p, *comp_first, *comp_last, *first, *rest; - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - } + comp_first = comp_last = NULL; - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - /* It's a rename. Look up the target name and try again. */ - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - } + for (i = 0, rest = form; i < len; i++) { + first = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); - if (!SAME_OBJ(var, normal)) { - /* Someone might keep the stx: */ - can_recycle_stx = NULL; - } + c = compile_expr(first, + (!i ? first_env : ((i == (len-1)) ? last_env : env)), + !i && start_app_position); - if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type))) { - if (SAME_OBJ(var, stop_expander)) { - /* Return original: */ - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - } - return form; - } else if (rec[drec].comp && SAME_OBJ(var, normal) && !env->observer) { - /* Skip creation of intermediate form */ - Scheme_Syntax *f; - rec[drec].pre_unwrapped = 1; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - if (can_recycle_stx && !quick_stx) { - quick_stx = can_recycle_stx; - scheme_stx_set(quick_stx, NULL, NULL); - } - return f(form, env, rec, drec); - } else { - if (!rec[drec].comp - && (rec[drec].depth == -2) /* local-expand */ - && SAME_OBJ(var, normal) - && SAME_OBJ(SCHEME_STX_VAL(stx), top_symbol)) { - rec[drec].pre_unwrapped = 1; - } else { - name = scheme_stx_taint_disarm(form, NULL); - form = scheme_datum_to_syntax(scheme_make_pair(stx, name), form, form, 0, 2); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, form); - } - } + p = scheme_make_pair(c, scheme_null); + if (comp_last) + SCHEME_CDR(comp_last) = p; + else + comp_first = p; + comp_last = p; - if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); /* in "expand" branch */ - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; - } - } else { - name = stx; - goto macro; - } + if (!i && start_app_position && (len == 2) + && SAME_OBJ(c, scheme_varref_const_p_proc)) + last_env = scheme_set_comp_env_flags(last_env, COMP_ENV_CHECKING_CONSTANT); } + + return comp_first; } else { - /* Not allowed this context! */ - char *phase, buf[30]; - if (env->genv->phase == 0) - phase = ""; - else if (env->genv->phase == 1) - phase = " in the transformer environment"; - else { - phase = buf; - sprintf(buf, " at phase %" PRIdPTR, env->genv->phase); - } - if (has_orig_unbound) { - scheme_wrong_syntax(scheme_compile_stx_string, - orig_unbound_name, form, - "unbound identifier%s;\n" - " also, no %S syntax transformer is bound%s", - phase, - SCHEME_STX_VAL(stx), - scheme_stx_describe_context(orig_unbound_name, - scheme_env_phase(env->genv), - 0)); - } else { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, - "%s is not allowed;\n" - " no %S syntax transformer is bound%s", - not_allowed, - SCHEME_STX_VAL(stx), - phase, - scheme_stx_describe_context(orig_unbound_name, - scheme_env_phase(env->genv), - 0)); - } + scheme_signal_error("internal error: compile-list on non-list"); return NULL; } +} - macro: - if (!rec[drec].comp && !rec[drec].depth) { - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; /* We've gone as deep as requested */ - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form); - } - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope); - - if (env->expand_result_adjust) { - Scheme_Expand_Result_Adjust_Proc adjust; - adjust = env->expand_result_adjust; - form = adjust(form, env->expand_result_adjust_arg); - } - } else - form = adjust_for_other_context(form, var, env); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form); - } +static Scheme_Object *compile_plain_app(Scheme_Object *form, Scheme_Comp_Env *env) +{ + Scheme_Object *result, *rator; + int len; - if (rec[drec].comp) - goto top; - else { - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) - goto top; - else { - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); /* in "expand" branch */ - return form; + len = scheme_stx_proper_list_length(form); + + if (len < 0) + scheme_wrong_syntax("application", NULL, form, NULL); + + env = scheme_set_comp_env_name(env, NULL); + + form = compile_list(form, env, env, env, 1); + + result = scheme_make_application(form, NULL); + + /* Record which application this is for a variable that is used only in + application positions. */ + if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type)) + rator = ((Scheme_App_Rec *)result)->args[0]; + else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type)) + rator = ((Scheme_App2_Rec *)result)->rator; + else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type)) + rator = ((Scheme_App3_Rec *)result)->rator; + else + rator = NULL; + if (rator) { + rator = scheme_optimize_extract_tail_inside(rator); + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type)) { + if (SCHEME_VAR(rator)->use_count < SCHEME_USE_COUNT_INF) { + if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type)) + SCHEME_APPN_FLAGS((Scheme_App_Rec *)result) |= SCHEME_VAR(rator)->use_count; + else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type)) + SCHEME_APPN_FLAGS((Scheme_App2_Rec *)result) |= SCHEME_VAR(rator)->use_count; + else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type)) + SCHEME_APPN_FLAGS((Scheme_App3_Rec *)result) |= SCHEME_VAR(rator)->use_count; + } } } + + return result; } -static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) +static int arg_count(Scheme_Object *lam) { Scheme_Object *l, *id, *form = lam; int cnt = 0; DupCheckRecord r; - lam = scheme_stx_taint_disarm(lam, NULL); - lam = SCHEME_STX_CDR(lam); if (!SCHEME_STX_PAIRP(lam)) return -1; @@ -4968,13 +1661,12 @@ while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); } if (!SCHEME_STX_NULLP(lam)) return -1; - - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); while (SCHEME_STX_PAIRP(l)) { id = SCHEME_STX_CAR(l); - scheme_check_identifier("lambda", id, NULL, env, form); + scheme_check_identifier("lambda", id, "argument", form); scheme_dup_symbol_check(&r, NULL, id, "argument", form); l = SCHEME_STX_CDR(l); cnt++; @@ -4984,62 +1676,29 @@ return cnt; } -static Scheme_Object * -compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) +static Scheme_Object *compile_app(Scheme_Object *orig_form, Scheme_Comp_Env *env) { - Scheme_Object *form, *naya, *forms, *orig_vname = env->value_name; - int tsc; - - forms = scheme_stx_taint_disarm(orig_form, NULL); + Scheme_Object *form, *forms, *orig_vname = env->value_name; - tsc = rec[drec].pre_unwrapped; - rec[drec].pre_unwrapped = 0; - - if (tsc) { - form = forms; - } else { - form = SCHEME_STX_CDR(forms); - form = scheme_datum_to_syntax(form, forms, forms, 0, 0); - } + forms = orig_form; + form = forms; if (SCHEME_STX_NULLP(form)) { /* Compile/expand empty application to null list: */ - if (rec[drec].comp) - return scheme_null; - else - return scheme_datum_to_syntax(icons(quote_symbol, - icons(form, scheme_null)), - orig_form, - scheme_sys_wraps(env), - 0, 2); + return scheme_null; } else if (!SCHEME_STX_PAIRP(form)) { /* will end in error */ - if (rec[drec].comp) - return compile_application(form, env, rec, drec); - else { - env->value_name = NULL; - naya = expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed and returned... */ - } - } else if (rec[drec].comp) { - Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form; + return compile_plain_app(form, env); + } else { + Scheme_Object *name, *origname, *orig_rest_form, *rest_form; name = SCHEME_STX_CAR(form); origname = name; - gval = env->value_name; - env->value_name = NULL; - - name = scheme_check_immediate_macro(name, env, rec, drec, &gval, 0); - - env->value_name = gval; - /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ - if (SAME_OBJ(gval, scheme_lambda_syntax)) { - Scheme_Object *argsnbody, *d_name; + if (SAME_OBJ(SCHEME_STX_SYM(name), lambda_symbol)) { + Scheme_Object *argsnbody; - d_name = scheme_stx_taint_disarm(name, NULL); - argsnbody = SCHEME_STX_CDR(d_name); + argsnbody = SCHEME_STX_CDR(name); if (SCHEME_STX_PAIRP(argsnbody)) { Scheme_Object *args, *body; @@ -5060,7 +1719,7 @@ if ((pl < 0) || (al == pl)) { DupCheckRecord r; - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); while (!SCHEME_STX_NULLP(args)) { Scheme_Object *v, *n; @@ -5069,14 +1728,13 @@ n = args; else n = SCHEME_STX_CAR(args); - scheme_check_identifier("lambda", n, NULL, env, name); + scheme_check_identifier("lambda", n, NULL, name); /* If we don't check here, the error is in terms of `let': */ scheme_dup_symbol_check(&r, NULL, n, "argument", name); if (pl < 0) { v = scheme_intern_symbol("list"); - v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(env), 0, 0); v = cons(v, rest); } else v = SCHEME_STX_CAR(rest); @@ -5090,1131 +1748,478 @@ if (pl < 0) { /* rator is (lambda rest-x ....) */ break; - } else { - args = SCHEME_STX_CDR(args); - rest = SCHEME_STX_CDR(rest); - } - } - - body = scheme_datum_to_syntax(icons(begin_symbol, body), form, - scheme_sys_wraps(env), - 0, 2); - - body = scheme_datum_to_syntax(cons(let_values_symbol, - cons(bindings, - cons(body, scheme_null))), - form, - scheme_sys_wraps(env), - 0, 2); - - body = scheme_syntax_taint_rearm(body, orig_form); - - env->value_name = orig_vname; - - return compile_expand_expr(body, env, rec, drec, 0); - } else { -#if 0 - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - "procedure application: bad ((lambda (...) ...) ...) syntax"); - return NULL; -#endif - } - } - } - } - } - - orig_rest_form = SCHEME_STX_CDR(form); - - /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ - if (SCHEME_STX_SYMBOLP(name)) { - Scheme_Object *at_first, *at_second, *the_end; - at_first = SCHEME_STX_CDR(form); - if (SCHEME_STX_PAIRP(at_first)) { - at_second = SCHEME_STX_CDR(at_first); - if (SCHEME_STX_PAIRP(at_second)) { - the_end = SCHEME_STX_CDR(at_second); - if (SCHEME_STX_NULLP(the_end)) { - Scheme_Object *orig_at_second = at_second; - - if (!cwv_stx || (env->genv->phase != cwv_stx_phase)) { - cwv_stx_phase = env->genv->phase; - cwv_stx = scheme_datum_to_syntax(call_with_values_symbol, - scheme_false, scheme_sys_wraps(env), 0, 0); - } - - if (scheme_stx_free_eq(name, cwv_stx, 0)) { - Scheme_Object *first, *orig_first; - orig_first = SCHEME_STX_CAR(at_first); - first = scheme_check_immediate_macro(orig_first, env, rec, drec, &gval, 0); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(first) - && (arg_count(first, env) == 0)) { - Scheme_Object *second, *orig_second; - orig_second = SCHEME_STX_CAR(at_second); - second = scheme_check_immediate_macro(orig_second, env, rec, drec, &gval, 0); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(second) - && (arg_count(second, env) >= 0)) { - Scheme_Object *lhs, *orig_post_first, *orig_post_second; - orig_post_first = first; - orig_post_second = second; - first = scheme_stx_taint_disarm(first, NULL); - second = scheme_stx_taint_disarm(second, NULL); - second = SCHEME_STX_CDR(second); - lhs = SCHEME_STX_CAR(second); - second = SCHEME_STX_CDR(second); - first = SCHEME_STX_CDR(first); - first = SCHEME_STX_CDR(first); - first = icons(begin_symbol, first); - first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1); - second = icons(begin_symbol, second); - second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1); - /* Convert to let-values: */ - name = icons(let_values_symbol, - icons(icons(icons(lhs, icons(first, scheme_null)), - scheme_null), - icons(second, scheme_null))); - form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2); - env->value_name = orig_vname; - return compile_expand_expr(form, env, rec, drec, 0); - } - if (!SAME_OBJ(second, orig_second)) { - at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2); - } - } - if (!SAME_OBJ(first, orig_first) - || !SAME_OBJ(at_second, orig_at_second)) { - at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2); - } - } - } - } - } - rest_form = at_first; - } else { - rest_form = orig_rest_form; - } - - if (NOT_SAME_OBJ(name, origname) - || NOT_SAME_OBJ(rest_form, orig_rest_form)) { - form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2); - } - - return compile_application(form, env, rec, drec); - } else { - env->value_name = NULL; - naya = expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed returned... */ - } - - if (SAME_OBJ(form, naya)) - return orig_form; - - /* Add #%app prefix back: */ - { - Scheme_Object *first; - - first = SCHEME_STX_CAR(forms); - return scheme_datum_to_syntax(scheme_make_pair(first, naya), orig_form, orig_form, 0, 2); - } -} - -static Scheme_Object * -app_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_app(form, env, rec, drec); -} - -static Scheme_Object * -app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_APP(env->observer); - return compile_expand_app(form, env, erec, drec); -} - -static Scheme_Object * -datum_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c, *v; - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else { - c = SCHEME_STX_CDR(form); - /* Need datum->syntax, in case c is a list: */ - c = scheme_datum_to_syntax(c, form, form, 0, 2); - } - - v = SCHEME_STX_VAL(c); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression"); - return NULL; - } - - return scheme_syntax_to_datum(c, 0, NULL); -} - -static Scheme_Object * -datum_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest, *v, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_DATUM(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - rest = SCHEME_STX_CDR(form); - - v = SCHEME_STX_VAL(rest); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression"); - return NULL; - } - - return scheme_datum_to_syntax(icons(quote_symbol, - icons(rest, scheme_null)), - orig_form, - scheme_sys_wraps(env), - 0, 2); -} - -int scheme_check_top_identifier_bound(Scheme_Object *c, Scheme_Env *genv, int disallow_unbound) -{ - Scheme_Object *symbol, *binding; - Scheme_Object *modidx; - int bad; - - binding = scheme_stx_lookup(c, scheme_make_integer(genv->phase)); - - if (SCHEME_VECTORP(binding)) { - modidx = SCHEME_VEC_ELS(binding)[0]; - if (SCHEME_FALSEP(modidx)) modidx = NULL; - symbol = SCHEME_VEC_ELS(binding)[1]; - if (modidx) { - /* If it's an access path, resolve it: */ - if (genv->module - && SAME_OBJ(scheme_module_resolve(modidx, 1), genv->module->modname)) - bad = 0; - else - bad = 1; - } else - bad = 1; - } else - bad = 1; - - if (disallow_unbound) { - if (bad || !scheme_lookup_in_table(genv->toplevel, (const char *)symbol)) { - GC_CAN_IGNORE const char *reason; - int need_phase = 0; - - if (genv->phase == 1) { - reason = "unbound identifier in module (in phase 1, transformer environment)%s"; - /* Check in the run-time environment */ - if (scheme_lookup_in_table(genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the run-time definition)%s"); - } else if (genv->template_env->syntax - && scheme_lookup_in_table(genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the macro definition that is visible to run-time expressions)%s"); - } - } else if (genv->phase == 0) - reason = "unbound identifier in module%s"; - else { - reason = "unbound identifier in module (in phase %d)%s"; - need_phase = 1; - } - - if (need_phase) - scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, genv->phase, - scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); - else - scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, - scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); - } - } - - return !bad; -} - -static Scheme_Object *check_top(Scheme_Object *orig_form, - Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, - int *_need_bound_check) -{ - Scheme_Object *c, *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else - c = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_SYMBOLP(c)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - if (env->genv->module) { - int bad; - bad = !scheme_check_top_identifier_bound(c, env->genv, env->genv->disallow_unbound > 0); - if (_need_bound_check) - *_need_bound_check = bad; - } - - return c; -} - -static Scheme_Object * -top_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c, *b; - int need_bound_check = 0; - - c = check_top(form, env, rec, drec, &need_bound_check); - - if (need_bound_check) - scheme_register_unbound_toplevel(env, c); - - b = scheme_stx_lookup(c, scheme_make_integer(env->genv->phase)); - if (SCHEME_VECTORP(b)) - c = SCHEME_VEC_ELS(b)[1]; - else - c = scheme_future_global_binding(c, env->genv); - - if (env->genv->module && !rec[drec].resolve_module_ids) { - /* Self-reference in a module; need to remember the modidx. Don't - need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - c, env->genv->module->insp, - -1, env->genv->mod_phase, 0, - NULL); - } else { - c = (Scheme_Object *)scheme_global_bucket(c, env->genv); - } - - return scheme_register_toplevel_in_prefix(c, env, rec, drec, 0, NULL); -} - -static Scheme_Object * -top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *c; - int need_bound_check = 0; - - SCHEME_EXPAND_OBSERVE_PRIM_TOP(env->observer); - c = check_top(form, env, erec, drec, &need_bound_check); - - if (env->genv->module) - return c; /* strip `#%top' prefix */ - - return form; -} + } else { + args = SCHEME_STX_CDR(args); + rest = SCHEME_STX_CDR(rest); + } + } + + body = scheme_datum_to_syntax(cons(let_values_symbol, + cons(bindings, body)), + form, + DTS_COPY_PROPS); -Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_expr(form, env, rec, drec, 0); -} + env = scheme_set_comp_env_name(env, orig_vname); -Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_expr(form, env, erec, drec, 0); -} + return compile_expr(body, env, 0); + } + } + } + } + } -Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya; - Scheme_Object *ids, *id; - int pos; + orig_rest_form = SCHEME_STX_CDR(form); - /* We don't add a scope for this frame, because the lifted identifier - already has a scope. */ + /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ + if (SAME_OBJ(SCHEME_STX_SYM(name), call_with_values_symbol)) { + Scheme_Object *at_first, *at_second, *the_end; + at_first = SCHEME_STX_CDR(form); + if (SCHEME_STX_PAIRP(at_first)) { + at_second = SCHEME_STX_CDR(at_first); + if (SCHEME_STX_PAIRP(at_second)) { + the_end = SCHEME_STX_CDR(at_second); + if (SCHEME_STX_NULLP(the_end)) { + Scheme_Object *first; + first = SCHEME_STX_CAR(at_first); + if (SCHEME_STX_PAIRP(first) + && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(first)), lambda_symbol) + && (arg_count(first) == 0)) { + Scheme_Object *second; + second = SCHEME_STX_CAR(at_second); + if (SCHEME_STX_PAIRP(second) + && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(second)), lambda_symbol) + && (arg_count(second) >= 0)) { + Scheme_Object *lhs; + second = SCHEME_STX_CDR(second); + lhs = SCHEME_STX_CAR(second); + second = SCHEME_STX_CDR(second); + first = SCHEME_STX_CDR(first); + first = SCHEME_STX_CDR(first); + first = icons(begin_symbol, first); + first = scheme_datum_to_syntax(first, at_first, DTS_COPY_PROPS); + second = icons(begin_symbol, second); + second = scheme_datum_to_syntax(second, at_second, DTS_COPY_PROPS); + /* Convert to let-values: */ + name = icons(let_values_symbol, + icons(icons(icons(lhs, icons(first, scheme_null)), + scheme_null), + icons(second, scheme_null))); + form = scheme_datum_to_syntax(name, forms, DTS_COPY_PROPS); + env->value_name = orig_vname; + return compile_expr(form, env, 0); + } + } + } + } + } + rest_form = at_first; + } else { + rest_form = orig_rest_form; + } - pos = scheme_list_length(*_ids); - naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, NULL, (*ip)->next); - (*ip)->next = naya; - *ip = naya; + if (NOT_SAME_OBJ(name, origname) + || NOT_SAME_OBJ(rest_form, orig_rest_form)) { + form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, DTS_COPY_PROPS); + } - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - scheme_add_compilation_binding(--pos, id, naya); + return compile_plain_app(form, env); } - - return icons(*_ids, icons(expr, scheme_null)); } -Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, - Scheme_Object *orig_form, int comp) -{ - Scheme_Object *revl, *reve, *a; - - if (SCHEME_NULLP(l)) return obj; - - revl = scheme_reverse(l); +/*========================================================================*/ +/* expression compilation dispatcher */ +/*========================================================================*/ - reve = NULL; - if (comp) { - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - reve = scheme_make_raw_pair((Scheme_Object *)env, reve); - env = env->next; - } - } +static Scheme_Object *compile_expr_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; + Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) { - a = SCHEME_CAR(revl); - if (comp) { - /* propagate previously generated variables for re-compile */ - a = scheme_datum_to_syntax(a, scheme_false, scheme_false, 0, 0); - env = (Scheme_Comp_Env *)SCHEME_CAR(reve); - reve = SCHEME_CDR(reve); - MZ_ASSERT(env->flags & SCHEME_CAPTURE_LIFTED); - if (env->vars) - a = scheme_stx_property(a, existing_variables_symbol, - scheme_make_raw_pair(scheme_make_integer(env->num_bindings), - (Scheme_Object *)env->vars)); - } - obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - icons(icons(a, scheme_null), - icons(obj, scheme_null))); - } + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; - obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0); - - return obj; + return compile_expr(form, env, p->ku.k.i1); } -static Scheme_Object *compile_expand_expr_lift_to_let_k(void); - -static Scheme_Object * -compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *rec, int drec) +Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position) { - Scheme_Expand_Info recs[2]; - Scheme_Object *l, *orig_form = form, *context_key; - Scheme_Comp_Env *inserted, **ip; - #ifdef DO_STACK_CHECK { # include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); p->ku.k.p1 = (void *)form; p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; + p->ku.k.i1 = app_position; - form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return form; + return scheme_handle_stack_overflow(compile_expr_k); } } #endif - inserted = scheme_new_compilation_frame(0, 0, NULL, env); - - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = inserted; - - context_key = scheme_generate_lifts_key(); - - scheme_frame_captures_lifts(inserted, scheme_pair_lifted, (Scheme_Object *)ip, scheme_false, - context_key, NULL, scheme_false, scheme_false); + DO_CHECK_FOR_BREAK(scheme_current_thread, ;); - if (rec[drec].comp) { - scheme_init_compile_recs(rec, drec, recs, 2); - form = scheme_compile_expr(form, inserted, recs, 0); + if (!SCHEME_STX_PAIRP(form)) { + Scheme_Object *val = SCHEME_STX_SYM(form); + if (SCHEME_SYMBOLP(val)) + return scheme_compile_lookup(form, env, (app_position ? SCHEME_APP_POS : 0)); + else if (SCHEME_NUMBERP(val) + || SCHEME_CHAR_STRINGP(val) + || SCHEME_BYTE_STRINGP(val) + || SAME_OBJ(val, scheme_true) + || SAME_OBJ(val, scheme_false)) + return val; + else + scheme_wrong_syntax("compile", form, NULL, "unrecognized form"); } else { - scheme_init_expand_recs(rec, drec, recs, 2); - form = scheme_expand_expr(form, inserted, recs, 0); + Scheme_Object *name = SCHEME_STX_CAR(form); + if (SCHEME_STX_SYMBOLP(name)) { + /* check for primitive expression forms */ + name = SCHEME_STX_SYM(name); + if (SAME_OBJ(name, quote_symbol)) + return quote_compile(form, env); + else if (SAME_OBJ(name, let_values_symbol)) + return let_values_compile(form, env); + else if (SAME_OBJ(name, letrec_values_symbol)) + return letrec_values_compile(form, env); + else if (SAME_OBJ(name, lambda_symbol)) + return lambda_compile(form, env); + else if (SAME_OBJ(name, case_lambda_symbol)) + return case_lambda_compile(form, env); + else if (SAME_OBJ(name, set_symbol)) + return set_compile(form, env); + else if (SAME_OBJ(name, if_symbol)) + return if_compile(form, env); + else if (SAME_OBJ(name, begin_symbol)) + return begin_compile(form, env); + else if (SAME_OBJ(name, begin0_symbol)) + return begin0_compile(form, env); + else if (SAME_OBJ(name, with_cont_mark_symbol)) + return with_cont_mark_compile(form, env); + else if (SAME_OBJ(name, ref_symbol)) + return ref_compile(form, env); + else if (SAME_OBJ(name, ref_symbol)) + return ref_compile(form, env); + } } - l = scheme_frame_get_lifts(inserted); - if (SCHEME_NULLP(l)) { - /* No lifts */ - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 1); - return form; - } else { - /* We have lifts, so add let* wrapper and go again */ - Scheme_Object *o; - if (rec[drec].comp) { - /* Wrap compiled part so the compiler recognizes it later: */ - o = scheme_alloc_object(); - o->type = scheme_already_comp_type; - SCHEME_IPTR_VAL(o) = form; - } else - o = form; - form = scheme_add_lifts_as_let(o, l, inserted->next, orig_form, rec[drec].comp); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(env->observer, form); - } - form = compile_expand_expr_lift_to_let(form, env, recs, 1); - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 2); - return form; - } + return compile_app(form, env); } -static Scheme_Object *compile_expand_expr_lift_to_let_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return compile_expand_expr_lift_to_let(form, env, rec, 0); -} +/*========================================================================*/ +/* linklet compilation */ +/*========================================================================*/ -Scheme_Object * -scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static int is_define_values(Scheme_Object *form) { - return compile_expand_expr_lift_to_let(form, env, rec, drec); -} + Scheme_Object *rest; + + if (!SCHEME_STX_PAIRP(form)) + return 0; -Scheme_Object * -scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_expr_lift_to_let(form, env, erec, drec); -} + rest = SCHEME_STX_CAR(form); + if (!SAME_OBJ(SCHEME_STX_SYM(rest), define_values_symbol)) + return 0; -static Scheme_Object *beginify(Scheme_Comp_Env *env, Scheme_Object *lst) -{ - return scheme_datum_to_syntax(scheme_make_pair(begin_symbol, lst), - lst, - scheme_sys_wraps(env), - 0, 0); + return 1; } -static Scheme_Object *add_scope_at_arbitrary_phase(Scheme_Object *stx, Scheme_Object *rib) +static Scheme_Object *define_parse(Scheme_Object *form, + Scheme_Object **_vars, Scheme_Object **_val, + Scheme_Comp_Env **_env, + DupCheckRecord *r, + int *_extra_vars_pos) { - return scheme_stx_add_scope(stx, rib, scheme_make_integer(0)); -} - -static Scheme_Object * -compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int mixed) -/* This ugly code parses a block of code, transforming embedded - define-values and define-syntax into letrec and letrec-syntax. - It is espcailly ugly because we have to expand macros - before deciding what we have. */ -{ - Scheme_Object *first, *orig = forms, *pre_exprs = scheme_null, *old, *orig_vname = env->value_name; - Scheme_Object *rib, *ectx, *frame_scopes; - Scheme_Compile_Info recs[2]; - DupCheckRecord r; - - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(env->observer, forms); - } - - if (SCHEME_STX_NULLP(forms)) { - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - return scheme_null; - } else { - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms); - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, forms); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, forms); - return forms; - } - } - - rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE); - ectx = scheme_make_pair(scheme_make_struct_instance(scheme_liberal_def_ctx_type, 0, NULL), - scheme_null); - - scheme_begin_dup_symbol_check(&r, env); + Scheme_Object *vars, *rest, *name, *v, *extra_vars = scheme_null; + Scheme_Comp_Env *env; + int len; - frame_scopes = scheme_make_frame_scopes(rib); + len = check_form(form, form); + if (len != 3) + bad_form(form, len); + + rest = SCHEME_STX_CDR(form); + vars = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + *_val = SCHEME_STX_CAR(rest); - env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, - frame_scopes, - env); - env->intdef_name = ectx; + *_vars = vars; + + while (SCHEME_STX_PAIRP(vars)) { + name = SCHEME_STX_CAR(vars); + scheme_check_identifier(NULL, name, NULL, form); - env->expand_result_adjust = add_scope_at_arbitrary_phase; - env->expand_result_adjust_arg = rib; + vars = SCHEME_STX_CDR(vars); - forms = scheme_datum_to_syntax(forms, scheme_false, scheme_false, 0, 0); + scheme_dup_symbol_check(r, NULL, name, "binding", form); - old = forms; - forms = add_scope_at_arbitrary_phase(forms, rib); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(env->observer, forms, old); - } + v = scheme_compile_lookup(name, *_env, SCHEME_NULL_FOR_UNBOUND); + if (v && (!SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type) + || ((Scheme_IR_Toplevel *)v)->instance_pos != -1)) + scheme_wrong_syntax(NULL, name, form, "not a definable variable"); + + if (!v) { + v = (Scheme_Object *)scheme_make_ir_toplevel(-1, *_extra_vars_pos, 0); + env = scheme_extend_comp_env(*_env, name, v, 1, 0); + *_env = env; + extra_vars = scheme_make_pair(name, extra_vars); + (*_extra_vars_pos)++; + } + } - try_again: + if (!SCHEME_STX_NULLP(vars)) + scheme_wrong_syntax(NULL, vars, form, "bad variable list"); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } + return extra_vars; +} - if (!SCHEME_STX_PAIRP(forms)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax"); - return NULL; +static void check_import_export_clause(Scheme_Object *e, Scheme_Object *orig_form) +{ + if (SCHEME_STX_SYMBOLP(e)) + return; + + if (SCHEME_STX_PAIRP(e)) { + if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) { + e = SCHEME_STX_CDR(e); + if (SCHEME_STX_PAIRP(e)) { + if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) { + e = SCHEME_STX_CDR(e); + if (SCHEME_STX_NULLP(e)) + return; + } + } + } } - first = SCHEME_STX_CAR(forms); - - { - Scheme_Object *gval, *result; - int more = 1, is_last; + scheme_wrong_syntax(NULL, e, orig_form, "bad import/export clause"); +} - is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms)); - if (is_last) - env->value_name = orig_vname; +Scheme_Object *extract_source_name(Scheme_Object *e) +{ + Scheme_Object *a; - result = forms; + a = scheme_stx_property(e, source_name_symbol, NULL); + if (!a || !SCHEME_SYMBOLP(a)) + a = SCHEME_STX_SYM(e); - /* Check for macro expansion, which could mask the real - define-values, define-syntax, etc.: */ - first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); + return a; +} - if (is_last) - env->value_name = NULL; - - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - Scheme_Object *orig_forms = forms; +Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys) +{ + Scheme_Linklet *linklet; + Scheme_Object *orig_form = form, *imports, *exports; + Scheme_Object *defn_syms, *a, *e, *extra_vars, *vec, *v; + Scheme_Object *import_syms, *import_symss, *bodies, *all_extra_vars; + Scheme_Hash_Tree *source_names, *also_used_names; + Scheme_IR_Toplevel *tl; + int body_len, len, islen, i, j, extra_vars_pos; + Scheme_Comp_Env *env, *d_env; + DupCheckRecord r; - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - } + body_len = check_form(form, form); + if (body_len < 3) + bad_form(form, body_len); - /* FIXME: Redundant with check done by scheme_flatten_begin below? */ - if (scheme_stx_proper_list_length(first) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - IMPROPER_LIST_FORM); - - forms = SCHEME_STX_CDR(forms); - - if (SCHEME_STX_NULLP(forms)) { - /* A `begin' that ends the block. An `inferred-name' property - attached to this begin should apply to the ultimate last - thing in the block. */ - Scheme_Object *v; - v = scheme_check_name_property(first, env->value_name); - env->value_name = v; - } + linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + linklet->so.type = scheme_linklet_type; - forms = scheme_flatten_begin(first, forms); + env = scheme_new_comp_env(linklet, set_undef ? COMP_ENV_ALLOW_SET_UNDEFINED : 0); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_SPLICE(env->observer, forms); - } + form = SCHEME_STX_CDR(form); + imports = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + exports = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + body_len -= 3; - if (SCHEME_STX_NULLP(forms)) { - if (!SCHEME_PAIRP(pre_exprs)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - "empty form is not allowed"); - return NULL; - } else { - /* fall through to handle expressions without definitions */ - } + /* Parse imports, filling in `ilens` and `import_syms`, and also + extending `env`. */ + islen = scheme_stx_proper_list_length(imports); + if (islen < 0) + scheme_wrong_syntax(NULL, imports, orig_form, IMPROPER_LIST_FORM); + + if (import_keys && (SCHEME_VEC_SIZE(import_keys) != islen)) + scheme_contract_error("compile-linklet", + "import count of linklet form does not match given number of import keys", + "linklet", 1, linklet, + "linklet form imports", 1, scheme_make_integer(islen), + "given keys", 1, scheme_make_integer(SCHEME_VEC_SIZE(import_keys)), + NULL); + + import_symss = scheme_make_vector(islen, scheme_false); + + for (i = 0; i < islen; i++, imports = SCHEME_STX_CDR(imports)) { + a = SCHEME_STX_CAR(imports); + len = scheme_stx_proper_list_length(a); + + import_syms = scheme_make_vector(len, NULL); + SCHEME_VEC_ELS(import_symss)[i] = import_syms; + + for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) { + e = SCHEME_STX_CAR(a); + check_import_export_clause(e, orig_form); + if (SCHEME_STX_SYMBOLP(e)) { + SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(e); } else { - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - - goto try_again; + SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(SCHEME_STX_CAR(e)); + e = SCHEME_STX_CADR(e); } + tl = scheme_make_ir_toplevel(i, j, SCHEME_TOPLEVEL_READY); + env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1); + if (!env) + scheme_wrong_syntax("linklet", e, NULL, "duplicate import"); + } - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - } else if (SAME_OBJ(gval, scheme_define_values_syntax) - || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - /* Turn defines into a letrec: */ - Scheme_Object *var, *vars, *v, *link; - Scheme_Object *l = scheme_null, *start = NULL; - Scheme_Object *stx_l = scheme_null, *stx_start = NULL; - int is_val; - - while (1) { - int cnt; - - if (!SCHEME_NULLP(pre_exprs)) { - Scheme_Object *begin_stx, *values_app_stx; - - pre_exprs = scheme_reverse(pre_exprs); - - begin_stx = scheme_datum_to_syntax(begin_symbol, - scheme_false, - scheme_sys_wraps(env), - 0, 0); - values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null), - scheme_false, - scheme_sys_wraps(env), - 0, 0); - - while (SCHEME_PAIRP(pre_exprs)) { - v = scheme_make_pair(scheme_null, - scheme_make_pair(scheme_make_pair(begin_stx, - scheme_make_pair(SCHEME_CAR(pre_exprs), - scheme_make_pair(values_app_stx, - scheme_null))), - scheme_null)); - v = scheme_datum_to_syntax(v, SCHEME_CAR(pre_exprs), SCHEME_CAR(pre_exprs), 0, 0); - - link = scheme_make_pair(v, scheme_null); - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - - pre_exprs = SCHEME_CDR(pre_exprs); - } - } - - is_val = SAME_OBJ(gval, scheme_define_values_syntax); - - v = SCHEME_STX_CDR(first); - - if (!rec[drec].comp) { - if (is_val) { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer); - } - } - - if (!SCHEME_STX_PAIRP(v)) - scheme_wrong_syntax(NULL, NULL, first, - IMPROPER_LIST_FORM); - - var = NULL; - vars = SCHEME_STX_CAR(v); - cnt = 0; - while (SCHEME_STX_PAIRP(vars)) { - var = SCHEME_STX_CAR(vars); - if (!SCHEME_STX_SYMBOLP(var)) - scheme_wrong_syntax(NULL, var, first, - "name must be an identifier"); - /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */ - vars = SCHEME_STX_CDR(vars); - cnt++; - } - if (!SCHEME_STX_NULLP(vars)) { - vars = SCHEME_STX_CAR(v); - scheme_wrong_syntax(NULL, vars, first, - "not a sequence of identifiers"); - } - - /* Preserve properties and track at the clause level: */ - v = scheme_datum_to_syntax(v, first, first, 0, 0); - var = SCHEME_STX_CAR(first); - v = scheme_stx_track(v, first, var); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer,v); - } - - link = scheme_make_pair(v, scheme_null); - if (is_val) { - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - } else { - if (!stx_start) - stx_start = link; - else - SCHEME_CDR(stx_l) = link; - stx_l = link; - } - - result = SCHEME_STX_CDR(result); - if (!SCHEME_STX_NULLP(result) && !SCHEME_STX_PAIRP(result)) - scheme_wrong_syntax(NULL, NULL, first, NULL); - - { - /* Execute internal macro definition and register non-macros */ - Scheme_Comp_Env *new_env; - Scheme_Object *names, *expr, *l, *a; - int pos; - - new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, NULL, env); - new_env->intdef_name = ectx; - - names = SCHEME_STX_CAR(v); - expr = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(expr)) { - if (SCHEME_STX_NULLP(expr)) - scheme_wrong_syntax(NULL, NULL, first, - "missing expression"); - else - scheme_wrong_syntax(NULL, NULL, first, - IMPROPER_LIST_FORM); - } - link = SCHEME_STX_CDR(expr); - if (!SCHEME_STX_NULLP(link)) { - scheme_wrong_syntax(NULL, NULL, first, - "extra data after expression"); - } - expr = SCHEME_STX_CAR(expr); - - scheme_add_local_syntax(cnt, new_env); + linklet->num_total_imports += len; + } - names = scheme_revert_use_site_scopes(names, env); + /* Parse exports, filling in `defn_syms` and extending `env`. */ + len = scheme_stx_proper_list_length(exports); + if (len < 0) + scheme_wrong_syntax(NULL, exports, orig_form, IMPROPER_LIST_FORM); - /* Initialize environment slots to #f, which means "not syntax". */ - cnt = 0; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_set_local_syntax(cnt++, a, scheme_false, new_env, 0); - } - - /* Check for duplicates: */ - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); - } + linklet->num_exports = len; - if (!is_val) { - /* Evaluate and bind syntaxes */ - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - } - scheme_prepare_exp_env(new_env->genv); - scheme_prepare_compile_env(new_env->genv->exp_env); - pos = 0; - scheme_bind_syntaxes("local syntax definition", - names, expr, - new_env->genv->exp_env, new_env->insp, - rec, drec, new_env->observer, - new_env, new_env, - &pos, rib, 1); - } - - /* Remember extended environment */ - env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, frame_scopes, new_env); - env->intdef_name = ectx; - env->expand_result_adjust = add_scope_at_arbitrary_phase; - env->expand_result_adjust_arg = rib; - } - - define_try_again: - if (!SCHEME_STX_NULLP(result)) { - first = SCHEME_STX_CAR(result); - first = scheme_datum_to_syntax(first, forms, forms, 0, 0); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(result)); - if (is_last) - env->value_name = orig_vname; - first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); - if (is_last) - env->value_name = NULL; - more = 1; - if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) - && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - result = SCHEME_STX_CDR(result); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - } - result = scheme_flatten_begin(first, result); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_SPLICE(env->observer,result); - } - goto define_try_again; - } else if (mixed) { - /* accumulate expr for either sequence after definitions - or made-up empty bindings before the next definition */ - pre_exprs = scheme_make_pair(first, pre_exprs); - result = SCHEME_STX_CDR(result); - goto define_try_again; - } else { - /* Keep partially expanded `first': */ - result = SCHEME_STX_CDR(result); - result = scheme_make_pair(first, result); - break; - } - } - } else - break; - } + scheme_begin_dup_symbol_check(&r); - if (SCHEME_STX_PAIRP(result) || SCHEME_PAIRP(pre_exprs)) { - if (!start) - start = scheme_null; - - if (SCHEME_PAIRP(pre_exprs)) - result = scheme_reverse(pre_exprs); /* from mixed mode */ - - if (!mixed) { - result = scheme_make_pair(scheme_make_pair(scheme_intern_symbol("#%stratified-body"), - result), - scheme_null); - } - - if (stx_start || (mixed && !rec[drec].comp && (rec[drec].depth != -1))) { - result = scheme_make_pair(letrec_syntaxes_symbol, - scheme_make_pair((stx_start ? stx_start : scheme_null), - scheme_make_pair(start, result))); - } else { - result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); - } - result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2); + defn_syms = scheme_make_vector(len, NULL); + source_names = scheme_make_hash_tree(0); + also_used_names = scheme_make_hash_tree(0); - more = 0; - } else { - /* Empty body: illegal. */ - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, orig), - "no expression after a sequence of internal definitions"); - } - } else if (mixed) { - /* accumulate expr for either an expr-only sequence or made-up - empty bindings before a definition that appears later */ - pre_exprs = scheme_make_pair(first, pre_exprs); - first = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(first, forms, forms, 0, 0); - if (SCHEME_STX_NULLP(forms)) { - /* fall through to handle expressions without definitions */ - } else { - goto try_again; - } + for (j = 0; j < len; j++, exports = SCHEME_STX_CDR(exports)) { + e = SCHEME_STX_CAR(exports); + check_import_export_clause(e, orig_form); + if (SCHEME_STX_SYMBOLP(e)) { + SCHEME_VEC_ELS(defn_syms)[j] = SCHEME_STX_SYM(e); } else { - /* fall through to handle just expressions in non-mixed mode */ + SCHEME_VEC_ELS(defn_syms)[j] = SCHEME_STX_SYM(SCHEME_STX_CADR(e)); + e = SCHEME_STX_CAR(e); } + a = extract_source_name(e); + if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) { + scheme_wrong_syntax("linklet", a, NULL, "duplicate export"); + } + if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[j])) + source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[j], a); + else + also_used_names = scheme_hash_tree_set(also_used_names, a, scheme_true); + tl = scheme_make_ir_toplevel(-1, j, 0); + env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1); + if (!env) + scheme_wrong_syntax("linklet", e, NULL, "export duplicates import"); + } - if (!more) { - /* We've converted to a letrec or letrec-values+syntaxes */ - rec[drec].env_already = (mixed ? 2 : 1); - - if (rec[drec].comp) { - env = scheme_no_defines(env); - env->value_name = orig_vname; - result = scheme_compile_expr(result, env, rec, drec); - return scheme_make_pair(result, scheme_null); - } else { - if (!mixed && ((rec[drec].depth == -2) || (rec[drec].depth > 0))) { - if (SAME_OBJ(letrec_syntaxes_symbol, SCHEME_STX_VAL(SCHEME_CAR(SCHEME_STX_VAL(result))))) - result = force_traditional_letrec(result, env); - } - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(env->observer, - scheme_make_pair(result, scheme_null)); - } - env = scheme_no_defines(env); - env->value_name = orig_vname; - result = scheme_expand_expr(result, env, rec, drec); - } - result = scheme_make_pair(result, scheme_null); - return scheme_datum_to_syntax(result, forms, forms, 0, 0); + /* Looks for `define-values` forms to detect variables that are defined but + not exported */ + extra_vars_pos = len; + all_extra_vars = scheme_null; + + for (i = 0, a = form; i < body_len; i++, a = SCHEME_STX_CDR(a)) { + e = SCHEME_STX_CAR(a); + if (is_define_values(e)) { + Scheme_Object *vars, *vals; + extra_vars = define_parse(e, &vars, &vals, &env, &r, &extra_vars_pos); + if (extra_vars) { + all_extra_vars = scheme_append(extra_vars, all_extra_vars); } } } - if (SCHEME_PAIRP(pre_exprs)) - pre_exprs = scheme_reverse(pre_exprs); - - env = scheme_no_defines(env); - - if (rec[drec].comp) { - Scheme_Object *rest; - - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, 2); - - if (SCHEME_NULLP(pre_exprs)) - rest = SCHEME_STX_CDR(forms); - else { - first = SCHEME_CAR(pre_exprs); - rest = SCHEME_CDR(pre_exprs); + if (extra_vars_pos) { + a = defn_syms; + defn_syms = scheme_make_vector(extra_vars_pos, NULL); + for (i = 0; i < len; i++) { + SCHEME_VEC_ELS(defn_syms)[i] = SCHEME_VEC_ELS(a)[i]; } - rest = scheme_datum_to_syntax(rest, orig, orig, 0, 0); - - if (SCHEME_STX_NULLP(rest)) - env->value_name = orig_vname; - else - env->value_name = NULL; - - first = scheme_compile_expr(first, env, recs, 0); - - if (!SCHEME_STX_NULLP(rest)) - env->value_name = orig_vname; - else - env->value_name = NULL; - - forms = compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - return scheme_make_pair(first, forms); - } else { - Scheme_Object *newforms; - - scheme_init_expand_recs(rec, drec, recs, 2); - - if (SCHEME_PAIRP(pre_exprs)) - newforms = pre_exprs; - else { - newforms = SCHEME_STX_CDR(forms); - newforms = scheme_make_pair(first, newforms); + all_extra_vars = scheme_reverse(all_extra_vars); + for (i = len; i < extra_vars_pos; i++, all_extra_vars = SCHEME_CDR(all_extra_vars)) { + e = SCHEME_CAR(all_extra_vars); + a = SCHEME_STX_SYM(e); + if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) { + /* Internal name conflicts with an exported name --- which is allowed, but means + that we need to pick a different name for the bucket */ + a = generate_defn_name(a, source_names, also_used_names, extra_vars_pos); + } + SCHEME_VEC_ELS(defn_syms)[i] = a; + a = extract_source_name(e); + if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[i])) + source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[i], a); + else + also_used_names = scheme_hash_tree_set(also_used_names, a, scheme_true); } - - forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1); - - if (scheme_stx_proper_list_length(forms) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax"); - - env->value_name = orig_vname; - - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms); /* in "expand" branch */ - forms = expand_list(forms, env, recs, 0); - return forms; } -} - -static Scheme_Object * -compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_block(forms, env, rec, drec, 1); -} -static Scheme_Object * -expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_block(forms, env, erec, drec, 1); -} - -static Scheme_Object * -compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_block(forms, env, rec, drec, 0); -} - -static Scheme_Object * -expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_block(forms, env, erec, drec, 0); -} - -static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first = NULL, *last = NULL, *fm, *vname; + /* Prepare linklet record */ - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form); + linklet->importss = import_symss; + linklet->defns = defn_syms; + linklet->source_names = source_names; - if (SCHEME_STX_NULLP(form)) { - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - return scheme_null; - } + /* Compile body forms */ + bodies = scheme_make_vector(body_len, scheme_false); - if (scheme_stx_proper_list_length(form) < 0) { - /* This is already checked for anything but application */ - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - IMPROPER_LIST_FORM); - } + linklet->bodies = bodies; - fm = form; - vname = env->value_name; - while (SCHEME_STX_PAIRP(fm)) { - Scheme_Object *r, *p; - Scheme_Expand_Info erec1; + for (i = 0; i < body_len; i++, form = SCHEME_STX_CDR(form)) { + e = SCHEME_STX_CAR(form); + if (is_define_values(e)) { + a = SCHEME_STX_CADR(e); + len = scheme_stx_proper_list_length(a); + vec = scheme_make_vector(len+1, NULL); - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); + if (len == 1) + d_env = scheme_set_comp_env_name(env, SCHEME_STX_CAR(a)); + else + d_env = env; + + for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) { + v = scheme_compile_lookup(SCHEME_STX_CAR(a), env, 0); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); + MZ_ASSERT(((Scheme_IR_Toplevel *)v)->instance_pos == -1); + SCHEME_DEFN_VAR_(vec, j) = v; + } - p = SCHEME_STX_CDR(fm); + a = compile_expr(SCHEME_STX_CADR(SCHEME_STX_CDR(e)), d_env, 0); + SCHEME_DEFN_RHS(vec) = a; + + if (SCHEME_TRUEP(scheme_stx_property(e, compiler_inline_hint_symbol, NULL))) { + /* mark compiler-inline hint: */ + SCHEME_SET_DEFN_ALWAYS_INLINE(vec); + } + + e = vec; + e->type = scheme_define_values_type; + } else { + e = compile_expr(e, env, 0); + } - scheme_init_expand_recs(erec, drec, &erec1, 1); - env->value_name = (SCHEME_STX_NULLP(p) ? vname : NULL); - - r = SCHEME_STX_CAR(fm); - r = scheme_expand_expr(r, env, &erec1, 0); - p = scheme_make_pair(r, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - env->value_name = NULL; - - fm = SCHEME_STX_CDR(fm); + SCHEME_VEC_ELS(bodies)[i] = e; } - form = scheme_datum_to_syntax(first, form, form, 0, 0); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - return form; + return linklet; } - -Scheme_Object * -scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto) +static Scheme_Object *generate_defn_name(Scheme_Object *base_sym, + Scheme_Hash_Tree *used_names, + Scheme_Hash_Tree *also_used_names, + int search_start) { - Scheme_Object *l, *ll, *a, *name, *body; + char buf[32]; + Scheme_Object *n; - if (scheme_stx_proper_list_length(expr) < 0) - scheme_wrong_syntax(NULL, NULL, expr, IMPROPER_LIST_FORM); - - name = SCHEME_STX_CAR(expr); - body = SCHEME_STX_CDR(expr); - - /* Extract body of `begin' and add tracking information */ - l = scheme_copy_list(scheme_flatten_syntax_list(body, NULL)); - for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) { - a = SCHEME_CAR(ll); - a = scheme_stx_track(a, expr, name); - SCHEME_CAR(ll) = a; + while (1) { + sprintf(buf, ".%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + n = scheme_symbol_append(base_sym, n); + if (!scheme_hash_tree_get(used_names, n) && !scheme_hash_tree_get(also_used_names, n)) + return n; } - - return scheme_append(l, append_onto); -} - -/**********************************************************************/ -/* stop expander */ -/**********************************************************************/ - -static Scheme_Object *stop_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - scheme_signal_error("internal error: shouldn't get to stop syntax"); - return NULL; } -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - return form; -} - -Scheme_Object *scheme_get_stop_expander(void) -{ - return stop_expander; -} - -void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env) -{ - Scheme_Object *stx; - stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); - scheme_set_local_syntax(pos, stx, stop_expander, env, 0); -} /**********************************************************************/ /* precise GC */ diff -Nru racket-6.12+ppa1/src/racket/src/compile-startup.rkt racket-7.0+ppa1/src/racket/src/compile-startup.rkt --- racket-6.12+ppa1/src/racket/src/compile-startup.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/compile-startup.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,125 @@ +(module compile-startup '#%kernel + (#%require '#%linklet + "help-startup.rkt") + + ;; Decode a linklet S-expression from "startup.inc" (in the source + ;; directory), compile it, and write it back as "cstartup.inc" (in + ;; the build directory) + + (define-values (dest) (vector-ref (current-command-line-arguments) 0)) + (define-values (zo-dest) (vector-ref (current-command-line-arguments) 1)) + (define-values (src) (vector-ref (current-command-line-arguments) 2)) + (define-values (vers) (vector-ref (current-command-line-arguments) 3)) + (define-values (other-files) (list-tail (vector->list (current-command-line-arguments)) 4)) + + (define-values (version-comparisons) (get-version-comparisons vers)) + + ;; Bail out if we don't need to do anything: + (if (file-exists? dest) + (if (call-with-input-file dest (lambda (i) + (begin + (read-line i 'any) + (not (eof-object? (read-line i 'any)))))) + (if (andmap (lambda (f) + ((file-or-directory-modify-seconds dest) + . > . + (file-or-directory-modify-seconds f))) + (list* src vers other-files)) + (exit 0) + (void)) + (void)) + (void)) + + ;; Startup code as an S-expression uses the pattern + ;; (lambda (begin ' )) + ;; or + ;; (case-lambda [ (begin ' )] ...) + ;; to record a name for a function. Detect that pattern and + ;; shift to an 'inferred-name property. We rely on the fact + ;; that the names `lambda`, `case-lambda`, and `quote` are + ;; never shadowed, so we don't have to parse expression forms + ;; in general. + (define-values (rename-functions) + (lambda (e) + (if (if (pair? e) + (eq? 'quote (car e)) + #f) + e + (let-values ([(name) + (if (pair? e) + (let-values ([(begin-name) + (lambda (b) + (if (pair? b) + (if (eq? 'begin (car b)) + (if (pair? (cdr b)) + (if (pair? (cddr b)) + (let-values ([(a) (cadr b)]) + (if (pair? a) + (if (eq? 'quote (car a)) + (cadr a) + #f) + #f)) + #f) + #f) + #f) + #f))]) + (if (eq? 'lambda (car e)) + (let-values ([(b) (caddr e)]) + (begin-name b)) + (if (eq? 'case-lambda (car e)) + (if (pair? (cdr e)) + (let-values ([(clause) (cadr e)]) + (begin-name (cadr clause))) + #f) + #f))) + #f)]) + (if name + (correlated-property (datum->correlated #f (cons (car e) (rename-functions (cdr e)))) + 'inferred-name + name) + (if (pair? e) + (cons (rename-functions (car e)) + (rename-functions (cdr e))) + e)))))) + (define-values (datum->correlated) (hash-ref (primitive-table '#%kernel) 'datum->syntax)) + (define-values (correlated-property) (hash-ref (primitive-table '#%kernel) 'syntax-property)) + + (define-values (linklet) (compile-linklet (rename-functions (get-linklet src)) + #f #f #f + '(serializable unsafe static))) + + (define-values (DIGS-PER-LINE) 20) + + ;; In case someone wants to inspect the output with `raco decompile`: + (call-with-output-file + zo-dest + (lambda (outfile) (write (hash->linklet-bundle (hasheq 'startup linklet)) outfile)) + 'truncate) + + (call-with-output-file + dest + (lambda (outfile) + (let-values ([(p) (open-output-bytes)]) + (write (hash->linklet-bundle (hasheq 'startup linklet)) p) + (let-values ([(s) (get-output-bytes p)]) + (fprintf outfile "#if 0 ~a\n" version-comparisons) + (fprintf outfile "# include \"startup.inc\"\n") + (fprintf outfile "#else\n") + (fprintf outfile "static unsigned char expr[] = {\n") + (letrec-values ([(loop) + (lambda (chars pos) + (if (null? chars) + (void) + (begin + (fprintf outfile "~a," (car chars)) + (loop (cdr chars) + (if (= pos DIGS-PER-LINE) + (begin + (newline outfile) + 0) + (add1 pos))))))]) + (loop (bytes->list s) 0)) + (fprintf outfile "0};\n") + (fprintf outfile "# define EVAL_STARTUP EVAL_ONE_SIZED_STR((char *)expr, ~a)\n" (bytes-length s)) + (fprintf outfile "#endif\n")))) + 'truncate)) diff -Nru racket-6.12+ppa1/src/racket/src/cstartup.inc racket-7.0+ppa1/src/racket/src/cstartup.inc --- racket-6.12+ppa1/src/racket/src/cstartup.inc 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/cstartup.inc 1970-01-01 00:00:00.000000000 +0000 @@ -1,1569 +0,0 @@ - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,53,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18, -0,22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0, -89,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173, -0,180,0,202,0,204,0,218,0,246,0,251,0,255,0,72,1,79,1,90,1, -128,1,135,1,144,1,177,1,210,1,16,2,21,2,102,2,107,2,112,2,133, -2,30,3,51,3,104,3,173,3,242,3,132,4,24,5,35,5,118,5,0,0, -148,7,0,0,3,1,5,105,110,115,112,48,71,35,37,109,105,110,45,115,116, -120,29,11,11,11,65,97,110,100,66,99,111,110,100,68,100,101,102,105,110,101, -65,108,101,116,66,108,101,116,42,73,108,101,116,42,45,118,97,108,117,101,115, -68,108,101,116,114,101,99,64,111,114,74,112,97,114,97,109,101,116,101,114,105, -122,101,68,117,110,108,101,115,115,66,119,104,101,110,70,104,101,114,101,45,115, -116,120,67,113,117,111,116,101,29,94,2,16,70,35,37,107,101,114,110,101,108, -11,29,94,2,16,70,35,37,112,97,114,97,109,122,11,64,105,102,67,98,101, -103,105,110,72,108,101,116,45,118,97,108,117,101,115,63,120,75,108,101,116,114, -101,99,45,118,97,108,117,101,115,68,108,97,109,98,100,97,1,20,112,97,114, -97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,63,118,75,100, -101,102,105,110,101,45,118,97,108,117,101,115,38,28,16,3,93,16,2,29,11, -11,11,2,3,2,29,93,143,16,5,39,2,31,40,2,34,2,2,39,38,29, -93,2,30,36,30,0,39,36,31,1,145,40,143,2,32,16,4,2,17,39,39, -2,1,143,2,32,16,4,2,18,39,39,2,1,16,22,2,4,2,33,2,5, -2,33,2,6,2,33,2,7,2,33,2,8,2,33,2,9,2,33,2,10,2, -33,2,11,2,33,2,12,2,33,2,13,2,33,2,14,2,33,38,32,143,2, -31,2,29,38,33,93,143,2,32,143,2,1,2,3,36,34,2,144,40,143,2, -35,16,4,2,17,40,39,2,1,16,2,2,15,93,143,2,35,147,2,1,2, -3,40,2,15,143,2,3,40,2,15,38,35,143,2,34,2,29,18,143,66,104, -101,114,101,2,28,27,248,22,170,4,195,249,22,163,4,80,143,42,39,251,22, -92,2,19,248,22,105,199,12,249,22,82,2,20,248,22,107,201,27,248,22,170, -4,195,249,22,163,4,80,143,42,39,251,22,92,2,19,248,22,105,199,249,22, -82,2,20,248,22,107,201,12,27,248,22,84,248,22,170,4,196,28,248,22,90, -193,20,14,144,40,39,40,28,248,22,90,248,22,84,194,248,22,190,20,193,249, -22,163,4,80,143,42,39,251,22,92,2,19,248,22,190,20,199,249,22,82,2, -4,248,22,191,20,201,11,18,143,10,2,28,27,248,22,84,248,22,170,4,196, -28,248,22,90,193,20,14,144,40,39,40,28,248,22,90,248,22,84,194,248,22, -190,20,193,249,22,163,4,80,143,42,39,250,22,92,2,21,248,22,92,249,22, -92,248,22,92,2,22,248,22,190,20,201,251,22,92,2,19,2,22,2,22,249, -22,82,2,11,248,22,191,20,204,18,143,11,2,28,248,22,170,4,193,27,248, -22,170,4,194,249,22,82,248,22,92,248,22,83,196,248,22,191,20,195,27,248, -22,84,248,22,170,4,23,197,1,249,22,163,4,80,143,42,39,28,248,22,66, -248,22,164,4,248,22,83,23,198,2,27,249,22,2,32,0,88,148,8,36,40, -46,11,9,222,33,43,248,22,170,4,248,22,105,23,200,2,250,22,92,2,23, -248,22,92,249,22,92,248,22,92,248,22,190,20,23,204,2,250,22,93,2,24, -249,22,2,22,83,23,204,2,248,22,107,23,206,2,249,22,82,248,22,190,20, -23,202,1,249,22,2,22,105,23,200,1,250,22,93,2,21,249,22,2,32,0, -88,148,8,36,40,50,11,9,222,33,44,248,22,170,4,248,22,190,20,201,248, -22,191,20,198,27,248,22,170,4,194,249,22,82,248,22,92,248,22,83,196,248, -22,191,20,195,27,248,22,84,248,22,170,4,23,197,1,249,22,163,4,80,143, -42,39,250,22,93,2,23,249,22,2,32,0,88,148,8,36,40,50,11,9,222, -33,46,248,22,170,4,248,22,83,201,248,22,191,20,198,27,248,22,84,248,22, -170,4,196,27,248,22,170,4,248,22,83,195,249,22,163,4,80,143,43,39,28, -248,22,90,195,250,22,93,2,21,9,248,22,191,20,199,250,22,92,2,7,248, -22,92,248,22,83,199,250,22,93,2,8,248,22,191,20,201,248,22,191,20,202, -27,248,22,84,248,22,170,4,196,27,248,22,170,4,248,22,83,195,249,22,163, -4,80,143,43,39,28,248,22,90,195,250,22,93,2,21,9,248,22,191,20,199, -250,22,92,2,21,248,22,92,248,22,83,199,250,22,93,2,9,248,22,191,20, -201,248,22,191,20,202,27,248,22,84,248,22,170,4,23,197,1,27,249,22,1, -22,97,249,22,2,22,170,4,248,22,170,4,248,22,83,199,248,22,128,5,249, -22,163,4,80,143,44,39,251,22,92,1,22,119,105,116,104,45,99,111,110,116, -105,110,117,97,116,105,111,110,45,109,97,114,107,2,25,250,22,93,1,23,101, -120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111, -110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114, -107,45,115,101,116,45,102,105,114,115,116,11,2,25,202,250,22,93,2,21,9, -248,22,191,20,204,27,248,22,84,248,22,170,4,196,28,248,22,90,193,20,14, -144,40,39,40,249,22,163,4,80,143,42,39,27,248,22,170,4,248,22,83,197, -28,249,22,182,9,64,61,62,248,22,164,4,248,22,105,196,250,22,92,2,21, -248,22,92,249,22,92,21,93,2,26,248,22,190,20,199,250,22,93,2,5,249, -22,92,2,26,249,22,92,248,22,114,203,2,26,248,22,191,20,202,251,22,92, -2,19,28,249,22,182,9,248,22,164,4,248,22,190,20,200,66,101,108,115,101, -10,248,22,190,20,197,250,22,93,2,21,9,248,22,191,20,200,249,22,82,2, -5,248,22,191,20,202,18,143,94,10,66,118,111,105,100,2,28,27,248,22,84, -248,22,170,4,196,249,22,163,4,80,143,42,39,28,248,22,66,248,22,164,4, -248,22,83,197,250,22,92,2,27,248,22,92,248,22,190,20,199,248,22,105,198, -27,248,22,164,4,248,22,190,20,197,250,22,92,2,27,248,22,92,248,22,83, -197,250,22,93,2,24,248,22,191,20,199,248,22,191,20,202,145,40,9,20,122, -145,2,1,39,16,1,11,16,0,20,27,15,61,9,2,2,2,2,2,3,11, -11,11,11,9,9,11,11,11,10,40,80,143,39,39,20,122,145,2,1,39,16, -0,16,0,41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4,2,5, -2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16,11,11, -11,11,11,11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2,7,2, -8,2,9,2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39,16,1, -2,15,40,11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16, -0,16,0,39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39,40,80, -143,39,39,40,20,122,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5, -2,13,88,148,8,36,40,56,40,9,223,0,33,37,40,20,122,145,2,1,39, -16,1,2,15,16,0,11,16,5,2,14,88,148,8,36,40,56,40,9,223,0, -33,38,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,4,88, -148,8,36,40,56,42,9,223,0,33,39,40,20,122,145,2,1,39,16,1,2, -15,16,1,33,40,11,16,5,2,11,88,148,8,36,40,59,42,9,223,0,33, -41,40,20,122,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,7, -88,148,8,36,40,61,40,9,223,0,33,45,40,20,122,145,2,1,39,16,1, -2,15,16,0,11,16,5,2,10,88,148,8,36,40,56,40,9,223,0,33,47, -40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8, -36,40,57,40,9,223,0,33,48,40,20,122,145,2,1,39,16,1,2,15,16, -0,11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,40,20,122, -145,2,1,39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36,40,59, -40,9,223,0,33,50,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16, -5,2,5,88,148,8,36,40,61,42,9,223,0,33,51,40,20,122,145,2,1, -39,16,1,2,15,16,1,33,52,11,16,5,2,6,88,148,8,36,40,57,40, -9,223,0,33,53,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,0, -94,2,17,2,18,93,2,17,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2091); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,53,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,183,0,0,0,1,0,0,8,0,16, -0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0, -211,0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145, -1,184,1,202,1,233,1,245,1,6,2,18,2,33,2,57,2,89,2,118,2, -138,2,160,2,183,2,207,2,225,2,0,3,14,3,31,3,75,3,83,3,88, -3,132,3,139,3,149,3,164,3,173,3,178,3,180,3,213,3,237,3,2,4, -15,4,25,4,34,4,45,4,63,4,76,4,86,4,96,4,102,4,107,4,119, -4,122,4,126,4,131,4,134,4,158,4,201,4,214,4,236,4,247,4,19,5, -42,5,50,5,74,5,95,5,39,6,69,6,155,9,178,9,195,9,163,11,7, -12,21,12,210,12,251,14,4,15,13,15,27,15,37,15,57,16,160,16,29,17, -102,17,175,17,21,18,50,18,121,18,255,18,70,19,21,20,139,20,152,20,14, -21,27,21,134,21,201,21,214,21,225,21,106,22,224,22,7,23,118,23,213,25, -237,25,99,26,166,27,173,27,220,27,233,27,223,28,237,28,91,29,249,29,0, -30,152,31,224,31,235,31,246,31,151,32,171,32,231,32,238,32,94,33,148,33, -167,33,118,34,134,34,91,35,87,36,124,36,133,36,220,37,81,40,97,40,164, -40,185,40,205,40,225,40,26,41,6,44,228,44,244,44,119,45,177,45,210,45, -81,46,245,46,6,47,68,49,139,51,155,51,39,52,227,52,243,52,143,53,75, -54,84,54,91,54,167,55,243,56,105,57,186,60,60,61,192,61,157,63,107,64, -139,64,253,64,0,0,175,72,0,0,3,1,5,105,110,115,112,48,69,35,37, -117,116,105,108,115,74,112,97,116,104,45,115,116,114,105,110,103,63,66,98,115, -98,115,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,73,114, -101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,120,101,99, -117,116,97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115, -116,45,115,116,114,105,110,103,45,62,112,97,116,104,45,108,105,115,116,1,42, -99,97,108,108,45,119,105,116,104,45,100,101,102,97,117,108,116,45,114,101,97, -100,105,110,103,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -67,113,117,111,116,101,29,94,2,10,70,35,37,112,97,114,97,109,122,11,76, -45,99,104,101,99,107,45,114,101,108,112,97,116,104,79,45,99,104,101,99,107, -45,99,111,108,108,101,99,116,105,111,110,73,45,99,104,101,99,107,45,102,97, -105,108,77,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104,75,102,105, -110,100,45,99,111,108,45,102,105,108,101,1,20,99,111,108,108,101,99,116,105, -111,110,45,102,105,108,101,45,112,97,116,104,1,18,102,105,110,100,45,109,97, -105,110,45,99,111,108,108,101,99,116,115,1,32,101,120,101,45,114,101,108,97, -116,105,118,101,45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112, -97,116,104,78,102,105,110,100,45,109,97,105,110,45,99,111,110,102,105,103,78, -103,101,116,45,99,111,110,102,105,103,45,116,97,98,108,101,1,21,103,101,116, -45,105,110,115,116,97,108,108,97,116,105,111,110,45,110,97,109,101,76,99,111, -101,114,99,101,45,116,111,45,112,97,116,104,1,37,99,111,108,108,101,99,116, -115,45,114,101,108,97,116,105,118,101,45,112,97,116,104,45,62,99,111,109,112, -108,101,116,101,45,112,97,116,104,79,97,100,100,45,99,111,110,102,105,103,45, -115,101,97,114,99,104,1,29,102,105,110,100,45,108,105,98,114,97,114,121,45, -99,111,108,108,101,99,116,105,111,110,45,108,105,110,107,115,73,108,105,110,107, -115,45,99,97,99,104,101,78,115,116,97,109,112,45,112,114,111,109,112,116,45, -116,97,103,73,102,105,108,101,45,62,115,116,97,109,112,76,110,111,45,102,105, -108,101,45,115,116,97,109,112,63,1,22,103,101,116,45,108,105,110,107,101,100, -45,99,111,108,108,101,99,116,105,111,110,115,1,30,110,111,114,109,97,108,105, -122,101,45,99,111,108,108,101,99,116,105,111,110,45,114,101,102,101,114,101,110, -99,101,1,27,102,105,108,101,45,101,120,105,115,116,115,63,47,109,97,121,98, -101,45,99,111,109,112,105,108,101,100,1,18,112,97,116,104,45,97,100,100,45, -101,120,116,101,110,115,105,111,110,1,20,99,104,101,99,107,45,101,120,116,101, -110,115,105,111,110,45,99,97,108,108,1,21,112,97,116,104,45,97,100,106,117, -115,116,45,101,120,116,101,110,115,105,111,110,1,22,112,97,116,104,45,114,101, -112,108,97,99,101,45,101,120,116,101,110,115,105,111,110,79,108,111,97,100,47, -117,115,101,45,99,111,109,112,105,108,101,100,1,29,102,105,110,100,45,108,105, -98,114,97,114,121,45,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104, -115,75,101,109,98,101,100,100,101,100,45,108,111,97,100,78,110,111,114,109,97, -108,45,112,97,116,104,45,99,97,115,101,6,41,41,40,111,114,47,99,32,112, -97,116,104,45,102,111,114,45,115,111,109,101,45,115,121,115,116,101,109,63,32, -112,97,116,104,45,115,116,114,105,110,103,63,41,69,119,105,110,100,111,119,115, -6,2,2,92,49,6,41,41,40,111,114,47,99,32,112,97,116,104,45,115,116, -114,105,110,103,63,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115, -121,115,116,101,109,63,41,6,4,4,112,97,116,104,5,8,92,92,63,92,82, -69,76,92,6,12,12,112,97,116,104,45,115,116,114,105,110,103,63,70,114,101, -108,97,116,105,118,101,66,108,111,111,112,5,0,6,30,30,40,112,114,111,99, -101,100,117,114,101,45,97,114,105,116,121,45,105,110,99,108,117,100,101,115,47, -99,32,48,41,6,21,21,105,110,118,97,108,105,100,32,114,101,108,97,116,105, -118,101,32,112,97,116,104,6,18,18,40,97,110,121,47,99,32,46,32,45,62, -32,46,32,97,110,121,41,74,99,111,108,108,101,99,116,115,45,100,105,114,71, -101,120,101,99,45,102,105,108,101,70,111,114,105,103,45,100,105,114,72,99,111, -110,102,105,103,45,100,105,114,79,105,110,115,116,97,108,108,97,116,105,111,110, -45,110,97,109,101,6,10,10,108,105,110,107,115,46,114,107,116,100,71,97,100, -100,111,110,45,100,105,114,71,102,115,45,99,104,97,110,103,101,67,101,114,114, -111,114,66,114,111,111,116,73,115,116,97,116,105,99,45,114,111,111,116,6,0, -0,6,1,1,47,5,3,46,122,111,5,1,95,6,21,21,40,111,114,47,99, -32,115,116,114,105,110,103,63,32,98,121,116,101,115,63,41,6,40,40,99,97, -110,110,111,116,32,97,100,100,32,97,110,32,101,120,116,101,110,115,105,111,110, -32,116,111,32,97,32,114,111,111,116,32,112,97,116,104,58,32,5,11,80,76, -84,67,79,76,76,69,67,84,83,1,20,99,111,108,108,101,99,116,115,45,115, -101,97,114,99,104,45,100,105,114,115,6,8,8,99,111,108,108,101,99,116,115, -28,248,22,134,16,193,10,28,248,22,162,7,193,27,248,22,157,16,194,28,192, -192,248,22,158,16,194,11,0,21,35,114,120,34,94,91,92,92,93,91,92,92, -93,91,63,93,91,92,92,93,34,0,6,35,114,120,34,47,34,0,22,35,114, -120,34,91,47,92,92,93,91,46,32,93,43,91,47,92,92,93,42,36,34,0, -19,35,114,120,34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,86, -94,28,248,22,135,16,23,195,2,11,28,248,22,134,16,23,195,2,11,28,28, -248,22,162,7,23,195,2,28,248,22,157,16,23,195,2,10,248,22,158,16,23, -195,2,11,11,250,22,134,12,2,41,2,42,23,197,2,28,28,248,22,135,16, -23,195,2,249,22,182,9,248,22,136,16,23,197,2,2,43,249,22,182,9,247, -22,189,8,2,43,27,28,248,22,162,7,23,196,2,23,195,2,248,22,174,8, -248,22,139,16,23,197,2,28,249,22,132,17,2,76,23,195,2,28,248,22,162, -7,195,248,22,142,16,195,194,27,248,22,137,8,23,195,1,249,22,143,16,248, -22,177,8,250,22,140,17,2,77,28,249,22,132,17,2,78,23,201,2,23,199, -1,250,22,140,17,2,79,23,202,1,2,44,80,144,47,40,41,2,43,28,248, -22,162,7,194,248,22,142,16,194,193,0,28,35,114,120,34,94,92,92,92,92, -92,92,92,92,91,63,93,92,92,92,92,85,78,67,92,92,92,92,34,86,95, -28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195,2,28,248,22, -157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,28,248,22,135,16,23, -195,2,11,252,22,134,12,2,6,2,45,39,23,199,2,23,200,2,28,248,22, -134,16,23,196,2,11,28,28,248,22,162,7,23,196,2,28,248,22,157,16,23, -196,2,10,248,22,158,16,23,196,2,11,11,28,248,22,135,16,23,196,2,11, -252,22,134,12,2,6,2,45,40,23,199,2,23,200,2,27,28,248,22,135,16, -23,196,2,248,22,136,16,23,196,2,247,22,137,16,86,95,28,248,22,159,16, -23,196,2,11,28,249,22,182,9,247,22,137,16,23,195,2,11,253,22,136,12, -2,6,6,54,54,112,97,116,104,32,105,115,32,110,111,116,32,99,111,109,112, -108,101,116,101,32,97,110,100,32,110,111,116,32,116,104,101,32,112,108,97,116, -102,111,114,109,39,115,32,99,111,110,118,101,110,116,105,111,110,2,46,23,201, -2,6,24,24,112,108,97,116,102,111,114,109,32,99,111,110,118,101,110,116,105, -111,110,32,116,121,112,101,247,22,137,16,28,249,22,182,9,28,248,22,135,16, -23,199,2,248,22,136,16,23,199,2,247,22,137,16,23,195,2,11,253,22,136, -12,2,6,6,37,37,103,105,118,101,110,32,112,97,116,104,115,32,117,115,101, -32,100,105,102,102,101,114,101,110,116,32,99,111,110,118,101,110,116,105,111,110, -115,2,46,23,201,2,6,9,9,114,111,111,116,32,112,97,116,104,23,202,2, -27,27,248,22,163,16,28,248,22,159,16,23,199,2,23,198,1,248,22,160,16, -23,199,1,86,94,28,248,22,135,16,23,194,2,11,28,248,22,134,16,23,194, -2,11,28,28,248,22,162,7,23,194,2,28,248,22,157,16,23,194,2,10,248, -22,158,16,23,194,2,11,11,250,22,134,12,2,41,2,42,23,196,2,28,28, -248,22,135,16,23,194,2,249,22,182,9,248,22,136,16,23,196,2,2,43,249, -22,182,9,247,22,189,8,2,43,27,28,248,22,162,7,23,195,2,23,194,2, -248,22,174,8,248,22,139,16,23,196,2,28,249,22,132,17,2,76,23,195,2, -86,94,23,193,1,28,248,22,162,7,194,248,22,142,16,194,193,27,248,22,137, -8,23,195,1,249,22,143,16,248,22,177,8,250,22,140,17,2,77,28,249,22, -132,17,2,78,23,201,2,23,199,1,250,22,140,17,2,79,23,202,1,2,44, -80,144,50,40,41,2,43,28,248,22,162,7,193,248,22,142,16,193,192,27,248, -22,139,16,23,195,2,28,249,22,182,9,23,197,2,66,117,110,105,120,28,249, -22,159,8,194,5,1,47,28,248,22,135,16,198,197,248,22,142,16,198,249,22, -152,16,199,249,22,143,16,249,22,162,8,248,22,139,16,200,40,198,28,249,22, -182,9,23,197,2,2,43,249,22,152,16,23,200,1,249,22,143,16,28,249,22, -132,17,0,27,35,114,120,34,94,92,92,92,92,92,92,92,92,91,63,93,92, -92,92,92,91,97,45,122,93,58,34,23,199,2,251,22,163,8,2,47,250,22, -162,8,203,43,44,5,1,92,249,22,162,8,202,45,28,249,22,132,17,2,81, -23,199,2,249,22,163,8,2,47,249,22,162,8,200,43,28,249,22,132,17,2, -81,23,199,2,249,22,163,8,2,47,249,22,162,8,200,43,28,249,22,132,17, -0,14,35,114,120,34,94,92,92,92,92,92,92,92,92,34,23,199,2,249,22, -163,8,5,4,85,78,67,92,249,22,162,8,200,41,28,249,22,132,17,0,12, -35,114,120,34,94,91,97,45,122,93,58,34,198,249,22,163,8,250,22,162,8, -201,39,40,249,22,162,8,200,41,12,198,12,32,83,88,148,8,36,42,56,11, -72,102,111,117,110,100,45,101,120,101,99,222,33,86,32,84,88,148,8,36,43, -61,11,66,110,101,120,116,222,33,85,27,248,22,161,16,23,197,2,28,249,22, -184,9,23,195,2,23,198,1,11,28,248,22,157,16,23,194,2,27,249,22,152, -16,23,200,1,23,196,1,28,23,196,2,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,197,2,86,95,23,195,1,23,194,1,27,28,23,199,2,27,248, -22,161,16,23,199,2,28,249,22,184,9,23,195,2,23,200,2,86,94,23,193, -1,11,28,248,22,157,16,23,194,2,250,2,83,23,203,2,23,204,2,249,22, -152,16,23,200,2,23,198,1,250,2,83,23,203,2,23,204,2,23,196,1,11, -28,23,193,2,86,97,23,200,1,23,199,1,23,197,1,23,194,1,192,27,28, -248,22,134,16,23,196,2,27,249,22,152,16,23,198,2,23,204,2,28,248,22, -147,16,23,194,2,192,28,248,22,146,16,193,192,11,11,28,23,193,2,86,97, -23,201,1,23,200,1,23,198,1,23,195,1,192,28,23,200,2,86,97,23,201, -1,23,200,1,23,198,1,23,195,1,11,27,248,22,161,16,23,200,2,28,249, -22,184,9,194,23,201,1,11,28,248,22,157,16,193,250,2,83,203,204,249,22, -152,16,200,197,250,2,83,203,204,195,86,95,23,196,1,23,195,1,192,86,94, -23,197,1,28,23,195,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,2,86,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,161,16,23, -199,2,28,249,22,184,9,23,195,2,23,200,2,86,94,23,193,1,11,28,248, -22,157,16,23,194,2,250,2,83,23,202,2,23,203,2,249,22,152,16,23,200, -2,23,198,1,250,2,83,23,202,2,23,203,2,23,196,1,11,28,23,193,2, -192,27,28,248,22,134,16,23,196,2,27,249,22,152,16,23,198,2,23,203,2, -28,248,22,147,16,23,194,2,192,28,248,22,146,16,193,192,11,11,28,23,193, -2,192,28,23,199,2,11,27,248,22,161,16,23,200,2,28,249,22,184,9,194, -23,201,1,11,28,248,22,157,16,193,250,2,83,202,203,249,22,152,16,200,197, -250,2,83,202,203,195,192,28,23,194,2,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,199,2,86,95,23,195,1,23,194,1,27,28,23,197,2,251,2, -84,23,201,2,23,202,2,23,203,2,23,198,2,11,28,23,193,2,192,27,28, -248,22,134,16,195,27,249,22,152,16,197,201,28,248,22,147,16,23,194,2,192, -28,248,22,146,16,193,192,11,11,28,192,192,28,197,11,251,2,84,201,202,203, -198,194,32,87,88,148,8,36,43,60,11,2,50,222,33,88,28,248,22,90,23, -197,2,11,27,249,22,152,16,248,22,160,16,248,22,83,23,201,2,23,198,2, -28,248,22,146,16,23,194,2,250,2,83,196,197,195,27,248,22,191,20,23,199, -1,28,248,22,90,23,194,2,11,27,249,22,152,16,248,22,160,16,248,22,83, -23,198,2,23,200,2,28,248,22,146,16,23,194,2,250,2,83,198,199,195,27, -248,22,191,20,23,196,1,28,248,22,90,23,194,2,11,27,249,22,152,16,248, -22,160,16,248,22,83,23,198,2,23,202,2,28,248,22,146,16,23,194,2,250, -2,83,200,201,195,27,248,22,191,20,23,196,1,28,248,22,90,23,194,2,11, -27,249,22,152,16,248,22,160,16,248,22,83,197,203,28,248,22,146,16,193,250, -2,83,202,203,195,251,2,87,203,204,205,248,22,191,20,198,86,95,28,248,22, -134,16,23,195,2,11,28,28,248,22,162,7,23,195,2,28,248,22,157,16,23, -195,2,10,248,22,158,16,23,195,2,11,11,250,22,134,12,2,7,2,48,23, -197,2,28,23,195,2,28,28,28,248,22,134,16,23,196,2,10,28,248,22,162, -7,23,196,2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11, -248,22,157,16,23,196,2,11,11,250,22,134,12,2,7,6,45,45,40,111,114, -47,99,32,35,102,32,40,97,110,100,47,99,32,112,97,116,104,45,115,116,114, -105,110,103,63,32,114,101,108,97,116,105,118,101,45,112,97,116,104,63,41,41, -23,198,2,11,28,28,248,22,157,16,23,195,2,90,144,42,11,89,146,42,39, -11,248,22,155,16,23,198,2,249,22,182,9,194,2,49,11,27,249,22,184,8, -247,22,183,8,5,4,80,65,84,72,27,28,23,194,2,249,80,143,43,44,249, -22,174,8,23,198,1,7,63,9,86,94,23,194,1,9,27,28,249,22,182,9, -247,22,189,8,2,43,249,22,82,248,22,143,16,5,1,46,23,196,1,23,194, -1,28,248,22,90,23,194,2,86,97,23,199,1,23,198,1,23,197,1,23,193, -1,11,27,249,22,152,16,248,22,160,16,248,22,83,23,198,2,23,200,2,28, -248,22,146,16,23,194,2,86,95,23,198,1,23,194,1,250,2,83,202,201,195, -27,248,22,191,20,23,196,1,28,248,22,90,23,194,2,86,97,23,201,1,23, -200,1,23,199,1,23,193,1,11,27,249,22,152,16,248,22,160,16,248,22,83, -23,198,2,23,202,2,28,248,22,146,16,23,194,2,86,95,23,200,1,23,194, -1,250,2,83,204,203,195,27,248,22,191,20,23,196,1,28,248,22,90,23,194, -2,86,97,23,203,1,23,202,1,23,201,1,23,193,1,11,27,249,22,152,16, -248,22,160,16,248,22,83,23,198,2,23,204,2,28,248,22,146,16,23,194,2, -86,95,23,202,1,23,194,1,250,2,83,206,205,195,27,248,22,191,20,23,196, -1,28,248,22,90,23,194,2,86,97,23,205,1,23,204,1,23,203,1,23,193, -1,11,27,249,22,152,16,248,22,160,16,248,22,83,197,205,28,248,22,146,16, -193,250,2,83,23,16,23,15,195,251,2,87,23,17,23,16,23,15,248,22,191, -20,198,27,248,22,160,16,23,196,1,28,248,22,146,16,193,250,2,83,199,198, -195,11,250,80,144,42,43,42,196,197,11,250,80,144,42,43,42,196,11,11,32, -92,88,148,8,36,42,58,11,2,50,222,33,94,0,8,35,114,120,35,34,92, -34,34,27,249,22,128,17,23,196,2,23,198,2,28,23,193,2,86,94,23,196, -1,27,248,22,105,23,195,2,27,27,248,22,114,23,197,1,27,249,22,128,17, -23,200,2,23,196,2,28,23,193,2,86,94,23,194,1,27,248,22,105,23,195, -2,27,250,2,92,23,203,1,203,248,22,114,23,199,1,27,28,249,22,182,9, -247,22,189,8,2,43,250,22,140,17,2,93,23,198,1,2,51,194,28,249,22, -159,8,194,2,51,249,22,97,203,195,249,22,82,248,22,143,16,195,195,86,95, -23,198,1,23,193,1,27,28,249,22,182,9,247,22,189,8,2,43,250,22,140, -17,2,93,23,198,1,2,51,194,28,249,22,159,8,194,2,51,249,22,97,201, -9,249,22,82,248,22,143,16,195,9,27,28,249,22,182,9,247,22,189,8,2, -43,250,22,140,17,2,93,23,198,1,2,51,194,28,249,22,159,8,194,2,51, -249,22,97,199,195,249,22,82,248,22,143,16,195,195,86,95,23,194,1,23,193, -1,27,28,249,22,182,9,247,22,189,8,2,43,250,22,140,17,2,93,23,200, -1,2,51,196,28,249,22,159,8,194,2,51,249,22,97,197,9,249,22,82,248, -22,143,16,195,9,86,95,28,248,22,151,8,194,11,28,248,22,162,7,194,11, -250,22,134,12,2,8,6,21,21,40,111,114,47,99,32,98,121,116,101,115,63, -32,115,116,114,105,110,103,63,41,196,28,28,248,22,91,195,249,22,4,22,134, -16,196,11,11,250,22,134,12,2,8,6,14,14,40,108,105,115,116,111,102,32, -112,97,116,104,63,41,197,250,2,92,195,197,28,248,22,162,7,197,248,22,176, -8,197,196,28,28,248,22,0,23,195,2,249,22,48,23,196,2,39,11,20,13, -144,80,144,39,46,40,26,35,80,144,8,35,47,40,249,22,31,11,80,144,8, -37,46,40,22,165,15,10,22,166,15,10,22,167,15,10,22,168,15,11,22,169, -15,11,22,173,15,10,22,172,15,11,22,174,15,10,22,171,15,10,22,175,15, -10,22,170,15,11,22,176,15,10,22,177,15,10,22,178,15,10,22,179,15,11, -22,180,15,10,22,163,15,11,247,23,194,1,250,22,134,12,2,9,2,52,23, -197,1,86,94,28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195, -2,28,248,22,157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,250,22, -134,12,23,196,2,2,48,23,197,2,28,248,22,157,16,23,195,2,12,251,22, -136,12,23,197,1,2,53,2,46,23,198,1,86,94,28,248,22,134,16,23,195, -2,11,28,28,248,22,162,7,23,195,2,28,248,22,157,16,23,195,2,10,248, -22,158,16,23,195,2,11,11,250,22,134,12,23,196,2,2,48,23,197,2,28, -248,22,157,16,23,195,2,12,251,22,136,12,23,197,1,2,53,2,46,23,198, -1,86,95,28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195,2, -28,248,22,157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,250,22,134, -12,23,196,2,2,48,23,197,2,28,248,22,157,16,23,195,2,86,94,23,194, -1,11,251,22,136,12,23,197,2,2,53,2,46,23,198,1,249,22,3,20,20, -94,88,148,8,36,40,50,11,9,223,2,33,98,23,195,1,23,197,1,28,28, -248,22,0,23,195,2,249,22,48,23,196,2,40,11,12,250,22,134,12,23,196, -1,2,54,23,197,1,86,94,28,248,22,134,16,23,194,2,11,28,28,248,22, -162,7,23,194,2,28,248,22,157,16,23,194,2,10,248,22,158,16,23,194,2, -11,11,250,22,134,12,2,15,2,48,23,196,2,28,248,22,157,16,23,194,2, -12,251,22,136,12,2,15,2,53,2,46,23,197,1,86,97,28,248,22,134,16, -23,196,2,11,28,28,248,22,162,7,23,196,2,28,248,22,157,16,23,196,2, -10,248,22,158,16,23,196,2,11,11,250,22,134,12,2,15,2,48,23,198,2, -28,248,22,157,16,23,196,2,11,251,22,136,12,2,15,2,53,2,46,23,199, -2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,101,23,198,2,28, -28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,11,250,22,134,12,2, -15,2,54,23,197,2,252,80,143,44,52,23,199,1,23,200,1,23,201,1,11, -11,86,94,28,248,22,134,16,23,194,2,11,28,28,248,22,162,7,23,194,2, -28,248,22,157,16,23,194,2,10,248,22,158,16,23,194,2,11,11,250,22,134, -12,2,17,2,48,23,196,2,28,248,22,157,16,23,194,2,12,251,22,136,12, -2,17,2,53,2,46,23,197,1,86,99,28,248,22,134,16,23,197,2,11,28, -28,248,22,162,7,23,197,2,28,248,22,157,16,23,197,2,10,248,22,158,16, -23,197,2,11,11,250,22,134,12,2,17,2,48,23,199,2,28,248,22,157,16, -23,197,2,11,251,22,136,12,2,17,2,53,2,46,23,200,2,28,248,22,134, -16,23,198,2,11,28,28,248,22,162,7,23,198,2,28,248,22,157,16,23,198, -2,10,248,22,158,16,23,198,2,11,11,250,22,134,12,2,17,2,48,23,200, -2,28,248,22,157,16,23,198,2,11,251,22,136,12,2,17,2,53,2,46,23, -201,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,103,23,200,2, -28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,11,250,22,134,12, -2,17,2,54,23,197,2,252,80,143,44,52,23,199,1,23,202,1,23,203,1, -23,201,1,23,200,1,27,248,22,175,16,2,55,28,248,22,159,16,23,194,2, -248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11,89,146, -42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43,42,248,22,175,16, -2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248,22,162, -16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248,22,175, -16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,11,249,80, -144,41,55,40,39,80,144,41,8,40,42,27,248,22,175,16,2,58,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,11,249,80,144,41,55,40,40,80,144,41,8,41,42,27,20,13,144,80, -144,40,46,40,26,35,80,144,8,36,47,40,249,22,31,11,80,144,8,38,46, -40,22,165,15,10,22,166,15,10,22,167,15,10,22,168,15,11,22,169,15,11, -22,173,15,10,22,172,15,11,22,174,15,10,22,171,15,10,22,175,15,10,22, -170,15,11,22,176,15,10,22,177,15,10,22,178,15,10,22,179,15,11,22,180, -15,10,22,163,15,11,247,22,157,6,28,248,22,152,2,193,192,11,27,28,23, -195,2,249,22,152,16,23,197,1,6,11,11,99,111,110,102,105,103,46,114,107, -116,100,86,94,23,195,1,11,27,28,23,194,2,28,248,22,146,16,23,195,2, -249,22,149,6,23,196,1,80,144,43,8,42,42,11,11,28,192,192,21,17,1, -0,250,22,161,2,23,196,1,2,59,247,22,180,8,250,22,161,2,195,2,59, -247,22,180,8,28,248,22,162,7,23,195,2,27,248,22,142,16,23,196,1,28, -248,22,159,16,23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,43,54, -42,28,23,193,2,192,247,22,176,16,28,248,22,151,8,23,195,2,27,248,22, -143,16,23,196,1,28,248,22,159,16,23,194,2,192,249,22,160,16,23,195,1, -27,247,80,144,43,54,42,28,23,193,2,192,247,22,176,16,28,248,22,134,16, -23,195,2,28,248,22,159,16,23,195,2,193,249,22,160,16,23,196,1,27,247, -80,144,42,54,42,28,23,193,2,192,247,22,176,16,193,27,248,22,175,16,2, -55,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,49,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,44,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,11,28,248,22,159,16,23,195,2,193,249,22,160,16,23, -196,1,27,249,80,144,44,55,40,39,80,144,44,8,43,42,28,23,193,2,192, -247,22,176,16,28,248,22,159,16,23,195,2,248,22,162,16,23,195,1,28,248, -22,158,16,23,195,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22, -160,16,250,80,144,48,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2, -57,86,95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,200,1,23, -196,1,27,250,80,144,43,43,42,248,22,175,16,2,56,23,198,1,10,28,23, -193,2,248,22,162,16,23,194,1,11,28,248,22,90,23,196,2,9,28,248,22, -83,23,196,2,249,22,82,27,248,22,190,20,23,199,2,28,248,22,162,7,23, -194,2,27,248,22,142,16,23,195,1,28,248,22,159,16,23,194,2,192,249,22, -160,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2,192,247,22,176,16, -28,248,22,151,8,23,194,2,27,248,22,143,16,23,195,1,28,248,22,159,16, -23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,46,54,42,28,23,193, -2,192,247,22,176,16,28,248,22,134,16,23,194,2,28,248,22,159,16,23,194, -2,192,249,22,160,16,23,195,1,27,247,80,144,45,54,42,28,23,193,2,192, -247,22,176,16,192,27,248,22,191,20,23,199,1,28,248,22,90,23,194,2,86, -95,23,197,1,23,193,1,9,28,248,22,83,23,194,2,249,22,82,248,80,144, -45,60,42,248,22,190,20,23,197,2,27,248,22,191,20,23,197,1,28,248,22, -90,23,194,2,86,95,23,200,1,23,193,1,9,28,248,22,83,23,194,2,249, -22,82,248,80,144,48,60,42,248,22,190,20,23,197,2,249,80,144,49,8,44, -42,23,204,1,248,22,191,20,23,198,1,249,22,97,23,202,2,249,80,144,49, -8,44,42,23,204,1,248,22,191,20,23,198,1,249,22,97,23,199,2,27,248, -22,191,20,23,197,1,28,248,22,90,23,194,2,86,95,23,200,1,23,193,1, -9,28,248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,190,20, -23,197,2,249,80,144,49,8,44,42,23,204,1,248,22,191,20,23,198,1,249, -22,97,23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,191,20,23,198, -1,249,22,97,23,196,2,27,248,22,191,20,23,199,1,28,248,22,90,23,194, -2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,60,42,248,22,190, -20,23,197,2,27,248,22,191,20,23,197,1,28,248,22,90,23,194,2,86,95, -23,200,1,23,193,1,9,28,248,22,83,23,194,2,249,22,82,248,80,144,48, -60,42,248,22,190,20,23,197,2,249,80,144,49,8,44,42,23,204,1,248,22, -191,20,23,198,1,249,22,97,23,202,2,249,80,144,49,8,44,42,23,204,1, -248,22,191,20,23,198,1,249,22,97,23,199,2,27,248,22,191,20,23,197,1, -28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144, -48,60,42,248,22,190,20,23,197,2,249,80,144,49,8,44,42,23,204,1,248, -22,191,20,23,198,1,249,22,97,23,202,2,249,80,144,49,8,44,42,23,204, -1,248,22,191,20,23,198,1,27,250,22,161,2,23,198,1,23,199,1,11,28, -192,249,80,144,42,8,44,42,198,194,196,27,248,22,175,16,2,58,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,11,27,248,80,144,41,58,42,249,80,144,43,55,40,40,80,144,43,8, -45,42,27,27,250,22,161,2,23,198,2,72,108,105,110,107,115,45,102,105,108, -101,11,27,28,23,194,2,23,194,1,86,94,23,194,1,249,22,152,16,27,250, -22,161,2,23,202,2,71,115,104,97,114,101,45,100,105,114,11,28,192,192,249, -22,152,16,64,117,112,6,5,5,115,104,97,114,101,2,60,28,248,22,162,7, -23,194,2,27,248,22,142,16,23,195,1,28,248,22,159,16,23,194,2,192,249, -22,160,16,23,195,1,27,247,80,144,47,54,42,28,23,193,2,192,247,22,176, -16,28,248,22,151,8,23,194,2,27,248,22,143,16,23,195,1,28,248,22,159, -16,23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,47,54,42,28,23, -193,2,192,247,22,176,16,28,248,22,134,16,23,194,2,28,248,22,159,16,23, -194,2,192,249,22,160,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2, -192,247,22,176,16,192,250,22,97,248,22,92,11,28,247,22,183,16,28,247,22, -184,16,248,22,92,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,204, -2,2,59,247,22,180,8,2,60,9,9,28,247,22,184,16,250,80,144,47,8, -23,42,23,200,1,1,18,108,105,110,107,115,45,115,101,97,114,99,104,45,102, -105,108,101,115,248,22,92,23,200,1,9,248,22,129,14,23,194,1,249,22,14, -80,144,41,8,26,41,28,248,22,149,13,23,197,2,32,0,88,148,8,36,39, -44,11,9,222,11,20,20,94,88,148,8,36,39,46,11,9,223,3,33,121,23, -196,1,32,123,88,148,39,40,59,11,2,50,222,33,124,90,144,42,11,89,146, -42,39,11,248,22,155,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22, -134,16,23,194,2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32, -0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194, -2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22, -147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194, -2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248, -2,123,23,194,1,11,11,11,11,32,125,88,148,8,36,40,58,11,2,50,222, -33,126,27,249,22,172,6,8,128,128,23,196,2,28,248,22,157,7,23,194,2, -9,249,22,82,23,195,1,27,249,22,172,6,8,128,128,23,199,2,28,248,22, -157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172,6,8,128,128,23, -202,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172, -6,8,128,128,23,205,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195, -1,248,2,125,23,206,1,27,249,22,172,6,8,128,128,23,196,2,28,248,22, -151,8,23,194,2,28,249,22,179,20,248,22,172,21,23,196,2,8,128,128,249, -22,1,22,163,8,249,22,82,23,197,1,27,249,22,172,6,8,128,128,23,201, -2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172,6, -8,128,128,23,204,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1, -27,249,22,172,6,8,128,128,23,207,2,28,248,22,157,7,23,194,2,9,249, -22,82,23,195,1,27,249,22,172,6,8,128,128,23,210,2,28,248,22,157,7, -23,194,2,9,249,22,82,23,195,1,248,2,125,23,211,1,192,192,248,22,142, -6,23,194,1,20,13,144,80,144,40,8,28,40,80,144,40,8,46,42,27,28, -249,22,134,9,248,22,189,8,2,62,41,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,198,2,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194, -2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22, -147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194, -2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90, -144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95,23,195,1,23, -194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194,2,249,22,154, -6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248,2,123,23,194, -1,86,94,23,193,1,11,86,94,23,193,1,11,86,94,23,193,1,11,86,94, -23,193,1,11,11,28,248,22,146,16,23,195,2,27,28,249,22,134,9,248,22, -189,8,2,62,41,249,22,154,6,23,197,2,32,0,88,148,8,36,39,44,11, -9,222,11,11,86,94,28,23,194,2,248,22,156,6,23,195,1,86,94,23,194, -1,11,249,22,82,27,248,22,133,6,23,199,1,250,22,44,22,35,88,148,39, -39,8,24,11,9,223,3,33,127,20,20,94,88,148,8,36,39,46,11,9,223, -3,33,128,2,23,196,1,194,249,22,82,11,194,28,28,23,195,2,28,248,22, -84,23,196,2,248,22,179,9,249,22,132,15,39,248,22,191,20,23,199,2,11, -11,194,249,22,12,20,20,94,88,148,8,32,39,61,16,4,39,8,128,80,8, -240,0,64,0,0,39,9,224,2,3,33,129,2,23,196,1,80,144,41,8,26, -41,28,192,248,22,179,9,248,22,83,194,10,28,192,248,22,179,9,248,22,83, -194,10,86,95,28,248,22,170,12,23,198,2,27,247,22,159,12,28,249,22,149, -12,23,195,2,2,63,251,22,155,12,23,197,1,2,63,250,22,146,8,6,42, -42,101,114,114,111,114,32,114,101,97,100,105,110,103,32,99,111,108,108,101,99, -116,105,111,110,32,108,105,110,107,115,32,102,105,108,101,32,126,115,58,32,126, -97,23,201,2,248,22,166,12,23,206,2,247,22,27,86,94,23,193,1,11,11, -28,23,195,2,250,22,159,2,80,144,45,8,25,41,23,196,1,249,22,82,23, -200,1,21,17,0,0,86,95,23,195,1,23,193,1,11,28,248,22,170,12,23, -198,2,86,94,23,197,1,248,23,195,1,247,22,141,2,196,88,148,39,40,58, -8,240,0,0,0,2,9,226,0,3,2,1,33,133,2,20,20,94,248,22,157, -6,23,194,2,28,248,22,157,7,248,22,157,6,23,195,1,11,248,22,130,12, -6,30,30,101,120,112,101,99,116,101,100,32,97,32,115,105,110,103,108,101,32, -83,45,101,120,112,114,101,115,115,105,111,110,248,22,142,6,23,194,1,28,248, -22,91,193,28,28,249,22,175,20,41,248,22,96,195,10,249,22,175,20,42,248, -22,96,195,28,28,248,22,162,7,248,22,83,194,10,28,249,22,182,9,2,64, -248,22,83,195,10,249,22,182,9,2,65,248,22,83,195,28,27,248,22,105,194, -28,248,22,134,16,193,10,28,248,22,162,7,193,28,248,22,157,16,193,10,248, -22,158,16,193,11,28,248,22,90,248,22,107,194,10,248,22,141,17,248,22,114, -194,11,11,11,11,28,248,22,147,16,249,22,152,16,23,197,2,23,198,2,27, -248,22,70,248,22,138,16,23,198,1,250,22,159,2,23,197,2,23,196,2,249, -22,82,23,200,1,250,22,161,2,23,202,1,23,201,1,9,12,250,22,159,2, -23,196,1,23,198,1,249,22,82,23,199,1,23,201,1,28,28,248,22,90,248, -22,107,23,197,2,10,249,22,132,17,248,22,114,23,198,2,247,22,180,8,27, -248,22,162,16,249,22,160,16,248,22,105,23,200,2,23,198,1,28,249,22,182, -9,248,22,190,20,23,199,2,2,65,86,94,23,196,1,249,22,3,20,20,94, -88,148,8,36,40,56,11,9,224,2,3,33,138,2,23,196,1,248,22,165,16, -23,196,1,28,249,22,182,9,248,22,190,20,23,199,2,2,64,86,94,23,196, -1,86,94,28,250,22,161,2,23,197,2,11,11,11,250,22,159,2,23,197,2, -11,9,249,22,167,2,23,196,2,20,20,95,88,148,8,36,41,53,11,9,224, -2,3,33,139,2,23,196,1,23,195,1,27,248,22,70,248,22,190,20,23,199, -1,250,22,159,2,23,198,2,23,196,2,249,22,82,248,22,132,2,23,200,1, -250,22,161,2,23,203,1,23,201,1,9,12,250,22,159,2,23,196,1,23,197, -1,248,22,98,23,199,1,27,28,23,195,2,28,248,22,83,23,196,2,27,249, -22,133,6,23,197,2,68,98,105,110,97,114,121,250,22,44,22,35,88,148,8, -36,39,47,11,9,223,3,33,135,2,20,20,94,88,148,8,36,39,46,11,9, -223,3,33,136,2,23,196,1,9,9,86,94,28,28,248,22,91,23,194,2,249, -22,4,32,0,88,148,8,36,40,48,11,9,222,33,137,2,23,195,2,11,11, -248,22,130,12,6,18,18,105,108,108,45,102,111,114,109,101,100,32,99,111,110, -116,101,110,116,27,247,22,141,2,27,90,144,42,11,89,146,42,39,11,248,22, -155,16,23,200,2,192,86,96,249,22,3,20,20,94,88,148,8,36,40,57,11, -9,224,2,3,33,140,2,23,195,1,23,197,1,249,22,167,2,195,88,148,8, -36,41,51,11,9,223,3,33,141,2,250,22,159,2,80,144,47,8,25,41,23, -199,1,249,22,82,23,202,1,198,193,20,13,144,80,144,40,8,28,40,250,80, -144,43,8,47,42,23,196,2,23,198,2,11,27,250,22,161,2,80,144,44,8, -25,41,23,197,2,21,143,11,17,0,0,27,248,22,83,23,195,2,27,249,80, -144,45,8,27,42,23,198,2,23,196,2,28,249,22,184,9,23,195,2,23,196, -1,248,22,191,20,195,20,13,144,80,144,43,8,28,40,250,80,144,46,8,47, -42,23,199,2,23,201,1,23,196,2,27,20,20,95,88,148,8,36,39,55,8, -240,0,0,0,2,9,225,5,1,4,33,142,2,23,197,1,23,194,1,28,249, -22,48,23,195,2,39,20,13,144,80,144,44,46,40,26,35,80,144,8,40,47, -40,249,22,31,11,80,144,8,42,46,40,22,165,15,10,22,166,15,10,22,167, -15,10,22,168,15,11,22,169,15,11,22,173,15,10,22,172,15,11,22,174,15, -10,22,171,15,10,22,175,15,10,22,170,15,11,22,176,15,10,22,177,15,10, -22,178,15,10,22,179,15,11,22,180,15,10,22,163,15,11,247,23,193,1,250, -22,134,12,2,9,2,52,23,196,1,248,22,8,20,20,94,88,148,39,40,8, -49,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,9,224,1,2,33, -143,2,23,195,1,0,7,35,114,120,34,47,43,34,28,248,22,162,7,23,195, -2,27,249,22,130,17,2,145,2,23,197,2,28,23,193,2,28,249,22,134,4, -248,22,104,23,196,2,248,22,188,3,248,22,169,21,23,199,2,249,22,7,250, -22,184,7,23,200,1,39,248,22,104,23,199,1,23,198,1,249,22,7,250,22, -184,7,23,200,2,39,248,22,104,23,199,2,249,22,82,249,22,184,7,23,201, -1,248,22,106,23,200,1,23,200,1,86,94,23,193,1,249,22,7,23,197,1, -23,198,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,1,86,94, -23,195,1,28,249,22,182,9,23,195,2,2,49,86,94,23,193,1,249,22,7, -23,196,1,23,200,1,27,249,22,82,23,197,1,23,201,1,28,248,22,162,7, -23,195,2,27,249,22,130,17,2,145,2,23,197,2,28,23,193,2,28,249,22, -134,4,248,22,104,23,196,2,248,22,188,3,248,22,169,21,23,199,2,249,22, -7,250,22,184,7,23,200,1,39,248,22,104,23,199,1,23,196,1,249,22,7, -250,22,184,7,23,200,2,39,248,22,104,23,199,2,249,22,82,249,22,184,7, -23,201,1,248,22,106,23,200,1,23,198,1,86,94,23,193,1,249,22,7,23, -197,1,23,196,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,1, -86,94,23,195,1,28,249,22,182,9,23,195,2,2,49,86,94,23,193,1,249, -22,7,23,196,1,23,198,1,249,80,144,48,8,31,42,194,249,22,82,197,199, -28,248,22,90,23,196,2,9,28,248,22,83,23,196,2,28,248,22,152,2,248, -22,190,20,23,197,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22, -190,20,23,204,2,23,202,2,9,250,22,161,2,248,22,190,20,23,202,2,11, -9,27,248,22,191,20,23,200,1,28,248,22,90,23,194,2,86,95,23,198,1, -23,193,1,9,28,248,22,83,23,194,2,28,248,22,152,2,248,22,190,20,23, -195,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22,190,20,23,202, -2,23,206,2,9,250,22,161,2,248,22,190,20,23,200,2,11,9,249,80,144, -48,8,48,42,23,203,1,248,22,191,20,23,199,1,27,248,80,144,45,8,30, -42,248,22,190,20,23,196,2,250,22,97,250,22,161,2,23,199,2,23,205,2, -9,250,22,161,2,23,199,1,11,9,249,80,144,49,8,48,42,23,204,1,248, -22,191,20,23,200,1,249,22,97,247,22,179,16,249,80,144,47,8,48,42,23, -202,1,248,22,191,20,23,198,1,27,248,80,144,41,8,30,42,248,22,190,20, -23,198,2,250,22,97,250,22,161,2,23,199,2,23,201,2,9,250,22,161,2, -23,199,1,11,9,27,248,22,191,20,23,201,1,28,248,22,90,23,194,2,86, -95,23,199,1,23,193,1,9,28,248,22,83,23,194,2,28,248,22,152,2,248, -22,190,20,23,195,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22, -190,20,23,202,2,23,207,2,9,250,22,161,2,248,22,190,20,23,200,2,11, -9,249,80,144,49,8,48,42,23,204,1,248,22,191,20,23,199,1,27,248,80, -144,46,8,30,42,248,22,190,20,23,196,2,250,22,97,250,22,161,2,23,199, -2,23,206,2,9,250,22,161,2,23,199,1,11,9,249,80,144,50,8,48,42, -23,205,1,248,22,191,20,23,200,1,249,22,97,247,22,179,16,249,80,144,48, -8,48,42,23,203,1,248,22,191,20,23,198,1,249,22,97,247,22,179,16,27, -248,22,191,20,23,199,1,28,248,22,90,23,194,2,9,28,248,22,83,23,194, -2,28,248,22,152,2,248,22,190,20,23,195,2,250,22,97,249,22,2,22,132, -2,250,22,161,2,248,22,190,20,23,202,2,23,205,2,9,250,22,161,2,248, -22,190,20,23,200,2,11,9,249,80,144,47,8,48,42,23,202,1,248,22,191, -20,23,199,1,27,248,80,144,44,8,30,42,248,22,190,20,23,196,2,250,22, -97,250,22,161,2,23,199,2,23,204,2,9,250,22,161,2,23,199,1,11,9, -249,80,144,48,8,48,42,23,203,1,248,22,191,20,23,200,1,249,22,97,247, -22,179,16,249,80,144,46,8,48,42,23,201,1,248,22,191,20,23,198,1,32, -148,2,88,148,8,36,40,50,11,2,50,222,33,149,2,28,248,22,90,248,22, -84,23,195,2,248,22,92,27,248,22,190,20,195,28,248,22,134,16,193,248,22, -138,16,193,192,250,22,93,27,248,22,190,20,23,198,2,28,248,22,134,16,193, -248,22,138,16,193,192,2,67,248,2,148,2,248,22,191,20,23,198,1,250,22, -146,8,6,7,7,10,32,126,97,32,126,97,6,1,1,32,23,196,1,249,22, -146,8,6,6,6,10,32,32,32,126,97,248,22,135,2,23,196,1,32,152,2, -88,148,39,41,51,11,68,102,105,108,116,101,114,222,33,153,2,28,248,22,90, -23,195,2,9,28,248,23,194,2,248,22,83,23,196,2,249,22,82,248,22,190, -20,23,197,2,249,2,152,2,23,197,1,248,22,191,20,23,199,1,249,2,152, -2,23,195,1,248,22,191,20,23,197,1,28,248,22,90,23,201,2,86,95,23, -200,1,23,194,1,28,23,201,2,86,97,23,199,1,23,198,1,23,197,1,23, -196,1,28,194,249,22,152,16,202,196,200,27,28,248,22,90,23,199,2,2,66, -249,22,1,22,185,7,248,2,148,2,23,201,2,248,23,198,1,251,22,146,8, -6,70,70,99,111,108,108,101,99,116,105,111,110,32,110,111,116,32,102,111,117, -110,100,10,32,32,99,111,108,108,101,99,116,105,111,110,58,32,126,115,10,32, -32,105,110,32,99,111,108,108,101,99,116,105,111,110,32,100,105,114,101,99,116, -111,114,105,101,115,58,126,97,126,97,28,248,22,90,23,204,1,28,248,22,134, -16,23,205,2,248,22,138,16,23,205,1,23,204,1,250,22,185,7,28,248,22, -134,16,23,208,2,248,22,138,16,23,208,1,23,207,1,2,67,23,201,2,249, -22,1,22,185,7,249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,150, -2,19,248,22,96,23,211,2,19,248,22,96,247,22,179,16,28,249,22,135,4, -249,22,190,3,23,198,4,23,197,4,44,23,211,2,249,22,97,247,22,179,16, -248,22,92,249,22,146,8,6,50,50,46,46,46,32,91,126,97,32,97,100,100, -105,116,105,111,110,97,108,32,108,105,110,107,101,100,32,97,110,100,32,112,97, -99,107,97,103,101,32,100,105,114,101,99,116,111,114,105,101,115,93,249,22,190, -3,23,201,4,23,200,4,2,2,28,249,22,5,22,134,2,23,207,2,250,22, -146,8,6,49,49,10,32,32,32,115,117,98,45,99,111,108,108,101,99,116,105, -111,110,58,32,126,115,10,32,32,105,110,32,112,97,114,101,110,116,32,100,105, -114,101,99,116,111,114,105,101,115,58,126,97,23,201,1,249,22,1,22,185,7, -249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,151,2,249,2,152,2, -22,134,2,23,214,1,86,95,23,205,1,23,198,1,2,66,27,248,22,83,23, -202,2,27,28,248,22,134,16,23,195,2,249,22,152,16,23,196,1,23,202,2, -248,22,135,2,23,195,1,28,28,248,22,134,16,248,22,190,20,23,204,2,248, -22,147,16,23,194,2,10,27,250,22,1,22,152,16,23,197,1,23,203,2,28, -28,248,22,90,23,201,2,10,248,22,147,16,23,194,2,28,23,198,2,28,28, -250,80,144,45,8,32,42,195,200,199,10,27,28,248,22,134,16,199,248,22,138, -16,199,198,19,248,22,165,7,23,195,2,27,28,249,22,179,20,23,196,4,43, -28,249,22,168,7,6,4,4,46,114,107,116,249,22,184,7,23,199,2,249,22, -190,3,23,200,4,43,249,22,185,7,250,22,184,7,23,200,1,39,249,22,190, -3,23,201,4,43,6,3,3,46,115,115,86,94,23,195,1,11,86,94,23,195, -1,11,28,23,193,2,250,80,144,48,8,32,42,198,23,196,1,202,11,2,28, -197,249,22,152,16,194,199,192,26,8,80,144,50,8,49,42,204,205,206,23,15, -23,16,23,17,248,22,191,20,23,19,28,23,19,23,19,200,192,26,8,80,144, -50,8,49,42,204,205,206,23,15,23,16,23,17,248,22,191,20,23,19,23,19, -26,8,80,144,49,8,49,42,203,204,205,206,23,15,23,16,248,22,191,20,23, -18,23,18,90,144,41,11,89,146,41,39,11,249,80,144,43,8,31,42,23,199, -1,23,200,1,27,248,22,70,28,248,22,134,16,195,248,22,138,16,195,194,27, -27,247,22,180,16,28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,28, -248,22,152,2,248,22,190,20,23,195,2,250,22,97,249,22,2,22,132,2,250, -22,161,2,248,22,190,20,23,202,2,23,203,2,9,250,22,161,2,248,22,190, -20,23,200,2,11,9,249,80,144,49,8,48,42,23,200,1,248,22,191,20,23, -199,1,27,248,80,144,46,8,30,42,248,22,190,20,23,196,2,250,22,97,250, -22,161,2,23,199,2,23,202,2,9,250,22,161,2,23,199,1,11,9,249,80, -144,50,8,48,42,23,201,1,248,22,191,20,23,200,1,249,22,97,247,22,179, -16,249,80,144,48,8,48,42,23,199,1,248,22,191,20,23,198,1,26,8,80, -144,51,8,49,42,23,17,23,16,205,203,202,200,200,11,32,156,2,88,148,8, -36,42,57,11,2,50,222,33,157,2,28,248,22,139,4,195,249,22,144,16,251, -22,163,8,250,22,162,8,202,39,248,22,156,8,203,2,51,249,22,162,8,201, -248,22,172,21,202,2,68,28,248,22,135,16,195,248,22,136,16,195,247,22,137, -16,27,248,22,188,3,196,28,28,248,22,139,4,193,11,249,22,182,9,8,46, -249,22,157,8,198,196,249,22,144,16,251,22,163,8,250,22,162,8,203,39,201, -2,69,249,22,162,8,202,248,22,187,3,201,2,68,28,248,22,135,16,196,248, -22,136,16,196,247,22,137,16,250,2,156,2,196,197,195,248,22,146,16,27,250, -22,152,16,23,198,1,23,202,1,23,199,1,28,249,22,182,9,23,199,2,66, -115,97,109,101,192,28,248,22,157,16,23,198,2,249,22,152,16,194,198,249,80, -144,46,42,42,23,195,1,23,199,1,249,22,5,20,20,96,88,148,39,40,54, -47,9,226,5,6,3,2,33,158,2,23,195,1,23,196,1,23,199,1,23,197, -1,27,248,22,146,16,249,22,152,16,23,198,2,23,199,2,28,23,193,2,192, -28,23,197,1,27,90,144,41,11,89,146,41,39,11,250,80,144,46,8,34,42, -23,202,2,2,68,2,34,27,248,22,140,16,23,196,1,27,250,2,156,2,23, -204,1,23,197,2,248,22,156,8,23,198,1,28,248,22,135,16,195,249,22,152, -16,196,194,192,27,247,22,181,16,249,22,5,20,20,96,88,148,39,40,51,47, -9,226,5,2,3,6,33,159,2,23,199,1,23,196,1,23,195,1,247,22,182, -16,11,86,95,28,248,22,135,16,23,194,2,11,28,248,22,134,16,23,194,2, -11,28,28,248,22,162,7,23,194,2,28,248,22,157,16,23,194,2,10,248,22, -158,16,23,194,2,11,11,252,22,134,12,23,200,2,2,42,39,23,198,2,23, -199,2,28,248,22,162,7,23,195,2,86,94,23,194,1,11,28,248,22,151,8, -23,195,2,86,94,23,194,1,11,252,22,134,12,23,200,2,2,70,40,23,198, -2,23,199,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,2,86, -94,23,195,1,86,94,28,23,193,2,86,95,23,198,1,23,196,1,11,250,22, -137,12,23,201,1,2,71,23,199,1,249,22,7,23,195,1,23,196,1,32,162, -2,88,148,8,36,45,8,23,11,2,50,222,33,163,2,28,248,22,139,4,23, -199,2,86,95,23,198,1,23,196,1,19,248,22,156,8,23,199,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,207,2,39,23,202,4,2,51,249,23,204, -1,23,206,2,248,22,172,21,23,207,1,28,248,22,162,7,200,249,22,177,8, -201,8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16,2,27, -248,22,188,3,23,200,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9, -8,46,249,22,157,8,23,202,2,23,197,2,249,22,144,16,251,22,163,8,250, -22,162,8,23,207,2,39,23,202,2,23,203,1,249,23,204,1,23,206,1,248, -22,187,3,23,202,1,28,248,22,162,7,200,249,22,177,8,201,8,63,199,28, -248,22,135,16,197,248,22,136,16,197,247,22,137,16,28,248,22,139,4,23,194, -2,86,95,23,197,1,23,193,1,19,248,22,156,8,23,200,2,249,22,144,16, -251,22,163,8,250,22,162,8,23,208,2,39,23,202,4,2,51,249,23,205,1, -23,207,2,248,22,172,21,23,208,1,28,248,22,162,7,201,249,22,177,8,202, -8,63,200,28,248,22,135,16,198,248,22,136,16,198,247,22,137,16,2,27,248, -22,188,3,23,195,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9,8, -46,249,22,157,8,23,203,2,23,197,2,249,22,144,16,251,22,163,8,250,22, -162,8,23,208,2,39,23,202,2,23,204,1,249,23,205,1,23,207,1,248,22, -187,3,23,202,1,28,248,22,162,7,201,249,22,177,8,202,8,63,200,28,248, -22,135,16,198,248,22,136,16,198,247,22,137,16,28,248,22,139,4,23,194,2, -86,95,23,198,1,23,193,1,19,248,22,156,8,23,201,2,249,22,144,16,251, -22,163,8,250,22,162,8,23,209,2,39,23,202,4,2,51,249,23,206,1,23, -208,2,248,22,172,21,23,209,1,28,248,22,162,7,202,249,22,177,8,203,8, -63,201,28,248,22,135,16,199,248,22,136,16,199,247,22,137,16,2,27,248,22, -188,3,23,195,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9,8,46, -249,22,157,8,23,204,2,23,197,2,249,22,144,16,251,22,163,8,250,22,162, -8,23,209,2,39,23,202,2,23,205,1,249,23,206,1,23,208,1,248,22,187, -3,23,202,1,28,248,22,162,7,202,249,22,177,8,203,8,63,201,28,248,22, -135,16,199,248,22,136,16,199,247,22,137,16,253,2,162,2,201,202,203,204,205, -198,90,144,41,11,89,146,41,39,11,86,95,28,248,22,135,16,23,199,2,11, -28,248,22,134,16,23,199,2,11,28,28,248,22,162,7,23,199,2,28,248,22, -157,16,23,199,2,10,248,22,158,16,23,199,2,11,11,252,22,134,12,23,200, -2,2,42,39,23,203,2,23,204,2,28,248,22,162,7,23,200,2,11,28,248, -22,151,8,23,200,2,11,252,22,134,12,23,200,2,2,70,40,23,203,2,23, -204,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,202,2,86,94,23, -195,1,86,94,28,192,86,94,23,198,1,11,250,22,137,12,23,201,1,2,71, -23,204,2,249,22,7,194,195,27,248,22,140,16,23,196,1,27,19,248,22,156, -8,23,196,2,28,249,22,175,20,23,195,4,39,86,94,23,199,1,249,22,144, -16,251,22,163,8,250,22,162,8,23,204,2,39,248,22,172,21,23,205,2,2, -51,249,23,208,1,23,203,2,248,22,172,21,23,204,1,28,248,22,162,7,23, -16,249,22,177,8,23,17,8,63,23,15,28,248,22,135,16,203,248,22,136,16, -203,247,22,137,16,27,248,22,188,3,23,195,4,28,28,248,22,139,4,23,194, -2,11,249,22,182,9,8,46,249,22,157,8,23,200,2,23,197,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,205,2,39,23,202,2,23,206,1,249,23, -209,1,23,204,1,248,22,187,3,23,202,1,28,248,22,162,7,23,17,249,22, -177,8,23,18,8,63,23,16,28,248,22,135,16,204,248,22,136,16,204,247,22, -137,16,28,248,22,139,4,23,194,2,86,95,23,200,1,23,193,1,249,22,144, -16,251,22,163,8,250,22,162,8,23,205,2,39,248,22,172,21,23,206,2,2, -51,249,23,209,1,23,204,2,248,22,172,21,23,205,1,28,248,22,162,7,23, -17,249,22,177,8,23,18,8,63,23,16,28,248,22,135,16,204,248,22,136,16, -204,247,22,137,16,27,248,22,188,3,23,195,1,28,28,248,22,139,4,23,194, -2,11,249,22,182,9,8,46,249,22,157,8,23,201,2,23,197,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,206,2,39,23,202,2,23,207,1,249,23, -210,1,23,205,1,248,22,187,3,23,202,1,28,248,22,162,7,23,18,249,22, -177,8,23,19,8,63,23,17,28,248,22,135,16,205,248,22,136,16,205,247,22, -137,16,253,2,162,2,23,210,1,23,209,1,23,208,1,23,207,1,23,203,1, -23,199,1,2,28,248,22,135,16,195,249,22,152,16,196,194,192,32,165,2,88, -148,8,36,43,58,11,2,50,222,33,166,2,28,248,22,139,4,196,249,22,144, -16,251,22,163,8,250,22,162,8,203,39,248,22,156,8,204,2,51,2,51,28, -248,22,162,7,199,249,22,177,8,200,8,63,198,28,248,22,135,16,196,248,22, -136,16,196,247,22,137,16,27,248,22,188,3,197,28,28,248,22,139,4,193,11, -249,22,182,9,8,46,249,22,157,8,199,196,249,22,144,16,251,22,163,8,250, -22,162,8,204,39,201,2,51,2,51,28,248,22,162,7,200,249,22,177,8,201, -8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16,251,2,165, -2,197,198,199,196,90,144,41,11,89,146,41,39,11,86,95,28,248,22,135,16, -23,196,2,11,28,248,22,134,16,23,196,2,11,28,28,248,22,162,7,23,196, -2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11,11,252,22, -134,12,2,37,2,42,39,23,200,2,23,201,2,28,248,22,162,7,23,197,2, -11,28,248,22,151,8,23,197,2,11,252,22,134,12,2,37,2,70,40,23,200, -2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,199,2,86, -94,23,195,1,86,94,28,192,11,250,22,137,12,2,37,2,71,23,201,2,249, -22,7,194,195,27,248,22,140,16,23,196,1,27,251,2,165,2,23,202,1,23, -201,1,23,198,2,248,22,156,8,23,199,1,28,248,22,135,16,195,249,22,152, -16,196,194,192,32,168,2,88,148,8,36,43,58,11,2,50,222,33,169,2,28, -248,22,139,4,196,249,22,144,16,251,22,163,8,250,22,162,8,203,39,248,22, -156,8,204,2,51,249,22,162,8,202,248,22,172,21,203,28,248,22,162,7,199, -249,22,177,8,200,8,63,198,28,248,22,135,16,196,248,22,136,16,196,247,22, -137,16,27,248,22,188,3,197,28,28,248,22,139,4,193,11,249,22,182,9,8, -46,249,22,157,8,199,196,249,22,144,16,251,22,163,8,250,22,162,8,204,39, -201,2,69,249,22,162,8,203,248,22,187,3,201,28,248,22,162,7,200,249,22, -177,8,201,8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16, -251,2,168,2,197,198,199,196,90,144,41,11,89,146,41,39,11,86,95,28,248, -22,135,16,23,196,2,11,28,248,22,134,16,23,196,2,11,28,28,248,22,162, -7,23,196,2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11, -11,252,22,134,12,2,34,2,42,39,23,200,2,23,201,2,28,248,22,162,7, -23,197,2,11,28,248,22,151,8,23,197,2,11,252,22,134,12,2,34,2,70, -40,23,200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -199,2,86,94,23,195,1,86,94,28,192,11,250,22,137,12,2,34,2,71,23, -201,2,249,22,7,194,195,27,248,22,140,16,23,196,1,27,251,2,168,2,23, -202,1,23,201,1,23,198,2,248,22,156,8,23,199,1,28,248,22,135,16,195, -249,22,152,16,196,194,192,249,247,22,185,5,23,195,1,11,249,247,22,185,5, -194,11,28,248,22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,50,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,45, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22, -160,16,23,198,1,247,22,176,16,27,248,22,191,20,23,199,1,28,248,22,90, -23,194,2,86,94,23,193,1,9,27,248,80,144,45,56,42,248,22,83,23,196, -2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22, -176,16,248,80,144,47,8,50,42,248,22,191,20,23,198,1,86,94,23,193,1, -248,80,144,45,8,50,42,248,22,191,20,23,196,1,86,94,23,193,1,27,248, -22,191,20,23,197,1,28,248,22,90,23,194,2,9,27,248,80,144,43,56,42, -248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16, -23,198,1,247,22,176,16,248,80,144,45,8,50,42,248,22,191,20,23,198,1, -86,94,23,193,1,248,80,144,43,8,50,42,248,22,191,20,23,196,1,28,248, -22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22,159,16,23,194, -2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11,89, -146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,50,43,42,248,22,175, -16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248,22, -162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,45,43,42,248,22, -175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,86,94, -23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198, -1,247,22,176,16,27,248,22,191,20,23,199,1,28,248,22,90,23,194,2,86, -94,23,193,1,9,27,248,80,144,45,56,42,248,22,83,23,196,2,28,23,193, -2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248,80, -144,47,8,51,42,248,22,191,20,23,198,1,86,94,23,193,1,248,80,144,45, -8,51,42,248,22,191,20,23,196,1,86,94,23,193,1,27,248,22,191,20,23, -197,1,28,248,22,90,23,194,2,9,27,248,80,144,43,56,42,248,22,83,23, -196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247, -22,176,16,248,80,144,45,8,51,42,248,22,191,20,23,198,1,86,94,23,193, -1,248,80,144,43,8,51,42,248,22,191,20,23,196,1,27,248,22,175,16,2, -58,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,49,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,44,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,11,28,248,22,90,23,195,2,9,27,27,248,22,83,23, -197,2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158, -16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16, -250,80,144,50,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86, -95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1, -27,250,80,144,45,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2, -248,22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248, -22,162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22,191,20,23,199, -1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,27,248,22,83,23,196, -2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,54,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,49,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248,22, -162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22,191,20,23,198,1, -28,248,22,90,23,194,2,86,94,23,193,1,9,27,248,80,144,49,56,42,248, -22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23, -198,1,247,22,176,16,248,80,144,51,8,53,42,248,22,191,20,23,198,1,86, -94,23,193,1,248,80,144,49,8,53,42,248,22,191,20,23,196,1,86,94,23, -193,1,27,248,22,191,20,23,196,1,28,248,22,90,23,194,2,86,94,23,193, -1,9,27,248,80,144,47,56,42,248,22,83,23,196,2,28,23,193,2,249,22, -82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248,80,144,49,8, -53,42,248,22,191,20,23,198,1,86,94,23,193,1,248,80,144,47,8,53,42, -248,22,191,20,23,196,1,86,94,23,193,1,27,248,22,191,20,23,197,1,28, -248,22,90,23,194,2,9,27,27,248,22,83,23,196,2,28,248,22,159,16,23, -194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11, -89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,52,43,42,248,22, -175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248, -22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,47,43,42,248, -22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,86, -94,23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23, -198,1,247,22,176,16,27,248,22,191,20,23,198,1,28,248,22,90,23,194,2, -86,94,23,193,1,9,27,248,80,144,47,56,42,248,22,83,23,196,2,28,23, -193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248, -80,144,49,8,53,42,248,22,191,20,23,198,1,86,94,23,193,1,248,80,144, -47,8,53,42,248,22,191,20,23,196,1,86,94,23,193,1,27,248,22,191,20, -23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,45,56,42,248,22,83, -23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1, -247,22,176,16,248,80,144,47,8,53,42,248,22,191,20,23,198,1,86,94,23, -193,1,248,80,144,45,8,53,42,248,22,191,20,23,196,1,27,247,22,183,16, -27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43,44,41,28,23, -196,2,27,249,22,184,8,247,22,183,8,2,72,28,192,249,22,174,8,194,7, -63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,73,27,28,23,200, -1,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,205,1,2,59,247, -22,180,8,2,74,86,94,23,199,1,11,27,248,80,144,49,8,50,42,250,22, -97,9,248,22,92,248,22,175,16,2,55,9,28,193,249,22,82,195,194,192,27, -247,22,183,16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43, -44,41,28,23,196,2,27,249,22,184,8,247,22,183,8,2,72,28,192,249,22, -174,8,194,7,63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,73, -27,28,23,200,1,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,205, -1,2,59,247,22,180,8,2,74,86,94,23,199,1,11,27,248,80,144,49,8, -51,42,250,22,97,23,207,1,248,22,92,248,22,175,16,2,55,9,28,193,249, -22,82,195,194,192,27,247,22,183,16,27,248,80,144,42,58,42,249,80,144,44, -55,40,40,80,144,44,8,52,42,249,80,144,43,44,41,28,23,196,2,27,249, -22,184,8,247,22,183,8,2,72,28,192,249,22,174,8,194,7,63,2,66,2, -66,250,80,144,46,8,23,42,23,198,2,2,73,27,28,23,200,1,250,22,152, -16,248,22,175,16,2,61,250,22,161,2,23,205,1,2,59,247,22,180,8,2, -74,86,94,23,199,1,11,27,27,250,22,97,23,207,1,248,22,92,248,22,175, -16,2,55,23,208,1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,27, -248,22,83,23,196,2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1, -28,248,22,158,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16, -249,22,160,16,250,80,144,60,43,42,248,22,175,16,2,56,11,11,248,22,175, -16,2,57,86,95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199, -1,23,196,1,27,250,80,144,55,43,42,248,22,175,16,2,56,23,197,1,10, -28,23,193,2,248,22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2, -249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22, -191,20,23,198,1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,248,80, -144,55,56,42,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16, -249,22,160,16,23,198,1,247,22,176,16,248,80,144,57,8,53,42,248,22,191, -20,23,198,1,86,94,23,193,1,248,80,144,55,8,53,42,248,22,191,20,23, -196,1,86,94,23,193,1,27,248,22,191,20,23,196,1,28,248,22,90,23,194, -2,86,94,23,193,1,9,27,248,80,144,53,56,42,248,22,83,23,196,2,28, -23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16, -248,80,144,55,8,53,42,248,22,191,20,23,198,1,86,94,23,193,1,248,80, -144,53,8,53,42,248,22,191,20,23,196,1,28,193,249,22,82,195,194,192,27, -20,13,144,80,144,40,46,40,26,9,80,144,49,47,40,249,22,31,11,80,144, -51,46,40,22,172,15,10,22,179,15,10,22,180,15,10,22,181,15,10,248,22, -157,6,23,196,2,28,248,22,157,7,23,194,2,12,86,94,248,22,191,9,23, -194,1,27,20,13,144,80,144,41,46,40,26,9,80,144,50,47,40,249,22,31, -11,80,144,52,46,40,22,172,15,10,22,179,15,10,22,180,15,10,22,181,15, -10,248,22,157,6,23,197,2,28,248,22,157,7,23,194,2,12,86,94,248,22, -191,9,23,194,1,27,20,13,144,80,144,42,46,40,26,9,80,144,51,47,40, -249,22,31,11,80,144,53,46,40,22,172,15,10,22,179,15,10,22,180,15,10, -22,181,15,10,248,22,157,6,23,198,2,28,248,22,157,7,23,194,2,12,86, -94,248,22,191,9,23,194,1,248,80,144,43,8,54,42,197,86,94,249,22,148, -7,247,22,181,5,23,195,2,248,22,172,6,249,22,142,4,39,249,22,190,3, -23,199,1,23,198,1,27,248,22,134,6,28,23,198,2,23,198,1,86,94,23, -198,1,27,250,80,144,45,43,42,248,22,175,16,2,56,11,11,27,248,22,145, -4,23,199,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,27,248,22, -145,4,23,202,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,249,22, -149,6,23,199,1,20,20,95,88,148,8,36,39,51,11,9,224,2,4,33,181, -2,23,197,1,23,195,1,248,80,144,41,8,54,42,193,145,40,9,20,122,145, -2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11, -11,11,11,11,9,9,11,11,11,10,47,80,143,39,39,20,122,145,2,1,54, -16,40,2,3,2,4,2,5,2,6,2,7,2,8,2,9,30,2,11,1,20, -112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11, -5,30,2,11,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101, -114,105,122,97,116,105,111,110,11,4,2,12,2,13,2,14,2,15,2,16,2, -17,2,18,30,2,11,1,19,99,97,99,104,101,45,99,111,110,102,105,103,117, -114,97,116,105,111,110,11,1,2,19,2,20,2,21,2,22,2,23,2,24,2, -25,2,26,2,27,2,28,2,29,30,2,11,1,21,101,120,99,101,112,116,105, -111,110,45,104,97,110,100,108,101,114,45,107,101,121,11,3,2,30,2,31,2, -32,2,33,2,34,2,35,2,36,2,37,2,38,2,39,2,40,16,0,40,42, -39,16,0,39,16,19,2,13,2,14,2,12,2,25,2,4,2,35,2,23,2, -24,2,19,2,29,2,33,2,21,2,22,2,31,2,27,2,30,2,32,2,36, -2,28,58,11,11,11,16,17,2,9,2,17,2,15,2,40,2,16,2,7,2, -26,2,39,2,18,2,20,2,38,2,5,2,34,2,8,2,37,2,3,2,6, -16,17,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,16,17, -2,9,2,17,2,15,2,40,2,16,2,7,2,26,2,39,2,18,2,20,2, -38,2,5,2,34,2,8,2,37,2,3,2,6,56,56,40,12,11,11,16,0, -16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,51,20, -15,16,2,32,0,88,148,8,36,40,47,11,2,3,222,33,75,80,144,39,39, -40,20,15,16,2,249,22,164,7,7,92,7,92,80,144,39,40,40,20,15,16, -2,88,148,8,36,40,57,41,2,5,223,0,33,80,80,144,39,41,40,20,15, -16,2,88,148,8,36,41,61,41,2,6,223,0,33,82,80,144,39,42,40,20, -15,16,2,20,26,96,2,7,88,148,8,36,42,8,24,8,32,9,223,0,33, -89,88,148,8,36,41,50,55,9,223,0,33,90,88,148,8,36,40,49,55,9, -223,0,33,91,80,144,39,43,40,20,15,16,2,27,248,22,188,16,248,22,176, -8,27,28,249,22,182,9,247,22,189,8,2,43,6,1,1,59,6,1,1,58, -250,22,146,8,6,14,14,40,91,94,126,97,93,42,41,126,97,40,46,42,41, -23,196,2,23,196,1,88,148,8,36,41,51,11,2,8,223,0,33,95,80,144, -39,44,40,20,15,16,2,88,148,39,40,8,44,8,128,6,2,9,223,0,33, -96,80,144,39,45,40,20,15,16,2,32,0,88,148,8,36,41,50,11,2,12, -222,33,97,80,144,39,48,40,20,15,16,2,32,0,88,148,8,36,42,51,11, -2,13,222,33,99,80,144,39,49,40,20,15,16,2,32,0,88,148,8,36,41, -49,11,2,14,222,33,100,80,144,39,50,40,20,15,16,2,88,148,39,42,53, -8,128,128,2,15,223,0,33,102,80,144,39,51,40,20,15,16,2,88,148,39, -44,55,8,128,128,2,17,223,0,33,104,80,144,39,53,40,20,15,16,2,88, -148,39,39,56,55,9,223,0,33,105,80,144,39,8,40,42,20,15,16,2,88, -148,39,39,47,16,4,39,40,8,128,4,39,2,18,223,0,33,106,80,144,39, -54,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33,107,80,144,39,8, -41,42,20,15,16,2,88,148,39,39,47,16,4,39,40,8,128,8,39,2,20, -223,0,33,108,80,144,39,57,40,20,15,16,2,88,148,8,36,39,8,44,8, -128,6,9,223,0,33,109,80,144,39,8,42,42,20,15,16,2,88,148,8,36, -40,50,16,4,39,39,8,128,16,39,2,21,223,0,33,110,80,144,39,58,40, -20,15,16,2,20,28,143,32,0,88,148,39,40,48,11,2,22,222,33,111,32, -0,88,148,39,40,48,11,2,22,222,33,112,80,144,39,59,40,20,15,16,2, -88,148,8,36,40,50,8,240,0,128,0,0,2,23,223,0,33,113,80,144,39, -60,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33,114,80,144,39,8, -43,42,20,15,16,2,88,148,8,36,40,51,16,4,39,40,8,128,32,39,2, -24,223,0,33,115,80,144,39,61,40,20,15,16,2,88,148,39,40,56,55,2, -19,223,0,33,116,80,144,39,56,40,20,15,16,2,88,148,8,36,41,58,16, -4,8,240,0,128,0,0,8,32,8,128,64,39,2,50,223,0,33,117,80,144, -39,8,44,42,20,15,16,2,88,148,8,36,42,52,16,4,39,39,8,128,64, -39,2,25,223,0,33,118,80,144,39,8,23,40,20,15,16,2,88,148,39,39, -56,55,9,223,0,33,119,80,144,39,8,45,42,20,15,16,2,88,148,8,36, -39,57,16,4,8,240,0,128,0,0,8,137,2,8,128,128,39,2,26,223,0, -33,120,80,144,39,8,24,40,20,15,16,2,247,22,143,2,80,144,39,8,25, -40,20,15,16,2,248,22,16,67,115,116,97,109,112,80,144,39,8,26,40,20, -15,16,2,88,148,39,40,49,8,240,0,0,0,4,9,223,0,33,122,80,144, -39,8,46,42,20,15,16,2,88,148,39,41,51,16,4,39,8,128,80,8,240, -0,64,0,0,39,2,29,223,0,33,130,2,80,144,39,8,27,40,20,15,16, -2,20,28,143,32,0,88,148,8,36,40,47,11,2,30,222,33,131,2,32,0, -88,148,8,36,40,47,11,2,30,222,33,132,2,80,144,39,8,29,40,20,15, -16,2,88,148,8,36,42,48,8,240,0,0,0,2,74,109,97,107,101,45,104, -97,110,100,108,101,114,223,0,33,134,2,80,144,39,8,47,42,20,15,16,2, -88,148,39,40,47,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,2, -31,223,0,33,144,2,80,144,39,8,30,40,20,15,16,2,88,148,39,41,59, -16,2,39,8,240,0,128,0,0,2,32,223,0,33,146,2,80,144,39,8,31, -40,20,15,16,2,88,148,8,36,41,61,16,4,39,8,240,0,64,0,0,39, -40,2,50,223,0,33,147,2,80,144,39,8,48,42,20,15,16,2,88,148,39, -47,8,33,16,4,39,39,40,41,67,99,108,111,111,112,223,0,33,154,2,80, -144,39,8,49,42,20,15,16,2,88,148,39,44,8,25,16,4,39,8,240,0, -192,0,0,39,42,2,16,223,0,33,155,2,80,144,39,52,40,20,15,16,2, -88,148,39,42,58,16,4,47,39,43,39,2,33,223,0,33,160,2,80,144,39, -8,32,40,20,15,16,2,32,0,88,148,39,42,53,11,2,35,222,33,161,2, -80,144,39,8,34,40,20,15,16,2,32,0,88,148,8,36,44,8,26,11,2, -36,222,33,164,2,80,144,39,8,35,40,20,15,16,2,32,0,88,148,8,36, -41,55,11,2,37,222,33,167,2,80,144,39,8,36,40,20,15,16,2,32,0, -88,148,8,36,41,55,11,2,34,222,33,170,2,80,144,39,8,33,40,20,15, -16,2,20,28,143,32,0,88,148,39,40,47,11,2,38,222,33,171,2,32,0, -88,148,39,40,47,11,2,38,222,33,172,2,80,144,39,8,37,40,20,15,16, -2,88,148,8,36,40,58,16,4,55,41,39,43,2,50,223,0,33,173,2,80, -144,39,8,50,42,20,15,16,2,88,148,8,36,40,58,16,4,55,41,39,47, -2,50,223,0,33,174,2,80,144,39,8,51,42,20,15,16,2,88,148,39,39, -56,55,9,223,0,33,175,2,80,144,39,8,52,42,20,15,16,2,88,148,8, -36,40,8,23,16,4,55,41,39,8,32,2,50,223,0,33,176,2,80,144,39, -8,53,42,20,15,16,2,20,26,96,2,39,88,148,39,39,60,16,4,8,32, -8,140,2,39,43,9,223,0,33,177,2,88,148,39,40,61,16,4,8,32,8, -140,2,39,47,9,223,0,33,178,2,88,148,39,41,8,30,16,4,8,48,8, -139,2,39,8,48,9,223,0,33,179,2,80,144,39,8,38,40,20,15,16,2, -88,148,8,36,40,60,16,4,8,128,6,39,39,8,64,2,50,223,0,33,180, -2,80,144,39,8,54,42,20,15,16,2,88,148,8,36,42,57,16,4,55,39, -39,8,64,2,40,223,0,33,182,2,80,144,39,8,39,40,95,29,94,2,10, -70,35,37,107,101,114,110,101,108,11,29,94,2,10,71,35,37,109,105,110,45, -115,116,120,11,2,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 19016); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,53,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23, -0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,181,0,191,0,199,0, -209,0,217,0,0,0,253,1,0,0,3,1,5,105,110,115,112,48,76,35,37, -112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,114,117,99,116,58, -84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,78,84,72,45,112, -108,97,99,101,45,99,104,97,110,110,101,108,79,84,72,45,112,108,97,99,101, -45,99,104,97,110,110,101,108,63,1,20,84,72,45,112,108,97,99,101,45,99, -104,97,110,110,101,108,45,114,101,102,1,21,84,72,45,112,108,97,99,101,45, -99,104,97,110,110,101,108,45,115,101,116,33,1,19,84,72,45,112,108,97,99, -101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108,97,99, -101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,144,41,42,42,23,196, -1,39,249,80,144,41,42,42,23,196,1,39,249,80,144,41,42,42,195,39,249, -80,144,41,42,42,23,196,1,40,249,80,144,41,42,42,195,40,145,40,9,20, -122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11, -11,11,11,11,11,11,9,9,11,11,11,10,49,80,143,39,39,20,122,145,2, -1,39,16,7,2,3,2,4,2,5,2,6,2,7,2,8,2,9,16,0,40, -42,39,16,0,39,16,2,2,6,2,7,41,11,11,11,16,5,2,4,2,8, -2,9,2,5,2,3,16,5,11,11,11,11,11,16,5,2,4,2,8,2,9, -2,5,2,3,44,44,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11, -11,16,0,16,0,16,0,39,39,16,3,20,15,16,6,253,22,141,11,2,4, -11,41,39,11,248,22,92,249,22,82,22,189,10,88,148,39,40,48,47,9,223, -9,33,10,80,144,39,39,40,80,144,39,40,40,80,144,39,41,40,80,144,39, -42,40,80,144,39,43,40,20,15,16,2,20,28,143,88,148,39,40,48,47,9, -223,0,33,11,88,148,39,40,48,47,9,223,0,33,12,80,144,39,44,40,20, -15,16,2,20,28,143,88,148,39,40,48,47,9,223,0,33,13,88,148,39,40, -48,47,9,223,0,33,14,80,144,39,45,40,93,29,94,67,113,117,111,116,101, -70,35,37,107,101,114,110,101,108,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 582); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,53,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,8,0,15, -0,26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0, -186,0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108, -1,113,1,131,1,137,1,142,1,147,1,156,1,162,1,167,1,171,1,186,1, -191,1,198,1,202,1,207,1,214,1,221,1,232,1,240,1,50,2,116,2,191, -2,10,3,116,3,159,3,9,4,52,4,149,4,192,4,33,5,76,5,9,13, -39,13,90,13,165,13,181,13,197,13,211,13,227,13,46,14,62,14,78,14,94, -14,169,14,76,15,92,15,167,15,162,16,42,17,117,17,24,18,37,18,190,18, -118,19,161,19,243,19,115,20,176,20,184,20,195,20,229,21,76,22,89,22,10, -23,17,23,177,23,21,24,43,24,53,24,67,24,105,24,204,24,208,24,215,24, -165,25,187,34,240,34,8,35,32,35,0,0,113,39,0,0,3,1,5,105,110, -115,112,48,68,35,37,98,111,111,116,72,100,108,108,45,115,117,102,102,105,120, -1,25,100,101,102,97,117,108,116,45,108,111,97,100,47,117,115,101,45,99,111, -109,112,105,108,101,100,67,113,117,111,116,101,29,94,2,5,70,35,37,112,97, -114,97,109,122,11,29,94,2,5,69,35,37,117,116,105,108,115,11,1,24,45, -109,111,100,117,108,101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98, -108,101,78,114,101,103,105,115,116,101,114,45,122,111,45,112,97,116,104,1,20, -100,101,102,97,117,108,116,45,114,101,97,100,101,114,45,103,117,97,114,100,69, -67,65,67,72,69,45,78,73,45,112,97,116,104,45,99,97,99,104,101,76,112, -97,116,104,45,99,97,99,104,101,45,103,101,116,77,112,97,116,104,45,99,97, -99,104,101,45,115,101,116,33,79,45,108,111,97,100,105,110,103,45,102,105,108, -101,110,97,109,101,1,19,45,108,111,97,100,105,110,103,45,112,114,111,109,112, -116,45,116,97,103,73,45,112,114,101,118,45,114,101,108,116,111,77,45,112,114, -101,118,45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114, -101,108,97,116,105,118,101,45,115,116,114,105,110,103,1,22,102,111,114,109,97, -116,45,115,111,117,114,99,101,45,108,111,99,97,116,105,111,110,73,111,114,105, -103,45,112,97,114,97,109,122,1,29,115,116,97,110,100,97,114,100,45,109,111, -100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,66,98,111, -111,116,66,115,101,97,108,79,108,111,97,100,47,117,115,101,45,99,111,109,112, -105,108,101,100,5,4,46,114,107,116,66,115,97,109,101,5,3,46,122,111,6, -6,6,110,97,116,105,118,101,67,105,108,111,111,112,66,108,111,111,112,65,108, -105,98,6,12,12,109,111,100,117,108,101,45,112,97,116,104,63,6,2,2,46, -46,68,115,117,98,109,111,100,6,1,1,46,66,102,105,108,101,68,112,108,97, -110,101,116,6,4,4,46,114,107,116,6,8,8,109,97,105,110,46,114,107,116, -69,105,103,110,111,114,101,100,250,22,152,16,28,249,22,182,9,23,201,2,2, -27,86,94,23,199,1,23,197,1,28,248,22,157,16,23,200,2,249,22,152,16, -23,199,1,23,201,1,249,80,144,46,45,42,23,199,1,23,201,1,23,200,1, -249,80,144,46,46,42,23,198,1,2,28,250,22,152,16,28,249,22,182,9,23, -201,2,2,27,86,94,23,199,1,23,197,1,28,248,22,157,16,23,200,2,249, -22,152,16,23,199,1,23,201,1,249,80,144,46,45,42,23,199,1,23,201,1, -23,200,1,249,80,144,46,46,42,23,198,1,2,28,252,22,152,16,28,249,22, -182,9,23,203,2,2,27,86,94,23,201,1,23,199,1,28,248,22,157,16,23, -202,2,249,22,152,16,23,201,1,23,203,1,249,80,144,48,45,42,23,201,1, -23,203,1,23,202,1,2,29,247,22,190,8,249,80,144,48,46,42,23,200,1, -80,144,48,39,41,252,22,152,16,28,249,22,182,9,23,203,2,2,27,86,94, -23,201,1,23,199,1,28,248,22,157,16,23,202,2,249,22,152,16,23,201,1, -23,203,1,249,80,144,48,45,42,23,201,1,23,203,1,23,202,1,2,29,247, -22,190,8,249,80,144,48,46,42,23,200,1,80,144,48,39,41,27,252,22,152, -16,28,249,22,182,9,23,205,2,2,27,86,94,23,203,1,23,201,1,28,248, -22,157,16,23,204,2,249,22,152,16,23,203,1,23,205,1,249,80,144,52,45, -42,23,203,1,23,205,1,23,205,1,2,29,247,22,190,8,249,80,144,52,46, -42,23,202,1,80,144,52,39,41,27,250,22,170,16,196,11,32,0,88,148,8, -36,39,44,11,9,222,11,28,192,249,22,82,195,28,196,194,39,11,249,22,5, -20,20,98,88,148,8,36,40,59,8,129,3,9,228,7,8,6,4,3,2,33, -46,23,195,1,23,196,1,23,197,1,23,199,1,23,201,1,23,198,1,27,252, -22,152,16,28,249,22,182,9,23,205,2,2,27,86,94,23,203,1,23,201,1, -28,248,22,157,16,23,204,2,249,22,152,16,23,203,1,23,205,1,249,80,144, -52,45,42,23,203,1,23,205,1,23,205,1,2,29,247,22,190,8,249,80,144, -52,46,42,23,202,1,80,144,52,39,41,27,250,22,170,16,196,11,32,0,88, -148,8,36,39,44,11,9,222,11,28,192,249,22,82,195,28,196,194,39,11,249, -22,5,20,20,98,88,148,8,36,40,59,8,129,3,9,228,7,8,6,4,3, -2,33,48,23,195,1,23,196,1,23,197,1,23,199,1,23,201,1,23,198,1, -27,250,22,152,16,28,249,22,182,9,23,203,2,2,27,86,94,23,201,1,23, -199,1,28,248,22,157,16,23,202,2,249,22,152,16,23,201,1,23,203,1,249, -80,144,50,45,42,23,201,1,23,203,1,23,203,1,249,80,144,50,46,42,23, -200,1,2,28,27,250,22,170,16,196,11,32,0,88,148,8,36,39,44,11,9, -222,11,28,192,249,22,82,195,28,196,194,39,11,249,22,5,20,20,98,88,148, -8,36,40,57,8,128,3,9,228,7,8,6,4,3,2,33,50,23,195,1,23, -196,1,23,197,1,23,199,1,23,201,1,23,198,1,27,250,22,152,16,28,249, -22,182,9,23,203,2,2,27,86,94,23,201,1,23,199,1,28,248,22,157,16, -23,202,2,249,22,152,16,23,201,1,23,203,1,249,80,144,50,45,42,23,201, -1,23,203,1,23,203,1,249,80,144,50,46,42,23,200,1,2,28,27,250,22, -170,16,196,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,82, -195,28,196,194,39,11,249,22,5,20,20,98,88,148,8,36,40,57,8,128,3, -9,228,7,8,6,4,3,2,33,52,23,195,1,23,196,1,23,197,1,23,199, -1,23,201,1,23,198,1,86,95,28,248,80,144,41,43,42,23,196,2,11,250, -22,134,12,2,25,6,12,12,112,97,116,104,45,115,116,114,105,110,103,63,23, -198,2,28,23,196,2,28,28,248,22,66,23,197,2,10,28,248,22,91,23,197, -2,28,249,22,177,20,248,22,96,23,199,2,40,28,28,248,22,66,248,22,83, -23,198,2,10,248,22,179,9,248,22,83,23,198,2,249,22,4,22,66,248,22, -84,23,199,2,11,11,11,11,250,22,134,12,2,25,6,71,71,40,111,114,47, -99,32,35,102,32,115,121,109,98,111,108,63,32,40,99,111,110,115,47,99,32, -40,111,114,47,99,32,35,102,32,115,121,109,98,111,108,63,41,32,40,110,111, -110,45,101,109,112,116,121,45,108,105,115,116,111,102,32,115,121,109,98,111,108, -63,41,41,41,23,198,2,11,27,28,23,197,2,247,22,134,5,11,27,28,23, -194,2,250,22,161,2,80,143,45,44,248,22,153,17,247,22,165,14,11,11,27, -28,23,194,2,250,22,161,2,248,22,84,23,198,2,23,198,2,11,11,28,23, -193,2,86,97,23,198,1,23,196,1,23,195,1,23,194,1,20,13,144,80,144, -43,41,40,250,80,144,46,42,40,249,22,31,11,80,144,48,41,40,22,135,5, -248,22,105,23,197,2,27,248,22,114,23,195,2,20,13,144,80,144,44,41,40, -250,80,144,47,42,40,249,22,31,11,80,144,49,41,40,22,186,5,28,248,22, -134,16,23,197,2,23,196,1,86,94,23,196,1,247,22,176,16,249,247,22,184, -5,248,22,190,20,23,197,1,23,202,1,86,94,23,193,1,27,28,248,22,159, -16,23,200,2,23,199,2,27,247,22,186,5,28,192,249,22,160,16,23,202,2, -194,23,200,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,203,1,86, -94,23,195,1,90,144,41,11,89,146,41,39,11,28,23,205,2,27,248,22,139, -16,23,198,2,19,248,22,156,8,194,28,28,249,22,179,20,23,195,4,43,249, -22,159,8,2,26,249,22,162,8,197,249,22,190,3,23,199,4,43,11,249,22, -7,23,200,2,248,22,143,16,249,22,163,8,250,22,162,8,201,39,249,22,190, -3,23,203,4,43,5,3,46,115,115,249,22,7,23,200,2,11,2,249,22,7, -23,198,2,11,27,28,249,22,182,9,23,196,2,23,199,2,23,199,2,249,22, -152,16,23,198,2,23,196,2,27,28,23,196,2,28,249,22,182,9,23,198,2, -23,200,1,23,200,1,86,94,23,200,1,249,22,152,16,23,199,2,23,198,2, -86,95,23,200,1,23,198,1,11,27,28,249,22,182,9,23,200,2,70,114,101, -108,97,116,105,118,101,86,94,23,198,1,2,27,23,198,1,27,247,22,181,16, -27,247,22,182,16,27,27,250,22,170,16,23,202,2,11,32,0,88,148,8,36, -39,44,11,9,222,11,28,192,249,22,82,23,201,2,28,23,211,2,194,39,11, -27,28,23,198,2,28,23,194,2,11,27,250,22,170,16,23,202,2,11,32,0, -88,148,8,36,39,44,11,9,222,11,28,192,249,22,82,23,201,2,28,23,212, -2,194,39,11,11,27,28,23,195,2,23,195,2,23,194,2,27,88,148,8,36, -41,54,8,128,3,64,122,111,225,19,6,9,33,42,27,88,148,8,36,41,54, -8,128,3,68,97,108,116,45,122,111,225,20,7,11,33,43,27,88,148,8,36, -41,56,8,129,3,9,225,21,8,11,33,44,27,88,148,8,36,41,56,8,129, -3,9,225,22,9,13,33,45,27,28,23,200,2,23,200,2,248,22,179,9,23, -200,2,27,28,23,208,2,28,23,200,2,86,94,23,201,1,23,200,2,248,22, -179,9,23,202,1,86,94,23,201,1,11,27,28,23,195,2,27,249,22,5,20, -20,94,88,148,39,40,53,8,129,3,9,228,28,7,14,15,18,27,33,47,23, -200,1,23,206,2,27,28,23,202,2,11,193,28,192,192,28,193,28,23,202,2, -28,249,22,138,4,248,22,84,196,248,22,84,23,205,2,193,11,11,11,86,94, -23,197,1,11,28,23,193,2,86,109,23,217,1,23,216,1,23,215,1,23,209, -1,23,208,1,23,207,1,23,206,1,23,204,1,23,203,1,23,201,1,23,200, -1,23,199,1,23,198,1,23,196,1,23,195,1,23,194,1,20,13,144,80,144, -8,25,41,40,250,80,144,8,28,42,40,249,22,31,11,80,144,8,30,41,40, -22,135,5,11,20,13,144,80,144,8,25,41,40,250,80,144,8,28,42,40,249, -22,31,11,80,144,8,30,41,40,22,186,5,28,248,22,134,16,23,209,2,23, -208,1,86,94,23,208,1,247,22,176,16,249,247,22,187,16,248,22,83,23,196, -1,23,222,1,86,94,23,193,1,27,28,23,195,2,27,249,22,5,20,20,94, -88,148,39,40,53,8,129,3,9,228,29,7,15,16,20,28,33,49,23,200,1, -23,207,2,27,28,23,204,2,11,193,28,192,86,94,23,204,1,192,28,193,28, -203,28,249,22,138,4,248,22,84,196,248,22,84,206,193,11,11,11,86,94,23, -197,1,11,28,23,193,2,86,106,23,218,1,23,217,1,23,216,1,23,210,1, -23,209,1,23,208,1,23,205,1,23,204,1,23,201,1,23,200,1,23,199,1, -23,196,1,23,195,1,20,13,144,80,144,8,26,41,40,250,80,144,8,29,42, -40,249,22,31,11,80,144,8,31,41,40,22,135,5,23,210,1,20,13,144,80, -144,8,26,41,40,250,80,144,8,29,42,40,249,22,31,11,80,144,8,31,41, -40,22,186,5,28,248,22,134,16,23,210,2,23,209,1,86,94,23,209,1,247, -22,176,16,249,247,22,187,16,248,22,83,23,196,1,23,223,1,86,94,23,193, -1,27,28,23,197,2,27,249,22,5,20,20,95,88,148,39,40,53,8,128,3, -9,228,30,11,16,17,20,29,33,51,23,213,1,23,204,1,23,208,2,27,28, -23,204,2,11,193,28,192,192,28,193,28,23,204,2,28,249,22,138,4,248,22, -84,196,248,22,84,23,207,2,193,11,11,11,86,95,23,210,1,23,201,1,11, -28,23,193,2,86,103,23,219,1,23,211,1,23,209,1,23,208,1,23,206,1, -23,205,1,23,202,1,23,200,1,23,197,1,23,196,1,86,94,252,80,143,8, -32,47,23,223,1,23,222,1,248,22,83,23,199,2,11,23,212,2,20,13,144, -80,144,8,27,41,40,250,80,144,8,30,42,40,249,22,31,11,80,144,8,32, -41,40,22,135,5,11,20,13,144,80,144,8,27,41,40,250,80,144,8,30,42, -40,249,22,31,11,80,144,8,32,41,40,22,186,5,28,248,22,134,16,23,211, -2,23,210,1,86,94,23,210,1,247,22,176,16,249,247,22,184,5,248,22,190, -20,23,196,1,23,224,32,0,0,0,1,86,94,23,193,1,27,28,23,197,1, -27,249,22,5,20,20,97,88,148,39,40,53,8,128,3,9,228,31,11,17,18, -22,30,33,53,23,223,1,23,215,1,23,210,1,23,204,1,23,209,1,27,28, -23,205,2,11,193,28,192,86,94,23,205,1,192,28,193,28,204,28,249,22,138, -4,248,22,84,196,248,22,84,23,15,193,11,11,11,86,98,23,220,1,23,212, -1,23,207,1,23,206,1,23,201,1,11,28,23,193,2,86,95,23,210,1,23, -198,1,86,94,252,80,143,8,33,47,23,224,32,0,0,0,1,23,223,1,248, -22,83,23,199,2,23,214,2,23,213,2,20,13,144,80,144,8,28,41,40,250, -80,144,8,31,42,40,249,22,31,11,80,144,8,33,41,40,22,135,5,23,212, -1,20,13,144,80,144,8,28,41,40,250,80,144,8,31,42,40,249,22,31,11, -80,144,8,33,41,40,22,186,5,28,248,22,134,16,23,212,2,23,211,1,86, -94,23,211,1,247,22,176,16,249,247,22,184,5,248,22,190,20,23,196,1,23, -224,33,0,0,0,1,86,96,23,219,1,23,218,1,23,193,1,28,28,248,22, -80,23,224,32,0,0,0,2,248,22,190,20,23,224,32,0,0,0,2,10,27, -28,23,199,2,86,94,23,210,1,23,211,1,86,94,23,211,1,23,210,1,28, -28,248,22,80,23,224,33,0,0,0,2,248,22,179,9,248,22,146,16,23,195, -2,11,12,20,13,144,80,144,8,29,41,40,250,80,144,8,32,42,40,249,22, -31,11,80,144,8,34,41,40,22,135,5,28,23,224,35,0,0,0,2,28,23, -202,1,11,23,196,2,86,94,23,202,1,11,20,13,144,80,144,8,29,41,40, -250,80,144,8,32,42,40,249,22,31,11,80,144,8,34,41,40,22,186,5,28, -248,22,134,16,23,213,2,23,212,1,86,94,23,212,1,247,22,176,16,249,247, -22,184,5,23,195,1,23,224,34,0,0,0,1,12,28,23,194,2,250,22,159, -2,248,22,84,23,198,1,23,196,1,250,22,92,23,201,1,23,202,1,23,203, -1,12,27,249,22,134,9,80,144,42,50,41,249,22,133,4,248,22,129,4,248, -22,179,2,200,8,128,8,27,28,193,248,22,182,2,194,11,28,192,27,249,22, -103,198,195,28,192,248,22,84,193,11,11,27,249,22,133,4,248,22,129,4,248, -22,179,2,23,199,2,8,128,8,27,249,22,134,9,80,144,43,50,41,23,196, -2,250,22,135,9,80,144,44,50,41,23,197,1,248,22,181,2,249,22,82,249, -22,82,23,204,1,23,205,1,27,28,23,200,2,248,22,182,2,200,11,28,192, -192,9,32,58,88,149,8,38,42,54,11,2,30,39,223,48,33,73,32,59,88, -149,8,38,42,53,11,2,30,39,223,48,33,72,32,60,88,148,8,36,40,53, -11,2,31,222,33,71,32,61,88,149,8,38,42,53,11,2,30,39,223,48,33, -62,28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9, -7,47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198, -2,39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201, -1,250,2,61,195,23,197,4,248,22,187,3,198,32,63,88,149,8,38,42,55, -11,2,30,39,223,48,33,70,32,64,88,149,8,38,42,54,11,2,30,39,223, -48,33,67,32,65,88,149,8,38,42,53,11,2,30,39,223,48,33,66,28,249, -22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7,47,249, -22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2,39,23, -200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1,250,2, -65,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23,196,4, -248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23,199,2, -249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7,23,198, -1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,65,23,197, -1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4,23,195, -2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7,23,198, -2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,248,2,60, -249,22,184,7,23,199,1,248,22,187,3,23,199,1,250,2,64,196,23,198,4, -248,22,187,3,196,32,68,88,149,8,38,42,53,11,2,30,39,223,48,33,69, -28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7, -47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2, -39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1, -250,2,68,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23, -196,4,248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23, -199,2,249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7, -23,198,1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,64, -23,197,1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4, -23,195,2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7, -23,198,2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,27, -249,22,184,7,23,199,1,248,22,187,3,23,199,1,19,248,22,165,7,23,195, -2,250,2,68,23,197,1,23,196,4,39,2,27,248,22,187,3,23,195,1,28, -249,22,134,4,23,195,2,23,198,4,248,22,92,195,28,249,22,149,9,7,47, -249,22,166,7,23,199,2,23,197,2,249,22,82,250,22,184,7,23,200,2,39, -23,198,2,248,2,60,249,22,184,7,23,200,1,248,22,187,3,23,199,1,250, -2,63,197,23,199,4,248,22,187,3,196,19,248,22,165,7,23,195,2,28,249, -22,175,20,39,23,195,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166, -7,23,198,2,39,249,22,82,250,22,184,7,23,199,2,39,39,27,249,22,184, -7,23,199,1,40,19,248,22,165,7,23,195,2,250,2,61,23,197,1,23,196, -4,39,2,28,249,22,175,20,40,23,195,4,248,22,92,194,28,249,22,149,9, -7,47,249,22,166,7,23,198,2,40,249,22,82,250,22,184,7,23,199,2,39, -40,248,2,60,249,22,184,7,23,199,1,41,250,2,63,196,23,196,4,41,2, -28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7, -47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2, -39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1, -250,2,59,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23, -196,4,248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23, -199,2,249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7, -23,198,1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,59, -23,197,1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4, -23,195,2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7, -23,198,2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,248, -2,60,249,22,184,7,23,199,1,248,22,187,3,23,199,1,250,2,58,196,23, -198,4,248,22,187,3,196,32,74,88,148,39,40,58,11,2,31,222,33,75,28, -248,22,90,248,22,84,23,195,2,249,22,7,9,248,22,190,20,23,196,1,90, -144,41,11,89,146,41,39,11,27,248,22,191,20,23,197,2,28,248,22,90,248, -22,84,23,195,2,249,22,7,9,248,22,190,20,195,90,144,41,11,89,146,41, -39,11,27,248,22,191,20,196,28,248,22,90,248,22,84,23,195,2,249,22,7, -9,248,22,190,20,195,90,144,41,11,89,146,41,39,11,248,2,74,248,22,191, -20,196,249,22,7,249,22,82,248,22,190,20,199,196,195,249,22,7,249,22,82, -248,22,190,20,199,196,195,249,22,7,249,22,82,248,22,190,20,23,200,1,23, -197,1,23,196,1,27,19,248,22,165,7,23,196,2,250,2,58,23,198,1,23, -196,4,39,2,28,23,195,1,192,28,248,22,90,248,22,84,23,195,2,249,22, -7,9,248,22,190,20,23,196,1,27,248,22,191,20,23,195,2,90,144,41,11, -89,146,41,39,11,28,248,22,90,248,22,84,23,197,2,249,22,7,9,248,22, -190,20,23,198,1,27,248,22,191,20,23,197,2,90,144,41,11,89,146,41,39, -11,28,248,22,90,248,22,84,23,197,2,249,22,7,9,248,22,190,20,197,90, -144,41,11,89,146,41,39,11,248,2,74,248,22,191,20,198,249,22,7,249,22, -82,248,22,190,20,201,196,195,249,22,7,249,22,82,248,22,190,20,23,203,1, -196,195,249,22,7,249,22,82,248,22,190,20,23,201,1,23,197,1,23,196,1, -248,22,160,12,252,22,176,10,248,22,169,4,23,200,2,248,22,165,4,23,200, -2,248,22,166,4,23,200,2,248,22,167,4,23,200,2,248,22,168,4,23,200, -1,28,24,194,2,12,20,13,144,80,144,39,41,40,80,143,39,59,89,146,40, -40,10,249,22,137,5,21,94,2,32,6,19,19,112,108,97,110,101,116,47,114, -101,115,111,108,118,101,114,46,114,107,116,1,27,112,108,97,110,101,116,45,109, -111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,27, -28,23,195,2,28,249,22,182,9,23,197,2,80,143,42,55,86,94,23,195,1, -80,143,40,56,27,248,22,161,5,23,197,2,27,28,248,22,80,23,195,2,248, -22,190,20,23,195,1,23,194,1,28,248,22,134,16,23,194,2,90,144,42,11, -89,146,42,39,11,248,22,155,16,23,197,1,86,95,20,18,144,11,80,143,45, -55,199,20,18,144,11,80,143,45,56,192,192,86,94,23,193,1,11,86,94,23, -195,1,11,28,23,193,2,192,27,247,22,186,5,28,23,193,2,192,247,22,176, -16,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,2,86,95,23,195, -1,23,193,1,28,249,22,128,17,0,11,35,114,120,34,91,46,93,115,115,36, -34,248,22,139,16,23,197,1,249,80,144,44,61,42,23,199,1,2,26,196,249, -80,144,41,57,42,195,10,249,22,12,23,196,1,80,144,41,54,41,86,96,28, -248,22,159,5,23,196,2,11,250,22,134,12,2,22,6,21,21,114,101,115,111, -108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,63,23,198,2,28, -23,196,2,28,248,22,166,14,23,197,2,11,250,22,134,12,2,22,6,20,20, -40,111,114,47,99,32,35,102,32,110,97,109,101,115,112,97,99,101,63,41,23, -199,2,11,28,24,193,2,248,24,194,1,23,196,2,86,94,23,193,1,11,27, -250,22,161,2,80,144,44,44,41,248,22,153,17,247,22,165,14,11,27,28,23, -194,2,23,194,1,86,94,23,194,1,27,249,22,82,247,22,141,2,247,22,141, -2,86,94,250,22,159,2,80,144,46,44,41,248,22,153,17,247,22,165,14,195, -192,86,94,250,22,159,2,248,22,83,23,197,2,23,200,2,70,100,101,99,108, -97,114,101,100,28,23,198,2,27,28,248,22,80,248,22,161,5,23,200,2,248, -22,160,5,248,22,83,248,22,161,5,23,201,1,23,198,1,27,250,22,161,2, -80,144,47,44,41,248,22,153,17,23,204,1,11,28,23,193,2,27,250,22,161, -2,248,22,84,23,198,1,23,198,2,11,28,23,193,2,250,22,159,2,248,22, -191,20,23,200,1,23,198,1,23,196,1,12,12,12,86,94,251,22,155,12,247, -22,159,12,67,101,114,114,111,114,6,69,69,100,101,102,97,117,108,116,32,109, -111,100,117,108,101,32,110,97,109,101,32,114,101,115,111,108,118,101,114,32,99, -97,108,108,101,100,32,119,105,116,104,32,116,104,114,101,101,32,97,114,103,117, -109,101,110,116,115,32,40,100,101,112,114,101,99,97,116,101,100,41,11,251,24, -197,1,23,198,1,23,199,1,23,200,1,10,32,85,88,148,39,43,57,11,2, -31,222,33,86,28,248,22,90,23,197,2,28,248,22,90,195,193,249,22,82,195, -248,22,98,197,28,249,22,184,9,248,22,83,23,199,2,2,34,28,248,22,90, -23,196,2,86,95,23,196,1,23,195,1,250,22,130,12,2,22,6,37,37,116, -111,111,32,109,97,110,121,32,34,46,46,34,115,32,105,110,32,115,117,98,109, -111,100,117,108,101,32,112,97,116,104,58,32,126,46,115,250,22,93,2,35,28, -249,22,184,9,23,202,2,2,36,23,200,1,28,248,22,134,16,23,201,2,23, -200,1,249,22,92,28,248,22,66,23,203,2,2,5,2,37,23,202,1,23,199, -1,251,2,85,196,197,248,22,84,199,248,22,191,20,200,251,2,85,196,197,249, -22,82,248,22,190,20,202,200,248,22,191,20,200,251,2,85,197,196,9,197,27, -250,22,185,7,27,28,23,198,2,28,247,22,147,12,248,80,144,47,58,42,23, -199,2,11,11,28,192,192,6,29,29,115,116,97,110,100,97,114,100,45,109,111, -100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,6,2,2, -58,32,250,22,139,17,0,7,35,114,120,34,92,110,34,23,203,1,249,22,146, -8,6,23,23,10,32,32,102,111,114,32,109,111,100,117,108,101,32,112,97,116, -104,58,32,126,115,10,23,203,2,248,22,129,14,28,23,195,2,251,22,137,13, -23,198,1,247,22,27,248,22,92,23,200,1,23,200,1,86,94,23,195,1,250, -22,164,13,23,197,1,247,22,27,23,199,1,19,248,22,165,7,194,28,249,22, -179,20,23,195,4,42,28,249,22,182,9,7,46,249,22,166,7,197,249,22,190, -3,23,199,4,42,28,28,249,22,182,9,7,115,249,22,166,7,197,249,22,190, -3,23,199,4,41,249,22,182,9,7,115,249,22,166,7,197,249,22,190,3,23, -199,4,40,11,249,22,185,7,250,22,184,7,198,39,249,22,190,3,23,200,4, -42,2,39,193,193,193,2,28,249,22,168,7,194,2,36,2,27,28,249,22,168, -7,194,2,34,64,117,112,192,0,8,35,114,120,34,91,46,93,34,32,92,88, -148,8,36,40,50,11,2,31,222,33,93,28,248,22,90,23,194,2,9,250,22, -93,6,4,4,10,32,32,32,248,22,138,16,248,22,106,23,198,2,248,2,92, -248,22,191,20,23,198,1,28,249,22,184,9,248,22,84,23,200,2,23,196,1, -28,249,22,182,9,248,22,190,20,23,200,1,23,198,1,251,22,130,12,2,22, -6,41,41,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,10,32, -32,97,116,32,112,97,116,104,58,32,126,97,10,32,32,112,97,116,104,115,58, -126,97,23,197,1,249,22,1,22,185,7,248,2,92,248,22,98,23,203,1,12, -12,247,23,193,1,250,22,163,4,11,196,195,20,13,144,80,144,49,53,41,249, -22,82,249,22,82,23,206,1,23,201,1,23,203,1,20,13,144,80,144,49,41, -40,252,80,144,54,42,40,249,22,31,11,80,144,56,41,40,22,134,5,23,204, -2,22,136,5,248,28,23,199,2,20,20,94,88,148,8,36,40,49,11,9,223, -6,33,96,23,199,1,86,94,23,199,1,22,7,28,248,22,66,23,201,2,23, -200,1,28,28,248,22,80,23,201,2,249,22,182,9,248,22,190,20,23,203,2, -2,32,11,23,200,1,86,94,23,200,1,28,248,22,159,5,23,206,2,27,248, -22,161,5,23,207,2,28,248,22,66,193,249,22,92,2,5,194,192,23,205,2, -249,247,22,185,5,23,198,1,27,248,22,70,248,22,138,16,23,203,1,28,23, -198,2,28,250,22,161,2,248,22,190,20,23,207,1,23,205,1,11,249,22,82, -11,199,249,22,82,194,199,192,86,96,28,248,22,170,5,23,196,2,11,28,248, -22,161,4,23,198,2,250,22,132,12,11,6,15,15,98,97,100,32,109,111,100, -117,108,101,32,112,97,116,104,23,200,2,250,22,134,12,2,22,2,33,23,198, -2,28,23,196,2,28,248,22,159,5,23,197,2,11,250,22,134,12,2,22,6, -31,31,40,111,114,47,99,32,35,102,32,114,101,115,111,108,118,101,100,45,109, -111,100,117,108,101,45,112,97,116,104,63,41,23,199,2,11,28,23,197,2,28, -248,22,161,4,23,198,2,11,250,22,134,12,2,22,6,17,17,40,111,114,47, -99,32,35,102,32,115,121,110,116,97,120,63,41,23,200,2,11,27,32,0,88, -148,39,41,50,11,78,102,108,97,116,116,101,110,45,115,117,98,45,112,97,116, -104,222,33,87,28,28,248,22,80,23,197,2,249,22,182,9,248,22,190,20,23, -199,2,2,5,11,86,98,23,199,1,23,198,1,23,197,1,23,194,1,23,193, -1,248,22,160,5,248,22,105,23,198,1,28,28,248,22,80,23,197,2,28,249, -22,182,9,248,22,190,20,23,199,2,2,35,28,248,22,80,248,22,105,23,198, -2,249,22,182,9,248,22,109,23,199,2,2,5,11,11,11,86,97,23,199,1, -23,198,1,23,197,1,23,194,1,248,22,160,5,249,23,196,1,248,22,122,23, -200,2,248,22,107,23,200,1,28,28,248,22,80,23,197,2,28,249,22,182,9, -248,22,190,20,23,199,2,2,35,28,28,249,22,184,9,248,22,105,23,199,2, -2,36,10,249,22,184,9,248,22,105,23,199,2,2,34,28,23,197,2,27,248, -22,161,5,23,199,2,28,248,22,66,193,10,28,248,22,80,193,248,22,66,248, -22,190,20,194,11,11,11,11,11,86,96,23,199,1,23,198,1,23,194,1,27, -248,22,161,5,23,199,1,248,22,160,5,249,23,197,1,28,248,22,80,23,197, -2,248,22,190,20,23,197,2,23,196,2,27,28,249,22,184,9,248,22,105,23, -204,2,2,34,248,22,191,20,201,248,22,107,201,28,248,22,80,23,198,2,249, -22,97,248,22,191,20,199,194,192,28,28,248,22,80,23,197,2,249,22,182,9, -248,22,190,20,23,199,2,2,38,11,86,94,23,193,1,86,94,248,80,144,42, -8,28,42,23,195,2,253,24,200,1,23,202,1,23,203,1,23,204,1,23,205, -1,11,80,143,47,59,28,28,248,22,80,23,197,2,28,249,22,182,9,248,22, -190,20,23,199,2,2,35,28,248,22,80,248,22,105,23,198,2,249,22,182,9, -248,22,109,23,199,2,2,38,11,11,11,86,94,23,193,1,86,94,248,80,144, -42,8,28,42,23,195,2,253,24,200,1,248,22,105,23,203,2,23,203,1,23, -204,1,23,205,1,248,22,107,23,203,1,80,143,47,59,86,94,23,194,1,27, -88,148,8,36,40,57,8,240,0,0,8,0,1,19,115,104,111,119,45,99,111, -108,108,101,99,116,105,111,110,45,101,114,114,225,3,4,6,33,88,27,32,0, -88,148,8,36,40,53,11,69,115,115,45,62,114,107,116,222,33,89,27,28,248, -22,80,23,200,2,28,249,22,182,9,2,35,248,22,190,20,23,202,2,27,248, -22,105,23,201,2,28,28,249,22,184,9,23,195,2,2,36,10,249,22,184,9, -23,195,2,2,34,86,94,23,193,1,28,23,201,2,27,248,22,161,5,23,203, -2,28,248,22,80,193,248,22,190,20,193,192,250,22,130,12,2,22,6,45,45, -110,111,32,98,97,115,101,32,112,97,116,104,32,102,111,114,32,114,101,108,97, -116,105,118,101,32,115,117,98,109,111,100,117,108,101,32,112,97,116,104,58,32, -126,46,115,23,203,2,192,23,199,2,23,199,2,27,28,248,22,80,23,201,2, -28,249,22,182,9,2,35,248,22,190,20,23,203,2,27,28,28,249,22,184,9, -248,22,105,23,204,2,2,36,23,202,2,28,249,22,184,9,248,22,105,23,204, -2,2,34,23,202,2,11,27,248,22,161,5,23,204,2,27,28,249,22,184,9, -248,22,105,23,206,2,2,34,248,22,191,20,23,204,1,248,22,107,23,204,1, -28,248,22,80,23,195,2,249,23,202,1,248,22,190,20,23,197,2,249,22,97, -248,22,191,20,23,199,1,23,197,1,249,23,202,1,23,196,1,23,195,1,249, -23,200,1,2,36,28,249,22,184,9,248,22,105,23,206,2,2,34,248,22,191, -20,23,204,1,248,22,107,23,204,1,28,248,22,80,193,248,22,191,20,193,11, -86,95,23,200,1,23,197,1,11,86,95,23,200,1,23,197,1,11,27,28,248, -22,66,23,196,2,86,94,23,196,1,27,248,80,144,48,51,42,249,22,82,23, -199,2,248,22,153,17,247,22,165,14,28,23,193,2,86,94,23,198,1,192,90, -144,41,11,89,146,41,39,11,249,80,144,51,57,42,248,22,73,23,201,2,11, -27,28,248,22,90,23,195,2,2,40,249,22,185,7,23,197,2,2,39,252,80, -144,55,8,23,42,23,206,1,28,248,22,90,23,200,2,23,200,1,86,94,23, -200,1,248,22,83,23,200,2,28,248,22,90,23,200,2,86,94,23,199,1,9, -248,22,84,23,200,1,23,198,1,10,28,248,22,162,7,23,196,2,86,94,23, -197,1,27,248,80,144,48,8,29,42,23,204,2,27,248,80,144,49,51,42,249, -22,82,23,200,2,23,197,2,28,23,193,2,86,95,23,198,1,23,194,1,192, -90,144,41,11,89,146,41,39,11,249,80,144,52,57,42,23,201,2,11,28,248, -22,90,23,194,2,86,94,23,193,1,249,22,152,16,23,198,1,248,23,203,1, -23,197,1,250,22,1,22,152,16,23,199,1,249,22,97,249,22,2,32,0,88, -148,8,36,40,47,11,9,222,33,90,23,200,1,248,22,92,248,23,207,1,23, -201,1,28,248,22,134,16,23,196,2,86,95,23,197,1,23,196,1,248,80,144, -47,8,30,42,248,22,162,16,28,248,22,159,16,23,198,2,23,197,2,249,22, -160,16,23,199,2,248,80,144,51,8,29,42,23,207,2,28,249,22,182,9,248, -22,83,23,198,2,2,32,27,248,80,144,48,51,42,249,22,82,23,199,2,248, -22,153,17,247,22,165,14,28,23,193,2,86,95,23,198,1,23,197,1,192,90, -144,41,11,89,146,41,39,11,249,80,144,51,57,42,248,22,105,23,201,2,11, -27,28,248,22,90,248,22,107,23,201,2,28,248,22,90,23,195,2,249,22,132, -17,2,91,23,197,2,11,10,27,28,23,194,2,248,23,202,1,23,197,2,28, -248,22,90,23,196,2,86,94,23,201,1,2,40,28,249,22,132,17,2,91,23, -198,2,248,23,202,1,23,197,2,86,94,23,201,1,249,22,185,7,23,198,2, -2,39,27,28,23,195,1,86,94,23,197,1,249,22,97,28,248,22,90,248,22, -107,23,205,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,97,249,22, -2,80,144,58,8,31,42,248,22,107,23,208,2,23,198,1,28,248,22,90,23, -197,2,86,94,23,196,1,248,22,92,23,198,1,86,94,23,197,1,23,196,1, -252,80,144,57,8,23,42,23,208,1,248,22,83,23,199,2,248,22,191,20,23, -199,1,23,199,1,10,86,95,23,197,1,23,196,1,28,249,22,182,9,248,22, -190,20,23,198,2,2,37,248,80,144,47,8,30,42,248,22,162,16,249,22,160, -16,248,22,164,16,248,22,105,23,201,2,248,80,144,51,8,29,42,23,207,2, -12,86,94,28,248,22,134,16,23,194,2,11,28,248,22,129,9,23,194,2,11, -28,23,203,2,250,22,132,12,69,114,101,113,117,105,114,101,249,22,146,8,6, -17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23, -198,2,248,22,83,23,199,2,6,0,0,23,206,2,250,22,134,12,2,22,2, -33,23,198,2,27,28,248,22,129,9,23,195,2,249,22,134,9,23,196,2,39, -249,22,162,16,248,22,163,16,23,197,2,11,27,28,248,22,129,9,23,196,2, -249,22,134,9,23,197,2,40,248,80,144,49,8,24,42,23,195,2,90,144,42, -11,89,146,42,39,11,28,248,22,129,9,23,199,2,250,22,7,2,41,249,22, -134,9,23,203,2,41,2,41,248,22,155,16,23,198,2,86,95,23,195,1,23, -193,1,27,28,248,22,129,9,23,200,2,249,22,134,9,23,201,2,42,249,80, -144,54,61,42,23,197,2,5,0,27,28,248,22,129,9,23,201,2,249,22,134, -9,23,202,2,43,248,22,160,5,23,200,2,27,250,22,161,2,80,144,57,44, -41,248,22,153,17,247,22,165,14,11,27,28,23,194,2,23,194,1,86,94,23, -194,1,27,249,22,82,247,22,141,2,247,22,141,2,86,94,250,22,159,2,80, -144,59,44,41,248,22,153,17,247,22,165,14,195,192,27,28,23,204,2,248,22, -160,5,249,22,82,248,22,161,5,23,200,2,23,207,2,23,196,2,86,95,28, -23,214,2,28,250,22,161,2,248,22,83,23,198,2,195,11,86,96,23,213,1, -23,204,1,23,194,1,11,27,251,22,31,11,80,144,61,53,41,9,28,248,22, -15,80,144,8,23,54,41,80,144,61,54,41,247,22,17,27,248,22,153,17,247, -22,165,14,86,94,249,22,3,88,148,8,36,40,57,11,9,226,2,3,12,13, -33,94,23,196,2,248,28,248,22,15,80,144,60,54,41,32,0,88,148,39,40, -45,11,9,222,33,95,80,144,59,8,32,42,20,20,98,88,148,39,39,8,25, -8,240,12,64,0,0,9,233,20,1,2,4,6,7,11,12,14,15,23,33,97, -23,216,1,23,207,1,23,197,1,23,195,1,23,194,1,86,96,23,213,1,23, -204,1,23,194,1,11,28,248,22,129,9,23,204,1,11,28,23,214,1,28,28, -248,22,162,7,23,206,2,10,28,248,22,66,23,206,2,10,28,248,22,80,23, -206,2,249,22,182,9,248,22,190,20,23,208,2,2,32,11,249,80,144,58,52, -42,28,248,22,162,7,23,208,2,249,22,82,23,209,1,248,80,144,61,8,29, -42,23,217,1,86,94,23,214,1,249,22,82,23,209,1,248,22,153,17,247,22, -165,14,252,22,131,9,23,209,1,23,208,1,23,206,1,23,204,1,23,203,1, -11,11,192,86,96,20,18,144,11,80,143,39,59,248,80,144,40,8,27,40,249, -22,31,11,80,144,42,41,40,248,22,133,5,80,144,40,60,41,248,22,185,5, -80,144,40,40,41,248,22,164,15,80,144,40,48,42,20,18,144,11,80,143,39, -59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,20,18,144,11, -80,143,39,59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,145, -40,9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2, -2,29,11,11,11,11,11,11,11,9,9,11,11,11,10,43,80,143,39,39,20, -122,145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5,30,2,6,1, -23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116, -105,111,110,11,4,30,2,7,74,112,97,116,104,45,115,116,114,105,110,103,63, -42,196,15,2,8,30,2,7,73,114,101,114,111,111,116,45,112,97,116,104,44, -196,16,30,2,7,1,18,112,97,116,104,45,97,100,100,45,101,120,116,101,110, -115,105,111,110,44,196,12,2,9,2,10,2,11,2,12,2,13,2,14,2,15, -2,16,2,17,2,18,2,19,2,20,2,21,2,22,30,2,7,1,22,112,97, -116,104,45,114,101,112,108,97,99,101,45,101,120,116,101,110,115,105,111,110,44, -196,14,30,2,7,75,102,105,110,100,45,99,111,108,45,102,105,108,101,49,196, -4,30,2,7,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104, -42,196,11,2,23,2,24,30,2,6,76,114,101,112,97,114,97,109,101,116,101, -114,105,122,101,11,6,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2, -8,2,12,2,17,2,18,2,11,2,4,2,10,2,3,2,20,2,13,2,14, -2,9,2,19,2,22,55,11,11,11,16,3,2,23,2,21,2,24,16,3,11, -11,11,16,3,2,23,2,21,2,24,42,42,40,12,11,11,16,0,16,0,16, -0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,24,20,15,16,2, -248,22,189,8,71,115,111,45,115,117,102,102,105,120,80,144,39,39,40,20,15, -16,2,27,249,22,182,9,247,22,185,16,76,109,111,100,105,102,121,45,115,101, -99,111,110,100,115,88,148,39,41,8,42,8,189,7,2,4,224,1,0,33,54, -80,144,39,40,40,20,15,16,2,32,0,88,148,8,36,44,55,11,2,9,222, -33,55,80,144,39,47,40,20,15,16,2,20,28,143,32,0,88,148,8,36,40, -45,11,2,10,222,192,32,0,88,148,8,36,40,45,11,2,10,222,192,80,144, -39,48,40,20,15,16,2,247,22,144,2,80,144,39,44,40,20,15,16,2,8, -128,8,80,144,39,49,40,20,15,16,2,249,22,130,9,8,128,8,11,80,144, -39,50,40,20,15,16,2,88,148,8,36,40,53,8,128,32,2,13,223,0,33, -56,80,144,39,51,40,20,15,16,2,88,148,8,36,41,57,8,128,32,2,14, -223,0,33,57,80,144,39,52,40,20,15,16,2,247,22,78,80,144,39,53,40, -20,15,16,2,248,22,16,76,109,111,100,117,108,101,45,108,111,97,100,105,110, -103,80,144,39,54,40,20,15,16,2,11,80,143,39,55,20,15,16,2,11,80, -143,39,56,20,15,16,2,32,0,88,148,39,41,60,11,2,19,222,33,76,80, -144,39,57,40,20,15,16,2,32,0,88,148,8,36,40,52,11,2,20,222,33, -77,80,144,39,58,40,20,15,16,2,11,80,143,39,59,20,15,16,2,88,149, -8,34,40,48,8,240,4,0,16,0,1,21,112,114,101,112,45,112,108,97,110, -101,116,45,114,101,115,111,108,118,101,114,33,40,224,1,0,33,78,80,144,39, -8,28,42,20,15,16,2,88,148,39,40,53,8,240,0,0,3,0,69,103,101, -116,45,100,105,114,223,0,33,79,80,144,39,8,29,42,20,15,16,2,88,148, -39,40,52,8,240,0,0,64,0,74,112,97,116,104,45,115,115,45,62,114,107, -116,223,0,33,80,80,144,39,8,30,42,20,15,16,2,88,148,8,36,40,48, -8,240,0,0,4,0,9,223,0,33,81,80,144,39,8,31,42,20,15,16,2, -88,148,39,40,48,8,240,0,128,0,0,9,223,0,33,82,80,144,39,8,32, -42,20,15,16,2,27,11,20,19,143,39,90,144,40,10,89,146,40,39,10,20, -26,96,2,22,88,148,8,36,41,57,8,32,9,224,2,1,33,83,88,148,39, -42,52,11,9,223,0,33,84,88,148,39,43,8,34,16,4,8,240,44,240,0, -0,8,240,220,241,0,0,40,39,9,224,2,1,33,98,207,80,144,39,60,40, -20,15,16,2,88,148,39,39,48,16,2,8,134,8,8,176,32,2,23,223,0, -33,99,80,144,39,8,25,40,20,15,16,2,20,28,143,88,148,8,36,39,48, -16,2,43,8,144,32,2,24,223,0,33,100,88,148,8,36,39,48,16,2,43, -8,144,32,2,24,223,0,33,101,80,144,39,8,26,40,96,29,94,2,5,70, -35,37,107,101,114,110,101,108,11,29,94,2,5,71,35,37,109,105,110,45,115, -116,120,11,2,7,2,6,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10344); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,49,46,48,46,53,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,18,0,0,0,1,0,0,8,0,18, -0,22,0,28,0,42,0,56,0,68,0,88,0,102,0,117,0,130,0,135,0, -139,0,151,0,235,0,242,0,20,1,0,0,224,1,0,0,3,1,5,105,110, -115,112,48,71,35,37,98,117,105,108,116,105,110,29,11,11,11,67,113,117,111, -116,101,29,94,2,4,70,35,37,107,101,114,110,101,108,11,29,94,2,4,70, -35,37,101,120,112,111,98,115,11,29,94,2,4,68,35,37,98,111,111,116,11, -29,94,2,4,76,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29, -94,2,4,70,35,37,112,97,114,97,109,122,11,29,94,2,4,71,35,37,110, -101,116,119,111,114,107,11,29,94,2,4,69,35,37,117,116,105,108,115,11,38, -12,93,2,13,36,13,0,39,38,14,93,143,16,3,39,2,15,2,2,39,36, -15,1,150,40,143,2,16,16,4,2,5,39,39,2,1,143,2,16,16,4,2, -6,39,39,2,1,143,2,16,16,4,2,7,39,39,2,1,143,2,16,16,4, -2,8,39,39,2,1,143,2,16,16,4,2,9,39,39,2,1,143,2,16,16, -4,2,10,39,39,2,1,143,2,16,16,4,2,11,39,39,2,1,16,0,38, -16,143,2,15,2,12,18,143,16,2,143,10,16,3,93,16,2,29,11,11,11, -2,3,2,12,2,14,143,11,16,3,9,9,2,14,16,3,9,9,9,145,40, -9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2, -2,3,11,11,11,11,9,9,11,11,11,33,17,40,80,143,39,39,20,122,145, -2,1,39,16,0,16,0,40,42,39,16,0,39,16,0,39,11,11,11,16,0, -16,0,16,0,39,39,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11, -11,16,0,16,0,16,0,39,39,16,0,105,2,5,2,6,29,94,2,4,71, -35,37,102,111,114,101,105,103,110,11,29,94,2,4,70,35,37,117,110,115,97, -102,101,11,29,94,2,4,71,35,37,102,108,102,120,110,117,109,11,2,7,2, -8,2,9,2,10,2,11,29,94,2,4,69,35,37,112,108,97,99,101,11,29, -94,2,4,71,35,37,102,117,116,117,114,101,115,11,29,94,2,4,71,35,37, -108,105,110,107,108,101,116,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 559); - } diff -Nru racket-6.12+ppa1/src/racket/src/dynext.c racket-7.0+ppa1/src/racket/src/dynext.c --- racket-6.12+ppa1/src/racket/src/dynext.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/dynext.c 2018-07-27 22:12:02.000000000 +0000 @@ -85,7 +85,6 @@ # include "schemex.h" #endif -static Scheme_Object *load_extension(int argc, Scheme_Object **argv); static Scheme_Object *current_load_extension(int argc, Scheme_Object *argv[]); #ifdef LINK_EXTENSIONS_BY_TABLE @@ -122,7 +121,7 @@ #define BAD_VERSION_STR "found version does not match the expected version" -void scheme_init_dynamic_extension(Scheme_Env *env) +void scheme_init_dynamic_extension(Scheme_Startup_Env *env) { if (scheme_starting_up) { #ifdef LINK_EXTENSIONS_BY_TABLE @@ -134,8 +133,7 @@ #endif } - GLOBAL_PRIM_W_ARITY2("load-extension", load_extension, 1, 1, 0, -1, env); - GLOBAL_PARAMETER("current-load-extension", current_load_extension, MZCONFIG_LOAD_EXTENSION_HANDLER, env); + ADD_PARAMETER("current-load-extension", current_load_extension, MZCONFIG_LOAD_EXTENSION_HANDLER, env); } static Scheme_Object * @@ -496,9 +494,28 @@ GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1)); } -static Scheme_Object *load_extension(int argc, Scheme_Object **argv) +static int submodule_spec_p(Scheme_Object *expected_module) { - return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER); + Scheme_Object *a; + + if (SCHEME_PAIRP(expected_module)) { + a = SCHEME_CAR(expected_module); + if (!SCHEME_FALSEP(a) && !SCHEME_SYMBOLP(a)) + return 0; + expected_module = SCHEME_CDR(expected_module); + if (!SCHEME_PAIRP(expected_module)) + return 0; + while (SCHEME_PAIRP(expected_module)) { + a = SCHEME_CAR(expected_module); + if (!SCHEME_SYMBOLP(a)) + return 0; + expected_module = SCHEME_CDR(expected_module); + } + if (SCHEME_NULLP(expected_module)) + return 1; + } + + return 0; } Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv) @@ -509,8 +526,17 @@ if (!SCHEME_PATH_STRINGP(argv[0])) scheme_wrong_contract("default-load-extension-handler", "path-string?", 0, argc, argv); expected_module = argv[1]; - if (!SCHEME_FALSEP(expected_module) && !SCHEME_SYMBOLP(expected_module)) - scheme_wrong_contract("default-load-extension-handler", "(or/c symbol? #f)", 1, argc, argv); + if (!SCHEME_FALSEP(expected_module) + && !SCHEME_SYMBOLP(expected_module) + && !submodule_spec_p(expected_module)) + scheme_wrong_contract("default-load-extension-handler", + "(or/c symbol? #f (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))", + 1, argc, argv); + + if (SCHEME_PAIRP(expected_module) && SCHEME_FALSEP(SCHEME_CAR(expected_module))) { + /* caller requests quiet failure for separate loading of submodule */ + return scheme_void; + } filename = scheme_expand_string_filename(argv[0], "default-load-extension-handler", @@ -522,10 +548,10 @@ Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env) { - Scheme_Object *a[1]; - + Scheme_Object *load_ext_proc, *a[1]; + load_ext_proc = scheme_get_startup_export("load-extension"); a[0] = scheme_make_byte_string(filename); - return load_extension(1, a); + return scheme_apply_multi(load_ext_proc, 1, a); } void scheme_free_dynamic_extensions() diff -Nru racket-6.12+ppa1/src/racket/src/dynext.inc racket-7.0+ppa1/src/racket/src/dynext.inc --- racket-6.12+ppa1/src/racket/src/dynext.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/dynext.inc 2018-07-27 22:12:02.000000000 +0000 @@ -119,7 +119,7 @@ scheme_extension_table->scheme_get_string_output = scheme_get_string_output; scheme_extension_table->scheme_pipe = scheme_pipe; scheme_extension_table->scheme_add_global = scheme_add_global; - scheme_extension_table->scheme_add_global_constant = scheme_add_global_constant; + scheme_extension_table->scheme_addto_prim_instance = scheme_addto_prim_instance; scheme_extension_table->scheme_remove_global = scheme_remove_global; scheme_extension_table->scheme_constant = scheme_constant; scheme_extension_table->scheme_new_special_frame = scheme_new_special_frame; diff -Nru racket-6.12+ppa1/src/racket/src/env.c racket-7.0+ppa1/src/racket/src/env.c --- racket-6.12+ppa1/src/racket/src/env.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/env.c 2018-07-27 22:12:02.000000000 +0000 @@ -23,14 +23,9 @@ All rights reserved. */ -/* This file implements environments (both compile-time and top-level - envionments, a.k.a. namespaces), and also implements much of the - initialization sequence (filling the initial namespace). */ - #include "schpriv.h" #include "schminc.h" #include "schmach.h" -#include "schexpobs.h" #include "schrktio.h" #ifdef MZ_USE_FUTURES # include "future.h" @@ -47,125 +42,67 @@ THREAD_LOCAL_DECL(int scheme_starting_up); /* globals READ-ONLY SHARED */ -Scheme_Object *scheme_varref_const_p_proc; -READ_ONLY static Scheme_Env *kernel_env; -READ_ONLY static Scheme_Env *unsafe_env; -READ_ONLY static Scheme_Env *flfxnum_env; -READ_ONLY static Scheme_Env *extfl_env; -READ_ONLY static Scheme_Env *futures_env; READ_ONLY static Scheme_Object *kernel_symbol; -READ_ONLY static Scheme_Object *flip_symbol; -READ_ONLY static Scheme_Object *add_symbol; -READ_ONLY static Scheme_Object *remove_symbol; -THREAD_LOCAL_DECL(static int intdef_counter); +READ_ONLY Scheme_Startup_Env *scheme_startup_env; static int builtin_ref_counter; static int builtin_unsafe_start; +THREAD_LOCAL_DECL(static Scheme_Instance *scheme_startup_instance); + THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_string_table); THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_number_table); /* local functions */ -static void make_kernel_env(void); +static void init_startup_env(void); +static Scheme_Startup_Env *make_startup_env(); -static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size); -static Scheme_Env *make_empty_inited_env(int toplevel_size); -static Scheme_Env *make_empty_not_inited_env(int toplevel_size); - -static Scheme_Object *namespace_identifier(int, Scheme_Object *[]); -static Scheme_Object *namespace_module_identifier(int, Scheme_Object *[]); -static Scheme_Object *namespace_base_phase(int, Scheme_Object *[]); -static Scheme_Object *namespace_variable_value(int, Scheme_Object *[]); -static Scheme_Object *namespace_set_variable_value(int, Scheme_Object *[]); -static Scheme_Object *namespace_undefine_variable(int, Scheme_Object *[]); -static Scheme_Object *namespace_mapped_symbols(int, Scheme_Object *[]); -static Scheme_Object *namespace_module_registry(int, Scheme_Object *[]); -static Scheme_Object *variable_p(int, Scheme_Object *[]); -static Scheme_Object *variable_modidx(int, Scheme_Object *[]); -static Scheme_Object *variable_module_path(int, Scheme_Object *[]); -static Scheme_Object *variable_module_source(int, Scheme_Object *[]); -static Scheme_Object *variable_namespace(int, Scheme_Object *[]); -static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); -static Scheme_Object *variable_phase(int, Scheme_Object *[]); -static Scheme_Object *variable_base_phase(int, Scheme_Object *[]); -static Scheme_Object *variable_inspector(int, Scheme_Object *[]); -static Scheme_Object *variable_const_p(int, Scheme_Object *[]); -static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); -static Scheme_Object *now_transforming_with_lifts(int argc, Scheme_Object *argv[]); -static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]); -static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_definitions(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_submodules(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_binding_id(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]); -static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_rename_transformer(int argc, Scheme_Object *argv[]); -static Scheme_Object *rename_transformer_target(int argc, Scheme_Object *argv[]); -static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]); +static void init_unsafe(Scheme_Startup_Env *env); +static void init_flfxnum(Scheme_Startup_Env *env); +static void init_extfl(Scheme_Startup_Env *env); +static void init_futures(Scheme_Startup_Env *env); +static void init_foreign(Scheme_Startup_Env *env); static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); -Scheme_Env *scheme_engine_instance_init(); static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int); - - /*========================================================================*/ /* initialization */ /*========================================================================*/ +Scheme_Object *scheme_get_startup_export(const char *s) +{ + Scheme_Object *sym; + Scheme_Bucket *b; + + sym = scheme_intern_symbol(s); + b = scheme_instance_variable_bucket_or_null(sym, scheme_startup_instance); + + if (b) + return (Scheme_Object *)b->val; + + return NULL; +} + static void boot_module_resolver() { - Scheme_Object *boot, *a[2]; - a[0] = scheme_make_pair(scheme_intern_symbol("quote"), - scheme_make_pair(scheme_intern_symbol("#%boot"), - scheme_null)); - a[1] = scheme_intern_symbol("boot"); - boot = scheme_dynamic_require(2, a); + Scheme_Object *boot; + boot = scheme_get_startup_export("boot"); scheme_apply(boot, 0, NULL); } void scheme_seal_parameters() { - Scheme_Object *seal, *a[2]; - a[0] = scheme_make_pair(scheme_intern_symbol("quote"), - scheme_make_pair(scheme_intern_symbol("#%boot"), - scheme_null)); - a[1] = scheme_intern_symbol("seal"); - seal = scheme_dynamic_require(2, a); - scheme_apply(seal, 0, NULL); + Scheme_Object *seal; + seal = scheme_get_startup_export("seal"); + (void)scheme_apply_multi(seal, 0, NULL); } void os_platform_init() { @@ -180,7 +117,8 @@ #endif } -Scheme_Env *scheme_restart_instance() { +Scheme_Env *scheme_restart_instance() +{ Scheme_Env *env; void *stack_base; stack_base = (void *) scheme_get_current_os_thread_stack_base(); @@ -198,11 +136,9 @@ scheme_make_thread(stack_base); scheme_init_error_escape_proc(NULL); - scheme_init_module_resolver(); + scheme_namespace_to_env = scheme_make_bucket_table(5, SCHEME_hash_weak_ptr); env = scheme_make_empty_env(); - scheme_install_initial_module_set(env); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); scheme_init_port_config(); scheme_init_port_fun_config(); @@ -210,29 +146,25 @@ scheme_init_logger_config(); scheme_init_exn_config(); + scheme_startup_instance = scheme_make_instance(scheme_intern_symbol("startup"), scheme_false); + scheme_init_startup_instance(scheme_startup_instance); + boot_module_resolver(); + scheme_init_resolver_config(); + return env; } Scheme_Env *scheme_basic_env() { Scheme_Env *env; + void *stack_base; if (scheme_main_thread) { return scheme_restart_instance(); } - env = scheme_engine_instance_init(); - - return env; -} - -Scheme_Env *scheme_engine_instance_init() -/* READ-ONLY GLOBAL structures, ONE-TIME initialization */ -{ - Scheme_Env *env; - void *stack_base; stack_base = (void *) scheme_get_current_os_thread_stack_base(); os_platform_init(); @@ -283,13 +215,12 @@ /* These calls must be made here so that they allocate out of the master GC */ scheme_init_symbol_table(); - scheme_init_module_path_table(); scheme_init_type(); scheme_init_custodian_extractors(); #ifndef DONT_USE_FOREIGN scheme_init_foreign_globals(); #endif - make_kernel_env(); + init_startup_env(); scheme_init_logging_once(); @@ -302,6 +233,8 @@ scheme_spawn_master_place(); #endif + /* Create the initial place with its initial namespace */ + env = place_instance_init(stack_base, 1); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) @@ -318,171 +251,182 @@ return env; } -static void init_unsafe(Scheme_Env *env) +static void init_startup_env(void) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(unsafe_env); + Scheme_Startup_Env *env; +#ifdef TIME_STARTUP_PROCESS + intptr_t startt; +#endif - unsafe_env = scheme_primitive_module(scheme_intern_symbol("#%unsafe"), env); + REGISTER_SO(kernel_symbol); + kernel_symbol = scheme_intern_symbol("#%kernel"); - scheme_init_unsafe_number(unsafe_env); - scheme_init_unsafe_numarith(unsafe_env); - scheme_init_unsafe_numcomp(unsafe_env); - scheme_init_unsafe_list(unsafe_env); - scheme_init_unsafe_hash(unsafe_env); - scheme_init_unsafe_vector(unsafe_env); - scheme_init_unsafe_fun(unsafe_env); - scheme_init_unsafe_thread(unsafe_env); - scheme_init_unsafe_port(unsafe_env); - - scheme_init_extfl_unsafe_number(unsafe_env); - scheme_init_extfl_unsafe_numarith(unsafe_env); - scheme_init_extfl_unsafe_numcomp(unsafe_env); - - scheme_finish_primitive_module(unsafe_env); - pt = unsafe_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(unsafe_env, NULL); - unsafe_env->attached = 1; + env = make_startup_env(); -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT - + EXPECTED_UNSAFE_COUNT)) { - printf("Unsafe count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - - EXPECTED_FLFXNUM_COUNT - EXPECTED_EXTFL_COUNT - - EXPECTED_FUTURES_COUNT, EXPECTED_UNSAFE_COUNT); - abort(); - } + REGISTER_SO(scheme_startup_env); + scheme_startup_env = env; + + scheme_defining_primitives = 1; + builtin_ref_counter = 0; + +#ifdef TIME_STARTUP_PROCESS + printf("init @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); +# define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n)) +# define MARK_START_TIME() startt = scheme_get_process_milliseconds() +# define DONE_TIME(n) (printf(#n ": %" PRIdPTR "\n", (intptr_t)(scheme_get_process_milliseconds() - startt))) +#else +# define MZTIMEIT(n, f) f +# define MARK_START_TIME() /**/ +# define DONE_TIME(n) /**/ #endif -} -static void init_flfxnum(Scheme_Env *env) -{ - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(flfxnum_env); + /* The ordering of the first few init calls is important, so add to + the end of the list, not the beginning. */ + MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); + MZTIMEIT(fun, scheme_init_fun(env)); + MZTIMEIT(symbol, scheme_init_symbol(env)); + MZTIMEIT(list, scheme_init_list(env)); + MZTIMEIT(number, scheme_init_number(env)); + MZTIMEIT(numarith, scheme_init_numarith(env)); + MZTIMEIT(numcomp, scheme_init_numcomp(env)); + MZTIMEIT(numstr, scheme_init_numstr(env)); + MZTIMEIT(bignum, scheme_init_bignum()); + MZTIMEIT(char-const, scheme_init_char_constants()); + MZTIMEIT(stx, scheme_init_stx(env)); + MZTIMEIT(port, scheme_init_port(env)); + MZTIMEIT(portfun, scheme_init_port_fun(env)); + MZTIMEIT(string, scheme_init_string(env)); + MZTIMEIT(vector, scheme_init_vector(env)); + MZTIMEIT(char, scheme_init_char(env)); + MZTIMEIT(bool, scheme_init_bool(env)); + MZTIMEIT(syntax, scheme_init_compile(env)); + MZTIMEIT(eval, scheme_init_eval(env)); + MZTIMEIT(struct, scheme_init_struct(env)); + MZTIMEIT(error, scheme_init_error(env)); +#ifndef NO_SCHEME_EXNS + MZTIMEIT(exn, scheme_init_exn(env)); +#endif + MZTIMEIT(process, scheme_init_thread(env)); + scheme_init_port_wait(); + scheme_init_inspector(); + scheme_init_logger_wait(); + scheme_init_struct_wait(); + MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env)); +#ifndef NO_SCHEME_THREADS + MZTIMEIT(sema, scheme_init_sema(env)); +#endif + MZTIMEIT(read, scheme_init_read(env)); + MZTIMEIT(print, scheme_init_print(env)); + MZTIMEIT(file, scheme_init_file(env)); + MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env)); +#ifndef NO_REGEXP_UTILS + MZTIMEIT(regexp, scheme_regexp_initialize(env)); +#endif + MZTIMEIT(params, scheme_init_parameterization()); + MZTIMEIT(futures, scheme_init_futures_once()); + MZTIMEIT(places, scheme_init_places_once()); + MZTIMEIT(linklet, scheme_init_linklet(env)); +#ifndef NO_TCP_SUPPORT + MZTIMEIT(network, scheme_init_network(env)); +#endif + MZTIMEIT(paramz, scheme_init_paramz(env)); + MZTIMEIT(place, scheme_init_place(env)); + + scheme_register_network_evts(); - flfxnum_env = scheme_primitive_module(scheme_intern_symbol("#%flfxnum"), env); + MARK_START_TIME(); - scheme_init_flfxnum_number(flfxnum_env); - scheme_init_flfxnum_numarith(flfxnum_env); - scheme_init_flfxnum_numcomp(flfxnum_env); - - scheme_finish_primitive_module(flfxnum_env); - pt = flfxnum_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(flfxnum_env, NULL); - flfxnum_env->attached = 1; + init_flfxnum(env); + init_extfl(env); + init_futures(env); + builtin_unsafe_start = builtin_ref_counter; + scheme_init_unsafe_linklet(env); + init_unsafe(env); + init_foreign(env); + #if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT)) { - printf("Flfxnum count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT, - EXPECTED_FLFXNUM_COUNT); + if (builtin_ref_counter != EXPECTED_PRIM_COUNT) { + printf("Primitive count %d doesn't match expected count %d\n" + "Turn off USE_COMPILED_STARTUP in src/schminc.h\n", + builtin_ref_counter, EXPECTED_PRIM_COUNT); abort(); } #endif -} -static void init_extfl(Scheme_Env *env) -{ - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(extfl_env); + scheme_init_variable_references_constants(); - extfl_env = scheme_primitive_module(scheme_intern_symbol("#%extfl"), env); + scheme_init_longdouble_fixup(); - scheme_init_extfl_number(extfl_env); - scheme_init_extfl_numarith(extfl_env); - scheme_init_extfl_numcomp(extfl_env); - scheme_init_extfl_numstr(extfl_env); - - scheme_finish_primitive_module(extfl_env); - pt = extfl_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(extfl_env, NULL); - extfl_env->attached = 1; + scheme_init_startup(); -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT)) { - printf("extfl count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT, - EXPECTED_EXTFL_COUNT); - abort(); - } -#endif + scheme_defining_primitives = 0; } -static void init_futures(Scheme_Env *env) +static void init_unsafe(Scheme_Startup_Env *env) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(futures_env); + scheme_switch_prim_instance(env, "#%unsafe"); - futures_env = scheme_primitive_module(scheme_intern_symbol("#%futures"), env); + scheme_init_unsafe_number(env); + scheme_init_unsafe_numarith(env); + scheme_init_unsafe_numcomp(env); + scheme_init_unsafe_list(env); + scheme_init_unsafe_hash(env); + scheme_init_unsafe_vector(env); + scheme_init_unsafe_fun(env); + scheme_init_unsafe_thread(env); + scheme_init_unsafe_port(env); - scheme_init_futures(futures_env); + scheme_init_extfl_unsafe_number(env); + scheme_init_extfl_unsafe_numarith(env); + scheme_init_extfl_unsafe_numcomp(env); - scheme_finish_primitive_module(futures_env); - pt = futures_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(futures_env, NULL); - futures_env->attached = 1; - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) { - printf("Futures count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT - - EXPECTED_EXTFL_COUNT, - EXPECTED_FUTURES_COUNT); - abort(); - } -#endif + scheme_restore_prim_instance(env); } -static void init_foreign(Scheme_Env *env) +static void init_flfxnum(Scheme_Startup_Env *env) { - Scheme_Env *ffi_env; + scheme_switch_prim_instance(env, "#%flfxnum"); + + scheme_init_flfxnum_number(env); + scheme_init_flfxnum_numarith(env); + scheme_init_flfxnum_numcomp(env); - scheme_init_foreign(env); + scheme_restore_prim_instance(env); +} - ffi_env = scheme_get_foreign_env(); - scheme_populate_pt_ht(ffi_env->module->me->rt); - ffi_env->attached = 1; +static void init_extfl(Scheme_Startup_Env *env) +{ + scheme_switch_prim_instance(env, "#%extfl"); -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT - + EXPECTED_UNSAFE_COUNT + EXPECTED_FOREIGN_COUNT)) { - printf("Foreign count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT - - EXPECTED_EXTFL_COUNT - EXPECTED_FUTURES_COUNT - - EXPECTED_UNSAFE_COUNT, - EXPECTED_FOREIGN_COUNT); - abort(); - } -#endif -} + scheme_init_extfl_number(env); + scheme_init_extfl_numarith(env); + scheme_init_extfl_numcomp(env); + scheme_init_extfl_numstr(env); -Scheme_Env *scheme_get_unsafe_env() { - return unsafe_env; + scheme_restore_prim_instance(env); } -Scheme_Env *scheme_get_flfxnum_env() { - return flfxnum_env; -} +static void init_futures(Scheme_Startup_Env *env) +{ + scheme_switch_prim_instance(env, "#%futures"); -Scheme_Env *scheme_get_extfl_env() { - return extfl_env; + scheme_init_futures(env); + + scheme_restore_prim_instance(env); } -Scheme_Env *scheme_get_futures_env() { - return futures_env; +static void init_foreign(Scheme_Startup_Env *env) +{ + scheme_init_foreign(env); } +/*========================================================================*/ +/* place-specific intialization */ +/*========================================================================*/ -static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) { +static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) +{ Scheme_Env *env; #ifdef TIME_STARTUP_PROCESS @@ -522,10 +466,6 @@ scheme_init_stx_places(initial_main_os_thread); - scheme_init_syntax_bindings(); - - scheme_init_module_resolver(); - #ifdef TIME_STARTUP_PROCESS printf("process @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); #endif @@ -542,6 +482,7 @@ scheme_init_string_places(); scheme_init_logger(); scheme_init_eval_places(); + scheme_init_linklet_places(); scheme_init_compile_places(); scheme_init_regexp_places(); scheme_init_sema_places(); @@ -550,9 +491,6 @@ scheme_init_foreign_places(); #endif - env = scheme_make_empty_env(); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); - /*initialize config */ scheme_init_port_config(); scheme_init_port_fun_config(); @@ -562,14 +500,8 @@ scheme_init_exn_config(); #endif scheme_init_error_config(); + scheme_init_place_per_place(); -/* BEGIN PRIMITIVE MODULES */ - scheme_init_linklet(env); - scheme_init_network(env); - scheme_init_paramz(env); - scheme_init_expand_observe(env); - scheme_init_place(env); -/* END PRIMITIVE MODULES */ #if defined(MZ_USE_PLACES) && defined(MZ_USE_JIT) scheme_jit_fill_threadlocal_table(); #endif @@ -586,11 +518,17 @@ printf("pre-embedded @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); #endif - scheme_add_embedded_builtins(env); + REGISTER_SO(scheme_startup_instance); + scheme_startup_instance = scheme_make_instance(scheme_intern_symbol("startup"), scheme_false); + scheme_init_startup_instance(scheme_startup_instance); + REGISTER_SO(scheme_namespace_to_env); + scheme_namespace_to_env = scheme_make_bucket_table(5, SCHEME_hash_weak_ptr); + env = scheme_make_empty_env(); + boot_module_resolver(); - scheme_save_initial_module_set(env); + scheme_init_resolver_config(); scheme_starting_up = 0; @@ -608,7 +546,8 @@ } #ifdef MZ_USE_PLACES -Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) { +Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) +{ Scheme_Env *env; # if defined(MZ_PRECISE_GC) int *signal_fd; @@ -667,199 +606,6 @@ rktio_destroy(scheme_rktio); } -static void make_kernel_env(void) -{ - Scheme_Env *env; -#ifdef TIME_STARTUP_PROCESS - intptr_t startt; -#endif - - env = make_empty_inited_env(GLOBAL_TABLE_SIZE); - - REGISTER_SO(kernel_env); - kernel_env = env; - - scheme_defining_primitives = 1; - builtin_ref_counter = 0; - -#ifdef TIME_STARTUP_PROCESS - printf("init @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); -# define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n)) -# define MARK_START_TIME() startt = scheme_get_process_milliseconds() -# define DONE_TIME(n) (printf(#n ": %" PRIdPTR "\n", (intptr_t)(scheme_get_process_milliseconds() - startt))) -#else -# define MZTIMEIT(n, f) f -# define MARK_START_TIME() /**/ -# define DONE_TIME(n) /**/ -#endif - - /* The ordering of the first few init calls is important, so add to - the end of the list, not the beginning. */ - MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); - MZTIMEIT(fun, scheme_init_fun(env)); - MZTIMEIT(symbol, scheme_init_symbol(env)); - MZTIMEIT(list, scheme_init_list(env)); - MZTIMEIT(number, scheme_init_number(env)); - MZTIMEIT(numarith, scheme_init_numarith(env)); - MZTIMEIT(numcomp, scheme_init_numcomp(env)); - MZTIMEIT(numstr, scheme_init_numstr(env)); - MZTIMEIT(bignum, scheme_init_bignum()); - MZTIMEIT(char-const, scheme_init_char_constants()); - MZTIMEIT(stx, scheme_init_stx(env)); - MZTIMEIT(module, scheme_init_module(env)); - MZTIMEIT(port, scheme_init_port(env)); - MZTIMEIT(portfun, scheme_init_port_fun(env)); - MZTIMEIT(string, scheme_init_string(env)); - MZTIMEIT(vector, scheme_init_vector(env)); - MZTIMEIT(char, scheme_init_char(env)); - MZTIMEIT(bool, scheme_init_bool(env)); - MZTIMEIT(syntax, scheme_init_compile(env)); - MZTIMEIT(eval, scheme_init_eval(env)); - MZTIMEIT(struct, scheme_init_struct(env)); - MZTIMEIT(error, scheme_init_error(env)); -#ifndef NO_SCHEME_EXNS - MZTIMEIT(exn, scheme_init_exn(env)); -#endif - MZTIMEIT(process, scheme_init_thread(env)); - scheme_init_port_wait(); - scheme_init_inspector(); - scheme_init_logger_wait(); - scheme_init_struct_wait(); - MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env)); -#ifndef NO_SCHEME_THREADS - MZTIMEIT(sema, scheme_init_sema(env)); -#endif - MZTIMEIT(read, scheme_init_read(env)); - MZTIMEIT(print, scheme_init_print(env)); - MZTIMEIT(file, scheme_init_file(env)); - MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env)); -#ifndef NO_REGEXP_UTILS - MZTIMEIT(regexp, scheme_regexp_initialize(env)); -#endif - MZTIMEIT(params, scheme_init_parameterization()); - MZTIMEIT(futures, scheme_init_futures_once()); - MZTIMEIT(places, scheme_init_places_once()); - - MARK_START_TIME(); - - GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env); - GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env); - GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env); - GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env); - GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("variable-reference?", variable_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-path-index", variable_modidx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-source", variable_module_source, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-base-phase", variable_base_phase, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-declaration-inspector", variable_inspector, 1, 1, env); - - REGISTER_SO(scheme_varref_const_p_proc); - scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, - "variable-reference-constant?", - 1, 1); - scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env); - - GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-transforming-with-lifts?", now_transforming_with_lifts, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); - GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); - GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 2, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-introduce", intdef_context_intro, 2, 3, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-binding-identifiers", intdef_context_ids, 1, 1, env); - GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-identifier-as-binding", local_binding_id, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-submodules", local_submodules, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env); - - GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env); - GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-module", local_lift_module, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env); - - DONE_TIME(env); - - scheme_register_network_evts(); - - REGISTER_SO(kernel_symbol); - kernel_symbol = scheme_intern_symbol("#%kernel"); - - REGISTER_SO(flip_symbol); - REGISTER_SO(add_symbol); - REGISTER_SO(remove_symbol); - flip_symbol = scheme_intern_symbol("flip"); - add_symbol = scheme_intern_symbol("add"); - remove_symbol = scheme_intern_symbol("remove"); - - MARK_START_TIME(); - - scheme_finish_kernel(env); - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != EXPECTED_PRIM_COUNT) { - printf("Primitive count %d doesn't match expected count %d\n" - "Turn off USE_COMPILED_STARTUP in src/schminc.h\n", - builtin_ref_counter, EXPECTED_PRIM_COUNT); - abort(); - } -#endif - - init_flfxnum(env); - init_extfl(env); - init_futures(env); - - builtin_unsafe_start = builtin_ref_counter; - init_unsafe(env); - init_foreign(env); - - scheme_init_print_global_constants(); - scheme_init_variable_references_constants(); - - scheme_init_longdouble_fixup(); - - scheme_defining_primitives = 0; -} - -int scheme_is_kernel_env(Scheme_Env *env) { - return (env == kernel_env); -} - -Scheme_Env *scheme_get_kernel_env() { - return kernel_env; -} - /* Shutdown procedure for resetting a namespace: */ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -874,939 +620,166 @@ } /*========================================================================*/ -/* namespace constructors */ +/* instances and startup env */ /*========================================================================*/ -void scheme_prepare_env_stx_context(Scheme_Env *env) +static Scheme_Startup_Env *make_startup_env(void) { - Scheme_Object *mc, *shift, *insp; + Scheme_Startup_Env *e; + Scheme_Hash_Table *table; + Scheme_Hash_Table *primitive_tables; - if (env->stx_context) return; + e = MALLOC_ONE_TAGGED(Scheme_Startup_Env); + e->so.type = scheme_startup_env_type; - insp = env->access_insp; - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + primitive_tables = scheme_make_hash_table(SCHEME_hash_ptr); + e->primitive_tables = primitive_tables; - if (env->module) { - shift = scheme_make_shift(scheme_make_integer(0), - NULL, NULL, - env->module_registry->exports, - (env->module->prefix - ? env->module->prefix->src_insp_desc - : env->module->insp), - insp); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->current_table = table; + scheme_hash_set(e->primitive_tables, kernel_symbol, (Scheme_Object *)table); - mc = scheme_make_module_context(insp, shift, env->module->modname); - } else - mc = scheme_make_module_context(insp, NULL, scheme_false); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->all_primitives_table = table; - env->stx_context = mc; -} - -Scheme_Env *scheme_make_empty_env(void) -{ - Scheme_Env *e; - - e = make_empty_inited_env(7); - - return e; -} - -Scheme_Env *make_empty_inited_env(int toplevel_size) -{ - Scheme_Env *env; - Scheme_Object *vector; - Scheme_Hash_Table* hash_table; - Scheme_Module_Registry *reg; - - env = make_env(NULL, toplevel_size); - - vector = scheme_make_vector(5, scheme_false); - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(vector)[0] = (Scheme_Object *)hash_table; - env->modchain = vector; - - reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry); - reg->so.type = scheme_module_registry_type; - env->module_registry = reg; - - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - reg->loaded = hash_table; - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(hash_table->iso)) |= 0x1; /* print (for debugging) as opqaue */ - reg->exports = hash_table; - - env->label_env = NULL; - - return env; -} - -Scheme_Env *make_empty_not_inited_env(int toplevel_size) -{ - Scheme_Env *e; - - e = make_env(NULL, toplevel_size); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->primitive_ids_table = table; return e; } -static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size) -{ - Scheme_Env *env; - Scheme_Bucket_Table *bucket_table; - - env = MALLOC_ONE_TAGGED(Scheme_Env); - env->so.type = scheme_namespace_type; - - bucket_table = scheme_make_bucket_table(toplevel_size, SCHEME_hash_ptr); - env->toplevel = bucket_table; - env->toplevel->with_home = 1; - - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - env->syntax = bucket_table; - - if (base) { - env->modchain = base->modchain; - env->module_registry = base->module_registry; - env->module_pre_registry = base->module_pre_registry; - env->label_env = base->label_env; - } else { - env->modchain = NULL; - env->module_registry = NULL; - env->module_pre_registry = NULL; - env->label_env = NULL; - } - - return env; -} - -Scheme_Env *scheme_make_env_like(Scheme_Env *base) -{ - return make_env(base, 10); -} - -Scheme_Env * -scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, - int new_exp_module_tree, int new_pre_registry) +void scheme_switch_prim_instance(Scheme_Startup_Env *env, const char *name) { - Scheme_Env *menv; - Scheme_Module_Registry *reg; - - menv = make_env(env, 7); - - if (new_pre_registry) { - /* pre_registry is for declarations to be used by submodules */ - reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry); - reg->so.type = scheme_module_registry_type; - menv->module_pre_registry = reg; - } - - menv->module = m; - menv->instance_env = env; - menv->reader_env = (env->reader_env ? env->reader_env : env); - - if (new_exp_module_tree) { - /* It would be nice to share the label env with `env`, but we need - to set `module_pre_registry` in `menv->label_env` and not shared - it with `env->label_env`: */ - menv->label_env = NULL; - scheme_prepare_label_env(menv); - menv->instance_env = menv; - } else { - scheme_prepare_label_env(env); - menv->label_env = env->label_env; - } - - if (new_exp_module_tree) { - Scheme_Object *p; - Scheme_Hash_Table *modules; - - modules = scheme_make_hash_table(SCHEME_hash_ptr); - p = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(p)[0] = (Scheme_Object *)modules; - menv->modchain = p; - } + Scheme_Hash_Table *table; + Scheme_Object *sym; - if (SAME_OBJ(env, env->exp_env)) { - /* label phase */ - menv->exp_env = menv; - menv->template_env = menv; + sym = scheme_intern_symbol(name); + + table = (Scheme_Hash_Table *)scheme_hash_get(env->primitive_tables, sym); + if (!table) { + table = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(env->primitive_tables, sym, (Scheme_Object *)table); } - return menv; + env->current_table = table; } -void scheme_prepare_exp_env(Scheme_Env *env) +void scheme_restore_prim_instance(Scheme_Startup_Env *env) { - if (!env->exp_env) { - Scheme_Env *eenv; - Scheme_Object *modchain, *mc; - - scheme_prepare_label_env(env); - - eenv = make_empty_not_inited_env(7); - eenv->phase = env->phase + 1; - eenv->mod_phase = env->mod_phase + 1; - - eenv->module = env->module; - eenv->module_registry = env->module_registry; - eenv->module_pre_registry = env->module_pre_registry; - eenv->access_insp = env->access_insp; - eenv->guard_insp = env->guard_insp; - - modchain = SCHEME_VEC_ELS(env->modchain)[1]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *next_modules; - - next_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules; - SCHEME_VEC_ELS(env->modchain)[1] = modchain; - SCHEME_VEC_ELS(modchain)[2] = env->modchain; - } - eenv->modchain = modchain; - - env->exp_env = eenv; - eenv->template_env = env; - eenv->label_env = env->label_env; - eenv->instance_env = env->instance_env; - eenv->reader_env = (env->reader_env ? env->reader_env : env); - - scheme_prepare_env_stx_context(env); - mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv)); - eenv->stx_context = mc; - - if (env->disallow_unbound) - eenv->disallow_unbound = env->disallow_unbound; - } + Scheme_Hash_Table *table; + table = (Scheme_Hash_Table *)scheme_hash_get(env->primitive_tables, kernel_symbol); + env->current_table = table; } -void scheme_prepare_template_env(Scheme_Env *env) +void scheme_addto_prim_instance(const char *name, Scheme_Object *obj, Scheme_Startup_Env *env) { - if (!env->template_env) { - Scheme_Env *eenv; - Scheme_Object *modchain, *mc; - - scheme_prepare_label_env(env); - - eenv = make_empty_not_inited_env(7); - eenv->phase = env->phase - 1; - eenv->mod_phase = env->mod_phase - 1; - - eenv->module = env->module; - eenv->module_registry = env->module_registry; - eenv->module_pre_registry = env->module_pre_registry; - eenv->guard_insp = env->guard_insp; - eenv->access_insp = env->access_insp; - - modchain = SCHEME_VEC_ELS(env->modchain)[2]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *prev_modules; - - prev_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules; - SCHEME_VEC_ELS(env->modchain)[2] = modchain; - SCHEME_VEC_ELS(modchain)[1] = env->modchain; - } - eenv->modchain = modchain; - - scheme_prepare_env_stx_context(env); - mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv)); - eenv->stx_context = mc; - - env->template_env = eenv; - eenv->exp_env = env; - eenv->label_env = env->label_env; - eenv->instance_env = env->instance_env; - eenv->reader_env = (env->reader_env ? env->reader_env : env); - - if (env->disallow_unbound) - eenv->disallow_unbound = env->disallow_unbound; - } + scheme_addto_primitive_instance_by_symbol(scheme_intern_symbol(name), obj, env); } -void scheme_prepare_label_env(Scheme_Env *env) +void +scheme_addto_primitive_instance_by_symbol(Scheme_Object *name, Scheme_Object *obj, Scheme_Startup_Env *env) { - if (!env->label_env) { - Scheme_Env *lenv; - Scheme_Object *modchain; - Scheme_Hash_Table *prev_modules; - - lenv = make_empty_not_inited_env(7); - lenv->phase = 0; - lenv->mod_phase = 0; - - lenv->module = env->module; - lenv->module_registry = env->module_registry; - lenv->module_pre_registry = env->module_pre_registry; - lenv->guard_insp = env->guard_insp; - lenv->access_insp = env->access_insp; - - modchain = scheme_make_vector(5, scheme_false); - prev_modules = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules; - SCHEME_VEC_ELS(modchain)[2] = modchain; - SCHEME_VEC_ELS(modchain)[1] = modchain; - lenv->modchain = modchain; - - env->label_env = lenv; - - lenv->exp_env = lenv; - lenv->label_env = lenv; - lenv->template_env = lenv; - lenv->instance_env = env->instance_env; - lenv->reader_env = (env->reader_env ? env->reader_env : env); - } -} + scheme_hash_set(env->current_table, name, obj); + scheme_hash_set(env->all_primitives_table, name, obj); -Scheme_Object *scheme_env_phase(Scheme_Env *env) -{ - if (env == env->label_env) - return scheme_false; - else - return scheme_make_integer(env->phase); + scheme_hash_set(env->primitive_ids_table, obj, scheme_make_integer(builtin_ref_counter)); + builtin_ref_counter++; } -Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase) +Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start) { - if (SCHEME_FALSEP(phase)) { - scheme_prepare_label_env(env); - env = env->label_env; - } else { - intptr_t ph = SCHEME_INT_VAL(phase) - env->phase; - intptr_t j; - - if (ph > 0) { - for (j = 0; j < ph; j++) { - scheme_prepare_exp_env(env); - env = env->exp_env; - } - } else if (ph < 0) { - for (j = 0; j > ph; j--) { - scheme_prepare_template_env(env); - env = env->template_env; - } - } - } + Scheme_Object **t, *v; + int i; - return env; -} + t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1)); +#ifdef MEMORY_COUNTING_ON + scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1); +#endif -Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone_phase) -{ - /* New env should have the same syntax and globals table, but it lives in - a different namespace. */ - Scheme_Env *menv2; - Scheme_Bucket_Table *bucket_table; - - scheme_prepare_label_env(ns); - - menv2 = MALLOC_ONE_TAGGED(Scheme_Env); - menv2->so.type = scheme_namespace_type; - - menv2->module = menv->module; - menv2->module_registry = ns->module_registry; - menv2->module_pre_registry = ns->module_pre_registry; - menv2->guard_insp = menv->guard_insp; - menv2->access_insp = menv->access_insp; - - menv2->instance_env = menv2; - - if (menv->phase < clone_phase) - menv2->syntax = menv->syntax; - else { - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - menv2->syntax = bucket_table; + for (i = builtin_ref_counter + 1; i--; ) { + t[i] = scheme_false; } - menv2->phase = menv->phase; - menv2->mod_phase = menv->mod_phase; - menv2->link_midx = menv->link_midx; - if (menv->phase <= clone_phase) { - menv2->ran = menv->ran; - } - if (menv->mod_phase == 0) { - char *running; - int amt; - running = (char *)scheme_malloc_atomic(menv->module->num_phases); - menv2->running = running; - memset(running, 0, menv->module->num_phases); - amt = (clone_phase - menv->phase) + 1; - if (amt > 0) { - if (amt > menv->module->num_phases) - amt = menv->module->num_phases; - memcpy(running, menv->running, amt); + for (i = scheme_startup_env->primitive_ids_table->size; i--; ) { + v = scheme_startup_env->primitive_ids_table->vals[i]; + if (v) { + t[SCHEME_INT_VAL(v)] = scheme_startup_env->primitive_ids_table->keys[i]; } } - menv2->require_names = menv->require_names; - menv2->et_require_names = menv->et_require_names; - menv2->tt_require_names = menv->tt_require_names; - menv2->dt_require_names = menv->dt_require_names; - menv2->other_require_names = menv->other_require_names; - - if (menv->phase <= clone_phase) { - menv2->toplevel = menv->toplevel; - } else { - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - menv2->toplevel = bucket_table; - menv2->toplevel->with_home = 1; - } - - menv2->modchain = modchain; - - if (SAME_OBJ(menv->exp_env, menv)) { - /* label phase */ - menv2->exp_env = menv2; - menv2->template_env = menv2; - } else if (menv->phase < clone_phase) { - if (!SCHEME_NULLP(menv2->module->et_requires)) { - /* We'll need the next link in the modchain: */ - modchain = SCHEME_VEC_ELS(modchain)[1]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *next_modules; - - next_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules; - SCHEME_VEC_ELS(menv2->modchain)[1] = modchain; - SCHEME_VEC_ELS(modchain)[2] = menv2->modchain; - } - } - - if (menv->exp_env) { - /* Share for-syntax bindings, too: */ - scheme_prepare_exp_env(menv2); - menv2->exp_env->toplevel = menv->exp_env->toplevel; - } - } - - scheme_prepare_label_env(ns); - menv2->label_env = ns->label_env; - menv2->reader_env = (ns->reader_env ? ns->reader_env : ns); + *_unsafe_start = builtin_unsafe_start; - return menv2; + return t; } -Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home) +const char *scheme_look_for_primitive(void *code) { - Scheme_Bucket_Table *r; - Scheme_Bucket **bs; intptr_t i; + Scheme_Object *val; - r = scheme_make_bucket_table(ht->size, SCHEME_hash_ptr); - if (home) - r->with_home = 1; - - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - Scheme_Object *name = (Scheme_Object *)b->key; - Scheme_Object *val = (Scheme_Object *)b->val; - - b = scheme_bucket_from_table(r, (const char *)name); - b->val = val; - if (home) { - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, home); - } + for (i = scheme_startup_env->all_primitives_table->size; i--; ) { + val = scheme_startup_env->all_primitives_table->vals[i]; + if (val && SCHEME_PRIMP(val)) { + if (SCHEME_PRIM(val) == code) + return ((Scheme_Primitive_Proc *)val)->name; } } - return r; + return NULL; } -Scheme_Object *scheme_get_home_weak_link(Scheme_Env *e) +Scheme_Object *scheme_builtin_value(const char *name) { - if (!e->weak_self_link) { - Scheme_Object *wb; - if (scheme_starting_up) - wb = scheme_box((Scheme_Object *)e); - else - wb = scheme_make_weak_box((Scheme_Object *)e); - e->weak_self_link = wb; + Scheme_Object *sym, *v; + Scheme_Bucket *b; + + sym = scheme_intern_symbol(name); + v = scheme_hash_get(scheme_startup_env->all_primitives_table, sym); + if (!v) { + b = scheme_instance_variable_bucket_or_null(sym, scheme_startup_instance); + if (b) + return b->val; } - return e->weak_self_link; -} - -Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b) -{ - Scheme_Object *l; - - l = ((Scheme_Bucket_With_Home *)b)->home_link; - if (l) { - if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) - return (Scheme_Env *)l; - else - return (Scheme_Env *)SCHEME_WEAK_BOX_VAL(l); - } else - return NULL; -} - -void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e) -{ - if (!((Scheme_Bucket_With_Home *)b)->home_link) { - if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) - ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e; - else { - Scheme_Object *link; - link = scheme_get_home_weak_link(e); - ((Scheme_Bucket_With_Home *)b)->home_link = link; - } - } + return v; } /*========================================================================*/ /* namespace bindings */ /*========================================================================*/ -/********** Lookup **********/ - -Scheme_Object * -scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env) -{ - Scheme_Bucket *b; - - b = scheme_bucket_or_null_from_table(env->toplevel, (char *)symbol, 0); - if (b) { - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, env); - return (Scheme_Object *)b->val; - } - - return NULL; -} - -Scheme_Bucket * -scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env) -{ - Scheme_Bucket *b; - - b = scheme_bucket_from_table(env->toplevel, (char *)symbol); - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, env); - - return b; -} - -Scheme_Bucket * -scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env) +Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env) { Scheme_Bucket *b; - - b = scheme_bucket_from_table(env->syntax, (char *)symbol); - - return b; -} - -/********** Set **********/ - -void -scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, - Scheme_Object *obj, - int valvar, int constant) -{ - if (valvar) { - Scheme_Bucket *b; - b = scheme_bucket_from_table(env->toplevel, (const char *)sym); - b->val = obj; - ASSERT_IS_VARIABLE_BUCKET(b); - if (constant && scheme_defining_primitives) { - ((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++; - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); - } else if (constant) - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); - scheme_set_bucket_home(b, env); - } else - scheme_add_to_table(env->syntax, (const char *)sym, obj, constant); -} - -void -scheme_add_global(const char *name, Scheme_Object *obj, Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 0); -} - -void -scheme_add_global_symbol(Scheme_Object *sym, Scheme_Object *obj, Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, sym, obj, 1, 0); -} - -void -scheme_add_global_constant(const char *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 1); -} - -void -scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, name, obj, 1, 1); -} - -void -scheme_add_global_keyword(const char *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 0, 0); -} - -void -scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, name, obj, 0, 0); -} - -static Scheme_Object *vector_to_ht(Scheme_Object *vec, int kind) -{ - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *orig_val; - intptr_t i; - - ht = scheme_make_hash_tree(kind); - - i = SCHEME_VEC_SIZE(vec); - if (i & 1) return (Scheme_Object *)ht; /* defend against bad bytecode */ - - while (i -= 2) { - key = SCHEME_VEC_ELS(vec)[i]; - orig_val = SCHEME_VEC_ELS(vec)[i+1]; - - val = scheme_stx_force_delayed(orig_val); - if (val != orig_val) - SCHEME_VEC_ELS(vec)[i+1] = val; - - /* defend against bad bytecode here, too: */ - if (kind) { - if (!SCHEME_INTP(key) - || !SCHEME_VECTORP(val)) - key = NULL; - } else { - if (!SCHEME_SYMBOLP(key) - || ((!SCHEME_STXP(val) - || !SCHEME_SYMBOLP(SCHEME_STX_VAL(val))) - && !SAME_OBJ(val, scheme_true))) - key = NULL; - } - - if (key) { - if (kind) - val = vector_to_ht(val, 0); - else if (!SAME_OBJ(val, scheme_true)) - val = scheme_stx_force_delayed(val); - - ht = scheme_hash_tree_set(ht, key, val); - } - } - - return (Scheme_Object *)ht; -} - -void scheme_binding_names_from_module(Scheme_Env *menv) -{ - Scheme_Module *m; - Scheme_Object *binding_names; - - if (menv->binding_names - || !menv->module - || menv->binding_names_need_shift) - return; - - m = menv->module; - - if (menv->phase == 0) { - binding_names = m->binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 0); - m->binding_names = binding_names; - } - } else if (menv->phase == 1) { - binding_names = m->et_binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 0); - m->et_binding_names = binding_names; - } - } else if (m->other_binding_names) { - binding_names = m->other_binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 1); - m->other_binding_names = binding_names; - } - if (SCHEME_HASHTP(binding_names)) - binding_names = scheme_hash_get((Scheme_Hash_Table *)binding_names, scheme_env_phase(menv)); - else - binding_names = scheme_hash_tree_get((Scheme_Hash_Tree *)binding_names, scheme_env_phase(menv)); - } else - binding_names = NULL; - - menv->binding_names = binding_names; - menv->binding_names_need_shift = 1; + b = scheme_instance_variable_bucket_or_null(symbol, env->instance); + if (b) + return b->val; + else + return NULL; } -void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var) +Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env) { - Scheme_Object *id; - - if (!as_var) - val = SCHEME_PTR_VAL(val); /* remove "is a compile-time binding" wrapper */ - - if (!env - || (env->module - && !env->interactive_bindings - && !scheme_is_binding_rename_transformer(val))) - return; - - if (as_var) { - if (!env->shadowed_syntax) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->shadowed_syntax = ht; - } - - scheme_hash_set(env->shadowed_syntax, n, scheme_true); - } else { - if (env->shadowed_syntax) - scheme_hash_set(env->shadowed_syntax, n, NULL); - } - - scheme_binding_names_from_module(env); - - if (env->binding_names) { - if (SCHEME_HASHTP(env->binding_names)) - id = scheme_eq_hash_get((Scheme_Hash_Table *)env->binding_names, n); - else - id = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, n); - if (id && !SCHEME_STXP(id)) - id = NULL; - } else - id = NULL; - - if (!id) { - if (env->module) - return; - scheme_prepare_env_stx_context(env); - id = scheme_datum_to_syntax(n, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_module_context(id, env->stx_context); - } - - if (env->binding_names_need_shift) { - id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), - env->module->self_modidx, env->link_midx, - env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); - } - - scheme_add_module_binding(id, scheme_env_phase(env), - (env->module - ? (env->link_midx - ? env->link_midx - : env->module->self_modidx) - : scheme_false), - ((env->module && env->module->prefix) - ? env->module->prefix->src_insp_desc - : env->guard_insp), - n, - scheme_env_phase(env)); - - /* If the binding is a rename transformer, also install - a mapping */ - if (scheme_is_binding_rename_transformer(val)) - scheme_add_binding_copy(id, scheme_rename_transformer_id(val, NULL), scheme_env_phase(env)); -} - -static void install_one_binding_name(Scheme_Hash_Table *bt, Scheme_Object *name, Scheme_Object *id, Scheme_Env *benv) -{ - if (SCHEME_SYMBOLP(name) && SCHEME_STX_SYMBOLP(id)) { - if (benv->stx_context) - id = scheme_stx_push_introduce_module_context(id, benv->stx_context); - scheme_hash_set(bt, name, id); - } -} - -void scheme_install_binding_names(Scheme_Object *binding_namess, Scheme_Env *env) -/* binding_namess has a per-phase mapping of symbosl to identifier, recorded - when `define` and `define-syntaxes` forms were compiled at the top level; - install the symbol-to-identifier mapping that was recorded during compilation - into the current namespace */ -{ - Scheme_Env *benv; - Scheme_Object *sym, *id, *table; - Scheme_Hash_Tree *ht; - Scheme_Hash_Table *bt; - intptr_t i, phase; - - if (!binding_namess) return; - - while (SCHEME_PAIRP(binding_namess)) { - table = SCHEME_CAR(binding_namess); - if (!SCHEME_PAIRP(table)) - return; - phase = SCHEME_INT_VAL(SCHEME_CAR(table)); - table = SCHEME_CDR(table); - - if (phase < 0) - return; - - benv = env; - while (phase > 0) { - scheme_prepare_exp_env(benv); - benv = benv->exp_env; - phase--; - } - - bt = scheme_get_binding_names_table(benv); - - if (SCHEME_HASHTRP(table)) { - ht = (Scheme_Hash_Tree *)table; - i = -1; - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &sym, &id); - install_one_binding_name(bt, sym, id, benv); - } - } else if (SCHEME_VECTORP(table)) { - for (i = SCHEME_VEC_SIZE(table) >> 1; i--; ) { - install_one_binding_name(bt, SCHEME_VEC_ELS(table)[2*i], SCHEME_VEC_ELS(table)[2*i+1], benv); - } - } - - binding_namess = SCHEME_CDR(binding_namess); - } + return scheme_instance_variable_bucket(symbol, env->instance); } -/********** Auxilliary tables **********/ - -Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start) +void scheme_add_global(const char *name, Scheme_Object *obj, Scheme_Env *env) { - Scheme_Bucket_Table *ht; - Scheme_Object **t; - Scheme_Bucket **bs; - Scheme_Env *kenv; - intptr_t i; - int j; - - t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1)); -#ifdef MEMORY_COUNTING_ON - scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1); -#endif - - for (j = builtin_ref_counter + 1; j--; ) { - t[j] = scheme_false; - } - - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID)) - t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val; - } - } - - *_unsafe_start = builtin_unsafe_start; - - return t; + scheme_add_global_symbol(scheme_intern_symbol(name), obj, env); } -Scheme_Hash_Table *scheme_map_constants_to_globals(void) +void scheme_add_global_symbol(Scheme_Object *sym, Scheme_Object *obj, Scheme_Env *env) { - Scheme_Bucket_Table *ht; - Scheme_Hash_Table*result; - Scheme_Bucket **bs; - Scheme_Env *kenv; - intptr_t i; - int j; - - result = scheme_make_hash_table(SCHEME_hash_ptr); - - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) { - scheme_hash_set(result, b->val, (Scheme_Object *)b); - } - } - } - - return result; + Scheme_Bucket *b; + b = scheme_global_bucket(sym, env); + b->val = obj; } -const char *scheme_look_for_primitive(void *code) +Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]) { - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - Scheme_Env *kenv; - intptr_t i; - int j; - - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - if (SCHEME_PRIMP(b->val)) { - if (SCHEME_PRIM(b->val) == code) - return ((Scheme_Primitive_Proc *)b->val)->name; - } - } - } - } - - return NULL; + Scheme_Object *proc; + proc = scheme_get_startup_export("make-namespace"); + return scheme_apply(proc, argc, argv); } /*========================================================================*/ @@ -1840,1163 +813,6 @@ } /*========================================================================*/ -/* run-time and expansion-time Racket interface */ -/*========================================================================*/ - -static Scheme_Object * -namespace_identifier(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *obj; - Scheme_Env *genv; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-symbol->identifier", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1])) - scheme_wrong_contract("namespace-symbol->identifier", "namespace?", 1, argc, argv); - - if (argc > 1) - genv = (Scheme_Env *)argv[1]; - else - genv = scheme_get_env(NULL); - - obj = argv[0]; - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); - - scheme_prepare_env_stx_context(genv); - obj = scheme_stx_add_module_context(obj, genv->stx_context); - - return obj; -} - -static Scheme_Object * -namespace_module_identifier(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv; - Scheme_Object *phase; - - if (argc > 0) { - if (SCHEME_NAMESPACEP(argv[0])) { - genv = (Scheme_Env *)argv[0]; - phase = scheme_env_phase(genv); - } else if (SCHEME_FALSEP(argv[0])) { - phase = scheme_false; - } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) { - phase = argv[0]; - } else { - scheme_wrong_contract("namespace-module-identifier", "(or/c namespace? #f exact-integer?)", 0, argc, argv); - return NULL; - } - } else { - genv = scheme_get_env(NULL); - phase = scheme_env_phase(genv); - } - - return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, - scheme_sys_wraps_phase(phase), 0, 0); -} - -static Scheme_Object * -namespace_base_phase(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv; - - if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-base-phase", "namespace?", 0, argc, argv); - - if (argc) - genv = (Scheme_Env *)argv[0]; - else - genv = scheme_get_env(NULL); - - return scheme_env_phase(genv); -} - -static Scheme_Object * -namespace_variable_value(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v, *id = NULL; - Scheme_Env *genv; - int use_map; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-variable-value", "symbol?", 0, argc, argv); - use_map = ((argc > 1) ? SCHEME_TRUEP(argv[1]) : 1); - if ((argc > 2) && SCHEME_TRUEP(argv[2]) - && !scheme_check_proc_arity(NULL, 0, 2, argc, argv)) - scheme_wrong_contract("namespace-variable-value", "(or/c (-> any) #f)", 2, argc, argv); - if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3])) - scheme_wrong_contract("namespace-variable-value", "namespace?", 3, argc, argv); - - if (argc > 3) - genv = (Scheme_Env *)argv[3]; - else - genv = scheme_get_env(NULL); - - if (!use_map) - v = scheme_lookup_global(argv[0], genv); - else - v = scheme_namespace_lookup_value(argv[0], genv, &id, &use_map); - - if (!v) { - if ((argc > 2) && SCHEME_TRUEP(argv[2])) - return _scheme_tail_apply(argv[2], 0, NULL); - else if (use_map == -1) { - scheme_wrong_syntax("namespace-variable-value", NULL, id, "bound to syntax"); - return NULL; - } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0], - "namespace-variable-value: given name is not defined\n" - " name: %S", - argv[0]); - return NULL; - } - } - - return v; -} - -static Scheme_Object * -namespace_set_variable_value(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - Scheme_Bucket *bucket; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-set-variable-value!", "symbol?", 0, argc, argv); - if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3])) - scheme_wrong_contract("namespace-set-variable-value!", "namespace?", 3, argc, argv); - - if (argc > 3) - env = (Scheme_Env *)argv[3]; - else - env = scheme_get_env(NULL); - - bucket = scheme_global_bucket(argv[0], env); - - scheme_set_global_bucket("namespace-set-variable-value!", bucket, argv[1], 1); - - if ((argc > 2) && SCHEME_TRUEP(argv[2])) { - scheme_binding_names_from_module(env); - if (!env->binding_names - || (SCHEME_HASHTRP(env->binding_names) - && !scheme_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, argv[0])) - || (SCHEME_HASHTP(env->binding_names) - && !scheme_hash_get((Scheme_Hash_Table *)env->binding_names, argv[0]))) { - Scheme_Object *id; - id = scheme_datum_to_syntax(argv[0], scheme_false, scheme_false, 0, 0); - scheme_prepare_env_stx_context(env); - id = scheme_stx_add_module_context(id, env->stx_context); - (void)scheme_global_binding(id, env, 0); - } - scheme_shadow(env, argv[0], argv[1], 1); - } - - return scheme_void; -} - -static Scheme_Object * -namespace_undefine_variable(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - Scheme_Bucket *bucket; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-undefine-variable!", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1])) - scheme_wrong_contract("namespace-undefine-variable!", "namespace?", 1, argc, argv); - - if (argc > 1) - env = (Scheme_Env *)argv[1]; - else - env = scheme_get_env(NULL); - - if (scheme_lookup_global(argv[0], env)) { - bucket = scheme_global_bucket(argv[0], env); - scheme_set_global_bucket("namespace-undefine-variable!", - bucket, - NULL, - 0); - bucket->val = NULL; - } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0], - "namespace-undefine-variable!: given name is not defined\n" - " name: %S", - argv[0]); - } - - return scheme_void; -} - -static Scheme_Object * -namespace_mapped_symbols(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *l; - Scheme_Env *env; - Scheme_Hash_Table *mapped; - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - intptr_t i, j; - - if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-mapped-symbols", "namespace?", 0, argc, argv); - - if (argc) - env = (Scheme_Env *)argv[0]; - else - env = scheme_get_env(NULL); - - mapped = scheme_make_hash_table(SCHEME_hash_ptr); - - for (j = 0; j < 2; j++) { - if (j) - ht = env->syntax; - else - ht = env->toplevel; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - scheme_hash_set(mapped, (Scheme_Object *)b->key, scheme_true); - } - } - } - - if (env->stx_context) - scheme_module_context_add_mapped_symbols(env->stx_context, mapped); - - l = scheme_null; - for (i = mapped->size; i--; ) { - if (mapped->vals[i]) - l = scheme_make_pair(mapped->keys[i], l); - } - - return l; -} - -static Scheme_Object *namespace_module_registry(int argc, Scheme_Object **argv) -{ - if (!SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-module-registry", "namespace?", 0, argc, argv); - - return (Scheme_Object *)((Scheme_Env *)argv[0])->module_registry; -} - -static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - Scheme_Env *env; - intptr_t ph; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) { - v = NULL; - env = NULL; - } - else { - v = SCHEME_PTR1_VAL(argv[0]); - env = scheme_get_bucket_home((Scheme_Bucket *)v); - } - - if (!env) - scheme_wrong_contract(who, "variable-reference?", 0, argc, argv); - - ph = env->phase; - if (tl == 2) { - return scheme_make_integer(ph); - } else if (tl == 3) { - return scheme_make_integer(ph - env->mod_phase); - } else if (tl == 4) { - if (((Scheme_Object *)((Scheme_Bucket *)v)->key != scheme_stack_dump_key) - || !env->module) { - scheme_contract_error(who, - "variable reference does not refer to an anonymous module variable", - "variable reference", 1, argv[0], - NULL); - } - return env->access_insp; - } else if (tl) { - /* return env directly; need to set up */ - if (!env->mod_phase && env->module) - scheme_prep_namespace_rename(env); - env->interactive_bindings = 1; - } else { - /* new namespace: */ - Scheme_Env *new_env; - new_env = make_env(env, 0); - new_env->phase = env->phase; - env = new_env; - } - - return (Scheme_Object *)env; -} - -static Scheme_Object *variable_namespace(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->empty-namespace", 0, argc, argv); -} - -static Scheme_Object *variable_top_level_namespace(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->namespace", 1, argc, argv); -} - -static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->phase", 2, argc, argv); -} - -static Scheme_Object *variable_base_phase(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->base-phase", 3, argc, argv); -} - -static Scheme_Object *variable_inspector(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->module-declaration-inspector", 4, argc, argv); -} - -static Scheme_Object *variable_const_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - v = argv[0]; - - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) - scheme_wrong_contract("variable-reference-constant?", "variable-reference?", 0, argc, argv); - - if (SCHEME_VARREF_FLAGS(v) & 0x1) - return scheme_true; - - v = SCHEME_PTR1_VAL(v); - if (((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_IMMUTATED) - return scheme_true; - - return scheme_false; -} - -static Scheme_Object *variable_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - return env ? scheme_true : scheme_false; -} - -static Scheme_Object *variable_module_path(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->resolved-module-path", "variable-reference?", 0, argc, argv); - - if (env->module) - return env->module->modname; - else - return scheme_false; -} - -static Scheme_Object *variable_modidx(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->module-path-index", "variable-reference?", 0, argc, argv); - - if (env->module) { - if (!env->link_midx) { - if (env->module->self_modidx - && SCHEME_TRUEP(((Scheme_Modidx *)env->module->self_modidx)->path)) - return env->module->self_modidx; - else - return scheme_resolved_module_path_to_modidx(env->module->modname); - } else - return env->link_midx; - } else - return scheme_false; -} - -static Scheme_Object *variable_module_source(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->module-source", "variable-reference?", 0, argc, argv); - - if (env->module) - return scheme_resolved_module_path_value(env->module->modsrc); - else - return scheme_false; -} - -static Scheme_Object * -now_transforming(int argc, Scheme_Object *argv[]) -{ - return (scheme_current_thread->current_local_env - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -now_transforming_with_lifts(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env = scheme_current_thread->current_local_env; - - env = scheme_get_env_for_lifts(env); - - if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) - env = NULL; - - return (env - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -now_transforming_module(int argc, Scheme_Object *argv[]) -{ - if (scheme_get_module_lift_env(scheme_current_thread->current_local_env)) - return scheme_true; - return scheme_false; -} - -static void not_currently_transforming(const char *name) -{ - scheme_contract_error(name, - "not currently transforming", - NULL); -} - -static Scheme_Object * -do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *v, *sym, *a[2], *observer; - Scheme_Env *menv; - Scheme_Comp_Env *env; - int renamed = 0; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming(name); - - sym = argv[0]; - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(observer, sym); - - if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_contract(name, "identifier?", 0, argc, argv); - - if (argc > 1) { - scheme_check_proc_arity2(name, 0, 1, argc, argv, 1); - if ((argc > 2) - && SCHEME_TRUEP(argv[2])) { - Scheme_Comp_Env *stx_env; - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_contract(name, "(or/c internal-definition-context? #f)", 2, argc, argv); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; - if (!scheme_is_sub_env(stx_env, env)) { - scheme_contract_error(name, - "transforming context does not match given internal-definition context", - NULL); - } - env = stx_env; - } - } - - if (scheme_current_thread->current_local_scope) - sym = scheme_stx_flip_scope(sym, scheme_current_thread->current_local_scope, - scheme_env_phase(env->genv)); - - menv = NULL; - - while (1) { - v = scheme_compile_lookup(sym, env, - (SCHEME_NULL_FOR_UNBOUND - + SCHEME_RESOLVE_MODIDS - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST - + (!recur ? SCHEME_STOP_AT_FREE_EQ : 0)), - scheme_current_thread->current_local_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym); - - /* Deref globals */ - if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) - v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; - - if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_false); - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - return _scheme_tail_apply(argv[1], 0, NULL); - else - scheme_contract_error(name, - (renamed - ? "not defined as syntax (after renaming)" - : "not defined as syntax"), - "identifier", 1, argv[0], - NULL); - } - - v = SCHEME_PTR_VAL(v); - if (scheme_is_rename_transformer(v)) { - sym = scheme_transfer_srcloc(scheme_rename_transformer_id(v, NULL), sym); - renamed = 1; - menv = NULL; - SCHEME_USE_FUEL(1); - if (!recur) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - a[0] = v; - a[1] = sym; - return scheme_values(2, a); - } - } else if (!recur) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - a[0] = v; - a[1] = scheme_false; - return scheme_values(2, a); - } else { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - return v; - } - } -} - -static Scheme_Object * -local_exp_time_value(int argc, Scheme_Object *argv[]) -{ - return do_local_exp_time_value("syntax-local-value", argc, argv, 1); -} - -static Scheme_Object * -local_exp_time_value_one(int argc, Scheme_Object *argv[]) -{ - return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0); -} - -static Scheme_Object * -local_exp_time_name(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *sym; - - sym = scheme_current_thread->current_local_name; - if (!sym) - not_currently_transforming("syntax-local-name"); - - return sym; -} - -static Scheme_Object * -local_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-context"); - - if (env->flags & SCHEME_INTDEF_FRAME) { - if (!env->intdef_name) { - Scheme_Object *sym, *pr, *prev = NULL; - Scheme_Comp_Env *lenv = env; - char buf[22]; - while (1) { - if (env->flags & SCHEME_FOR_INTDEF) - lenv = lenv->next; - else { - sprintf(buf, "internal-define%d", intdef_counter++); - sym = scheme_make_symbol(buf); /* uninterned! */ - pr = scheme_make_pair(sym, scheme_null); - lenv->intdef_name = pr; - if (prev) - SCHEME_CDR(prev) = pr; - if (lenv->next->flags & SCHEME_INTDEF_FRAME) { - if (lenv->next->intdef_name) { - SCHEME_CDR(pr) = lenv->next->intdef_name; - break; - } else { - prev = pr; - lenv = lenv->next; - /* Go again to continue building the list */ - } - } else - break; - } - } - } - return env->intdef_name; - } else if (scheme_is_module_env(env)) - return scheme_intern_symbol("module"); - else if (scheme_is_module_begin_env(env)) - return scheme_intern_symbol("module-begin"); - else if (scheme_is_toplevel(env)) - return scheme_intern_symbol("top-level"); - else - return scheme_intern_symbol("expression"); -} - -static Scheme_Object * -local_phase_level(int argc, Scheme_Object *argv[]) -{ - Scheme_Thread *p = scheme_current_thread; - intptr_t phase; - - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : 0); - - return scheme_make_integer(phase); -} - -static Scheme_Object * -local_make_intdef_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env, *senv; - Scheme_Object *c, *rib; - void **d; - - d = MALLOC_N(void*, 4); - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-make-definition-context"); - - if (argc && SCHEME_TRUEP(argv[0])) { - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[0]))) - scheme_wrong_contract("syntax-local-make-definition-context", "(or/c internal-definition-context? #f)", 0, argc, argv); - senv = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[0]))[0]; - if (!scheme_is_sub_env(senv, env)) { - scheme_contract_error("syntax-local-make-definition-context", - "transforming context does " - "not match given internal-definition context", - NULL); - } - env = senv; - d[1] = argv[0]; - } - d[0] = env; - d[3] = env; - - rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE); - scheme_add_compilation_frame_intdef_scope(env, rib); - if ((argc > 1) && SCHEME_FALSEP(argv[1])) - rib = scheme_box(rib); /* box means "don't add context" for `local-expand` */ - - c = scheme_alloc_object(); - c->type = scheme_intdef_context_type; - SCHEME_PTR1_VAL(c) = d; - SCHEME_PTR2_VAL(c) = rib; - - return c; -} - -static Scheme_Object * -intdef_context_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-seal", - "internal-definition-context?", 0, argc, argv); - - return scheme_void; -} - -static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *res, *phase, *scope; - int mode = SCHEME_STX_FLIP; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-introduce", - "internal-definition-context?", 0, argc, argv); - - res = argv[1]; - if (!SCHEME_STXP(res)) - scheme_wrong_contract("internal-definition-context-introduce", - "syntax?", 1, argc, argv); - - if (argc > 2) - mode = scheme_get_introducer_mode("internal-definition-context-introduce", 2, argc, argv); - - phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(argv[0]))[0]); - - scope = SCHEME_PTR2_VAL(argv[0]); - if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope); - res = scheme_stx_adjust_scope(res, scope, phase, mode); - - return res; -} - -static Scheme_Object * -id_intdef_remove(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *l, *res, *scope, *phase; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("identifier-remove-from-definition-context", - "identifier?", 0, argc, argv); - - l = argv[1]; - if (!SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) { - while (SCHEME_PAIRP(l)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_intdef_context_type)) - break; - l = SCHEME_CDR(l); - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("identifier-remove-from-definition-context", - "(or/c internal-definition-context? (listof internal-definition-context?))", - 1, argc, argv); - } - - l = argv[1]; - if (SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) - l = scheme_make_pair(l, scheme_null); - - res = argv[0]; - - phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(SCHEME_CAR(l)))[0]); - - while (SCHEME_PAIRP(l)) { - scope = SCHEME_PTR2_VAL(SCHEME_CAR(l)); - if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope); - res = scheme_stx_remove_scope(res, scope, phase); - l = SCHEME_CDR(l); - } - - return res; -} - -static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-binding-identifiers", - "internal-definition-context?", - 0, argc, argv); - - return scheme_intdef_bind_identifiers(argv[0]); -} - -static Scheme_Object * -local_introduce(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *s; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-introduce"); - - s = argv[0]; - if (!SCHEME_STXP(s)) - scheme_wrong_contract("syntax-local-introduce", "syntax?", 0, argc, argv); - - if (scheme_current_thread->current_local_scope) - s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_scope, scheme_env_phase(env->genv)); - if (scheme_current_thread->current_local_use_scope) - s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_use_scope, scheme_env_phase(env->genv)); - - return s; -} - -static Scheme_Object * -local_get_shadower(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *sym; - int only_generated = 0; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-get-shadower"); - - sym = argv[0]; - if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_contract("syntax-local-get-shadower", "identifier?", 0, argc, argv); - - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - only_generated = 1; - - return scheme_get_shadower(sym, env, only_generated); -} - -int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv) -{ - int mode = SCHEME_STX_FLIP; - - if (SAME_OBJ(argv[which], flip_symbol)) - mode = SCHEME_STX_FLIP; - else if (SAME_OBJ(argv[which], add_symbol)) - mode = SCHEME_STX_ADD; - else if (SAME_OBJ(argv[which], remove_symbol)) - mode = SCHEME_STX_REMOVE; - else - scheme_wrong_contract(who, "(or/c 'flip 'add 'remove)", which, argc, argv); - - return mode; -} - -static Scheme_Object * -introducer_proc(void *info, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *s; - int mode = SCHEME_STX_FLIP; - - s = argv[0]; - if (!SCHEME_STXP(s)) { - scheme_wrong_contract("syntax-introducer", "syntax?", 0, argc, argv); - return NULL; - } - if (argc > 1) - mode = scheme_get_introducer_mode("syntax-introducer", 1, argc, argv); - - return scheme_stx_adjust_scope(s, ((Scheme_Object **)info)[0], ((Scheme_Object **)info)[1], mode); -} - -static Scheme_Object * -make_introducer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *scope, **info; - Scheme_Env *genv; - int kind; - - if ((argc > 0) && SCHEME_TRUEP(argv[0])) - kind = SCHEME_STX_USE_SITE_SCOPE; - else - kind = SCHEME_STX_MACRO_SCOPE; - - scope = scheme_new_scope(kind); - info = MALLOC_N(Scheme_Object*, 2); - - info[0] = scope; - if (scheme_current_thread->current_local_env) - info[1] = scheme_env_phase(scheme_current_thread->current_local_env->genv); - else { - genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV); - info[1] = scheme_env_phase(genv); - } - - return scheme_make_closed_prim_w_arity(introducer_proc, info, - "syntax-introducer", 1, 2); -} - -static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]) -{ - scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "syntax-local-make-delta-introducer: " NOT_SUPPORTED_STR); - ESCAPED_BEFORE_HERE; -} - -static Scheme_Object *local_binding_id(int argc, Scheme_Object **argv) -{ - Scheme_Object *a = argv[0]; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract("syntax-local-identifier-as-binding", "identifier?", 0, argc, argv); - - if (scheme_current_thread->current_local_env) - return scheme_revert_use_site_scopes(a, scheme_current_thread->current_local_env); - else - return a; -} - -Scheme_Object *scheme_get_local_inspector() -{ - Scheme_Thread *p = scheme_current_thread; - - if (p->current_local_menv) - return p->current_local_menv->access_insp; - else - return scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); -} - -static Scheme_Object * -local_module_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-module-exports"); - - return scheme_module_exported_list(argv[0], env->genv); -} - -static Scheme_Object *local_submodules(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *l, *r = scheme_null, *n; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-submodules"); - - if (env->genv->module) { - l = env->genv->module->pre_submodule_names; - if (!l) - l = env->genv->module->pre_submodules; - if (l) { - while (!SCHEME_NULLP(l)) { - n = SCHEME_CAR(l); - if (!SCHEME_SYMBOLP(n)) { - n = scheme_resolved_module_path_value(((Scheme_Module *)n)->modname); - while (SCHEME_PAIRP(SCHEME_CDR(n))) { - n = SCHEME_CDR(n); - } - n = SCHEME_CAR(n); - } - r = scheme_make_pair(n, r); - l = SCHEME_CDR(l); - } - } - } - - return r; -} - -static Scheme_Object * -local_module_definitions(int argc, Scheme_Object *argv[]) -{ - if (!scheme_current_thread->current_local_env - || !scheme_current_thread->current_local_bindings) - scheme_contract_error("syntax-local-module-defined-identifiers", - "not currently transforming module provides", - NULL); - - return SCHEME_CDR(scheme_current_thread->current_local_bindings); -} - -static Scheme_Object * -local_module_imports(int argc, Scheme_Object *argv[]) -{ - if (!scheme_current_thread->current_local_env - || !scheme_current_thread->current_local_bindings) - scheme_contract_error("syntax-local-module-required-identifiers", - "not currently transforming module provides", - NULL); - - if (SCHEME_TRUEP(argv[0]) && !scheme_is_module_path(argv[0])) - scheme_wrong_contract("syntax-local-module-required-identifiers", "(or/c module-path? #f)", 0, argc, argv); - - if (!SCHEME_FALSEP(argv[1]) - && !SAME_OBJ(scheme_true, argv[1]) - && !SCHEME_INTP(argv[1]) - && !SCHEME_BIGNUMP(argv[1])) - scheme_wrong_contract("syntax-local-module-required-identifiers", "(or/c exact-integer? #f #t)", 1, argc, argv); - - return scheme_module_imported_list(scheme_current_thread->current_local_env->genv, - scheme_current_thread->current_local_bindings, - argv[0], - argv[1]); -} - -static Scheme_Object * -local_module_expanding_provides(int argc, Scheme_Object *argv[]) -{ - if (scheme_current_thread->current_local_env - && scheme_current_thread->current_local_bindings) - return scheme_true; - else - return scheme_false; -} - -static Scheme_Object * -local_lift_expr(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *ids; - ids = scheme_do_local_lift_expr("syntax-local-lift-expression", 0, argc, argv); - return SCHEME_CAR(ids); -} - -static Scheme_Object * -local_lift_exprs(int argc, Scheme_Object *argv[]) -{ - return scheme_do_local_lift_expr("syntax-local-lift-values-expression", 1, argc, argv); -} - -static Scheme_Object * -local_lift_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-lift-context"); - - return scheme_local_lift_context(env); -} - -static Scheme_Object * -local_lift_end_statement(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope, *expr; - - expr = argv[0]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-lift-module-end-declaration", "syntax?", 0, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-module-end-declaration"); - - return scheme_local_lift_end_statement(expr, local_scope, env); -} - -static Scheme_Object * -local_lift_module(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope, *expr; - - expr = argv[0]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-lift-module", "syntax?", 0, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-module"); - - return scheme_local_lift_module(expr, local_scope, env); -} - -static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope; - intptr_t phase; - - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-local-lift-require", "syntax?", 1, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-require"); - - phase = env->genv->phase; - - return scheme_local_lift_require(argv[0], argv[1], phase, local_scope, env); -} - -static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *form, *local_scope; - - form = argv[0]; - if (!SCHEME_STXP(form)) - scheme_wrong_contract("syntax-local-lift-provide", "syntax?", 1, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-provide"); - - return scheme_local_lift_provide(form, local_scope, env); -} - -static Scheme_Object * -make_set_transformer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - scheme_check_proc_arity("make-set!-transformer", 1, 0, argc, argv); - - v = scheme_alloc_small_object(); - v->type = scheme_set_macro_type; - SCHEME_PTR_VAL(v) = argv[0]; - - return v; -} - -static Scheme_Object * -set_transformer_p(int argc, Scheme_Object *argv[]) -{ - return (scheme_is_set_transformer(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -set_transformer_proc(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_set_transformer(argv[0])) - scheme_wrong_contract("set!-transformer-procedure", "set!-transformer?", 0, argc, argv); - - return scheme_set_transformer_proc(argv[0]); -} - -static Scheme_Object * -make_rename_transformer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("make-rename-transformer", "identifier?", 0, argc, argv); - - v = scheme_alloc_object(); - v->type = scheme_id_macro_type; - SCHEME_PTR1_VAL(v) = argv[0]; - SCHEME_PTR2_VAL(v) = scheme_false; /* used to be an introducer procedure */ - - return v; -} - -static Scheme_Object * -rename_transformer_target(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_rename_transformer(argv[0])) - scheme_wrong_contract("rename-transformer-target", "rename-transformer?", 0, argc, argv); - - return scheme_rename_transformer_id(argv[0], NULL); -} - -static Scheme_Object * -rename_transformer_p(int argc, Scheme_Object *argv[]) -{ - return (scheme_is_rename_transformer(argv[0]) - ? scheme_true - : scheme_false); -} - -/*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/racket/src/error.c racket-7.0+ppa1/src/racket/src/error.c --- racket-6.12+ppa1/src/racket/src/error.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/error.c 2018-07-27 22:12:02.000000000 +0000 @@ -54,18 +54,13 @@ SHARED_OK static Scheme_Object *init_syslog_level = scheme_make_integer(INIT_SYSLOG_LEVEL); SHARED_OK static Scheme_Object *init_stderr_level = scheme_make_integer(SCHEME_LOG_ERROR); +SHARED_OK static Scheme_Object *init_stdout_level = scheme_make_integer(0); THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger); THREAD_LOCAL_DECL(static Scheme_Logger *scheme_gc_logger); THREAD_LOCAL_DECL(static Scheme_Logger *scheme_future_logger); THREAD_LOCAL_DECL(static Scheme_Logger *scheme_place_logger); /* readonly globals */ -READ_ONLY const char *scheme_compile_stx_string = "compile"; -READ_ONLY const char *scheme_expand_stx_string = "expand"; -READ_ONLY const char *scheme_application_stx_string = "application"; -READ_ONLY const char *scheme_set_stx_string = "set!"; -READ_ONLY const char *scheme_var_ref_string = "#%variable-reference"; -READ_ONLY const char *scheme_begin_stx_string = "begin"; ROSYM static Scheme_Object *none_symbol; ROSYM static Scheme_Object *fatal_symbol; ROSYM static Scheme_Object *error_symbol; @@ -103,7 +98,6 @@ /* locals */ static Scheme_Object *error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]); -static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[]); @@ -111,6 +105,7 @@ static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]); +static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]); static Scheme_Object *error_escape_handler(int, Scheme_Object *[]); static Scheme_Object *error_display_handler(int, Scheme_Object *[]); static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]); @@ -153,15 +148,23 @@ static char *make_provided_list(Scheme_Object *o, int count, intptr_t *lenout); static char *init_buf(intptr_t *len, intptr_t *blen); -void scheme_set_logging(int syslog_level, int stderr_level) + +void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level) { if (syslog_level > -1) init_syslog_level = scheme_make_integer(syslog_level); if (stderr_level > -1) init_stderr_level = scheme_make_integer(stderr_level); + if (stdout_level > -1) + init_stdout_level = scheme_make_integer(stdout_level); } -void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level) +void scheme_set_logging(int syslog_level, int stderr_level) +{ + scheme_set_logging2(syslog_level, stderr_level, -1); +} + +void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level) { /* A spec is (list* .... ) */ if (syslog_level) { @@ -172,6 +175,15 @@ REGISTER_SO(init_stderr_level); init_stderr_level = stderr_level; } + if (stdout_level) { + REGISTER_SO(init_stdout_level); + init_stdout_level = stdout_level; + } +} + +void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level) +{ + scheme_set_logging2_spec(syslog_level, stderr_level, NULL); } void scheme_init_logging_once(void) @@ -180,8 +192,12 @@ int j; Scheme_Object *l, *s; - for (j = 0; j < 2; j++) { - l = (j ? init_stderr_level : init_syslog_level); + for (j = 0; j < 3; j++) { + switch (j) { + case 0: l = init_syslog_level; break; + case 1: l = init_stderr_level; break; + default: l = init_stdout_level; break; + } if (l) { while (!SCHEME_INTP(l)) { l = SCHEME_CDR(l); @@ -755,7 +771,7 @@ return i; } -static intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...) +intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...) { intptr_t len; GC_CAN_IGNORE va_list args; @@ -776,9 +792,9 @@ #define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \ p = scheme_make_noncm_prim(func, name, a1, a2); \ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \ - scheme_add_global_constant(name, p, env); + scheme_addto_prim_instance(name, p, env); -void scheme_init_error(Scheme_Env *env) +void scheme_init_error(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -792,7 +808,6 @@ /* errors */ ESCAPING_NONCM_PRIM("error", error, 1, -1, env); ESCAPING_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env); - ESCAPING_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 5, env); ESCAPING_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env); @@ -801,39 +816,40 @@ ESCAPING_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env); scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1); - scheme_add_global_constant("raise-arity-error", scheme_raise_arity_error_proc, env); + scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env); + ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 2, -1, env); - GLOBAL_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env); - GLOBAL_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env); - GLOBAL_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env); - GLOBAL_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env); - GLOBAL_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env); - GLOBAL_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env); - GLOBAL_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env); - GLOBAL_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env); + ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env); + ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env); + ADD_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env); + ADD_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env); + ADD_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env); + ADD_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env); + ADD_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env); + ADD_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env); - GLOBAL_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); + ADD_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); /* logging */ - GLOBAL_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); - GLOBAL_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); - GLOBAL_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env); - GLOBAL_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env); - GLOBAL_NONCM_PRIM("make-logger", make_logger, 0, -1, env); - GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env); - - GLOBAL_PRIM_W_ARITY("log-message", log_message, 4, 6, env); - GLOBAL_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env); - - GLOBAL_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env); - - GLOBAL_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env); - - GLOBAL_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env); - GLOBAL_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env); + ADD_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); + ADD_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); + ADD_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env); + ADD_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env); + ADD_NONCM_PRIM("make-logger", make_logger, 0, -1, env); + ADD_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env); + + ADD_PRIM_W_ARITY("log-message", log_message, 4, 6, env); + ADD_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env); + ADD_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env); + + ADD_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env); + + ADD_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env); + + ADD_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env); + ADD_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env); + ADD_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env); REGISTER_SO(scheme_def_exit_proc); REGISTER_SO(default_display_handler); @@ -874,7 +890,7 @@ arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard); } - scheme_add_global_constant("prop:arity-string", arity_property, env); + scheme_addto_prim_instance("prop:arity-string", arity_property, env); REGISTER_SO(def_exe_yield_proc); def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler, @@ -893,6 +909,7 @@ scheme_main_logger = scheme_make_logger(NULL, NULL); scheme_main_logger->syslog_level = init_syslog_level; scheme_main_logger->stderr_level = init_stderr_level; + scheme_main_logger->stdout_level = init_stdout_level; REGISTER_SO(scheme_gc_logger); scheme_gc_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("GC")); @@ -1084,12 +1101,6 @@ len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL); HIDE_FROM_XFORM(va_end(args)); - if (scheme_current_thread->current_local_env) { - char *s2 = " [during expansion]"; - strcpy(buffer + len, s2); - len += strlen(s2); - } - buffer[len] = 0; if (scheme_starting_up) { @@ -2252,108 +2263,34 @@ } void scheme_read_err(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - int gotc, Scheme_Object *indentation, const char *detail, ...) { GC_CAN_IGNORE va_list args; - char *s, *ls, lbuf[30], *fn, *suggests; - intptr_t slen, fnlen; - int show_loc; - Scheme_Object *loc; + Scheme_Object *pn; + char *s, *fn; + intptr_t slen; HIDE_FROM_XFORM(va_start(args, detail)); slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); HIDE_FROM_XFORM(va_end(args)); - ls = ""; - fnlen = 0; - - show_loc = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)); - - /* Via read/recursive, it's possible that the reader will try to - complain about a character that precedes the start of a port. - In that case, pos can be 0. */ - if (!pos) line = col = pos = -1; - - if (stxsrc) { - Scheme_Object *xsrc; - - xsrc = scheme_make_stx_w_offset(scheme_false, line, col, pos, span, stxsrc, STX_SRCTAG); - - stxsrc = ((Scheme_Stx *)xsrc)->srcloc->src; - line = ((Scheme_Stx *)xsrc)->srcloc->line; - col = ((Scheme_Stx *)xsrc)->srcloc->col; - pos = ((Scheme_Stx *)xsrc)->srcloc->pos; - - if (show_loc) - fn = make_stx_srcloc_string(((Scheme_Stx *)xsrc)->srcloc, &fnlen); - else + if (port) { + pn = scheme_input_port_record(port)->name; + if (SCHEME_PATHP(pn)) { + pn = scheme_remove_current_directory_prefix(pn); + fn = SCHEME_PATH_VAL(pn); + } else fn = NULL; } else fn = NULL; - if (!fn && show_loc) { - intptr_t column; - - if (col < 0) - column = pos; - else - column = col; - - if (port) { - Scheme_Object *pn; - pn = scheme_input_port_record(port)->name; - if (SCHEME_PATHP(pn)) { - pn = scheme_remove_current_directory_prefix(pn); - fn = SCHEME_PATH_VAL(pn); - } else - fn = "UNKNOWN"; - } else - fn = "UNKNOWN"; - - fnlen = strlen(fn); - - if (column >= 0) { - scheme_sprintf(lbuf, 30, ":%L%ld", line, column-1); - ls = lbuf; - } else - ls = ": "; - } else if (!show_loc) { - fn = ""; - fnlen = 0; - } - - if (indentation) - suggests = scheme_extract_indentation_suggestions(indentation); + if (fn) + scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t\n in: %s", s, slen, fn); else - suggests = ""; + scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t", s, slen); +} - loc = scheme_make_location(stxsrc ? stxsrc : scheme_false, - (line < 0) ? scheme_false : scheme_make_integer(line), - (col < 0) ? scheme_false : scheme_make_integer(col-1), - (pos < 0) ? scheme_false : scheme_make_integer(pos), - (span < 0) ? scheme_false : scheme_make_integer(span)); - - scheme_raise_exn(((gotc == EOF) - ? MZEXN_FAIL_READ_EOF - : ((gotc == SCHEME_SPECIAL) - ? MZEXN_FAIL_READ_NON_CHAR - : MZEXN_FAIL_READ)), - scheme_make_pair(loc, scheme_null), - "%t%s%s%t%s%s", - fn, fnlen, ls, - fnlen ? ": " : "", - s, slen, - (*suggests ? "\n possible cause: " : ""), suggests); -} - -Scheme_Object *scheme_numr_err(Scheme_Object *complain, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation, - const char *detail, ...) +Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...) { GC_CAN_IGNORE va_list args; char *s; @@ -2366,20 +2303,14 @@ if (SCHEME_FALSEP(complain)) return scheme_make_sized_utf8_string(s, slen); - scheme_read_err(complain, - stxsrc, - line, col, pos, span, - 0, indentation, - "read: %s", s); + scheme_read_err(complain, "read: %s", s); ESCAPED_BEFORE_HERE; } static void do_wrong_syntax(const char *where, Scheme_Object *detail_form, Scheme_Object *form, - char *s, intptr_t slen, - Scheme_Object *extra_sources, - int exn_kind) + char *s, intptr_t slen) { intptr_t len, vlen, dvlen, blen, plen; char *buffer; @@ -2394,21 +2325,6 @@ slen = strlen(s); } - /* Check for special strings that indicate `form' doesn't have a - good name: */ - if ((where == scheme_compile_stx_string) - || (where == scheme_expand_stx_string)) { - where = NULL; - } else if (where == scheme_application_stx_string) { - who = scheme_intern_symbol("#%app"); - } else if ((where == scheme_set_stx_string) - || (where == scheme_var_ref_string) - || (where == scheme_begin_stx_string)) { - who = scheme_intern_symbol(where); - if (where == scheme_begin_stx_string) - where = "begin (possibly implicit)"; - } - buffer = init_buf(&len, &blen); p = NULL; @@ -2420,22 +2336,20 @@ Scheme_Object *pform; if (SCHEME_STXP(form)) { p = make_stx_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen); - pform = scheme_syntax_to_datum(form, 0, NULL); + pform = scheme_syntax_to_datum(form); /* Try to extract syntax name from syntax */ - if (!who && (SCHEME_SYMBOLP(SCHEME_STX_VAL(form)) || SCHEME_STX_PAIRP(form))) { + if (!who && (SCHEME_STX_SYMBOLP(form) || SCHEME_STX_PAIRP(form))) { Scheme_Object *first; if (SCHEME_STX_PAIRP(form)) first = SCHEME_STX_CAR(form); else first = form; - if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first))) - who = SCHEME_STX_VAL(first); /* printed name is local name */ + if (SCHEME_STX_SYMBOLP(first)) + who = SCHEME_STX_SYM(first); /* printed name is local name */ } } else { pform = form; - if (!detail_form) - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); } /* don't use error_write_to_string_w_max since this is code */ if (show_src) @@ -2455,17 +2369,8 @@ if (SCHEME_STXP(detail_form)) { if (((Scheme_Stx *)detail_form)->srcloc->line >= 0) p = make_stx_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen); - pform = scheme_syntax_to_datum(detail_form, 0, NULL); - /* To go in exn record: */ - form = detail_form; - } else { - pform = detail_form; - /* To go in exn record: */ - form = scheme_datum_to_syntax(detail_form, - /* Use source location of `form': */ - SCHEME_STXP(form) ? form : scheme_false, - scheme_false, 1, 0); } + pform = scheme_syntax_to_datum(detail_form); /* don't use error_write_to_string_w_max since this is code */ if (show_src) @@ -2528,16 +2433,7 @@ where, s, slen); - if (SCHEME_FALSEP(form)) - form = extra_sources; - else { - if (SCHEME_STXP(form)) - form = scheme_stx_taint(form); - form = scheme_make_pair(form, extra_sources); - } - - scheme_raise_exn(exn_kind, - form, + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%t", buffer, blen); } @@ -2560,46 +2456,7 @@ HIDE_FROM_XFORM(va_end(args)); } - do_wrong_syntax(where, detail_form, form, s, slen, scheme_null, MZEXN_FAIL_SYNTAX); -} - -void scheme_unbound_syntax(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - const char *detail, ...) -{ - char *s; - intptr_t slen; - GC_CAN_IGNORE va_list args; - - HIDE_FROM_XFORM(va_start(args, detail)); - slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); - HIDE_FROM_XFORM(va_end(args)); - - do_wrong_syntax(where, detail_form, form, s, slen, scheme_null, MZEXN_FAIL_SYNTAX_UNBOUND); -} - -void scheme_wrong_syntax_with_more_sources(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - Scheme_Object *extra_sources, - const char *detail, ...) -{ - char *s; - intptr_t slen; - - if (!detail) { - s = NULL; - slen = 0; - } else { - GC_CAN_IGNORE va_list args; - - HIDE_FROM_XFORM(va_start(args, detail)); - slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); - HIDE_FROM_XFORM(va_end(args)); - } - - do_wrong_syntax(where, detail_form, form, s, slen, extra_sources, MZEXN_FAIL_SYNTAX); + do_wrong_syntax(where, detail_form, form, s, slen); } void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv) @@ -2662,16 +2519,14 @@ "%s%sresult arity mismatch;\n" " expected number of values not received\n" " expected: %d\n" - " received: %d\n" - "%s%t%s" + " received: %d" + "%t\n" " values...:%t", where ? where : "", where ? ": " : "", expected, got, - slen ? " from: " : "", s, slen, - slen ? "\n" : "", v, vlen); scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, @@ -2713,42 +2568,33 @@ void scheme_unbound_global(Scheme_Bucket *b) { Scheme_Object *name = (Scheme_Object *)b->key; - Scheme_Env *home; + Scheme_Instance *home; home = scheme_get_bucket_home(b); - if (home && home->module) { + if (home) { + Scheme_Object *src_name; const char *errmsg; - char *phase, phase_buf[20], *phase_note = ""; - + if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) errmsg = ("%S: undefined;\n" " cannot reference an identifier before its definition\n" - " in module: %D%s%s"); + " in module: %D\n" + " internal name: %S"); else errmsg = ("%S: undefined;\n" - " cannot reference an identifier before its definition%_%s%s"); + " cannot reference an identifier before its definition%_%_"); - if (home->phase) { - sprintf(phase_buf, "\n phase: %" PRIdPTR "", home->phase); - phase = phase_buf; - if ((home->phase == 1) && (home->template_env)) { - if (scheme_lookup_in_table(home->template_env->toplevel, (const char *)name)) - phase_note = "\n explanation: cannot access the run-time definition"; - else if (home->template_env->syntax - && scheme_lookup_in_table(home->template_env->syntax, (const char *)name)) - phase_note = "\n explanation cannot access the syntax binding for run-time expressions"; - } - } else - phase = ""; + src_name = scheme_hash_tree_get(home->source_names, name); + if (!src_name) + src_name = name; scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, - name, + src_name, errmsg, name, - scheme_get_modsrc(home->module), - phase, - phase_note); + home->name, + name); } else { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, name, @@ -2901,51 +2747,6 @@ return do_error("raise-user-error", MZEXN_FAIL_USER, argc, argv); } -static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) -{ - const char *who; - Scheme_Object *str, *extra_sources = scheme_null; - - if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("raise-syntax-error", "(or/c symbol? #f)", 0, argc, argv); - if (!SCHEME_CHAR_STRINGP(argv[1])) - scheme_wrong_contract("raise-syntax-error", "string?", 1, argc, argv); - - if (SCHEME_SYMBOLP(argv[0])) - who = scheme_symbol_val(argv[0]); - else - who = NULL; - - str = argv[1]; - if (SCHEME_MUTABLEP(str)) { - str = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(str), - SCHEME_CHAR_STRLEN_VAL(str), - 1); - } - - if (argc > 4) { - extra_sources = argv[4]; - while (SCHEME_PAIRP(extra_sources)) { - if (!SCHEME_STXP(SCHEME_CAR(extra_sources))) - break; - extra_sources = SCHEME_CDR(extra_sources); - } - if (!SCHEME_NULLP(extra_sources)) { - scheme_wrong_contract("raise-syntax-error", "(listof syntax?)", 4, argc, argv); - return NULL; - } - extra_sources = argv[4]; - } - - scheme_wrong_syntax_with_more_sources(who, - ((argc > 3) && !SCHEME_FALSEP(argv[3])) ? argv[3] : NULL, - ((argc > 2) && !SCHEME_FALSEP(argv[2])) ? argv[2] : NULL, - extra_sources, - "%T", str); - - return NULL; -} - typedef void (*wrong_proc_t)(const char *name, const char *expected, int which, int argc, Scheme_Object **argv); @@ -3180,7 +2981,7 @@ if (!scheme_nonneg_exact_p(argv[1]) && !is_arity_at_least(argv[1]) && !is_arity_list(argv[1])) - scheme_wrong_contract("raise-mismatch-error", + scheme_wrong_contract("raise-arity-error", "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", 1, argc, argv); @@ -3216,6 +3017,50 @@ return NULL; } +static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]) +{ + const char *where = NULL, *detail = NULL; + Scheme_Object **got_argv; + int i, expected; + + if (SCHEME_FALSEP(argv[0])) + where = NULL; + else if (SCHEME_SYMBOLP(argv[0])) + where = scheme_symbol_val(argv[0]); + else + scheme_wrong_contract("raise-result-arity-error", "(or/c symbol? #f)", 0, argc, argv); + + if (SCHEME_INTP(argv[1])) { + expected = SCHEME_INT_VAL(argv[1]); + } else if (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1])) + expected = (int)(((unsigned)-1) >> 1); /* not right, but as big as we can report */ + else + expected = -1; + if (expected < 0) + scheme_wrong_contract("raise-result-arity-error", "exact-nonnegative-integer?", 1, argc, argv); + + if (SCHEME_FALSEP(argv[2])) + detail = NULL; + else if (SCHEME_CHAR_STRINGP(argv[2])) { + Scheme_Object *bstr; + bstr = scheme_char_string_to_byte_string(argv[2]); + detail = SCHEME_BYTE_STR_VAL(bstr); + } else + scheme_wrong_contract("raise-result-arity-error", "(or/c string? #f)", 2, argc, argv); + + got_argv = MALLOC_N(Scheme_Object*, argc-3); + for (i = 3; i < argc; i++) { + got_argv[i-3] = argv[i]; + } + + scheme_wrong_return_arity(where, expected, + argc-3, got_argv, + (detail ? "%s" : NULL), detail, + NULL); + + return scheme_void; +} + static Scheme_Object *good_print_width(int c, Scheme_Object **argv) { int ok; @@ -3354,7 +3199,6 @@ /* Some exns include srcloc in the msg, so skip the first srcloc of those when needed */ if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)) && (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[1]) - || scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[1]) || scheme_is_struct_instance(exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].type, argv[1]))) l = SCHEME_CDR(l); @@ -3738,6 +3582,9 @@ level = extract_max_spec_level(parent->stderr_level, name); if (level > want_level) want_level = level; + level = extract_max_spec_level(parent->stdout_level, name); + if (level > want_level) + want_level = level; if (parent->propagate_level) level = extract_max_spec_level(parent->propagate_level, name); @@ -3959,7 +3806,19 @@ fwrite(buffer, len, 1, stderr); fwrite("\n", 1, 1, stderr); } - + + if (extract_spec_level(logger->stdout_level, name) >= level) { + if (name) { + intptr_t slen; + slen = SCHEME_SYM_LEN(name); + fwrite(SCHEME_SYM_VAL(name), slen, 1, stdout); + fwrite(": ", 2, 1, stdout); + } + fwrite(buffer, len, 1, stdout); + fwrite("\n", 1, 1, stdout); + fflush(stdout); + } + queue = logger->readers; while (queue) { b = SCHEME_CAR(queue); @@ -4020,6 +3879,7 @@ logger.local_timestamp = 0; logger.syslog_level = init_syslog_level; logger.stderr_level = init_stderr_level; + logger.stdout_level = init_stdout_level; scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false); } @@ -4809,23 +4669,6 @@ return scheme_values(3, argv); } -static Scheme_Object *syntax_field_check(int argc, Scheme_Object **argv) -{ - Scheme_Object *l; - - l = argv[2]; - while (SCHEME_PAIRP(l)) { - if (!SCHEME_STXP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - - if (!SCHEME_NULLP(l)) - scheme_wrong_field_contract(argv[3], "(listof syntax?)", argv[2]); - - return scheme_values(3, argv); -} - static Scheme_Object *read_field_check(int argc, Scheme_Object **argv) { Scheme_Object *l; @@ -4863,52 +4706,6 @@ return scheme_values (3, argv); } -static Scheme_Object *module_path_field_check(int pos, int argc, Scheme_Object **argv) -{ - if (!scheme_is_module_path(argv[pos])) - scheme_wrong_field_contract(argv[pos+1], "(or/c #f module-path?)", argv[pos]); - - return scheme_values (pos+1, argv); -} - -static Scheme_Object *module_path_field_check_2(int argc, Scheme_Object **argv) -{ - return module_path_field_check(2, argc, argv); -} - -static Scheme_Object *module_path_field_check_3(int argc, Scheme_Object **argv) -{ - return module_path_field_check(3, argc, argv); -} - -static Scheme_Object *extract_syntax_locations(int argc, Scheme_Object **argv) -{ - if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[0])) { - Scheme_Object *stxs, *stx, *first = scheme_null, *last = NULL, *loco, *p; - Scheme_Stx_Srcloc *loc; - stxs = scheme_struct_ref(argv[0], 2); - while (SCHEME_PAIRP(stxs)) { - stx = SCHEME_CAR(stxs); - loc = ((Scheme_Stx *)stx)->srcloc; - loco = scheme_make_location(loc->src ? loc->src : scheme_false, - (loc->line >= 0) ? scheme_make_integer(loc->line) : scheme_false, - (loc->col >= 0) ? scheme_make_integer(loc->col-1) : scheme_false, - (loc->pos >= 0) ? scheme_make_integer(loc->pos) : scheme_false, - (loc->span >= 0) ? scheme_make_integer(loc->span) : scheme_false); - p = scheme_make_pair(loco, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - stxs = SCHEME_CDR(stxs); - } - return first; - } - scheme_wrong_contract("exn:fail:syntax-locations-accessor", "exn:fail:syntax?", 0, argc, argv); - return NULL; -} - static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv) { if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[0])) @@ -4917,33 +4714,7 @@ return NULL; } -static Scheme_Object *extract_module_path(int pos, int argc, Scheme_Object **argv, - int exn_kind, const - char *accessor_name, const char *contract) -{ - if (scheme_is_struct_instance(exn_table[exn_kind].type, argv[0])) - return scheme_struct_ref(argv[0], pos); - scheme_wrong_contract(accessor_name, contract, 0, argc, argv); - return NULL; -} - -static Scheme_Object *extract_module_path_2(int argc, Scheme_Object **argv) -{ - return extract_module_path(2, argc, argv, - MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, - "exn:fail:filesystem:missing-module:path-accessor", - "exn:fail:filesystem:missing-module?"); -} - -static Scheme_Object *extract_module_path_3(int argc, Scheme_Object **argv) -{ - return extract_module_path(3, argc, argv, - MZEXN_FAIL_SYNTAX_MISSING_MODULE, - "exn:fail:syntax:missing-module:path-accessor", - "exn:fail:syntax:missing-module?"); -} - -void scheme_init_exn(Scheme_Env *env) +void scheme_init_exn(Scheme_Startup_Env *env) { int i, j; Scheme_Object *tmpo, **tmpop; @@ -4991,20 +4762,20 @@ exn_table[i].count, EXN_FLAGS); for (j = exn_table[i].count - 1; j--; ) { - scheme_add_global_constant_symbol(exn_table[i].names[j], - values[j], - env); + scheme_addto_primitive_instance_by_symbol(exn_table[i].names[j], + values[j], + env); } } } - scheme_add_global_constant("uncaught-exception-handler", + scheme_addto_prim_instance("uncaught-exception-handler", scheme_register_parameter(init_exn_handler, "uncaught-exception-handler", MZCONFIG_INIT_EXN_HANDLER), env); - scheme_add_global_constant("raise", + scheme_addto_prim_instance("raise", scheme_make_noncm_prim(sch_raise, "raise", 1, 2), diff -Nru racket-6.12+ppa1/src/racket/src/eval.c racket-7.0+ppa1/src/racket/src/eval.c --- racket-6.12+ppa1/src/racket/src/eval.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/eval.c 2018-07-27 22:12:02.000000000 +0000 @@ -68,23 +68,21 @@ Bytecodes are not linear. They're actually trees of expression nodes. - Top-level variables (global or module) are referenced through the - Scheme stack, so that the variables can be "re-linked" each time a - module is instantiated. Syntax constants are similarly accessed - through the Scheme stack. The global variables and syntax objects - are sometimes called the "prefix", and scheme_push_prefix() - initializes the prefix portion of the stack. This prefix is - captured in a continuation that refers to global or module-level - variables (which is why the closure is not entirely flat). Special - GC support allows a prefix to be pruned to just the globals that - are used by live closures. + Top-level variables (imported or defined in a linklet) are + referenced through the Scheme stack, so that the variables can be + re-linked each time a linklet is instantiated. The top-level are + sometimes called the "prefix", and push_prefix() initializes the + prefix portion of the stack. This prefix is captured in a + continuation that refers to top-level variables (which is why the + closure is not entirely flat). Special GC support allows a prefix + to be pruned to just the globals that are used by live closures. Bytecode compilation: Compilation works in five passes. The first pass, called "compile", is the expander and compiler - front-end. See "compile.c", along with "compenv.c" and "module.c". + front-end. See "compile.c" along with "compenv.c". The second pass, called "letrec_check", determines which references to `letrec'-bound variables need to be guarded with a run-time @@ -141,7 +139,6 @@ #include "schpriv.h" #include "schrunst.h" -#include "schexpobs.h" #ifdef MZ_USE_FUTURES # include "future.h" #endif @@ -186,9 +183,6 @@ SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON; void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; } -SHARED_OK static int validate_compile_result = 0; -SHARED_OK static int recompile_every_compile = 0; - /* THREAD LOCAL SHARED */ THREAD_LOCAL_DECL(volatile int scheme_fuel_counter); #ifdef USE_STACK_BOUNDARY_VAR @@ -196,10 +190,12 @@ THREAD_LOCAL_DECL(uintptr_t volatile scheme_jit_stack_boundary); #endif THREAD_LOCAL_DECL(int scheme_continuation_application_count); -THREAD_LOCAL_DECL(static int generate_lifts_count); THREAD_LOCAL_DECL(int scheme_overflow_count); THREAD_LOCAL_DECL(Scheme_Prefix *scheme_prefix_finalize); THREAD_LOCAL_DECL(Scheme_Prefix *scheme_inc_prefix_finalize); +THREAD_LOCAL_DECL(Scheme_Object *is_syntax_proc); +THREAD_LOCAL_DECL(Scheme_Object *expander_syntax_to_datum_proc); +THREAD_LOCAL_DECL(Scheme_Bucket_Table *scheme_namespace_to_env); int scheme_get_overflow_count() { return scheme_overflow_count; } /* read-only globals */ @@ -207,67 +203,19 @@ READ_ONLY Scheme_Object *scheme_multiple_values; /* symbols */ -ROSYM static Scheme_Object *app_symbol; -ROSYM static Scheme_Object *datum_symbol; -ROSYM static Scheme_Object *top_symbol; -ROSYM static Scheme_Object *top_level_symbol; -ROSYM static Scheme_Object *define_values_symbol; -ROSYM static Scheme_Object *letrec_values_symbol; -ROSYM static Scheme_Object *lambda_symbol; -ROSYM static Scheme_Object *unknown_symbol; -ROSYM static Scheme_Object *void_link_symbol; -ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *letrec_syntaxes_symbol; -ROSYM static Scheme_Object *begin_symbol; -ROSYM static Scheme_Object *let_values_symbol; -ROSYM static Scheme_Object *module_symbol; -ROSYM static Scheme_Object *module_begin_symbol; -ROSYM static Scheme_Object *expression_symbol; -ROSYM static Scheme_Object *definition_context_symbol; ROSYM Scheme_Object *scheme_stack_dump_key; READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */ /* locals */ -static Scheme_Object *eval(int argc, Scheme_Object *argv[]); -static Scheme_Object *compile(int argc, Scheme_Object *argv[]); -static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *recompile(int argc, Scheme_Object *argv[]); -static Scheme_Object *expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv); -static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv); -static Scheme_Object *local_eval(int argc, Scheme_Object **argv); -static Scheme_Object *expand_once(int argc, Scheme_Object **argv); -static Scheme_Object *expand_to_top_form(int argc, Scheme_Object **argv); static Scheme_Object *enable_break(int, Scheme_Object *[]); -static Scheme_Object *current_eval(int argc, Scheme_Object *[]); -static Scheme_Object *current_compile(int argc, Scheme_Object *[]); - -static Scheme_Object *eval_stx(int argc, Scheme_Object *argv[]); -static Scheme_Object *compile_stx(int argc, Scheme_Object *argv[]); -static Scheme_Object *expand_stx(int argc, Scheme_Object **argv); -static Scheme_Object *expand_stx_once(int argc, Scheme_Object **argv); -static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv); -static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv); static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv); static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv); static Scheme_Object *use_jit(int argc, Scheme_Object **argv); static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv); -static Scheme_Object *recompile_top(Scheme_Object *top, int comp_flags); - -static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env); - void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full); -#ifdef MZ_PRECISE_GC -static void mark_pruned_prefixes(struct NewGC *gc); -static int check_pruned_prefix(void *p); -#endif - #define cons(x,y) scheme_make_pair(x,y) typedef void (*DW_PrePost_Proc)(void *); @@ -283,7 +231,7 @@ /*========================================================================*/ void -scheme_init_eval (Scheme_Env *env) +scheme_init_eval (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -305,111 +253,19 @@ scheme_multiple_values->type = scheme_multiple_values_type; #endif - REGISTER_SO(define_values_symbol); - REGISTER_SO(letrec_values_symbol); - REGISTER_SO(lambda_symbol); - REGISTER_SO(unknown_symbol); - REGISTER_SO(void_link_symbol); - REGISTER_SO(quote_symbol); - REGISTER_SO(letrec_syntaxes_symbol); - REGISTER_SO(begin_symbol); - REGISTER_SO(let_values_symbol); - - define_values_symbol = scheme_intern_symbol("define-values"); - letrec_values_symbol = scheme_intern_symbol("letrec-values"); - let_values_symbol = scheme_intern_symbol("let-values"); - lambda_symbol = scheme_intern_symbol("lambda"); - unknown_symbol = scheme_intern_symbol("unknown"); - void_link_symbol = scheme_intern_symbol("-v"); - quote_symbol = scheme_intern_symbol("quote"); - letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); - begin_symbol = scheme_intern_symbol("begin"); - - REGISTER_SO(module_symbol); - REGISTER_SO(module_begin_symbol); - REGISTER_SO(expression_symbol); - REGISTER_SO(top_level_symbol); - REGISTER_SO(definition_context_symbol); - - module_symbol = scheme_intern_symbol("module"); - module_begin_symbol = scheme_intern_symbol("module-begin"); - expression_symbol = scheme_intern_symbol("expression"); - top_level_symbol = scheme_intern_symbol("top-level"); - definition_context_symbol = scheme_intern_symbol("definition-context"); - - REGISTER_SO(app_symbol); - REGISTER_SO(datum_symbol); - REGISTER_SO(top_symbol); - - app_symbol = scheme_intern_symbol("#%app"); - datum_symbol = scheme_intern_symbol("#%datum"); - top_symbol = scheme_intern_symbol("#%top"); - REGISTER_SO(scheme_stack_dump_key); scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */ - GLOBAL_PRIM_W_ARITY2("eval", eval, 1, 2, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env); - - GLOBAL_PRIM_W_ARITY("compile", compile, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-expression-recompile", recompile, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compile-syntax", compile_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-expression?", compiled_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand", expand, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax", expand_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("local-expand", local_expand, 3, 4, env); - GLOBAL_PRIM_W_ARITY2("syntax-local-expand-expression", local_expand_expr, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-bind-syntaxes", local_eval, 3, 3, env); - GLOBAL_PRIM_W_ARITY("local-expand/capture-lifts", local_expand_catch_lifts, 3, 5, env); - GLOBAL_PRIM_W_ARITY("local-transformer-expand", local_transformer_expand, 3, 4, env); - GLOBAL_PRIM_W_ARITY("local-transformer-expand/capture-lifts", local_transformer_expand_catch_lifts, 3, 5, env); - GLOBAL_PRIM_W_ARITY("expand-once", expand_once, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax-once", expand_stx_once, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-to-top-form", expand_to_top_form, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax-to-top-form", expand_stx_to_top_form, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-syntax-introduce", top_introduce_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("break-enabled", enable_break, 0, 1, env); - - GLOBAL_PARAMETER("current-eval", current_eval, MZCONFIG_EVAL_HANDLER, env); - GLOBAL_PARAMETER("current-compile", current_compile, MZCONFIG_COMPILE_HANDLER, env); - GLOBAL_PARAMETER("compile-allow-set!-undefined", allow_set_undefined, MZCONFIG_ALLOW_SET_UNDEFINED, env); - GLOBAL_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env); - GLOBAL_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env); - GLOBAL_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env); - - if (scheme_getenv("PLT_VALIDATE_COMPILE")) { - /* Enables validation of bytecode as it is generated, - to double-check that the compiler is producing - valid bytecode as it should. */ - validate_compile_result = 1; - } + ADD_PRIM_W_ARITY("break-enabled", enable_break, 0, 1, env); - { - /* Enables re-running the optimizer N times on every compilation. */ - const char *s; - s = scheme_getenv("PLT_RECOMPILE_COMPILE"); - if (s) { - int i = 0; - while ((s[i] >= '0') && (s[i] <= '9')) { - recompile_every_compile = (recompile_every_compile * 10) + (s[i]-'0'); - i++; - } - if (recompile_every_compile <= 0) - recompile_every_compile = 1; - else if (recompile_every_compile > 32) - recompile_every_compile = 32; - } - } + ADD_PARAMETER("compile-allow-set!-undefined", allow_set_undefined, MZCONFIG_ALLOW_SET_UNDEFINED, env); + ADD_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env); + ADD_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env); + ADD_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env); } void scheme_init_eval_places() { -#ifdef MZ_PRECISE_GC - scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */ - scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; - GC_set_post_propagate_hook(mark_pruned_prefixes); - GC_set_treat_as_incremental_mark(scheme_prefix_type, check_pruned_prefix); -#endif #ifdef DEBUG_CHECK_STACK_FRAME_SIZE (void)scheme_do_eval(SCHEME_TAIL_CALL_WAITING, 0, NULL, 0); #endif @@ -836,227 +692,6 @@ } /*========================================================================*/ -/* linking variables */ -/*========================================================================*/ - -static Scheme_Object *link_module_variable(Scheme_Object *modidx, - Scheme_Object *varname, - int check_access, Scheme_Object *insp, - int pos, int mod_phase, - Scheme_Env *env, - Scheme_Object **exprs, int which, - int flags, Scheme_Object *shape) -{ - Scheme_Object *modname; - Scheme_Env *menv; - Scheme_Bucket *bkt; - int self = 0; - - /* If it's a name id, resolve the name. */ - modname = scheme_module_resolve(modidx, 1); - - if (env->module && SAME_OBJ(env->module->modname, modname) - && (env->mod_phase == mod_phase)) { - self = 1; - menv = env; - } else { - menv = scheme_module_access(modname, env, mod_phase); - - if (!menv) { - Scheme_Object *modsrc; - modsrc = (env->module - ? scheme_get_modsrc(env->module) - : scheme_false); - scheme_wrong_syntax("link", NULL, varname, - "namespace mismatch;\n" - " reference to a module that is not available\n" - " reference phase: %d\n" - " referenced module: %D\n" - " referenced phase level: %d\n" - " reference in module: %D", - env->phase, - modname, - mod_phase, - modsrc); - return NULL; - } - - if (check_access && !SAME_OBJ(menv, env)) { - varname = scheme_check_accessible_in_module_instance(menv, varname, NULL, - NULL, insp, - pos, 0, - NULL, NULL, - env, NULL, NULL); - } - } - - if (exprs) { - Scheme_Object *simplified; - if (self) { - simplified = varname; - } else { - if (flags & SCHEME_MODVAR_CONST) { - Scheme_Object *v; - v = scheme_make_vector((mod_phase != 0) ? 4 : 3, modname); - SCHEME_VEC_ELS(v)[1] = varname; - SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false); - if (mod_phase != 0) - SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase); - simplified = v; - } else { - Scheme_Object *v = modname; - if (mod_phase != 0) - v = scheme_make_pair(v, scheme_make_integer(mod_phase)); - v = scheme_make_pair(varname, v); - simplified = v; - } - simplified = scheme_make_mutable_pair(simplified, exprs[which]); - } - exprs[which] = simplified; - } - - bkt = scheme_global_bucket(varname, menv); - if (!self) { - const char *bad_reason = NULL; - - if (!bkt->val) { - bad_reason = "is uninitialized"; - } else if (flags) { - if (flags & SCHEME_MODVAR_CONST) { - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_CONSISTENT)) - bad_reason = "is not a procedure or structure-type constant across all instantiations"; - else if (shape && SCHEME_TRUEP(shape)) { - if (!scheme_get_or_check_procedure_shape(bkt->val, shape)) - bad_reason = "has the wrong procedure or structure-type shape"; - } - } else { - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_CONST | GLOB_IS_IMMUTATED))) - bad_reason = "is not constant"; - } - } - - if (bad_reason) { - Scheme_Object *modsrc; - modsrc = (env->module - ? scheme_get_modsrc(env->module) - : scheme_false); - scheme_wrong_syntax("link", NULL, varname, - "bad variable linkage;\n" - " reference to a variable that %s\n" - " reference phase level: %d\n" - " variable module: %D\n" - " variable phase: %d\n" - " reference in module: %D", - bad_reason, - env->phase, - modname, - mod_phase, - modsrc); - } - - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_IMMUTATED | GLOB_IS_LINKED))) - ((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED; - } - - return (Scheme_Object *)bkt; -} - -static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env, - Scheme_Object *src_modidx, - Scheme_Object *dest_modidx, - Scheme_Object *insp) -{ - Scheme_Object *expr = exprs[which]; - - if (SCHEME_MPAIRP(expr)) { - /* Simplified reference was installed by link_module_variable; - simplified is in CAR, and original is in CDR */ - expr = SCHEME_CAR(expr); - } - - if (SCHEME_FALSEP(expr)) { - /* See scheme_make_environment_dummy */ - Scheme_Bucket *b; - b = scheme_global_bucket(scheme_stack_dump_key, env); - if (!(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK)) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_STRONG_HOME_LINK; - ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)env; - } - return (Scheme_Object *)b; - } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr) || SCHEME_VECTORP(expr)) { - /* Simplified module reference (as installed by link_module_variable) */ - Scheme_Object *modname, *varname, *shape; - int mod_phase = 0, flags = 0; - if (SCHEME_SYMBOLP(expr)) { - if (!env->module) { - /* compiled as a module variable, but instantiated in a non-module - namespace; grab a bucket */ - return (Scheme_Object *)scheme_global_bucket(expr, env); - } else { - varname = expr; - modname = env->module->modname; - mod_phase = env->mod_phase; - } - shape = NULL; - } else if (SCHEME_PAIRP(expr)) { - varname = SCHEME_CAR(expr); - modname = SCHEME_CDR(expr); - if (SCHEME_PAIRP(modname)) { - mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname)); - modname = SCHEME_CAR(modname); - } - shape = NULL; - } else { - modname = SCHEME_VEC_ELS(expr)[0]; - varname = SCHEME_VEC_ELS(expr)[1]; - flags = SCHEME_MODVAR_CONST; - shape = SCHEME_VEC_ELS(expr)[2]; - if (SCHEME_VEC_SIZE(expr) > 3) - mod_phase = SCHEME_INT_VAL(SCHEME_VEC_ELS(expr)[3]); - } - return link_module_variable(modname, - varname, - 0, NULL, - -1, mod_phase, - env, - NULL, 0, - flags, shape); - } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) { - Scheme_Bucket *b = (Scheme_Bucket *)expr; - Scheme_Env *home; - - home = scheme_get_bucket_home(b); - - if (!env) - return (Scheme_Object *)b; - else if (!home || !home->module) - return (Scheme_Object *)scheme_global_bucket((Scheme_Object *)b->key, env); - else - return link_module_variable(home->module->modname, - (Scheme_Object *)b->key, - 1, home->access_insp, - -1, home->mod_phase, - env, - exprs, which, - 0, NULL); - } else { - Module_Variable *mv = (Module_Variable *)expr; - - if ((!insp || SCHEME_FALSEP(insp)) && !mv->insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - return link_module_variable(scheme_modidx_shift(mv->modidx, - src_modidx, - dest_modidx), - mv->sym, 1, (mv->insp ? mv->insp : insp), - mv->pos, mv->mod_phase, - env, - exprs, which, - SCHEME_MODVAR_FLAGS(mv) & 0x3, mv->shape); - } -} - -/*========================================================================*/ /* continuation marks */ /*========================================================================*/ @@ -1243,9 +878,6 @@ MZ_DO_NOT_INLINE(static Scheme_Object *apply_values_execute(Scheme_Object *data)); MZ_DO_NOT_INLINE(static Scheme_Object *bangboxenv_execute(Scheme_Object *data)); MZ_DO_NOT_INLINE(static Scheme_Object *begin0_execute(Scheme_Object *obj)); -MZ_DO_NOT_INLINE(static Scheme_Object *splice_execute(Scheme_Object *data)); -MZ_DO_NOT_INLINE(static Scheme_Object *define_syntaxes_execute(Scheme_Object *form)); -MZ_DO_NOT_INLINE(static Scheme_Object *begin_for_syntax_execute(Scheme_Object *form)); /* called in schapp.h */ static Scheme_Object *do_apply_known_k(void) @@ -1926,9 +1558,9 @@ && (val || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_LINKED))) b->val = val; else { - Scheme_Env *home; + Scheme_Instance *home; home = scheme_get_bucket_home(b); - if (home && home->module) { + if (home) { const char *msg; int is_set; @@ -1960,7 +1592,7 @@ : "constant") : "variable"), (Scheme_Object *)b->key, - scheme_get_modsrc(home->module)); + home->name); } else { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, "%s: " CANNOT_SET_ERROR_STR ";\n" @@ -1989,28 +1621,16 @@ b->val = macro; } -static Scheme_Object * -define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, - Resolve_Prefix *rp, Scheme_Env *dm_env, - Scheme_Dynamic_State *dyn_state) +static Scheme_Object *define_values_execute(Scheme_Object *vec) { - Scheme_Object *name, *macro, *vals_expr, *vals, *var; + Scheme_Object *name, *vals_expr, *vals, *var; + int delta = 1; int i, g, show_any; Scheme_Bucket *b; - Scheme_Object **save_runstack = NULL; vals_expr = SCHEME_VEC_ELS(vec)[0]; - if (dm_env) { - scheme_prepare_exp_env(dm_env); - - save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); - scheme_pop_prefix(save_runstack); - } else { - vals = _scheme_eval_linked_expr_multi(vals_expr); - dm_env = NULL; - } + vals = _scheme_eval_linked_expr_multi(vals_expr); if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { Scheme_Object **values; @@ -2026,49 +1646,34 @@ scheme_current_thread->values_buffer = NULL; scheme_current_thread->ku.multiple.array = NULL; - if (dm_env) - is_st = 0; - else if (scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, - NULL, NULL, NULL, NULL, - NULL, NULL, MZ_RUNSTACK, 0, - NULL, NULL, NULL, 5)) - is_st = 1; - else if (scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, - NULL, NULL, NULL, NULL, MZ_RUNSTACK, 0, - NULL, NULL, 5)) - is_st = 1; - else - is_st = 0; + is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, + NULL, NULL, NULL, NULL, + NULL, MZ_RUNSTACK, 0, + NULL, NULL, 5); + if (!is_st) + is_st = scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, + NULL, NULL, NULL, MZ_RUNSTACK, 0, + NULL, 5); for (i = 0; i < g; i++) { - var = SCHEME_VEC_ELS(vec)[i+delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); + Scheme_Prefix *toplevels; - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; - - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0); - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - scheme_set_global_bucket("define-values", b, values[i], 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, values[i], 1); + var = SCHEME_VEC_ELS(vec)[i+delta]; + if (SAME_TYPE(SCHEME_TYPE(var), scheme_toplevel_type)) { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + } else + b = (Scheme_Bucket *)SCHEME_STATIC_TOPLEVEL_PREFIX(var)->a[SCHEME_TOPLEVEL_POS(var)]; - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - if (is_st) - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); - else - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - } + scheme_set_global_bucket("define-values", b, values[i], 1); + + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { + if (is_st) + ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); + else + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; } } - if (defmacro) - scheme_pop_prefix(save_runstack); return scheme_void; } else { @@ -2076,66 +1681,39 @@ scheme_current_thread->values_buffer = NULL; } } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */ - var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); + Scheme_Prefix *toplevels; - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = vals; - - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0); - } else { - Scheme_Prefix *toplevels; + var = SCHEME_VEC_ELS(vec)[delta]; + if (SAME_TYPE(SCHEME_TYPE(var), scheme_toplevel_type)) { toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + } else + b = (Scheme_Bucket *)SCHEME_STATIC_TOPLEVEL_PREFIX(var)->a[SCHEME_TOPLEVEL_POS(var)]; - scheme_set_global_bucket("define-values", b, vals, 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, vals, 1); - - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - int flags = GLOB_IS_IMMUTATED; - if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED)) - flags |= GLOB_IS_CONSISTENT; - ((Scheme_Bucket_With_Flags *)b)->flags |= flags; - } + scheme_set_global_bucket("define-values", b, vals, 1); - if (defmacro) - scheme_pop_prefix(save_runstack); + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { + int flags = GLOB_IS_IMMUTATED; + if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED) + || (SCHEME_TYPE(vals_expr) >= _scheme_values_types_)) + flags |= GLOB_IS_CONSISTENT; + ((Scheme_Bucket_With_Flags *)b)->flags |= flags; } return scheme_void; } else g = 1; - - /* Special handling of 0 values for define-syntaxes: - just create binding. This makes (define-values (a b c) (values)) - a kind of declaration form, which is useful is - a, b, or c is introduced by a macro. */ - if (dm_env && !g) { - for (i = SCHEME_VEC_SIZE(vec) - delta; i--; ) { - b = scheme_global_keyword_bucket(SCHEME_VEC_ELS(vec)[i+delta], dm_env); - scheme_shadow(dm_env, (Scheme_Object *)b->key, scheme_false, 1); - } - return scheme_void; - } i = SCHEME_VEC_SIZE(vec) - delta; show_any = i; if (show_any) { + Scheme_Prefix *toplevels; var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); - name = (Scheme_Object *)b->key; - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - name = (Scheme_Object *)b->key; - } + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + name = (Scheme_Object *)b->key; } else name = NULL; @@ -2144,9 +1722,7 @@ symname = (show_any ? scheme_symbol_name(name) : ""); - scheme_wrong_return_arity((defmacro - ? "define-syntaxes" - : "define-values"), + scheme_wrong_return_arity("define-values", i, g, (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, "\n in: %s%s%s", @@ -2158,11 +1734,6 @@ return NULL; } -static Scheme_Object *define_values_execute(Scheme_Object *data) -{ - return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL); -} - static Scheme_Object *set_execute (Scheme_Object *data) { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; @@ -2172,9 +1743,12 @@ val = _scheme_eval_linked_expr(sb->val); - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(sb->var)]; - var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(sb->var)]; - + if (SAME_TYPE(SCHEME_TYPE(sb->var), scheme_toplevel_type)) { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(sb->var)]; + var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(sb->var)]; + } else + var = (Scheme_Bucket *)SCHEME_STATIC_TOPLEVEL_PREFIX(sb->var)->a[SCHEME_TOPLEVEL_POS(sb->var)]; + scheme_set_global_bucket("set!", var, val, sb->set_undef); return scheme_void; @@ -2185,23 +1759,34 @@ Scheme_Prefix *toplevels; Scheme_Object *o; Scheme_Object *var; - Scheme_Object *tl = SCHEME_PTR1_VAL(data); - Scheme_Env *env; + Scheme_Object *tl; + Scheme_Instance *home; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; - var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; - if (SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) - env = NULL; - else - env = scheme_environment_from_dummy(SCHEME_PTR2_VAL(data)); + tl = SCHEME_PTR1_VAL(data); + if (SCHEME_FALSEP(tl)) + var = NULL; + else if (SCHEME_SYMBOLP(tl) || SAME_OBJ(tl, scheme_true)) + var = tl; + else { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; + var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + } + + tl = SCHEME_PTR2_VAL(data); + if (SCHEME_FALSEP(tl)) + home = NULL; + else { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; + o = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + home = scheme_get_bucket_home((Scheme_Bucket *)o); + } o = scheme_alloc_object(); o->type = scheme_global_ref_type; - SCHEME_PTR1_VAL(o) = var; - SCHEME_PTR2_VAL(o) = (env ? (Scheme_Object *)env : scheme_false); + SCHEME_PTR1_VAL(o) = (var ? var : scheme_false); + SCHEME_PTR2_VAL(o) = (home ? (Scheme_Object *)home : scheme_false); - if (SCHEME_VARREF_FLAGS(data) & 0x1) - SCHEME_VARREF_FLAGS(o) |= 0x1; + SCHEME_VARREF_FLAGS(data) |= (SCHEME_VARREF_FLAGS(o) & VARREF_FLAGS_MASK); return o; } @@ -2365,123 +1950,6 @@ return v; } -static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv) -{ - return _scheme_eval_linked_expr_multi((Scheme_Object *)expr); -} - -static Scheme_Object *splice_execute(Scheme_Object *data) -{ - if (SAME_TYPE(SCHEME_TYPE(data), scheme_splice_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)data; - int i, cnt = seq->count - 1; - - for (i = 0; i < cnt; i++) { - ignore_result(_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i])); - } - - return _scheme_eval_linked_expr_multi(seq->array[cnt]); - } else { - /* sequence was optimized on read? */ - return _scheme_eval_linked_expr_multi(data); - } -} - -static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env); - -static void *define_syntaxes_execute_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = p->ku.k.p1; - Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - return do_define_syntaxes_execute(form, dm_env); -} - -static Scheme_Object * -do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) -{ - Scheme_Thread *p = scheme_current_thread; - Resolve_Prefix *rp; - Scheme_Object *base_stack_depth, *dummy; - int depth; - Scheme_Comp_Env *rhs_env; - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1]; - base_stack_depth = SCHEME_VEC_ELS(form)[2]; - - depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1; - if (!scheme_check_runstack(depth)) { - p->ku.k.p1 = form; - - if (!dm_env) { - /* Need to get env before we enlarge the runstack: */ - dummy = SCHEME_VEC_ELS(form)[3]; - dm_env = scheme_environment_from_dummy(dummy); - } - p->ku.k.p2 = (Scheme_Object *)dm_env; - - return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); - } - - dummy = SCHEME_VEC_ELS(form)[3]; - - rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, NULL, - SCHEME_TOPLEVEL_FRAME); - - if (!dm_env) - dm_env = scheme_environment_from_dummy(dummy); - - { - Scheme_Dynamic_State dyn_state; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - scheme_prepare_exp_env(dm_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)dm_env->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - dm_env, dm_env->link_midx); - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) { - (void)define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state); - } else { - Scheme_Object **save_runstack; - - form = SCHEME_VEC_ELS(form)[0]; - - save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); - - while (!SCHEME_NULLP(form)) { - ignore_result(scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state)); - form = SCHEME_CDR(form); - } - - scheme_pop_prefix(save_runstack); - } - - scheme_pop_continuation_frame(&cframe); - - return scheme_void; - } -} - -static Scheme_Object *define_syntaxes_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL); -} - -static Scheme_Object *begin_for_syntax_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL); -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -2582,7 +2050,6 @@ (char *)SCHEME_VEC_ELS(vinfo)[1], (Validate_TLS)SCHEME_VEC_ELS(vinfo)[2], SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]), - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]), SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]), (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[8]) ? (void *)SCHEME_VEC_ELS(vinfo)[8] @@ -3263,6 +2730,17 @@ global_lookup(v = , obj, v); goto returnv_never_multi; } + case scheme_static_toplevel_type: + { + obj = SCHEME_STATIC_TOPLEVEL_PREFIX(obj)->a[SCHEME_TOPLEVEL_POS(obj)]; + v = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->val; + if (!v) { + UPDATE_THREAD_RSPTR_FOR_ERROR(); + scheme_unbound_global((Scheme_Bucket *)obj); + return NULL; + } + goto returnv_never_multi; + } case scheme_local_type: { v = RUNSTACK[SCHEME_LOCAL_POS(obj)]; @@ -3811,27 +3289,6 @@ goto eval_top; } - case scheme_quote_syntax_type: - { - GC_CAN_IGNORE Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - Scheme_Prefix *globs; - int i, c, pos; - - i = qs->position; - c = qs->depth; - pos = qs->midpoint; - - globs = (Scheme_Prefix *)RUNSTACK[c]; - v = globs->a[i+pos+1]; - if (!v) { - v = globs->a[pos]; - v = scheme_delayed_shift((Scheme_Object **)v, i); - globs->a[i+pos+1] = v; - } - - goto returnv_never_multi; - } - case scheme_define_values_type: { UPDATE_THREAD_RSPTR(); @@ -3843,18 +3300,6 @@ obj = SCHEME_VEC_ELS(obj)[0]; goto eval_top; } - case scheme_define_syntaxes_type: - { - UPDATE_THREAD_RSPTR(); - v = define_syntaxes_execute(obj); - break; - } - case scheme_begin_for_syntax_type: - { - UPDATE_THREAD_RSPTR(); - v = begin_for_syntax_execute(obj); - break; - } case scheme_set_bang_type: { UPDATE_THREAD_RSPTR(); @@ -3873,18 +3318,6 @@ v = begin0_execute(obj); break; } - case scheme_splice_sequence_type: - { - UPDATE_THREAD_RSPTR(); - v = splice_execute(obj); - break; - } - case scheme_require_form_type: - { - UPDATE_THREAD_RSPTR(); - v = scheme_top_level_require_execute(obj); - break; - } case scheme_varref_form_type: { UPDATE_THREAD_RSPTR(); @@ -3932,12 +3365,6 @@ v = scheme_case_lambda_execute(obj); break; } - case scheme_module_type: - { - UPDATE_THREAD_RSPTR(); - v = scheme_module_execute(obj, NULL); - break; - } default: v = obj; goto returnv_never_multi; @@ -4004,1569 +3431,237 @@ /* eval/compile/expand starting points */ /*========================================================================*/ -Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv) +Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]) { - scheme_prepare_env_stx_context(genv); + Scheme_Object *proc; + proc = scheme_get_startup_export("dynamic-require"); + return scheme_apply(proc, argc, argv); +} - if (SCHEME_STX_PAIRP(form)) { - Scheme_Object *a, *d, *module_stx; - - a = SCHEME_STX_CAR(form); - if (SCHEME_STX_SYMBOLP(a)) { - a = scheme_stx_push_module_context(a, genv->stx_context); - module_stx = scheme_datum_to_syntax(module_symbol, - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 0); - if (scheme_stx_free_eq(a, module_stx, genv->phase)) { - /* Don't add context to the whole module, since the - `module` form will just discard it: */ - d = SCHEME_STX_CDR(form); - a = scheme_make_pair(a, d); - form = scheme_datum_to_syntax(a, form, form, 0, 1); - return form; - } - } - } +int scheme_is_syntax(Scheme_Object *v) +{ + Scheme_Object *a[1]; + if (!is_syntax_proc) { + REGISTER_SO(is_syntax_proc); + is_syntax_proc = scheme_get_startup_export("syntax?"); + } + a[0] = v; + return SCHEME_TRUEP(scheme_apply(is_syntax_proc, 1, a)); +} - form = scheme_stx_push_module_context(form, genv->stx_context); +Scheme_Object *scheme_expander_syntax_to_datum(Scheme_Object *v) +{ + Scheme_Object *a[1]; + if (scheme_starting_up) + return v; + else { + if (!expander_syntax_to_datum_proc) { + REGISTER_SO(expander_syntax_to_datum_proc); + expander_syntax_to_datum_proc = scheme_get_startup_export("maybe-syntax->datum"); + } + a[0] = v; + return scheme_apply(expander_syntax_to_datum_proc, 1, a); + } +} - return form; +Scheme_Object *scheme_namespace_require(Scheme_Object *mod_path) +{ + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("namespace-require"); + a[0] = mod_path; + return scheme_apply(proc, 1, a); } -static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_eval) +static Scheme_Env *namespace_to_env(Scheme_Object *ns) { - Scheme_Object *argv[2], *o; + Scheme_Env *env; - argv[0] = form; - argv[1] = (immediate_eval ? scheme_true : scheme_false); - o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER); - o = scheme_apply(o, 2, argv); - - if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { - argv[0] = o; - scheme_wrong_contract("compile-handler", "compiled-expression?", 0, -1, argv); - return NULL; + env = scheme_lookup_in_table(scheme_namespace_to_env, (char *)ns); + + if (!env) { + env = MALLOC_ONE_TAGGED(Scheme_Env); + env->so.type = scheme_env_type; + env->namespace = ns; + scheme_add_to_table(scheme_namespace_to_env, (char *)ns, (void *)env, 0); } - return o; + return env; } -static int get_comp_flags(Scheme_Config *config) +Scheme_Env *scheme_make_empty_env(void) { - int comp_flags = 0; + Scheme_Object *proc, *ns, *inst, *a[2]; + Scheme_Env *env; + + proc = scheme_get_startup_export("current-namespace"); + ns = scheme_apply(proc, 0, NULL); - if (!config) - config = scheme_current_config(); + env = namespace_to_env(ns); - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_ALLOW_SET_UNDEFINED))) - comp_flags |= COMP_ALLOW_SET_UNDEFINED; - if (SCHEME_FALSEP(scheme_get_param(scheme_current_config(), - MZCONFIG_DISALLOW_INLINE))) - comp_flags |= COMP_CAN_INLINE; + proc = scheme_get_startup_export("namespace->instance"); + a[0] = ns; + a[1] = scheme_make_integer(0); + inst = scheme_apply(proc, 2, a); - return comp_flags; + env->instance = (Scheme_Instance *)inst; + + return env; } -static void create_binding_namess(Scheme_Comp_Env *cenv) +Scheme_Env *scheme_get_current_namespace_as_env() { - Scheme_Hash_Table *binding_namess; - binding_namess= scheme_make_hash_table(SCHEME_hash_ptr); - cenv->binding_namess = binding_namess; + Scheme_Object *proc, *ns; + + proc = scheme_get_startup_export("current-namespace"); + ns = scheme_apply(proc, 0, NULL); + + return namespace_to_env(ns); } - -static Scheme_Object *binding_namess_as_list(Scheme_Hash_Table *binding_namess) +void scheme_set_current_namespace_as_env(Scheme_Env *env) { - int i; - Scheme_Object *l = scheme_null, **sorted_keys; - - if (!binding_namess->count) - return scheme_null; + Scheme_Object *proc, *a[1]; + + proc = scheme_get_startup_export("current-namespace"); - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)binding_namess); - - for (i = binding_namess->count; i--; ) { - l = scheme_make_pair(scheme_make_pair(sorted_keys[i], - scheme_hash_get(binding_namess, sorted_keys[i])), - l); - } - - return l; -} - -static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, - Scheme_Object *src_insp_desc, - Scheme_Object *binding_namess, - int comp_flags) -{ - Optimize_Info *oi; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Compilation_Top *top; - int enforce_consts, max_let_depth; - Scheme_Config *config; - - config = scheme_current_config(); - enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); - if (enforce_consts) - comp_flags |= COMP_ENFORCE_CONSTS; - oi = scheme_optimize_info_create(cp, env, insp, 1); - scheme_optimize_info_enforce_const(oi, enforce_consts); - if (!(comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, cp, src_insp_desc); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, enforce_consts); - scheme_enable_expression_resolve_lifts(ri); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - o = scheme_merge_expression_resolve_lifts(o, rp, ri); - - rp = scheme_remap_prefix(rp, ri); - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->max_let_depth = max_let_depth; - top->code = o; - top->prefix = rp; - top->binding_namess = binding_namess; - return (Scheme_Object *)top; + a[0] = env->namespace; + (void)scheme_apply(proc, 1, a); } -static void *compile_k(void) +Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable) { - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form, *frame_scopes; - int writeable, for_eval, top_intro, enforce_consts, comp_flags; - Scheme_Env *genv; - Scheme_Compile_Info rec, rec2; - Scheme_Object *o, *rl, *tl_queue; - Scheme_Compilation_Top *top; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - Scheme_Object *gval, *insp; - Scheme_Comp_Env *cenv; - - form = (Scheme_Object *)p->ku.k.p1; - genv = (Scheme_Env *)p->ku.k.p2; - writeable = p->ku.k.i1; - for_eval = p->ku.k.i2; - top_intro = p->ku.k.i3; + Scheme_Object *compile_proc, *a[3]; + compile_proc = scheme_get_startup_export("compile"); + a[0] = form; + a[1] = env->namespace; + a[2] = (writeable ? scheme_true : scheme_false); + return scheme_apply(compile_proc, 3, a); +} - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; +Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env) +{ + return scheme_compile(form, env, 0); +} - if (!SCHEME_STXP(form)) { - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); - top_intro = 1; - } +Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env) +{ + Scheme_Object *eval_proc, *a[2]; + eval_proc = scheme_get_startup_export("eval-top-level"); + a[0] = obj; + a[1] = env->namespace; + return scheme_apply(eval_proc, 2, a); +} - if (top_intro) - form = scheme_top_introduce(form, genv); +Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env) +{ + Scheme_Object *eval_proc, *a[2]; + eval_proc = scheme_get_startup_export("eval-top-level"); + a[0] = obj; + a[1] = env->namespace; + return scheme_apply_multi(eval_proc, 2, a); +} - tl_queue = scheme_null; +static Scheme_Object *finish_eval_with_prompt(void *_data, int argc, Scheme_Object **argv) +{ + Scheme_Object *data = (Scheme_Object *)_data; + return scheme_eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); +} - { - Scheme_Config *config; - config = scheme_current_config(); - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); - comp_flags = get_comp_flags(config); - if (enforce_consts) - comp_flags |= COMP_ENFORCE_CONSTS; - } +Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env) +{ + return scheme_call_with_prompt(finish_eval_with_prompt, + scheme_make_pair(obj, (Scheme_Object *)env)); +} - scheme_prepare_env_stx_context(genv); +static Scheme_Object *finish_eval_multi_with_prompt(void *_data, int argc, Scheme_Object **argv) +{ + Scheme_Object *data = (Scheme_Object *)_data; + return scheme_eval_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); +} - if (genv->stx_context) - frame_scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL); - else - frame_scopes = NULL; +Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env) +{ + return scheme_call_with_prompt_multi(finish_eval_multi_with_prompt, + scheme_make_pair(obj, (Scheme_Object *)env)); +} - while (1) { - scheme_prepare_compile_env(genv); - - rec.comp = 1; - rec.dont_mark_local_use = 0; - rec.resolve_module_ids = !writeable && !genv->module; - rec.substitute_bindings = 1; - rec.pre_unwrapped = 0; - rec.env_already = 0; - rec.comp_flags = comp_flags; - - cenv = scheme_new_comp_env(genv, insp, frame_scopes, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME); - create_binding_namess(cenv); - - cenv->expand_result_adjust = scheme_stx_push_introduce_module_context; - cenv->expand_result_adjust_arg = genv->stx_context; - - if (for_eval) { - /* Need to look for top-level `begin', and if we - find one, break it up to eval first expression - before the rest. */ - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false, - /* lifted modules like definitions: */ - scheme_true); - form = scheme_check_immediate_macro(form, - cenv, &rec, 0, - &gval, - 1); - if (SAME_OBJ(gval, scheme_begin_syntax)) { - if (scheme_stx_proper_list_length(form) > 1) { - form = SCHEME_STX_CDR(form); - tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL), - tl_queue); - tl_queue = scheme_append(scheme_frame_get_lifts(cenv), - tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } else { - rl = scheme_frame_get_require_lifts(cenv); - o = scheme_frame_get_lifts(cenv); - if (!SCHEME_NULLP(o) - || !SCHEME_NULLP(rl)) { - o = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, o, genv->stx_context); - rl = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, rl, genv->stx_context); - tl_queue = scheme_make_pair(form, tl_queue); - tl_queue = scheme_append(o, tl_queue); - tl_queue = scheme_append(rl, tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } - break; - } - } - } - - if (for_eval) { - o = call_compile_handler(form, 1); - top = (Scheme_Compilation_Top *)o; - } else { - /* We want to simply compile `form', but we have to loop in case - an expression is lifted in the process of compiling: */ - Scheme_Object *l, *prev_o = NULL, *binding_namess; - int max_let_depth; - - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false, - /* lifted modules like definitions: */ - scheme_true); - - scheme_init_compile_recs(&rec, 0, &rec2, 1); - - o = scheme_compile_expr(form, cenv, &rec2, 0); - - /* If we had compiled an expression in a previous iteration, - combine it in a sequence: */ - if (prev_o) { - Scheme_Sequence *seq; - seq = scheme_malloc_sequence(2); - seq->so.type = scheme_sequence_type; - seq->count = 2; - seq->array[0] = o; - seq->array[1] = prev_o; - o = (Scheme_Object *)seq; - } - - /* If any definitions were lifted in the process of compiling o, - we need to fold them in. */ - l = scheme_frame_get_lifts(cenv); - rl = scheme_frame_get_require_lifts(cenv); - if (!SCHEME_NULLP(l) - || !SCHEME_NULLP(rl)) { - rl = scheme_append(rl, l); - rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), - rl); - form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0); - prev_o = o; - } else - break; - } - - o = scheme_letrec_check_expr(o); - - oi = scheme_optimize_info_create(cenv->prefix, genv, insp, 1); - scheme_optimize_info_enforce_const(oi, enforce_consts); - if (!(comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, cenv->prefix, insp); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, enforce_consts); - scheme_enable_expression_resolve_lifts(ri); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - o = scheme_merge_expression_resolve_lifts(o, rp, ri); - - rp = scheme_remap_prefix(rp, ri); - - binding_namess = binding_namess_as_list(cenv->binding_namess); - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->max_let_depth = max_let_depth; - top->code = o; - top->prefix = rp; - top->binding_namess = binding_namess; - - if (recompile_every_compile) { - int i; - for (i = recompile_every_compile; i--; ) { - top = (Scheme_Compilation_Top *)recompile_top((Scheme_Object *)top, comp_flags); - } - } - - if (validate_compile_result) { - scheme_validate_code(NULL, top->code, - top->max_let_depth, - top->prefix->num_toplevels, - top->prefix->num_stxes, - top->prefix->num_lifts, - NULL, - NULL, - 0); - } - } - - if (SCHEME_PAIRP(tl_queue)) { - /* This compile is interleaved with evaluation, - and we need to eval now before compiling more. */ - _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv); - - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } - - return (void *)top; -} - -static Scheme_Object *_compile(Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int top_intro) -{ - Scheme_Thread *p = scheme_current_thread; - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type)) - return form; - - if (SCHEME_STXP(form)) { - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) - return SCHEME_STX_VAL(form); - } - - p->ku.k.p1 = form; - p->ku.k.p2 = env; - p->ku.k.i1 = writeable; - p->ku.k.i2 = for_eval; - p->ku.k.i3 = top_intro; - - return (Scheme_Object *)scheme_top_level_do(compile_k, eb); -} - -Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable) -{ - return _compile(form, env, writeable, 0, 1, 1); -} - -Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env) -{ - return _compile(form, env, 0, 1, 1, 1); -} - -Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env) -{ - return scheme_eval_compiled(scheme_compile_for_eval(obj, env), env); -} - -Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env) -{ - return scheme_eval_compiled_multi(scheme_compile_for_eval(obj, env), env); -} - -static Scheme_Object *finish_eval_with_prompt(void *_data, int argc, Scheme_Object **argv) -{ - Scheme_Object *data = (Scheme_Object *)_data; - return _scheme_eval_compiled(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); -} - -Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env) -{ - Scheme_Object *expr; - expr = scheme_compile_for_eval(obj, env); - return scheme_call_with_prompt(finish_eval_with_prompt, - scheme_make_pair(expr, (Scheme_Object *)env)); -} - -static Scheme_Object *finish_eval_multi_with_prompt(void *_data, int argc, Scheme_Object **argv) -{ - Scheme_Object *data = (Scheme_Object *)_data; - return _scheme_eval_compiled_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); -} - -Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env) -{ - Scheme_Object *expr; - expr = scheme_compile_for_eval(obj, env); - return scheme_call_with_prompt_multi(finish_eval_multi_with_prompt, - scheme_make_pair(expr, (Scheme_Object *)env)); -} - -static void *eval_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *v, **save_runstack; - Resolve_Prefix *rp; - Scheme_Env *env; - int isexpr, multi, use_jit, as_tail; - - v = (Scheme_Object *)p->ku.k.p1; - env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - multi = p->ku.k.i1; - isexpr = p->ku.k.i2; - as_tail = p->ku.k.i3; - - { - Scheme_Object *b; - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - use_jit = SCHEME_TRUEP(b); - } - - if (isexpr) { - if (multi) - v = _scheme_eval_linked_expr_multi_wp(v, p); - else - v = _scheme_eval_linked_expr_wp(v, p); - } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_compilation_top_type)) { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)v; - int depth; - - if (!top->prefix) - depth = 0; - else - depth = top->max_let_depth + scheme_prefix_depth(top->prefix); - - if (!scheme_check_runstack(depth)) { - p->ku.k.p1 = top; - p->ku.k.p2 = env; - p->ku.k.i1 = multi; - p->ku.k.i2 = 0; - return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_k); - } - - v = top->code; - - if (!top->prefix) { - /* top->code is shared module code */ - scheme_module_execute(top->code, env); - v = scheme_void; - } else { - if (use_jit) - v = scheme_jit_expr(v); - else - v = scheme_eval_clone(v); - rp = scheme_prefix_eval_clone(top->prefix); - - scheme_install_binding_names(top->binding_namess, env); - - save_runstack = scheme_push_prefix(env, 0, rp, NULL, NULL, 0, env->phase, NULL, scheme_false); - - if (as_tail) { - /* Cons up a closure to capture the prefix */ - Scheme_Lambda *data; - mzshort *map; - int i, sz; - - sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK); - map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz); - for (i = 0; i < sz; i++) { - map[i] = i; - } - - data = MALLOC_ONE_TAGGED(Scheme_Lambda); - data->iso.so.type = scheme_ir_lambda_type; - data->num_params = 0; - data->max_let_depth = top->max_let_depth + sz; - data->closure_size = sz; - data->closure_map = map; - data->body = v; - - v = scheme_make_closure(p, (Scheme_Object *)data, 1); - - v = _scheme_tail_apply(v, 0, NULL); - } else if (multi) - v = _scheme_eval_linked_expr_multi_wp(v, p); - else - v = _scheme_eval_linked_expr_wp(v, p); - - scheme_pop_prefix(save_runstack); - } - } else { - v = scheme_void; - } - - return (void *)v; -} - -static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env, - int isexpr, int multi, int top, int as_tail) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = env; - p->ku.k.i1 = multi; - p->ku.k.i2 = isexpr; - p->ku.k.i3 = as_tail; - - if (top) - return (Scheme_Object *)scheme_top_level_do(eval_k, 1); - else - return (Scheme_Object *)eval_k(); -} - -Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 0, 1, 0); -} - -Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 1, 1, 0); -} - -Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 0, 0, 0); -} - -Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 1, 0, 0); -} - -static Scheme_Object *finish_compiled_multi_with_prompt(void *_data, int argc, Scheme_Object **argv) -{ - Scheme_Object *data = (Scheme_Object *)_data; - return _eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data), 0, 1, 0, 0); -} - -Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env) -{ - return _scheme_call_with_prompt_multi(finish_compiled_multi_with_prompt, - scheme_make_pair(obj, (Scheme_Object *)env)); -} - -Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj) -{ - return _eval(obj, NULL, 1, 0, 1, 0); -} - -Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *obj) -{ - return _eval(obj, NULL, 1, 1, 1, 0); -} - -Scheme_Object *scheme_eval_linked_expr_multi_with_dynamic_state(Scheme_Object *obj, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = NULL; - p->ku.k.i1 = 1; - p->ku.k.i2 = 1; - p->ku.k.i3 = 0; - - return (Scheme_Object *)scheme_top_level_do_worker(eval_k, 1, 0, dyn_state); -} - -/* for mzc: */ -Scheme_Object *scheme_load_compiled_stx_string(const char *str, intptr_t len) -{ - Scheme_Object *port, *expr; - - port = scheme_make_sized_byte_string_input_port(str, -len); - - expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); - - expr = _scheme_eval_compiled(expr, scheme_get_env(NULL)); - - /* Unwrap syntax once; */ - expr = SCHEME_STX_VAL(expr); - - return expr; -} - -/* for mzc: */ -Scheme_Object *scheme_compiled_stx_symbol(Scheme_Object *stx) -{ - return SCHEME_STX_VAL(stx); -} - -/* for mzc: */ -Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx) -{ - /* If modidx, then last element is a module index; shift the rest. */ - if (modidx) { - int i, len = SCHEME_VEC_SIZE(expr); - Scheme_Object *orig = SCHEME_VEC_ELS(expr)[len - 1], *s, *result; - - orig = SCHEME_STX_VAL(orig); - result = scheme_make_vector(len - 1, NULL); - - for (i = 0; i < len - 1; i++) { - s = SCHEME_VEC_ELS(expr)[i]; - s = scheme_stx_shift(s, - scheme_make_integer(shift), - orig, modidx, - env->module_registry->exports, - NULL, NULL); - SCHEME_VEC_ELS(result)[i] = s; - } - - return result; - } else - return expr; -} - -static Scheme_Object *add_lifts_as_begin(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env) -{ - obj = scheme_append(l, scheme_make_pair(obj, scheme_null)); - obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - obj); - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0); - return obj; -} - -static void *expand_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *obj, *observer, *catch_lifts_key; - Scheme_Comp_Env *env, **ip; - Scheme_Expand_Info erec1; - int depth, top_intro, just_to_top, as_local, comp_flags; - - obj = (Scheme_Object *)p->ku.k.p1; - env = (Scheme_Comp_Env *)p->ku.k.p2; - depth = p->ku.k.i1; - top_intro = p->ku.k.i2; - just_to_top = p->ku.k.i3; - catch_lifts_key = p->ku.k.p4; - as_local = p->ku.k.i4; /* < 0 => catch lifts to let; 2 => catch lifts to optional `begin` */ - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - if (SCHEME_FALSEP(catch_lifts_key)) - catch_lifts_key = scheme_top_level_lifts_key(env); - - if (!SCHEME_STXP(obj)) - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); - - if (top_intro) - obj = scheme_top_introduce(obj, env->genv); - - if (!as_local) { - env->expand_result_adjust = scheme_stx_push_introduce_module_context; - env->expand_result_adjust_arg = env->genv->stx_context; - } - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_START_EXPAND(observer); - - env->observer = observer; - - comp_flags = get_comp_flags(NULL); - - if (as_local < 0) { - /* Insert a dummy frame so that `pair_lifted' can add more. */ - env = scheme_new_compilation_frame(0, 0, NULL, env); - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = env; - } else - ip = NULL; - - scheme_prepare_compile_env(env->genv); - - /* Loop for lifted expressions: */ - while (1) { - erec1.comp = 0; - erec1.depth = ((depth == -3) ? -2 : depth); - erec1.pre_unwrapped = 0; - erec1.env_already = 0; - erec1.comp_flags = comp_flags; - erec1.substitute_bindings = (depth != -3); - - if (catch_lifts_key) { - Scheme_Object *data; - data = (as_local < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); - scheme_frame_captures_lifts(env, - (as_local < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, - data, - scheme_false, catch_lifts_key, - (!as_local && catch_lifts_key) ? scheme_null : NULL, - scheme_false, - /* lifted modules like definitions: */ - ((env->flags & SCHEME_TOPLEVEL_FRAME) - ? scheme_true /* lifted `module` like definition */ - : ((env->flags & SCHEME_MODULE_FRAME) - ? scheme_void /* lifted `module[*]` like definition */ - : scheme_false))); - } - - if (just_to_top) { - Scheme_Object *gval; - obj = scheme_check_immediate_macro(obj, env, &erec1, 0, &gval, 1); - } else - obj = scheme_expand_expr(obj, env, &erec1, 0); - - if (catch_lifts_key) { - Scheme_Object *l, *rl; - l = scheme_frame_get_lifts(env); - rl = scheme_frame_get_require_lifts(env); - if (SCHEME_PAIRP(l) - || SCHEME_PAIRP(rl)) { - l = scheme_append(rl, l); - if (as_local < 0) - obj = scheme_add_lifts_as_let(obj, l, env, scheme_false, 0); - else - obj = add_lifts_as_begin(obj, l, env); - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(env->observer, obj); - if ((depth >= 0) || as_local) - break; - } else { - if ((as_local > 0) && (as_local < 2)) { - obj = add_lifts_as_begin(obj, scheme_null, env); - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(env->observer,obj); - } - break; - } - } else - break; - } - - return obj; -} - -static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env, - int depth, int top_intro, int just_to_top, - Scheme_Object *catch_lifts_key, int eb, - int as_local) - /* as_local < 0 => catch lifts to let; - depth = -3 => depth = -2, and no substituion of references with bindings */ -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = env; - p->ku.k.i1 = depth; - p->ku.k.i2 = top_intro; - p->ku.k.i3 = just_to_top; - p->ku.k.p4 = catch_lifts_key; - p->ku.k.i4 = as_local; - - return (Scheme_Object *)scheme_top_level_do(expand_k, eb); -} - -Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env) -{ - return r_expand(obj, scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 1, 0, scheme_false, -1, 0); -} - -Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) -{ - return scheme_tail_eval(obj); -} - -/* local functions */ - -static Scheme_Object * -sch_eval(const char *who, int argc, Scheme_Object *argv[]) -{ - if (argc == 1) { - return _scheme_tail_apply(scheme_get_param(scheme_current_config(), MZCONFIG_EVAL_HANDLER), - 1, argv); - } else { - Scheme_Config *config; - - if (SCHEME_TYPE(argv[1]) != scheme_namespace_type) - scheme_wrong_contract(who, "namespace?", 1, argc, argv); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - argv[1]); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - return _scheme_tail_apply(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, argv); - } -} - -static Scheme_Object * -eval(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *a[2], *form; - - form = argv[0]; - if (SCHEME_STXP(form) - && !SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) { - Scheme_Env *genv; - if (argc > 1) { - if (SCHEME_TYPE(argv[1]) != scheme_namespace_type) - scheme_wrong_contract("eval", "namespace?", 1, argc, argv); - genv = (Scheme_Env *)argv[1]; - } else - genv = scheme_get_env(NULL); - form = scheme_top_introduce(form, genv); - } - - a[0] = form; - if (argc > 1) - a[1] = argv[1]; - return sch_eval("eval", argc, a); -} - -static Scheme_Object * -eval_stx(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_STXP(argv[0])) { - scheme_wrong_contract("eval-syntax", "syntax?", 0, argc, argv); - return NULL; - } - - return sch_eval("eval-syntax", argc, argv); -} - -Scheme_Object * -scheme_default_eval_handler(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - Scheme_Object *v; - - env = scheme_get_env(NULL); - - v = _compile(argv[0], env, 0, 1, 0, 0); - - /* Returns a tail apply: */ - return _eval(v, env, 0, 1, 0, 1); -} - -Scheme_Object * -scheme_default_compile_handler(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return _compile(argv[0], env, SCHEME_FALSEP(argv[1]), 0, 0, 0); -} - -static Scheme_Object * -current_eval(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-eval", - scheme_make_integer(MZCONFIG_EVAL_HANDLER), - argc, argv, - 1, NULL, NULL, 0); -} - -static Scheme_Object * -current_compile(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-compile", - scheme_make_integer(MZCONFIG_COMPILE_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - -static Scheme_Object * -top_introduce_stx(int argc, Scheme_Object **argv) -{ - Scheme_Object *form; - - if (!SCHEME_STXP(argv[0])) { - scheme_wrong_contract("namespace-syntax-introduce", "syntax?", 0, argc, argv); - return NULL; - } - - form = argv[0]; - - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) { - Scheme_Env *genv; - genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV); - form = scheme_top_introduce(form, genv); - } - - return form; -} - -Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *e) -{ - return scheme_datum_to_syntax(e, scheme_false, scheme_sys_wraps(NULL), 0, 0); -} - -static Scheme_Object * -compile(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *form = argv[0]; - Scheme_Env *genv; - - if (!SCHEME_STXP(form)) - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); - - genv = scheme_get_env(NULL); - form = scheme_top_introduce(form, genv); - - return call_compile_handler(form, 0); -} - -static Scheme_Object * -compile_stx(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("compile-syntax", "syntax?", 0, argc, argv); - - return call_compile_handler(argv[0], 0); -} - -static Scheme_Object * -compiled_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *recompile_top(Scheme_Object *top, int comp_flags) -{ - Comp_Prefix *cp; - Scheme_Object *code; - -#if 0 - printf("Resolved Code:\n%s\n\n", scheme_print_to_string(((Scheme_Compilation_Top *)top)->code, NULL)); -#endif - - code = scheme_unresolve_top(top, &cp, comp_flags); - -#if 0 - printf("Unresolved Prefix:\n"); - printf("%s\n\n", scheme_print_to_string(cp, NULL)); - printf("Unresolved Code:\n"); - printf("%s\n\n", scheme_print_to_string(code, NULL)); -#endif - - top = optimize_resolve_expr(code, cp, scheme_get_env(NULL), - scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR), - ((Scheme_Compilation_Top*)top)->prefix->src_insp_desc, - ((Scheme_Compilation_Top*)top)->binding_namess, - comp_flags); - - return top; -} - -static Scheme_Object * -recompile(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type)) { - scheme_wrong_contract("compiled-expression-recompile", "compiled-expression?", 0, argc, argv); - } - - return recompile_top(argv[0], get_comp_flags(NULL)); -} - -static Scheme_Object *expand(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 1, 0, scheme_false, 0, 0); -} - -static Scheme_Object *expand_stx(int argc, Scheme_Object **argv) +Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) { - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 0, 0, scheme_false, 0, 0); -} - -int scheme_is_expansion_context_symbol(Scheme_Object *v) -{ - return (SAME_OBJ(v, module_symbol) - || SAME_OBJ(v, module_begin_symbol) - || SAME_OBJ(v, expression_symbol) - || SAME_OBJ(v, top_level_symbol) - || SAME_OBJ(v, definition_context_symbol)); -} - -Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags) -{ - if (flags & SCHEME_TOPLEVEL_FRAME) - return top_level_symbol; - else if (flags & SCHEME_MODULE_FRAME) - return module_symbol; - else if (flags & SCHEME_MODULE_BEGIN_FRAME) - return module_begin_symbol; - else if (flags & SCHEME_INTDEF_FRAME) - return definition_context_symbol; - else - return expression_symbol; + return _scheme_eval_linked_expr(obj); } -Scheme_Object *scheme_generate_lifts_key(void) +Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) { - char buf[20]; - sprintf(buf, "lifts%d", generate_lifts_count++); - return scheme_make_symbol(buf); /* uninterned */ + return _scheme_eval_linked_expr_multi(obj); } -Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env) +Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) { - if (!env->genv->lift_key) { - Scheme_Object *o; - o = scheme_generate_lifts_key(); - env->genv->lift_key = o; - } - return env->genv->lift_key; + return scheme_tail_eval(obj); } -Scheme_Object * -scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) +Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) { - Scheme_Object *l, *ids, *id; - - /* Registers scoped ids: */ - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - (void)scheme_global_binding(id, env->genv, 0); - } - - l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), - icons(*_ids, - icons(expr, - scheme_null))); + Scheme_Env *env; + Scheme_Instance *inst; + Scheme_Hash_Tree *protected; - return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0); -} + /* An environment wrapper just for filling in the instance: */ + env = MALLOC_ONE_TAGGED(Scheme_Env); + env->so.type = scheme_env_type; + env->namespace = for_env->namespace; /* records target namespace, not instance's namespace! */ -static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming) -{ - Scheme_Object *rl = renaming, *phase = scheme_make_integer(0); + inst = scheme_make_instance(name, NULL); + env->instance = (Scheme_Instance *)inst; - if (SCHEME_PAIRP(renaming)) { - while (!SCHEME_NULLP(rl)) { - l = scheme_stx_add_scope(l, SCHEME_CAR(rl), phase); - rl = SCHEME_CDR(rl); - } - } else { - l = scheme_stx_add_scope(l, renaming, phase); - } + protected = scheme_make_hash_tree(0); + env->protected = protected; - return l; + return env; } -static void update_intdef_chain(Scheme_Object *intdef) +void scheme_finish_primitive_module(Scheme_Env *env) { - Scheme_Comp_Env *orig, *current_next; - Scheme_Object *base; - - /* If this intdef chains to another, and if the other has been - extended, then fix up the chain. */ - - while (1) { - base = (Scheme_Object *)((void **)SCHEME_PTR1_VAL(intdef))[1]; - if (base) { - current_next = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(base))[0]; - orig = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[2]; - if (orig) { - orig->next = current_next; - } else { - ((void **)SCHEME_PTR1_VAL(base))[0] = current_next; - } - intdef = base; - } else { - break; - } - } -} - -static Scheme_Object * -do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) -/* catch_lifts == -1 => wrap as `let-values`; - catch_lifts == 1 => `begin`; - catch_lifts == 2 => `begin`, if any */ -{ - Scheme_Comp_Env *env, *orig_env, *adjust_env = NULL, **ip; - Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL; - int cnt, pos, kind, is_modstar; - int bad_sub_env = 0, bad_intdef = 0, keep_ref_ids = 0; - Scheme_Object *observer, *catch_lifts_key = NULL; - - env = scheme_current_thread->current_local_env; - orig_env = env; - - if (!env) - scheme_contract_error(name, - "not currently transforming", - NULL); - - if (for_stx) { - scheme_prepare_exp_env(env->genv); - env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0); - scheme_propagate_require_lift_capture(orig_env, env); - } - scheme_prepare_compile_env(env->genv); - - if (for_expr) - kind = 0; /* expression */ - else if (!for_stx && SAME_OBJ(argv[1], module_symbol)) { - kind = SCHEME_MODULE_FRAME | SCHEME_USE_SCOPES_TO_NEXT; /* module body */ - if (orig_env->flags & SCHEME_MODULE_FRAME) - adjust_env = orig_env; - } else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol)) - kind = SCHEME_MODULE_BEGIN_FRAME; /* just inside module for expanding to `#%module-begin` */ - else if (SAME_OBJ(argv[1], top_level_symbol)) { - kind = SCHEME_TOPLEVEL_FRAME; - if (catch_lifts < 0) catch_lifts = (for_stx ? 2 : 0); - if (orig_env->flags & SCHEME_TOPLEVEL_FRAME) - adjust_env = orig_env; - } else if (SAME_OBJ(argv[1], expression_symbol)) - kind = 0; - else if (scheme_proper_list_length(argv[1]) > 0) - kind = SCHEME_INTDEF_FRAME | SCHEME_USE_SCOPES_TO_NEXT; - else { - scheme_wrong_contract(name, - (for_stx - ? "(or/c 'expression 'top-level (and/c pair? list?))" - : "(or/c 'expression 'module 'module-begin 'top-level (and/c pair? list?))"), - 1, argc, argv); - return NULL; - } - - if (argc > 3) { - if (SCHEME_TRUEP(argv[3])) { - if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) { - Scheme_Comp_Env *stx_env; - update_intdef_chain(argv[3]); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0]; - renaming = SCHEME_PTR2_VAL(argv[3]); - if (SCHEME_BOXP(renaming)) /* box means "don't add" */ - renaming = NULL; - if (!scheme_is_sub_env(stx_env, env)) - bad_sub_env = 1; - env = stx_env; - } else if (SCHEME_PAIRP(argv[3])) { - Scheme_Object *rl = argv[3]; - while (SCHEME_PAIRP(rl)) { - if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) { - Scheme_Comp_Env *stx_env; - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0]; - if (!scheme_is_sub_env(stx_env, env)) - bad_sub_env = 1; - } else - break; - rl = SCHEME_CDR(rl); - } - if (!SCHEME_NULLP(rl)) - bad_intdef = 1; - else { - rl = argv[3]; - update_intdef_chain(SCHEME_CAR(rl)); - env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0]; - if (SCHEME_NULLP(SCHEME_CDR(rl))) { - renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl)); - if (SCHEME_BOXP(renaming)) - renaming = NULL; - } else { - /* reverse and extract: */ - renaming = scheme_null; - while (!SCHEME_NULLP(rl)) { - l = SCHEME_PTR2_VAL(SCHEME_CAR(rl)); - if (!SCHEME_BOXP(l)) - renaming = cons(l, renaming); - rl = SCHEME_CDR(rl); - } - } - } - } else - bad_intdef = 1; - } - - if (argc > 4) { - /* catch_lifts */ - catch_lifts_key = argv[4]; - } - } - - if (catch_lifts && !catch_lifts_key) - catch_lifts_key = scheme_generate_lifts_key(); - - /* For each given stop-point identifier, shadow any potential syntax - in the environment with an identity-expanding syntax expander. */ - - (void)scheme_get_stop_expander(); - - env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_FOR_STOPS - | kind), - NULL, - env); - - if (adjust_env && adjust_env->expand_result_adjust) { - env->expand_result_adjust = adjust_env->expand_result_adjust; - env->expand_result_adjust_arg = adjust_env->expand_result_adjust_arg; - } - - if (catch_lifts < 0) { - /* Note: extra frames can get inserted after env by pair_lifted */ - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = env; - } else - ip = NULL; - - if (kind & SCHEME_INTDEF_FRAME) - env->intdef_name = argv[1]; - env->in_modidx = scheme_current_thread->current_local_modidx; - - local_scope = scheme_current_thread->current_local_scope; + Scheme_Object *proc, *a[5]; - if (for_expr) { - } else if (SCHEME_TRUEP(argv[2])) { -# define NUM_CORE_EXPR_STOP_FORMS 15 - cnt = scheme_proper_list_length(argv[2]); - - if ((cnt == 1) - && SCHEME_STXP(SCHEME_CAR(argv[2])) - && SCHEME_SYMBOLP(SCHEME_STX_VAL(SCHEME_CAR(argv[2])))) - is_modstar = scheme_stx_free_eq_x(scheme_modulestar_stx, SCHEME_CAR(argv[2]), env->genv->phase); - else - is_modstar = 0; - - if (cnt > 0) { - if (!is_modstar) - cnt += NUM_CORE_EXPR_STOP_FORMS; - scheme_add_local_syntax(cnt, env); - } - pos = 0; - - for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *i; - - i = SCHEME_CAR(l); - if (!SCHEME_STXP(i) || !SCHEME_STX_SYMBOLP(i)) { - scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv); - return NULL; - } - - if (cnt > 0) - scheme_set_local_syntax(pos++, i, scheme_get_stop_expander(), env, 0); - } - if (!SCHEME_NULLP(l)) { - scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv); - return NULL; - } - - if ((cnt > 0) && !is_modstar) { - scheme_add_core_stop_form(pos++, begin_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("set!"), env); - scheme_add_core_stop_form(pos++, app_symbol, env); - scheme_add_core_stop_form(pos++, top_symbol, env); - scheme_add_core_stop_form(pos++, lambda_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("case-lambda"), env); - scheme_add_core_stop_form(pos++, let_values_symbol, env); - scheme_add_core_stop_form(pos++, letrec_values_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("if"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("begin0"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("with-continuation-mark"), env); - scheme_add_core_stop_form(pos++, letrec_syntaxes_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); - scheme_add_core_stop_form(pos++, quote_symbol, env); - keep_ref_ids = 1; - } - } - - /* Report errors related to 3rd argument, finally */ - if (argc > 3) { - if (bad_intdef) { - scheme_wrong_contract(name, "(or/c internal-definition-context? (non-empty-listof internal-definition-context?) #f)", - 3, argc, argv); - return NULL; - } else if (bad_sub_env) { - scheme_contract_error(name, - "transforming context does not match internal-definition context", - NULL); - return NULL; - } - } - - l = argv[0]; - - if (!SCHEME_STXP(l)) - l = scheme_datum_to_syntax(l, scheme_false, scheme_false, 1, 0); - - orig_l = l; - - observer = scheme_get_expand_observe(); - if (observer) { - SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l); - if (for_stx) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - } - } - - env->observer = observer; - - if (local_scope) { - /* Since we have an expression from local context, - we need to remove the temporary scope... */ - l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv)); - } - - if (renaming) { - l = add_intdef_renamings(l, renaming); - env->expand_result_adjust = add_intdef_renamings; - env->expand_result_adjust_arg = renaming; - } - - SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l); - - if (SCHEME_FALSEP(argv[2])) { - Scheme_Object *xl, *gval; - Scheme_Compile_Expand_Info drec[1]; - - if (catch_lifts_key) { - Scheme_Object *data; - data = (catch_lifts < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); - scheme_frame_captures_lifts(env, - (catch_lifts < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, - data, - scheme_top_level_lifts_key(env), - catch_lifts_key, NULL, - scheme_false, - ((kind & SCHEME_TOPLEVEL_FRAME) - ? scheme_true /* lifted `module` like definition */ - : ((kind & SCHEME_MODULE_FRAME) - ? scheme_void /* lifted `module[*]` like definition */ - : scheme_false))); /* no lifted modules */ - } - - memset(drec, 0, sizeof(drec)); - drec[0].depth = -2; - { - int comp_flags; - comp_flags = get_comp_flags(NULL); - drec[0].comp_flags = comp_flags; - } - - if (!(env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME))) - env->value_name = scheme_current_thread->current_local_name; - - xl = scheme_check_immediate_macro(l, env, drec, 0, &gval, 1); - - if (SAME_OBJ(xl, l) && !for_expr) { - SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl); - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, orig_l); - return orig_l; - } - - if (catch_lifts_key) { - int observe = 1; - if (catch_lifts < 0) - xl = scheme_add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0); - else { - l = scheme_frame_get_lifts(env); - if (SCHEME_PAIRP(l) || (catch_lifts < 2)) - xl = add_lifts_as_begin(xl, l, env); - else - observe = 0; - } - if (observe) { - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl); - } - } - - l = xl; - } else { - /* Expand the expression. depth = -2 means expand all the way, but - preserve letrec-syntax, while -3 is -2 but also avoid replacing reference ids - with binding ids. */ - l = r_expand(l, env, (keep_ref_ids ? -3 : -2), 0, 0, catch_lifts_key, 0, - catch_lifts ? catch_lifts : 1); - } - - SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l); - - if (renaming) - l = add_intdef_renamings(l, renaming); - - if (for_expr) { - /* Package up expanded expr with the environment. */ - while (1) { - if (orig_env->flags & SCHEME_FOR_STOPS) - orig_env = orig_env->next; - else if ((orig_env->flags & SCHEME_INTDEF_FRAME) - && !orig_env->num_bindings) - orig_env = orig_env->next; - else - break; - } - exp_expr = scheme_alloc_object(); - exp_expr->type = scheme_expanded_syntax_type; - SCHEME_PTR1_VAL(exp_expr) = l; - SCHEME_PTR2_VAL(exp_expr) = orig_env; - exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0); - if (local_scope) - exp_expr = scheme_stx_flip_scope(exp_expr, local_scope, scheme_env_phase(env->genv)); - } - - if (local_scope) { - /* Put the temporary scope back: */ - l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv)); - } - - if (for_expr) { - Scheme_Object *a[2]; - SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(observer, exp_expr); - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); - a[0] = l; - a[1] = exp_expr; - return scheme_values(2, a); - } else { - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); - return l; - } -} - - -static Scheme_Object * -local_expand(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-expand", 0, 0, 0, argc, argv); -} - -static Scheme_Object * -local_expand_expr(int argc, Scheme_Object **argv) -{ - return do_local_expand("syntax-local-expand-expression", 0, 0, 1, argc, argv); -} - -static Scheme_Object * -local_transformer_expand(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-transformer-expand", 1, -1, 0, argc, argv); -} - -static Scheme_Object * -local_expand_catch_lifts(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-expand/capture-lifts", 0, 1, 0, argc, argv); + proc = scheme_get_startup_export("declare-primitive-module!"); + a[0] = env->instance->name; + a[1] = (Scheme_Object *)env->instance; + a[2] = env->namespace; /* target namespace */ + a[3] = (Scheme_Object *)env->protected; + a[4] = (env->cross_phase ? scheme_true : scheme_false); + scheme_apply(proc, 5, a); } -static Scheme_Object * -local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv) +void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless) { - return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, 0, argc, argv); + env->cross_phase = phaseless; } -static Scheme_Object * -expand_once(int argc, Scheme_Object **argv) +void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) { - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 1, 0, scheme_false, 0, 0); + Scheme_Hash_Tree *protected; + protected = scheme_hash_tree_set(env->protected, name, scheme_true); + env->protected = protected; } -static Scheme_Object * -expand_stx_once(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax-once", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 0, 0, scheme_false, 0, 0); -} +/* local functions */ -static Scheme_Object * -expand_to_top_form(int argc, Scheme_Object **argv) +static Scheme_Object *read_syntax(Scheme_Object *port, Scheme_Object *src) { - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 1, 1, scheme_false, 0, 0); + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("read-syntax"); + a[0] = src; + a[1] = port; + return scheme_apply(proc, 2, a); } -static Scheme_Object * -expand_stx_to_top_form(int argc, Scheme_Object **argv) +static Scheme_Object *namespace_introduce(Scheme_Object *stx) { - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax-to-top", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 0, 1, scheme_false, 0, 0); + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("namespace-introduce"); + a[0] = stx; + return scheme_apply(proc, 1, a); } static Scheme_Object *do_eval_string_all(Scheme_Object *port, const char *str, Scheme_Env *env, @@ -5582,21 +3677,10 @@ port = scheme_make_byte_string_input_port(str); do { - expr = scheme_read_syntax(port, scheme_false); + expr = read_syntax(port, scheme_false); - if (cont == -2) { - if (SCHEME_STXP(expr)) { - Scheme_Object *m; - m = SCHEME_STX_VAL(expr); - if (SCHEME_PAIRP(m)) { - m = scheme_make_pair(scheme_datum_to_syntax(module_symbol, - SCHEME_CAR(m), - scheme_sys_wraps(NULL), - 0, 0), - SCHEME_CDR(m)); - expr = scheme_datum_to_syntax(m, expr, expr, 0, 1); - } - } + if ((cont == -2) && !SAME_OBJ(expr, scheme_eof)) { + expr = namespace_introduce(expr); } if (SAME_OBJ(expr, scheme_eof)) @@ -5688,8 +3772,8 @@ void scheme_embedded_load(intptr_t len, const char *desc, int predefined) { - Scheme_Object *s, *e, *a[3], *eload; - eload = scheme_builtin_value("embedded-load"); + Scheme_Object *s, *e, *a[4], *eload; + eload = scheme_get_startup_export("embedded-load"); if (len < 0) { /* description mode */ s = scheme_make_utf8_string(desc); @@ -5704,15 +3788,21 @@ s = scheme_make_sized_byte_string((char *)desc, len, 0); a[2] = s; } - if (predefined) - scheme_starting_up = 1; - (void)scheme_apply(eload, 3, a); - if (predefined) - scheme_starting_up = 0; + a[3] = (predefined ? scheme_true : scheme_false); + (void)scheme_apply(eload, 4, a); +} + +int scheme_is_predefined_module_path(Scheme_Object *m) +{ + Scheme_Object *is_predef, *a[1], *r; + is_predef = scheme_get_startup_export("embedded-load"); + a[0] = m; + r = scheme_apply(is_predef, 1, a); + return SCHEME_TRUEP(r); } -void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *post_dirs) -{ +void scheme_init_collection_paths_post(Scheme_Env *env, Scheme_Object *extra_dirs, Scheme_Object *post_dirs) +{ mz_jmp_buf * volatile save, newbuf; Scheme_Thread * volatile p; p = scheme_get_current_thread(); @@ -5744,9 +3834,9 @@ p->error_buf = save; } -void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs) +void scheme_init_collection_paths(Scheme_Env *env, Scheme_Object *extra_dirs) { - scheme_init_collection_paths_post(global_env, extra_dirs, scheme_null); + scheme_init_collection_paths_post(env, extra_dirs, scheme_null); } void scheme_init_compiled_roots(Scheme_Env *global_env, const char *paths) @@ -5832,427 +3922,58 @@ } } -static Scheme_Object *flip_scope_at_phase_and_revert_expr(Scheme_Object *a, Scheme_Object *m_p) -{ - Scheme_Comp_Env *env = (Scheme_Comp_Env *)SCHEME_CDR(m_p); - - a = scheme_revert_use_site_scopes(a, env); - - return scheme_stx_flip_scope(a, SCHEME_CAR(m_p), scheme_env_phase(env->genv)); -} - -static Scheme_Object *add_scope_at_phase(Scheme_Object *a, Scheme_Object *m_p) -{ - return scheme_stx_add_scope(a, SCHEME_CAR(m_p), SCHEME_CDR(m_p)); -} - -static Scheme_Object *revert_expr_scopes(Scheme_Object *a, Scheme_Object *env) -{ - return scheme_revert_use_site_scopes(a, (Scheme_Comp_Env *)env); -} - -static Scheme_Object * -local_eval(int argc, Scheme_Object **argv) -{ - Scheme_Comp_Env *env, *stx_env, *init_env; - Scheme_Object *l, *a, *rib, *expr, *names, *rn_names, *observer; - int cnt = 0, pos; - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_LOCAL_BIND(observer, argv[0]); - - names = argv[0]; - for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - break; - cnt++; - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("syntax-local-bind-syntaxes", "(listof identifier?)", 0, argc, argv); - - expr = argv[1]; - if (!SCHEME_FALSEP(expr) && !SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-bind-syntaxes", "(or/c syntax? #f)", 1, argc, argv); - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_contract("syntax-local-bind-syntaxes", "internal-definition-context?", 2, argc, argv); - - env = scheme_current_thread->current_local_env; - if (!env) - scheme_contract_error("syntax-local-bind-syntaxes", - "not currently transforming", - NULL); - - update_intdef_chain(argv[2]); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; - init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[3]; - rib = SCHEME_PTR2_VAL(argv[2]); - if (SCHEME_BOXP(rib)) rib = SCHEME_BOX_VAL(rib); - - if (!scheme_is_sub_env(stx_env, env)) { - scheme_contract_error("syntax-local-bind-syntaxes", - "transforming context does not match given internal-definition context", - NULL); - } - - stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF | SCHEME_USE_SCOPES_TO_NEXT, rib, stx_env); - scheme_add_local_syntax(cnt, stx_env); - env->observer = observer; - - /* Scope names */ - if (scheme_current_thread->current_local_scope) - names = scheme_named_map_1(NULL, flip_scope_at_phase_and_revert_expr, names, - scheme_make_raw_pair(scheme_current_thread->current_local_scope, - (Scheme_Object *)stx_env)); - - SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names); - - /* Initialize environment slots to #f, which means "not syntax". */ - cnt = 0; - for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = scheme_revert_use_site_scopes(a, init_env); - scheme_set_local_syntax(cnt++, a, scheme_false, stx_env, 0); - } - - stx_env->in_modidx = scheme_current_thread->current_local_modidx; - if (!SCHEME_FALSEP(expr)) { - Scheme_Compile_Expand_Info rec; - rec.comp = 0; - rec.depth = -1; - rec.pre_unwrapped = 0; - rec.env_already = 0; - rec.substitute_bindings = 1; - rec.comp_flags = get_comp_flags(NULL); - - /* Evaluate and bind syntaxes */ - if (scheme_current_thread->current_local_scope) - expr = scheme_stx_flip_scope(expr, scheme_current_thread->current_local_scope, - scheme_env_phase(env->genv)); - - scheme_prepare_exp_env(stx_env->genv); - scheme_prepare_compile_env(stx_env->genv->exp_env); - pos = 0; - expr = scheme_stx_add_scope(expr, rib, scheme_env_phase(stx_env->genv)); - rn_names = scheme_named_map_1(NULL, add_scope_at_phase, names, - scheme_make_pair(rib, scheme_env_phase(stx_env->genv))); - rn_names = scheme_named_map_1(NULL, revert_expr_scopes, rn_names, (Scheme_Object *)init_env); - scheme_bind_syntaxes("local syntax definition", rn_names, expr, - stx_env->genv->exp_env, stx_env->insp, - &rec, 0, stx_env->observer, - stx_env, stx_env, - &pos, rib, 1); - } - - /* Remember extended environment */ - ((void **)SCHEME_PTR1_VAL(argv[2]))[0] = stx_env; - if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2]) - ((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env; - - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_BIND(observer); - - return scheme_void; -} - -Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef) -{ - Scheme_Comp_Env *stx_env, *init_env; - Scheme_Object *l = scheme_null; - int i; - - update_intdef_chain(intdef); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[0]; - init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[3]; - - while (stx_env != init_env) { - for (i = stx_env->num_bindings; i--; ) { - l = scheme_make_pair(stx_env->binders[i], l); - } - stx_env = stx_env->next; - } - - return l; -} - -/*========================================================================*/ -/* cloning prefix information */ -/*========================================================================*/ - -Scheme_Object *scheme_eval_clone(Scheme_Object *expr) -{ - /* Clone as much as necessary of `expr' so that prefixes are - cloned. Cloned prefixes, in turn, can be updated by linking to - reduce the overhead of cross-module references. */ - switch (SCHEME_TYPE(expr)) { - case scheme_module_type: - if (scheme_startup_use_jit) - return scheme_module_jit(expr); - else - return scheme_module_eval_clone(expr); - break; - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: - return scheme_syntaxes_eval_clone(expr); - default: - return expr; - } -} - -Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp) -{ - Resolve_Prefix *naya; - Scheme_Object **tls; - - if (!rp->num_toplevels) - return rp; - - naya = MALLOC_ONE_TAGGED(Resolve_Prefix); - memcpy(naya, rp, sizeof(Resolve_Prefix)); - - tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); - memcpy(tls, rp->toplevels, sizeof(Scheme_Object *) * rp->num_toplevels); - naya->toplevels = tls; - - return naya; -} - -/*========================================================================*/ -/* creating/pushing prefix for top-levels and syntax objects */ -/*========================================================================*/ - -int scheme_prefix_depth(Resolve_Prefix *rp) -{ - if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) - return 1; - else - return 0; -} - -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, - Scheme_Object *src_modidx, Scheme_Object *now_modidx, - int src_phase, int now_phase, - Scheme_Env *dummy_env, Scheme_Object *insp) -{ - Scheme_Object **rs_save, **rs, *v; - Scheme_Prefix *pf; - int i, j, tl_map_len; - - rs_save = rs = MZ_RUNSTACK; - - if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) { - i = rp->num_toplevels; - if (rp->num_stxes) { - i += rp->num_stxes + 1; - } - i += rp->num_lifts; - - tl_map_len = ((rp->num_toplevels + rp->num_lifts + (rp->num_stxes ? 1 : 0)) + 31) / 32; - - pf = scheme_malloc_tagged(sizeof(Scheme_Prefix) - + ((i-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + (tl_map_len * sizeof(int))); - pf->iso.so.type = scheme_prefix_type; - pf->num_slots = i; - pf->num_toplevels = rp->num_toplevels; - pf->num_stxes = rp->num_stxes; - --rs; - MZ_RUNSTACK = rs; - rs[0] = (Scheme_Object *)pf; - - for (i = 0; i < rp->num_toplevels; i++) { - v = rp->toplevels[i]; - if (!already_linked || SCHEME_FALSEP(v)) - v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp); - else if (SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)) { - /* not already linked, after all */ - v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx, insp); - } - pf->a[i] = v; - } - - if (rp->num_stxes) { - if (insp && SCHEME_FALSEP(insp)) - insp = scheme_get_current_inspector(); - i = rp->num_toplevels; - v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), - src_modidx, now_modidx, - !already_linked ? genv->module_registry->exports : NULL, - rp->src_insp_desc, insp); - if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { - /* Put lazy-shift info in pf->a[i]: */ - Scheme_Object **ls; - ls = MALLOC_N(Scheme_Object *, 2); - ls[0] = v; - ls[1] = (Scheme_Object *)rp; - pf->a[i] = (Scheme_Object *)ls; - /* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */ - } else { - /* No shift, so fill in stxes immediately */ - i++; - for (j = 0; j < rp->num_stxes; j++) { - pf->a[i + j] = rp->stxes[j]; - } - } - j = rp->num_stxes + 1; - } else - j = 0; - - if (rp->num_lifts) { - Scheme_Object *sym, *home; - sym = scheme_make_symbol(""); /* uninterned! */ - j += rp->num_toplevels; - home = (Scheme_Object *)scheme_get_home_weak_link(genv); - for (i = 0; i < rp->num_lifts; i++, j++) { - v = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Bucket_With_Home); - v->type = scheme_variable_type; - ((Scheme_Bucket_With_Flags *)v)->flags = GLOB_HAS_HOME_PTR; - ((Scheme_Bucket_With_Home *)v)->home_link = home; - ((Scheme_Bucket *)v)->key = (char *)sym; - pf->a[j] = v; - } - } - } - - return rs_save; +Scheme_Object *scheme_make_modidx(Scheme_Object *path, + Scheme_Object *base, + Scheme_Object *resolved) +{ + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("module-path-index-join"); + a[0] = path; + a[1] = base; + return scheme_apply(proc, 2, a); + } -void scheme_pop_prefix(Scheme_Object **rs) +int scheme_is_module_path_index(Scheme_Object *v) { - /* This function must not allocate, since a relevant multiple-values - result may be in the thread record (and we don't want it zerod) */ - MZ_RUNSTACK = rs; + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("module-path-index?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -Scheme_Object *scheme_suspend_prefix(Scheme_Object **rs) +int scheme_is_resolved_module_path(Scheme_Object *v) { - if (rs != MZ_RUNSTACK) { - Scheme_Object *v; - v = MZ_RUNSTACK[0]; - MZ_RUNSTACK++; - return v; - } else - return NULL; + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("resolved-module-path?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -Scheme_Object **scheme_resume_prefix(Scheme_Object *v) +int scheme_is_module_path(Scheme_Object *v) { - if (v) { - --MZ_RUNSTACK; - MZ_RUNSTACK[0] = v; - return MZ_RUNSTACK + 1; - } else - return MZ_RUNSTACK; + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("module-path?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -#ifdef MZ_PRECISE_GC -static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC +int scheme_module_is_declared(Scheme_Object *name, int try_load) { - if (!GC_is_partial(gc)) { - if (scheme_inc_prefix_finalize != (Scheme_Prefix *)0x1) { - Scheme_Prefix *pf = scheme_inc_prefix_finalize; - while (pf->next_final != (Scheme_Prefix *)0x1) { - pf = pf->next_final; - } - pf->next_final = scheme_prefix_finalize; - scheme_prefix_finalize = scheme_inc_prefix_finalize; - scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; - } - } - - if (scheme_prefix_finalize != (Scheme_Prefix *)0x1) { - Scheme_Prefix *pf = scheme_prefix_finalize, *next; - Scheme_Object *clo; - int i, *use_bits, maxpos; - - scheme_prefix_finalize = (Scheme_Prefix *)0x1; - while (pf != (Scheme_Prefix *)0x1) { - /* If not marked, only references are through closures: */ - if (!GC_is_marked2(pf, gc)) { - /* Clear slots that are not use in map */ - maxpos = (pf->num_slots - pf->num_stxes); - use_bits = PREFIX_TO_USE_BITS(pf); - for (i = (maxpos + 31) / 32; i--; ) { - int j; - for (j = 0; j < 32; j++) { - if (!(use_bits[i] & ((unsigned)1 << j))) { - int pos; - pos = (i * 32) + j; - if (pos < pf->num_toplevels) - pf->a[pos] = NULL; /* top level */ - else if (pos < maxpos) { - if (pf->num_stxes) { - if (pos == pf->num_toplevels) { - /* any syntax object */ - int k; - for (k = pf->num_stxes+1; k--;) { - pf->a[k + pf->num_toplevels] = NULL; - } - } else - pf->a[pos + pf->num_stxes] = NULL; /* lifted */ - } else - pf->a[pos] = NULL; /* lifted */ - } - } - } - use_bits[i] = 0; - } - /* Should mark/copy pf, but not trigger or require mark propagation: */ -#ifdef MZ_GC_BACKTRACE - GC_set_backpointer_object(pf->backpointer); -#endif - GC_mark_no_recur(gc, 1); - gcMARK2(pf, gc); - pf = (Scheme_Prefix *)GC_resolve2(pf, gc); - GC_retract_only_mark_stack_entry(pf, gc); - GC_mark_no_recur(gc, 0); - } else - pf = (Scheme_Prefix *)GC_resolve2(pf, gc); - - /* Clear use map */ - use_bits = PREFIX_TO_USE_BITS(pf); - maxpos = (pf->num_slots - pf->num_stxes); - for (i = (maxpos + 31) / 32; i--; ) - use_bits[i] = 0; - - /* Fix up closures that reference this prefix: */ - clo = (Scheme_Object *)GC_resolve2(pf->fixup_chain, gc); - pf->fixup_chain = NULL; - while (clo) { - Scheme_Object *next; - if (SCHEME_TYPE(clo) == scheme_closure_type) { - Scheme_Closure *cl = (Scheme_Closure *)clo; - int closure_size = ((Scheme_Lambda *)GC_resolve2(cl->code, gc))->closure_size; - next = cl->vals[closure_size - 1]; - cl->vals[closure_size-1] = (Scheme_Object *)pf; - } else if (SCHEME_TYPE(clo) == scheme_native_closure_type) { - Scheme_Native_Closure *cl = (Scheme_Native_Closure *)clo; - int closure_size = ((Scheme_Native_Lambda *)GC_resolve2(cl->code, gc))->closure_size; - next = cl->vals[closure_size - 1]; - cl->vals[closure_size-1] = (Scheme_Object *)pf; - } else { - MZ_ASSERT(0); - next = NULL; - } - clo = (Scheme_Object *)GC_resolve2(next, gc); - } - if (SCHEME_PREFIX_FLAGS(pf) & 0x1) - SCHEME_PREFIX_FLAGS(pf) -= 0x1; - - /* Next */ - next = pf->next_final; - pf->next_final = NULL; - - pf = next; - } - } + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("module-declared?"); + a[0] = name; + a[1] = (try_load ? scheme_true : scheme_false); + return SCHEME_TRUEP(scheme_apply(proc, 2, a)); } -int check_pruned_prefix(void *p) XFORM_SKIP_PROC +Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *v) { - Scheme_Prefix *pf = (Scheme_Prefix *)p; - return SCHEME_PREFIX_FLAGS(pf) & 0x1; + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("datum->kernel-syntax"); + a[0] = v; + return scheme_apply(proc, 1, a); } -#endif /*========================================================================*/ /* precise GC traversers */ diff -Nru racket-6.12+ppa1/src/racket/src/file.c racket-7.0+ppa1/src/racket/src/file.c --- racket-6.12+ppa1/src/racket/src/file.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/file.c 2018-07-27 22:12:02.000000000 +0000 @@ -54,12 +54,6 @@ #define IS_A_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_SEP(x) : IS_A_DOS_SEP(x)) #define IS_A_PRIM_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_PRIM_SEP(x) : IS_A_DOS_PRIM_SEP(x)) -SHARED_OK int scheme_ignore_user_paths; -void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; } - -SHARED_OK int scheme_ignore_link_paths; -void scheme_set_ignore_link_paths(int v) { scheme_ignore_link_paths = v; } - #define CURRENT_WD() scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY) #define TO_PATH(x) (SCHEME_GENERAL_PATHP(x) ? x : scheme_char_string_to_path(x)) @@ -127,13 +121,6 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]); static Scheme_Object *file_identity(int argc, Scheme_Object *argv[]); static Scheme_Object *file_size(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[]); -static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]); -static Scheme_Object *compiled_file_roots(int, Scheme_Object *[]); -static Scheme_Object *use_user_paths(int, Scheme_Object *[]); -static Scheme_Object *use_link_paths(int, Scheme_Object *[]); -static Scheme_Object *use_compiled_file_check(int, Scheme_Object *[]); static Scheme_Object *find_system_path(int argc, Scheme_Object **argv); static Scheme_Object *current_directory(int argc, Scheme_Object *argv[]); @@ -172,7 +159,7 @@ READ_ONLY static Scheme_Object *windows_symbol, *unix_symbol; -void scheme_init_file(Scheme_Env *env) +void scheme_init_file(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -235,270 +222,235 @@ p = scheme_make_immed_prim(path_p, "path?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("path?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("path?", p, env); - scheme_add_global_constant("path-for-some-system?", + scheme_addto_prim_instance("path-for-some-system?", scheme_make_folding_prim(general_path_p, "path-for-some-system?", 1, 1, 1), env); - scheme_add_global_constant("path-convention-type", + scheme_addto_prim_instance("path-convention-type", scheme_make_folding_prim(path_kind, "path-convention-type", 1, 1, 1), env); - scheme_add_global_constant("system-path-convention-type", + scheme_addto_prim_instance("system-path-convention-type", scheme_make_immed_prim(platform_path_kind, "system-path-convention-type", 0, 0), env); - scheme_add_global_constant("path->string", + scheme_addto_prim_instance("path->string", scheme_make_immed_prim(path_to_string, "path->string", 1, 1), env); - scheme_add_global_constant("path->bytes", + scheme_addto_prim_instance("path->bytes", scheme_make_immed_prim(path_to_bytes, "path->bytes", 1, 1), env); - scheme_add_global_constant("path-element->bytes", + scheme_addto_prim_instance("path-element->bytes", scheme_make_immed_prim(path_element_to_bytes, "path-element->bytes", 1, 1), env); - scheme_add_global_constant("path-element->string", + scheme_addto_prim_instance("path-element->string", scheme_make_immed_prim(path_element_to_string, "path-element->string", 1, 1), env); - scheme_add_global_constant("string->path", + scheme_addto_prim_instance("string->path", scheme_make_immed_prim(string_to_path, "string->path", 1, 1), env); - scheme_add_global_constant("bytes->path", + scheme_addto_prim_instance("bytes->path", scheme_make_immed_prim(bytes_to_path, "bytes->path", 1, 2), env); - scheme_add_global_constant("bytes->path-element", + scheme_addto_prim_instance("bytes->path-element", scheme_make_immed_prim(bytes_to_path_element, "bytes->path-element", 1, 2), env); - scheme_add_global_constant("string->path-element", + scheme_addto_prim_instance("string->path-element", scheme_make_immed_prim(string_to_path_element, "string->path-element", 1, 1), env); - scheme_add_global_constant("file-exists?", + scheme_addto_prim_instance("file-exists?", scheme_make_prim_w_arity(file_exists, "file-exists?", 1, 1), env); - scheme_add_global_constant("directory-exists?", + scheme_addto_prim_instance("directory-exists?", scheme_make_prim_w_arity(directory_exists, "directory-exists?", 1, 1), env); - scheme_add_global_constant("link-exists?", + scheme_addto_prim_instance("link-exists?", scheme_make_prim_w_arity(link_exists, "link-exists?", 1, 1), env); - scheme_add_global_constant("delete-file", + scheme_addto_prim_instance("delete-file", scheme_make_prim_w_arity(delete_file, "delete-file", 1, 1), env); - scheme_add_global_constant("rename-file-or-directory", + scheme_addto_prim_instance("rename-file-or-directory", scheme_make_prim_w_arity(rename_file, "rename-file-or-directory", 2, 3), env); - scheme_add_global_constant("copy-file", + scheme_addto_prim_instance("copy-file", scheme_make_prim_w_arity(copy_file, "copy-file", 2, 3), env); - scheme_add_global_constant("build-path", + scheme_addto_prim_instance("build-path", scheme_make_immed_prim(scheme_build_path, "build-path", 1, -1), env); - scheme_add_global_constant("build-path/convention-type", + scheme_addto_prim_instance("build-path/convention-type", scheme_make_immed_prim(build_path_kind, "build-path/convention-type", 2, -1), env); - scheme_add_global_constant("path->directory-path", + scheme_addto_prim_instance("path->directory-path", scheme_make_immed_prim(path_to_directory_path, "path->directory-path", 1, 1), env); - scheme_add_global_constant("split-path", + scheme_addto_prim_instance("split-path", scheme_make_prim_w_arity2(split_path, "split-path", 1, 1, 3, 3), env); - scheme_add_global_constant("explode-path", + scheme_addto_prim_instance("explode-path", scheme_make_immed_prim(explode_path, "explode-path", 1, 1), env); - scheme_add_global_constant("relative-path?", + scheme_addto_prim_instance("relative-path?", scheme_make_immed_prim(relative_path_p, "relative-path?", 1, 1), env); - scheme_add_global_constant("absolute-path?", + scheme_addto_prim_instance("absolute-path?", scheme_make_immed_prim(absolute_path_p, "absolute-path?", 1, 1), env); - scheme_add_global_constant("complete-path?", + scheme_addto_prim_instance("complete-path?", scheme_make_immed_prim(complete_path_p, "complete-path?", 1, 1), env); - scheme_add_global_constant("path->complete-path", + scheme_addto_prim_instance("path->complete-path", scheme_make_immed_prim(path_to_complete_path, "path->complete-path", 1, 2), env); - scheme_add_global_constant("resolve-path", + scheme_addto_prim_instance("resolve-path", scheme_make_prim_w_arity(resolve_path, "resolve-path", 1, 1), env); - scheme_add_global_constant("simplify-path", + scheme_addto_prim_instance("simplify-path", scheme_make_prim_w_arity(scheme_simplify_path, "simplify-path", 1, 2), env); - scheme_add_global_constant("cleanse-path", + scheme_addto_prim_instance("cleanse-path", scheme_make_prim_w_arity(cleanse_path, "cleanse-path", 1, 1), env); - scheme_add_global_constant("expand-user-path", + scheme_addto_prim_instance("expand-user-path", scheme_make_prim_w_arity(expand_user_path, "expand-user-path", 1, 1), env); - scheme_add_global_constant("directory-list", + scheme_addto_prim_instance("directory-list", scheme_make_prim_w_arity(directory_list, "directory-list", 0, 1), env); - scheme_add_global_constant("filesystem-root-list", + scheme_addto_prim_instance("filesystem-root-list", scheme_make_prim_w_arity(filesystem_root_list, "filesystem-root-list", 0, 0), env); - scheme_add_global_constant("make-directory", + scheme_addto_prim_instance("make-directory", scheme_make_prim_w_arity(make_directory, "make-directory", 1, 1), env); - scheme_add_global_constant("delete-directory", + scheme_addto_prim_instance("delete-directory", scheme_make_prim_w_arity(delete_directory, "delete-directory", 1, 1), env); - scheme_add_global_constant("make-file-or-directory-link", + scheme_addto_prim_instance("make-file-or-directory-link", scheme_make_prim_w_arity(make_link, "make-file-or-directory-link", 2, 2), env); - scheme_add_global_constant("file-or-directory-modify-seconds", + scheme_addto_prim_instance("file-or-directory-modify-seconds", scheme_make_prim_w_arity(file_modify_seconds, "file-or-directory-modify-seconds", 1, 3), env); - scheme_add_global_constant("file-or-directory-permissions", + scheme_addto_prim_instance("file-or-directory-permissions", scheme_make_prim_w_arity(file_or_dir_permissions, "file-or-directory-permissions", 1, 2), env); - scheme_add_global_constant("file-or-directory-identity", + scheme_addto_prim_instance("file-or-directory-identity", scheme_make_prim_w_arity(file_identity, "file-or-directory-identity", 1, 2), env); - scheme_add_global_constant("file-size", + scheme_addto_prim_instance("file-size", scheme_make_prim_w_arity(file_size, "file-size", 1, 1), env); - scheme_add_global_constant("current-drive", + scheme_addto_prim_instance("current-drive", scheme_make_prim_w_arity(current_drive, "current-drive", 0, 0), env); - scheme_add_global_constant("find-system-path", + scheme_addto_prim_instance("find-system-path", scheme_make_prim_w_arity(find_system_path, "find-system-path", 1, 1), env); - scheme_add_global_constant("current-directory", + scheme_addto_prim_instance("current-directory", scheme_register_parameter(current_directory, "current-directory", MZCONFIG_CURRENT_DIRECTORY), env); - scheme_add_global_constant("current-directory-for-user", + scheme_addto_prim_instance("current-directory-for-user", scheme_register_parameter(current_user_directory, "current-directory-for-user", MZCONFIG_CURRENT_USER_DIRECTORY), env); - scheme_add_global_constant("current-force-delete-permissions", + scheme_addto_prim_instance("current-force-delete-permissions", scheme_register_parameter(current_force_delete_perms, "current-force-delete-permissions", MZCONFIG_FORCE_DELETE_PERMS), env); - - scheme_add_global_constant("current-library-collection-paths", - scheme_register_parameter(current_library_collection_paths, - "current-library-collection-paths", - MZCONFIG_COLLECTION_PATHS), - env); - scheme_add_global_constant("current-library-collection-links", - scheme_register_parameter(current_library_collection_links, - "current-library-collection-links", - MZCONFIG_COLLECTION_LINKS), - env); - scheme_add_global_constant("use-compiled-file-paths", - scheme_register_parameter(use_compiled_kind, - "use-compiled-file-paths", - MZCONFIG_USE_COMPILED_KIND), - env); - scheme_add_global_constant("current-compiled-file-roots", - scheme_register_parameter(compiled_file_roots, - "current-compiled-file-roots", - MZCONFIG_USE_COMPILED_ROOTS), - env); - scheme_add_global_constant("use-user-specific-search-paths", - scheme_register_parameter(use_user_paths, - "use-user-specific-search-paths", - MZCONFIG_USE_USER_PATHS), - env); - scheme_add_global_constant("use-collection-link-paths", - scheme_register_parameter(use_link_paths, - "use-collection-link-paths", - MZCONFIG_USE_LINK_PATHS), - env); - scheme_add_global_constant("use-compiled-file-check", - scheme_register_parameter(use_compiled_file_check, - "use-compiled-file-check", - MZCONFIG_USE_COMPILED_FILE_CHECK), - env); } void scheme_init_file_places() @@ -613,48 +565,8 @@ Scheme_Object *make_exposed_sized_offset_path(int *optional, int already_protected, char *chars, intptr_t d, intptr_t len, int copy, int kind) - /* Called to make a directory path where the end has been removed. - We may need to remove a redundant separator. - Under Windows, if the resulting last element has spaces or is a - special file, then we need to protect it with "\\?\". */ + /* Called to make a directory path where the end has been removed. */ { - if (kind == SCHEME_WINDOWS_PATH_KIND) { - if (!already_protected) { - int i, name_end; - int non_dot = 0, trailing_dots = 0, protect = 0; - /* Skip trailing seps: */ - for (i = d + len - 1; (i > d) && IS_A_DOS_SEP(chars[i]); --i) { - } - name_end = i+1; - for (; (i > d) && !IS_A_DOS_SEP(chars[i]); --i) { - if ((chars[i] != ' ') && (chars[i] != '.')) - non_dot = 1; - else if (!non_dot) - trailing_dots = 1; - } - if (non_dot && trailing_dots) - protect = 1; - else if (name_end == (d + len)) - protect = is_special_filename(chars, i+1, name_end, 0, 1); - - if (protect) { - Scheme_Object *first, *last, *a[2]; - char *s2; - int l; - l = name_end - (i+1); - s2 = (char *)scheme_malloc_atomic(l + 9 + 1); - memcpy(s2, "\\\\?\\REL\\\\", 9); - memcpy(s2+9, chars + i + 1, l); - s2[l + 9] = 0; - last = scheme_make_sized_offset_kind_path(s2, 0, l+9, 0, SCHEME_WINDOWS_PATH_KIND); - first = make_exposed_sized_offset_path(NULL, 0, chars, d, i-d+1, 1, SCHEME_WINDOWS_PATH_KIND); - a[0] = first; - a[1] = last; - return scheme_build_path(2, a); - } - } - } - /* We may need to remove a redundant separator from the directory path. Try removing it, and see if anyone would care: */ if (do_path_to_directory_path(chars, d, len - 1, scheme_true, 1, kind)) { @@ -1491,9 +1403,9 @@ else len = strlen(s); - /* Keep separators that are at the very end: */ + /* Don't strip before a separator: */ if ((len - skip_end > delta) && IS_A_DOS_SEP(s[len - 1 - skip_end])) { - skip_end++; + return (char *)s; } if ((len - skip_end > delta) @@ -4754,7 +4666,7 @@ "make-file-or-directory-link: cannot make link;\n" " the path already exists\n" " path: %q", - filename_for_error(argv[0])); + filename_for_error(argv[1])); } else { scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, "make-file-or-directory-link: cannot make link\n" @@ -5008,240 +4920,6 @@ argc, argv, -1, NULL, NULL, 1); } -static Scheme_Object *check_link_key_val(Scheme_Object *key, Scheme_Object *val) -{ - Scheme_Object *new_val = scheme_null, *a; - - if (!SCHEME_FALSEP(key) - && (!SCHEME_SYMBOLP(key) - || !scheme_is_module_path(key))) - return NULL; - - while (SCHEME_PAIRP(val)) { - a = SCHEME_CAR(val); - if (!SCHEME_PATH_STRINGP(a)) - return NULL; - a = TO_PATH(a); - if (!scheme_is_complete_path(SCHEME_PATH_VAL(a), - SCHEME_PATH_LEN(a), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - new_val = scheme_make_pair(a, new_val); - val = SCHEME_CDR(val); - } - - if (!SCHEME_NULLP(val)) - return NULL; - - return scheme_reverse(new_val); -} - -static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok, int links_ok) -{ - Scheme_Object *v = argv[0]; - Scheme_Object *new_hts = scheme_null; - - if (scheme_proper_list_length(v) < 0) - return NULL; - - if (SCHEME_NULLP(v)) - return v; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *s; - s = SCHEME_CAR(v); - if (sym_ok && SAME_OBJ(s, same_symbol)) { - /* ok */ - } else if (links_ok && SCHEME_FALSEP(s)) { - /* ok */ - } else if (links_ok && (SCHEME_CHAPERONE_HASHTP(s) - || SCHEME_CHAPERONE_HASHTRP(s) - || SCHEME_CHAPERONE_BUCKTP(s))) { - Scheme_Hash_Tree *new_ht; - Scheme_Object *key, *val, *idx, *a[2]; - - new_ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - a[0] = s; - idx = scheme_hash_table_iterate_start(1, a); - while (SCHEME_TRUEP(idx)) { - a[0] = s; - a[1] = idx; - key = scheme_hash_table_iterate_key(2, a); - - val = scheme_chaperone_hash_get(s, key); - if (val) { - val = check_link_key_val(key, val); - if (!val) return NULL; - new_ht = scheme_hash_tree_set(new_ht, key, val); - } - - a[0] = s; - a[1] = idx; - idx = scheme_hash_table_iterate_next(2, a); - } - - new_hts = scheme_make_pair((Scheme_Object *)new_ht, new_hts); - } else { - if (!SCHEME_PATH_STRINGP(s)) - return NULL; - s = TO_PATH(s); - if (!abs_ok && !scheme_is_relative_path(SCHEME_PATH_VAL(s), - SCHEME_PATH_LEN(s), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - if (!rel_ok && !scheme_is_complete_path(SCHEME_PATH_VAL(s), - SCHEME_PATH_LEN(s), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - } - v = SCHEME_CDR(v); - } - - if (!SCHEME_NULLP(v)) - return NULL; - - new_hts = scheme_reverse(new_hts); - - /* Convert to list of paths: */ - { - Scheme_Object *last = NULL, *first = NULL, *p, *s; - v = argv[0]; - while (SCHEME_PAIRP(v)) { - s = SCHEME_CAR(v); - if (SCHEME_SYMBOLP(s)) { - /* ok */ - } else if (SCHEME_FALSEP(s)) { - /* ok */ - } else if (SCHEME_PATH_STRINGP(s)) { - s = TO_PATH(s); - } else { - s = SCHEME_CAR(new_hts); - new_hts = SCHEME_CDR(new_hts); - } - - p = scheme_make_pair(s, scheme_null); - if (!first) - first = p; - else - SCHEME_CDR(last) = p; - last = p; - - v = SCHEME_CDR(v); - } - - return first; - } -} - -static Scheme_Object *collpaths_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 0, 1, 0, 0); -} - -Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) { - return current_library_collection_paths(argc, argv); -} - -static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-library-collection-paths", - scheme_make_integer(MZCONFIG_COLLECTION_PATHS), - argc, argv, - -1, collpaths_p, "(listof (and/c path-string? complete-path?))", 1); -} - -static Scheme_Object *colllinks_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 0, 1, 0, 1); -} - -Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]) { - return current_library_collection_links(argc, argv); -} - -static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-library-collection-links", - scheme_make_integer(MZCONFIG_COLLECTION_LINKS), - argc, argv, - -1, colllinks_p, - "(listof (or/c #f (and/c path-string? complete-path?)" - /**/ " (hash/c (or/c (and/c symbol? module-path?) #f)" - /**/ " (listof (and/c path-string? complete-path?)))))", - 1); -} - -static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 1, 0, 0, 0); -} - -static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("use-compiled-file-paths", - scheme_make_integer(MZCONFIG_USE_COMPILED_KIND), - argc, argv, - -1, compiled_kind_p, "(listof (and/c path-string? relative-path?))", 1); -} - -static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 1, 1, 1, 0); -} - -Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]) -{ - return compiled_file_roots(argc, argv); -} - -static Scheme_Object *compiled_file_roots(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-compiled-file-roots", - scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS), - argc, argv, - -1, compiled_roots_p, "(listof (or/c path-string? 'same))", 1); -} - -static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("use-user-specific-search-paths", - scheme_make_integer(MZCONFIG_USE_USER_PATHS), - argc, argv, - -1, NULL, NULL, 1); -} - -static Scheme_Object *use_link_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("use-collection-link-paths", - scheme_make_integer(MZCONFIG_USE_LINK_PATHS), - argc, argv, - -1, NULL, NULL, 1); -} - -static Scheme_Object *compiled_file_check_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v = argv[0]; - - if (SCHEME_SYMBOLP(v) - && !SCHEME_SYM_WEIRDP(v) - && (((SCHEME_SYM_LEN(v) == 14) - && !strcmp(SCHEME_SYM_VAL(v), "modify-seconds")) - || ((SCHEME_SYM_LEN(v) == 6) - && !strcmp(SCHEME_SYM_VAL(v), "exists")))) - return v; - - return NULL; -} - -static Scheme_Object *use_compiled_file_check(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("use-compiled-file-check", - scheme_make_integer(MZCONFIG_USE_COMPILED_FILE_CHECK), - argc, argv, - -1, compiled_file_check_p, "(or/c 'modify-seconds 'exists)", 0); -} - /********************************************************************************/ Scheme_Object *scheme_get_run_cmd(void) @@ -5307,10 +4985,10 @@ } else { scheme_wrong_contract("find-system-path", "(or/c 'home-dir 'pref-dir 'pref-file 'temp-dir\n" - " 'init-dir 'init-file 'addon-dir\n" - " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" - " 'collects-dir 'config-dir 'orig-dir\n" - " 'host-collects-dir 'host-config-fir)", + " 'init-dir 'init-file 'addon-dir\n" + " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" + " 'collects-dir 'config-dir 'orig-dir\n" + " 'host-collects-dir 'host-config-dir)", 0, argc, argv); return NULL; } @@ -5420,6 +5098,9 @@ #ifdef DOS_FILE_SYSTEM +static scheme_dll_open_proc alt_dll_open; +static scheme_dll_find_object_proc alt_find_obj; + void scheme_set_dll_path(wchar_t *p) { rktio_set_dll_path(p); @@ -5439,4 +5120,34 @@ return r2; } +void scheme_set_dll_procs(scheme_dll_open_proc dll_open, scheme_dll_find_object_proc find_obj) +{ + rktio_set_dll_procs(dll_open, find_obj); + alt_dll_open = dll_open; + alt_find_obj = find_obj; +} + +HANDLE scheme_dll_load_library(const char *s, const wchar_t *ws, int *_mode) +{ + if (alt_dll_open) { + void *h; + h = alt_dll_open(s, 0); + if (h) { + *_mode = 1; + return (HANDLE)h; + } + } + + *_mode = 0; + return LoadLibraryW(scheme_get_dll_path(ws)); +} + +void *scheme_dll_get_proc_address(HANDLE m, const char *name, int dll_mode) +{ + if (dll_mode) + return alt_find_obj((void *)m, name); + else + return GetProcAddress(m, name); +} + #endif diff -Nru racket-6.12+ppa1/src/racket/src/fun.c racket-7.0+ppa1/src/racket/src/fun.c --- racket-6.12+ppa1/src/racket/src/fun.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/fun.c 2018-07-27 22:12:02.000000000 +0000 @@ -30,7 +30,6 @@ overflow and continuation-jump limits. */ #include "schpriv.h" -#include "schexpobs.h" #include "schmach.h" #include "schrktio.h" @@ -82,6 +81,7 @@ READ_ONLY static Scheme_Object *abort_continuation_proc; READ_ONLY static Scheme_Object *internal_call_cc_prim; READ_ONLY static Scheme_Object *finish_call_cc_prim; +READ_ONLY static Scheme_Object *propagate_abort_prim; /* Caches need to be thread-local: */ THREAD_LOCAL_DECL(static Scheme_Prompt *available_prompt); @@ -95,6 +95,8 @@ THREAD_LOCAL_DECL(int scheme_cont_capture_count); THREAD_LOCAL_DECL(static int scheme_prompt_capture_count); +#define MARK_CACHE_THRESHOLD 16 + /* locals */ static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]); static Scheme_Object *apply (int argc, Scheme_Object *argv[]); @@ -105,6 +107,7 @@ static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]); +static Scheme_Object *propagate_abort (int argc, Scheme_Object *argv[]); static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_prompt (int argc, Scheme_Object *argv[]); @@ -207,7 +210,7 @@ /*========================================================================*/ void -scheme_init_fun (Scheme_Env *env) +scheme_init_fun (Scheme_Startup_Env *env) { Scheme_Object *o; @@ -228,8 +231,9 @@ o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("procedure?", o, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure?", o, env); scheme_procedure_p_proc = o; @@ -238,34 +242,30 @@ "apply", 2, -1, 0, -1); - scheme_add_global_constant("apply", scheme_apply_proc, env); - scheme_add_global_constant("map", - scheme_make_noncm_prim(map, - "map", - 2, -1), - env); - scheme_add_global_constant("for-each", - scheme_make_noncm_prim(for_each, - "for-each", - 2, -1), - env); - scheme_add_global_constant("andmap", - scheme_make_prim_w_arity(andmap, - "andmap", - 2, -1), - env); - scheme_add_global_constant("ormap", - scheme_make_prim_w_arity(ormap, - "ormap", - 2, -1), - env); + scheme_addto_prim_instance("apply", scheme_apply_proc, env); + + o = scheme_make_noncm_prim(map, "map", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("map", o, env); + + o = scheme_make_noncm_prim(for_each, "for-each", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("for-each", o, env); + + o = scheme_make_prim_w_arity(andmap, "andmap", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("andmap", o, env); + + o = scheme_make_prim_w_arity(ormap, "ormap", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("ormap", o, env); REGISTER_SO(scheme_call_with_values_proc); scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values, "call-with-values", 2, 2, 0, -1); - scheme_add_global_constant("call-with-values", + scheme_addto_prim_instance("call-with-values", scheme_call_with_values_proc, env); @@ -278,7 +278,7 @@ | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("values", + scheme_addto_prim_instance("values", scheme_values_proc, env); @@ -286,7 +286,7 @@ "call-with-escape-continuation", 1, 1, 0, -1); - scheme_add_global_constant("call-with-escape-continuation", o, env); + scheme_addto_prim_instance("call-with-escape-continuation", o, env); REGISTER_SO(internal_call_cc_prim); internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc, @@ -298,6 +298,8 @@ "finish-call-with-current-continuation", 2, 2, 0, -1); + REGISTER_SO(propagate_abort_prim); + propagate_abort_prim = scheme_make_prim_w_arity(propagate_abort, "propagate-abort", 0, -1); # define MAX_CALL_CC_ARG_COUNT 2 o = scheme_make_prim_w_arity2(call_cc, @@ -305,15 +307,15 @@ 1, MAX_CALL_CC_ARG_COUNT, 0, -1); - scheme_add_global_constant("call-with-current-continuation", o, env); + scheme_addto_prim_instance("call-with-current-continuation", o, env); - scheme_add_global_constant("continuation?", + scheme_addto_prim_instance("continuation?", scheme_make_folding_prim(continuation_p, "continuation?", 1, 1, 1), env); - scheme_add_global_constant("call-with-continuation-barrier", + scheme_addto_prim_instance("call-with-continuation-barrier", scheme_make_prim_w_arity2(call_with_continuation_barrier, "call-with-continuation-barrier", 1, 1, @@ -325,11 +327,11 @@ "call-with-continuation-prompt", 1, -1, 0, -1); - scheme_add_global_constant("call-with-continuation-prompt", + scheme_addto_prim_instance("call-with-continuation-prompt", call_with_prompt_proc, env); - scheme_add_global_constant("call-with-composable-continuation", + scheme_addto_prim_instance("call-with-composable-continuation", scheme_make_prim_w_arity2(call_with_control, "call-with-composable-continuation", 1, 2, @@ -340,93 +342,93 @@ abort_continuation_proc = scheme_make_prim_w_arity(abort_continuation, "abort-current-continuation", 1, -1); - scheme_add_global_constant("abort-current-continuation", + scheme_addto_prim_instance("abort-current-continuation", abort_continuation_proc, env); - scheme_add_global_constant("continuation-prompt-available?", + scheme_addto_prim_instance("continuation-prompt-available?", scheme_make_prim_w_arity(continuation_prompt_available, "continuation-prompt-available?", 1, 2), env); - scheme_add_global_constant("make-continuation-prompt-tag", + scheme_addto_prim_instance("make-continuation-prompt-tag", scheme_make_prim_w_arity(make_prompt_tag, "make-continuation-prompt-tag", 0, 1), env); - scheme_add_global_constant("default-continuation-prompt-tag", + scheme_addto_prim_instance("default-continuation-prompt-tag", scheme_make_prim_w_arity(get_default_prompt_tag, "default-continuation-prompt-tag", 0, 0), env); - scheme_add_global_constant("continuation-prompt-tag?", + scheme_addto_prim_instance("continuation-prompt-tag?", scheme_make_folding_prim(prompt_tag_p, "continuation-prompt-tag?", 1, 1, 1), env); - scheme_add_global_constant("impersonate-prompt-tag", + scheme_addto_prim_instance("impersonate-prompt-tag", scheme_make_prim_w_arity(impersonate_prompt_tag, "impersonate-prompt-tag", 3, -1), env); - scheme_add_global_constant("chaperone-prompt-tag", + scheme_addto_prim_instance("chaperone-prompt-tag", scheme_make_prim_w_arity(chaperone_prompt_tag, "chaperone-prompt-tag", 3, -1), env); - scheme_add_global_constant("call-with-semaphore", + scheme_addto_prim_instance("call-with-semaphore", scheme_make_prim_w_arity2(call_with_sema, "call-with-semaphore", 2, -1, 0, -1), env); - scheme_add_global_constant("call-with-semaphore/enable-break", + scheme_addto_prim_instance("call-with-semaphore/enable-break", scheme_make_prim_w_arity2(call_with_sema_enable_break, "call-with-semaphore/enable-break", 2, -1, 0, -1), env); - scheme_add_global_constant("make-continuation-mark-key", + scheme_addto_prim_instance("make-continuation-mark-key", scheme_make_prim_w_arity(make_continuation_mark_key, "make-continuation-mark-key", 0, 1), env); - scheme_add_global_constant("continuation-mark-key?", + scheme_addto_prim_instance("continuation-mark-key?", scheme_make_prim_w_arity(continuation_mark_key_p, "continuation-mark-key?", 1, 1), env); - scheme_add_global_constant("impersonate-continuation-mark-key", + scheme_addto_prim_instance("impersonate-continuation-mark-key", scheme_make_prim_w_arity(impersonate_continuation_mark_key, "impersonate-continuation-mark-key", 3, -1), env); - scheme_add_global_constant("chaperone-continuation-mark-key", + scheme_addto_prim_instance("chaperone-continuation-mark-key", scheme_make_prim_w_arity(chaperone_continuation_mark_key, "chaperone-continuation-mark-key", 3, -1), env); - scheme_add_global_constant("current-continuation-marks", + scheme_addto_prim_instance("current-continuation-marks", scheme_make_prim_w_arity(cc_marks, "current-continuation-marks", 0, 1), env); - scheme_add_global_constant("continuation-marks", + scheme_addto_prim_instance("continuation-marks", scheme_make_prim_w_arity(cont_marks, "continuation-marks", 1, 2), env); - scheme_add_global_constant("continuation-mark-set->list", + scheme_addto_prim_instance("continuation-mark-set->list", scheme_make_prim_w_arity(extract_cc_marks, "continuation-mark-set->list", 2, 3), env); - scheme_add_global_constant("continuation-mark-set->list*", + scheme_addto_prim_instance("continuation-mark-set->list*", scheme_make_prim_w_arity(extract_cc_markses, "continuation-mark-set->list*", 2, 4), @@ -436,22 +438,22 @@ "continuation-mark-set-first", 2, 4); SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("continuation-mark-set-first", o, env); + scheme_addto_prim_instance("continuation-mark-set-first", o, env); REGISTER_SO(scheme_call_with_immed_mark_proc); scheme_call_with_immed_mark_proc = scheme_make_prim_w_arity2(call_with_immediate_cc_mark, "call-with-immediate-continuation-mark", 2, 3, 0, -1); - scheme_add_global_constant("call-with-immediate-continuation-mark", + scheme_addto_prim_instance("call-with-immediate-continuation-mark", scheme_call_with_immed_mark_proc, env); - scheme_add_global_constant("continuation-mark-set?", + scheme_addto_prim_instance("continuation-mark-set?", scheme_make_prim_w_arity(cc_marks_p, "continuation-mark-set?", 1, 1), env); - scheme_add_global_constant("continuation-mark-set->context", + scheme_addto_prim_instance("continuation-mark-set->context", scheme_make_prim_w_arity(extract_cc_proc_marks, "continuation-mark-set->context", 1, 1), @@ -462,70 +464,71 @@ "void", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_void_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("void", scheme_void_proc, env); + scheme_addto_prim_instance("void", scheme_void_proc, env); REGISTER_SO(scheme_void_p_proc); scheme_void_p_proc = scheme_make_folding_prim(void_p, "void?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_void_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("void?", scheme_void_p_proc, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("void?", scheme_void_p_proc, env); - scheme_add_global_constant("time-apply", + scheme_addto_prim_instance("time-apply", scheme_make_prim_w_arity2(time_apply, "time-apply", 2, 2, 4, 4), env); - scheme_add_global_constant("current-milliseconds", + scheme_addto_prim_instance("current-milliseconds", scheme_make_immed_prim(current_milliseconds, "current-milliseconds", 0, 0), env); - scheme_add_global_constant("current-inexact-milliseconds", + scheme_addto_prim_instance("current-inexact-milliseconds", scheme_make_immed_prim(current_inexact_milliseconds, "current-inexact-milliseconds", 0, 0), env); - scheme_add_global_constant("current-process-milliseconds", + scheme_addto_prim_instance("current-process-milliseconds", scheme_make_immed_prim(current_process_milliseconds, "current-process-milliseconds", 0, 1), env); - scheme_add_global_constant("current-gc-milliseconds", + scheme_addto_prim_instance("current-gc-milliseconds", scheme_make_immed_prim(current_gc_milliseconds, "current-gc-milliseconds", 0, 0), env); - scheme_add_global_constant("current-seconds", + scheme_addto_prim_instance("current-seconds", scheme_make_immed_prim(current_seconds, "current-seconds", 0, 0), env); - scheme_add_global_constant("seconds->date", + scheme_addto_prim_instance("seconds->date", scheme_make_immed_prim(seconds_to_date, "seconds->date", 1, 2), env); - scheme_add_global_constant("dynamic-wind", + scheme_addto_prim_instance("dynamic-wind", scheme_make_prim_w_arity(dynamic_wind, "dynamic-wind", 3, 3), env); - scheme_add_global_constant("object-name", + scheme_addto_prim_instance("object-name", scheme_make_folding_prim(object_name, "object-name", 1, 1, 1), env); - scheme_add_global_constant("procedure-arity", + scheme_addto_prim_instance("procedure-arity", scheme_make_folding_prim(procedure_arity, "procedure-arity", 1, 1, 1), env); - scheme_add_global_constant("procedure-arity?", + scheme_addto_prim_instance("procedure-arity?", scheme_make_folding_prim(procedure_arity_p, "procedure-arity?", 1, 1, 1), @@ -534,98 +537,102 @@ o = scheme_make_folding_prim(scheme_procedure_arity_includes, "procedure-arity-includes?", 2, 3, 1); - SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); scheme_procedure_arity_includes_proc = o; - scheme_add_global_constant("procedure-arity-includes?", o, env); + scheme_addto_prim_instance("procedure-arity-includes?", o, env); - scheme_add_global_constant("procedure-reduce-arity", + scheme_addto_prim_instance("procedure-reduce-arity", scheme_make_prim_w_arity(procedure_reduce_arity, "procedure-reduce-arity", 2, 2), env); - scheme_add_global_constant("procedure-rename", + scheme_addto_prim_instance("procedure-rename", scheme_make_prim_w_arity(procedure_rename, "procedure-rename", 2, 2), env); - scheme_add_global_constant("procedure->method", + scheme_addto_prim_instance("procedure->method", scheme_make_prim_w_arity(procedure_to_method, "procedure->method", 1, 1), env); - scheme_add_global_constant("procedure-closure-contents-eq?", - scheme_make_folding_prim(procedure_equal_closure_p, - "procedure-closure-contents-eq?", - 2, 2, 1), - env); + + o = scheme_make_folding_prim(procedure_equal_closure_p, + "procedure-closure-contents-eq?", + 2, 2, 1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure-closure-contents-eq?", o, env); REGISTER_SO(scheme_procedure_specialize_proc); o = scheme_make_prim_w_arity(procedure_specialize, "procedure-specialize", 1, 1); scheme_procedure_specialize_proc = o; - scheme_add_global_constant("procedure-specialize", o, env); + scheme_addto_prim_instance("procedure-specialize", o, env); - scheme_add_global_constant("chaperone-procedure", + scheme_addto_prim_instance("chaperone-procedure", scheme_make_prim_w_arity(chaperone_procedure, "chaperone-procedure", 2, -1), env); - scheme_add_global_constant("impersonate-procedure", + scheme_addto_prim_instance("impersonate-procedure", scheme_make_prim_w_arity(impersonate_procedure, "impersonate-procedure", 2, -1), env); - scheme_add_global_constant("chaperone-procedure*", + scheme_addto_prim_instance("chaperone-procedure*", scheme_make_prim_w_arity(chaperone_procedure_star, "chaperone-procedure*", 2, -1), env); - scheme_add_global_constant("impersonate-procedure*", + scheme_addto_prim_instance("impersonate-procedure*", scheme_make_prim_w_arity(impersonate_procedure_star, "impersonate-procedure*", 2, -1), env); - scheme_add_global_constant("primitive?", + scheme_addto_prim_instance("primitive?", scheme_make_folding_prim(primitive_p, "primitive?", 1, 1, 1), env); - scheme_add_global_constant("primitive-closure?", + scheme_addto_prim_instance("primitive-closure?", scheme_make_folding_prim(primitive_closure_p, "primitive-closure?", 1, 1, 1), env); - scheme_add_global_constant("primitive-result-arity", + scheme_addto_prim_instance("primitive-result-arity", scheme_make_folding_prim(primitive_result_arity, "primitive-result-arity", 1, 1, 1), env); - scheme_add_global_constant("procedure-result-arity", + scheme_addto_prim_instance("procedure-result-arity", scheme_make_folding_prim(procedure_result_arity, "procedure-result-arity", 1, 1, 1), env); - scheme_add_global_constant("current-print", + scheme_addto_prim_instance("current-print", scheme_register_parameter(current_print, "current-print", MZCONFIG_PRINT_HANDLER), env); - scheme_add_global_constant("current-prompt-read", + scheme_addto_prim_instance("current-prompt-read", scheme_register_parameter(current_prompt_read, "current-prompt-read", MZCONFIG_PROMPT_READ_HANDLER), env); - scheme_add_global_constant("current-read-interaction", + scheme_addto_prim_instance("current-read-interaction", scheme_register_parameter(current_read, "current-read-interaction", MZCONFIG_READ_HANDLER), env); - scheme_add_global_constant("current-get-interaction-input-port", + scheme_addto_prim_instance("current-get-interaction-input-port", scheme_register_parameter(current_get_read_input_port, "current-get-interaction-input-port", MZCONFIG_READ_INPUT_PORT_HANDLER), @@ -674,7 +681,7 @@ } void -scheme_init_unsafe_fun (Scheme_Env *env) +scheme_init_unsafe_fun (Scheme_Startup_Env *env) { Scheme_Object *o; @@ -683,37 +690,37 @@ scheme_check_not_undefined_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_OPT_IMMEDIATE | scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED)); - scheme_add_global_constant("check-not-unsafe-undefined", o, env); + scheme_addto_prim_instance("check-not-unsafe-undefined", o, env); REGISTER_SO(scheme_check_assign_not_undefined_proc); o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2); scheme_check_assign_not_undefined_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("check-not-unsafe-undefined/assign", o, env); + scheme_addto_prim_instance("check-not-unsafe-undefined/assign", o, env); - scheme_add_global_constant("unsafe-undefined", scheme_undefined, env); + scheme_addto_prim_instance("unsafe-undefined", scheme_undefined, env); REGISTER_SO(scheme_chaperone_undefined_property); o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined")); scheme_chaperone_undefined_property = o; - scheme_add_global_constant("prop:chaperone-unsafe-undefined", o, env); + scheme_addto_prim_instance("prop:chaperone-unsafe-undefined", o, env); o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1); - scheme_add_global_constant("chaperone-struct-unsafe-undefined", o, env); + scheme_addto_prim_instance("chaperone-struct-unsafe-undefined", o, env); - scheme_add_global_constant("unsafe-chaperone-procedure", + scheme_addto_prim_instance("unsafe-chaperone-procedure", scheme_make_prim_w_arity(unsafe_chaperone_procedure, "unsafe-chaperone-procedure", 2, -1), env); - scheme_add_global_constant("unsafe-impersonate-procedure", + scheme_addto_prim_instance("unsafe-impersonate-procedure", scheme_make_prim_w_arity(unsafe_impersonate_procedure, "unsafe-impersonate-procedure", 2, -1), env); - GLOBAL_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env); } void @@ -744,7 +751,7 @@ { Scheme_Primitive_Proc *prim; int hasr, size; - + hasr = ((minr != 1) || (maxr != 1)); size = (hasr ? sizeof(Scheme_Prim_W_Result_Arity) @@ -827,7 +834,8 @@ { /* A non-cm primitive leaves the mark stack unchanged when it returns, it can't return multiple values or a tail call, and it cannot - use its third argument (i.e., the closure pointer). */ + use its third argument (i.e., the closure pointer) unless + SCHEME_PRIM_IS_CLOSURE is also set. */ return make_prim_closure(fun, 1, name, mina, maxa, SCHEME_PRIM_OPT_NONCM, 1, 1, @@ -1137,38 +1145,6 @@ return prompt; } -static void save_dynamic_state(Scheme_Thread *thread, Scheme_Dynamic_State *state) { - state->current_local_env = thread->current_local_env; - state->scope = thread->current_local_scope; - state->use_scope = thread->current_local_use_scope; - state->name = thread->current_local_name; - state->modidx = thread->current_local_modidx; - state->menv = thread->current_local_menv; -} - -static void restore_dynamic_state(Scheme_Dynamic_State *state, Scheme_Thread *thread) { - thread->current_local_env = state->current_local_env; - thread->current_local_scope = state->scope; - thread->current_local_use_scope = state->use_scope; - thread->current_local_name = state->name; - thread->current_local_modidx = state->modidx; - thread->current_local_menv = state->menv; -} - -void scheme_set_dynamic_state(Scheme_Dynamic_State *state, Scheme_Comp_Env *env, - Scheme_Object *scope, Scheme_Object *use_scope, - Scheme_Object *name, - Scheme_Env *menv, - Scheme_Object *modidx) -{ - state->current_local_env = env; - state->scope = scope; - state->use_scope = use_scope; - state->name = name; - state->modidx = modidx; - state->menv = menv; -} - static void *apply_again_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -1188,10 +1164,10 @@ } void *scheme_top_level_do(void *(*k)(void), int eb) { - return scheme_top_level_do_worker(k, eb, 0, NULL); + return scheme_top_level_do_worker(k, eb, 0); } -void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Scheme_Dynamic_State *dyn_state) +void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread) { /* Wraps a function `k' with a handler for stack overflows and barriers to full-continuation jumps. No barrier if !eb. */ @@ -1200,7 +1176,6 @@ mz_jmp_buf *save; mz_jmp_buf newbuf; Scheme_Stack_State envss; - Scheme_Dynamic_State save_dyn_state; Scheme_Thread * volatile p = scheme_current_thread; volatile int old_pcc = scheme_prompt_capture_count; Scheme_Cont_Frame_Data cframe; @@ -1237,12 +1212,6 @@ while (1) { scheme_save_env_stack_w_thread(envss, p); - save_dynamic_state(p, &save_dyn_state); - - if (dyn_state) { - restore_dynamic_state(dyn_state, p); - dyn_state = NULL; - } if (prompt) { scheme_push_continuation_frame(&cframe); @@ -1286,7 +1255,6 @@ } } } - restore_dynamic_state(&save_dyn_state, p); } if (!again) @@ -1313,8 +1281,6 @@ if (!new_thread) { p = scheme_current_thread; - restore_dynamic_state(&save_dyn_state, p); - p->error_buf = save; } @@ -1380,27 +1346,41 @@ { if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) { Scheme_Thread *p = scheme_current_thread; - GC_CAN_IGNORE Scheme_Object *rator; + GC_CAN_IGNORE Scheme_Object *rator, *result; GC_CAN_IGNORE Scheme_Object **rands; - + int argc = p->ku.apply.tail_num_rands, popc = 0; + + rands = p->ku.apply.tail_rands; + /* Watch out for use of tail buffer: */ - if (p->ku.apply.tail_rands == p->tail_buffer) - scheme_realloc_tail_buffer(p); + if (rands == p->tail_buffer) { + GC_CAN_IGNORE Scheme_Object **runstack = MZ_RUNSTACK; + if (((runstack - MZ_RUNSTACK_START) - argc) > SCHEME_TAIL_COPY_THRESHOLD) { + /* There's room on the runstack; use that instead of allocating a new buffer */ + runstack -= argc; + memcpy(runstack, rands, argc * sizeof(Scheme_Object *)); + rands = runstack; + popc = argc; + MZ_RUNSTACK = rands; + } else { + scheme_realloc_tail_buffer(p); + rands = p->ku.apply.tail_rands; + } + } rator = p->ku.apply.tail_rator; - rands = p->ku.apply.tail_rands; p->ku.apply.tail_rator = NULL; p->ku.apply.tail_rands = NULL; - if (multi_ok) { - return _scheme_apply_multi(rator, - p->ku.apply.tail_num_rands, - rands); - } else { - return _scheme_apply(rator, - p->ku.apply.tail_num_rands, - rands); - } + if (multi_ok) + result = _scheme_apply_multi(rator, argc, rands); + else + result = _scheme_apply(rator, argc, rands); + + if (popc) + MZ_RUNSTACK += popc; + + return result; } else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) { Scheme_Thread *p = scheme_current_thread; if (multi_ok) @@ -1516,33 +1496,7 @@ p->ku.k.i1 = 0; p->ku.k.i2 = 1; - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1, NULL); -} - -Scheme_Object * -scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = rator; - p->ku.k.p2 = rands; - p->ku.k.i1 = num_rands; - p->ku.k.i2 = 0; - - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state); -} - -Scheme_Object * -scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = rator; - p->ku.k.p2 = rands; - p->ku.k.i1 = num_rands; - p->ku.k.i2 = 1; - - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state); + return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1); } Scheme_Object * @@ -1730,302 +1684,6 @@ return X_scheme_apply_to_list(rator, rands, 0, 0); } -static Scheme_Object *cert_with_specials_k(void); - -static Scheme_Object * -cert_with_specials(Scheme_Object *code, - Scheme_Object *insp, - Scheme_Object *old_stx, - intptr_t phase, - int deflt, int cadr_deflt) -/* Arms (insp) or re-arms (old_stx) taints. */ -{ - Scheme_Object *prop; - int next_cadr_deflt = 0, phase_delta = 0; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Object **args; - args = MALLOC_N(Scheme_Object*, 3); - args[0] = code; - args[1] = insp; - args[2] = old_stx; - p->ku.k.p1 = (void *)args; - p->ku.k.i1 = phase; - p->ku.k.i2 = deflt; - p->ku.k.i3 = cadr_deflt; - return scheme_handle_stack_overflow(cert_with_specials_k); - } - } -#endif - - if (SCHEME_STXP(code)) { - if (scheme_stx_is_tainted(code)) - /* nothing happens to already-tainted syntax objects */ - return code; - - prop = scheme_stx_property(code, taint_mode_symbol, NULL); - if (SCHEME_FALSEP(prop)) - prop = scheme_stx_property(code, certify_mode_symbol, NULL); - if (SAME_OBJ(prop, none_symbol)) - return code; - else if (SAME_OBJ(prop, opaque_symbol)) { - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); - } else if (SAME_OBJ(prop, transparent_symbol)) { - cadr_deflt = 0; - /* fall through */ - } else if (SAME_OBJ(prop, transparent_binding_symbol)) { - cadr_deflt = 0; - next_cadr_deflt = 1; - /* fall through */ - } else { - /* Default transparency depends on module-identifier=? comparison - to `begin', `define-values', and `define-syntaxes'. */ - int trans = deflt; - if (SCHEME_TRUEP(prop)) - scheme_log(NULL, - SCHEME_LOG_WARNING, - 0, - "warning: unrecognized 'taint-mode property value: %V", - prop); - if (SCHEME_STX_PAIRP(code)) { - Scheme_Object *name; - /* name = SCHEME_STX_CAR(code); */ - name = scheme_stx_taint_disarm(code, NULL); - name = SCHEME_STX_CAR(name); - if (SCHEME_STX_SYMBOLP(name)) { - if (scheme_stx_free_eq_x(scheme_begin_stx, name, phase) - || scheme_stx_free_eq_x(scheme_module_begin_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 0; - } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 0; - phase_delta = 1; - } else if (scheme_stx_free_eq_x(scheme_define_values_stx, name, phase) - || scheme_stx_free_eq_x(scheme_define_syntaxes_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 1; - } - } - } - - if (!trans) { - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); - } - } - } - - if (SCHEME_STX_PAIRP(code)) { - Scheme_Object *a, *d, *v; - - a = SCHEME_STX_CAR(code); - a = cert_with_specials(a, insp, old_stx, phase + phase_delta, cadr_deflt, 0); - d = SCHEME_STX_CDR(code); - d = cert_with_specials(d, insp, old_stx, phase + phase_delta, 1, next_cadr_deflt); - - v = scheme_make_pair(a, d); - - if (SCHEME_PAIRP(code)) - return v; - - v = scheme_datum_to_syntax(v, code, scheme_false, 0, 1); - - if (scheme_syntax_is_original(v) - && !scheme_syntax_is_original(code)) { - /* Since we copied properties without scopes, we need to - explicitly remove originalness */ - v = scheme_syntax_remove_original(v); - } - - return v; - } else if (SCHEME_STX_NULLP(code)) - return code; - - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); -} - -static Scheme_Object *cert_with_specials_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object **args = (Scheme_Object **)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return cert_with_specials(args[0], args[1], args[2], - p->ku.k.i1, - p->ku.k.i2, p->ku.k.i3); -} - -Scheme_Object * -scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, - Scheme_Object *rator, Scheme_Object *code, - Scheme_Comp_Env *env, Scheme_Object *boundname, - Scheme_Compile_Expand_Info *rec, int drec, - int for_set, - int scope_macro_use) -{ - Scheme_Object *orig_code = code; - - if (scheme_is_rename_transformer(rator)) { - Scheme_Object *scope; - - rator = scheme_rename_transformer_id(rator, env); - /* rator is now an identifier */ - - /* and it's introduced by this expression: */ - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - rator = scheme_stx_flip_scope(rator, scope, scheme_true); - - if (for_set) { - Scheme_Object *tail, *setkw; - - tail = SCHEME_STX_CDR(code); - setkw = SCHEME_STX_CAR(code); - tail = SCHEME_STX_CDR(tail); - code = scheme_make_pair(setkw, scheme_make_pair(rator, tail)); - code = scheme_datum_to_syntax(code, orig_code, orig_code, 0, 0); - } else if (SCHEME_SYMBOLP(SCHEME_STX_VAL(code))) - code = rator; - else { - code = SCHEME_STX_CDR(code); - code = scheme_make_pair(rator, code); - code = scheme_datum_to_syntax(code, orig_code, scheme_sys_wraps(env), 0, 0); - } - - code = scheme_stx_track(code, orig_code, name); - - /* Restore old dye packs: */ - code = cert_with_specials(code, NULL, orig_code, env->genv->phase, 0, 0); - - return code; - } else { - Scheme_Object *scope, *use_scope, *rands_vec[1], *track_code, *pre_code; - - if (scheme_is_set_transformer(rator)) - rator = scheme_set_transformer_proc(rator); - - { - /* Ensure that source doesn't already have 'taint-mode or 'certify-mode, - in case argument properties are used for result properties. */ - Scheme_Object *prop; - prop = scheme_stx_property(code, taint_mode_symbol, NULL); - if (SCHEME_TRUEP(prop)) - code = scheme_stx_property(code, taint_mode_symbol, scheme_false); - prop = scheme_stx_property(code, certify_mode_symbol, NULL); - if (SCHEME_TRUEP(prop)) - code = scheme_stx_property(code, certify_mode_symbol, scheme_false); - } - track_code = code; /* after mode properties are removed */ - - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - code = scheme_stx_flip_scope(code, scope, scheme_true); - - if (scope_macro_use) { - use_scope = scheme_new_scope(SCHEME_STX_USE_SITE_SCOPE); - scheme_add_compilation_frame_use_site_scope(env, use_scope); - code = scheme_stx_add_scope(code, use_scope, scheme_true); - } else - use_scope = NULL; - - code = scheme_stx_taint_disarm(code, NULL); - - pre_code = code; - SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(env->observer, code); - - { - Scheme_Dynamic_State dyn_state; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - scheme_prepare_exp_env(env->genv); - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env->genv->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, env, scope, use_scope, boundname, - menv, menv ? menv->link_midx : env->genv->link_midx); - - rands_vec[0] = code; - code = scheme_apply_with_dynamic_state(rator, 1, rands_vec, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - SCHEME_EXPAND_OBSERVE_MACRO_POST_X(env->observer, code, pre_code); - - if (!SCHEME_STXP(code)) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%S: received value from syntax expander was not syntax\n" - " received: %V", - SCHEME_STX_SYM(name), - code); - } - - code = scheme_stx_flip_scope(code, scope, scheme_true); - - code = scheme_stx_track(code, track_code, name); - - /* Restore old dye packs: */ - code = cert_with_specials(code, NULL, orig_code, env->genv->phase, 0, 0); - - return code; - } -} - -Scheme_Object *scheme_syntax_taint_arm(Scheme_Object *stx, Scheme_Object *insp, int use_mode) -{ - intptr_t phase; - - if (SCHEME_FALSEP(insp)) { - insp = scheme_get_local_inspector(); - } - - if (use_mode) { - Scheme_Thread *p = scheme_current_thread; - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - return cert_with_specials(stx, insp, NULL, phase, 0, 0); - } else - return scheme_stx_taint_arm(stx, insp); -} - -Scheme_Object *scheme_syntax_taint_disarm(Scheme_Object *o, Scheme_Object *insp) -{ - if (SCHEME_FALSEP(insp)) { - insp = scheme_get_local_inspector(); - } - - return scheme_stx_taint_disarm(o, insp); -} - -Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *stx, Scheme_Object *from_stx) -{ - Scheme_Thread *p = scheme_current_thread; - intptr_t phase; - - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - - return cert_with_specials(stx, NULL, from_stx, phase, 0, 0); -} - /*========================================================================*/ /* arity */ /*========================================================================*/ @@ -2367,8 +2025,10 @@ if (type == scheme_lambda_type) data = (Scheme_Lambda *)p; - else + else if (type == scheme_closure_type) data = SCHEME_CLOSURE_CODE(p); + else + return scheme_false; mina = maxa = data->num_params; if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) { @@ -2551,7 +2211,7 @@ return 0; } -Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected) +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise) /* result is interned --- a symbol or fixnum */ { Scheme_Object *p; @@ -2559,11 +2219,11 @@ if (expected && SCHEME_SYMBOLP(expected)) { if (SCHEME_SYM_VAL(expected)[0] == 's') { - return (scheme_check_structure_shape(e, expected) + return (scheme_get_or_check_structure_shape(e, expected) ? expected : NULL); } else if (SCHEME_SYM_VAL(expected)[0] == 'p') { - return (scheme_check_structure_property_shape(e, expected) + return (scheme_get_or_check_structure_property_shape(e, expected) ? expected : NULL); } @@ -2572,8 +2232,13 @@ if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type)) e = SCHEME_VEC_ELS(e)[1]; - p = scheme_get_or_check_arity(e, -3); + if (!SCHEME_PROCP(e) && (SCHEME_TYPE(e) >= _scheme_ir_values_types_)) + return NULL; + p = scheme_get_or_check_arity(e, -3); + if (SCHEME_FALSEP(p)) + return NULL; + if (SCHEME_PAIRP(p)) { /* encode as a symbol */ int sz = 32, c = 0; @@ -2600,8 +2265,13 @@ it preserves marks, which is useful information for the JIT. */ intptr_t i = SCHEME_INT_VAL(p); i = ((uintptr_t)i) << 1; - if (scheme_closure_preserves_marks(e)) { - i |= 0x1; + if (expected && SCHEME_INTP(expected) && !(SCHEME_INT_VAL(expected) & 0x1)) { + /* It's ok for an `e` that preserves marks to match an + expectation of not preserving marks */ + } else { + if (!imprecise && scheme_closure_preserves_marks(e)) { + i |= 0x1; + } } p = scheme_make_integer(i); } @@ -2818,7 +2488,8 @@ } else { Scheme_Object *name; - if (type == scheme_ir_lambda_type) { + if ((type == scheme_ir_lambda_type) + || (type == scheme_lambda_type)) { name = ((Scheme_Lambda *)p)->name; } else if (type == scheme_closure_type) { name = SCHEME_CLOSURE_CODE(p)->name; @@ -3088,7 +2759,7 @@ /* -2 means a bignum */ inc_ok = ((argc > 2) && SCHEME_TRUEP(argv[2])); - + return get_or_check_arity(argv[0], n, argv[1], inc_ok); } @@ -3119,7 +2790,7 @@ return 0; } -void scheme_init_reduced_proc_struct(Scheme_Env *env) +void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env) { if (!scheme_reduced_procedure_struct) { Scheme_Inspector *insp; @@ -5797,6 +5468,7 @@ /* Prune resume_mc continuation marks that have replacements in the deepest frame of cont, and add extra_marks */ prune_cont_marks(resume_mc, cont, extra_marks); + p->cont_mark_pos_bottom = cont->cont_mark_pos_bottom; } mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, resume_mc, 0); @@ -5953,6 +5625,8 @@ } } + meta_prompt->boundary_mark_pos = cont->cont_mark_pos_bottom; /* for mark splicing */ + p->meta_prompt = meta_prompt; } @@ -6098,12 +5772,13 @@ prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &prompt_cont, &prompt_pos); if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, pt)) { - scheme_contract_error((composable - ? "call-with-composable-continuation" - : "call-with-current-continuation"), - "continuation includes no prompt with the given tag", - "tag", 1, prompt_tag, - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "%s: continuation includes no prompt with the given tag\n" + " tag: %V", + (composable + ? "call-with-composable-continuation" + : "call-with-current-continuation"), + prompt_tag); return NULL; } @@ -7441,7 +7116,7 @@ prim = scheme_make_closed_prim(f, data); a[0] = prim; a[1] = scheme_default_prompt_tag; - a[2] = scheme_make_prim(propagate_abort); + a[2] = propagate_abort_prim; if (multi) { if (top_level) @@ -7608,10 +7283,10 @@ prompt = original_default_prompt; if (!prompt) { - scheme_contract_error("abort-current-continuation", - "continuation includes no prompt with the given tag", - "tag", 1, prompt_tag, - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "abort-current-continuation: continuation includes no prompt with the given tag\n" + " tag: %V", + prompt_tag); return NULL; } @@ -7846,6 +7521,7 @@ p = NULL; econt = NULL; cont = NULL; + top_cont = NULL; break; } @@ -7887,6 +7563,7 @@ p = NULL; econt = NULL; cont = NULL; + top_cont = NULL; break; } else { @@ -7992,10 +7669,10 @@ } if (!who) return NULL; - scheme_contract_error(who, - "no corresponding prompt in the continuation", - "tag", 1, prompt_tag, - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "%s: no corresponding prompt in the continuation\n" + " tag: %V", + who, prompt_tag); } } @@ -8076,11 +7753,12 @@ } if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) - if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) - scheme_contract_error("current-continuation-marks", - "no corresponding prompt in the continuation", - "prompt tag", 1, prompt_tag, - NULL); + if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "current-continuation-marks: no corresponding prompt in the continuation\n" + " prompt tag: %V", + prompt_tag); + } } return scheme_current_continuation_marks(argc ? prompt_tag : NULL); @@ -8114,10 +7792,9 @@ return make_empty_marks(); } else if (SCHEME_ECONTP(argv[0])) { if (!scheme_escape_continuation_ok(argv[0])) { - scheme_contract_error("continuation-marks", - "escape continuation not in the current thread's continuation", - "escape continuation", 1, argv[0], - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "continuation-marks: escape continuation not in the current thread's continuation\n" + " escape continuation: %V", argv[0]); return NULL; } else { Scheme_Meta_Continuation *mc; @@ -8395,23 +8072,14 @@ name = scheme_make_pair(scheme_false, loc); else name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc); - } else if (SCHEME_PAIRP(name) && SCHEME_RMPP(SCHEME_CAR(name))) { - /* a resolved module path means that we're running a module body */ + } else if (SCHEME_PAIRP(name) && SAME_OBJ(SCHEME_CDR(name), scheme_true)) { + /* a pair with #t we're running a module body */ const char *what; - if (SCHEME_FALSEP(SCHEME_CDR(name))) - what = "[traversing imports]"; - else if (SCHEME_VOIDP(SCHEME_CDR(name))) - what = "[running expand-time body]"; - else - what = "[running body]"; + what = "[running body]"; name = SCHEME_CAR(name); - name = SCHEME_PTR_VAL(name); - if (SCHEME_PAIRP(name)) - name = scheme_make_pair(scheme_intern_symbol("submod"), name); - loc = scheme_make_location(name, scheme_false, - scheme_false, scheme_false, scheme_false); + loc = scheme_make_location(name, scheme_false, scheme_false, scheme_false, scheme_false); name = scheme_intern_symbol(what); name = scheme_make_pair(name, loc); @@ -8435,6 +8103,16 @@ return scheme_get_stack_trace(argv[0]); } +XFORM_NONGCING static Scheme_Object *default_mark_value(Scheme_Object *key) +{ + if (key == scheme_parameterization_key) + return (Scheme_Object *)scheme_current_thread->init_config; + else if (key == scheme_break_enabled_key) + return scheme_current_thread->init_break_cell; + + return NULL; +} + static Scheme_Object * scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key_arg, Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta, @@ -8533,7 +8211,7 @@ val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val); pos = startpos - findpos; - if (pos > 16) { + if (pos > MARK_CACHE_THRESHOLD) { pos >>= 1; findpos = findpos + pos; if (mc) { @@ -8622,68 +8300,95 @@ } } while (mc); } - - if (key == scheme_parameterization_key) { - return (Scheme_Object *)scheme_current_thread->init_config; - } - if (key == scheme_break_enabled_key) { - return scheme_current_thread->init_break_cell; - } - - return NULL; + + return default_mark_value(key); } XFORM_NONGCING static Scheme_Object * -extract_one_cc_mark_fast(Scheme_Object *key) +extract_one_cc_mark_fast(Scheme_Object *key, int *_conclusive) /* A non-GCing fast path for scheme_extract_one_cc_mark_with_meta() where there are no complications. */ { - intptr_t findpos, bottom, startpos, minbottom; + intptr_t findpos, bottom, startpos; intptr_t pos; Scheme_Object *val = NULL; Scheme_Object *cache; Scheme_Cont_Mark *seg; Scheme_Thread *p = scheme_current_thread; - - startpos = (intptr_t)MZ_CONT_MARK_STACK; + Scheme_Meta_Continuation *mc = NULL; - bottom = p->cont_mark_stack_bottom; - minbottom = startpos - 32; - if (bottom < minbottom) - bottom = minbottom; + do { + if (mc) { + startpos = mc->cont_mark_total; + bottom = 0; + } else { + startpos = (intptr_t)MZ_CONT_MARK_STACK; + bottom = p->cont_mark_stack_bottom; + } - findpos = startpos; + findpos = startpos; - /* Search mark stack, checking caches along the way: */ - while (findpos-- > bottom) { - seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE]; - pos = findpos & SCHEME_MARK_SEGMENT_MASK; + /* Search mark stack, checking caches along the way: */ + while (findpos-- > bottom) { + if ((startpos - findpos) > MARK_CACHE_THRESHOLD) { + /* Use full search to trigger caching */ + return NULL; + } - if (SAME_OBJ(seg[pos].key, key)) - return seg[pos].val; - else { - cache = seg[pos].cache; - if (cache && SCHEME_HASHTP(cache)) - cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, scheme_false); - if (cache && SCHEME_VECTORP(cache)) { - /* If slot 1 has a key, this cache has just one key--value - pair. Otherwise, slot 2 is a hash table. */ - if (SCHEME_VEC_ELS(cache)[1]) { - if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) - return SCHEME_VEC_ELS(cache)[2]; - } else { - Scheme_Hash_Table *ht; - ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2]; - val = scheme_eq_hash_get(ht, key); - if (val) { - return SCHEME_CAR(val); + if (mc) { + seg = mc->cont_mark_stack_copied; + pos = findpos; + } else { + seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE]; + pos = findpos & SCHEME_MARK_SEGMENT_MASK; + } + + if (SAME_OBJ(seg[pos].key, key)) { + *_conclusive = 1; + return seg[pos].val; + } else { + cache = seg[pos].cache; + if (cache && SCHEME_HASHTP(cache)) + cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, scheme_false); + if (cache && SCHEME_VECTORP(cache)) { + /* If slot 1 has a key, this cache has just one key--value + pair. Otherwise, slot 2 is a hash table. */ + if (SCHEME_VEC_ELS(cache)[1]) { + if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) { + val = SCHEME_VEC_ELS(cache)[2]; + if (val) { + *_conclusive = 1; + return val; + } else + break; /* cached absence of a value */ + } + } else { + Scheme_Hash_Table *ht; + ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2]; + val = scheme_eq_hash_get(ht, key); + if (val) { + val = SCHEME_CAR(val); + if (val) { + *_conclusive = 1; + return val; + } else + break; /* cached absence of a value */ + } } } } } - } - - return NULL; + + if (mc) + mc = mc->next; + else + mc = p->meta_continuation; + } while (mc); + + /* Since we searched the metacontinuation chain, + the absence of a value is conclusive */ + *_conclusive = 1; + return default_mark_value(key); } static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key, @@ -8755,8 +8460,9 @@ Scheme_Object *v; if (!mark_set) { - v = extract_one_cc_mark_fast(key); - if (v) return v; + int conclusive = 0; + v = extract_one_cc_mark_fast(key, &conclusive); + if (conclusive) return v; } return scheme_extract_one_cc_mark_with_meta(mark_set, key, NULL, NULL, NULL); @@ -8778,10 +8484,10 @@ if (SCHEME_TRUEP(argv[0]) && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) scheme_wrong_contract("continuation-mark-set-first", "(or/c continuation-mark-set? #f)", 0, argc, argv); - + if ((argv[1] == scheme_parameterization_key) || (argv[1] == scheme_break_enabled_key)) { - /* Minor hack: these keys are used in "startup.rkt" to access + /* Minor hack: these keys are used in the startup linklet to access parameterizations, and we want that access to go through prompts. If they keys somehow leaked, it's ok, because that doesn't expose anything that isn't already exposed by functions @@ -8803,11 +8509,12 @@ if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) { if (SCHEME_FALSEP(argv[0])) { - if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) - scheme_contract_error("continuation-mark-set-first", - "no corresponding prompt in the current continuation", - "tag", 1, prompt_tag, - NULL); + if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "continuation-mark-set-first: no corresponding prompt in the current continuation\n" + " tag: %V", + prompt_tag); + } } } } @@ -8854,10 +8561,10 @@ if (argc > 1) { if (SCHEME_ECONTP(argv[1])) { if (!scheme_escape_continuation_ok(argv[1])) { - scheme_contract_error("continuation-prompt-available?", - "escape continuation not in the current thread's continuation", - "escape continuation", 1, argv[1], - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "continuation-prompt-available?: escape continuation not in the current thread's continuation\n" + " escape continuation: %V", + argv[1]); return NULL; } else { Scheme_Meta_Continuation *mc; @@ -9499,12 +9206,13 @@ prompt = original_default_prompt; } if (!prompt) { - scheme_contract_error("abort-current-continuation", - "abort in progress, but current continuation includes" - " no prompt with the given tag" - " after a `dynamic-wind' post-thunk return", - "tag", 1, tag, - NULL); + scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION, + "abort-current-continuation:" + " abort in progress, but current continuation includes" + " no prompt with the given tag" + " after a `dynamic-wind' post-thunk return\n" + " tag: %V", + tag); return NULL; } p->cjs.jumping_to_continuation = (Scheme_Object *)prompt; @@ -10040,8 +9748,9 @@ argv); config = scheme_current_config(); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false); + // FIXME + // config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); + // config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false); scheme_push_continuation_frame(&cframe); scheme_install_config(config); diff -Nru racket-6.12+ppa1/src/racket/src/future.c racket-7.0+ppa1/src/racket/src/future.c --- racket-6.12+ppa1/src/racket/src/future.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/future.c 2018-07-27 22:12:02.000000000 +0000 @@ -267,6 +267,7 @@ { } +/* Set differently below when futures are supported */ #define SCHEME_FUTURE_PRIM_IS_NARY_INLINED SCHEME_PRIM_SOMETIMES_INLINED #define SCHEME_FUTURE_PRIM_IS_UNARY_INLINED SCHEME_PRIM_SOMETIMES_INLINED @@ -456,6 +457,7 @@ Scheme_Current_LWC *lwc; } future_thread_params_t; +/* Set differently above when futures are not supported */ #define SCHEME_FUTURE_PRIM_IS_NARY_INLINED SCHEME_PRIM_IS_NARY_INLINED #define SCHEME_FUTURE_PRIM_IS_UNARY_INLINED SCHEME_PRIM_IS_UNARY_INLINED @@ -466,17 +468,12 @@ /**********************************************************************/ /* Invoked by the runtime on startup to make primitives known */ -void scheme_init_futures(Scheme_Env *newenv) +void scheme_init_futures(Scheme_Startup_Env *newenv) { Scheme_Object *p; - /* Order and properties here need to be in sync with the order and - properties in the other scheme_init_futures() */ - - scheme_add_global_constant( - "future?", - scheme_make_folding_prim( - future_p, + scheme_addto_prim_instance("future?", + scheme_make_folding_prim(future_p, "future?", 1, 1, @@ -485,12 +482,10 @@ p = scheme_make_prim_w_arity(scheme_future, "future", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("future", p, newenv); + scheme_addto_prim_instance("future", p, newenv); - scheme_add_global_constant( - "processor-count", - scheme_make_prim_w_arity( - processor_count, + scheme_addto_prim_instance("processor-count", + scheme_make_prim_w_arity(processor_count, "processor-count", 0, 0), @@ -498,72 +493,62 @@ p = scheme_make_prim_w_arity(touch, "touch", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("touch", p, newenv); + scheme_addto_prim_instance("touch", p, newenv); - p = scheme_make_immed_prim( - scheme_current_future, - "current-future", - 0, - 0); + p = scheme_make_immed_prim(scheme_current_future, + "current-future", + 0, + 0); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("current-future", p, newenv); + scheme_addto_prim_instance("current-future", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_p, - "fsemaphore?", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_p, + "fsemaphore?", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore?", p, newenv); + scheme_addto_prim_instance("fsemaphore?", p, newenv); - p = scheme_make_immed_prim( - make_fsemaphore, - "make-fsemaphore", - 1, - 1); + p = scheme_make_immed_prim(make_fsemaphore, + "make-fsemaphore", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("make-fsemaphore", p, newenv); + scheme_addto_prim_instance("make-fsemaphore", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_count, - "fsemaphore-count", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_count, + "fsemaphore-count", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-count", p, newenv); + scheme_addto_prim_instance("fsemaphore-count", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_wait, - "fsemaphore-wait", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_wait, + "fsemaphore-wait", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-wait", p, newenv); + scheme_addto_prim_instance("fsemaphore-wait", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_post, - "fsemaphore-post", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_post, + "fsemaphore-post", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-post", p, newenv); + scheme_addto_prim_instance("fsemaphore-post", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_try_wait, - "fsemaphore-try-wait?", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_try_wait, + "fsemaphore-try-wait?", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-try-wait?", p, newenv); - - GLOBAL_PRIM_W_ARITY("would-be-future", would_be_future, 1, 1, newenv); - GLOBAL_PRIM_W_ARITY("futures-enabled?", futures_enabled, 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("reset-future-logs-for-tracing!", reset_future_logs_for_tracking, 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("mark-future-trace-end!", mark_future_trace_end, 0, 0, newenv); + scheme_addto_prim_instance("fsemaphore-try-wait?", p, newenv); - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); + ADD_PRIM_W_ARITY("would-be-future", would_be_future, 1, 1, newenv); + ADD_PRIM_W_ARITY("futures-enabled?", futures_enabled, 0, 0, newenv); + ADD_PRIM_W_ARITY("reset-future-logs-for-tracing!", reset_future_logs_for_tracking, 0, 0, newenv); + ADD_PRIM_W_ARITY("mark-future-trace-end!", mark_future_trace_end, 0, 0, newenv); } #ifdef MZ_USE_FUTURES @@ -573,7 +558,7 @@ init_cpucount(); REGISTER_SO(bad_multi_result_proc); - bad_multi_result_proc = scheme_make_prim(bad_multi_result); + bad_multi_result_proc = scheme_make_prim_w_arity(bad_multi_result, "bad-multi-result", 0, -1); } void scheme_init_futures_per_place() diff -Nru racket-6.12+ppa1/src/racket/src/hash.c racket-7.0+ppa1/src/racket/src/hash.c --- racket-6.12+ppa1/src/racket/src/hash.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/hash.c 2018-07-27 22:12:02.000000000 +0000 @@ -1572,7 +1572,6 @@ } case scheme_vector_type: case scheme_fxvector_type: - case scheme_wrap_chunk_type: { int len = SCHEME_VEC_SIZE(o), i, val; Scheme_Object *elem; @@ -1850,33 +1849,6 @@ o = (Scheme_Object *)((Scheme_Place_Bi_Channel *)o)->link->sendch; } break; - case scheme_resolved_module_path_type: - /* Needed for interning */ - { - k += 7; - o = SCHEME_PTR_VAL(o); - } - break; - case scheme_module_index_type: - { - Scheme_Modidx *midx = (Scheme_Modidx *)o; -# include "mzhashchk.inc" - hi->depth += 2; - k++; - k = (k << 3) + k; - k += equal_hash_key(midx->path, 0, hi); - o = midx->base; - } - break; - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; - hi->depth += 2; - k = (k << 3) + k; - k += equal_hash_key((Scheme_Object *)mt->simple_scopes, 0, hi); - o = mt->multi_scopes; - } - break; default: { Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t]; @@ -2075,7 +2047,6 @@ } case scheme_vector_type: case scheme_fxvector_type: - case scheme_wrap_chunk_type: { int len = SCHEME_VEC_SIZE(o), i; uintptr_t k = 0; @@ -2352,30 +2323,6 @@ return k; } - case scheme_resolved_module_path_type: - /* Needed for interning */ - o = SCHEME_PTR_VAL(o); - goto top; - case scheme_module_index_type: - { - Scheme_Modidx *midx = (Scheme_Modidx *)o; - uintptr_t v1, v2; -# include "mzhashchk.inc" - hi->depth += 2; - v1 = equal_hash_key2(midx->path, hi); - v2 = equal_hash_key2(midx->base, hi); - return v1 + v2; - } - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; - uintptr_t k; - hi->depth += 2; - k = equal_hash_key2((Scheme_Object *)mt->simple_scopes, hi); - k += equal_hash_key2(mt->multi_scopes, hi); - return k; - } - break; case scheme_place_bi_channel_type: /* a bi channel has sendch and recvch, but sends are the same iff recvs are the same: */ @@ -2812,8 +2759,133 @@ # define HAMT_TRAVERSE_NEXT(i) ((i)+1) #endif +XFORM_NONGCING static void hamt_subtree_at_index(Scheme_Hash_Tree *ht, mzlonglong pos, + Scheme_Hash_Tree **_subtree, int *_i, int *_popcount) +{ + int popcount, i; + Scheme_Hash_Tree *sub; + + while (1) { + popcount = hamt_popcount(ht->bitmap); + i = HAMT_TRAVERSE_INIT(popcount); + while (1) { + if (HASHTR_SUBTREEP(ht->els[i]) + || HASHTR_COLLISIONP(ht->els[i])) { + sub = (Scheme_Hash_Tree *)ht->els[i]; + if (pos < sub->count) { + ht = sub; + break; /* to outer loop */ + } else + pos -= sub->count; + } else { + if (!pos) { + *_subtree = ht; + *_i = i; + if (_popcount) *_popcount = popcount; + return; + } + --pos; + } + i = HAMT_TRAVERSE_NEXT(i); + } + } +} + +/* We have two different implementations of Scheme_Hash_Tree traversal + as exposed by `unsafe-immutable-hash-next`, etc.: + + * Consecutive integers from 0 as the index values (the same as + `scheme_hash_tree_next`), or + + * Subtree lists (for the spine of a subtree up to the root) plus + offset into a subtree. + + The second one is more direct, but requires some allocation. To + avoid allocation for small trees, it uses an integer encoding of a + path. + + The first implementation is better for small trees, and the second + is better for very large trees, but there's not a big difference. + Small trees dominate for macro expansion, which is a big use of + hash trees, so that gives the first implementation the edge. + + Microbenchmark: + + (let loop ([size 2]) + (define ht (for/hasheq ([i (in-range size)]) + (values i i))) + (define c (quotient 10000000 size)) + (printf "~s: " size) + (time + (for ([j (in-range c)]) + (for/fold ([v #f]) ([k (in-immutable-hash-keys ht)]) + k))) + (unless (= size (expt 2 20)) + (loop (* size 2)))) + + */ + +#if 1 +/* ------ Implementation 1 of hash-tree traversal ------ */ + +Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht) +{ + ht = resolve_placeholder(ht); + + if (!ht->count) + return scheme_false; + else + return scheme_make_integer(0); +} + +XFORM_NONGCING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_Object *args, + Scheme_Hash_Tree **_subtree, int *_i) +{ + Scheme_Hash_Tree *ht; + + if (SCHEME_NP_CHAPERONEP(obj)) + obj = SCHEME_CHAPERONE_VAL(obj); + ht = (Scheme_Hash_Tree *)obj; + ht = resolve_placeholder(ht); + + hamt_subtree_at_index(ht, SCHEME_INT_VAL(args), _subtree, _i, NULL); +} + +XFORM_NONGCING Scheme_Object *scheme_unsafe_hash_tree_access(Scheme_Hash_Tree *subtree, int i) +{ + return _mzHAMT_VAL(subtree, i, hamt_popcount(subtree->bitmap)); +} + +Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Hash_Tree *ht, Scheme_Object *args) +{ + intptr_t i = SCHEME_INT_VAL(args) + 1; + ht = resolve_placeholder(ht); + if (i < ht->count) + return scheme_make_integer(i); + else + return scheme_false; +} + +#else +/* ------ Implementation 2 of hash-tree traversal ------ */ + #define mzHAMT_MAX_INDEX_LEVEL 4 /* For the compressed form of the index */ +Scheme_Object *make_index_frame(Scheme_Hash_Tree *ht, intptr_t i, Scheme_Object *rest) +{ + Scheme_Object *vec; + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)ht; + SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(i); + SCHEME_VEC_ELS(vec)[2] = rest; + return vec; +} + +#define INDEX_FRAMEP(o) SCHEME_VECTORP(o) +#define INDEX_FRAME_SUBTREE(o) ((Scheme_Hash_Tree *)(SCHEME_VEC_ELS(o)[0])) +#define INDEX_FRAME_INDEX(o) (SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[1])) +#define INDEX_FRAME_REST(o) (SCHEME_VEC_ELS(o)[2]) + /* instead of returning a pos, these unsafe iteration ops */ /* return a view into the tree consisting of a: */ /* - subtree */ @@ -2845,9 +2917,7 @@ || HASHTR_COLLISIONP(ht->els[i]))) { /* go down tree but save return point */ if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); } else if (level < mzHAMT_MAX_INDEX_LEVEL) { ht_n[level] = ht; i_n[level] = i; @@ -2855,13 +2925,9 @@ } else { stack = scheme_null; for (j = 0; j < mzHAMT_MAX_INDEX_LEVEL; j++) { - stack = scheme_make_pair((Scheme_Object *)ht_n[j], - scheme_make_pair(scheme_make_integer(i_n[j]), - stack)); - } - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht_n[j], i_n[j], stack); + } + stack = make_index_frame(ht, i, stack); level = -1; } ht = (Scheme_Hash_Tree *)ht->els[i]; @@ -2869,9 +2935,7 @@ } if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); return stack; } else { i = (1<els[i]) || HASHTR_COLLISIONP(ht->els[i]))) { if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); return stack; } else { i = (1<els[i]; @@ -3002,38 +3058,21 @@ } } +#endif + XFORM_NONGCING static void hamt_at_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val, uintptr_t *_code) { int popcount, i; Scheme_Hash_Tree *sub; - while (1) { - popcount = hamt_popcount(ht->bitmap); - i = HAMT_TRAVERSE_INIT(popcount); - while (1) { - if (HASHTR_SUBTREEP(ht->els[i]) - || HASHTR_COLLISIONP(ht->els[i])) { - sub = (Scheme_Hash_Tree *)ht->els[i]; - if (pos < sub->count) { - ht = sub; - break; /* to outer loop */ - } else - pos -= sub->count; - } else { - if (!pos) { - *_key = ht->els[i]; - if (_val) - *_val = _mzHAMT_VAL(ht, i, popcount); - if (_code) - *_code = _mzHAMT_CODE(ht, i, popcount); - return; - } - --pos; - } - i = HAMT_TRAVERSE_NEXT(i); - } - } + hamt_subtree_at_index(ht, pos, &sub, &i, &popcount); + + *_key = sub->els[i]; + if (_val) + *_val = _mzHAMT_VAL(sub, i, popcount); + if (_code) + *_code = _mzHAMT_CODE(sub, i, popcount); } int scheme_hash_tree_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) @@ -3318,6 +3357,9 @@ } } else { /* update collision */ + /* (we're not looking for a shortcut here if the current value + matched the new value, but we could do that if it seems + worthwhile; hopefully, collisions are relatively rare) */ in_tree = hamt_set(in_tree, code, 0, key, val, 0); inc = 0; } @@ -3357,6 +3399,9 @@ return tree; } else return tree; + } else if (SAME_OBJ(val, mzHAMT_VAL(in_tree, pos))) { + /* Shortcut: setting to the current value */ + return tree; } else return hamt_set(tree, h, 0, key, val, 0); } else { diff -Nru racket-6.12+ppa1/src/racket/src/help-startup.rkt racket-7.0+ppa1/src/racket/src/help-startup.rkt --- racket-6.12+ppa1/src/racket/src/help-startup.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/help-startup.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +(module help-startup '#%kernel + (#%provide get-linklet + get-version-comparisons) + + (define-values (get-lines) + (lambda (in) + (let-values ([(l) (read-line in 'any)]) + (if (eof-object? l) + null + (cons l (get-lines in)))))) + + (define-values (get-linklet) + (lambda (src) + (read + (open-input-string + (apply + string-append + (map (lambda (l) + (regexp-replace* #rx"\\\\(.)" + (substring l 1 (sub1 (string-length l))) + "\\1")) + (reverse (cdr (reverse (cddr (call-with-input-file src get-lines))))))))))) + + (define-values (get-version-comparisons) + (lambda (vers) + (call-with-input-file + vers + (lambda (in) + (letrec-values ([(get-version-comparisons) + (lambda () + (let-values ([(line) (read-line in 'any)]) + (if (eof-object? line) + "" + (let-values ([(m) (regexp-match #rx"^#define (MZSCHEME_VERSION_[A-Z]) ([0-9]+)" + line)]) + (if m + (string-append " || (" (cadr m) " != " (caddr m) ")" + (get-version-comparisons)) + (get-version-comparisons))))))]) + (get-version-comparisons))))))) diff -Nru racket-6.12+ppa1/src/racket/src/jitarith.c racket-7.0+ppa1/src/racket/src/jitarith.c --- racket-6.12+ppa1/src/racket/src/jitarith.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitarith.c 2018-07-27 22:12:02.000000000 +0000 @@ -201,6 +201,7 @@ #endif return unsafely; case scheme_toplevel_type: + case scheme_static_toplevel_type: /* Can generalize to allow any toplevel if scheme_generate_pop_unboxed() is fixed */ if ((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) < SCHEME_TOPLEVEL_READY) return 0; diff -Nru racket-6.12+ppa1/src/racket/src/jit.c racket-7.0+ppa1/src/racket/src/jit.c --- racket-6.12+ppa1/src/racket/src/jit.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jit.c 2018-07-27 22:12:02.000000000 +0000 @@ -53,6 +53,11 @@ o = scheme_alloc_object(); o->type = scheme_global_ref_type; SCHEME_PTR1_VAL(o) = var; + if (!SCHEME_FALSEP(dummy)) { + Scheme_Instance *home; + home = scheme_get_bucket_home((Scheme_Bucket *)dummy); + dummy = (Scheme_Object *)home; + } SCHEME_PTR2_VAL(o) = dummy; return o; @@ -414,7 +419,7 @@ return is_short(branch->fbranch, fuel); } case scheme_toplevel_type: - case scheme_quote_syntax_type: + case scheme_static_toplevel_type: case scheme_local_type: case scheme_local_unbox_type: case scheme_lambda_type: @@ -447,29 +452,6 @@ return globs->a[pos]; } -static Scheme_Object *extract_syntax(Scheme_Quote_Syntax *qs, Scheme_Native_Closure *nc) -{ - /* GLOBAL ASSUMPTION: we assume that globals are the last thing - in the closure; grep for "GLOBAL ASSUMPTION" in fun.c. */ - Scheme_Prefix *globs; - int i, pos; - Scheme_Object *v; - - globs = (Scheme_Prefix *)nc->vals[nc->code->u2.orig_code->closure_size - 1]; - - i = qs->position; - pos = qs->midpoint; - - v = globs->a[i+pos+1]; - if (!v) { - v = globs->a[pos]; - v = scheme_delayed_shift((Scheme_Object **)v, i); - globs->a[i+pos+1] = v; - } - - return v; -} - static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant) { if (PAST_LIMIT()) return NULL; @@ -520,7 +502,8 @@ } } - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type)) { + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { c = scheme_extract_global(obj, jitter->nc, 0); if (c) { c = ((Scheme_Bucket *)c)->val; @@ -528,6 +511,14 @@ return c; } } + + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_static_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { + c = SCHEME_STATIC_TOPLEVEL_PREFIX(obj)->a[SCHEME_TOPLEVEL_POS(obj)]; + c = ((Scheme_Bucket *)c)->val; + if (c) + return c; + } } return obj; @@ -562,6 +553,10 @@ if ((((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_PRED) return 0; + /* Closures need a 3rd argument, so don't claim NONCM for them, either. + (Currently, all of those are predicates, anyway.) */ + if (((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_IS_CLOSURE) + return 0; return 1; } } @@ -581,6 +576,17 @@ } } + if (SAME_TYPE(SCHEME_TYPE(a), scheme_static_toplevel_type) + && ((SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED)) { + Scheme_Object *p; + p = SCHEME_STATIC_TOPLEVEL_PREFIX(a)->a[SCHEME_TOPLEVEL_POS(a)]; + p = ((Scheme_Bucket *)p)->val; + if (p && SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) { + if (scheme_native_closure_preserves_marks(p)) + return 1; + } + } + if (SAME_TYPE(SCHEME_TYPE(a), scheme_local_type)) { int pos = SCHEME_LOCAL_POS(a) - stack_start; if (pos >= 0) { @@ -591,6 +597,11 @@ } } + if (SAME_TYPE(SCHEME_TYPE(a), scheme_native_closure_type)) { + if (scheme_native_closure_preserves_marks(a)) + return 1; + } + if (depth && SAME_TYPE(SCHEME_TYPE(a), scheme_closure_type)) { Scheme_Lambda *lam; @@ -662,7 +673,7 @@ { Scheme_Object *rator; rator = scheme_specialize_to_constant(((Scheme_App_Rec *)obj)->args[0], jitter, - stack_start + ((Scheme_App_Rec *)obj)->num_args); + stack_start + ((Scheme_App_Rec *)obj)->num_args); if (scheme_inlined_nary_prim(rator, obj, jitter) && !SAME_OBJ(rator, scheme_values_proc)) return 1; @@ -697,7 +708,7 @@ break; case scheme_toplevel_type: - case scheme_quote_syntax_type: + case scheme_static_toplevel_type: case scheme_local_type: case scheme_local_unbox_type: case scheme_lambda_type: @@ -758,6 +769,12 @@ break; case scheme_toplevel_type: + if ((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST) + return 1; + break; + case scheme_static_toplevel_type: + if ((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + return 1; break; case scheme_lambda_type: break; @@ -768,7 +785,6 @@ return 1; break; - case scheme_quote_syntax_type: case scheme_local_unbox_type: return 1; break; @@ -805,6 +821,15 @@ } } } + } else if (t == scheme_static_toplevel_type) { + if ((SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { + Scheme_Object *p; + + p = SCHEME_STATIC_TOPLEVEL_PREFIX(v)->a[SCHEME_TOPLEVEL_POS(v)]; + p = ((Scheme_Bucket *)p)->val; + if (p) + return SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type); + } } return 0; @@ -847,7 +872,8 @@ { Scheme_Type t = SCHEME_TYPE(obj); - if (SAME_TYPE(t, scheme_toplevel_type)) { + if (SAME_TYPE(t, scheme_toplevel_type) + || SAME_TYPE(t, scheme_static_toplevel_type)) { return (((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) ? 1 : 0); @@ -859,7 +885,8 @@ { Scheme_Type t = SCHEME_TYPE(obj); - if (SAME_TYPE(t, scheme_toplevel_type)) { + if (SAME_TYPE(t, scheme_toplevel_type) + || SAME_TYPE(t, scheme_static_toplevel_type)) { return (((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) ? 1 : 0); @@ -879,7 +906,7 @@ else if (SAME_TYPE(t, scheme_local_type)) return ((SCHEME_LOCAL_POS(wrt) != pos) || !(SCHEME_GET_LOCAL_FLAGS(wrt) == SCHEME_LOCAL_CLEAR_ON_READ)); - else if (SAME_TYPE(t, scheme_toplevel_type)) + else if (SAME_TYPE(t, scheme_toplevel_type) || SAME_TYPE(t, scheme_static_toplevel_type)) return 1; else if (t == scheme_application2_type) { Scheme_App2_Rec *app = (Scheme_App2_Rec *)wrt; @@ -2045,6 +2072,7 @@ && !jitter->unbox && !IS_SKIP_TYPE(SCHEME_TYPE(obj)) && !SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type) + && !SAME_TYPE(SCHEME_TYPE(obj), scheme_static_toplevel_type) && !SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) && !SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type) && (SCHEME_TYPE(obj) < _scheme_values_types_)) { @@ -2117,6 +2145,43 @@ if (for_branch) finish_branch(jitter, target, for_branch); return 1; } + case scheme_static_toplevel_type: + { + int can_fail; + /* Other parts of the JIT rely on this code not modifying R1 */ + can_fail = ((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) < SCHEME_TOPLEVEL_READY); + if (!can_fail && result_ignored) { + /* skip */ + } else { + Scheme_Object *b; + START_JIT_DATA(); + LOG_IT(("static-top-level\n")); + if ((SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { + /* load constant */ + b = SCHEME_STATIC_TOPLEVEL_PREFIX(obj)->a[SCHEME_TOPLEVEL_POS(obj)]; + b = ((Scheme_Bucket *)b)->val; + scheme_mz_load_retained(jitter, target, b); + } else { + mz_rs_sync_fail_branch(); + /* Load bucket: */ + b = SCHEME_STATIC_TOPLEVEL_PREFIX(obj)->a[SCHEME_TOPLEVEL_POS(obj)]; + scheme_mz_load_retained(jitter, JIT_R2, b); + /* Extract bucket value */ + jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val)); + CHECK_LIMIT(); + if (can_fail) { + /* Is it NULL? */ + scheme_generate_pop_unboxed(jitter); + CHECK_LIMIT(); + (void)jit_beqi_p(sjc.unbound_global_code, target, 0); + } + if (jitter->unbox) scheme_generate_unboxing(jitter, target); + END_JIT_DATA(0); + } + if (for_branch) finish_branch(jitter, target, for_branch); + } + return 1; + } case scheme_local_type: { /* Other parts of the JIT rely on this code modifying only the target register, @@ -2359,13 +2424,19 @@ scheme_generate_non_tail(p, jitter, 0, 1, 0); CHECK_LIMIT(); mz_rs_sync(); - - /* Load prefix: */ - pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(v)); - mz_rs_ldxi(JIT_R2, pos); - /* Extract bucket from prefix: */ - pos = SCHEME_TOPLEVEL_POS(v); - jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + + if (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)) { + /* Load prefix: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(v)); + mz_rs_ldxi(JIT_R2, pos); + /* Extract bucket from prefix: */ + pos = SCHEME_TOPLEVEL_POS(v); + jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + } else { + /* Load bucket */ + v = SCHEME_STATIC_TOPLEVEL_PREFIX(v)->a[SCHEME_TOPLEVEL_POS(v)]; + scheme_mz_load_retained(jitter, JIT_R2, v); + } CHECK_LIMIT(); /* R0 has values, R2 has bucket */ @@ -2570,7 +2641,9 @@ (void)jit_calli(code); /* non-tail code pops args off runstack for us */ jitter->need_set_rs = 1; + __START_SHORT_JUMPS__(1); mz_patch_ucbranch(ref5); + __END_SHORT_JUMPS__(1); if (target != JIT_R0) jit_movr_p(target, JIT_R0); } @@ -2666,7 +2739,7 @@ finish_branch_with_true(jitter, for_branch); else { Scheme_Object *dummy; - int pos, is_const; + int pos, is_const, prefix_ready = 0; mz_rs_sync(); @@ -2674,19 +2747,31 @@ dummy = SCHEME_PTR2_VAL(obj); obj = SCHEME_PTR1_VAL(obj); - - /* Load global array: */ - pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); - /* Load bucket: */ - pos = SCHEME_TOPLEVEL_POS(obj); - jit_ldxi_p(JIT_R1, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); - CHECK_LIMIT(); + + if (!SCHEME_SYMBOLP(obj) && !SCHEME_FALSEP(obj) && !SAME_OBJ(obj, scheme_true)) { + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); + jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + /* Load bucket: */ + pos = SCHEME_TOPLEVEL_POS(obj); + jit_ldxi_p(JIT_R1, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + CHECK_LIMIT(); + prefix_ready = 1; + } else if (SCHEME_FALSEP(obj)) { + (void)jit_movi_p(JIT_R1, scheme_false); + } else { + scheme_mz_load_retained(jitter, JIT_R1, obj); + } /* Load dummy bucket: */ if (SCHEME_FALSEP(dummy)) { (void)jit_movi_p(JIT_R2, scheme_false); } else { + if (!prefix_ready) { + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(dummy)); + jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + } pos = SCHEME_TOPLEVEL_POS(dummy); jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); CHECK_LIMIT(); @@ -2712,12 +2797,7 @@ return 1; } break; - case scheme_splice_sequence_type: case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: - case scheme_require_form_type: - case scheme_module_type: case scheme_inline_variant_type: { scheme_signal_error("internal error: cannot JIT a top-level form"); @@ -2990,18 +3070,20 @@ mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); (void)jit_movi_p(JIT_R0, NULL); - jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_V1, JIT_R0); - for (i = 0; i < lv->count; i++) { - jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); - if (ab) { - pos = mz_remap(lv->position + i); - jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); - jit_str_p(JIT_R0, JIT_R1); - } else { - pos = mz_remap(lv->position + i); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R1); + if (lv->count) { + jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_V1, JIT_R0); + for (i = 0; i < lv->count; i++) { + jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); + if (ab) { + pos = mz_remap(lv->position + i); + jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + jit_str_p(JIT_R0, JIT_R1); + } else { + pos = mz_remap(lv->position + i); + jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R1); + } + CHECK_LIMIT(); } - CHECK_LIMIT(); } } } @@ -3293,44 +3375,6 @@ return scheme_generate(wcm->body, jitter, is_tail, wcm_may_replace, multi_ok, orig_target, for_branch, for_values); } - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - int i, c, p; - START_JIT_DATA(); - - LOG_IT(("quote-syntax\n")); - - if (for_branch) - finish_branch_with_true(jitter, for_branch); - else { - i = qs->position; - c = mz_remap(qs->depth); - p = qs->midpoint; - - mz_rs_sync(); - - if (SCHEME_NATIVE_LAMBDA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) { - Scheme_Object *stx; - stx = extract_syntax(qs, jitter->nc); - scheme_mz_load_retained(jitter, target, stx); - CHECK_LIMIT(); - } else { - jit_movi_i(JIT_R0, WORDS_TO_BYTES(c)); - jit_movi_i(JIT_R1, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[i + p + 1])); - jit_movi_i(JIT_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p])); - (void)jit_calli(sjc.quote_syntax_code); - CHECK_LIMIT(); - - if (target != JIT_R0) - jit_movr_p(target, JIT_R0); - } - } - - END_JIT_DATA(10); - - return 1; - } default: /* Other parts of the JIT rely on this code modifying the target register, only */ if (for_branch) { @@ -3854,7 +3898,8 @@ } /* A define-values context? */ - if (lam->context && SAME_TYPE(SCHEME_TYPE(lam->context), scheme_toplevel_type)) { + if (lam->context && (SAME_TYPE(SCHEME_TYPE(lam->context), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(lam->context), scheme_static_toplevel_type))) { jitter->self_toplevel_pos = SCHEME_TOPLEVEL_POS(lam->context); jitter->self_closure_size = lam->closure_size; } diff -Nru racket-6.12+ppa1/src/racket/src/jitcall.c racket-7.0+ppa1/src/racket/src/jitcall.c --- racket-6.12+ppa1/src/racket/src/jitcall.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitcall.c 2018-07-27 22:12:02.000000000 +0000 @@ -1856,26 +1856,33 @@ } } } - } else if (t == scheme_toplevel_type) { - if ((SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { + } else if ((t == scheme_toplevel_type) || (t == scheme_static_toplevel_type)) { + int flags = SCHEME_TOPLEVEL_FLAGS(rator); + + if ((flags & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { /* We can re-order evaluation of the rator. */ reorder_ok = 1; - + if (jitter->nc - && ((SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) { + && ((flags & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) { Scheme_Object *p; - p = scheme_extract_global(rator, jitter->nc, 0); + if (t == scheme_toplevel_type) + p = scheme_extract_global(rator, jitter->nc, 0); + else + p = SCHEME_STATIC_TOPLEVEL_PREFIX(rator)->a[SCHEME_TOPLEVEL_POS(rator)]; if (p) { p = ((Scheme_Bucket *)p)->val; if (can_direct_native(p, num_rands, &extract_case)) { + int pos = SCHEME_TOPLEVEL_POS(rator); + direct_native = 1; - - if ((SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos) + + if ((pos == jitter->self_toplevel_pos) && (num_rands < MAX_SHARED_CALL_RANDS)) { - if (is_tail) + if (is_tail) { direct_self = 1; - else if (jitter->self_nontail_code) + } else if (jitter->self_nontail_code) nontail_self = 1; } } diff -Nru racket-6.12+ppa1/src/racket/src/jitcommon.c racket-7.0+ppa1/src/racket/src/jitcommon.c --- racket-6.12+ppa1/src/racket/src/jitcommon.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitcommon.c 2018-07-27 22:12:02.000000000 +0000 @@ -212,7 +212,6 @@ { int in; GC_CAN_IGNORE jit_insn *ref; - GC_CAN_IGNORE jit_insn *ref2 USED_ONLY_FOR_FUTURES; /* *** check_arity_code *** */ /* Called as a function: */ @@ -277,56 +276,6 @@ (void)mz_finish_lwe(ts_scheme_unbound_global, ref); CHECK_LIMIT(); - /* *** quote_syntax_code *** */ - /* R0 is WORDS_TO_BYTES(c), R1 is &0->a[i+p+1], R2 is &0->a[p] */ - sjc.quote_syntax_code = jit_get_ip(); - mz_prolog(JIT_V1); - __START_SHORT_JUMPS__(1); - /* Load global array: */ - jit_ldxr_p(JIT_V1, JIT_RUNSTACK, JIT_R0); -#ifdef JIT_PRECISE_GC - /* Save global-array index before we lose it: */ - mz_set_local_p(JIT_R0, JIT_LOCAL3); -#endif - /* Load syntax object: */ - jit_ldxr_p(JIT_R0, JIT_V1, JIT_R1); - /* Is it null? */ - ref = jit_bnei_p(jit_forward(), JIT_R0, 0x0); - CHECK_LIMIT(); - /* Syntax object is NULL, so we need to create it. */ - jit_ldxr_p(JIT_R0, JIT_V1, JIT_R2); /* put element at p in R0 */ -#ifndef JIT_PRECISE_GC - /* Save global array: */ - mz_set_local_p(JIT_V1, JIT_LOCAL3); -#endif - /* Move R1 to V1 to save it: */ - jit_movr_p(JIT_V1, JIT_R1); - /* Compute i in JIT_R1: */ - jit_subr_p(JIT_R1, JIT_R1, JIT_R2); - jit_subi_p(JIT_R1, JIT_R1, WORDS_TO_BYTES(1)); - jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE); - CHECK_LIMIT(); - /* Call scheme_delayed_shift: */ - JIT_UPDATE_THREAD_RSPTR(); - CHECK_LIMIT(); - mz_prepare(2); - jit_pusharg_l(JIT_R1); - jit_pusharg_p(JIT_R0); - (void)mz_finish_lwe(ts_scheme_delayed_shift, ref2); - CHECK_LIMIT(); - jit_retval(JIT_R0); - /* Restore global array into JIT_R1, and put computed element at i+p+1: */ -#ifdef JIT_PRECISE_GC - mz_get_local_p(JIT_R1, JIT_LOCAL3); - jit_ldxr_p(JIT_R1, JIT_RUNSTACK, JIT_R1); -#else - mz_get_local_p(JIT_R1, JIT_LOCAL3); -#endif - jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); - mz_patch_branch(ref); - __END_SHORT_JUMPS__(1); - mz_epilog(JIT_V1); - return 1; } @@ -337,7 +286,7 @@ /* *** [bad_][m]{car,cdr,...,{imag,real}_part}_code *** */ /* Argument is in R2 for cXX+r, R0 otherwise */ - for (i = 0; i < 13; i++) { + for (i = 0; i < 14; i++) { void *code; code = jit_get_ip(); @@ -381,6 +330,9 @@ case 12: sjc.bad_cXr_code = code; break; + case 13: + sjc.bad_syntax_e_code = code; + break; } mz_prolog(JIT_R1); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); @@ -441,6 +393,9 @@ case 12: (void)mz_finish_lwe(ts_apply_prim_to_fail, ref); break; + case 13: + (void)mz_finish_lwe(ts_scheme_checked_syntax_e, ref); + break; } CHECK_LIMIT(); @@ -547,6 +502,29 @@ mz_epilog(JIT_R2); scheme_jit_register_sub_func(jitter, sjc.set_box_code, scheme_false); + /* *** unbox_star_fail_code *** */ + /* R0 is argument */ + sjc.unbox_star_fail_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_unbox_star, ref); /* doesn't return */ + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.unbox_star_fail_code, scheme_false); + + /* *** set_box_star_fail_code *** */ + /* R0 is box, R1 is value */ + sjc.set_box_star_fail_code = jit_get_ip(); + mz_prolog(JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(2); + jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_set_box_star, ref); /* doesn't return */ + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.set_box_star_fail_code, scheme_false); + /* *** {box,vector}_cas_fail_code *** */ /* Arguments are on runstack; */ /* call scheme_{box,vector}_cas to raise the exception, @@ -575,6 +553,17 @@ scheme_jit_register_sub_func(jitter, ref2, scheme_false); } + /* *** weak_box_value_code *** */ + /* R0 is argument */ + sjc.weak_box_value_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_weak_box_value, ref); /* doesn't return */ + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.weak_box_value_code, scheme_false); + /* *** bad_vector_length_code *** */ /* R0 is argument */ sjc.bad_vector_length_code = jit_get_ip(); @@ -596,6 +585,17 @@ CHECK_LIMIT(); scheme_jit_register_sub_func(jitter, sjc.bad_vector_length_code, scheme_false); + /* *** bad_vector_star_length_code *** */ + /* R0 is argument */ + sjc.bad_vector_star_length_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_vector_star_length, ref); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.bad_vector_star_length_code, scheme_false); + /* *** bad_flvector_length_code *** */ /* R0 is argument */ sjc.bad_flvector_length_code = jit_get_ip(); @@ -1089,7 +1089,7 @@ jit_str_p(JIT_RUNSTACK, JIT_R0); /* if we have a chaperone-vector*, fall through and use extra arg */ - jit_ldxi_s(JIT_R2, JIT_R2, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R2, &MZ_OPT_HASH_KEY(&((Scheme_Vector *)0x0)->iso)); ref_not_star = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_VEC_CHAPERONE_STAR); /* get outermost from further down the stack */ jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); @@ -1127,7 +1127,7 @@ mz_patch_branch(ref_chaperone_of_check); jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); /* if impersonator, no chaperone-of check needed */ ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, SCHEME_CHAPERONE_IS_IMPERSONATOR); @@ -1173,7 +1173,7 @@ vector, it includes the offset to the start of the elements array). In set mode, value is on run stack. */ for (iii = 0; iii < 2; iii++) { /* ref, set */ - for (ii = -1; ii < 4; ii++) { /* chap-vector, vector, string, bytes, fx */ + for (ii = -1; ii < 5; ii++) { /* chap-vector, vector, string, bytes, fx, vector* */ for (i = 0; i < 2; i++) { /* check index? */ GC_CAN_IGNORE jit_insn *ref, *reffail; GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES; @@ -1186,6 +1186,7 @@ switch (ii) { case -1: case 0: + case 4: ty = scheme_vector_type; offset = (int)(intptr_t)&SCHEME_VEC_ELS(0x0); count_offset = (int)(intptr_t)&SCHEME_VEC_SIZE(0x0); @@ -1204,6 +1205,20 @@ sjc.chap_vector_set_check_index_code = code; } } + } else if (ii == 4) { + if (!iii) { + if (!i) { + sjc.vector_star_ref_code = code; + } else { + sjc.vector_star_ref_check_index_code = code; + } + } else { + if (!i) { + sjc.vector_star_set_code = code; + } else { + sjc.vector_star_set_check_index_code = code; + } + } } else if (!iii) { if (!i) { sjc.vector_ref_code = code; @@ -1336,6 +1351,14 @@ jit_retval(JIT_R0); mz_epilog(JIT_R2); break; + case 4: + if (!iii) { + (void)mz_finish_lwe(ts_scheme_checked_vector_star_ref, refrts); + } else { + (void)mz_finish_lwe(ts_scheme_checked_vector_star_set, refrts); + } + /* doesn't return */ + break; case 1: if (!iii) { (void)mz_finish_lwe(ts_scheme_checked_string_ref, refrts); @@ -1405,7 +1428,7 @@ (void)jit_bler_ul(reffail, JIT_R2, JIT_V1); if (log_elem_size) jit_lshi_ul(JIT_V1, JIT_V1, log_elem_size); - if (!ii || (ii == -1)) /* vector */ + if (!ii || (ii == -1) || (ii == 4)) /* vector */ jit_addi_p(JIT_V1, JIT_V1, offset); } else { /* constant index supplied: */ @@ -1417,6 +1440,7 @@ case -1: /* chap-vector */ case 0: /* vector */ case 3: /* fxvector */ + case 4: /* vector* */ jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); break; case 1: /* string */ @@ -1466,6 +1490,7 @@ (void)jit_bmci_l(reffail, JIT_R2, 0x1); case -1: /* chap-vector, fall-though from fxvector */ case 0: /* vector, fall-though from fxvector */ + case 4: /* vector*, fall-through from fxvector */ jit_stxr_p(JIT_V1, JIT_R0, JIT_R2); break; case 1: /* string */ @@ -1570,7 +1595,7 @@ int result_ignored, int check_proc, int check_arg_fixnum, int type_pos, int field_pos, - int authentic, + int authentic, int type_unpacked, int pop_and_jump, GC_CAN_IGNORE jit_insn *refslow, GC_CAN_IGNORE jit_insn *refslow2, GC_CAN_IGNORE jit_insn *bref_false, GC_CAN_IGNORE jit_insn *bref_true) @@ -1600,44 +1625,47 @@ bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); refretry = jit_get_ip(); jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); if (!authentic) { ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); CHECK_LIMIT(); ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); CHECK_LIMIT(); - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); mz_patch_branch(ref9); jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0)); (void)jit_jmpi(refretry); mz_patch_branch(ref3); + __END_INNER_TINY__(branch_short); } else { + __END_INNER_TINY__(branch_short); bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type); } - __END_INNER_TINY__(1); } else { if (check_arg_fixnum) { (void)jit_bmsi_ul(refslow2, JIT_R1, 0x1); } jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); (void)jit_bnei_i(refslow2, JIT_R2, scheme_proc_struct_type); bref1 = bref2 = NULL; } - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); mz_patch_branch(ref2); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); CHECK_LIMIT(); if (type_pos != 0) { - /* Put argument struct type in R2, target struct type in V1 */ + /* Put argument struct type in R2, target struct type in V1 if not unpacked */ + jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); if (type_pos < 0) { + MZ_ASSERT(!type_unpacked); jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); } CHECK_LIMIT(); @@ -1645,9 +1673,9 @@ if (type_pos < 0) { /* common case: types are the same */ if (kind >= 2) { - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); } else bref8 = NULL; } else @@ -1693,10 +1721,11 @@ CHECK_LIMIT(); /* (Re-)load target type into V1: */ - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (!type_unpacked) + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); if (kind == 1) { - bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); + bref4 = jit_bner_p(jit_forward(), JIT_R2, (type_unpacked ? JIT_R0 : JIT_V1)); /* True branch: */ if (!for_branch) { @@ -1715,9 +1744,9 @@ mz_epilog(JIT_V1); refdone = NULL; } else if (!for_branch) { - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); refdone = jit_jmpi(jit_forward()); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); } else { refdone = NULL; } @@ -1751,18 +1780,19 @@ mz_epilog(JIT_V1); } if (!pop_and_jump) { - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); mz_patch_ucbranch(refdone); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); } } } else { + MZ_ASSERT(!type_unpacked); (void)jit_bner_p(refslow2, JIT_R2, JIT_V1); bref4 = NULL; if (bref8) { - __START_INNER_TINY__(1); + __START_INNER_TINY__(branch_short); mz_patch_branch(bref8); - __END_INNER_TINY__(1); + __END_INNER_TINY__(branch_short); } /* Extract field */ if (field_pos < 0) { @@ -1920,59 +1950,6 @@ scheme_jit_register_sub_func(jitter, code, scheme_false); } - /* *** syntax_e_code *** */ - /* R0 is (potential) syntax object */ - { - GC_CAN_IGNORE jit_insn *ref, *reffail; - GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES; - sjc.syntax_e_code = jit_get_ip(); - __START_TINY_JUMPS__(1); - mz_prolog(JIT_R2); - - ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); - - reffail = jit_get_ip(); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); - CHECK_RUNSTACK_OVERFLOW(); - jit_str_p(JIT_RUNSTACK, JIT_R0); - jit_movi_i(JIT_R1, 1); - JIT_UPDATE_THREAD_RSPTR(); - CHECK_LIMIT(); - jit_prepare(2); - jit_pusharg_p(JIT_RUNSTACK); - jit_pusharg_i(JIT_R1); - (void)mz_finish_lwe(ts_scheme_checked_syntax_e, refrts); - jit_retval(JIT_R0); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); - mz_epilog(JIT_R2); - CHECK_LIMIT(); - - /* It's not a fixnum... */ - mz_patch_branch(ref); - (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R2); - - /* It's a syntax object... needs to propagate? */ - jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.to_propagate); - ref = jit_beqi_p(jit_forward(), JIT_R2, 0x0); - CHECK_LIMIT(); - - /* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */ - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); - (void)jit_bmsi_ul(reffail, JIT_R2, STX_SUBSTX_FLAG); - - /* Maybe needs taint handling; check STX_ARMED_FLAG flag */ - mz_patch_branch(ref); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); - (void)jit_bmsi_ul(reffail, JIT_R2, STX_ARMED_FLAG); - - /* No propagations or dye packs. Extract value. */ - jit_ldxi_p(JIT_R0, JIT_R0, &((Scheme_Stx *)0x0)->val); - - mz_epilog(JIT_R2); - CHECK_LIMIT(); - __END_TINY_JUMPS__(1); - } - /* *** struct_{pred,get,set}[_branch,_multi,_tail]_code *** */ /* R0 is (potential) struct proc, R1 is (potential) struct. */ /* In branch mode, V1 is target address for false branch. */ @@ -2051,7 +2028,7 @@ __END_SHORT_JUMPS__(1); scheme_generate_struct_op(jitter, kind, for_branch, NULL, 1, 0, - 1, 1, -1, -1, 0, + 1, 1, -1, -1, 0, 0, 1, refslow, refslow2, bref5, bref6); CHECK_LIMIT(); @@ -2367,7 +2344,7 @@ } else num_args = 0; - scheme_generate_struct_alloc(jitter, num_args, 1, 1, ii == 2, ii == 1, JIT_R0); + scheme_generate_struct_alloc(jitter, num_args, 1, 1, 1, ii == 2, ii == 1, JIT_R0); CHECK_LIMIT(); @@ -2962,7 +2939,7 @@ scheme_is_list(). */ refloop = jit_get_ip(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref1 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_FLAG_MASK); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -2972,7 +2949,7 @@ ref3 = mz_bnei_t(jit_forward(), JIT_R0, scheme_pair_type, JIT_R2); CHECK_LIMIT(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref4 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_FLAG_MASK); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -2994,7 +2971,7 @@ mz_patch_branch(ref2); mz_patch_branch(ref5); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); #ifdef MZ_USE_FUTURES if (scheme_is_multithreaded(0)) { /* Need an atomic update in case another thread is setting @@ -3002,7 +2979,7 @@ ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_LIST); jit_movr_i(JIT_R0, JIT_R2); jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_LIST); - jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); /* In the unlikely case that the compare-and-swap fails, then it's ok to lose the caching of the list bit: */ jit_lock_cmpxchgr_s(JIT_R1, JIT_R2); /* implicitly uses JIT_R0 */ @@ -3011,7 +2988,7 @@ #endif { jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_LIST); - jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso), JIT_R1, JIT_R2); + jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso), JIT_R1, JIT_R2); } __END_SHORT_JUMPS__(1); @@ -3030,21 +3007,21 @@ mz_patch_branch(ref8); mz_patch_ucbranch(ref6); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); #ifdef MZ_USE_FUTURES /* As above: */ if (scheme_is_multithreaded(0)) { ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_NON_LIST); jit_movr_i(JIT_R0, JIT_R2); jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_NON_LIST); - jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); jit_lock_cmpxchgr_s(JIT_R1, JIT_R2); /* implicitly uses JIT_R0 */ mz_patch_branch(ref5); } else #endif { jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_NON_LIST); - jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso), JIT_R1, JIT_R2); + jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso), JIT_R1, JIT_R2); } CHECK_LIMIT(); @@ -3096,7 +3073,7 @@ ref4 = mz_bnei_t(jit_forward(), JIT_R0, scheme_pair_type, JIT_R2); CHECK_LIMIT(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref5 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_IS_NON_LIST); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -3469,6 +3446,29 @@ CHECK_LIMIT(); } + /* symbol_interned_p_code */ + /* R0 has non-symbol argument */ + { + GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES; + + sjc.symbol_interned_p_code = jit_get_ip(); + + mz_prolog(JIT_R2); + + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + JIT_UPDATE_THREAD_RSPTR(); + jit_str_p(JIT_RUNSTACK, JIT_R0); + CHECK_LIMIT(); + jit_movi_i(JIT_R0, 1); + mz_prepare(2); + jit_pusharg_p(JIT_RUNSTACK); + jit_pusharg_i(JIT_R0); + mz_finish_prim_lwe(ts_scheme_checked_symbol_interned_p, refr); /* doesn't return */ + + scheme_jit_register_sub_func(jitter, sjc.symbol_interned_p_code, scheme_false); + CHECK_LIMIT(); + } + return 1; } @@ -3728,48 +3728,17 @@ scheme_jit_register_sub_func(jitter, sjc.struct_proc_extract_code, scheme_false); } - /* *** module_run_start_code *** */ - /* Pushes a module name onto the stack for stack traces. */ - { - int in; - - sjc.module_run_start_code = jit_get_ip(); - jit_prolog(3); - in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* menv */ - in = jit_arg_p(); - jit_getarg_p(JIT_R1, in); /* env */ - in = jit_arg_p(); - jit_getarg_p(JIT_R2, in); /* &name */ - CHECK_LIMIT(); - - /* Store the name where we can find it */ - mz_push_locals(); - mz_set_local_p(JIT_R2, JIT_LOCAL2); - - jit_prepare(2); - jit_pusharg_p(JIT_R1); - jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_run_finish); - CHECK_LIMIT(); - mz_pop_locals(); - jit_ret(); - CHECK_LIMIT(); - - scheme_jit_register_sub_func(jitter, sjc.module_run_start_code, scheme_eof); - } - - /* *** module_exprun_start_code *** */ + /* *** linklet_run_start_code *** */ /* Pushes a module name onto the stack for stack traces. */ { int in; - sjc.module_exprun_start_code = jit_get_ip(); + sjc.linklet_run_start_code = jit_get_ip(); jit_prolog(3); in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* menv */ + jit_getarg_p(JIT_R0, in); /* linklet */ in = jit_arg_p(); - jit_getarg_i(JIT_R1, in); /* set_ns */ + jit_getarg_p(JIT_R1, in); /* instance */ in = jit_arg_p(); jit_getarg_p(JIT_R2, in); /* &name */ CHECK_LIMIT(); @@ -3778,44 +3747,19 @@ mz_push_locals(); mz_set_local_p(JIT_R2, JIT_LOCAL2); - jit_prepare(2); - jit_pusharg_i(JIT_R1); - jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_exprun_finish); - CHECK_LIMIT(); - mz_pop_locals(); - jit_ret(); - CHECK_LIMIT(); + jit_movi_i(JIT_R2, 1); - scheme_jit_register_sub_func(jitter, sjc.module_exprun_start_code, scheme_eof); - } - - /* *** module_start_start_code *** */ - /* Pushes a module name onto the stack for stack traces. */ - { - int in; - - sjc.module_start_start_code = jit_get_ip(); - jit_prolog(2); - in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* a */ - in = jit_arg_p(); - jit_getarg_p(JIT_R1, in); /* &name */ - CHECK_LIMIT(); - - /* Store the name where we can find it */ - mz_push_locals(); - mz_set_local_p(JIT_R1, JIT_LOCAL2); - - jit_prepare(1); + jit_prepare(3); + jit_pusharg_i(JIT_R2); + jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_start_finish); + (void)mz_finish(scheme_linklet_run_finish); CHECK_LIMIT(); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); - scheme_jit_register_sub_func(jitter, sjc.module_start_start_code, scheme_eof); + scheme_jit_register_sub_func(jitter, sjc.linklet_run_start_code, scheme_eof); } /* *** thread_start_child_code *** */ @@ -4153,6 +4097,39 @@ } } + /* hash_ref_code */ + /* args are in R0, R1, R2 */ + { + GC_CAN_IGNORE jit_insn *ref USED_ONLY_FOR_FUTURES; + + sjc.hash_ref_code = jit_get_ip(); + + mz_prolog(JIT_V1); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3)); + CHECK_RUNSTACK_OVERFLOW(); + jit_str_p(JIT_RUNSTACK, JIT_R0); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); + jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + CHECK_LIMIT(); + + jit_movi_i(JIT_R1, 3); + jit_prepare(2); + jit_pusharg_p(JIT_RUNSTACK); + jit_pusharg_i(JIT_R1); + (void)mz_finish_lwe(ts_scheme_checked_hash_ref, ref); + CHECK_LIMIT(); + jit_retval(JIT_R0); + + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3)); + JIT_UPDATE_THREAD_RSPTR(); + + mz_epilog(JIT_V1); + CHECK_LIMIT(); + + scheme_jit_register_sub_func(jitter, sjc.hash_ref_code, scheme_false); + } + #ifdef MZ_USE_LWC /* native_starter_code */ { diff -Nru racket-6.12+ppa1/src/racket/src/jit.h racket-7.0+ppa1/src/racket/src/jit.h --- racket-6.12+ppa1/src/racket/src/jit.h 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jit.h 2018-07-27 22:12:02.000000000 +0000 @@ -294,7 +294,6 @@ void *bad_result_arity_code; void *unbound_global_code; - void *quote_syntax_code; void *call_original_unary_arith_code; void *call_original_binary_arith_code; void *call_original_binary_rev_arith_code; @@ -307,24 +306,25 @@ void *bad_cXr_code; void *bad_mcar_code, *bad_mcdr_code; void *bad_set_mcar_code, *bad_set_mcdr_code; + void *bad_syntax_e_code; void *imag_part_code, *real_part_code, *make_rectangular_code; void *bad_flimag_part_code, *bad_flreal_part_code, *bad_make_flrectangular_code; - void *unbox_code, *set_box_code, *box_cas_fail_code; + void *unbox_code, *set_box_code, *unbox_star_fail_code, *set_box_star_fail_code, *box_cas_fail_code, *weak_box_value_code; void *vector_cas_fail_code; - void *bad_vector_length_code; + void *bad_vector_length_code, *bad_vector_star_length_code; void *bad_flvector_length_code; void *bad_fxvector_length_code; void *bad_string_length_code; void *bad_bytes_length_code; void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code; void *chap_vector_ref_code, *chap_vector_ref_check_index_code, *chap_vector_set_code, *chap_vector_set_check_index_code; + void *vector_star_ref_code, *vector_star_ref_check_index_code, *vector_star_set_code, *vector_star_set_check_index_code; void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; void *flvector_ref_check_index_code[JIT_NUM_FL_KINDS]; void *flvector_set_check_index_code[JIT_NUM_FL_KINDS], *flvector_set_flonum_check_index_code[JIT_NUM_FL_KINDS]; void *fxvector_ref_code, *fxvector_ref_check_index_code, *fxvector_set_code, *fxvector_set_check_index_code; void *struct_raw_ref_code, *struct_raw_set_code, *struct_raw_refs_code; - void *syntax_e_code; void *on_demand_jit_arity_code, *in_progress_on_demand_jit_arity_code; void *get_stack_pointer_code; void *stack_cache_pop_code; @@ -344,11 +344,13 @@ void *bad_char_to_integer_code, *slow_integer_to_char_code; void *slow_cpointer_tag_code, *slow_set_cpointer_tag_code; void *values_code; + void *symbol_interned_p_code; void *list_p_code, *list_p_branch_code; void *list_length_code; void *list_ref_code, *list_tail_code; + void *hash_ref_code; void *finish_tail_call_code, *finish_tail_call_fixup_code; - void *module_run_start_code, *module_exprun_start_code, *module_start_start_code; + void *linklet_run_start_code; void *thread_start_child_code; void *box_flonum_from_stack_code, *box_flonum_from_reg_code; void *fl1_fail_code[JIT_NUM_FL_KINDS], *fl2rr_fail_code[2][JIT_NUM_FL_KINDS]; @@ -1420,7 +1422,7 @@ Branch_Info *for_branch); int scheme_generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry, int known_list, int dest); int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, - int inline_slow, int pop_and_jump, + int inline_slow, int pop_and_jump, int check_proc, int is_tail, int multi_ok, int dest); int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters, int skipped); @@ -1529,7 +1531,7 @@ int result_ignored, int check_proc, int check_arg_fixnum, int type_pos, int field_pos, - int authentic, + int authentic, int type_unpacked, int pop_and_jump, jit_insn *refslow, jit_insn *refslow2, jit_insn *bref_false, jit_insn *bref_true); diff -Nru racket-6.12+ppa1/src/racket/src/jitinline.c racket-7.0+ppa1/src/racket/src/jitinline.c --- racket-6.12+ppa1/src/racket/src/jitinline.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitinline.c 2018-07-27 22:12:02.000000000 +0000 @@ -36,7 +36,7 @@ #endif #include "jit_ts.c" -static Scheme_Object *equal_as_bool(Scheme_Object *a, Scheme_Object *b) +static Scheme_Object *equal_as_bool(Scheme_Object *a, Scheme_Object *b) XFORM_ASSERT_NO_CONVERSION { if (scheme_equal(a, b)) return scheme_true; @@ -181,6 +181,11 @@ p = scheme_extract_global(o, jitter->nc, 0); p = ((Scheme_Bucket *)p)->val; return check_val_struct_prim(p, arity); + } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_static_toplevel_type)) { + Scheme_Object *p; + p = SCHEME_STATIC_TOPLEVEL_PREFIX(o)->a[SCHEME_TOPLEVEL_POS(o)]; + p = ((Scheme_Bucket *)p)->val; + return check_val_struct_prim(p, arity); } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) { Scheme_Object *p; p = scheme_extract_closure_local(o, jitter, extra_push, 0); @@ -272,6 +277,7 @@ return 1; } +/* -1 for can_chaperone for `chaperone?` test */ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app, Scheme_Type lo_ty, Scheme_Type hi_ty, int can_chaperone, Branch_Info *for_branch, int branch_short, @@ -535,6 +541,77 @@ return 1; } +static int generate_inlined_char_category_test(mz_jit_state *jitter, Scheme_App2_Rec *app, int bit, + Branch_Info *for_branch, int branch_short, + int dest) +{ + GC_CAN_IGNORE jit_insn *reffail = NULL, *ref, *pref; + + LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)app->rator)->name)); + + mz_runstack_skipped(jitter, 1); + + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync(); + + __START_SHORT_JUMPS__(branch_short); + + if (for_branch) { + scheme_prepare_branch_jump(jitter, for_branch); + CHECK_LIMIT(); + } + + pref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); + reffail = jit_get_ip(); + (void)jit_movi_p(JIT_R2, ((Scheme_Primitive_Proc *)app->rator)->prim_val); + __END_SHORT_JUMPS__(branch_short); + (void)jit_calli(sjc.call_original_unary_arith_code); + __START_SHORT_JUMPS__(branch_short); + mz_patch_branch(pref); + (void)mz_bnei_t(reffail, JIT_R0, scheme_char_type, JIT_R2); + + /* Extract character value */ + jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); + + /* Lookup */ + jit_movi_p(JIT_R1, scheme_uchar_table); + jit_rshi_i(JIT_R2, JIT_R0, (SCHEME_UCHAR_FIND_SHIFT - JIT_LOG_WORD_SIZE)); + jit_andi_i(JIT_R2, JIT_R2, (SCHEME_UCHAR_FIND_HI_MASK << JIT_LOG_WORD_SIZE)); + jit_ldxr_p(JIT_R1, JIT_R1, JIT_R2); + jit_andi_i(JIT_R2, JIT_R0, SCHEME_UCHAR_FIND_LO_MASK); + jit_lshi_i(JIT_R2, JIT_R2, 1); /* 1 = log_2(sizeof(short)) */ + jit_ldxr_s(JIT_R1, JIT_R1, JIT_R2); + + /* JIT_R1 now has character-property bits */ + ref = jit_bmci_i(jit_forward(), JIT_R1, bit); + CHECK_LIMIT(); + + if (for_branch) { + scheme_add_branch_false(for_branch, ref); + scheme_branch_for_true(jitter, for_branch); + CHECK_LIMIT(); + } else { + GC_CAN_IGNORE jit_insn *ref2; + (void)jit_movi_p(dest, scheme_true); + __START_INNER_TINY__(branch_short); + ref2 = jit_jmpi(jit_forward()); + __END_INNER_TINY__(branch_short); + mz_patch_branch(ref); + (void)jit_movi_p(dest, scheme_false); + __START_INNER_TINY__(branch_short); + mz_patch_ucbranch(ref2); + __END_INNER_TINY__(branch_short); + } + + __END_SHORT_JUMPS__(branch_short); + + return 1; +} + static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Object *rator) { if (SCHEME_PROCP(rator)) @@ -545,6 +622,10 @@ rator = scheme_extract_global(rator, jitter->nc, 0); if (rator) return ((Scheme_Bucket *)rator)->val; + } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_static_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) { + rator = SCHEME_STATIC_TOPLEVEL_PREFIX(rator)->a[SCHEME_TOPLEVEL_POS(rator)]; + return ((Scheme_Bucket *)rator)->val; } return NULL; @@ -559,9 +640,22 @@ { GC_CAN_IGNORE jit_insn *ref, *ref2, *refslow; Scheme_Object *inline_rator; + int type_unpacked = 0; LOG_IT(("inlined struct op\n")); + if ((kind == INLINE_STRUCT_PROC_PRED) + && SAME_TYPE(SCHEME_TYPE(rator), scheme_static_toplevel_type)) { + /* If a static toplevel has a predicate, then we can extract the + structure type eagerly */ + inline_rator = extract_struct_constant(jitter, rator); + if (inline_rator) { + rator = ((Scheme_Primitive_Closure *)inline_rator)->val[0]; + type_unpacked = 1; + } + } else + inline_rator = NULL; + if (!rand2) { scheme_generate_two_args(rator, rand, jitter, 1, 1); /* sync'd below */ CHECK_LIMIT(); @@ -586,7 +680,8 @@ if ((kind == INLINE_STRUCT_PROC_PRED) || (kind == INLINE_STRUCT_PROC_GET) || (kind == INLINE_STRUCT_PROC_SET)) { - inline_rator = extract_struct_constant(jitter, rator); + if (!inline_rator) + inline_rator = extract_struct_constant(jitter, rator); if (inline_rator && (kind != INLINE_STRUCT_PROC_PRED)) { __START_SHORT_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1); @@ -671,7 +766,9 @@ (void)jit_calli(sjc.struct_prop_pred_code); } } else if (kind == INLINE_STRUCT_PROC_CONSTR) { - scheme_generate_struct_alloc(jitter, rand2 ? 2 : 1, 0, 0, is_tail, multi_ok, JIT_R0); + int check_proc; + check_proc = !extract_struct_constant(jitter, rator); + scheme_generate_struct_alloc(jitter, rand2 ? 2 : 1, 0, 0, check_proc, is_tail, multi_ok, JIT_R0); CHECK_LIMIT(); } else { scheme_signal_error("internal error: unknown struct-op mode"); @@ -711,7 +808,7 @@ result_ignored, 0, 0, tpos, pos, - authentic, + authentic, type_unpacked, 0, refslow, refslow, NULL, NULL); CHECK_LIMIT(); @@ -837,6 +934,8 @@ int is_tail, int multi_ok, int dest) /* de-sync'd ok; for branch, sync'd before */ { + int check_proc; + /* generate code to evaluate the arguments */ scheme_generate_app(app, NULL, app->num_args, app->num_args, jitter, 0, 0, 0, 1); CHECK_LIMIT(); @@ -844,8 +943,10 @@ jit_movr_l(JIT_R0, JIT_V1); /* move rator to R0 */ + check_proc = !extract_struct_constant(jitter, rator); + /* arguments are now on the runstack, rator is in R0 */ - scheme_generate_struct_alloc(jitter, app->num_args, 0, 0, is_tail, multi_ok, dest); + scheme_generate_struct_alloc(jitter, app->num_args, 0, 0, check_proc, is_tail, multi_ok, dest); CHECK_LIMIT(); @@ -858,7 +959,7 @@ } int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, - int inline_slow, int pop_and_jump, + int inline_slow, int pop_and_jump, int check_proc, int is_tail, int multi_ok, int dest) /* Rator is in R0. For unary case, R1 is argument. @@ -980,27 +1081,31 @@ /* Continue trying fast path: check proc */ mz_patch_branch(ref); - (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); - (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR); - CHECK_LIMIT(); + if (check_proc) { + (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR); + CHECK_LIMIT(); + } jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); /* R2 now has the Scheme_Struct_Type* */ - if (num_args != 2) { - /* V1 is available */ - jit_ldxi_i(JIT_V1, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); - if (num_args == -1) - (void)jit_bner_i(refslow, JIT_V1, JIT_R1); - else - (void)jit_bnei_i(refslow, JIT_V1, num_args); - } else { - /* No registers available, so we'll have to re-extract to R2 */ - jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); - (void)jit_bnei_i(refslow, JIT_R2, num_args); - jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); + if (check_proc) { + if (num_args != 2) { + /* V1 is available */ + jit_ldxi_i(JIT_V1, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); + if (num_args == -1) + (void)jit_bner_i(refslow, JIT_V1, JIT_R1); + else + (void)jit_bnei_i(refslow, JIT_V1, num_args); + } else { + /* No registers available, so we'll have to re-extract to R2 */ + jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); + (void)jit_bnei_i(refslow, JIT_R2, num_args); + jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); + } } CHECK_LIMIT(); @@ -1229,6 +1334,9 @@ } else if (IS_NAMED_PRIM(rator, "syntax?")) { generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, 0, for_branch, branch_short, dest); return 1; + } else if(IS_NAMED_PRIM(rator, "variable-reference?")) { + generate_inlined_type_test(jitter, app, scheme_global_ref_type, scheme_global_ref_type, 0, for_branch, branch_short, dest); + return 1; } else if (IS_NAMED_PRIM(rator, "char?")) { generate_inlined_type_test(jitter, app, scheme_char_type, scheme_char_type, 0, for_branch, branch_short, dest); return 1; @@ -1286,6 +1394,12 @@ } else if (IS_NAMED_PRIM(rator, "path?")) { generate_inlined_type_test(jitter, app, SCHEME_PLATFORM_PATH_KIND, SCHEME_PLATFORM_PATH_KIND, 0, for_branch, branch_short, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "hash?")) { + generate_inlined_type_test(jitter, app, scheme_hash_table_type, scheme_bucket_table_type, 1, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "syntax?")) { + generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, 0, for_branch, branch_short, dest); + return 1; } else if (IS_NAMED_PRIM(rator, "eof-object?")) { generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, dest); return 1; @@ -1307,6 +1421,50 @@ } else if (IS_NAMED_PRIM(rator, "immutable?")) { generate_inlined_immutable_test(jitter, app, for_branch, branch_short, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "char-whitespace?")) { + generate_inlined_char_category_test(jitter, app, SCHEME_ISSPACE_BIT, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "symbol-interned?")) { + GC_CAN_IGNORE jit_insn *ref1, *reffail, *ref_no; + + mz_runstack_skipped(jitter, 1); + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync(); + + __START_SHORT_JUMPS__(branch_short); + + __START_INNER_TINY__(branch_short); + ref1 = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); + __END_INNER_TINY__(branch_short); + reffail = jit_get_ip(); + (void)jit_calli(sjc.symbol_interned_p_code); + + __START_INNER_TINY__(branch_short); + mz_patch_branch(ref1); + (void)mz_bnei_t(reffail, JIT_R0, scheme_symbol_type, JIT_R2); + __END_INNER_TINY__(branch_short); + + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Symbol *)0x0)->iso)); + + if (for_branch) { + ref_no = jit_bmsi_ul(jit_forward(), JIT_R2, 0x3); + scheme_add_branch_false(for_branch, ref_no); + scheme_branch_for_true(jitter, for_branch); + } else { + (void)jit_movi_p(dest, scheme_false); + __START_INNER_TINY__(branch_short); + ref_no = jit_bmsi_ul(jit_forward(), JIT_R2, 0x3); + (void)jit_movi_p(dest, scheme_true); + mz_patch_branch(ref_no); + __END_INNER_TINY__(branch_short); + } + + __END_SHORT_JUMPS__(branch_short); + + return 1; } else if (IS_NAMED_PRIM(rator, "list?") || IS_NAMED_PRIM(rator, "list-pair?")) { int for_list_pair = 0; @@ -1339,7 +1497,7 @@ CHECK_LIMIT(); /* We have a pair. Optimistically check for PAIR_IS_LIST: */ - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref6 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_IS_LIST); if (for_branch) { @@ -1411,7 +1569,7 @@ /* Check for positive bignum: */ __START_SHORT_JUMPS__(branch_short); ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_bignum_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref3 = jit_bmci_ul(jit_forward(), JIT_R2, 0x1); __END_SHORT_JUMPS__(branch_short); /* Ok bignum. Instead of jumping, install the fixnum 1: */ @@ -1603,7 +1761,37 @@ jit_movr_p(dest, JIT_R0); return 1; + } else if (IS_NAMED_PRIM(rator, "syntax-e")) { + GC_CAN_IGNORE jit_insn *reffail = NULL, *ref; + + LOG_IT(("inlined syntax-e\n")); + + mz_runstack_skipped(jitter, 1); + + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync_fail_branch(); + + __START_TINY_JUMPS__(1); + + ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); + reffail = jit_get_ip(); + __END_TINY_JUMPS__(1); + (void)jit_calli(sjc.bad_syntax_e_code); + __START_TINY_JUMPS__(1); + mz_patch_branch(ref); + (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R1); + (void)jit_ldxi_p(dest, JIT_R0, &(SCHEME_STX_VAL((Scheme_Stx *)0x0))); + VALIDATE_RESULT(dest); + CHECK_LIMIT(); + __END_TINY_JUMPS__(1); + + return 1; } else if (IS_NAMED_PRIM(rator, "vector-length") + || IS_NAMED_PRIM(rator, "vector*-length") || IS_NAMED_PRIM(rator, "fxvector-length") || IS_NAMED_PRIM(rator, "unsafe-vector-length") || IS_NAMED_PRIM(rator, "unsafe-fxvector-length") @@ -1636,7 +1824,7 @@ for_fl = 1; extfl = 1; unsafe = 1; - } else { + } else if (IS_NAMED_PRIM(rator, "vector-length")) { can_chaperone = 1; } @@ -1663,9 +1851,12 @@ (void)jit_calli(sjc.bad_flvector_length_code)); } else if (for_fx) (void)jit_calli(sjc.bad_fxvector_length_code); - else { + else if (can_chaperone) { (void)jit_calli(sjc.bad_vector_length_code); /* can return with updated R0 */ + } else { + (void)jit_calli(sjc.bad_vector_star_length_code); + /* does not return */ } /* bad_vector_length_code may unpack a proxied object */ @@ -1754,8 +1945,14 @@ jit_fixnum_l(dest, JIT_R0); return 1; - } else if (IS_NAMED_PRIM(rator, "unbox")) { + } else if (IS_NAMED_PRIM(rator, "unbox") + || IS_NAMED_PRIM(rator, "unbox*") + || IS_NAMED_PRIM(rator, "weak-box-value")) { GC_CAN_IGNORE jit_insn *reffail, *ref, *refdone; + int for_weak, for_star; + + for_weak = IS_NAMED_PRIM(rator, "weak-box-value"); + for_star = IS_NAMED_PRIM(rator, "unbox*"); LOG_IT(("inlined unbox\n")); @@ -1773,20 +1970,39 @@ __END_TINY_JUMPS__(1); reffail = jit_get_ip(); - (void)jit_calli(sjc.unbox_code); - jit_movr_p(dest, JIT_R0); + if (for_weak) + (void)jit_calli(sjc.weak_box_value_code); /* always raises an exception */ + else if (for_star) + (void)jit_calli(sjc.unbox_star_fail_code); + else + (void)jit_calli(sjc.unbox_code); + if (!for_weak && !for_star) + jit_movr_p(dest, JIT_R0); __START_TINY_JUMPS__(1); - refdone = jit_jmpi(jit_forward()); + if (!for_weak && !for_star) + refdone = jit_jmpi(jit_forward()); + else + refdone = NULL; mz_patch_branch(ref); - (void)mz_bnei_t(reffail, JIT_R0, scheme_box_type, JIT_R1); + (void)mz_bnei_t(reffail, JIT_R0, (for_weak ? scheme_weak_box_type : scheme_box_type), JIT_R1); __END_TINY_JUMPS__(1); (void)jit_ldxi_p(dest, JIT_R0, &SCHEME_BOX_VAL(0x0)); - - __START_TINY_JUMPS__(1); - mz_patch_ucbranch(refdone); - __END_TINY_JUMPS__(1); + + if (for_weak) { + __START_TINY_JUMPS__(1); + ref = jit_bnei_p(jit_forward(), dest, NULL); + jit_movi_p(dest, scheme_false); + mz_patch_branch(ref); + __END_TINY_JUMPS__(1); + } + + if (!for_weak && !for_star) { + __START_TINY_JUMPS__(1); + mz_patch_ucbranch(refdone); + __END_TINY_JUMPS__(1); + } return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-unbox*")) { @@ -1820,7 +2036,7 @@ __START_TINY_JUMPS__(1); ref = mz_bnei_t(jit_forward(), JIT_R0, scheme_chaperone_type, JIT_R1); (void)jit_calli(sjc.unbox_code); - jit_retval(dest); + jit_movr_p(dest, JIT_R0); ref2 = jit_jmpi(jit_forward()); mz_patch_branch(ref); CHECK_LIMIT(); @@ -1833,22 +2049,6 @@ __END_TINY_JUMPS__(1); return 1; - } else if (IS_NAMED_PRIM(rator, "syntax-e")) { - LOG_IT(("inlined syntax-e\n")); - - mz_runstack_skipped(jitter, 1); - - scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); - CHECK_LIMIT(); - - mz_runstack_unskipped(jitter, 1); - - mz_rs_sync(); - - (void)jit_calli(sjc.syntax_e_code); - jit_movr_p(dest, JIT_R0); - - return 1; } else if (IS_NAMED_PRIM(rator, "imag-part") || IS_NAMED_PRIM(rator, "real-part") || IS_NAMED_PRIM(rator, "flimag-part") @@ -2220,6 +2420,50 @@ __END_TINY_JUMPS__(1); return 1; + } else if (IS_NAMED_PRIM(rator, "prefab-struct-key")) { + GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3; + + mz_runstack_skipped(jitter, 1); + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync(); + + jit_movi_p(JIT_R1, scheme_false); + + __START_SHORT_JUMPS__(1); + ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); + + /* check for chaperone: */ + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); + ref3 = jit_bnei_i(jit_forward(), JIT_R2, scheme_chaperone_type); + mz_patch_branch(ref2); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAPERONE_VAL((Scheme_Object *)0x0)); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + mz_patch_branch(ref3); + CHECK_LIMIT(); + + /* check for structure: */ + ref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_structure_type); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&((Scheme_Struct_Type *)0x0)->prefab_key); + ref3 = jit_beqi_p(jit_forward(), JIT_R0, NULL); + /* is a prefab; extract key */ + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); + jit_movr_p(JIT_R1, JIT_R0); + CHECK_LIMIT(); + + mz_patch_branch(ref3); + mz_patch_branch(ref2); + mz_patch_branch(ref); + CHECK_LIMIT(); + __END_SHORT_JUMPS__(1); + + jit_movr_p(dest, JIT_R1); + + return 1; } else if (IS_NAMED_PRIM(rator, "cpointer-tag")) { GC_CAN_IGNORE jit_insn *ref, *refslow, *refdone; @@ -2436,7 +2680,7 @@ return direction; } -static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, +static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int cmp, Branch_Info *for_branch, int branch_short, int dest) /* de-sync'd ok */ { @@ -2451,6 +2695,27 @@ direction = scheme_generate_two_args(r1, r2, jitter, 0, 2); CHECK_LIMIT(); + if (direction < 0) { + /* reverse sense of comparison */ + GC_CAN_IGNORE Scheme_Object *tmp = r2; + r2 = r1; + r1 = tmp; + switch (cmp) { + case CMP_LEQ: + cmp = CMP_GEQ; + break; + case CMP_GEQ: + cmp = CMP_LEQ; + break; + case CMP_GT: + cmp = CMP_LT; + break; + case CMP_LT: + cmp = CMP_GT; + break; + } + } + mz_rs_sync(); __START_SHORT_JUMPS__(branch_short); @@ -2503,13 +2768,39 @@ CHECK_LIMIT(); } - if (!direct) { + if (!direct || (cmp != CMP_EQUAL)) { /* Extract character value */ jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); jit_ldxi_i(JIT_R1, JIT_R1, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); - ref = jit_bner_i(jit_forward(), JIT_R0, JIT_R1); + + switch (cmp) { + case CMP_EQUAL: + ref = jit_bner_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_LEQ: + ref = jit_bgtr_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_GEQ: + ref = jit_bltr_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_GT: + ref = jit_bler_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_LT: + ref = jit_bger_i(jit_forward(), JIT_R0, JIT_R1); + break; + default: + ref = NULL; /* never happens */ + } } else { - ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); + /* Equality on small chars can compare pointers */ + switch(cmp) { + case CMP_EQUAL: + ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); + break; + default: + ref = NULL; /* never happens */ + } } CHECK_LIMIT(); if (for_branch) { @@ -2564,9 +2855,12 @@ (void)jit_calli(sjc.struct_raw_set_code); else if (for_fx) (void)jit_calli(sjc.fxvector_set_check_index_code); - else if (!for_fl) - (void)jit_calli(sjc.vector_set_check_index_code); - else if (unbox_flonum) + else if (!for_fl) { + if (can_chaperone) + (void)jit_calli(sjc.vector_set_check_index_code); + else + (void)jit_calli(sjc.vector_star_set_check_index_code); + } else if (unbox_flonum) (void)jit_calli(sjc.flvector_set_flonum_check_index_code[extfl]); else (void)jit_calli(sjc.flvector_set_check_index_code[extfl]); @@ -2575,9 +2869,12 @@ (void)jit_calli(sjc.struct_raw_ref_code); else if (for_fx) (void)jit_calli(sjc.fxvector_ref_check_index_code); - else if (!for_fl) - (void)jit_calli(sjc.vector_ref_check_index_code); - else + else if (!for_fl) { + if (can_chaperone) + (void)jit_calli(sjc.vector_ref_check_index_code); + else + (void)jit_calli(sjc.vector_star_ref_check_index_code); + } else (void)jit_calli(sjc.flvector_ref_check_index_code[extfl]); } CHECK_LIMIT(); @@ -2798,7 +3095,9 @@ if (!SCHEME_INTP(a1) && !SCHEME_FALSEP(a1) && !SCHEME_VOIDP(a1) - && !SAME_OBJ(a1, scheme_true)) { + && !SAME_OBJ(a1, scheme_true) + && !SAME_OBJ(a1, scheme_null) + && !SAME_OBJ(a1, scheme_undefined)) { scheme_mz_load_retained(jitter, JIT_R1, a1); ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); /* In case true is a fall-through, note that the test @@ -3269,7 +3568,19 @@ scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_BIT, 0, for_branch, branch_short, 0, 0, NULL, dest); return 1; } else if (IS_NAMED_PRIM(rator, "char=?")) { - generate_binary_char(jitter, app, for_branch, branch_short, dest); + generate_binary_char(jitter, app, CMP_EQUAL, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char<=?")) { + generate_binary_char(jitter, app, CMP_LEQ, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char>=?")) { + generate_binary_char(jitter, app, CMP_GEQ, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char>?")) { + generate_binary_char(jitter, app, CMP_GT, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "charrand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); @@ -3859,8 +4176,14 @@ if (ref3) mz_patch_branch(ref3); reffail = jit_get_ip(); - (void)jit_calli(sjc.set_box_code); - ref2 = jit_jmpi(jit_forward()); + if (!for_star) + (void)jit_calli(sjc.set_box_code); + else + (void)jit_calli(sjc.set_box_star_fail_code); + if (!for_star) + ref2 = jit_jmpi(jit_forward()); + else + ref2 = NULL; mz_patch_branch(ref); if (!unsafe) { jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)0x0)); @@ -3870,9 +4193,11 @@ (void)jit_stxi_p(&SCHEME_BOX_VAL(0x0), JIT_R0, JIT_R1); - __START_TINY_JUMPS__(1); - mz_patch_ucbranch(ref2); - __END_TINY_JUMPS__(1); + if (!for_star) { + __START_TINY_JUMPS__(1); + mz_patch_ucbranch(ref2); + __END_TINY_JUMPS__(1); + } if (!result_ignored) (void)jit_movi_p(dest, scheme_void); @@ -3989,7 +4314,7 @@ /* (slow path) */ refslow = jit_get_ip(); (void)jit_calli(sjc.make_rectangular_code); - jit_retval(dest); + jit_movr_p(dest, JIT_R0); CHECK_LIMIT(); refdone = jit_jmpi(jit_forward()); /* (end of slow path) */ @@ -4220,7 +4545,12 @@ if (!SCHEME_PRIMP(rator)) return 0; - if (!(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED)) + if (SAME_OBJ(rator, scheme_hash_ref_proc)) { + if ((app->num_args != 3) + || (SCHEME_TYPE(app->args[3]) < _scheme_values_types_) + || SCHEME_PROCP(app->args[3])) + return 0; + } else if (!(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED)) return 0; if (app->num_args < ((Scheme_Primitive_Proc *)rator)->mina) @@ -4383,6 +4713,7 @@ return 1; } else if (!for_branch) { if (IS_NAMED_PRIM(rator, "vector-set!") + || IS_NAMED_PRIM(rator, "vector*-set!") || IS_NAMED_PRIM(rator, "unsafe-vector-set!") || IS_NAMED_PRIM(rator, "unsafe-vector*-set!") || IS_NAMED_PRIM(rator, "flvector-set!") @@ -4406,6 +4737,10 @@ if (IS_NAMED_PRIM(rator, "vector-set!")) { which = 0; check_mutable = 1; + } else if (IS_NAMED_PRIM(rator, "vector*-set!")) { + which = 0; + can_chaperone = 0; + check_mutable = 1; } else if (IS_NAMED_PRIM(rator, "fxvector-set!")) { which = 0; for_fx = 1; @@ -5217,6 +5552,51 @@ (void)jit_movi_p(dest, scheme_void); return 1; + } else if (IS_NAMED_PRIM(rator, "hash-ref")) { + GC_CAN_IGNORE jit_insn *refdone0, *refdone, *refslow; + + /* We only get here if we have three arguments with the last as a + non-procedure constant */ + + scheme_generate_two_args(app->args[1], app->args[2], jitter, 1, 3); + CHECK_LIMIT(); + + mz_rs_sync(); + + /* Jump to slow path for anything other than an immutable hasheq */ + __START_SHORT_JUMPS__(1); + refslow = mz_bnei_t(jit_forward(), JIT_R0, scheme_eq_hash_tree_type, JIT_R2); + __END_SHORT_JUMPS__(1); + + /* scheme_eq_hash_tree_get doesn't trigger a GC */ + jit_prepare(2); + jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)jit_finish(scheme_eq_hash_tree_get); + jit_retval(dest); + + __START_SHORT_JUMPS__(1); + refdone0 = jit_bnei_p(jit_forward(), dest, NULL); + scheme_mz_load_retained(jitter, dest, app->args[3]); + CHECK_LIMIT(); + + refdone = jit_jmpi(jit_forward()); + + /* slow path */ + mz_patch_branch(refslow); + __END_SHORT_JUMPS__(1); + + scheme_mz_load_retained(jitter, JIT_R2, app->args[3]); + (void)jit_calli(sjc.hash_ref_code); + jit_movr_p(dest, JIT_R0); + CHECK_LIMIT(); + + __START_SHORT_JUMPS__(1); + mz_patch_branch(refdone0); + mz_patch_ucbranch(refdone); + __END_SHORT_JUMPS__(1); + + return 1; } } diff -Nru racket-6.12+ppa1/src/racket/src/jitprep.c racket-7.0+ppa1/src/racket/src/jitprep.c --- racket-6.12+ppa1/src/racket/src/jitprep.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitprep.c 2018-07-27 22:12:02.000000000 +0000 @@ -35,7 +35,7 @@ #ifdef MZ_USE_JIT -static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit); +static Scheme_Object *jit_expr(Scheme_Object *expr); static Scheme_Object *jit_application(Scheme_Object *o) { @@ -48,7 +48,7 @@ for (i = 0; i < n; i++) { orig = app->args[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (!SAME_OBJ(orig, naya)) break; } @@ -65,7 +65,7 @@ for (i++; i < n; i++) { orig = app2->args[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); app2->args[i] = naya; } @@ -79,8 +79,8 @@ app = (Scheme_App2_Rec *)o; - nrator = scheme_jit_expr(app->rator); - nrand = scheme_jit_expr(app->rand); + nrator = jit_expr(app->rator); + nrand = jit_expr(app->rand); if (SAME_OBJ(nrator, app->rator) && SAME_OBJ(nrand, app->rand)) @@ -101,9 +101,9 @@ app = (Scheme_App3_Rec *)o; - nrator = scheme_jit_expr(app->rator); - nrand1 = scheme_jit_expr(app->rand1); - nrand2 = scheme_jit_expr(app->rand2); + nrator = jit_expr(app->rator); + nrand1 = jit_expr(app->rand1); + nrand2 = jit_expr(app->rand2); if (SAME_OBJ(nrator, app->rator) && SAME_OBJ(nrand1, app->rand1) @@ -130,7 +130,7 @@ for (i = 0; i < n; i++) { orig = seq->array[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (!SAME_OBJ(orig, naya)) break; } @@ -146,7 +146,7 @@ for (i++; i < n; i++) { orig = seq2->array[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); seq2->array[i] = naya; } @@ -160,9 +160,9 @@ b = (Scheme_Branch_Rec *)o; - t = scheme_jit_expr(b->test); - tb = scheme_jit_expr(b->tbranch); - fb = scheme_jit_expr(b->fbranch); + t = jit_expr(b->test); + tb = jit_expr(b->tbranch); + fb = jit_expr(b->fbranch); if (SAME_OBJ(t, b->test) && SAME_OBJ(tb, b->tbranch) @@ -183,8 +183,8 @@ Scheme_Let_Value *lv = (Scheme_Let_Value *)o; Scheme_Object *body, *rhs; - rhs = scheme_jit_expr(lv->value); - body = scheme_jit_expr(lv->body); + rhs = jit_expr(lv->value); + body = jit_expr(lv->body); if (SAME_OBJ(rhs, lv->value) && SAME_OBJ(body, lv->body)) @@ -203,8 +203,8 @@ Scheme_Let_One *lo = (Scheme_Let_One *)o; Scheme_Object *body, *rhs; - rhs = scheme_jit_expr(lo->value); - body = scheme_jit_expr(lo->body); + rhs = jit_expr(lo->value); + body = jit_expr(lo->body); if (SAME_OBJ(rhs, lo->value) && SAME_OBJ(body, lo->body)) @@ -223,7 +223,7 @@ Scheme_Let_Void *lv = (Scheme_Let_Void *)o; Scheme_Object *body; - body = scheme_jit_expr(lv->body); + body = jit_expr(lv->body); if (SAME_OBJ(body, lv->body)) return o; @@ -255,7 +255,7 @@ procs2[i] = v; } - v = scheme_jit_expr(lr->body); + v = jit_expr(lr->body); lr2->body = v; return (Scheme_Object *)lr2; @@ -266,9 +266,9 @@ Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_jit_expr(wcm->key); - v = scheme_jit_expr(wcm->val); - b = scheme_jit_expr(wcm->body); + k = jit_expr(wcm->key); + v = jit_expr(wcm->val); + b = jit_expr(wcm->body); if (SAME_OBJ(wcm->key, k) && SAME_OBJ(wcm->val, v) && SAME_OBJ(wcm->body, b)) @@ -300,26 +300,26 @@ static Scheme_Object *define_values_jit(Scheme_Object *data) { - Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya; + Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya; if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type) - && (SCHEME_VEC_SIZE(data) == 2)) - naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]); + && (SCHEME_DEFN_VAR_COUNT(data) == 1)) + naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0)); else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type) && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type) - && (SCHEME_VEC_SIZE(data) == 2)) { - naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]); - if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0])) + && (SCHEME_DEFN_VAR_COUNT(data) == 1)) { + naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0)); + if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig))) naya = clone_inline_variant(orig, naya); } else - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { orig = naya; naya = scheme_clone_vector(data, 0, 1); - SCHEME_VEC_ELS(naya)[0] = orig; + SCHEME_DEFN_RHS(naya) = orig; return naya; } } @@ -329,7 +329,7 @@ Scheme_Object *a, *orig; orig = SCHEME_VEC_ELS(data)[0]; - a = scheme_jit_expr(orig); + a = jit_expr(orig); if (!SAME_OBJ(a, orig)) return clone_inline_variant(data, a); else @@ -343,7 +343,7 @@ orig_val = sb->val; - naya_val = scheme_jit_expr(orig_val); + naya_val = jit_expr(orig_val); if (SAME_OBJ(naya_val, orig_val)) return data; @@ -364,8 +364,8 @@ { Scheme_Object *f, *e; - f = scheme_jit_expr(SCHEME_PTR1_VAL(data)); - e = scheme_jit_expr(SCHEME_PTR2_VAL(data)); + f = jit_expr(SCHEME_PTR1_VAL(data)); + e = jit_expr(SCHEME_PTR2_VAL(data)); if (SAME_OBJ(f, SCHEME_PTR1_VAL(data)) && SAME_OBJ(e, SCHEME_PTR2_VAL(data))) @@ -384,9 +384,9 @@ Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_jit_expr(wcm->key); - v = scheme_jit_expr(wcm->val); - b = scheme_jit_expr(wcm->body); + k = jit_expr(wcm->key); + v = jit_expr(wcm->val); + b = jit_expr(wcm->body); if (SAME_OBJ(wcm->key, k) && SAME_OBJ(wcm->val, v) && SAME_OBJ(wcm->body, b)) @@ -482,7 +482,7 @@ Scheme_Object *orig, *naya, *new_data; orig = SCHEME_PTR2_VAL(data); - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { @@ -503,7 +503,7 @@ count = seq->count; for (i = 0; i < count; i++) { old = seq->array[i]; - naya = scheme_jit_expr(old); + naya = jit_expr(old); if (!SAME_OBJ(old, naya)) break; } @@ -522,23 +522,13 @@ seq2->array[i] = naya; for (i++; i < count; i++) { old = seq->array[i]; - naya = scheme_jit_expr(old); + naya = jit_expr(old); seq2->array[i] = naya; } return (Scheme_Object *)seq2; } -static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_clone(expr, 1); -} - -static Scheme_Object *begin_for_syntax_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_clone(expr, 1); -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -589,7 +579,7 @@ /* expressions */ /*========================================================================*/ -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) +static Scheme_Object *jit_expr(Scheme_Object *expr) { Scheme_Type type = SCHEME_TYPE(expr); @@ -601,7 +591,6 @@ case scheme_application3_type: return jit_application3(expr); case scheme_sequence_type: - case scheme_splice_sequence_type: return jit_sequence(expr); case scheme_branch_type: return jit_branch(expr); @@ -632,18 +621,12 @@ } case scheme_define_values_type: return define_values_jit(expr); - case scheme_define_syntaxes_type: - return define_syntaxes_jit(expr); - case scheme_begin_for_syntax_type: - return begin_for_syntax_jit(expr); case scheme_set_bang_type: return set_jit(expr); case scheme_boxenv_type: return bangboxenv_jit(expr); case scheme_begin0_sequence_type: return begin0_jit(expr); - case scheme_require_form_type: - return scheme_top_level_require_jit(expr); case scheme_varref_form_type: return ref_jit(expr); case scheme_apply_values_type: @@ -652,8 +635,6 @@ return with_immed_mark_jit(expr); case scheme_case_lambda_sequence_type: return scheme_case_lambda_jit(expr); - case scheme_module_type: - return scheme_module_jit(expr); case scheme_inline_variant_type: return inline_variant_jit(expr); default: @@ -661,60 +642,47 @@ } } -#else - -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) -{ - return expr; -} +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *linklet, int step) +/* step 1: clone the immediate record, to be mutated for actual prepataion + step 2: actual preparation */ +{ + Scheme_Linklet *new_linklet; + Scheme_Object *bodies, *v; + int i; + + if (!linklet->jit_ready) { + new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + memcpy(new_linklet, linklet, sizeof(Scheme_Linklet)); + } else + new_linklet = linklet; -#endif + if (new_linklet->jit_ready >= step) + return new_linklet; -static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) -{ - Resolve_Prefix *rp, *orig_rp; - Scheme_Object *naya, *rhs; - - rhs = SCHEME_VEC_ELS(expr)[0]; -#ifdef MZ_USE_JIT - if (jit) { - if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) - naya = scheme_jit_expr(rhs); - else { - int changed = 0; - Scheme_Object *a, *l = rhs; - naya = scheme_null; - while (!SCHEME_NULLP(l)) { - a = scheme_jit_expr(SCHEME_CAR(l)); - if (!SAME_OBJ(a, SCHEME_CAR(l))) - changed = 1; - naya = scheme_make_pair(a, naya); - l = SCHEME_CDR(l); - } - if (changed) - naya = scheme_reverse(naya); - else - naya = rhs; - } - } else -#endif - naya = rhs; + if (step == 1) { + new_linklet->jit_ready = 1; + return new_linklet; + } - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; - rp = scheme_prefix_eval_clone(orig_rp); - - if (SAME_OBJ(naya, rhs) - && SAME_OBJ(orig_rp, rp)) - return expr; - else { - expr = scheme_clone_vector(expr, 0, 1); - SCHEME_VEC_ELS(expr)[0] = naya; - SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; - return expr; + i = SCHEME_VEC_SIZE(linklet->bodies); + bodies = scheme_make_vector(i, NULL); + while (i--) { + v = jit_expr(SCHEME_VEC_ELS(linklet->bodies)[i]); + SCHEME_VEC_ELS(bodies)[i] = v; } + + new_linklet->bodies = bodies; + + new_linklet->jit_ready = 2; + + return new_linklet; } -Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr) +#else + +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *linklet, int step) { - return do_define_syntaxes_clone(expr, 0); + return linklet; } + +#endif diff -Nru racket-6.12+ppa1/src/racket/src/jitstack.c racket-7.0+ppa1/src/racket/src/jitstack.c --- racket-6.12+ppa1/src/racket/src/jitstack.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitstack.c 2018-07-27 22:12:02.000000000 +0000 @@ -198,7 +198,8 @@ } #ifdef MZ_USE_DWARF_LIBUNWIND - unw_getcontext(&cx); + if (unw_getcontext(&cx) != 0) + return NULL; unw_init_local(&c, &cx); unw_set_safe_pointer_range(&c, stack_start, real_stack_end); use_unw = 1; @@ -694,36 +695,16 @@ } -typedef void *(*Module_Run_Proc)(Scheme_Env *menv, Scheme_Env *env, Scheme_Object **name); -typedef void *(*Module_Exprun_Proc)(Scheme_Env *menv, int set_ns, Scheme_Object **name); -typedef void *(*Module_Start_Proc)(struct Start_Module_Args *a, Scheme_Object **name); +typedef Scheme_Object *(*Linklet_Run_Proc)(Scheme_Linklet *linklet, Scheme_Instance *inst, Scheme_Object **name); typedef void (*Thread_Start_Child_Proc)(Scheme_Thread *child, Scheme_Object *child_thunk); -void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name) -{ - Module_Run_Proc proc = (Module_Run_Proc)sjc.module_run_start_code; - if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(menv, env, &name); - else - return scheme_module_run_finish(menv, env); -} - -void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name) -{ - Module_Exprun_Proc proc = (Module_Exprun_Proc)sjc.module_exprun_start_code; - if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(menv, set_ns, &name); - else - return scheme_module_exprun_finish(menv, set_ns); -} - -void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name) +Scheme_Object *scheme_linklet_run_start(Scheme_Linklet *linklet, Scheme_Instance *inst, Scheme_Object *name) { - Module_Start_Proc proc = (Module_Start_Proc)sjc.module_start_start_code; + Linklet_Run_Proc proc = (Linklet_Run_Proc)sjc.linklet_run_start_code; if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(a, &name); + return proc(linklet, inst, &name); else - return scheme_module_start_finish(a); + return scheme_linklet_run_finish(linklet, inst, 1); } void scheme_thread_start_child(Scheme_Thread *child, Scheme_Object *child_thunk) diff -Nru racket-6.12+ppa1/src/racket/src/jitstate.c racket-7.0+ppa1/src/racket/src/jitstate.c --- racket-6.12+ppa1/src/racket/src/jitstate.c 2018-01-12 21:54:33.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jitstate.c 2018-07-27 22:12:02.000000000 +0000 @@ -93,7 +93,8 @@ && !SAME_OBJ((Scheme_Object *)obj, scheme_true) && !SAME_OBJ((Scheme_Object *)obj, scheme_false) && !SAME_OBJ((Scheme_Object *)obj, scheme_void) - && !SAME_OBJ((Scheme_Object *)obj, scheme_null)) { + && !SAME_OBJ((Scheme_Object *)obj, scheme_null) + && !SAME_OBJ((Scheme_Object *)obj, scheme_undefined)) { #ifdef JIT_PRECISE_GC int retptr; void *p; diff -Nru racket-6.12+ppa1/src/racket/src/jit_ts.c racket-7.0+ppa1/src/racket/src/jit_ts.c --- racket-6.12+ppa1/src/racket/src/jit_ts.c 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/jit_ts.c 2018-07-27 22:12:02.000000000 +0000 @@ -47,9 +47,9 @@ define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_MARKS) define_ts_s_s(call_with_values_from_multiple_result, FSRC_MARKS) define_ts_S_s(apply_checked_fail, FSRC_MARKS) -define_ts_Sl_s(scheme_delayed_shift, FSRC_OTHER) define_ts_b_v(scheme_unbound_global, FSRC_MARKS) define_ts_ss_v(scheme_set_box, FSRC_MARKS) +define_ts_ss_v(scheme_set_box_star, FSRC_MARKS) define_ts_iS_s(scheme_checked_car, FSRC_MARKS) define_ts_iS_s(scheme_checked_cdr, FSRC_MARKS) define_ts_iS_s(scheme_checked_caar, FSRC_MARKS) @@ -70,20 +70,23 @@ define_ts_iS_s(scheme_checked_make_flrectangular, FSRC_MARKS) define_ts_iS_s(scheme_checked_vector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_vector_set, FSRC_MARKS) +define_ts_iS_s(scheme_checked_vector_star_ref, FSRC_MARKS) +define_ts_iS_s(scheme_checked_vector_star_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_string_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_string_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_byte_string_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_flvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_flvector_set, FSRC_MARKS) +define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS) #ifdef MZ_LONG_DOUBLE define_ts_iS_s(scheme_checked_extflvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_extflvector_set, FSRC_MARKS) #endif define_ts_iS_s(scheme_checked_fxvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_fxvector_set, FSRC_MARKS) -define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS) define_ts_s_s(scheme_vector_length, FSRC_MARKS) +define_ts_s_s(scheme_vector_star_length, FSRC_MARKS) define_ts_s_s(scheme_flvector_length, FSRC_MARKS) #ifdef MZ_LONG_DOUBLE define_ts_s_s(scheme_extflvector_length, FSRC_MARKS) @@ -94,6 +97,8 @@ define_ts_ss_s(scheme_string_eq_2, FSRC_MARKS) define_ts_ss_s(scheme_byte_string_eq_2, FSRC_MARKS) define_ts_s_s(scheme_unbox, FSRC_MARKS) +define_ts_s_s(scheme_unbox_star, FSRC_MARKS) +define_ts_s_s(scheme_weak_box_value, FSRC_MARKS) define_ts_si_s(scheme_struct_ref, FSRC_MARKS) define_ts_sis_v(scheme_struct_set, FSRC_MARKS) define_ts_Sii_s(unsafe_struct_refs, FSRC_MARKS) @@ -102,6 +107,7 @@ define_ts_ssi_s(vector_check_chaperone_of, FSRC_MARKS) define_ts_iS_s(scheme_checked_list_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_list_tail, FSRC_MARKS) +define_ts_iS_s(scheme_checked_hash_ref, FSRC_MARKS) define_ts_iSs_s(scheme_struct_getter, FSRC_MARKS) define_ts_iSs_s(scheme_struct_setter, FSRC_MARKS) define_ts_iS_s(scheme_box_cas, FSRC_MARKS) @@ -110,6 +116,7 @@ define_ts_ss_s(scheme_chaperone_get_immediate_cc_mark, FSRC_MARKS) define_ts_iS_s(scheme_checked_char_to_integer, FSRC_MARKS) define_ts_iS_s(scheme_checked_integer_to_char, FSRC_MARKS) +define_ts_iS_s(scheme_checked_symbol_interned_p, FSRC_MARKS) # ifndef CAN_INLINE_ALLOC define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER) # endif @@ -187,7 +194,6 @@ # define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity # define ts_call_wrong_return_arity call_wrong_return_arity # define ts_scheme_unbound_global scheme_unbound_global -# define ts_scheme_delayed_shift scheme_delayed_shift # define ts_scheme_checked_car scheme_checked_car # define ts_scheme_checked_cdr scheme_checked_cdr # define ts_scheme_checked_caar scheme_checked_caar @@ -208,12 +214,16 @@ # define ts_scheme_checked_make_flrectangular scheme_checked_make_flrectangular # define ts_scheme_make_complex scheme_make_complex # define ts_scheme_unbox scheme_unbox +# define ts_scheme_unbox_star scheme_unbox_star +# define ts_scheme_weak_box_value scheme_weak_box_value # define ts_scheme_set_box scheme_set_box +# define ts_scheme_set_box_star scheme_set_box_star # define ts_scheme_box_cas scheme_box_cas # define ts_scheme_checked_vector_cas scheme_checked_vector_cas # define ts_chaperone_set_mark chaperone_set_mark # define ts_scheme_chaperone_get_immediate_cc_mark scheme_chaperone_get_immediate_cc_mark # define ts_scheme_vector_length scheme_vector_length +# define ts_scheme_vector_star_length scheme_vector_star_length # define ts_scheme_flvector_length scheme_flvector_length #ifdef MZ_LONG_DOUBLE # define ts_scheme_extflvector_length scheme_extflvector_length @@ -235,19 +245,21 @@ # define ts_call_with_values_from_multiple_result call_with_values_from_multiple_result # define ts_scheme_checked_vector_ref scheme_checked_vector_ref # define ts_scheme_checked_vector_set scheme_checked_vector_set +# define ts_scheme_checked_vector_star_ref scheme_checked_vector_star_ref +# define ts_scheme_checked_vector_star_set scheme_checked_vector_star_set # define ts_scheme_checked_string_ref scheme_checked_string_ref # define ts_scheme_checked_string_set scheme_checked_string_set # define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref # define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set # define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref # define ts_scheme_checked_flvector_set scheme_checked_flvector_set +# define ts_scheme_checked_syntax_e scheme_checked_syntax_e #ifdef MZ_LONG_DOUBLE # define ts_scheme_checked_extflvector_ref scheme_checked_extflvector_ref # define ts_scheme_checked_extflvector_set scheme_checked_extflvector_set #endif # define ts_scheme_checked_fxvector_ref scheme_checked_fxvector_ref # define ts_scheme_checked_fxvector_set scheme_checked_fxvector_set -# define ts_scheme_checked_syntax_e scheme_checked_syntax_e # define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure # define ts_scheme_procedure_arity_includes scheme_procedure_arity_includes # define ts_apply_checked_fail apply_checked_fail @@ -256,10 +268,12 @@ # define ts_vector_check_chaperone_of vector_check_chaperone_of # define ts_scheme_checked_list_ref scheme_checked_list_ref # define ts_scheme_checked_list_tail scheme_checked_list_tail +# define ts_scheme_checked_hash_ref scheme_checked_hash_ref # define ts_scheme_struct_getter scheme_struct_getter # define ts_scheme_struct_setter scheme_struct_setter # define ts_scheme_checked_char_to_integer scheme_checked_char_to_integer # define ts_scheme_checked_integer_to_char scheme_checked_integer_to_char +# define ts_scheme_checked_symbol_interned_p scheme_checked_symbol_interned_p # define ts_scheme_check_not_undefined scheme_check_not_undefined # define ts_scheme_check_assign_not_undefined scheme_check_assign_not_undefined # define ts_scheme_foreign_ptr_ref scheme_foreign_ptr_ref diff -Nru racket-6.12+ppa1/src/racket/src/letrec_check.c racket-7.0+ppa1/src/racket/src/letrec_check.c --- racket-6.12+ppa1/src/racket/src/letrec_check.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/letrec_check.c 2018-07-27 22:12:02.000000000 +0000 @@ -814,14 +814,11 @@ if (SCHEME_VEC_SIZE(lam) <= 1) return lam; else { - Scheme_Object *vars = SCHEME_VEC_ELS(lam)[0]; - Scheme_Object *val = SCHEME_VEC_ELS(lam)[1]; - SCHEME_ASSERT(SCHEME_PAIRP(vars) || SCHEME_NULLP(vars), - "letrec_check_define_values: processing resolved code"); + Scheme_Object *val = SCHEME_VEC_ELS(lam)[0]; val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(lam)[1] = val; + SCHEME_VEC_ELS(lam)[0] = val; } return lam; @@ -882,33 +879,6 @@ return o; } -static Scheme_Object *letrec_check_define_syntaxes(Scheme_Object *lam, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - Scheme_Object *val; - val = SCHEME_VEC_ELS(lam)[3]; - - val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(lam)[3] = val; - - return lam; -} - -static Scheme_Object *letrec_check_begin_for_syntax(Scheme_Object *lam, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - Scheme_Object *l, *a, *val; - - l = SCHEME_VEC_ELS(lam)[2]; - - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - val = letrec_check_expr(a, frame, pos); - SCHEME_CAR(l) = val; - l = SCHEME_CDR(l); - } - - return lam; -} - static Scheme_Object *letrec_check_case_lambda(Scheme_Object *o, Letrec_Check_Frame *frame, Scheme_Object *pos) { Scheme_Case_Lambda *cl; @@ -959,43 +929,6 @@ return lam; } -static Scheme_Object *letrec_check_module(Scheme_Object *o, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - int i, cnt; - Scheme_Module *m; - Scheme_Object *val; - m = (Scheme_Module *)o; - - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; - } - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - for(i = 0; i < cnt; i++) { - val = SCHEME_VEC_ELS(m->bodies[0])[i]; - val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(m->bodies[0])[i] = val; - } - - { - /* check submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - letrec_check_expr(SCHEME_CAR(p), frame, pos); - p = SCHEME_CDR(p); - } - } - } - } - - return o; -} - static Scheme_Object *letrec_check_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -1041,7 +974,6 @@ case scheme_application3_type: return letrec_check_application3(expr, frame, pos); case scheme_sequence_type: - case scheme_splice_sequence_type: return letrec_check_sequence(expr, frame, pos); case scheme_branch_type: return letrec_check_branch(expr, frame, pos); @@ -1053,10 +985,7 @@ return letrec_check_lets(expr, frame, pos); case scheme_ir_toplevel_type: /* var ref to a top level */ return expr; - case scheme_ir_quote_syntax_type: - return expr; case scheme_variable_type: - case scheme_module_variable_type: scheme_signal_error("got top-level in wrong place"); return 0; case scheme_define_values_type: @@ -1065,10 +994,6 @@ return letrec_check_ref(expr, frame, pos); case scheme_set_bang_type: return letrec_check_set(expr, frame, pos); - case scheme_define_syntaxes_type: - return letrec_check_define_syntaxes(expr, frame, pos); - case scheme_begin_for_syntax_type: - return letrec_check_begin_for_syntax(expr, frame, pos); case scheme_case_lambda_sequence_type: return letrec_check_case_lambda(expr, frame, pos); case scheme_begin0_sequence_type: @@ -1078,17 +1003,14 @@ case scheme_with_immed_mark_type: scheme_signal_error("internal error: with-immediate-mark not expected before optimization"); return NULL; - case scheme_require_form_type: - return expr; - case scheme_module_type: - return letrec_check_module(expr, frame, pos); default: return expr; } } -Scheme_Object *scheme_letrec_check_expr(Scheme_Object *expr) +Scheme_Linklet *scheme_letrec_check_linklet(Scheme_Linklet *linklet) { + int i, cnt; Scheme_Object *val; Scheme_Object *init_pos = scheme_false; Letrec_Check_Frame *frame; @@ -1105,11 +1027,16 @@ positions. We use a list of numbers for the RHS of a `let[rec]-values` form with multiple variables. */ - val = letrec_check_expr(expr, frame, init_pos); + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for(i = 0; i < cnt; i++) { + val = SCHEME_VEC_ELS(linklet->bodies)[i]; + val = letrec_check_expr(val, frame, init_pos); + SCHEME_VEC_ELS(linklet->bodies)[i] = val; + } clean_dead_deferred_expr(*frame->deferred_chain); - return val; + return linklet; } /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/racket/src/linklet.c racket-7.0+ppa1/src/racket/src/linklet.c --- racket-6.12+ppa1/src/racket/src/linklet.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/linklet.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1732 @@ +/* + Racket + Copyright (c) 2004-2016 PLT Design Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schrunst.h" + +READ_ONLY Scheme_Object *scheme_varref_const_p_proc; +READ_ONLY Scheme_Object *scheme_varref_unsafe_p_proc; + +SHARED_OK Scheme_Hash_Tree *empty_hash_tree; + +SHARED_OK static int validate_compile_result = 0; +SHARED_OK static int recompile_every_compile = 0; + +static Scheme_Object *serializable_symbol; +static Scheme_Object *unsafe_symbol; +static Scheme_Object *static_symbol; +static Scheme_Object *constant_symbol; +static Scheme_Object *consistent_symbol; +static Scheme_Object *noncm_symbol; +static Scheme_Object *immediate_symbol; +static Scheme_Object *omitable_symbol; +static Scheme_Object *folding_symbol; + +THREAD_LOCAL_DECL(Scheme_Hash_Table *local_primitive_tables); + +static Scheme_Object *primitive_table(int argc, Scheme_Object **argv); +static Scheme_Object *primitive_to_position(int argc, Scheme_Object **argv); +static Scheme_Object *position_to_primitive(int argc, Scheme_Object **argv); +static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_p(int argc, Scheme_Object **argv); +static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_import_variables(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_export_variables(int argc, Scheme_Object **argv); + +static Scheme_Object *instance_p(int argc, Scheme_Object **argv); +static Scheme_Object *make_instance(int argc, Scheme_Object **argv); +static Scheme_Object *instance_name(int argc, Scheme_Object **argv); +static Scheme_Object *instance_data(int argc, Scheme_Object **argv); +static Scheme_Object *instance_variable_names(int argc, Scheme_Object **argv); +static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv); +static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv); +static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv); +static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv); +static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv); + +static Scheme_Object *variable_p(int argc, Scheme_Object **argv); +static Scheme_Object *variable_instance(int argc, Scheme_Object **argv); +static Scheme_Object *variable_const_p(int argc, Scheme_Object **argv); +static Scheme_Object *variable_unsafe_p(int argc, Scheme_Object **argv); + +static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Scheme_Linklet *linklet, + Scheme_Object *name, + Scheme_Object **_import_keys, + Scheme_Object *get_import, + int unsafe_mode, int static_mode); + +static Scheme_Object *_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt); + +static Scheme_Hash_Tree *push_prefix(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + Scheme_Hash_Tree *source_names); +static void pop_prefix(); +static Scheme_Object *suspend_prefix(); +static void resume_prefix(Scheme_Object *v); + +static Scheme_Bucket *make_bucket(Scheme_Object *key, Scheme_Object *val, Scheme_Instance *inst); + +#ifdef MZ_PRECISE_GC +static void mark_pruned_prefixes(struct NewGC *gc); +static int check_pruned_prefix(void *p); +#endif + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +/*========================================================================*/ +/* initialization */ +/*========================================================================*/ + +void scheme_init_linklet(Scheme_Startup_Env *env) +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + + REGISTER_SO(serializable_symbol); + REGISTER_SO(unsafe_symbol); + REGISTER_SO(static_symbol); + serializable_symbol = scheme_intern_symbol("serializable"); + unsafe_symbol = scheme_intern_symbol("unsafe"); + static_symbol = scheme_intern_symbol("static"); + + REGISTER_SO(constant_symbol); + REGISTER_SO(consistent_symbol); + constant_symbol = scheme_intern_symbol("constant"); + consistent_symbol = scheme_intern_symbol("consistent"); + + REGISTER_SO(noncm_symbol); + REGISTER_SO(immediate_symbol); + REGISTER_SO(omitable_symbol); + REGISTER_SO(folding_symbol); + noncm_symbol = scheme_intern_symbol("noncm"); + immediate_symbol = scheme_intern_symbol("immediate"); + omitable_symbol = scheme_intern_symbol("omitable"); + folding_symbol = scheme_intern_symbol("folding"); + + scheme_switch_prim_instance(env, "#%linklet"); + + ADD_IMMED_PRIM("primitive->compiled-position", primitive_to_position, 1, 1, env); + ADD_IMMED_PRIM("compiled-position->primitive", position_to_primitive, 1, 1, env); + ADD_IMMED_PRIM("primitive-in-category?", primitive_in_category_p, 2, 2, env); + + ADD_FOLDING_PRIM("linklet?", linklet_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY2("compile-linklet", compile_linklet, 1, 5, 2, 2, env); + ADD_PRIM_W_ARITY2("recompile-linklet", recompile_linklet, 1, 4, 2, 2, env); + ADD_IMMED_PRIM("eval-linklet", eval_linklet, 1, 1, env); + ADD_PRIM_W_ARITY("read-compiled-linklet", read_compiled_linklet, 1, 1, env); + ADD_PRIM_W_ARITY2("instantiate-linklet", instantiate_linklet, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY("linklet-import-variables", linklet_import_variables, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-export-variables", linklet_export_variables, 1, 1, env); + + ADD_FOLDING_PRIM("instance?", instance_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("make-instance", make_instance, 1, -1, env); + ADD_PRIM_W_ARITY("instance-name", instance_name, 1, 1, env); + ADD_PRIM_W_ARITY("instance-data", instance_data, 1, 1, env); + ADD_PRIM_W_ARITY("instance-variable-names", instance_variable_names, 1, 1, env); + ADD_PRIM_W_ARITY2("instance-variable-value", instance_variable_value, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY("instance-set-variable-value!", instance_set_variable_value, 3, 4, env); + ADD_PRIM_W_ARITY("instance-unset-variable!", instance_unset_variable, 2, 2, env); + + ADD_FOLDING_PRIM("linklet-directory?", linklet_directory_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("hash->linklet-directory", hash_to_linklet_directory, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-directory->hash", linklet_directory_to_hash, 1, 1, env); + + ADD_FOLDING_PRIM("linklet-bundle?", linklet_bundle_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("hash->linklet-bundle", hash_to_linklet_bundle, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-bundle->hash", linklet_bundle_to_hash, 1, 1, env); + + ADD_FOLDING_PRIM_UNARY_INLINED("variable-reference?", variable_p, 1, 1, 1, env); + ADD_IMMED_PRIM("variable-reference->instance", variable_instance, 1, 2, env); + + REGISTER_SO(scheme_varref_const_p_proc); + scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, + "variable-reference-constant?", + 1, 1); + scheme_addto_prim_instance("variable-reference-constant?", scheme_varref_const_p_proc, env); + + REGISTER_SO(scheme_varref_unsafe_p_proc); + scheme_varref_unsafe_p_proc = scheme_make_prim_w_arity(variable_unsafe_p, + "variable-reference-from-unsafe?", + 1, 1); + scheme_addto_prim_instance("variable-reference-from-unsafe?", scheme_varref_unsafe_p_proc, env); + + scheme_restore_prim_instance(env); + + if (scheme_getenv("PLT_VALIDATE_COMPILE")) { + /* Enables validation of bytecode as it is generated, + to double-check that the compiler is producing + valid bytecode as it should. */ + validate_compile_result = 1; + } + + { + /* Enables re-running the optimizer N times on every compilation. */ + const char *s; + s = scheme_getenv("PLT_RECOMPILE_COMPILE"); + if (s) { + int i = 0; + while ((s[i] >= '0') && (s[i] <= '9')) { + recompile_every_compile = (recompile_every_compile * 10) + (s[i]-'0'); + i++; + } + if (recompile_every_compile <= 0) + recompile_every_compile = 1; + else if (recompile_every_compile > 32) + recompile_every_compile = 32; + } + } +} + +void scheme_init_unsafe_linklet(Scheme_Startup_Env *env) +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + + scheme_switch_prim_instance(env, "#%linklet"); + + ADD_IMMED_PRIM("primitive-table", primitive_table, 1, 2, env); + + scheme_restore_prim_instance(env); +} + +void scheme_init_linklet_places(void) +{ +#ifdef MZ_PRECISE_GC + scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */ + scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; + GC_set_post_propagate_hook(mark_pruned_prefixes); + GC_set_treat_as_incremental_mark(scheme_prefix_type, check_pruned_prefix); +#endif +} + +/*========================================================================*/ +/* linklet and instance functions */ +/*========================================================================*/ + +static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]) +{ + Scheme_Hash_Table *table; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("primitive-table", "symbol?", 0, argc, argv); + if ((argc > 1) && !SCHEME_HASHTRP(argv[1])) + scheme_wrong_contract("primitive-table", "(and/c hash? immutable?)", 1, argc, argv); + + table = (Scheme_Hash_Table *)scheme_hash_get(scheme_startup_env->primitive_tables, argv[0]); + if (!table && local_primitive_tables) + table = (Scheme_Hash_Table *)scheme_hash_get(local_primitive_tables, argv[0]); + + if (!table) { + if (argc > 1) { + if (!local_primitive_tables) { + REGISTER_SO(local_primitive_tables); + local_primitive_tables = scheme_make_hash_table(SCHEME_hash_ptr); + } + scheme_hash_set(local_primitive_tables, argv[0], argv[1]); + } else + return scheme_false; + } + + if (argc < 2) + return (Scheme_Object *)table; + else + return scheme_void; +} + +static Scheme_Object *primitive_to_position(int argc, Scheme_Object **argv) +{ + Scheme_Object *pos; + pos = scheme_hash_get(scheme_startup_env->primitive_ids_table, argv[0]); + return (pos ? pos : scheme_false); +} + +static Scheme_Object *position_to_primitive(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + if (SCHEME_INTP(argv[0]) && (SCHEME_INT_VAL(argv[0]) >= 0)) + v = scheme_position_to_builtin(SCHEME_INT_VAL(argv[0])); + else + v = NULL; + return (v ? v : scheme_false); +} + +static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v, *cat; + int r; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("primitive-in-category?", "symbol?", 0, argc, argv); + cat = argv[1]; + if (!SCHEME_SYMBOLP(cat)) + scheme_wrong_contract("primitive-in-category?", "symbol?", 1, argc, argv); + + v = scheme_hash_get(scheme_startup_env->all_primitives_table, argv[0]); + if (!v) + r = 0; + else if (SCHEME_PRIMP(v)) { + int opt = ((Scheme_Prim_Proc_Header *)v)->flags & SCHEME_PRIM_OPT_MASK; + if (SAME_OBJ(cat, noncm_symbol)) { + r = (opt >= SCHEME_PRIM_OPT_NONCM); + /* Remove closures from noncm */ + if (((Scheme_Prim_Proc_Header *)v)->flags & SCHEME_PRIM_IS_CLOSURE) + r = 0; + } else if (SAME_OBJ(cat, immediate_symbol)) + r = (opt >= SCHEME_PRIM_OPT_IMMEDIATE); + else if (SAME_OBJ(cat, folding_symbol)) + r = (opt >= SCHEME_PRIM_OPT_FOLDING); + else if (SAME_OBJ(cat, omitable_symbol)) + r = (SCHEME_PRIM_PROC_OPT_FLAGS(v) & (SCHEME_PRIM_IS_OMITABLE_ANY + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL + | SCHEME_PRIM_IS_UNSAFE_OMITABLE)); + else + r = 0; + } else + r = 0; + + return (r ? scheme_true : scheme_false); +} + +static Scheme_Object *linklet_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type) + ? scheme_true + : scheme_false); +} + +static void check_linklet_allowed(const char *who, Scheme_Linklet *linklet) +{ + if (linklet->reject_eval) { + scheme_raise_exn(MZEXN_FAIL, + "%s: cannot use linklet loaded with non-original code inspector", + who); + } +} + +void extract_import_info(const char *who, int argc, Scheme_Object **argv, + Scheme_Object **_import_keys, Scheme_Object **_get_import) +{ + + if (argc > 2) { + *_import_keys = argv[2]; + if (SCHEME_FALSEP(*_import_keys)) + *_import_keys = NULL; + else if (!SCHEME_VECTORP(*_import_keys)) + scheme_wrong_contract(who, "(or/c vector? #f)", 2, argc, argv); + } else + *_import_keys = NULL; + + if (argc > 3) { + scheme_check_proc_arity2(who, 1, 3, argc, argv, 1); + if (SCHEME_TRUEP(argv[3])) { + if (!*_import_keys) { + scheme_contract_error(who, + "no vector supplied for import keys, but import-getting function provided;\n" + " the function argument must be `#f' when the vector argument is `#f'", + "import-getting function", 1, argv[3], + NULL); + } + *_get_import = argv[3]; + } else + *_get_import = NULL; + } else + *_get_import = NULL; +} + +static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Object *name, *e, *import_keys, *get_import, *a[2]; + int unsafe = 0, static_mode = 0; + + /* Last argument, `serializable?`, is ignored */ + + extract_import_info("compile-linklet", argc, argv, &import_keys, &get_import); + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) + name = argv[1]; + else + name = scheme_intern_symbol("anonymous"); + + e = argv[0]; + if (!SCHEME_STXP(e)) + e = scheme_datum_to_syntax(e, scheme_false, DTS_CAN_GRAPH); + + if (argc > 4) { + Scheme_Object *flags, *redundant = NULL, *flag; + int serializable = 0; + + flags = argv[4]; + while (SCHEME_PAIRP(flags)) { + flag = SCHEME_CAR(flags); + if (SAME_OBJ(flag, serializable_symbol)) { + if (serializable && !redundant) + redundant = flag; + serializable = 1; + } else if (SAME_OBJ(flag, unsafe_symbol)) { + if (unsafe && !redundant) + redundant = flag; + unsafe = 1; + } else if (SAME_OBJ(flag, static_symbol)) { + if (static_mode && !redundant) + redundant = flag; + static_mode = 1; + } else + break; + flags = SCHEME_CDR(flags); + } + if (!SCHEME_NULLP(flags)) + scheme_wrong_contract("compile-linklet", "(listof/c 'serializable 'unsafe)", 4, argc, argv); + if (redundant) + scheme_contract_error("compile-linklet", "redundant option", + "redundant option", 1, redundant, + "supplied options", 1, argv[4], + NULL); + } + + e = (Scheme_Object *)compile_and_or_optimize_linklet(e, NULL, name, &import_keys, get_import, + unsafe, static_mode); + + if (import_keys) { + a[0] = e; + a[1] = import_keys; + return scheme_values(2, a); + } else + return e; +} + +static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Object *name, *import_keys, *get_import, *a[2]; + Scheme_Linklet *linklet; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("recompile-linklet", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + check_linklet_allowed("recompile-linklet", linklet); + + extract_import_info("recompile-linklet", argc, argv, &import_keys, &get_import); + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) + name = argv[1]; + else + name = ((Scheme_Linklet *)argv[0])->name; + + if (import_keys && (SCHEME_VEC_SIZE(import_keys) != SCHEME_VEC_SIZE(linklet->importss))) { + scheme_contract_error("recompile-linklet", + "given number of import keys does not match import count of linklet", + "linklet", 1, linklet, + "linklet imports", 1, scheme_make_integer(SCHEME_VEC_SIZE(linklet->importss)), + "given keys", 1, scheme_make_integer(SCHEME_VEC_SIZE(import_keys)), + NULL); + } + + linklet = compile_and_or_optimize_linklet(NULL, linklet, name, &import_keys, get_import, 0, 0); + + if (import_keys) { + a[0] = (Scheme_Object *)linklet; + a[1] = import_keys; + + return scheme_values(2, a); + } else + return (Scheme_Object *)linklet; +} + +static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv) +{ + /* "Evaluation" is not necessary before instantiation, but it makes + the linklet JIT-prepared (so the JIT-prepared linklet could be + reused, for example) while also making the linklet ineligible for + marshaling. */ + Scheme_Linklet *linklet; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("eval-linklet", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + check_linklet_allowed("eval-linklet", linklet); + + if (!linklet->jit_ready) { + Scheme_Object *b; + b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); + if (SCHEME_TRUEP(b)) { + /* Make a JIT-prepable linklet --- but don't actually prep until + forced by instantiation. */ + linklet = scheme_jit_linklet(linklet, 1); + } + } + + return (Scheme_Object *)linklet; +} + +static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv) +{ + if (!SCHEME_INPUT_PORTP(argv[0])) + scheme_wrong_contract("read-compiled-linklet", "input-port?", 0, argc, argv); + + return scheme_read_compiled(argv[0]); +} + +static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + Scheme_Object *l; + Scheme_Instance *inst, **instances; + int len = 0, num_importss, use_prompt, return_instance; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("instantiate-linklet", "linklet?", 0, argc, argv); + + l = argv[1]; + while (!SCHEME_NULLP(l)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_instance_type)) + break; + l = SCHEME_CDR(l); + len++; + } + if (!SCHEME_NULLP(l)) + scheme_wrong_contract("instantiate-linklet", "(listof instance?)", 1, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + check_linklet_allowed("instantiate-linklet", linklet); + num_importss = SCHEME_VEC_SIZE(linklet->importss); + if (len != num_importss) + scheme_contract_error("instantiate-linklet", + "given number of instances does not match import count of linklet", + "linklet", 1, linklet, + "expected imports", 1, scheme_make_integer(num_importss), + "given instances", 1, scheme_make_integer(len), + NULL); + + if ((argc > 2) && SCHEME_TRUEP(argv[2])) { + if (!SAME_TYPE(SCHEME_TYPE(argv[2]), scheme_instance_type)) + scheme_wrong_contract("instantiate-linklet", "(or/c instance? #f)", 2, argc, argv); + inst = (Scheme_Instance *)argv[2]; + return_instance = 0; + } else { + inst = scheme_make_instance(linklet->name, scheme_false); + return_instance = 1; + } + + use_prompt = ((argc < 4) || SCHEME_TRUEP(argv[3])); + + instances = MALLOC_N(Scheme_Instance*, len); + l = argv[1]; + len = 0; + while (!SCHEME_NULLP(l)) { + instances[len++] = (Scheme_Instance *)SCHEME_CAR(l); + l = SCHEME_CDR(l); + } + + if (!return_instance) + return _instantiate_linklet_multi(linklet, inst, len, instances, use_prompt); + else { + (void)_instantiate_linklet_multi(linklet, inst, len, instances, use_prompt); + return (Scheme_Object *)inst; + } +} + +static Scheme_Object *linklet_import_variables(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + int i, j; + Scheme_Object *l, *ll = scheme_null; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("linklet-import-variables", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + for (i = SCHEME_VEC_SIZE(linklet->importss); i--; ) { + l = scheme_null; + for (j = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j--; ) { + l = scheme_make_pair(SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j], l); + } + ll = scheme_make_pair(l, ll); + } + + return ll; +} + +static Scheme_Object *linklet_export_variables(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + int i; + Scheme_Object *l = scheme_null; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("linklet-export-variables", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + for (i = linklet->num_exports; i--; ) { + l = scheme_make_pair(SCHEME_VEC_ELS(linklet->defns)[i], l); + } + + return l; +} + +static Scheme_Object *instance_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type) + ? scheme_true + : scheme_false); +} + +static int parse_constantness_flag(const char *who, int i, int argc, Scheme_Object **argv) +{ + int set_flags = 0; + + if (SCHEME_FALSEP(argv[i])) + set_flags = 0; + else if (SAME_OBJ(argv[i], constant_symbol)) + set_flags = GLOB_IS_IMMUTATED; + else if (SAME_OBJ(argv[i], consistent_symbol)) + set_flags = GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT; + else + scheme_wrong_contract(who, "(or/c #f 'constant 'consistent)", i, argc, argv); + + return set_flags; +} + +static Scheme_Object *make_instance(int argc, Scheme_Object **argv) +{ + Scheme_Instance *inst; + int i; + + inst = scheme_make_instance(argv[0], (argc > 1) ? argv[1] : scheme_false); + + if (argc > 3) { + Scheme_Bucket **a, *b; + int set_flags = 0; + + set_flags = parse_constantness_flag("make-instance", 2, argc, argv); + + i = 3; + a = MALLOC_N(Scheme_Bucket *, (argc - i) >> 1); + + for (; i < argc; i += 2) { + if (!SCHEME_SYMBOLP(argv[i])) + scheme_wrong_contract("make-instance", "symbol?", i, argc, argv); + if (i+1 == argc) + scheme_contract_error("make-instance", + "value missing for variable name", + "variable name", 1, argv[i], + NULL); + b = make_bucket(argv[i], argv[i+1], inst); + if (set_flags) + ((Scheme_Bucket_With_Flags *)b)->flags |= set_flags; + a[(i-2)>>1] = b; + } + + inst->array_size = (argc-2)>>1; + inst->variables.a = a; + } + + return (Scheme_Object *)inst; +} + +static Scheme_Object *instance_name(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-name", "instance?", 0, argc, argv); + + return ((Scheme_Instance *)argv[0])->name; +} + +static Scheme_Object *instance_data(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-data", "instance?", 0, argc, argv); + + return ((Scheme_Instance *)argv[0])->data; +} + +static Scheme_Object *instance_variable_names(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + int i; + Scheme_Object *l = scheme_null; + Scheme_Instance *inst; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-variable-names", "instance?", 0, argc, argv); + + inst = (Scheme_Instance *)argv[0]; + + if (inst->array_size) { + for (i = inst->array_size; i--; ) { + l = scheme_make_pair((Scheme_Object *)inst->variables.a[i]->key, l); + } + } else if (inst->variables.bt) { + for (i = inst->variables.bt->size; i--; ) { + b = inst->variables.bt->buckets[i]; + if (b && b->val) { + l = scheme_make_pair((Scheme_Object *)b->key, l); + } + } + } + + return l; +} + +static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv) +{ + Scheme_Instance *inst; + Scheme_Bucket *b; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-variable-value", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-variable-value", "symbol?", 1, argc, argv); + + inst = (Scheme_Instance *)argv[0]; + + b = scheme_instance_variable_bucket_or_null(argv[1], inst); + if (b && b->val) + return b->val; + + if (argc > 2) { + if (SCHEME_PROCP(argv[2])) + return _scheme_tail_apply(argv[2], 0, NULL); + return argv[2]; + } + + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "instance-variable-value: instance variable not found\n" + " instance: %V\n" + " name: %S", + inst->name, + argv[1]); + return NULL; +} + +static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + int set_flags = 0; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-set-variable-value!", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-set-variable-value!", "symbol?", 1, argc, argv); + if (argc > 3) + set_flags = parse_constantness_flag("instance-set-variable-value!", 3, argc, argv); + + b = scheme_instance_variable_bucket(argv[1], (Scheme_Instance *)argv[0]); + + scheme_set_global_bucket("instance-set-variable-value!", b, argv[2], 1); + + b->val = argv[2]; + if (set_flags) + ((Scheme_Bucket_With_Flags *)b)->flags |= set_flags; + + return scheme_void; +} + +static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-unset-variable!", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-unset-variable!", "symbol?", 1, argc, argv); + + b = scheme_instance_variable_bucket(argv[1], (Scheme_Instance *)argv[0]); + b->val = NULL; + + return scheme_void; +} + +static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type)) + scheme_wrong_contract("linklet-directory->hash", "linklet-directory?", 0, argc, argv); + + return SCHEME_PTR_VAL(argv[0]); +} + +static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv) +{ + mzlonglong pos; + Scheme_Object *k, *v; + Scheme_Hash_Tree *hash; + + if (!SCHEME_HASHTRP(argv[0]) + || !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0]))) + scheme_wrong_contract("hash->linklet-directory", + "(and/c hash? hash-eq? immutable? (not/c impersonator?))", + 0, argc, argv); + hash = (Scheme_Hash_Tree *)argv[0]; + + /* mapping: #f -> bundle, sym -> linklet directory */ + + pos = scheme_hash_tree_next(hash, -1); + while (pos != -1) { + scheme_hash_tree_index(hash, pos, &k, &v); + if (SCHEME_FALSEP(k)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)) + scheme_contract_error("hash->linklet-directory", + "value for #f key is not a linklet bundle", + "value", 1, v, + NULL); + } else if (SCHEME_SYMBOLP(k)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type)) + scheme_contract_error("hash->linklet-directory", + "value for symbol key is not a linklet directory", + "key", 1, k, + "value", 1, v, + NULL); + } else { + scheme_contract_error("hash->linklet-directory", + "key in given hash is not #f or a symbol", + "key", 1, k, + NULL); + } + pos = scheme_hash_tree_next(hash, pos); + } + + v = scheme_alloc_small_object(); + v->type = scheme_linklet_directory_type; + SCHEME_PTR_VAL(v) = argv[0]; + return v; +} + +static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type)) + scheme_wrong_contract("linklet-bundle->hash", "linklet-bundle?", 0, argc, argv); + + return SCHEME_PTR_VAL(argv[0]); +} + +static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv) +{ + mzlonglong pos; + Scheme_Object *k, *v; + Scheme_Hash_Tree *hash; + + if (!SCHEME_HASHTRP(argv[0]) + || !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0]))) + scheme_wrong_contract("hash->linklet-bundle", + "(and/c hash? hash-eq? immutable? (not/c impersonator?))", + 0, argc, argv); + + hash = (Scheme_Hash_Tree *)argv[0]; + + /* mapping: keys must be symbols and fixnums */ + + pos = scheme_hash_tree_next(hash, -1); + while (pos != -1) { + scheme_hash_tree_index(hash, pos, &k, &v); + if (!SCHEME_SYMBOLP(k) && !SCHEME_INTP(k)) { + scheme_contract_error("hash->linklet-bundle", + "key in given hash is not a symbol or fixnum", + "key", 1, k, + NULL); + } + pos = scheme_hash_tree_next(hash, pos); + } + + v = scheme_alloc_small_object(); + v->type = scheme_linklet_bundle_type; + SCHEME_PTR_VAL(v) = argv[0]; + return v; +} + +static Scheme_Object *variable_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *variable_instance(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference->instance", "variable-reference?", 0, argc, argv); + + if ((argc < 2) || SCHEME_FALSEP(argv[1])) { + /* Definition instance might be a primitive-table symbol, or it might be #f for "anonymous": */ + v = SCHEME_PTR1_VAL(argv[0]); + if (SCHEME_SYMBOLP(v) || SCHEME_FALSEP(v)) + return v; + else if (SAME_OBJ(v, scheme_true)) + return SCHEME_PTR2_VAL(argv[0]); /* same as use instance for a local */ + else { + v = (Scheme_Object *)scheme_get_bucket_home((Scheme_Bucket *)v); + if (!v) { + /* The definition instance was GCed? Return the use-site instance */ + return SCHEME_PTR2_VAL(argv[0]); + } + return v; + } + } else { + /* Get use instance: */ + return SCHEME_PTR2_VAL(argv[0]); + } +} + +static Scheme_Object *variable_const_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference-constant?", "variable-reference?", 0, argc, argv); + + if (SCHEME_VARREF_FLAGS(v) & VARREF_IS_CONSTANT) + return scheme_true; + + v = SCHEME_PTR1_VAL(v); + if (!SCHEME_FALSEP(v)) { + if (SCHEME_SYMBOLP(v) + || (((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_IMMUTATED)) + return scheme_true; + } + + return scheme_false; +} + +static Scheme_Object *variable_unsafe_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference-from-unsafe?", "variable-reference?", 0, argc, argv); + + if (SCHEME_VARREF_FLAGS(v) & VARREF_FROM_UNSAFE) + return scheme_true; + else + return scheme_false; +} + +/*========================================================================*/ +/* instance variable buckets */ +/*========================================================================*/ + +Scheme_Object *scheme_get_home_weak_link(Scheme_Instance *i) +{ + if (!i->weak_self_link) { + Scheme_Object *wb; + if (scheme_starting_up) + wb = scheme_box((Scheme_Object *)i); + else + wb = scheme_make_weak_box((Scheme_Object *)i); + i->weak_self_link = wb; + } + + return i->weak_self_link; +} + +Scheme_Instance *scheme_get_bucket_home(Scheme_Bucket *b) +{ + Scheme_Object *l; + + l = ((Scheme_Bucket_With_Home *)b)->home_link; + if (l) { + if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) + return (Scheme_Instance *)l; + else + return (Scheme_Instance *)SCHEME_WEAK_BOX_VAL(l); + } else + return NULL; +} + +void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Instance *e) +{ + if (!((Scheme_Bucket_With_Home *)b)->home_link) { + if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) + ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e; + else { + Scheme_Object *link; + link = scheme_get_home_weak_link(e); + ((Scheme_Bucket_With_Home *)b)->home_link = link; + } + } +} + +static Scheme_Bucket *make_bucket(Scheme_Object *key, Scheme_Object *val, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + b = (Scheme_Bucket *)MALLOC_ONE_TAGGED(Scheme_Bucket_With_Home); + b->so.type = scheme_variable_type; + b->key = (char *)key; + b->val = val; + scheme_set_bucket_home(b, inst); + + return b; +} + +Scheme_Instance *scheme_make_instance(Scheme_Object *name, Scheme_Object *data) +{ + Scheme_Instance *inst; + + if (!empty_hash_tree) { + REGISTER_SO(empty_hash_tree); + empty_hash_tree = scheme_make_hash_tree(0); + } + + inst = MALLOC_ONE_TAGGED(Scheme_Instance); + inst->iso.so.type = scheme_instance_type; + + inst->name = (name ? name : scheme_false); + inst->data = data; + + inst->source_names = empty_hash_tree; + + if (scheme_starting_up) { + /* Avoid recording procedure-implementation details in bytecode + that uses the instances that are created on startup. */ + SCHEME_INSTANCE_FLAGS(inst) |= SCHEME_INSTANCE_USE_IMPRECISE; + } + + return inst; +} + +void scheme_instance_to_hash_mode(Scheme_Instance *inst, int size_estimate) +{ + Scheme_Bucket_Table *variables; + Scheme_Bucket **a; + + if (inst->array_size) { + size_estimate = inst->array_size * 2; + a = inst->variables.a; + } else + a = NULL; + + variables = scheme_make_bucket_table(size_estimate, SCHEME_hash_ptr); + variables->with_home = 1; + + inst->variables.bt = variables; + inst->array_size = 0; + + if (a) { + size_estimate >>= 1; + while (size_estimate--) { + scheme_add_bucket_to_table(inst->variables.bt, a[size_estimate]); + } + } +} + +Scheme_Bucket *scheme_instance_variable_bucket(Scheme_Object *symbol, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + if (inst->array_size) { + int i; + for (i = inst->array_size; i--; ) { + b = inst->variables.a[i]; + if (SAME_OBJ(symbol, (Scheme_Object *)b->key)) + return b; + } + } + + if (inst->array_size || !inst->variables.bt) + scheme_instance_to_hash_mode(inst, 0); + + b = scheme_bucket_from_table(inst->variables.bt, (char *)symbol); + ASSERT_IS_VARIABLE_BUCKET(b); + if (SCHEME_FALSEP(symbol)) + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_STRONG_HOME_LINK; + + scheme_set_bucket_home(b, inst); + + return b; +} + +Scheme_Bucket *scheme_instance_variable_bucket_or_null(Scheme_Object *symbol, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + if (inst->array_size) { + int i; + for (i = inst->array_size; i--; ) { + b = inst->variables.a[i]; + if (SAME_OBJ(symbol, (Scheme_Object *)b->key)) + return b; + } + return NULL; + } else if (!inst->variables.bt) + return NULL; + + b = scheme_bucket_or_null_from_table(inst->variables.bt, (char *)symbol, 0); + if (b) { + ASSERT_IS_VARIABLE_BUCKET(b); + scheme_set_bucket_home(b, inst); + } + + return b; +} + +/*========================================================================*/ +/* managing bucket names */ +/*========================================================================*/ + +static Scheme_Object *generate_bucket_name(Scheme_Object *old_name, Scheme_Instance *instance) +{ + int search_start = 0; + char buf[32]; + Scheme_Object *n; + + while (1) { + sprintf(buf, ".%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + n = scheme_symbol_append(old_name, n); + if (!scheme_instance_variable_bucket_or_null(n, instance)) + return n; + search_start++; + } +} + +static Scheme_Hash_Tree *update_source_names(Scheme_Hash_Tree *source_names, + Scheme_Object *old_name, Scheme_Object *new_name) +{ + Scheme_Object *v; + + v = scheme_hash_tree_get(source_names, old_name); + if (v) + return scheme_hash_tree_set(source_names, new_name, v); + else + return source_names; +} + +/*========================================================================*/ +/* compiling linklets */ +/*========================================================================*/ + +static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Scheme_Linklet *linklet, + Scheme_Object *name, + Scheme_Object **_import_keys, Scheme_Object *get_import, + int unsafe_mode, int static_mode) +{ + Scheme_Config *config; + int enforce_const, set_undef, can_inline; + + config = scheme_current_config(); + enforce_const = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); + set_undef = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_ALLOW_SET_UNDEFINED)); + can_inline = SCHEME_FALSEP(scheme_get_param(config, MZCONFIG_DISALLOW_INLINE)); + + if (_import_keys && !*_import_keys) + _import_keys = NULL; + + if (!linklet) { + linklet = scheme_compile_linklet(form, set_undef, (_import_keys ? *_import_keys : NULL)); + linklet = scheme_letrec_check_linklet(linklet); + } else { + linklet = scheme_unresolve_linklet(linklet, (set_undef ? COMP_ALLOW_SET_UNDEFINED : 0)); + } + linklet->name = name; + linklet = scheme_optimize_linklet(linklet, enforce_const, can_inline, unsafe_mode, + _import_keys, get_import); + + linklet = scheme_resolve_linklet(linklet, enforce_const, static_mode); + linklet = scheme_sfs_linklet(linklet); + + if (recompile_every_compile) { + int i; + for (i = recompile_every_compile; i--; ) { + linklet = scheme_unresolve_linklet(linklet, (set_undef ? COMP_ALLOW_SET_UNDEFINED : 0)); + linklet = scheme_optimize_linklet(linklet, enforce_const, can_inline, unsafe_mode, + _import_keys, get_import); + linklet = scheme_resolve_linklet(linklet, enforce_const, static_mode); + linklet = scheme_sfs_linklet(linklet); + } + } + + if (validate_compile_result) + scheme_validate_linklet(NULL, linklet); + + return linklet; +} + +Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name) +{ + return compile_and_or_optimize_linklet(form, NULL, name, NULL, NULL, 0, 1); +} + +/*========================================================================*/ +/* instantiating linklets */ +/*========================================================================*/ + +static Scheme_Object *body_one_expr(void *prefix_plus_expr, int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + resume_prefix(SCHEME_CAR((Scheme_Object *)prefix_plus_expr)); + v = _scheme_eval_linked_expr_multi(SCHEME_CDR((Scheme_Object *)prefix_plus_expr)); + (void)suspend_prefix(); + + return v; +} + +static int needs_prompt(Scheme_Object *e) +{ + Scheme_Type t; + + while (1) { + t = SCHEME_TYPE(e); + if (t > _scheme_values_types_) + return 0; + + switch (t) { + case scheme_lambda_type: + case scheme_toplevel_type: + case scheme_local_type: + case scheme_local_unbox_type: + return 0; + case scheme_case_lambda_sequence_type: + return 0; + case scheme_define_values_type: + e = SCHEME_VEC_ELS(e)[0]; + break; + case scheme_inline_variant_type: + e = SCHEME_VEC_ELS(e)[0]; + break; + default: + return 1; + } + } +} + +Scheme_Object *scheme_linklet_run_finish(Scheme_Linklet* linklet, Scheme_Instance *instance, int use_prompt) +{ + Scheme_Thread *p; + Scheme_Object *body, *save_prefix, *v = scheme_void; + int i, cnt; + mz_jmp_buf newbuf, * volatile savebuf; + + p = scheme_current_thread; + savebuf = p->error_buf; + p->error_buf = &newbuf; + + if (scheme_setjmp(newbuf)) { + Scheme_Thread *p2; + p2 = scheme_current_thread; + p2->error_buf = savebuf; + scheme_longjmp(*savebuf, 1); + } else { + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + body = SCHEME_VEC_ELS(linklet->bodies)[i]; + if (use_prompt && needs_prompt(body)) { + /* We need to push the prefix after the prompt is set, so + restore the runstack and then add the prefix back. */ + save_prefix = suspend_prefix(); + v = _scheme_call_with_prompt_multi(body_one_expr, + scheme_make_raw_pair(save_prefix, body)); + resume_prefix(save_prefix); + + /* Double-check that the definition-installing part of the + continuation was not skipped. Otherwise, the compiler would + not be able to assume that a variable reference that is + lexically later (incuding a reference to an imported + variable) always references a defined variable. Putting the + prompt around a definition's RHS might be a better + approach, but that would change the language (so mabe next + time). */ + if (SAME_TYPE(SCHEME_TYPE(body), scheme_define_values_type)) { + int vcnt, j; + + vcnt = SCHEME_VEC_SIZE(body) - 1; + for (j = 0; j < vcnt; j++) { + Scheme_Object *var; + Scheme_Prefix *toplevels; + Scheme_Bucket *b; + + var = SCHEME_VEC_ELS(body)[j+1]; + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + + if (!b->val) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, + b->key, + "define-values: skipped variable definition;\n" + " cannot continue without defining variable\n" + " variable: %S\n" + " in module: %D", + (Scheme_Object *)b->key, + instance->name); + } + } + } + } else + v = _scheme_eval_linked_expr_multi(body); + + if (i < (cnt - 1)) + scheme_ignore_result(v); + } + + p = scheme_current_thread; + p->error_buf = savebuf; + } + + return v; +} + +static Scheme_Object *eval_linklet_body(Scheme_Linklet *linklet, Scheme_Instance *instance, int use_prompt) +{ +#ifdef MZ_USE_JIT + if (use_prompt) + return scheme_linklet_run_start(linklet, instance, scheme_make_pair(instance->name, scheme_true)); +#endif + + return scheme_linklet_run_finish(linklet, instance, use_prompt); +} + +static void *instantiate_linklet_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Linklet *linklet = (Scheme_Linklet *)p->ku.k.p1; + Scheme_Instance *instance = (Scheme_Instance *)p->ku.k.p2; + Scheme_Instance **instances = (Scheme_Instance **)p->ku.k.p3; + int multi = p->ku.k.i1; + int num_instances = p->ku.k.i2; + int use_prompt = p->ku.k.i3; + int depth; + Scheme_Object *b, *v; + Scheme_Hash_Tree *source_names; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + depth = linklet->max_let_depth; + if (!scheme_check_runstack(depth)) { + p->ku.k.p1 = linklet; + p->ku.k.p2 = instance; + p->ku.k.p3 = instances; + p->ku.k.i1 = multi; + p->ku.k.i2 = num_instances; + p->ku.k.i3 = use_prompt; + return (Scheme_Object *)scheme_enlarge_runstack(depth, instantiate_linklet_k); + } + + if (!linklet->jit_ready) { + b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); + if (SCHEME_TRUEP(b)) + linklet = scheme_jit_linklet(linklet, 2); + } else { + linklet = scheme_jit_linklet(linklet, 2); + } + + /* Pushng the prefix looks up imported variables */ + source_names = push_prefix(linklet, instance, num_instances, instances, linklet->source_names); + + /* For variables in this instances, merge source-name info from the + linklet to the instance */ + if (source_names->count) { + if (instance->source_names->count) { + mzlonglong pos; + Scheme_Hash_Tree *ht = instance->source_names; + Scheme_Object *k, *v; + pos = scheme_hash_tree_next(source_names, -1); + while (pos != -1) { + scheme_hash_tree_index(source_names, pos, &k, &v); + ht = scheme_hash_tree_set(ht, k, v); + pos = scheme_hash_tree_next(source_names, pos); + } + instance->source_names = ht; + } else + instance->source_names = source_names; + } + + v = eval_linklet_body(linklet, instance, use_prompt); + + pop_prefix(); + + if (!multi) + v = scheme_check_one_value(v); + + return (void *)v; +} + +static Scheme_Object *do_instantiate_linklet(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt, int multi, int top) +{ + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = linklet; + p->ku.k.p2 = instance; + p->ku.k.p3 = instances; + + p->ku.k.i1 = multi; + p->ku.k.i2 = num_instances; + p->ku.k.i3 = use_prompt; + + if (top) + return (Scheme_Object *)scheme_top_level_do(instantiate_linklet_k, 1); + else + return (Scheme_Object *)instantiate_linklet_k(); +} + +static Scheme_Object *_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt) +{ + return do_instantiate_linklet(linklet, instance, num_instances, instances, use_prompt, 1, 0); +} + +Scheme_Object *scheme_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt) +{ + return do_instantiate_linklet(linklet, instance, num_instances, instances, use_prompt, 1, 1); +} + +/*========================================================================*/ +/* creating/pushing prefix for top-levels and syntax objects */ +/*========================================================================*/ + +Scheme_Prefix *scheme_allocate_linklet_prefix(Scheme_Linklet *linklet, int extra) +{ + int num_defns, n; + + num_defns = SCHEME_VEC_SIZE(linklet->defns); + + n = 1 + linklet->num_total_imports + num_defns + extra; + + return scheme_allocate_prefix(n); +} + +Scheme_Prefix *scheme_allocate_prefix(intptr_t n) +{ + Scheme_Prefix *pf; + int tl_map_len; + + tl_map_len = (n + 31) / 32; + + pf = scheme_malloc_tagged(sizeof(Scheme_Prefix) + + ((n-mzFLEX_DELTA) * sizeof(Scheme_Object *)) + + (tl_map_len * sizeof(int))); + pf->iso.so.type = scheme_prefix_type; + pf->num_slots = n; + + return pf; +} + +static Scheme_Hash_Tree *push_prefix(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + Scheme_Hash_Tree *source_names) +{ + Scheme_Object **rs, *v; + Scheme_Prefix *pf; + int i, j, pos, num_importss, num_defns, starts_empty; + GC_CAN_IGNORE const char *bad_reason = NULL; + + rs = MZ_RUNSTACK; + + num_importss = SCHEME_VEC_SIZE(linklet->importss); + num_defns = SCHEME_VEC_SIZE(linklet->defns); + + pf = linklet->static_prefix; + if (!pf) + pf = scheme_allocate_linklet_prefix(linklet, 0); + + --rs; + MZ_RUNSTACK = rs; + rs[0] = (Scheme_Object *)pf; + + pos = 0; + + /* Initial bucket, key by #f, provides access to the instance */ + if (linklet->need_instance_access) + v = (Scheme_Object *)scheme_instance_variable_bucket(scheme_false, instance); + else + v = NULL; + pf->a[pos++] = v; + + for (j = 0; j < num_importss; j++) { + int num_imports = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[j]); + for (i = 0; i < num_imports; i++) { + v = SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[j])[i]; + v = (Scheme_Object *)scheme_instance_variable_bucket(v, (Scheme_Instance *)instances[j]); + + if (v) { + if (!((Scheme_Bucket *)v)->val) { + bad_reason = "is unintialized"; + v = NULL; + } else if (linklet->import_shapes) { + Scheme_Object *shape = SCHEME_VEC_ELS(linklet->import_shapes)[pos-1]; + if (SAME_OBJ(shape, scheme_void)) { + /* Optimizer assumed constant; if it isn't, too bad */ + bad_reason = NULL; + } else if (SAME_OBJ(shape, scheme_true)) { + if (!(((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_CONSISTENT)) { + bad_reason = "is not a procedure or structure-type constant across all instantiations"; + v = NULL; + } + } else if (SCHEME_TRUEP(shape)) { + if (!scheme_get_or_check_procedure_shape(((Scheme_Bucket *)v)->val, shape, 0)) { + bad_reason = "has the wrong procedure or structure-type shape"; + v = NULL; + } + } + } + } else + bad_reason = "is not exported"; + + if (!v) { + scheme_signal_error("instantiate-linklet: mismatch;\n" + " reference to a variable that %s;\n" + " possibly, bytecode file needs re-compile because dependencies changed\n" + " name: %D\n" + " exporting instance: %D\n" + " importing instance: %D", + bad_reason, + SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[j])[i], + instances[j]->name, + instance->name); + } + pf->a[pos++] = v; + } + } + + starts_empty = (!instance->array_size && !instance->variables.bt); + + if (!num_defns) { + /* don't allocate empty array, etc. */ + } else if (starts_empty && (num_defns < 10)) { + /* Faster to build an array-shaped instance (which will be + converted to a bucket table on demand, if necessary) */ + Scheme_Bucket **a, *b; + + a = MALLOC_N(Scheme_Bucket *, num_defns); + for (i = 0; i < num_defns; i++) { + v = SCHEME_VEC_ELS(linklet->defns)[i]; + if (SCHEME_FALSEP(v)) { + pf->a[pos++] = NULL; + } else { + b = make_bucket(v, NULL, instance); + a[i] = b; + pf->a[pos++] = (Scheme_Object *)b; + } + } + + instance->array_size = num_defns; + instance->variables.a = a; + } else { + /* General case: bucket-table instance: */ + for (i = 0; i < num_defns; i++) { + v = SCHEME_VEC_ELS(linklet->defns)[i]; + if (SCHEME_FALSEP(v)) { + v = NULL; + } else { + if ((i >= linklet->num_exports) && !starts_empty) { + /* avoid conflict with any existing bucket */ + if (scheme_instance_variable_bucket_or_null(v, instance)) { + v = generate_bucket_name(v, instance); + source_names = update_source_names(source_names, SCHEME_VEC_ELS(linklet->defns)[i], v); + } + } + v = (Scheme_Object *)scheme_instance_variable_bucket(v, instance); + } + pf->a[pos++] = v; + } + } + + return source_names; +} + +static void pop_prefix() +{ + /* This function must not allocate, since a relevant multiple-values + result may be in the thread record (and we don't want it zerod) */ + MZ_RUNSTACK++; +} + +static Scheme_Object *suspend_prefix() +{ + Scheme_Object *v; + v = MZ_RUNSTACK[0]; + MZ_RUNSTACK++; + return v; +} + +static void resume_prefix(Scheme_Object *v) +{ + --MZ_RUNSTACK; + MZ_RUNSTACK[0] = v; +} + +#ifdef MZ_PRECISE_GC +static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC +{ + if (!GC_is_partial(gc)) { + if (scheme_inc_prefix_finalize != (Scheme_Prefix *)0x1) { + Scheme_Prefix *pf = scheme_inc_prefix_finalize; + while (pf->next_final != (Scheme_Prefix *)0x1) { + pf = pf->next_final; + } + pf->next_final = scheme_prefix_finalize; + scheme_prefix_finalize = scheme_inc_prefix_finalize; + scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; + } + } + + if (scheme_prefix_finalize != (Scheme_Prefix *)0x1) { + Scheme_Prefix *pf = scheme_prefix_finalize, *next; + Scheme_Object *clo; + int i, *use_bits, maxpos; + + scheme_prefix_finalize = (Scheme_Prefix *)0x1; + while (pf != (Scheme_Prefix *)0x1) { + /* If not marked, only references are through closures: */ + if (!GC_is_marked2(pf, gc)) { + /* Clear slots that are not use in map */ + maxpos = pf->num_slots; + use_bits = PREFIX_TO_USE_BITS(pf); + for (i = (maxpos + 31) / 32; i--; ) { + int j; + for (j = 0; j < 32; j++) { + if (!(use_bits[i] & ((unsigned)1 << j))) { + int pos; + pos = (i * 32) + j; + if (pos < maxpos) + pf->a[pos] = NULL; + } + } + use_bits[i] = 0; + } + /* Should mark/copy pf, but not trigger or require mark propagation: */ +#ifdef MZ_GC_BACKTRACE + GC_set_backpointer_object(pf->backpointer); +#endif + GC_mark_no_recur(gc, 1); + gcMARK2(pf, gc); + pf = (Scheme_Prefix *)GC_resolve2(pf, gc); + GC_retract_only_mark_stack_entry(pf, gc); + GC_mark_no_recur(gc, 0); + pf->saw_num_slots = -1; + } else + pf = (Scheme_Prefix *)GC_resolve2(pf, gc); + + /* Clear use map */ + use_bits = PREFIX_TO_USE_BITS(pf); + maxpos = pf->num_slots; + for (i = (maxpos + 31) / 32; i--; ) + use_bits[i] = 0; + + /* Fix up closures that reference this prefix: */ + clo = (Scheme_Object *)GC_resolve2(pf->fixup_chain, gc); + pf->fixup_chain = NULL; + while (clo) { + Scheme_Object *next; + if (SCHEME_TYPE(clo) == scheme_closure_type) { + Scheme_Closure *cl = (Scheme_Closure *)clo; + int closure_size = ((Scheme_Lambda *)GC_resolve2(cl->code, gc))->closure_size; + next = cl->vals[closure_size - 1]; + cl->vals[closure_size-1] = (Scheme_Object *)pf; + } else if (SCHEME_TYPE(clo) == scheme_native_closure_type) { + Scheme_Native_Closure *cl = (Scheme_Native_Closure *)clo; + int closure_size = ((Scheme_Native_Lambda *)GC_resolve2(cl->code, gc))->closure_size; + next = cl->vals[closure_size - 1]; + cl->vals[closure_size-1] = (Scheme_Object *)pf; + } else { + MZ_ASSERT(0); + next = NULL; + } + clo = (Scheme_Object *)GC_resolve2(next, gc); + } + if (SCHEME_PREFIX_FLAGS(pf) & 0x1) + SCHEME_PREFIX_FLAGS(pf) -= 0x1; + + /* Next */ + next = pf->next_final; + pf->next_final = NULL; + + pf = next; + } + } +} + +int check_pruned_prefix(void *p) XFORM_SKIP_PROC +{ + Scheme_Prefix *pf = (Scheme_Prefix *)p; + return SCHEME_PREFIX_FLAGS(pf) & 0x1; +} +#endif + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#include "mzmark_linklet.inc" + +static void register_traversers(void) +{ +} + +END_XFORM_SKIP; + +#endif diff -Nru racket-6.12+ppa1/src/racket/src/list.c racket-7.0+ppa1/src/racket/src/list.c --- racket-6.12+ppa1/src/racket/src/list.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/list.c 2018-07-27 22:12:02.000000000 +0000 @@ -49,10 +49,17 @@ READ_ONLY Scheme_Object *scheme_unsafe_mcar_proc; READ_ONLY Scheme_Object *scheme_unsafe_mcdr_proc; READ_ONLY Scheme_Object *scheme_unsafe_unbox_proc; +READ_ONLY Scheme_Object *scheme_unsafe_unbox_star_proc; +READ_ONLY Scheme_Object *scheme_unsafe_set_box_star_proc; + /* read only locals */ ROSYM static Scheme_Object *weak_symbol; ROSYM static Scheme_Object *equal_symbol; +ROSYM static Scheme_Hash_Tree *empty_hash; +ROSYM static Scheme_Hash_Tree *empty_hasheq; +ROSYM static Scheme_Hash_Tree *empty_hasheqv; + /* locals */ static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *mpair_p_prim (int argc, Scheme_Object *argv[]); @@ -100,7 +107,9 @@ static Scheme_Object *immutable_box (int argc, Scheme_Object *argv[]); static Scheme_Object *box_p (int argc, Scheme_Object *argv[]); static Scheme_Object *unbox (int argc, Scheme_Object *argv[]); +static Scheme_Object *unbox_star (int argc, Scheme_Object *argv[]); static Scheme_Object *set_box (int argc, Scheme_Object *argv[]); +static Scheme_Object *set_box_star (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_box_cas (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv); @@ -117,7 +126,6 @@ static Scheme_Object *direct_hash(int argc, Scheme_Object *argv[]); static Scheme_Object *direct_hasheq(int argc, Scheme_Object *argv[]); static Scheme_Object *direct_hasheqv(int argc, Scheme_Object *argv[]); -static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_p(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]); @@ -126,7 +134,6 @@ static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]); -static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_clear_bang(int argc, Scheme_Object *argv[]); @@ -209,32 +216,29 @@ static Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val); static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table); -#define BOX "box" -#define BOXP "box?" -#define UNBOX "unbox" -#define SETBOX "set-box!" - void -scheme_init_list (Scheme_Env *env) +scheme_init_list (Scheme_Startup_Env *env) { Scheme_Object *p; scheme_null->type = scheme_null_type; - scheme_add_global_constant ("null", scheme_null, env); + scheme_addto_prim_instance ("null", scheme_null, env); REGISTER_SO(scheme_pair_p_proc); p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("pair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("pair?", p, env); scheme_pair_p_proc = p; REGISTER_SO(scheme_mpair_p_proc); p = scheme_make_folding_prim(mpair_p_prim, "mpair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("mpair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("mpair?", p, env); scheme_mpair_p_proc = p; REGISTER_SO(scheme_cons_proc); @@ -242,56 +246,63 @@ scheme_cons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("cons", p, env); + scheme_addto_prim_instance ("cons", p, env); REGISTER_SO(scheme_car_proc); p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1); scheme_car_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("car", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("car", p, env); REGISTER_SO(scheme_cdr_proc); p = scheme_make_folding_prim(scheme_checked_cdr, "cdr", 1, 1, 1); scheme_cdr_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdr", p, env); REGISTER_SO(scheme_mcons_proc); p = scheme_make_immed_prim(mcons_prim, "mcons", 2, 2); scheme_mcons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("mcons", p, env); + | SCHEME_PRIM_IS_OMITABLE_ALLOCATION + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcons", p, env); p = scheme_make_immed_prim(scheme_checked_mcar, "mcar", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("mcar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcar", p, env); p = scheme_make_immed_prim(scheme_checked_mcdr, "mcdr", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("mcdr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcdr", p, env); p = scheme_make_immed_prim(scheme_checked_set_mcar, "set-mcar!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("set-mcar!", p, env); + scheme_addto_prim_instance ("set-mcar!", p, env); p = scheme_make_immed_prim(scheme_checked_set_mcdr, "set-mcdr!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("set-mcdr!", p, env); + scheme_addto_prim_instance ("set-mcdr!", p, env); REGISTER_SO(scheme_null_p_proc); p = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1); scheme_null_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("null?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("null?", p, env); REGISTER_SO(scheme_list_p_proc); p = scheme_make_folding_prim(list_p_prim, "list?", 1, 1, 1); scheme_list_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("list?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("list?", p, env); REGISTER_SO(scheme_list_proc); p = scheme_make_immed_prim(list_prim, "list", 0, -1); @@ -300,7 +311,7 @@ | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("list", p, env); + scheme_addto_prim_instance ("list", p, env); REGISTER_SO(scheme_list_star_proc); p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1); @@ -309,31 +320,33 @@ | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("list*", p, env); + scheme_addto_prim_instance ("list*", p, env); REGISTER_SO(scheme_list_pair_p_proc); p = scheme_make_folding_prim(list_pair_p_prim, "list-pair?", 1, 1, 1); scheme_list_pair_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("list-pair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("list-pair?", p, env); p = scheme_make_folding_prim(immutablep, "immutable?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("immutable?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("immutable?", p, env); p = scheme_make_immed_prim(length_prim, "length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("length", p, env); - - scheme_add_global_constant ("append", - scheme_make_immed_prim(append_prim, - "append", - 0, -1), - env); - scheme_add_global_constant ("reverse", + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("length", p, env); + + p = scheme_make_immed_prim(append_prim, "append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("append", p, env); + + scheme_addto_prim_instance ("reverse", scheme_make_immed_prim(reverse_prim, "reverse", 1, 1), @@ -341,469 +354,482 @@ p = scheme_make_immed_prim(scheme_checked_list_tail, "list-tail", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("list-tail", p, env); + scheme_addto_prim_instance ("list-tail", p, env); p = scheme_make_immed_prim(scheme_checked_list_ref, "list-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("list-ref",p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("list-ref",p, env); - scheme_add_global_constant ("assq", + scheme_addto_prim_instance ("assq", scheme_make_immed_prim(assq, "assq", 2, 2), env); - scheme_add_global_constant ("assv", + scheme_addto_prim_instance ("assv", scheme_make_immed_prim(assv, "assv", 2, 2), env); - scheme_add_global_constant ("assoc", + scheme_addto_prim_instance ("assoc", scheme_make_immed_prim(assoc, "assoc", 2, 2), env); p = scheme_make_folding_prim(scheme_checked_caar, "caar", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("caar", p, env); p = scheme_make_folding_prim(scheme_checked_cadr, "cadr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cadr", p, env); p = scheme_make_folding_prim(scheme_checked_cdar, "cdar", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdar", p, env); p = scheme_make_folding_prim(scheme_checked_cddr, "cddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cddr", p, env); p = scheme_make_folding_prim(caaar_prim, "caaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaar", p, env); + scheme_addto_prim_instance ("caaar", p, env); p = scheme_make_folding_prim(caadr_prim, "caadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caadr", p, env); + scheme_addto_prim_instance ("caadr", p, env); p = scheme_make_folding_prim(cadar_prim, "cadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadar", p, env); + scheme_addto_prim_instance ("cadar", p, env); p = scheme_make_folding_prim(cdaar_prim, "cdaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaar", p, env); + scheme_addto_prim_instance ("cdaar", p, env); p = scheme_make_folding_prim(cdadr_prim, "cdadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdadr", p, env); + scheme_addto_prim_instance ("cdadr", p, env); p = scheme_make_folding_prim(cddar_prim, "cddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddar", p, env); + scheme_addto_prim_instance ("cddar", p, env); p = scheme_make_folding_prim(caddr_prim, "caddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("caddr", p, env); p = scheme_make_folding_prim(cdddr_prim, "cdddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdddr", p, env); p = scheme_make_folding_prim(cddddr_prim, "cddddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cddddr", p, env); p = scheme_make_folding_prim(cadddr_prim, "cadddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cadddr", p, env); p = scheme_make_folding_prim(cdaddr_prim, "cdaddr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaddr", p, env); + scheme_addto_prim_instance ("cdaddr", p, env); p = scheme_make_folding_prim(cddadr_prim, "cddadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddadr", p, env); + scheme_addto_prim_instance ("cddadr", p, env); p = scheme_make_folding_prim(cdddar_prim, "cdddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdddar", p, env); + scheme_addto_prim_instance ("cdddar", p, env); p = scheme_make_folding_prim(caaddr_prim, "caaddr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaddr", p, env); + scheme_addto_prim_instance ("caaddr", p, env); p = scheme_make_folding_prim(cadadr_prim, "cadadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadadr", p, env); + scheme_addto_prim_instance ("cadadr", p, env); p = scheme_make_folding_prim(caddar_prim, "caddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caddar", p, env); + scheme_addto_prim_instance ("caddar", p, env); p = scheme_make_folding_prim(cdaadr_prim, "cdaadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaadr", p, env); + scheme_addto_prim_instance ("cdaadr", p, env); p = scheme_make_folding_prim(cdadar_prim, "cdadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdadar", p, env); + scheme_addto_prim_instance ("cdadar", p, env); p = scheme_make_folding_prim(cddaar_prim, "cddaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddaar", p, env); + scheme_addto_prim_instance ("cddaar", p, env); p = scheme_make_folding_prim(cdaaar_prim, "cdaaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaaar", p, env); + scheme_addto_prim_instance ("cdaaar", p, env); p = scheme_make_folding_prim(cadaar_prim, "cadaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadaar", p, env); + scheme_addto_prim_instance ("cadaar", p, env); p = scheme_make_folding_prim(caadar_prim, "caadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caadar", p, env); + scheme_addto_prim_instance ("caadar", p, env); p = scheme_make_folding_prim(caaadr_prim, "caaadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaadr", p, env); + scheme_addto_prim_instance ("caaadr", p, env); p = scheme_make_folding_prim(caaaar_prim, "caaaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaaar", p, env); + scheme_addto_prim_instance ("caaaar", p, env); REGISTER_SO(scheme_box_proc); - p = scheme_make_immed_prim(box, BOX, 1, 1); + p = scheme_make_immed_prim(box, "box", 1, 1); scheme_box_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant(BOX, p, env); + scheme_addto_prim_instance("box", p, env); REGISTER_SO(scheme_box_immutable_proc); p = scheme_make_immed_prim(immutable_box, "box-immutable", 1, 1); scheme_box_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("box-immutable", p, env); + scheme_addto_prim_instance("box-immutable", p, env); REGISTER_SO(scheme_box_p_proc); - p = scheme_make_folding_prim(box_p, BOXP, 1, 1, 1); + p = scheme_make_folding_prim(box_p, "box?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant(BOXP, p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("box?", p, env); scheme_box_p_proc = p; - p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant(UNBOX, p, env); + p = scheme_make_noncm_prim(unbox, "unbox", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unbox", p, env); - p = scheme_make_immed_prim(set_box, SETBOX, 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant(SETBOX, p, env); + p = scheme_make_immed_prim(set_box, "set-box!", 2, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("set-box!", p, env); + + p = scheme_make_noncm_prim(unbox_star, "unbox*", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unbox*", p, env); + + p = scheme_make_immed_prim(set_box_star, "set-box*!", 2, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("set-box*!", p, env); p = scheme_make_immed_prim(scheme_box_cas, "box-cas!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("box-cas!", p, env); + scheme_addto_prim_instance("box-cas!", p, env); - scheme_add_global_constant("chaperone-box", + scheme_addto_prim_instance("chaperone-box", scheme_make_prim_w_arity(chaperone_box, "chaperone-box", 3, -1), env); - scheme_add_global_constant("impersonate-box", + scheme_addto_prim_instance("impersonate-box", scheme_make_prim_w_arity(impersonate_box, "impersonate-box", 3, -1), env); - scheme_add_global_constant("make-hash", - scheme_make_immed_prim(make_hash, - "make-hash", - 0, 1), - env); - scheme_add_global_constant("make-hasheq", - scheme_make_immed_prim(make_hasheq, - "make-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-hasheqv", - scheme_make_immed_prim(make_hasheqv, - "make-hasheqv", - 0, 1), - env); - scheme_add_global_constant("make-weak-hash", - scheme_make_immed_prim(make_weak_hash, - "make-weak-hash", - 0, 1), - env); - scheme_add_global_constant("make-weak-hasheq", - scheme_make_immed_prim(make_weak_hasheq, - "make-weak-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-weak-hasheqv", - scheme_make_immed_prim(make_weak_hasheqv, - "make-weak-hasheqv", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hash", - scheme_make_immed_prim(scheme_make_immutable_hash, - "make-immutable-hash", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hasheq", - scheme_make_immed_prim(scheme_make_immutable_hasheq, - "make-immutable-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hasheqv", - scheme_make_immed_prim(scheme_make_immutable_hasheqv, - "make-immutable-hasheqv", - 0, 1), - env); - scheme_add_global_constant("hash", - scheme_make_immed_prim(direct_hash, - "hash", - 0, -1), - env); - scheme_add_global_constant("hasheq", - scheme_make_immed_prim(direct_hasheq, - "hasheq", - 0, -1), - env); - scheme_add_global_constant("hasheqv", - scheme_make_immed_prim(direct_hasheqv, - "hasheqv", - 0, -1), - env); - scheme_add_global_constant("hash?", - scheme_make_folding_prim(hash_p, - "hash?", - 1, 1, 1), - env); - scheme_add_global_constant("hash-eq?", + + p = scheme_make_immed_prim(make_hash, "make-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hash", p, env); + + p = scheme_make_immed_prim(make_hasheq, "make-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hasheq", p, env); + + p = scheme_make_immed_prim(make_hasheqv, "make-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hasheqv", p, env); + + p = scheme_make_immed_prim(make_weak_hash, "make-weak-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hash", p, env); + + p = scheme_make_immed_prim(make_weak_hasheq, "make-weak-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hasheq", p, env); + + p = scheme_make_immed_prim(make_weak_hasheqv, "make-weak-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hasheqv", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hash, "make-immutable-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hash", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hasheq, "make-immutable-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hasheq", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hasheqv, "make-immutable-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hasheqv", p, env); + + p = scheme_make_immed_prim(direct_hash, "hash", 0, -1); + /* not SCHEME_PRIM_IS_OMITABLE_ALLOCATION, because `equal?`-hashing functions are called */ + scheme_addto_prim_instance("hash", p, env); + + p = scheme_make_immed_prim(direct_hasheq, "hasheq", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("hasheq", p, env); + + p = scheme_make_immed_prim(direct_hasheqv, "hasheqv", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("hasheqv", p, env); + + p = scheme_make_folding_prim(hash_p, "hash?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("hash?", p, env); + + + scheme_addto_prim_instance("hash-eq?", scheme_make_folding_prim(scheme_hash_eq_p, "hash-eq?", 1, 1, 1), env); - scheme_add_global_constant("hash-eqv?", + scheme_addto_prim_instance("hash-eqv?", scheme_make_folding_prim(scheme_hash_eqv_p, "hash-eqv?", 1, 1, 1), env); - scheme_add_global_constant("hash-equal?", + scheme_addto_prim_instance("hash-equal?", scheme_make_folding_prim(scheme_hash_equal_p, "hash-equal?", 1, 1, 1), env); - scheme_add_global_constant("hash-weak?", + scheme_addto_prim_instance("hash-weak?", scheme_make_folding_prim(hash_weak_p, "hash-weak?", 1, 1, 1), env); - scheme_add_global_constant("hash-count", - scheme_make_immed_prim(hash_table_count, - "hash-count", - 1, 1), - env); - scheme_add_global_constant("hash-copy", + + p = scheme_make_immed_prim(scheme_checked_hash_count, "hash-count", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); + scheme_addto_prim_instance("hash-count", p, env); + + scheme_addto_prim_instance("hash-copy", scheme_make_noncm_prim(hash_table_copy, "hash-copy", 1, 1), env); - scheme_add_global_constant("hash-set!", + scheme_addto_prim_instance("hash-set!", scheme_make_noncm_prim(hash_table_put_bang, "hash-set!", 3, 3), env); - scheme_add_global_constant("hash-set", + scheme_addto_prim_instance("hash-set", scheme_make_noncm_prim(scheme_hash_table_put, "hash-set", 3, 3), env); REGISTER_SO(scheme_hash_ref_proc); - scheme_hash_ref_proc = scheme_make_prim_w_arity(hash_table_get, "hash-ref", 2, 3); - scheme_add_global_constant("hash-ref", scheme_hash_ref_proc, env); - scheme_add_global_constant("hash-remove!", + scheme_hash_ref_proc = scheme_make_prim_w_arity(scheme_checked_hash_ref, "hash-ref", 2, 3); + scheme_addto_prim_instance("hash-ref", scheme_hash_ref_proc, env); + scheme_addto_prim_instance("hash-remove!", scheme_make_noncm_prim(hash_table_remove_bang, "hash-remove!", 2, 2), env); - scheme_add_global_constant("hash-remove", + scheme_addto_prim_instance("hash-remove", scheme_make_noncm_prim(hash_table_remove, "hash-remove", 2, 2), env); - scheme_add_global_constant("hash-clear!", + scheme_addto_prim_instance("hash-clear!", scheme_make_noncm_prim(hash_table_clear_bang, "hash-clear!", 1, 1), env); - scheme_add_global_constant("hash-clear", + scheme_addto_prim_instance("hash-clear", scheme_make_noncm_prim(hash_table_clear, "hash-clear", 1, 1), env); - scheme_add_global_constant("hash-map", + scheme_addto_prim_instance("hash-map", scheme_make_noncm_prim(hash_table_map, "hash-map", 2, 3), env); - scheme_add_global_constant("hash-for-each", + scheme_addto_prim_instance("hash-for-each", scheme_make_noncm_prim(hash_table_for_each, "hash-for-each", 2, 3), env); - scheme_add_global_constant("hash-iterate-first", + scheme_addto_prim_instance("hash-iterate-first", scheme_make_immed_prim(scheme_hash_table_iterate_start, "hash-iterate-first", 1, 1), env); - scheme_add_global_constant("hash-iterate-next", + scheme_addto_prim_instance("hash-iterate-next", scheme_make_immed_prim(scheme_hash_table_iterate_next, "hash-iterate-next", 2, 2), env); - scheme_add_global_constant("hash-iterate-value", + scheme_addto_prim_instance("hash-iterate-value", scheme_make_noncm_prim(scheme_hash_table_iterate_value, "hash-iterate-value", 2, 2), env); - scheme_add_global_constant("hash-iterate-key", + scheme_addto_prim_instance("hash-iterate-key", scheme_make_noncm_prim(scheme_hash_table_iterate_key, "hash-iterate-key", 2, 2), env); - scheme_add_global_constant("hash-iterate-pair", + scheme_addto_prim_instance("hash-iterate-pair", scheme_make_immed_prim(scheme_hash_table_iterate_pair, "hash-iterate-pair", 2, 2), env); - scheme_add_global_constant("hash-iterate-key+value", + scheme_addto_prim_instance("hash-iterate-key+value", scheme_make_prim_w_arity2(scheme_hash_table_iterate_key_value, "hash-iterate-key+value", 2, 2, 2, 2), env); - scheme_add_global_constant("hash-keys-subset?", + scheme_addto_prim_instance("hash-keys-subset?", scheme_make_immed_prim(hash_keys_subset_p, "hash-keys-subset?", 2, 2), env); - scheme_add_global_constant("chaperone-hash", + scheme_addto_prim_instance("chaperone-hash", scheme_make_prim_w_arity(chaperone_hash, "chaperone-hash", 5, -1), env); - scheme_add_global_constant("impersonate-hash", + scheme_addto_prim_instance("impersonate-hash", scheme_make_prim_w_arity(impersonate_hash, "impersonate-hash", 5, -1), env); - scheme_add_global_constant("eq-hash-code", + scheme_addto_prim_instance("eq-hash-code", scheme_make_immed_prim(eq_hash_code, "eq-hash-code", 1, 1), env); - scheme_add_global_constant("eqv-hash-code", + scheme_addto_prim_instance("eqv-hash-code", scheme_make_immed_prim(eqv_hash_code, "eqv-hash-code", 1, 1), env); - scheme_add_global_constant("equal-hash-code", + scheme_addto_prim_instance("equal-hash-code", scheme_make_noncm_prim(equal_hash_code, "equal-hash-code", 1, 1), env); - scheme_add_global_constant("equal-secondary-hash-code", + scheme_addto_prim_instance("equal-secondary-hash-code", scheme_make_noncm_prim(equal_hash2_code, "equal-secondary-hash-code", 1, 1), env); - scheme_add_global_constant("make-weak-box", + scheme_addto_prim_instance("make-weak-box", scheme_make_immed_prim(make_weak_box, "make-weak-box", 1, 1), env); - scheme_add_global_constant("weak-box-value", - scheme_make_immed_prim(weak_box_value, - "weak-box-value", - 1, 2), - env); - scheme_add_global_constant("weak-box?", + + p = scheme_make_immed_prim(weak_box_value, "weak-box-value", 1, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("weak-box-value", p, env); + + scheme_addto_prim_instance("weak-box?", scheme_make_folding_prim(weak_boxp, "weak-box?", 1, 1, 1), env); - scheme_add_global_constant("make-ephemeron", + scheme_addto_prim_instance("make-ephemeron", scheme_make_immed_prim(make_ephemeron, "make-ephemeron", 2, 2), env); - scheme_add_global_constant("ephemeron-value", + scheme_addto_prim_instance("ephemeron-value", scheme_make_immed_prim(ephemeron_value, "ephemeron-value", 1, 2), env); - scheme_add_global_constant("ephemeron?", + scheme_addto_prim_instance("ephemeron?", scheme_make_folding_prim(ephemeronp, "ephemeron?", 1, 1, 1), env); - scheme_add_global_constant("impersonator-ephemeron", + scheme_addto_prim_instance("impersonator-ephemeron", scheme_make_immed_prim(impersonator_ephemeron, "impersonator-ephemeron", 1, 1), env); - scheme_add_global_constant("make-reader-graph", + scheme_addto_prim_instance("make-reader-graph", scheme_make_prim_w_arity(make_graph, "make-reader-graph", 1, 1), env); - scheme_add_global_constant("make-placeholder", + scheme_addto_prim_instance("make-placeholder", scheme_make_prim_w_arity(make_placeholder, "make-placeholder", 1, 1), env); - scheme_add_global_constant("placeholder-get", + scheme_addto_prim_instance("placeholder-get", scheme_make_prim_w_arity(placeholder_get, "placeholder-get", 1, 1), env); - scheme_add_global_constant("placeholder-set!", + scheme_addto_prim_instance("placeholder-set!", scheme_make_prim_w_arity(placeholder_set, "placeholder-set!", 2, 2), env); - scheme_add_global_constant("placeholder?", + scheme_addto_prim_instance("placeholder?", scheme_make_folding_prim(placeholder_p, "placeholder?", 1, 1, 1), env); - scheme_add_global_constant("make-hash-placeholder", + scheme_addto_prim_instance("make-hash-placeholder", scheme_make_prim_w_arity(make_hash_placeholder, "make-hash-placeholder", 1, 1), env); - scheme_add_global_constant("make-hasheq-placeholder", + scheme_addto_prim_instance("make-hasheq-placeholder", scheme_make_prim_w_arity(make_hasheq_placeholder, "make-hasheq-placeholder", 1, 1), env); - scheme_add_global_constant("make-hasheqv-placeholder", + scheme_addto_prim_instance("make-hasheqv-placeholder", scheme_make_prim_w_arity(make_hasheqv_placeholder, "make-hasheqv-placeholder", 1, 1), env); - scheme_add_global_constant("hash-placeholder?", + scheme_addto_prim_instance("hash-placeholder?", scheme_make_folding_prim(table_placeholder_p, "hash-placeholder?", 1, 1, 1), @@ -814,10 +840,17 @@ weak_symbol = scheme_intern_symbol("weak"); equal_symbol = scheme_intern_symbol("equal"); + + REGISTER_SO(empty_hash); + REGISTER_SO(empty_hasheq); + REGISTER_SO(empty_hasheqv); + empty_hash = scheme_make_hash_tree(1); + empty_hasheq = scheme_make_hash_tree(0); + empty_hasheqv = scheme_make_hash_tree(2); } void -scheme_init_unsafe_list (Scheme_Env *env) +scheme_init_unsafe_list (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -827,91 +860,103 @@ p = scheme_make_immed_prim(unsafe_cons_list, "unsafe-cons-list", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("unsafe-cons-list", p, env); + scheme_addto_prim_instance ("unsafe-cons-list", p, env); scheme_unsafe_cons_list_proc = p; REGISTER_SO(scheme_unsafe_car_proc); p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL - | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-car", p, env); + | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-car", p, env); scheme_unsafe_car_proc = p; REGISTER_SO(scheme_unsafe_cdr_proc); p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL - | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-cdr", p, env); + | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-cdr", p, env); scheme_unsafe_cdr_proc = p; p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-list-ref", p, env); + scheme_addto_prim_instance ("unsafe-list-ref", p, env); p = scheme_make_folding_prim(unsafe_list_tail, "unsafe-list-tail", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-list-tail", p, env); + scheme_addto_prim_instance ("unsafe-list-tail", p, env); REGISTER_SO(scheme_unsafe_mcar_proc); p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("unsafe-mcar", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-mcar", p, env); scheme_unsafe_mcar_proc = p; REGISTER_SO(scheme_unsafe_mcdr_proc); p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("unsafe-mcdr", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-mcdr", p, env); scheme_unsafe_mcdr_proc = p; p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("unsafe-set-mcar!", p, env); + scheme_addto_prim_instance ("unsafe-set-mcar!", p, env); p = scheme_make_immed_prim(unsafe_set_mcdr, "unsafe-set-mcdr!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("unsafe-set-mcdr!", p, env); + scheme_addto_prim_instance ("unsafe-set-mcdr!", p, env); REGISTER_SO(scheme_unsafe_unbox_proc); p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-unbox", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-unbox", p, env); scheme_unsafe_unbox_proc = p; + REGISTER_SO(scheme_unsafe_unbox_star_proc); p = scheme_make_immed_prim(unsafe_unbox_star, "unsafe-unbox*", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-unbox*", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-unbox*", p, env); + scheme_unsafe_unbox_star_proc = p; p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("unsafe-set-box!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-set-box!", p, env); + REGISTER_SO(scheme_unsafe_set_box_star_proc); p = scheme_make_immed_prim(unsafe_set_box_star, "unsafe-set-box*!", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("unsafe-set-box*!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-set-box*!", p, env); + scheme_unsafe_set_box_star_proc = p; p = scheme_make_prim_w_arity(scheme_box_cas, "unsafe-box*-cas!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-box*-cas!", p, env); + scheme_addto_prim_instance("unsafe-box*-cas!", p, env); } void -scheme_init_unsafe_hash (Scheme_Env *env) +scheme_init_unsafe_hash (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -920,38 +965,38 @@ "unsafe-mutable-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-first", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_start, "unsafe-immutable-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-first", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_start, "unsafe-weak-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-weak-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-first", p, env); /* unsafe-hash-iterate-next ---------------------------------------- */ p = scheme_make_immed_prim(unsafe_hash_table_iterate_next, "unsafe-mutable-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-next", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_next, "unsafe-immutable-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-next", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_next, "unsafe-weak-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-weak-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-next", p, env); /* unsafe-hash-iterate-key ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_key, @@ -959,21 +1004,21 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_key, "unsafe-immutable-hash-iterate-key", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_key, "unsafe-weak-hash-iterate-key", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-key", p, env); /* unsafe-hash-iterate-value ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_value, @@ -981,21 +1026,21 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_value, "unsafe-immutable-hash-iterate-value", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_value, "unsafe-weak-hash-iterate-value", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-value", p, env); /* unsafe-hash-iterate-key+value ---------------------------------------- */ p = scheme_make_prim_w_arity2(unsafe_hash_table_iterate_key_value, @@ -1004,7 +1049,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-key+value", p, env); p = scheme_make_prim_w_arity2(unsafe_hash_tree_iterate_key_value, "unsafe-immutable-hash-iterate-key+value", @@ -1012,7 +1057,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-key+value", p, env); p = scheme_make_prim_w_arity2(unsafe_bucket_table_iterate_key_value, "unsafe-weak-hash-iterate-key+value", @@ -1020,7 +1065,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-key+value", p, env); /* unsafe-hash-iterate-pair ---------------------------------------- */ p = scheme_make_immed_prim(unsafe_hash_table_iterate_pair, @@ -1029,14 +1074,14 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-pair", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_pair, "unsafe-immutable-hash-iterate-pair", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-pair", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_pair, "unsafe-weak-hash-iterate-pair", @@ -1044,7 +1089,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-pair", p, env); } Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) @@ -1856,10 +1901,23 @@ && SCHEME_BOXP(SCHEME_CHAPERONE_VAL(obj))) return chaperone_unbox(obj); - scheme_wrong_contract(UNBOX, "box?", 0, 1, &obj); + scheme_wrong_contract("unbox", "box?", 0, 1, &obj); } - return (Scheme_Object *)SCHEME_BOX_VAL(obj); + return SCHEME_BOX_VAL(obj); +} + +Scheme_Object *scheme_unbox_star(Scheme_Object *obj) +{ + if (!SCHEME_BOXP(obj)) + scheme_wrong_contract("unbox*", "(and/c box? (not/c impersonator?))", 0, 1, &obj); + + return SCHEME_BOX_VAL(obj); +} + +static void bad_cas_box(Scheme_Object *box) +{ + scheme_wrong_contract("box-cas!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &box); } Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[]) @@ -1870,11 +1928,11 @@ Scheme_Object *nv = argv[2]; /* This procedure is used for both the safe and unsafe version, but - * the JIT elides the checking for the unsafe version. - */ + the JIT elides the checking for the unsafe version. */ if (!SCHEME_MUTABLE_BOXP(box)) { - scheme_wrong_contract("box-cas!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &box); + bad_cas_box(box); + return NULL; } #ifdef MZ_USE_FUTURES @@ -1925,11 +1983,19 @@ return; } - scheme_wrong_contract(SETBOX, "(and/c box? (not/c immutable?))", 0, 1, &b); + scheme_wrong_contract("set-box!", "(and/c box? (not/c immutable?))", 0, 1, &b); } SCHEME_BOX_VAL(b) = v; } +void scheme_set_box_star(Scheme_Object *b, Scheme_Object *v) +{ + if (!SCHEME_MUTABLE_BOXP(b)) + scheme_wrong_contract("set-box*!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &b); + + SCHEME_BOX_VAL(b) = v; +} + static Scheme_Object *box(int c, Scheme_Object *p[]) { return scheme_box(p[0]); @@ -1955,12 +2021,23 @@ return scheme_unbox(p[0]); } +static Scheme_Object *unbox_star(int c, Scheme_Object *p[]) +{ + return scheme_unbox_star(p[0]); +} + static Scheme_Object *set_box(int c, Scheme_Object *p[]) { scheme_set_box(p[0], p[1]); return scheme_void; } +static Scheme_Object *set_box_star(int c, Scheme_Object *p[]) +{ + scheme_set_box_star(p[0], p[1]); + return scheme_void; +} + static Scheme_Object *do_chaperone_box(const char *name, int is_impersonator, int argc, Scheme_Object **argv) { Scheme_Chaperone *px; @@ -2185,7 +2262,7 @@ return make_immutable_table("make-immutable-hasheqv", 2, argc, argv); } -static Scheme_Object *direct_table(const char *who, int kind, int argc, Scheme_Object *argv[]) +static Scheme_Object *direct_table(const char *who, int kind, Scheme_Hash_Tree *empty, int argc, Scheme_Object *argv[]) { int i; Scheme_Hash_Tree *ht; @@ -2198,7 +2275,10 @@ return NULL; } - ht = scheme_make_hash_tree(kind); + if (!argc) + ht = scheme_make_hash_tree(kind); + else + ht = empty; for (i = 0; i < argc; i += 2) { ht = scheme_hash_tree_set(ht, argv[i], argv[i+1]); @@ -2209,17 +2289,17 @@ static Scheme_Object *direct_hash(int argc, Scheme_Object *argv[]) { - return direct_table("hash", 1, argc, argv); + return direct_table("hash", 1, empty_hash, argc, argv); } static Scheme_Object *direct_hasheq(int argc, Scheme_Object *argv[]) { - return direct_table("hasheq", 0, argc, argv); + return direct_table("hasheq", 0, empty_hasheq, argc, argv); } static Scheme_Object *direct_hasheqv(int argc, Scheme_Object *argv[]) { - return direct_table("hasheqv", 2, argc, argv); + return direct_table("hasheqv", 2, empty_hasheqv, argc, argv); } Scheme_Hash_Table *scheme_make_hash_table_equal() @@ -2237,21 +2317,6 @@ return t; } -static int compare_equal_modidx_eq(void *v1, void *v2) -{ - return !scheme_equal_modix_eq((Scheme_Object *)v1, (Scheme_Object *)v2); -} - -Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq() -{ - Scheme_Hash_Table *t; - - t = scheme_make_hash_table_equal(); - t->compare = compare_equal_modidx_eq; - - return t; -} - Scheme_Hash_Table *scheme_make_hash_table_eqv() { Scheme_Hash_Table *t; @@ -2264,7 +2329,7 @@ return t; } -static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; @@ -2528,7 +2593,7 @@ scheme_wrong_contract("hash-set", "(and hash? immutable?)", 0, argc, argv); return NULL; } - + return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], argv[2]); } @@ -2588,7 +2653,7 @@ return hash_failed(argc, argv); } -static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]) XFORM_ASSERT_NO_CONVERSION { Scheme_Object *v; @@ -3137,8 +3202,8 @@ return NULL; } - i1 = hash_table_count(1, argv); - c2 = hash_table_count(1, b); + i1 = scheme_checked_hash_count(1, argv); + c2 = scheme_checked_hash_count(1, b); if (SCHEME_INT_VAL(i1) > SCHEME_INT_VAL(c2)) return scheme_false; @@ -3529,7 +3594,15 @@ { return chaperone_hash_op(name, table, key, NULL, 3, scheme_null); } -static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *key, Scheme_Object **_chap_key, Scheme_Object **_chap_val, int ischap) + +Scheme_Object *scheme_chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key) +{ + return chaperone_hash_key(name, table, key); +} + +static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *key, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap) { Scheme_Object *chap_key, *chap_val; chap_key = chaperone_hash_key(name, obj, key); @@ -3540,6 +3613,13 @@ *_chap_val = chap_val; } +void scheme_chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap) +{ + return chaperone_hash_key_value(name, obj, k, _chap_key, _chap_val, ischap); +} + static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table) { return chaperone_hash_op(name, table, NULL, NULL, 4, scheme_null); @@ -3553,7 +3633,9 @@ return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null); } -Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj) + +Scheme_Object *scheme_chaperone_hash_table_filtered_copy(Scheme_Object *obj, + Hash_Table_Element_Filter_Proc filter) { Scheme_Object *a[3], *v, *v2, *idx, *key, *val; int is_eq, is_eqv; @@ -3564,14 +3646,14 @@ is_eq = SCHEME_TRUEP(scheme_hash_eq_p(1, a)); is_eqv = SCHEME_TRUEP(scheme_hash_eqv_p(1, a)); - if (SCHEME_HASHTP(obj)) { + if (SCHEME_HASHTP(v)) { if (is_eq) v2 = make_hasheq(0, NULL); else if (is_eqv) v2 = make_hasheqv(0, NULL); else v2 = make_hash(0, NULL); - } else if (SCHEME_HASHTRP(obj)) { + } else if (SCHEME_HASHTRP(v)) { if (is_eq) v2 = scheme_make_immutable_hasheq(0, NULL); else if (is_eqv) @@ -3594,6 +3676,7 @@ key = scheme_hash_table_iterate_key(2, a); val = scheme_chaperone_hash_get(obj, key); + if (filter && val) val = filter(val); if (val) { a[0] = v2; a[1] = key; @@ -3612,6 +3695,11 @@ return v2; } +Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj) +{ + return scheme_chaperone_hash_table_filtered_copy(obj, NULL); +} + static Scheme_Object *eq_hash_code(int argc, Scheme_Object *argv[]) { intptr_t v; @@ -3715,6 +3803,13 @@ return o; } +Scheme_Object *scheme_weak_box_value(Scheme_Object *obj) +{ + Scheme_Object *a[1]; + a[0] = obj; + return weak_box_value(1, a); +} + static Scheme_Object *weak_boxp(int argc, Scheme_Object *argv[]) { return (SCHEME_WEAKP(argv[0]) ? scheme_true : scheme_false); @@ -4344,7 +4439,7 @@ key = subtree->els[i]; if (SCHEME_NP_CHAPERONEP(obj)) { - chaperone_hash_key_value("unsafe-immutable-hash-iterate-pair", + chaperone_hash_key_value("unsafe-immutable-hash-iterate-key+value", obj, subtree->els[i], &res[0], &res[1], 0); } else { res[0] = key; diff -Nru racket-6.12+ppa1/src/racket/src/longdouble/longdouble.c racket-7.0+ppa1/src/racket/src/longdouble/longdouble.c --- racket-6.12+ppa1/src/racket/src/longdouble/longdouble.c 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/longdouble/longdouble.c 2018-07-27 22:12:02.000000000 +0000 @@ -611,6 +611,100 @@ return d; } +static long_double fail_long_double_infinity() { + long_double d; + memset(&d, 0, sizeof(d)); + memcpy(&d, &scheme_infinity_val, sizeof(double)); + return d; +} + +static long_double fail_long_double_minus_infinity() { + long_double d; + memset(&d, 0, sizeof(d)); + memcpy(&d, &scheme_minus_infinity_val, sizeof(double)); + return d; +} + +static long_double fail_long_double_nzero() { + long_double d; + memset(&d, 0, sizeof(d)); + memcpy(&d, &scheme_floating_point_nzero, sizeof(double)); + return d; +} + +static long_double fail_long_double_nan() { + long_double d; + memset(&d, 0, sizeof(d)); + memcpy(&d, &SCHEME_DBL_VAL(scheme_nan_object), sizeof(double)); + return d; +} + +static long_double fail_long_double_1() { + long_double d; + double one = 1.0; + memset(&d, 0, sizeof(d)); + memcpy(&d, &one, sizeof(double)); + return d; +} + +static long_double fail_long_double_div(long_double ld1, long_double ld2) { + double d1, d2; + long_double d; + memcpy(&d1, &ld1, sizeof(double)); + memcpy(&d2, &ld2, sizeof(double)); + if (d2 == 0.0) { + d1 = scheme_infinity_val; + } else { + memset(&d, 0, sizeof(d)); + d1 = d1 / d2; + } + memcpy(&d, &d1, sizeof(double)); + return d; +} + +static long_double fail_long_double_neg(long_double ld1) { + double d1; + long_double d; + memcpy(&d1, &ld1, sizeof(double)); + d1 = 0.0 - d1; + memcpy(&d, &d1, sizeof(double)); + return d; +} + +static long_double fail_long_double_sqrt(long_double ld1) { + double d1; + long_double d; + memcpy(&d1, &ld1, sizeof(double)); + if (d1 < 0) + d1 = SCHEME_DBL_VAL(scheme_nan_object); + memcpy(&d, &d1, sizeof(double)); + return d; +} + +static int fail_is_pos_infinity(long_double ld) { + double d; + memcpy(&d, &ld, sizeof(double)); + return MZ_IS_POS_INFINITY(d); +} + +static int fail_is_neg_infinity(long_double ld) { + double d; + memcpy(&d, &ld, sizeof(double)); + return MZ_IS_NEG_INFINITY(d); +} + +static int fail_is_infinity(long_double ld) { + double d; + memcpy(&d, &ld, sizeof(double)); + return MZ_IS_POS_INFINITY(d) || MZ_IS_NEG_INFINITY(d); +} + +static int fail_is_nan(long_double ld) { + double d; + memcpy(&d, &ld, sizeof(double)); + return MZ_IS_NAN(d); +} + static int fail_int() { return 0; } static void fail_void() { } static double fail_double() { return 0.0; } @@ -643,20 +737,22 @@ void scheme_load_long_double_dll() { HANDLE m; - m = LoadLibraryW(scheme_get_dll_path(L"longdouble.dll")); + int dll_mode; + + m = scheme_dll_load_library("longdouble.dll", L"longdouble.dll", &dll_mode); if (m) long_double_dll_available = 1; # define EXTRACT_LDBL(name, fail) \ - _imp_ ## name = (name ##_t)(m ? GetProcAddress(m, # name) : NULL); \ + _imp_ ## name = (name ##_t)(m ? scheme_dll_get_proc_address(m, # name, dll_mode) : NULL); \ if (!(_imp_ ## name)) _imp_ ## name = (name ##_t)fail; - EXTRACT_LDBL(get_long_double_infinity_val, fail_long_double); - EXTRACT_LDBL(get_long_double_minus_infinity_val, fail_long_double); + EXTRACT_LDBL(get_long_double_infinity_val, fail_long_double_infinity); + EXTRACT_LDBL(get_long_double_minus_infinity_val, fail_long_double_minus_infinity); EXTRACT_LDBL(get_long_double_zero, fail_long_double); - EXTRACT_LDBL(get_long_double_nzero, fail_long_double); - EXTRACT_LDBL(get_long_double_nan, fail_long_double); - EXTRACT_LDBL(get_long_double_1, fail_long_double); + EXTRACT_LDBL(get_long_double_nzero, fail_long_double_nzero); + EXTRACT_LDBL(get_long_double_nan, fail_long_double_nan); + EXTRACT_LDBL(get_long_double_1, fail_long_double_1); EXTRACT_LDBL(get_long_double_minus_1, fail_long_double); EXTRACT_LDBL(get_long_double_2, fail_long_double); EXTRACT_LDBL(get_long_double_one_half, fail_long_double); @@ -676,8 +772,8 @@ EXTRACT_LDBL(long_double_minus, fail_long_double); EXTRACT_LDBL(long_double_mult, fail_long_double); EXTRACT_LDBL(long_double_mult_i, fail_long_double); - EXTRACT_LDBL(long_double_div, fail_long_double); - EXTRACT_LDBL(long_double_neg, fail_long_double); + EXTRACT_LDBL(long_double_div, fail_long_double_div); + EXTRACT_LDBL(long_double_neg, fail_long_double_neg); EXTRACT_LDBL(long_double_eqv, fail_int); EXTRACT_LDBL(long_double_less, fail_int); EXTRACT_LDBL(long_double_less_or_eqv, fail_int); @@ -687,10 +783,10 @@ EXTRACT_LDBL(long_double_is_zero, fail_int); EXTRACT_LDBL(long_double_is_1, fail_int); EXTRACT_LDBL(long_double_minus_zero_p, fail_int); - EXTRACT_LDBL(long_double_is_nan, fail_int); - EXTRACT_LDBL(long_double_is_pos_infinity, fail_int); - EXTRACT_LDBL(long_double_is_neg_infinity, fail_int); - EXTRACT_LDBL(long_double_is_infinity, fail_int); + EXTRACT_LDBL(long_double_is_nan, fail_is_nan); + EXTRACT_LDBL(long_double_is_pos_infinity, fail_is_pos_infinity); + EXTRACT_LDBL(long_double_is_neg_infinity, fail_is_neg_infinity); + EXTRACT_LDBL(long_double_is_infinity, fail_is_infinity); EXTRACT_LDBL(long_double_fabs, fail_long_double); EXTRACT_LDBL(long_double_modf, fail_long_double); EXTRACT_LDBL(long_double_fmod, fail_long_double); @@ -707,7 +803,7 @@ EXTRACT_LDBL(long_double_exp, fail_long_double); EXTRACT_LDBL(long_double_ldexp, fail_long_double); EXTRACT_LDBL(long_double_pow, fail_long_double); - EXTRACT_LDBL(long_double_sqrt, fail_long_double); + EXTRACT_LDBL(long_double_sqrt, fail_long_double_sqrt); EXTRACT_LDBL(long_double_frexp, fail_long_double); EXTRACT_LDBL(long_double_sprint, fail_sprint); EXTRACT_LDBL(long_double_array_ref, fail_long_double); diff -Nru racket-6.12+ppa1/src/racket/src/makeexn racket-7.0+ppa1/src/racket/src/makeexn --- racket-6.12+ppa1/src/racket/src/makeexn 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/makeexn 2018-07-27 22:12:02.000000000 +0000 @@ -43,19 +43,20 @@ (variable [variable_field_check (id "symbol" "the variable's identifier")] "not-yet-defined global or module variable")) - (syntax [syntax_field_check + (#:only-kernstruct + syntax [syntax_field_check (exprs "immutable list of syntax objects" "illegal expression(s)") - {exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}] + {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_syntax_locations, "extract_syntax_locations", 0, -1)|}] "syntax error, but not a \\scmfirst{read} error" (unbound [] "unbound module variable") (missing-module [module_path_field_check_3 (path "module path" "module path") - {exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_3)|}] + {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_3, "extract_module_path_3", 0, -1)|}] "error resolving a module path")) (read [read_field_check (srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error") - {exn:source scheme_source_property |scheme_make_prim(extract_read_locations)|}] + {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)|}] "\\rawscm{read} parsing error" (eof [] "unexpected end-of-file") (non-char [] "unexpected non-character")) @@ -65,9 +66,10 @@ (errno [errno_field_check (errno "pair of symbol and number" "system error code")] "error with system error code") - (missing-module [module_path_field_check_2 + (#:only-kernstruct + missing-module [module_path_field_check_2 (path "module path" "module path") - {exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_2)|}] + {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_2, "extract_module_path_2", 0, -1)|}] "error resolving a module path")) (network [] "TCP and UDP errors" (errno [errno_field_check @@ -96,21 +98,22 @@ (define l info) (define-struct ex (define string base doc args props guard parent parent-def - numtotal depth mark)) + numtotal depth mark only-kernstruct?)) (define-struct fld (name type doc)) (define-struct prop (scheme-name c-name value)) (define max-exn-args 0) (define (make-an-ex sym parent parent-def parent-name totalargs args props - guard doc depth mark) + guard doc depth mark only-kernstruct?) (let* ([s (symbol->string sym)] [name (string-append parent-name (if (string=? "" parent-name) "" ":") s)] [count (+ totalargs (length args))]) - (when (> count max-exn-args) - (set! max-exn-args count)) + (when (and (> count max-exn-args) + (not only-kernstruct?)) + (set! max-exn-args count)) (make-ex (string-append "MZ" (list->string (let loop ([l (string->list name)]) @@ -133,7 +136,8 @@ parent-def count depth - mark))) + mark + only-kernstruct?))) (define (make-arg-list args) (cond @@ -153,28 +157,33 @@ [else (make-prop-list (cdr args))])) -(define (make-struct-list v parent parent-def parent-name totalargs depth) +(define (make-struct-list v parent parent-def parent-name totalargs depth only-kernstruct?) (cond [(null? v) '()] [else - (let*-values ([(s mark) - (let* ([s (symbol->string (car v))] - [c (string-ref s 0)]) - (if (or (char=? #\* c) - (char=? #\+ c)) - (values (string->symbol (substring s 1 (string-length s))) c) + (let*-values ([(v only-kernstruct?) + (if (eq? '#:only-kernstruct (car v)) + (values (cdr v) #t) + (values v only-kernstruct?))] + [(s mark) + (let* ([s (symbol->string (car v))] + [c (string-ref s 0)]) + (if (or (char=? #\* c) + (char=? #\+ c)) + (values (string->symbol (substring s 1 (string-length s))) c) (values (car v) #f)))] - [(e) (make-an-ex s parent parent-def parent-name totalargs - (if (null? (cadr v)) - null - (make-arg-list (cdadr v))) - (if (null? (cadr v)) - null - (make-prop-list (cdadr v))) - (if (null? (cadr v)) - #f - (caadr v)) - (caddr v) depth mark)]) + [(e) (make-an-ex s parent parent-def parent-name totalargs + (if (null? (cadr v)) + null + (make-arg-list (cdadr v))) + (if (null? (cadr v)) + null + (make-prop-list (cdadr v))) + (if (null? (cadr v)) + #f + (caadr v)) + (caddr v) depth mark + only-kernstruct?)]) (cons e (apply append (map @@ -184,10 +193,11 @@ (ex-define e) (ex-string e) (ex-numtotal e) - (add1 depth))) + (add1 depth) + only-kernstruct?)) (cdddr v)))))])) -(set! l (make-struct-list l #f #f "" 0 0)) +(set! l (make-struct-list l #f #f "" 0 0 #f)) (define (gen-kernstruct filename) @@ -277,7 +287,7 @@ #ifndef _MZEXN_DEFINES #define _MZEXN_DEFINES enum { - @(add-newlines (for/list ([e l]) @list{ @(ex-define e),})) + @(add-newlines (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{ @(ex-define e),})) MZEXN_OTHER }; #endif @@ -290,16 +300,22 @@ static exn_rec exn_table[] = { @(let loop ([ll l]) (let ([e (car ll)]) - (cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @; - @(if (ex-parent e) - (let loop ([pos 0][ll l]) - (if (eq? (car ll) (ex-parent e)) - pos - (loop (add1 pos) (cdr ll)))) - -1) }} - (if (null? (cdr ll)) - '() - (cons ",\n" (loop (cdr ll))))))) + (if (ex-only-kernstruct? e) + (loop (cdr ll)) + (cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @; + @(if (ex-parent e) + (let loop ([pos 0][ll l]) + (cond + [(eq? (car ll) (ex-parent e)) + pos] + [(ex-only-kernstruct? (car ll)) + (loop pos (cdr ll))] + [else + (loop (add1 pos) (cdr ll))])) + -1) }} + (if (null? (cdr ll)) + '() + (cons ",\n" (loop (cdr ll)))))))) }; #else static exn_rec *exn_table; @@ -312,7 +328,7 @@ #ifndef GLOBAL_EXN_ARRAY exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER); @(add-newlines - (for/list ([e l]) + (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{ exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"})) #endif @@ -320,7 +336,10 @@ #ifdef _MZEXN_DECL_FIELDS @(add-newlines - (for*/list ([e l] [l (in-value (ex-args e))] #:when (pair? l)) + (for*/list ([e l] + #:unless (ex-only-kernstruct? e) + [l (in-value (ex-args e))] + #:when (pair? l)) (define fields (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", ")) @list{ static const char *@(ex-define e)_FIELDS[@(length l)] = @; @@ -330,7 +349,10 @@ #ifdef _MZEXN_DECL_PROPS @(add-newlines - (for*/list ([e l] [l (in-value (ex-props e))] #:when (pair? l)) + (for*/list ([e l] + #:unless (ex-only-kernstruct? e) + [l (in-value (ex-props e))] + #:when (pair? l)) (define (acons x y l) @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)}) @list{# define @(ex-define e)_PROPS @; @@ -343,7 +365,8 @@ #ifdef _MZEXN_SETUP @(add-newlines - (for/list ([e l]) + (for/list ([e l] + #:unless (ex-only-kernstruct? e)) @list{ SETUP_STRUCT(@(ex-define e), @; @(let ([p (ex-parent-def e)]) (if p @list{EXN_PARENT(@p)} 'NULL)), @; @@ -356,7 +379,7 @@ 'scheme_null @list{@(ex-define e)_PROPS}), @; @(if (ex-guard e) - @list{scheme_make_prim(@(ex-guard e))} + @list{scheme_make_prim_w_arity(@(ex-guard e), "@(ex-guard e)" , 0, -1)} 'NULL))})) #endif @||}) diff -Nru racket-6.12+ppa1/src/racket/src/Makefile.in racket-7.0+ppa1/src/racket/src/Makefile.in --- racket-6.12+ppa1/src/racket/src/Makefile.in 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -17,7 +17,6 @@ OBJS = salloc.@LTO@ \ bignum.@LTO@ \ bool.@LTO@ \ - builtin.@LTO@ \ char.@LTO@ \ compenv.@LTO@ \ compile.@LTO@ \ @@ -41,9 +40,9 @@ jitstack.@LTO@ \ jitstate.@LTO@ \ letrec_check.@LTO@ \ + linklet.@LTO@ \ list.@LTO@ \ marshal.@LTO@ \ - module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ numarith.@LTO@ \ @@ -62,6 +61,8 @@ sema.@LTO@ \ setjmpup.@LTO@ \ sfs.@LTO@ \ + sort.@LTO@ \ + startup.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ symbol.@LTO@ \ @@ -75,7 +76,6 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/bignum.c \ $(srcdir)/bool.c \ - $(srcdir)/builtin.c \ $(srcdir)/char.c \ $(srcdir)/compenv.c \ $(srcdir)/compile.c \ @@ -99,9 +99,9 @@ $(srcdir)/jitstack.c \ $(srcdir)/jitstate.c \ $(srcdir)/letrec_check.c \ + $(srcdir)/linklet.c \ $(srcdir)/list.c \ $(srcdir)/marshal.c \ - $(srcdir)/module.c \ $(srcdir)/mzrt.c \ $(srcdir)/network.c \ $(srcdir)/numarith.c \ @@ -120,6 +120,7 @@ $(srcdir)/sema.c \ $(srcdir)/setjmpup.c \ $(srcdir)/sfs.c \ + $(srcdir)/startup.c \ $(srcdir)/string.c \ $(srcdir)/struct.c \ $(srcdir)/symbol.c \ @@ -185,8 +186,6 @@ $(CC) $(ALL_CFLAGS) -c $(srcdir)/bignum.c -o bignum.@LTO@ bool.@LTO@: $(srcdir)/bool.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/bool.c -o bool.@LTO@ -builtin.@LTO@: $(srcdir)/builtin.c - $(CC) $(ALL_CFLAGS) -c $(srcdir)/builtin.c -o builtin.@LTO@ char.@LTO@: $(srcdir)/char.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/char.c -o char.@LTO@ compenv.@LTO@: $(srcdir)/compenv.c @@ -234,12 +233,12 @@ $(CC) $(ALL_CFLAGS) -c $(srcdir)/jitstate.c -o jitstate.@LTO@ letrec_check.@LTO@: $(srcdir)/letrec_check.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/letrec_check.c -o letrec_check.@LTO@ +linklet.@LTO@: $(srcdir)/linklet.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/linklet.c -o linklet.@LTO@ list.@LTO@: $(srcdir)/list.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/list.c -o list.@LTO@ marshal.@LTO@: $(srcdir)/marshal.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/marshal.c -o marshal.@LTO@ -module.@LTO@: $(srcdir)/module.c - $(CC) $(ALL_CFLAGS) -c $(srcdir)/module.c -o module.@LTO@ mzrt.@LTO@: $(srcdir)/mzrt.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/mzrt.c -o mzrt.@LTO@ network.@LTO@: $(srcdir)/network.c @@ -276,6 +275,10 @@ $(CC) $(ALL_CFLAGS) -c $(srcdir)/setjmpup.c -o setjmpup.@LTO@ sfs.@LTO@: $(srcdir)/sfs.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/sfs.c -o sfs.@LTO@ +sort.@LTO@: $(srcdir)/sort.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/sort.c -o sort.@LTO@ +startup.@LTO@: $(srcdir)/startup.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/startup.c -I.. -I$(srcdir) -o startup.@LTO@ string.@LTO@: $(srcdir)/string.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/string.c -I. -o string.@LTO@ struct.@LTO@: $(srcdir)/struct.c @@ -332,8 +335,6 @@ $(srcdir)/stypes.h bool.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzeqchk.inc -builtin.@LTO@: $(COMMON_HEADERS) \ - $(srcdir)/stypes.h $(srcdir)/schminc.h $(srcdir)/startup.inc $(srcdir)/cstartup.inc char.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schuchar.inc compenv.@LTO@: $(COMMON_HEADERS) \ @@ -376,12 +377,12 @@ jitstate.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) letrec_check.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h +linklet.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/stypes.h list.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h marshal.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h -module.@LTO@: $(COMMON_HEADERS) \ - $(srcdir)/stypes.h mzrt.@LTO@: $(COMMON_HEADERS) network.@LTO@: $(COMMON_HEADERS) $(RKTIO_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_network.inc @@ -411,8 +412,7 @@ $(srcdir)/stypes.h read.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/schcpt.h $(srcdir)/schvers.h $(srcdir)/schminc.h \ - $(srcdir)/stypes.h $(srcdir)/mzmark_read.inc \ - $(srcdir)/read_vector.inc + $(srcdir)/stypes.h $(srcdir)/mzmark_read.inc regexp.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_regexp.inc $(srcdir)/schrx.h resolve.@LTO@: $(COMMON_HEADERS) \ @@ -421,6 +421,11 @@ $(srcdir)/stypes.h $(srcdir)/schmach.h sfs.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_sfs.inc +sort.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/stypes.h +startup.@LTO@: $(COMMON_HEADERS) $(srcdir)/schvers.h \ + $(srcdir)/stypes.h $(srcdir)/schminc.h $(srcdir)/startup.inc ../cstartup.inc \ + $(srcdir)/startup-glue.inc string.@LTO@: $(COMMON_HEADERS) $(RKTIO_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schvers.h $(srcdir)/mzmark_string.inc $(srcdir)/strops.inc \ $(srcdir)/schustr.inc $(srcdir)/systype.inc @@ -438,3 +443,8 @@ $(srcdir)/stypes.h validate.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_validate.inc + +# If "cstartup.inc" hasn't been built, yet, create it as +# a redirect to "startup.inc" +../cstartup.inc: + echo '#include "startup.inc"' > ../cstartup.inc diff -Nru racket-6.12+ppa1/src/racket/src/marshal.c racket-7.0+ppa1/src/racket/src/marshal.c --- racket-6.12+ppa1/src/racket/src/marshal.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/marshal.c 2018-07-27 22:12:02.000000000 +0000 @@ -25,724 +25,13 @@ #include "schpriv.h" -#define cons(a,b) scheme_make_pair(a,b) #define CONS(a,b) scheme_make_pair(a,b) -static Scheme_Object *write_let_value(Scheme_Object *obj); -static Scheme_Object *read_let_value(Scheme_Object *obj); -static Scheme_Object *write_let_void(Scheme_Object *obj); -static Scheme_Object *read_let_void(Scheme_Object *obj); -static Scheme_Object *write_letrec(Scheme_Object *obj); -static Scheme_Object *read_letrec(Scheme_Object *obj); -static Scheme_Object *write_let_one(Scheme_Object *obj); -static Scheme_Object *read_let_one(Scheme_Object *obj); -static Scheme_Object *write_top(Scheme_Object *obj); -static Scheme_Object *read_top(Scheme_Object *obj); -static Scheme_Object *write_case_lambda(Scheme_Object *obj); -static Scheme_Object *read_case_lambda(Scheme_Object *obj); - -static Scheme_Object *read_define_values(Scheme_Object *obj); -static Scheme_Object *write_define_values(Scheme_Object *obj); -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj); -static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj); -static Scheme_Object *read_set_bang(Scheme_Object *obj); -static Scheme_Object *write_set_bang(Scheme_Object *obj); -static Scheme_Object *read_boxenv(Scheme_Object *obj); -static Scheme_Object *write_boxenv(Scheme_Object *obj); -static Scheme_Object *read_varref(Scheme_Object *obj); -static Scheme_Object *write_varref(Scheme_Object *obj); -static Scheme_Object *read_apply_values(Scheme_Object *obj); -static Scheme_Object *write_apply_values(Scheme_Object *obj); -static Scheme_Object *read_with_immed_mark(Scheme_Object *obj); -static Scheme_Object *write_with_immed_mark(Scheme_Object *obj); -static Scheme_Object *read_inline_variant(Scheme_Object *obj); -static Scheme_Object *write_inline_variant(Scheme_Object *obj); - -static Scheme_Object *write_application(Scheme_Object *obj); -static Scheme_Object *read_application(Scheme_Object *obj); -static Scheme_Object *write_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj); -static Scheme_Object *read_sequence_splice(Scheme_Object *obj); -static Scheme_Object *write_branch(Scheme_Object *obj); -static Scheme_Object *read_branch(Scheme_Object *obj); -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *write_quote_syntax(Scheme_Object *obj); -static Scheme_Object *read_quote_syntax(Scheme_Object *obj); - -static Scheme_Object *write_toplevel(Scheme_Object *obj); -static Scheme_Object *read_toplevel(Scheme_Object *obj); -static Scheme_Object *write_variable(Scheme_Object *obj); -static Scheme_Object *read_variable(Scheme_Object *obj); -static Scheme_Object *write_module_variable(Scheme_Object *obj); -static Scheme_Object *read_module_variable(Scheme_Object *obj); -static Scheme_Object *write_local(Scheme_Object *obj); -static Scheme_Object *read_local(Scheme_Object *obj); -static Scheme_Object *read_local_unbox(Scheme_Object *obj); -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj); - -static Scheme_Object *write_lambda(Scheme_Object *obj); -static Scheme_Object *read_lambda(Scheme_Object *obj); - -static Scheme_Object *write_module(Scheme_Object *obj); -static Scheme_Object *read_module(Scheme_Object *obj); -static Scheme_Object *read_top_level_require(Scheme_Object *obj); -static Scheme_Object *write_top_level_require(Scheme_Object *obj); - -static Scheme_Object *ht_to_vector(Scheme_Object *ht, int delay); -static Scheme_Object *closure_marshal_name(Scheme_Object *name); - -void scheme_init_marshal(Scheme_Env *env) -{ - scheme_install_type_writer(scheme_application_type, write_application); - scheme_install_type_reader(scheme_application_type, read_application); - scheme_install_type_writer(scheme_application2_type, write_application); - scheme_install_type_reader(scheme_application2_type, read_application); - scheme_install_type_writer(scheme_application3_type, write_application); - scheme_install_type_reader(scheme_application3_type, read_application); - scheme_install_type_writer(scheme_sequence_type, write_sequence); - scheme_install_type_reader(scheme_sequence_type, read_sequence); - scheme_install_type_writer(scheme_branch_type, write_branch); - scheme_install_type_reader(scheme_branch_type, read_branch); - scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark); - scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark); - scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax); - scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax); - scheme_install_type_writer(scheme_begin0_sequence_type, write_sequence); - scheme_install_type_reader(scheme_begin0_sequence_type, read_sequence_save_first); - scheme_install_type_writer(scheme_splice_sequence_type, write_sequence); - scheme_install_type_reader(scheme_splice_sequence_type, read_sequence_splice); - - scheme_install_type_writer(scheme_let_value_type, write_let_value); - scheme_install_type_reader(scheme_let_value_type, read_let_value); - scheme_install_type_writer(scheme_let_void_type, write_let_void); - scheme_install_type_reader(scheme_let_void_type, read_let_void); - scheme_install_type_writer(scheme_letrec_type, write_letrec); - scheme_install_type_reader(scheme_letrec_type, read_letrec); - scheme_install_type_writer(scheme_let_one_type, write_let_one); - scheme_install_type_reader(scheme_let_one_type, read_let_one); - scheme_install_type_writer(scheme_case_lambda_sequence_type, write_case_lambda); - scheme_install_type_reader(scheme_case_lambda_sequence_type, read_case_lambda); - - scheme_install_type_writer(scheme_define_values_type, write_define_values); - scheme_install_type_reader(scheme_define_values_type, read_define_values); - scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); - scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); - scheme_install_type_writer(scheme_begin_for_syntax_type, write_begin_for_syntax); - scheme_install_type_reader(scheme_begin_for_syntax_type, read_begin_for_syntax); - scheme_install_type_writer(scheme_set_bang_type, write_set_bang); - scheme_install_type_reader(scheme_set_bang_type, read_set_bang); - scheme_install_type_writer(scheme_boxenv_type, write_boxenv); - scheme_install_type_reader(scheme_boxenv_type, read_boxenv); - scheme_install_type_writer(scheme_varref_form_type, write_varref); - scheme_install_type_reader(scheme_varref_form_type, read_varref); - scheme_install_type_writer(scheme_apply_values_type, write_apply_values); - scheme_install_type_reader(scheme_apply_values_type, read_apply_values); - scheme_install_type_writer(scheme_with_immed_mark_type, write_with_immed_mark); - scheme_install_type_reader(scheme_with_immed_mark_type, read_with_immed_mark); - scheme_install_type_writer(scheme_inline_variant_type, write_inline_variant); - scheme_install_type_reader(scheme_inline_variant_type, read_inline_variant); - - scheme_install_type_writer(scheme_compilation_top_type, write_top); - scheme_install_type_reader(scheme_compilation_top_type, read_top); - - scheme_install_type_writer(scheme_lambda_type, write_lambda); - scheme_install_type_reader(scheme_lambda_type, read_lambda); - - scheme_install_type_writer(scheme_toplevel_type, write_toplevel); - scheme_install_type_reader(scheme_toplevel_type, read_toplevel); - scheme_install_type_writer(scheme_variable_type, write_variable); - scheme_install_type_reader(scheme_variable_type, read_variable); - scheme_install_type_writer(scheme_module_variable_type, write_module_variable); - scheme_install_type_reader(scheme_module_variable_type, read_module_variable); - scheme_install_type_writer(scheme_local_type, write_local); - scheme_install_type_reader(scheme_local_type, read_local); - scheme_install_type_writer(scheme_local_unbox_type, write_local); - scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox); - scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix); - scheme_install_type_reader(scheme_resolve_prefix_type, read_resolve_prefix); - - scheme_install_type_writer(scheme_module_type, write_module); - scheme_install_type_reader(scheme_module_type, read_module); - scheme_install_type_writer(scheme_require_form_type, write_top_level_require); - scheme_install_type_reader(scheme_require_form_type, read_top_level_require); -} - - -static Scheme_Object *write_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)obj; - - return cons(scheme_make_integer(lv->count), - cons(scheme_make_integer(lv->position), - cons(SCHEME_LET_VALUE_AUTOBOX(lv) ? scheme_true : scheme_false, - cons(scheme_protect_quote(lv->value), - scheme_protect_quote(lv->body))))); -} - -static Scheme_Object *read_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); - lv->iso.so.type = scheme_let_value_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_VALUE_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->value = SCHEME_CAR(obj); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)obj; - - return cons(scheme_make_integer(lv->count), - cons(SCHEME_LET_VOID_AUTOBOX(lv) ? scheme_true : scheme_false, - scheme_protect_quote(lv->body))); -} - -static Scheme_Object *read_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); - lv->iso.so.type = scheme_let_void_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_VOID_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_one(Scheme_Object *obj) -{ - scheme_signal_error("let-one writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_let_one(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr = (Scheme_Letrec *)obj; - Scheme_Object *l = scheme_null; - int i = lr->count; - - while (i--) { - l = cons(scheme_protect_quote(lr->procs[i]), l); - } - - return cons(scheme_make_integer(lr->count), - cons(scheme_protect_quote(lr->body), l)); -} - -static Scheme_Object *read_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr; - int i, c; - Scheme_Object **sa; - - lr = MALLOC_ONE_TAGGED(Scheme_Letrec); - - lr->so.type = scheme_letrec_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - lr->body = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (c < 0) return NULL; - if (c < 4096) - sa = MALLOC_N(Scheme_Object*, c); - else { - sa = scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(c, sizeof(Scheme_Object *), 0)); - if (!sa) scheme_signal_error("out of memory allocating letrec bytecode"); - } - lr->procs = sa; - for (i = 0; i < c; i++) { - if (!SCHEME_PAIRP(obj)) return NULL; - lr->procs[i] = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - - return (Scheme_Object *)lr; -} - -static Scheme_Object *binding_namess_to_vectors(Scheme_Object *l) -{ - Scheme_Object *r = scheme_null; - - if (!l) return scheme_null; - - while (!SCHEME_NULLP(l)) { - r = cons(cons(SCHEME_CAR(SCHEME_CAR(l)), - ht_to_vector(SCHEME_CDR(SCHEME_CAR(l)), 0)), - r); - l = SCHEME_CDR(l); - } - - return r; -} - -static Scheme_Object *write_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; - - if (!top->prefix) - scheme_contract_error("write", - "cannot marshal shared compiled code", - "compiled code", 1, obj, - NULL); - - return cons(scheme_make_integer(top->max_let_depth), - cons(binding_namess_to_vectors(top->binding_namess), - cons((Scheme_Object *)top->prefix, - scheme_protect_quote(top->code)))); -} - -static Scheme_Object *read_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - if (!SCHEME_PAIRP(obj)) return NULL; - top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (top->max_let_depth < 0) return NULL; /* Should this check for a max as well? */ - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - top->binding_namess = SCHEME_CAR(obj); /* checking is in scheme_install_binding_names() */ - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); - top->code = SCHEME_CDR(obj); - if (!SAME_TYPE(SCHEME_TYPE(top->prefix), scheme_resolve_prefix_type)) - return NULL; - - return (Scheme_Object *)top; -} - -static Scheme_Object *write_case_lambda(Scheme_Object *obj) -{ - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; - int i; - Scheme_Object *l; - - i = cl->count; - - l = scheme_null; - for (; i--; ) { - l = cons(cl->array[i], l); - } - - return cons(closure_marshal_name(cl->name), - l); -} - -static Scheme_Object *read_case_lambda(Scheme_Object *obj) -{ - Scheme_Object *s, *a; - int count, i, all_closed = 1; - Scheme_Case_Lambda *cl; - - if (!SCHEME_PAIRP(obj)) return NULL; - s = SCHEME_CDR(obj); - for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { - count++; - } - - cl = (Scheme_Case_Lambda *) - scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *)); - - cl->so.type = scheme_case_lambda_sequence_type; - cl->count = count; - cl->name = SCHEME_CAR(obj); - if (SCHEME_NULLP(cl->name)) - cl->name = NULL; - - s = SCHEME_CDR(obj); - for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { - a = SCHEME_CAR(s); - cl->array[i] = a; - if (!SCHEME_PROCP(a)) { - if (!SAME_TYPE(SCHEME_TYPE(a), scheme_lambda_type)) - return NULL; - all_closed = 0; - } - else { - if (!SAME_TYPE(SCHEME_TYPE(a), scheme_closure_type)) - return NULL; - } - } - - if (all_closed) { - /* Empty closure: produce procedure value directly. - (We assume that this was generated by a direct write of - a case-lambda data record in print.c, and that it's not - in a CASE_LAMBDA_EXPD syntax record.) */ - return scheme_case_lambda_execute((Scheme_Object *)cl); - } - - return (Scheme_Object *)cl; -} - -static Scheme_Object *read_define_values(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_values_type; - return obj; -} - -static Scheme_Object *write_define_values(Scheme_Object *obj) -{ - Scheme_Object *e; - - obj = scheme_clone_vector(obj, 0, 0); - e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); - SCHEME_VEC_ELS(obj)[0] = e; - - return obj; -} - -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_syntaxes_type; - return obj; -} - -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) -{ - return write_define_values(obj); -} - -static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_begin_for_syntax_type; - return obj; -} - -static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj) -{ - return scheme_clone_vector(obj, 0, 0); -} - -static Scheme_Object *read_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb; - - sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - sb->so.type = scheme_set_bang_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj)); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - sb->var = SCHEME_CAR(obj); - sb->val = SCHEME_CDR(obj); - - return (Scheme_Object *)sb; -} - -static Scheme_Object *write_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; - return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false), - scheme_make_pair(sb->var, - scheme_protect_quote(sb->val))); -} - -Scheme_Object *write_varref(Scheme_Object *o) -{ - int is_const = (SCHEME_VARREF_FLAGS(o) & 0x1); - - if (is_const) { - if (SCHEME_PTR1_VAL(o) != SCHEME_PTR2_VAL(o)) - scheme_signal_error("internal error: expected varref halves to be the same"); - } - - return scheme_make_pair((is_const ? scheme_true : SCHEME_PTR1_VAL(o)), - SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_varref(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_varref_form_type; - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - if (SAME_OBJ(SCHEME_CAR(o), scheme_true)) { - SCHEME_VARREF_FLAGS(data) |= 0x1; - SCHEME_PTR1_VAL(data) = SCHEME_CDR(o); - } else - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - - return data; -} - -Scheme_Object *write_apply_values(Scheme_Object *o) -{ - return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), - scheme_protect_quote(SCHEME_PTR2_VAL(o))); -} - -Scheme_Object *read_apply_values(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -Scheme_Object *write_with_immed_mark(Scheme_Object *o) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *vec, *v; - - vec = scheme_make_vector(3, NULL); - - v = scheme_protect_quote(wcm->key); - SCHEME_VEC_ELS(vec)[0] = v; - v = scheme_protect_quote(wcm->val); - SCHEME_VEC_ELS(vec)[1] = v; - v = scheme_protect_quote(wcm->body); - SCHEME_VEC_ELS(vec)[2] = v; - - return vec; -} - -Scheme_Object *read_with_immed_mark(Scheme_Object *o) -{ - Scheme_With_Continuation_Mark *wcm; - - if (!SCHEME_VECTORP(o)) return NULL; - if (SCHEME_VEC_SIZE(o) != 3) return NULL; - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_immed_mark_type; - - wcm->key = SCHEME_VEC_ELS(o)[0]; - wcm->val = SCHEME_VEC_ELS(o)[1]; - wcm->body = SCHEME_VEC_ELS(o)[2]; - - return (Scheme_Object *)wcm; -} - -Scheme_Object *write_boxenv(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_boxenv(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -static Scheme_Object *read_inline_variant(Scheme_Object *obj) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(obj)) return NULL; - - data = scheme_make_vector(3, scheme_false); - data->type = scheme_inline_variant_type; - SCHEME_VEC_ELS(data)[0] = SCHEME_CAR(obj); - SCHEME_VEC_ELS(data)[1] = SCHEME_CDR(obj); - /* third slot is filled when module->accessible table is made */ - - return data; -} - -static Scheme_Object *write_inline_variant(Scheme_Object *obj) -{ - return scheme_make_pair(SCHEME_VEC_ELS(obj)[0], - SCHEME_VEC_ELS(obj)[1]); -} - - -#define BOOL(x) (x ? scheme_true : scheme_false) - -static Scheme_Object *write_application(Scheme_Object *obj) -{ - scheme_signal_error("app writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_application(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_sequence(Scheme_Object *obj) -{ - Scheme_Object *l; - int i; - - i = ((Scheme_Sequence *)obj)->count; - - l = scheme_null; - for (; i--; ) { - l = cons(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), l); - } - - return l; -} - -static Scheme_Object *read_sequence(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, 1, 1); -} - -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, -2, 1); -} - -static Scheme_Object *read_sequence_splice(Scheme_Object *obj) -{ - obj = scheme_make_sequence_compilation(obj, 1, 1); - if (!obj) return NULL; - - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type)) - obj->type = scheme_splice_sequence_type; - return obj; -} - -static Scheme_Object *write_branch(Scheme_Object *obj) -{ - scheme_signal_error("branch writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_branch(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - wcm = (Scheme_With_Continuation_Mark *)obj; - - return cons(scheme_protect_quote(wcm->key), - cons(scheme_protect_quote(wcm->val), - scheme_protect_quote(wcm->body))); -} - -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj))) - return NULL; /* bad .zo */ - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_cont_mark_type; - wcm->key = SCHEME_CAR(obj); - wcm->val = SCHEME_CADR(obj); - wcm->body = SCHEME_CDR(SCHEME_CDR(obj)); - - return (Scheme_Object *)wcm; -} - -static Scheme_Object *write_quote_syntax(Scheme_Object *obj) -{ - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - - return cons(scheme_make_integer(qs->depth), - cons(scheme_make_integer(qs->position), - scheme_make_integer(qs->midpoint))); -} - -static Scheme_Object *read_quote_syntax(Scheme_Object *obj) +void scheme_init_marshal(Scheme_Startup_Env *env) { - Scheme_Quote_Syntax *qs; - Scheme_Object *a; - int c, i, p; - - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - c = SCHEME_INT_VAL(a); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - i = SCHEME_INT_VAL(a); - - a = SCHEME_CDR(obj); - p = SCHEME_INT_VAL(a); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; + /* nothing */ } -#define BOOL(x) (x ? scheme_true : scheme_false) - static int not_relative_path(Scheme_Object *p, Scheme_Hash_Table *cache) { Scheme_Object *dir, *rel_p; @@ -758,7 +47,7 @@ return 0; } -static Scheme_Object *closure_marshal_name(Scheme_Object *name) +Scheme_Object *scheme_closure_marshal_name(Scheme_Object *name) { if (name) { if (SCHEME_VECTORP(name)) { @@ -783,16 +72,20 @@ return name; } -static Scheme_Object *write_lambda(Scheme_Object *obj) +void scheme_write_lambda(Scheme_Object *obj, + Scheme_Object **_name, + Scheme_Object **_ds, + Scheme_Object **_closure_map, + Scheme_Object **_tl_map) { Scheme_Lambda *data; - Scheme_Object *name, *l, *code, *ds, *tl_map; + Scheme_Object *name, *code, *ds, *tl_map, *closure_map; int svec_size, pos; Scheme_Marshal_Tables *mt; data = (Scheme_Lambda *)obj; - name = closure_marshal_name(data->name); + name = scheme_closure_marshal_name(data->name); svec_size = data->closure_size; if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { @@ -826,7 +119,6 @@ case scheme_true_type: case scheme_false_type: case scheme_void_type: - case scheme_quote_syntax_type: ds = code; break; default: @@ -922,53 +214,35 @@ } } - l = CONS(scheme_make_svector(svec_size, - data->closure_map), - ds); - - if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) - l = CONS(scheme_make_integer(data->closure_size), - l); - - return CONS(scheme_make_integer(SCHEME_LAMBDA_FLAGS(data) & 0x7F), - CONS(scheme_make_integer(data->num_params), - CONS(scheme_make_integer(data->max_let_depth), - CONS(tl_map, - CONS(name, - l))))); + *_name = name; + *_ds = ds; + closure_map = scheme_make_svector(svec_size, data->closure_map); + *_closure_map = closure_map; + *_tl_map = tl_map; } -static Scheme_Object *read_lambda(Scheme_Object *obj) +Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, int max_let_depth, + Scheme_Object *name, + Scheme_Object *ds, + Scheme_Object *closure_map, + Scheme_Object *tl_map) { Scheme_Lambda *data; - Scheme_Object *v, *tl_map; #define BAD_CC "bad compiled closure" #define X_SCHEME_ASSERT(x, y) data = (Scheme_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Lambda)); - data->iso.so.type = scheme_lambda_type; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - SCHEME_LAMBDA_FLAGS(data) = (short)(SCHEME_INT_VAL(v)); + SCHEME_LAMBDA_FLAGS(data) = (short)flags; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - data->num_params = SCHEME_INT_VAL(v); + data->num_params = num_params; if (data->num_params < 0) return NULL; - if (!SCHEME_PAIRP(obj)) return NULL; - data->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + data->max_let_depth = max_let_depth; if (data->max_let_depth < 0) return NULL; - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - tl_map = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); if (!SCHEME_FALSEP(tl_map)) { if (SCHEME_INTP(tl_map)) data->tl_map = (void *)tl_map; @@ -993,38 +267,21 @@ return NULL; } - if (!SCHEME_PAIRP(obj)) return NULL; - data->name = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + data->name = name; if (SCHEME_NULLP(data->name)) data->name = NULL; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + data->body = ds; - /* v is an svector or an integer... */ - if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { - if (!SCHEME_INTP(v)) return NULL; - data->closure_size = SCHEME_INT_VAL(v); - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } + if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(closure_map))) return NULL; + data->closure_map = SCHEME_SVEC_VEC(closure_map); - data->body = obj; - - if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL; - - if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS)) - data->closure_size = SCHEME_SVEC_LEN(v); - - if ((SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS)) - if (data->closure_size + scheme_boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(v)) - return NULL; - - data->closure_map = SCHEME_SVEC_VEC(v); + if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { + data->closure_size = closure_size; + if (data->closure_size + scheme_boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(closure_map)) + return NULL; + } else + data->closure_size = SCHEME_SVEC_LEN(closure_map); /* If the closure is empty, create the closure now */ if (!data->closure_size) @@ -1033,1020 +290,221 @@ return (Scheme_Object *)data; } - -static Scheme_Object *write_toplevel(Scheme_Object *obj) -{ - int pos, flags; - Scheme_Object *pr; - - pos = SCHEME_TOPLEVEL_POS(obj); - flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); - - pr = (flags - ? scheme_make_pair(scheme_make_integer(pos), - scheme_make_integer(flags)) - : scheme_make_integer(pos)); - - return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)), - pr); -} - -static Scheme_Object *read_toplevel(Scheme_Object *obj) +static Scheme_Object *hash_tree_to_vector(Scheme_Hash_Tree *ht) { - int pos, depth, flags; + Scheme_Object **keys; + Scheme_Object *vec, *k, *v; + int i = 0, pos = 0; - if (!SCHEME_PAIRP(obj)) return NULL; + vec = scheme_make_vector(2 * ht->count, NULL); - depth = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); + keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - if (SCHEME_PAIRP(obj)) { - pos = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK; - } else { - pos = (int)SCHEME_INT_VAL(obj); - flags = 0; + for (i = 0; i < ht->count; i++) { + k = keys[i]; + v = scheme_hash_tree_get(ht, k); + SCHEME_VEC_ELS(vec)[pos++] = k; + SCHEME_VEC_ELS(vec)[pos++] = v; } - if (depth < 0) return NULL; - if (pos < 0) return NULL; - - return scheme_make_toplevel(depth, pos, 1, flags); -} - -static Scheme_Object *write_variable(Scheme_Object *obj) - /* #%kernel references are handled in print.c, instead */ -{ - Scheme_Object *sym; - Scheme_Env *home; - Scheme_Module *m; - - sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key; - - home = scheme_get_bucket_home((Scheme_Bucket *)obj); - if (home) - m = home->module; - else - m = NULL; - - /* If we get a writeable variable (instead of a module variable), - it must be a reference to a module referenced directly by its - a symbolic name (i.e., no path). */ - - if (m) { - sym = scheme_make_pair(m->modname, sym); - if (home->mod_phase) - sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym); - } - - return sym; -} - -static Scheme_Object *read_variable(Scheme_Object *obj) - /* #%kernel references are handled in read.c, instead */ -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - if (!SCHEME_SYMBOLP(obj)) return NULL; - - return (Scheme_Object *)scheme_global_bucket(obj, env); -} - -static Scheme_Object *write_module_variable(Scheme_Object *obj) -{ - scheme_signal_error("module variables should have been handled in print.c"); - return NULL; + return vec; } -static Scheme_Object *read_module_variable(Scheme_Object *obj) +Scheme_Object *scheme_write_linklet(Scheme_Object *obj) { - scheme_signal_error("module variables should have been handled in read.c"); - return NULL; -} + Scheme_Linklet *linklet = (Scheme_Linklet *)obj; + Scheme_Object *l; -static Scheme_Object *write_local(Scheme_Object *obj) -{ - return scheme_make_integer(SCHEME_LOCAL_POS(obj)); -} + if (linklet->jit_ready) + scheme_arg_mismatch("write", + "cannot marshal linklet that has been evaluated", + obj); -static Scheme_Object *do_read_local(Scheme_Type t, Scheme_Object *obj) -{ - int n, flags; + l = scheme_null; + + if (linklet->import_shapes) + l = scheme_make_pair(linklet->import_shapes, l); + else + l = scheme_make_pair(scheme_false, l); - if (SCHEME_PAIRP(obj)) { - flags = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - } else - flags = 0; + l = scheme_make_pair(linklet->importss, l); + l = scheme_make_pair(linklet->defns, l); + l = scheme_make_pair(hash_tree_to_vector(linklet->source_names), l); - n = (int)SCHEME_INT_VAL(obj); - if (n < 0) return NULL; + l = scheme_make_pair(linklet->bodies, l); - return scheme_make_local(t, n, flags); -} + l = scheme_make_pair(scheme_make_integer(linklet->num_exports), l); + l = scheme_make_pair(scheme_make_integer(linklet->num_lifts), l); + l = scheme_make_pair(scheme_make_integer(linklet->max_let_depth), l); + l = scheme_make_pair((linklet->need_instance_access ? scheme_true : scheme_false), l); -static Scheme_Object *read_local(Scheme_Object *obj) -{ - return do_read_local(scheme_local_type, obj); -} + l = scheme_make_pair(linklet->name, l); -static Scheme_Object *read_local_unbox(Scheme_Object *obj) -{ - return do_read_local(scheme_local_unbox_type, obj); + return l; } -static Scheme_Object *make_delayed_syntax(Scheme_Object *stx) -{ - Scheme_Object *ds; - Scheme_Marshal_Tables *mt; - - mt = scheme_current_thread->current_mt; - if (mt->pass < 0) - return stx; - - ds = scheme_alloc_small_object(); - ds->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = stx; - - return ds; -} +#if 0 +# define return_NULL() return (printf("%d\n", __LINE__), NULL) +#else +# define return_NULL() return NULL +#endif -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj) +static int is_vector_of_symbols(Scheme_Object *v, int false_ok) { - Resolve_Prefix *rp = (Resolve_Prefix *)obj; - Scheme_Object *tv, *sv, *ds; int i; - i = rp->num_toplevels; - tv = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(tv)[i] = rp->toplevels[i]; - } - - i = rp->num_stxes; - sv = scheme_make_vector(i, NULL); - while (i--) { - if (rp->stxes[i]) { - if (SCHEME_INTP(rp->stxes[i])) { - /* Need to force this object, so we can write it. - This should only happen if we're writing back - code loaded from bytecode. */ - scheme_load_delayed_syntax(rp, i); - } - - ds = make_delayed_syntax(rp->stxes[i]); - } else - ds = scheme_false; - SCHEME_VEC_ELS(sv)[i] = ds; - } - - tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), - scheme_make_pair(tv, sv)); - - tv = scheme_make_pair(rp->src_insp_desc, tv); + if (!SCHEME_VECTORP(v)) + return 0; - return tv; -} - -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) -{ - Resolve_Prefix *rp; - Scheme_Object *tv, *sv, **a, *stx, *tl, *insp_desc; - intptr_t i; - - if (!SCHEME_PAIRP(obj)) return NULL; - insp_desc = SCHEME_CAR(obj); - if (!SCHEME_SYMBOLP(insp_desc)) - return NULL; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - - if (!SCHEME_INTP(SCHEME_CAR(obj))) { - obj = SCHEME_CDR(obj); - } - - if (!SCHEME_PAIRP(obj)) return NULL; - - i = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (i < 0) return NULL; - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - tv = SCHEME_CAR(obj); - sv = SCHEME_CDR(obj); - - if (!SCHEME_VECTORP(tv)) return NULL; - if (!SCHEME_VECTORP(sv)) return NULL; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = (int)SCHEME_VEC_SIZE(tv); - rp->num_stxes = (int)SCHEME_VEC_SIZE(sv); - rp->num_lifts = (int)i; - - i = rp->num_toplevels; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - tl = SCHEME_VEC_ELS(tv)[i]; - if (!SCHEME_FALSEP(tl) - && !SCHEME_SYMBOLP(tl) - && !SAME_TYPE(SCHEME_TYPE(tl), scheme_variable_type) - && !SAME_TYPE(SCHEME_TYPE(tl), scheme_module_variable_type)) - return NULL; - a[i] = tl; - } - rp->toplevels = a; - - i = rp->num_stxes; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - stx = SCHEME_VEC_ELS(sv)[i]; - if (SCHEME_FALSEP(stx)) { - stx = NULL; - } else if (SCHEME_RPAIRP(stx)) { - struct Scheme_Load_Delay *d; - Scheme_Object *pr; - d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx); - stx = SCHEME_CAR(stx); - pr = rp->delay_info_rpair; - if (!pr) { - pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d); - rp->delay_info_rpair = pr; - } - SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1); - } else { - if (!SCHEME_STXP(stx)) return NULL; - } - a[i] = stx; - } - rp->stxes = a; - - rp->src_insp_desc = insp_desc; - - return (Scheme_Object *)rp; -} - -static Scheme_Object *ht_to_vector(Scheme_Object *ht, int delay) -/* recurs for values in hash table; we assume that such nesting is shallow */ -{ - intptr_t i, j, c; - Scheme_Object **sorted_keys; - Scheme_Object *k, *val, *vec; - - if (!ht) - return scheme_false; - if (SCHEME_VECTORP(ht)) { - /* may need to force delayed syntax: */ - c = SCHEME_VEC_SIZE(ht); - for (i = 0; i < c; i += 2) { - val = SCHEME_VEC_ELS(ht)[i+1]; - if (!SAME_OBJ(scheme_true, val)) { - k = scheme_stx_force_delayed(val); - if (!SAME_OBJ(k, val)) - SCHEME_VEC_ELS(ht)[i+1] = k; - } - } - return ht; - } - - if (SCHEME_HASHTRP(ht)) - c = ((Scheme_Hash_Tree *)ht)->count; - else - c = ((Scheme_Hash_Table *)ht)->count; - - vec = scheme_make_vector(2 * c, NULL); - j = 0; - - sorted_keys = scheme_extract_sorted_keys(ht); - - if (SCHEME_HASHTRP(ht)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht; - for (i = 0; i < c; i++) { - k = sorted_keys[i]; - val = scheme_hash_tree_get(t, k); - if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val)) - val = ht_to_vector(val, delay); - else if (delay && !SAME_OBJ(val, scheme_true)) - val = make_delayed_syntax(val); - SCHEME_VEC_ELS(vec)[j++] = k; - SCHEME_VEC_ELS(vec)[j++] = val; - } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht; - for (i = 0; i < c; i++) { - k = sorted_keys[i]; - val = scheme_hash_get(t, k); - if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val)) - val = ht_to_vector(val, delay); - else if (delay && !SAME_OBJ(val, scheme_true)) - val = make_delayed_syntax(val); - SCHEME_VEC_ELS(vec)[j++] = k; - SCHEME_VEC_ELS(vec)[j++] = val; - } + for (i = SCHEME_VEC_SIZE(v); i--; ) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[i]) + && (!false_ok || !SCHEME_FALSEP(SCHEME_VEC_ELS(v)[i]))) + return 0; } - return vec; + return 1; } -static Scheme_Object *protect_expr_quotes(Scheme_Object *body) -/* protect each expression in a phase-1-or-higher module-body vector */ +static int is_vector_of_shapes(Scheme_Object *v) { - Scheme_Object *e, *v, *v2, *body2 = NULL; - int i, j; - - for (j = SCHEME_VEC_SIZE(body); j--; ) { - v = SCHEME_VEC_ELS(body)[j]; - e = scheme_protect_quote(SCHEME_VEC_ELS(v)[1]); - if (!SAME_OBJ(e, SCHEME_VEC_ELS(v)[1])) { - i = SCHEME_VEC_SIZE(v); - v2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(v2)[i] = SCHEME_VEC_ELS(v)[i]; - } - SCHEME_VEC_ELS(v2)[1] = e; - v = v2; - - if (!body2) { - i = SCHEME_VEC_SIZE(body); - body2 = scheme_make_vector(i, NULL); - while (--i > j) { - SCHEME_VEC_ELS(body2)[i] = SCHEME_VEC_ELS(body)[i]; - } - } - } + int i; + Scheme_Object *s; - if (body2) - SCHEME_VEC_ELS(body2)[j] = v; + if (!SCHEME_VECTORP(v)) + return 0; + + for (i = SCHEME_VEC_SIZE(v); i--; ) { + s = SCHEME_VEC_ELS(v)[i]; + if (SCHEME_TRUEP(s) + && !SCHEME_SYMBOLP(s) + && !SCHEME_INTP(s) + && !SAME_OBJ(s, scheme_true) + && !SAME_OBJ(s, scheme_void)) + return 0; } - return (body2 ? body2 : body); + return 1; } -static Scheme_Object *write_module(Scheme_Object *obj) +static int is_vector_of_vector_of_symbols(Scheme_Object *v) { - Scheme_Module *m = (Scheme_Module *)obj; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *l, *v, *phase; - int i, j, k, count, cnt; - Scheme_Object **sorted_keys; - - l = scheme_null; - cnt = 0; - if (m->other_requires) { - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->other_requires); - cnt = m->other_requires->count; - for (i = 0; i < cnt; i++) { - l = scheme_make_pair(sorted_keys[i], - scheme_make_pair(scheme_hash_get(m->other_requires, - sorted_keys[i]), - l)); - } - } - l = cons(scheme_make_integer(cnt), l); - - l = cons(m->dt_requires, l); - l = cons(m->tt_requires, l); - l = cons(m->et_requires, l); - l = cons(m->requires, l); - - for (j = 0; j < m->num_phases; j++) { - v = m->bodies[j]; - if (j > 0) - v = protect_expr_quotes(v); - l = cons(v, l); - } - - cnt = 0; - if (m->me->other_phases) - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->me->other_phases); - else - sorted_keys = NULL; - for (k = -3; k < (m->me->other_phases ? m->me->other_phases->count : 0); k++) { - switch (k) { - case -3: - phase = scheme_make_integer(-1); - pt = m->me->dt; - break; - case -2: - phase = scheme_make_integer(1); - pt = m->me->et; - break; - case -1: - phase = scheme_make_integer(0); - pt = m->me->rt; - break; - default: - phase = sorted_keys[k]; - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, phase); - } - - if (pt) { - l = cons(scheme_make_integer(pt->num_provides), l); - l = cons(scheme_make_integer(pt->num_var_provides), l); - - count = pt->num_provides; - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provides[i]; - } - l = cons(v, l); - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_srcs[i]; - } - l = cons(v, l); - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_src_names[i]; - } - l = cons(v, l); - - if (pt->provide_nominal_srcs) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_nominal_srcs[i]; - } - l = cons(v, l); - } else { - l = cons(scheme_false, l); - } - - if (pt->provide_src_phases) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = scheme_make_integer(pt->provide_src_phases[i]); - } - } else - v = scheme_false; - l = cons(v, l); - - if ((SCHEME_INT_VAL(phase) >= 0) && (SCHEME_INT_VAL(phase) < m->num_phases)) { - Scheme_Module_Export_Info *exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; - - if (exp_info) { - v = scheme_false; - - if (exp_info->provide_protects) { - for (i = 0; i < count; i++) { - if (exp_info->provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (exp_info->provide_protects[i] ? scheme_true : scheme_false); - } - } - } - l = cons(v, l); - - count = exp_info->num_indirect_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = exp_info->indirect_provides[i]; - } - l = cons(v, l); - - count = exp_info->num_indirect_syntax_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = exp_info->indirect_syntax_provides[i]; - } - l = cons(v, l); - } else - l = cons(scheme_void, l); - } else - l = cons(scheme_void, l); - - l = cons(pt->phase_index, l); - cnt++; - } - } - l = cons(scheme_make_integer(cnt), l); - l = cons(scheme_make_integer(m->num_phases), l); - - l = cons((Scheme_Object *)m->prefix, l); - l = cons(m->dummy, l); - - l = cons(scheme_make_integer(m->max_let_depth), l); - - v = m->rn_stx; - if (!v) - v = scheme_false; - else if (!SAME_OBJ(v, scheme_true)) { - v = scheme_stx_force_delayed(v); - if (!SAME_OBJ(v, m->rn_stx)) - m->rn_stx = v; - v = make_delayed_syntax(v); - } - l = cons(v, l); - - /* previously recorded "functional?" info: */ - l = cons(scheme_false, l); - l = cons(scheme_false, l); - - if (m->lang_info) - l = cons(scheme_protect_quote(m->lang_info), l); - else - l = cons(scheme_false, l); - - for (k = 0; k < 2; k++) { - v = (k ? m->pre_submodules : m->post_submodules); - if (v && !SCHEME_NULLP(v)) { - Scheme_Object *l2 = scheme_null; - while (!SCHEME_NULLP(v)) { - l2 = scheme_make_pair(write_module(SCHEME_CAR(v)), - l2); - v = SCHEME_CDR(v); - } - l = cons(l2, l); - } else - l = cons(scheme_null, l); - } - - l = cons((m->phaseless ? scheme_true : scheme_false), l); + int i; - l = cons(ht_to_vector(m->other_binding_names, 1), l); - l = cons(ht_to_vector(m->et_binding_names, 1), l); - l = cons(ht_to_vector(m->binding_names, 1), l); - l = cons(m->me->src_modidx, l); + if (!SCHEME_VECTORP(v)) + return 0; - l = cons(scheme_resolved_module_path_value(m->modsrc), l); - l = cons(scheme_resolved_module_path_value(m->modname), l); - - if (m->submodule_path) - l = cons(m->submodule_path, l); - else - l = cons(scheme_null, l); - - return l; -} - -static int check_requires_ok(Scheme_Object *l) -{ - Scheme_Object *x; - while (!SCHEME_NULLP(l)) { - x = SCHEME_CAR(l); - if (!SAME_TYPE(SCHEME_TYPE(x), scheme_module_index_type)) + for (i = SCHEME_VEC_SIZE(v); i--; ) { + if (!is_vector_of_symbols(SCHEME_VEC_ELS(v)[i], 0)) return 0; - l = SCHEME_CDR(l); } + return 1; } -#if 0 -# define return_NULL() return (printf("%d\n", __LINE__), NULL) -#else -# define return_NULL() return NULL -#endif - -static Scheme_Object *read_module(Scheme_Object *obj) +static Scheme_Object *vector_to_hash_tree(Scheme_Object *vec) { - Scheme_Module *m; - Scheme_Object *ie, *nie, **bodies, *bns; - Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; - Scheme_Module_Exports *me; - Scheme_Module_Phase_Exports *pt; - Scheme_Module_Export_Info **exp_infos, *exp_info; - char *ps; - int *sps; - int i, j, count, cnt; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; + Scheme_Hash_Tree *ht; + int i = 0; - me = scheme_make_module_exports(); - m->me = me; + if (!SCHEME_VECTORP(vec)) + return NULL; + if (SCHEME_VEC_SIZE(vec) & 0x1) + return NULL; - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - m->submodule_path = e; - if (!scheme_is_list(e)) return_NULL(); - while (!SCHEME_NULLP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); + ht = scheme_make_hash_tree(0); + for (i = SCHEME_VEC_SIZE(vec) - 2; i >= 0; i -= 2) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(vec)[i]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(vec)[i+1])) + return NULL; + ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(vec)[i], SCHEME_VEC_ELS(vec)[i+1]); } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modname = e; - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modsrc = e; - m->me->modsrc = e; - obj = SCHEME_CDR(obj); + return (Scheme_Object *)ht; +} - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->src_modidx = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SAME_TYPE(SCHEME_TYPE(me->src_modidx), scheme_module_index_type)) - return_NULL(); - ((Scheme_Modidx *)me->src_modidx)->resolved = m->modname; - m->self_modidx = me->src_modidx; +Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok) +{ + Scheme_Linklet *linklet = (Scheme_Linklet *)obj; + Scheme_Object *e, *a; - if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->binding_names = bns; - } - obj = SCHEME_CDR(obj); + linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + linklet->so.type = scheme_linklet_type; if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->et_binding_names = bns; - } + linklet->name = SCHEME_CAR(obj); + if (!SCHEME_SYMBOLP(linklet->name)) return_NULL(); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->other_binding_names = bns; - } + linklet->need_instance_access = SCHEME_TRUEP(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - m->phaseless = (SCHEME_TRUEP(SCHEME_CAR(obj)) ? scheme_true : NULL); - obj = SCHEME_CDR(obj); - - for (i = 0; i < 2; i++) { - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - nve = scheme_null; - while (!SCHEME_NULLP(e)) { - if (!SCHEME_PAIRP(e)) return_NULL(); - ne = read_module(SCHEME_CAR(e)); - nve = scheme_make_pair(ne, nve); - e = SCHEME_CDR(e); - } - if (i) - m->post_submodules = nve; - else - m->pre_submodules = nve; - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); e = SCHEME_CAR(obj); - if (SCHEME_FALSEP(e)) - e = NULL; - else if (!(SCHEME_VECTORP(e) - && (3 == SCHEME_VEC_SIZE(e)) - && scheme_is_module_path(SCHEME_VEC_ELS(e)[0]) - && SCHEME_SYMBOLP(SCHEME_VEC_ELS(e)[1]))) - return_NULL(); - m->lang_info = e; + linklet->max_let_depth = SCHEME_INT_VAL(e); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ + e = SCHEME_CAR(obj); + linklet->num_lifts = SCHEME_INT_VAL(e); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ + e = SCHEME_CAR(obj); + linklet->num_exports = SCHEME_INT_VAL(e); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - m->rn_stx = SCHEME_CAR(obj); + a = SCHEME_CAR(obj); + if (!SCHEME_VECTORP(a)) return_NULL(); + linklet->bodies = a; obj = SCHEME_CDR(obj); - if (SCHEME_FALSEP(m->rn_stx)) - m->rn_stx = NULL; if (!SCHEME_PAIRP(obj)) return_NULL(); - m->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + a = vector_to_hash_tree(SCHEME_CAR(obj)); + if (!a) return_NULL(); + linklet->source_names = (Scheme_Hash_Tree *)a; obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - m->dummy = SCHEME_CAR(obj); + a = SCHEME_CAR(obj); + if (!is_vector_of_symbols(a, 1)) return_NULL(); + linklet->defns = a; obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); + a = SCHEME_CAR(obj); + if (!is_vector_of_vector_of_symbols(a)) return_NULL(); + linklet->importss = a; obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (cnt < 1) return_NULL(); - - m->num_phases = cnt; - exp_infos = (Scheme_Module_Export_Info **)scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(cnt, sizeof(Scheme_Module_Export_Info *), 0)); - while (cnt--) { - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[cnt] = exp_info; + a = SCHEME_CAR(obj); + if (!SCHEME_FALSEP(a)) { + if (!is_vector_of_shapes(a)) return_NULL(); + linklet->import_shapes = a; } - m->exp_infos = exp_infos; - cnt = m->num_phases; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (cnt < 0) return_NULL(); - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - pt = me->rt; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - pt = me->et; - } else if (SAME_OBJ(phase, scheme_false)) { - pt = me->dt; - } else { - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = phase; - if (!me->other_phases) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - me->other_phases = ht; - } - scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (SCHEME_VOIDP(ie)) { - /* no exp_infos entry */ - count = -1; - } else { - if (!SCHEME_INTP(phase) || (SCHEME_INT_VAL(phase) < 0) - || (SCHEME_INT_VAL(phase) >= m->num_phases)) - return_NULL(); - exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - exp_info->indirect_syntax_provides = v; - exp_info->num_indirect_syntax_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - exp_info->indirect_provides = v; - exp_info->num_indirect_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (SCHEME_FALSEP(esp)) { - exp_info->provide_protects = NULL; - count = -1; - } else { - if (!SCHEME_VECTORP(esp)) return_NULL(); - count = SCHEME_VEC_SIZE(esp); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); - } - exp_info->provide_protects = ps; - } - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esph = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esnom = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esn = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - es = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nve = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ne = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if ((count != -1) && (SCHEME_INT_VAL(ne) != count)) return_NULL(); - - count = SCHEME_INT_VAL(ne); - pt->num_provides = count; - pt->num_var_provides = SCHEME_INT_VAL(nve); - - if (!SCHEME_VECTORP(e) || (SCHEME_VEC_SIZE(e) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(e)[i]; - } - pt->provides = v; - - if (!SCHEME_VECTORP(es) || (SCHEME_VEC_SIZE(es) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(es)[i]; - } - pt->provide_srcs = v; - - if (!SCHEME_VECTORP(esn) || (SCHEME_VEC_SIZE(esn) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esn)[i]; - } - pt->provide_src_names = v; - - if (SCHEME_FALSEP(esnom)) { - pt->provide_nominal_srcs = NULL; - } else { - if (!SCHEME_VECTORP(esnom) || (SCHEME_VEC_SIZE(esnom) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esnom)[i]; - } - pt->provide_nominal_srcs = v; - } - - if (SCHEME_FALSEP(esph)) - sps = NULL; - else { - if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); - sps = MALLOC_N_ATOMIC(int, count); - for (i = 0; i < count; i++) { - sps[i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(esph)[i]); - } - } - pt->provide_src_phases = sps; - } - - count = me->rt->num_provides; + if (linklet->num_exports > SCHEME_VEC_SIZE(linklet->defns)) + return_NULL(); + if (linklet->num_lifts > (SCHEME_VEC_SIZE(linklet->defns) - linklet->num_exports)) + return_NULL(); - bodies = MALLOC_N(Scheme_Object*, m->num_phases); - m->bodies = bodies; - for (j = m->num_phases; j--; ) { - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - if (j) { - bodies[j] = e; - for (i = SCHEME_VEC_SIZE(e); i--; ) { - e = SCHEME_VEC_ELS(bodies[j])[i]; - if (!SCHEME_VECTORP(e)) return_NULL(); - if (SCHEME_VEC_SIZE(e) != 5) return_NULL(); - /* SCHEME_VEC_ELS(e)[1] should be code */ - if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) - return_NULL(); - if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[0])) { - if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[4])) return_NULL(); - } else { - e = SCHEME_VEC_ELS(e)[0]; - if (!SCHEME_SYMBOLP(e)) { - while (SCHEME_PAIRP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); - } - if (!SCHEME_NULLP(e)) return_NULL(); - } - } - } - } else { - bodies[j] = e; + { + int i = 0, j; + for (j = SCHEME_VEC_SIZE(linklet->importss); j--; ) { + i += SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[j]); } - obj = SCHEME_CDR(obj); + linklet->num_total_imports = i; } - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->et_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->tt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->dt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) + if (linklet->import_shapes) { + if (linklet->num_total_imports != SCHEME_VEC_SIZE(linklet->import_shapes)) return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1)) - || SAME_OBJ(phase, scheme_make_integer(-1))) - return_NULL(); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - if (!check_requires_ok(e)) return_NULL(); - - if (!m->other_requires) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - m->other_requires = ht; - } - scheme_hash_set(m->other_requires, phase, e); - - obj = SCHEME_CDR(obj); } - - return (Scheme_Object *)m; -} - -Scheme_Object *write_top_level_require(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_top_level_require(Scheme_Object *o) -{ - Scheme_Object *data; - if (!SCHEME_PAIRP(o)) return NULL; + if (!unsafe_ok) + linklet->reject_eval = 1; - data = scheme_alloc_object(); - data->type = scheme_require_form_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; + return (Scheme_Object *)linklet; } diff -Nru racket-6.12+ppa1/src/racket/src/module.c racket-7.0+ppa1/src/racket/src/module.c --- racket-6.12+ppa1/src/racket/src/module.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/module.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,13081 +0,0 @@ -/* - Racket - Copyright (c) 2004-2018 PLT Design Inc. - Copyright (c) 2000-2001 Matthew Flatt - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301 USA. -*/ - -/* This file implements the first-order, top-level module system -- - both the expander and compiler front-end, as well as run-time - support for modules. An initiantiated module is implemented - essentially as a namespace. The bindings at the top level of a - module are namespace top-level bindings. */ - -#include "schpriv.h" -#include "schmach.h" -#include "schexpobs.h" - -#define mz_MIN(l,o) ((l) < (o) ? (l) : (o)) - -/* globals */ -SHARED_OK Scheme_Object *(*scheme_module_demand_hook)(int, Scheme_Object **); -THREAD_LOCAL_DECL(Scheme_Bucket_Table *scheme_module_code_cache); - -SHARED_OK static Scheme_Bucket_Table *modpath_table; -#ifdef MZ_USE_PLACES -SHARED_OK static mzrt_mutex *modpath_table_mutex; -#else -# define mzrt_mutex_lock(l) /* empty */ -# define mzrt_mutex_unlock(l) /* empty */ -#endif - -/* locals */ -static Scheme_Object *current_module_name_resolver(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_name_prefix(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_name_source(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_load_path(int argc, Scheme_Object *argv[]); -static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_attach_module_decl(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_indirect_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_submodules(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_phaseless_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_indirect_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_is_declared(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_is_predefined(int argc, Scheme_Object *argv[]); - -static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[]); - -static Scheme_Object *is_module_path(int argc, Scheme_Object **argv); - -static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[]); -static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[]); - -static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv); - -/* syntax */ -static Scheme_Object *module_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *modulestar_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *modulestar_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *module_begin_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *declare_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *declare_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *require_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *provide_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who); - -static void run_module(Scheme_Env *menv, int set_ns); -static void run_module_exptime(Scheme_Env *menv, int phase); - -static void eval_exptime(Scheme_Object *names, int count, - Scheme_Object *expr, - Scheme_Env *genv, Scheme_Comp_Env *env, - Resolve_Prefix *rp, int let_depth, int shift, - Scheme_Bucket_Table *syntax, int at_phase, - Scheme_Object *ids_for_rename_trans, - Scheme_Object *insp); - -typedef struct Module_Begin_Expand_State { - /* All pointers, because it's allocated with scheme_malloc(): */ - Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ - Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ - Scheme_Hash_Tree *all_defs; /* phase -> list of sxtid */ - Scheme_Hash_Table *all_defs_out; /* phase -> list of (cons protected? (stx-list except-name ...)) */ - int *all_simple_bindings; /* can we reconstruct bindings for `module->namespace`? */ - int *_num_phases; - Scheme_Object *saved_provides; /* list of (cons form phase) */ - Scheme_Object *saved_submodules; /* list of (cons form phase) */ - Scheme_Hash_Table *submodule_names; /* symbol -> #t (pre-module) or # (post-module) */ - Scheme_Hash_Table *modidx_cache; - Scheme_Object *redef_modname; - Scheme_Object *end_statementss; /* list of lists */ - Scheme_Object *modsrc; /* source for top-level module */ - Scheme_Object **sub_iidx_ptrs; /* contains `iidx`es for `(module* name #f ...)` submodules */ -} Module_Begin_Expand_State; - -static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int phase, Scheme_Object *body_lists, - Module_Begin_Expand_State *bxs); - -static Scheme_Object *expand_all_provides(Scheme_Object *form, - Scheme_Comp_Env *cenv, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *self_modidx, - Module_Begin_Expand_State *bxs, - int keep_expanded); - -static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Comp_Env *env, - Scheme_Object *l, int post, - Module_Begin_Expand_State *bxs, - int keep_expanded); - -static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, - Scheme_Object *expanded_provides, - int phase, - int kind); - -static void check_formerly_unbound(Scheme_Object *unbounds, Scheme_Comp_Env *env); -static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx); -static int is_modulestar_stop(Scheme_Comp_Env *env); - -typedef int (*Convert_Submodule_Proc)(Scheme_Object *mp, Scheme_Object *data); -static Scheme_Object *convert_submodule_path(Scheme_Object *name, - Convert_Submodule_Proc check, - Scheme_Object *check_data); -static int check_is_submodule(Scheme_Object *modname, Scheme_Object *_genv); - -static Scheme_Object *sys_wraps_phase(intptr_t p); - -static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b); - -static int phaseless_rhs(Scheme_Object *val, int var_count, int phase); - -#define cons scheme_make_pair - -/* global read-only kernel stuff */ -READ_ONLY static Scheme_Object *kernel_modname; -READ_ONLY static Scheme_Object *kernel_symbol; -READ_ONLY static Scheme_Object *kernel_modidx; -READ_ONLY static Scheme_Module *kernel; -READ_ONLY static Scheme_Object *flfxnum_modname; -READ_ONLY static Scheme_Object *extfl_modname; -READ_ONLY static Scheme_Object *futures_modname; -READ_ONLY static Scheme_Object *unsafe_modname; -READ_ONLY static Scheme_Object *foreign_modname; - -/* global read-only symbols */ -ROSYM static Scheme_Object *module_begin_symbol; -ROSYM static Scheme_Object *prefix_symbol; -ROSYM static Scheme_Object *only_symbol; -ROSYM static Scheme_Object *rename_symbol; -ROSYM static Scheme_Object *all_except_symbol; -ROSYM static Scheme_Object *prefix_all_except_symbol; -ROSYM static Scheme_Object *all_from_symbol; -ROSYM static Scheme_Object *all_from_except_symbol; -ROSYM static Scheme_Object *all_defined_symbol; -ROSYM static Scheme_Object *all_defined_except_symbol; -ROSYM static Scheme_Object *prefix_all_defined_symbol; -ROSYM static Scheme_Object *prefix_all_defined_except_symbol; -ROSYM static Scheme_Object *struct_symbol; -ROSYM static Scheme_Object *protect_symbol; -ROSYM static Scheme_Object *expand_symbol; -ROSYM static Scheme_Object *for_syntax_symbol; -ROSYM static Scheme_Object *for_template_symbol; -ROSYM static Scheme_Object *for_label_symbol; -ROSYM static Scheme_Object *for_meta_symbol; -ROSYM static Scheme_Object *just_meta_symbol; -ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *lib_symbol; -ROSYM static Scheme_Object *planet_symbol; -ROSYM static Scheme_Object *file_symbol; -ROSYM static Scheme_Object *submod_symbol; -ROSYM static Scheme_Object *module_name_symbol; -ROSYM static Scheme_Object *nominal_id_symbol; -ROSYM static Scheme_Object *phaseless_keyword; -ROSYM static Scheme_Object *empty_namespace_keyword; - -READ_ONLY static Scheme_Object *modbeg_syntax; - -/* phase wraps */ -THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps0); -THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps1); - -/* global syntax */ -THREAD_LOCAL_DECL(Scheme_Object *scheme_module_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_modulestar_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_module_begin_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_define_values_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_define_syntaxes_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_top_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_for_syntax_stx); - -THREAD_LOCAL_DECL(Scheme_Object *more_constant_stxes[NUM_MORE_CONSTANT_STXES]); - -#ifdef MZ_XFORM -# define cnstXOA XFORM_OK_ASSIGN -#else -# define cnstXOA /* empty */ -#endif -#define CONSTANT_STX(pos) cnstXOA (more_constant_stxes[pos]) - -#define require_stx CONSTANT_STX(0) -#define provide_stx CONSTANT_STX(1) -#define declare_stx CONSTANT_STX(2) -#define set_stx CONSTANT_STX(3) -#define app_stx CONSTANT_STX(4) -#define lambda_stx CONSTANT_STX(5) -#define case_lambda_stx CONSTANT_STX(6) -#define let_values_stx CONSTANT_STX(7) -#define letrec_values_stx CONSTANT_STX(8) -#define if_stx CONSTANT_STX(9) -#define begin0_stx CONSTANT_STX(10) -#define with_continuation_mark_stx CONSTANT_STX(11) -#define letrec_syntaxes_stx CONSTANT_STX(12) -#define var_ref_stx CONSTANT_STX(13) -#define expression_stx CONSTANT_STX(14) -#define quote_stx CONSTANT_STX(15) -#define datum_stx CONSTANT_STX(16) - -#define make_struct_type_stx CONSTANT_STX(17) -#define make_struct_type_property_stx CONSTANT_STX(18) -#define list_stx CONSTANT_STX(19) -#define cons_stx CONSTANT_STX(20) -#define gensym_stx CONSTANT_STX(21) -#define string_to_uninterned_symbol_stx CONSTANT_STX(22) - -READ_ONLY static Scheme_Object *empty_self_modidx; -READ_ONLY static Scheme_Object *empty_self_modname; - -THREAD_LOCAL_DECL(static Scheme_Object *empty_self_shift_cache); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *starts_table); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *submodule_empty_modidx_table); -#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) -# define PLACE_LOCAL_MODPATH_TABLE 1 -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *place_local_modpath_table); -#else -# define PLACE_LOCAL_MODPATH_TABLE 0 -#endif - -THREAD_LOCAL_DECL(static Scheme_Env *initial_modules_env); -THREAD_LOCAL_DECL(static int num_initial_modules); -THREAD_LOCAL_DECL(static Scheme_Object **initial_modules); - -/* caches */ -THREAD_LOCAL_DECL(static Scheme_Modidx *modidx_caching_chain); -THREAD_LOCAL_DECL(static Scheme_Object *global_shift_cache); -#define GLOBAL_SHIFT_CACHE_SIZE 40 -#ifdef USE_SENORA_GC -# define SHIFT_CACHE_NULL scheme_false -# define SHIFT_CACHE_NULLP(x) SCHEME_FALSEP(x) -#else -# define SHIFT_CACHE_NULL NULL -# define SHIFT_CACHE_NULLP(x) !(x) -#endif - -#define SCHEME_RMP_VAL(obj) SCHEME_PTR_VAL(obj) - -#define DONE_MODFORM_KIND 0 -#define EXPR_MODFORM_KIND 1 -#define DEFN_MODFORM_KIND 2 -#define PROVIDE_MODFORM_KIND 3 -#define MODULE_MODFORM_KIND 4 -#define SAVED_MODFORM_KIND 5 -#define DECLARE_MODFORM_KIND 6 -#define LIFTREQ_MODFORM_KIND 7 - -/* combined bitwise: */ -#define NON_PHASELESS_IMPORT 0x1 -#define NON_PHASELESS_FORM 0x2 - -typedef void (*Check_Func)(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modname, Scheme_Object *nominal_export, - Scheme_Object *modname, Scheme_Object *srcname, int exet, - int isval, void *data, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase); -static void parse_requires(Scheme_Object *form, int at_phase, - Scheme_Object *base_modidx, - Scheme_Env *env, - Scheme_Module *for_m, - Scheme_Object *rns, - Check_Func ck, void *data, - Scheme_Object *redef_modname, - int copy_vars, - int eval_exp, int eval_run, - int *all_simple, - Scheme_Hash_Table *modix_cache, - Scheme_Hash_Table *submodule_names, - int *non_phaseless); -static void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, - int at_phase, - Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Object *self_modidx, - Scheme_Hash_Table *all_defs_out, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded); -static int compute_reprovides(Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Module *mod_for_requires, - Scheme_Hash_Table *tables, - Scheme_Env *genv, - int num_phases, - Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, - const char *matching_form, - Scheme_Object *all_mods, Scheme_Object *all_phases); -static void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - int num_phases, Scheme_Module_Export_Info **exp_infos); -static Scheme_Object **compute_indirects(Scheme_Env *genv, - Scheme_Module_Phase_Exports *pt, - int *_count, - int vars); -static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, - int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list, - int not_new); -static void eval_module_body(Scheme_Env *menv, Scheme_Env *env); - -static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], - int copy, int etonly); - -static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); - -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, int *exets, - Scheme_Object **exsnoms, - int start, int count, int do_uninterned); - -#define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0])) -#define MODCHAIN_AVAIL(p, n) (SCHEME_VEC_ELS(p)[3+n]) - -/**********************************************************************/ -/* initialization */ -/**********************************************************************/ - -void scheme_init_module(Scheme_Env *env) -{ - scheme_add_global_keyword("module", - scheme_make_primitive_syntax(module_compile, - module_expand), - env); - scheme_add_global_keyword("module*", - scheme_make_primitive_syntax(modulestar_compile, - modulestar_expand), - env); - - REGISTER_SO(modbeg_syntax); - modbeg_syntax = scheme_make_primitive_syntax(module_begin_compile, - module_begin_expand); - - scheme_add_global_keyword("#%module-begin", - modbeg_syntax, - env); - - scheme_add_global_keyword("#%declare", - scheme_make_primitive_syntax(declare_compile, - declare_expand), - env); - - scheme_add_global_keyword("#%require", - scheme_make_primitive_syntax(require_compile, - require_expand), - env); - scheme_add_global_keyword("#%provide", - scheme_make_primitive_syntax(provide_compile, - provide_expand), - env); - -#ifdef MZ_USE_PLACES - mzrt_mutex_create(&modpath_table_mutex); -#endif - - if (!empty_self_modidx) { - REGISTER_SO(empty_self_modidx); - REGISTER_SO(empty_self_modname); - empty_self_modidx = scheme_make_modidx(scheme_false, scheme_false, scheme_false); - (void)scheme_hash_key(empty_self_modidx); - empty_self_modname = scheme_make_symbol("expanded module"); /* uninterned */ - empty_self_modname = scheme_intern_resolved_module_path(empty_self_modname); - } - - REGISTER_SO(quote_symbol); - REGISTER_SO(file_symbol); - REGISTER_SO(lib_symbol); - REGISTER_SO(planet_symbol); - REGISTER_SO(submod_symbol); - quote_symbol = scheme_intern_symbol("quote"); - file_symbol = scheme_intern_symbol("file"); - lib_symbol = scheme_intern_symbol("lib"); - planet_symbol = scheme_intern_symbol("planet"); - submod_symbol = scheme_intern_symbol("submod"); - - REGISTER_SO(kernel_symbol); - REGISTER_SO(kernel_modname); - REGISTER_SO(kernel_modidx); - REGISTER_SO(unsafe_modname); - REGISTER_SO(flfxnum_modname); - REGISTER_SO(extfl_modname); - REGISTER_SO(futures_modname); - REGISTER_SO(foreign_modname); - kernel_symbol = scheme_intern_symbol("#%kernel"); - kernel_modname = scheme_intern_resolved_module_path(kernel_symbol); - kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol, - scheme_make_pair(kernel_symbol, - scheme_null)), - scheme_false, kernel_modname); - (void)scheme_hash_key(kernel_modidx); - unsafe_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%unsafe")); - flfxnum_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%flfxnum")); - extfl_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%extfl")); - futures_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%futures")); - foreign_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%foreign")); - - REGISTER_SO(module_begin_symbol); - module_begin_symbol = scheme_intern_symbol("#%module-begin"); - - GLOBAL_PARAMETER("current-module-name-resolver", current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env); - GLOBAL_PARAMETER("current-module-declare-name", current_module_name_prefix, MZCONFIG_CURRENT_MODULE_NAME, env); - GLOBAL_PARAMETER("current-module-declare-source", current_module_name_source, MZCONFIG_CURRENT_MODULE_SRC, env); - GLOBAL_PARAMETER("current-module-path-for-load", current_module_load_path, MZCONFIG_CURRENT_MODULE_LOAD_PATH, env); - - GLOBAL_PRIM_W_ARITY("dynamic-require", scheme_dynamic_require, 2, 3, env); - GLOBAL_PRIM_W_ARITY("dynamic-require-for-syntax", dynamic_require_for_syntax, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-require", namespace_require, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-attach-module", namespace_attach_module, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-attach-module-declaration", namespace_attach_module_decl, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-unprotect-module", namespace_unprotect_module, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-require/copy", namespace_require_copy, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-require/constant", namespace_require_constant, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-require/expansion-time", namespace_require_etonly, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-module-expression?", module_compiled_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-compiled-name", module_compiled_name, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module-compiled-imports", module_compiled_imports, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module-compiled-exports", module_compiled_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("module-compiled-indirect-exports",module_compiled_indirect_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-compiled-language-info", module_compiled_lang_info, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-compiled-submodules", module_compiled_submodules, 2, 3, env); - GLOBAL_PRIM_W_ARITY("module-compiled-cross-phase-persistent?", module_compiled_phaseless_p, 1, 1, env); - GLOBAL_FOLDING_PRIM("module-path-index?", module_path_index_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path-index-resolve", module_path_index_resolve, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module-path-index-split", module_path_index_split, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-path-index-submodule", module_path_index_submodule,1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path-index-join", module_path_index_join, 2, 3, env); - GLOBAL_FOLDING_PRIM("resolved-module-path?", resolved_module_path_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-resolved-module-path", make_resolved_module_path, 1, 1, env); - GLOBAL_PRIM_W_ARITY("resolved-module-path-name", resolved_module_path_name, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-provide-protected?", module_export_protected_p, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module->namespace", module_to_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module->language-info", module_to_lang_info, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module->imports", module_to_imports, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module->exports", module_to_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("module->indirect-exports", module_to_indirect_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-declared?", module_is_declared, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module-predefined?", module_is_predefined, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path?", is_module_path, 1, 1, env); -} - -void scheme_init_module_resolver(void) -{ - Scheme_Object *o; - Scheme_Config *config; - - /* this function is called multiple times when scheme_basic_env() is called multiple times */ - - if (!starts_table) { - REGISTER_SO(starts_table); - starts_table = scheme_make_weak_equal_table(); -#if PLACE_LOCAL_MODPATH_TABLE - REGISTER_SO(place_local_modpath_table); - place_local_modpath_table = scheme_make_weak_equal_table(); -#endif - } - - config = scheme_current_config(); - - o = scheme_make_prim_w_arity(default_module_resolver, - "default-module-name-resolver", - 2, 4); - - scheme_set_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER, o); - - scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false); -} - -static void add_exp_infos(Scheme_Module *m) -{ - Scheme_Module_Export_Info **exp_infos, *exp_info; - - exp_infos = MALLOC_N(Scheme_Module_Export_Info *, 1); - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[0] = exp_info; - m->exp_infos = exp_infos; - m->num_phases = 1; -} - -void scheme_finish_kernel(Scheme_Env *env) -{ - /* When this function is called, the initial namespace has all the - primitive bindings for syntax and procedures. This function fills - in the module wrapper for #%kernel. */ - char *running; - - REGISTER_SO(kernel); - - kernel = MALLOC_ONE_TAGGED(Scheme_Module); - kernel->so.type = scheme_module_type; - kernel->predefined = 1; - kernel->phaseless = scheme_true; - env->module = kernel; - - { - Scheme_Object *insp; - insp = scheme_get_current_inspector(); - - env->guard_insp = insp; /* nothing is protected, anyway */ - env->access_insp = insp; - kernel->insp = insp; - } - - kernel->modname = kernel_modname; - kernel->modsrc = kernel_modname; - kernel->requires = scheme_null; - kernel->et_requires = scheme_null; - kernel->tt_requires = scheme_null; - kernel->dt_requires = scheme_null; - kernel->other_requires = NULL; - add_exp_infos(kernel); - - { - Scheme_Bucket_Table *ht; - int i, j, count, syntax_start = 0; - Scheme_Bucket **bs; - Scheme_Object **exs; - /* Provide all syntax and variables: */ - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else { - ht = env->syntax; - syntax_start = count; - } - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - count++; - } - } - - exs = MALLOC_N(Scheme_Object *, count); - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else - ht = env->syntax; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - exs[count++] = (Scheme_Object *)b->key; - } - } - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - kernel->me = me; - kernel->me->modsrc = kernel_modname; - } - - kernel->me->rt->provides = exs; - kernel->me->rt->provide_srcs = NULL; - kernel->me->rt->provide_src_names = exs; - kernel->me->rt->num_provides = count; - kernel->me->rt->num_var_provides = syntax_start; - scheme_populate_pt_ht(kernel->me->rt); - - running = (char *)scheme_malloc_atomic(2); - running[0] = 1; - running[1] = 1; - env->running = running; - env->attached = 1; - } - - REGISTER_SO(prefix_symbol); - REGISTER_SO(only_symbol); - REGISTER_SO(rename_symbol); - REGISTER_SO(all_except_symbol); - REGISTER_SO(prefix_all_except_symbol); - REGISTER_SO(all_from_symbol); - REGISTER_SO(all_from_except_symbol); - REGISTER_SO(all_defined_symbol); - REGISTER_SO(all_defined_except_symbol); - REGISTER_SO(prefix_all_defined_symbol); - REGISTER_SO(prefix_all_defined_except_symbol); - REGISTER_SO(struct_symbol); - REGISTER_SO(protect_symbol); - REGISTER_SO(expand_symbol); - REGISTER_SO(for_syntax_symbol); - REGISTER_SO(for_template_symbol); - REGISTER_SO(for_label_symbol); - REGISTER_SO(for_meta_symbol); - REGISTER_SO(just_meta_symbol); - prefix_symbol = scheme_intern_symbol("prefix"); - only_symbol = scheme_intern_symbol("only"); - rename_symbol = scheme_intern_symbol("rename"); - all_except_symbol = scheme_intern_symbol("all-except"); - prefix_all_except_symbol = scheme_intern_symbol("prefix-all-except"); - all_from_symbol = scheme_intern_symbol("all-from"); - all_from_except_symbol = scheme_intern_symbol("all-from-except"); - all_defined_symbol = scheme_intern_symbol("all-defined"); - all_defined_except_symbol = scheme_intern_symbol("all-defined-except"); - prefix_all_defined_symbol = scheme_intern_symbol("prefix-all-defined"); - prefix_all_defined_except_symbol = scheme_intern_symbol("prefix-all-defined-except"); - struct_symbol = scheme_intern_symbol("struct"); - protect_symbol = scheme_intern_symbol("protect"); - expand_symbol = scheme_intern_symbol("expand"); - for_syntax_symbol = scheme_intern_symbol("for-syntax"); - for_template_symbol = scheme_intern_symbol("for-template"); - for_label_symbol = scheme_intern_symbol("for-label"); - for_meta_symbol = scheme_intern_symbol("for-meta"); - just_meta_symbol = scheme_intern_symbol("just-meta"); - - REGISTER_SO(module_name_symbol); - module_name_symbol = scheme_intern_symbol("enclosing-module-name"); - - REGISTER_SO(nominal_id_symbol); - nominal_id_symbol = scheme_intern_symbol("nominal-id"); - - REGISTER_SO(phaseless_keyword); - { - const char *s = "cross-phase-persistent"; - phaseless_keyword = scheme_intern_exact_keyword(s, strlen(s)); - } - - REGISTER_SO(empty_namespace_keyword); - { - const char *s = "empty-namespace"; - empty_namespace_keyword = scheme_intern_exact_keyword(s, strlen(s)); - } -} - -void scheme_init_syntax_bindings() -{ - Scheme_Object *w; - - REGISTER_SO(scheme_sys_wraps0); - REGISTER_SO(scheme_sys_wraps1); - - scheme_sys_wraps0 = sys_wraps_phase(0); - scheme_sys_wraps1 = sys_wraps_phase(1); - - REGISTER_SO(scheme_module_stx); - REGISTER_SO(scheme_modulestar_stx); - REGISTER_SO(scheme_module_begin_stx); - REGISTER_SO(scheme_begin_stx); - REGISTER_SO(scheme_define_values_stx); - REGISTER_SO(scheme_define_syntaxes_stx); - REGISTER_SO(scheme_top_stx); - REGISTER_SO(scheme_begin_for_syntax_stx); - REGISTER_SO(more_constant_stxes); - - w = scheme_sys_wraps0; - scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_modulestar_stx = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_module_begin_stx = scheme_datum_to_syntax(module_begin_symbol, scheme_false, w, 0, 0); - scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - declare_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); - app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0); - scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0); - lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0); - case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0); - let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0); - letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); - if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); - begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); - with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); - letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); - var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); - expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0); - quote_stx = scheme_datum_to_syntax(scheme_intern_symbol("quote"), scheme_false, w, 0, 0); - datum_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%datum"), scheme_false, w, 0, 0); - - make_struct_type_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type"), scheme_false, w, 0, 0); - make_struct_type_property_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type-property"), scheme_false, w, 0, 0); - cons_stx = scheme_datum_to_syntax(scheme_intern_symbol("cons"), scheme_false, w, 0, 0); - list_stx = scheme_datum_to_syntax(scheme_intern_symbol("list"), scheme_false, w, 0, 0); - gensym_stx = scheme_datum_to_syntax(scheme_intern_symbol("gensym"), scheme_false, w, 0, 0); - string_to_uninterned_symbol_stx = scheme_datum_to_syntax(scheme_intern_symbol("string->uninterned-symbol"), - scheme_false, w, 0, 0); -} - -int scheme_is_kernel_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, kernel_modname); -} - -int scheme_is_unsafe_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, unsafe_modname); -} - -int scheme_is_flfxnum_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, flfxnum_modname); -} - -int scheme_is_extfl_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, extfl_modname); -} - -int scheme_is_futures_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, futures_modname); -} - -int scheme_is_foreign_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, foreign_modname); -} - -Scheme_Module *get_special_module(Scheme_Object *name) -{ - if (SAME_OBJ(name, kernel_modname)) - return kernel; - else if (SAME_OBJ(name, unsafe_modname)) - return scheme_get_unsafe_env()->module; - else if (SAME_OBJ(name, flfxnum_modname)) - return scheme_get_flfxnum_env()->module; - else if (SAME_OBJ(name, extfl_modname)) - return scheme_get_extfl_env()->module; - else if (SAME_OBJ(name, futures_modname)) - return scheme_get_futures_env()->module; - else if (SAME_OBJ(name, foreign_modname)) - return scheme_get_foreign_env()->module; - else - return NULL; -} - -Scheme_Env *get_special_modenv(Scheme_Object *name) -{ - if (SAME_OBJ(name, kernel_modname)) - return scheme_get_kernel_env(); - else if (SAME_OBJ(name, flfxnum_modname)) - return scheme_get_flfxnum_env(); - else if (SAME_OBJ(name, extfl_modname)) - return scheme_get_extfl_env(); - else if (SAME_OBJ(name, futures_modname)) - return scheme_get_futures_env(); - else if (SAME_OBJ(name, unsafe_modname)) - return scheme_get_unsafe_env(); - else if (SAME_OBJ(name, foreign_modname)) - return scheme_get_foreign_env(); - else - return NULL; -} - -static int is_builtin_modname(Scheme_Object *modname) -{ - return (SAME_OBJ(modname, kernel_modname) - || SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)); -} - -Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) -{ - intptr_t phase; - - if (!env) - phase = 0; - else if (SCHEME_INTP((Scheme_Object *)env)) - phase = SCHEME_INT_VAL((Scheme_Object *)env); - else - phase = env->genv->phase; - - return scheme_sys_wraps_phase(scheme_make_integer(phase)); -} - -static Scheme_Object *sys_wraps_phase(intptr_t p) -{ - Scheme_Object *rn, *w; - - rn = scheme_make_module_context(NULL, NULL, kernel_symbol); - rn = scheme_module_context_at_phase(rn, scheme_make_integer(p)); - - /* Add a module mapping for all kernel provides: */ - scheme_extend_module_context_with_shared(rn, kernel_modidx, - kernel->me->rt, - scheme_false, /* no prefix */ - NULL, /* no excepts */ - scheme_make_integer(p), - NULL, - NULL); - - w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); - w = scheme_stx_add_module_context(w, rn); - - return w; -} - -Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) -{ - intptr_t p; - - if (SCHEME_INTP(phase)) - p = SCHEME_INT_VAL(phase); - else - p = -1; - - if (p == 0) return scheme_sys_wraps0; - if (p == 1) return scheme_sys_wraps1; - - return sys_wraps_phase(p); -} - -void scheme_save_initial_module_set(Scheme_Env *env) -/* Can be called multiple times! */ -{ - int i, c, count; - Scheme_Hash_Table *ht; - - if (!initial_modules_env) { - REGISTER_SO(initial_modules_env); - } - initial_modules_env = env; - - ht = env->module_registry->loaded; - c = ht->size; - - count = 0; - for (i = 0; i < c; i++) { - if (ht->vals[i]) - count++; - } - - num_initial_modules = count; - - if (!initial_modules) { - REGISTER_SO(initial_modules); - } - initial_modules = MALLOC_N(Scheme_Object *, count); - - count = 0; - for (i = 0; i < c; i++) { - if (ht->vals[i]) { - initial_modules[count++] = ht->keys[i]; - } - } -} - -void scheme_install_initial_module_set(Scheme_Env *env) -{ - int i; - Scheme_Object *a[3]; - Scheme_Module *m; - - /* Copy over module declarations and instances: */ - for (i = 0; i < num_initial_modules; i++) { - a[0] = (Scheme_Object *)initial_modules_env; - a[1] = initial_modules[i]; - a[2] = (Scheme_Object *)env; - - /* Make sure module is running: */ - m = (Scheme_Module *)scheme_hash_get(initial_modules_env->module_registry->loaded, a[1]); - start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null, 0); - - namespace_attach_module(3, a); - } - - scheme_prepare_env_stx_context(env); -} - -static Scheme_Module *registry_get_loaded(Scheme_Env *env, Scheme_Object *name) -{ - Scheme_Object *o; - - if (env->module_pre_registry && env->module_pre_registry->loaded) { - o = scheme_hash_get(env->module_pre_registry->loaded, name); - if (o) - return (Scheme_Module *)o; - } - - return (Scheme_Module *)scheme_hash_get(env->module_registry->loaded, name); -} - -/**********************************************************************/ -/* linklets and instances */ -/**********************************************************************/ - -/* A minimal linklet API to support bootstrapping. */ - -static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]); - -void scheme_init_linklet(Scheme_Env *env) -{ - Scheme_Env *newenv; - Scheme_Object *modname; - - modname = scheme_intern_symbol("#%linklet"); - newenv = scheme_primitive_module(modname, env); - - GLOBAL_PRIM_W_ARITY("primitive-table", primitive_table, 1, 2, newenv); - - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); -} - -static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env, *menv; - Scheme_Object *name; - Scheme_Hash_Tree *ht; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("primitive-table", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_HASHTRP(argv[1])) - scheme_wrong_contract("primitive-table", "(and/c hash? immutable?)", 1, argc, argv); - - name = scheme_intern_resolved_module_path(argv[0]); - - env = scheme_get_env(NULL); - menv = get_special_modenv(name); - if (!menv) - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), name); - - if (!menv) { - if (argc > 1) { - Scheme_Object *k, *v; - mzlonglong pos; - - menv = scheme_primitive_module(argv[0], env); - - ht = (Scheme_Hash_Tree *)argv[1]; - pos = scheme_hash_tree_next(ht, -1); - while (pos != -1) { - scheme_hash_tree_index(ht, pos, &k, &v); - if (SCHEME_SYMBOLP(k)) { - scheme_add_global_symbol(k, v, menv); - } - pos = scheme_hash_tree_next(ht, pos); - } - - scheme_finish_primitive_module(menv); - - start_module(menv->module, env, 0, name, 0, 1, 0, scheme_null, 0); - } else - return scheme_false; - } - - if (argc < 2) { - Scheme_Bucket **bs, *b; - intptr_t i; - - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - bs = menv->toplevel->buckets; - for (i = menv->toplevel->size; i--; ) { - b = bs[i]; - if (b && b->val) { - ht = scheme_hash_tree_set(ht, (Scheme_Object *)b->key, b->val); - } - } - - return (Scheme_Object *)ht; - } else - return scheme_void; -} - -/**********************************************************************/ -/* parameters */ -/**********************************************************************/ - -static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv) -{ - Scheme_Object *p = argv[0]; - - if (argc == 2) - return scheme_void; /* ignore notify */ - - /* if (quote SYMBOL) */ - if (SCHEME_PAIRP(p) - && SAME_OBJ(SCHEME_CAR(p), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(p)) - && SCHEME_SYMBOLP(SCHEME_CAR(SCHEME_CDR(p))) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p)))) - return scheme_intern_resolved_module_path(SCHEME_CAR(SCHEME_CDR(p))); - - scheme_contract_error("default-module-name-resolver", - "the kernel's resolver works only on `quote' forms", - "given", 1, p, - NULL); - return NULL; -} - -static Scheme_Object *check_resolver(int argc, Scheme_Object **argv) -{ - if (scheme_check_proc_arity(NULL, 2, 0, argc, argv) - && scheme_check_proc_arity(NULL, 4, 0, argc, argv)) - return argv[0]; - - scheme_wrong_contract("current-module-name-resolver", - "(case-> (any/c any/c . -> . any) (any/c any/c any/c any/c . -> . any))", - 0, argc, argv); - - return NULL; -} - -static Scheme_Object * -current_module_name_resolver(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-name-resolver", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER), - argc, argv, - -1, check_resolver, - "(and/c (procedure-arity-includes/c 1)" - /* */ " (procedure-arity-includes/c 4))", - 1); -} - -static Scheme_Object *prefix_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (SCHEME_FALSEP(o) || (SCHEME_MODNAMEP(o))) - return o; - - return NULL; -} - -static Scheme_Object * -current_module_name_prefix(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME), - argc, argv, - -1, prefix_p, "(or/c resolved-module-path? #f)", 1); -} - -static Scheme_Object *source_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (!SCHEME_FALSEP(o) - && !SCHEME_SYMBOLP(o) - && (!SCHEME_PATHP(o) - || !scheme_is_complete_path(SCHEME_PATH_VAL(o), - SCHEME_PATH_LEN(o), - SCHEME_PLATFORM_PATH_KIND))) - return NULL; - - return o; -} - -static Scheme_Object * -current_module_name_source(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC), - argc, argv, - -1, source_p, - "(or/c symbol? (and/c path-string? complete-path?) #f)", - 1); -} - -static Scheme_Object *load_path_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (!SCHEME_FALSEP(o) - && !scheme_is_module_path(o) - && (!SCHEME_STXP(o) - || !scheme_is_module_path(scheme_syntax_to_datum(o, 0, NULL)))) - return NULL; - - return o; -} - -static Scheme_Object * -current_module_load_path(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-path-for-load", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH), - argc, argv, - -1, load_path_p, - "(or/c module-path?" - /**/ " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))" - /**/ " #f)", - 1); -} - -/**********************************************************************/ -/* procedures */ -/**********************************************************************/ - -int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp) -{ - if (!insp) - return 1; - if (SAME_OBJ(insp, scheme_true)) - return 0; - return !scheme_is_subinspector(home_insp, insp); -} - -static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], - Scheme_Env *env, - int get_bucket, - int phase, int mod_phase, int indirect_ok, - int fail_with_error, - int position) -{ - Scheme_Object *modname, *modidx; - Scheme_Object *name, *srcname, *srcmname, *fail_thunk; - Scheme_Module *m, *srcm; - Scheme_Env *menv, *lookup_env = NULL; - int i, count, protected = 0, check_protected_at_source = 0; - - const char *errname; - intptr_t base_phase; - - modname = argv[0]; - name = argv[1]; - if (argc > 2) - fail_thunk = argv[2]; - else - fail_thunk = NULL; - - errname = (phase - ? ((phase < 0) - ? "dynamic-require-for-template" - : "dynamic-require-for-syntax" ) - : "dynamic-require"); - - if (SCHEME_TRUEP(name) - && !SCHEME_SYMBOLP(name) - && !SAME_OBJ(name, scheme_make_integer(0)) - && !SCHEME_VOIDP(name)) { - scheme_wrong_contract(errname, "(or/c symbol? #f 0 void?)", 1, argc, argv); - return NULL; - } - - if (fail_thunk) - scheme_check_proc_arity(errname, 0, 2, argc, argv); - - if (SAME_TYPE(SCHEME_TYPE(modname), scheme_module_index_type)) - modidx = modname; - else - modidx = scheme_make_modidx(modname, scheme_false, scheme_false); - - modname = scheme_module_resolve(modidx, 1); - - if (phase == 1) { - scheme_prepare_exp_env(env); - if (mod_phase) - lookup_env = env->exp_env; - else - env = env->exp_env; - } - - base_phase = env->phase; - - m = module_load(modname, env, errname); - srcm = m; - - srcmname = NULL; - srcname = NULL; - - if (SCHEME_SYMBOLP(name)) { - if (mod_phase) { - srcname = name; - srcmname = modname; - } else { - /* Before starting, check whether the name is provided */ - count = srcm->me->rt->num_provides; - if (position >= 0) { - if (position < srcm->me->rt->num_var_provides) { - i = position; - if ((SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->me->rt->provide_src_names[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->me->rt->provide_src_names[i]), SCHEME_SYM_LEN(name))) { - name = srcm->me->rt->provides[i]; - } else { - i = count; /* not found */ - indirect_ok = 0; /* don't look further */ - } - } else { - position -= srcm->me->rt->num_var_provides; - i = count; - } - } else { - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, srcm->me->rt->provides[i])) { - if (i < srcm->me->rt->num_var_provides) { - break; - } else { - if (fail_with_error) { - int started = 0; - if (!phase - && srcm->me->rt->provide_srcs - && SCHEME_TRUEP(srcm->me->rt->provide_srcs[i])) { - /* Handle simple re-exporting */ - int j; - Scheme_Module *srcm2; - - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); - started = 1; - - srcmname = srcm->me->rt->provide_srcs[i]; - srcmname = scheme_modidx_shift(srcmname, - srcm->me->src_modidx, - srcm->self_modidx); - srcmname = scheme_module_resolve(srcmname, 1); - srcname = srcm->me->rt->provide_src_names[i]; - if (srcm->me->rt->provide_src_phases - && (srcm->me->rt->provide_src_phases[i] != 0)) { - /* shortcut only checks phase 0, so use the long way */ - srcmname = NULL; - } - - if (srcmname) { - srcm2 = module_load(srcmname, env, errname); - - for (j = srcm2->me->rt->num_var_provides; j--; ) { - if ((!srcm2->me->rt->provide_srcs - || SCHEME_FALSEP(srcm2->me->rt->provide_srcs[j])) - && SAME_OBJ(srcname, srcm2->me->rt->provide_src_names[j])) { - /* simple re-export applies: */ - srcm = srcm2; - count = srcm->me->rt->num_provides; - name = srcm2->me->rt->provides[j]; - i = j; - break; - } - } - if (j < 0) { - /* Try indirect: */ - Scheme_Module_Export_Info *exp_info = srcm2->exp_infos[0]; - for (j = exp_info->num_indirect_provides; j--; ) { - if (SAME_OBJ(srcname, exp_info->indirect_provides[j])) { - srcm = srcm2; - name = srcname; - count = srcm->me->rt->num_provides; - i = count; - position = j; - indirect_ok = 1; - break; - } - } - if (j < 0) { - /* simple re-exporting doesn't work */ - srcmname = NULL; - } - } - } - } - - if (srcmname) { - /* Simple re-exporting shortcut worked */ - break; - } else if (!phase) { - /* The long way: evaluate id in a fresh namespace */ - Scheme_Object *a[3], *ns; - Scheme_Config *config; - Scheme_Cont_Frame_Data cframe; - - if (!started) - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); - ns = scheme_make_namespace(0, NULL); - a[0] = (Scheme_Object *)env; - a[1] = srcm->modname; - a[2] = ns; - namespace_attach_module(3, a); - a[0] = scheme_make_pair(scheme_intern_symbol("only"), - scheme_make_pair(srcm->modname, - scheme_make_pair(name, - scheme_null))); - do_namespace_require((Scheme_Env *)ns, 1, a, 0, 0); - - scheme_push_continuation_frame(&cframe); - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - ns); - scheme_set_cont_mark(scheme_parameterization_key, - (Scheme_Object *)config); - - ns = scheme_eval(name, (Scheme_Env *)ns); - - scheme_pop_continuation_frame(&cframe); - - return ns; - } else { - scheme_contract_error(errname, - "name is provided as syntax", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - } - return NULL; - } - } - } - } - - if (i < count) { - if (srcm->exp_infos[0]->provide_protects) - protected = srcm->exp_infos[0]->provide_protects[i]; - srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false); - if (SCHEME_FALSEP(srcmname)) { - srcmname = srcm->modname; - } else { - srcmname = scheme_modidx_shift(srcmname, srcm->me->src_modidx, srcm->self_modidx); - srcmname = scheme_module_resolve(srcmname, 1); - check_protected_at_source = 1; - if (srcm->me->rt->provide_src_phases) - mod_phase += srcm->me->rt->provide_src_phases[i]; - } - srcname = srcm->me->rt->provide_src_names[i]; - } - - if (i == count) { - if (indirect_ok) { - /* Try indirect provides: */ - Scheme_Module_Export_Info *exp_info = srcm->exp_infos[0]; - count = exp_info->num_indirect_provides; - if (position >= 0) { - i = position; - if ((i < exp_info->num_indirect_provides) - && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(exp_info->indirect_provides[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(exp_info->indirect_provides[i]), SCHEME_SYM_LEN(name))) { - name = exp_info->indirect_provides[i]; - srcname = name; - srcmname = srcm->modname; - if (exp_info->provide_protects) - protected = exp_info->provide_protects[i]; - } else - i = count; /* not found */ - } else { - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, exp_info->indirect_provides[i])) { - srcname = name; - srcmname = srcm->modname; - if (exp_info->provide_protects) - protected = exp_info->provide_protects[i]; - break; - } - } - } - } - - if (i == count) { - if (fail_with_error) { - if (fail_thunk) - return scheme_tail_apply(fail_thunk, 0, NULL); - scheme_contract_error(errname, - "name is not provided", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - return NULL; - } - } - } - } - - start_module(m, env, 0, modidx, - (SCHEME_VOIDP(name) - ? 1 - : (SAME_OBJ(name, scheme_make_integer(0)) - ? -1 - : 0)), - (SCHEME_VOIDP(name) - ? 0 - : 1), - base_phase, - scheme_null, - 0); - - if (SCHEME_SYMBOLP(name)) { - Scheme_Bucket *b; - - menv = scheme_module_access(srcmname, lookup_env ? lookup_env : env, mod_phase); - - if (check_protected_at_source) { - Scheme_Module_Phase_Exports *pt; - if (mod_phase == 0) - pt = menv->module->me->rt; - else if (mod_phase == 1) - pt = menv->module->me->et; - else if (menv->module->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(menv->module->me->other_phases, - scheme_make_integer(mod_phase)); - else - pt = NULL; - if (pt) { - count = pt->num_provides; - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, pt->provides[i])) { - if (menv->module->exp_infos[mod_phase]->provide_protects) - protected = menv->module->exp_infos[mod_phase]->provide_protects[i]; - } - } - } - } - - if (protected) { - Scheme_Object *insp; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - if (scheme_module_protected_wrt(menv->guard_insp, insp)) - scheme_contract_error(errname, - "name is protected", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - - if (!menv || !menv->toplevel) { - scheme_contract_error(errname, - "module inialization failed", - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - - b = scheme_bucket_from_table(menv->toplevel, (const char *)srcname); - scheme_set_bucket_home(b, menv); - - if (get_bucket) - return (Scheme_Object *)b; - else { - if (!b->val) { - if (!menv->ran) - run_module(menv, 1); - } - if (!b->val && fail_with_error) { - if (fail_thunk) - return scheme_tail_apply(fail_thunk, 0, NULL); - scheme_unbound_global(b); - } - return b->val; - } - } else - return scheme_void; -} - -Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]) -{ - if (scheme_module_demand_hook) { - Scheme_Object *r; - r = scheme_module_demand_hook(argc, argv); - if (r) return r; - } - - return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 0, 0, 0, 1, -1); -} - -static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]) -{ - return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 1, 0, 0, 1, -1); -} - -static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], - int copy, int etonly) -{ - Scheme_Object *form; - - if (!env) - env = scheme_get_env(NULL); - scheme_prepare_exp_env(env); - - if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - form = argv[0]; - else { - form = scheme_datum_to_syntax(scheme_make_pair(require_stx, - scheme_make_pair(argv[0], scheme_null)), - scheme_false, scheme_false, 1, 0); - form = scheme_stx_add_module_context(form, env->stx_context); - } - - parse_requires(form, env->phase, scheme_false, env, NULL, - env->stx_context, - NULL /* ck */, NULL /* data */, - NULL, - copy, - (etonly ? 1 : -1), !etonly, - NULL, NULL, NULL, - NULL); - - return scheme_void; -} - -static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 0, 0); -} - -Scheme_Object *scheme_namespace_require(Scheme_Object *r) -{ - Scheme_Object *a[1]; - a[0] = r; - return namespace_require(1, a); -} - -static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 1, 0); -} - -static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 2, 0); -} - -static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 0, 1); -} - -static Scheme_Object *extend_list_depth(Scheme_Object *l, Scheme_Object *n, int with_ht) -{ - Scheme_Object *p, *orig; - int k; - - if (!SCHEME_INTP(n)) - scheme_raise_out_of_memory(NULL, NULL); - - k = SCHEME_INT_VAL(n); - - if (SCHEME_NULLP(l)) { - if (with_ht) - p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); - else - p = scheme_null; - l = scheme_make_pair(p, scheme_null); - } - - orig = l; - - while (k--) { - if (SCHEME_NULLP(SCHEME_CDR(l))) { - if (with_ht) - p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); - else - p = scheme_null; - p = scheme_make_pair(p, scheme_null); - SCHEME_CDR(l) = p; - } - l = SCHEME_CDR(l); - } - - return orig; -} - -static Scheme_Object *extract_at_depth(Scheme_Object *l, Scheme_Object *n) -{ - int k = SCHEME_INT_VAL(n); - - while (k--) { - l = SCHEME_CDR(l); - } - - return SCHEME_CAR(l); -} - -static void set_at_depth(Scheme_Object *l, Scheme_Object *n, Scheme_Object *v) -{ - int k = SCHEME_INT_VAL(n); - - while (k--) { - l = SCHEME_CDR(l); - } - - SCHEME_CAR(l) = v; -} - -#if 0 -static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) -{ - if (env && (env->exp_env == env)) { - /* label phase */ - return; - } - - if (!menv->module->primitive - && ((env && (menv->phase != env->phase)) - || (!env && (menv->phase != phase)))) { - fprintf(stderr, "phase mismatch\n"); - } -} - -static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) -{ - int i; - - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - check_phase((Scheme_Env *)ht->vals[i], NULL, phase); - } - } -} -#else -static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) { } -static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) { } -#endif - -void ensure_instantiate_for_label(const char *who, Scheme_Env *from_env, Scheme_Object *name, Scheme_Object *modidx) -{ - Scheme_Module *m2; - - m2 = registry_get_loaded(from_env, name); - if (!m2) - scheme_contract_error(who, - "module not declared (in the source namespace)", - "name", 1, name, - NULL); - else { - /* instantiate for-label: */ - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - /* make sure `from_env' is the current namespace, because - start_module() may need to resolve module paths: */ - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)from_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - start_module(m2, - from_env->label_env, 0, - modidx, - 0, 0, -1, - scheme_null, - 0); - - scheme_pop_continuation_frame(&cframe); - } -} - -static Scheme_Object *make_sub_modidx_pair(Scheme_Env *menv, Scheme_Object *name, int i) -{ - Scheme_Object *modidx; - - if (i) { - name = scheme_resolved_module_path_value(name); - while (SCHEME_PAIRP(SCHEME_CDR(name))) { - name = SCHEME_CDR(name); - } - name = SCHEME_CAR(name); - } else { - name = scheme_make_utf8_string(".."); - } - - modidx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - scheme_make_pair(name, - scheme_null))), - menv->link_midx, - scheme_false); - name = scheme_module_resolve(modidx, 0); - - return scheme_make_pair(name, modidx); -} - -#if 0 -# define LOG_ATTACH(x) (x, fflush(stdout)) -#else -# define LOG_ATTACH(x) /* nothing */ -#endif - -static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Scheme_Object *argv[], - int only_declare) -{ - Scheme_Env *from_env, *to_env, *menv, *menv2; - Scheme_Object *todo, *next_phase_todo, *prev_phase_todo; - Scheme_Object *name, *notifies = scheme_null, *a[2], *resolver; - Scheme_Object *to_modchain, *from_modchain, *l, *main_modidx; - Scheme_Hash_Table *checked, *next_checked, *prev_checked; - Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos; - Scheme_Module *m2; - int same_namespace, set_env_for_notify = 0, phase, orig_phase, max_phase; - Scheme_Object *nophase_todo; - Scheme_Hash_Table *nophase_checked; - - if (!SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract(who, "namespace?", 0, argc, argv); - from_env = (Scheme_Env *)argv[0]; - - if (argc > 2) { - if (!SCHEME_NAMESPACEP(argv[2])) - scheme_wrong_contract(who, "namespace?", 2, argc, argv); - to_env = (Scheme_Env *)argv[2]; - set_env_for_notify = 1; - } else - to_env = scheme_get_env(NULL); - - same_namespace = SAME_OBJ(from_env, to_env); - - if (from_env->phase != to_env->phase) { - scheme_contract_error("namespace-attach-module", - "source and destination namespace phases do not match", - "source phase", 1, scheme_make_integer(from_env->phase), - "destination phase", 1, scheme_make_integer(to_env->phase), - NULL); - } - - main_modidx = scheme_make_modidx(argv[1], scheme_false, scheme_false); - name = scheme_module_resolve(main_modidx, 0); - - if (!only_declare) { - todo = scheme_make_pair(name, scheme_null); - nophase_todo = scheme_null; - } else { - todo = scheme_null; - nophase_todo = scheme_make_pair(name, scheme_null); - } - - next_phase_todo = scheme_null; - prev_phase_todo = scheme_null; - from_modchain = from_env->modchain; - to_modchain = to_env->modchain; - phase = from_env->phase; - orig_phase = phase; - - checked = NULL; - next_checked = NULL; - prev_checked = NULL; - - past_checkeds = scheme_null; - past_todos = scheme_null; - future_checkeds = scheme_null; - future_todos = scheme_null; - past_to_modchains = scheme_null; - - nophase_checked = scheme_make_hash_table(SCHEME_hash_ptr); - if (only_declare) { - scheme_hash_set(nophase_checked, name, scheme_false); - } - - max_phase = phase; - - checked = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(checked, name, scheme_true); - - /* Check whether todo, or anything it needs, is already declared - incompatibly. Successive iterations of the outer loop explore - successive phases (i.e, for-syntax levels). */ - while (!SCHEME_NULLP(todo)) { - if (phase > max_phase) - max_phase = phase; - - if (!checked) - checked = scheme_make_hash_table(SCHEME_hash_ptr); - /* This is just a shortcut: */ - if (!next_checked) - next_checked = scheme_make_hash_table(SCHEME_hash_ptr); - - /* This loop iterates through require chains in the same phase */ - while (!SCHEME_NULLP(todo)) { - name = SCHEME_CAR(todo); - - todo = SCHEME_CDR(todo); - - if (!scheme_hash_get(checked, name)) { - scheme_signal_error("internal error: module not in `checked' table"); - } - - if (!is_builtin_modname(name)) { - LOG_ATTACH(printf("Check %d %s\n", phase, scheme_write_to_string(name, 0))); - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name); - - if (!menv) { - /* Assert: name == argv[1] */ - /* Module at least declared? */ - if (registry_get_loaded(from_env, name)) - scheme_contract_error(who, - "module not instantiated (in the source namespace)", - "name", 1, name, - NULL); - else - scheme_contract_error(who, - "unknown module (in the source namespace)", - "name", 1, name, - NULL); - } - - /* If to_modchain goes to #f, then our source check has gone - deeper in phases (for-syntax levels) than the target - namespace has ever gone, so there's definitely no conflict - at this level in that case. */ - if ((phase >= orig_phase) && SCHEME_TRUEP(to_modchain)) { - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - if (menv2) { - if (!SAME_OBJ(menv->toplevel, menv2->toplevel)) - m2 = menv2->module; - else - m2 = NULL; - } else { - m2 = registry_get_loaded(to_env, name); - if (m2 && SAME_OBJ(m2, menv->module)) - m2 = NULL; - } - - if (m2 && (phase > orig_phase) && SAME_OBJ(menv->module, m2)) { - /* different instance of same module is ok at higher phases */ - m2 = NULL; - } - - if (m2) { - char *phase, buf[32], *kind; - - if (!menv->phase) - phase = ""; - else if (menv->phase == 1) - phase = " phase: for syntax\n"; - else { - sprintf(buf, " phase: %" PRIdPTR "\n", menv->phase); - phase = buf; - } - - if (SAME_OBJ(menv->module, m2)) - kind = "instance of the same module"; - else - kind = "module with the same name"; - - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "namespace-attach-module: " - "a different %s is already " - "in the destination namespace\n" - "%s" - " module name: %D", - kind, phase, name); - return NULL; - } - } else - menv2 = NULL; - - if (!menv2 || same_namespace) { - /* Push requires onto the check list: */ - l = menv->require_names; - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(checked, name)) { - LOG_ATTACH(printf("Add %d %s (%p)\n", phase, scheme_write_to_string(name, 0), checked)); - todo = scheme_make_pair(name, todo); - scheme_hash_set(checked, name, (phase < orig_phase) ? scheme_false : scheme_true); - } - l = SCHEME_CDR(l); - } - - /* was here */ - - l = menv->et_require_names; - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(next_checked, name)) { - LOG_ATTACH(printf("Add +%d %s (%p)\n", phase+1, scheme_write_to_string(name, 0), next_checked)); - next_phase_todo = scheme_make_pair(name, next_phase_todo); - scheme_hash_set(next_checked, name, ((phase+1) < orig_phase) ? scheme_false : scheme_true); - } - l = SCHEME_CDR(l); - } - - l = menv->tt_require_names; - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!prev_checked) - prev_checked = scheme_make_hash_table(SCHEME_hash_ptr); - if (!scheme_hash_get(prev_checked, name)) { - LOG_ATTACH(printf("Add -%d %s (%p)\n", phase-1, scheme_write_to_string(name, 0), prev_checked)); - prev_phase_todo = scheme_make_pair(name, prev_phase_todo); - scheme_hash_set(prev_checked, name, (((phase-1) < orig_phase) ? scheme_false : scheme_true)); - } - l = SCHEME_CDR(l); - } - } - - if (!same_namespace) { - l = menv->dt_require_names; - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - - if (!scheme_hash_get(nophase_checked, name)) { - LOG_ATTACH(printf("Add * %s\n", scheme_write_to_string(name, NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, name, scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - - if (menv->other_require_names) { - Scheme_Hash_Table *oht; - int i; - oht = menv->other_require_names; - for (i = 0; i < oht->size; i++) { - if (oht->vals[i]) { - Scheme_Object *lphase = oht->keys[i]; - Scheme_Object *l = oht->vals[i], *todos, *checkeds; - - if (scheme_is_negative(lphase)) { - lphase = scheme_bin_minus(scheme_make_integer(0), lphase); - lphase = scheme_bin_minus(lphase, scheme_make_integer(2)); - past_todos = extend_list_depth(past_todos, lphase, 0); - past_checkeds = extend_list_depth(past_checkeds, lphase, 1); - todos = past_todos; - checkeds = past_checkeds; - } else { - lphase = scheme_bin_minus(lphase, scheme_make_integer(2)); - future_todos = extend_list_depth(future_todos, lphase, 0); - future_checkeds = extend_list_depth(future_checkeds, lphase, 1); - todos = future_todos; - checkeds = future_checkeds; - } - if (todos) { - Scheme_Object *a_todo; - Scheme_Hash_Table *a_checked; - - a_todo = extract_at_depth(todos, lphase); - a_checked = (Scheme_Hash_Table *)extract_at_depth(checkeds, lphase); - - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(a_checked, name)) { - LOG_ATTACH(printf("Add +%ld %s (%p)\n", - SCHEME_INT_VAL(oht->keys[i]), - scheme_write_to_string(name, 0), a_checked)); - a_todo = scheme_make_pair(name, a_todo); - scheme_hash_set(a_checked, - name, - (((phase + SCHEME_INT_VAL(oht->keys[i])) < orig_phase) - ? scheme_false - : scheme_true)); - } - l = SCHEME_CDR(l); - } - - set_at_depth(todos, lphase, a_todo); - } - } - } - } - - if (!same_namespace) { - /* attached submodules: like for-label imports: */ - int i; - for (i = 0; i < 3; i++) { - switch (i) { - case 0: - if (menv->module->supermodule) - l = scheme_make_pair(menv->module->supermodule, scheme_null); - else - l = scheme_null; - break; - case 1: - l = menv->module->post_submodules; - break; - case 2: - default: - l = menv->module->pre_submodules; - break; - } - if (l) { - while (!SCHEME_NULLP(l)) { - name = ((Scheme_Module *)SCHEME_CAR(l))->modname; - - if (!scheme_hash_get(nophase_checked, name)) { - name = make_sub_modidx_pair(menv, name, i); - LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, SCHEME_CAR(name), scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - } - } - } - } - - do { - if (!SCHEME_PAIRP(next_phase_todo)) { - /* Work on earlier phase */ - LOG_ATTACH(printf("prev\n")); - future_todos = cons(next_phase_todo, future_todos); - next_phase_todo = todo; - future_checkeds = cons((Scheme_Object *)next_checked, future_checkeds); - next_checked = checked; - - todo = prev_phase_todo; - checked = prev_checked; - - if (SCHEME_NULLP(past_todos)) { - prev_phase_todo = scheme_null; - prev_checked = NULL; - } else { - prev_phase_todo = SCHEME_CAR(past_todos); - past_todos = SCHEME_CDR(past_todos); - prev_checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds); - past_checkeds = SCHEME_CDR(past_checkeds); - } - - from_modchain = SCHEME_VEC_ELS(from_modchain)[2]; - if (phase > orig_phase) { - to_modchain = SCHEME_CAR(past_to_modchains); - past_to_modchains = SCHEME_CDR(past_to_modchains); - } - phase--; - } else { - /* Work on later phase */ - LOG_ATTACH(printf("later\n")); - past_todos = cons(prev_phase_todo, past_todos); - prev_phase_todo = todo; - past_checkeds = scheme_make_raw_pair((Scheme_Object *)prev_checked, past_checkeds); - prev_checked = checked; - - todo = next_phase_todo; - checked = next_checked; - - if (SCHEME_NULLP(future_todos)) { - next_phase_todo = scheme_null; - next_checked = NULL; - } else { - next_phase_todo = SCHEME_CAR(future_todos); - future_todos = SCHEME_CDR(future_todos); - next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds); - future_checkeds = SCHEME_CDR(future_checkeds); - } - - from_modchain = SCHEME_VEC_ELS(from_modchain)[1]; - if (phase >= orig_phase) { - past_to_modchains = cons(to_modchain, past_to_modchains); - if (SCHEME_TRUEP(to_modchain)) - to_modchain = SCHEME_VEC_ELS(to_modchain)[1]; - } - phase++; - } - } while (SCHEME_NULLP(todo) && (SCHEME_PAIRP(prev_phase_todo) - || SCHEME_PAIRP(past_todos))); - } - - LOG_ATTACH(printf("Done phase: %d\n", phase)); - - if (SCHEME_PAIRP(nophase_todo) && !from_env->label_env) - scheme_signal_error("internal error: missing label environment"); - - /* Recursively process phase-#f modules: */ - while (!SCHEME_NULLP(nophase_todo)) { - int is_submod; - - name = SCHEME_CAR(nophase_todo); - if (SCHEME_PAIRP(name)) { - is_submod = 1; - main_modidx = SCHEME_CDR(name); - name = SCHEME_CAR(name); - } else - is_submod = 0; - nophase_todo = SCHEME_CDR(nophase_todo); - - if (!is_builtin_modname(name)) { - int i; - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - - LOG_ATTACH(printf("Check #f %s\n", scheme_write_to_string(name, 0))); - - if (!menv) { - if ((only_declare || is_submod) && main_modidx) { - ensure_instantiate_for_label(who, from_env, name, main_modidx); - /* try again: */ - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - } - - if (!menv) - scheme_arg_mismatch(who, - "internal error; unknown module (for label): ", - name); - } - - main_modidx = NULL; - - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - m2 = registry_get_loaded(to_env, name); - if (m2 && !SAME_OBJ(m2, menv->module)) { - const char * kind = "module with the same name"; - const char * phase = ""; - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "namespace-attach-module: " - "a different %s is already " - "in the destination namespace\n" - "%s" - " module name: %D", - kind, phase, name); - } - - for (i = -4; - i < (menv->other_require_names ? menv->other_require_names->size : 0); - i++) { - switch (i) { - case -4: - l = menv->require_names; - break; - case -3: - l = menv->et_require_names; - break; - case -2: - l = menv->tt_require_names; - break; - case -1: - l = menv->dt_require_names; - break; - default: - l = menv->other_require_names->vals[i]; - break; - } - - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(nophase_checked, name)) { - LOG_ATTACH(printf("Add .* %s\n", scheme_write_to_string(name, 0))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, name, scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - - for (i = 0; i < 3; i++) { - switch (i) { - case 0: - if (menv->module->supermodule) - l = scheme_make_pair(menv->module->supermodule, scheme_null); - else - l = scheme_null; - break; - case 1: - l = menv->module->post_submodules; - break; - case 2: - default: - l = menv->module->pre_submodules; - break; - } - - if (l) { - while (!SCHEME_NULLP(l)) { - name = ((Scheme_Module *)SCHEME_CAR(l))->modname; - - if (!scheme_hash_get(nophase_checked, name)) { - name = make_sub_modidx_pair(menv, name, i); - LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, SCHEME_CAR(name), scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - } - } - - /* All of the modules that we saw are in the ***_checked hash tables */ - if (prev_checked) { - past_checkeds = cons((Scheme_Object *)prev_checked, past_checkeds); - } - if (!only_declare){ - if (!checked) - checked = scheme_make_hash_table(SCHEME_hash_ptr); - past_checkeds = cons((Scheme_Object *)checked, past_checkeds); - } - - if (phase < max_phase) { - past_checkeds = cons((Scheme_Object *)next_checked, past_checkeds); - phase++; - } - while (phase < max_phase) { - next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds); - past_checkeds = scheme_make_raw_pair((Scheme_Object *)next_checked, past_checkeds); - - future_checkeds = SCHEME_CDR(future_checkeds); - phase++; - } - /* Now all the modules to check are in the past_checkeds - list of hash tables. */ - - /* Transfers phase-#f modules first. */ - { - int i; - Scheme_Hash_Table *ht; - - scheme_prepare_label_env(to_env); - - ht = nophase_checked; - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - name = ht->keys[i]; - - if (!is_builtin_modname(name)) { - - LOG_ATTACH(printf("Copying no-phase %s\n", scheme_write_to_string(name, NULL))); - - m2 = registry_get_loaded(from_env, name); - scheme_hash_set(to_env->module_registry->loaded, name, (Scheme_Object *)m2); - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - menv2 = scheme_copy_module_env(menv, to_env->label_env, to_env->label_env->modchain, menv->phase + 1); - check_phase(menv2, to_env->label_env, 0); - scheme_hash_set(MODCHAIN_TABLE(to_env->label_env->modchain), name, (Scheme_Object *)menv2); - - if (menv->attached) - menv2->attached = 1; - - /* Push name onto notify list: */ - if (!same_namespace) - notifies = scheme_make_pair(name, notifies); - } - } - } - } - - /* Get modchain at `phase': */ - { - int i; - Scheme_Env *te = to_env; - from_modchain = from_env->modchain; - to_modchain = to_env->modchain; - for (i = from_env->phase; i < phase; i++) { - from_modchain = SCHEME_VEC_ELS(from_modchain)[1]; - - scheme_prepare_exp_env(te); - te = te->exp_env; - to_modchain = SCHEME_VEC_ELS(to_modchain)[1]; - } - } - - /* Go through that list, this time tranferring module instances. */ - /* Again, outer loop iterates through phases. */ - while (!SCHEME_NULLP(past_checkeds)) { - /* Inner loop iterates through requires within a phase. */ - int i; - - checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds); - - LOG_ATTACH(printf("Copying %d (%p)\n", phase, checked)); - - if (phase >= orig_phase) - check_modchain_consistency(MODCHAIN_TABLE(to_modchain), phase); - - for (i = checked->size; i--; ) { - if (checked->vals[i]) { - int just_declare = SCHEME_FALSEP(checked->vals[i]); - name = checked->keys[i]; - - if (!is_builtin_modname(name)) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name); - - LOG_ATTACH(printf("Copy %d %s (%d)\n", phase, scheme_write_to_string(name, 0), just_declare)); - - /* Declare in the new namespace: */ - if (!scheme_hash_get(to_env->module_registry->exports, name)) { - scheme_hash_set(to_env->module_registry->loaded, name, (Scheme_Object *)menv->module); - scheme_hash_set(to_env->module_registry->exports, name, (Scheme_Object *)menv->module->me); - - /* Push name onto notify list: */ - if (!same_namespace) - notifies = scheme_make_pair(name, notifies); - } - - /* Clone/copy menv for the new namespace: */ - if ((phase >= orig_phase) && !just_declare) { - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - if (!menv2) { - menv2 = scheme_copy_module_env(menv, to_env, to_modchain, orig_phase); - if (menv->attached) - menv2->attached = 1; - - check_phase(menv2, NULL, phase); - scheme_hash_set(MODCHAIN_TABLE(to_modchain), name, (Scheme_Object *)menv2); - } - } - } - } - } - - past_checkeds = SCHEME_CDR(past_checkeds); - if (!SCHEME_NULLP(past_checkeds)) { - from_modchain = SCHEME_VEC_ELS(from_modchain)[2]; - if (phase > orig_phase) - to_modchain = SCHEME_VEC_ELS(to_modchain)[2]; - --phase; - } - } - - /* Notify module name resolver of attached modules: */ - { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - config = scheme_current_config(); - - if (set_env_for_notify) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)to_env); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER); - while (!SCHEME_NULLP(notifies)) { - a[0] = SCHEME_CAR(notifies); - a[1] = (Scheme_Object *)from_env; - - scheme_apply(resolver, 2, a); - - notifies = SCHEME_CDR(notifies); - } - - if (set_env_for_notify) { - scheme_pop_continuation_frame(&cframe); - } - } - - return scheme_void; -} - -static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[]) -{ - return do_namespace_attach_module("namespace-attach-module", argc, argv, 0); -} - -static Scheme_Object *namespace_attach_module_decl(int argc, Scheme_Object *argv[]) -{ - return do_namespace_attach_module("namespace-attach-module-declaration", argc, argv, 1); -} - -static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *to_env, *menv2; - Scheme_Object *name, *to_modchain, *insp, *code_insp; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_inspector_type)) - scheme_wrong_contract("namespace-unprotect-module", "inspector?", 0, argc, argv); - - insp = argv[0]; - if (argc > 2) - to_env = (Scheme_Env *)argv[2]; - else - to_env = scheme_get_env(NULL); - - name = scheme_module_resolve(scheme_make_modidx(argv[1], scheme_false, scheme_false), 0); - - to_modchain = to_env->modchain; - - code_insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - if (!SAME_OBJ(name, kernel_modname) - && !SAME_OBJ(name, flfxnum_modname) - && !SAME_OBJ(name, extfl_modname) - && !SAME_OBJ(name, futures_modname) - && !SAME_OBJ(name, foreign_modname)) { - if (SAME_OBJ(name, unsafe_modname)) - menv2 = scheme_get_unsafe_env(); - else - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - - if (!menv2) { - scheme_contract_error("namespace-unprotect-module", - "module not instantiated (in the target namespace)", - "name", 1, name, - NULL); - } - - if (!scheme_module_protected_wrt(menv2->guard_insp, insp) && !menv2->attached) { - code_insp = scheme_make_inspector(code_insp); - menv2->guard_insp = code_insp; - } - } - - return scheme_void; -} - -static int plain_char(int c) -{ - return (((c >= 'a') && (c <= 'z')) - || ((c >= 'A') && (c <= 'Z')) - || ((c >= '0') && (c <= '9')) - || (c == '-') - || (c == '_') - || (c == '+')); -} - -static int ok_hex(int c) -{ - return (((c >= 'a') && (c <= 'f')) - || ((c >= '0') && (c <= '9'))); -} - -static int ok_escape(int c1, int c2) -{ - c1 = (((c1 >= 'a') && (c1 <= 'f')) - ? (c1 - 'a' + 10) - : (c1 - '0')); - c2 = (((c2 >= 'a') && (c2 <= 'f')) - ? (c2 - 'a' + 10) - : (c2 - '0')); - - c1 = (c1 << 4) + c2; - - if (plain_char(c1)) - return 0; - else - return 1; -} - -static int ok_path_string(Scheme_Object *obj, int dir_ok, int just_file_ok, int file_end_ok, int for_planet) -{ - mzchar *s = SCHEME_CHAR_STR_VAL(obj); - int i = SCHEME_CHAR_STRLEN_VAL(obj), c, start_package_pos = 0, end_package_pos = 0; - int prev_was_slash = 0, saw_slash = !file_end_ok, saw_dot = 0; - - if (!i) - return 0; - if (s[0] == '/') - return 0; - if (s[i - 1] == '/') - return 0; - - if (for_planet) { - /* Must have at least two slashes, and a version spec is allowed between them */ - int j, counter = 0, colon1_pos = 0, colon2_pos = 0; - for (j = 0; j < i; j++) { - c = s[j]; - if (c == '/') { - counter++; - if (counter == 1) - start_package_pos = j + 1; - else if (counter == 2) - end_package_pos = j; - } else if (c == ':') { - if (counter == 1) { - if (colon2_pos) - return 0; - else if (colon1_pos) - colon2_pos = j; - else - colon1_pos = j; - } - } - } - - if (counter == 1) - end_package_pos = i; - - if (end_package_pos <= start_package_pos) - return 0; - - if (colon1_pos) { - /* Check that the version spec is well-formed, leaving the rest to the loop below */ - int colon1_end = (colon2_pos ? colon2_pos : end_package_pos); - - if (colon1_end == (colon1_pos + 1)) - return 0; - for (j = colon1_pos + 1; j < colon1_end; j++) { - c = s[j]; - if (!((c >= '0') && (c <= '9'))) - return 0; - } - - if (colon2_pos) { - colon2_pos++; - c = s[colon2_pos]; - if ((c == '<') || (c == '>')) { - if (s[colon2_pos+1] == '=') - colon2_pos += 2; - else - return 0; - } else if (c == '=') { - colon2_pos += 1; - } else { - if ((c >= '0') && (c <= '9')) { - /* check for range: */ - for (j = colon2_pos; j < end_package_pos; j++) { - if (s[j] == '-') { - colon2_pos = j + 1; - break; - } else if (!((c >= '0') && (c <= '9'))) - return 0; - } - } - } - if (end_package_pos == colon2_pos) - return 0; - - for (j = colon2_pos; j < end_package_pos; j++) { - c = s[j]; - if (!((c >= '0') && (c <= '9'))) - return 0; - } - } - - /* tell loop below to ignore the version part: */ - start_package_pos = colon1_pos; - } else { - /* package must have normal directory syntax */ - start_package_pos = end_package_pos = 0; - } - } - - while (i--) { - c = s[i]; - if (c == '/') { - saw_slash = 1; - if (prev_was_slash) - return 0; - prev_was_slash = 1; - } else if (c == '.') { - if (s[i+1] && (s[i+1] != '/') && (s[i+1] != '.')) { - if (saw_slash) { - /* can't have suffix on a directory */ - return 0; - } - saw_dot = 1; - } - prev_was_slash = 0; - } else { - if (plain_char(c) - || ((c == '%') - && ok_hex(s[i+1]) - && ok_hex(s[i+2]) - && ok_escape(s[i+1], s[i+2]))) { - prev_was_slash = 0; - } else if ((i < start_package_pos) || (i >= end_package_pos)) - return 0; - else { - prev_was_slash = 0; - } - } - } - - if (!just_file_ok) { - if (saw_dot && !saw_slash) { - /* can't have a file name with no directory */ - return 0; - } - } - - if (!dir_ok) { - for (i = 0; s[i]; i++) { - if (s[i] == '.') { - if (!s[i+1] || (s[i+1] == '/')) - return 0; - if (s[i+1] == '.') - if (!s[i+2] || (s[i+2] == '/')) - return 0; - while (s[i] == '.') { - i++; - } - } - } - } - - return 1; -} - -static int ok_planet_number(Scheme_Object *a) -{ - if (SCHEME_INTP(a)) { - if (SCHEME_INT_VAL(a) >= 0) - return 1; - } else if (SCHEME_BIGNUMP(a)) { - if (SCHEME_BIGPOS(a)) - return 1; - } - return 0; -} - - -static int ok_planet_string(Scheme_Object *obj) -{ - mzchar *s; - int i, c; - - if (!SCHEME_CHAR_STRINGP(obj)) - return 0; - - s = SCHEME_CHAR_STR_VAL(obj); - i = SCHEME_CHAR_STRLEN_VAL(obj); - - if (!i) - return 0; - - while (i--) { - c = s[i]; - if ((c == '%') - && ok_hex(s[i+1]) - && ok_hex(s[i+2]) - && ok_escape(s[i+1], s[i+2])) { - /* ok */ - } else if (plain_char(c) || (c == '.')) { - /* ok */ - } else - return 0; - } - - return 1; -} - -int scheme_is_module_path(Scheme_Object *obj) -{ - if (SCHEME_PAIRP(obj) - && (SAME_OBJ(SCHEME_CAR(obj), submod_symbol))) { - Scheme_Object *p, *a; - int len = 0; - p = SCHEME_CDR(obj); - if (SCHEME_PAIRP(p)) { - p = SCHEME_CDR(p); - while (SCHEME_PAIRP(p)) { - len++; - a = SCHEME_CAR(p); - if (!SCHEME_SYMBOLP(a) - && (!SCHEME_CHAR_STRINGP(a) - || (SCHEME_CHAR_STRLEN_VAL(a) != 2) - || (SCHEME_CHAR_STR_VAL(a)[0] != '.') - || (SCHEME_CHAR_STR_VAL(a)[1] != '.'))) - break; - p = SCHEME_CDR(p); - } - } else - p = scheme_false; - if (SCHEME_NULLP(p)) { - obj = SCHEME_CDR(obj); - obj = SCHEME_CAR(obj); - if (SCHEME_CHAR_STRINGP(obj) - && (((SCHEME_CHAR_STRLEN_VAL(obj) == 1) - && (SCHEME_CHAR_STR_VAL(obj)[0] == '.')) - || ((SCHEME_CHAR_STRLEN_VAL(obj) == 2) - && (SCHEME_CHAR_STR_VAL(obj)[0] == '.') - && (SCHEME_CHAR_STR_VAL(obj)[1] == '.')))) - return 1; - } - } - - if (SCHEME_PATHP(obj)) - return 1; - - if (SCHEME_CHAR_STRINGP(obj)) { - return ok_path_string(obj, 1, 1, 1, 0); - } - - if (SCHEME_SYMBOLP(obj)) { - obj = scheme_make_sized_offset_utf8_string((char *)(obj), - SCHEME_SYMSTR_OFFSET(obj), - SCHEME_SYM_LEN(obj)); - return ok_path_string(obj, 0, 0, 0, 0); - } - - if (SCHEME_PAIRP(obj)) { - if (SAME_OBJ(SCHEME_CAR(obj), quote_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj)) { - if (SCHEME_NULLP(SCHEME_CDR(obj))) { - obj = SCHEME_CAR(obj); - return SCHEME_SYMBOLP(obj); - } else - return 0; - } else - return 0; - } else if (SAME_OBJ(SCHEME_CAR(obj), lib_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj)) { - Scheme_Object *a; - int is_first = 1; - while (SCHEME_PAIRP(obj)) { - a = SCHEME_CAR(obj); - if (SCHEME_CHAR_STRINGP(a)) { - if (!ok_path_string(a, 0, is_first, is_first, 0)) - return 0; - } else - return 0; - obj = SCHEME_CDR(obj); - is_first = 0; - } - if (SCHEME_NULLP(obj)) - return 1; - else - return 0; - } else - return 0; - } else if (SAME_OBJ(SCHEME_CAR(obj), file_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj) && SCHEME_NULLP(SCHEME_CDR(obj))) { - int i; - mzchar *s; - obj = SCHEME_CAR(obj); - if (!SCHEME_CHAR_STRINGP(obj)) - return 0; - s = SCHEME_CHAR_STR_VAL(obj); - i = SCHEME_CHAR_STRLEN_VAL(obj); - if (!i) - return 0; - while (i--) { - if (!s[i]) - return 0; - } - return 1; - } - } else if (SAME_OBJ(SCHEME_CAR(obj), planet_symbol)) { - Scheme_Object *a, *subs; - int len, counter; - - len = scheme_proper_list_length(obj); - - if (len == 2) { - /* Symbolic or string shorthand? */ - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (SCHEME_SYMBOLP(a)) { - obj = scheme_make_sized_offset_utf8_string((char *)(a), - SCHEME_SYMSTR_OFFSET(a), - SCHEME_SYM_LEN(a)); - return ok_path_string(obj, 0, 0, 0, 1); - } else if (SCHEME_CHAR_STRINGP(a)) { - return ok_path_string(a, 0, 0, 1, 1); - } - } - - if (len < 3) - return 0; - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (!SCHEME_CHAR_STRINGP(a)) - return 0; - if (!ok_path_string(a, 0, 1, 1, 0)) - return 0; - obj = SCHEME_CDR(obj); - subs = SCHEME_CDR(obj); - obj = SCHEME_CAR(obj); - len = scheme_proper_list_length(obj); - if (len < 2) - return 0; - - a = SCHEME_CAR(obj); - if (!ok_planet_string(a)) - return 0; - - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (!ok_planet_string(a)) - return 0; - - /* planet allows a major and minor version number: */ - counter = 0; - for (obj = SCHEME_CDR(obj); !SCHEME_NULLP(obj); obj = SCHEME_CDR(obj)) { - if (counter == 2) - return 0; - a = SCHEME_CAR(obj); - if (ok_planet_number(a)) { - /* ok */ - } else if ((counter == 1) && SCHEME_PAIRP(a)) { - if (scheme_proper_list_length(a) != 2) - return 0; - if (ok_planet_number(SCHEME_CAR(a))) { - if (ok_planet_number(SCHEME_CADR(a))) { - if (scheme_bin_lt_eq(SCHEME_CAR(a), SCHEME_CADR(a))) { - /* ok */ - } else - return 0; - } else - return 0; - } else if (SCHEME_SYMBOLP(SCHEME_CAR(a))) { - if (SCHEME_SYM_LEN(SCHEME_CAR(a))) { - int c; - c = SCHEME_SYM_VAL(SCHEME_CAR(a))[0]; - if ((c == '=') || (c == '+') || (c == '-')) { - if (!ok_planet_number(SCHEME_CADR(a))) - return 0; - /* else ok */ - } else - return 0; - } else - return 0; - } else - return 0; - } else - return 0; - counter++; - } - - for (; !SCHEME_NULLP(subs); subs = SCHEME_CDR(subs)) { - a = SCHEME_CAR(subs); - if (!SCHEME_CHAR_STRINGP(a)) - return 0; - if (!ok_path_string(a, 0, 0, 0, 0)) - return 0; - } - - return 1; - } - } - - return 0; -} - -static Scheme_Object *is_module_path(int argc, Scheme_Object **argv) -{ - return (scheme_is_module_path(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *require_binding_to_key(Scheme_Hash_Table *required, - Scheme_Object *binding_vec, - Scheme_Object *sym) -{ - Scheme_Object *vec, *vec2, *modname; - - vec = scheme_hash_get(required, sym); - if (vec) { - if (SCHEME_FALSEP(vec)) { - /* we've split the mapping for this symbol into binding-specific - mappings already; fall through */ - } else { - /* the symbol is mapped -- for the same binding? */ - if (same_resolved_modidx(SCHEME_VEC_ELS(binding_vec)[0], - SCHEME_VEC_ELS(vec)[1]) - && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[1], - SCHEME_VEC_ELS(vec)[2]) - && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[2], - SCHEME_VEC_ELS(vec)[8])) { - /* Yes, this symbol is mapped only for that one binding, so far */ - return sym; - } else { - /* need to re-key the existing mapping to a full binding, - map the plain symbol to #f, and fall through to generate - a full key for the new binding */ - vec2 = scheme_make_vector(4, NULL); - modname = scheme_module_resolve(SCHEME_VEC_ELS(vec)[1], 0); - SCHEME_VEC_ELS(vec2)[0] = modname; - SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(vec)[2]; - SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(vec)[8]; - SCHEME_VEC_ELS(vec2)[3] = sym; - - scheme_hash_set(required, vec2, vec); - scheme_hash_set(required, sym, scheme_false); - } - } - } else { - /* no binding mapped with this symbol in the key, yet, so we can - just use the symbol: */ - return sym; - } - - modname = scheme_module_resolve(SCHEME_VEC_ELS(binding_vec)[0], 0); - - vec2 = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec2)[0] = modname; - SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(binding_vec)[1]; - SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(binding_vec)[2]; - SCHEME_VEC_ELS(vec2)[3] = sym; - - return vec2; -} - -static int prep_required_id(Scheme_Object *vec) -{ - Scheme_Object *id = SCHEME_VEC_ELS(vec)[6]; - - if (SCHEME_SYMBOLP(id)) { - id = scheme_datum_to_syntax(id, scheme_false, SCHEME_VEC_ELS(vec)[5], 0, 0); - SCHEME_VEC_ELS(vec)[6] = id; - } - - return 1; -} - -static int do_add_simple_require_renames(Scheme_Object *rn, Scheme_Env *env, - Scheme_Hash_Table *required, Scheme_Object *orig_src, - Scheme_Module *im, Scheme_Module_Phase_Exports *pt, - Scheme_Object *idx, - Scheme_Object *src_phase_index, - int can_override, - int skip_binding_step) -{ - int i, saw_mb, numvals; - Scheme_Object **exs, **exss, **exsns, *midx, *vec, *nml, *key; - int *exets; - int with_shared = 1; - - saw_mb = 0; - - if (!pt->num_provides) - return 0; - - if (with_shared && !skip_binding_step) { - if (!pt->src_modidx && im->me->src_modidx) - pt->src_modidx = im->me->src_modidx; - scheme_extend_module_context_with_shared(rn, idx, pt, - scheme_false, /* no prefix */ - NULL, /* no excepts */ - src_phase_index, - orig_src, - NULL); - } - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - numvals = pt->num_var_provides; - for (i = pt->num_provides; i--; ) { - if (exss && !SCHEME_FALSEP(exss[i])) - midx = scheme_modidx_shift(exss[i], im->me->src_modidx, idx); - else - midx = idx; - if (!with_shared && !skip_binding_step) { - scheme_extend_module_context(rn, orig_src, midx, exs[i], exsns[i], idx, exs[i], - exets ? exets[i] : 0, src_phase_index, pt->phase_index); - } - if (SAME_OBJ(exs[i], module_begin_symbol)) - saw_mb = 1; - - if (required) { - /* - A `required' vector has the following slots: - 0 : list of nominal source (i.e., the modules written with `require') - 1 : the initial midx for the import - 2 : a symbolic name in the original exporting module - 3 : variable => #t; syntax => #f - 4 : the exported name as a symbol - 5 : a syntax object for error reporting - 6 : identifier as imported, where table key is corresponding binding; - a symbol value should be converted to an id using slot 5; see prep_required_id() - 7 : boolean, true if slot 6 is overrideable - 8 : source phase - */ - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(idx, scheme_null); - - /* Since all initial exports have different names, we can use the - simple form of a key and be consistent with binding_to_key(): */ - key = exs[i]; - - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = midx; - SCHEME_VEC_ELS(vec)[2] = exsns[i]; - SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = exs[i]; - SCHEME_VEC_ELS(vec)[5] = orig_src; - SCHEME_VEC_ELS(vec)[6] = exs[i]; /* => id by cmbining with orig_src */ - SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_make_integer(0); - - scheme_hash_set(required, key, vec); - } - } - - return saw_mb; -} - -static Scheme_Object *get_table(Scheme_Hash_Table *tables, Scheme_Object *phase) -{ - Scheme_Object *vec; - Scheme_Hash_Table *required; - - vec = scheme_hash_get(tables, phase); - if (!vec) { - required = scheme_make_hash_table_equal(); - vec = scheme_make_vector(3, scheme_false); - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; - scheme_hash_set(tables, phase, vec); - } - - return vec; -} - -static Scheme_Hash_Table *get_required_from_tables(Scheme_Hash_Table *tables, Scheme_Object *phase) -{ - Scheme_Object *vec; - - if (!tables) - return NULL; - - vec = get_table(tables, phase); - - return (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; -} - -static int add_simple_require_renames(Scheme_Object *orig_src, - Scheme_Object *rn_set, Scheme_Env *env, - Scheme_Hash_Table *tables, - Scheme_Module *im, Scheme_Object *idx, - Scheme_Object *import_shift /* = src_phase_index */, - Scheme_Object *only_export_phase, - int can_override, - int skip_binding_step) -{ - int saw_mb; - Scheme_Object *phase; - - if (im->me->rt - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(0)))) - saw_mb = do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, import_shift), env, - get_required_from_tables(tables, import_shift), - orig_src, im, im->me->rt, idx, - import_shift, - can_override, - skip_binding_step); - else - saw_mb = 0; - - if (im->me->et - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(1)))) { - if (SCHEME_FALSEP(import_shift)) - phase = scheme_false; - else - phase = scheme_bin_plus(scheme_make_integer(1), import_shift); - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, - get_required_from_tables(tables, phase), - orig_src, im, im->me->et, idx, - import_shift, - can_override, - skip_binding_step); - } - - if (im->me->dt - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_false))) { - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, scheme_false), env, - get_required_from_tables(tables, scheme_false), - orig_src, im, im->me->dt, idx, - import_shift, - can_override, - skip_binding_step); - } - - if (im->me->other_phases) { - Scheme_Object *val, *key; - int i; - for (i = 0; i < im->me->other_phases->size; i++) { - val = im->me->other_phases->vals[i]; - if (val) { - key = im->me->other_phases->keys[i]; - if (!only_export_phase || scheme_eqv(only_export_phase, key)) { - if (SCHEME_FALSEP(import_shift)) - phase = scheme_false; - else - phase = scheme_bin_plus(key, import_shift); - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, - get_required_from_tables(tables, phase), - orig_src, im, (Scheme_Module_Phase_Exports *)val, idx, - import_shift, - can_override, - skip_binding_step); - } - } - } - } - - return saw_mb; -} - -static void add_reconstructed_binding(Scheme_Object *name, Scheme_Object *one_rn, Scheme_Object *self_modidx, - Scheme_Env *env, int phase) -{ - Scheme_Hash_Table *binding_names; - - scheme_extend_module_context(one_rn, NULL, self_modidx, name, name, self_modidx, name, phase, - scheme_make_integer(phase), NULL); - - binding_names = (Scheme_Hash_Table *)env->binding_names; - if (!binding_names) { - binding_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->binding_names = (Scheme_Object *)binding_names; - } - scheme_hash_set(binding_names, name, - scheme_stx_add_module_context(scheme_datum_to_syntax(name, scheme_false, scheme_false, 0, 0), - one_rn)); -} - -void scheme_prep_namespace_rename(Scheme_Env *menv) -{ - while (menv->mod_phase > 0) { - scheme_prepare_template_env(menv); - menv = menv->template_env; - } - - scheme_prepare_exp_env(menv); - start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null, 1); - - if (!menv->rename_set_ready) { - if (menv->module->rn_stx) { - Scheme_Object *rns; - Scheme_Module *m = menv->module; - - scheme_prepare_env_stx_context(menv); - - if (SAME_OBJ(scheme_true, m->rn_stx)) { - /* Reconstruct renames based on defns and requires. This case is - used only when it's easy to reconstruct: no rename on import, - no prefixes or exclusions on import, no definitions within the - module that are inaccessible due to scope differences, etc. */ - int i, j; - Scheme_Module *im; - Scheme_Object *l, *idx, *one_rn, *shift, *name; - - rns = menv->stx_context; - one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(0)); - - /* Required: */ - for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) { - switch (i) { - case -4: - l = menv->require_names; - shift = scheme_make_integer(0); - break; - case -3: - l = menv->et_require_names; - shift = scheme_make_integer(1); - break; - case -2: - l = menv->tt_require_names; - shift = scheme_make_integer(-1); - break; - case -1: - l = menv->dt_require_names; - shift = scheme_false; - break; - default: - l = menv->other_require_names->vals[i]; - shift = menv->other_require_names->keys[i]; - break; - } - - if (l) { - /* Do initial import first to get shadowing right: */ - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - idx = SCHEME_CAR(l); - name = scheme_module_resolve(idx, 0); - - im = get_special_module(name); - if (!im) - im = registry_get_loaded(menv, name); - - add_simple_require_renames(NULL, rns, menv, NULL, im, idx, shift, - NULL, 0, 0); - } - } - } - - /* Local, provided: */ - for (i = 0; i < m->me->rt->num_provides; i++) { - if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { - name = m->me->rt->provide_src_names[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, menv, 0); - } - } - for (j = 0; j < m->num_phases; j++) { - Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; - Scheme_Env *penv; - one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(j)); - penv = scheme_find_env_at_phase(menv, scheme_make_integer(j)); - for (i = 0; i < exp_info->num_indirect_provides; i++) { - name = exp_info->indirect_provides[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); - } - for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { - name = exp_info->indirect_syntax_provides[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); - } - } - - rns = scheme_module_context_to_stx(rns, NULL); - - m->rn_stx = rns; - } else if (SCHEME_PAIRP(m->rn_stx)) { - /* Delayed shift: */ - Scheme_Object *rn_stx, *midx; - - rn_stx = SCHEME_CAR(m->rn_stx); - midx = SCHEME_CDR(m->rn_stx); - - rn_stx = scheme_stx_force_delayed(rn_stx); - - rn_stx = scheme_stx_shift(rn_stx, scheme_make_integer(0), midx, m->self_modidx, - NULL, m->prefix->src_insp_desc, menv->access_insp); - - m->rn_stx = rn_stx; - } else { - Scheme_Object *rn_stx; - rn_stx = scheme_stx_force_delayed(m->rn_stx); - m->rn_stx = rn_stx; - } - - rns = m->rn_stx; - if (menv->phase) - rns = scheme_stx_shift(rns, scheme_make_integer(menv->phase), NULL, NULL, NULL, NULL, NULL); - - rns = scheme_stx_to_module_context(rns); - menv->stx_context = rns; - - menv->rename_set_ready = 1; - } else { - /* had #:empty-namespace declaration */ - scheme_prepare_env_stx_context(menv); - } - } -} - -Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env) -{ - Scheme_Env *menv; - Scheme_Object *modchain; - - if (SCHEME_MODNAMEP(name)) { - ; - } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type)) { - name = scheme_module_resolve(name, 1); - } else { - /* name is path or module-path */ - name = scheme_module_resolve(scheme_make_modidx(name, scheme_false, scheme_false), 1); - } - - menv = get_special_modenv(name); - if (!menv) { - modchain = env->modchain; - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(modchain), name); - if (!menv) { - if (registry_get_loaded(env, name)) - scheme_contract_error("module->namespace", - "module not instantiated in the current namespace", - "name", 1, name, - NULL); - else - scheme_contract_error("module->namespace", - "unknown module in the current namespace", - "name", 1, name, - NULL); - } - } - - { - Scheme_Object *insp; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - if (scheme_module_protected_wrt(menv->guard_insp, insp) || menv->attached) { - scheme_contract_error("module->namespace", - "current code inspector cannot access namespace of module", - "module name", 1, name, - NULL); - } - } - - scheme_prep_namespace_rename(menv); - - menv->interactive_bindings = 1; - - return (Scheme_Object *)menv; -} - -static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - if (!SCHEME_PATHP(argv[0]) - && !SCHEME_MODNAMEP(argv[0]) - && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type) - && !scheme_is_module_path(argv[0])) - scheme_wrong_contract("module->namespace", "(or/c module-path? module-path-index? resolved-module-path?)", 0, argc, argv); - - return scheme_module_to_namespace(argv[0], env); -} - -static Scheme_Module *module_to_(const char *who, int argc, Scheme_Object *argv[], int unknown_ok) -{ - Scheme_Env *env; - Scheme_Object *name; - Scheme_Module *m; - - env = scheme_get_env(NULL); - - name = argv[0]; - - if (!SCHEME_PATHP(name) - && !SCHEME_MODNAMEP(name) - && !SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type) - && !scheme_is_module_path(name)) - scheme_wrong_contract(who, "(or/c module-path? module-path-index? resolved-module-path?)", 0, argc, argv); - - if (!SCHEME_MODNAMEP(name)) { - if (!SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type)) - name = scheme_make_modidx(name, scheme_false, scheme_false); - name = scheme_module_resolve(name, (argc > 1) ? SCHEME_TRUEP(argv[1]) : 0); - } - - m = get_special_module(name); - if (!m) { - env = scheme_get_env(NULL); - m = registry_get_loaded(env, name); - } - - if (!m && !unknown_ok) - scheme_contract_error(who, - "unknown module in the current namespace", - "name", 1, name, - NULL); - - return m; -} - -static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->language-info", argc, argv, 0); - - return (m->lang_info ? m->lang_info : scheme_false); -} - -static Scheme_Object *module_is_declared(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module-declared?", argc, argv, 1); - - return (m ? scheme_true : scheme_false); -} - -int scheme_module_is_declared(Scheme_Object *name, int try_load) -{ - Scheme_Object *a[2]; - Scheme_Module *m; - - a[0] = name; - a[1] = (try_load ? scheme_true : scheme_false); - m = module_to_("module-declared?", 2, a, 1); - - return (m ? 1 : 0); -} - -static Scheme_Object *module_is_predefined(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module-predefined?", argc, argv, 1); - - return ((m && m->predefined) ? scheme_true : scheme_false); -} - -int scheme_is_predefined_module_p(Scheme_Object *name) -{ - Scheme_Object *a[1]; - Scheme_Module *m; - - a[0] = name; - m = module_to_("module-predefined?", 1, a, 1); - - return m && m->predefined; -} - -static Scheme_Object *extract_compiled_imports(Scheme_Module *m) -{ - Scheme_Object *l; - int i; - - l = scheme_null; - if (!SCHEME_NULLP(m->requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(0), - m->requires), - l); - if (!SCHEME_NULLP(m->et_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(1), - m->et_requires), - l); - if (!SCHEME_NULLP(m->tt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(-1), - m->tt_requires), - l); - if (!SCHEME_NULLP(m->dt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_false, - m->dt_requires), - l); - - if (m->other_requires) { - for (i = 0; i < m->other_requires->size; i++) { - if (m->other_requires->vals[i]) { - l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i], - m->other_requires->vals[i]), - l); - } - } - } - - return l; -} - -static Scheme_Object *make_provide_desc(Scheme_Module_Phase_Exports *pt, int i) -{ - return scheme_make_pair(pt->provides[i], - scheme_make_pair((pt->provide_nominal_srcs - ? pt->provide_nominal_srcs[i] - : scheme_null), - scheme_null)); -} - -static Scheme_Object *extract_compiled_exports(Scheme_Module *m) -{ - Scheme_Object *a[2]; - Scheme_Object *ml, *vl, *val_l, *mac_l; - Scheme_Module_Phase_Exports *pt; - int i, n, k; - - val_l = scheme_null; - mac_l = scheme_null; - - for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { - switch(k) { - case -3: - pt = m->me->rt; - break; - case -2: - pt = m->me->et; - break; - case -1: - pt = m->me->dt; - break; - default: - pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; - break; - } - - if (pt) { - ml = scheme_null; - vl = scheme_null; - n = pt->num_var_provides; - for (i = pt->num_provides - 1; i >= n; --i) { - ml = scheme_make_pair(make_provide_desc(pt, i), ml); - } - for (; i >= 0; --i) { - vl = scheme_make_pair(make_provide_desc(pt, i), vl); - } - - if (!SCHEME_NULLP(vl)) - val_l = scheme_make_pair(scheme_make_pair(pt->phase_index, vl), - val_l); - - if (!SCHEME_NULLP(ml)) - mac_l = scheme_make_pair(scheme_make_pair(pt->phase_index, ml), - mac_l); - } - } - - a[0] = val_l; - a[1] = mac_l; - return scheme_values(2, a); -} - -static Scheme_Object *extract_compiled_indirect_exports(Scheme_Module *m) -{ - int k, i; - Scheme_Object *l, *a; - Scheme_Module_Export_Info *ei; - - l = scheme_null; - - for (k = m->num_phases; k--; ) { - ei = m->exp_infos[k]; - if (ei && ei->num_indirect_provides) { - a = scheme_null; - for (i = ei->num_indirect_provides; i--; ) { - a = scheme_make_pair(ei->indirect_provides[i], a); - } - a = scheme_make_pair(scheme_make_integer(k), a); - l = scheme_make_pair(a, l); - } - } - - return l; -} - -static Scheme_Object *module_to_imports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->imports", argc, argv, 0); - - return extract_compiled_imports(m); -} - -static Scheme_Object *module_to_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->exports", argc, argv, 0); - - return extract_compiled_exports(m); -} - -static Scheme_Object *module_to_indirect_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->indirect_exports", argc, argv, 0); - - return extract_compiled_indirect_exports(m); -} - -static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - return (m ? scheme_true : scheme_false); -} - -static Scheme_Object *wrap_module_in_top(Scheme_Object *m, Scheme_Object *t) -{ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - memcpy(top, t, sizeof(Scheme_Compilation_Top)); - top->code = m; - - return (Scheme_Object *)top; -} - -static void reset_submodule_paths(Scheme_Module *m) -{ - Scheme_Module *m2; - Scheme_Object *stack, *l, *l2, *v, *v2, *name, *submodule_path; - int k; - - stack = scheme_make_pair((Scheme_Object *)m, scheme_null); - while (!SCHEME_NULLP(stack)) { - m = (Scheme_Module *)SCHEME_CAR(stack); - stack = SCHEME_CDR(stack); - - submodule_path = scheme_resolved_module_path_value(m->modname); - if (SCHEME_SYMBOLP(submodule_path)) - submodule_path = scheme_make_pair(submodule_path, scheme_null); - submodule_path = scheme_reverse(submodule_path); - - for (k = 0; k < 2; k++) { - l = (k ? m->post_submodules : m->pre_submodules); - if (l) { - l2 = scheme_null; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, SCHEME_CAR(l), sizeof(Scheme_Module)); - - name = scheme_resolved_module_path_value(m2->modname); - if (SCHEME_PAIRP(name)) { - while (SCHEME_PAIRP(name) && SCHEME_PAIRP(SCHEME_CDR(name))) { - name = SCHEME_CDR(name); - } - name = SCHEME_CAR(name); - } - v = scheme_reverse(scheme_make_pair(name, submodule_path)); - v2 = scheme_intern_resolved_module_path(v); - m2->modname = v2; - m2->submodule_path = SCHEME_CDR(v); - - l2 = scheme_make_pair((Scheme_Object *)m2, l2); - stack = scheme_make_pair((Scheme_Object *)m2, stack); - } - l2 = scheme_reverse(l2); - if (k) - m->post_submodules = l2; - else - m->pre_submodules = l2; - } - } - } -} - -static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m, *m2; - Scheme_Object *v, *p; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) { - if (argc > 1) { - v = argv[1]; - if (!SCHEME_SYMBOLP(v)) { - if (SCHEME_PAIRP(v)) { - while (SCHEME_PAIRP(v)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - break; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) - v = NULL; - } else - v = NULL; - } - if (!v) - scheme_wrong_contract("module-compiled-name", "(or/c symbol? (listof symbol?))", 1, argc, argv); - if (SCHEME_PAIRP(v)) { - p = SCHEME_CDR(v); - if (SCHEME_NULLP(p)) - v = SCHEME_CAR(v); - } else - p = scheme_null; - v = scheme_intern_resolved_module_path(v); - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - m2->modname = v; - m2->submodule_path = p; - reset_submodule_paths(m2); - return wrap_module_in_top((Scheme_Object *)m2, argv[0]); - } else - return scheme_resolved_module_path_value(m->modname); - } - - scheme_wrong_contract("module-compiled-name", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_imports(m); - - scheme_wrong_contract("module-compiled-imports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_exports(m); - - scheme_wrong_contract("module-compiled-exports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_indirect_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_indirect_exports(m); - - scheme_wrong_contract("module-compiled-indirect-exports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) { - return (m->lang_info ? m->lang_info : scheme_false); - } - - scheme_wrong_contract("module-compiled-language-info", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_submodules(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m, *m2; - Scheme_Object *l, *l2; - int pre; - - m = scheme_extract_compiled_module(argv[0]); - pre = SCHEME_TRUEP(argv[1]); - - if (m) { - if (argc > 2) { - l2 = scheme_null; - for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - m2 = scheme_extract_compiled_module(SCHEME_CAR(l)); - if (!m2) break; - l2 = scheme_make_pair((Scheme_Object *)m2, l2); - } - if (SCHEME_NULLP(l)) { - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - l2 = scheme_reverse(l2); - if (pre) - m2->pre_submodules = l2; - else - m2->post_submodules = l2; - reset_submodule_paths(m2); - return wrap_module_in_top((Scheme_Object *)m2, argv[0]); - } else { - scheme_wrong_contract("module-compiled-submodules", "(listof compiled-module-expression?)", 2, argc, argv); - } - } else { - l2 = scheme_null; - l = (pre ? m->pre_submodules : m->post_submodules); - l = l ? l : scheme_null; - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - l2 = scheme_make_pair(wrap_module_in_top(SCHEME_CAR(l), argv[0]), l2); - } - } - - return scheme_reverse(l2); - } - - scheme_wrong_contract("module-compiled-submodules", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_phaseless_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - if (m) { - if (m->phaseless) - return scheme_true; - } else - scheme_wrong_contract("module-compiled-cross-phase-persistent?", - "compiled-module-expression?", 0, argc, argv); - - return scheme_false; -} - -static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-resolve", "module-path-index?", 0, argc, argv); - - return scheme_module_resolve(argv[0], 0); -} - -static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]) -{ - Scheme_Modidx *modidx; - Scheme_Object *a[2]; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-split", "module-path-index?", 0, argc, argv); - - modidx = (Scheme_Modidx *)argv[0]; - a[0] = modidx->path; - a[1] = modidx->base; - - return scheme_values(2, a); -} - -static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_module_path(argv[0]) - && !SCHEME_FALSEP(argv[0])) - scheme_wrong_contract("module-path-index-join", "(or/c module-path? #f)", 0, argc, argv); - - if (argv[1]) { /* mzc will generate NULL sometimes; see scheme_declare_module(), below */ - if (SCHEME_TRUEP(argv[1]) - && !SCHEME_MODNAMEP(argv[1]) - && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-join", "(or/c module-path-index? resolved-module-path? #f)", 1, argc, argv); - - if (SCHEME_FALSEP(argv[0]) && !SCHEME_FALSEP(argv[1])) - scheme_contract_error("module-path-index-join", - "first argument cannot be #f when second argument is not #f", - "second argument", 1, argv[1], - NULL); - } - - if (argc > 2) { - Scheme_Object *l = argv[2]; - if (SCHEME_TRUEP(l)) { - if (SCHEME_PAIRP(l)) { - while (SCHEME_PAIRP(l)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - } else - l = scheme_false; - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("module-path-index-join", "(non-empty-listof symbol?)", 2, argc, argv); - if (SCHEME_TRUEP(argv[0]) || SCHEME_TRUEP(argv[1])) - scheme_contract_error("module-path-index-join", - "third argument must be #f when first or second argument is non-#f", - "first argument", 1, argv[0], - "second argument", 1, argv[1], - "third argument", 1, argv[2], - NULL); - return scheme_get_submodule_empty_self_modidx(argv[2], 0); - } - } - - return scheme_make_modidx(argv[0], argv[1], scheme_false); -} - -static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[]) -{ - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-submodule", "module-path-index?", 0, argc, argv); - - return scheme_modidx_submodule(argv[0]); -} - -Scheme_Object *scheme_modidx_submodule(Scheme_Object *_modidx) -{ - Scheme_Modidx *modidx; - Scheme_Object *a; - - modidx = (Scheme_Modidx *)_modidx; - a = modidx->resolved; - if (SCHEME_TRUEP(modidx->path) - || SCHEME_TRUEP(modidx->base) - || SCHEME_FALSEP(a)) - return scheme_false; - - a = scheme_resolved_module_path_value(a); - if (!SCHEME_PAIRP(a)) - return scheme_false; - - return SCHEME_CDR(a); -} - -void scheme_init_module_path_table() -{ - REGISTER_SO(modpath_table); -#if PLACE_LOCAL_MODPATH_TABLE - modpath_table = scheme_make_nonlock_equal_bucket_table(); -#else - modpath_table = scheme_make_weak_equal_table(); -#endif -} - -static Scheme_Object *make_resolved_module_path_obj(Scheme_Object *o) -{ - Scheme_Object *rmp; - - rmp = scheme_alloc_small_object(); - rmp->type = scheme_resolved_module_path_type; - SCHEME_PTR_VAL(rmp) = o; - - return rmp; -} - -Scheme_Object *scheme_resolved_module_path_value(Scheme_Object *rmp) -{ - return SCHEME_RMP_VAL(rmp); -} - -int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o) { - Scheme_Object *rmp_val = SCHEME_RMP_VAL(rmp); - if (SAME_OBJ(rmp_val, o)) - return 1; - else if (SCHEME_BYTE_STRINGP(rmp_val) && SCHEME_SYMBOLP(o)) { - return !strncmp(SCHEME_BYTE_STR_VAL(rmp_val), - SCHEME_SYM_VAL(o), - mz_MIN(SCHEME_BYTE_STRLEN_VAL(rmp_val), SCHEME_SYM_LEN(o))); - } else { - scheme_arg_mismatch("scheme_resolved_module_path_value_matches", - "internal error: unknown type of resolved_module_path_value", - rmp_val); - return 0; - } -} - -Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) -{ - Scheme_Bucket_Table *create_table; - Scheme_Object *rmp; - Scheme_Bucket *b; - - rmp = make_resolved_module_path_obj(o); -#if PLACE_LOCAL_MODPATH_TABLE - if (place_local_modpath_table) { - scheme_start_atomic(); - b = scheme_bucket_or_null_from_table(place_local_modpath_table, (const char *)rmp, 0); - scheme_end_atomic_no_swap(); - if (b) { - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - } - } -#endif - - scheme_start_atomic(); - b = scheme_bucket_or_null_from_table(modpath_table, (const char *)rmp, 0); - scheme_end_atomic_no_swap(); - - if (b) { -#if PLACE_LOCAL_MODPATH_TABLE - return (Scheme_Object *)b->key; -#else - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); -#endif - } - -#if PLACE_LOCAL_MODPATH_TABLE - create_table = place_local_modpath_table ? place_local_modpath_table : modpath_table; -#else - create_table = modpath_table; -#endif - - scheme_start_atomic(); - b = scheme_bucket_from_table(create_table, (const char *)rmp); - scheme_end_atomic_no_swap(); - - if (!b->val) - b->val = scheme_true; - -#if PLACE_LOCAL_MODPATH_TABLE - if (!place_local_modpath_table) - return (Scheme_Object *)b->key; -#endif - return(Scheme_Object *)HT_EXTRACT_WEAK(b->key); -} - -static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]) -{ - return (SCHEME_MODNAMEP(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *p; - - p = argv[0]; - if (SCHEME_PAIRP(p)) { - if (scheme_is_list(p)) { - p = SCHEME_CDR(p); - if (SCHEME_PAIRP(p)) { - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) - break; - p = SCHEME_CDR(p); - } - } else - p = scheme_false; - if (SCHEME_NULLP(p)) - p = SCHEME_CAR(argv[0]); - else - p = scheme_false; - } else - p = scheme_false; - } - - if (!SCHEME_SYMBOLP(p) - && (!SCHEME_PATHP(p) - || !scheme_is_complete_path(SCHEME_PATH_VAL(p), - SCHEME_PATH_LEN(p), - SCHEME_PLATFORM_PATH_KIND))) - scheme_wrong_contract("make-resolved-module-path", - "(or/c symbol?" - " (and/c path? complete-path?)" - " (cons/c (or/c symbol? (and/c path? complete-path?)) (non-empty-listof symbol?))" - ")", - 0, argc, argv); - - return scheme_intern_resolved_module_path(argv[0]); -} - -static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_MODNAMEP(argv[0])) - scheme_wrong_contract("resolved-module-path-name", "resolved-module-path?", 0, argc, argv); - - return scheme_resolved_module_path_value(argv[0]); -} - - -static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - Scheme_Object *modname, *name; - Scheme_Module *m; - int i, count; - - if (!SCHEME_MODNAMEP(argv[0]) - && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-provide-protected?", "(or/c resolved-module-path? module-path-index?)", 0, argc, argv); - if (!SCHEME_SYMBOLP(argv[1])) - scheme_wrong_contract("module-provide-protected?", "symbol?", 1, argc, argv); - - modname = scheme_module_resolve(argv[0], 1); - name = argv[1]; - - env = scheme_get_env(NULL); - m = get_special_module(modname); - if (!m) - m = registry_get_loaded(env, modname); - if (!m) { - scheme_contract_error("module-provide-protected?", - "unknown module (in the source namespace)", - "name", 1, modname, - NULL); - return NULL; - } - - count = m->me->rt->num_provides; - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, m->me->rt->provides[i])) { - if (m->exp_infos[0]->provide_protects && m->exp_infos[0]->provide_protects[i]) - return scheme_true; - else - return scheme_false; - } - } - - return scheme_true; -} - -/**********************************************************************/ -/* basic module operations */ -/**********************************************************************/ - -Scheme_Object *scheme_make_modidx(Scheme_Object *path, - Scheme_Object *base_modidx, - Scheme_Object *resolved) -{ - Scheme_Modidx *modidx; - Scheme_Object *subpath; - - if (SCHEME_MODNAMEP(path)) - return path; - - if (SCHEME_PAIRP(path) - && SAME_OBJ(SCHEME_CAR(path), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(path)) - && SAME_OBJ(SCHEME_CADR(path), kernel_symbol) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(path))) - && kernel_modidx) - return kernel_modidx; - - modidx = MALLOC_ONE_TAGGED(Scheme_Modidx); - modidx->so.type = scheme_module_index_type; - modidx->path = path; - - /* base is needed only for relative-path strings, - `file' forms, path literals, and `(submod ...)' forms: */ - if (SCHEME_PAIRP(path) - && SAME_OBJ(submod_symbol, SCHEME_CAR(path))) - subpath = SCHEME_CAR(SCHEME_CDR(path)); - else - subpath = path; - if (SCHEME_CHAR_STRINGP(subpath) - || (SCHEME_PAIRP(subpath) - && SAME_OBJ(file_symbol, SCHEME_CAR(subpath))) - || SCHEME_PATHP(subpath)) - modidx->base = base_modidx; - else - modidx->base = scheme_false; - - modidx->resolved = resolved; - - return (Scheme_Object *)modidx; -} - -static int same_modidx(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = ((Scheme_Modidx *)a)->path; - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = ((Scheme_Modidx *)b)->path; - - return scheme_equal(a, b); -} - -static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = scheme_module_resolve(a, 1); - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = scheme_module_resolve(b, 1); - - return scheme_equal(a, b); -} - -Scheme_Object *scheme_resolved_module_path_to_modidx(Scheme_Object *rmp) -{ - Scheme_Object *path; - - path = SCHEME_PTR_VAL(rmp); - if (!SCHEME_PATHP(path)) { - if (SCHEME_SYMBOLP(path)) - path = scheme_make_pair(quote_symbol, scheme_make_pair(path, scheme_null)); - else { - if (SCHEME_SYMBOLP(SCHEME_CAR(path))) - path = scheme_make_pair(scheme_make_pair(quote_symbol, scheme_make_pair(SCHEME_CAR(path), scheme_null)), - scheme_null); - path = scheme_make_pair(submod_symbol, path); - } - } - - return scheme_make_modidx(path, scheme_false, rmp); -} - -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache) -{ - Scheme_Bucket *b; - Scheme_Object *modidx; - - if (SCHEME_NULLP(submodule_path)) { - if (can_cache) - return empty_self_modidx; - return scheme_make_modidx(scheme_false, scheme_false, empty_self_modname); - } - - if (!submodule_empty_modidx_table) { - REGISTER_SO(submodule_empty_modidx_table); - submodule_empty_modidx_table = scheme_make_weak_equal_table(); - } - - if (can_cache) { - scheme_start_atomic(); - b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); - if (b->val) - modidx = scheme_ephemeron_value(b->val); - else - modidx = NULL; - } else { - b = NULL; - modidx = NULL; - } - - if (!modidx) { - modidx = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), - submodule_path)); - modidx = scheme_make_modidx(scheme_false, scheme_false, modidx); - if (b) { - modidx = scheme_make_ephemeron(submodule_path, modidx); - b->val = modidx; - modidx = scheme_ephemeron_value(modidx); - } - } - - if (can_cache) - scheme_end_atomic_no_swap(); - - return modidx; -} - -static Scheme_Object *_module_resolve_k(void); - -static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, Scheme_Env *env, int load_it) -{ - if (SCHEME_MODNAMEP(modidx) || SCHEME_FALSEP(modidx)) - return modidx; - - if (SAME_OBJ(modidx, empty_self_modidx)) - return empty_self_modname; - - if (SCHEME_FALSEP(((Scheme_Modidx *)modidx)->resolved)) { - /* Need to resolve access path to a module name: */ - Scheme_Object *a[4]; - Scheme_Object *name, *base; - - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)base; - p->ku.k.p2 = (void *)env; - p->ku.k.i1 = load_it; - base = scheme_handle_stack_overflow(_module_resolve_k); - } else { - base = _module_resolve(base, NULL, env, load_it); - } - } - - if (SCHEME_SYMBOLP(base)) - base = scheme_false; - - if (stx && !SCHEME_FALSEP(stx) && !SCHEME_STXP(stx)) - stx = NULL; - - a[0] = ((Scheme_Modidx *)modidx)->path; - a[1] = base; - a[2] = (stx ? stx : scheme_false); - a[3] = (load_it ? scheme_true : scheme_false); - - if (SCHEME_FALSEP(a[0])) { - scheme_contract_error("module-path-index-resolve", - "\"self\" index has no resolution", - "module path index", 1, modidx, - NULL); - } - - - { - Scheme_Cont_Frame_Data cframe; - - if (env) { - Scheme_Config *config; - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a); - - if (env) { - scheme_pop_continuation_frame(&cframe); - } - } - - if (!SCHEME_MODNAMEP(name)) { - a[0] = name; - scheme_wrong_contract("module name resolver", "resolved-module-path?", -1, -1, a); - } - - ((Scheme_Modidx *)modidx)->resolved = name; - } - - return ((Scheme_Modidx *)modidx)->resolved; -} - -static Scheme_Object *_module_resolve_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *base = (Scheme_Object *)p->ku.k.p1; - Scheme_Env *env = (Scheme_Env *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return _module_resolve(base, NULL, env, p->ku.k.i1); -} - -Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it) -{ - return _module_resolve(modidx, NULL, NULL, load_it); -} - -Scheme_Object *module_resolve_in_namespace(Scheme_Object *modidx, Scheme_Env *env, int load_it) -{ - return _module_resolve(modidx, NULL, env, load_it); -} - -static Scheme_Object *clone_modidx(Scheme_Object *modidx, Scheme_Object *src_modidx) -{ - Scheme_Object *base; - - if (SAME_OBJ(modidx, src_modidx)) - return modidx; - - if (!SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) - return modidx; - - /* Need to shift relative part? */ - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { - /* FIXME: depth */ - base = clone_modidx(base, src_modidx); - } - - return scheme_make_modidx(((Scheme_Modidx *)modidx)->path, - base, - scheme_false); -} - - -Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, - Scheme_Object *shift_from_modidx, - Scheme_Object *shift_to_modidx) -{ - Scheme_Object *base; - - if (!shift_to_modidx) - return modidx; - - if (SAME_OBJ(modidx, shift_from_modidx)) - return shift_to_modidx; - - if (!SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) - return modidx; - - /* Need to shift relative part? */ - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { - /* FIXME: depth */ - Scheme_Object *sbase; - sbase = scheme_modidx_shift(base, shift_from_modidx, shift_to_modidx); - - if (!SAME_OBJ(base, sbase)) { - /* There was a shift in the relative part. */ - Scheme_Modidx *sbm; - int i, c; - Scheme_Object *smodidx, *cvec; - - /* Shift cached? sbase as a modname is rare, but we need at least a little - caching to make other things (e.g., .zo output) compact, so we use - a small global cache in that case. */ - - if (SCHEME_MODNAMEP(sbase)) { - sbm = NULL; - cvec = global_shift_cache; - } else if (SAME_OBJ(sbase, empty_self_modidx)) { - sbm = (Scheme_Modidx *)sbase; - cvec = empty_self_shift_cache; - } else { - sbm = (Scheme_Modidx *)sbase; - cvec = sbm->shift_cache; - } - - /* attempt lookup in cache */ - /* ASSERT(SCHEME_VECTORP(cvec)); */ - c = (cvec ? SCHEME_VEC_SIZE(cvec) : 0); - for (i = 0; i < c; i += 2) { - if (SHIFT_CACHE_NULLP(SCHEME_VEC_ELS(cvec)[i])) - break; - if (SAME_OBJ(modidx, SCHEME_VEC_ELS(cvec)[i])) - return SCHEME_VEC_ELS(cvec)[i + 1]; - } - - /* lookup failed, add entry to cache */ - smodidx = scheme_make_modidx(((Scheme_Modidx *)modidx)->path, - sbase, - scheme_false); - - /* make room in cache */ - if (!sbm) { - if (!global_shift_cache) - global_shift_cache = scheme_make_vector(GLOBAL_SHIFT_CACHE_SIZE, SHIFT_CACHE_NULL); - else { - for (i = (GLOBAL_SHIFT_CACHE_SIZE - 2); i--; ) { - SCHEME_VEC_ELS(global_shift_cache)[i+2] = SCHEME_VEC_ELS(global_shift_cache)[i]; - } - } - cvec = global_shift_cache; - i = 0; - } else { - /* May have GCed: */ - if (cvec && !sbm->shift_cache - && !SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx)) - sbm->shift_cache = cvec; - - if (i >= c) { - /* Grow cache vector */ - Scheme_Object *naya; - int j; - - naya = scheme_make_vector(c + 10, SHIFT_CACHE_NULL); - for (j = 0; j < c; j++) { - SCHEME_VEC_ELS(naya)[j] = SCHEME_VEC_ELS(cvec)[j]; - } - if (!SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx) && !sbm->shift_cache) { - sbm->cache_next = modidx_caching_chain; - modidx_caching_chain = sbm; - } - cvec = naya; - if (!SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx)) { - sbm->shift_cache = cvec; - } else { - empty_self_shift_cache = cvec; - } - } - } - - /* set entry in cache */ - SCHEME_VEC_ELS(cvec)[i] = modidx; - SCHEME_VEC_ELS(cvec)[i+1] = smodidx; - - return smodidx; - } - } - - return modidx; -} - -void scheme_clear_modidx_cache(void) -{ - Scheme_Modidx *sbm, *next; - - global_shift_cache = NULL; - empty_self_shift_cache = NULL; - - for (sbm = modidx_caching_chain; sbm; sbm = next) { - sbm->shift_cache = NULL; - next = sbm->cache_next; - sbm->cache_next = NULL; - } - modidx_caching_chain = NULL; -} - -static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const char *who) -{ - Scheme_Module *m; - - m = get_special_module(name); - if (!m) { - m = registry_get_loaded(env, name); - - if (!m) { - scheme_contract_error((who ? who : "require"), - "unknown module", - "module name", 1, name, - NULL); - return NULL; - } - } - - return m; -} - -static int is_procedure_expression(Scheme_Object *e) -{ - Scheme_Type t; - - if (SCHEME_PROCP(e)) - return 1; - - t = SCHEME_TYPE(e); - - return ((t == scheme_lambda_type) - || (t == scheme_case_lambda_sequence_type)); -} - -static void get_procedure_shape(Scheme_Object *e, Scheme_Object **_c) -{ - Scheme_Object *p, *v; - - p = scheme_get_or_check_procedure_shape(e, NULL); - - v = scheme_alloc_small_object(); - v->type = scheme_proc_shape_type; - SCHEME_PTR_VAL(v) = p; - - *_c = v; -} - -static void setup_accessible_table(Scheme_Module *m) -{ - if (!m->exp_infos[0]->accessible) { - Scheme_Module_Phase_Exports *pt; - int j; - - for (j = 0; j < m->num_phases; j++) { - if (!j) - pt = m->me->rt; - else if (j == 1) - pt = m->me->et; - else { - if (m->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, - scheme_make_integer(j)); - else - pt = NULL; - } - - if (pt) { - Scheme_Hash_Table *ht; - int i, count, nvp; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - nvp = pt->num_var_provides; - for (i = 0; i < nvp; i++) { - if (SCHEME_FALSEP(pt->provide_srcs[i])) { - scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i)); - } - } - - count = m->exp_infos[j]->num_indirect_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->exp_infos[j]->indirect_provides[i], scheme_make_integer(i + nvp)); - } - - /* Add syntax as negative ids: */ - count = pt->num_provides; - for (i = nvp; i < count; i++) { - if (SCHEME_FALSEP(pt->provide_srcs[i])) - scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1))); - } - - if (!j) { - /* find constants: */ - int i, cnt = SCHEME_VEC_SIZE(m->bodies[0]), k; - Scheme_Object *form, *tl; - - for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(m->bodies[0])[i]; - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - int checked_st = 0, is_st_prop = 0, has_guard = 0; - Scheme_Object *is_st = NULL; - Simple_Struct_Type_Info stinfo; - Scheme_Object *parent_identity; - for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { - tl = SCHEME_VEC_ELS(form)[k]; - if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { - int pos = SCHEME_TOPLEVEL_POS(tl); - if (pos < m->prefix->num_toplevels) { - tl = m->prefix->toplevels[pos]; - if (SCHEME_SYMBOLP(tl)) { - Scheme_Object *v; - v = scheme_hash_get(ht, tl); - if (!v) { - /* The defined name is inaccessible. The bytecode compiler - won't generate such modules, but synthesized module bytecode - might leave bindings out of the `toplevels' table. */ - } else { - if (SCHEME_VEC_SIZE(form) == 2) { - if (scheme_ir_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { - /* record simple constant from cross-module propagation: */ - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { - /* record a potentially inlineable function */ - if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) - SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { - /* that it's a procedure: */ - v = scheme_make_vector(2, v); - SCHEME_VEC_ELS(v)[1] = SCHEME_VEC_ELS(form)[0]; - } else { - /* record that it's fixed for any given instantiation: */ - v = scheme_make_pair(v, scheme_fixed_key); - } - } else { - if (!checked_st) { - if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - CHECK_STRUCT_TYPE_RESOLVED, - NULL, &stinfo, &parent_identity, - NULL, NULL, NULL, NULL, 0, - m->prefix->toplevels, ht, - &is_st, - 5)) { - is_st = scheme_make_pair(is_st, parent_identity); - } else { - is_st = NULL; - if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - CHECK_STRUCT_TYPE_RESOLVED, - &has_guard, - NULL, NULL, NULL, NULL, 0, - m->prefix->toplevels, ht, - 5)) - is_st_prop = 1; - } - checked_st = 1; - } - if (is_st) { - intptr_t shape; - shape = scheme_get_struct_proc_shape(k-1, &stinfo); - /* Vector of size 3 => struct shape */ - v = scheme_make_vector(3, v); - SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); - SCHEME_VEC_ELS(v)[2] = is_st; - } else if (is_st_prop) { - intptr_t shape; - shape = scheme_get_struct_property_proc_shape(k-1, has_guard); - /* Vector of size 4 => struct property shape */ - v = scheme_make_vector(4, v); - SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); - SCHEME_VEC_ELS(v)[2] = scheme_false; - SCHEME_VEC_ELS(v)[3] = scheme_false; - } - } - scheme_hash_set(ht, tl, v); - } - } else - scheme_signal_error("internal error: strange defn target %d", SCHEME_TYPE(tl)); - } - } - } - } - } - } - - m->exp_infos[j]->accessible = ht; - } - } - } -} - -Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t rev_mod_phase) -{ - Scheme_Env *menv; - - menv = get_special_modenv(name); - - if (!menv) { - Scheme_Object *chain; - int ph; - - chain = env->modchain; - ph = rev_mod_phase; - while (ph && chain) { - chain = (SCHEME_VEC_ELS(chain))[2]; - if (SCHEME_FALSEP(chain)) - return NULL; - ph--; - } - - if (!chain) { - scheme_signal_error("internal error: missing chain for module instances"); - return NULL; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(chain), name); - - while ((ph < rev_mod_phase) && menv) { - menv = menv->exp_env; - ph++; - } - } - - return menv; -} - -static void check_certified(Scheme_Object *guard_insp, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object *stx, /* for error reporting */ - Scheme_Module *module, /* for error reporting */ - Scheme_Object *symbol, /* for error reporting */ - int var, /* for error reporting */ - int prot, /* for error reporting */ - int *_would_complain) -{ - int need_cert = 1; - - if (need_cert && current_insp) - need_cert = scheme_module_protected_wrt(guard_insp, current_insp); - if (need_cert && binding_insp) - need_cert = scheme_module_protected_wrt(guard_insp, binding_insp); - - if (need_cert) { - if (_would_complain) { - *_would_complain = 1; - } else { - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; - } - scheme_wrong_syntax(scheme_compile_stx_string, stx, symbol, - "access disallowed by code inspector to %s %s from module: %D", - prot ? "protected" : "unexported", - var ? "variable" : "syntax", - scheme_get_modsrc(module)); - } - } -} - -static Scheme_Object *to_defined_symbol_at_phase(Scheme_Object *symbol, Scheme_Env *env, Scheme_Object *phase) -{ - Scheme_Object *binding; - - binding = scheme_stx_lookup(symbol, phase); - if (SCHEME_VECTORP(binding) - && SAME_OBJ(env->module->self_modidx, SCHEME_VEC_ELS(binding)[0]) - && SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) - return SCHEME_VEC_ELS(binding)[1]; - - return SCHEME_STX_VAL(symbol); -} - -static Scheme_Object *to_defined_symbol(Scheme_Object *symbol, Scheme_Env *env) -{ - return to_defined_symbol_at_phase(symbol, env, scheme_make_integer(env->phase)); -} - -static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t mod_phase, Scheme_Object *guard_insp, - Scheme_Object *symbol, - Scheme_Object *stx, /* for error reporting, only */ - Scheme_Object *current_insp, - Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, /* for error reporting, only */ - int *_would_complain, - Scheme_Object **_is_constant) -/* Returns the actual name when !want_pos, needed in case of - uninterned names. Otherwise, returns a position value on success. - If position < -1, then merely checks for protected syntax. - - Access for protected and unexported names depends on - `current_insp` (dynamic context) and `binding_insp` (static context). */ -{ - Scheme_Module_Phase_Exports *pt; - - if (SAME_OBJ(scheme_get_kernel_env()->module, module) - || ((module->primitive && !module->exp_infos[0]->provide_protects))) { - if (want_pos) - return scheme_make_integer(-1); - else - return symbol; - } - - switch (mod_phase) { - case 0: - pt = module->me->rt; - break; - case 1: - pt = module->me->et; - break; - default: - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(module->me->other_phases, - scheme_make_integer(mod_phase)); - break; - } - - if (pt) { - if (position >= 0) { - /* Check whether the symbol at `pos' matches the string part of - the expected symbol. */ - Scheme_Object *isym; - int need_cert = 0; - - if (position < pt->num_var_provides) { - if (!pt->provide_srcs - || SCHEME_FALSEP(pt->provide_srcs[position])) - isym = pt->provide_src_names[position]; - else - isym = NULL; - } else { - int ipos = position - pt->num_var_provides; - int num_indirect_provides; - Scheme_Object **indirect_provides; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) { - num_indirect_provides = module->exp_infos[mod_phase]->num_indirect_provides; - indirect_provides = module->exp_infos[mod_phase]->indirect_provides; - } else { - num_indirect_provides = 0; - indirect_provides = NULL; - } - - if (ipos < num_indirect_provides) { - isym = indirect_provides[ipos]; - need_cert = 1; - if (_protected) - *_protected = 1; - } else - isym = NULL; - } - - if (isym) { - if (SAME_OBJ(isym, symbol) - || (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol) - && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) { - - if ((position < pt->num_var_provides) - && scheme_module_protected_wrt(guard_insp, current_insp)) { - char *provide_protects; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) - provide_protects = module->exp_infos[mod_phase]->provide_protects; - else - provide_protects = NULL; - - if (provide_protects - && provide_protects[position]) { - if (_protected) - *_protected = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); - } - } - - if (need_cert) - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); - - if (want_pos) - return scheme_make_integer(position); - else - return isym; - } - } - /* failure */ - } else { - Scheme_Object *pos; - - if (mod_phase < module->num_phases) - pos = scheme_hash_get(module->exp_infos[mod_phase]->accessible, symbol); - else - pos = NULL; - - if (pos) { - if (SCHEME_PAIRP(pos)) { - if (_is_constant) *_is_constant = SCHEME_CDR(pos); - pos = SCHEME_CAR(pos); - } else if (SCHEME_VECTORP(pos)) { - if (SCHEME_VEC_SIZE(pos) == 2) { - if (_is_constant) - get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant); - } else if (SCHEME_VEC_SIZE(pos) == 3) { - /* vector of size 3 => struct proc */ - if (_is_constant) { - Scheme_Object *ps; - - ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]), - SCHEME_VEC_ELS(pos)[2]); - - *_is_constant = ps; - } - } else { - MZ_ASSERT(SCHEME_VEC_SIZE(pos) == 4); - /* vector of size 4 => struct property proc */ - if (_is_constant) { - Scheme_Object *ps; - - ps = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1])); - - *_is_constant = ps; - } - } - pos = SCHEME_VEC_ELS(pos)[0]; - } - } - - if (pos) { - if (position < -1) { - if (SCHEME_INT_VAL(pos) < 0) - pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1); - else - pos = NULL; - } else { - if (SCHEME_INT_VAL(pos) < 0) - pos = NULL; - } - } - - if (pos) { - char *provide_protects; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) - provide_protects = module->exp_infos[mod_phase]->provide_protects; - else - provide_protects = NULL; - - if (provide_protects - && (SCHEME_INT_VAL(pos) < pt->num_provides) - && provide_protects[SCHEME_INT_VAL(pos)]) { - if (_protected) - *_protected = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); - } - - if ((position >= -1) - && (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) { - /* unexported var -- need cert */ - if (_protected) - *_protected = 1; - if (_unexported) - *_unexported = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); - } - - if (want_pos) - return pos; - else - return symbol; - } - - if (position < -1) { - /* unexported syntax -- need cert */ - if (_unexported) - *_unexported = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 0, 0, _would_complain); - return NULL; - } - } - } - - if (_would_complain) { - *_would_complain = 1; - return NULL; - } - - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; - } - - { - const char *srcstr; - intptr_t srclen; - - if (from_env->module) - srcstr = scheme_display_to_string(scheme_get_modsrc(from_env->module), &srclen); - else { - srcstr = ""; - srclen = 0; - } - - scheme_wrong_syntax("link", stx, symbol, - "module mismatch;\n" - " possibly, bytecode file needs re-compile because dependencies changed\n" - "%s%t%s" - " exporting module: %D\n" - " exporting phase level: %d\n" - " internal explanation: variable not provided (directly or indirectly%s)", - srclen ? " importing module: " : "", - srcstr, srclen, - srclen ? "\n" : "", - scheme_get_modsrc(module), - mod_phase, - (position >= 0) ? " and at the expected position" : ""); - } - - return NULL; -} - -Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, - Scheme_Object *symbol, - Scheme_Object *stx, /* for error reporting, only */ - Scheme_Object *current_insp, - Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, /* for error reporting, only */ - int *_would_complain, - Scheme_Object **_is_constant) -{ - if (!SCHEME_SYMBOLP(symbol)) - symbol = to_defined_symbol(symbol, env); - - return check_accessible_in_module(env->module, env->mod_phase, env->guard_insp, - symbol, stx, - current_insp, binding_insp, - position, want_pos, - _protected, _unexported, - from_env, - _would_complain, - _is_constant); -} - -Scheme_Object *scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, - Scheme_Object *symbol, int position, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object **_is_constant) -{ - Scheme_Module *module; - Scheme_Object *modname, *pos; - int would_complain = 0; - - modname = scheme_module_resolve(modidx, 0); - - module = registry_get_loaded(env, modname); - if (!module) - return 0; - - pos = check_accessible_in_module(module, mod_phase, scheme_make_inspector(module->insp), - symbol, NULL, - current_insp, binding_insp, - position, 1, - NULL, NULL, - NULL, - &would_complain, - _is_constant); - - return (would_complain - ? NULL - : (pos ? pos : scheme_make_integer(position))); -} - - -void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env) -{ - Scheme_Env *unsafe_env; - - unsafe_env = scheme_get_unsafe_env(); - - if (insp && SCHEME_HASHTRP(insp)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)insp; - int i; - Scheme_Object *k, *v; - - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &v); - insp = k; - if (scheme_module_protected_wrt(unsafe_env->guard_insp, insp)) { - break; - } - } - - if (i < 0) - return; - } - - if (!insp || scheme_module_protected_wrt(unsafe_env->guard_insp, insp)) { - scheme_wrong_syntax("link", - NULL, NULL, - "attempt to access unsafe bindings from an untrusted context"); - } -} - -int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname) -{ - Scheme_Module *m; - Scheme_Object *pos; - - if (SAME_OBJ(modname, kernel_modname) - || SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)) - return -1; - - m = module_load(modname, env, NULL); - if (!m || m->primitive) - return -1; - - setup_accessible_table(m); - - pos = scheme_hash_get(m->exp_infos[0]->accessible, varname); - - if (SCHEME_PAIRP(pos)) - pos = SCHEME_CAR(pos); - else if (SCHEME_VECTORP(pos)) - pos = SCHEME_VEC_ELS(pos)[0]; - - if (pos && (SCHEME_INT_VAL(pos) >= 0)) - return SCHEME_INT_VAL(pos); - else - return -1; -} - -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, - Scheme_Object *name, int mod_phase) -{ - if (SAME_OBJ(modname, kernel_modname)) { - Scheme_Env *kenv; - kenv = scheme_get_kernel_env(); - if (SCHEME_STXP(name)) - name = SCHEME_STX_SYM(name); - return scheme_lookup_in_table(kenv->syntax, (char *)name); - } else if (SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)) { - /* no unsafe, flfxnum, extfl, or futures syntax */ - return NULL; - } else { - Scheme_Env *menv; - Scheme_Object *val; - int i; - - for (i = 0; i < mod_phase; i++) { - scheme_prepare_template_env(env); - env = env->template_env; - if (!env) return NULL; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), modname); - - if (!menv) - return NULL; - - if (menv->module - && menv->running - && ((mod_phase+1) < menv->module->num_phases) - && !menv->running[mod_phase+1]) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, name, - "module mismatch;\n" - " attempted to use a module that is not available\n" - " possible cause:\n" - " using (dynamic-require .... #f)\n" - " but need (dynamic-require .... 0)\n" - " module: %D\n" - " phase: %d", - scheme_get_modsrc(menv->module), - mod_phase); - return NULL; - } - - for (i = 0; i < mod_phase; i++) { - scheme_prepare_exp_env(menv); - menv = menv->exp_env; - if (!menv) return NULL; - } - - if (SCHEME_STXP(name)) - name = to_defined_symbol(name, menv); - - val = scheme_lookup_in_table(menv->syntax, (char *)name); - - return val; - } -} - -static int wait_registry(Scheme_Env *env) -{ - Scheme_Object *lock, *a[2]; - - while (1) { - lock = scheme_hash_get(env->module_registry->loaded, scheme_false); - if (!lock) - return 1; - - if (SAME_OBJ(SCHEME_CDR(lock), (Scheme_Object *)scheme_current_thread)) - return 0; - - a[0] = SCHEME_CAR(lock); - a[1] = SCHEME_CDR(lock); - (void)scheme_sync(2, a); - } -} - -static void lock_registry(Scheme_Env *env) -{ - Scheme_Object *lock; - lock = scheme_make_pair(scheme_make_sema(0), - (Scheme_Object *) scheme_current_thread); - scheme_hash_set(env->module_registry->loaded, scheme_false, lock); -} - -static void unlock_registry(Scheme_Env *env) -{ - Scheme_Object *lock; - if (env) { - lock = scheme_hash_get(env->module_registry->loaded, scheme_false); - scheme_post_sema(SCHEME_CAR(lock)); - scheme_hash_set(env->module_registry->loaded, scheme_false, NULL); - } -} - -XFORM_NONGCING static intptr_t make_key(int base_phase, int eval_exp, int eval_run) -{ - return (((unsigned)base_phase << 3) - | (eval_exp ? ((eval_exp > 0) ? 2 : 4) : 0) - | (eval_run ? 1 : 0)); -} - -static int did_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run) -{ - intptr_t key; - - key = make_key(base_phase, eval_exp, eval_run); - - if (!v) - return 0; - - if (scheme_hash_tree_get((Scheme_Hash_Tree *)v, scheme_make_integer(key))) - return 1; - - return 0; -} - -static Scheme_Object *add_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run) -{ - intptr_t key; - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; - Scheme_Bucket *b; - - if (!ht) - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - key = make_key(base_phase, eval_exp, eval_run); - - ht = scheme_hash_tree_set(ht, scheme_make_integer(key), scheme_true); - - b = scheme_bucket_from_table(starts_table, (const char *)ht); - if (!b->val) - b->val = scheme_true; - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); -} - -#if 0 -static int indent = 0; -# define show_indent(d) (indent += d) -static void show(const char *what, Scheme_Env *menv, int v1, int v2, int ph, int base_phase) -{ - if (menv->phase > 3) return; - if (1 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) - if (1 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { - int i; - for (i = 0; i < indent; i++) { - fprintf(stderr, " "); - } - fprintf(stderr, "%s \t%s @%ld+%d/%d [%d/%d] %p\n", - what, scheme_write_to_string(menv->module->modname, NULL), - menv->phase, ph, base_phase, v1, v2, menv->modchain); - } -} -static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int i, int base_phase){ - show(what, menv, v1, v2, i, base_phase); -} -#else -# define show_indent(d) /* nothing */ -# define show(w, m, v1, v2, i, bp) /* nothing */ -# define show_done(w, m, v1, v2, i, bp) /* nothing */ -#endif - -static void clone_require_names(Scheme_Module *m, Scheme_Object *phase) -{ - Scheme_Object *np, *np_first, *np_last, *l, *reqs; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - reqs = m->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - reqs = m->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - reqs = m->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - reqs = m->dt_requires; - } else { - if (m->other_requires) { - reqs = scheme_hash_get(m->other_requires, phase); - if (!reqs) - reqs = scheme_null; - } else - reqs = scheme_null; - } - - if (SCHEME_NULLP(reqs)) return; - - np_first = scheme_null; - np_last = NULL; - - for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - np = cons(clone_modidx(SCHEME_CAR(l), m->me->src_modidx), scheme_null); - if (np_last) - SCHEME_CDR(np_last) = np; - else - np_first = np; - np_last = np; - } - - np = np_first; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - m->requires = np; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - m->et_requires = np; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - m->tt_requires = np; - } else if (SAME_OBJ(phase, scheme_false)) { - m->dt_requires = np; - } else { - scheme_hash_set(m->other_requires, phase, np); - } -} - -static void clone_all_require_names(Scheme_Module *m) -{ - clone_require_names(m, scheme_make_integer(0)); - clone_require_names(m, scheme_make_integer(1)); - clone_require_names(m, scheme_make_integer(-1)); - clone_require_names(m, scheme_false); - - if (m->other_requires) { - Scheme_Hash_Table *ht; - intptr_t i; - ht = scheme_clone_hash_table(m->other_requires); - m->other_requires = ht; - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - clone_require_names(m, ht->keys[i]); - } - } - } -} - -static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, - Scheme_Env *load_env, Scheme_Object *syntax_idx) -{ - Scheme_Object *np, *np_first, *np_last, *midx, *l, *reqs, *req_names; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - req_names = menv->require_names; - reqs = menv->module->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - req_names = menv->et_require_names; - reqs = menv->module->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - req_names = menv->tt_require_names; - reqs = menv->module->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - req_names = menv->dt_require_names; - reqs = menv->module->dt_requires; - } else { - if (menv->module->other_requires) { - reqs = scheme_hash_get(menv->module->other_requires, phase); - if (!reqs) - reqs = scheme_null; - } else - reqs = scheme_null; - if (!SCHEME_NULLP(reqs) && !menv->other_require_names) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_eqv(); - menv->other_require_names = ht; - } - if (menv->other_require_names) - req_names = scheme_hash_get(menv->other_require_names, phase); - else - req_names = NULL; - } - - if (req_names && !SCHEME_NULLP(req_names)) - return; - - np_first = scheme_null; - np_last = NULL; - - for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = scheme_modidx_shift(SCHEME_CAR(l), - menv->module->me->src_modidx, - (syntax_idx ? syntax_idx : menv->link_midx)); - - if (load_env) - module_load(scheme_module_resolve(midx, 1), load_env, NULL); - - np = cons(midx, scheme_null); - if (np_last) - SCHEME_CDR(np_last) = np; - else - np_first = np; - np_last = np; - } - - np = np_first; - - if (!SAME_OBJ(np, req_names)) { - if (SAME_OBJ(phase, scheme_make_integer(0))) { - menv->require_names = np; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - menv->et_require_names = np; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - menv->tt_require_names = np; - } else if (SAME_OBJ(phase, scheme_false)) { - menv->dt_require_names = np; - } else { - if (menv->other_require_names) - scheme_hash_set(menv->other_require_names, phase, np); - } - } -} - -static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx); - -static Scheme_Object *chain_start_module_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Env *menv = (Scheme_Env *)p->ku.k.p1; - Scheme_Env *env = (Scheme_Env *)p->ku.k.p2; - Scheme_Object *cycle_list = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *syntax_idx = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - chain_start_module(menv, env, - p->ku.k.i1, p->ku.k.i2, - p->ku.k.i3, cycle_list, syntax_idx); - - return scheme_true; -} - -static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx) -{ - Scheme_Object *new_cycle_list, *midx, *l; - Scheme_Module *im; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)menv; - p->ku.k.p2 = (void *)env; - p->ku.k.i1 = eval_exp; - p->ku.k.i2 = eval_run; - p->ku.k.i3 = base_phase; - p->ku.k.p3 = (void *)cycle_list; - p->ku.k.p4 = (void *)syntax_idx; - (void)scheme_handle_stack_overflow(chain_start_module_k); - return; - } - } -#endif - - new_cycle_list = scheme_make_pair(menv->module->modname, cycle_list); - - if (!SCHEME_NULLP(menv->module->dt_requires)) { - compute_require_names(menv, scheme_false, env, syntax_idx); - - scheme_prepare_label_env(menv); - - for (l = menv->dt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv->label_env, 0, - midx, - 0, 0, base_phase, - new_cycle_list, - 0); - } - } - - if (!SCHEME_NULLP(menv->module->tt_requires)) { - - compute_require_names(menv, scheme_make_integer(-1), env, syntax_idx); - - scheme_prepare_template_env(menv); - - for (l = menv->tt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv->template_env, 0, - midx, - eval_exp, eval_run, base_phase, - new_cycle_list, - 0); - } - } - - compute_require_names(menv, scheme_make_integer(0), env, syntax_idx); - - for (l = menv->require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - - scheme_prepare_exp_env(menv); - menv->exp_env->link_midx = menv->link_midx; - - if (!SCHEME_NULLP(menv->module->et_requires)) { - compute_require_names(menv, scheme_make_integer(1), env, syntax_idx); - - for (l = menv->et_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - } - - if (menv->module->other_requires) { - int i; - Scheme_Object *phase, *n; - Scheme_Env *menv2; - for (i = 0; i < menv->module->other_requires->size; i++) { - if (menv->module->other_requires->vals[i]) { - phase = menv->module->other_requires->keys[i]; - - if (scheme_is_negative(phase)) { - compute_require_names(menv, phase, env, syntax_idx); - - n = phase; - menv2 = menv; - while (scheme_is_negative(n)) { - scheme_prepare_template_env(menv2); - menv2 = menv2->template_env; - n = scheme_bin_plus(n, scheme_make_integer(1)); - } - - l = scheme_hash_get(menv->other_require_names, phase); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv2, 0, - midx, - eval_exp, eval_run, base_phase, - new_cycle_list, - 0); - } - } else { - compute_require_names(menv, phase, env, syntax_idx); - - n = phase; - menv2 = menv; - while (scheme_is_positive(n)) { - scheme_prepare_exp_env(menv2); - menv2->exp_env->link_midx = menv2->link_midx; - menv2 = menv2->exp_env; - n = scheme_bin_minus(n, scheme_make_integer(1)); - } - - l = scheme_hash_get(menv->other_require_names, phase); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - } - } - } - } -} - -typedef struct Start_Module_Args { - Scheme_Env *menv; - Scheme_Env *env; - int eval_exp; - int eval_run; - intptr_t base_phase; - Scheme_Object *cycle_list; - Scheme_Object *syntax_idx; -} Start_Module_Args; - -static void chain_start_module_w_push(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx) -{ - Start_Module_Args a; - - a.menv = menv; - a.env = env; - a.eval_exp = eval_exp; - a.eval_run = eval_run; - a.base_phase = base_phase; - a.cycle_list = cycle_list; - a.syntax_idx = syntax_idx; - -#ifdef MZ_USE_JIT - (void)scheme_module_start_start(&a, scheme_make_pair(menv->module->modname, scheme_false)); -#else - (void)scheme_module_start_finish(&a); -#endif -} - -void *scheme_module_start_finish(struct Start_Module_Args *a) -{ - chain_start_module(a->menv, a->env, - a->eval_exp, a->eval_run, a->base_phase, - a->cycle_list, a->syntax_idx); - return NULL; -} - -static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, - Scheme_Object *syntax_idx, int not_new) -{ - Scheme_Env *menv; - - if (!restart) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (menv) { - check_phase(menv, env, 0); - return menv; - } - } - - if (m->primitive) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (!menv) { - menv = m->primitive; - scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - } - menv->require_names = scheme_null; - menv->et_require_names = scheme_null; - menv->tt_require_names = scheme_null; - menv->dt_require_names = scheme_null; - return menv; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (!menv || restart) { - Scheme_Object *insp; - - if (!menv) { - char *running; - - if (not_new) - scheme_signal_error("internal error: shouldn't instantiate module %s now", - scheme_write_to_string(m->modname, NULL)); - - /* printf("new %ld %s\n", env->phase, scheme_write_to_string(m->modname, NULL)); */ - menv = scheme_new_module_env(env, m, 0, 0); - scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - - running = (char *)scheme_malloc_atomic(menv->module->num_phases); - menv->running = running; - memset(menv->running, 0, menv->module->num_phases); - - menv->phase = env->phase; - menv->link_midx = syntax_idx; - } else { - Scheme_Env *env2; - - if (menv->module->num_phases < m->num_phases) { - char *running; - running = (char *)scheme_malloc_atomic(m->num_phases); - menv->running = running; - } - - menv->module = m; - memset(menv->running, 0, menv->module->num_phases); - menv->ran = 0; - menv->did_starts = NULL; - - for (env2 = menv->exp_env; env2; env2 = env2->exp_env) { - env2->module = m; - } - for (env2 = menv->template_env; env2; env2 = env2->template_env) { - env2->module = m; - } - env2 = menv->label_env; - if (env2) - env2->module = m; - - menv->interactive_bindings = 1; - } - - menv->access_insp = m->insp; - insp = scheme_make_inspector(m->insp); - menv->guard_insp = insp; - - /* These three should be set by various "finish"es, but - we initialize them in case there's an error running a "finish". */ - menv->require_names = scheme_null; - menv->et_require_names = scheme_null; - menv->tt_require_names = scheme_null; - menv->dt_require_names = scheme_null; - - if (env->label_env != env) { - setup_accessible_table(m); - - /* Create provided global variables: */ - if ((menv->phase <= 0) - && ((menv->phase + m->num_phases) > 0)) { - Scheme_Module_Phase_Exports *pt; - Scheme_Object **exss, **exsns; - int i, count; - Scheme_Env *menv2 = menv; - int pl; - - pl = -menv->phase; - - for (i = 0; i < pl; i++) { - scheme_prepare_exp_env(menv2); - menv2 = menv2->exp_env; - } - - switch(pl) { - case 0: - pt = m->me->rt; - break; - case 1: - pt = m->me->et; - break; - default: - if (m->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, scheme_make_integer(pl)); - else - pt = NULL; - break; - } - - if (pt) { - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - count = pt->num_var_provides; - - for (i = 0; i < count; i++) { - if (SCHEME_FALSEP(exss[i])) - scheme_add_to_table(menv2->toplevel, (const char *)exsns[i], NULL, 0); - } - } - - if (m->exp_infos[pl]) { - count = m->exp_infos[pl]->num_indirect_provides; - exsns = m->exp_infos[pl]->indirect_provides; - for (i = 0; i < count; i++) { - scheme_add_to_table(menv2->toplevel, (const char *)exsns[i], NULL, 0); - } - } - } - } - } - - return menv; -} - -static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int phase, int restart) -{ - if (!restart) { - if (menv && menv->running[phase]) - return; - } - - if (menv->module->primitive) - return; - - menv->running[phase] = 1; - if (scheme_starting_up) - menv->attached = 1; /* protect initial modules from redefinition, etc. */ - - run_module_exptime(menv, phase); - - return; -} - -static void run_module_exptime(Scheme_Env *menv, int phase) -{ -#ifdef MZ_USE_JIT - (void)scheme_module_exprun_start(menv, phase, scheme_make_pair(menv->module->modname, scheme_void)); -#else - (void)scheme_module_exprun_finish(menv, phase); -#endif -} - -void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) -{ - int let_depth, for_stx; - Scheme_Object *names, *e; - Resolve_Prefix *rp; - Scheme_Comp_Env *rhs_env; - int i, cnt, len; - Scheme_Env *exp_env; - Scheme_Bucket_Table *syntax; - - if (menv->module->primitive) - return NULL; - - if ((menv->module->num_phases <= at_phase) || (!SCHEME_VEC_SIZE(menv->module->bodies[at_phase]))) - return NULL; - - for (i = 1; i < at_phase; i++) { - scheme_prepare_exp_env(menv); - if (!menv->exp_env->link_midx) - menv->exp_env->link_midx = menv->link_midx; - menv = menv->exp_env; - } - scheme_prepare_exp_env(menv); - exp_env = menv->exp_env; - if (!exp_env->link_midx) - exp_env->link_midx = menv->link_midx; - - if (!exp_env) - return NULL; - - syntax = menv->syntax; - - rhs_env = scheme_new_comp_env(menv, menv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - - cnt = SCHEME_VEC_SIZE(menv->module->bodies[at_phase]); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(menv->module->bodies[at_phase])[i]; - - names = SCHEME_VEC_ELS(e)[0]; - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]); - e = SCHEME_VEC_ELS(e)[1]; - - if (for_stx) { - names = NULL; - len = 0; - } else { - if (SCHEME_SYMBOLP(names)) - names = scheme_make_pair(names, scheme_null); - len = scheme_list_length(names); - } - - eval_exptime(names, len, e, exp_env, rhs_env, - rp, let_depth, 1, (for_stx ? NULL : syntax), at_phase, - scheme_false, menv->access_insp); - } - - return NULL; -} - -static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) -{ - if (m->primitive) { - menv->running[0] = 1; - menv->ran = 1; - return; - } - - if (menv->running[0] > 0) { - return; - } - - menv->running[0] = 1; - - if (menv->module->prim_body) { - Scheme_Invoke_Proc ivk = menv->module->prim_body; - menv->ran = 1; - ivk(menv, menv->phase, menv->link_midx, m->bodies[0]); - } else { - eval_module_body(menv, env); - } -} - -static void should_run_for_compile(Scheme_Env *menv, int phase) -{ - if (menv->running[phase]) return; - - if (!phase) { - scheme_prepare_template_env(menv); - menv = menv->template_env; - } else { - while (phase > 1) { - scheme_prepare_exp_env(menv); - menv = menv->exp_env; - phase--; - } - } - -#if 0 - if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname)) - scheme_signal_error("internal error: inconsistent instance_env"); -#endif - - if (!menv->available_next[0]) { - menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); - MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv; - } -} - -static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, - Scheme_Object *syntax_idx, int eval_exp, int eval_run, intptr_t base_phase, - Scheme_Object *cycle_list, int not_new) -/* Make an instance of module `m' in `env', which means that phase level 0 of module `m' - will be shifted to phase `env->phase'. - Let P=`base_phase'-`env->phase'. - - If `eval_run', then instantiate phase-level P of `m' (which is at `base_phase' in `env'). - - If `eval_exp' is -1, then (also) make its P+1 phase-level ready. - - If `eval_exp' is 1, then visit at phase P => run phase P+1. */ -{ - Scheme_Env *menv; - Scheme_Object *l; - int prep_namespace = 0, i; - - if (is_builtin_modname(m->modname)) - return; - - for (l = cycle_list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m->modname, SCHEME_CAR(l))) { - scheme_contract_error("module", - "import cycle detected", - "module in cycle", 1, scheme_get_modsrc(m), - NULL); - } - } - - menv = instantiate_module(m, env, restart, syntax_idx, not_new); - - check_phase(menv, env, 0); - - show("chck", menv, eval_exp, eval_run, 0, base_phase); - - if (did_start(menv->did_starts, base_phase, eval_exp, eval_run)) - return; - - show("strt", menv, eval_exp, eval_run, 0, base_phase); - show_indent(+1); - - { - Scheme_Object *v; - v = add_start(menv->did_starts, base_phase, eval_exp, eval_run); - menv->did_starts = v; - } - - chain_start_module_w_push(menv, env, eval_exp, eval_run, base_phase, cycle_list, syntax_idx); - - if (restart) { - if (menv->rename_set_ready) { - menv->rename_set_ready = 0; - prep_namespace = 1; - } - } - - if (eval_run || eval_exp) { - for (i = menv->module->num_phases; i-- ; ) { - if (env->phase + i == base_phase) { - if (eval_exp) { - if (i + 1 < menv->module->num_phases) { - if (eval_exp > 0) { - show("exp=", menv, eval_exp, eval_run, i, base_phase); - expstart_module(menv, env, i+1, restart); - } else { - should_run_for_compile(menv, i); - } - } - } - if (eval_run) { - show("run=", menv, eval_exp, eval_run, i, base_phase); - if (i == 0) - do_start_module(m, menv, env, restart); - else - expstart_module(menv, env, i, restart); - } - } else if (env->phase + i > base_phase) { - if (eval_exp) { - should_run_for_compile(menv, i); - if (eval_exp > 0) { - if (env->phase + i == base_phase + 1) { - show("run+", menv, eval_exp, eval_run, i, base_phase); - if (i == 0) - do_start_module(m, menv, env, restart); - else - expstart_module(menv, env, i, restart); - } - } - } - } else { - /* env->phase + i < base_phase */ - } - } - - } - - show_indent(-1); - show_done("done", menv, eval_exp, eval_run, 0, base_phase); - - if (prep_namespace) - scheme_prep_namespace_rename(menv); -} - -static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) -{ - Scheme_Object *v, *prev; - Scheme_Env *menv, *uenv; - int need_lock; - - need_lock = wait_registry(env); - - v = MODCHAIN_AVAIL(env->modchain, pos); - if (!SCHEME_FALSEP(v)) { - MODCHAIN_AVAIL(env->modchain, pos) = scheme_false; - - /* Reverse order of the list; if X requires Y, Y - has been pushed onto the front of the list - before X. */ - prev = scheme_false; - while (SCHEME_NAMESPACEP(v)) { - menv = (Scheme_Env *)v; - v = menv->available_next[pos]; - menv->available_next[pos] = prev; - prev = (Scheme_Object *)menv; - } - v = prev; - - if (need_lock) { - lock_registry(env); - uenv = env; - } else - uenv = NULL; - - while (SCHEME_NAMESPACEP(v)) { - menv = (Scheme_Env *)v; - v = menv->available_next[pos]; - menv->available_next[pos] = NULL; - BEGIN_ESCAPEABLE(unlock_registry, uenv); - start_module(menv->module, menv->instance_env, 0, - NULL, 1, 0, base_phase, - scheme_null, 1); - END_ESCAPEABLE(); - } - - if (need_lock) - unlock_registry(env); - } -} - -void scheme_prepare_compile_env(Scheme_Env *env) -/* We're going to compile expressions at env->phase, so make sure - that env->phase is visited. */ -{ - do_prepare_compile_env(env, env->phase, 0); -} - -static void *eval_module_body_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Env *menv, *env; - - menv = (Scheme_Env *)p->ku.k.p1; - env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - eval_module_body(menv, env); - - return NULL; -} - -#if 0 -# define LOG_RUN_DECLS intptr_t start_time -# define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds()) -# define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \ - scheme_write_to_string(mod->modname, NULL), \ - scheme_get_process_milliseconds() - start_time)) -#else -# define LOG_RUN_DECLS /* empty */ -# define LOG_START_RUN(mod) /* empty */ -# define LOG_END_RUN(mod) /* empty */ -#endif - -static void eval_module_body(Scheme_Env *menv, Scheme_Env *env) -{ - if (menv->module->phaseless) { - /* Phaseless modules are implemented by last-minute sharing of the - `toplevels' table. In principle, much more repeated work up to - this point could be skipped, but this is the simplest point to - implement the sharing. */ - if (SAME_OBJ(scheme_true, menv->module->phaseless)) { - menv->module->phaseless = (Scheme_Object *)menv->toplevel; - } else { - menv->toplevel = (Scheme_Bucket_Table *)menv->module->phaseless; - return; - } - } - -#ifdef MZ_USE_JIT - (void)scheme_module_run_start(menv, env, scheme_make_pair(scheme_get_modsrc(menv->module), scheme_true)); -#else - (void)scheme_module_run_finish(menv, env); -#endif -} - -static Scheme_Object *body_one_expr(void *prefix_plus_expr, int argc, Scheme_Object **argv) -{ - Scheme_Object *v, **saved_runstack; - - saved_runstack = scheme_resume_prefix(SCHEME_CAR((Scheme_Object *)prefix_plus_expr)); - v = _scheme_eval_linked_expr_multi(SCHEME_CDR((Scheme_Object *)prefix_plus_expr)); - scheme_suspend_prefix(saved_runstack); - - scheme_ignore_result(v); - - return scheme_void; -} - -static int needs_prompt(Scheme_Object *e) -{ - Scheme_Type t; - - while (1) { - t = SCHEME_TYPE(e); - if (t > _scheme_values_types_) - return 0; - - switch (t) { - case scheme_lambda_type: - case scheme_toplevel_type: - case scheme_local_type: - case scheme_local_unbox_type: - return 0; - case scheme_case_lambda_sequence_type: - return 0; - case scheme_define_values_type: - e = SCHEME_VEC_ELS(e)[0]; - break; - case scheme_inline_variant_type: - e = SCHEME_VEC_ELS(e)[0]; - break; - default: - return 1; - } - } -} - -void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) -{ - Scheme_Thread *p; - Scheme_Module *m = menv->module; - Scheme_Object *body, **save_runstack, *save_prefix; - int depth; - int i, cnt; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - int volatile save_phase_shift; - mz_jmp_buf newbuf, * volatile savebuf; - LOG_RUN_DECLS; - - menv->running[0] = 1; - menv->ran = 1; - - depth = m->max_let_depth + scheme_prefix_depth(m->prefix); - if (!scheme_check_runstack(depth)) { - p = scheme_current_thread; - p->ku.k.p1 = menv; - p->ku.k.p2 = env; - (void)scheme_enlarge_runstack(depth, eval_module_body_k); - return NULL; - } - - LOG_START_RUN(menv->module); - - save_runstack = scheme_push_prefix(menv, 0, m->prefix, - m->me->src_modidx, menv->link_midx, - 0, menv->phase, NULL, - menv->access_insp); - - p = scheme_current_thread; - save_phase_shift = p->current_phase_shift; - p->current_phase_shift = menv->phase; - savebuf = p->error_buf; - p->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - Scheme_Thread *p2; - p2 = scheme_current_thread; - p2->error_buf = savebuf; - p2->current_phase_shift = save_phase_shift; - scheme_longjmp(*savebuf, 1); - } else { - if (env && menv->phase) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - for (i = 0; i < cnt; i++) { - body = SCHEME_VEC_ELS(m->bodies[0])[i]; - if (needs_prompt(body)) { - /* We need to push the prefix after the prompt is set, so - restore the runstack and then add the prefix back. */ - save_prefix = scheme_suspend_prefix(save_runstack); - (void)_scheme_call_with_prompt_multi(body_one_expr, - scheme_make_raw_pair(save_prefix, body)); - scheme_resume_prefix(save_prefix); - - /* Double-check that the definition-installing part of the - continuation was not skipped. Otherwise, the compiler would - not be able to assume that a variable reference that is - lexically later (incuding a reference to an imported - variable) always references a defined variable. Putting the - prompt around a definition's RHS might be a better - approach, but that would change the language (so mabe next - time). */ - if (SAME_TYPE(SCHEME_TYPE(body), scheme_define_values_type)) { - int vcnt, j; - - vcnt = SCHEME_VEC_SIZE(body) - 1; - for (j = 0; j < vcnt; j++) { - Scheme_Object *var; - Scheme_Prefix *toplevels; - Scheme_Bucket *b; - - var = SCHEME_VEC_ELS(body)[j+1]; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - if (!b->val) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, - b->key, - "define-values: skipped variable definition;\n" - " cannot continue without defining variable\n" - " variable: %S\n" - " in module: %D", - (Scheme_Object *)b->key, - menv->module->modsrc); - } - } - } - } else - scheme_ignore_result(_scheme_eval_linked_expr_multi(body)); - } - - if (scheme_module_demand_hook) { - Scheme_Object *a[1], *val, *sym; - a[0] = menv->module->modname; - sym = scheme_module_demand_hook(1, a); - if (sym) { - val = scheme_lookup_global(sym, menv); - if (val) { - a[0] = val; - val = scheme_module_demand_hook(3, a); - if (val) { - scheme_add_global_symbol(sym, val, menv); - } - } - } - } - - if (env && menv->phase) { - scheme_pop_continuation_frame(&cframe); - } - - p = scheme_current_thread; - p->error_buf = savebuf; - p->current_phase_shift = save_phase_shift; - - scheme_pop_prefix(save_runstack); - } - - LOG_END_RUN(menv->module); - - return NULL; -} - -static void run_module(Scheme_Env *menv, int set_ns) -{ - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - if (set_ns) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)menv); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - eval_module_body(menv, NULL); - - if (set_ns) { - scheme_pop_continuation_frame(&cframe); - } - -} - -Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) -{ - Scheme_Module *m; - Scheme_Env *env; - Scheme_Object *prefix, *insp, *src, *midx; - Scheme_Config *config; - char *running; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; - m->phaseless = scheme_true; - - env = scheme_new_module_env(for_env, m, 0, 0); - - if (!scheme_defining_primitives) { - config = scheme_current_config(); - prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); - if (SCHEME_MODNAMEP(prefix)) - name = prefix; - else - name = scheme_intern_resolved_module_path(name); - src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC); - if (SCHEME_FALSEP(src)) - src = prefix; - else - src = scheme_intern_resolved_module_path(src); - if (SCHEME_FALSEP(src)) - src = name; - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - } - else { - name = scheme_intern_resolved_module_path(name); - src = name; - insp = scheme_get_current_inspector(); - } - - m->modname = name; - m->modsrc = src; - m->requires = scheme_null; - m->et_requires = scheme_null; - m->tt_requires = scheme_null; - m->dt_requires = scheme_null; - m->primitive = env; - m->insp = insp; - - midx = scheme_make_modidx(scheme_false, scheme_false, name); - m->self_modidx = midx; - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - m->me = me; - me->modsrc = src; - } - - scheme_hash_set(for_env->module_registry->exports, m->modname, (Scheme_Object *)m->me); - - env->access_insp = insp; - insp = scheme_make_inspector(insp); - env->guard_insp = insp; - - scheme_hash_set(for_env->module_registry->loaded, m->modname, (Scheme_Object *)m); - - running = scheme_malloc_atomic(2); - running[0] = 1; - running[1] = 1; - env->running = running; - - return env; -} - -void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless) -{ - env->module->phaseless = (phaseless ? scheme_true : NULL); -} - -void scheme_finish_primitive_module(Scheme_Env *env) -{ - Scheme_Module *m = env->module; - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - Scheme_Object **exs; - int i, count; - - if (!m->exp_infos) - add_exp_infos(m); - - /* Provide all variables: */ - count = 0; - ht = env->toplevel; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - count++; - } - - exs = MALLOC_N(Scheme_Object *, count); - count = 0; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - exs[count++] = (Scheme_Object *)b->key; - } - - m->me->rt->provides = exs; - m->me->rt->provide_srcs = NULL; - m->me->rt->provide_src_names = exs; - m->me->rt->num_provides = count; - m->me->rt->num_var_provides = count; - - qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); - - env->running[0] = 1; -} - -void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) -{ - Scheme_Module *m = env->module; - int i; - - if (!m->exp_infos) - add_exp_infos(m); - - if (!m->exp_infos[0]->provide_protects) { - Scheme_Hash_Table *ht; - char *exps; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - exps = MALLOC_N_ATOMIC(char, m->me->rt->num_provides); - for (i = m->me->rt->num_provides; i--; ) { - exps[i] = 0; - scheme_hash_set(ht, m->me->rt->provides[i], scheme_make_integer(i)); - } - add_exp_infos(m); - m->exp_infos[0]->provide_protects = exps; - m->exp_infos[0]->accessible = ht; - } - - if (name) { - for (i = m->me->rt->num_provides; i--; ) { - if (SAME_OBJ(name, m->me->rt->provides[i])) { - m->exp_infos[0]->provide_protects[i] = 1; - break; - } - } - } else { - /* Protect all */ - for (i = m->me->rt->num_provides; i--; ) { - m->exp_infos[0]->provide_protects[i] = 1; - } - } -} - -Scheme_Bucket *scheme_module_bucket(Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env) -{ - Scheme_Object *a[2]; - - if (SAME_OBJ(modname, kernel_symbol)) - a[0] = ((Scheme_Modidx *)kernel_modidx)->path; - else - a[0] = modname; - a[1] = var; - - return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos); -} - -Scheme_Object *scheme_builtin_value(const char *name) -{ - Scheme_Object *a[2], *v; - - a[1] = scheme_intern_symbol(name); - - /* Try kernel first: */ - a[0] = kernel_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try flfxnum next: */ - a[0] = flfxnum_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try extfl next: */ - a[0] = extfl_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try unsafe next: */ - a[0] = unsafe_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Also try #%utils... */ - a[0] = scheme_make_pair(quote_symbol, - scheme_make_pair(scheme_intern_symbol("#%utils"), - scheme_null)); - v = _dynamic_require(2, a, initial_modules_env, 0, 0, 0, 0, 0, -1); - if (v) - return v; - - return NULL; -} - -Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { - Scheme_Compilation_Top *c = (Scheme_Compilation_Top *)o; - - if (!c->prefix) /* => compiled module is in `code' field */ - return (Scheme_Module *)c->code; - - if (SAME_TYPE(SCHEME_TYPE(c->code), scheme_module_type)) { - return (Scheme_Module *)c->code; - } - } - - return NULL; -} - -Scheme_Module_Exports *scheme_make_module_exports() -{ - Scheme_Module_Exports *me; - Scheme_Module_Phase_Exports *pt; - - me = MALLOC_ONE_RT(Scheme_Module_Exports); - SET_REQUIRED_TAG(me->type = scheme_rt_module_exports); - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_make_integer(0); - me->rt = pt; - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_make_integer(1); - me->et = pt; - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_false; - me->dt = pt; - - return me; -} - -/**********************************************************************/ -/* define-syntaxes */ -/**********************************************************************/ - -static void *eval_exptime_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *names; - int count, at_phase; - Scheme_Object *expr; - Scheme_Env *genv; - Scheme_Comp_Env *comp_env; - Resolve_Prefix *rp; - int let_depth, shift; - Scheme_Bucket_Table *syntax; - Scheme_Object *ids_for_rename_trans, *insp; - - names = (Scheme_Object *)p->ku.k.p1; - expr = (Scheme_Object *)p->ku.k.p2; - genv = (Scheme_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[0]; - comp_env = (Scheme_Comp_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[1]; - ids_for_rename_trans = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[2]; - rp = (Resolve_Prefix *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[3]; - syntax = (Scheme_Bucket_Table *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[4]; - insp = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[5]; - count = p->ku.k.i1; - let_depth = p->ku.k.i2; - shift = p->ku.k.i3; - at_phase = p->ku.k.i4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, at_phase, - ids_for_rename_trans, insp); - - return NULL; -} - -static int is_simple_expr(Scheme_Object *v) -{ - Scheme_Type t; - - t = SCHEME_TYPE(v); - if (SAME_TYPE(t, scheme_lambda_type)) - return 1; - - return 0; -} - -static void eval_exptime(Scheme_Object *names, int count, - Scheme_Object *expr, - Scheme_Env *genv, Scheme_Comp_Env *comp_env, - Resolve_Prefix *rp, - int let_depth, int shift, Scheme_Bucket_Table *syntax, - int at_phase, - Scheme_Object *ids_for_rename_trans, - Scheme_Object *insp) -{ - Scheme_Object *macro, *vals, *name, **save_runstack; - int i, g, depth; - - depth = let_depth + scheme_prefix_depth(rp); - if (!scheme_check_runstack(depth)) { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = names; - p->ku.k.p2 = expr; - vals = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vals)[0] = (Scheme_Object *)genv; - SCHEME_VEC_ELS(vals)[1] = (Scheme_Object *)comp_env; - SCHEME_VEC_ELS(vals)[2] = ids_for_rename_trans; - SCHEME_VEC_ELS(vals)[3] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vals)[4] = (Scheme_Object *)syntax; - SCHEME_VEC_ELS(vals)[5] = insp; - p->ku.k.p4 = vals; - p->ku.k.i1 = count; - p->ku.k.i2 = let_depth; - p->ku.k.i3 = shift; - p->ku.k.i4 = at_phase; - (void)scheme_enlarge_runstack(depth, eval_exptime_k); - return; - } - - if (SCHEME_TYPE(expr) > _scheme_values_types_) { - vals = expr; - } else { - save_runstack = scheme_push_prefix(genv, 0, rp, - (shift ? genv->module->me->src_modidx : NULL), - (shift ? genv->link_midx : NULL), - at_phase, genv->phase, - NULL, insp); - - if (is_simple_expr(expr)) { - vals = _scheme_eval_linked_expr_multi_wp(expr, scheme_current_thread); - } else { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Dynamic_State dyn_state; - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)genv); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, - genv, (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx)); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(expr, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - scheme_pop_prefix(save_runstack); - } - - if (names) { - if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { - g = scheme_current_thread->ku.multiple.count; - if (count == g) { - Scheme_Object **values; - - values = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(values, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { - name = SCHEME_CAR(names); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; - - if (SCHEME_TRUEP(ids_for_rename_trans) - && scheme_is_binding_rename_transformer(values[i])) { - scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(values[i], NULL), - scheme_make_integer(at_phase-1)); - } - scheme_add_to_table(syntax, (const char *)name, macro, 0); - - if (SCHEME_TRUEP(ids_for_rename_trans)) - ids_for_rename_trans = SCHEME_CDR(ids_for_rename_trans); - } - - return; - } - } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { - name = SCHEME_CAR(names); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = vals; - - if (SCHEME_TRUEP(ids_for_rename_trans) - && scheme_is_binding_rename_transformer(vals)) { - scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(vals, NULL), - scheme_make_integer(at_phase-1)); - } - scheme_add_to_table(syntax, (const char *)name, macro, 0); - - return; - } else - g = 1; - - if (count) - name = SCHEME_CAR(names); - else - name = NULL; - - { - const char *symname; - - symname = (name ? scheme_symbol_name(name) : ""); - - scheme_wrong_return_arity("define-syntaxes", - count, g, - (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((count == 1) ? "\"" : "\", ...") : ""); - } - } -} - -/**********************************************************************/ -/* module */ -/**********************************************************************/ - -static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule); - -static Scheme_Object *do_module_execute_k() -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *data = (Scheme_Object *)p->ku.k.p1; - Scheme_Env *genv = (Scheme_Env *)p->ku.k.p2; - Scheme_Object *prefix = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *supermodule = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return do_module_execute(data, genv, p->ku.k.i1, p->ku.k.i2, prefix, supermodule); -} - -static Scheme_Object *do_module_execute_recur(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule) -{ -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)data; - p->ku.k.p2 = (void *)genv; - p->ku.k.i1 = set_cache; - p->ku.k.i2 = set_in_pre; - p->ku.k.p3 = (void *)prefix; - p->ku.k.p4 = (void *)supermodule; - return scheme_handle_stack_overflow(do_module_execute_k); - } else { - return do_module_execute(data, genv, set_cache, set_in_pre, prefix, supermodule); - } -} - -static void execute_submodules(Scheme_Module *m, int pre, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix) -{ - Scheme_Object *p; - - p = (pre ? m->pre_submodules : m->post_submodules); - - if (p) { - if (SCHEME_PAIRP(scheme_resolved_module_path_value(prefix))) { - prefix = scheme_resolved_module_path_value(prefix); - prefix = scheme_intern_resolved_module_path(SCHEME_CAR(prefix)); - } - - while (!SCHEME_NULLP(p)) { - do_module_execute_recur(SCHEME_CAR(p), genv, set_cache, set_in_pre, prefix, - (Scheme_Object *)m); - p = SCHEME_CDR(p); - } - } -} - -static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule) -{ - Scheme_Module *m, *old_m; - Scheme_Env *env; - Scheme_Env *old_menv; - Scheme_Config *config; - Scheme_Object *src, *insp; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m, data, sizeof(Scheme_Module)); - - if (set_cache && m->code_key - && (!m->pre_submodules || SCHEME_NULLP(m->pre_submodules)) - && (!m->post_submodules || SCHEME_NULLP(m->post_submodules))) { - if (!scheme_module_code_cache) { - REGISTER_SO(scheme_module_code_cache); - scheme_module_code_cache = scheme_make_weak_equal_table(); - } - scheme_add_to_table(scheme_module_code_cache, - (const char *)m->code_key, - scheme_make_ephemeron(m->code_key, data), - 0); - } - - if (m->code_key) { - /* clone `requires', etc., so that different uses of the cached - module don't share resolution of modiule paths in modidxs */ - clone_all_require_names(m); - } - - config = scheme_current_config(); - - if (!prefix) - prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); - - if (SCHEME_MODNAMEP(prefix)) { - if (m->submodule_path && !SCHEME_NULLP(m->submodule_path)) { - prefix = scheme_make_pair(scheme_resolved_module_path_value(prefix), - m->submodule_path); - prefix = scheme_intern_resolved_module_path(prefix); - } - - m->modname = prefix; - - if (m->self_modidx) { - if (!SCHEME_SYMBOLP(m->self_modidx)) { - Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx; - Scheme_Object *nmidx; - - nmidx = scheme_make_modidx(midx->path, midx->base, m->modname); - m->self_modidx = nmidx; - - if (m->rn_stx && !SAME_OBJ(scheme_true, m->rn_stx)) { - /* Delay the shift: */ - Scheme_Object *v; - v = m->rn_stx; - v = scheme_make_pair(v, (Scheme_Object *)midx); - m->rn_stx = v; - } - } - } - } else - prefix = m->modname; /* used for submodules */ - - /* printf("declare %s\n", scheme_write_to_string(m->modname, NULL)); */ - - src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC); - if (!SCHEME_FALSEP(src)) { - src = scheme_intern_resolved_module_path(src); - m->modsrc = src; - } else { - src = m->modname; - if (m->submodule_path && !SCHEME_NULLP(m->submodule_path)) { - src = scheme_resolved_module_path_value(src); - if (SCHEME_PAIRP(src)) - src = SCHEME_CAR(src); - src = scheme_intern_resolved_module_path(src); - } - m->modsrc = src; - } - - if (supermodule) - m->supermodule = supermodule; - - if (genv) - env = genv; - else - env = scheme_environment_from_dummy(m->dummy); - - old_menv = get_special_modenv(m->modname); - if (!old_menv) - old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - - if (old_menv) { - if (scheme_module_protected_wrt(old_menv->guard_insp, insp) || old_menv->attached) { - scheme_contract_error("module->namespace", - "current code inspector cannot redeclare module", - "module name", 1, m->modname, - NULL); - return NULL; - } - } - - if (old_menv) - old_m = old_menv->module; - else - old_m = (Scheme_Module *)scheme_hash_get(env->module_registry->loaded, m->modname); - - if (old_m && old_m->phaseless) { - scheme_contract_error("module->namespace", - "cannot redeclare cross-phase persistent module", - "module name", 1, m->modname, - NULL); - return NULL; - } - - if (!set_in_pre) { - /* execute pre-submodules: */ - execute_submodules(m, 1, genv, set_cache, set_in_pre, prefix); - } - - if (!SAME_OBJ(m->me->modsrc, m->modsrc)) { - /* have to clone m->me, etc. */ - Scheme_Module_Exports *naya_me; - - naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports); - memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports)); - m->me = naya_me; - m->me->modsrc = m->modsrc; - } - - m->insp = insp; - if (set_in_pre) { - if (!env->module_pre_registry->loaded) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->module_pre_registry->loaded = ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; /* print (for debugging) as opqaue */ - env->module_pre_registry->exports = ht; - } - scheme_hash_set(env->module_pre_registry->loaded, m->modname, (Scheme_Object *)m); - scheme_hash_set(env->module_pre_registry->exports, m->modname, (Scheme_Object *)m->me); - } else { - scheme_hash_set(env->module_registry->loaded, m->modname, (Scheme_Object *)m); - scheme_hash_set(env->module_registry->exports, m->modname, (Scheme_Object *)m->me); - } - - if (!set_in_pre) { - Scheme_Object *resolver, *a[2]; - resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER); - a[0] = m->modname; - a[1] = scheme_false; - scheme_apply(resolver, 2, a); - } - - /* Replacing an already-running or already-syntaxing module? */ - if (old_menv) { - old_menv->interactive_bindings = 1; - start_module(m, env, 1, NULL, - ((m->num_phases > 1) ? old_menv->running[1] : 0), - old_menv->running[0], - env->phase, scheme_null, 1); - } - - /* execute post-submodules: */ - execute_submodules(m, 0, genv, set_cache, set_in_pre, prefix); - - return scheme_void; -} - -Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv) -{ - return do_module_execute(data, genv, 1, 0, NULL, NULL); -} - -Scheme_Object *scheme_get_modsrc(Scheme_Module *mod) -{ - Scheme_Object *p, *p2; - - p = scheme_resolved_module_path_value(mod->modname); - if (SCHEME_PAIRP(p)) { - /* Construct a submodule path based on `modsrc` instead of `modname`. */ - p2 = scheme_resolved_module_path_value(mod->modsrc); - if (SAME_OBJ(SCHEME_CAR(p), p2)) - return mod->modname; - else - return scheme_intern_resolved_module_path(scheme_make_pair(p2, SCHEME_CDR(p))); - } else - return mod->modsrc; -} - -static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp) -{ - Scheme_Object *vec2; - int i; - - i = SCHEME_VEC_SIZE(vec); - vec2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i]; - } - SCHEME_VEC_ELS(vec2)[1] = naya; - SCHEME_VEC_ELS(vec2)[3] = (Scheme_Object *)rp; - - return vec2; -} - -static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit) -{ - Scheme_Object *orig, *naya = NULL; - Resolve_Prefix *orig_rp, *rp; - int i, cnt; - - cnt = SCHEME_VEC_SIZE(orig_l); - for (i = 0; i < cnt; i++) { - orig = SCHEME_VEC_ELS(orig_l)[i]; - if (in_vec) { - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3]; - rp = scheme_prefix_eval_clone(orig_rp); - orig = SCHEME_VEC_ELS(orig)[1]; - } else { - orig_rp = rp = NULL; - } - - if (jit) - naya = scheme_jit_expr(orig); - else - naya = orig; - - if (!SAME_OBJ(orig, naya) - || !SAME_OBJ(orig_rp, rp)) - break; - } - - if (i < cnt) { - Scheme_Object *new_l; - int j; - new_l = scheme_make_vector(cnt, NULL); - for (j = 0; j < i; j++) { - SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j]; - } - if (in_vec) - naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp); - SCHEME_VEC_ELS(new_l)[i] = naya; - for (i++; i < cnt; i++) { - orig = SCHEME_VEC_ELS(orig_l)[i]; - if (in_vec) { - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3]; - rp = scheme_prefix_eval_clone(orig_rp); - orig = SCHEME_VEC_ELS(orig)[1]; - } else { - orig_rp = rp = NULL; - } - - if (jit) - naya = scheme_jit_expr(orig); - else - naya = orig; - - if (in_vec) { - if (!SAME_OBJ(orig, naya) - || !SAME_OBJ(rp, orig_rp)) - naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp); - else - naya = SCHEME_VEC_ELS(orig_l)[i]; - } - SCHEME_VEC_ELS(new_l)[i] = naya; - } - return new_l; - } else - return orig_l; -} - -static Scheme_Object *do_module_clone(Scheme_Object *data, int jit) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *l1, *l2, *pre_submods, *post_submods, *sm, **naya = NULL; - int j, i, submod_changed; - Resolve_Prefix *rp; - - rp = scheme_prefix_eval_clone(m->prefix); - - for (j = m->num_phases; j--; ) { - if (!jit && !j) { - if (naya) - naya[0] = m->bodies[0]; - break; - } - l1 = jit_vector(m->bodies[j], j > 0, jit); - if (naya) - naya[j] = l1; - else if (!SAME_OBJ(l1, m->bodies[j])) { - naya = MALLOC_N(Scheme_Object*, m->num_phases); - for (i = m->num_phases; i-- > j; ) { - naya[i] = m->bodies[i]; - } - naya[j] = l1; - } - } - - pre_submods = m->pre_submodules; - post_submods = m->post_submodules; - submod_changed = 0; - - for (j = 0; j < 2; j++) { - l1 = (j ? post_submods : pre_submods); - if (l1 && !SCHEME_NULLP(l1)) { - l2 = scheme_null; - while (!SCHEME_NULLP(l1)) { - sm = do_module_clone(SCHEME_CAR(l1), jit); - if (!SAME_OBJ(sm, SCHEME_CAR(l1))) - submod_changed = 1; - l2 = scheme_make_pair(sm, l2); - l1 = SCHEME_CDR(l1); - } - if (submod_changed) { - l2 = scheme_reverse(l2); - if (j) - post_submods = l2; - else - pre_submods = l2; - } - } - } - - if (!naya) { - if (SAME_OBJ(rp, m->prefix) && !submod_changed) - return data; - naya = m->bodies; - } - - m = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m, data, sizeof(Scheme_Module)); - m->bodies = naya; - m->prefix = rp; - - m->pre_submodules = pre_submods; - m->post_submodules = post_submods; - - return (Scheme_Object *)m; -} - -Scheme_Object *scheme_module_jit(Scheme_Object *data) -{ - return do_module_clone(data, 1); -} - -Scheme_Object *scheme_module_eval_clone(Scheme_Object *data) -{ - return do_module_clone(data, 0); -} - -static Scheme_Object *strip_lexical_context(Scheme_Object *stx); - -static Scheme_Object *strip_lexical_context_k() -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *v = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return strip_lexical_context(v); -} - -static Scheme_Object *strip_lexical_context(Scheme_Object *stx) -{ - Scheme_Object *v = NULL; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)v; - - return scheme_handle_stack_overflow(strip_lexical_context_k); - } -#endif - - if (SCHEME_STXP(stx)) { - stx = scheme_stx_taint_disarm(stx, NULL); - v = SCHEME_STX_VAL(stx); - } else - v = stx; - - if (SCHEME_PAIRP(v)) { - v = scheme_make_pair(strip_lexical_context(SCHEME_CAR(v)), - strip_lexical_context(SCHEME_CDR(v))); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2, *a; - int i = SCHEME_VEC_SIZE(v); - v2 = scheme_make_vector(i, NULL); - for (; i--; ) { - a = strip_lexical_context(SCHEME_VEC_ELS(v)[i]); - SCHEME_VEC_ELS(v2)[i] = a; - } - } else if (SCHEME_BOXP(v)) { - v = strip_lexical_context(SCHEME_BOX_VAL(v)); - v = scheme_box(v); - } - /* FIXME: handle prefabs & hashes */ - - if (SCHEME_STXP(stx)) - v = scheme_datum_to_syntax(v, stx, scheme_false, 0, 1); - - return v; -} - -static void check_not_tainted(Scheme_Object *orig) -{ - if (scheme_stx_is_tainted(orig)) - scheme_wrong_syntax(NULL, orig, NULL, - "cannot expand module body tainted by macro expansion"); -} - -static Scheme_Env *find_env(Scheme_Env *env, intptr_t ph) -{ - return scheme_find_env_at_phase(env, scheme_make_integer(ph - env->phase)); -} - -static Scheme_Object *extract_root_module_name(Scheme_Module *m) -{ - Scheme_Object *root_module_name; - - root_module_name = m->submodule_ancestry; - if (SCHEME_NULLP(root_module_name)) { - root_module_name = m->modname; - } else { - while (SCHEME_PAIRP(SCHEME_CDR(root_module_name))) { - root_module_name = SCHEME_CDR(root_module_name); - } - root_module_name = ((Scheme_Env *)SCHEME_CAR(root_module_name))->module->modname; - } - - return root_module_name; -} - -static void add_binding_names_from_environment(Scheme_Module *m, Scheme_Env *benv) -{ - if (benv->binding_names) { - int c; - - if (SCHEME_HASHTP(benv->binding_names)) - c = ((Scheme_Hash_Table *)benv->binding_names)->count; - else - c = ((Scheme_Hash_Tree *)benv->binding_names)->count; - - if (c) { - Scheme_Hash_Table *ht; - - ht = (Scheme_Hash_Table *)m->other_binding_names; - if (!ht) { - ht = scheme_make_hash_table_eqv(); - m->other_binding_names = (Scheme_Object *)ht; - } - - scheme_hash_set(ht, scheme_env_phase(benv), benv->binding_names); - } - } -} - -#if 0 -# define LOG_EXPAND_DECLS intptr_t start_time -# define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) -# define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \ - scheme_write_to_string(mod->modname, NULL), \ - scheme_get_process_milliseconds() - start_time)) -#else -# define LOG_EXPAND_DECLS /* empty */ -# define LOG_START_EXPAND(mod) /* empty */ -# define LOG_END_EXPAND(mod) /* empty */ -#endif - -static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *submodule_ancestry, Scheme_Object *submodule_path, int post, - Module_Begin_Expand_State *super_bxs, - Scheme_Object *super_phase_shift) -{ - Scheme_Object *fm, *disarmed_form; - Scheme_Object *nm, *ii, *iidx, *self_modidx, *rmp, *rn_set, *mb_ctx, *ctx_form; - Scheme_Module *iim; - Scheme_Env *menv, *top_env; - Scheme_Comp_Env *benv; - Scheme_Module *m; - Scheme_Object *mbval, *orig_ii; - Scheme_Object *this_empty_self_modidx, **sub_iidx_ptrs; - int saw_mb, check_mb = 0, shift_back = 0; - Scheme_Object *restore_confusing_name = NULL; - LOG_EXPAND_DECLS; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_MODULE(env->observer); - if (rec[drec].depth > 0) - rec[drec].depth++; - } - - if (!scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a module-definition context"); - - disarmed_form = scheme_stx_taint_disarm(form, NULL); - - fm = SCHEME_STX_CDR(disarmed_form); - if (!SCHEME_STX_PAIRP(fm)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - nm = SCHEME_STX_CAR(fm); - if (!SCHEME_STX_SYMBOLP(nm)) - scheme_wrong_syntax(NULL, nm, form, "module name is not an identifier"); - fm = SCHEME_STX_CDR(fm); - if (!SCHEME_STX_PAIRP(fm)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - ii = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - - orig_ii = ii; - - if (post && SCHEME_FALSEP(SCHEME_STX_VAL(ii))) { - ii = NULL; - ctx_form = disarmed_form; - } else { - /* "Punch a hole" in the enclosing context by removing the - immediately enclosing module context: */ - fm = disarmed_form; - fm = scheme_revert_use_site_scopes(fm, env); - fm = scheme_stx_unintroduce_from_module_context(fm, env->genv->stx_context); - ctx_form = fm; - fm = SCHEME_STX_CDR(fm); - nm = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - ii = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - super_phase_shift = scheme_make_integer(0); - orig_ii = ii; - } - - if (!SCHEME_STXP(fm)) - fm = scheme_datum_to_syntax(fm, scheme_false, scheme_false, 0, 0); - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; - m->phaseless = (scheme_starting_up ? scheme_true : NULL); - - /* must set before calling new_module_env: */ - rmp = SCHEME_STX_VAL(nm); - rmp = scheme_intern_resolved_module_path(rmp); - m->modname = rmp; - if (super_bxs) - m->modsrc = super_bxs->modsrc; - else - m->modsrc = rmp; - - if (!SCHEME_NULLP(submodule_ancestry)) - submodule_path = scheme_append(submodule_path, scheme_make_pair(SCHEME_STX_VAL(nm), scheme_null)); - m->submodule_ancestry = submodule_ancestry; - m->submodule_path = submodule_path; - - if (!SCHEME_NULLP(submodule_path)) { - Scheme_Object *self_name; - self_name = scheme_resolved_module_path_value(extract_root_module_name(m)); - self_name = scheme_intern_resolved_module_path(scheme_make_pair(self_name, submodule_path)); - m->modname = self_name; - } - - LOG_START_EXPAND(m); - - if (SAME_OBJ(m->modname, kernel_modname) - || SAME_OBJ(m->modname, unsafe_modname) - || SAME_OBJ(m->modname, flfxnum_modname) - || SAME_OBJ(m->modname, extfl_modname) - || SAME_OBJ(m->modname, futures_modname) - || SAME_OBJ(m->modname, foreign_modname)) { - /* Too confusing. Give it a different name while compiling. */ - Scheme_Object *k2; - const char *kname; - if (SAME_OBJ(m->modname, kernel_modname)) - kname = "#%kernel"; - else if (SAME_OBJ(m->modname, flfxnum_modname)) - kname = "#%flfxnum"; - else if (SAME_OBJ(m->modname, extfl_modname)) - kname = "#%extfl"; - else if (SAME_OBJ(m->modname, futures_modname)) - kname = "#%futures"; - else if (SAME_OBJ(m->modname, foreign_modname)) - kname = "#%foreign"; - else - kname = "#%unsafe"; - k2 = scheme_intern_resolved_module_path(scheme_make_symbol(kname)); /* uninterned! */ - restore_confusing_name = m->modname; - m->modname = k2; - } - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - m->me = me; - me->modsrc = m->modsrc; - } - - top_env = env->genv; - /* Create module env from phase-0 env. This doesn't create bad - sharing, because compile-time module instances for compiling this - module are all fresh instances. */ - while (top_env->phase) { - scheme_prepare_template_env(top_env); - top_env = top_env->template_env; - } - - /* Create module environment. This environment gets a fresh table - for phase-1 instances: */ - menv = scheme_new_module_env(top_env, m, 1, SCHEME_NULLP(submodule_ancestry)); - - menv->disallow_unbound = 1; - - self_modidx = scheme_make_modidx(scheme_false, scheme_false, m->modname); - m->self_modidx = self_modidx; - m->me->src_modidx = self_modidx; - - m->insp = env->insp; - - if (ii) { - m->ii_src = ii; - - ii = scheme_syntax_to_datum(ii, 0, NULL); - - if (!scheme_is_module_path(ii)) { - scheme_wrong_syntax(NULL, m->ii_src, form, "initial import is not a well-formed module path"); - } - - iidx = scheme_make_modidx(ii, - self_modidx, - scheme_false); - } else { - void **super_bxs_info; - Scheme_Object *shift; - - iidx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string(".."), - scheme_null)), - self_modidx, - scheme_false); - - shift = scheme_make_pair(iidx, *super_bxs->sub_iidx_ptrs); - *super_bxs->sub_iidx_ptrs = shift; - - super_phase_shift = scheme_bin_minus(scheme_make_integer(0), super_phase_shift); - - shift = scheme_make_shift(super_phase_shift, - top_env->module->self_modidx, iidx, - menv->module_registry->exports, - m->insp, m->insp); - - super_bxs_info = MALLOC_N(void*, 6); - super_bxs_info[0] = super_bxs; - super_bxs_info[1] = shift; - super_bxs_info[2] = top_env->module->self_modidx; - super_bxs_info[3] = iidx; - super_bxs_info[4] = top_env; - super_bxs_info[5] = super_phase_shift; - m->super_bxs_info = super_bxs_info; - } - - sub_iidx_ptrs = MALLOC_N(Scheme_Object*, 1); - *sub_iidx_ptrs = scheme_null; - m->sub_iidx_ptrs = sub_iidx_ptrs; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - } - - /* load the module for the initial require */ - if (iidx) { - iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); - start_module(iim, find_env(menv, SCHEME_INT_VAL(super_phase_shift)), 0, iidx, 1, 0, menv->phase, scheme_null, 0); - } else - iim = NULL; - - m->requires = scheme_null; - m->et_requires = scheme_null; - m->tt_requires = scheme_null; - m->dt_requires = scheme_null; - - if (iim && iim->phaseless) - m->phaseless = scheme_true; - - if (iidx) { - Scheme_Object *ins; - ins = cons(iidx, scheme_null); - if (SAME_OBJ(super_phase_shift, scheme_make_integer(0))) { - m->requires = ins; - } else if (SAME_OBJ(super_phase_shift, scheme_make_integer(-1))) { - m->tt_requires = ins; - } else { - Scheme_Hash_Table *oht; - oht = m->other_requires; - if (!oht) { - oht = scheme_make_hash_table_eqv(); - m->other_requires = oht; - } - scheme_hash_set(oht, super_phase_shift, ins); - } - } - - scheme_prepare_env_stx_context(menv); - - rn_set = menv->stx_context; - - { - Scheme_Object *insp; - menv->access_insp = env->insp; - insp = scheme_make_inspector(env->insp); - menv->guard_insp = insp; - } - - scheme_prepare_exp_env(menv); - - /* Allow phase-1 references to unbound identifiers; we check - at the end of body expansion to make sure that all referenced - identifiers were eventually bound. Meanwhile, - reference-before-definition errors are possible. */ - menv->exp_env->disallow_unbound = -1; - - mb_ctx = scheme_false; - - /* For each provide in iim, add a module rename to fm */ - orig_ii = scheme_stx_add_module_context(orig_ii, rn_set); - if (ii) { - saw_mb = add_simple_require_renames(orig_ii, rn_set, menv, NULL, iim, iidx, scheme_make_integer(0), - NULL, 1, 0); - mb_ctx = scheme_datum_to_syntax(scheme_false, scheme_false, orig_ii, 0, 0); - } else { - Scheme_Object *shift; - shift = (Scheme_Object *)m->super_bxs_info[1]; - fm = scheme_stx_add_shift(fm, shift); - mb_ctx = scheme_stx_add_shift(ctx_form, shift); - orig_ii = scheme_stx_add_shift(orig_ii, shift); - shift_back = 1; - /* there must be a `#%module-begin' in the enclosing module; if it's - shadowed, then we want a different error message than the one for - saw_mb == 0 */ - saw_mb = 1; - } - - m->ii_src = orig_ii; - - { - Scheme_Object *frame_scopes; - frame_scopes = scheme_module_context_frame_scopes(rn_set, NULL); - if (rec[drec].comp) - benv = scheme_new_comp_env(menv, env->insp, frame_scopes, - SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); - else - benv = scheme_new_expand_env(menv, env->insp, frame_scopes, - SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); - benv->observer = env->observer; - } - - /* If fm isn't a single expression, it certainly needs a - `#%module-begin': */ - if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) { - /* Perhaps expandable... */ - fm = SCHEME_STX_CAR(fm); - check_not_tainted(fm); - } else { - fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2), - fm); - check_mb = 1; - } - - fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2); - - if (!rec[drec].comp) { - if (check_mb) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm); - } - } - - fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - - this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path, 1); - - /* phase shift to replace self_modidx of previous expansion: */ - fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); - if (m->ii_src) { - /* shift the initial import to record the chain for rn_stx */ - ii = scheme_stx_shift(m->ii_src, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); - m->ii_src = ii; - } - - fm = scheme_stx_add_module_frame_context(fm, rn_set); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm); - } - - if (!check_mb) { - fm = scheme_check_immediate_macro(fm, benv, rec, drec, &mbval, 1); - - /* If expansion is not the primitive `#%module-begin', add local one: */ - if (!SAME_OBJ(mbval, modbeg_syntax)) { - Scheme_Object *mb; - mb = scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 0); - fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null)); - fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2); - fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm); - } - - check_mb = 1; - } - } - - if (check_mb && !saw_mb) { - scheme_wrong_syntax(NULL, NULL, form, - "no #%%module-begin binding in the module's language"); - } - - if (rec[drec].comp) { - Scheme_Object *dummy, *pv; - - dummy = scheme_make_environment_dummy(env); - m->dummy = dummy; - - scheme_compile_rec_done_local(rec, drec); - fm = scheme_compile_expr(fm, benv, rec, drec); - - /* result should be a module body value: */ - if (!SAME_OBJ(fm, (Scheme_Object *)m)) { - scheme_wrong_syntax(NULL, NULL, form, "expansion of #%%module-begin is not a #%%plain-module-begin form"); - } - - if (restore_confusing_name) - m->modname = restore_confusing_name; - - m->ii_src = NULL; - m->super_bxs_info = NULL; - m->sub_iidx_ptrs = NULL; - - pv = scheme_stx_property(form, scheme_intern_symbol("module-language"), NULL); - if (pv && SCHEME_TRUEP(pv)) { - if (SCHEME_VECTORP(pv) - && (3 == SCHEME_VEC_SIZE(pv)) - && scheme_is_module_path(SCHEME_VEC_ELS(pv)[0]) - && SCHEME_SYMBOLP(SCHEME_VEC_ELS(pv)[1])) - m->lang_info = pv; - } - - fm = (Scheme_Object *)m; - } else { - Scheme_Object *hints, *formname, *ps; - Scheme_Object *shift; - - fm = scheme_expand_expr(fm, benv, rec, drec); - - if (shift_back) { - shift = (Scheme_Object *)m->super_bxs_info[5]; - fm = scheme_stx_add_shift(fm, scheme_bin_minus(scheme_make_integer(0), shift)); - } - - m->ii_src = NULL; - m->super_bxs_info = NULL; - m->sub_iidx_ptrs = NULL; - - hints = m->hints; - m->hints = NULL; - - formname = SCHEME_STX_CAR(disarmed_form); - fm = cons(formname, - cons(nm, - cons(orig_ii, - cons(fm, scheme_null)))); - - fm = scheme_datum_to_syntax(fm, form, ctx_form, 0, 2); - - /* for future expansion, shift away from self_modidx: */ - ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); - fm = scheme_stx_add_shift(fm, ps); - - if (hints) { - Scheme_Object *stx, *l; - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-requires"), - m->requires); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-syntax-requires"), - m->et_requires); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-template-requires"), - m->tt_requires); - - l = scheme_null; - if (!SCHEME_NULLP(m->dt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_false, m->dt_requires), - l); - if (m->other_requires) { - int i; - for (i = 0; i < m->other_requires->size; i++) { - if (m->other_requires->vals[i]) { - l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i], - m->other_requires->vals[i]), - l); - } - } - } - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-meta-requires"), - l); - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-variable-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-syntax-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-indirect-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-indirect-for-meta-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-kernel-reprovide-hint"), - SCHEME_CAR(hints)); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-self-path-index"), - this_empty_self_modidx); - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-context-simple?"), - (SAME_OBJ(scheme_true, m->rn_stx) - ? scheme_true - : scheme_false)); - - stx = scheme_datum_to_syntax(scheme_intern_symbol("inside"), scheme_false, scheme_false, 0, 0); - stx = scheme_stx_add_module_context(stx, rn_set); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-context"), - scheme_stx_add_shift(stx, ps)); - - stx = scheme_datum_to_syntax(scheme_intern_symbol("outside"), scheme_false, scheme_false, 0, 0); - stx = scheme_stx_introduce_to_module_context(stx, rn_set); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-inside-context"), - scheme_stx_add_shift(stx, ps)); - } - - /* make self_modidx like the empty modidx; this update plays the - role of applying a shift to identifiers that are in syntax - properties, such as the 'origin property */ - if (SAME_OBJ(this_empty_self_modidx, empty_self_modidx)) - ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname; - else - ((Scheme_Modidx *)self_modidx)->resolved = ((Scheme_Modidx *)this_empty_self_modidx)->resolved; - - while (SCHEME_PAIRP(*sub_iidx_ptrs)) { - /* Each in `*sub_iidx_ptrs` corresponds to the implicit `..` import for - a `(module* name #f ...)` submodule: */ - ((Scheme_Modidx *)SCHEME_CAR(*sub_iidx_ptrs))->resolved = ((Scheme_Modidx *)self_modidx)->resolved; - *sub_iidx_ptrs = SCHEME_CDR(*sub_iidx_ptrs); - } - } - - if (rec[drec].comp || (rec[drec].depth != -2)) { - /* rename tables no longer needed; NULL them out */ - menv->stx_context = NULL; - } - - m->submodule_ancestry = NULL; /* ancestry no longer needed; NULL to avoid leak */ - - LOG_END_EXPAND(m); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm); - } - return fm; -} - -static Scheme_Object * -module_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_module(form, env, rec, drec, scheme_null, scheme_null, 0, - NULL, scheme_make_integer(0)); -} - -static Scheme_Object * -module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return do_module(form, env, erec, drec, scheme_null, scheme_null, 0, - NULL, scheme_make_integer(0)); -} - -static Scheme_Object * -modulestar_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not in a module top-level)"); - return NULL; -} - -static Scheme_Object * -modulestar_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return modulestar_compile(form, env, erec, drec); -} - -/* For mzc: */ -Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env) -{ - Scheme_Comp_Env *rhs_env; - Scheme_Dynamic_State dyn_state; - - rhs_env = scheme_new_comp_env(env, NULL, NULL, SCHEME_TOPLEVEL_FRAME); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - env, (env->link_midx - ? env->link_midx - : (env->module - ? env->module->me->src_modidx - : NULL))); - - return scheme_apply_multi_with_dynamic_state(proc, 0, NULL, &dyn_state); -} - -Scheme_Object *scheme_prune_bindings_table(Scheme_Object *binding_names, Scheme_Object *rn_stx, Scheme_Object *phase) -{ - int dropped = 0; - intptr_t i; - Scheme_Object *k, *val, *base_stx; - Scheme_Hash_Tree *ht; - - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - base_stx = scheme_stx_add_module_context(scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0), - scheme_module_context_at_phase(scheme_stx_to_module_context(rn_stx), - phase)); - - if (SCHEME_HASHTRP(binding_names)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)binding_names; - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &val); - if (!scheme_stx_could_bind(val, - scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), - phase)) { - dropped = 1; - val = scheme_true; - } - ht = scheme_hash_tree_set(ht, k, val); - } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)binding_names; - for (i = t->size; i--; ) { - if (t->vals[i]) { - k = t->keys[i]; - val = t->vals[i]; - if (!scheme_stx_could_bind(val, - scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), - phase)) { - dropped = 1; - val = scheme_true; - } - ht = scheme_hash_tree_set(ht, k, val); - } - } - } - - if (dropped) - return (Scheme_Object *)ht; - else - return binding_names; -} - -/**********************************************************************/ -/* #%module-begin */ -/**********************************************************************/ - -static void check_require_name(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, - Scheme_Object *modidx, Scheme_Object *exname, int exet, - int isval, void *tables, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) -{ - Scheme_Hash_Table *required; - Scheme_Object *vec, *nml, *tvec, *binding; - - tvec = scheme_hash_get((Scheme_Hash_Table *)tables, phase); - if (!tvec) { - required = get_required_from_tables(tables, phase); - } else { - required = (Scheme_Hash_Table *)(SCHEME_VEC_ELS(tvec)[1]); - } - - if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { - /* no mapping so far means that we haven't imported anything - with this name so far, and we'll be able to use a symbol - as a key; see require_binding_to_key() */ - binding = SCHEME_STX_VAL(id); - } else { - /* Look for import collisions by checking whether `id` has a binding; - if so, then check whether that binding matches an import that - we have already. If it has a binding and it's not the same binding, - then it's an import conflict. If it's the same bindig, we keep - track of all the imports of the binding. */ - binding = scheme_stx_lookup_exact(id, phase); - if (SCHEME_FALSEP(binding)) { - /* not defined */ - binding = NULL; - } else { - if (!SCHEME_VECTORP(binding) - || (SCHEME_VECTORP(binding) - && self_modidx - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], self_modidx))) { - scheme_wrong_syntax("module", id, form, "imported identifier already defined"); - return; - } else if (SCHEME_VECTORP(binding) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], exname) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) - && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { - /* import is redundant, but may add new nominal info */ - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - } else { - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - if (scheme_hash_get(required, binding)) { - /* use error report or override below */ - } else { - /* identifier has a binding in some context, but not within the current module */ - binding = NULL; - } - } - } - - if (!binding) { - if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { - /* we can just use a symbol as a key, since it's not mapped - so far */ - binding = SCHEME_STX_VAL(id); - } else { - /* generate a binding vector: */ - binding = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(binding)[0] = modidx; - SCHEME_VEC_ELS(binding)[1] = exname; - SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); - /* convert to a general key: */ - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - } - } - } - - if (!SAME_OBJ(src_phase_index, scheme_make_integer(0)) - || !SAME_OBJ(nominal_export_phase, scheme_make_integer(0)) - || !SAME_OBJ(nominal_name, SCHEME_STX_VAL(id))) { - nominal_modidx = scheme_make_pair(nominal_modidx, - scheme_make_pair(src_phase_index, - scheme_make_pair(nominal_name, - scheme_make_pair(nominal_export_phase, - scheme_null)))); - } - - vec = scheme_hash_get(required, binding); - if (vec) { - Scheme_Object *srcs; - char *fromsrc = NULL, *fromsrc_colon = "", *phase_expl; - intptr_t fromsrclen = 0; - - if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx) - && SAME_OBJ(SCHEME_VEC_ELS(vec)[2], exname) - && SAME_OBJ(SCHEME_VEC_ELS(vec)[8], scheme_make_integer(exet))) { - /* already required, same source; add redundant nominal (for re-provides), - and also add source phase for re-provides. */ - nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = nml; - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) - && prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) - SCHEME_VEC_ELS(vec)[7] = scheme_false; - return; - } - - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) - && prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) { - /* can override; first, remove old binding mapping: */ - if (SCHEME_SYMBOLP(binding)) - scheme_hash_set(required, binding, scheme_false); - else - scheme_hash_set(required, binding, NULL); - /* construct overriding `binding`: */ - binding = scheme_make_vector(4, NULL); - vec = scheme_module_resolve(modidx, 0); - SCHEME_VEC_ELS(binding)[0] = vec; - SCHEME_VEC_ELS(binding)[1] = exname; - SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); - SCHEME_VEC_ELS(binding)[3] = SCHEME_STX_VAL(id); - } else { - /* error: already imported */ - srcs = scheme_null; - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[5])) { - srcs = scheme_make_pair(SCHEME_VEC_ELS(vec)[5], srcs); - /* don't use error_write_to_string_w_max since this is code */ - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) { - fromsrc = scheme_write_to_string_w_max(scheme_syntax_to_datum(SCHEME_VEC_ELS(vec)[5], 0, NULL), - &fromsrclen, 32); - fromsrc_colon = ":"; - } - } - - if (!fromsrc) { - fromsrc = "a different source"; - fromsrclen = strlen(fromsrc); - } - - if (err_src) - srcs = scheme_make_pair(err_src, srcs); - - if (SCHEME_FALSEP(phase)) - phase_expl = " for label"; - else if (!SCHEME_INT_VAL(phase)) - phase_expl = ""; - else if (SCHEME_INT_VAL(phase) == 1) - phase_expl = " for syntax"; - else { - char buf[32]; - sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); - phase_expl = scheme_strdup(buf); - } - - scheme_wrong_syntax_with_more_sources("module", id, err_src, srcs, - "identifier already imported%s from%s %t", - phase_expl, - fromsrc_colon, fromsrc, fromsrclen); - } - } - - /* Remember require: */ - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(nominal_modidx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = modidx; - SCHEME_VEC_ELS(vec)[2] = exname; - SCHEME_VEC_ELS(vec)[3] = (isval ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(id); - SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false); - SCHEME_VEC_ELS(vec)[6] = id; - SCHEME_VEC_ELS(vec)[7] = scheme_false; - SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet); - - scheme_hash_set(required, binding, vec); -} - -static int check_already_required(Scheme_Hash_Table *required, - Scheme_Object *id, int phase, - Scheme_Object *binding) -{ - Scheme_Object *vec; - - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - - vec = scheme_hash_get(required, binding); - if (vec) { - if (prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, scheme_make_integer(phase))) { - scheme_hash_set(required, binding, NULL); - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) - return 0; - return 1; - } - } - - return 0; -} - -static void warn_previously_required(Scheme_Object *modname, Scheme_Object *name) -{ - scheme_log(NULL, SCHEME_LOG_WARNING, 0, - "warning: defined identifier is already imported: %S in module: %D", - SCHEME_STX_VAL(name), - modname); -} - -static int check_already_defined(Scheme_Object *name, Scheme_Env *genv) -{ - return (scheme_lookup_in_table(genv->toplevel, (const char *)name) - || scheme_lookup_in_table(genv->syntax, (const char *)name)); -} - -static void propagate_imports(Module_Begin_Expand_State *bxs, - Module_Begin_Expand_State *super_bxs, - Scheme_Object *rn, - Scheme_Object *from_idx, - Scheme_Object *to_idx, - Scheme_Env *super_genv, - Scheme_Env *genv, - Scheme_Object *phase_shift) -/* Record imports from the enclosing module as imports here, - and record definitions from the enclosing module as imports here. */ -{ - Scheme_Hash_Table *ht, *required, *super_required; - Scheme_Object *phase, *super_key, *name, *super_vec, *vec; - Scheme_Object *l, *v, *super_defs, *key, *val, *binding; - int i, j; - Scheme_Env *super_def_genv; - - ht = super_bxs->tables; - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - phase = ht->keys[i]; - super_required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(ht->vals[i])[1]; - - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_plus(phase, phase_shift); - - required = (Scheme_Hash_Table *)get_required_from_tables(bxs->tables, phase); - - for (j = super_required->size; j--; ) { - if (super_required->vals[j]) { - super_key = super_required->keys[j]; - super_vec = super_required->vals[j]; - - if (SCHEME_TRUEP(super_vec)) { - vec = scheme_make_vector(9, NULL); - - l = SCHEME_VEC_ELS(super_vec)[0]; - v = scheme_null; - while (!SCHEME_NULLP(l)) { - v = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(l), from_idx, to_idx), - v); - l = SCHEME_CDR(l); - } - v = scheme_reverse(v); - SCHEME_VEC_ELS(vec)[0] = v; - - v = scheme_modidx_shift(SCHEME_VEC_ELS(super_vec)[1], from_idx, to_idx); - SCHEME_VEC_ELS(vec)[1] = v; - - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(super_vec)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(super_vec)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(super_vec)[4]; - SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(super_vec)[5]; - - if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) - prep_required_id(super_vec); - - v = SCHEME_VEC_ELS(super_vec)[6]; - if (SCHEME_TRUEP(v) && !SAME_OBJ(phase_shift, scheme_make_integer(0))) - v = scheme_stx_add_shift(v, phase_shift); - SCHEME_VEC_ELS(vec)[6] = v; - - SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ - - SCHEME_VEC_ELS(vec)[8] = SCHEME_VEC_ELS(super_vec)[8]; - } else - vec = scheme_false; - - scheme_hash_set(required, super_key, vec); - } - } - } - } - - i = -1; - while (1) { - i = scheme_hash_tree_next(super_bxs->all_defs, i); - if (i == -1) break; - if (scheme_hash_tree_index(super_bxs->all_defs, i, &key, &val)) { - phase = key; - super_defs = val; - - super_def_genv = find_env(super_genv, SCHEME_INT_VAL(phase)); - - required = (Scheme_Hash_Table *)get_required_from_tables(bxs->tables, - scheme_bin_plus(phase, phase_shift)); - - while (!SCHEME_NULLP(super_defs)) { - name = SCHEME_CAR(super_defs); - super_defs = SCHEME_CDR(super_defs); - - vec = scheme_make_vector(9, NULL); - - v = scheme_make_pair(to_idx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = v; - SCHEME_VEC_ELS(vec)[1] = to_idx; - binding = scheme_stx_lookup_stop_at_free_eq(name, phase, NULL); - if (!SCHEME_VECTORP(binding) - || !SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) - scheme_signal_error("internal error: broken binding of defined id from enclosing module: %V at %V = %V", - name, phase, binding); - v = SCHEME_VEC_ELS(binding)[1]; - SCHEME_VEC_ELS(vec)[2] = v; - if (scheme_lookup_in_table(super_def_genv->toplevel, (char *)v)) - SCHEME_VEC_ELS(vec)[3] = scheme_true; - else - SCHEME_VEC_ELS(vec)[3] = scheme_false; - SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(name); - SCHEME_VEC_ELS(vec)[5] = name; - if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) - name = scheme_stx_add_shift(name, phase_shift); - SCHEME_VEC_ELS(vec)[6] = name; - SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ - SCHEME_VEC_ELS(vec)[8] = phase; - - v = require_binding_to_key(required, binding, SCHEME_STX_VAL(name)); - scheme_hash_set(required, v, vec); - } - } - } -} - -Scheme_Object *introduce_to_module_context(Scheme_Object *a, Scheme_Object *rn) -{ - return scheme_stx_introduce_to_module_context(a, rn); -} - -Scheme_Object *reverse_and_introduce_module_context(Scheme_Object *fm, Scheme_Object *rn) -{ - Scheme_Object *l2 = scheme_null; - - while (!SCHEME_NULLP(fm)) { - l2 = scheme_make_pair(introduce_to_module_context(SCHEME_CAR(fm), rn), - l2); - fm = SCHEME_CDR(fm); - } - return l2; -} - -static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) -{ - name = scheme_stx_lookup_exact(name, scheme_env_phase((Scheme_Env *)_genv)); - return SCHEME_VEC_ELS(name)[1]; -} - -static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires) -{ - for (; !SCHEME_NULLP(imods); imods = SCHEME_CDR(imods)) { - Scheme_Object *il, *ilast = NULL; - Scheme_Object *idx = SCHEME_CAR(imods); - - for (il = requires; SCHEME_PAIRP(il); il = SCHEME_CDR(il)) { - if (same_modidx(idx, SCHEME_CAR(il))) - break; - ilast = il; - } - - if (SCHEME_NULLP(il)) { - il = scheme_make_pair(idx, scheme_null); - if (ilast) - SCHEME_CDR(ilast) = il; - else - requires = il; - } - } - - return requires; -} - -static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *_env) -{ - Scheme_Comp_Env *env; - Scheme_Object *rn, *name, *ids, *id, *new_ids = scheme_null; - - env = (Scheme_Comp_Env *)SCHEME_VEC_ELS(data)[0]; - rn = SCHEME_VEC_ELS(data)[2]; - - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - - id = introduce_to_module_context(id, rn); - - name = scheme_global_binding(id, env->genv, 0); - - /* Create the bucket, indicating that the name will be defined: */ - scheme_add_global_symbol(name, scheme_undefined, env->genv); - - new_ids = cons(id, new_ids); - } - - new_ids = scheme_reverse(new_ids); - *_ids = new_ids; - - return scheme_make_lifted_defn(scheme_sys_wraps(env), _ids, expr, _env); -} - -static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase, int can_just_meta) -{ - Scheme_Object *l, *a; - - l = e; - if (SCHEME_STXP(l)) l = scheme_stx_content(l); - if (SCHEME_PAIRP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - - if (can_just_meta && SAME_OBJ(a, just_meta_symbol)) { - /* Shift any `for-meta` within `just-meta`: */ - l = SCHEME_CDR(l); - if (scheme_proper_list_length(l) >= 1) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - if (SCHEME_FALSEP(a) || SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { - e = scheme_null; - for (l = SCHEME_CDR(l); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - e = scheme_make_pair(shift_require_phase(SCHEME_CAR(l), phase, 0), - e); - } - - e = scheme_reverse(e); - return scheme_make_pair(just_meta_symbol, scheme_make_pair(a, e)); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, l); - } else if (SAME_OBJ(a, for_meta_symbol)) { - l = SCHEME_CDR(l); - if (SCHEME_PAIRP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - if (SCHEME_FALSEP(a)) { - return e; - } else if (SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { - phase = scheme_bin_plus(a, phase); - l = SCHEME_CDR(l); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, scheme_null); - } else if (SAME_OBJ(a, for_label_symbol)) { - return e; - } else if (SAME_OBJ(a, for_syntax_symbol)) { - phase = scheme_bin_plus(scheme_make_integer(1), phase); - l = SCHEME_CDR(l); - } else if (SAME_OBJ(a, for_template_symbol)) { - phase = scheme_bin_plus(scheme_make_integer(-1), phase); - l = SCHEME_CDR(l); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, scheme_null); - - return scheme_make_pair(for_meta_symbol, - scheme_make_pair(phase, l)); -} - -static Scheme_Object *make_require_form(Scheme_Object *module_path, intptr_t rel_phase, - Scheme_Object *scope, intptr_t scope_phase) -{ - Scheme_Object *e = module_path, *r; - - if (rel_phase != 0) { - e = shift_require_phase(e, scheme_make_integer(rel_phase), 1); - } - if (scope_phase == 0) - r = require_stx; - else { - r = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), - scheme_false, - sys_wraps_phase(scope_phase), - 0, 0); - } - e = scheme_make_pair(r, scheme_make_pair(e, scheme_null)); - e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0); - - e = scheme_stx_add_scope(e, scope, scheme_make_integer(scope_phase)); - - return e; -} - -Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, - intptr_t phase, - Scheme_Object *scope, - void *data, - Scheme_Object **_ref_expr, - Scheme_Comp_Env *cenv) -{ - Scheme_Object *e; - Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1]; - Scheme_Env *env = (Scheme_Env *)((void **)data)[2]; - Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3]; - Scheme_Object *rns = (Scheme_Object *)((void **)data)[4]; - void *tables = ((void **)data)[6]; - Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7]; - int *all_simple = (int *)((void **)data)[8]; - Scheme_Hash_Table *submodule_names = (Scheme_Hash_Table *)((void **)data)[9]; - - if (*_ref_expr) { - e = introduce_to_module_context(*_ref_expr, rns); - *_ref_expr = e; - } - - e = make_require_form(module_path, phase - env->phase, scope, env->phase); - e = scheme_revert_use_site_scopes(e, cenv); - e = introduce_to_module_context(e, rns); - - parse_requires(e, env->phase, base_modidx, env, for_m, - rns, - check_require_name, tables, - redef_modname, - 0, - 1, phase ? 1 : 0, - all_simple, - NULL, - submodule_names, - NULL); - - scheme_prepare_compile_env(env); - if (phase > env->phase) { - /* Right-hand side of a `define-syntax`; need to prepare compile-time env */ - scheme_prepare_compile_env(env->exp_env); - } - - return e; -} - -static Scheme_Object *package_require_data(Scheme_Object *base_modidx, - Scheme_Env *env, - Scheme_Module *for_m, - Scheme_Object *rns, - void *data, - Scheme_Object *redef_modname, - int *all_simple, - Scheme_Hash_Table *submodule_names) -{ - void **vals; - - vals = MALLOC_N(void*, 10); - vals[0] = NULL; /* this slot is available */ - vals[1] = base_modidx; - vals[2] = env; - vals[3] = for_m; - vals[4] = rns; - vals[5] = NULL; /* removed argument */ - vals[6] = data; - vals[7] = redef_modname; - vals[8] = all_simple; - vals[9] = submodule_names; - - return scheme_make_raw_pair((Scheme_Object *)vals, NULL); -} - - -static void flush_definitions(Scheme_Env *genv) -{ - if (genv->syntax) { - Scheme_Bucket_Table *t; - t = scheme_make_bucket_table(7, SCHEME_hash_ptr); - genv->syntax = t; - } - if (genv->toplevel) { - Scheme_Bucket_Table *t; - t = scheme_make_bucket_table(7, SCHEME_hash_ptr); - t->with_home = 1; - genv->toplevel = t; - } - - genv->binding_names = NULL; -} - -static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - int num_phases, *_num_phases, i, exicount, *all_simple_bindings, has_submodules; - Scheme_Hash_Tree *all_defs; - Scheme_Hash_Table *tables, *all_defs_out, *all_provided, *all_reprovided, *modidx_cache; - Scheme_Module_Export_Info **exp_infos, *exp_info; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l; - Scheme_Env *genv; - Module_Begin_Expand_State *bxs; - Scheme_Expand_Info crec; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (!(env->flags & SCHEME_MODULE_BEGIN_FRAME)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)"); - - if (scheme_stx_proper_list_length(form) < 0) - scheme_wrong_syntax(NULL, NULL, form, IMPROPER_LIST_FORM); - - if (!env->genv->module) - scheme_wrong_syntax(NULL, NULL, form, "not currently transforming a module"); - - /* Redefining a module? */ - redef_modname = env->genv->module->modname; - if (!scheme_hash_get(env->genv->module_registry->loaded, redef_modname)) - redef_modname = NULL; - - tables = scheme_make_hash_table_equal(); - - modidx_cache = scheme_make_hash_table_equal(); - - all_provided = scheme_make_hash_table_eqv(); - all_reprovided = scheme_make_hash_table_eqv(); - all_defs = scheme_make_hash_tree(SCHEME_hashtr_eqv); - all_defs_out = scheme_make_hash_table_eqv(); - - rn_set = env->genv->stx_context; - - /* For `module->namespace`: */ - { - Scheme_Object *rn_stx; - rn_stx = scheme_module_context_to_stx(rn_set, env->genv->module->ii_src); - env->genv->module->rn_stx = rn_stx; - } - - /* It's possible that #%module-begin expansion introduces - scoped identifiers for definitions. */ - form = introduce_to_module_context(form, rn_set); - - observer = env->observer; - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); - } - - _num_phases = MALLOC_ONE_ATOMIC(int); - *_num_phases = 0; - - all_simple_bindings = (int *)scheme_malloc_atomic(sizeof(int)); - *all_simple_bindings = 1; - - if (env->genv->module->super_bxs_info) { - *all_simple_bindings = 0; - } - - bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); - bxs->tables = tables; - bxs->all_provided = all_provided; - bxs->all_reprovided = all_reprovided; - bxs->all_defs = all_defs; - bxs->all_defs_out = all_defs_out; - bxs->all_simple_bindings = all_simple_bindings; - bxs->_num_phases = _num_phases; - bxs->saved_provides = scheme_null; - bxs->saved_submodules = scheme_null; - bxs->submodule_names = NULL; - bxs->modidx_cache = modidx_cache; - bxs->redef_modname = redef_modname; - bxs->end_statementss = scheme_null; - bxs->modsrc = env->genv->module->modsrc; - bxs->sub_iidx_ptrs = env->genv->module->sub_iidx_ptrs; - - if (env->genv->module->super_bxs_info) { - /* initialize imports that are available for export from the enclosing module's - `all_defs' and `imports' (within `tables'): */ - void **super_bxs_info = env->genv->module->super_bxs_info; - propagate_imports(bxs, - (Module_Begin_Expand_State *)super_bxs_info[0], - (Scheme_Object *)super_bxs_info[1], - (Scheme_Object *)super_bxs_info[2], - (Scheme_Object *)super_bxs_info[3], - (Scheme_Env *)super_bxs_info[4], - env->genv, - (Scheme_Object *)super_bxs_info[5]); - } - - if (!rec[drec].comp) { - /* In expand mode, we need to compile anyway in case of nested modules. */ - crec.comp = 1; - crec.dont_mark_local_use = 0; - crec.resolve_module_ids = 0; - crec.substitute_bindings = 1; - crec.pre_unwrapped = 0; - crec.env_already = 0; - crec.comp_flags = rec[drec].comp_flags; - - if (!env->prefix) { - Comp_Prefix *cp; - cp = MALLOC_ONE_RT(Comp_Prefix); -#ifdef MZTAG_REQUIRED - cp->type = scheme_rt_comp_prefix; -#endif - env->prefix = cp; - } - } - - body_lists = do_module_begin_at_phase(form, env, - rec[drec].comp ? rec : &crec, - rec[drec].comp ? drec : 0, - rec[drec].comp ? NULL : rec, drec, - 0, - scheme_null, - bxs); - num_phases = *_num_phases; - - if (!rec[drec].comp) { - expanded_l = SCHEME_CAR(body_lists); - body_lists = SCHEME_CDR(body_lists); - } else - expanded_l = body_lists; - - /* Compute provides for re-provides and all-defs-out: */ - (void)compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - num_phases, - bxs->all_defs, all_defs_out, - "require", NULL, NULL); - - exp_infos = MALLOC_N(Scheme_Module_Export_Info*, num_phases); - for (i = 0; i < num_phases; i++) { - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[i] = exp_info; - } - - /* Compute provide arrays */ - compute_provide_arrays(all_provided, tables, - env->genv->module->me, - env->genv, - form, - num_phases, exp_infos); - - /* Compute indirect provides (which is everything at the top-level): */ - genv = env->genv; - for (i = 0; i < num_phases; i++) { - switch (i) { - case 0: - pt = env->genv->module->me->rt; - break; - case 1: - pt = env->genv->module->me->et; - break; - default: - if (env->genv->module->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->genv->module->me->other_phases, - scheme_make_integer(i)); - else - pt = NULL; - break; - } - if (pt) { - exis = compute_indirects(genv, pt, &exicount, 1); - exp_infos[i]->indirect_provides = exis; - exp_infos[i]->num_indirect_provides = exicount; - exis = compute_indirects(genv, pt, &exicount, 0); - exp_infos[i]->indirect_syntax_provides = exis; - exp_infos[i]->num_indirect_syntax_provides = exicount; - } - genv = genv->exp_env; - } - - has_submodules = (!SCHEME_NULLP(bxs->saved_submodules) - || (env->genv->module->submodule_path - && !SCHEME_NULLP(env->genv->module->submodule_path))); - - if (!rec[drec].comp) { - Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; - int excount = rt->num_provides; - int exvcount = rt->num_var_provides; - Scheme_Object **exsns = rt->provide_src_names; - Scheme_Object **exs = rt->provides; - Scheme_Object **exss = rt->provide_srcs; - - /* Produce annotations (in the form of properties) - for module information: - 'module-variable-provides = '(item ...) - 'module-syntax-provides = '(item ...) - 'module-indirect-provides = '(id ...) - 'module-indirect-for-meta-provides = '((phase id ...) ...) - 'module-kernel-reprovide-hint = 'kernel-reexport - - item = name - | (ext-id . def-id) - | (modidx ext-id . def-id) - kernel-reexport = #f - | #t - | exclusion-id - */ - int j, k; - Scheme_Object *e, *a, *result; - - result = scheme_null; - - /* kernel re-export info (now always #f): */ - result = scheme_make_pair(scheme_false, result); - - /* Indirect provides for phases other than 0 */ - e = scheme_null; - for (k = num_phases; k--; ) { - if (exp_infos[k]->num_indirect_provides) { - a = scheme_null; - for (j = exp_infos[k]->num_indirect_provides; j--; ) { - a = scheme_make_pair(exp_infos[k]->indirect_provides[j], a); - } - a = scheme_make_pair(scheme_make_integer(k), a); - e = scheme_make_pair(a, e); - } - } - result = scheme_make_pair(e, result); - - /* Indirect provides */ - a = scheme_null; - for (j = exp_infos[0]->num_indirect_provides; j--; ) { - a = scheme_make_pair(exp_infos[0]->indirect_provides[j], a); - } - result = scheme_make_pair(a, result); - - /* add syntax and value exports: */ - for (j = 0; j < 2; j++) { - int top, i; - - e = scheme_null; - - if (!j) { - i = exvcount; - top = excount; - } else { - i = 0; - top = exvcount; - } - - for (; i < top; i++) { - if (SCHEME_FALSEP(exss[i]) - && SAME_OBJ(exs[i], exsns[i])) - a = exs[i]; - else { - a = scheme_make_pair(exs[i], exsns[i]); - if (!SCHEME_FALSEP(exss[i])) { - a = scheme_make_pair(exss[i], a); - } - } - e = scheme_make_pair(a, e); - } - result = scheme_make_pair(e, result); - } - - env->genv->module->hints = result; - } - - if (rec[drec].comp || has_submodules) { - Scheme_Object *a, **bodies; - - bodies = MALLOC_N(Scheme_Object*, num_phases); - for (i = 0; i < num_phases; i++) { - a = SCHEME_CAR(body_lists); - if (i > 0) a = scheme_reverse(a); - a = scheme_list_to_vector(a); - bodies[i] = a; - body_lists = SCHEME_CDR(body_lists); - } - env->genv->module->bodies = bodies; - env->genv->module->num_phases = num_phases; - - env->genv->module->exp_infos = exp_infos; - - if (!*all_simple_bindings) { - /* No need to keep indirect syntax provides */ - for (i = 0; i < num_phases; i++) { - exp_infos[i]->indirect_syntax_provides = NULL; - exp_infos[i]->num_indirect_syntax_provides = 0; - } - } - - if (*all_simple_bindings && env->genv->module->rn_stx && rec[drec].comp) { - /* We will be able to reconstruct binding for `module->namespace`: */ - env->genv->module->rn_stx = scheme_true; - } else { - Scheme_Env *bnenv = env->genv; - env->genv->module->binding_names = bnenv->binding_names; - if (bnenv->exp_env) { - bnenv = bnenv->exp_env; - env->genv->module->et_binding_names = bnenv->binding_names; - for (bnenv = bnenv->exp_env; bnenv; bnenv = bnenv->exp_env) { - add_binding_names_from_environment(env->genv->module, bnenv); - } - bnenv = env->genv; - } - for (bnenv = bnenv->template_env; bnenv; bnenv = bnenv->template_env) { - add_binding_names_from_environment(env->genv->module, bnenv); - } - } - } else { - /* For a property on the expanded module: */ - if (*all_simple_bindings && env->genv->module->rn_stx) { - /* We will be able to reconstruct binding for `module->namespace`: */ - env->genv->module->rn_stx = scheme_true; - } - } - - if (rec[drec].comp || has_submodules) { - Scheme_Object *dummy; - dummy = scheme_make_environment_dummy(env); - env->genv->module->dummy = dummy; - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - /* Submodules */ - if (has_submodules) { - Scheme_Object *expanded_modules, *root_module_name; - - root_module_name = extract_root_module_name(env->genv->module); - - /* Need to declare the just-finished module, so it can be - referenced by nested modules: */ - { - Optimize_Info *oi; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Object *o; - int max_let_depth; - int use_jit; - - /* Since we optimize & resolve the module here, it won't need to - be optimized and resolved later. The resolve pass - sets m->comp_prefix to NULL, which is how optimize & resolve - know to avoid re-optimizing and re-resolving. */ - - /* Note: don't use MZCONFIG_USE_JIT for module bodies */ - use_jit = scheme_startup_use_jit; - - o = scheme_letrec_check_expr((Scheme_Object *)env->genv->module); - - oi = scheme_optimize_info_create(env->prefix, env->genv, env->insp, 1); - scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, env->prefix, env->insp); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - if (use_jit) - o = scheme_jit_expr(o); - else - o = scheme_eval_clone(o); - - (void)do_module_execute(o, env->genv, 0, 1, root_module_name, NULL); - } - - if (!rec[drec].comp && (is_modulestar_stop(env))) { - Scheme_Object *l = bxs->saved_submodules; - expanded_modules = NULL; - while (!SCHEME_NULLP(l)) { - expanded_modules = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(l)), - expanded_modules); - l = SCHEME_CDR(l); - } - bxs->saved_submodules = scheme_null; - } else - expanded_modules = expand_submodules(rec, drec, env, bxs->saved_submodules, 1, bxs, !rec[drec].comp); - - if (!rec[drec].comp) { - (void)fixup_expanded(expanded_l, expanded_modules, 0, MODULE_MODFORM_KIND); - } - } - - /* Return module or expanded code: */ - if (rec[drec].comp) { - return (Scheme_Object *)env->genv->module; - } else { - Scheme_Object *p; - - if (rec[drec].depth == -2) { - /* This was a local expand. Flush definitions, because the body expand may start over. */ - Scheme_Env *f_genv = env->genv; - while (f_genv) { - flush_definitions(f_genv); - f_genv = f_genv->exp_env; - } - } - - p = SCHEME_STX_CAR(form); - - return scheme_datum_to_syntax(cons(p, expanded_l), orig_form, orig_form, 0, 2); - } -} - -static Scheme_Object *get_higher_phase_lifts(Module_Begin_Expand_State *bxs, - Scheme_Object *begin_for_syntax_stx) -{ - Scheme_Object *p, *e, *fm = scheme_null, *bfs; - - if (SCHEME_PAIRP(bxs->end_statementss)) { - /* No other ends, so start shitfing higher-phase ends into `b-f-s': */ - int depth = 1; - for (p = bxs->end_statementss; SCHEME_PAIRP(p); p = SCHEME_CDR(p), depth++) { - if (SCHEME_PAIRP(SCHEME_CAR(p))) - break; - } - if (SCHEME_PAIRP(p)) { - /* wrap `depth' `begin-for-syntaxes' around SCHEME_CAR(p): */ - int di; - e = scheme_reverse(SCHEME_CAR(p)); - bfs = scheme_datum_to_syntax(SCHEME_STX_VAL(begin_for_syntax_stx), scheme_false, sys_wraps_phase(depth-1), 0, 0); - e = scheme_make_pair(bfs, e); - for (di = 1; di < depth; di++) { - bfs = scheme_datum_to_syntax(SCHEME_STX_VAL(begin_for_syntax_stx), scheme_false, sys_wraps_phase(depth-di-1), 0, 0); - e = scheme_make_pair(bfs, scheme_make_pair(e, scheme_null)); - } - fm = scheme_make_pair(scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0), - scheme_null); - /* first `depth' end-statement lists are now empty: */ - p = SCHEME_CDR(p); - for (di = 0; di < depth; di++) { - p = scheme_make_pair(scheme_null, p); - } - bxs->end_statementss = p; - } else - bxs->end_statementss = scheme_null; - } - - return fm; -} - -static Scheme_Object *revert_use_site_scopes_via_context(Scheme_Object *o, Scheme_Object *rn_set, intptr_t phase) -{ - return scheme_stx_adjust_module_use_site_context(o, - rn_set, - SCHEME_STX_REMOVE); -} - -static Scheme_Object *handle_submodule_form(const char *who, - Scheme_Object *e, - Scheme_Comp_Env *env, int phase, - Scheme_Object *rn_set, Scheme_Object *observer, - Module_Begin_Expand_State *bxs, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int *_kind) -{ - Scheme_Object *name = NULL, *fst, *p; - int is_star; - - fst = SCHEME_STX_CAR(e); - - is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase); - - e = revert_use_site_scopes_via_context(e, rn_set, phase); - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - if (is_star) { - SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer); - } - } - - if (SCHEME_STX_PAIRP(e)) { - p = SCHEME_STX_CDR(e); - if (SCHEME_STX_PAIRP(p)) { - name = SCHEME_STX_CAR(p); - p = SCHEME_STX_CDR(p); - if (!SCHEME_STX_SYMBOLP(name) - || !SCHEME_STX_PAIRP(p)) { - name = NULL; - } - } - } - if (!name) { - scheme_wrong_syntax(who, NULL, e, NULL); - } - - if (!bxs->submodule_names) { - Scheme_Hash_Table *smn; - smn = scheme_make_hash_table(SCHEME_hash_ptr); - bxs->submodule_names = smn; - } - if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) { - scheme_wrong_syntax(who, name, fst, "duplicate submodule definition"); - } - scheme_hash_set(bxs->submodule_names, - SCHEME_STX_VAL(name), - is_star ? scheme_void : scheme_true); - - if (!is_star) { - p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env, - scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0, - bxs, !!erec); - if (erec) - e = SCHEME_CAR(p); - else - e = NULL; - *_kind = DONE_MODFORM_KIND; - } else { - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_submodules); - bxs->saved_submodules = p; - *_kind = MODULE_MODFORM_KIND; - } - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e); - } - - return e; -} - -static Scheme_Object *do_module_begin_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - void **args = p->ku.k.p1; - Scheme_Object *form = (Scheme_Object *)args[0]; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)args[1]; - Scheme_Compile_Expand_Info *rec = (Scheme_Compile_Expand_Info *)args[2]; - Scheme_Compile_Expand_Info *erec = (Scheme_Compile_Expand_Info *)args[3]; - int phase = SCHEME_INT_VAL((Scheme_Object *)args[4]); - Scheme_Object *body_lists = (Scheme_Object *)args[5]; - Module_Begin_Expand_State *bxs = (Module_Begin_Expand_State *)args[6]; - - p->ku.k.p1 = NULL; - - return do_module_begin_at_phase(form, env, rec, 0, erec, 0, - phase, body_lists, bxs); -} - -static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int phase, - Scheme_Object *body_lists, /* starts from phase + 1; null in expand mode */ - Module_Begin_Expand_State *bxs) -/* Result in expand mode is expressions in order. - Result in compile mode is a body_lists starting with `phase', - where a body_lists has each phase in order, with each list after the first in reverse order. - If both rec[drec].comp && erec, cons results. - If !rec[drec].comp, then erec is non-NULL. */ -{ - Scheme_Object *fm, *first, *last, *p, *rn_set, *exp_body, *self_modidx, *prev_p; - Scheme_Object *expanded_l; - Scheme_Comp_Env *xenv, *cenv, *rhs_env; - Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) - first nominal-modidx goes with modidx, rest are for re-provides */ - Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ - Scheme_Object *all_rt_defs; /* list of stxid; this is almost redundant to the syntax and toplevel - tables, but it preserves the original name for exporting */ - Scheme_Hash_Tree *adt; - Scheme_Object *lift_data; - Scheme_Object *lift_ctx; - Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; - int maybe_has_lifts = 0, expand_ends = (phase == 0), non_phaseless, requested_phaseless; - int requested_empty_namespace; - Scheme_Object *observer, *vec, *end_statements; - Scheme_Object *begin_for_syntax_stx, *non_phaseless_form = NULL; - const char *who = "module"; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *pt = scheme_current_thread; - Scheme_Compile_Expand_Info *recx, *erecx; - void **args; - - if (rec) { - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); - } else - recx = NULL; - - if (erec) { - erecx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(erecx, erec + derec, sizeof(Scheme_Compile_Expand_Info)); - } else - erecx = NULL; - - args = MALLOC_N(void*, 7); - - args[0] = form; - args[1] = env; - args[2] = recx; - args[3] = erecx; - args[4] = scheme_make_integer(phase); - args[5] = body_lists; - args[6] = bxs; - - pt->ku.k.p1 = (void *)args; - - fm = scheme_handle_stack_overflow(do_module_begin_k); - - if (recx) - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - if (erecx) - memcpy(erec + derec, erecx, sizeof(Scheme_Compile_Expand_Info)); - - return fm; - } -#endif - - if (*bxs->_num_phases < phase + 1) - *bxs->_num_phases = phase + 1; - - non_phaseless = (env->genv->module->phaseless ? 0 : NON_PHASELESS_IMPORT); - requested_phaseless = 0; - requested_empty_namespace = 0; - env->genv->module->phaseless = NULL; - - /* Expand each expression in form up to `begin', `define-values', `define-syntax', - `require', `provide', `#%app', etc. */ - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_MODULE_FRAME - | SCHEME_FOR_STOPS), - NULL, - env); - - install_stops(xenv, phase, &begin_for_syntax_stx); - - first = scheme_null; - last = NULL; - - rn_set = env->genv->stx_context; - - xenv->expand_result_adjust = introduce_to_module_context; - xenv->expand_result_adjust_arg = rn_set; - - vec = get_table(bxs->tables, scheme_make_integer(phase)); - if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[0])) - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; - if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[2])) - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; - - if (phase == 0) { - /* Put initial requires into the table: - (This is redundant for the rename set, but we need to fill - the `all_requires' table, etc.) */ - if (env->genv->module->ii_src && SCHEME_TRUEP(SCHEME_STX_VAL(env->genv->module->ii_src))) { - Scheme_Module *iim; - Scheme_Object *nmidx, *orig_src; - - /* stx src of original import: */ - orig_src = env->genv->module->ii_src; - if (!orig_src) - orig_src = scheme_false; - else if (!SCHEME_STXP(orig_src)) - orig_src = scheme_false; - - nmidx = SCHEME_CAR(env->genv->module->requires); - iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); - - add_simple_require_renames(orig_src, rn_set, env->genv, bxs->tables, - iim, nmidx, - scheme_make_integer(0), - NULL, 1, 1); - - scheme_hash_set(bxs->modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); - } - } - - provided = (Scheme_Hash_Table *)scheme_hash_get(bxs->all_provided, scheme_make_integer(phase)); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(bxs->all_provided, scheme_make_integer(phase), (Scheme_Object *)provided); - } - - all_rt_defs = scheme_hash_tree_get(bxs->all_defs, scheme_make_integer(phase)); - if (!all_rt_defs) all_rt_defs = scheme_null; - - if (SCHEME_NULLP(body_lists)) - exp_body = scheme_null; - else { - exp_body = SCHEME_CAR(body_lists); - body_lists = SCHEME_CDR(body_lists); - } - - self_modidx = env->genv->module->self_modidx; - - /* For syntax-local-context, etc., in a d-s RHS: */ - rhs_env = scheme_new_comp_env(env->genv, env->insp, NULL, SCHEME_TOPLEVEL_FRAME); - - observer = env->observer; - rhs_env->observer = observer; - - maybe_has_lifts = 0; - lift_ctx = scheme_generate_lifts_key(); - - req_data = package_require_data(self_modidx, env->genv, env->genv->module, - rn_set, - bxs->tables, - bxs->redef_modname, - bxs->all_simple_bindings, - bxs->submodule_names); - - if (SCHEME_PAIRP(bxs->end_statementss)) { - end_statements = SCHEME_CAR(bxs->end_statementss); - bxs->end_statementss = SCHEME_CDR(bxs->end_statementss); - } else - end_statements = scheme_null; - - /* Pass 1 */ - - /* Partially expand all expressions, and process definitions, requires, - and provides. Also, flatten top-level `begin' expressions: */ - for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) { - Scheme_Object *e; - int kind; - - while (1) { - Scheme_Object *fst; - - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - e = SCHEME_STX_CAR(fm); - - p = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(xenv) - : end_statements); - prev_p = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(xenv) - : scheme_null); - scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), - p, lift_ctx, req_data, prev_p, scheme_void); - maybe_has_lifts = 1; - - { - Scheme_Expand_Info erec1; - erec1.comp = 0; - erec1.depth = -1; - erec1.pre_unwrapped = 0; - erec1.substitute_bindings = 1; - erec1.env_already = 0; - erec1.comp_flags = rec[drec].comp_flags; - e = scheme_expand_expr(e, xenv, &erec1, 0); - } - - lifted_reqs = scheme_frame_get_require_lifts(xenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) { - p = scheme_make_pair(scheme_make_pair(lifted_reqs, scheme_make_integer(LIFTREQ_MODFORM_KIND)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - fst = scheme_frame_get_lifts(xenv); - if (!SCHEME_NULLP(fst)) { - /* Expansion lifted expressions, so add them to - the front and try again. */ - *bxs->all_simple_bindings = 0; - fm = SCHEME_STX_CDR(fm); - e = introduce_to_module_context(e, rn_set); - fm = scheme_named_map_1(NULL, introduce_to_module_context, fm, rn_set); - fm = scheme_make_pair(e, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm); - } - fm = scheme_append(fst, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst); - } - } else { - /* No definition lifts added... */ - if (SCHEME_STX_PAIRP(e)) - fst = SCHEME_STX_CAR(e); - else - fst = NULL; - - if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_free_eq_x(scheme_begin_stx, fst, phase)) { - fm = SCHEME_STX_CDR(fm); - e = introduce_to_module_context(e, rn_set); - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); - } - fm = scheme_flatten_begin(e, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm); - } - if (SCHEME_STX_NULLP(fm)) { - e = scheme_frame_get_provide_lifts(xenv); - e = scheme_reverse(e); - if (expand_ends) { - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_introduce_module_context(fm, rn_set); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); - maybe_has_lifts = 0; - } else - fm = e; - if (SCHEME_NULLP(fm) && expand_ends) - fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - } - if (SCHEME_NULLP(fm)) { - e = NULL; - break; - } - } - } else - break; - } - } - if (!e) break; /* (begin) expansion at end */ - - e = introduce_to_module_context(e, rn_set); - - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); - } - - if (SCHEME_STX_PAIRP(e)) { - Scheme_Object *fst; - - fst = SCHEME_STX_CAR(e); - - if (SCHEME_STX_SYMBOLP(fst)) { - if (scheme_stx_free_eq_x(scheme_define_values_stx, fst, phase)) { - /************ define-values *************/ - Scheme_Object *vars, *val; - int var_count = 0; - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer); - } - - /* Create top-level vars; uses revert_use_site_scopes() on the vars */ - scheme_define_parse(e, &vars, &val, 0, xenv, 1); - - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name, *orig_name, *binding; - - name = SCHEME_STX_CAR(vars); - - orig_name = name; - - /* Remember the original: */ - all_rt_defs = scheme_make_pair(name, all_rt_defs); - - binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); - - if (!SCHEME_FALSEP(binding)) { - if (SCHEME_SYMBOLP(binding)) { - scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); - return NULL; - } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) - && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { - scheme_wrong_syntax(who, orig_name, e, "duplicate definition for identifier"); - return NULL; - } else if (check_already_required(required, name, phase, binding)) - warn_previously_required(env->genv->module->modname, orig_name); - } - - /* Generate symbol for this binding: */ - name = scheme_global_binding(name, env->genv, 0); - - /* Create the bucket, indicating that the name will be defined: */ - scheme_add_global_symbol(name, scheme_undefined, env->genv); - - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) - || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) - *bxs->all_simple_bindings = 0; - - vars = SCHEME_STX_CDR(vars); - var_count++; - } - - if (!(non_phaseless & NON_PHASELESS_FORM) && !phaseless_rhs(val, var_count, phase)) { - non_phaseless |= NON_PHASELESS_FORM; - non_phaseless_form = val; - } - - if (!rec[drec].comp) { - /* Reconstruct to remove scopes that don't belong on the binding names in the expansion: */ - e = scheme_datum_to_syntax(scheme_make_pair(fst, scheme_make_pair(vars, - scheme_make_pair(val, - scheme_null))), - e, e, 0, 2); - } - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - kind = DEFN_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(scheme_define_syntaxes_stx, fst, phase) - || scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { - /************ define-syntaxes & begin-for-syntax *************/ - /* Define the macro: */ - Scheme_Compile_Info mrec, erec1; - Scheme_Object *names, *orig_names, *l, *code, *m, *vec, *boundname, *frame_scopes; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Comp_Env *oenv, *eenv; - Optimize_Info *oi; - int count = 0; - int for_stx; - int max_let_depth; - - for_stx = scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase); - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - } - - if (for_stx) { - if (erec) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer); - } - if (scheme_stx_proper_list_length(e) < 0) - scheme_wrong_syntax(NULL, NULL, e, NULL); - code = e; - } else { - if (erec) { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer); - } - scheme_define_parse(e, &names, &code, 1, env, 1); - } - - if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) - boundname = SCHEME_STX_CAR(names); - else - boundname = scheme_false; - - if (erec) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer); - } - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - frame_scopes = scheme_module_context_use_site_frame_scopes(env->genv->exp_env->stx_context); - - eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, - frame_scopes, - SCHEME_KEEP_SCOPES_FRAME); - eenv->observer = observer; - if (!for_stx) - scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, - req_data, scheme_false, scheme_false); - - oenv = env; - - if (!for_stx) { - orig_names = scheme_null; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *name, *orig_name, *binding; - name = SCHEME_STX_CAR(l); - - orig_name = name; - - /* Remember the original: */ - all_rt_defs = scheme_make_pair(name, all_rt_defs); - orig_names = scheme_make_pair(name, orig_names); - - binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); - - if (!SCHEME_FALSEP(binding)) { - if (SCHEME_SYMBOLP(binding)) { - scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); - return NULL; - } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) - && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { - scheme_wrong_syntax(who, orig_name, e, - "duplicate definition for identifier"); - return NULL; - } else if (check_already_required(required, name, phase, binding)) - warn_previously_required(oenv->genv->module->modname, orig_name); - } - - /* Generate symbol for this binding: */ - name = scheme_global_binding(name, env->genv, 0); - - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) - || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) - *bxs->all_simple_bindings = 0; - - count++; - } - orig_names = scheme_reverse(orig_names); - } else - orig_names = NULL; - - if (for_stx) - names = NULL; - else - names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); - - mrec.comp = 1; - mrec.dont_mark_local_use = 0; - mrec.resolve_module_ids = 0; - mrec.substitute_bindings = 1; - mrec.pre_unwrapped = 0; - mrec.env_already = 0; - mrec.comp_flags = rec[drec].comp_flags; - - if (erec) { - erec1.comp = 0; - erec1.depth = -1; - erec1.pre_unwrapped = 0; - erec1.substitute_bindings = 1; - erec1.env_already = 0; - erec1.comp_flags = rec[drec].comp_flags; - } - - if (for_stx) { - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - if (erec) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - /* We expand & compile the for-syntax code in one pass. */ - } - m = do_module_begin_at_phase(code, eenv, - &mrec, 0, - (erec ? &erec1 : NULL), 0, - phase + 1, body_lists, - bxs); - if (erec) { - code = SCHEME_STX_CAR(code); - code = scheme_make_pair(code, SCHEME_CAR(m)); - m = SCHEME_CDR(m); - } - if (rec[drec].comp) - body_lists = SCHEME_CDR(m); - m = SCHEME_CAR(m); - /* turn list of compiled expressions into a splice: */ - m = scheme_make_sequence_compilation(m, 0, 0); - if (m->type == scheme_sequence_type) - m->type = scheme_splice_sequence_type; - } else { - if (erec) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - eenv->value_name = boundname; - eenv->observer = xenv->observer; - code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); - } - eenv->value_name = boundname; - eenv->observer = NULL; - m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); - eenv->value_name = NULL; - } - - if (!for_stx) { - lifted_reqs = scheme_frame_get_require_lifts(eenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) { - p = scheme_make_pair(scheme_make_pair(lifted_reqs, scheme_make_integer(LIFTREQ_MODFORM_KIND)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - m = scheme_letrec_check_expr(m); - - oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, env->insp, 1); - scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - m = scheme_optimize_expr(m, oi, 0); - - rp = scheme_resolve_prefix(1, eenv->prefix, env->insp); - ri = scheme_resolve_info_create(rp); - scheme_enable_expression_resolve_lifts(ri); - m = scheme_resolve_expr(m, ri); - m = scheme_merge_expression_resolve_lifts(m, rp, ri); - rp = scheme_remap_prefix(rp, ri); - - max_let_depth = scheme_resolve_info_max_let_depth(ri); - - /* Add code with names and lexical depth to exp-time body: */ - vec = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(vec)[0] = (for_stx - ? scheme_false - : ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - ? SCHEME_CAR(names) - : names)); - SCHEME_VEC_ELS(vec)[1] = m; - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(max_let_depth); - SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false); - exp_body = scheme_make_pair(vec, exp_body); - - if (eenv->prefix->unbound) - unbounds = scheme_make_pair(eenv->prefix->unbound, unbounds); - - m = scheme_sfs(m, NULL, max_let_depth); - if (scheme_startup_use_jit /* Note: not scheme_resolve_info_use_jit(ri) */) - m = scheme_jit_expr(m); - rp = scheme_prefix_eval_clone(rp); - - eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, - (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), - phase + 1, - for_stx ? scheme_false : orig_names, NULL); - - if (erec) { - if (for_stx) { - m = code; - } else { - m = SCHEME_STX_CDR(e); - m = SCHEME_STX_CAR(m); - m = scheme_make_pair(fst, - scheme_make_pair(orig_names, scheme_make_pair(code, scheme_null))); - } - e = scheme_datum_to_syntax(m, e, e, 0, 2); - } else - e = NULL; - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - - kind = DONE_MODFORM_KIND; - - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } else if (scheme_stx_free_eq_x(require_stx, fst, phase)) { - /************ require *************/ - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer); - } - - e = revert_use_site_scopes_via_context(e, rn_set, phase); - - /* Adds requires to renamings and required modules to requires lists: */ - parse_requires(e, phase, self_modidx, env->genv, env->genv->module, - rn_set, - check_require_name, bxs->tables, - bxs->redef_modname, - 0, - 1, phase ? 1 : 0, - bxs->all_simple_bindings, bxs->modidx_cache, - bxs->submodule_names, - &non_phaseless); - - if (!erec) - e = NULL; - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - kind = DONE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(provide_stx, fst, phase)) { - /************ provide *************/ - /* remember it for pass 3 */ - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_provides); - bxs->saved_provides = p; - kind = PROVIDE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(declare_stx, fst, phase)) { - /************ declare *************/ - Scheme_Object *kws, *kw; - - kws = SCHEME_STX_CDR(e); - while (SCHEME_STX_PAIRP(kws)) { - kw = SCHEME_STX_CAR(kws); - if (SCHEME_KEYWORDP(SCHEME_STX_VAL(kw))) { - if (SAME_OBJ(SCHEME_STX_VAL(kw), phaseless_keyword)) { - if (requested_phaseless) - scheme_wrong_syntax(who, kw, e, "duplicate declaration"); - requested_phaseless = 1; - } else if (SAME_OBJ(SCHEME_STX_VAL(kw), empty_namespace_keyword)) { - if (requested_empty_namespace) - scheme_wrong_syntax(who, kw, e, "duplicate declaration"); - requested_empty_namespace = 1; - } else { - scheme_wrong_syntax(who, kw, e, "unrecognized keyword"); - } - } else { - scheme_wrong_syntax(who, kw, e, "expected a keyword"); - } - kws = SCHEME_STX_CDR(kws); - } - if (!SCHEME_STX_NULLP(kws)) - scheme_wrong_syntax(who, NULL, e, IMPROPER_LIST_FORM); - - kind = DECLARE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(scheme_module_stx, fst, phase) - || scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase)) { - /************ module[*] *************/ - /* check outer syntax & name, then expand pre-module or remember for post-module pass */ - int k; - - e = handle_submodule_form(who, - e, env, phase, - rn_set, observer, - bxs, - rec, drec, erec, derec, - &k); - kind = k; - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - - if (e) { - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - fm = SCHEME_STX_CDR(fm); - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) { - e = scheme_frame_get_provide_lifts(xenv); - e = scheme_reverse(e); - if (expand_ends) { - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_introduce_module_context(fm, rn_set); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); - maybe_has_lifts = 0; - if (SCHEME_NULLP(fm)) - fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); - } else - fm = e; - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - } - } - } - /* first = a list of (cons semi-expanded-expression kind) */ - - if (!expand_ends) { - if (maybe_has_lifts) - end_statements = scheme_frame_get_end_statement_lifts(xenv); - } - - if (!phase) { - /* Check that all bindings used in phase-N expressions (for N >= 1) - were defined by now: */ - check_formerly_unbound(unbounds, env); - } - - /* Pass 2 */ - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - } - - { - /* Module and each `begin-for-syntax' group manages its own prefix: */ - Scheme_Object *frame_scopes; - frame_scopes = scheme_module_context_frame_scopes(rn_set, xenv->scopes); - cenv = scheme_new_comp_env(env->genv, env->insp, frame_scopes, - SCHEME_TOPLEVEL_FRAME | SCHEME_KEEP_SCOPES_FRAME); - cenv->observer = env->observer; - cenv->intdef_next = xenv; - } - - lift_data = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; - SCHEME_VEC_ELS(lift_data)[1] = self_modidx; - SCHEME_VEC_ELS(lift_data)[2] = rn_set; - - maybe_has_lifts = 0; - - prev_p = NULL; - expanded_l = scheme_null; - for (p = first; !SCHEME_NULLP(p); ) { - Scheme_Object *e, *l, *ll; - int kind; - - e = SCHEME_CAR(p); - kind = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - if (kind == SAVED_MODFORM_KIND) { - expanded_l = scheme_make_pair(SCHEME_CDR(e), expanded_l); - SCHEME_CAR(p) = SCHEME_CAR(e); - prev_p = p; - p = SCHEME_CDR(p); - } else if (kind == DECLARE_MODFORM_KIND) { - expanded_l = scheme_make_pair(e, expanded_l); - p = SCHEME_CDR(p); - } else if (kind == LIFTREQ_MODFORM_KIND) { - expanded_l = scheme_append(e, expanded_l); - p = SCHEME_CDR(p); - } else if ((kind == PROVIDE_MODFORM_KIND) - || (kind == MODULE_MODFORM_KIND)) { - /* handle `provide's and `module's in later passes */ - if (erec) - expanded_l = scheme_make_pair(e, expanded_l); - if (rec[drec].comp) { - if (!prev_p) - first = SCHEME_CDR(p); - else - SCHEME_CDR(prev_p) = SCHEME_CDR(p); - } - p = SCHEME_CDR(p); - } else if ((kind == EXPR_MODFORM_KIND) - || (kind == DEFN_MODFORM_KIND)) { - Scheme_Comp_Env *nenv; - - l = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(cenv) - : end_statements); - ll = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(cenv) - : scheme_null); - scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll, scheme_void); - maybe_has_lifts = 1; - - if (kind == DEFN_MODFORM_KIND) - nenv = cenv; - else - nenv = scheme_new_compilation_frame(0, 0, NULL, cenv); - - if (erec) { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, derec, &erec1, 1); - e = scheme_expand_expr(e, nenv, &erec1, 0); - expanded_l = scheme_make_pair(e, expanded_l); - } - - if (rec[drec].comp) { - Scheme_Compile_Info crec1; - scheme_init_compile_recs(rec, drec, &crec1, 1); - crec1.resolve_module_ids = 0; - nenv->observer = NULL; - e = scheme_compile_expr(e, nenv, &crec1, 0); - nenv->observer = env->observer; - } - - lifted_reqs = scheme_frame_get_require_lifts(cenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) - expanded_l = scheme_make_pair(SCHEME_CAR(expanded_l), - scheme_append(lifted_reqs, SCHEME_CDR(expanded_l))); - - l = scheme_frame_get_lifts(cenv); - if (SCHEME_NULLP(l)) { - /* No lifts - continue normally */ - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - /* Lifts - insert them and try again */ - Scheme_Object *fst; - *bxs->all_simple_bindings = 0; - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); - } - if (erec) { - e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)), - scheme_make_integer(SAVED_MODFORM_KIND)); /* kept both expanded & maybe compiled */ - /* add back expanded at correct position later: */ - expanded_l = SCHEME_CDR(expanded_l); - } else - e = scheme_make_pair(e, scheme_make_integer(DONE_MODFORM_KIND)); /* don't re-compile/-expand */ - SCHEME_CAR(p) = e; - for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = SCHEME_CAR(ll); - if (SCHEME_STX_PAIRP(SCHEME_CAR(e))) - fst = SCHEME_STX_CAR(SCHEME_CAR(e)); - else - fst = NULL; - if (fst - && (scheme_stx_free_eq3(fst, scheme_module_stx, scheme_make_integer(phase), scheme_make_integer(0)) - || scheme_stx_free_eq3(fst, scheme_modulestar_stx, scheme_make_integer(phase), scheme_make_integer(0)))) { - /* a `module` or `module*` form; handle as in first pass */ - int k; - e = handle_submodule_form(who, - e, env, phase, - rn_set, observer, - bxs, - rec, drec, erec, derec, - &k); - if (e) - e = scheme_make_pair(e, scheme_make_integer(k)); - else - e = scheme_make_pair(scheme_void, DONE_MODFORM_KIND); - } else { - e = scheme_make_pair(e, scheme_make_integer(DEFN_MODFORM_KIND)); - } - SCHEME_CAR(ll) = e; - } - p = scheme_append(l, p); - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } else { - if (erec) - expanded_l = scheme_make_pair(e, expanded_l); - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_NULLP(p) && maybe_has_lifts) { - int expr_cnt; - Scheme_Object *sp; - e = scheme_frame_get_provide_lifts(cenv); - e = scheme_reverse(e); - if (expand_ends) { - p = scheme_frame_get_end_statement_lifts(cenv); - p = scheme_reverse(p); - expr_cnt = scheme_list_length(p); - if (!SCHEME_NULLP(e)) - p = scheme_append(p, e); - } else { - p = e; - expr_cnt = 0; - } - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); - } - for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = SCHEME_CAR(ll); - if (expr_cnt <= 0) { - sp = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_provides); - bxs->saved_provides = sp; - } - e = scheme_make_pair(e, ((expr_cnt > 0) - ? scheme_make_integer(EXPR_MODFORM_KIND) - : scheme_make_integer(PROVIDE_MODFORM_KIND))); - SCHEME_CAR(ll) = e; - expr_cnt--; - } - maybe_has_lifts = 0; - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } - if (erec) expanded_l = scheme_reverse(expanded_l); - - /* If not phase 0, save end statements */ - if (!expand_ends) { - if (maybe_has_lifts) - end_statements = scheme_frame_get_end_statement_lifts(cenv); - if (!SCHEME_NULLP(end_statements) || !SCHEME_NULLP(bxs->end_statementss)) { - p = scheme_make_pair(end_statements, bxs->end_statementss); - bxs->end_statementss = p; - } - } - - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - - /* Pass 3 */ - /* if at phase 0, expand provides for all phases */ - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - } - - if (phase == 0) { - Scheme_Object *expanded_provides; - - expanded_provides = expand_all_provides(form, cenv, - (erec ? erec : rec), (erec ? derec : drec), - self_modidx, - bxs, !!erec); - - if (erec) { - expanded_provides = scheme_reverse(expanded_provides); - (void)fixup_expanded(expanded_l, expanded_provides, 0, PROVIDE_MODFORM_KIND); - } - } - - /* first = a list of compiled expressions */ - /* expanded_l = list of expanded expressions */ - - /* If compiling, drop expressions that are constants: */ - if (rec[drec].comp) { - Scheme_Object *prev = NULL, *next; - for (p = first; !SCHEME_NULLP(p); p = next) { - next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL)) { - if (prev) - SCHEME_CDR(prev) = next; - else - first = next; - } else - prev = p; - } - } - - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - - if (cenv->prefix->non_phaseless) - non_phaseless |= NON_PHASELESS_IMPORT; - - if (!phase) - env->genv->module->comp_prefix = cenv->prefix; - else - env->prefix = cenv->prefix; - - if (!SCHEME_NULLP(exp_body)) { - if (*bxs->_num_phases < phase + 2) - *bxs->_num_phases = phase + 2; - } - - if (requested_phaseless) { - if (!non_phaseless) - env->genv->module->phaseless = scheme_true; - else { - if (non_phaseless & NON_PHASELESS_IMPORT) - scheme_wrong_syntax(who, NULL, form, "cannot be cross-phase persistent due to required modules"); - else - scheme_wrong_syntax(who, non_phaseless_form, form, "does not satisfy cross-phase persistent grammar"); - } - } - - if (requested_empty_namespace) - env->genv->module->rn_stx = NULL; - - if (rec[drec].comp) { - body_lists = scheme_make_pair(first, scheme_make_pair(exp_body, body_lists)); - if (erec) - return scheme_make_pair(expanded_l, body_lists); - else - return body_lists; - } else - return expanded_l; -} - -static Scheme_Object *expand_all_provides(Scheme_Object *form, - Scheme_Comp_Env *cenv, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *self_modidx, - Module_Begin_Expand_State *bxs, - int keep_expanded) -/* expands `#%provide's for all phases in a module that is otherwise - fully expanded; returns a list of expanded forms in reverse order, - if requested by `keep_expanded'. */ -{ - Scheme_Object *saved_provides; - Scheme_Object *observer, *expanded_provides = scheme_null; - int provide_phase; - Scheme_Object *e, *ex, *fst; - Scheme_Comp_Env *pcenv; - - observer = cenv->observer; - - saved_provides = scheme_reverse(bxs->saved_provides); - while (!SCHEME_NULLP(saved_provides)) { - e = SCHEME_CAR(saved_provides); - provide_phase = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - fst = SCHEME_STX_CAR(e); - - /* Expand and add provides to table: */ - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); - } - - ex = e; - - if (provide_phase != 0) { - Scheme_Env *penv = cenv->genv; - int k; - for (k = 0; k < provide_phase; k++) { - penv = penv->exp_env; - } - if (rec[drec].comp) - pcenv = scheme_new_comp_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - else - pcenv = scheme_new_expand_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - pcenv->observer = cenv->observer; - } else { - pcenv = cenv; - } - - parse_provides(form, fst, e, provide_phase, - bxs->all_provided, bxs->all_reprovided, - self_modidx, - bxs->all_defs_out, - bxs->tables, - bxs->all_defs, - pcenv, rec, drec, - &ex); - - if (keep_expanded) - expanded_provides = scheme_make_pair(ex, expanded_provides); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - - saved_provides = SCHEME_CDR(saved_provides); - } - - return expanded_provides; -} - -static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Comp_Env *env, - Scheme_Object *l, int post, - Module_Begin_Expand_State *bxs, - int keep_expanded) -{ - Scheme_Object *mods = scheme_null, *mod, *ancestry; - - ancestry = scheme_make_pair((Scheme_Object *)env->genv, env->genv->module->submodule_ancestry); - /* do_module() will extend submodule_path */ - - env = scheme_new_compilation_frame(0, - (SCHEME_TOPLEVEL_FRAME | SCHEME_NESTED_MODULE_FRAME), - NULL, - env); - - l = scheme_reverse(l); - - while (!SCHEME_NULLP(l)) { - mod = SCHEME_CAR(l); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, SCHEME_CAR(mod)); - } - mod = do_module(SCHEME_CAR(mod), env, rec, drec, ancestry, env->genv->module->submodule_path, post, - bxs, SCHEME_CDR(mod)); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,mod); - } - - mods = scheme_make_pair(mod, mods); - - l = SCHEME_CDR(l); - } - - if (keep_expanded) - mods = scheme_reverse(mods); - - if (rec[drec].comp) { - if (post) { - env->genv->module->post_submodules = mods; - /* also reverse pres, now: */ - l = env->genv->module->pre_submodules; - if (l) { - l = scheme_reverse(l); - env->genv->module->pre_submodules = l; - } - } else { - l = env->genv->module->pre_submodules; - if (!l) l = scheme_null; - l = scheme_make_pair(SCHEME_CAR(mods), l); - env->genv->module->pre_submodules = l; - } - } else if (!SCHEME_NULLP(mods)) { - /* setting pre_submodules to '() indicates that there were submodules during expansion */ - env->genv->module->pre_submodules = scheme_null; - if (!post) { - l = env->genv->module->pre_submodule_names; - if (!l) l = scheme_null; - /* extract just the name: */ - mod = SCHEME_CAR(mods); - mod = SCHEME_STX_CDR(mod); - mod = SCHEME_STX_CAR(mod); - mod = SCHEME_STX_VAL(mod); - l = scheme_make_pair(mod, l); - env->genv->module->pre_submodule_names = l; - } - } - - return mods; -} - -static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, - Scheme_Object *expanded_provides, - int phase, int kind) -/* mutates `expanded_l' to find `#%provide's or `module's (possibly nested in - `begin-for-syntax') and replace them with the ones in - `expanded_provides'. The provides in `expanded_l' and - `expanded_provides' are matched up by order. */ -{ - Scheme_Object *p, *e, *fst, *prov_stx, *l; - - if (kind == PROVIDE_MODFORM_KIND) - prov_stx = provide_stx; - else - prov_stx = scheme_modulestar_stx; - - for (p = expanded_l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - e = SCHEME_CAR(p); - if (SCHEME_STX_PAIRP(e)) { - fst = SCHEME_STX_CAR(e); - if (scheme_stx_free_eq_x(prov_stx, fst, phase)) { - SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); - expanded_provides = SCHEME_CDR(expanded_provides); - } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { - l = scheme_flatten_syntax_list(e, NULL); - l = scheme_copy_list(l); - expanded_provides = fixup_expanded(SCHEME_CDR(l), expanded_provides, phase + 1, kind); - e = scheme_datum_to_syntax(l, e, e, 0, 2); - SCHEME_CAR(p) = e; - } - } - } - - return expanded_provides; -} - -static void check_formerly_unbound(Scheme_Object *unbounds, - Scheme_Comp_Env *env) -{ - Scheme_Object *stack = scheme_null, *lst, *p; - Scheme_Env *uenv = env->genv->exp_env; - - while (!SCHEME_NULLP(unbounds)) { - stack = scheme_null; - uenv = env->genv->exp_env; - - lst = SCHEME_CAR(unbounds); - while(1) { - while (!SCHEME_NULLP(lst)) { - p = SCHEME_CAR(lst); - if (SCHEME_PAIRP(p)) { - if (!uenv->exp_env) - scheme_signal_error("internal error: no such environment to check unbounds"); - else { - /* switch to nested list, push current list onto stack: */ - stack = scheme_make_pair(scheme_make_pair(SCHEME_CDR(lst), (Scheme_Object *)uenv), - stack); - uenv = uenv->exp_env; - lst = SCHEME_CAR(lst); - } - } else { - (void)scheme_check_top_identifier_bound(p, uenv, 1); - lst = SCHEME_CDR(lst); - } - } - if (!SCHEME_NULLP(stack)) { - lst = SCHEME_CAR(stack); - stack = SCHEME_CDR(stack); - uenv = (Scheme_Env *)SCHEME_CDR(lst); - lst = SCHEME_CAR(lst); - } else - break; - } - unbounds = SCHEME_CDR(unbounds); - } - - /* Disallow unbound variables from now on: */ - uenv = env->genv->exp_env; - while (uenv) { - uenv->disallow_unbound = 1; - uenv = uenv->exp_env; - } -} - -static int is_modulestar_stop(Scheme_Comp_Env *env) -{ - Scheme_Object *p; - p = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, scheme_sys_wraps(env), 0, 0); - p = scheme_compile_lookup(p, env, - (SCHEME_NULL_FOR_UNBOUND - + SCHEME_DONT_MARK_USE - + SCHEME_ENV_CONSTANTS_OK - + (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)), - env->in_modidx, - NULL, NULL, - NULL, NULL, NULL); - return (scheme_get_stop_expander() == p); -} - -static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx) -{ - Scheme_Object *stop, *w, *s; - - stop = scheme_get_stop_expander(); - - scheme_add_local_syntax(22, xenv); - - if (phase == 0) { - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); - scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv, 0); - scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv, 0); - scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv, 0); - *_begin_for_syntax_stx = scheme_begin_for_syntax_stx; - scheme_set_local_syntax(4, require_stx, stop, xenv, 0); - scheme_set_local_syntax(5, provide_stx, stop, xenv, 0); - scheme_set_local_syntax(6, set_stx, stop, xenv, 0); - scheme_set_local_syntax(7, app_stx, stop, xenv, 0); - scheme_set_local_syntax(8, scheme_top_stx, stop, xenv, 0); - scheme_set_local_syntax(9, lambda_stx, stop, xenv, 0); - scheme_set_local_syntax(10, case_lambda_stx, stop, xenv, 0); - scheme_set_local_syntax(11, let_values_stx, stop, xenv, 0); - scheme_set_local_syntax(12, letrec_values_stx, stop, xenv, 0); - scheme_set_local_syntax(13, if_stx, stop, xenv, 0); - scheme_set_local_syntax(14, begin0_stx, stop, xenv, 0); - scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv, 0); - scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv, 0); - scheme_set_local_syntax(17, var_ref_stx, stop, xenv, 0); - scheme_set_local_syntax(18, expression_stx, stop, xenv, 0); - scheme_set_local_syntax(19, scheme_modulestar_stx, stop, xenv, 0); - scheme_set_local_syntax(20, scheme_module_stx, stop, xenv, 0); - scheme_set_local_syntax(21, declare_stx, stop, xenv, 0); - } else { - w = scheme_sys_wraps_phase(scheme_make_integer(phase)); - s = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_set_local_syntax(0, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_set_local_syntax(1, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_set_local_syntax(2, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - scheme_set_local_syntax(3, s, stop, xenv, 0); - *_begin_for_syntax_stx = s; - s = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - scheme_set_local_syntax(4, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - scheme_set_local_syntax(5, s, stop, xenv, 0); - scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_set_local_syntax(19, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_set_local_syntax(20, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - scheme_set_local_syntax(21, s, stop, xenv, 0); - } -} - -static Scheme_Object * -module_begin_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_module_begin(form, env, rec, drec); -} - -static Scheme_Object * -module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(env->observer); - return do_module_begin(form, env, erec, drec); -} - -static void check_already_provided(Scheme_Hash_Table *provided, Scheme_Object *outname, Scheme_Object *name, - int protected, Scheme_Object *form, Scheme_Object *phase) -{ - Scheme_Object *v; - - v = scheme_hash_get(provided, outname); - if (v) { - if (!scheme_stx_free_eq2(SCHEME_CAR(v), name, phase)) - scheme_wrong_syntax("module", outname, form, "identifier already provided (as a different binding)"); - - if (protected && SCHEME_FALSEP(SCHEME_CDR(v))) - scheme_wrong_syntax("module", outname, form, "identifier already provided as unprotected"); - if (!protected && SCHEME_TRUEP(SCHEME_CDR(v))) - scheme_wrong_syntax("module", outname, form, "identifier already provided as protected"); - } -} - -int compute_reprovides(Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Module *mod_for_requires, - Scheme_Hash_Table *tables, - Scheme_Env *_genv, - int num_phases, - Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, - const char *matching_form, - Scheme_Object *all_mods, /* a phase list to use for all mods */ - Scheme_Object *all_phases) /* a module-path list for all phases */ -{ - Scheme_Hash_Table *provided, *required; - Scheme_Object *reprovided, *tvec; - int i, k, z; - Scheme_Object *rx, *provided_list, *phase, *req_phase; - Scheme_Object *all_x_defs, *all_x_defs_out; - Scheme_Env *genv; - - if (all_phases) { - /* synthesize all_reprovided for the loop below: */ - if (all_mods) - reprovided = scheme_make_pair(scheme_false, scheme_null); - else - reprovided = all_phases; - all_reprovided = scheme_make_hash_table_eqv(); - if (mod_for_requires->requires - && !SCHEME_NULLP(mod_for_requires->requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(0), reprovided); - if (mod_for_requires->et_requires - && !SCHEME_NULLP(mod_for_requires->et_requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(1), reprovided); - if (mod_for_requires->tt_requires - && !SCHEME_NULLP(mod_for_requires->tt_requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(-1), reprovided); - if (mod_for_requires->dt_requires - && !SCHEME_NULLP(mod_for_requires->dt_requires)) - scheme_hash_set(all_reprovided, scheme_false, reprovided); - if (mod_for_requires->other_requires) { - for (z = 0; z < mod_for_requires->other_requires->size; z++) { - if (mod_for_requires->other_requires->vals[z]) - scheme_hash_set(all_reprovided, - mod_for_requires->other_requires->keys[z], - reprovided); - } - } - } else if (all_mods) { - reprovided = scheme_make_pair(scheme_false, scheme_null); - all_reprovided = scheme_make_hash_table_eqv(); - while (SCHEME_PAIRP(all_mods)) { - scheme_hash_set(all_reprovided, SCHEME_CAR(all_mods), reprovided); - all_mods = SCHEME_CDR(all_mods); - } - } - - /* First, check the sanity of the re-provide specifications (unless - we synthesized them): */ - if (!all_mods) { - for (z = 0; z < all_reprovided->size; z++) { - if (all_reprovided->vals[z]) { - Scheme_Object *requires; - - reprovided = all_reprovided->vals[z]; - phase = all_reprovided->keys[z]; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - requires = mod_for_requires->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - requires = mod_for_requires->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - requires = mod_for_requires->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - requires = mod_for_requires->dt_requires; - } else { - if (mod_for_requires->other_requires) - requires = scheme_hash_get(mod_for_requires->other_requires, phase); - else - requires = NULL; - } - if (!requires) - requires = scheme_null; - - for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { - Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns; - - for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - if (same_modidx(midx, SCHEME_CAR(l))) - break; - } - if (SCHEME_NULLP(l)) { - /* Didn't require the named module */ - if (matching_form) { - Scheme_Object *name; - name = SCHEME_CAR(rx); - name = SCHEME_STX_CDR(name); - name = SCHEME_STX_CAR(name); - scheme_wrong_syntax("module", - SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path, - name, - "cannot provide from a module without a matching `%s'", - matching_form); - } else { - return 0; - } - } - - exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx))); - for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) { - /* Make sure excluded name was required: */ - Scheme_Object *a, *b, *vec = NULL; - - for (k = 0; k < tables->size; k++) { - if (tables->vals[k]) { - tvec = tables->vals[k]; - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1]; - - if (required) { - a = SCHEME_STX_CAR(l); - b = scheme_stx_lookup(a, tables->keys[k]); - if (SCHEME_VECTORP(b) - && !SAME_OBJ(SCHEME_VEC_ELS(b)[0], _genv->module->self_modidx)) - b = require_binding_to_key(required, b, SCHEME_STX_VAL(a)); - vec = scheme_hash_get(required, b); - } else - vec = NULL; - - if (vec) { - /* Check for nominal modidx in list */ - Scheme_Object *nml, *nml_modidx; - nml = SCHEME_VEC_ELS(vec)[0]; - for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { - nml_modidx = SCHEME_CAR(nml); - if (SCHEME_PAIRP(nml_modidx)) - nml_modidx = SCHEME_CAR(nml_modidx); - if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx)) - break; - } - if (!SCHEME_PAIRP(nml)) - vec = NULL; /* So it was provided, but not from the indicated module */ - } - - if (vec) - break; - } - } - if (!vec) { - a = SCHEME_STX_CAR(l); - scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)), - "excluded name was not required from the module"); - } - } - } - } - } - } - - - /* For each reprovided, walk through requires, check for re-provided bindings: */ - for (z = 0; z < all_reprovided->size; z++) { - reprovided = all_reprovided->vals[z]; - if (reprovided && !SCHEME_NULLP(reprovided)) { - phase = all_reprovided->keys[z]; - - for (k = 0; k < tables->size; k++) { - tvec = tables->vals[k]; - if (tvec) { - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1]; - req_phase = tables->keys[k]; - - for (i = required->size; i--; ) { - if (required->vals[i] && SCHEME_TRUEP(required->vals[i])) { - Scheme_Object *nominal_modidx, *outname, *nml, *orig_nml, *id; - int break_outer = 0; - - orig_nml = SCHEME_VEC_ELS(required->vals[i])[0]; - outname = SCHEME_VEC_ELS(required->vals[i])[4]; - prep_required_id(required->vals[i]); - id = SCHEME_VEC_ELS(required->vals[i])[6]; - - for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { - for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { - nominal_modidx = SCHEME_CAR(nml); - if (SCHEME_PAIRP(nominal_modidx)) - nominal_modidx = SCHEME_CAR(nominal_modidx); - if (all_mods || same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) { - Scheme_Object *nml_pi; - - if (SCHEME_PAIRP(SCHEME_CAR(nml))) - nml_pi = SCHEME_CADR(SCHEME_CAR(nml)); - else - nml_pi = scheme_make_integer(0); - - if (SAME_OBJ(phase, nml_pi)) { - Scheme_Object *exns, *ree; - - if (!all_mods) { - break_outer = 1; - - ree = SCHEME_CDR(SCHEME_CAR(rx)); - - exns = SCHEME_CDR(ree); - } else { - ree = NULL; - exns = scheme_null; - } - - for (; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - /* Was this name excluded? */ - Scheme_Object *a; - a = SCHEME_STX_VAL(SCHEME_STX_CAR(exns)); - if (SAME_OBJ(a, outname)) - break; - } - - if (SCHEME_STX_NULLP(exns)) { - /* Not excluded, so provide it. */ - if (matching_form) { - /* Assert: !all_mods */ - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, req_phase); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, req_phase, (Scheme_Object *)provided); - } - check_already_provided(provided, outname, id, 0, SCHEME_CAR(ree), req_phase); - scheme_hash_set(provided, outname, scheme_make_pair(id, scheme_false)); - } else { - provided_list = scheme_hash_get(all_provided, req_phase); - if (!provided_list) - provided_list = scheme_null; - provided_list = scheme_make_pair(id, provided_list); - scheme_hash_set(all_provided, req_phase, provided_list); - } - } - } - } - if (break_outer) break; - } - } - } - } - } - } - } - } - - /* Do all-defined provides */ - genv = _genv; - for (z = 0; z < num_phases; z++) { - all_x_defs = scheme_hash_tree_get(all_defs, scheme_make_integer(z)); - if (!all_x_defs) all_x_defs = scheme_null; - all_x_defs_out = scheme_hash_get(all_defs_out, scheme_make_integer(z)); - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(z)); - phase = scheme_make_integer(z); - - if (all_x_defs_out) { - for (; !SCHEME_NULLP(all_x_defs_out); all_x_defs_out = SCHEME_CDR(all_x_defs_out)) { - Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx, *name_sym; - int protected; - - ree = SCHEME_CAR(all_x_defs_out); - protected = SCHEME_TRUEP(SCHEME_CDR(ree)); - ree = SCHEME_CAR(ree); - ree_kw = SCHEME_CAR(ree); - ree = SCHEME_CDR(ree); - exl = SCHEME_CAR(ree); - pfx = SCHEME_CDR(ree); - - /* Make sure each excluded name was defined: */ - for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - a = SCHEME_STX_CAR(exns); - name = to_defined_symbol(a, genv); - if (!scheme_lookup_in_table(genv->toplevel, (const char *)name) - && !scheme_lookup_in_table(genv->syntax, (const char *)name)) { - scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); - } - } - - for (adl = all_x_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { - name = SCHEME_CAR(adl); - exname = SCHEME_STX_SYM(name); - name_sym = to_defined_symbol(name, genv); - - /* Was this one excluded? */ - for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - a = SCHEME_STX_CAR(exns); - a = to_defined_symbol(a, genv); - if (SAME_OBJ(a, name_sym)) - break; - } - - if (SCHEME_STX_NULLP(exns)) { - /* not excluded */ - - /* But don't export uninterned: */ - if (!SCHEME_SYM_UNINTERNEDP(exname)) { - /* Also, check that ree_kw and the identifier have the same - introduction (in case one or the other was introduced by - a macro). We perform this check by getting exname's tl_id - as if it had ree_kw's context, then comparing that result - to the actual tl_id. */ - a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); - a = to_defined_symbol(a, genv); - - if (SAME_OBJ(a, name_sym)) { - /* Add prefix, if any */ - if (SCHEME_TRUEP(pfx)) { - exname = scheme_symbol_append(pfx, exname); - } - check_already_provided(provided, exname, name, protected, ree_kw, phase); - - scheme_hash_set(provided, exname, - scheme_make_pair(name, protected ? scheme_true : scheme_false)); - } - } - } - } - } - } - - genv = _genv->exp_env; - } - - return 1; -} - -static Scheme_Object **compute_indirects(Scheme_Env *genv, - Scheme_Module_Phase_Exports *pt, - int *_count, - int vars) -{ - int i, count, j, start, end; - Scheme_Bucket **bs, *b; - Scheme_Object **exsns = pt->provide_src_names, **exss = pt->provide_srcs, **exis; - int exicount; - Scheme_Bucket_Table *t; - - if (vars) { - start = 0; - end = pt->num_provides; /* check both vars & syntax, in case of rename transformer */ - t = genv->toplevel; - } else { - start = pt->num_var_provides; - end = pt->num_provides; - t = genv->syntax; - } - - count = (t ? t->count : 0); - - if (!count) { - *_count = 0; - return NULL; - } - - bs = t->buckets; - - exis = MALLOC_N(Scheme_Object *, count); - - for (count = 0, i = t->size; i--; ) { - b = bs[i]; - if (b && b->val) { - Scheme_Object *name; - - name = (Scheme_Object *)b->key; - - /* If the name is directly provided, no need for indirect... */ - for (j = start; j < end; j++) { - if (SAME_OBJ(name, exsns[j]) - && SCHEME_FALSEP(exss[j])) - break; - } - - if (j == end) - exis[count++] = name; - } - } - - if (!count) { - *_count = 0; - return NULL; - } - - exicount = count; - - qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); - - *_count = exicount; - return exis; -} - -Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath, - Scheme_Object *mode) -{ - Scheme_Object *l, *all_mods, *all_phases; - Scheme_Hash_Table *tables, *all_reprovided, *all_provided; - int v, i; - - tables = (Scheme_Hash_Table *)SCHEME_CAR(bindings); - all_reprovided = scheme_make_hash_table_eqv(); - - if (SCHEME_FALSEP(modpath)) { - if (SAME_OBJ(mode, scheme_true)) { - all_mods = scheme_null; - all_phases = scheme_null; - } else { - all_mods = scheme_make_pair(mode, scheme_null); - all_phases = NULL; - } - } else { - Scheme_Object *reprovided; - - modpath = convert_submodule_path(modpath, check_is_submodule, - (Scheme_Object *)genv); - - reprovided = scheme_make_pair(scheme_make_pair(modpath, - scheme_make_pair(scheme_false, - scheme_null)), - scheme_null); - all_mods = NULL; - if (SAME_OBJ(mode, scheme_true)) { - all_phases = reprovided; - } else { - scheme_hash_set(all_reprovided, mode, reprovided); - all_phases = NULL; - } - } - - /* Receives result: */ - all_provided = scheme_make_hash_table_eqv(); - - v = compute_reprovides(all_provided, - all_reprovided, - genv->module, - tables, - genv, - 0, - NULL, NULL, - NULL, - all_mods, all_phases); - - if (!v) { - return scheme_false; - } else { - l = scheme_null; - for (i = 0; i < all_provided->size; i++) { - if (all_provided->vals[i]) { - l = scheme_make_pair(scheme_make_pair(all_provided->keys[i], - all_provided->vals[i]), - l); - } - } - - return l; - } -} - -static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object *in_name, Scheme_Object *noms) -{ - Scheme_Object *first = scheme_null, *last = NULL, *p, *a; - - if (SCHEME_STXP(in_name)) - in_name = SCHEME_STX_VAL(in_name); - - if (SAME_OBJ(in_name, out_name)) - return noms; - - while (SCHEME_PAIRP(noms)) { - a = SCHEME_CAR(noms); - if (SCHEME_PAIRP(a)) { - /* no change */ - } else { - a = scheme_make_pair(a, - scheme_make_pair(scheme_make_integer(0), - scheme_make_pair(in_name, - scheme_make_pair(scheme_make_integer(0), - scheme_null)))); - } - - p = scheme_make_pair(a, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - noms = SCHEME_CDR(noms); - } - - return first; -} - -static int lookup(Scheme_Env *name_env, int as_syntax, Scheme_Object *name) -{ - Scheme_Bucket_Table *bt = (as_syntax ? name_env->syntax : name_env->toplevel); - - if (!bt) return 0; - - return !!scheme_lookup_in_table(bt, (const char *)name); -} - -void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - int num_phases, Scheme_Module_Export_Info **exp_infos) -{ - int i, k, count, z; - Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase, *binding; - Scheme_Hash_Table *provided, *required; - char *exps; - int *exets; - int excount, exvcount; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *nominal_mod, *nominal_name, *nominal_in_phase, *nominal_src_phase; - Scheme_Env *name_env; - - for (z = 0; z < all_provided->size; z++) { - provided = (Scheme_Hash_Table *)all_provided->vals[z]; - - if (provided) { - phase = all_provided->keys[z]; - required = get_required_from_tables(tables, phase); - if (!required) - required = scheme_make_hash_table_equal(); - - if (SAME_OBJ(phase, scheme_make_integer(0))) - pt = me->rt; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - pt = me->et; - else if (SAME_OBJ(phase, scheme_false)) - pt = me->dt; - else { - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = phase; - if (!me->other_phases) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_eqv(); - me->other_phases = ht; - } - scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); - } - - for (count = 0, i = provided->size; i--; ) { - if (provided->vals[i]) - count++; - } - - exs = MALLOC_N(Scheme_Object *, count); - exsns = MALLOC_N(Scheme_Object *, count); - exss = MALLOC_N(Scheme_Object *, count); - exsnoms = MALLOC_N(Scheme_Object *, count); - exps = MALLOC_N_ATOMIC(char, count); - exets = MALLOC_N_ATOMIC(int, count); - memset(exets, 0, count * sizeof(int)); - - name_env = scheme_find_env_at_phase(genv, phase); - - count = 0; - exvcount = 0; - - for (k = 0; k < 2; k++) { - for (i = provided->size; i--; ) { - if (provided->vals[i]) { - Scheme_Object *name, *prnt_name, *v; - int protected, defined; - - v = provided->vals[i]; /* external name as symbol */ - name = SCHEME_CAR(v); /* internal identifier */ - protected = SCHEME_TRUEP(SCHEME_CDR(v)); - prnt_name = name; - - binding = scheme_stx_lookup_w_nominal(name, phase, - 0, - NULL, NULL, NULL, - NULL, - &nominal_mod, &nominal_name, - &nominal_in_phase, - &nominal_src_phase); - - if (SCHEME_VECTORP(binding)) { - defined = SAME_OBJ(SCHEME_VEC_ELS(binding)[0], genv->module->self_modidx); - name = SCHEME_VEC_ELS(binding)[1]; - } else { - defined = 0; - name = scheme_false; - } - - if (defined && lookup(name_env, k, name)) { - /* Defined locally */ - exs[count] = provided->keys[i]; - exsns[count] = name; - exss[count] = scheme_false; /* means "self" */ - exsnoms[count] = scheme_null; /* since "self" */ - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(phase); - count++; - } else if (defined && lookup(name_env, 1-k, name)) { - /* Skip definition for other round */ - } else if (!defined - && SCHEME_VECTORP(binding) - && (v = scheme_hash_get(required, require_binding_to_key(required, - binding, - SCHEME_STX_VAL(prnt_name))))) { - /* Required */ - if (protected) { - name = SCHEME_CAR(provided->vals[i]); - scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); - } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3]) == (k == 0)) { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); - count++; - } - } else if (!defined && SCHEME_VECTORP(binding)) { - if (k == 1) { - /* Exporting a binding that was not explicitly imported --- must be - due to a rename transformer or a macro-introduced `provide`. - We treat all such bindings as syntax, even though they - may correspond to variables. */ - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(binding)[1]; - exss[count] = SCHEME_VEC_ELS(binding)[0]; - noms = adjust_for_rename(exs[count], nominal_name, cons(nominal_mod, scheme_null)); - exsnoms[count] = noms; - exps[count] = protected; - count++; - } - } else { - /* Not defined, imported, or otherwise bound */ - char buf[32], *phase_expl; - if (phase) { - if (SCHEME_FALSEP(phase)) { - phase_expl = " for-label"; - } else { - sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); - phase_expl = scheme_strdup(buf); - } - } else - phase_expl = ""; - scheme_wrong_syntax("module", prnt_name, form, - "provided identifier not defined or imported%s", - phase_expl); - } - } - } - - if (!k) - exvcount = count; - } - - excount = count; - - /* Discard exsnom[n]s if there are no re-exports */ - for (i = 0; i < excount; i++) { - if (!SCHEME_NULLP(exsnoms[i])) - break; - } - if (i >= excount) { - exsnoms = NULL; - } - - /* Discard exets if all 0 */ - if (exets) { - for (i = 0; i < excount; i++) { - if (exets[i]) - break; - } - if (i >= excount) - exets = NULL; - } - - /* Sort provide array for variables: interned followed by - uninterned, alphabetical within each. This is important for - having a consistent provide arrays. */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1); - - /* Sort syntax, too, for deterministic output */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exvcount, excount-exvcount, 0); - - pt->num_provides = excount; - pt->num_var_provides = exvcount; - pt->provides = exs; - pt->provide_src_names = exsns; - pt->provide_srcs = exss; - pt->provide_nominal_srcs = exsnoms; - pt->provide_src_phases = exets; - - /* Discard exps if all 0 */ - if (exps) { - for (i = 0; i < excount; i++) { - if (exps[i]) - break; - } - if (i >= excount) - exps = NULL; - } - - if (exps) { - if (SCHEME_TRUEP(phase)) { - if ((SCHEME_INT_VAL(phase) < 0) - || (SCHEME_INT_VAL(phase) >= num_phases)) - scheme_signal_error("internal error: bad phase for exports"); - exp_infos[SCHEME_INT_VAL(phase)]->provide_protects = exps; - } - } - } - } -} - -/* Helper: */ -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, - char *exps, int *exets, - Scheme_Object **exsnoms, - int start, int count, int do_uninterned) -{ - int i, j; - Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; - char tmp_exp; - int tmp_exet; - - if (do_uninterned) { - /* Look for uninterned and move to end: */ - - for (j = count; j--; ) { - if (!SCHEME_SYM_WEIRDP(exs[j])) - break; - } - - for (i = start; i < j; i++) { - if (SCHEME_SYM_WEIRDP(exs[i])) { - tmp_ex = exs[i]; - exs[i] = exs[j]; - exs[j] = tmp_ex; - - if (exsns) { - tmp_exsn = exsns[i]; - tmp_exs = exss[i]; - tmp_exp = exps[i]; - - exsns[i] = exsns[j]; - exss[i] = exss[j]; - exps[i] = exps[j]; - - exsns[j] = tmp_exsn; - exss[j] = tmp_exs; - exps[j] = tmp_exp; - } - if (exets) { - tmp_exet = exets[i]; - exets[i] = exets[j]; - exets[j] = tmp_exet; - } - if (exsnoms) { - tmp_exsnom = exsnoms[i]; - - exsnoms[i] = exsnoms[j]; - - exsnoms[j] = tmp_exsnom; - } - - j--; - /* Skip over uninterns already at the end: */ - while (j) { - if (!SCHEME_SYM_WEIRDP(exs[j])) - break; - else - j--; - } - } - } - - /* Sort interned and uninterned separately: */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, j + 1, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0); - } else { - j = start; - while (count > 1) { - j = start; - pivot = exs[j]; - - for (i = 1; i < count; i++) { - int k = i + start; - if (strcmp(SCHEME_SYM_VAL(exs[k]), SCHEME_SYM_VAL(pivot)) < 0) { - tmp_ex = exs[k]; - exs[k] = exs[j]; - exs[j] = tmp_ex; - - if (exsns) { - tmp_exsn = exsns[k]; - tmp_exs = exss[k]; - tmp_exp = exps[k]; - - exsns[k] = exsns[j]; - exss[k] = exss[j]; - exps[k] = exps[j]; - - exsns[j] = tmp_exsn; - exss[j] = tmp_exs; - exps[j] = tmp_exp; - } - if (exets) { - tmp_exet = exets[k]; - exets[k] = exets[j]; - exets[j] = tmp_exet; - } - if (exsnoms) { - tmp_exsnom = exsnoms[k]; - - exsnoms[k] = exsnoms[j]; - - exsnoms[j] = tmp_exsnom; - } - - j++; - } - } - - if (j == start) { - start++; - --count; - } else - break; - } - - if (count > 1) { - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, j - start, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j, count - (j - start), 0); - } - } -} - -static Scheme_Object *expand_provide(Scheme_Object *e, int at_phase, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Expand_Info erec1; - Scheme_Thread *p; - Scheme_Object *b, *stop; - Scheme_Comp_Env *xenv; - mz_jmp_buf newbuf, * volatile savebuf; - - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_FOR_STOPS), - NULL, - cenv); - stop = scheme_get_stop_expander(); - scheme_add_local_syntax(1, xenv); - if (!at_phase) - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); - else - scheme_set_local_syntax(0, scheme_datum_to_syntax(scheme_intern_symbol("begin"), - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(at_phase)), - 0, 0), - stop, xenv, 0); - - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = -1; - - p = scheme_current_thread; - - b = scheme_make_pair((Scheme_Object *)tables, (Scheme_Object *)all_defs); - p->current_local_bindings = b; - - savebuf = p->error_buf; - p->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - Scheme_Thread *p2; - p2 = scheme_current_thread; - p2->current_local_bindings = NULL; - p2->error_buf = savebuf; - scheme_longjmp(*savebuf, 1); - return NULL; - } else { - e = scheme_expand_expr(e, xenv, &erec1, 0); - - p = scheme_current_thread; - p->current_local_bindings = NULL; - p->error_buf = savebuf; - - return e; - } -} - -void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, - int at_phase, - Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Object *self_modidx, - Scheme_Hash_Table *all_defs_out, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded) -{ - Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL, *rebuild_from = scheme_null; - int protect_cnt = 0, mode_cnt = 0, expanded = 0; - Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL; - Scheme_Object *all_x_defs_out, *all_x_defs; - Scheme_Hash_Table *provided; - Scheme_Object *phase; - - if (scheme_stx_proper_list_length(e) < 0) - scheme_wrong_syntax(NULL, e, form, IMPROPER_LIST_FORM); - - for (l = SCHEME_STX_CDR(e); !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *a, *midx, *name, *av; - - a = SCHEME_STX_CAR(l); - - while (1) { - if (SCHEME_STX_PAIRP(a) && (scheme_stx_proper_list_length(a) > 0)) { - fst = SCHEME_STX_CAR(a); - if (SCHEME_STX_SYMBOLP(fst)) - av = SCHEME_STX_VAL(fst); - else - av = NULL; - if (SAME_OBJ(protect_symbol, av)) { - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed"); - if (_expanded) - rebuild_from = scheme_make_pair(a, rebuild_from); - protect_stx = a; - a = SCHEME_STX_CDR(a); - a = scheme_flatten_syntax_list(a, NULL); - l = SCHEME_STX_CDR(l); - l = scheme_append(a, l); - protect_cnt = scheme_list_length(a); - - if (protect_cnt != 1) - expanded = 1; - - /* In case a provide ends with an empty protect: */ - if (SCHEME_STX_NULLP(l)) - break; - - a = SCHEME_STX_CAR(l); - } else if (SAME_OBJ(av, for_syntax_symbol) - || SAME_OBJ(av, for_label_symbol) - || SAME_OBJ(av, for_meta_symbol)) { - if (mode_cnt) - scheme_wrong_syntax(NULL, a, e, - (SAME_OBJ(av, for_syntax_symbol) - ? "nested `for-syntax' not allowed" - : (SAME_OBJ(av, for_label_symbol) - ? "nested `for-label' not allowed" - : "nested `for-meta' not allowed"))); - - mode_stx = a; - a = SCHEME_STX_CDR(a); - a = scheme_flatten_syntax_list(a, NULL); - if (SAME_OBJ(av, for_meta_symbol)) { - if (SCHEME_NULLP(a)) { - scheme_wrong_syntax(NULL, mode_stx, e, "missing `for-meta' phase"); - } - mode = SCHEME_CAR(a); - mode = SCHEME_STX_VAL(mode); - if (!SCHEME_FALSEP(mode) - && !SCHEME_INTP(mode) - && !SCHEME_BIGNUMP(mode)) { - scheme_wrong_syntax(NULL, mode_stx, e, "bad `for-meta' phase"); - } - a = SCHEME_CDR(a); - } else if (SAME_OBJ(av, for_syntax_symbol)) - mode = scheme_make_integer(1); - else if (SAME_OBJ(av, for_label_symbol)) - mode = scheme_false; - l = SCHEME_STX_CDR(l); - l = scheme_append(a, l); - mode_cnt = scheme_list_length(a); - if (protect_cnt) - protect_cnt += (mode_cnt - 1);; - a = SCHEME_STX_CAR(l); - } else - break; - } else - break; - } - - if (SCHEME_FALSEP(mode)) - phase = mode; - else - phase = scheme_bin_plus(mode, scheme_make_integer(at_phase)); - - all_x_defs_out = scheme_hash_get(all_defs_out, phase); - if (!all_x_defs_out) all_x_defs_out = scheme_null; - - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, phase); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, phase, (Scheme_Object *)provided); - } - - if (SCHEME_STX_SYMBOLP(a)) { - /* */ - name = SCHEME_STX_VAL(a); - check_already_provided(provided, name, a, protect_cnt, form, phase); - /* Provide a: */ - scheme_hash_set(provided, name, scheme_make_pair(a, protect_cnt ? scheme_true : scheme_false)); - } else if (SCHEME_STX_PAIRP(a)) { - Scheme_Object *rest; - - fst = SCHEME_STX_CAR(a); - rest = SCHEME_STX_CDR(a); - - if (SAME_OBJ(expand_symbol, SCHEME_STX_VAL(fst))) { - Scheme_Object *p; - int islist; - - if (SCHEME_STX_PAIRP(rest)) { - p = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "extra forms after one to expand"); - } else { - scheme_wrong_syntax(NULL, a, e, "missing form to expand"); - return; - } - - all_x_defs = scheme_hash_tree_get(all_defs, mode); - if (!all_x_defs) all_x_defs = scheme_null; - p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec); - - if (_expanded) - rebuild_from = scheme_make_pair(p, rebuild_from); - - /* Check for '(begin datum ...) result: */ - p = scheme_flatten_syntax_list(p, &islist); - if (!islist) - p = NULL; - else if (SCHEME_NULLP(p)) - p = NULL; - else { - rest = SCHEME_CAR(p); - if (!SCHEME_STX_SYMBOLP(rest) - || !scheme_stx_free_eq_x(scheme_begin_stx, rest, at_phase)) { - p = NULL; - } - } - - if (!p) { - scheme_wrong_syntax(NULL, a, e, "expansion was not a `begin' sequence"); - return; - } - - p = SCHEME_CDR(p); - l = SCHEME_STX_CDR(l); - l = scheme_make_pair(scheme_false, scheme_append(p, l)); - - if (protect_cnt) { - protect_cnt += scheme_stx_proper_list_length(p); - } - if (mode_cnt) { - mode_cnt += scheme_stx_proper_list_length(p); - } - - expanded = 1; - } else if (SAME_OBJ(rename_symbol, SCHEME_STX_VAL(fst))) { - /* (rename ) */ - Scheme_Object *inm, *enm; - - if (!SCHEME_STX_PAIRP(rest) - || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - inm = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - enm = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(inm)) - scheme_wrong_syntax(NULL, a, e, "internal name is not an identifier"); - if (!SCHEME_STX_SYMBOLP(enm)) - scheme_wrong_syntax(NULL, a, e, "external name is not an identifier"); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "data following external name"); - - enm = SCHEME_STX_VAL(enm); - - check_already_provided(provided, enm, inm, protect_cnt, a, phase); - /* Provide enm: */ - scheme_hash_set(provided, enm, scheme_make_pair(inm, protect_cnt ? scheme_true : scheme_false)); - } else if (SAME_OBJ(all_from_symbol, SCHEME_STX_VAL(fst))) { - /* (all-from ) */ - Scheme_Object *reprovided; - - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "not allowed as protected"); - if (!SCHEME_STX_PAIRP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - scheme_wrong_syntax(NULL, a, e, "data following `all-from'"); - - midx = SCHEME_STX_CAR(rest); - midx = scheme_make_modidx(scheme_syntax_to_datum(midx, 0, NULL), - self_modidx, - scheme_false); - - reprovided = scheme_hash_get(all_reprovided, mode); - if (!reprovided) - reprovided = scheme_null; - - reprovided = scheme_make_pair(scheme_make_pair(midx, scheme_make_pair(e, scheme_null)), - reprovided); - - scheme_hash_set(all_reprovided, mode, reprovided); - } else if (SAME_OBJ(all_from_except_symbol, SCHEME_STX_VAL(fst))) { - /* (all-from-except ...) */ - Scheme_Object *reprovided; - Scheme_Object *exns, *el, *p; - int len; - - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "not allowed as protected"); - - len = scheme_stx_proper_list_length(a); - - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - else if (len == 1) - scheme_wrong_syntax(NULL, a, e, "missing module name"); - - midx = SCHEME_STX_CAR(rest); - midx = scheme_make_modidx(scheme_syntax_to_datum(midx, 0, NULL), - self_modidx, - scheme_false); - exns = SCHEME_STX_CDR(rest); - - /* Check all exclusions are identifiers: */ - for (el = exns; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "excluded name is not an identifier"); - } - } - - reprovided = scheme_hash_get(all_reprovided, mode); - if (!reprovided) - reprovided = scheme_null; - - reprovided = scheme_make_pair(scheme_make_pair(midx, scheme_make_pair(e, exns)), - reprovided); - - scheme_hash_set(all_reprovided, mode, reprovided); - } else if (SAME_OBJ(struct_symbol, SCHEME_STX_VAL(fst))) { - /* (struct ( ...)) */ - int len, i; - Scheme_Object *prnt_base, *base, *fields, *el, **names, *p; - - len = scheme_stx_proper_list_length(rest); - if (len != 2) { - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - else - scheme_wrong_syntax(NULL, a, e, - "not a struct identifier followed by " - "a sequence of field identifiers"); - } - - base = SCHEME_STX_CAR(rest); - fields = SCHEME_STX_CDR(rest); - fields = SCHEME_STX_CAR(fields); - - if (!SCHEME_STX_SYMBOLP(base)) - scheme_wrong_syntax(NULL, base, e, - "struct name is not an identifier"); - - /* Check all field names are identifiers: */ - for (el = fields; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "field name is not an identifier"); - } - } - if (!SCHEME_STX_NULLP(el)) - scheme_wrong_syntax(NULL, fields, e, IMPROPER_LIST_FORM); - - prnt_base = base; - base = SCHEME_STX_VAL(base); - fields = scheme_syntax_to_datum(fields, 0, NULL); - - names = scheme_make_struct_names(base, fields, SCHEME_STRUCT_EXPTIME, &len); - - for (i = 0; i < len; i++) { - /* Wrap local name with prnt_base in case there are scopes that - trigger "gensym"ing */ - p = scheme_datum_to_syntax(names[i], scheme_false, prnt_base, 0, 0); - check_already_provided(provided, names[i], p, protect_cnt, e, phase); - scheme_hash_set(provided, names[i], - scheme_make_pair(p, protect_cnt ? scheme_true : scheme_false)); - } - } else if (SAME_OBJ(all_defined_symbol, SCHEME_STX_VAL(fst))) { - /* (all-defined) */ - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - scheme_false)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else if (SAME_OBJ(prefix_all_defined_symbol, SCHEME_STX_VAL(fst))) { - /* (prefix-all-defined ) */ - Scheme_Object *prefix; - - if (!SCHEME_STX_PAIRP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - prefix = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - - if (!SCHEME_STX_SYMBOLP(prefix)) { - scheme_wrong_syntax(NULL, a, e, - "prefix is not an identifier"); - } - prefix = SCHEME_STX_VAL(prefix); - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else if (SAME_OBJ(all_defined_except_symbol, SCHEME_STX_VAL(fst)) - || SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst))) { - /* ([prefix-]all-defined-except ...) */ - Scheme_Object *exns, *el, *prefix = scheme_false, *p; - int len, is_prefix; - - is_prefix = SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst)); - - len = scheme_stx_proper_list_length(a); - - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - - if (is_prefix && (len < 2)) - scheme_wrong_syntax(NULL, a, e, "missing prefix"); - - if (is_prefix) { - prefix = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(prefix)) - scheme_wrong_syntax(NULL, a, e, "prefix is not an identifier"); - prefix = SCHEME_STX_VAL(prefix); - rest = SCHEME_STX_CDR(rest); - } - - exns = rest; - - /* Check all exclusions are identifiers: */ - for (el = exns; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "excluded name is not an identifier"); - } - } - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(exns, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else { - scheme_wrong_syntax(NULL, a, e, NULL); - } - } else { - scheme_wrong_syntax(NULL, a, e, NULL); - } - - a = SCHEME_STX_CAR(l); - if (SCHEME_TRUEP(a)) { - if (protect_cnt) { - Scheme_Object *f; - f = SCHEME_STX_CAR(protect_stx); - a = scheme_make_pair(f, scheme_make_pair(a, scheme_null)); - a = scheme_datum_to_syntax(a, protect_stx, protect_stx, 0, 0); - } - if (!SAME_OBJ(mode, scheme_make_integer(0))) { - Scheme_Object *f; - f = SCHEME_STX_CDR(mode_stx); - f = SCHEME_STX_CAR(f); - a = scheme_make_pair(for_meta_symbol, - scheme_make_pair(f, - scheme_make_pair(a, scheme_null))); - a = scheme_datum_to_syntax(a, mode_stx, mode_stx, 0, 0); - } - rebuilt = scheme_make_pair(a, rebuilt); - } - - if (protect_cnt) - --protect_cnt; - - if (all_x_defs_out) - scheme_hash_set(all_defs_out, mode, all_x_defs_out); - - if (mode_cnt) { - --mode_cnt; - if (!mode_cnt) - mode = scheme_make_integer(0); - } - } - - if (_expanded) { - if (expanded) { - Scheme_Object *a; - a = SCHEME_STX_CAR(e); - rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt)); - rebuilt = scheme_datum_to_syntax(rebuilt, e, e, 0, 2); - - while (SCHEME_PAIRP(rebuild_from)) { - rebuilt = scheme_stx_track(rebuilt, SCHEME_CAR(rebuild_from), NULL); - rebuild_from = SCHEME_CDR(rebuild_from); - } - - *_expanded = rebuilt; - } else { - *_expanded = e; - } - } -} - -static int check_in_hash(Scheme_Object *mp, Scheme_Object *data) -{ - Scheme_Object *v; - v = scheme_hash_get((Scheme_Hash_Table *)data, mp); - return v && SAME_OBJ(v, scheme_true); -} - -static int check_is_submodule(Scheme_Object *modname, Scheme_Object *_genv) -{ - Scheme_Env *genv = (Scheme_Env *)_genv; - Scheme_Object *l, *n; - - if (genv->module) { - l = genv->module->pre_submodule_names; - if (!l) - l = genv->module->pre_submodules; - if (l) { - while (!SCHEME_NULLP(l)) { - n = SCHEME_CAR(l); - if (SCHEME_SYMBOLP(n)) { - if (SAME_OBJ(n, modname)) - return 1; - } else { - n = scheme_resolved_module_path_value(((Scheme_Module *)n)->modname); - while (SCHEME_PAIRP(SCHEME_CDR(n))) { - n = SCHEME_CDR(n); - } - n = SCHEME_CAR(n); - if (SAME_OBJ(n, modname)) - return 1; - } - l = SCHEME_CDR(l); - } - } - } - - return 0; -} - -static Scheme_Object *convert_submodule_path(Scheme_Object *name, - Convert_Submodule_Proc check, - Scheme_Object *check_data) -{ - Scheme_Object *mp, *v; - - if (SAME_OBJ(SCHEME_CAR(name), submod_symbol) - && SCHEME_PAIRP(SCHEME_CDR(name)) - && SCHEME_PAIRP(SCHEME_CDR(SCHEME_CDR(name))) - && scheme_is_list(name)) - mp = SCHEME_CADR(name); - else - mp = name; - - if (SCHEME_PAIRP(mp) - && SAME_OBJ(SCHEME_CAR(mp), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(mp)) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(mp)))) { - mp = SCHEME_CADR(mp); - if (check(mp, check_data)) { - /* convert to `submod' format */ - if (SAME_OBJ(SCHEME_CAR(name), submod_symbol)) - v = SCHEME_CDR(SCHEME_CDR(name)); - else - v = scheme_null; - name = scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - scheme_make_pair(mp, v))); - } - } - - return name; -} - -Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *genv) -{ - Scheme_Object *modname, *l, *modidx, *stx, *phase, *result; - Scheme_Module *m; - int i, j; - Scheme_Module_Phase_Exports *pt; - - if (SCHEME_STXP(modpath)) { - stx = modpath; - modpath = scheme_syntax_to_datum(stx, 0, NULL); - } else - stx = NULL; - - modpath = convert_submodule_path(modpath, check_is_submodule, - (Scheme_Object *)genv); - - modidx = scheme_make_modidx(modpath, - (genv->module ? genv->module->self_modidx : scheme_false), - scheme_false); - - modname = _module_resolve(modidx, stx, NULL, 1); - - m = module_load(modname, genv, "syntax-local-module-exports"); - - if (!m) { - /* Can we get here? */ - return scheme_null; - } else { - result = scheme_null; - - for (i = -3; i < (m->me->other_phases ? m->me->other_phases->size : 0); i++) { - l = scheme_null; - switch (i) { - case -3: - pt = m->me->rt; - phase = scheme_make_integer(0); - break; - case -2: - pt = m->me->et; - phase = scheme_make_integer(1); - break; - case -1: - pt = m->me->dt; - phase = scheme_false; - break; - default: - pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[i]; - phase = m->me->other_phases->keys[i]; - break; - } - if (pt) { - for (j = 0; j < pt->num_provides; j++) { - l = scheme_make_pair(pt->provides[j], l); - } - - result = scheme_make_pair(scheme_make_pair(phase, l), - result); - } - } - - return result; - } -} - -static int expression_starts(Scheme_Object *expr, Scheme_Object *id, int phase) -{ - if (SCHEME_STX_PAIRP(expr)) { - expr = SCHEME_STX_CAR(expr); - if (SCHEME_STX_SYMBOLP(expr)) { - if (scheme_stx_free_eq_x(id, expr, phase)) - return 1; - } - } - - return 0; -} - -static int expression_starts_app(Scheme_Object *expr, Scheme_Object *id, int phase) -{ - if (expression_starts(expr, app_stx, phase)) { - expr = SCHEME_STX_CDR(expr); - return expression_starts(expr, id, phase); - } else if (expression_starts(expr, id, phase)) { - /* would explicit `#%app' be the core one? */ - id = scheme_datum_to_syntax(SCHEME_STX_VAL(app_stx), expr, expr, 0, 0); - id = scheme_stx_taint_rearm(id, expr); - if (scheme_stx_free_eq_x(app_stx, id, phase)) - return 1; - } - - return 0; -} - -static Scheme_Object *expression_app_args(Scheme_Object *expr, int phase) -{ - if (expression_starts(expr, app_stx, phase)) { - expr = SCHEME_STX_CDR(expr); - return SCHEME_STX_CDR(expr); - } else - return SCHEME_STX_CDR(expr); -} - -static int phaseless_literal(Scheme_Object *val) -{ - val = SCHEME_STX_VAL(val); - - if (SCHEME_BOOLP(val) - || SCHEME_SYMBOLP(val) - || SCHEME_KEYWORDP(val) - || SCHEME_NULLP(val) - || SCHEME_NUMBERP(val) - || (SCHEME_CHAR_STRINGP(val) && SCHEME_IMMUTABLEP(val)) - || (SCHEME_BYTE_STRINGP(val) && SCHEME_IMMUTABLEP(val))) - return 1; - - return 0; -} - -static int phaseless_constant_expression(Scheme_Object *val, int phase); - -static int phaseless_constant_expressions(Scheme_Object *expr, int phase) -{ - Scheme_Object *a; - - while (SCHEME_STX_PAIRP(expr)) { - a = SCHEME_STX_CAR(expr); - if (!phaseless_constant_expression(a, phase)) - return 0; - expr = SCHEME_STX_CDR(expr); - } - - return SCHEME_STX_NULLP(expr); -} - -static Scheme_Object *phaseless_constant_expression_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *val = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - if (phaseless_constant_expression(val, p->ku.k.i1)) - return scheme_true; - else - return scheme_false; -} - -static int phaseless_constant_expression(Scheme_Object *val, int phase) -{ -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)val; - p->ku.k.i1 = phase; - val = scheme_handle_stack_overflow(phaseless_constant_expression_k); - return SCHEME_TRUEP(val); - } - - /* identifier? */ - if (SCHEME_SYMBOLP(SCHEME_STX_VAL(val))) - return 1; - - if (expression_starts(val, lambda_stx, phase)) - return 1; - - if (expression_starts(val, case_lambda_stx, phase)) - return 1; - - if (expression_starts(val, quote_stx, phase)) { - val = SCHEME_STX_CDR(val); - if (SCHEME_STX_PAIRP(val)) { - val = SCHEME_STX_CAR(val); - if (phaseless_literal(val)) - return 1; - } - return 0; - } else if (expression_starts(val, datum_stx, phase)) { - val = SCHEME_STX_CDR(val); - if (phaseless_literal(val)) - return 1; - return 0; - } else if (phaseless_literal(val)) { - /* would explicit `#%datum' be the core one? */ - Scheme_Object *a; - a = SCHEME_STX_VAL(datum_stx); - val = scheme_stx_taint_rearm(scheme_datum_to_syntax(a, val, val, 0, 0), - val); - if (scheme_stx_free_eq_x(datum_stx, val, phase)) - return 1; - return 0; - } - - if (expression_starts_app(val, cons_stx, phase) - || expression_starts_app(val, list_stx, phase)) { - val = expression_app_args(val, phase); - return phaseless_constant_expressions(val, phase); - } - - return 0; -} - -static int expression_string_argument(Scheme_Object *val, int phase) -{ - Scheme_Object *a, *av; - - if (SCHEME_STX_PAIRP(val)) { - a = SCHEME_STX_CAR(val); - val = SCHEME_STX_CDR(val); - if (SCHEME_STX_NULLP(val)) { - av = SCHEME_STX_VAL(a); - if (SCHEME_CHAR_STRINGP(av) - && phaseless_constant_expression(a, phase)) - return 1; - else if (expression_starts(a, quote_stx, phase)) { - val = SCHEME_STX_CDR(a); - if (SCHEME_STX_PAIRP(val)) { - val = SCHEME_STX_CAR(val); - a = SCHEME_STX_VAL(val); - if (SCHEME_CHAR_STRINGP(a)) - return 1; - } - } - } - } - - return 0; -} - -static int phaseless_rhs(Scheme_Object *val, int var_count, int phase) -{ - if (var_count == 1) { - if (phaseless_constant_expression(val, phase)) - return 1; - else if (expression_starts_app(val, gensym_stx, phase)) { - val = expression_app_args(val, phase); - if (SCHEME_STX_NULLP(val)) - return 1; - else if (expression_string_argument(val, phase)) - return 1; - } else if (expression_starts_app(val, string_to_uninterned_symbol_stx, phase)) { - val = expression_app_args(val, phase); - if (expression_string_argument(val, phase)) - return 1; - } - } else if (var_count == 5) { - if (expression_starts_app(val, make_struct_type_stx, phase) - && phaseless_constant_expressions(val, phase)) { - return 1; - } - } else if (var_count == 3) { - if (expression_starts_app(val, make_struct_type_property_stx, phase) - && phaseless_constant_expressions(val, phase)) { - return 1; - } - } - - return 0; -} - -/**********************************************************************/ -/* top-level require */ -/**********************************************************************/ - -void add_single_require(Scheme_Module_Exports *me, /* from module */ - Scheme_Object *only_phase, - Scheme_Object *src_phase_index, /* import from phase 0 to src_phase_index */ - Scheme_Object *idx, /* from module's idx; may be saved for unmarshalling */ - Scheme_Env *orig_env, /* env for scope_src or copy_vars */ - Scheme_Object *rn_set, /* add requires to renames in this set when no scope_src */ - Scheme_Object *rn_stx, /* module context-as-stx that corresponds to all_simple */ - Scheme_Object *exns, /* NULL or [syntax] list of [syntax] symbols not to import */ - Scheme_Hash_Table *onlys, /* NULL or hash table of names to import; the hash table is mutated */ - Scheme_Object *prefix, /* NULL or prefix symbol */ - Scheme_Object *iname, /* NULL or symbol for a single import */ - Scheme_Object *orig_ename, /* NULL or symbol for a single import */ - Scheme_Object *scope_src, /* default scope_src; if onlys, each is also scope_src */ - int copy_vars, - int *all_simple, - Check_Func ck, /* NULL or called for each addition */ - void *data, - Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *cki, /* ck args */ - Scheme_Hash_Table *collapse_table) /* hints for collapsing to a shared table */ -{ - int j, var_count; - Scheme_Object *to_phase; - Scheme_Object **exs, **exsns, **exss; - int *exets; - Scheme_Object *nominal_modidx, *one_exn, *name, *rn, *ename = orig_ename; - Scheme_Hash_Table *orig_onlys; - int k, shared_rename, do_copy_vars; - Scheme_Env *name_env; - int can_save_marshal = 1; - - if (scope_src) { - if (all_simple - && *all_simple - && rn_stx - && SCHEME_STXP(rn_stx) - && !scheme_stx_equal_module_context(scope_src, rn_stx)) - *all_simple = 0; - } - - if (iname || ename || onlys) - can_save_marshal = 0; - - if (onlys) - orig_onlys = scheme_clone_hash_table(onlys); - else - orig_onlys = NULL; - - for (k = -3; k < (me->other_phases ? me->other_phases->size : 0); k++) { - Scheme_Module_Phase_Exports *pt; - - switch(k) { - case -3: - pt = me->rt; - break; - case -2: - pt = me->et; - break; - case -1: - pt = me->dt; - break; - default: - pt = (Scheme_Module_Phase_Exports *)me->other_phases->vals[k]; - break; - } - - if (pt && only_phase) { - if (!scheme_eqv(pt->phase_index, only_phase)) - pt = NULL; - } - - name_env = orig_env; - if (pt) { - if (SCHEME_FALSEP(pt->phase_index) - || SCHEME_FALSEP(src_phase_index)) { - to_phase = scheme_false; - scheme_prepare_label_env(name_env); - name_env = name_env->label_env; - } else { - if (orig_env) { - to_phase = pt->phase_index; - while (SCHEME_INT_VAL(to_phase) > 0) { - scheme_prepare_exp_env(name_env); - name_env = name_env->exp_env; - to_phase = scheme_bin_minus(to_phase, scheme_make_integer(1)); - } - while (SCHEME_INT_VAL(to_phase) < 0) { - scheme_prepare_template_env(name_env); - name_env = name_env->template_env; - to_phase = scheme_bin_plus(to_phase, scheme_make_integer(1)); - } - } - to_phase = scheme_bin_plus(pt->phase_index, src_phase_index); - } - } else - to_phase = NULL; - - if (pt) { - one_exn = NULL; - - nominal_modidx = idx; - - rn = scheme_module_context_at_phase(rn_set, to_phase); - - if (copy_vars) - do_copy_vars = !orig_env->module && !orig_env->phase && SAME_OBJ(src_phase_index, scheme_make_integer(0)) && (k == -3); - else - do_copy_vars = 0; - - if (can_save_marshal - && !orig_ename - && pt->num_provides - && !do_copy_vars) { - /* Simple "import everything" (possibly with prefix and exceptions) - whose mappings can be shared via the exporting module: */ - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - shared_rename = 1; - } else - shared_rename = 0; - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - var_count = pt->num_var_provides; - - for (j = pt->num_provides; j--; ) { - Scheme_Object *modidx; - - if (orig_ename) { - if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) - continue; /* we don't want this one. */ - } else if (onlys) { - name = scheme_hash_get(orig_onlys, exs[j]); - if (!name) - continue; /* we don't want this one. */ - scope_src = name; - /* Remove to indicate that it's been imported: */ - scheme_hash_set(onlys, exs[j], NULL); - } else { - if (exns) { - Scheme_Object *l, *a; - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - if (SAME_OBJ(a, exs[j])) - break; - } - if (!SCHEME_STX_NULLP(l)) - continue; /* we don't want this one. */ - } - - if (one_exn) { - if (SAME_OBJ(one_exn, exs[j])) - continue; /* we don't want this one. */ - } - } - - modidx = ((exss && !SCHEME_FALSEP(exss[j])) - ? scheme_modidx_shift(exss[j], me->src_modidx, idx) - : idx); - - if (SCHEME_SYM_WEIRDP(exs[j])) { - /* This shouldn't happen. In case it does, don't import a - gensym or parallel symbol. The former is useless. The - latter is supposed to be module-specific, and it could - collide with local module-specific ids. */ - iname = NULL; - continue; - } - - if (!iname) - iname = exs[j]; - - if (prefix) - iname = scheme_symbol_append(prefix, iname); - - if (scope_src) - iname = scheme_datum_to_syntax(iname, scheme_false, scope_src, 0, 0); - else { - iname = scheme_datum_to_syntax(iname, scheme_false, scheme_false, 0, 0); - iname = scheme_stx_add_module_context(iname, rn); - } - - if (ck) - ck(iname, (orig_env->module ? orig_env->module->self_modidx : NULL), - nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, - (j < var_count), - data, cki, form, err_src, scope_src, to_phase, src_phase_index, pt->phase_index); - - { - int done; - - if (do_copy_vars && (j < var_count)) { - Scheme_Env *menv; - Scheme_Object *val, *modname; - Scheme_Bucket *b; - modname = scheme_module_resolve(modidx, 1); - menv = scheme_module_access(modname, orig_env, 0); - val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); - b = scheme_global_bucket(scheme_global_binding(iname, orig_env, 0), orig_env); - scheme_set_global_bucket(((copy_vars == 2) - ? "namespace-require/constant" - : "namespace-require/copy"), - b, val, 1); - if (copy_vars == 2) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - done = 0; - } else { - scheme_shadow(orig_env, (Scheme_Object *)b->key, val, 1); - done = 1; - } - } else - done = 0; - - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - - if (!done && !shared_rename) { - scheme_add_module_binding_w_nominal(iname, to_phase, - modidx, exsns[j], (exets - ? scheme_make_integer(exets[j]) - : scheme_make_integer(0)), - scheme_module_context_inspector(rn), - nominal_modidx, exs[j], - src_phase_index, - pt->phase_index, - pt, collapse_table); - } - } - - iname = NULL; - - if (ename) { - ename = NULL; - break; - } - } - - if (shared_rename) { - Scheme_Hash_Tree *excepts; - - if (exns) { - Scheme_Object *l, *a; - excepts = scheme_make_hash_tree(SCHEME_hashtr_eq); - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - excepts = scheme_hash_tree_set(excepts, a, scheme_true); - } - } else - excepts = NULL; - - scheme_extend_module_context_with_shared(rn, idx, pt, - (prefix ? prefix : scheme_false), - excepts, - src_phase_index, scope_src, - NULL); - } - } - } - - if (ename) { - scheme_wrong_syntax(NULL, ename, form, "no such provided variable"); - return; - } -} - -void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, - Scheme_Object *context, - Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, - Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ - Scheme_Hash_Tree *excepts, /* NULL => empty */ - Scheme_Hash_Table *export_registry, - Scheme_Object *insp_desc, Scheme_Object *req_insp_desc, - Scheme_Object *replace_at) -{ - Scheme_Object *name; - Scheme_Module_Exports *me; - Scheme_Env *env; - Scheme_Module *mod; - Scheme_Module_Phase_Exports *pt; - - name = scheme_module_resolve(modidx, 0); - - mod = get_special_module(name); - if (mod) - me = mod->me; - else - me = NULL; - - if (!me) { - if (!export_registry) { - env = scheme_get_env(scheme_current_config()); - export_registry = env->module_registry->exports; - } - - me = (Scheme_Module_Exports *)scheme_hash_get(export_registry, name); - if (!me) { - scheme_signal_error("compiled/expanded code out of context;" - " cannot find exports to restore imported renamings" - " for module: %D", - name); - return; - } - } - - if (SAME_OBJ(pt_phase, scheme_make_integer(0))) - pt = me->rt; - else if (SAME_OBJ(pt_phase, scheme_make_integer(1))) - pt = me->et; - else if (SAME_OBJ(pt_phase, scheme_false)) - pt = me->dt; - else if (me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(me->other_phases, pt_phase); - else - pt = NULL; - - if (pt) { - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - scheme_extend_module_context_with_shared(scheme_make_pair(bind_phase, req_insp_desc), - req_modidx, pt, - prefix, excepts, - src_phase, context, - replace_at); - } -} - -Scheme_Object *scheme_get_kernel_modidx(void) -{ - return kernel_modidx; -} - -void parse_requires(Scheme_Object *form, int at_phase, - Scheme_Object *base_modidx, - Scheme_Env *main_env, - Scheme_Module *for_m, - Scheme_Object *rn_set, - Check_Func ck, void *data, - Scheme_Object *redef_modname, - int copy_vars, - int eval_exp, int eval_run, - int *all_simple, - Scheme_Hash_Table *modidx_cache, - Scheme_Hash_Table *submodule_names, - int *non_phaseless) -/* form can be a module-path index or a quoted require spec */ -{ - Scheme_Object *ll = form, *mode = scheme_make_integer(0), *just_mode = NULL, *x_mode, *x_just_mode; - Scheme_Module *m; - Scheme_Object *idxstx, *idx, *name, *i, *exns, *prefix, *iname, *ename, *aa, *aav; - Scheme_Object *scope_src, *err_src; - Scheme_Hash_Table *onlys; - Scheme_Env *env; - int skip_one, mode_cnt = 0, just_mode_cnt = 0, is_mpi; - Scheme_Hash_Table *collapse_table; - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_module_index_type)) { - ll = scheme_make_pair(scheme_false, scheme_make_pair(form, scheme_null)); - is_mpi = 1; - } else { - if (scheme_stx_proper_list_length(form) < 0) - scheme_wrong_syntax(NULL, NULL, form, IMPROPER_LIST_FORM); - is_mpi = 0; - } - - collapse_table = scheme_make_hash_table(SCHEME_hash_ptr); - - for (ll = SCHEME_STX_CDR(ll); !SCHEME_STX_NULLP(ll); ll = SCHEME_STX_CDR(ll)) { - i = SCHEME_STX_CAR(ll); - iname = ename = NULL; - onlys = NULL; - if (SCHEME_STX_PAIRP(i)) { - aa = SCHEME_STX_CAR(i); - aav = SCHEME_STX_VAL(aa); - } else { - aa = NULL; - aav = NULL; - } - - err_src = i; - scope_src = i; - skip_one = 0; - - if (is_mpi) { - idxstx = i; - exns = NULL; - prefix = NULL; - scope_src = NULL; - } else if (SAME_OBJ(for_syntax_symbol, aav) - || SAME_OBJ(for_template_symbol, aav) - || SAME_OBJ(for_label_symbol, aav) - || SAME_OBJ(for_meta_symbol, aav) - || SAME_OBJ(just_meta_symbol, aav)) { - if (!SAME_OBJ(just_meta_symbol, aav)) { - if (mode_cnt) - scheme_wrong_syntax(NULL, i, form, - (SAME_OBJ(for_syntax_symbol, aav) - ? "nested `for-syntax' not allowed" - : (SAME_OBJ(for_template_symbol, aav) - ? "nested `for-template' not allowed" - : (SAME_OBJ(for_label_symbol, aav) - ? "nested `for-label' not allowed" - : "nested `for-meta' not allowed")))); - } else { - if (just_mode_cnt) - scheme_wrong_syntax(NULL, i, form, "nested `just-meta' not allowed"); - } - - aa = scheme_flatten_syntax_list(i, NULL); - ll = SCHEME_STX_CDR(ll); - if (SAME_OBJ(for_meta_symbol, aav) - || SAME_OBJ(just_meta_symbol, aav)) { - Scheme_Object *a_mode; - aa = SCHEME_STX_CDR(aa); - if (SCHEME_STX_NULLP(aa)) - scheme_wrong_syntax(NULL, i, form, "missing `%s-meta' level specification", - (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - a_mode = SCHEME_STX_CAR(aa); - a_mode = SCHEME_STX_VAL(a_mode); - if (!SCHEME_FALSEP(a_mode) - && !SCHEME_INTP(a_mode) - && !SCHEME_BIGNUMP(a_mode)) - scheme_wrong_syntax(NULL, i, form, "bad `%s-meta' level specification", - (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - if (SAME_OBJ(for_meta_symbol, aav)) { - if (SCHEME_FALSEP(a_mode)) - mode = a_mode; - else - mode = scheme_bin_plus(a_mode, scheme_make_integer(0)); - } else - just_mode = a_mode; - } else { - if (SAME_OBJ(for_syntax_symbol, aav)) - mode = scheme_make_integer(1); - else if (SAME_OBJ(for_template_symbol, aav)) - mode = scheme_make_integer(-1); - else - mode = scheme_false; - } - ll = scheme_append(aa, ll); - - if (!SAME_OBJ(just_meta_symbol, aav)) { - mode_cnt = scheme_list_length(aa); - if (just_mode_cnt) - just_mode_cnt += (mode_cnt - 1); - } else { - just_mode_cnt = scheme_list_length(aa); - if (mode_cnt) - mode_cnt += (just_mode_cnt - 1); - } - - skip_one = 1; - } else if (aa && SAME_OBJ(prefix_symbol, SCHEME_STX_VAL(aa))) { - /* prefix */ - int len; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len != 3) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else if (len < 2) - reason = "prefix missing"; - else if (len < 3) - reason = "module name missing"; - else - reason = "extra data after module name"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - i = SCHEME_STX_CDR(i); - prefix = SCHEME_STX_CAR(i); - i = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(i); - exns = NULL; - - if (!SCHEME_SYMBOLP(SCHEME_STX_VAL(prefix))) { - scheme_wrong_syntax(NULL, prefix, form, "bad prefix (not an identifier)"); - return; - } - - prefix = SCHEME_STX_VAL(prefix); - - } else if (aa && (SAME_OBJ(all_except_symbol, SCHEME_STX_VAL(aa)) - || SAME_OBJ(prefix_all_except_symbol, SCHEME_STX_VAL(aa)))) { - /* all-except and prefix-all-except */ - Scheme_Object *l; - int len; - int has_prefix; - - if (all_simple) - *all_simple = 0; - - has_prefix = SAME_OBJ(prefix_all_except_symbol, SCHEME_STX_VAL(aa)); - - len = scheme_stx_proper_list_length(i); - if (len < 0) - scheme_wrong_syntax(NULL, i, form, IMPROPER_LIST_FORM); - else if (has_prefix && (len < 2)) - scheme_wrong_syntax(NULL, i, form, "prefix missing"); - else if (len < (has_prefix ? 3 : 2)) - scheme_wrong_syntax(NULL, i, form, "module name missing"); - - idxstx = SCHEME_STX_CDR(i); - if (has_prefix) { - prefix = SCHEME_STX_CAR(idxstx); - idxstx = SCHEME_STX_CDR(idxstx); - - if (!SCHEME_SYMBOLP(SCHEME_STX_VAL(prefix))) { - scheme_wrong_syntax(NULL, prefix, form, "prefix is not an identifier"); - return; - } - prefix = SCHEME_STX_VAL(prefix); - } else - prefix = NULL; - exns = SCHEME_STX_CDR(idxstx); - idxstx = SCHEME_STX_CAR(idxstx); - - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) { - l = SCHEME_STX_CAR(l); - scheme_wrong_syntax(NULL, l, form, - "excluded name is not an identifier"); - } - } - if (SCHEME_STX_NULLP(exns)) - exns = NULL; - } else if (aa && SAME_OBJ(only_symbol, SCHEME_STX_VAL(aa))) { - /* only */ - int len; - Scheme_Object *rest, *nm; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len < 2) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else - reason = "module name missing"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - onlys = scheme_make_hash_table(SCHEME_hash_ptr); - - rest = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - while (SCHEME_STX_PAIRP(rest)) { - nm = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(nm)) { - scheme_wrong_syntax(NULL, nm, form, "name for `only' is not an identifier"); - } - scheme_hash_set(onlys, SCHEME_STX_VAL(nm), nm); - rest = SCHEME_STX_CDR(rest); - } - - scope_src = NULL; - exns = NULL; - prefix = NULL; - } else if (aa && SAME_OBJ(rename_symbol, SCHEME_STX_VAL(aa))) { - /* rename */ - int len; - Scheme_Object *rest; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len != 4) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else if (len < 2) - reason = "module name missing"; - else if (len < 3) - reason = "internal name missing"; - else if (len < 4) - reason = "external name missing"; - else - reason = "extra data after external name"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - rest = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - iname = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - ename = SCHEME_STX_CAR(rest); - - if (!SCHEME_STX_SYMBOLP(iname)) - scheme_wrong_syntax(NULL, i, form, "internal name is not an identifier"); - if (!SCHEME_STX_SYMBOLP(ename)) - scheme_wrong_syntax(NULL, i, form, "external name is not an identifier"); - - scope_src = iname; - - iname = SCHEME_STX_VAL(iname); - - prefix = NULL; - exns = NULL; - } else { - idxstx = i; - exns = NULL; - prefix = NULL; - } - - if (!skip_one) { - int start = 1; - Scheme_Env *rename_env; - - if (SCHEME_FALSEP(mode)) { - start = 0; - scheme_prepare_label_env(main_env); - env = main_env->label_env; - rename_env = main_env; - } else if (scheme_is_positive(mode)) { - Scheme_Object *n = mode; - env = main_env; - do { - scheme_prepare_exp_env(env); - env = env->exp_env; - n = scheme_bin_minus(n, scheme_make_integer(1)); - } while (scheme_is_positive(n)); - rename_env = env; - } else if (scheme_is_negative(mode)) { - Scheme_Object *n = mode; - env = main_env; - do { - scheme_prepare_template_env(env); - env = env->template_env; - n = scheme_bin_plus(n, scheme_make_integer(1)); - } while (scheme_is_negative(n)); - rename_env = env; - } else { - env = main_env; - rename_env = env; - } - - if (is_mpi) { - idx = form; - } else { - name = scheme_syntax_to_datum(idxstx, 0, NULL); - - if (submodule_names && SCHEME_PAIRP(name)) { - /* check for 'x where x is a submodule name */ - name = convert_submodule_path(name, check_in_hash, - (Scheme_Object *)submodule_names); - } - - if (modidx_cache) - idx = scheme_hash_get(modidx_cache, name); - else - idx = NULL; - if (!idx) { - if (SCHEME_PAIRP(name) - && SAME_OBJ(SCHEME_CAR(name), submod_symbol) - && SCHEME_PAIRP(SCHEME_CDR(name)) - && SCHEME_PATHP(SCHEME_CADR(name))) { - idx = scheme_make_modidx(SCHEME_CADR(name), base_modidx, scheme_false); - idx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - SCHEME_CDDR(name))), - idx, - scheme_false); - } else - idx = scheme_make_modidx(name, base_modidx, scheme_false); - if (modidx_cache) - scheme_hash_set(modidx_cache, name, idx); - } - } - - name = _module_resolve(idx, idxstx, NULL, 1); - - m = module_load(name, env, NULL); - - start_module(m, env, 0, idx, - start ? eval_exp : 0, start ? eval_run : 0, - main_env->phase, scheme_null, 0); - - if (non_phaseless && !m->phaseless) - *non_phaseless |= NON_PHASELESS_IMPORT; - - x_just_mode = just_mode; - x_mode = mode; - if (at_phase) { - if (x_mode && SCHEME_TRUEP(x_mode)) { - x_mode = scheme_bin_plus(x_mode, scheme_make_integer(at_phase)); - } - /* x_just_mode refers to the mode at export, which doesn't shift - by phase context at import */ - } - - /* Add name to require list, if it's not there: */ - if (main_env->module) { - Scheme_Object *reqs; - if (SAME_OBJ(x_mode, scheme_make_integer(0))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->requires); - main_env->module->requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_make_integer(1))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->et_requires); - main_env->module->et_requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_make_integer(-1))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->tt_requires); - main_env->module->tt_requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_false)) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->dt_requires); - main_env->module->dt_requires = reqs; - } else { - Scheme_Hash_Table *oht; - oht = main_env->module->other_requires; - if (!oht) { - oht = scheme_make_hash_table_eqv(); - main_env->module->other_requires = oht; - } - reqs = scheme_hash_get(oht, x_mode); - if (!reqs) - reqs = scheme_null; - reqs = add_req(scheme_make_pair(idx, scheme_null), reqs); - scheme_hash_set(oht, x_mode, reqs); - } - } - - if (SAME_TYPE(SCHEME_TYPE(idx), scheme_resolved_module_path_type)) - idx = scheme_resolved_module_path_to_modidx(idx); - - add_single_require(m->me, x_just_mode, x_mode, idx, rename_env, - rn_set, (for_m ? for_m->rn_stx : NULL), - exns, onlys, prefix, iname, ename, - scope_src, - copy_vars, - all_simple, - ck, data, - form, err_src, i, - collapse_table); - - if (onlys && onlys->count) { - /* Something required in `only' wasn't provided by the module */ - int k; - for (k = 0; k < onlys->size; k++) { - if (onlys->vals[k]) - scheme_wrong_syntax(NULL, onlys->vals[k], form, "no such provided variable"); - } - } - } - - if (mode_cnt) { - --mode_cnt; - if (!mode_cnt) - mode = scheme_make_integer(0); - } - if (just_mode_cnt) { - --just_mode_cnt; - if (!just_mode_cnt) - just_mode = NULL; - } - } -} - -static void check_dup_require(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, - Scheme_Object *modidx, Scheme_Object *srcname, int exet, - int isval, void *ht, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) -{ - Scheme_Object *binding; - - binding = scheme_stx_lookup_exact(id, to_phase); - if (SCHEME_FALSEP(binding)) { - /* not bound, so import is ok */ - } else if (SCHEME_VECTORP(binding) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], srcname) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) - && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { - /* import is redunant, but ok */ - } else if (SCHEME_VECTORP(binding) - && SCHEME_FALSEP(SCHEME_VEC_ELS(binding)[0])) { - /* shadowing a top-level definition is ok */ - } else { - scheme_wrong_syntax(NULL, id, form, "duplicate import identifier"); - } -} - -static Scheme_Object *check_require_form(Scheme_Env *env, Scheme_Object *form) -{ - Scheme_Hash_Table *ht; - Scheme_Object *rest, *modidx; - Scheme_Env *tmp_env; - - if (env->module) - modidx = env->module->self_modidx; - else - modidx = scheme_false; - - /* Don't check for dups if we import from less that two sources, - since dup checking for a single source happens at that source: */ - rest = SCHEME_STX_CDR(form); - if (SCHEME_STX_NULLP(rest)) { - rest = NULL; - } else if (SCHEME_STX_PAIRP(rest)) { - rest = SCHEME_STX_CDR(rest); - if (SCHEME_STX_NULLP(rest)) { - rest = NULL; - } - } - - scheme_prepare_exp_env(env); - scheme_prepare_template_env(env); - - if (rest) { - /* Parse into dummy environment, first, then parse - into top-level if that works without error. We need those two - steps to avoid creating some bindings before discovering a - collision, and also for checking for duplicates in the spec as - opposed to duplicates with existing imports. */ - ht = scheme_make_hash_table_equal(); - - tmp_env = scheme_make_env_like(env); - scheme_prepare_exp_env(tmp_env); - scheme_prepare_template_env(tmp_env); - - /* add a scope to form so that it doesn't collide with anything: */ - form = scheme_stx_add_scope(form, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env)); - - parse_requires(form, tmp_env->phase, modidx, tmp_env, NULL, - tmp_env->stx_context, - check_dup_require, ht, - NULL, - 0, - 1, 0, - NULL, NULL, NULL, - NULL); - } - - return modidx; -} - -static Scheme_Object * -do_require_execute(Scheme_Env *env, Scheme_Object *form, int to_context) -{ - Scheme_Object *modidx; - - if (to_context) { - /* Use the current top-level context: */ - form = scheme_stx_from_generic_to_module_context(form, env->stx_context); - } - - /* Check for collisions again, in case there's a difference between - compile and run times: */ - modidx = check_require_form(env, form); - - parse_requires(form, env->phase, modidx, env, NULL, - env->stx_context, - NULL, NULL, - NULL, - 0, - -1, 1, - NULL, NULL, NULL, - NULL); - - return scheme_void; -} - -Scheme_Object * -scheme_top_level_require_execute(Scheme_Object *data) -{ - do_require_execute(scheme_environment_from_dummy(SCHEME_PTR1_VAL(data)), - SCHEME_PTR2_VAL(data), - 1); - return scheme_void; -} - -Scheme_Object * -scheme_top_level_require_jit(Scheme_Object *data) -{ - return data; -} - -static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - Scheme_Object *dummy, *data; - - if (!scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not at top-level or in module body"); - - /* If we get here, it must be a top-level require. */ - - (void)check_require_form(env->genv, form); - - if (rec && rec[drec].comp) { - /* Remove all context specific to the compile-time environment: */ - form = scheme_stx_from_module_context_to_generic(form, env->genv->stx_context); - - /* Dummy lets us access a top-level environment: */ - dummy = scheme_make_environment_dummy(env); - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - data = scheme_alloc_object(); - data->type = scheme_require_form_type; - SCHEME_PTR1_VAL(data) = dummy; - SCHEME_PTR2_VAL(data) = form; - - return data; - } else - return form; -} - -static Scheme_Object * -require_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_require(form, env, rec, drec); -} - -static Scheme_Object * -require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(env->observer); - return do_require(form, env, erec, drec); -} - -Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, - intptr_t phase, - Scheme_Comp_Env *cenv, - Scheme_Object *scope) -{ - Scheme_Object *form; - - form = make_require_form(module_path, phase, scope, cenv->genv->phase); - - form = scheme_revert_use_site_scopes(form, cenv); - - do_require_execute(cenv->genv, form, 0); - - return form; -} - -/**********************************************************************/ -/* dummy forms */ -/**********************************************************************/ - -static Scheme_Object * -provide_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(env->observer); - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -declare_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -declare_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(env->observer); - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} diff -Nru racket-6.12+ppa1/src/racket/src/mzclpf_post.inc racket-7.0+ppa1/src/racket/src/mzclpf_post.inc --- racket-6.12+ppa1/src/racket/src/mzclpf_post.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzclpf_post.inc 2018-07-27 22:12:02.000000000 +0000 @@ -17,7 +17,6 @@ if (pf) { int *use_bits; uintptr_t map; - int mark_stxes; /* pf might have been marked via fields: */ pf = (Scheme_Prefix *)GC_resolve2(pf, gc); @@ -39,7 +38,6 @@ pf->backpointer = (Scheme_Object *)c; #endif } - mark_stxes = 0; /* Add this closure to the chain to be repaired when the prefix is marked and potentially moved; if we're here @@ -60,12 +58,7 @@ for (i = 0; i < 31; i++) { if (map & ((unsigned int)1 << i)) { if (!(use_bits[0] & ((unsigned int)1 << i))) { - if ((i < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[i], gc); /* top level */ - else if (i == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[i + pf->num_stxes], gc); /* lifted */ + gcMARK2(pf->a[i], gc); /* top level */ } } } @@ -81,12 +74,7 @@ if (map & ((unsigned int)1 << j)) { if (!(use_bits[i] & ((unsigned int)1 << j))) { pos = (i * 32) + j; - if ((pos < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[pos], gc); /* top level */ - else if (pos == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[pos + pf->num_stxes], gc); /* lifted */ + gcMARK2(pf->a[pos], gc); /* top level */ } } } @@ -94,11 +82,5 @@ } } } - if (mark_stxes) { - /* Mark all syntax-object references */ - for (i = pf->num_stxes+1; i--;) { - gcMARK2(pf->a[i+pf->num_toplevels], gc); - } - } } } diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_compenv.inc racket-7.0+ppa1/src/racket/src/mzmark_compenv.inc --- racket-6.12+ppa1/src/racket/src/mzmark_compenv.inc 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_compenv.inc 2018-07-27 22:12:02.000000000 +0000 @@ -12,32 +12,9 @@ #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcMARK2(e->genv, gc); - gcMARK2(e->insp, gc); - gcMARK2(e->prefix, gc); - gcMARK2(e->next, gc); - gcMARK2(e->use_scopes_next, gc); - gcMARK2(e->intdef_next, gc); - gcMARK2(e->scopes, gc); - gcMARK2(e->value_name, gc); - gcMARK2(e->observer, gc); - gcMARK2(e->binders, gc); - gcMARK2(e->bindings, gc); - gcMARK2(e->vals, gc); - gcMARK2(e->shadower_deltas, gc); gcMARK2(e->vars, gc); - gcMARK2(e->dup_check, gc); - gcMARK2(e->intdef_name, gc); - gcMARK2(e->in_modidx, gc); - gcMARK2(e->skip_table, gc); - - gcMARK2(e->use, gc); - gcMARK2(e->lifts, gc); - gcMARK2(e->bindings, gc); - - gcMARK2(e->binding_namess, gc); - - gcMARK2(e->expand_result_adjust_arg, gc); + gcMARK2(e->value_name, gc); + gcMARK2(e->linklet, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -52,32 +29,9 @@ #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcFIXUP2(e->genv, gc); - gcFIXUP2(e->insp, gc); - gcFIXUP2(e->prefix, gc); - gcFIXUP2(e->next, gc); - gcFIXUP2(e->use_scopes_next, gc); - gcFIXUP2(e->intdef_next, gc); - gcFIXUP2(e->scopes, gc); - gcFIXUP2(e->value_name, gc); - gcFIXUP2(e->observer, gc); - gcFIXUP2(e->binders, gc); - gcFIXUP2(e->bindings, gc); - gcFIXUP2(e->vals, gc); - gcFIXUP2(e->shadower_deltas, gc); gcFIXUP2(e->vars, gc); - gcFIXUP2(e->dup_check, gc); - gcFIXUP2(e->intdef_name, gc); - gcFIXUP2(e->in_modidx, gc); - gcFIXUP2(e->skip_table, gc); - - gcFIXUP2(e->use, gc); - gcFIXUP2(e->lifts, gc); - gcFIXUP2(e->bindings, gc); - - gcFIXUP2(e->binding_namess, gc); - - gcFIXUP2(e->expand_result_adjust_arg, gc); + gcFIXUP2(e->value_name, gc); + gcFIXUP2(e->linklet, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_linklet.inc racket-7.0+ppa1/src/racket/src/mzmark_linklet.inc --- racket-6.12+ppa1/src/racket/src/mzmark_linklet.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_linklet.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,2 @@ +/* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ + diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_optimize.inc racket-7.0+ppa1/src/racket/src/mzmark_optimize.inc --- racket-6.12+ppa1/src/racket/src/mzmark_optimize.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_optimize.inc 2018-07-27 22:12:02.000000000 +0000 @@ -13,10 +13,9 @@ Optimize_Info *i = (Optimize_Info *)p; gcMARK2(i->next, gc); - gcMARK2(i->consts, gc); - gcMARK2(i->cp, gc); - gcMARK2(i->env, gc); - gcMARK2(i->insp, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->cross, gc); + gcMARK2(i->imports_used, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); @@ -38,10 +37,9 @@ Optimize_Info *i = (Optimize_Info *)p; gcFIXUP2(i->next, gc); - gcFIXUP2(i->consts, gc); - gcFIXUP2(i->cp, gc); - gcFIXUP2(i->env, gc); - gcFIXUP2(i->insp, gc); + gcFIXUP2(i->linklet, gc); + gcFIXUP2(i->cross, gc); + gcFIXUP2(i->imports_used, gc); gcFIXUP2(i->top_level_consts, gc); gcFIXUP2(i->transitive_use_var, gc); gcFIXUP2(i->context, gc); diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_portfun.inc racket-7.0+ppa1/src/racket/src/mzmark_portfun.inc --- racket-6.12+ppa1/src/racket/src/mzmark_portfun.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_portfun.inc 2018-07-27 22:12:02.000000000 +0000 @@ -1,55 +1,5 @@ /* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ -static int mark_load_handler_data_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -#else - return 0; -#endif -} - -static int mark_load_handler_data_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - LoadHandlerData *d = (LoadHandlerData *)p; - - gcMARK2(d->config, gc); - gcMARK2(d->port, gc); - gcMARK2(d->p, gc); - gcMARK2(d->stxsrc, gc); - gcMARK2(d->expected_module, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -# endif -#endif -} - -static int mark_load_handler_data_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - LoadHandlerData *d = (LoadHandlerData *)p; - - gcFIXUP2(d->config, gc); - gcFIXUP2(d->port, gc); - gcFIXUP2(d->p, gc); - gcFIXUP2(d->stxsrc, gc); - gcFIXUP2(d->expected_module, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -# endif -#endif -} - -#define mark_load_handler_data_IS_ATOMIC 0 -#define mark_load_handler_data_IS_CONST_SIZE 1 - - static int mark_indexed_string_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Indexed_String)); diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_print.inc racket-7.0+ppa1/src/racket/src/mzmark_print.inc --- racket-6.12+ppa1/src/racket/src/mzmark_print.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_print.inc 2018-07-27 22:12:02.000000000 +0000 @@ -60,17 +60,10 @@ gcMARK2(mt->symtab, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reachable_scopes, gc); - gcMARK2(mt->reachable_scope_stack, gc); - gcMARK2(mt->pending_reachable_ids, gc); - gcMARK2(mt->conditionally_reachable_scopes, gc); gcMARK2(mt->intern_map, gc); - gcMARK2(mt->identity_map, gc); - gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); gcMARK2(mt->cdata_map, gc); - gcMARK2(mt->rn_saved, gc); gcMARK2(mt->shared_offsets, gc); gcMARK2(mt->path_cache, gc); gcMARK2(mt->sorted_keys, gc); @@ -89,17 +82,10 @@ gcFIXUP2(mt->symtab, gc); gcFIXUP2(mt->st_refs, gc); gcFIXUP2(mt->st_ref_stack, gc); - gcFIXUP2(mt->reachable_scopes, gc); - gcFIXUP2(mt->reachable_scope_stack, gc); - gcFIXUP2(mt->pending_reachable_ids, gc); - gcFIXUP2(mt->conditionally_reachable_scopes, gc); gcFIXUP2(mt->intern_map, gc); - gcFIXUP2(mt->identity_map, gc); - gcFIXUP2(mt->top_map, gc); gcFIXUP2(mt->key_map, gc); gcFIXUP2(mt->delay_map, gc); gcFIXUP2(mt->cdata_map, gc); - gcFIXUP2(mt->rn_saved, gc); gcFIXUP2(mt->shared_offsets, gc); gcFIXUP2(mt->path_cache, gc); gcFIXUP2(mt->sorted_keys, gc); diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_read.inc racket-7.0+ppa1/src/racket/src/mzmark_read.inc --- racket-6.12+ppa1/src/racket/src/mzmark_read.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_read.inc 2018-07-27 22:12:02.000000000 +0000 @@ -52,8 +52,6 @@ gcMARK2(cp->symtab, gc); gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); - gcMARK2(cp->magic_sym, gc); - gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); gcMARK2(cp->symtab_refs, gc); @@ -76,8 +74,6 @@ gcFIXUP2(cp->symtab, gc); gcFIXUP2(cp->symtab_entries, gc); gcFIXUP2(cp->relto, gc); - gcFIXUP2(cp->magic_sym, gc); - gcFIXUP2(cp->magic_val, gc); gcFIXUP2(cp->shared_offsets, gc); gcFIXUP2(cp->delay_info, gc); gcFIXUP2(cp->symtab_refs, gc); @@ -94,50 +90,6 @@ #define mark_cport_IS_CONST_SIZE 1 -static int mark_readtable_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Readtable)); -#else - return 0; -#endif -} - -static int mark_readtable_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Readtable *t = (Readtable *)p; - gcMARK2(t->mapping, gc); - gcMARK2(t->fast_mapping, gc); - gcMARK2(t->symbol_parser, gc); - gcMARK2(t->names, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Readtable)); -# endif -#endif -} - -static int mark_readtable_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Readtable *t = (Readtable *)p; - gcFIXUP2(t->mapping, gc); - gcFIXUP2(t->fast_mapping, gc); - gcFIXUP2(t->symbol_parser, gc); - gcFIXUP2(t->names, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Readtable)); -# endif -#endif -} - -#define mark_readtable_IS_ATOMIC 0 -#define mark_readtable_IS_CONST_SIZE 1 - - static int mark_read_params_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(ReadParams)); @@ -149,11 +101,9 @@ static int mark_read_params_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED ReadParams *rp = (ReadParams *)p; - gcMARK2(rp->table, gc); - gcMARK2(rp->magic_sym, gc); - gcMARK2(rp->magic_val, gc); gcMARK2(rp->delay_load_info, gc); gcMARK2(rp->read_relative_path, gc); + gcMARK2(rp->graph_ht, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -166,11 +116,9 @@ static int mark_read_params_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED ReadParams *rp = (ReadParams *)p; - gcFIXUP2(rp->table, gc); - gcFIXUP2(rp->magic_sym, gc); - gcFIXUP2(rp->magic_val, gc); gcFIXUP2(rp->delay_load_info, gc); gcFIXUP2(rp->read_relative_path, gc); + gcFIXUP2(rp->graph_ht, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -249,10 +197,6 @@ static int mark_unmarshal_tables_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcMARK2(ut->rns, gc); - gcMARK2(ut->current_rns, gc); - gcMARK2(ut->multi_scope_pairs, gc); - gcMARK2(ut->current_multi_scope_pairs, gc); gcMARK2(ut->rp, gc); gcMARK2(ut->decoded, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS @@ -267,10 +211,6 @@ static int mark_unmarshal_tables_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcFIXUP2(ut->rns, gc); - gcFIXUP2(ut->current_rns, gc); - gcFIXUP2(ut->multi_scope_pairs, gc); - gcFIXUP2(ut->current_multi_scope_pairs, gc); gcFIXUP2(ut->rp, gc); gcFIXUP2(ut->decoded, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_resolve.inc racket-7.0+ppa1/src/racket/src/mzmark_resolve.inc --- racket-6.12+ppa1/src/racket/src/mzmark_resolve.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_resolve.inc 2018-07-27 22:12:02.000000000 +0000 @@ -12,12 +12,16 @@ #ifndef GC_NO_MARK_PROCEDURE_NEEDED Resolve_Info *i = (Resolve_Info *)p; - gcMARK2(i->prefix, gc); - gcMARK2(i->stx_map, gc); + gcMARK2(i->linklet, gc); gcMARK2(i->tl_map, gc); gcMARK2(i->redirects, gc); gcMARK2(i->lifts, gc); + gcMARK2(i->top, gc); gcMARK2(i->next, gc); + gcMARK2(i->toplevel_starts, gc); + gcMARK2(i->toplevel_deltas, gc); + gcMARK2(i->toplevel_defns, gc); + gcMARK2(i->static_mode, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -32,12 +36,16 @@ #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Resolve_Info *i = (Resolve_Info *)p; - gcFIXUP2(i->prefix, gc); - gcFIXUP2(i->stx_map, gc); + gcFIXUP2(i->linklet, gc); gcFIXUP2(i->tl_map, gc); gcFIXUP2(i->redirects, gc); gcFIXUP2(i->lifts, gc); + gcFIXUP2(i->top, gc); gcFIXUP2(i->next, gc); + gcFIXUP2(i->toplevel_starts, gc); + gcFIXUP2(i->toplevel_deltas, gc); + gcFIXUP2(i->toplevel_defns, gc); + gcFIXUP2(i->static_mode, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -65,16 +73,10 @@ Unresolve_Info *i = (Unresolve_Info *)p; gcMARK2(i->vars, gc); - gcMARK2(i->prefix, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->linklet_key, gc); + gcMARK2(i->opt_info, gc); gcMARK2(i->closures, gc); - gcMARK2(i->module, gc); - gcMARK2(i->comp_prefix, gc); - gcMARK2(i->new_toplevels, gc); - gcMARK2(i->from_modidx, gc); - gcMARK2(i->to_modidx, gc); - gcMARK2(i->opt_env, gc); - gcMARK2(i->opt_insp, gc); - gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -93,16 +95,10 @@ Unresolve_Info *i = (Unresolve_Info *)p; gcFIXUP2(i->vars, gc); - gcFIXUP2(i->prefix, gc); + gcFIXUP2(i->linklet, gc); + gcFIXUP2(i->linklet_key, gc); + gcFIXUP2(i->opt_info, gc); gcFIXUP2(i->closures, gc); - gcFIXUP2(i->module, gc); - gcFIXUP2(i->comp_prefix, gc); - gcFIXUP2(i->new_toplevels, gc); - gcFIXUP2(i->from_modidx, gc); - gcFIXUP2(i->to_modidx, gc); - gcFIXUP2(i->opt_env, gc); - gcFIXUP2(i->opt_insp, gc); - gcFIXUP2(i->inline_variants, gc); gcFIXUP2(i->toplevels, gc); gcFIXUP2(i->definitions, gc); gcFIXUP2(i->ref_lifts, gc); diff -Nru racket-6.12+ppa1/src/racket/src/mzmarksrc.c racket-7.0+ppa1/src/racket/src/mzmarksrc.c --- racket-6.12+ppa1/src/racket/src/mzmarksrc.c 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmarksrc.c 2018-07-27 22:12:02.000000000 +0000 @@ -13,19 +13,6 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Bucket_With_Home)); } -module_var { - mark: - Module_Variable *mv = (Module_Variable *)p; - - gcMARK2(mv->modidx, gc); - gcMARK2(mv->sym, gc); - gcMARK2(mv->insp, gc); - gcMARK2(mv->shape, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -} - bucket_obj { mark: Scheme_Bucket *b = (Scheme_Bucket *)p; @@ -49,10 +36,11 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Toplevel)); } -quotesyntax_obj { +static_toplevel_obj { mark: + gcMARK2(SCHEME_STATIC_TOPLEVEL_PREFIX(p), gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); + gcBYTES_TO_WORDS(sizeof(Scheme_Toplevel)); } cpointer_obj { @@ -234,6 +222,9 @@ gcMARK2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcMARK2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcMARK2(var->letrec_check.frame, gc); break; @@ -252,6 +243,12 @@ gcBYTES_TO_WORDS(sizeof(Scheme_IR_Local)); } +ir_toplevel { + mark: + size: + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +} + ir_let_value { mark: Scheme_IR_Let_Value *c = (Scheme_IR_Let_Value *)p; @@ -690,13 +687,6 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Output_Port)); } - -syntax_compiler { - mark: - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -} - thread_val { mark: Scheme_Thread *pr = (Scheme_Thread *)p; @@ -752,14 +742,6 @@ gcMARK2(pr->return_marks_to, gc); gcMARK2(pr->returned_marks, gc); - gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_scope, gc); - gcMARK2(pr->current_local_use_scope, gc); - gcMARK2(pr->current_local_name, gc); - gcMARK2(pr->current_local_modidx, gc); - gcMARK2(pr->current_local_menv, gc); - gcMARK2(pr->current_local_bindings, gc); - gcMARK2(pr->current_mt, gc); gcMARK2(pr->constant_folding, gc); @@ -936,61 +918,27 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Bucket_Table)); } -namespace_val { +env_val { mark: Scheme_Env *e = (Scheme_Env *)p; - gcMARK2(e->module, gc); - gcMARK2(e->module_registry, gc); - gcMARK2(e->module_pre_registry, gc); - gcMARK2(e->guard_insp, gc); - gcMARK2(e->access_insp, gc); - - gcMARK2(e->stx_context, gc); - gcMARK2(e->tmp_bind_scope, gc); - - gcMARK2(e->syntax, gc); - gcMARK2(e->exp_env, gc); - gcMARK2(e->template_env, gc); - gcMARK2(e->label_env, gc); - gcMARK2(e->instance_env, gc); - gcMARK2(e->reader_env, gc); - - gcMARK2(e->shadowed_syntax, gc); - - gcMARK2(e->lift_key, gc); - - gcMARK2(e->link_midx, gc); - gcMARK2(e->require_names, gc); - gcMARK2(e->et_require_names, gc); - gcMARK2(e->tt_require_names, gc); - gcMARK2(e->dt_require_names, gc); - gcMARK2(e->other_require_names, gc); - gcMARK2(e->running, gc); - gcMARK2(e->did_starts, gc); - gcMARK2(e->available_next[0], gc); - gcMARK2(e->available_next[1], gc); - - gcMARK2(e->toplevel, gc); - gcMARK2(e->modchain, gc); - - gcMARK2(e->modvars, gc); - - gcMARK2(e->weak_self_link, gc); - - gcMARK2(e->binding_names, gc); - + gcMARK2(e->namespace, gc); + gcMARK2(e->instance, gc); + gcMARK2(e->protected, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Env)); } -module_reg_val { +startup_env_val { mark: - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcMARK2(r->loaded, gc); - gcMARK2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcMARK2(e->current_table, gc); + gcMARK2(e->primitive_tables, gc); + gcMARK2(e->all_primitives_table, gc); + gcMARK2(e->primitive_ids_table, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); } random_state_val { @@ -999,17 +947,6 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Random_State)); } -compilation_top_val { - mark: - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcMARK2(t->code, gc); - gcMARK2(t->prefix, gc); - gcMARK2(t->binding_namess, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -} - prefix_val { Scheme_Prefix *pf = (Scheme_Prefix *)p; mark: @@ -1019,34 +956,10 @@ size: gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); } -resolve_prefix_val { - mark: - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcMARK2(rp->toplevels, gc); - gcMARK2(rp->stxes, gc); - gcMARK2(rp->delay_info_rpair, gc); - gcMARK2(rp->src_insp_desc, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -} - -comp_prefix_val { - mark: - Comp_Prefix *cp = (Comp_Prefix *)p; - gcMARK2(cp->toplevels, gc); - gcMARK2(cp->inline_variants, gc); - gcMARK2(cp->unbound, gc); - gcMARK2(cp->stxes, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -} - svector_val { mark: Scheme_Object *o = (Scheme_Object *)p; @@ -1062,139 +975,38 @@ Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->scopes, gc); - gcMARK2(stx->u.to_propagate, gc); - gcMARK2(stx->shifts, gc); - gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Stx)); } -stx_off_val { - mark: - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcMARK2(o->src, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); -} - -module_val { +linklet_val { mark: - Scheme_Module *m = (Scheme_Module *)p; - - gcMARK2(m->phaseless, gc); - - gcMARK2(m->code_key, gc); - - gcMARK2(m->modname, gc); - gcMARK2(m->modsrc, gc); - - gcMARK2(m->et_requires, gc); - gcMARK2(m->requires, gc); - gcMARK2(m->tt_requires, gc); - gcMARK2(m->dt_requires, gc); - gcMARK2(m->other_requires, gc); - - gcMARK2(m->bodies, gc); - - gcMARK2(m->me, gc); - - gcMARK2(m->exp_infos, gc); - - gcMARK2(m->self_modidx, gc); - - gcMARK2(m->binding_names, gc); - gcMARK2(m->et_binding_names, gc); - gcMARK2(m->other_binding_names, gc); - - gcMARK2(m->insp, gc); - - gcMARK2(m->lang_info, gc); - - gcMARK2(m->hints, gc); - gcMARK2(m->ii_src, gc); - gcMARK2(m->super_bxs_info, gc); - gcMARK2(m->sub_iidx_ptrs, gc); - - gcMARK2(m->comp_prefix, gc); - gcMARK2(m->prefix, gc); - gcMARK2(m->dummy, gc); + Scheme_Linklet *l = (Scheme_Linklet *)p; - gcMARK2(m->rn_stx, gc); - - gcMARK2(m->submodule_path, gc); - gcMARK2(m->pre_submodules, gc); - gcMARK2(m->post_submodules, gc); - gcMARK2(m->pre_submodule_names, gc); - gcMARK2(m->supermodule, gc); - gcMARK2(m->submodule_ancestry, gc); - - gcMARK2(m->primitive, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); -} - -exp_info_val { - mark: - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->accessible, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -} - -module_phase_exports_val { - mark: - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcMARK2(m->phase_index, gc); - - gcMARK2(m->src_modidx, gc); - - gcMARK2(m->provides, gc); - gcMARK2(m->provide_srcs, gc); - gcMARK2(m->provide_src_names, gc); - gcMARK2(m->provide_nominal_srcs, gc); - gcMARK2(m->provide_src_phases, gc); - - gcMARK2(m->ht, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -} - -module_exports_val { - mark: - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; - - gcMARK2(m->rt, gc); - gcMARK2(m->et, gc); - gcMARK2(m->dt, gc); - gcMARK2(m->other_phases, gc); - - gcMARK2(m->src_modidx, gc); - gcMARK2(m->modsrc, gc); + gcMARK2(l->name, gc); + gcMARK2(l->importss, gc); + gcMARK2(l->import_shapes, gc); + gcMARK2(l->defns, gc); + gcMARK2(l->source_names, gc); + gcMARK2(l->bodies, gc); + gcMARK2(l->constants, gc); + gcMARK2(l->static_prefix, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); } -modidx_val { +instance_val { mark: - Scheme_Modidx *modidx = (Scheme_Modidx *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcMARK2(modidx->path, gc); - gcMARK2(modidx->base, gc); - gcMARK2(modidx->resolved, gc); - gcMARK2(modidx->shift_cache, gc); - gcMARK2(modidx->cache_next, gc); + gcMARK2(i->variables.a, gc); + gcMARK2(i->weak_self_link, gc); + gcMARK2(i->source_names, gc); + gcMARK2(i->name, gc); + gcMARK2(i->data, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); } guard_val { @@ -1248,6 +1060,7 @@ gcMARK2(l->root_timestamp, gc); gcMARK2(l->syslog_level, gc); gcMARK2(l->stderr_level, gc); + gcMARK2(l->stdout_level, gc); gcMARK2(l->propagate_level, gc); gcMARK2(l->readers, gc); size: @@ -1283,38 +1096,21 @@ /**********************************************************************/ +START linklet; + +END linklet; + +/**********************************************************************/ + START compenv; mark_comp_env { mark: Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcMARK2(e->genv, gc); - gcMARK2(e->insp, gc); - gcMARK2(e->prefix, gc); - gcMARK2(e->next, gc); - gcMARK2(e->use_scopes_next, gc); - gcMARK2(e->intdef_next, gc); - gcMARK2(e->scopes, gc); - gcMARK2(e->value_name, gc); - gcMARK2(e->observer, gc); - gcMARK2(e->binders, gc); - gcMARK2(e->bindings, gc); - gcMARK2(e->vals, gc); - gcMARK2(e->shadower_deltas, gc); gcMARK2(e->vars, gc); - gcMARK2(e->dup_check, gc); - gcMARK2(e->intdef_name, gc); - gcMARK2(e->in_modidx, gc); - gcMARK2(e->skip_table, gc); - - gcMARK2(e->use, gc); - gcMARK2(e->lifts, gc); - gcMARK2(e->bindings, gc); - - gcMARK2(e->binding_namess, gc); - - gcMARK2(e->expand_result_adjust_arg, gc); + gcMARK2(e->value_name, gc); + gcMARK2(e->linklet, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env)); @@ -1330,12 +1126,16 @@ mark: Resolve_Info *i = (Resolve_Info *)p; - gcMARK2(i->prefix, gc); - gcMARK2(i->stx_map, gc); + gcMARK2(i->linklet, gc); gcMARK2(i->tl_map, gc); gcMARK2(i->redirects, gc); gcMARK2(i->lifts, gc); + gcMARK2(i->top, gc); gcMARK2(i->next, gc); + gcMARK2(i->toplevel_starts, gc); + gcMARK2(i->toplevel_deltas, gc); + gcMARK2(i->toplevel_defns, gc); + gcMARK2(i->static_mode, gc); size: gcBYTES_TO_WORDS(sizeof(Resolve_Info)); @@ -1346,16 +1146,10 @@ Unresolve_Info *i = (Unresolve_Info *)p; gcMARK2(i->vars, gc); - gcMARK2(i->prefix, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->linklet_key, gc); + gcMARK2(i->opt_info, gc); gcMARK2(i->closures, gc); - gcMARK2(i->module, gc); - gcMARK2(i->comp_prefix, gc); - gcMARK2(i->new_toplevels, gc); - gcMARK2(i->from_modidx, gc); - gcMARK2(i->to_modidx, gc); - gcMARK2(i->opt_env, gc); - gcMARK2(i->opt_insp, gc); - gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -1424,10 +1218,9 @@ Optimize_Info *i = (Optimize_Info *)p; gcMARK2(i->next, gc); - gcMARK2(i->consts, gc); - gcMARK2(i->cp, gc); - gcMARK2(i->env, gc); - gcMARK2(i->insp, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->cross, gc); + gcMARK2(i->imports_used, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); @@ -1645,20 +1438,6 @@ START portfun; -mark_load_handler_data { - mark: - LoadHandlerData *d = (LoadHandlerData *)p; - - gcMARK2(d->config, gc); - gcMARK2(d->port, gc); - gcMARK2(d->p, gc); - gcMARK2(d->stxsrc, gc); - gcMARK2(d->expected_module, gc); - - size: - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -} - mark_indexed_string { mark: Scheme_Indexed_String *is = (Scheme_Indexed_String *)p; @@ -1795,17 +1574,10 @@ gcMARK2(mt->symtab, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reachable_scopes, gc); - gcMARK2(mt->reachable_scope_stack, gc); - gcMARK2(mt->pending_reachable_ids, gc); - gcMARK2(mt->conditionally_reachable_scopes, gc); gcMARK2(mt->intern_map, gc); - gcMARK2(mt->identity_map, gc); - gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); gcMARK2(mt->cdata_map, gc); - gcMARK2(mt->rn_saved, gc); gcMARK2(mt->shared_offsets, gc); gcMARK2(mt->path_cache, gc); gcMARK2(mt->sorted_keys, gc); @@ -2269,8 +2041,6 @@ gcMARK2(cp->symtab, gc); gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); - gcMARK2(cp->magic_sym, gc); - gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); gcMARK2(cp->symtab_refs, gc); @@ -2278,25 +2048,12 @@ gcBYTES_TO_WORDS(sizeof(CPort)); } -mark_readtable { - mark: - Readtable *t = (Readtable *)p; - gcMARK2(t->mapping, gc); - gcMARK2(t->fast_mapping, gc); - gcMARK2(t->symbol_parser, gc); - gcMARK2(t->names, gc); - size: - gcBYTES_TO_WORDS(sizeof(Readtable)); -} - mark_read_params { mark: ReadParams *rp = (ReadParams *)p; - gcMARK2(rp->table, gc); - gcMARK2(rp->magic_sym, gc); - gcMARK2(rp->magic_val, gc); gcMARK2(rp->delay_load_info, gc); gcMARK2(rp->read_relative_path, gc); + gcMARK2(rp->graph_ht, gc); size: gcBYTES_TO_WORDS(sizeof(ReadParams)); } @@ -2320,10 +2077,6 @@ mark_unmarshal_tables { mark: Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcMARK2(ut->rns, gc); - gcMARK2(ut->current_rns, gc); - gcMARK2(ut->multi_scope_pairs, gc); - gcMARK2(ut->current_multi_scope_pairs, gc); gcMARK2(ut->rp, gc); gcMARK2(ut->decoded, gc); size: @@ -2401,40 +2154,6 @@ gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Srcloc)); } -mark_scope { - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - mark: - gcMARK2(m->bindings, gc); - if (for_multi) { - gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } - size: - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -} - -mark_scope_table { - mark: - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcMARK2(m->simple_scopes, gc); - gcMARK2(m->multi_scopes, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -} - -mark_propagate_table { - mark: - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_MARK(&m->st, gc); - gcMARK2(m->prev, gc); - gcMARK2(m->phase_shift, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -} - END syntax; /**********************************************************************/ diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_syntax.inc racket-7.0+ppa1/src/racket/src/mzmark_syntax.inc --- racket-6.12+ppa1/src/racket/src/mzmark_syntax.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_syntax.inc 2018-07-27 22:12:02.000000000 +0000 @@ -38,141 +38,3 @@ #define mark_srcloc_IS_CONST_SIZE 1 -static int mark_scope_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -#else - return 0; -#endif -} - -static int mark_scope_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - gcMARK2(m->bindings, gc); - if (for_multi) { - gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -# endif -#endif -} - -static int mark_scope_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - gcFIXUP2(m->bindings, gc); - if (for_multi) { - gcFIXUP2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcFIXUP2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -# endif -#endif -} - -#define mark_scope_IS_ATOMIC 0 -#define mark_scope_IS_CONST_SIZE 0 - - -static int mark_scope_table_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -#else - return 0; -#endif -} - -static int mark_scope_table_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcMARK2(m->simple_scopes, gc); - gcMARK2(m->multi_scopes, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -# endif -#endif -} - -static int mark_scope_table_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcFIXUP2(m->simple_scopes, gc); - gcFIXUP2(m->multi_scopes, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -# endif -#endif -} - -#define mark_scope_table_IS_ATOMIC 0 -#define mark_scope_table_IS_CONST_SIZE 1 - - -static int mark_propagate_table_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -#else - return 0; -#endif -} - -static int mark_propagate_table_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_MARK(&m->st, gc); - gcMARK2(m->prev, gc); - gcMARK2(m->phase_shift, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -# endif -#endif -} - -static int mark_propagate_table_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_FIXUP(&m->st, gc); - gcFIXUP2(m->prev, gc); - gcFIXUP2(m->phase_shift, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -# endif -#endif -} - -#define mark_propagate_table_IS_ATOMIC 0 -#define mark_propagate_table_IS_CONST_SIZE 1 - - diff -Nru racket-6.12+ppa1/src/racket/src/mzmark_type.inc racket-7.0+ppa1/src/racket/src/mzmark_type.inc --- racket-6.12+ppa1/src/racket/src/mzmark_type.inc 2016-10-07 19:56:36.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/mzmark_type.inc 2018-07-27 22:12:02.000000000 +0000 @@ -46,54 +46,6 @@ #define variable_obj_IS_CONST_SIZE 1 -static int module_var_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -#else - return 0; -#endif -} - -static int module_var_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Module_Variable *mv = (Module_Variable *)p; - - gcMARK2(mv->modidx, gc); - gcMARK2(mv->sym, gc); - gcMARK2(mv->insp, gc); - gcMARK2(mv->shape, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -# endif -#endif -} - -static int module_var_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Module_Variable *mv = (Module_Variable *)p; - - gcFIXUP2(mv->modidx, gc); - gcFIXUP2(mv->sym, gc); - gcFIXUP2(mv->insp, gc); - gcFIXUP2(mv->shape, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -# endif -#endif -} - -#define module_var_IS_ATOMIC 0 -#define module_var_IS_CONST_SIZE 1 - - static int bucket_obj_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Bucket)); @@ -206,38 +158,40 @@ #define toplevel_obj_IS_CONST_SIZE 1 -static int quotesyntax_obj_SIZE(void *p, struct NewGC *gc) { +static int static_toplevel_obj_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); + gcBYTES_TO_WORDS(sizeof(Scheme_Static_Toplevel)); #else return 0; #endif } -static int quotesyntax_obj_MARK(void *p, struct NewGC *gc) { +static int static_toplevel_obj_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED + gcMARK2(SCHEME_STATIC_TOPLEVEL_PREFIX(p), gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); + gcBYTES_TO_WORDS(sizeof(Scheme_Static_Toplevel)); # endif #endif } -static int quotesyntax_obj_FIXUP(void *p, struct NewGC *gc) { +static int static_toplevel_obj_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED + gcFIXUP2(SCHEME_STATIC_TOPLEVEL_PREFIX(p), gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); + gcBYTES_TO_WORDS(sizeof(Scheme_Static_Toplevel)); # endif #endif } -#define quotesyntax_obj_IS_ATOMIC 1 -#define quotesyntax_obj_IS_CONST_SIZE 1 +#define static_toplevel_obj_IS_ATOMIC 0 +#define static_toplevel_obj_IS_CONST_SIZE 1 static int cpointer_obj_SIZE(void *p, struct NewGC *gc) { @@ -961,6 +915,9 @@ gcMARK2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcMARK2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcMARK2(var->letrec_check.frame, gc); break; @@ -990,6 +947,9 @@ gcFIXUP2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcFIXUP2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcFIXUP2(var->letrec_check.frame, gc); break; @@ -1017,6 +977,40 @@ #define ir_local_IS_CONST_SIZE 1 +static int ir_toplevel_SIZE(void *p, struct NewGC *gc) { +#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +#else + return 0; +#endif +} + +static int ir_toplevel_MARK(void *p, struct NewGC *gc) { +#ifndef GC_NO_MARK_PROCEDURE_NEEDED +# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS + return 0; +# else + return + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +# endif +#endif +} + +static int ir_toplevel_FIXUP(void *p, struct NewGC *gc) { +#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED +# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS + return 0; +# else + return + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +# endif +#endif +} + +#define ir_toplevel_IS_ATOMIC 1 +#define ir_toplevel_IS_CONST_SIZE 1 + + static int ir_let_value_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_IR_Let_Value)); @@ -2590,41 +2584,6 @@ #define output_port_IS_CONST_SIZE 1 - -static int syntax_compiler_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -#else - return 0; -#endif -} - -static int syntax_compiler_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -# endif -#endif -} - -static int syntax_compiler_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -# endif -#endif -} - -#define syntax_compiler_IS_ATOMIC 1 -#define syntax_compiler_IS_CONST_SIZE 1 - - static int thread_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Thread)); @@ -2688,14 +2647,6 @@ gcMARK2(pr->return_marks_to, gc); gcMARK2(pr->returned_marks, gc); - gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_scope, gc); - gcMARK2(pr->current_local_use_scope, gc); - gcMARK2(pr->current_local_name, gc); - gcMARK2(pr->current_local_modidx, gc); - gcMARK2(pr->current_local_menv, gc); - gcMARK2(pr->current_local_bindings, gc); - gcMARK2(pr->current_mt, gc); gcMARK2(pr->constant_folding, gc); @@ -2820,14 +2771,6 @@ gcFIXUP2(pr->return_marks_to, gc); gcFIXUP2(pr->returned_marks, gc); - gcFIXUP2(pr->current_local_env, gc); - gcFIXUP2(pr->current_local_scope, gc); - gcFIXUP2(pr->current_local_use_scope, gc); - gcFIXUP2(pr->current_local_name, gc); - gcFIXUP2(pr->current_local_modidx, gc); - gcFIXUP2(pr->current_local_menv, gc); - gcFIXUP2(pr->current_local_bindings, gc); - gcFIXUP2(pr->current_mt, gc); gcFIXUP2(pr->constant_folding, gc); @@ -3284,7 +3227,7 @@ #define bucket_table_val_IS_CONST_SIZE 1 -static int namespace_val_SIZE(void *p, struct NewGC *gc) { +static int env_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Env)); #else @@ -3292,50 +3235,13 @@ #endif } -static int namespace_val_MARK(void *p, struct NewGC *gc) { +static int env_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Env *e = (Scheme_Env *)p; - gcMARK2(e->module, gc); - gcMARK2(e->module_registry, gc); - gcMARK2(e->module_pre_registry, gc); - gcMARK2(e->guard_insp, gc); - gcMARK2(e->access_insp, gc); - - gcMARK2(e->stx_context, gc); - gcMARK2(e->tmp_bind_scope, gc); - - gcMARK2(e->syntax, gc); - gcMARK2(e->exp_env, gc); - gcMARK2(e->template_env, gc); - gcMARK2(e->label_env, gc); - gcMARK2(e->instance_env, gc); - gcMARK2(e->reader_env, gc); - - gcMARK2(e->shadowed_syntax, gc); - - gcMARK2(e->lift_key, gc); - - gcMARK2(e->link_midx, gc); - gcMARK2(e->require_names, gc); - gcMARK2(e->et_require_names, gc); - gcMARK2(e->tt_require_names, gc); - gcMARK2(e->dt_require_names, gc); - gcMARK2(e->other_require_names, gc); - gcMARK2(e->running, gc); - gcMARK2(e->did_starts, gc); - gcMARK2(e->available_next[0], gc); - gcMARK2(e->available_next[1], gc); - - gcMARK2(e->toplevel, gc); - gcMARK2(e->modchain, gc); - - gcMARK2(e->modvars, gc); - - gcMARK2(e->weak_self_link, gc); - - gcMARK2(e->binding_names, gc); - + gcMARK2(e->namespace, gc); + gcMARK2(e->instance, gc); + gcMARK2(e->protected, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -3345,50 +3251,13 @@ #endif } -static int namespace_val_FIXUP(void *p, struct NewGC *gc) { +static int env_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Env *e = (Scheme_Env *)p; - gcFIXUP2(e->module, gc); - gcFIXUP2(e->module_registry, gc); - gcFIXUP2(e->module_pre_registry, gc); - gcFIXUP2(e->guard_insp, gc); - gcFIXUP2(e->access_insp, gc); - - gcFIXUP2(e->stx_context, gc); - gcFIXUP2(e->tmp_bind_scope, gc); - - gcFIXUP2(e->syntax, gc); - gcFIXUP2(e->exp_env, gc); - gcFIXUP2(e->template_env, gc); - gcFIXUP2(e->label_env, gc); - gcFIXUP2(e->instance_env, gc); - gcFIXUP2(e->reader_env, gc); - - gcFIXUP2(e->shadowed_syntax, gc); - - gcFIXUP2(e->lift_key, gc); - - gcFIXUP2(e->link_midx, gc); - gcFIXUP2(e->require_names, gc); - gcFIXUP2(e->et_require_names, gc); - gcFIXUP2(e->tt_require_names, gc); - gcFIXUP2(e->dt_require_names, gc); - gcFIXUP2(e->other_require_names, gc); - gcFIXUP2(e->running, gc); - gcFIXUP2(e->did_starts, gc); - gcFIXUP2(e->available_next[0], gc); - gcFIXUP2(e->available_next[1], gc); - - gcFIXUP2(e->toplevel, gc); - gcFIXUP2(e->modchain, gc); - - gcFIXUP2(e->modvars, gc); - - gcFIXUP2(e->weak_self_link, gc); - - gcFIXUP2(e->binding_names, gc); - + gcFIXUP2(e->namespace, gc); + gcFIXUP2(e->instance, gc); + gcFIXUP2(e->protected, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -3398,48 +3267,54 @@ #endif } -#define namespace_val_IS_ATOMIC 0 -#define namespace_val_IS_CONST_SIZE 1 +#define env_val_IS_ATOMIC 0 +#define env_val_IS_CONST_SIZE 1 -static int module_reg_val_SIZE(void *p, struct NewGC *gc) { +static int startup_env_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); #else return 0; #endif } -static int module_reg_val_MARK(void *p, struct NewGC *gc) { +static int startup_env_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcMARK2(r->loaded, gc); - gcMARK2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcMARK2(e->current_table, gc); + gcMARK2(e->primitive_tables, gc); + gcMARK2(e->all_primitives_table, gc); + gcMARK2(e->primitive_ids_table, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); # endif #endif } -static int module_reg_val_FIXUP(void *p, struct NewGC *gc) { +static int startup_env_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcFIXUP2(r->loaded, gc); - gcFIXUP2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcFIXUP2(e->current_table, gc); + gcFIXUP2(e->primitive_tables, gc); + gcFIXUP2(e->all_primitives_table, gc); + gcFIXUP2(e->primitive_ids_table, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); # endif #endif } -#define module_reg_val_IS_ATOMIC 0 -#define module_reg_val_IS_CONST_SIZE 1 +#define startup_env_val_IS_ATOMIC 0 +#define startup_env_val_IS_CONST_SIZE 1 static int random_state_val_SIZE(void *p, struct NewGC *gc) { @@ -3476,56 +3351,12 @@ #define random_state_val_IS_CONST_SIZE 1 -static int compilation_top_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -#else - return 0; -#endif -} - -static int compilation_top_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcMARK2(t->code, gc); - gcMARK2(t->prefix, gc); - gcMARK2(t->binding_namess, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -# endif -#endif -} - -static int compilation_top_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcFIXUP2(t->code, gc); - gcFIXUP2(t->prefix, gc); - gcFIXUP2(t->binding_namess, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -# endif -#endif -} - -#define compilation_top_val_IS_ATOMIC 0 -#define compilation_top_val_IS_CONST_SIZE 1 - - static int prefix_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS Scheme_Prefix *pf = (Scheme_Prefix *)p; gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); #else return 0; @@ -3544,7 +3375,7 @@ return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); # endif #endif @@ -3562,7 +3393,7 @@ return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); # endif #endif @@ -3572,98 +3403,6 @@ #define prefix_val_IS_CONST_SIZE 0 -static int resolve_prefix_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -#else - return 0; -#endif -} - -static int resolve_prefix_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcMARK2(rp->toplevels, gc); - gcMARK2(rp->stxes, gc); - gcMARK2(rp->delay_info_rpair, gc); - gcMARK2(rp->src_insp_desc, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -# endif -#endif -} - -static int resolve_prefix_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcFIXUP2(rp->toplevels, gc); - gcFIXUP2(rp->stxes, gc); - gcFIXUP2(rp->delay_info_rpair, gc); - gcFIXUP2(rp->src_insp_desc, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -# endif -#endif -} - -#define resolve_prefix_val_IS_ATOMIC 0 -#define resolve_prefix_val_IS_CONST_SIZE 1 - - -static int comp_prefix_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -#else - return 0; -#endif -} - -static int comp_prefix_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Comp_Prefix *cp = (Comp_Prefix *)p; - gcMARK2(cp->toplevels, gc); - gcMARK2(cp->inline_variants, gc); - gcMARK2(cp->unbound, gc); - gcMARK2(cp->stxes, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -# endif -#endif -} - -static int comp_prefix_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Comp_Prefix *cp = (Comp_Prefix *)p; - gcFIXUP2(cp->toplevels, gc); - gcFIXUP2(cp->inline_variants, gc); - gcFIXUP2(cp->unbound, gc); - gcFIXUP2(cp->stxes, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -# endif -#endif -} - -#define comp_prefix_val_IS_ATOMIC 0 -#define comp_prefix_val_IS_CONST_SIZE 1 - - static int svector_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); @@ -3719,10 +3458,6 @@ Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->scopes, gc); - gcMARK2(stx->u.to_propagate, gc); - gcMARK2(stx->shifts, gc); - gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -3738,10 +3473,6 @@ Scheme_Stx *stx = (Scheme_Stx *)p; gcFIXUP2(stx->val, gc); gcFIXUP2(stx->srcloc, gc); - gcFIXUP2(stx->scopes, gc); - gcFIXUP2(stx->u.to_propagate, gc); - gcFIXUP2(stx->shifts, gc); - gcFIXUP2(stx->taints, gc); gcFIXUP2(stx->props, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -3756,388 +3487,106 @@ #define stx_val_IS_CONST_SIZE 1 -static int stx_off_val_SIZE(void *p, struct NewGC *gc) { +static int linklet_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); #else return 0; #endif } -static int stx_off_val_MARK(void *p, struct NewGC *gc) { +static int linklet_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcMARK2(o->src, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); -# endif -#endif -} - -static int stx_off_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcFIXUP2(o->src, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); -# endif -#endif -} - -#define stx_off_val_IS_ATOMIC 0 -#define stx_off_val_IS_CONST_SIZE 1 - - -static int module_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); -#else - return 0; -#endif -} - -static int module_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module *m = (Scheme_Module *)p; - - gcMARK2(m->phaseless, gc); - - gcMARK2(m->code_key, gc); + Scheme_Linklet *l = (Scheme_Linklet *)p; - gcMARK2(m->modname, gc); - gcMARK2(m->modsrc, gc); - - gcMARK2(m->et_requires, gc); - gcMARK2(m->requires, gc); - gcMARK2(m->tt_requires, gc); - gcMARK2(m->dt_requires, gc); - gcMARK2(m->other_requires, gc); - - gcMARK2(m->bodies, gc); - - gcMARK2(m->me, gc); - - gcMARK2(m->exp_infos, gc); - - gcMARK2(m->self_modidx, gc); - - gcMARK2(m->binding_names, gc); - gcMARK2(m->et_binding_names, gc); - gcMARK2(m->other_binding_names, gc); - - gcMARK2(m->insp, gc); - - gcMARK2(m->lang_info, gc); - - gcMARK2(m->hints, gc); - gcMARK2(m->ii_src, gc); - gcMARK2(m->super_bxs_info, gc); - gcMARK2(m->sub_iidx_ptrs, gc); - - gcMARK2(m->comp_prefix, gc); - gcMARK2(m->prefix, gc); - gcMARK2(m->dummy, gc); - - gcMARK2(m->rn_stx, gc); - - gcMARK2(m->submodule_path, gc); - gcMARK2(m->pre_submodules, gc); - gcMARK2(m->post_submodules, gc); - gcMARK2(m->pre_submodule_names, gc); - gcMARK2(m->supermodule, gc); - gcMARK2(m->submodule_ancestry, gc); - - gcMARK2(m->primitive, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); -# endif -#endif -} - -static int module_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module *m = (Scheme_Module *)p; - - gcFIXUP2(m->phaseless, gc); - - gcFIXUP2(m->code_key, gc); - - gcFIXUP2(m->modname, gc); - gcFIXUP2(m->modsrc, gc); - - gcFIXUP2(m->et_requires, gc); - gcFIXUP2(m->requires, gc); - gcFIXUP2(m->tt_requires, gc); - gcFIXUP2(m->dt_requires, gc); - gcFIXUP2(m->other_requires, gc); - - gcFIXUP2(m->bodies, gc); - - gcFIXUP2(m->me, gc); - - gcFIXUP2(m->exp_infos, gc); - - gcFIXUP2(m->self_modidx, gc); - - gcFIXUP2(m->binding_names, gc); - gcFIXUP2(m->et_binding_names, gc); - gcFIXUP2(m->other_binding_names, gc); - - gcFIXUP2(m->insp, gc); - - gcFIXUP2(m->lang_info, gc); - - gcFIXUP2(m->hints, gc); - gcFIXUP2(m->ii_src, gc); - gcFIXUP2(m->super_bxs_info, gc); - gcFIXUP2(m->sub_iidx_ptrs, gc); - - gcFIXUP2(m->comp_prefix, gc); - gcFIXUP2(m->prefix, gc); - gcFIXUP2(m->dummy, gc); - - gcFIXUP2(m->rn_stx, gc); - - gcFIXUP2(m->submodule_path, gc); - gcFIXUP2(m->pre_submodules, gc); - gcFIXUP2(m->post_submodules, gc); - gcFIXUP2(m->pre_submodule_names, gc); - gcFIXUP2(m->supermodule, gc); - gcFIXUP2(m->submodule_ancestry, gc); - - gcFIXUP2(m->primitive, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); -# endif -#endif -} - -#define module_val_IS_ATOMIC 0 -#define module_val_IS_CONST_SIZE 1 - - -static int exp_info_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -#else - return 0; -#endif -} - -static int exp_info_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->accessible, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -# endif -#endif -} - -static int exp_info_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcFIXUP2(m->provide_protects, gc); - gcFIXUP2(m->indirect_provides, gc); - - gcFIXUP2(m->indirect_syntax_provides, gc); - - gcFIXUP2(m->accessible, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -# endif -#endif -} - -#define exp_info_val_IS_ATOMIC 0 -#define exp_info_val_IS_CONST_SIZE 1 - - -static int module_phase_exports_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -#else - return 0; -#endif -} - -static int module_phase_exports_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcMARK2(m->phase_index, gc); - - gcMARK2(m->src_modidx, gc); - - gcMARK2(m->provides, gc); - gcMARK2(m->provide_srcs, gc); - gcMARK2(m->provide_src_names, gc); - gcMARK2(m->provide_nominal_srcs, gc); - gcMARK2(m->provide_src_phases, gc); - - gcMARK2(m->ht, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -# endif -#endif -} - -static int module_phase_exports_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcFIXUP2(m->phase_index, gc); - - gcFIXUP2(m->src_modidx, gc); - - gcFIXUP2(m->provides, gc); - gcFIXUP2(m->provide_srcs, gc); - gcFIXUP2(m->provide_src_names, gc); - gcFIXUP2(m->provide_nominal_srcs, gc); - gcFIXUP2(m->provide_src_phases, gc); - - gcFIXUP2(m->ht, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -# endif -#endif -} - -#define module_phase_exports_val_IS_ATOMIC 0 -#define module_phase_exports_val_IS_CONST_SIZE 1 - - -static int module_exports_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); -#else - return 0; -#endif -} - -static int module_exports_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; - - gcMARK2(m->rt, gc); - gcMARK2(m->et, gc); - gcMARK2(m->dt, gc); - gcMARK2(m->other_phases, gc); - - gcMARK2(m->src_modidx, gc); - gcMARK2(m->modsrc, gc); + gcMARK2(l->name, gc); + gcMARK2(l->importss, gc); + gcMARK2(l->import_shapes, gc); + gcMARK2(l->defns, gc); + gcMARK2(l->source_names, gc); + gcMARK2(l->bodies, gc); + gcMARK2(l->constants, gc); + gcMARK2(l->static_prefix, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); # endif #endif } -static int module_exports_val_FIXUP(void *p, struct NewGC *gc) { +static int linklet_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; + Scheme_Linklet *l = (Scheme_Linklet *)p; - gcFIXUP2(m->rt, gc); - gcFIXUP2(m->et, gc); - gcFIXUP2(m->dt, gc); - gcFIXUP2(m->other_phases, gc); - - gcFIXUP2(m->src_modidx, gc); - gcFIXUP2(m->modsrc, gc); + gcFIXUP2(l->name, gc); + gcFIXUP2(l->importss, gc); + gcFIXUP2(l->import_shapes, gc); + gcFIXUP2(l->defns, gc); + gcFIXUP2(l->source_names, gc); + gcFIXUP2(l->bodies, gc); + gcFIXUP2(l->constants, gc); + gcFIXUP2(l->static_prefix, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); # endif #endif } -#define module_exports_val_IS_ATOMIC 0 -#define module_exports_val_IS_CONST_SIZE 1 +#define linklet_val_IS_ATOMIC 0 +#define linklet_val_IS_CONST_SIZE 1 -static int modidx_val_SIZE(void *p, struct NewGC *gc) { +static int instance_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); #else return 0; #endif } -static int modidx_val_MARK(void *p, struct NewGC *gc) { +static int instance_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Modidx *modidx = (Scheme_Modidx *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcMARK2(modidx->path, gc); - gcMARK2(modidx->base, gc); - gcMARK2(modidx->resolved, gc); - gcMARK2(modidx->shift_cache, gc); - gcMARK2(modidx->cache_next, gc); + gcMARK2(i->variables.a, gc); + gcMARK2(i->weak_self_link, gc); + gcMARK2(i->source_names, gc); + gcMARK2(i->name, gc); + gcMARK2(i->data, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); # endif #endif } -static int modidx_val_FIXUP(void *p, struct NewGC *gc) { +static int instance_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Modidx *modidx = (Scheme_Modidx *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcFIXUP2(modidx->path, gc); - gcFIXUP2(modidx->base, gc); - gcFIXUP2(modidx->resolved, gc); - gcFIXUP2(modidx->shift_cache, gc); - gcFIXUP2(modidx->cache_next, gc); + gcFIXUP2(i->variables.a, gc); + gcFIXUP2(i->weak_self_link, gc); + gcFIXUP2(i->source_names, gc); + gcFIXUP2(i->name, gc); + gcFIXUP2(i->data, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); # endif #endif } -#define modidx_val_IS_ATOMIC 0 -#define modidx_val_IS_CONST_SIZE 1 +#define instance_val_IS_ATOMIC 0 +#define instance_val_IS_CONST_SIZE 1 static int guard_val_SIZE(void *p, struct NewGC *gc) { @@ -4329,6 +3778,7 @@ gcMARK2(l->root_timestamp, gc); gcMARK2(l->syslog_level, gc); gcMARK2(l->stderr_level, gc); + gcMARK2(l->stdout_level, gc); gcMARK2(l->propagate_level, gc); gcMARK2(l->readers, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS @@ -4349,6 +3799,7 @@ gcFIXUP2(l->root_timestamp, gc); gcFIXUP2(l->syslog_level, gc); gcFIXUP2(l->stderr_level, gc); + gcFIXUP2(l->stdout_level, gc); gcFIXUP2(l->propagate_level, gc); gcFIXUP2(l->readers, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS diff -Nru racket-6.12+ppa1/src/racket/src/network.c racket-7.0+ppa1/src/racket/src/network.c --- racket-6.12+ppa1/src/racket/src/network.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/network.c 2018-07-27 22:12:02.000000000 +0000 @@ -118,63 +118,61 @@ static void register_traversers(void); #endif -void scheme_init_network(Scheme_Env *env) +void scheme_init_network(Scheme_Startup_Env *env) { - Scheme_Env *netenv; - #ifdef MZ_PRECISE_GC register_traversers(); #endif - netenv = scheme_primitive_module(scheme_intern_symbol("#%network"), env); + scheme_switch_prim_instance(env, "#%network"); - GLOBAL_PRIM_W_ARITY2 ( "tcp-connect" , tcp_connect , 2 , 4 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-connect/enable-break" , tcp_connect_break , 2 , 4 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-listen" , tcp_listen , 1 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-close" , tcp_stop , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-accept-ready?" , tcp_accept_ready , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-accept" , tcp_accept , 1 , 1 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-accept-evt" , tcp_accept_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-accept/enable-break" , tcp_accept_break , 1 , 1 , 2 , 2 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "tcp-listener?" , tcp_listener_p , 1 , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-addresses" , tcp_addresses , 1 , 2 , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-abandon-port" , tcp_abandon_port , 1 , 1 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "tcp-port?" , tcp_port_p , 1 , 1 , 1 , netenv ) ; - - GLOBAL_PRIM_W_ARITY ( "udp-open-socket" , make_udp , 0 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-close" , udp_close , 1 , 1 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "udp?" , udp_p , 1 , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-bound?" , udp_bound_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-connected?" , udp_connected_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-bind!" , udp_bind , 3 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-connect!" , udp_connect , 3 , 3 , netenv ) ; - - GLOBAL_PRIM_W_ARITY ( "udp-send-to" , udp_send_to , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send" , udp_send , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to*" , udp_send_to_star , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send*" , udp_send_star , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to/enable-break" , udp_send_to_enable_break , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send/enable-break" , udp_send_enable_break , 2 , 4 , netenv ) ; - - GLOBAL_PRIM_W_ARITY ( "udp-receive!" , udp_receive , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!*" , udp_receive_star , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!/enable-break" , udp_receive_enable_break , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive-ready-evt" , udp_read_ready_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-ready-evt" , udp_write_ready_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!-evt" , udp_read_evt , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-evt" , udp_write_evt , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to-evt" , udp_write_to_evt , 4 , 6 , netenv ) ; - - GLOBAL_PRIM_W_ARITY ( "udp-multicast-loopback?" , udp_multicast_loopback_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-loopback!", udp_multicast_set_loopback,2, 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-ttl" , udp_multicast_ttl , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-ttl!" , udp_multicast_set_ttl , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-interface" , udp_multicast_interface , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-interface!", udp_multicast_set_interface,2,2, netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-join-group!" , udp_multicast_join_group , 3 , 3 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-leave-group!", udp_multicast_leave_group, 3 , 3 , netenv ) ; + ADD_PRIM_W_ARITY2 ( "tcp-connect" , tcp_connect , 2 , 4 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-connect/enable-break" , tcp_connect_break , 2 , 4 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "tcp-listen" , tcp_listen , 1 , 4 , env) ; + ADD_PRIM_W_ARITY ( "tcp-close" , tcp_stop , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "tcp-accept-ready?" , tcp_accept_ready , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-accept" , tcp_accept , 1 , 1 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "tcp-accept-evt" , tcp_accept_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-accept/enable-break" , tcp_accept_break , 1 , 1 , 2 , 2 , env) ; + ADD_FOLDING_PRIM ( "tcp-listener?" , tcp_listener_p , 1 , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-addresses" , tcp_addresses , 1 , 2 , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "tcp-abandon-port" , tcp_abandon_port , 1 , 1 , env) ; + ADD_FOLDING_PRIM ( "tcp-port?" , tcp_port_p , 1 , 1 , 1 , env) ; + + ADD_PRIM_W_ARITY ( "udp-open-socket" , make_udp , 0 , 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-close" , udp_close , 1 , 1 , env) ; + ADD_FOLDING_PRIM ( "udp?" , udp_p , 1 , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-bound?" , udp_bound_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-connected?" , udp_connected_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-bind!" , udp_bind , 3 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-connect!" , udp_connect , 3 , 3 , env) ; + + ADD_PRIM_W_ARITY ( "udp-send-to" , udp_send_to , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send" , udp_send , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to*" , udp_send_to_star , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send*" , udp_send_star , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to/enable-break" , udp_send_to_enable_break , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send/enable-break" , udp_send_enable_break , 2 , 4 , env) ; + + ADD_PRIM_W_ARITY ( "udp-receive!" , udp_receive , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!*" , udp_receive_star , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!/enable-break" , udp_receive_enable_break , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive-ready-evt" , udp_read_ready_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-ready-evt" , udp_write_ready_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!-evt" , udp_read_evt , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-evt" , udp_write_evt , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to-evt" , udp_write_to_evt , 4 , 6 , env) ; + + ADD_PRIM_W_ARITY ( "udp-multicast-loopback?" , udp_multicast_loopback_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-loopback!", udp_multicast_set_loopback,2, 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-ttl" , udp_multicast_ttl , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-ttl!" , udp_multicast_set_ttl , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-interface" , udp_multicast_interface , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-interface!", udp_multicast_set_interface,2,2, env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-join-group!" , udp_multicast_join_group , 3 , 3 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-leave-group!", udp_multicast_leave_group, 3 , 3 , env) ; - scheme_finish_primitive_module(netenv); + scheme_restore_prim_instance(env); } static int check_fd_sema(rktio_fd_t *s, int mode, Scheme_Schedule_Info *sinfo, Scheme_Object *orig) diff -Nru racket-6.12+ppa1/src/racket/src/numarith.c racket-7.0+ppa1/src/racket/src/numarith.c --- racket-6.12+ppa1/src/racket/src/numarith.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/numarith.c 2018-07-27 22:12:02.000000000 +0000 @@ -27,6 +27,10 @@ #include "nummacs.h" #include +READ_ONLY Scheme_Object *scheme_unsafe_fx_plus_proc; +READ_ONLY Scheme_Object *scheme_unsafe_fx_minus_proc; +READ_ONLY Scheme_Object *scheme_unsafe_fx_times_proc; + static Scheme_Object *plus (int argc, Scheme_Object *argv[]); static Scheme_Object *minus (int argc, Scheme_Object *argv[]); static Scheme_Object *mult (int argc, Scheme_Object *argv[]); @@ -87,7 +91,7 @@ # define SQRT_MACHINE_CODE_AVAILABLE 1 #endif -void scheme_init_numarith(Scheme_Env *env) +void scheme_init_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -97,7 +101,7 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("add1", p, env); + scheme_addto_prim_instance("add1", p, env); p = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED @@ -105,7 +109,7 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("sub1", p, env); + scheme_addto_prim_instance("sub1", p, env); p = scheme_make_folding_prim(plus, "+", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -114,7 +118,7 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("+", p, env); + scheme_addto_prim_instance("+", p, env); p = scheme_make_folding_prim(minus, "-", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -124,7 +128,7 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("-", p, env); + scheme_addto_prim_instance("-", p, env); p = scheme_make_folding_prim(mult, "*", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -133,7 +137,7 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("*", p, env); + scheme_addto_prim_instance("*", p, env); p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -141,7 +145,7 @@ | SCHEME_PRIM_WANTS_NUMBER | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("/", p, env); + scheme_addto_prim_instance("/", p, env); p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED @@ -149,21 +153,21 @@ | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("abs", p, env); + scheme_addto_prim_instance("abs", p, env); p = scheme_make_folding_prim(quotient, "quotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("quotient", p, env); + scheme_addto_prim_instance("quotient", p, env); p = scheme_make_folding_prim(rem_prim, "remainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("remainder", p, env); + scheme_addto_prim_instance("remainder", p, env); - scheme_add_global_constant("quotient/remainder", + scheme_addto_prim_instance("quotient/remainder", scheme_make_prim_w_arity2(quotient_remainder, "quotient/remainder", 2, 2, @@ -174,48 +178,51 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("modulo", p, env); + scheme_addto_prim_instance("modulo", p, env); } -void scheme_init_flfxnum_numarith(Scheme_Env *env) +void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; p = scheme_make_folding_prim(fx_plus, "fx+", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx+", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fx+", p, env); p = scheme_make_folding_prim(fx_minus, "fx-", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx-", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fx-", p, env); p = scheme_make_folding_prim(fx_mult, "fx*", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx*", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fx*", p, env); p = scheme_make_folding_prim(fx_div, "fxquotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxquotient", p, env); + scheme_addto_prim_instance("fxquotient", p, env); p = scheme_make_folding_prim(fx_rem, "fxremainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxremainder", p, env); + scheme_addto_prim_instance("fxremainder", p, env); p = scheme_make_folding_prim(fx_mod, "fxmodulo", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmodulo", p, env); + scheme_addto_prim_instance("fxmodulo", p, env); p = scheme_make_folding_prim(fx_abs, "fxabs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED) | SCHEME_PRIM_PRODUCES_FIXNUM; - scheme_add_global_constant("fxabs", p, env); + scheme_addto_prim_instance("fxabs", p, env); p = scheme_make_folding_prim(fl_plus, "fl+", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -225,7 +232,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl+", p, env); + scheme_addto_prim_instance("fl+", p, env); p = scheme_make_folding_prim(fl_minus, "fl-", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -235,7 +242,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl-", p, env); + scheme_addto_prim_instance("fl-", p, env); p = scheme_make_folding_prim(fl_mult, "fl*", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -245,7 +252,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl*", p, env); + scheme_addto_prim_instance("fl*", p, env); p = scheme_make_folding_prim(fl_div, "fl/", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -255,7 +262,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl/", p, env); + scheme_addto_prim_instance("fl/", p, env); p = scheme_make_folding_prim(fl_abs, "flabs", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -265,7 +272,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("flabs", p, env); + scheme_addto_prim_instance("flabs", p, env); p = scheme_make_folding_prim(fl_sqrt, "flsqrt", 1, 1, 1); if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE) @@ -275,11 +282,11 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("flsqrt", p, env); + scheme_addto_prim_instance("flsqrt", p, env); } -void scheme_init_extfl_numarith(Scheme_Env *env) +void scheme_init_extfl_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -292,7 +299,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl+", p, env); + scheme_addto_prim_instance("extfl+", p, env); p = scheme_make_folding_prim(extfl_minus, "extfl-", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -302,7 +309,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl-", p, env); + scheme_addto_prim_instance("extfl-", p, env); p = scheme_make_folding_prim(extfl_mult, "extfl*", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -312,7 +319,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl*", p, env); + scheme_addto_prim_instance("extfl*", p, env); p = scheme_make_folding_prim(extfl_div, "extfl/", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -322,7 +329,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl/", p, env); + scheme_addto_prim_instance("extfl/", p, env); p = scheme_make_folding_prim(extfl_abs, "extflabs", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -332,7 +339,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("extflabs", p, env); + scheme_addto_prim_instance("extflabs", p, env); p = scheme_make_folding_prim(extfl_sqrt, "extflsqrt", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)) @@ -342,55 +349,61 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("extflsqrt", p, env); + scheme_addto_prim_instance("extflsqrt", p, env); } -void scheme_init_unsafe_numarith(Scheme_Env *env) +void scheme_init_unsafe_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; + REGISTER_SO(scheme_unsafe_fx_plus_proc); p = scheme_make_folding_prim(unsafe_fx_plus, "unsafe-fx+", 2, 2, 1); + scheme_unsafe_fx_plus_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx+", p, env); + scheme_addto_prim_instance("unsafe-fx+", p, env); + REGISTER_SO(scheme_unsafe_fx_minus_proc); p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 2, 2, 1); + scheme_unsafe_fx_minus_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx-", p, env); + scheme_addto_prim_instance("unsafe-fx-", p, env); + REGISTER_SO(scheme_unsafe_fx_times_proc); p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 2, 2, 1); + scheme_unsafe_fx_times_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx*", p, env); + scheme_addto_prim_instance("unsafe-fx*", p, env); p = scheme_make_folding_prim(unsafe_fx_div, "unsafe-fxquotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxquotient", p, env); + scheme_addto_prim_instance("unsafe-fxquotient", p, env); p = scheme_make_folding_prim(unsafe_fx_rem, "unsafe-fxremainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxremainder", p, env); + scheme_addto_prim_instance("unsafe-fxremainder", p, env); p = scheme_make_folding_prim(unsafe_fx_mod, "unsafe-fxmodulo", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmodulo", p, env); + scheme_addto_prim_instance("unsafe-fxmodulo", p, env); p = scheme_make_folding_prim(unsafe_fx_abs, "unsafe-fxabs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxabs", p, env); + scheme_addto_prim_instance("unsafe-fxabs", p, env); p = scheme_make_folding_prim(unsafe_fl_plus, "unsafe-fl+", 2, 2, 1); @@ -402,7 +415,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl+", p, env); + scheme_addto_prim_instance("unsafe-fl+", p, env); p = scheme_make_folding_prim(unsafe_fl_minus, "unsafe-fl-", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -413,7 +426,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl-", p, env); + scheme_addto_prim_instance("unsafe-fl-", p, env); p = scheme_make_folding_prim(unsafe_fl_mult, "unsafe-fl*", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -424,7 +437,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl*", p, env); + scheme_addto_prim_instance("unsafe-fl*", p, env); p = scheme_make_folding_prim(unsafe_fl_div, "unsafe-fl/", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -435,7 +448,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl/", p, env); + scheme_addto_prim_instance("unsafe-fl/", p, env); p = scheme_make_folding_prim(unsafe_fl_abs, "unsafe-flabs", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -446,7 +459,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("unsafe-flabs", p, env); + scheme_addto_prim_instance("unsafe-flabs", p, env); p = scheme_make_folding_prim(unsafe_fl_sqrt, "unsafe-flsqrt", 1, 1, 1); if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE) @@ -457,10 +470,10 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("unsafe-flsqrt", p, env); + scheme_addto_prim_instance("unsafe-flsqrt", p, env); } -void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) +void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -474,7 +487,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl+", p, env); + scheme_addto_prim_instance("unsafe-extfl+", p, env); p = scheme_make_folding_prim(unsafe_extfl_minus, "unsafe-extfl-", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -485,7 +498,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl-", p, env); + scheme_addto_prim_instance("unsafe-extfl-", p, env); p = scheme_make_folding_prim(unsafe_extfl_mult, "unsafe-extfl*", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -496,7 +509,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl*", p, env); + scheme_addto_prim_instance("unsafe-extfl*", p, env); p = scheme_make_folding_prim(unsafe_extfl_div, "unsafe-extfl/", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -507,7 +520,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl/", p, env); + scheme_addto_prim_instance("unsafe-extfl/", p, env); p = scheme_make_folding_prim(unsafe_extfl_abs, "unsafe-extflabs", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -518,7 +531,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("unsafe-extflabs", p, env); + scheme_addto_prim_instance("unsafe-extflabs", p, env); p = scheme_make_folding_prim(unsafe_extfl_sqrt, "unsafe-extflsqrt", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)) @@ -529,7 +542,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("unsafe-extflsqrt", p, env); + scheme_addto_prim_instance("unsafe-extflsqrt", p, env); } Scheme_Object * diff -Nru racket-6.12+ppa1/src/racket/src/number.c racket-7.0+ppa1/src/racket/src/number.c --- racket-6.12+ppa1/src/racket/src/number.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/number.c 2018-07-27 22:12:02.000000000 +0000 @@ -345,7 +345,7 @@ void -scheme_init_number (Scheme_Env *env) +scheme_init_number (Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -450,11 +450,10 @@ #ifdef ZERO_LONG_MINUS_ZERO_IS_LONG_POS_ZERO scheme_long_floating_point_nzero = long_double_div(long_double_neq(long_double_1(), scheme_long_infinity_val)); #else - scheme_long_floating_point_nzero = long_double_neg(scheme_long_floating_point_nzero); + scheme_long_floating_point_nzero = long_double_neg(scheme_long_floating_point_zero); #endif scheme_long_minus_infinity_val = long_double_neg(scheme_long_infinity_val); - long_not_a_number_val = long_double_plus(scheme_long_infinity_val, scheme_long_minus_infinity_val); long_not_a_number_val = long_double_sqrt(long_double_neg(get_long_double_1())); scheme_zerol = scheme_make_long_double(get_long_double_1()); @@ -479,69 +478,81 @@ p = scheme_make_folding_prim(number_p, "number?", 1, 1, 1); scheme_number_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("number?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("number?", p, env); p = scheme_make_folding_prim(complex_p, "complex?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("complex?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("complex?", p, env); REGISTER_SO(scheme_real_p_proc); p = scheme_make_folding_prim(real_p, "real?", 1, 1, 1); scheme_real_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("real?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("real?", p, env); p = scheme_make_folding_prim(rational_p, "rational?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("rational?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("rational?", p, env); p = scheme_make_folding_prim(integer_p, "integer?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("integer?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("integer?", p, env); p = scheme_make_folding_prim(exact_integer_p, "exact-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-integer?", p, env); p = scheme_make_folding_prim(exact_nonnegative_integer_p, "exact-nonnegative-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-nonnegative-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-nonnegative-integer?", p, env); p = scheme_make_folding_prim(exact_positive_integer_p, "exact-positive-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-positive-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-positive-integer?", p, env); REGISTER_SO(scheme_fixnum_p_proc); p = scheme_make_immed_prim(fixnum_p, "fixnum?", 1, 1); scheme_fixnum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("fixnum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fixnum?", p, env); p = scheme_make_folding_prim(inexact_real_p, "inexact-real?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("inexact-real?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("inexact-real?", p, env); REGISTER_SO(scheme_flonum_p_proc); p = scheme_make_folding_prim(flonum_p, "flonum?", 1, 1, 1); scheme_flonum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("flonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("flonum?", p, env); p = scheme_make_folding_prim(single_flonum_p, "single-flonum?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("single-flonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("single-flonum?", p, env); p = scheme_make_folding_prim(real_to_single_flonum, "real->single-flonum", 1, 1, 1); - scheme_add_global_constant("real->single-flonum", p, env); + scheme_addto_prim_instance("real->single-flonum", p, env); p = scheme_make_folding_prim(real_to_double_flonum, "real->double-flonum", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -549,14 +560,14 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("real->double-flonum", p, env); + scheme_addto_prim_instance("real->double-flonum", p, env); - scheme_add_global_constant("exact?", + scheme_addto_prim_instance("exact?", scheme_make_folding_prim(exact_p, "exact?", 1, 1, 1), env); - scheme_add_global_constant("inexact?", + scheme_addto_prim_instance("inexact?", scheme_make_folding_prim(scheme_inexact_p, "inexact?", 1, 1, 1), @@ -564,36 +575,40 @@ p = scheme_make_folding_prim(scheme_odd_p, "odd?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("odd?", p, env); + scheme_addto_prim_instance("odd?", p, env); p = scheme_make_folding_prim(scheme_even_p, "even?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("even?", p, env); + scheme_addto_prim_instance("even?", p, env); p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-and", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-and", p, env); p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-ior", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-ior", p, env); p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-xor", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-xor", p, env); p = scheme_make_folding_prim(bitwise_not, "bitwise-not", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("bitwise-not", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-not", p, env); p = scheme_make_folding_prim(bitwise_bit_set_p, "bitwise-bit-set?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("bitwise-bit-set?", p, env); + scheme_addto_prim_instance("bitwise-bit-set?", p, env); - scheme_add_global_constant("bitwise-bit-field", + scheme_addto_prim_instance("bitwise-bit-field", scheme_make_folding_prim(bitwise_bit_field, "bitwise-bit-field", 3, 3, 1), @@ -601,109 +616,109 @@ p = scheme_make_folding_prim(scheme_bitwise_shift, "arithmetic-shift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("arithmetic-shift", p, env); + scheme_addto_prim_instance("arithmetic-shift", p, env); p = scheme_make_folding_prim(integer_length, "integer-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("integer-length", p, env); + scheme_addto_prim_instance("integer-length", p, env); - scheme_add_global_constant("gcd", + scheme_addto_prim_instance("gcd", scheme_make_folding_prim(gcd, "gcd", 0, -1, 1), env); - scheme_add_global_constant("lcm", + scheme_addto_prim_instance("lcm", scheme_make_folding_prim(lcm, "lcm", 0, -1, 1), env); - scheme_add_global_constant("floor", + scheme_addto_prim_instance("floor", scheme_make_folding_prim(scheme_floor, "floor", 1, 1, 1), env); - scheme_add_global_constant("ceiling", + scheme_addto_prim_instance("ceiling", scheme_make_folding_prim(ceiling, "ceiling", 1, 1, 1), env); - scheme_add_global_constant("truncate", + scheme_addto_prim_instance("truncate", scheme_make_folding_prim(sch_truncate, "truncate", 1, 1, 1), env); - scheme_add_global_constant("round", + scheme_addto_prim_instance("round", scheme_make_folding_prim(sch_round, "round", 1, 1, 1), env); - scheme_add_global_constant("numerator", + scheme_addto_prim_instance("numerator", scheme_make_folding_prim(numerator, "numerator", 1, 1, 1), env); - scheme_add_global_constant("denominator", + scheme_addto_prim_instance("denominator", scheme_make_folding_prim(denominator, "denominator", 1, 1, 1), env); - scheme_add_global_constant("exp", + scheme_addto_prim_instance("exp", scheme_make_folding_prim(exp_prim, "exp", 1, 1, 1), env); - scheme_add_global_constant("log", - scheme_make_folding_prim(log_prim, + scheme_addto_prim_instance("log", + scheme_make_folding_prim(log_prim, "log", 1, 2, 1), env); - scheme_add_global_constant("sin", + scheme_addto_prim_instance("sin", scheme_make_folding_prim(sin_prim, "sin", 1, 1, 1), env); - scheme_add_global_constant("cos", + scheme_addto_prim_instance("cos", scheme_make_folding_prim(cos_prim, "cos", 1, 1, 1), env); - scheme_add_global_constant("tan", + scheme_addto_prim_instance("tan", scheme_make_folding_prim(tan_prim, "tan", 1, 1, 1), env); - scheme_add_global_constant("asin", + scheme_addto_prim_instance("asin", scheme_make_folding_prim(asin_prim, "asin", 1, 1, 1), env); - scheme_add_global_constant("acos", + scheme_addto_prim_instance("acos", scheme_make_folding_prim(acos_prim, "acos", 1, 1, 1), env); - scheme_add_global_constant("atan", + scheme_addto_prim_instance("atan", scheme_make_folding_prim(atan_prim, "atan", 1, 2, 1), env); - scheme_add_global_constant("sqrt", + scheme_addto_prim_instance("sqrt", scheme_make_folding_prim(scheme_sqrt, "sqrt", 1, 1, 1), env); - scheme_add_global_constant("integer-sqrt", + scheme_addto_prim_instance("integer-sqrt", scheme_make_folding_prim(int_sqrt, "integer-sqrt", 1, 1, 1), env); - scheme_add_global_constant("integer-sqrt/remainder", + scheme_addto_prim_instance("integer-sqrt/remainder", scheme_make_prim_w_arity2(int_sqrt_rem, "integer-sqrt/remainder", 1, 1, 2, 2), env); - scheme_add_global_constant("expt", + scheme_addto_prim_instance("expt", scheme_make_folding_prim(scheme_expt, "expt", 2, 2, 1), @@ -711,9 +726,9 @@ p = scheme_make_folding_prim(scheme_checked_make_rectangular, "make-rectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-rectangular", p, env); + scheme_addto_prim_instance("make-rectangular", p, env); - scheme_add_global_constant("make-polar", + scheme_addto_prim_instance("make-polar", scheme_make_folding_prim(scheme_make_polar, "make-polar", 2, 2, 1), @@ -721,18 +736,18 @@ p = scheme_make_folding_prim(scheme_checked_real_part, "real-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("real-part", p, env); + scheme_addto_prim_instance("real-part", p, env); p = scheme_make_folding_prim(scheme_checked_imag_part, "imag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("imag-part", p, env); + scheme_addto_prim_instance("imag-part", p, env); - scheme_add_global_constant("angle", + scheme_addto_prim_instance("angle", scheme_make_folding_prim(angle, "angle", 1, 1, 1), env); - scheme_add_global_constant("magnitude", + scheme_addto_prim_instance("magnitude", scheme_make_folding_prim(magnitude, "magnitude", 1, 1, 1), @@ -744,41 +759,41 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("exact->inexact", p, env); + scheme_addto_prim_instance("exact->inexact", p, env); p = scheme_make_folding_prim(scheme_inexact_to_exact, "inexact->exact", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("inexact->exact", p, env); + scheme_addto_prim_instance("inexact->exact", p, env); } -void scheme_init_flfxnum_number(Scheme_Env *env) +void scheme_init_flfxnum_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; - scheme_add_global_constant("flvector", + scheme_addto_prim_instance("flvector", scheme_make_prim_w_arity(flvector, "flvector", 0, -1), env); - scheme_add_global_constant("flvector?", + scheme_addto_prim_instance("flvector?", scheme_make_folding_prim(flvector_p, "flvector?", 1, 1, 1), env); - scheme_add_global_constant("make-flvector", + scheme_addto_prim_instance("make-flvector", scheme_make_immed_prim(make_flvector, "make-flvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env); p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("flvector-length", p, env); + scheme_addto_prim_instance("flvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_flvector_ref, "flvector-ref", @@ -789,51 +804,51 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flvector-ref", p, env); + scheme_addto_prim_instance("flvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_flvector_set, "flvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("flvector-set!", p, env); + scheme_addto_prim_instance("flvector-set!", p, env); - scheme_add_global_constant("fxvector", + scheme_addto_prim_instance("fxvector", scheme_make_prim_w_arity(fxvector, "fxvector", 0, -1), env); - scheme_add_global_constant("fxvector?", + scheme_addto_prim_instance("fxvector?", scheme_make_folding_prim(fxvector_p, "fxvector?", 1, 1, 1), env); - scheme_add_global_constant("make-fxvector", + scheme_addto_prim_instance("make-fxvector", scheme_make_immed_prim(make_fxvector, "make-fxvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env); p = scheme_make_immed_prim(fxvector_length, "fxvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxvector-length", p, env); + scheme_addto_prim_instance("fxvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_fxvector_ref, "fxvector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxvector-ref", p, env); + scheme_addto_prim_instance("fxvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_fxvector_set, "fxvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("fxvector-set!", p, env); + scheme_addto_prim_instance("fxvector-set!", p, env); p = scheme_make_folding_prim(integer_to_fl, "->fl", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -842,7 +857,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("->fl", p, env); + scheme_addto_prim_instance("->fl", p, env); p = scheme_make_folding_prim(fl_to_integer, "fl->exact-integer", 1, 1, 1); if (scheme_can_inline_fp_comp()) @@ -850,37 +865,41 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("fl->exact-integer", p, env); + scheme_addto_prim_instance("fl->exact-integer", p, env); p = scheme_make_folding_prim(fx_and, "fxand", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxand", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxand", p, env); p = scheme_make_folding_prim(fx_or, "fxior", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxior", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxior", p, env); p = scheme_make_folding_prim(fx_xor, "fxxor", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxxor", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxxor", p, env); p = scheme_make_folding_prim(fx_not, "fxnot", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxnot", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxnot", p, env); p = scheme_make_folding_prim(fx_lshift, "fxlshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxlshift", p, env); + scheme_addto_prim_instance("fxlshift", p, env); p = scheme_make_folding_prim(fx_rshift, "fxrshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxrshift", p, env); + scheme_addto_prim_instance("fxrshift", p, env); p = scheme_make_folding_prim(fx_to_fl, "fx->fl", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -889,7 +908,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fx->fl", p, env); + scheme_addto_prim_instance("fx->fl", p, env); p = scheme_make_folding_prim(fl_to_fx, "fl->fx", 1, 1, 1); if (scheme_can_inline_fp_comp()) @@ -899,7 +918,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fl->fx", p, env); + scheme_addto_prim_instance("fl->fx", p, env); p = scheme_make_folding_prim(fl_truncate, "fltruncate", 1, 1, 1); @@ -910,7 +929,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fltruncate", p, env); + scheme_addto_prim_instance("fltruncate", p, env); p = scheme_make_folding_prim(fl_round, "flround", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -920,7 +939,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flround", p, env); + scheme_addto_prim_instance("flround", p, env); p = scheme_make_folding_prim(fl_ceiling, "flceiling", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -930,7 +949,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flceiling", p, env); + scheme_addto_prim_instance("flceiling", p, env); p = scheme_make_folding_prim(fl_floor, "flfloor", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -940,7 +959,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flfloor", p, env); + scheme_addto_prim_instance("flfloor", p, env); p = scheme_make_folding_prim(fl_sin, "flsin", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -950,7 +969,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flsin", p, env); + scheme_addto_prim_instance("flsin", p, env); p = scheme_make_folding_prim(fl_cos, "flcos", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -960,7 +979,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flcos", p, env); + scheme_addto_prim_instance("flcos", p, env); p = scheme_make_folding_prim(fl_tan, "fltan", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -970,7 +989,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fltan", p, env); + scheme_addto_prim_instance("fltan", p, env); p = scheme_make_folding_prim(fl_asin, "flasin", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -980,7 +999,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flasin", p, env); + scheme_addto_prim_instance("flasin", p, env); p = scheme_make_folding_prim(fl_acos, "flacos", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -990,7 +1009,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flacos", p, env); + scheme_addto_prim_instance("flacos", p, env); p = scheme_make_folding_prim(fl_atan, "flatan", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1000,7 +1019,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flatan", p, env); + scheme_addto_prim_instance("flatan", p, env); p = scheme_make_folding_prim(fl_log, "fllog", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1010,7 +1029,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fllog", p, env); + scheme_addto_prim_instance("fllog", p, env); p = scheme_make_folding_prim(fl_exp, "flexp", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1020,7 +1039,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flexp", p, env); + scheme_addto_prim_instance("flexp", p, env); p = scheme_make_folding_prim(fl_expt, "flexpt", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -1030,24 +1049,24 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flexpt", p, env); + scheme_addto_prim_instance("flexpt", p, env); p = scheme_make_folding_prim(scheme_checked_make_rectangular, "make-flrectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-flrectangular", p, env); + scheme_addto_prim_instance("make-flrectangular", p, env); p = scheme_make_folding_prim(scheme_checked_flreal_part, "flreal-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flreal-part", p, env); + scheme_addto_prim_instance("flreal-part", p, env); p = scheme_make_folding_prim(scheme_checked_flimag_part, "flimag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flimag-part", p, env); + scheme_addto_prim_instance("flimag-part", p, env); } -void scheme_init_extfl_number(Scheme_Env *env) +void scheme_init_extfl_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1056,38 +1075,39 @@ p = scheme_make_folding_prim(extflonum_p, "extflonum?", 1, 1, 1); scheme_extflonum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("extflonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("extflonum?", p, env); - scheme_add_global_constant("extflonum-available?", + scheme_addto_prim_instance("extflonum-available?", scheme_make_noncm_prim(extflonum_available_p, "extflonum-available?", 0, 0), env); - scheme_add_global_constant("extflvector", + scheme_addto_prim_instance("extflvector", scheme_make_prim_w_arity(extflvector, "extflvector", 0, -1), env); - scheme_add_global_constant("extflvector?", + scheme_addto_prim_instance("extflvector?", scheme_make_folding_prim(extflvector_p, "extflvector?", 1, 1, 1), env); - scheme_add_global_constant("make-extflvector", + scheme_addto_prim_instance("make-extflvector", scheme_make_immed_prim(make_extflvector, "make-extflvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-extflvector", shared_extflvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-extflvector", make_shared_extflvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-extflvector", shared_extflvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-extflvector", make_shared_extflvector, 1, 2, env); p = scheme_make_immed_prim(extflvector_length, "extflvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("extflvector-length", p, env); + scheme_addto_prim_instance("extflvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_extflvector_ref, "extflvector-ref", 2, 2); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1096,7 +1116,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflvector-ref", p, env); + scheme_addto_prim_instance("extflvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_extflvector_set, "extflvector-set!", 3, 3); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1105,7 +1125,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("extflvector-set!", p, env); + scheme_addto_prim_instance("extflvector-set!", p, env); p = scheme_make_folding_prim(integer_to_extfl, "->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1114,7 +1134,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("->extfl", p, env); + scheme_addto_prim_instance("->extfl", p, env); p = scheme_make_folding_prim(extfl_to_integer, "extfl->exact-integer", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -1122,7 +1142,7 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->exact-integer", p, env); + scheme_addto_prim_instance("extfl->exact-integer", p, env); p = scheme_make_folding_prim(real_to_long_double_flonum, "real->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1131,7 +1151,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("real->extfl", p, env); + scheme_addto_prim_instance("real->extfl", p, env); p = scheme_make_folding_prim(extfl_to_exact, "extfl->exact", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1139,7 +1159,7 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->exact", p, env); + scheme_addto_prim_instance("extfl->exact", p, env); p = scheme_make_folding_prim(extfl_to_inexact, "extfl->inexact", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1147,7 +1167,7 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->inexact", p, env); + scheme_addto_prim_instance("extfl->inexact", p, env); p = scheme_make_folding_prim(fx_to_extfl, "fx->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1156,7 +1176,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("fx->extfl", p, env); + scheme_addto_prim_instance("fx->extfl", p, env); p = scheme_make_folding_prim(extfl_to_fx, "extfl->fx", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -1166,7 +1186,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("extfl->fx", p, env); + scheme_addto_prim_instance("extfl->fx", p, env); p = scheme_make_folding_prim(extfl_truncate, "extfltruncate", 1, 1, 1); @@ -1177,7 +1197,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfltruncate", p, env); + scheme_addto_prim_instance("extfltruncate", p, env); p = scheme_make_folding_prim(extfl_round, "extflround", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1187,7 +1207,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflround", p, env); + scheme_addto_prim_instance("extflround", p, env); p = scheme_make_folding_prim(extfl_ceiling, "extflceiling", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1197,7 +1217,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflceiling", p, env); + scheme_addto_prim_instance("extflceiling", p, env); p = scheme_make_folding_prim(extfl_floor, "extflfloor", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1207,7 +1227,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflfloor", p, env); + scheme_addto_prim_instance("extflfloor", p, env); p = scheme_make_folding_prim(extfl_sin, "extflsin", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1217,7 +1237,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflsin", p, env); + scheme_addto_prim_instance("extflsin", p, env); p = scheme_make_folding_prim(extfl_cos, "extflcos", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1227,7 +1247,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflcos", p, env); + scheme_addto_prim_instance("extflcos", p, env); p = scheme_make_folding_prim(extfl_tan, "extfltan", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1237,7 +1257,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfltan", p, env); + scheme_addto_prim_instance("extfltan", p, env); p = scheme_make_folding_prim(extfl_asin, "extflasin", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1247,7 +1267,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflasin", p, env); + scheme_addto_prim_instance("extflasin", p, env); p = scheme_make_folding_prim(extfl_acos, "extflacos", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1257,7 +1277,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflacos", p, env); + scheme_addto_prim_instance("extflacos", p, env); p = scheme_make_folding_prim(extfl_atan, "extflatan", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1267,7 +1287,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflatan", p, env); + scheme_addto_prim_instance("extflatan", p, env); p = scheme_make_folding_prim(extfl_log, "extfllog", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1277,7 +1297,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfllog", p, env); + scheme_addto_prim_instance("extfllog", p, env); p = scheme_make_folding_prim(extfl_exp, "extflexp", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1287,7 +1307,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflexp", p, env); + scheme_addto_prim_instance("extflexp", p, env); p = scheme_make_folding_prim(extfl_expt, "extflexpt", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1297,10 +1317,10 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflexpt", p, env); + scheme_addto_prim_instance("extflexpt", p, env); } -void scheme_init_unsafe_number(Scheme_Env *env) +void scheme_init_unsafe_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1309,7 +1329,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxand", p, env); + scheme_addto_prim_instance("unsafe-fxand", p, env); REGISTER_SO(scheme_unsafe_fxand_proc); scheme_unsafe_fxand_proc = p; @@ -1317,7 +1337,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxior", p, env); + scheme_addto_prim_instance("unsafe-fxior", p, env); REGISTER_SO(scheme_unsafe_fxior_proc); scheme_unsafe_fxior_proc = p; @@ -1325,7 +1345,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxxor", p, env); + scheme_addto_prim_instance("unsafe-fxxor", p, env); REGISTER_SO(scheme_unsafe_fxxor_proc); scheme_unsafe_fxxor_proc = p; @@ -1333,7 +1353,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxnot", p, env); + scheme_addto_prim_instance("unsafe-fxnot", p, env); REGISTER_SO(scheme_unsafe_fxnot_proc); scheme_unsafe_fxnot_proc = p; @@ -1341,13 +1361,13 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxlshift", p, env); + scheme_addto_prim_instance("unsafe-fxlshift", p, env); p = scheme_make_folding_prim(unsafe_fx_rshift, "unsafe-fxrshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxrshift", p, env); + scheme_addto_prim_instance("unsafe-fxrshift", p, env); REGISTER_SO(scheme_unsafe_fxrshift_proc); scheme_unsafe_fxrshift_proc = p; @@ -1359,14 +1379,14 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-fx->fl", p, env); + scheme_addto_prim_instance("unsafe-fx->fl", p, env); p = scheme_make_folding_prim(unsafe_fl_to_fx, "unsafe-fl->fx", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fl->fx", p, env); + scheme_addto_prim_instance("unsafe-fl->fx", p, env); p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref", 2, 2); @@ -1378,7 +1398,7 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-f64vector-ref", p, env); + scheme_addto_prim_instance("unsafe-f64vector-ref", p, env); p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", 3, 3); @@ -1388,14 +1408,14 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("unsafe-f64vector-set!", p, env); + scheme_addto_prim_instance("unsafe-f64vector-set!", p, env); p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-flvector-length", p, env); + scheme_addto_prim_instance("unsafe-flvector-length", p, env); p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", 2, 2); @@ -1407,20 +1427,20 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flvector-ref", p, env); + scheme_addto_prim_instance("unsafe-flvector-ref", p, env); p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("unsafe-flvector-set!", p, env); + scheme_addto_prim_instance("unsafe-flvector-set!", p, env); p = scheme_make_immed_prim(unsafe_fxvector_length, "unsafe-fxvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxvector-length", p, env); + scheme_addto_prim_instance("unsafe-fxvector-length", p, env); p = scheme_make_immed_prim(unsafe_fxvector_ref, "unsafe-fxvector-ref", 2, 2); @@ -1428,24 +1448,24 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxvector-ref", p, env); + scheme_addto_prim_instance("unsafe-fxvector-ref", p, env); p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-fxvector-set!", p, env); + scheme_addto_prim_instance("unsafe-fxvector-set!", p, env); p = scheme_make_immed_prim(s16_ref, "unsafe-s16vector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-s16vector-ref", p, env); + scheme_addto_prim_instance("unsafe-s16vector-ref", p, env); p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-s16vector-set!", p, env); + scheme_addto_prim_instance("unsafe-s16vector-set!", p, env); p = scheme_make_immed_prim(u16_ref, "unsafe-u16vector-ref", 2, 2); @@ -1453,29 +1473,29 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-u16vector-ref", p, env); + scheme_addto_prim_instance("unsafe-u16vector-ref", p, env); p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-u16vector-set!", p, env); + scheme_addto_prim_instance("unsafe-u16vector-set!", p, env); p = scheme_make_folding_prim(unsafe_make_flrectangular, "unsafe-make-flrectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-make-flrectangular", p, env); + scheme_addto_prim_instance("unsafe-make-flrectangular", p, env); p = scheme_make_folding_prim(unsafe_flreal_part, "unsafe-flreal-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flreal-part", p, env); + scheme_addto_prim_instance("unsafe-flreal-part", p, env); p = scheme_make_folding_prim(unsafe_flimag_part, "unsafe-flimag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flimag-part", p, env); + scheme_addto_prim_instance("unsafe-flimag-part", p, env); p = scheme_make_immed_prim(unsafe_flrandom, "unsafe-flrandom", 1, 1); if (scheme_can_inline_fp_op()) @@ -1484,10 +1504,10 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flrandom", p, env); + scheme_addto_prim_instance("unsafe-flrandom", p, env); } -void scheme_init_extfl_unsafe_number(Scheme_Env *env) +void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1500,7 +1520,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-fx->extfl", p, env); + scheme_addto_prim_instance("unsafe-fx->extfl", p, env); p = scheme_make_folding_prim(unsafe_extfl_to_fx, "unsafe-extfl->fx", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1511,7 +1531,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-extfl->fx", p, env); + scheme_addto_prim_instance("unsafe-extfl->fx", p, env); p = scheme_make_immed_prim(unsafe_extflvector_length, "unsafe-extflvector-length", 1, 1); @@ -1522,7 +1542,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-extflvector-length", p, env); + scheme_addto_prim_instance("unsafe-extflvector-length", p, env); p = scheme_make_immed_prim(unsafe_extflvector_ref, "unsafe-extflvector-ref", 2, 2); @@ -1534,7 +1554,7 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-extflvector-ref", p, env); + scheme_addto_prim_instance("unsafe-extflvector-ref", p, env); p = scheme_make_immed_prim(unsafe_extflvector_set, "unsafe-extflvector-set!", 3, 3); @@ -1544,7 +1564,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("unsafe-extflvector-set!", p, env); + scheme_addto_prim_instance("unsafe-extflvector-set!", p, env); p = scheme_make_immed_prim(extfl_ref, "unsafe-f80vector-ref", 2, 2); @@ -1556,7 +1576,7 @@ | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-f80vector-ref", p, env); + scheme_addto_prim_instance("unsafe-f80vector-ref", p, env); p = scheme_make_immed_prim(extfl_set, "unsafe-f80vector-set!", 3, 3); @@ -1566,7 +1586,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("unsafe-f80vector-set!", p, env); + scheme_addto_prim_instance("unsafe-f80vector-set!", p, env); } #ifdef _MSC_VER @@ -1775,6 +1795,7 @@ } XFORM_NONGCING static MZ_INLINE int minus_zero_p(double d) + XFORM_SKIP_PROC { #ifdef MZ_IS_NEG_ZERO return MZ_IS_NEG_ZERO(d); @@ -1788,7 +1809,9 @@ return minus_zero_p(d); } -static int rational_dbl_p(double f) { +XFORM_NONGCING static int rational_dbl_p(double f) + XFORM_SKIP_PROC +{ return !(MZ_IS_NAN(f) || MZ_IS_INFINITY(f)); } @@ -1934,7 +1957,7 @@ return (SCHEME_REALP(o) ? scheme_true : scheme_false); } -static int is_rational(const Scheme_Object *o) +XFORM_NONGCING static int is_rational(const Scheme_Object *o) { if (SCHEME_FLOATP(o)) return rational_dbl_p(SCHEME_FLOAT_VAL(o)); @@ -5401,6 +5424,35 @@ SAFE_BIN_EXTFL(expt) +static Scheme_Object *fold_fixnum_bitwise_shift(int argc, Scheme_Object *argv[]) +{ + intptr_t v, base, amt, kept; + + /* Unlike folding for other fixnum operations, even if the arguments + are fixnums, we must specifically ensure that the result is a + fixnum. It's up to the programmer to ensure that fixnums passed + in are ok for all platforms, but we have to bail out of folding + if the result is not going to be consistent for all platforms. */ + if (!SCHEME_INTP(argv[0]) || !SCHEME_INTP(argv[1])) + scheme_signal_error("unsafe-fxlshift: arguments are not both fixnums"); + + amt = SCHEME_INT_VAL(argv[1]); + kept = (sizeof(intptr_t) * 8) - amt - 2; /* bits that are definitely kept */ + if ((amt >= 29) || (kept <= 1)) + scheme_signal_error("unsafe-fxlshift: shift is too large"); + + base = SCHEME_INT_VAL(argv[0]); + /* Consistent if potentially unkept bits are all 0 or 1 */ + if (!(base - (base & ((1 << kept) - 1))) + || !(~(base | ((1 << kept) - 1)))) { + v = base << amt; + + return scheme_make_integer(v); + } else { + scheme_signal_error("unsafe-fxlshift: result is not clearly consistent across platforms"); + return NULL; + } +} #define UNSAFE_FX(name, op, fold, type) \ static Scheme_Object *name(int argc, Scheme_Object *argv[]) \ @@ -5414,8 +5466,7 @@ UNSAFE_FX(unsafe_fx_and, &, scheme_bitwise_and, intptr_t) UNSAFE_FX(unsafe_fx_or, |, bitwise_or, intptr_t) UNSAFE_FX(unsafe_fx_xor, ^, bitwise_xor, intptr_t) -UNSAFE_FX(unsafe_fx_lshift, <<, scheme_bitwise_shift, uintptr_t) - +UNSAFE_FX(unsafe_fx_lshift, <<, fold_fixnum_bitwise_shift, uintptr_t) UNSAFE_FX(unsafe_fx_rshift, >>, neg_bitwise_shift, intptr_t) static Scheme_Object *unsafe_fx_not (int argc, Scheme_Object *argv[]) diff -Nru racket-6.12+ppa1/src/racket/src/numcomp.c racket-7.0+ppa1/src/racket/src/numcomp.c --- racket-6.12+ppa1/src/racket/src/numcomp.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/numcomp.c 2018-07-27 22:12:02.000000000 +0000 @@ -98,7 +98,7 @@ #define zeroi scheme_exact_zero -void scheme_init_numcomp(Scheme_Env *env) +void scheme_init_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -106,96 +106,121 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_NUMBER - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("=", p, env); p = scheme_make_folding_prim(lt, "<", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("<", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("<", p, env); p = scheme_make_folding_prim(gt, ">", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant(">", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance(">", p, env); p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("<=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("<=", p, env); p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant(">=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance(">=", p, env); p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_NUMBER - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("zero?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("zero?", p, env); p = scheme_make_folding_prim(positive_p, "positive?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("positive?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("positive?", p, env); p = scheme_make_folding_prim(negative_p, "negative?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("negative?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("negative?", p, env); p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS - | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("max", p, env); + | SCHEME_PRIM_PRODUCES_REAL + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("max", p, env); p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS - | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("min", p, env); + | SCHEME_PRIM_PRODUCES_REAL + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("min", p, env); } -void scheme_init_flfxnum_numcomp(Scheme_Env *env) +void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; p = scheme_make_folding_prim(fx_eq, "fx=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx=", p, env); p = scheme_make_folding_prim(fx_lt, "fx<", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx<", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx<", p, env); p = scheme_make_folding_prim(fx_gt, "fx>", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx>", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx>", p, env); p = scheme_make_folding_prim(fx_lt_eq, "fx<=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx<=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx<=", p, env); p = scheme_make_folding_prim(fx_gt_eq, "fx>=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx>=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx>=", p, env); p = scheme_make_folding_prim(fx_min, "fxmin", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -203,8 +228,9 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmin", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxmin", p, env); p = scheme_make_folding_prim(fx_max, "fxmax", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -212,8 +238,9 @@ else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmax", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxmax", p, env); p = scheme_make_folding_prim(fl_eq, "fl=", 2, 2, 1); @@ -223,7 +250,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl=", p, env); + scheme_addto_prim_instance("fl=", p, env); p = scheme_make_folding_prim(fl_lt, "fl<", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -232,7 +259,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl<", p, env); + scheme_addto_prim_instance("fl<", p, env); p = scheme_make_folding_prim(fl_gt, "fl>", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -241,7 +268,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl>", p, env); + scheme_addto_prim_instance("fl>", p, env); p = scheme_make_folding_prim(fl_lt_eq, "fl<=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -250,7 +277,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl<=", p, env); + scheme_addto_prim_instance("fl<=", p, env); p = scheme_make_folding_prim(fl_gt_eq, "fl>=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -259,7 +286,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl>=", p, env); + scheme_addto_prim_instance("fl>=", p, env); p = scheme_make_folding_prim(fl_min, "flmin", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -269,7 +296,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("flmin", p, env); + scheme_addto_prim_instance("flmin", p, env); p = scheme_make_folding_prim(fl_max, "flmax", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -279,10 +306,10 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("flmax", p, env); + scheme_addto_prim_instance("flmax", p, env); } -void scheme_init_extfl_numcomp(Scheme_Env *env) +void scheme_init_extfl_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -294,7 +321,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl=", p, env); + scheme_addto_prim_instance("extfl=", p, env); p = scheme_make_folding_prim(extfl_lt, "extfl<", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -303,7 +330,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl<", p, env); + scheme_addto_prim_instance("extfl<", p, env); p = scheme_make_folding_prim(extfl_gt, "extfl>", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -312,7 +339,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl>", p, env); + scheme_addto_prim_instance("extfl>", p, env); p = scheme_make_folding_prim(extfl_lt_eq, "extfl<=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -321,7 +348,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl<=", p, env); + scheme_addto_prim_instance("extfl<=", p, env); p = scheme_make_folding_prim(extfl_gt_eq, "extfl>=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -330,7 +357,7 @@ flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl>=", p, env); + scheme_addto_prim_instance("extfl>=", p, env); p = scheme_make_folding_prim(extfl_min, "extflmin", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -340,7 +367,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extflmin", p, env); + scheme_addto_prim_instance("extflmin", p, env); p = scheme_make_folding_prim(extfl_max, "extflmax", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -350,10 +377,10 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extflmax", p, env); + scheme_addto_prim_instance("extflmax", p, env); } -void scheme_init_unsafe_numcomp(Scheme_Env *env) +void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -362,35 +389,35 @@ p = scheme_make_folding_prim(unsafe_fx_eq, "unsafe-fx=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx=", p, env); + scheme_addto_prim_instance("unsafe-fx=", p, env); scheme_unsafe_fx_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_lt_proc); p = scheme_make_folding_prim(unsafe_fx_lt, "unsafe-fx<", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx<", p, env); + scheme_addto_prim_instance("unsafe-fx<", p, env); scheme_unsafe_fx_lt_proc = p; REGISTER_SO(scheme_unsafe_fx_gt_proc); p = scheme_make_folding_prim(unsafe_fx_gt, "unsafe-fx>", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx>", p, env); + scheme_addto_prim_instance("unsafe-fx>", p, env); scheme_unsafe_fx_gt_proc = p; REGISTER_SO(scheme_unsafe_fx_lt_eq_proc); p = scheme_make_folding_prim(unsafe_fx_lt_eq, "unsafe-fx<=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx<=", p, env); + scheme_addto_prim_instance("unsafe-fx<=", p, env); scheme_unsafe_fx_lt_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_gt_eq_proc); p = scheme_make_folding_prim(unsafe_fx_gt_eq, "unsafe-fx>=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx>=", p, env); + scheme_addto_prim_instance("unsafe-fx>=", p, env); scheme_unsafe_fx_gt_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_min_proc); @@ -398,7 +425,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmin", p, env); + scheme_addto_prim_instance("unsafe-fxmin", p, env); scheme_unsafe_fx_min_proc = p; REGISTER_SO(scheme_unsafe_fx_max_proc); @@ -406,7 +433,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmax", p, env); + scheme_addto_prim_instance("unsafe-fxmax", p, env); scheme_unsafe_fx_max_proc = p; p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 2, 2, 1); @@ -417,7 +444,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl=", p, env); + scheme_addto_prim_instance("unsafe-fl=", p, env); p = scheme_make_folding_prim(unsafe_fl_lt, "unsafe-fl<", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -427,7 +454,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl<", p, env); + scheme_addto_prim_instance("unsafe-fl<", p, env); p = scheme_make_folding_prim(unsafe_fl_gt, "unsafe-fl>", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -437,7 +464,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl>", p, env); + scheme_addto_prim_instance("unsafe-fl>", p, env); p = scheme_make_folding_prim(unsafe_fl_lt_eq, "unsafe-fl<=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -447,7 +474,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl<=", p, env); + scheme_addto_prim_instance("unsafe-fl<=", p, env); p = scheme_make_folding_prim(unsafe_fl_gt_eq, "unsafe-fl>=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -457,7 +484,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl>=", p, env); + scheme_addto_prim_instance("unsafe-fl>=", p, env); p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -468,7 +495,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-flmin", p, env); + scheme_addto_prim_instance("unsafe-flmin", p, env); p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -479,10 +506,10 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-flmax", p, env); + scheme_addto_prim_instance("unsafe-flmax", p, env); } -void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) +void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -495,7 +522,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl=", p, env); + scheme_addto_prim_instance("unsafe-extfl=", p, env); p = scheme_make_folding_prim(unsafe_extfl_lt, "unsafe-extfl<", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -505,7 +532,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl<", p, env); + scheme_addto_prim_instance("unsafe-extfl<", p, env); p = scheme_make_folding_prim(unsafe_extfl_gt, "unsafe-extfl>", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -515,7 +542,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl>", p, env); + scheme_addto_prim_instance("unsafe-extfl>", p, env); p = scheme_make_folding_prim(unsafe_extfl_lt_eq, "unsafe-extfl<=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -525,7 +552,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl<=", p, env); + scheme_addto_prim_instance("unsafe-extfl<=", p, env); p = scheme_make_folding_prim(unsafe_extfl_gt_eq, "unsafe-extfl>=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -535,7 +562,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl>=", p, env); + scheme_addto_prim_instance("unsafe-extfl>=", p, env); p = scheme_make_folding_prim(unsafe_extfl_min, "unsafe-extflmin", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -546,7 +573,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extflmin", p, env); + scheme_addto_prim_instance("unsafe-extflmin", p, env); p = scheme_make_folding_prim(unsafe_extfl_max, "unsafe-extflmax", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -557,7 +584,7 @@ | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extflmax", p, env); + scheme_addto_prim_instance("unsafe-extflmax", p, env); } /* Prototype needed for 3m conversion: */ diff -Nru racket-6.12+ppa1/src/racket/src/numstr.c racket-7.0+ppa1/src/racket/src/numstr.c --- racket-6.12+ppa1/src/racket/src/numstr.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/numstr.c 2018-07-27 22:12:02.000000000 +0000 @@ -96,7 +96,7 @@ #define zeroi scheme_exact_zero -void scheme_init_numstr(Scheme_Env *env) +void scheme_init_numstr(Scheme_Startup_Env *env) { REGISTER_SO(decimal_as_inexact_symbol); REGISTER_SO(decimal_as_exact_symbol); @@ -108,89 +108,89 @@ read_symbol = scheme_intern_symbol("read"); number_or_false_symbol = scheme_intern_symbol("number-or-false"); - scheme_add_global_constant("number->string", + scheme_addto_prim_instance("number->string", scheme_make_immed_prim(number_to_string, "number->string", 1, 2), env); - scheme_add_global_constant("string->number", + scheme_addto_prim_instance("string->number", scheme_make_folding_prim(string_to_number, "string->number", 1, 4, 1), env); - scheme_add_global_constant("integer-bytes->integer", + scheme_addto_prim_instance("integer-bytes->integer", scheme_make_immed_prim(bytes_to_integer, "integer-bytes->integer", 2, 5), env); - scheme_add_global_constant("integer->integer-bytes", + scheme_addto_prim_instance("integer->integer-bytes", scheme_make_immed_prim(integer_to_bytes, "integer->integer-bytes", 3, 6), env); - scheme_add_global_constant("floating-point-bytes->real", + scheme_addto_prim_instance("floating-point-bytes->real", scheme_make_immed_prim(bytes_to_real, "floating-point-bytes->real", 1, 4), env); - scheme_add_global_constant("real->floating-point-bytes", + scheme_addto_prim_instance("real->floating-point-bytes", scheme_make_immed_prim(real_to_bytes, "real->floating-point-bytes", 2, 5), env); - scheme_add_global_constant("system-big-endian?", + scheme_addto_prim_instance("system-big-endian?", scheme_make_immed_prim(system_big_endian_p, "system-big-endian?", 0, 0), env); - scheme_add_global_constant("random", + scheme_addto_prim_instance("random", scheme_make_immed_prim(sch_random, "random", 0, 2), env); - scheme_add_global_constant("random-seed", + scheme_addto_prim_instance("random-seed", scheme_make_immed_prim(random_seed, "random-seed", 1, 1), env); - scheme_add_global_constant("make-pseudo-random-generator", + scheme_addto_prim_instance("make-pseudo-random-generator", scheme_make_immed_prim(make_pseudo_random_generator, "make-pseudo-random-generator", 0, 0), env); - scheme_add_global_constant("vector->pseudo-random-generator", + scheme_addto_prim_instance("vector->pseudo-random-generator", scheme_make_immed_prim(sch_pack, "vector->pseudo-random-generator", 1, 1), env); - scheme_add_global_constant("vector->pseudo-random-generator!", + scheme_addto_prim_instance("vector->pseudo-random-generator!", scheme_make_immed_prim(sch_pack_bang, "vector->pseudo-random-generator!", 2, 2), env); - scheme_add_global_constant("pseudo-random-generator->vector", + scheme_addto_prim_instance("pseudo-random-generator->vector", scheme_make_immed_prim(sch_unpack, "pseudo-random-generator->vector", 1, 1), env); - scheme_add_global_constant("pseudo-random-generator-vector?", + scheme_addto_prim_instance("pseudo-random-generator-vector?", scheme_make_immed_prim(sch_check_pack, "pseudo-random-generator-vector?", 1, 1), env); - scheme_add_global_constant("pseudo-random-generator?", + scheme_addto_prim_instance("pseudo-random-generator?", scheme_make_immed_prim(pseudo_random_generator_p, "pseudo-random-generator?", 1, 1), env); - scheme_add_global_constant("current-pseudo-random-generator", + scheme_addto_prim_instance("current-pseudo-random-generator", scheme_register_parameter(current_pseudo_random_generator, "current-pseudo-random-generator", MZCONFIG_RANDOM_STATE), env); - scheme_add_global_constant("current-evt-pseudo-random-generator", + scheme_addto_prim_instance("current-evt-pseudo-random-generator", scheme_register_parameter(current_sched_pseudo_random_generator, "current-evt-pseudo-random-generator", MZCONFIG_SCHEDULER_RANDOM_STATE), @@ -217,14 +217,14 @@ #endif } -void scheme_init_extfl_numstr(Scheme_Env *env) +void scheme_init_extfl_numstr(Scheme_Startup_Env *env) { - scheme_add_global_constant("floating-point-bytes->extfl", + scheme_addto_prim_instance("floating-point-bytes->extfl", scheme_make_immed_prim(bytes_to_long_double, "floating-point-bytes->extfl", 1, 4), env); - scheme_add_global_constant("extfl->floating-point-bytes", + scheme_addto_prim_instance("extfl->floating-point-bytes", scheme_make_immed_prim(long_double_to_bytes, "extfl->floating-point-bytes", 1, 4), @@ -520,12 +520,29 @@ #define DISALLOW_EXTFLONUM(special, other) \ if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \ if (report) \ - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, \ + return scheme_numr_err(complain, \ "cannot combine extflonum into complex number: %u", \ str, len); \ return scheme_false; \ } +/* + The scheme_read-number() parser could be simplified somewhat, + because it only has to work for: + + - `string->number` when called on a well-formed fixnum, bignum, + {double-,single-,ext}flonum; + + - reading S-expression literals from bytes, where numbers will be + in a canonical form (no `#`), but where symbols still must be + distinguished from numbers; and + + - printing symbols, to detect when they need to be escaped. + + For those purposes, it doesn't need to provide good error messages, + deal with non-default exactness, or handle non-base-10 + representations for non-real numbers. +*/ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, int is_float, int is_not_float, @@ -533,9 +550,7 @@ int radix, int radix_set, Scheme_Object *complain, int *div_by_zero, - int test_only, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation) + int test_only) { int i, has_decimal, must_parse, has_slash; int report, delta; @@ -557,8 +572,8 @@ if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') { if (radix_set) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad radix specification: %u", + return scheme_numr_err(complain, + "bad radix specification in `%u`", str, len); else return scheme_false; @@ -567,8 +582,8 @@ } else { if (is_float || is_not_float) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad exactness specification: %u", + return scheme_numr_err(complain, + "bad exactness specification in `%u`", str, len); else return scheme_false; @@ -602,8 +617,8 @@ break; default: if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad `#' indicator `%c': %u", + return scheme_numr_err(complain, + "bad `#` indicator `%c` in `%u`", str[delta+1], str, len); return scheme_false; } @@ -617,8 +632,7 @@ if (!(len - delta)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits"); + return scheme_numr_err(complain, "no digits"); return scheme_false; } @@ -630,7 +644,7 @@ if (!is_not_float) return special; if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -675,7 +689,7 @@ if (is_not_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -684,9 +698,7 @@ other = scheme_read_number(s2, len - delta - 6 + 4, is_float, is_not_float, 1, radix, 1, 0, - &dbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &dbz, test_only); if (SCHEME_CHAR_STRINGP(other)) return other; @@ -697,8 +709,8 @@ if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -718,7 +730,7 @@ if (is_not_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -771,16 +783,14 @@ if (s2[i]) other = scheme_false; - else { + else other = scheme_read_number(s2, len - delta - 7, is_float, is_not_float, 1, radix, 1, 0, - &dbz, test_only, - stxsrc, line, col, pos, span, - indentation); - if (SCHEME_CHAR_STRINGP(other)) - return other; - } + &dbz, test_only); + + if (SCHEME_CHAR_STRINGP(other)) + return other; DISALLOW_EXTFLONUM(special, other); @@ -788,8 +798,8 @@ if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -835,8 +845,8 @@ mzchar ch = str[i]; if (!ch) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "embedded null character: %u", + return scheme_numr_err(complain, + "embedded null character in `%u`", str, len); return scheme_false; } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) { @@ -846,8 +856,8 @@ } else if ((ch == '+') || (ch == '-')) { if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "too many signs: %u", + return scheme_numr_err(complain, + "too many signs in `%u`", str, len); return scheme_false; } @@ -855,15 +865,15 @@ } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) { if (has_at) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot mix `@' and `i': %u", + return scheme_numr_err(complain, + "cannot mix `@` and `i` in `%u`", str, len); return scheme_false; } if (i + 1 < len) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "`i' must be at the end: %u", + return scheme_numr_err(complain, + "`i' must be at the end in `%u`", str, len); return scheme_false; } @@ -871,15 +881,15 @@ } else if (ch == '@') { if (has_at) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "too many `@'s: %u", + return scheme_numr_err(complain, + "too many `@`s in `%u`", str, len); return scheme_false; } if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "`@' cannot be at start: %u", + return scheme_numr_err(complain, + "`@` cannot be at start in `%u`", str, len); return scheme_false; } @@ -912,9 +922,7 @@ n1 = scheme_read_number(first, has_sign - delta, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &fdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &fdbz, test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; } else @@ -933,9 +941,7 @@ n2 = scheme_read_number(second, has_i - has_sign, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &sdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &sdbz, test_only); if (SCHEME_CHAR_STRINGP(n2)) return n2; } else if (str[has_sign] == '-') @@ -958,8 +964,8 @@ if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -1002,11 +1008,10 @@ n2 = scheme_read_number(second, len - has_at - 1, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &fdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &fdbz, test_only); + if (SCHEME_CHAR_STRINGP(n2)) - return n2; + return n2; if (!fdbz) { if (SCHEME_FALSEP(n2)) @@ -1018,9 +1023,7 @@ is_float, is_not_float, decimal_means_float, radix, 1, complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (!SCHEME_LONG_DBLP(n2)) { n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */ @@ -1037,9 +1040,7 @@ is_float, is_not_float, decimal_means_float, radix, 1, next_complain, &sdbz, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; @@ -1061,8 +1062,8 @@ if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero in %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -1101,16 +1102,16 @@ if (ch == '.') { if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "multiple decimal points: %u", + return scheme_numr_err(complain, + "multiple decimal points in `%u`", str, len); return scheme_false; } if (has_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "decimal points and fractions " - "cannot be mixed: %u", + "cannot be mixed in `%u`", str, len); return scheme_false; } @@ -1119,8 +1120,8 @@ && ((radix <= 10) || !isbaseNdigit(radix, ch))) { if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot begin with `%c' in %u", + return scheme_numr_err(complain, + "cannot begin with `%c` in `%u`", ch, str, len); return scheme_false; } @@ -1129,23 +1130,23 @@ } else if (ch == '/') { if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot have slash at start: %u", + return scheme_numr_err(complain, + "cannot have slash at start in `%u`", str, len); return scheme_false; } if (has_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "multiple slashes: %u", + return scheme_numr_err(complain, + "multiple slashes in `%u`", str, len); return scheme_false; } if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "decimal points and fractions " - "cannot be mixed: %u", + "cannot be mixed in `%u`", str, len); return scheme_false; } @@ -1155,16 +1156,16 @@ } else if ((ch == '-') || (ch == '+')) { if (has_slash || has_decimal || has_hash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced sign: %u", + return scheme_numr_err(complain, + "misplaced sign in `%u`", str, len); return scheme_false; } } else if (ch == '#') { if (!saw_digit_since_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1173,15 +1174,15 @@ } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) { if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number: %u", + return scheme_numr_err(complain, + "bad decimal number in `%u`", str, len); return scheme_false; } if (has_hash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1192,8 +1193,8 @@ saw_nonzero_digit = 1; if (has_hash_since_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1243,8 +1244,8 @@ if (has_expt && !(str[has_expt + 1])) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits after \"%c\": %u", + return scheme_numr_err(complain, + "no digits after `%c` in `%u`", str[has_expt], str, len); return scheme_false; } @@ -1282,8 +1283,8 @@ if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number %u", + return scheme_numr_err(complain, + "bad decimal number `%u`", str, len); return scheme_false; } @@ -1291,8 +1292,8 @@ if (is_long_double && is_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to inexact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to inexact in `%u`", str, len); return scheme_false; } @@ -1352,8 +1353,8 @@ if (!str[has_expt + 1]) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits after \"%c\": %u", + return scheme_numr_err(complain, + "no digits after `%c` in `%u`", str[has_expt], str, len); return scheme_false; } @@ -1372,8 +1373,8 @@ exponent = scheme_read_bignum(substr, 0, radix); if (SCHEME_FALSEP(exponent)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad exponent: %u", + return scheme_numr_err(complain, + "bad exponent in `%u`", str, len); return scheme_false; } @@ -1396,9 +1397,7 @@ is_float, is_not_float, 1, radix, 1, next_complain, &dbz, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (SCHEME_CHAR_STRINGP(mantissa)) return mantissa; @@ -1408,13 +1407,13 @@ if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); } if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad number: %u", + return scheme_numr_err(complain, + "bad number `%u`", str, len); return scheme_false; } @@ -1467,16 +1466,16 @@ || !dcp || (dcp == 1 && !(isAdigit(digits[0]) || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number %u", + return scheme_numr_err(complain, + "bad decimal number `%u`", str, len); return scheme_false; } if (is_long_double && is_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to inexact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to inexact in `%u`", str, len); return scheme_false; } @@ -1562,8 +1561,8 @@ } else { if (is_long_double) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to exact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to exact in `%u`", str, len); return scheme_false; } @@ -1600,13 +1599,9 @@ 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); - + test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; - if (SAME_OBJ(n1, scheme_false)) return scheme_false; @@ -1629,21 +1624,18 @@ 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); } if (SCHEME_CHAR_STRINGP(n2)) return n2; - if (SAME_OBJ(n2, scheme_false)) return scheme_false; if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); if (div_by_zero) *div_by_zero = 1; @@ -1661,7 +1653,7 @@ if (SCHEME_FLOATP(n1)) { if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", n1); return scheme_false; @@ -1677,8 +1669,8 @@ o = scheme_read_bignum(str, delta, radix); if (SAME_OBJ(o, scheme_false)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad number: %u", + return scheme_numr_err(complain, + "bad number `%u`", str, len); } else if (is_float) { /* Special case: "#i-0" => -0. */ @@ -1802,8 +1794,7 @@ ESCAPED_BEFORE_HERE; } } else { - decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_READ_DECIMAL_INEXACT)); + decimal_inexact = 1; } mzstr = SCHEME_CHAR_STR_VAL(argv[0]); @@ -1812,8 +1803,7 @@ v = scheme_read_number(mzstr, len, 0, 0, decimal_inexact, radix, 0, reader_mode, &div_by_zero, - 0, NULL, 0, 0, 0, 0, - NULL); + 0); if (!reader_mode && SCHEME_LONG_DBLP(v)) return scheme_false; @@ -2382,7 +2372,7 @@ offset = 0; if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) { - scheme_contract_error("integer-bytes->integer", + scheme_contract_error("integer->integer-bytes", "byte string length is shorter than starting position plus size", "byte string length", 1, scheme_make_integer(SCHEME_BYTE_STRLEN_VAL(s)), "starting position", 1, scheme_make_integer(offset), diff -Nru racket-6.12+ppa1/src/racket/src/optimize.c racket-7.0+ppa1/src/racket/src/optimize.c --- racket-6.12+ppa1/src/racket/src/optimize.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/optimize.c 2018-07-27 22:12:02.000000000 +0000 @@ -37,10 +37,10 @@ #define OPT_LIMIT_FUNCTION_RESIZE 0 #define OPT_BRANCH_ADDS_NO_SIZE 1 #define OPT_DELAY_GROUP_PROPAGATE 0 -#define OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override) (size_override) +#define OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(size_override) (size_override) #define MAX_PROC_INLINE_SIZE 256 -#define CROSS_MODULE_INLINE_SIZE 8 +#define CROSS_LINKLET_INLINE_SIZE 8 /* Various kinds of fuel ensure that the compiler doesn't go into a loop @@ -48,6 +48,23 @@ #define INITIAL_INLINING_FUEL 32 #define INITIAL_FLATTENING_FUEL 16 + +#define SCHEME_LAMBDA_FRAME 1 + +typedef struct Cross_Linklet_Info +{ + /* Must be all pointers; allocated with scheme_malloc() */ + Scheme_Object *get_import; /* NULL or (key -> linklet (vector key ...)) */ + Scheme_Hash_Tree *import_keys; /* import-position -> key */ + Scheme_Hash_Tree *rev_import_keys; /* key -> import-position */ + Scheme_Hash_Tree *linklets; /* key -> linklet-or-instance */ + Scheme_Hash_Tree *import_next_keys; /* key -> (vector key ...) */ + Scheme_Hash_Tree *inline_variants; /* key -> symbol -> value */ + Scheme_Hash_Tree *import_syms; /* import-position -> ((symbol -> variable-position) + . + (variable-position -> symbol)) */ + int used_import_shape; +} Cross_Linklet_Info; + /* Clasification for predicates. Each one implies the smaller. */ #define RLV_IS_RELEVANT 1 /* The predicate is remembered by the optimizer */ @@ -60,14 +77,14 @@ MZTAG_IF_REQUIRED short flags; struct Optimize_Info *next; - int original_frame, new_frame; - Scheme_Object *consts; - Comp_Prefix *cp; + struct Scheme_Linklet *linklet; int init_kclock; - /* Compilation context, used for unresolving for cross-module inlining: */ - Scheme_Env *env; - Scheme_Object *insp; + /* For cross-linklet inlining: */ + Cross_Linklet_Info *cross; + + /* Track which imports are still used after optimization */ + Scheme_Hash_Tree **imports_used; /* import position -> variable position -> true */ /* Propagated up and down the chain: */ int size; @@ -87,7 +104,7 @@ int sclock; /* virtual clock that ticks when space consumption is potentially observed */ int psize; short inline_fuel, flatten_fuel; - char letrec_not_twice, enforce_const, use_psize, has_nonleaf; + char letrec_not_twice, enforce_const, unsafe_mode, use_psize, has_nonleaf; Scheme_Hash_Table *top_level_consts; int maybe_values_argument; /* triggers an approximation for clock increments */ @@ -116,6 +133,8 @@ int init_flatten_fuel, min_flatten_fuel; } Optimize_Info_Sequence; +static Scheme_Object *optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context); + static int get_rator_flags(Scheme_Object *rator, int num_args, Optimize_Info *info); Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, int argc); static void merge_lambda_arg_types(Scheme_Lambda *lam1, Scheme_Lambda *lam2); @@ -150,7 +169,9 @@ static Scheme_IR_Local *clone_variable(Scheme_IR_Local *var); static void increment_use_count(Scheme_IR_Local *var, int as_rator); -static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags); +static Optimize_Info *optimize_info_create(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode); +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int flags); static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent); static void register_transitive_uses(Scheme_IR_Local *var, Optimize_Info *info); @@ -168,6 +189,12 @@ static Scheme_Object *optimize_clone(int single_use, Scheme_Object *obj, Optimize_Info *info, Scheme_Hash_Tree *var_map, int as_rator); +static Scheme_Object *get_import_shape(Optimize_Info *info, Scheme_IR_Toplevel *var); +static Scheme_Object *get_import_inline(Optimize_Info *info, Scheme_IR_Toplevel *var, int argc, int case_ok); +static void register_import_used(Optimize_Info *info, Scheme_IR_Toplevel *expr); +static void record_optimize_shapes(Optimize_Info *info, Scheme_Linklet *linklet, Scheme_Object **_import_keys); +static Scheme_Object *get_value_shape(Scheme_Object *v, int imprecise); + XFORM_NONGCING static int relevant_predicate(Scheme_Object *pred); XFORM_NONGCING static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2); XFORM_NONGCING static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2); @@ -250,20 +277,20 @@ /* Convert a context to a string that is suitable for use in logging */ { if (context) { - Scheme_Object *mod, *func; + Scheme_Object *linklet, *func; const char *ctx, *prefix, *mctx, *mprefix; char *all; int clen, plen, mclen, mplen, len; if (SCHEME_PAIRP(context)) { func = SCHEME_CAR(context); - mod = SCHEME_CDR(context); - } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) { + linklet = SCHEME_CDR(context); + } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_linklet_type)) { func = scheme_false; - mod = context; + linklet = context; } else { func = context; - mod = scheme_false; + linklet = scheme_false; } if (SAME_TYPE(SCHEME_TYPE(func), scheme_ir_lambda_type)) { @@ -299,8 +326,8 @@ prefix = ""; } - if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) { - mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL); + if (SAME_TYPE(SCHEME_TYPE(linklet), scheme_linklet_type)) { + mctx = scheme_display_to_string(((Scheme_Linklet *)linklet)->name, NULL); mprefix = " in module: "; } else { mctx = ""; @@ -369,25 +396,35 @@ return 0; } +static Scheme_Object *get_defn_shape(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + Scheme_Object *v; + + if (info->top_level_consts && (var->instance_pos == -1)) { + v = scheme_hash_get(info->top_level_consts, scheme_make_integer(var->variable_pos)); + if (v) return v; + + v = scheme_hash_get(info->top_level_consts, scheme_false); + if (v && scheme_hash_get((Scheme_Hash_Table *)v, scheme_make_integer(var->variable_pos))) + return scheme_fixed_key; + } + + return NULL; +} + static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info, int prop_ok) /* Determines whether `rator` is known to be a struct accessor, etc. */ { Scheme_Object *c; - if (info - && (info->top_level_consts || info->cp->inline_variants) - && SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { - int pos; - pos = SCHEME_TOPLEVEL_POS(rator); - c = NULL; - if (info->top_level_consts) - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - if (!c && info->cp->inline_variants) - c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); + if (info && SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { + c = get_defn_shape(info, (Scheme_IR_Toplevel *)rator); + if (!c) + c = get_import_shape(info, (Scheme_IR_Toplevel *)rator); + if (c && (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type) - || (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) { + || (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) return c; - } } return NULL; @@ -405,7 +442,9 @@ int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK); int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT); if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED)) - || ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) { + || ((num_args == field_count) + && (mode == STRUCT_PROC_SHAPE_CONSTR) + && (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) { return 1; } } else if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)) { @@ -439,10 +478,10 @@ /* Checks whether the bytecode `o` returns `vals` values with no side-effects and without pushing and using continuation marks. A -1 for `vals` means that any return count is ok. - Also used with fully resolved expression by `module' to check + Also used with fully resolved expression by `linklet` to check for "functional" bodies, in which case `flags` includes `OMITTABLE_RESOLVED`. - The `opt_info` argument is used only to access module-level + The `opt_info` argument is used only to access linklet-level information, not local bindings. If `warn_info` is supplied, complain when a mismatch is detected. We rely on the letrec-check pass to avoid omitting early references @@ -475,17 +514,16 @@ || (vtype == scheme_ir_lambda_type) || (vtype == scheme_inline_variant_type) || (vtype == scheme_case_lambda_sequence_type) - || (vtype == scheme_quote_syntax_type) - || (vtype == scheme_varref_form_type) - || (vtype == scheme_ir_quote_syntax_type)) { + || (vtype == scheme_varref_form_type)) { note_match(1, vals, warn_info); return ((vals == 1) || (vals < 0)); } - if (vtype == scheme_toplevel_type) { + if ((vtype == scheme_toplevel_type) || (vtype == scheme_static_toplevel_type)) { note_match(1, vals, warn_info); if (!(flags & OMITTABLE_KEEP_VARS) && (flags & OMITTABLE_RESOLVED) && ((vals == 1) || (vals < 0))) { - if (SCHEME_TOPLEVEL_FLAGS(o) & SCHEME_TOPLEVEL_FLAGS_MASK) + int tl_flags = SCHEME_TOPLEVEL_FLAGS(o); + if (tl_flags & SCHEME_TOPLEVEL_FLAGS_MASK) return 1; else return 0; @@ -496,15 +534,34 @@ note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (!(flags & OMITTABLE_KEEP_VARS) - && ((SCHEME_TOPLEVEL_FLAGS(o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY)) + && ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY)) return 1; - else if ((SCHEME_TOPLEVEL_FLAGS(o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + else if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) return 1; else return 0; } } + /* check for struct-type declaration: */ + if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) { + Scheme_Object *auto_e; + int auto_e_depth; + auto_e = scheme_is_simple_make_struct_type(o, vals, + (((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) + | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED + | CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK), + &auto_e_depth, + NULL, NULL, + opt_info, + NULL, NULL, 0, NULL, NULL, + 5); + if (auto_e) { + if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info)) + return 1; + } + } + if (vtype == scheme_branch_type) { Scheme_Branch_Rec *b; b = (Scheme_Branch_Rec *)o; @@ -652,35 +709,14 @@ return 1; } - /* check for struct-type declaration: */ - if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) { - Scheme_Object *auto_e; - int auto_e_depth; - auto_e = scheme_is_simple_make_struct_type(o, vals, - (((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) - | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED - | CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK), - &auto_e_depth, - NULL, NULL, - (opt_info ? opt_info->top_level_consts : NULL), - ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), - NULL, NULL, 0, NULL, NULL, NULL, - 5); - if (auto_e) { - if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info)) - return 1; - } - } - /* check for struct-type property declaration: */ if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) { if (scheme_is_simple_make_struct_type_property(o, vals, (((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED), NULL, - (opt_info ? opt_info->top_level_consts : NULL), - ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), - NULL, NULL, 0, NULL, NULL, + opt_info, + NULL, NULL, 0, NULL, 5)) return 1; } @@ -1206,6 +1242,8 @@ && is_local_ref(app->args[2], delta+1, 1, vars) && is_local_ref(app->args[3], delta+2, 1, vars)) { int i, num_gets = 0, num_sets = 0, normal_ops = 1; + int setter_fields = 0, normal_sets = 1; + int prev_setter_pos = app->num_args; /* bigger than any setter index can be */ for (i = app->num_args; i > 3; i--) { if (is_local_ref(app->args[i], delta, 5, vars)) { normal_ops = 0; @@ -1218,11 +1256,22 @@ delta2, _stinfo->field_count, vars)) break; if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) { + int pos = SCHEME_INT_VAL(app3->args[2]); if (num_gets) { - /* Since we're alking backwards, it's not normal to hit a mutator + /* Since we're walking backwards, it's not normal to hit a mutator after (i.e., before in argument order) a selector */ normal_ops = 0; } + if (normal_sets) { + if (pos >= prev_setter_pos) { + /* setters are not in the usual order; zero out the mask */ + normal_sets = 0; + setter_fields = 0; + } else if (pos < (31 - STRUCT_PROC_SHAPE_SHIFT)) { + setter_fields |= (1 << pos); + prev_setter_pos = pos; + } + } num_sets++; } else { if (SCHEME_INT_VAL(app3->args[2]) != (i - 4)) { @@ -1255,6 +1304,7 @@ _stinfo->indexed_ops = 1; _stinfo->num_gets = num_gets; _stinfo->num_sets = num_sets; + _stinfo->setter_fields = setter_fields; return 1; } } @@ -1288,56 +1338,57 @@ #define OK_CONSTANT_VALUE 5 static int is_ok_value(Ok_Value_Callback ok_value, void *data, - Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) + Scheme_Linklet *enclosing_linklet) /* Does `arg` produce a value that satisfies `ok_value`? */ { int pos; Scheme_Object *v; if (SAME_TYPE(SCHEME_TYPE(arg), scheme_ir_toplevel_type)) { - pos = SCHEME_TOPLEVEL_POS(arg); - if (top_level_consts || inline_variants) { + if (info) { /* This is optimize mode */ - v = NULL; - if (top_level_consts) - v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); - if (!v && inline_variants) - v = scheme_hash_get(inline_variants, scheme_make_integer(pos)); + v = get_defn_shape(info, (Scheme_IR_Toplevel *)arg); + if (!v) + v = get_import_shape(info, (Scheme_IR_Toplevel *)arg); if (v) return ok_value(data, v, OK_CONSTANT_SHAPE); } - } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) { + } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(arg), scheme_static_toplevel_type)) { pos = SCHEME_TOPLEVEL_POS(arg); if (runstack) { /* This is eval mode; conceptually, this code belongs in define_execute_with_dynamic_state() */ Scheme_Bucket *b; Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta]; + if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) + toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta]; + else + toplevels = SCHEME_STATIC_TOPLEVEL_PREFIX(arg); b = (Scheme_Bucket *)toplevels->a[pos]; if (b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) return ok_value(data, b->val, OK_CONSTANT_VALUE); - } - if (symbols) { - /* This is module-export mode; conceptually, this code belongs in - setup_accessible_table() */ - Scheme_Object *name; - name = symbols[pos]; - if (SCHEME_SYMBOLP(name)) { - v = scheme_hash_get(symbol_table, name); + } else if (enclosing_linklet) { + /* This is linklet-export mode; conceptually, this code belongs in + linklet_setup_constants() */ + if (pos > enclosing_linklet->num_total_imports) { + Scheme_Object *name; + pos -= (enclosing_linklet->num_total_imports + 1); + name = SCHEME_VEC_ELS(enclosing_linklet->defns)[pos]; + v = scheme_hash_get(enclosing_linklet->constants, name); if (v) return ok_value(data, v, OK_CONSTANT_VARIANT); - } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) { - if (((Module_Variable *)name)->shape) - return ok_value(data, ((Module_Variable *)name)->shape, OK_CONSTANT_ENCODED_SHAPE); + } else if (pos >= 1 + && (pos <= enclosing_linklet->num_total_imports) + && enclosing_linklet->import_shapes) { + pos -= 1; + return ok_value(data, SCHEME_VEC_ELS(enclosing_linklet->import_shapes)[pos], OK_CONSTANT_ENCODED_SHAPE); } - } - if (top_level_table) { + } else if (top_level_table) { /* This is validate mode; conceptually, this code belongs in define_values_validate() */ v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); @@ -1345,15 +1396,17 @@ return ok_value(data, v, OK_CONSTANT_VALIDATE_SHAPE); } } - } - + } else if (SCHEME_TYPE(arg) > _scheme_ir_values_types_) + return ok_value(data, arg, OK_CONSTANT_VALUE); + return 0; } static int ok_constant_super_value(void *data, Scheme_Object *v, int mode) /* Is `v` a structure type (which can serve as a supertype)? */ { - Scheme_Object **_parent_identity = (Scheme_Object **)data; + Scheme_Object **_parent_identity = (Scheme_Object **)((void **)data)[0]; + int *_nonfail_constr = (int *)((void **)data)[1]; if (mode == OK_CONSTANT_SHAPE) { if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { @@ -1362,20 +1415,28 @@ if (mode == STRUCT_PROC_SHAPE_STRUCT) { if (_parent_identity) *_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v); + if (_nonfail_constr) + *_nonfail_constr = SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; return field_count + 1; } } } else if (mode == OK_CONSTANT_ENCODED_SHAPE) { intptr_t k; if (scheme_decode_struct_shape(v, &k)) { - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } } } else if (mode == OK_CONSTANT_VALIDATE_SHAPE) { int k = SCHEME_INT_VAL(v); if ((k >= 0) - && (k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + && (k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } } else if (mode == OK_CONSTANT_VARIANT) { if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { if (_parent_identity) @@ -1384,39 +1445,50 @@ if (v && SCHEME_INTP(v)) { int mode = (SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_MASK); int field_count = (SCHEME_INT_VAL(v) >> STRUCT_PROC_SHAPE_SHIFT); - if (mode == STRUCT_PROC_SHAPE_STRUCT) + if (mode == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; return field_count + 1; + } } } } else if (mode == OK_CONSTANT_VALUE) { if (SCHEME_STRUCT_TYPEP(v)) { Scheme_Struct_Type *st = (Scheme_Struct_Type *)v; - if (st->num_slots == st->num_islots) + if (st->num_slots == st->num_islots) { + if (_nonfail_constr) + *_nonfail_constr = st->nonfail_constructor; return st->num_slots + 1; + } } } return 0; } -static int is_constant_super(Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, +static int is_constant_super(Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, - Scheme_Object **_parent_identity) + Scheme_Linklet *enclosing_linklet, + Scheme_Object **_parent_identity, + int *_nonfail_constr) /* Does `arg` produce another structure type (which can serve as a supertype)? */ { - return is_ok_value(ok_constant_super_value, _parent_identity, + void *data[2]; + + data[0] = _parent_identity; + data[1] = _nonfail_constr; + + return is_ok_value(ok_constant_super_value, data, arg, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table); + enclosing_linklet); } -static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mode) +static int ok_constant_property_without_guard(void *data, Scheme_Object *v, int mode) { intptr_t k = 0; @@ -1449,34 +1521,32 @@ return (k == STRUCT_PROP_PROC_SHAPE_PROP); } -static int is_struct_type_property_without_guard(Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, +static int is_struct_type_property_without_guard(Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) + Scheme_Linklet *enclosing_linklet) /* Does `arg` produce a structure type property that has no guard (so that any value is ok)? */ { - return is_ok_value(ok_constant_property_with_guard, NULL, + return is_ok_value(ok_constant_property_without_guard, NULL, arg, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table); + enclosing_linklet); } static int is_simple_property_list(Scheme_Object *a, int resolved, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int just_for_authentic, int *_authentic) /* Does `a` produce a property list that always lets `make-struct-type` succeed? */ { Scheme_Object *arg; int i, count; - + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { if (!SAME_OBJ(((Scheme_App_Rec *)a)->args[0], scheme_list_proc)) return 0; @@ -1515,10 +1585,10 @@ *_authentic = 1; if (!just_for_authentic) { if (is_struct_type_property_without_guard(a3->rand1, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table)) { + enclosing_linklet)) { if (!scheme_omittable_expr(a3->rand2, 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) return 0; } else @@ -1530,19 +1600,18 @@ return 0; } } - + return 1; } -Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags, +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags, GC_CAN_IGNORE int *_auto_e_depth, Simple_Struct_Type_Info *_stinfo, Scheme_Object **_parent_identity, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, Scheme_Object **_name, int fuel) /* Checks whether it's a `make-struct-type' call --- that, if `flags` includes @@ -1550,7 +1619,6 @@ pending a check of the auto-value argument if `flags` includes `CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK`. The expression itself must have no side-effects except for errors (but the possibility of errors means that the expression is not necessarily omittable). - The resulting *constructor* must always succeed (i.e., no guards). The result is the auto-value argument or scheme_true if it's simple, NULL if not. The first result of `e` will be a struct type, the second a constructor, and the third a predicate; the rest are selectors and mutators. */ @@ -1565,15 +1633,16 @@ if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { - int super_count_plus_one; + int super_count_plus_one, super_nonfail_constr = 1; if (_parent_identity) *_parent_identity = scheme_null; if (!SCHEME_FALSEP(app->args[2])) super_count_plus_one = is_constant_super(app->args[2], - top_level_consts, inline_variants, top_level_table, runstack, + info, top_level_table, runstack, rs_delta + app->num_args, - symbols, symbol_table, _parent_identity); + enclosing_linklet, _parent_identity, + &super_nonfail_constr); else super_count_plus_one = 0; @@ -1600,10 +1669,10 @@ && scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) || ((flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED) && is_simple_property_list(app->args[6], resolved, - top_level_consts, inline_variants, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, 0, NULL))) && ((app->num_args < 7) /* inspector: */ @@ -1622,7 +1691,9 @@ SCHEME_INT_VAL(app->args[3]))) && ((app->num_args < 10) /* guard: */ - || SCHEME_FALSEP(app->args[10])) + || SCHEME_FALSEP(app->args[10]) + /* Could try to check for procedure with correct arity: */ + || !(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED)) && ((app->num_args < 11) /* constructor name: */ || SCHEME_FALSEP(app->args[11]) @@ -1647,12 +1718,14 @@ _stinfo->authentic = 0; if ((app->num_args > 6) && is_simple_property_list(app->args[6], resolved, - top_level_consts, inline_variants, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, 1, &authentic)) _stinfo->authentic = authentic; + _stinfo->nonfail_constructor = (super_nonfail_constr + && ((app->num_args < 10) || SCHEME_FALSEP(app->args[10]))); _stinfo->num_gets = 1; _stinfo->num_sets = 1; } @@ -1675,9 +1748,9 @@ if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(lv->value, 5, flags, _auto_e_depth, _stinfo, _parent_identity, - top_level_consts, inline_variants, top_level_table, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, _name, fuel-1); if (auto_e) { @@ -1707,9 +1780,9 @@ if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(e2, 5, flags, _auto_e_depth, _stinfo, _parent_identity, - top_level_consts, inline_variants, top_level_table, + info, top_level_table, runstack, rs_delta + lvd->count, - symbols, symbol_table, + enclosing_linklet, _name, fuel-1); if (auto_e) { @@ -1732,11 +1805,10 @@ int scheme_is_simple_make_struct_type_property(Scheme_Object *e, int vals, int flags, int *_has_guard, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int fuel) /* Reports whether `app` is a call to `make-struct-type-property` to produce a propert with no guard. */ @@ -1782,12 +1854,15 @@ if (stinfo->field_count == stinfo->init_field_count) return (STRUCT_PROC_SHAPE_STRUCT | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) + | (stinfo->nonfail_constructor ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR : 0) | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT)); else return STRUCT_PROC_SHAPE_OTHER; break; case 1: - return STRUCT_PROC_SHAPE_CONSTR | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT); + return (STRUCT_PROC_SHAPE_CONSTR + | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT) + | (stinfo->nonfail_constructor ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR : 0)); break; case 2: return (STRUCT_PROC_SHAPE_PRED @@ -1800,10 +1875,30 @@ return (STRUCT_PROC_SHAPE_GETTER | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) | ((stinfo->super_field_count + (k - 3)) << STRUCT_PROC_SHAPE_SHIFT)); - } else + } else { + int idx = (k - 3 - stinfo->num_gets), setter_fields = stinfo->setter_fields, pos = 0; + + /* setter_fields is a bitmap for first (31-STRUCT_PROC_SHAPE_SHIFT) fields that may have a setter */ + while ((idx > 0) || !(setter_fields & 1)) { + if (setter_fields & 1) { + idx--; + } + setter_fields = setter_fields >> 1; + pos++; + if (!setter_fields) break; + } + + if (!idx && (setter_fields & 1)) + pos += stinfo->super_field_count + 1; + else { + /* represent "unknown" by zero */ + pos = 0; + } + return (STRUCT_PROC_SHAPE_SETTER | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) - | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT)); + | (pos << STRUCT_PROC_SHAPE_SHIFT)); + } } } @@ -1851,7 +1946,7 @@ XFORM_NONGCING static int is_struct_identity_subtype(Scheme_Object *sub, Scheme_Object *sup) { - /* A structure identity is a list of symbols, but the symbols are + /* A structure identity is typically a list of symbols, but the symbols are just for debugging. Instead, the address of each pair forming the list represents an identiity. */ while (SCHEME_PAIRP(sub)) { @@ -2044,9 +2139,8 @@ switch (SCHEME_TYPE(expr)) { case scheme_toplevel_type: + case scheme_static_toplevel_type: return ((SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED); - case scheme_ir_quote_syntax_type: - return 1; case scheme_ir_local_type: { /* Ok if not mutable */ @@ -2170,33 +2264,34 @@ #define STR_INLINE_LIMIT 256 -int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_module) +int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_linklet) /* Is the constant a value that we can "copy" in the code? */ { return (SCHEME_VOIDP(fb) || SAME_OBJ(fb, scheme_true) + || SAME_OBJ(fb, scheme_undefined) || SCHEME_FALSEP(fb) || (SCHEME_SYMBOLP(fb) - && (!cross_module || (!SCHEME_SYM_WEIRDP(fb) + && (!cross_linklet || (!SCHEME_SYM_WEIRDP(fb) && (SCHEME_SYM_LEN(fb) < STR_INLINE_LIMIT)))) || (SCHEME_KEYWORDP(fb) - && (!cross_module || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT))) || SCHEME_EOFP(fb) || SCHEME_INTP(fb) || SCHEME_NULLP(fb) - || (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_toplevel_type)) - || (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type)) + || (!cross_linklet && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_toplevel_type)) + || (!cross_linklet && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type)) || SCHEME_PRIMP(fb) /* Values that are hashed by the printer and/or interned on read to avoid duplication: */ || SCHEME_CHARP(fb) || (SCHEME_CHAR_STRINGP(fb) - && (!cross_module || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) || (SCHEME_BYTE_STRINGP(fb) - && (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type) || (SCHEME_NUMBERP(fb) - && (!cross_module || small_inline_number(fb))) + && (!cross_linklet || small_inline_number(fb))) || SAME_TYPE(SCHEME_TYPE(fb), scheme_ctype_type)); } @@ -2357,7 +2452,6 @@ break; } case scheme_ir_toplevel_type: - case scheme_ir_quote_syntax_type: /* FIXME: other syntax types not covered */ default: sz += 1; @@ -2407,10 +2501,10 @@ if (!expected) { /* No arguments, so no need for a `let` wrapper: */ - sub_info = optimize_info_add_frame(info, 0, 0, 0); + sub_info = optimize_info_add_frame(info, 0); if (!single_use || lam->ir_info->is_dup) sub_info->inline_fuel >>= 1; - p = scheme_optimize_expr(p, sub_info, context); + p = optimize_expr(p, sub_info, context); info->single_result = sub_info->single_result; info->preserves_marks = sub_info->preserves_marks; optimize_info_done(sub_info, NULL); @@ -2473,7 +2567,7 @@ else lh->body = p; - sub_info = optimize_info_add_frame(info, 0, 0, 0); + sub_info = optimize_info_add_frame(info, 0); if (!single_use || lam->ir_info->is_dup) sub_info->inline_fuel >>= 1; @@ -2562,16 +2656,15 @@ } Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, - int argc, int for_inline, int *_single_use) + int argc, int for_inline, int for_props, int *_single_use) /* Return a known procedure, if any. - When argc == -1 it may return a case-lambda. Else, it will check the arity - and split a case-lambda to extact the relevant lambda. If the arity is - wrong the result is scheme_true. - If for_inline, it may return a potential size. Else, it will go inside - potential sizes, noinline procedures, lets, begins and other construction, + When argc == -1, the result may be a case-lambda or `scheme_constant_key`; + otherwise, unless `for_props`, the arity is used to split a case-lambda to extact + the relevant lambda, and if the arity is wrong, the result is `scheme_true`. + If `for_inline`, the result may be a potential size, otherwise this function + goes inside potential sizes, noinline procedures, lets, begins and other construction, so the result can't be inlined and must be used only to get the properties - of the actual procedure. It may also return a struct_(prop_)proc_shape.*/ - + of the actual procedure. */ { Scheme_Object *prev = NULL; @@ -2601,51 +2694,16 @@ return NULL; } - while (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)) { - int pos; - pos = SCHEME_TOPLEVEL_POS(le); + if (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)) { + Scheme_Object *inl; *_single_use = 0; - if (info->cp->inline_variants) { - Scheme_Object *iv; - iv = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); - if (iv && SCHEME_TRUEP(iv)) { - Scheme_Hash_Table *iv_ht = NULL; - if (SCHEME_HASHTP(iv)) { - iv_ht = (Scheme_Hash_Table *)iv; - iv = scheme_hash_get(iv_ht, scheme_make_integer(argc)); - if (!iv) - iv = scheme_hash_get(iv_ht, scheme_false); - } - if (SAME_TYPE(SCHEME_TYPE(iv), scheme_vector_type)) { /* inline variant + shift info */ - int has_cases = 0; - Scheme_Object *orig_iv = iv; - MZ_ASSERT(SAME_TYPE(scheme_inline_variant_type, SCHEME_TYPE(SCHEME_VEC_ELS(iv)[0]))); - /* unresolving may add new top-levels to `info->cp`: */ - iv = scheme_unresolve(SCHEME_VEC_ELS(iv)[0], argc, &has_cases, - info->cp, info->env, info->insp, SCHEME_INT_VAL(SCHEME_VEC_ELS(iv)[3]), - SCHEME_VEC_ELS(iv)[1], SCHEME_VEC_ELS(iv)[2]); - if (has_cases) { - if (!iv_ht) { - iv_ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(iv_ht, scheme_false, orig_iv); - scheme_hash_set(info->cp->inline_variants, scheme_make_integer(pos), (Scheme_Object *)iv_ht); - } - scheme_hash_set(iv_ht, scheme_make_integer(argc), iv ? iv : scheme_false); - } else - scheme_hash_set(info->cp->inline_variants, scheme_make_integer(pos), iv ? iv : scheme_false); - } - if (iv && SCHEME_TRUEP(iv)) { - le = iv; - break; - } - } - } - if (info->top_level_consts) { - le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - if (!le) - return NULL; - } else - break; + do { + inl = get_import_inline(info, (Scheme_IR_Toplevel *)le, argc, for_props); + if ((argc < 0) && SAME_OBJ(inl, scheme_constant_key)) + return inl; + if (!inl) inl = get_defn_shape(info, (Scheme_IR_Toplevel *)le); + if (inl) le = inl; + } while (inl && SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)); } if (SCHEME_WILL_BE_LAMBDAP(le)) { @@ -2679,9 +2737,10 @@ } if (ok_arity || (argc == -1)) { return for_inline ? NULL : le; - } else { + } else if (for_props) + return le; + else return scheme_true; - } } if (SAME_TYPE(SCHEME_TYPE(le), scheme_struct_prop_proc_shape_type)) { @@ -2698,9 +2757,10 @@ } if (ok_arity || (argc == -1)) { return for_inline ? NULL : le; - } else { + } else if (for_props) + return le; + else return scheme_true; - } } if (SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type)) { @@ -2708,7 +2768,7 @@ Scheme_Object *cp; int i, count; - if (argc == -1) + if ((argc == -1) || for_props) return le; count = cl->count; @@ -2733,7 +2793,7 @@ if (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_lambda_type)) { Scheme_Lambda *lam = (Scheme_Lambda *)le; - if (argc == -1) + if ((argc == -1) || for_props) return le; if ((lam->num_params == argc) @@ -2748,7 +2808,7 @@ if (SCHEME_PROCP(le)) { Scheme_Object *a[1]; - if (argc == -1) + if ((argc == -1) || for_props) return le; a[0] = le; @@ -2758,13 +2818,19 @@ return scheme_true; } + if (for_props + && le + && (SAME_TYPE(SCHEME_TYPE(le), scheme_lambda_type) + || SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type))) + return le; + return NULL; } Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, int argc) { int single_use = 0; - return do_lookup_constant_proc(info, le, argc, 0, &single_use); + return do_lookup_constant_proc(info, le, argc, 0, 0, &single_use); } #if 0 @@ -2803,7 +2869,7 @@ } le2 = le; - le = do_lookup_constant_proc(info, le, argc, 1, &single_use); + le = do_lookup_constant_proc(info, le, argc, 1, 0, &single_use); if (!le) { info->has_nonleaf = 1; @@ -2826,7 +2892,7 @@ int len; const char *pname = NULL, *context; info->escapes = 1; - le2 = lookup_constant_proc(info, le2, -1); + le2 = do_lookup_constant_proc(info, le2, argc, 1, 1, &single_use); if (!SAME_TYPE(SCHEME_TYPE(le2), scheme_struct_proc_shape_type) && !SAME_TYPE(SCHEME_TYPE(le2), scheme_struct_prop_proc_shape_type)){ pname = scheme_get_proc_name(le2, &len, 0); @@ -2865,40 +2931,43 @@ if (le) { LOG_INLINE(fprintf(stderr, "Inline %d[%d]<=%d@%d %d %s\n", sz, is_leaf, threshold, info->inline_fuel, single_use, scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL))); - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "inlining %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - threshold, - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "inlining %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + threshold, + scheme_optimize_context_to_string(info->context)); le = apply_inlined((Scheme_Lambda *)le, sub_info, argc, app, app2, app3, context, orig_le, prev, single_use); return le; } else { LOG_INLINE(fprintf(stderr, "No inline %s\n", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL))); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "no-inlining %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + threshold, + scheme_optimize_context_to_string(info->context)); + } + } else { + LOG_INLINE(fprintf(stderr, "No fuel %s %d[%d]>%d@%d %d\n", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, is_leaf, threshold, + info->inline_fuel, info->use_psize)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) scheme_log(info->logger, SCHEME_LOG_DEBUG, 0, - "no-inlining %s size: %d threshold: %d#%s", + "out-of-fuel %s size: %d threshold: %d#%s", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), sz, threshold, scheme_optimize_context_to_string(info->context)); - } - } else { - LOG_INLINE(fprintf(stderr, "No fuel %s %d[%d]>%d@%d %d\n", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, is_leaf, threshold, - info->inline_fuel, info->use_psize)); - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "out-of-fuel %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - threshold, - scheme_optimize_context_to_string(info->context)); } } @@ -3071,7 +3140,7 @@ reset_rator(app, rator); orig_rator = replace_tail_inside(app, inside, orig_rator); - return scheme_optimize_expr(orig_rator, info, context); + return optimize_expr(orig_rator, info, context); } static int is_nonmutating_nondependant_primitive(Scheme_Object *rator, int n) @@ -3226,6 +3295,8 @@ return scheme_real_p_proc; else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_NUMBER) return scheme_number_p_proc; + else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_BOOL) + return scheme_boolean_p_proc; else if (SAME_OBJ(rator, scheme_cons_proc)) return scheme_pair_p_proc; else if (SAME_OBJ(rator, scheme_unsafe_cons_list_proc)) @@ -3272,65 +3343,12 @@ || IS_NAMED_PRIM(rator, "bytes-set!") || IS_NAMED_PRIM(rator, "set-box!")) return scheme_void_p_proc; - else if (IS_NAMED_PRIM(rator, "vector-set!") - || IS_NAMED_PRIM(rator, "string-set!") - || IS_NAMED_PRIM(rator, "bytes-set!")) - return scheme_void_p_proc; else if (IS_NAMED_PRIM(rator, "string->symbol") || IS_NAMED_PRIM(rator, "gensym")) return scheme_symbol_p_proc; else if (IS_NAMED_PRIM(rator, "string->keyword")) return scheme_keyword_p_proc; - else if (IS_NAMED_PRIM(rator, "pair?") - || IS_NAMED_PRIM(rator, "mpair?") - || IS_NAMED_PRIM(rator, "list?") - || IS_NAMED_PRIM(rator, "list-pair?") - || IS_NAMED_PRIM(rator, "vector?") - || IS_NAMED_PRIM(rator, "box?") - || IS_NAMED_PRIM(rator, "number?") - || IS_NAMED_PRIM(rator, "real?") - || IS_NAMED_PRIM(rator, "complex?") - || IS_NAMED_PRIM(rator, "rational?") - || IS_NAMED_PRIM(rator, "integer?") - || IS_NAMED_PRIM(rator, "exact-integer?") - || IS_NAMED_PRIM(rator, "exact-nonnegative-integer?") - || IS_NAMED_PRIM(rator, "exact-positive-integer?") - || IS_NAMED_PRIM(rator, "inexact-real?") - || IS_NAMED_PRIM(rator, "fixnum?") - || IS_NAMED_PRIM(rator, "flonum?") - || IS_NAMED_PRIM(rator, "single-flonum?") - || IS_NAMED_PRIM(rator, "null?") - || IS_NAMED_PRIM(rator, "void?") - || IS_NAMED_PRIM(rator, "symbol?") - || IS_NAMED_PRIM(rator, "keyword?") - || IS_NAMED_PRIM(rator, "string?") - || IS_NAMED_PRIM(rator, "bytes?") - || IS_NAMED_PRIM(rator, "path?") - || IS_NAMED_PRIM(rator, "char?") - || IS_NAMED_PRIM(rator, "interned-char?") - || IS_NAMED_PRIM(rator, "boolean?") - || IS_NAMED_PRIM(rator, "chaperone?") - || IS_NAMED_PRIM(rator, "impersonator?") - || IS_NAMED_PRIM(rator, "procedure?") - || IS_NAMED_PRIM(rator, "eof-object?") - || IS_NAMED_PRIM(rator, "immutable?") - || IS_NAMED_PRIM(rator, "not") - || IS_NAMED_PRIM(rator, "true-object?") - || IS_NAMED_PRIM(rator, "zero?") - || IS_NAMED_PRIM(rator, "procedure-arity-includes?") - || IS_NAMED_PRIM(rator, "variable-reference-constant?") - || IS_NAMED_PRIM(rator, "eq?") - || IS_NAMED_PRIM(rator, "eqv?") - || IS_NAMED_PRIM(rator, "equal?") - || IS_NAMED_PRIM(rator, "string=?") - || IS_NAMED_PRIM(rator, "bytes=?") - || IS_NAMED_PRIM(rator, "char=?") - || IS_NAMED_PRIM(rator, "free-identifier=?") - || IS_NAMED_PRIM(rator, "bound-identifier=?") - || IS_NAMED_PRIM(rator, "procedure-closure-contents-eq?")) { - return scheme_boolean_p_proc; - } - + { Scheme_Object *p; p = local_type_to_predicate(produces_local_type(rator, argc)); @@ -3372,7 +3390,7 @@ switch (SCHEME_TYPE(expr)) { case scheme_ir_local_type: { - if (scheme_hash_tree_get(ignore_vars, expr)) + if (scheme_eq_hash_tree_get(ignore_vars, expr)) return NULL; if (!SCHEME_VAR(expr)->mutated) { @@ -3424,7 +3442,7 @@ break; case scheme_application3_type: { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; if (SCHEME_PRIMP(app->rator) && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED) && IS_NAMED_PRIM(app->rator, "bitwise-and")) { @@ -3514,9 +3532,6 @@ case scheme_case_lambda_sequence_type: return scheme_procedure_p_proc; break; - case scheme_ir_quote_syntax_type: - return scheme_syntax_p_proc; - break; case scheme_branch_type: { Scheme_Object *l, *r; @@ -3575,24 +3590,26 @@ return scheme_box_p_proc; break; default: - if (SCHEME_FLOATP(expr)) - return scheme_flonum_p_proc; - if (SCHEME_LONG_DBLP(expr)) - return scheme_extflonum_p_proc; - if (SCHEME_INTP(expr) - && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr))) - return scheme_fixnum_p_proc; - if (SCHEME_REALP(expr)) - return scheme_real_p_proc; - if (SCHEME_NUMBERP(expr)) + if (SCHEME_NUMBERP(expr)) { + if (SCHEME_FLOATP(expr)) + return scheme_flonum_p_proc; + if (SCHEME_LONG_DBLP(expr)) + return scheme_extflonum_p_proc; + if (SCHEME_INTP(expr) + && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr))) + return scheme_fixnum_p_proc; + if (SCHEME_REALP(expr)) + return scheme_real_p_proc; return scheme_number_p_proc; + } if (SCHEME_NULLP(expr)) return scheme_null_p_proc; - if (scheme_is_list(expr)) - return scheme_list_pair_p_proc; - if (SCHEME_PAIRP(expr)) + if (SCHEME_PAIRP(expr)) { + if (scheme_is_list(expr)) + return scheme_list_pair_p_proc; return scheme_pair_p_proc; + } if (SCHEME_MPAIRP(expr)) return scheme_mpair_p_proc; if (SCHEME_CHAR_STRINGP(expr)) @@ -3607,10 +3624,11 @@ return scheme_keyword_p_proc; if (SCHEME_SYMBOLP(expr)) return scheme_symbol_p_proc; - if (SCHEME_CHARP(expr) && SCHEME_CHAR_VAL(expr) < 256) - return scheme_interned_char_p_proc; - if (SCHEME_CHARP(expr)) + if (SCHEME_CHARP(expr)) { + if (SCHEME_CHAR_VAL(expr) < 256) + return scheme_interned_char_p_proc; return scheme_char_p_proc; + } if (SAME_OBJ(expr, scheme_true)) return scheme_true_object_p_proc; if (SCHEME_FALSEP(expr)) @@ -3764,12 +3782,12 @@ /* Check for (apply ... (list ...)) early: */ le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args], info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); if (app->num_args == 3) { le = call_with_immed_mark(app->args[0], app->args[1], app->args[2], app->args[3], info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); } le = check_app_let_rator(o, app->args[0], info, app->num_args, context); @@ -3796,7 +3814,7 @@ } optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->args[i], info, sub_context); + le = optimize_expr(app->args[i], info, sub_context); app->args[i] = le; if (info->escapes) { int j; @@ -3858,22 +3876,19 @@ /* Record some properties of an application that are useful to the SFS pass. */ { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(rator); - rator = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - rator = no_potential_size(rator); - if (!rator) return 0; - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) { - return APPN_FLAG_SFS_TAIL; - } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) { - int ps = SCHEME_PROC_SHAPE_MODE(rator); - if ((ps == STRUCT_PROC_SHAPE_PRED) - || (ps == STRUCT_PROC_SHAPE_GETTER) - || (ps == STRUCT_PROC_SHAPE_SETTER)) - return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); - return 0; - } + rator = get_defn_shape(info, (Scheme_IR_Toplevel *)rator); + rator = no_potential_size(rator); + if (!rator) return 0; + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) { + return APPN_FLAG_SFS_TAIL; + } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) { + int ps = SCHEME_PROC_SHAPE_MODE(rator) & STRUCT_PROC_SHAPE_MASK; + if ((ps == STRUCT_PROC_SHAPE_PRED) + || (ps == STRUCT_PROC_SHAPE_GETTER) + || (ps == STRUCT_PROC_SHAPE_SETTER) + || (ps == STRUCT_PROC_SHAPE_CONSTR)) + return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); + return 0; } } @@ -3891,9 +3906,12 @@ return 0; } +#define CHECK_PRIM_AD_HOC_OPT_FLAGS 0 + static int check_known_variant(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe, + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode, Scheme_Object *implies_pred) /* Replace the rator with an unsafe version if we know that it's ok: if the argument is consistent with `expect_pred`; if `unsafe` is @@ -3905,10 +3923,30 @@ generate an error. If unsafe is NULL then rator has no unsafe version, so only check the type. */ { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { +#if CHECK_PRIM_AD_HOC_OPT_FLAGS + if (who) { + Scheme_Object *p; + p = scheme_builtin_value(who); + if (!p) { + printf("bad primitive name: %s\n", who); + abort(); + } + if (!(SCHEME_PRIM_PROC_OPT_FLAGS(p) & SCHEME_PRIM_AD_HOC_OPT)) { + printf("missing SCHEME_PRIM_AD_HOC_OPT: %s\n", who); + abort(); + } + } +#endif + + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { Scheme_Object *pred; - pred = expr_implies_predicate(rand, info); + if (unsafe_mode) + pred = expect_pred; + else + pred = expr_implies_predicate(rand, info); + if (pred) { if (predicate_implies(pred, expect_pred)) { if (unsafe) { @@ -3932,10 +3970,11 @@ static void check_known(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) /* When the expected predicate for unsafe substitution is the same as the implied predicate. */ { - (void)check_known_variant(info, app, rator, rand, who, expect_pred, unsafe, expect_pred); + (void)check_known_variant(info, app, rator, rand, who, expect_pred, unsafe, unsafe_mode, expect_pred); } static void check_known_rator(Optimize_Info *info, Scheme_Object *rator) @@ -3955,18 +3994,24 @@ static void check_known_both_try(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) /* Replace the rator with an unsafe version if both rands have the right type. If not, don't save the type, nor mark this as an error */ { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { Scheme_Object *pred1, *pred2; - - pred1 = expr_implies_predicate(rand1, info); - if (pred1 && SAME_OBJ(pred1, expect_pred)) { - pred2 = expr_implies_predicate(rand2, info); - if (pred2 && SAME_OBJ(pred2, expect_pred)) { + + if (unsafe_mode) { + reset_rator(app, unsafe); + } else { + pred1 = expr_implies_predicate(rand1, info); + if (pred1 && SAME_OBJ(pred1, expect_pred)) { + pred2 = expr_implies_predicate(rand2, info); + if (pred2 && SAME_OBJ(pred2, expect_pred)) { reset_rator(app, unsafe); + } } } } @@ -3974,26 +4019,30 @@ static void check_known_both_variant(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe, + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode, Scheme_Object *implies_pred) { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { int ok1; - ok1 = check_known_variant(info, app, rator, rand1, who, expect_pred, NULL, implies_pred); - check_known_variant(info, app, rator, rand2, who, expect_pred, (ok1 ? unsafe : NULL), implies_pred); + ok1 = check_known_variant(info, app, rator, rand1, who, expect_pred, NULL, unsafe_mode, implies_pred); + check_known_variant(info, app, rator, rand2, who, expect_pred, (ok1 ? unsafe : NULL), unsafe_mode, implies_pred); } } static void check_known_both(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) { - check_known_both_variant(info, app, rator, rand1, rand2, who, expect_pred, unsafe, expect_pred); + check_known_both_variant(info, app, rator, rand1, rand2, who, expect_pred, unsafe, unsafe_mode, expect_pred); } static void check_known_all(Optimize_Info *info, Scheme_Object *_app, int skip_head, int skip_tail, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) { Scheme_App_Rec *app = (Scheme_App_Rec *)_app; if (SCHEME_PRIMP(app->args[0]) && (!who || IS_NAMED_PRIM(app->args[0], who))) { @@ -4001,7 +4050,7 @@ for (i = skip_head; i < app->num_args - skip_tail; i++) { if (!check_known_variant(info, _app, app->args[0], app->args[i+1], who, expect_pred, - NULL, expect_pred)) + NULL, unsafe_mode, expect_pred)) ok_so_far = 0; } @@ -4118,40 +4167,49 @@ if (app->num_args >= 3) rand3 = app->args[3]; - check_known(info, app_o, rator, rand1, "vector-set!", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand2, "vector-set!", scheme_fixnum_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "map", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "for-each", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "andmap", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "ormap", scheme_list_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "string-set!", scheme_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "string-set!", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand3, "string-set!", scheme_char_p_proc, NULL); - check_known(info, app_o, rator, rand1, "bytes-set!", scheme_byte_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "bytes-set!", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand3, "bytes-set!", scheme_fixnum_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known(info, app_o, rator, rand1, "vector-set!", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "vector*-set!", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector*-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "map", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "for-each", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "andmap", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "ormap", scheme_list_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "string-set!", scheme_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_string_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "string-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand3, "string-set!", scheme_char_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "bytes-set!", scheme_byte_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_bytes_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "bytes-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand3, "bytes-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); - check_known_all(info, app_o, 0, 0, "string-append", scheme_string_p_proc, scheme_true); - check_known_all(info, app_o, 0, 0, "bytes-append", scheme_byte_string_p_proc, scheme_true); + check_known_all(info, app_o, 0, 0, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known_all(info, app_o, 0, 0, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); - check_known_all(info, app_o, 0, 1, "append", scheme_list_p_proc, scheme_true); + check_known_all(info, app_o, 0, 1, "append", scheme_list_p_proc, scheme_true, info->unsafe_mode); + } if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known_all(info, app_o, 0, 0, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known_all(info, app_o, 0, 0, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - /* Some of these may have changed app->rator. */ + /* Some of these may have changed app->rator. */ rator = app->args[0]; } @@ -4227,7 +4285,7 @@ expr = (Scheme_Object *)seq; } - return scheme_optimize_expr(expr, info, context); + return optimize_expr(expr, info, context); } } } @@ -4274,7 +4332,7 @@ sub_context = OPT_CONTEXT_SINGLED; - le = scheme_optimize_expr(app->rator, info, sub_context); + le = optimize_expr(app->rator, info, sub_context); app->rator = le; if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -4299,7 +4357,7 @@ optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand, info, sub_context); + le = optimize_expr(app->rand, info, sub_context); app->rand = le; optimize_info_seq_done(info, &info_seq); if (info->escapes) { @@ -4490,77 +4548,114 @@ } } + /* We can resolve (variable-reference-from-unsafe (#%variable-reference)) + to a specific boolean result */ + if (SAME_OBJ(scheme_varref_unsafe_p_proc, rator) + && SAME_TYPE(SCHEME_TYPE(rand), scheme_varref_form_type)) { + Scheme_Object *result = (info->unsafe_mode ? scheme_true : scheme_false); + return replace_tail_inside(result, inside, app->rand); + } - if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, "zero?")) { + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_BOOL) + && (IS_NAMED_PRIM(rator, "zero?") + || IS_NAMED_PRIM(rator, "positive?") + || IS_NAMED_PRIM(rator, "negative?"))) { Scheme_Object* pred; Scheme_App3_Rec *new; pred = expr_implies_predicate(rand, info); if (pred && SAME_OBJ(pred, scheme_fixnum_p_proc)) { - new = (Scheme_App3_Rec *)make_application_3(scheme_unsafe_fx_eq_proc, app->rand, scheme_make_integer(0), info); + Scheme_Object *cmp; + if (IS_NAMED_PRIM(rator, "positive?")) + cmp = scheme_unsafe_fx_gt_proc; + else if (IS_NAMED_PRIM(rator, "negative?")) + cmp = scheme_unsafe_fx_lt_proc; + else + cmp = scheme_unsafe_fx_eq_proc; + new = (Scheme_App3_Rec *)make_application_3(cmp, app->rand, scheme_make_integer(0), info); SCHEME_APPN_FLAGS(new) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); return finish_optimize_application3(new, info, context); } } + if (SAME_OBJ(rator, scheme_system_type_proc) + && SCHEME_SYMBOLP(rand) + && !SCHEME_SYM_WEIRDP(rand) + && !strcmp(SCHEME_SYM_VAL(rand), "vm")) { + /* For the expander's benefit, optimize `(system-type 'vm)` to `'racket` + to effectively select backend details statically. */ + return scheme_intern_symbol("racket"); + } + { /* Try to check the argument's type, and use the unsafe versions if possible. */ Scheme_Object *app_o = (Scheme_Object *)app; - check_known_variant(info, app_o, rator, rand, "bitwise-not", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, scheme_real_p_proc); - check_known_variant(info, app_o, rator, rand, "fxnot", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, scheme_real_p_proc); - - check_known(info, app_o, rator, rand, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); - check_known(info, app_o, rator, rand, "unsafe-car", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); - check_known(info, app_o, rator, rand, "unsafe-cdr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); - check_known(info, app_o, rator, rand, "unsafe-mcar", scheme_mpair_p_proc, NULL); - check_known(info, app_o, rator, rand, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); - check_known(info, app_o, rator, rand, "unsafe-mcdr", scheme_mpair_p_proc, NULL); - check_known(info, app_o, rator, rand, "string-length", scheme_string_p_proc, scheme_unsafe_string_length_proc); - check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_byte_string_length_proc); - /* It's not clear that these are useful, since a chaperone check is needed anyway: */ - check_known(info, app_o, rator, rand, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); - check_known(info, app_o, rator, rand, "unsafe-unbox", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand, "unsafe-unbox*", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); - - check_known(info, app_o, rator, rand, "length", scheme_list_p_proc, scheme_true); - - check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true); - - check_known(info, app_o, rator, rand, "string->symbol", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true); - + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known_variant(info, app_o, rator, rand, "bitwise-not", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, 0, scheme_real_p_proc); + check_known_variant(info, app_o, rator, rand, "fxnot", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, info->unsafe_mode, scheme_real_p_proc); + + check_known(info, app_o, rator, rand, "car", scheme_pair_p_proc, scheme_unsafe_car_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-car", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-cdr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-mcar", scheme_mpair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-mcdr", scheme_mpair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string-length", scheme_string_p_proc, scheme_unsafe_string_length_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_byte_string_length_proc, info->unsafe_mode); + /* It's not clear that these are useful, since a chaperone check is needed anyway: */ + check_known(info, app_o, rator, rand, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unbox*", scheme_box_p_proc, + (info->unsafe_mode ? scheme_unsafe_unbox_star_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-unbox", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-unbox*", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector*-length", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_length_proc : NULL), info->unsafe_mode); + + check_known(info, app_o, rator, rand, "length", scheme_list_p_proc, scheme_true, info->unsafe_mode); + + check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + + check_known(info, app_o, rator, rand, "string->symbol", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true, info->unsafe_mode); + } + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known(info, app_o, rator, rand, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known(info, app_o, rator, rand, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - /* These operation don't have an unsafe replacement. Check to record types and detect errors: */ - check_known(info, app_o, rator, rand, "caar", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cadr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdar", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cddr", scheme_pair_p_proc, NULL); - - check_known(info, app_o, rator, rand, "caddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cadddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cddddr", scheme_pair_p_proc, NULL); - - check_known(info, app_o, rator, rand, "list->vector", scheme_list_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "vector->list", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector->values", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector->immutable-vector", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "make-vector", scheme_fixnum_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + /* These operation don't have an unsafe replacement. Check to record types and detect errors: */ + check_known(info, app_o, rator, rand, "caar", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cadr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdar", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand, "caddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cadddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cddddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand, "list->vector", scheme_list_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->list", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->values", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->immutable-vector", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "make-vector", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + } /* Some of these may have changed app->rator. */ rator = app->rator; @@ -4575,12 +4670,19 @@ if ((mode == STRUCT_PROC_SHAPE_PRED) || (mode == STRUCT_PROC_SHAPE_GETTER)) { Scheme_Object *pred; - pred = expr_implies_predicate(rand, info); + int unsafe = 0; + + if (info->unsafe_mode && (mode == STRUCT_PROC_SHAPE_GETTER)) { + pred = NULL; + unsafe = 1; + } else + pred = expr_implies_predicate(rand, info); - if (pred - && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) - && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), - SCHEME_PROC_SHAPE_IDENTITY(alt))) { + if (unsafe + || (pred + && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) + && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), + SCHEME_PROC_SHAPE_IDENTITY(alt)))) { if (mode == STRUCT_PROC_SHAPE_PRED) { /* We know that the predicate will succeed */ return replace_tail_inside(make_discarding_sequence(rand, scheme_true, info), @@ -4598,11 +4700,16 @@ SCHEME_APPN_FLAGS(new) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); return finish_optimize_application3(new, info, context); } + } else if ((mode == STRUCT_PROC_SHAPE_PRED) && pred && predicate_implies_not(pred, alt)) { + /* We know that the predicate will fail */ + return replace_tail_inside(make_discarding_sequence(rand, scheme_false, info), + inside, + app->rand); } /* Register type based on getter succeeding: */ if ((mode == STRUCT_PROC_SHAPE_GETTER) - && SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(alt)) + && !SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt)) && SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type)) add_type(info, rand, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED, SCHEME_PROC_SHAPE_IDENTITY(alt))); @@ -4638,22 +4745,23 @@ if (SAME_OBJ(app->rator, scheme_check_not_undefined_proc) && SCHEME_SYMBOLP(app->rand2)) { - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "warning%s: use-before-definition check inserted on variable: %S", - scheme_optimize_context_to_string(info->context), - app->rand2); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "warning%s: use-before-definition check inserted on variable: %S", + scheme_optimize_context_to_string(info->context), + app->rand2); } /* Check for (apply ... (list ...)) early: */ le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); le = call_with_immed_mark(app->rator, app->rand1, app->rand2, NULL, info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); le = check_app_let_rator(o, app->rator, info, 2, context); if (le) @@ -4667,7 +4775,7 @@ sub_context = OPT_CONTEXT_SINGLED; - le = scheme_optimize_expr(app->rator, info, sub_context); + le = optimize_expr(app->rator, info, sub_context); app->rator = le; if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -4694,7 +4802,7 @@ optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand1, info, sub_context); + le = optimize_expr(app->rand1, info, sub_context); app->rand1 = le; if (info->escapes) { info->size += 1; @@ -4711,7 +4819,7 @@ optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand2, info, sub_context); + le = optimize_expr(app->rand2, info, sub_context); app->rand2 = le; optimize_info_seq_done(info, &info_seq); if (info->escapes) { @@ -4968,74 +5076,146 @@ if (SCHEME_PRIMP(app->rator)) { Scheme_Object *app_o = (Scheme_Object *)app, *rator = app->rator, *rand1 = app->rand1, *rand2 = app->rand2; - - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-and", scheme_fixnum_p_proc, scheme_unsafe_fxand_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-ior", scheme_fixnum_p_proc, scheme_unsafe_fxior_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-xor", scheme_fixnum_p_proc, scheme_unsafe_fxxor_proc, scheme_real_p_proc); - - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxand", scheme_fixnum_p_proc, scheme_unsafe_fxand_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxior", scheme_fixnum_p_proc, scheme_unsafe_fxior_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxxor", scheme_fixnum_p_proc, scheme_unsafe_fxxor_proc, scheme_real_p_proc); - - check_known_both_try(info, app_o, rator, rand1, rand2, "=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, ">", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, ">=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "min", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "max", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc); - - check_known_both_try(info, app_o, rator, rand1, rand2, "fx=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx>", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx>=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fxmin", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fxmax", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc); - - rator = app->rator; /* in case it was updated */ - check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true); - check_known_both(info, app_o, rator, rand1, rand2, "bytes-append", scheme_byte_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand1, "string-ref", scheme_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "string-ref", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand1, "bytes-ref", scheme_byte_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "bytes-ref", scheme_fixnum_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "append", scheme_list_p_proc, scheme_true); - check_known(info, app_o, rator, rand1, "list-ref", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand2, "list-ref", scheme_fixnum_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-and", scheme_fixnum_p_proc, + scheme_unsafe_fxand_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-ior", scheme_fixnum_p_proc, + scheme_unsafe_fxior_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-xor", scheme_fixnum_p_proc, + scheme_unsafe_fxxor_proc, info->unsafe_mode, scheme_real_p_proc); + + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxand", scheme_fixnum_p_proc, + scheme_unsafe_fxand_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxior", scheme_fixnum_p_proc, + scheme_unsafe_fxior_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxxor", scheme_fixnum_p_proc, + scheme_unsafe_fxxor_proc, info->unsafe_mode, scheme_real_p_proc); + + check_known_both_try(info, app_o, rator, rand1, rand2, "=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, ">", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, ">=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "min", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "max", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc, 0); + + check_known_both_try(info, app_o, rator, rand1, rand2, "fx=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx>", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx>=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fxmin", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fxmax", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc, info->unsafe_mode); + + check_known_both_try(info, app_o, rator, rand1, rand2, "fx+", scheme_fixnum_p_proc, scheme_unsafe_fx_plus_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx-", scheme_fixnum_p_proc, scheme_unsafe_fx_minus_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx*", scheme_fixnum_p_proc, scheme_unsafe_fx_times_proc, info->unsafe_mode); + + rator = app->rator; /* in case it was updated */ + + check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known_both(info, app_o, rator, rand1, rand2, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "string-ref", scheme_string_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "string-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "bytes-ref", scheme_byte_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_bytes_ref_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "bytes-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "append", scheme_list_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "list-ref", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "list-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + } if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known_both(info, app_o, rator, rand1, rand2, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known_both(info, app_o, rator, rand1, rand2, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - check_known(info, app_o, rator, rand1, "vector-ref", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand2, "vector-ref", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand1, "make-vector", scheme_fixnum_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "set-box!", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand1, "unsafe-set-box!", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand1, "unsafe-set-box*!", scheme_box_p_proc, NULL); - - check_known(info, app_o, rator, rand1, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand2, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known(info, app_o, rator, rand1, "vector-ref", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "vector*-ref", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_ref_proc: NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector*-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "make-vector", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "set-box!", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "set-box*!", scheme_box_p_proc, + (info->unsafe_mode ? scheme_unsafe_set_box_star_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand1, "unsafe-set-box!", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "unsafe-set-box*!", scheme_box_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand2, "map", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "for-each", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "andmap", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "ormap", scheme_list_p_proc, NULL); + check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "map", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "for-each", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "andmap", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "ormap", scheme_list_p_proc, NULL, info->unsafe_mode); + } rator = app->rator; /* in case it was updated */ } + + /* Using a struct mutator? */ + { + Scheme_Object *alt; + alt = get_struct_proc_shape(app->rator, info, 0); + if (alt) { + int mode = (SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_MASK); + + if (mode == STRUCT_PROC_SHAPE_SETTER) { + Scheme_Object *pred; + int unsafe = 0; + + if (info->unsafe_mode) { + pred = NULL; + unsafe = 1; + } else + pred = expr_implies_predicate(app->rand1, info); + + if ((unsafe + || (pred + && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) + && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), + SCHEME_PROC_SHAPE_IDENTITY(alt)))) + /* Only if the field position is known: */ + && ((SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT) != 0)) { + /* Struct type matches, so use `unsafe-struct-set!` */ + Scheme_Object *l; + Scheme_App_Rec *new_app; + int pos = (SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT) - 1; + l = scheme_make_pair(scheme_make_integer(pos), + scheme_make_pair(app->rand2, + scheme_null)); + l = scheme_make_pair(app->rand1, l); + l = scheme_make_pair(((SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_AUTHENTIC) + ? scheme_unsafe_struct_star_set_proc + : scheme_unsafe_struct_set_proc), + l); + new_app = (Scheme_App_Rec *)scheme_make_application(l, info); + SCHEME_APPN_FLAGS(new_app) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); + return finish_optimize_application(new_app, info, context); + } + + /* Register type based on setter succeeding: */ + if (!SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt)) + && SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type)) + add_type(info, app->rand1, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED, + SCHEME_PROC_SHAPE_IDENTITY(alt))); + } + } + } increment_clocks_for_application(info, app->rator, 2); @@ -5139,9 +5319,6 @@ Scheme_Object *o3; int i, j, k, count, extra = 0, split = 0, b0, new_count; - if (SAME_TYPE(SCHEME_TYPE(o), scheme_splice_sequence_type)) - return o; - if (!info->flatten_fuel) return o; @@ -5222,10 +5399,10 @@ if (sub_opt) { optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(s->array[i], info, - ((i + 1 == count) - ? scheme_optimize_tail_context(context) - : 0)); + le = optimize_expr(s->array[i], info, + ((i + 1 == count) + ? scheme_optimize_tail_context(context) + : 0)); } else le = s->array[i]; @@ -5340,7 +5517,8 @@ if (SAME_TYPE(SCHEME_TYPE(a), scheme_ir_toplevel_type) && SAME_TYPE(SCHEME_TYPE(b), scheme_ir_toplevel_type) - && (SCHEME_TOPLEVEL_POS(a) == SCHEME_TOPLEVEL_POS(b))) + && (SCHEME_IR_TOPLEVEL_INSTANCE(a) == SCHEME_IR_TOPLEVEL_INSTANCE(b)) + && (SCHEME_IR_TOPLEVEL_POS(a) == SCHEME_IR_TOPLEVEL_POS(b))) return a; if (b_info @@ -5491,7 +5669,7 @@ i = scheme_hash_tree_next(f_types, -1); while (i != -1) { scheme_hash_tree_index(f_types, i, &var, &f_pred); - t_pred = scheme_hash_tree_get(t_types, var); + t_pred = scheme_eq_hash_tree_get(t_types, var); if (t_pred) { if (predicate_implies(f_pred, t_pred)) add_type(base_info, var, t_pred); @@ -5624,12 +5802,15 @@ return 0; /* we don't track structure-type identity precisely enough to know - that structures don't rule out other structures --- or even other - prdicates (such as `procedure?`) */ - if (SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type) - || SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type)) + that structures don't rule out other structures; among the + tracked predicates, only `procedure?` is compatible with + structures */ + if ((SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type) + || SAME_OBJ(pred1, scheme_procedure_p_proc)) + && (SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type) + || SAME_OBJ(pred2, scheme_procedure_p_proc))) return 0; - + /* Otherwise, with our current set of predicates, overlapping matches happen only when one implies the other: */ return (!predicate_implies(pred1, pred2) && !predicate_implies(pred2, pred1)); @@ -5661,7 +5842,7 @@ shape = get_struct_proc_shape(app->rator, info, 0); if (shape && ((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) - && SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(shape))) { + && !SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(shape))) { add_type(info, app->rand, shape); } } @@ -5773,7 +5954,7 @@ optimize_info_seq_init(info, &info_seq); - t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN | OPT_CONTEXT_SINGLED); + t = optimize_expr(t, info, OPT_CONTEXT_BOOLEAN | OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -5842,9 +6023,9 @@ info->size -= 1; if (SCHEME_FALSEP(t2)) - xb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); + xb = optimize_expr(fb, info, scheme_optimize_tail_context(context)); else - xb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); + xb = optimize_expr(tb, info, scheme_optimize_tail_context(context)); optimize_info_seq_done(info, &info_seq); return replace_tail_inside(xb, inside, t); @@ -5860,10 +6041,10 @@ init_kclock = info->kclock; init_sclock = info->sclock; - then_info = optimize_info_add_frame(info, 0, 0, 0); + then_info = optimize_info_add_frame(info, 0); add_types_for_t_branch(t, then_info, 5); - then_info_init = optimize_info_add_frame(then_info, 0, 0, 0); - tb = scheme_optimize_expr(tb, then_info, scheme_optimize_tail_context(context)); + then_info_init = optimize_info_add_frame(then_info, 0); + tb = optimize_expr(tb, then_info, scheme_optimize_tail_context(context)); optimize_info_done(then_info, NULL); info->escapes = 0; @@ -5874,10 +6055,10 @@ optimize_info_seq_step(info, &info_seq); - else_info = optimize_info_add_frame(info, 0, 0, 0); + else_info = optimize_info_add_frame(info, 0); add_types_for_f_branch(t, else_info, 5); - else_info_init = optimize_info_add_frame(else_info, 0, 0, 0); - fb = scheme_optimize_expr(fb, else_info, scheme_optimize_tail_context(context)); + else_info_init = optimize_info_add_frame(else_info, 0); + fb = optimize_expr(fb, else_info, scheme_optimize_tail_context(context)); optimize_info_done(else_info, NULL); if (then_info->escapes && else_info->escapes) { @@ -6044,7 +6225,7 @@ optimize_info_seq_init(info, &info_seq); - k = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); + k = optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6053,7 +6234,7 @@ optimize_info_seq_step(info, &info_seq); - v = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); + v = optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6069,7 +6250,7 @@ optimize_info_seq_step(info, &info_seq); - b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); + b = optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); if (init_vclock == info->vclock) { /* body has no effect itself, so we can rewind the clock */ @@ -6116,14 +6297,12 @@ static Scheme_Object * define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0]; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1]; + Scheme_Object *val = SCHEME_DEFN_RHS(data); optimize_info_used_top(info); - val = scheme_optimize_expr(val, info, 0); + val = optimize_expr(val, info, 0); - SCHEME_VEC_ELS(data)[0] = vars; - SCHEME_VEC_ELS(data)[1] = val; + SCHEME_DEFN_RHS(data) = val; return data; } @@ -6137,7 +6316,7 @@ var = sb->var; val = sb->val; - val = scheme_optimize_expr(val, info, OPT_CONTEXT_SINGLED); + val = optimize_expr(val, info, OPT_CONTEXT_SINGLED); if (info->escapes) return ensure_noncm(val, info); @@ -6148,6 +6327,7 @@ if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { register_use(SCHEME_VAR(var), info); } else { + MZ_ASSERT(((Scheme_IR_Toplevel *)var)->instance_pos == -1); optimize_info_used_top(info); } @@ -6195,28 +6375,14 @@ if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { SCHEME_PTR1_VAL(data) = (SCHEME_VAR(v)->mutated ? scheme_false : scheme_true); } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)) { - /* Knowing whether a top-level variable is fixed lets up optimize + /* Knowing whether a top-level variable is fixed lets us optimize uses of `variable-reference-constant?` */ - if (info->top_level_consts) { - int pos = SCHEME_TOPLEVEL_POS(v); - int fixed = 0; - - if (scheme_hash_get(info->top_level_consts, scheme_make_integer(pos))) - fixed = 1; - else { - GC_CAN_IGNORE Scheme_Object *t; - t = scheme_hash_get(info->top_level_consts, scheme_false); - if (t) { - if (scheme_hash_get((Scheme_Hash_Table *)t, scheme_make_integer(pos))) - fixed = 1; - } - } - - if (fixed) { - v = scheme_toplevel_to_flagged_toplevel(v, SCHEME_TOPLEVEL_FIXED); - SCHEME_PTR1_VAL(data) = v; - } + if (get_defn_shape(info, (Scheme_IR_Toplevel *)v) + || get_import_shape(info, (Scheme_IR_Toplevel *)v)) { + v = scheme_ir_toplevel_to_flagged_toplevel(v, SCHEME_TOPLEVEL_FIXED); + SCHEME_PTR1_VAL(data) = v; } + register_import_used(info, (Scheme_IR_Toplevel *)v); } info->preserves_marks = 1; @@ -6259,7 +6425,7 @@ optimize_info_seq_init(info, &info_seq); - f = scheme_optimize_expr(f, info, OPT_CONTEXT_SINGLED); + f = optimize_expr(f, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6267,7 +6433,7 @@ } optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); + e = optimize_expr(e, info, 0); optimize_info_seq_done(info, &info_seq); @@ -6316,14 +6482,14 @@ optimize_info_seq_init(info, &info_seq); - key = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); + key = optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); optimize_info_seq_step(info, &info_seq); if (info->escapes) { optimize_info_seq_done(info, &info_seq); return ensure_noncm(key, info); } - val = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); + val = optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); optimize_info_seq_step(info, &info_seq); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6332,14 +6498,14 @@ optimize_info_seq_done(info, &info_seq); - body_info = optimize_info_add_frame(info, 1, 1, 0); + body_info = optimize_info_add_frame(info, 0); var = SCHEME_VAR(SCHEME_CAR(wcm->body)); set_optimize_mode(var); var->optimize.lambda_depth = body_info->lambda_depth; var->optimize_used = 0; var->optimize.init_kclock = info->kclock; - body = scheme_optimize_expr(SCHEME_CDR(wcm->body), body_info, 0); + body = optimize_expr(SCHEME_CDR(wcm->body), body_info, 0); optimize_info_done(body_info, NULL); @@ -6389,7 +6555,7 @@ for (i = 0; i < seq->count; i++) { le = seq->array[i]; - le = scheme_optimize_expr(le, info, 0); + le = optimize_expr(le, info, 0); seq->array[i] = le; } @@ -6438,11 +6604,11 @@ optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(s->array[i], - info, - (!i - ? scheme_optimize_result_context(context) - : 0)); + le = optimize_expr(s->array[i], + info, + (!i + ? scheme_optimize_result_context(context) + : 0)); if (!i) { single_result = info->single_result; @@ -6577,53 +6743,6 @@ return replace_tail_inside(expr, inside, orig_first); } -static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info) -{ - Scheme_Object *val; - Optimize_Info *einfo; - - val = SCHEME_VEC_ELS(data)[3]; - - einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); - if (info->inline_fuel < 0) - einfo->inline_fuel = -1; - einfo->logger = info->logger; - - val = scheme_optimize_expr(val, einfo, 0); - - SCHEME_VEC_ELS(data)[3] = val; - - return data; -} - -static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return do_define_syntaxes_optimize(data, info); -} - -static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Object *l, *a; - Optimize_Info *einfo; - - l = SCHEME_VEC_ELS(data)[2]; - - while (!SCHEME_NULLP(l)) { - einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); - if (info->inline_fuel < 0) - einfo->inline_fuel = -1; - einfo->logger = info->logger; - - a = SCHEME_CAR(l); - a = scheme_optimize_expr(a, einfo, 0); - SCHEME_CAR(l) = a; - - l = SCHEME_CDR(l); - } - - return data; -} - /*========================================================================*/ /* let, let-values, letrec, etc. */ /*========================================================================*/ @@ -6663,7 +6782,7 @@ case scheme_ir_toplevel_type: return 1; case scheme_ir_local_type: - if (!scheme_hash_tree_get(exclude_vars, o)) + if (!scheme_eq_hash_tree_get(exclude_vars, o)) return 1; break; case scheme_branch_type: @@ -6753,27 +6872,29 @@ } return 1; } else { - Scheme_Lambda *lam = (Scheme_Lambda *)value; - if (sz < 0) - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - /* contains non-copyable body elements that prevent inlining */ - "non-copyable %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - 0, /* no sensible threshold here */ - scheme_optimize_context_to_string(info->context)); - else - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - /* too large to be an inlining candidate */ - "too-large %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - 0, /* no sensible threshold here */ - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) { + Scheme_Lambda *lam = (Scheme_Lambda *)value; + if (sz < 0) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + /* contains non-copyable body elements that prevent inlining */ + "non-copyable %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + 0, /* no sensible threshold here */ + scheme_optimize_context_to_string(info->context)); + else + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + /* too large to be an inlining candidate */ + "too-large %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + 0, /* no sensible threshold here */ + scheme_optimize_context_to_string(info->context)); + } return 0; } } @@ -6789,25 +6910,25 @@ } if (SAME_TYPE(SCHEME_TYPE(value), scheme_ir_toplevel_type)) { - if ((SCHEME_TOPLEVEL_FLAGS(value) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)value) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + return 1; + if (get_import_shape(info, (Scheme_IR_Toplevel *)value)) return 1; - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(value); - value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - value = no_potential_size(value); - if (SAME_OBJ(value, scheme_constant_key) - || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) - return 0; - if (value) - return 1; - } - return 0; - } - /* Test this after the specific cases, - because it recognizes locals and toplevels. */ - if (scheme_ir_duplicate_ok(value, 0)) + value = get_defn_shape(info, (Scheme_IR_Toplevel *)value); + value = no_potential_size(value); + if (SAME_OBJ(value, scheme_constant_key) + || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) + return 0; + else if (value) + return 1; + else + return 0; + } + + /* Test this after the specific cases, + because it recognizes locals and toplevels. */ + if (scheme_ir_duplicate_ok(value, 0)) return 1; return 0; @@ -6906,7 +7027,7 @@ } else if (fuel && SAME_TYPE(SCHEME_TYPE(e), scheme_branch_type)) { Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_ir_local_type) - && !scheme_hash_tree_get(except_vars, b->test) + && !scheme_eq_hash_tree_get(except_vars, b->test) && !SCHEME_VAR(b->test)->mutated) { return (is_values_apply(b->tbranch, n, info, except_vars, 0) && is_values_apply(b->fbranch, n, info, except_vars, 0)); @@ -7326,6 +7447,47 @@ } } +/* Convert up to `c` clauses for `let-values` into a `begin`, where + the converted clauses have zero bindings. The `head` argument will + be non-NULL if there's a possibility of remaining clauses. */ +static Scheme_Object *convert_leading_zero_bindings_to_begin(Scheme_IR_Let_Header *head, + Scheme_Object *start_body, + int c) +{ + Scheme_Object *body; + Scheme_IR_Let_Value *irlv; + Scheme_Sequence *seq; + int i, n = 0; + + body = start_body; + for (i = 0; i < c; i++) { + irlv = (Scheme_IR_Let_Value *)body; + if (irlv->count) + break; + n++; + body = irlv->body; + } + + seq = scheme_malloc_sequence(n + 1); + seq->so.type = scheme_sequence_type; + seq->count = n + 1; + body = start_body; + for (i = 0; i < n; i++) { + irlv = (Scheme_IR_Let_Value *)body; + seq->array[i] = irlv->value; + body = irlv->body; + } + + if (n < c) { + head->num_clauses -= n; + head->body = body; + seq->array[n] = (Scheme_Object *)head; + } else + seq->array[n] = body; + + return (Scheme_Object *)seq; +} + static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, int context) /* This is the main entry point for optimizing a `let[rec]-values` form. */ { @@ -7372,7 +7534,7 @@ b3->tbranch = scheme_true; b3->fbranch = b->fbranch; - form = scheme_optimize_expr((Scheme_Object *)b3, info, context); + form = optimize_expr((Scheme_Object *)b3, info, context); return form; } @@ -7390,10 +7552,18 @@ if (SAME_OBJ((Scheme_Object *)irlv->vars[0], irlv->body)) { body = irlv->value; body = ensure_single_value_noncm(body, info); - return scheme_optimize_expr(body, info, context); + return optimize_expr(body, info, context); } } + /* Zero leading bindings in unsafe mode => convert to `begin`, since + we can unsafely drop the check on the number of results */ + if (!is_rec && info->unsafe_mode && head->num_clauses + && !((Scheme_IR_Let_Value *)head->body)->count) { + body = convert_leading_zero_bindings_to_begin(head, head->body, head->num_clauses); + return optimize_expr(body, info, context); + } + if (!is_rec) { int try_again; do { @@ -7427,13 +7597,13 @@ irlv->value = seq->array[seq->count - 1]; seq->array[seq->count - 1] = (Scheme_Object *)head; - return scheme_optimize_expr((Scheme_Object *)seq, info, context); + return optimize_expr((Scheme_Object *)seq, info, context); } } } while (try_again); } - body_info = optimize_info_add_frame(info, head->count, head->count, 0); + body_info = optimize_info_add_frame(info, 0); rhs_info = body_info; merge_skip_vars = scheme_make_hash_tree(SCHEME_hashtr_eq); @@ -7521,14 +7691,14 @@ pre_sclock = rhs_info->sclock; if (!found_escapes) { optimize_info_seq_step(rhs_info, &info_seq); - value = scheme_optimize_expr(pre_body->value, rhs_info, - (((pre_body->count == 1) - ? OPT_CONTEXT_SINGLED - : 0) - | (((pre_body->count == 1) - && !pre_body->vars[0]->non_app_count) - ? (pre_body->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) - : 0))); + value = optimize_expr(pre_body->value, rhs_info, + (((pre_body->count == 1) + ? OPT_CONTEXT_SINGLED + : 0) + | (((pre_body->count == 1) + && !pre_body->vars[0]->non_app_count) + ? (pre_body->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) + : 0))); pre_body->value = value; if (rhs_info->escapes) found_escapes = 1; @@ -7860,14 +8030,14 @@ rhs_info->use_psize = info->use_psize; optimize_info_seq_step(rhs_info, &info_seq); - value = scheme_optimize_expr(self_value, rhs_info, - (((irlv->count == 1) - ? OPT_CONTEXT_SINGLED - : 0) - | (((irlv->count == 1) - && !irlv->vars[0]->non_app_count) - ? (irlv->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) - : 0))); + value = optimize_expr(self_value, rhs_info, + (((irlv->count == 1) + ? OPT_CONTEXT_SINGLED + : 0) + | (((irlv->count == 1) + && !irlv->vars[0]->non_app_count) + ? (irlv->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) + : 0))); if (!OPT_DISCOURAGE_EARLY_INLINE) --rhs_info->letrec_not_twice; @@ -7984,7 +8154,7 @@ optimize_info_seq_done(body_info, &info_seq); if (!found_escapes) { - body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context)); + body = optimize_expr(body, body_info, scheme_optimize_tail_context(context)); } else { body = ensure_noncm(escape_body, body_info); body_info->single_result = 1; @@ -8217,6 +8387,36 @@ form = optimize_sequence(form, info, context, 0); } + if (!is_rec && info->unsafe_mode) { + /* Peel zero-binding clauses off the end in unsafe mode? */ + if (SAME_TYPE(SCHEME_TYPE(form), scheme_ir_let_header_type)) { + int i, c, n; + head = (Scheme_IR_Let_Header *)form; + c = head->num_clauses; + n = head->count; + prev_body = NULL; + body = head->body; + for (i = 0; i < c; i++) { + if (!n) { + /* We've seen as many bindings as exist, to the rest + must be clauses with zero bindings */ + body = convert_leading_zero_bindings_to_begin(NULL, body, c - i); + if (prev_body) { + prev_body->body = body; + head->num_clauses = i; + } else + form = body; + break; + } else { + irlv = (Scheme_IR_Let_Value *)body; + n -= irlv->count; + prev_body = irlv; + body = irlv->body; + } + } + } + } + return form; } @@ -8228,7 +8428,7 @@ optimize_lambda(Scheme_Object *_lam, Optimize_Info *info, int context) { Scheme_Lambda *lam; - Scheme_Object *code, *ctx; + Scheme_Object *code, *ctx, *to_remove; Scheme_IR_Lambda_Info *cl; int i, init_vclock, init_aclock, init_kclock, init_sclock; Scheme_Hash_Table *ht; @@ -8239,8 +8439,7 @@ info->single_result = 1; info->preserves_marks = 1; - info = optimize_info_add_frame(info, lam->num_params, lam->num_params, - SCHEME_LAMBDA_FRAME); + info = optimize_info_add_frame(info, SCHEME_LAMBDA_FRAME); ht = scheme_make_hash_table(SCHEME_hash_ptr); info->uses = ht; @@ -8280,7 +8479,7 @@ } } - code = scheme_optimize_expr(lam->body, info, 0); + code = optimize_expr(lam->body, info, 0); propagate_used_variables(info); @@ -8300,6 +8499,30 @@ lam->body = code; + /* Double check that variables registered for the closure are marked + as used. Although the resolve pass double-checks use flags, we + need to remove any variable that was tentaively marked as used, + because it's non-use may turn a `letrec` into a `let`, and the + `let`-bound variable may be later used after all --- after the + `letrec`->`let` conversion is decided. In other words, ensure + that the closure's free variables are consistent with any + `letrec`->`let` decisions when the `lambda` appear on the + right-hand side of a binding. */ + to_remove = scheme_null; + for (i = 0; i < ht->size; i++) { + if (ht->vals[i]) { + Scheme_IR_Local *var = SCHEME_VAR(ht->keys[i]); + if (!var->optimize_used) { + /* Must have been tentively used, but not used after all. */ + to_remove = scheme_make_pair((Scheme_Object *)var, to_remove); + } + } + } + while (SCHEME_PAIRP(to_remove)) { + scheme_hash_set(ht, SCHEME_CAR(to_remove), NULL); + to_remove = SCHEME_CDR(to_remove); + } + /* Remembers positions of used vars (and unsets usage for this level) */ cl->base_closure = info->uses; if (env_uses_toplevel(info)) @@ -8455,7 +8678,7 @@ ht = scheme_make_hash_table(SCHEME_hash_ptr); for (i = 0; i < cl->base_closure->size; i++) { if (cl->base_closure->vals[i]) { - var = scheme_hash_tree_get(var_map, cl->base_closure->keys[i]); + var = scheme_eq_hash_tree_get(var_map, cl->base_closure->keys[i]); scheme_hash_set(ht, (var ? var @@ -8497,7 +8720,7 @@ } /*========================================================================*/ -/* modules */ +/* linklets */ /*========================================================================*/ static int set_code_closure_flags(Scheme_Object *clones, @@ -8528,11 +8751,11 @@ return flags; } -static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimize_Info *info, +static Scheme_Object *is_cross_linklet_inline_candidiate(Scheme_Object *e, Optimize_Info *info, int size_override) { if (SCHEME_LAMBDAP(e)) { - if (size_override || (lambda_body_size(e, 1) < CROSS_MODULE_INLINE_SIZE)) + if (size_override || (lambda_body_size(e, 1) < CROSS_LINKLET_INLINE_SIZE)) return optimize_clone(0, e, info, empty_eq_hash_tree, 0); } @@ -8573,21 +8796,22 @@ return 0; } -void install_definition(Scheme_Object *vec, int pos, Scheme_Object *var, Scheme_Object *rhs) +void install_definition(Scheme_Object *bodies, int pos, Scheme_Object *old_defn, int name_pos, Scheme_Object *rhs) { Scheme_Object *def; - var = scheme_make_pair(var, scheme_null); def = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(def)[0] = var; - SCHEME_VEC_ELS(def)[1] = rhs; + SCHEME_DEFN_RHS(def) = rhs; + SCHEME_DEFN_VAR_(def, 0) = SCHEME_DEFN_VAR_(old_defn, name_pos); def->type = scheme_define_values_type; - SCHEME_VEC_ELS(vec)[pos] = def; + SCHEME_VEC_ELS(bodies)[pos] = def; } -int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Object *vec, int offset) +int split_define_values(Scheme_Object *defn, int n, Scheme_Object *bodies, int offset) { + Scheme_Object *e = SCHEME_DEFN_RHS(defn); + if (SAME_TYPE(SCHEME_TYPE(e), scheme_ir_let_header_type)) { /* This is a tedious case to recognize the pattern (let ([x rhs] ...) (values x ...)) @@ -8616,11 +8840,10 @@ if (SAME_OBJ(app->rator, scheme_values_proc) && SAME_OBJ(app->rand1, (Scheme_Object *)lv->vars[0]) && SAME_OBJ(app->rand2, (Scheme_Object *)((Scheme_IR_Let_Value *)lv->body)->vars[0])) { - if (vars) { - install_definition(vec, offset, SCHEME_CAR(vars), lv->value); - vars = SCHEME_CDR(vars); + if (bodies) { + install_definition(bodies, offset, defn, 0, lv->value); lv = (Scheme_IR_Let_Value *)lv->body; - install_definition(vec, offset+1, SCHEME_CAR(vars), lv->value); + install_definition(bodies, offset+1, defn, 1, lv->value); } return 1; } @@ -8635,12 +8858,11 @@ return 0; lv = (Scheme_IR_Let_Value *)lv->body; } - if (vars) { + if (bodies) { body = lh->body; for (i = 0; i < n; i++) { Scheme_IR_Let_Value *lv2 = (Scheme_IR_Let_Value *)body; - install_definition(vec, offset+i, SCHEME_CAR(vars), lv2->value); - vars = SCHEME_CDR(vars); + install_definition(bodies, offset+i, defn, i, lv2->value); body = lv2->body; } } @@ -8653,10 +8875,9 @@ if (SAME_OBJ(app->rator, scheme_values_proc) && scheme_omittable_expr(app->rand1, 1, 5, 0, NULL, NULL) && scheme_omittable_expr(app->rand2, 1, 5, 0, NULL, NULL)) { - if (vars) { - install_definition(vec, offset, SCHEME_CAR(vars), app->rand1); - vars = SCHEME_CDR(vars); - install_definition(vec, offset+1, SCHEME_CAR(vars), app->rand2); + if (bodies) { + install_definition(bodies, offset, defn, 0, app->rand1); + install_definition(bodies, offset+1, defn, 1, app->rand2); } return 1; } @@ -8669,10 +8890,9 @@ if (!scheme_omittable_expr(app->args[i+1], 1, 5, 0, NULL, NULL)) return 0; } - if (vars) { + if (bodies) { for (i = 0; i < n; i++) { - install_definition(vec, offset+i, SCHEME_CAR(vars), app->args[i+1]); - vars = SCHEME_CDR(vars); + install_definition(bodies, offset+i, defn, i, app->args[i+1]); } } return 1; @@ -8699,123 +8919,139 @@ return fixed_table; } -static Scheme_Object * -module_optimize(Scheme_Object *data, Optimize_Info *info, int context) +Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode, + Scheme_Object **_import_keys, Scheme_Object *get_import) { - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *vars, *old_context; + Scheme_Object *e; int start_simultaneous = 0, i_m, cnt; Scheme_Object *cl_first = NULL, *cl_last = NULL; Scheme_Hash_Table *consts = NULL, *fixed_table = NULL, *re_consts = NULL; Scheme_Hash_Table *originals = NULL; - int cont, next_pos_ready = -1, inline_fuel, is_proc_def; - Comp_Prefix *prev_cp; + int cont, inline_fuel, is_proc_def, any_defns = 0; + Optimize_Info *info; Optimize_Info *limited_info; Optimize_Info_Sequence info_seq; + Scheme_Hash_Tree **iu; + /* For now, treat unsafe mode as a hint that cooperation with the validator + is not needed. We may eventually give up on the validator completely. */ + int support_validation = !unsafe_mode; + + info = optimize_info_create(linklet, enforce_const, can_inline, unsafe_mode); + info->context = (Scheme_Object *)linklet; + + /* Less inlining for a large module: */ + if (SCHEME_VEC_SIZE(linklet->bodies) > 128) + info->inline_fuel >>= 1; + + if (_import_keys) { + Cross_Linklet_Info *cross; + Scheme_Hash_Tree *ht; + int i; - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; - } - - if (m->phaseless) { - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "compilation of cross-phase persistent module: %D", - m->modname); + iu = MALLOC_N(Scheme_Hash_Tree*, 1); + *iu = empty_eq_hash_tree; + info->imports_used = iu; + + cross = (Cross_Linklet_Info *)scheme_malloc(sizeof(Cross_Linklet_Info)); + info->cross = cross; + + cross->get_import = get_import; + + cross->import_keys = empty_eq_hash_tree; + cross->rev_import_keys = empty_eq_hash_tree; + for (i = 0; i < SCHEME_VEC_SIZE(*_import_keys); i++) { + ht = scheme_hash_tree_set(cross->import_keys, + scheme_make_integer(i), + SCHEME_VEC_ELS(*_import_keys)[i]); + cross->import_keys = ht; + ht = scheme_hash_tree_set(cross->rev_import_keys, + SCHEME_VEC_ELS(*_import_keys)[i], + scheme_make_integer(i)); + cross->rev_import_keys = ht; + } + cross->linklets = empty_eq_hash_tree; + cross->import_next_keys = empty_eq_hash_tree; + cross->inline_variants = empty_eq_hash_tree; + cross->import_syms = empty_eq_hash_tree; } - old_context = info->context; - info->context = (Scheme_Object *)m; - optimize_info_seq_init(info, &info_seq); - prev_cp = info->cp; - info->cp = m->comp_prefix; - - /* Use `limited_info` for optimization decisions that need to be - rediscovered by the validator. The validator knows shape - information for imported variables, and it knows about structure - bindings for later forms. */ - limited_info = MALLOC_ONE_RT(Optimize_Info); -#ifdef MZTAG_REQUIRED - limited_info->type = scheme_rt_optimize_info; -#endif - limited_info->cp = info->cp; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); + cnt = SCHEME_VEC_SIZE(linklet->bodies); /* First, flatten `(define-values (x ...) (values e ...))' to `(define (x) e) ...' when possible. */ { int inc = 0; for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - n = scheme_list_length(vars); + n = SCHEME_DEFN_VAR_COUNT(e); if (n > 1) { - e = SCHEME_VEC_ELS(e)[1]; - if (split_define_values(e, n, NULL, NULL, 0)) + if (split_define_values(e, n, NULL, 0)) inc += (n - 1); } + any_defns = 1; } } if (inc > 0) { - Scheme_Object *new_vec; + Scheme_Object *new_bodies; int j = 0; - new_vec = scheme_make_vector(cnt+inc, NULL); + new_bodies = scheme_make_vector(cnt+inc, scheme_false); for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - n = scheme_list_length(vars); + n = SCHEME_DEFN_VAR_COUNT(e); if (n > 1) { - if (split_define_values(SCHEME_VEC_ELS(e)[1], n, vars, new_vec, j)) { + if (split_define_values(e, n, new_bodies, j)) { j += n; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } cnt += inc; - m->bodies[0] = new_vec; + linklet->bodies = new_bodies; } } - if (OPT_ESTIMATE_FUTURE_SIZES) { + if (any_defns) { + /* Use `limited_info` for optimization decisions that need to be + rediscovered by the validator. The validator knows shape + information for imported variables, and it knows about structure + bindings for later forms. */ + limited_info = MALLOC_ONE_RT(Optimize_Info); +#ifdef MZTAG_REQUIRED + limited_info->type = scheme_rt_optimize_info; +#endif + limited_info->linklet = info->linklet; + } else + limited_info = NULL; + + if (OPT_ESTIMATE_FUTURE_SIZES && any_defns) { if (info->enforce_const) { /* For each identifier bound to a procedure, register an initial size estimate, which is used to discourage early loop unrolling at the expense of later inlining. */ for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; + n = SCHEME_DEFN_VAR_COUNT(e); + if ((n == 1) && SCHEME_LAMBDAP(SCHEME_DEFN_RHS(e))) { + Scheme_IR_Toplevel *var = SCHEME_DEFN_VAR(e, 0); - n = scheme_list_length(vars); - if ((n == 1) && SCHEME_LAMBDAP(e)) { - Scheme_Toplevel *tl; - - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - int pos; + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { if (!consts) consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, - scheme_make_integer(pos), - estimate_closure_size(e)); + scheme_hash_set(consts, scheme_make_integer(var->variable_pos), estimate_closure_size(e)); } } } @@ -8830,32 +9066,31 @@ for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; is_proc_def = 0; if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *e2; - e2 = SCHEME_VEC_ELS(e)[1]; + e2 = SCHEME_DEFN_RHS(e); if (is_general_lambda(e2, info)) is_proc_def = 1; } } + inline_fuel = info->inline_fuel; if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { info->use_psize = 1; - inline_fuel = info->inline_fuel; if (inline_fuel > 2) info->inline_fuel = 2; - } else - inline_fuel = 0; + } optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); + e = optimize_expr(e, info, 0); if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { info->use_psize = 0; - info->inline_fuel = inline_fuel; } - SCHEME_VEC_ELS(m->bodies[0])[i_m] = e; + info->inline_fuel = inline_fuel; + SCHEME_VEC_ELS(linklet->bodies)[i_m] = e; if (info->enforce_const) { /* If this expression/definition can't have any side effect @@ -8865,26 +9100,32 @@ int n, cnst = 0, sproc = 0, sprop = 0, has_guard = 0; Scheme_Object *sstruct = NULL, *parent_identity = NULL; Simple_Struct_Type_Info stinfo; + Scheme_Object *defn = e; - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; + n = SCHEME_DEFN_VAR_COUNT(defn); + e = SCHEME_DEFN_RHS(defn); - n = scheme_list_length(vars); + if (support_validation) + limited_info->cross = info->cross; cont = scheme_omittable_expr(e, n, -1, - /* ignore APPN_FLAG_OMITTABLE, because the - validator won't be able to reconstruct it - in general; also, don't recognize struct-type - functions, since they weren't recognized - as immediate calls */ - (OMITTABLE_IGNORE_APPN_OMIT - | OMITTABLE_IGNORE_MAKE_STRUCT_TYPE), + (support_validation + /* ignore APPN_FLAG_OMITTABLE, because the + validator won't be able to reconstruct it + in general; also, don't recognize struct-type + functions, since they weren't recognized + as immediate calls */ + ? (OMITTABLE_IGNORE_APPN_OMIT + | OMITTABLE_IGNORE_MAKE_STRUCT_TYPE) + : 0), /* similarly, use `limited_info` instead of `info' here, because the decision of omittable should not depend on information that's only available at optimization time: */ - limited_info, + (support_validation ? limited_info : info), info); + if (support_validation) + info->cross = limited_info->cross; if (n == 1) { if (ir_propagate_ok(e, info, 0, NULL)) @@ -8895,39 +9136,41 @@ } } else if (scheme_is_simple_make_struct_type(e, n, 0, NULL, &stinfo, &parent_identity, - info->top_level_consts, - info->cp->inline_variants, - NULL, NULL, 0, NULL, NULL, + info, + NULL, NULL, 0, NULL, &sstruct, 5)) { sstruct = scheme_make_pair(sstruct, parent_identity); cnst = 1; } else if (scheme_is_simple_make_struct_type_property(e, n, 0, &has_guard, - info->top_level_consts, - info->cp->inline_variants, - NULL, NULL, 0, NULL, NULL, + info, + NULL, NULL, 0, NULL, 5)) { sprop = 1; cnst = 1; } else sstruct = NULL; - if ((sstruct || sprop) && !cont) { + if (support_validation && (sstruct || sprop) && !cont) { /* Since the `make-struct-type` or `make-struct-tye-property` form is immediate enough that the validator can see it, re-check whether we can continue a group of simultaneously defined variables. */ cont = scheme_omittable_expr(e, n, 5, OMITTABLE_IGNORE_APPN_OMIT, limited_info, NULL); } + if (cont) { + /* Record for the resolve pass's pruning that definition is omittable */ + SCHEME_SET_DEFN_CAN_OMIT(defn); + } + if (cnst) { - Scheme_Toplevel *tl; + Scheme_IR_Toplevel *var; int i; for (i = 0; i < n; i++) { - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - vars = SCHEME_CDR(vars); + var = SCHEME_DEFN_VAR(defn, i); - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { Scheme_Object *e2; if (sstruct) { @@ -8954,15 +9197,12 @@ } if (e2) { - int pos; - pos = tl->position; - consts = info->top_level_consts; if (!consts) { consts = scheme_make_hash_table(SCHEME_hash_ptr); info->top_level_consts = consts; } - scheme_hash_set(consts, scheme_make_integer(pos), e2); + scheme_hash_set(consts, scheme_make_integer(var->variable_pos), e2); if (sstruct || sprop) { /* include in `limited_info` */ @@ -8971,7 +9211,7 @@ limited_consts = scheme_make_hash_table(SCHEME_hash_ptr); limited_info->top_level_consts = limited_consts; } - scheme_hash_set(limited_consts, scheme_make_integer(pos), e2); + scheme_hash_set(limited_consts, scheme_make_integer(var->variable_pos), e2); } if (sstruct || (SCHEME_TYPE(e2) > _scheme_ir_values_types_)) { @@ -8979,46 +9219,45 @@ } else { if (!re_consts) re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); + scheme_hash_set(re_consts, scheme_make_integer(i_m), scheme_make_integer(var->variable_pos)); } } else { /* At least mark it as fixed */ - fixed_table = set_as_fixed(fixed_table, info, tl->position); + fixed_table = set_as_fixed(fixed_table, info, SCHEME_IR_TOPLEVEL_POS(var)); } } } - } else { + } else if (cont) { /* The binding is not inlinable/propagatable, but unless it's set!ed, it is constant after evaluating the definition. We map the top-level position to indicate constantness --- immediately if `cont`, and later if not. */ - Scheme_Object *l, *a; - int pos; - - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - - /* Test for set!: */ - if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { - pos = SCHEME_TOPLEVEL_POS(a); - - if (cont) - fixed_table = set_as_fixed(fixed_table, info, pos); - else - next_pos_ready = pos; - } - } - } + int i, n = SCHEME_DEFN_VAR_COUNT(defn); + Scheme_IR_Toplevel *var; + + for (i = 0; i < n; i++) { + var = SCHEME_DEFN_VAR(defn, i); + + /* Test for set!: */ + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { + if (!info->top_level_consts + || !scheme_hash_get(info->top_level_consts, (Scheme_Object *)var)) { + fixed_table = set_as_fixed(fixed_table, info, var->variable_pos); + } + } + } + } } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL); + if (i_m + 1 == cnt) + cont = 0; + else + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL); } - if (i_m + 1 == cnt) - cont = 0; - } else + } else { cont = 1; + } - if (!cont) { + if (!cont || (i_m + 1 == cnt)) { Scheme_Object *prop_later = NULL; /* If we have new constants, re-optimize to inline: */ if (consts) { @@ -9034,14 +9273,14 @@ while (1) { /* Re-optimize this expression. */ - int old_sz, new_sz; + int old_sz, new_sz, orig_fuel; - e = SCHEME_VEC_ELS(m->bodies[0])[start_simultaneous]; + e = SCHEME_VEC_ELS(linklet->bodies)[start_simultaneous]; if (OPT_DELAY_GROUP_PROPAGATE || OPT_LIMIT_FUNCTION_RESIZE) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *sub_e; - sub_e = SCHEME_VEC_ELS(e)[1]; + sub_e = SCHEME_DEFN_RHS(e); old_sz = lambda_body_size(sub_e, 0); } else old_sz = 0; @@ -9049,8 +9288,10 @@ old_sz = 0; optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); - SCHEME_VEC_ELS(m->bodies[0])[start_simultaneous] = e; + orig_fuel = info->inline_fuel; + e = optimize_expr(e, info, 0); + info->inline_fuel = orig_fuel; + SCHEME_VEC_ELS(linklet->bodies)[start_simultaneous] = e; if (re_consts) { /* Install optimized closures into constant table --- @@ -9060,10 +9301,10 @@ if (rpos) { Scheme_Object *old_e; - e = SCHEME_VEC_ELS(e)[1]; + e = SCHEME_DEFN_RHS(e); old_e = scheme_hash_get(info->top_level_consts, rpos); - if (old_e && SCHEME_LAMBDAP(old_e) && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(1)) { + if (old_e && SCHEME_LAMBDAP(old_e) && OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(1)) { if (!originals) originals = scheme_make_hash_table(SCHEME_hash_ptr); scheme_hash_set(originals, scheme_make_integer(start_simultaneous), old_e); @@ -9120,9 +9361,26 @@ } } - if (next_pos_ready > -1) { - fixed_table = set_as_fixed(fixed_table, info, next_pos_ready); - next_pos_ready = -1; + if (!cont) { + /* Now that the definition is evaluated, its variables are + certainly fixed if they're not `set!`ed. */ + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int i, n = SCHEME_DEFN_VAR_COUNT(e); + Scheme_IR_Toplevel *var; + + for (i = 0; i < n; i++) { + var = SCHEME_DEFN_VAR(e, i); + + /* Test for set!: */ + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { + if (!info->top_level_consts + || !scheme_hash_get(info->top_level_consts, (Scheme_Object *)var)) { + fixed_table = set_as_fixed(fixed_table, info, var->variable_pos); + } + } + } + } } } @@ -9131,21 +9389,20 @@ if (info->enforce_const) { for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int size_override; - size_override = SCHEME_IMMUTABLEP(e); - vars = SCHEME_VEC_ELS(e)[0]; - if (SCHEME_PAIRP(vars) && SCHEME_NULLP(SCHEME_CDR(vars))) { + size_override = SCHEME_DEFN_ALWAYS_INLINEP(e); + if (SCHEME_DEFN_VAR_COUNT(e) == 1) { Scheme_Object *sub_e, *alt_e; - sub_e = SCHEME_VEC_ELS(e)[1]; - alt_e = is_cross_module_inline_candidiate(sub_e, info, 0); - if (!alt_e && originals && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override)) { + sub_e = SCHEME_DEFN_RHS(e); + alt_e = is_cross_linklet_inline_candidiate(sub_e, info, 0); + if (!alt_e && originals && OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(size_override)) { alt_e = scheme_hash_get(originals, scheme_make_integer(i_m)); if (SAME_OBJ(alt_e, sub_e) && !size_override) alt_e = NULL; else if (alt_e) - alt_e = is_cross_module_inline_candidiate(alt_e, info, size_override); + alt_e = is_cross_linklet_inline_candidiate(alt_e, info, size_override); } if (alt_e) { Scheme_Object *iv; @@ -9153,7 +9410,7 @@ iv->type = scheme_inline_variant_type; SCHEME_VEC_ELS(iv)[0] = sub_e; SCHEME_VEC_ELS(iv)[1] = alt_e; - SCHEME_VEC_ELS(e)[1] = iv; + SCHEME_DEFN_RHS(e) = iv; } } } @@ -9165,59 +9422,33 @@ int can_omit = 0; for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if ((i_m < (cnt - 1)) && scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { can_omit++; } } if (can_omit) { - Scheme_Object *vec; + Scheme_Object *new_bodies; int j = 0; - vec = scheme_make_vector(cnt - can_omit, NULL); + new_bodies = scheme_make_vector(cnt - can_omit, scheme_false); for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { - SCHEME_VEC_ELS(vec)[j++] = e; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if ((i_m == (cnt-1)) || !scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { + SCHEME_VEC_ELS(new_bodies)[j++] = e; } } - m->bodies[0] = vec; + linklet->bodies = new_bodies; } cnt -= can_omit; } - info->context = old_context; - info->cp = prev_cp; - - /* Exp-time body was optimized during compilation */ + /* Record shapes, if any, of imports as used for optimization; also + reflect import usage, so that the resolve pass can remove unused + imports */ + record_optimize_shapes(info, linklet, _import_keys); - { - /* optimize submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - optimize_info_seq_step(info, &info_seq); - scheme_optimize_expr(SCHEME_CAR(p), info, 0); - p = SCHEME_CDR(p); - } - } - } - } - - optimize_info_seq_done(info, &info_seq); - - info->escapes = 0; - - return data; -} - -static Scheme_Object * -top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return data; + return linklet; } /*========================================================================*/ @@ -9234,10 +9465,10 @@ p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_optimize_expr(expr, info, context); + return optimize_expr(expr, info, context); } -Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) +Scheme_Object *optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) { Scheme_Type type = SCHEME_TYPE(expr); @@ -9274,7 +9505,7 @@ val = optimize_info_propagate_local(expr); if (val) { info->size -= 1; - return scheme_optimize_expr(val, info, context); + return optimize_expr(val, info, context); } val = collapse_local(expr, info, context); @@ -9315,7 +9546,7 @@ o->moved = 1; - val = scheme_optimize_expr(o->expr, info, context); + val = optimize_expr(o->expr, info, context); if (info->maybe_values_argument) { /* Although `val` could be counted as taking 0 time, we advance @@ -9353,7 +9584,6 @@ case scheme_application3_type: return optimize_application3(expr, info, context); case scheme_sequence_type: - case scheme_splice_sequence_type: return optimize_sequence(expr, info, context, 1); case scheme_branch_type: return optimize_branch(expr, info, context); @@ -9368,19 +9598,35 @@ return optimize_lets(expr, info, context); case scheme_ir_toplevel_type: info->size += 1; - if (info->top_level_consts) { - int pos; + { Scheme_Object *c; while (1) { - pos = SCHEME_TOPLEVEL_POS(expr); - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + c = get_import_inline(info, (Scheme_IR_Toplevel *)expr, -1, 0); + if (!c) + c = get_defn_shape(info, (Scheme_IR_Toplevel *)expr); c = no_potential_size(c); if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_ir_toplevel_type)) expr = c; else break; } + + if (c) { + if (SAME_OBJ(c, scheme_constant_key)) { + /* can't copy, but constant across instantiations */ + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); + if (context & OPT_CONTEXT_BOOLEAN) + c = scheme_true; + else + c = NULL; + } else if (SAME_OBJ(c, scheme_fixed_key)) { + /* not constant across instantiations, but at least fixed */ + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_FIXED); + c = NULL; + } + } else + info->vclock += 1; if (c) { if (context & OPT_CONTEXT_BOOLEAN) @@ -9391,38 +9637,14 @@ /* We can't inline, but mark the top level as a constant, so we can direct-jump and avoid null checks in JITed code: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); - } else { - /* false is mapped to a table of non-constant ready values: */ - c = scheme_hash_get(info->top_level_consts, scheme_false); - if (c) { - c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos)); - - if (c) { - /* We can't inline, but mark the top level as ready and fixed, - so we can avoid null checks in JITed code, etc: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_FIXED); - } - } - if (!c) - info->vclock += 1; + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); } - } else { - info->vclock += 1; } optimize_info_used_top(info); - return expr; - case scheme_ir_quote_syntax_type: - if (context & OPT_CONTEXT_BOOLEAN) - return scheme_true; - else { - info->size += 1; - optimize_info_used_top(info); - } + register_import_used(info, (Scheme_IR_Toplevel *)expr); return expr; case scheme_variable_type: - case scheme_module_variable_type: - scheme_signal_error("got top-level in wrong place"); + scheme_signal_error("got toplevel in wrong place"); return 0; case scheme_define_values_type: return define_values_optimize(expr, info, context); @@ -9430,10 +9652,6 @@ return ref_optimize(expr, info, context); case scheme_set_bang_type: return set_optimize(expr, info, context); - case scheme_define_syntaxes_type: - return define_syntaxes_optimize(expr, info, context); - case scheme_begin_for_syntax_type: - return begin_for_syntax_optimize(expr, info, context); case scheme_case_lambda_sequence_type: if (context & OPT_CONTEXT_BOOLEAN) return scheme_true; @@ -9445,10 +9663,6 @@ return apply_values_optimize(expr, info, context); case scheme_with_immed_mark_type: return with_immed_mark_optimize(expr, info, context); - case scheme_require_form_type: - return top_level_require_optimize(expr, info, context); - case scheme_module_type: - return module_optimize(expr, info, context); default: info->size += 1; if ((context & OPT_CONTEXT_BOOLEAN) @@ -9484,7 +9698,7 @@ case scheme_ir_local_type: { Scheme_Object *v; - v = scheme_hash_tree_get(var_map, expr); + v = scheme_eq_hash_tree_get(var_map, expr); if (v) return v; else if (!single_use) @@ -9620,7 +9834,6 @@ } case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2; int i; @@ -9682,15 +9895,10 @@ case scheme_ir_lambda_type: return clone_lambda(single_use, expr, info, var_map); case scheme_ir_toplevel_type: - case scheme_ir_quote_syntax_type: return expr; case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: case scheme_boxenv_type: return NULL; - case scheme_require_form_type: - return NULL; case scheme_varref_form_type: return ref_clone(single_use, expr, info, var_map); case scheme_set_bang_type: @@ -9701,8 +9909,6 @@ return with_immed_mark_clone(single_use, expr, info, var_map); case scheme_case_lambda_sequence_type: return case_lambda_clone(single_use, expr, info, var_map); - case scheme_module_type: - return NULL; default: if (t > _scheme_ir_values_types_) { if (single_use || scheme_ir_duplicate_ok(expr, 0)) @@ -9717,7 +9923,8 @@ /* compile-time env for optimization */ /*========================================================================*/ -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger) +static Optimize_Info *optimize_info_allocate(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode) { Optimize_Info *info; @@ -9727,16 +9934,27 @@ #endif info->inline_fuel = INITIAL_INLINING_FUEL; info->flatten_fuel = INITIAL_FLATTENING_FUEL; - info->cp = cp; - info->env = env; - info->insp = insp; - - if (get_logger) { - Scheme_Logger *logger; - logger = (Scheme_Logger *)scheme_get_param(scheme_current_config(), MZCONFIG_LOGGER); - logger = scheme_make_logger(logger, scheme_intern_symbol("optimizer")); - info->logger = logger; - } + info->linklet = linklet; + + info->enforce_const = enforce_const; + if (!can_inline) + info->inline_fuel = -1; + info->unsafe_mode = unsafe_mode; + + return info; +} + +static Optimize_Info *optimize_info_create(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode) +{ + Optimize_Info *info; + Scheme_Logger *logger; + + info = optimize_info_allocate(linklet, enforce_const, can_inline, unsafe_mode); + + logger = (Scheme_Logger *)scheme_get_param(scheme_current_config(), MZCONFIG_LOGGER); + logger = scheme_make_logger(logger, scheme_intern_symbol("optimizer")); + info->logger = logger; return info; } @@ -9760,21 +9978,6 @@ info->flatten_fuel = info_seq->min_flatten_fuel; } -void scheme_optimize_info_enforce_const(Optimize_Info *oi, int enforce_const) -{ - oi->enforce_const = enforce_const; -} - -void scheme_optimize_info_set_context(Optimize_Info *oi, Scheme_Object *ctx) -{ - oi->context = ctx; -} - -void scheme_optimize_info_never_inline(Optimize_Info *oi) -{ - oi->inline_fuel = -1; -} - static void propagate_used_variables(Optimize_Info *info) { Scheme_Hash_Table *ht; @@ -9856,6 +10059,7 @@ Scheme_IR_Let_Value *irlv = at_irlv; while (n--) { + MZ_ASSERT(SAME_TYPE(irlv->iso.so.type, scheme_ir_let_value_type)); for (i = irlv->count; i--; ) { if (irlv->vars[i]->optimize_used) return 1; @@ -10001,7 +10205,7 @@ while (info) { if (info->types) { - pred = scheme_hash_tree_get(info->types, var); + pred = scheme_eq_hash_tree_get(info->types, var); if (pred) return pred; } @@ -10011,19 +10215,18 @@ return NULL; } -static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int flags) { Optimize_Info *naya; - naya = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); + naya = optimize_info_allocate(info->linklet, 0, 0, 0); naya->flags = (short)flags; naya->next = info; - naya->original_frame = orig; - naya->new_frame = current; naya->inline_fuel = info->inline_fuel; naya->flatten_fuel = info->flatten_fuel; naya->letrec_not_twice = info->letrec_not_twice; naya->enforce_const = info->enforce_const; + naya->unsafe_mode = info->unsafe_mode; naya->top_level_consts = info->top_level_consts; naya->context = info->context; naya->vclock = info->vclock; @@ -10039,6 +10242,8 @@ naya->lambda_depth = info->lambda_depth + ((flags & SCHEME_LAMBDA_FRAME) ? 1 : 0); naya->uses = info->uses; naya->transitive_use_var = info->transitive_use_var; + naya->cross = info->cross; + naya->imports_used = info->imports_used; return naya; } @@ -10059,6 +10264,611 @@ parent->has_nonleaf = 1; } + +/*========================================================================*/ +/* shapes from linklet imports */ +/*========================================================================*/ + +static int is_procedure_expression(Scheme_Object *e) +{ + Scheme_Type t; + + if (SCHEME_PROCP(e)) + return 1; + + t = SCHEME_TYPE(e); + + return ((t == scheme_lambda_type) + || (t == scheme_case_lambda_sequence_type)); +} + +static void linklet_setup_constants(Scheme_Linklet *linklet) +{ + int i, cnt, k, defns_start; + Scheme_Object *form, *tl; + Scheme_Hash_Table *ht; + + if (linklet->constants) + return; + + /* find constants: */ + ht = scheme_make_hash_table(SCHEME_hash_ptr); + linklet->constants = ht; + + defns_start = 1 + linklet->num_total_imports; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + form = SCHEME_VEC_ELS(linklet->bodies)[i]; + + if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { + int checked_st = 0, is_st_prop = 0, has_guard = 0; + Scheme_Object *is_st = NULL; + Simple_Struct_Type_Info stinfo; + Scheme_Object *parent_identity; + + for (k = SCHEME_DEFN_VAR_COUNT(form); k--; ) { + tl = (Scheme_Object *)SCHEME_DEFN_VAR(form, k); + if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { + int pos = SCHEME_TOPLEVEL_POS(tl) - defns_start; + + if (pos < linklet->num_exports) { + Scheme_Object *v; + + if (SCHEME_DEFN_VAR_COUNT(form) == 1) { + if (scheme_ir_duplicate_ok(SCHEME_DEFN_RHS(form), 1)) { + /* record simple constant for cross-linklet propagation: */ + v = SCHEME_DEFN_RHS(form); + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_DEFN_RHS(form)), scheme_inline_variant_type)) { + /* record a potentially inlineable function */ + v = SCHEME_DEFN_RHS(form); + } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { + /* record that it's a procedure: */ + v = scheme_make_vector(2, scheme_false); + SCHEME_VEC_ELS(v)[0] = SCHEME_DEFN_RHS(form); + } else { + /* record that it's fixed for any given instantiation: */ + v = scheme_fixed_key; + } + } else { + if (!checked_st) { + if (scheme_is_simple_make_struct_type(SCHEME_DEFN_RHS(form), + SCHEME_DEFN_VAR_COUNT(form), + CHECK_STRUCT_TYPE_RESOLVED, + NULL, &stinfo, &parent_identity, + NULL, NULL, NULL, 0, linklet, + &is_st, + 5)) { + is_st = scheme_make_pair(is_st, parent_identity); + } else { + is_st = NULL; + if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + CHECK_STRUCT_TYPE_RESOLVED, + &has_guard, + NULL, NULL, NULL, 0, linklet, + 5)) + is_st_prop = 1; + } + checked_st = 1; + } + if (is_st) { + intptr_t shape; + shape = scheme_get_struct_proc_shape(k, &stinfo); + /* Vector of size 3 => struct shape */ + v = scheme_make_vector(3, scheme_false); + SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + SCHEME_VEC_ELS(v)[2] = is_st; + } else if (is_st_prop) { + intptr_t shape; + shape = scheme_get_struct_property_proc_shape(k, has_guard); + /* Vector of size 4 => struct property shape */ + v = scheme_make_vector(4, scheme_false); + SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + } else + v = NULL; + } + if (v) + scheme_hash_set(ht, SCHEME_VEC_ELS(linklet->defns)[pos], v); + } + } + } + } + } +} + +static Scheme_Object *get_linklet_or_instance_for_import_key(Optimize_Info *info, Scheme_Object *key) +{ + Scheme_Object *v, *next_keys, *a[1]; + Cross_Linklet_Info *cross = info->cross; + Scheme_Hash_Tree *ht; + + if (!cross || !cross->get_import) + return NULL; + + v = scheme_eq_hash_tree_get(cross->linklets, key); + if (!v) { + a[0] = key; + v = scheme_apply_multi(cross->get_import, 1, a); + if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + && (scheme_current_thread->ku.multiple.count == 2)) { + v = scheme_current_thread->ku.multiple.array[0]; + next_keys = scheme_current_thread->ku.multiple.array[1]; + } else { + scheme_wrong_return_arity("compile-linklet", + 2, + (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + ? scheme_current_thread->ku.multiple.count + : 1), + (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + ? (Scheme_Object **)v + : scheme_current_thread->ku.multiple.array), + ""); + return NULL; + } + + ht = scheme_hash_tree_set(cross->linklets, key, v); + cross->linklets = ht; + + if (!SCHEME_FALSEP(v)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) + && !SAME_TYPE(SCHEME_TYPE(v), scheme_instance_type)) + scheme_wrong_contract("compile-linklet", "(or/c linklet? instance? #f)", -1, 0, &v); + + if (!SCHEME_FALSEP(next_keys) + && (!SCHEME_VECTORP(next_keys) + || !SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) + || SCHEME_VEC_SIZE(next_keys) != SCHEME_VEC_SIZE(((Scheme_Linklet *)v)->importss))) + scheme_contract_error("compile-linklet", + "result is not #f or a vector of keys that match the result linklet's import count", + (SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) ? "linklet" : "instance"), 1, v, + "import count", 1, scheme_make_integer(SCHEME_VEC_SIZE(((Scheme_Linklet *)v)->importss)), + "invalid as vector of keys", 1, next_keys, + NULL); + + if (SCHEME_TRUEP(next_keys)) { + ht = scheme_hash_tree_set(cross->import_next_keys, key, next_keys); + cross->import_next_keys = ht; + } + } + } + + if (SCHEME_FALSEP(v)) + return NULL; + + return v; +} + +static Scheme_Object *get_import_inline_or_shape(Optimize_Info *info, Scheme_IR_Toplevel *var, + int argc, int want_shape, int for_props) +/* Returns either a procedure shape, a value to inline, or (when `for_props`) + a function to be used just for its properties. The + special values scheme_constant_key and scheme_fixed_key may be + returned. If `argc` is less than 0, then scheme_constant_key is + returned for procedures. If `want_shape` or `argc` is less than 0 + and a non-NULL value is returned, then `info` records the fact that + shape information is used. */ +{ + Scheme_Object *key, *v, *name, *l_or_i; + Scheme_Hash_Table *iv_ht; + Scheme_Linklet *linklet; + + if (!info->cross || (var->instance_pos < 0)) + return NULL; + + key = scheme_eq_hash_tree_get(info->cross->import_keys, scheme_make_integer(var->instance_pos)); + if (!key) + return NULL; + + l_or_i = get_linklet_or_instance_for_import_key(info, key); + + if (!l_or_i) + return NULL; + + if ((var->instance_pos < SCHEME_VEC_SIZE(info->linklet->importss)) + && (var->variable_pos < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(info->linklet->importss)[var->instance_pos]))) + name = SCHEME_VEC_ELS(SCHEME_VEC_ELS(info->linklet->importss)[var->instance_pos])[var->variable_pos]; + else { + Scheme_Hash_Tree *ht; + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(info->cross->import_syms, + scheme_make_integer(var->instance_pos)); + MZ_ASSERT(ht); + name = scheme_eq_hash_tree_get(ht, scheme_make_integer(var->variable_pos)); + } + MZ_ASSERT(name); + MZ_ASSERT(SCHEME_SYMBOLP(name)); + + if (SAME_TYPE(SCHEME_TYPE(l_or_i), scheme_linklet_type)) { + linklet = (Scheme_Linklet *)l_or_i; + + if (!linklet->constants) + linklet_setup_constants(linklet); + + if (!want_shape && !for_props && (argc >= 0)) { + /* check for previously unresolved for this linklet: */ + iv_ht = (Scheme_Hash_Table *)scheme_eq_hash_tree_get(info->cross->inline_variants, key); + if (iv_ht) { + v = scheme_hash_get(iv_ht, name); + if (v) { + /* We have previously unresolved to `v` */ + if (SCHEME_HASHTP(v)) { + /* It's a `case-lambda`, so try to get the right clause */ + v = scheme_hash_get((Scheme_Hash_Table *)v, scheme_make_integer(argc)); + if (v) + return v; + /* Try to unresolve the right arity */ + } else if (SCHEME_FALSEP(v)) { + /* previous unresove attempt failed */ + return NULL; + } else + return v; + } + } + /* Otherwise, not yet unresolved (maybe because it doesn't need to be) */ + } else + iv_ht = NULL; + + v = scheme_hash_get(linklet->constants, name); + + if (!v) + return NULL; + + if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 2)) { + /* a procedure */ + if (want_shape) + v = scheme_get_or_check_procedure_shape(SCHEME_VEC_ELS(v)[0], NULL, 0); + else if (for_props) + return SCHEME_VEC_ELS(v)[0]; + else if (argc < 0) + v = scheme_constant_key; + else + v = NULL; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_inline_variant_type)) { + /* a procedure that can be inlined (if unresolve succeeds) */ + if (for_props) { + return SCHEME_VEC_ELS(v)[0]; + } else if (want_shape) { + v = scheme_get_or_check_procedure_shape(v, NULL, 0); + if (v) + info->cross->used_import_shape = 1; + } else if (argc >= 0) { + int has_cases = 0; + + v = scheme_unresolve(v, argc, &has_cases, linklet, key, info); + + if (!iv_ht) { + Scheme_Hash_Tree *ht; + iv_ht = scheme_make_hash_table(SCHEME_hash_ptr); + ht = scheme_hash_tree_set(info->cross->inline_variants, key, (Scheme_Object *)iv_ht); + info->cross->inline_variants = ht; + } + + /* Save unresolved */ + if (has_cases) { + Scheme_Hash_Table *cl_ht; + cl_ht = (Scheme_Hash_Table *)scheme_hash_get(iv_ht, name); + if (!cl_ht) { + cl_ht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(iv_ht, name, (Scheme_Object *)cl_ht); + } + scheme_hash_set(cl_ht, scheme_make_integer(argc), v); + } else if (v) + scheme_hash_set(iv_ht, name, v); + else + scheme_hash_set(iv_ht, name, scheme_false); /* record that it won't work */ + } else + v = scheme_constant_key; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { + if (want_shape) + v = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1]), + SCHEME_VEC_ELS(v)[2]); + else if ((argc < 0) || for_props) + v = scheme_constant_key; + else + v = NULL; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) { + if (want_shape) + v = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + else if ((argc < 0) || for_props) + v = scheme_constant_key; + else + v = NULL; + } + } else { + Scheme_Bucket *b; + int imprecise = SCHEME_INSTANCE_FLAGS((Scheme_Instance *)l_or_i) & SCHEME_INSTANCE_USE_IMPRECISE; + b = scheme_instance_variable_bucket_or_null(name, (Scheme_Instance *)l_or_i); + if (b && b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + v = b->val; + if (want_shape) + v = get_value_shape(v, imprecise); + else if (argc < 0) + v = scheme_constant_key; + else + v = NULL; + } else + v = NULL; + } + + if (v && (want_shape || (argc < 0))) + info->cross->used_import_shape = 1; + + return v; +} + +Scheme_Object *scheme_optimize_add_import_variable(Optimize_Info *info, Scheme_Object *linklet_key, Scheme_Object *symbol) +/* Called from unresolver (for cross-linklet inlining) to find or add + an imported variable from an existing instance import */ +{ + Scheme_Object *pos, *var_pos, *vec; + Scheme_Hash_Tree *syms, *ht; + int i; + + if (SCHEME_FALSEP(linklet_key)) + return NULL; + + pos = scheme_eq_hash_tree_get(info->cross->rev_import_keys, linklet_key); + MZ_ASSERT(pos); + + syms = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(info->cross->import_syms, pos); + if (!syms) { + syms = empty_eq_hash_tree; + if (SCHEME_INT_VAL(pos) < SCHEME_VEC_SIZE(info->linklet->importss)) { + /* initialize from the linklet that we're optimizing */ + vec = SCHEME_VEC_ELS(info->linklet->importss)[SCHEME_INT_VAL(pos)]; + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + syms = scheme_hash_tree_set(syms, SCHEME_VEC_ELS(vec)[i], scheme_make_integer(i)); + syms = scheme_hash_tree_set(syms, scheme_make_integer(i), SCHEME_VEC_ELS(vec)[i]); + } + } else { + /* must not have imported anything, yet, so the empty table is correct */ + } + ht = scheme_hash_tree_set(info->cross->import_syms, pos, (Scheme_Object *)syms); + info->cross->import_syms = ht; + } + + var_pos = scheme_eq_hash_tree_get(syms, symbol); + if (!var_pos) { + var_pos = scheme_make_integer(syms->count >> 1); + syms = scheme_hash_tree_set(syms, symbol, var_pos); + syms = scheme_hash_tree_set(syms, var_pos, symbol); + ht = scheme_hash_tree_set(info->cross->import_syms, pos, (Scheme_Object *)syms); + info->cross->import_syms = ht; + } + + /* SCHEME_TOPLEVEL_READY is conservative; optimizer can compute a refinement later */ + return (Scheme_Object *)scheme_make_ir_toplevel(SCHEME_INT_VAL(pos), SCHEME_INT_VAL(var_pos), SCHEME_TOPLEVEL_READY); +} + +Scheme_Object *scheme_optimize_get_import_key(Optimize_Info *info, Scheme_Object *linklet_key, int instance_pos) +/* Called from unresolver (for cross-linklet inlining) to find or add + an imported instance */ +{ + Scheme_Object *next_keys, *key, *pos; + Scheme_Hash_Tree *ht; + + next_keys = scheme_eq_hash_tree_get(info->cross->import_next_keys, linklet_key); + if (!next_keys) { + /* chaining is not supported by the compilation client */ + return NULL; + } + + MZ_ASSERT(instance_pos < SCHEME_VEC_SIZE(next_keys)); + + key = SCHEME_VEC_ELS(next_keys)[instance_pos]; + pos = scheme_eq_hash_tree_get(info->cross->rev_import_keys, key); + if (!pos) { + /* Add this linklet as an import */ + pos = scheme_make_integer(info->cross->import_keys->count); + + ht = scheme_hash_tree_set(info->cross->import_keys, pos, key); + info->cross->import_keys = ht; + + ht = scheme_hash_tree_set(info->cross->rev_import_keys, key, pos); + info->cross->rev_import_keys = ht; + } + + return key; +} + +static Scheme_Object *get_import_shape(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + return get_import_inline_or_shape(info, var, -1, 1, 0); +} + +static Scheme_Object *get_import_inline(Optimize_Info *info, Scheme_IR_Toplevel *var, int argc, int for_props) +/* argc < 0 => scheme_constant_key for non-copyable procedures */ +{ + return get_import_inline_or_shape(info, var, argc, 0, for_props); +} + +static void register_import_used(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + if ((var->instance_pos >= 0) && info->imports_used) { + /* Record that the import is used. The resolve pass can + drop references that have been optimized away. */ + Scheme_Hash_Tree *ht; + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(*info->imports_used, scheme_make_integer(var->instance_pos)); + if (!ht) + ht = empty_eq_hash_tree; + if (!scheme_eq_hash_tree_get(ht, scheme_make_integer(var->variable_pos))) { + ht = scheme_hash_tree_set(ht, scheme_make_integer(var->variable_pos), scheme_true); + ht = scheme_hash_tree_set(*info->imports_used, scheme_make_integer(var->instance_pos), (Scheme_Object *)ht); + (*info->imports_used) = ht; + } + } +} + +static void record_optimize_shapes(Optimize_Info *info, Scheme_Linklet *linklet, Scheme_Object **_import_keys) +{ + int i, j, k, used, total, added_imports = 0, dropped_imports = 0, total_used; + Scheme_Object *shapes, *v, *name; + Scheme_Linklet *in_linklet; + Scheme_Instance *in_instance; + Scheme_Hash_Tree *ht; + Scheme_Bucket *b; + + if (info->cross) { + /* Add new imported instances */ + if (info->cross->import_keys->count > SCHEME_VEC_SIZE(linklet->importss)) { + added_imports = SCHEME_VEC_SIZE(linklet->importss) - info->cross->import_keys->count; + v = scheme_make_vector(info->cross->import_keys->count, scheme_make_vector(0, NULL)); + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + SCHEME_VEC_ELS(v)[i] = SCHEME_VEC_ELS(linklet->importss)[i]; + } + linklet->importss = v; + } + + /* Add imported variables for each instance */ + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(info->cross->import_syms, scheme_make_integer(i)); + if (ht && ((ht->count >> 1) > SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]))) { + Scheme_Object *sym; + v = scheme_make_vector((ht->count >> 1), NULL); + SCHEME_VEC_ELS(linklet->importss)[i] = v; + + for (j = ht->count >> 1; j--; ) { + sym = scheme_eq_hash_tree_get(ht, scheme_make_integer(j)); + MZ_ASSERT(sym); + SCHEME_VEC_ELS(v)[j] = sym; + } + } + } + } + + /* Prune unused imports (or, more precisely, tell the resolver how to prune) */ + total_used = 0; + total = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + used = 0; + k = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); + total += k; + if (info->imports_used) { + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(*info->imports_used, scheme_make_integer(i)); + if (!ht) ht = empty_eq_hash_tree; + for (j = 0; j < k; j++) { + if (!scheme_eq_hash_tree_get(ht, scheme_make_integer(j))) { + /* Set symbol to #f to communicate non-use to the resolve pass: */ + SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j] = scheme_false; + } else + used++; + } + } else + used += k; + total_used += used; + if (!used && _import_keys + /* When a key is #f or an instance, then dropping is not allowed */ + && ((i >= SCHEME_VEC_SIZE(*_import_keys)) + || (SCHEME_TRUEP(SCHEME_VEC_ELS(*_import_keys)[i]) + && !SAME_TYPE(scheme_instance_type, SCHEME_TYPE(SCHEME_VEC_ELS(*_import_keys)[i]))))) { + dropped_imports++; + /* A number commuicates to the resolve pass that the import + instance had that many variables, but we can drop it + entirely */ + SCHEME_VEC_ELS(linklet->importss)[i] = scheme_make_integer(k); + } + } + linklet->num_total_imports = total; + + if (dropped_imports || added_imports) { + /* Report a revised set of imports back to the client */ + v = scheme_make_vector(SCHEME_VEC_SIZE(linklet->importss) - dropped_imports, NULL); + *_import_keys = v; + used = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + v = scheme_eq_hash_tree_get(info->cross->import_keys, scheme_make_integer(i)); + MZ_ASSERT(v); + SCHEME_VEC_ELS((*_import_keys))[used++] = v; + } + } + MZ_ASSERT(used == (SCHEME_VEC_SIZE(linklet->importss) - dropped_imports)); + } + + if (info->cross && info->cross->used_import_shape) { + /* The import-shapes vector needs only the imports that will be kept */ + shapes = scheme_make_vector(total_used, scheme_false); + linklet->import_shapes = shapes; + k = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + v = scheme_eq_hash_tree_get(info->cross->import_keys, scheme_make_integer(i)); + if (v) + v = scheme_eq_hash_tree_get(info->cross->linklets, v); + in_linklet = ((v && SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type)) ? (Scheme_Linklet *)v : NULL); + in_instance = ((v && SAME_TYPE(SCHEME_TYPE(v), scheme_instance_type)) ? (Scheme_Instance *)v : NULL); + MZ_ASSERT(!in_linklet || SAME_TYPE(in_linklet->so.type, scheme_linklet_type)); + MZ_ASSERT(!in_instance || SAME_TYPE(in_instance->iso.so.type, scheme_instance_type)); + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++) { + name = SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j]; + if (SCHEME_TRUEP(name)) { + if (in_linklet && in_linklet->constants) { + v = scheme_hash_get(in_linklet->constants, name); + if (v) { + if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { + v = scheme_intern_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) { + v = scheme_intern_struct_prop_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SCHEME_VECTORP(v)) { + MZ_ASSERT(SCHEME_VEC_SIZE(v) == 2); + v = scheme_get_or_check_procedure_shape(SCHEME_VEC_ELS(v)[0], NULL, 0); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_inline_variant_type)) { + v = scheme_get_or_check_procedure_shape(v, NULL, 0); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SAME_OBJ(v, scheme_fixed_key)) { + SCHEME_VEC_ELS(shapes)[k] = scheme_void; + } else { + /* anything else is constant-propagated or irrelevant */ + } + } + } else if (in_instance) { + b = scheme_instance_variable_bucket_or_null(name, in_instance); + if (b && b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + int imprecise = SCHEME_INSTANCE_FLAGS(in_instance) & SCHEME_INSTANCE_USE_IMPRECISE; + v = get_value_shape(b->val, imprecise); + if (v) { + if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) + v = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(v)); + else if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_prop_proc_shape_type)) + v = scheme_intern_struct_prop_proc_shape(SCHEME_PROP_PROC_SHAPE_MODE(v)); + SCHEME_VEC_ELS(shapes)[k] = v; + } else + SCHEME_VEC_ELS(shapes)[k] = scheme_void; + } + } + k++; + } + } + } + } + MZ_ASSERT(k == total_used); + } +} + +static Scheme_Object *get_value_shape(Scheme_Object *v, int imprecise) +{ + intptr_t s; + Scheme_Object *identity; + + s = scheme_get_or_check_structure_shape(v, NULL); + if (s != -1) { + if (SCHEME_STRUCT_TYPEP(v)) + identity = v; + else + identity = SCHEME_PRIM_CLOSURE_ELS(v)[0]; + return scheme_make_struct_proc_shape(s, identity); + } + + s = scheme_get_or_check_structure_property_shape(v, NULL); + if (s != -1) + return scheme_make_struct_property_proc_shape(s); + + return scheme_get_or_check_procedure_shape(v, NULL, imprecise); +} + /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/racket/src/place.c racket-7.0+ppa1/src/racket/src/place.c --- racket-6.12+ppa1/src/racket/src/place.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/place.c 2018-07-27 22:12:02.000000000 +0000 @@ -88,9 +88,11 @@ # define mzPDC_DIRECT_UNCOPY 3 # define mzPDC_DESER 4 # define mzPDC_CLEAN 5 + +static Scheme_Object *strip_chaperones(Scheme_Object *so); #endif -static void places_prepare_direct(Scheme_Object *so); +static Scheme_Object *places_prepare_direct(Scheme_Object *so); static void log_place_event(const char *what, const char *tag, int has_amount, intptr_t amount); # ifdef MZ_PRECISE_GC @@ -100,13 +102,13 @@ static void *place_start_proc(void *arg); MZ_DO_NOT_INLINE(static void *place_start_proc_after_stack(void *data_arg, void *stack_base)); -# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) +# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) ADD_PRIM_W_ARITY(name, func, a1, a2, env) #else SHARED_OK static int scheme_places_enabled = 0; -# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, not_implemented, a1, a2, env) +# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) ADD_PRIM_W_ARITY(name, not_implemented, a1, a2, env) static Scheme_Object *not_implemented(int argc, Scheme_Object **argv) { @@ -124,39 +126,35 @@ /* initialization */ /*========================================================================*/ -void scheme_init_place(Scheme_Env *env) +void scheme_init_place(Scheme_Startup_Env *env) { - Scheme_Env *plenv; - #ifdef MZ_PRECISE_GC register_traversers(); #endif - - plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env); - GLOBAL_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, plenv); - GLOBAL_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, plenv); - PLACE_PRIM_W_ARITY("dynamic-place", scheme_place, 5, 5, plenv); - PLACE_PRIM_W_ARITY("place-pumper-threads", place_pumper_threads, 1, 2, plenv); - PLACE_PRIM_W_ARITY("place-sleep", place_sleep, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-wait", place_wait, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-kill", place_kill, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-break", place_break, 1, 2, plenv); - PLACE_PRIM_W_ARITY("place?", place_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-channel", place_channel, 0, 0, plenv); - PLACE_PRIM_W_ARITY("place-channel-put", place_send, 2, 2, plenv); - PLACE_PRIM_W_ARITY("place-channel-get", place_receive, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-channel?", place_channel_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-message-allowed?", place_allowed_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-dead-evt", make_place_dead, 1, 1, plenv); - - scheme_finish_primitive_module(plenv); - - /* Treat place creation as "unsafe", since the new place starts with - permissive guards that can access unsafe features that affect - existing places. */ - scheme_protect_primitive_provide(plenv, scheme_intern_symbol("dynamic-place")); + scheme_switch_prim_instance(env, "#%place"); + + ADD_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, env); + ADD_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, env); + PLACE_PRIM_W_ARITY("dynamic-place", scheme_place, 5, 5, env); + PLACE_PRIM_W_ARITY("place-pumper-threads", place_pumper_threads, 1, 2, env); + PLACE_PRIM_W_ARITY("place-sleep", place_sleep, 1, 1, env); + PLACE_PRIM_W_ARITY("place-wait", place_wait, 1, 1, env); + PLACE_PRIM_W_ARITY("place-kill", place_kill, 1, 1, env); + PLACE_PRIM_W_ARITY("place-break", place_break, 1, 2, env); + PLACE_PRIM_W_ARITY("place?", place_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-channel", place_channel, 0, 0, env); + PLACE_PRIM_W_ARITY("place-channel-put", place_send, 2, 2, env); + PLACE_PRIM_W_ARITY("place-channel-get", place_receive, 1, 1, env); + PLACE_PRIM_W_ARITY("place-channel?", place_channel_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-message-allowed?", place_allowed_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-dead-evt", make_place_dead, 1, 1, env); + scheme_restore_prim_instance(env); +} + +void scheme_init_place_per_place() +{ #ifdef MZ_USE_PLACES REGISTER_SO(all_child_places); @@ -264,6 +262,12 @@ } } +static int is_predefined_module_path(Scheme_Object *v) +{ + /* Every table of primitives should have a corresponding predefined module */ + return !!scheme_hash_get(scheme_startup_env->primitive_tables, v); +} + Scheme_Object *place_pumper_threads(int argc, Scheme_Object *args[]) { Scheme_Place *place; Scheme_Object *tmp; @@ -343,7 +347,7 @@ out_arg = args[3]; err_arg = args[4]; - if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0]) && !SCHEME_MODNAMEP(args[0])) { + if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0]) && !scheme_is_resolved_module_path(args[0])) { scheme_wrong_contract("dynamic-place", "(or/c module-path? path? resolved-module-path?)", 0, argc, args); } if (!SCHEME_SYMBOLP(args[1])) { @@ -361,7 +365,7 @@ if (SCHEME_PAIRP(args[0]) && SAME_OBJ(SCHEME_CAR(args[0]), quote_symbol) - && !scheme_is_predefined_module_p(args[0])) { + && !is_predefined_module_path(args[0])) { scheme_contract_error("dynamic-place", "not a filesystem or predefined module-path", "module path", 1, args[0], NULL); @@ -483,13 +487,22 @@ place_data->err = rw[5]; } } - - places_prepare_direct(place_data->current_library_collection_paths); - places_prepare_direct(place_data->current_library_collection_links); - places_prepare_direct(place_data->compiled_roots); - places_prepare_direct(place_data->channel); - places_prepare_direct(place_data->module); - places_prepare_direct(place_data->function); + + { + Scheme_Object *tmp; + tmp = places_prepare_direct(place_data->current_library_collection_paths); + place_data->current_library_collection_paths = tmp; + tmp = places_prepare_direct(place_data->current_library_collection_links); + place_data->current_library_collection_links = tmp; + tmp = places_prepare_direct(place_data->compiled_roots); + place_data->compiled_roots = tmp; + tmp = places_prepare_direct(place_data->channel); + place_data->channel = tmp; + tmp = places_prepare_direct(place_data->module); + place_data->module = tmp; + tmp = places_prepare_direct(place_data->function); + place_data->function = tmp; + } /* create new place */ proc_thread = mz_proc_thread_create(place_start_proc, place_data); @@ -773,8 +786,10 @@ #endif } -static void places_prepare_direct(Scheme_Object *so) { +static Scheme_Object *places_prepare_direct(Scheme_Object *so) { + so = strip_chaperones(so); (void)do_places_deep_copy(so, mzPDC_CHECK, 1, NULL, NULL); + return so; } static Scheme_Object *places_deep_direct_uncopy(Scheme_Object *so) { @@ -1929,6 +1944,79 @@ } +static Scheme_Object *strip_chaperones_k(void); + +/* Recognizes the same shapes as places_deep_copy_worker, but also + allows chaperones and impersonators. The result is an + impersonator-free copy of `so`. */ +static Scheme_Object *strip_chaperones(Scheme_Object *so) +{ + Scheme_Object *o; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)so; + return scheme_handle_stack_overflow(strip_chaperones_k); + } + } +#endif + + if (SCHEME_CHAPERONEP(so)) + o = SCHEME_CHAPERONE_VAL(so); + else + o = so; + + if (SCHEME_PAIRP(o)) { + return scheme_make_pair(strip_chaperones(SCHEME_CAR(o)), + strip_chaperones(SCHEME_CDR(o))); + } else if (SCHEME_VECTORP(o)) { + Scheme_Object *v, *e; + intptr_t len = SCHEME_VEC_SIZE(o), i; + v = scheme_make_vector(len, NULL); + for (i = 0; i < len; i++) { + if (SAME_OBJ(o, so)) + e = SCHEME_VEC_ELS(so)[i]; + else + e = scheme_chaperone_vector_ref(so, i); + e = strip_chaperones(e); + SCHEME_VEC_ELS(v)[i] = e; + } + return v; + } else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o)) { + return scheme_chaperone_hash_table_filtered_copy(so, strip_chaperones); + } else if (SCHEME_STRUCTP(o)) { + Scheme_Structure *s = (Scheme_Structure *)(o), *s2; + Scheme_Object *e; + intptr_t i, len = s->stype->num_slots; + if (!s->stype->prefab_key) + return NULL; + s2 = (Scheme_Structure *)scheme_make_blank_prefab_struct_instance(s->stype); + for (i = 0; i < len; i++) { + if (SAME_OBJ(o, so)) + e = s->slots[i]; + else + e = scheme_struct_ref(so, i); + e = strip_chaperones(e); + s2->slots[i] = e; + } + return (Scheme_Object *)s2; + } else + return so; +} + +static Scheme_Object *strip_chaperones_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *so = (Scheme_Object *)p->ku.k.p1; + + p->ku.k.p1 = NULL; + + return strip_chaperones(so); +} + #if 0 /* unused code, may be useful when/if we revive shared symbol and prefab key tables */ Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base, @@ -2358,13 +2446,10 @@ saved_error_buf = p->error_buf; p->error_buf = &new_error_buf; if (!scheme_setjmp(new_error_buf)) { - Scheme_Object *dynamic_require; - if (!scheme_rktio) scheme_signal_error("place: I/O manager initialization failed"); - dynamic_require = scheme_builtin_value("dynamic-require"); - place_main = scheme_apply(dynamic_require, 2, a); + place_main = scheme_dynamic_require(2, a); a[0] = channel; (void)scheme_apply(place_main, 1, a); rc = scheme_make_integer(0); @@ -2394,10 +2479,21 @@ new_so = trivial_copy(so, NULL); if (new_so) return new_so; - GC_create_message_allocator(); - new_so = do_places_deep_copy(so, mzPDC_COPY, 0, master_chain, invalid_object); - tmp = GC_finish_message_allocator(); - (*msg_memory) = tmp; + while (1) { + GC_create_message_allocator(); + new_so = do_places_deep_copy(so, mzPDC_COPY, 0, master_chain, invalid_object); + tmp = GC_finish_message_allocator(); + (*msg_memory) = tmp; + + if (!new_so && SCHEME_CHAPERONEP(*invalid_object)) { + /* try again after removing chaperones */ + so = strip_chaperones(so); + if (!so) + break; + } else + break; + } + return new_so; #else return so; @@ -2478,11 +2574,20 @@ static Scheme_Object* place_allowed_p(int argc, Scheme_Object *args[]) { Scheme_Hash_Table *ht = NULL; - - if (places_deep_copy_worker(args[0], &ht, mzPDC_CHECK, 1, 0, NULL, NULL)) + Scheme_Object *v, *invalid_object = NULL; + + v = args[0]; + + if (places_deep_copy_worker(v, &ht, mzPDC_CHECK, 1, 0, NULL, &invalid_object)) return scheme_true; - else + else { + if (invalid_object && SCHEME_CHAPERONEP(invalid_object)) { + v = strip_chaperones(v); + if (v && places_deep_copy_worker(v, &ht, mzPDC_CHECK, 1, 0, NULL, NULL)) + return scheme_true; + } return scheme_false; + } } # ifdef MZ_PRECISE_GC diff -Nru racket-6.12+ppa1/src/racket/src/port.c racket-7.0+ppa1/src/racket/src/port.c --- racket-6.12+ppa1/src/racket/src/port.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/port.c 2018-07-27 22:12:02.000000000 +0000 @@ -296,7 +296,7 @@ /*========================================================================*/ void -scheme_init_port (Scheme_Env *env) +scheme_init_port (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -385,17 +385,17 @@ scheme_null_output_port_type = scheme_make_port_type(""); scheme_redirect_output_port_type = scheme_make_port_type(""); - scheme_add_global_constant("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env); - scheme_add_global_constant("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env); - scheme_add_global_constant("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env); - scheme_add_global_constant("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env); - scheme_add_global_constant("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env); - scheme_add_global_constant("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env); + scheme_addto_prim_instance("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env); + scheme_addto_prim_instance("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env); + scheme_addto_prim_instance("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env); + scheme_addto_prim_instance("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env); + scheme_addto_prim_instance("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env); + scheme_addto_prim_instance("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env); - GLOBAL_PARAMETER("subprocess-group-enabled", subproc_group_on, MZCONFIG_SUBPROC_GROUP_ENABLED, env); - GLOBAL_PARAMETER("current-subprocess-custodian-mode", current_subproc_cust_mode, MZCONFIG_SUBPROC_CUSTODIAN_MODE, env); + ADD_PARAMETER("subprocess-group-enabled", subproc_group_on, MZCONFIG_SUBPROC_GROUP_ENABLED, env); + ADD_PARAMETER("current-subprocess-custodian-mode", current_subproc_cust_mode, MZCONFIG_SUBPROC_CUSTODIAN_MODE, env); - scheme_add_global_constant("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env); + scheme_addto_prim_instance("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env); } void scheme_init_port_wait() @@ -410,15 +410,15 @@ filesystem_change_evt_need_wakeup, NULL, 1); } -void scheme_init_unsafe_port (Scheme_Env *env) +void scheme_init_unsafe_port (Scheme_Startup_Env *env) { - GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->port", unsafe_fd_to_port, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-port->file-descriptor", unsafe_port_to_fd, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->semaphore", unsafe_fd_to_semaphore, 2, 2, env); - - GLOBAL_PRIM_W_ARITY("unsafe-socket->port", unsafe_socket_to_port, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-port->socket", unsafe_port_to_socket, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-socket->semaphore", unsafe_socket_to_semaphore, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-file-descriptor->port", unsafe_fd_to_port, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-port->file-descriptor", unsafe_port_to_fd, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-file-descriptor->semaphore", unsafe_fd_to_semaphore, 2, 2, env); + + ADD_PRIM_W_ARITY("unsafe-socket->port", unsafe_socket_to_port, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-port->socket", unsafe_port_to_socket, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-socket->semaphore", unsafe_socket_to_semaphore, 2, 2, env); } void scheme_init_port_places(void) @@ -1306,11 +1306,13 @@ } else if (v == SCHEME_SPECIAL) { ip->special = NULL; scheme_bad_time_for_special(who, port); - } else if (v == skip) { + } else if (v > 0) { peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(skip)); /* Ok... ready to continue (if skip == peek_skip) */ - } else + } else { + /* This shouldn't happen, but just in case */ return 0; + } } if (size) { @@ -2670,7 +2672,6 @@ int cnt; Scheme_Object *a[4], *special; Scheme_Input_Port *ip; - Scheme_Cont_Frame_Data cframe; SCHEME_USE_FUEL(1); @@ -2696,8 +2697,6 @@ if (peek) { /* do location increment, since read didn't */ - if (line > 0) - line++; if (col >= 0) col++; if (pos > 0) @@ -2715,13 +2714,8 @@ a[3] = (pos > 0) ? scheme_make_integer(pos) : scheme_false; } - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(src, for_read); - special = scheme_apply(special, cnt, a); - scheme_pop_continuation_frame(&cframe); - return special; } @@ -2738,11 +2732,7 @@ stxsrc = ip->name; } - /* Don't use scheme_tell_all(), because we always want the - Racket-computed values here. */ - line = scheme_tell_line(port); - col = scheme_tell_column(port); - pos = scheme_tell(port); + scheme_tell_all(port, &line, &col, &pos); return scheme_get_special(port, stxsrc, line, col, pos, peek, ht); } @@ -2769,7 +2759,6 @@ static Scheme_Object *check_special_args(void *sbox, int argc, Scheme_Object **argv) { Scheme_Object *special; - Scheme_Cont_Frame_Data cframe; if (SCHEME_TRUEP(argv[1])) if (!scheme_nonneg_exact_p(argv[1]) || (SAME_OBJ(argv[1], scheme_make_integer(0)))) @@ -2787,13 +2776,8 @@ "read-special: cannot be called a second time"); *(Scheme_Object **)sbox = NULL; - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(NULL, NULL); - special = _scheme_apply(special, 4, argv); - scheme_pop_continuation_frame(&cframe); - return special; } @@ -3656,12 +3640,27 @@ return is_fd_terminal(fd) ? scheme_true : scheme_false; } +static void maybe_raise_missing_module(char *name, char *filename, char *pre, char *rel, char *post, char *errstr) +{ + Scheme_Object *proc, *a[6]; + + proc = scheme_get_startup_export("maybe-raise-missing-module"); + + a[0] = scheme_make_utf8_string(name); + a[1] = scheme_make_utf8_string(filename); + a[2] = scheme_make_utf8_string(pre); + a[3] = scheme_make_utf8_string(rel); + a[4] = scheme_make_utf8_string(post); + a[5] = scheme_make_utf8_string(errstr); + + scheme_apply_multi(proc, 6, a); +} + static void filename_exn(char *name, char *msg, char *filename, int maybe_module_errno) { char *dir, *drive; int len; char *pre, *rel, *post; - Scheme_Object *mod_path, *mp; len = strlen(filename); @@ -3681,38 +3680,20 @@ post = dir ? "" : ""; if (maybe_module_errno && scheme_last_error_is_racket(maybe_module_errno)) { - mod_path = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_LOAD_PATH); - if (SCHEME_TRUEP(mod_path)) { - if (SCHEME_STXP(mod_path)) { - char *srcloc; - intptr_t srcloc_len; - mp = scheme_syntax_to_datum(mod_path, 0, NULL); - srcloc = scheme_make_srcloc_string(mod_path, &srcloc_len); - scheme_raise_exn(MZEXN_FAIL_SYNTAX_MISSING_MODULE, - scheme_make_pair(mod_path, scheme_null), - mp, - "%t%s: %s\n" - " module path: %W\n" - " path: %q%s%q%s\n" - " system error: %R", - srcloc, srcloc_len, - srcloc_len ? "" : name, - "cannot open module file", - mp, filename, - pre, rel, post); - } else { - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, - mod_path, - "%s: %s\n" - " module path: %W\n" - " path: %q%s%q%s\n" - " system error: %R", - name, "cannot open module file", - mod_path, filename, - pre, rel, post); - } - return; - } + char buffer[256]; + int errkind, errid; + + scheme_sprintf(buffer, sizeof(buffer)-1, "%R"); + buffer[sizeof(buffer)-1] = 0; + + /* Save errors, in case we don't raise missing-module */ + errkind = rktio_get_last_error_kind(scheme_rktio); + errid = rktio_get_last_error(scheme_rktio); + + maybe_raise_missing_module(name, filename, pre, rel, post, buffer); + + /* Restore error, which might have been changed by a scheduler action */ + rktio_set_last_error(scheme_rktio, errkind, errid); } scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, diff -Nru racket-6.12+ppa1/src/racket/src/portfun.c racket-7.0+ppa1/src/racket/src/portfun.c --- racket-6.12+ppa1/src/racket/src/portfun.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/portfun.c 2018-07-27 22:12:02.000000000 +0000 @@ -47,11 +47,6 @@ static Scheme_Object *call_with_input_file (int, Scheme_Object *[]); static Scheme_Object *with_input_from_file (int, Scheme_Object *[]); static Scheme_Object *with_output_to_file (int, Scheme_Object *[]); -static Scheme_Object *read_f (int, Scheme_Object *[]); -static Scheme_Object *read_recur_f (int, Scheme_Object *[]); -static Scheme_Object *read_syntax_f (int, Scheme_Object *[]); -static Scheme_Object *read_syntax_recur_f (int, Scheme_Object *[]); -static Scheme_Object *read_language (int, Scheme_Object *[]); static Scheme_Object *read_char (int, Scheme_Object *[]); static Scheme_Object *read_char_spec (int, Scheme_Object *[]); static Scheme_Object *read_byte (int, Scheme_Object *[]); @@ -99,15 +94,11 @@ static Scheme_Object *newline (int, Scheme_Object *[]); static Scheme_Object *write_char (int, Scheme_Object *[]); static Scheme_Object *write_byte (int, Scheme_Object *[]); -static Scheme_Object *load (int, Scheme_Object *[]); -static Scheme_Object *current_load (int, Scheme_Object *[]); -static Scheme_Object *current_load_use_compiled (int, Scheme_Object *[]); static Scheme_Object *current_load_directory(int argc, Scheme_Object *argv[]); static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]); #ifdef LOAD_ON_DEMAND static Scheme_Object *load_on_demand_enabled(int argc, Scheme_Object *argv[]); #endif -static Scheme_Object *default_load (int, Scheme_Object *[]); static Scheme_Object *flush_output (int, Scheme_Object *[]); static Scheme_Object *open_input_char_string (int, Scheme_Object *[]); static Scheme_Object *open_input_byte_string (int, Scheme_Object *[]); @@ -152,6 +143,7 @@ ROSYM static Scheme_Object *crlf_symbol; ROSYM static Scheme_Object *module_symbol; ROSYM static Scheme_Object *string_symbol; +ROSYM static Scheme_Object *special_symbol; READ_ONLY static Scheme_Object *default_read_handler; READ_ONLY static Scheme_Object *default_display_handler; @@ -168,6 +160,15 @@ SHARED_OK Scheme_Object *initial_compiled_file_paths; SHARED_OK Scheme_Object *initial_compiled_file_roots; +SHARED_OK static int compiled_file_check = SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS; +ROSYM static Scheme_Object *initial_compiled_file_check_symbol; + +SHARED_OK int scheme_ignore_user_paths; +void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; } + +SHARED_OK int scheme_ignore_link_paths; +void scheme_set_ignore_link_paths(int v) { scheme_ignore_link_paths = v; } + THREAD_LOCAL_DECL(static Scheme_Object *dummy_input_port); THREAD_LOCAL_DECL(static Scheme_Object *dummy_output_port); @@ -178,7 +179,7 @@ /*========================================================================*/ void -scheme_init_port_fun(Scheme_Env *env) +scheme_init_port_fun(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -200,6 +201,7 @@ REGISTER_SO(crlf_symbol); REGISTER_SO(module_symbol); REGISTER_SO(string_symbol); + REGISTER_SO(special_symbol); any_symbol = scheme_intern_symbol("any"); any_one_symbol = scheme_intern_symbol("any-one"); @@ -208,6 +210,7 @@ crlf_symbol = scheme_intern_symbol("return-linefeed"); module_symbol = scheme_intern_symbol("module"); string_symbol = scheme_intern_symbol("string"); + special_symbol = scheme_intern_symbol("special"); scheme_write_proc = scheme_make_noncm_prim(sch_write, "write", 1, 2); scheme_display_proc = scheme_make_noncm_prim(display, "display", 1, 2); @@ -220,161 +223,146 @@ default_write_handler = scheme_make_prim_w_arity(sch_default_write_handler, "default-port-write-handler", 2, 2); default_print_handler = scheme_make_prim_w_arity(sch_default_print_handler, "default-port-print-handler", 2, 3); - scheme_add_global_constant("eof", scheme_eof, env); + scheme_addto_prim_instance("eof", scheme_eof, env); - GLOBAL_PARAMETER("current-input-port", current_input_port, MZCONFIG_INPUT_PORT, env); - GLOBAL_PARAMETER("current-output-port", current_output_port, MZCONFIG_OUTPUT_PORT, env); - GLOBAL_PARAMETER("current-error-port", current_error_port, MZCONFIG_ERROR_PORT, env); - GLOBAL_PARAMETER("current-load", current_load, MZCONFIG_LOAD_HANDLER, env); - GLOBAL_PARAMETER("current-load/use-compiled", current_load_use_compiled, MZCONFIG_LOAD_COMPILED_HANDLER, env); - GLOBAL_PARAMETER("current-load-relative-directory", current_load_directory, MZCONFIG_LOAD_DIRECTORY, env); - GLOBAL_PARAMETER("current-write-relative-directory", current_write_directory, MZCONFIG_WRITE_DIRECTORY, env); - GLOBAL_PARAMETER("global-port-print-handler", global_port_print_handler, MZCONFIG_PORT_PRINT_HANDLER, env); + ADD_PARAMETER("current-input-port", current_input_port, MZCONFIG_INPUT_PORT, env); + ADD_PARAMETER("current-output-port", current_output_port, MZCONFIG_OUTPUT_PORT, env); + ADD_PARAMETER("current-error-port", current_error_port, MZCONFIG_ERROR_PORT, env); + ADD_PARAMETER("current-load-relative-directory", current_load_directory, MZCONFIG_LOAD_DIRECTORY, env); + ADD_PARAMETER("current-write-relative-directory", current_write_directory, MZCONFIG_WRITE_DIRECTORY, env); + ADD_PARAMETER("global-port-print-handler", global_port_print_handler, MZCONFIG_PORT_PRINT_HANDLER, env); #ifdef LOAD_ON_DEMAND - GLOBAL_PARAMETER("load-on-demand-enabled", load_on_demand_enabled, MZCONFIG_LOAD_DELAY_ENABLED, env); + ADD_PARAMETER("load-on-demand-enabled", load_on_demand_enabled, MZCONFIG_LOAD_DELAY_ENABLED, env); #endif - GLOBAL_PARAMETER("port-count-lines-enabled", global_port_count_lines, MZCONFIG_PORT_COUNT_LINES, env); + ADD_PARAMETER("port-count-lines-enabled", global_port_count_lines, MZCONFIG_PORT_COUNT_LINES, env); - GLOBAL_FOLDING_PRIM("input-port?", input_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("output-port?", output_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("file-stream-port?", scheme_file_stream_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("string-port?", string_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("terminal-port?", scheme_terminal_port_p, 1, 1, 1, env); - - GLOBAL_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env); - GLOBAL_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env); - GLOBAL_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env); - GLOBAL_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env); - GLOBAL_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env); - GLOBAL_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env); - GLOBAL_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env); - GLOBAL_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env); - GLOBAL_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env); - GLOBAL_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env); - GLOBAL_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env); - GLOBAL_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env); - GLOBAL_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env); - GLOBAL_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env); + ADD_FOLDING_PRIM("input-port?", input_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("output-port?", output_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("file-stream-port?", scheme_file_stream_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("string-port?", string_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("terminal-port?", scheme_terminal_port_p, 1, 1, 1, env); + + ADD_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env); + ADD_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env); + ADD_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env); + ADD_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env); + ADD_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env); + ADD_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env); + ADD_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env); + ADD_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env); + ADD_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env); + ADD_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env); + ADD_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env); + ADD_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env); + ADD_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env); + ADD_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env); - GLOBAL_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 4, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("load", load, 1, 1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); - GLOBAL_NONCM_PRIM("set-port-next-location!", set_port_next_location, 4, 4, env); - - GLOBAL_PRIM_W_ARITY("filesystem-change-evt", filesystem_change_evt, 1, 2, env); - GLOBAL_NONCM_PRIM("filesystem-change-evt?", filesystem_change_evt_p, 1, 1, env); - GLOBAL_NONCM_PRIM("filesystem-change-evt-cancel", filesystem_change_evt_cancel, 1, 1, env); - - GLOBAL_NONCM_PRIM("read", read_f, 0, 1, env); - GLOBAL_NONCM_PRIM("read/recursive", read_recur_f, 0, 4, env); - GLOBAL_NONCM_PRIM("read-syntax", read_syntax_f, 0, 2, env); - GLOBAL_NONCM_PRIM("read-syntax/recursive", read_syntax_recur_f, 0, 5, env); - GLOBAL_PRIM_W_ARITY2("read-language", read_language, 0, 2, 0, -1, env); - GLOBAL_NONCM_PRIM("read-char", read_char, 0, 1, env); - GLOBAL_PRIM_W_ARITY2("read-char-or-special", read_char_spec, 0, 3, 0, -1, env); - GLOBAL_NONCM_PRIM("read-byte", read_byte, 0, 1, env); - GLOBAL_PRIM_W_ARITY2("read-byte-or-special", read_byte_spec, 0, 3, 0, -1, env); - GLOBAL_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env); - GLOBAL_NONCM_PRIM("read-line", read_line, 0, 2, env); - GLOBAL_NONCM_PRIM("read-string", sch_read_string, 1, 2, env); - GLOBAL_NONCM_PRIM("read-string!", sch_read_string_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-string", sch_peek_string, 2, 3, env); - GLOBAL_NONCM_PRIM("peek-string!", sch_peek_string_bang, 2, 5, env); - GLOBAL_NONCM_PRIM("read-bytes", sch_read_bytes, 1, 2, env); - GLOBAL_NONCM_PRIM("read-bytes!", sch_read_bytes_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-bytes", sch_peek_bytes, 2, 3, env); - GLOBAL_NONCM_PRIM("peek-bytes!", sch_peek_bytes_bang, 2, 5, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!", read_bytes_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!*", read_bytes_bang_nonblock, 1, 4, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!/enable-break", read_bytes_bang_break, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!", peek_bytes_bang, 2, 6, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!*", peek_bytes_bang_nonblock, 2, 6, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!/enable-break", peek_bytes_bang_break, 2, 6, env); - GLOBAL_NONCM_PRIM("port-provides-progress-evts?", can_provide_progress_evt, 1, 1, env); - GLOBAL_NONCM_PRIM("write-bytes", write_bytes, 1, 4, env); - GLOBAL_NONCM_PRIM("write-string", write_string, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail", write_bytes_avail, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail*", write_bytes_avail_nonblock, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail/enable-break", write_bytes_avail_break, 1, 4, env); - GLOBAL_NONCM_PRIM("port-writes-atomic?", can_write_atomic, 1, 1, env); - GLOBAL_NONCM_PRIM("port-writes-special?", can_write_special, 1, 1, env); - GLOBAL_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env); - GLOBAL_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env); - GLOBAL_NONCM_PRIM("peek-char", peek_char, 0, 2, env); - GLOBAL_PRIM_W_ARITY2("peek-char-or-special", peek_char_spec, 0, 4, 0, -1, env); - GLOBAL_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env); - GLOBAL_PRIM_W_ARITY2("peek-byte-or-special", peek_byte_spec, 0, 5, 0, -1, env); - GLOBAL_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env); - GLOBAL_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env); - GLOBAL_NONCM_PRIM("newline", newline, 0, 1, env); - GLOBAL_NONCM_PRIM("write-char", write_char, 1, 2, env); - GLOBAL_NONCM_PRIM("write-byte", write_byte, 1, 2, env); - GLOBAL_NONCM_PRIM("port-commit-peeked", peeked_read, 3, 4, env); - GLOBAL_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, env); - GLOBAL_NONCM_PRIM("progress-evt?", is_progress_evt, 1, 2, env); - GLOBAL_NONCM_PRIM("port-closed-evt", closed_evt, 0, 1, env); - GLOBAL_NONCM_PRIM("write-bytes-avail-evt", write_bytes_avail_evt, 1, 4, env); - GLOBAL_NONCM_PRIM("write-special-evt", write_special_evt, 2, 2, env); - GLOBAL_NONCM_PRIM("port-read-handler", port_read_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-display-handler", port_display_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-print-handler", port_print_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("flush-output", flush_output, 0, 1, env); - GLOBAL_NONCM_PRIM("file-position", scheme_file_position, 1, 2, env); - GLOBAL_NONCM_PRIM("file-position*", scheme_file_position_star, 1, 1, env); - GLOBAL_NONCM_PRIM("file-truncate", scheme_file_truncate, 2, 2, env); - GLOBAL_NONCM_PRIM("file-stream-buffer-mode", scheme_file_buffer, 1, 2, env); - GLOBAL_NONCM_PRIM("port-try-file-lock?", scheme_file_try_lock, 2, 2, env); - GLOBAL_NONCM_PRIM("port-file-unlock", scheme_file_unlock, 1, 1, env); - GLOBAL_NONCM_PRIM("port-file-identity", scheme_file_identity, 1, 1, env); - GLOBAL_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env); - GLOBAL_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 1, 1, env); + ADD_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env); + ADD_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); + ADD_NONCM_PRIM("set-port-next-location!", set_port_next_location, 4, 4, env); + + ADD_PRIM_W_ARITY("filesystem-change-evt", filesystem_change_evt, 1, 2, env); + ADD_NONCM_PRIM("filesystem-change-evt?", filesystem_change_evt_p, 1, 1, env); + ADD_NONCM_PRIM("filesystem-change-evt-cancel", filesystem_change_evt_cancel, 1, 1, env); + + ADD_NONCM_PRIM("read-char", read_char, 0, 1, env); + ADD_PRIM_W_ARITY2("read-char-or-special", read_char_spec, 0, 3, 0, -1, env); + ADD_NONCM_PRIM("read-byte", read_byte, 0, 1, env); + ADD_PRIM_W_ARITY2("read-byte-or-special", read_byte_spec, 0, 3, 0, -1, env); + ADD_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env); + ADD_NONCM_PRIM("read-line", read_line, 0, 2, env); + ADD_NONCM_PRIM("read-string", sch_read_string, 1, 2, env); + ADD_NONCM_PRIM("read-string!", sch_read_string_bang, 1, 4, env); + ADD_NONCM_PRIM("peek-string", sch_peek_string, 2, 3, env); + ADD_NONCM_PRIM("peek-string!", sch_peek_string_bang, 2, 5, env); + ADD_NONCM_PRIM("read-bytes", sch_read_bytes, 1, 2, env); + ADD_NONCM_PRIM("read-bytes!", sch_read_bytes_bang, 1, 4, env); + ADD_NONCM_PRIM("peek-bytes", sch_peek_bytes, 2, 3, env); + ADD_NONCM_PRIM("peek-bytes!", sch_peek_bytes_bang, 2, 5, env); + ADD_NONCM_PRIM("read-bytes-avail!", read_bytes_bang, 1, 4, env); + ADD_NONCM_PRIM("read-bytes-avail!*", read_bytes_bang_nonblock, 1, 4, env); + ADD_NONCM_PRIM("read-bytes-avail!/enable-break", read_bytes_bang_break, 1, 4, env); + ADD_NONCM_PRIM("peek-bytes-avail!", peek_bytes_bang, 2, 6, env); + ADD_NONCM_PRIM("peek-bytes-avail!*", peek_bytes_bang_nonblock, 2, 6, env); + ADD_NONCM_PRIM("peek-bytes-avail!/enable-break", peek_bytes_bang_break, 2, 6, env); + ADD_NONCM_PRIM("port-provides-progress-evts?", can_provide_progress_evt, 1, 1, env); + ADD_NONCM_PRIM("write-bytes", write_bytes, 1, 4, env); + ADD_NONCM_PRIM("write-string", write_string, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail", write_bytes_avail, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail*", write_bytes_avail_nonblock, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail/enable-break", write_bytes_avail_break, 1, 4, env); + ADD_NONCM_PRIM("port-writes-atomic?", can_write_atomic, 1, 1, env); + ADD_NONCM_PRIM("port-writes-special?", can_write_special, 1, 1, env); + ADD_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env); + ADD_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env); + ADD_NONCM_PRIM("peek-char", peek_char, 0, 2, env); + ADD_PRIM_W_ARITY2("peek-char-or-special", peek_char_spec, 0, 4, 0, -1, env); + ADD_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env); + ADD_PRIM_W_ARITY2("peek-byte-or-special", peek_byte_spec, 0, 5, 0, -1, env); + ADD_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env); + ADD_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env); + ADD_NONCM_PRIM("newline", newline, 0, 1, env); + ADD_NONCM_PRIM("write-char", write_char, 1, 2, env); + ADD_NONCM_PRIM("write-byte", write_byte, 1, 2, env); + ADD_NONCM_PRIM("port-commit-peeked", peeked_read, 3, 4, env); + ADD_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, env); + ADD_NONCM_PRIM("progress-evt?", is_progress_evt, 1, 2, env); + ADD_NONCM_PRIM("port-closed-evt", closed_evt, 0, 1, env); + ADD_NONCM_PRIM("write-bytes-avail-evt", write_bytes_avail_evt, 1, 4, env); + ADD_NONCM_PRIM("write-special-evt", write_special_evt, 2, 2, env); + ADD_NONCM_PRIM("port-read-handler", port_read_handler, 1, 2, env); + ADD_NONCM_PRIM("port-display-handler", port_display_handler, 1, 2, env); + ADD_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env); + ADD_NONCM_PRIM("port-print-handler", port_print_handler, 1, 2, env); + ADD_NONCM_PRIM("flush-output", flush_output, 0, 1, env); + ADD_NONCM_PRIM("file-position", scheme_file_position, 1, 2, env); + ADD_NONCM_PRIM("file-position*", scheme_file_position_star, 1, 1, env); + ADD_NONCM_PRIM("file-truncate", scheme_file_truncate, 2, 2, env); + ADD_NONCM_PRIM("file-stream-buffer-mode", scheme_file_buffer, 1, 2, env); + ADD_NONCM_PRIM("port-try-file-lock?", scheme_file_try_lock, 2, 2, env); + ADD_NONCM_PRIM("port-file-unlock", scheme_file_unlock, 1, 1, env); + ADD_NONCM_PRIM("port-file-identity", scheme_file_identity, 1, 1, env); + ADD_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env); + ADD_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 1, 1, env); REGISTER_SO(scheme_eof_object_p_proc); scheme_eof_object_p_proc = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_eof_object_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("eof-object?", scheme_eof_object_p_proc, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("eof-object?", scheme_eof_object_p_proc, env); + + scheme_addto_prim_instance("write", scheme_write_proc, env); + scheme_addto_prim_instance("display", scheme_display_proc, env); + scheme_addto_prim_instance("print", scheme_print_proc, env); - scheme_add_global_constant("write", scheme_write_proc, env); - scheme_add_global_constant("display", scheme_display_proc, env); - scheme_add_global_constant("print", scheme_print_proc, env); - - GLOBAL_IMMED_PRIM("pipe-content-length", pipe_length, 1, 1, env); + ADD_IMMED_PRIM("pipe-content-length", pipe_length, 1, 1, env); REGISTER_SO(scheme_default_global_print_handler); scheme_default_global_print_handler = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 3); } +void scheme_init_param_symbol() +{ + REGISTER_SO(initial_compiled_file_check_symbol); + if (compiled_file_check == SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS) + initial_compiled_file_check_symbol = scheme_intern_symbol("modify-seconds"); + else + initial_compiled_file_check_symbol = scheme_intern_symbol("exists"); +} void scheme_init_port_fun_config(void) { scheme_set_root_param(MZCONFIG_LOAD_DIRECTORY, scheme_false); scheme_set_root_param(MZCONFIG_WRITE_DIRECTORY, scheme_false); - if (initial_compiled_file_paths) - scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, initial_compiled_file_paths); - else - scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, scheme_make_pair(scheme_make_path("compiled"), scheme_null)); - if (initial_compiled_file_roots) - scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, initial_compiled_file_roots); - else - scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, scheme_make_pair(scheme_intern_symbol("same"), scheme_null)); - scheme_set_root_param(MZCONFIG_USE_USER_PATHS, (scheme_ignore_user_paths ? scheme_false : scheme_true)); - scheme_set_root_param(MZCONFIG_USE_LINK_PATHS, (scheme_ignore_link_paths ? scheme_false : scheme_true)); - - { - Scheme_Object *dlh; - dlh = scheme_make_prim_w_arity2(default_load, "default-load-handler", 2, 2, 0, -1); - scheme_set_root_param(MZCONFIG_LOAD_HANDLER, dlh); - } scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler); - + /* Use dummy port: */ REGISTER_SO(dummy_input_port); REGISTER_SO(dummy_output_port); @@ -382,6 +370,63 @@ dummy_output_port = scheme_make_null_output_port(1); } +static void set_param(const char *name, Scheme_Object *val) +{ + Scheme_Object *param, *a[1]; + param = scheme_get_startup_export(name); + a[0] = val; + (void)_scheme_apply_multi(param, 1, a); +} + +static Scheme_Object *get_param(const char *name) +{ + Scheme_Object *param; + param = scheme_get_startup_export(name); + return _scheme_apply(param, 0, NULL); +} + +void scheme_init_resolver_config(void) +{ + set_param("use-compiled-file-check", initial_compiled_file_check_symbol); + if (initial_compiled_file_paths) + set_param("use-compiled-file-paths", initial_compiled_file_paths); + else + set_param("use-compiled-file-paths", scheme_make_pair(scheme_make_path("compiled"), scheme_null)); + if (initial_compiled_file_roots) + set_param("current-compiled-file-roots", initial_compiled_file_roots); + else + set_param("current-compiled-file-roots", scheme_make_pair(scheme_intern_symbol("same"), scheme_null)); + set_param("use-user-specific-search-paths", (scheme_ignore_user_paths ? scheme_false : scheme_true)); + set_param("use-collection-link-paths", (scheme_ignore_link_paths ? scheme_false : scheme_true)); +} + +Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-library-collection-paths", argv[0]); + return scheme_void; + } else + return get_param("current-library-collection-paths"); +} + +Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-library-collection-links", argv[0]); + return scheme_void; + } else + return get_param("current-library-collection-links"); +} + +Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-compiled-file-roots", argv[0]); + return scheme_void; + } else + return get_param("current-compiled-file-roots"); +} + void scheme_set_compiled_file_paths(Scheme_Object *list) { if (!initial_compiled_file_paths) @@ -396,6 +441,11 @@ initial_compiled_file_roots = list; } +void scheme_set_compiled_file_check(int c) +{ + compiled_file_check = c; +} + /*========================================================================*/ /* port records */ /*========================================================================*/ @@ -2876,162 +2926,10 @@ else src = NULL; - return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); -} - -static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, - Scheme_Object **_readtable, int *_recur_graph) -{ - int pre_char = -1; - - if (argc > delta + 1) { - if (SCHEME_TRUEP(argv[delta + 1])) { - if (!SCHEME_CHARP(argv[delta + 1])) - scheme_wrong_contract(who, "(or/c char? #f)", delta + 1, argc, argv); - pre_char = SCHEME_CHAR_VAL(argv[delta + 1]); - } - if (argc > delta + 2) { - Scheme_Object *readtable; - readtable = argv[delta + 2]; - if (SCHEME_TRUEP(readtable) && !SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(readtable))) { - scheme_wrong_contract(who, "(or/c readtable? #f)", delta + 2, argc, argv); - } - *_readtable = readtable; - if (argc > delta + 3) { - *_recur_graph = SCHEME_TRUEP(argv[delta + 3]); - } - } - } - - return pre_char; -} - -static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *port, *readtable = NULL; - int pre_char = -1, recur_graph = recur; - Scheme_Input_Port *ip; - - if (argc && !SCHEME_INPUT_PORTP(argv[0])) - scheme_wrong_contract(who, "input-port?", 0, argc, argv); - - if (argc) - port = argv[0]; + if (src) + return scheme_read_syntax(argv[0], src); else - port = CURRENT_INPUT_PORT(scheme_current_config()); - - if (recur) { - pre_char = extract_recur_args(who, argc, argv, 0, &readtable, &recur_graph); - } - - ip = scheme_input_port_record(port); - - if (ip->read_handler && !recur) { - Scheme_Object *o[1]; - o[0] = port; - return _scheme_apply(ip->read_handler, 1, o); - } else { - if (port == scheme_orig_stdin_port) - scheme_flush_orig_outputs(); - - return scheme_internal_read(port, NULL, -1, 0, - recur_graph, recur, - pre_char, readtable, - NULL, NULL, NULL); - } -} - -static Scheme_Object *read_f(int argc, Scheme_Object *argv[]) -{ - return do_read_f("read", argc, argv, 0); -} - -static Scheme_Object *read_recur_f(int argc, Scheme_Object *argv[]) -{ - return do_read_f("read/recursive", argc, argv, 1); -} - -static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *port, *readtable = NULL; - int pre_char = -1, recur_graph = recur; - Scheme_Input_Port *ip; - - if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1])) - scheme_wrong_contract(who, "input-port?", 1, argc, argv); - - if (argc > 1) - port = argv[1]; - else - port = CURRENT_INPUT_PORT(scheme_current_config()); - - if (recur) { - pre_char = extract_recur_args(who, argc, argv, 1, &readtable, &recur_graph); - } - - ip = scheme_input_port_record(port); - - if (ip->read_handler && !recur) { - Scheme_Object *o[2], *result; - o[0] = port; - o[1] = (argc ? argv[0] : ip->name); - - result = _scheme_apply(ip->read_handler, 2, o); - if (SCHEME_STXP(result) || SCHEME_EOFP(result)) - return result; - else { - o[0] = result; - /* -1 for argument count indicates "result" */ - scheme_wrong_contract("read handler for read-syntax", "syntax?", 0, -1, o); - return NULL; - } - } else { - Scheme_Object *src; - - src = (argc ? argv[0] : ip->name); - - if (port == scheme_orig_stdin_port) - scheme_flush_orig_outputs(); - - return scheme_internal_read(port, src, -1, 0, - recur, recur_graph, - pre_char, readtable, - NULL, NULL, NULL); - } -} - -static Scheme_Object *read_syntax_f(int argc, Scheme_Object *argv[]) -{ - return do_read_syntax_f("read-syntax", argc, argv, 0); -} - -static Scheme_Object *read_syntax_recur_f(int argc, Scheme_Object *argv[]) -{ - return do_read_syntax_f("read-syntax/recursive", argc, argv, 1); -} - -static Scheme_Object *read_language(int argc, Scheme_Object **argv) -{ - Scheme_Object *port, *v, *fail_thunk = NULL; - - if (argc > 0) { - port = argv[0]; - if (!SCHEME_INPUT_PORTP(port)) - scheme_wrong_contract("read-language", "input-port?", 0, argc, argv); - if (argc > 1) { - scheme_check_proc_arity("read-language", 0, 1, argc, argv); - fail_thunk = argv[1]; - } - } else { - port = CURRENT_INPUT_PORT(scheme_current_config()); - } - - v = scheme_read_language(port, !!fail_thunk); - - if (SCHEME_VOIDP(v)) - return _scheme_tail_apply(fail_thunk, 0, NULL); - - return v; + return scheme_read(argv[0]); } static Scheme_Object * @@ -3087,17 +2985,24 @@ spec_wrap = argv[pos]; if (SCHEME_FALSEP(spec_wrap)) spec_wrap = NULL; - else if (!scheme_fast_check_arity(spec_wrap, 1)) - scheme_check_proc_arity2(name, 1, pos, argc, argv, 1); + else if (!(peek && SAME_OBJ(spec_wrap, special_symbol)) + && !scheme_fast_check_arity(spec_wrap, 1)) { + if (!scheme_check_proc_arity2(NULL, 1, pos, argc, argv, 1)) { + scheme_wrong_contract(name, + (peek + ? "(or/c (any/c -> any/c) #f 'special)" + : "(or/c (any/c -> any/c) #f)"), + pos, argc, argv); + return NULL; + } + } pos++; - if (argc > pos) { + if (argc > pos) src = argv[pos++]; - if (SCHEME_FALSEP(src)) - src = NULL; - } else - src = NULL; + else + src = scheme_false; } else { - src = NULL; + src = scheme_false; spec_wrap = NULL; } @@ -3128,6 +3033,8 @@ } if (ch == SCHEME_SPECIAL) { + if (SAME_OBJ(spec_wrap, special_symbol)) + return special_symbol; src = scheme_get_ready_special(port, src, peek); if (spec_wrap) { Scheme_Object *a[1]; @@ -4490,555 +4397,6 @@ return scheme_void; } -static intptr_t get_number(Scheme_Object *port, intptr_t pos) -{ - unsigned char buffer[4]; - intptr_t got, orig; - - orig = scheme_set_file_position(port, -1); - scheme_set_file_position(port, pos); - - got = scheme_get_byte_string("default-load-handler", - port, - (char *)buffer, 0, 4, - 0, 0, scheme_make_integer(0)); - - (void)scheme_set_file_position(port, orig); - - if (got != 4) - return 0; - - return (buffer[0] | (buffer[1] << 8) | (buffer[2] << 16) | (buffer[3] << 24)); -} - -static char *get_bytes(Scheme_Object *port, intptr_t pos, intptr_t len) -{ - char *s; - intptr_t orig; - - s = scheme_malloc_atomic(len + 1); - s[len] = 0; - - orig = scheme_set_file_position(port, -1); - scheme_set_file_position(port, pos); - - scheme_get_byte_string("default-load-handler", - port, - (char *)s, 0, len, - 0, 0, scheme_make_integer(0)); - - (void)scheme_set_file_position(port, orig); - - return s; -} - -typedef struct { - MZTAG_IF_REQUIRED - Scheme_Config *config; - Scheme_Object *port; - Scheme_Thread *p; - Scheme_Object *stxsrc; - Scheme_Object *expected_module; -} LoadHandlerData; - -static void post_load_handler(void *data) -{ - LoadHandlerData *lhd = (LoadHandlerData *)data; - - scheme_close_input_port((Scheme_Object *)lhd->port); -} - -static Scheme_Object *do_load_handler(void *data) -{ - LoadHandlerData *lhd = (LoadHandlerData *)data; - Scheme_Object *port = lhd->port; - Scheme_Thread *p = lhd->p; - Scheme_Config *config = lhd->config; - Scheme_Object *last_val = scheme_void, *obj, **save_array = NULL, *modname; - Scheme_Env *genv; - int save_count = 0, got_one = 0, as_module, check_module_name = 0, skip_no_more_check = 0; - - modname = lhd->expected_module; - - if (SCHEME_TRUEP(modname)) { - /* Look for a module directory: */ - intptr_t got; - int vers_size, dir_header_size; -# define DIR_HEADER_SIZE (3 + 20 + 16) - char buffer[DIR_HEADER_SIZE]; - - vers_size = strlen(MZSCHEME_VERSION); - dir_header_size = 4 + vers_size; - if (dir_header_size >= DIR_HEADER_SIZE) - scheme_signal_error("internal error: buffer size mismatch"); - got = scheme_get_byte_string("default-load-handler", - port, - buffer, 0, dir_header_size, - 0, 1, scheme_make_integer(0)); - - if ((got == dir_header_size) - && (buffer[0] == '#') - && (buffer[1] == '~') - && (buffer[2] == vers_size) - && (!scheme_strncmp(buffer + 3, MZSCHEME_VERSION, vers_size)) - && (buffer[3 + vers_size] == 'D')) { - /* File starts with a directory. The directory is a balanced binary search tree, - where each node has the shape - - and a 0 position for or means no child. */ - char *find_name, *s; - intptr_t namelen, i, name_size, pos, offset = 0, rellen; - - if (SCHEME_PAIRP(modname)) - find_name = scheme_submodule_path_to_string(SCHEME_CDR(modname), &namelen); - else { - find_name = ""; - namelen = 0; - } - - pos = dir_header_size + 4 /* skip total-module count */; - - while (pos) { - name_size = get_number(port, pos); - s = get_bytes(port, pos + 4, name_size); - if ((name_size == namelen) && !strncmp(find_name, s, name_size)) { - /* found it */ - offset = get_number(port, pos + 4 + name_size); - break; - } - /* try left or right? */ - rellen = namelen; - for (i = 0; (i < rellen) && (i < name_size); i++) { - if (find_name[i] != s[i]) { - if (((unsigned char *)find_name)[i] < ((unsigned char *)s)[i]) - rellen = 0; - else - rellen = name_size + 1; - break; - } - } - if (rellen < name_size) - pos = get_number(port, pos + 12 + name_size); - else - pos = get_number(port, pos + 16 + name_size); - } - - if (offset) { - scheme_set_file_position(port, offset); - if (!SCHEME_SYMBOLP(modname)) - modname = SCHEME_CAR(SCHEME_CDR(modname)); - skip_no_more_check = 1; - } else if (SCHEME_PAIRP(modname)) { - /* don't complain if a submodule isn't found */ - return scheme_void; - } - } - } - - if (SCHEME_PAIRP(modname)) { - modname = SCHEME_CAR(modname); - - if (SCHEME_FALSEP(modname)) { - /* caller says the main module is already loaded, - so don't reload for submodules */ - return scheme_void; - } - } - - if (scheme_module_code_cache && SCHEME_TRUEP(modname)) { - intptr_t got; - int vers_size, hash_header_size; -# define HASH_HEADER_SIZE (4 + 20 + 16) - char buffer[HASH_HEADER_SIZE]; - - vers_size = strlen(MZSCHEME_VERSION); - hash_header_size = 4 + vers_size + 20; - if (hash_header_size >= HASH_HEADER_SIZE) - scheme_signal_error("internal error: buffer size mismatch"); - got = scheme_get_byte_string("default-load-handler", - port, - buffer, 0, hash_header_size, - 0, 1, scheme_make_integer(0)); - - obj = NULL; - if ((got == hash_header_size) - && (buffer[0] == '#') - && (buffer[1] == '~') - && (buffer[2] == vers_size) - && (!scheme_strncmp(buffer + 3, MZSCHEME_VERSION, vers_size)) - && (buffer[3 + vers_size] == 'T')) { - int i; - for (i = 0; i < 20; i++) { - if (buffer[4 + vers_size + i]) - break; - } - if (i < 20) { - obj = scheme_make_sized_byte_string(buffer + 4 + vers_size, 20, 1); - } - } - - - if (obj) { - Scheme_Object *dir; - dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY); - if (SCHEME_TRUEP(dir)) - dir = scheme_path_to_directory_path(dir); - obj = scheme_make_pair(obj, dir); - obj = scheme_lookup_in_table(scheme_module_code_cache, (const char *)obj); - if (obj) - obj = scheme_ephemeron_value(obj); - if (obj) { - /* Synthesize a wrapper to pass through `eval': */ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->code = obj; - top->prefix = NULL; /* indicates a wrapper */ - - obj = (Scheme_Object *)top; - - return _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, &obj); - } - } - } - - while ((obj = scheme_internal_read(port, lhd->stxsrc, -1, 0, 0, 0, -1, NULL, - NULL, NULL, NULL)) - && !SCHEME_EOFP(obj)) { - save_array = NULL; - got_one = 1; - - /* ... begin special support for module loading ... */ - - genv = scheme_get_env(config); - as_module = 0; - - if (SCHEME_SYMBOLP(modname)) { - /* Must be of the form `(module ...)',possibly compiled. */ - /* Also, file should have no more expressions. */ - Scheme_Object *a, *d, *other = NULL; - Scheme_Module *m; - - d = obj; - - m = scheme_extract_compiled_module(SCHEME_STX_VAL(d)); - if (m) { - if (check_module_name) { - if (!scheme_resolved_module_path_value_matches(m->modname, modname)) { - other = m->modname; - d = NULL; - } - } - } else { - if (!SCHEME_STX_PAIRP(d)) - d = NULL; - else { - a = SCHEME_STX_CAR(d); - if (!SAME_OBJ(SCHEME_STX_VAL(a), module_symbol)) - d = NULL; - else { - d = SCHEME_STX_CDR(d); - if (!SCHEME_STX_PAIRP(d)) - d = NULL; - else { - a = SCHEME_STX_CAR(d); - other = SCHEME_STX_VAL(a); - if (check_module_name) { - if (!SAME_OBJ(other, modname)) - d = NULL; - } - } - } - } - } - - /* If d is NULL, shape was wrong */ - if (!d) { - Scheme_Object *err_msg; - if (!other || !SCHEME_SYMBOLP(other)) - err_msg = scheme_make_byte_string("something else"); - else { - char *s, *t; - intptr_t len, slen; - - t = "declaration for `"; - len = strlen(t); - slen = SCHEME_SYM_LEN(other); - - s = (char *)scheme_malloc_atomic(len + slen + 2); - memcpy(s, t, len); - memcpy(s + len, SCHEME_SYM_VAL(other), slen); - s[len + slen] = '\''; - s[len + slen + 1]= 0; - - err_msg = scheme_make_sized_byte_string(s, len + slen + 1, 0); - } - - { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected a `module' declaration\n" - " found: %T\n" - " in: %V", - err_msg, - ip->name); - } - - return NULL; - } - - /* Check no more expressions: */ - if (!skip_no_more_check) { - d = scheme_internal_read(port, lhd->stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); - if (!SCHEME_EOFP(d)) { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected only a `module' declaration;\n" - " found an extra form\n" - " in: %V", - modname, - ip->name); - - return NULL; - } - } - - if (!m) { - /* Replace `module' in read expression with one bound to #%kernel's `module': */ - a = SCHEME_STX_CAR(obj); - d = SCHEME_STX_CDR(obj); - a = scheme_datum_to_syntax(module_symbol, a, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 1); - d = scheme_make_pair(a, d); - obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1); - as_module = 1; - } - } else { - /* Add #%top-interaction, since we're in non-module mode: */ - Scheme_Object *a; - a = scheme_make_pair(scheme_intern_symbol("#%top-interaction"), obj); - obj = scheme_datum_to_syntax(a, obj, scheme_false, 0, 0); - } - - /* ... end special support for module loading ... */ - - if (!as_module && genv->stx_context) - obj = scheme_top_introduce(obj, genv); - - last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, &obj); - - /* If multi, we must save then: */ - if (last_val == SCHEME_MULTIPLE_VALUES) { - save_array = p->ku.multiple.array; - save_count = p->ku.multiple.count; - - if (SAME_OBJ(save_array, p->values_buffer)) - p->values_buffer = NULL; - } - - if (SCHEME_SYMBOLP(modname)) - break; - } - - if (SCHEME_SYMBOLP(modname) && !got_one) { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected a `module' declaration;\n" - " found end-of-file\n" - " in: %V", - modname, - ip->name); - - return NULL; - } - - if (save_array) { - p->ku.multiple.array = save_array; - p->ku.multiple.count = save_count; - } - - return last_val; -} - -static int nonempty_symbol_list(Scheme_Object *p) -{ - if (!SCHEME_PAIRP(p)) return 0; - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return 0; - p = SCHEME_CDR(p); - } - return SCHEME_NULLP(p); -} - -static Scheme_Object *default_load(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *port, *name, *expected_module, *v; - int use_delay_load; - Scheme_Thread *p = scheme_current_thread; - Scheme_Config *config; - LoadHandlerData *lhd; - Scheme_Cont_Frame_Data cframe; - - if (!SCHEME_PATH_STRINGP(argv[0])) - scheme_wrong_contract("default-load-handler", "path-string?", 0, argc, argv); - expected_module = argv[1]; - if (!SCHEME_FALSEP(expected_module) - && !SCHEME_SYMBOLP(expected_module) - && (!SCHEME_PAIRP(expected_module) - || (!SCHEME_FALSEP(SCHEME_CAR(expected_module)) - && !SCHEME_SYMBOLP(SCHEME_CAR(expected_module))) - || !nonempty_symbol_list(SCHEME_CDR(expected_module)))) - scheme_wrong_contract("default-load-handler", - "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))", - 1, argc, argv); - - port = scheme_do_open_input_file("default-load-handler", 0, 1, argv, 0, SCHEME_TRUEP(expected_module)); - - /* Turn on line/column counting, unless it's a .zo file: */ - if (SCHEME_PATHP(argv[0])) { - intptr_t len; - - len = SCHEME_BYTE_STRLEN_VAL(argv[0]); - if ((len < 3) - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 3] != '.') - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 2] != 'z') - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 1] != 'o')) - scheme_count_lines(port); - } else { - intptr_t len; - - len = SCHEME_CHAR_STRLEN_VAL(argv[0]); - if ((len < 3) - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 3] != '.') - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 2] != 'z') - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 1] != 'o')) - scheme_count_lines(port); - } - - config = scheme_current_config(); - - v = scheme_get_param(config, MZCONFIG_LOAD_DELAY_ENABLED); - use_delay_load = SCHEME_TRUEP(v); - - if (SCHEME_TRUEP(expected_module)) { - config = scheme_extend_config(config, MZCONFIG_CASE_SENS, - (scheme_case_sensitive ? scheme_true : scheme_false)); /* for legacy code */ - config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_PARENS, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_GRAPH, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_BOX, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_DOT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_QUASI, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_true); - config = scheme_extend_config(config, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_READTABLE, scheme_false); - config = scheme_extend_config(config, MZCONFIG_READ_CDOT, scheme_false); - config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); - config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); - } else { - config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_true); - } - - if (use_delay_load) { - v = scheme_path_to_complete_path(argv[0], NULL); - config = scheme_extend_config(config, MZCONFIG_DELAY_LOAD_INFO, v); - } - - lhd = MALLOC_ONE_RT(LoadHandlerData); -#ifdef MZTAG_REQUIRED - lhd->type = scheme_rt_load_handler_data; -#endif - lhd->p = p; - lhd->config = config; - lhd->port = port; - name = scheme_input_port_record(port)->name; - lhd->stxsrc = name; - lhd->expected_module = expected_module; - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - v = scheme_dynamic_wind(NULL, do_load_handler, post_load_handler, - NULL, (void *)lhd); - - scheme_pop_continuation_frame(&cframe); - - return v; -} - -Scheme_Object *scheme_load_with_clrd(int argc, Scheme_Object *argv[], - char *who, int handler_param) -{ - const char *filename; - Scheme_Object *load_dir, *a[2], *filename_path, *v; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - if (!SCHEME_PATH_STRINGP(argv[0])) - scheme_wrong_contract(who, "path-string?", 0, argc, argv); - - filename = scheme_expand_string_filename(argv[0], - who, - NULL, - SCHEME_GUARD_FILE_READ); - - /* Calculate load directory */ - load_dir = scheme_get_file_directory(filename); - - filename_path = scheme_make_sized_path((char *)filename, -1, 0); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_LOAD_DIRECTORY, - load_dir); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - a[0] = filename_path; - a[1] = scheme_false; - v = _scheme_apply_multi(scheme_get_param(config, handler_param), 2, a); - - scheme_pop_continuation_frame(&cframe); - - return v; -} - -static Scheme_Object *load(int argc, Scheme_Object *argv[]) -{ - return scheme_load_with_clrd(argc, argv, "load", MZCONFIG_LOAD_HANDLER); -} - -static Scheme_Object * -current_load(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("current-load", - scheme_make_integer(MZCONFIG_LOAD_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - -static Scheme_Object * -current_load_use_compiled(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("current-load/use-compiled", - scheme_make_integer(MZCONFIG_LOAD_COMPILED_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - static Scheme_Object *abs_directory_p(const char *name, Scheme_Object *d) { if (!SCHEME_FALSEP(d)) { @@ -5132,7 +4490,7 @@ Scheme_Object *scheme_load(const char *file) { - Scheme_Object *p[1]; + Scheme_Object *p[1], *load_proc; mz_jmp_buf newbuf, * volatile savebuf; Scheme_Object * volatile val; @@ -5142,8 +4500,8 @@ if (scheme_setjmp(newbuf)) { val = NULL; } else { - val = scheme_apply_multi(scheme_make_prim((Scheme_Prim *)load), - 1, p); + load_proc = scheme_get_startup_export("load"); + val = scheme_apply_multi(load_proc, 1, p); } scheme_current_thread->error_buf = savebuf; @@ -5181,7 +4539,6 @@ static void register_traversers(void) { GC_REG_TRAV(scheme_rt_indexed_string, mark_indexed_string); - GC_REG_TRAV(scheme_rt_load_handler_data, mark_load_handler_data); GC_REG_TRAV(scheme_rt_user_input, mark_user_input); GC_REG_TRAV(scheme_rt_user_output, mark_user_output); } diff -Nru racket-6.12+ppa1/src/racket/src/print.c racket-7.0+ppa1/src/racket/src/print.c --- racket-6.12+ppa1/src/racket/src/print.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/print.c 2018-07-27 22:12:02.000000000 +0000 @@ -48,7 +48,6 @@ /* read-only globals */ SHARED_OK static char compacts[_CPT_COUNT_]; -SHARED_OK static Scheme_Hash_Table *global_constants_ht; ROSYM Scheme_Object *quote_symbol; ROSYM Scheme_Object *quasiquote_symbol; @@ -155,6 +154,7 @@ PrintParams *pp, int notdisplay); static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp); +static Scheme_Object *srcloc_path_to_string(Scheme_Object *p); #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1) @@ -186,7 +186,7 @@ #define make_hash_table_symtab() scheme_make_hash_table_eqv() -void scheme_init_print(Scheme_Env *env) +void scheme_init_print(Scheme_Startup_Env *env) { int i; @@ -218,12 +218,6 @@ #endif } -void scheme_init_print_global_constants() -{ - REGISTER_SO(global_constants_ht); - global_constants_ht = scheme_map_constants_to_globals(); -} - void scheme_init_print_buffers_places() { REGISTER_SO(quick_buffer); @@ -1453,8 +1447,7 @@ || SCHEME_CHAR_STRINGP(v) \ || SCHEME_BYTE_STRINGP(v) \ || SCHEME_CHARP(v) \ - || SCHEME_NUMBERP(v) \ - || SAME_TYPE(SCHEME_TYPE(v), scheme_module_index_type)) + || SCHEME_NUMBERP(v)) av = ((Scheme_Object **)a)[0]; bv = ((Scheme_Object **)b)[0]; if (SCHEME_FIRSTP(av)) { @@ -1500,7 +1493,7 @@ PrintParams *pp) { intptr_t j, size, offset; - Scheme_Object **keys, *key, *obj; + Scheme_Object **keys, *key; size = mt->sorted_keys_count; keys = mt->sorted_keys; @@ -1509,15 +1502,8 @@ offset = pp->print_offset; mt->shared_offsets[j] = offset; key = keys[j << 1]; - if (mt->rn_saved) { - obj = scheme_hash_get(mt->rn_saved, key); - } else { - obj = NULL; - } - if (!obj) - obj = key; mt->print_now = j + 1; - print(obj ? obj : key, notdisplay, compact, ht, mt, pp); + print(key, notdisplay, compact, ht, mt, pp); mt->print_now = 0; } } @@ -1665,120 +1651,6 @@ print_compact_number(pp, l); } -Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *obj, Scheme_Object *val) -{ - int l; - l = add_symtab(mt, obj); - if (l) { - if (!mt->rn_saved) { - Scheme_Hash_Table *rn_saved; - rn_saved = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rn_saved = rn_saved; - } - if (mt->pass >= 2) { - /* Done already */ - } else - scheme_hash_set(mt->rn_saved, obj, val); - - if (mt->pass) - return scheme_make_integer(l); - } - return val; -} - -Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *obj) -{ - return get_symtab_idx(mt, obj); -} - -void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *obj) -{ - set_symtab_shared(mt, obj); -} - -void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt) -{ - Scheme_Object *p; - Scheme_Hash_Table *st_refs; - - if (mt->pass >= 0) { - p = scheme_make_pair((Scheme_Object *)mt->st_refs, - mt->st_ref_stack); - mt->st_ref_stack = p; - - st_refs = make_hash_table_symtab(); - - mt->st_refs = st_refs; - } -} - -void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep) -{ - Scheme_Hash_Table *st_refs = mt->st_refs; - - if (mt->pass >= 0) { - mt->st_refs = (Scheme_Hash_Table *)SCHEME_CAR(mt->st_ref_stack); - mt->st_ref_stack = SCHEME_CDR(mt->st_ref_stack); - - if (keep) { - if (!mt->st_refs->count) - mt->st_refs = st_refs; - else { - intptr_t i; - for (i = 0; i < st_refs->size; i++) { - if (st_refs->vals[i]) { - scheme_hash_set(mt->st_refs, st_refs->keys[i], st_refs->vals[i]); - } - } - } - } - } -} - -Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v) -{ - Scheme_Object *b; - - b = scheme_alloc_small_object(); - b->type = scheme_marshal_share_type; - SCHEME_PTR_VAL(b) = v; - - return b; -} - -static Scheme_Object *intern_modidx(Scheme_Hash_Table *interned, Scheme_Object *modidx) -{ - Scheme_Object *l = scheme_null; - Scheme_Modidx *midx; - - while (SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) { - midx = (Scheme_Modidx *)modidx; - modidx = scheme_hash_get(interned, modidx); - if (!modidx) { - modidx = (Scheme_Object *)midx; - if (SCHEME_FALSEP(midx->path)) { - scheme_hash_set(interned, modidx, modidx); - break; - } else { - l = scheme_make_pair(modidx, l); - modidx = midx->base; - } - } else - break; - } - - while (!SCHEME_NULLP(l)) { - midx = (Scheme_Modidx *)SCHEME_CAR(l); - modidx = scheme_make_modidx(midx->path, - modidx, - midx->resolved); - scheme_hash_set(interned, modidx, modidx); - l = SCHEME_CDR(l); - } - - return modidx; -} - static void print_escaped(PrintParams *pp, int notdisplay, Scheme_Object *obj, Scheme_Hash_Table *ht, Scheme_Marshal_Tables *mt, int shared) @@ -1877,98 +1749,87 @@ return 0; } -static Scheme_Object *write_modules_to_strings_k(void); +static Scheme_Object *write_bundles_to_strings_k(void); -static Scheme_Object *write_modules_to_strings(Scheme_Object *l, - Scheme_Module *m, - Resolve_Prefix *prefix) -{ - Scheme_Compilation_Top *top; - char *ns, *s; - intptr_t nlen, len; - Scheme_Object *pr; - Scheme_Module *m2; +/* Bundles are written so that all of the link subdirectories content + of a link directory are together and terminated by a bundle or + #f (i.e., post-order traversal) */ +static Scheme_Object *write_bundles_to_strings(Scheme_Object *accum_l, + Scheme_Object *ld, + Scheme_Object *name_list) +{ + Scheme_Hash_Tree *ht; + mzlonglong pos; + Scheme_Object *k, *v, *bundle = scheme_false; #ifdef DO_STACK_CHECK #include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = l; - p->ku.k.p2 = m; - p->ku.k.p3 = prefix; + p->ku.k.p1 = accum_l; + p->ku.k.p2 = ld; + p->ku.k.p3 = name_list; - return scheme_handle_stack_overflow(write_modules_to_strings_k); + return scheme_handle_stack_overflow(write_bundles_to_strings_k); } #endif - if ((m->pre_submodules && !SCHEME_NULLP(m->pre_submodules)) - || (m->post_submodules && !SCHEME_NULLP(m->post_submodules))) { - /* clone module to one without submodules: */ - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - m2->pre_submodules = scheme_null; - m2->post_submodules = scheme_null; - } else - m2 = m; + ht = (Scheme_Hash_Tree *)SCHEME_PTR_VAL(ld); - pr = m->pre_submodules; - if (pr) { - pr = scheme_reverse(pr); - while (!SCHEME_NULLP(pr)) { - l = write_modules_to_strings(l, (Scheme_Module *)SCHEME_CAR(pr), prefix); - pr = SCHEME_CDR(pr); + pos = scheme_hash_tree_next(ht, -1); + while (pos != -1) { + scheme_hash_tree_index(ht, pos, &k, &v); + if (SCHEME_SYMBOLP(k)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type)); + + accum_l = write_bundles_to_strings(accum_l, v, scheme_make_pair(k, name_list)); + } else { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + bundle = v; } + pos = scheme_hash_tree_next(ht, pos); } - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->code = (Scheme_Object *)m2; - top->max_let_depth = m->max_let_depth; - top->prefix = prefix; - - ns = scheme_submodule_path_to_string(m->submodule_path, &nlen); - s = scheme_write_to_string((Scheme_Object *)top, &len); - - l = scheme_make_pair(scheme_make_pair(scheme_make_sized_byte_string(ns, nlen, 0), - scheme_make_sized_byte_string(s, len, 0)), - l); - - pr = m->post_submodules; - if (pr) { - pr = scheme_reverse(pr); - while (!SCHEME_NULLP(pr)) { - l = write_modules_to_strings(l, (Scheme_Module *)SCHEME_CAR(pr), prefix); - pr = SCHEME_CDR(pr); - } + /* write root bundle, if any, or #f */ + { + intptr_t len, nlen; + char *s, *ns; + + ns = scheme_symbol_path_to_string(scheme_reverse(name_list), &nlen); + s = scheme_write_to_string(bundle, &len); + + accum_l = scheme_make_pair(scheme_make_pair(scheme_make_sized_byte_string(ns, nlen, 0), + scheme_make_sized_byte_string(s, len, 0)), + accum_l); } - return l; + return accum_l; } -static Scheme_Object *write_modules_to_strings_k(void) +static Scheme_Object *write_bundles_to_strings_k(void) { Scheme_Thread *p = scheme_current_thread; - Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; - Scheme_Module *m = (Scheme_Module *)p->ku.k.p2; - Resolve_Prefix *pf = (Resolve_Prefix *)p->ku.k.p3; + Scheme_Object *accum_l = (Scheme_Object *)p->ku.k.p1; + Scheme_Object *ld = (Scheme_Object *)p->ku.k.p2; + Scheme_Object *name_list = (Scheme_Object *)p->ku.k.p3; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - return write_modules_to_strings(l, m, pf); + return write_bundles_to_strings(accum_l, ld, name_list); } -typedef struct Module_And_Offset { - Scheme_Object *mod; +typedef struct Bundle_And_Offset { + Scheme_Object *bundle; Scheme_Object *offset; -} Module_And_Offset; +} Bundle_And_Offset; -static int compare_modules(const void *_am, const void *_bm) +static int compare_bundles(const void *_am, const void *_bm) { - Scheme_Object *a = ((Module_And_Offset *)_am)->mod; - Scheme_Object *b = ((Module_And_Offset *)_bm)->mod; + Scheme_Object *a = ((Bundle_And_Offset *)_am)->bundle; + Scheme_Object *b = ((Bundle_And_Offset *)_bm)->bundle; intptr_t i, alen, blen; unsigned char *as, *bs; @@ -1988,41 +1849,40 @@ return (alen - blen); } -static intptr_t compute_module_subtrees(Module_And_Offset *a, intptr_t *subtrees, +static intptr_t compute_bundle_subtrees(Bundle_And_Offset *a, intptr_t *subtrees, int start, int count, intptr_t offset) { int midpt = start + (count / 2); - Scheme_Object *o = SCHEME_CAR(a[midpt].mod); + Scheme_Object *o = SCHEME_CAR(a[midpt].bundle); intptr_t len; len = SCHEME_BYTE_STRLEN_VAL(o); offset += 4 + len + 16; if (midpt > start) - offset = compute_module_subtrees(a, subtrees, start, midpt - start, offset); + offset = compute_bundle_subtrees(a, subtrees, start, midpt - start, offset); subtrees[midpt] = offset; count -= (midpt - start + 1); if (count) - return compute_module_subtrees(a, subtrees, midpt + 1, count, offset); + return compute_bundle_subtrees(a, subtrees, midpt + 1, count, offset); else return offset; } - -static intptr_t write_module_tree(PrintParams *pp, Module_And_Offset *a, +static intptr_t write_bundle_tree(PrintParams *pp, Bundle_And_Offset *a, intptr_t *subtrees, int start, int count, intptr_t offset) { int midpt = start + (count / 2); - Scheme_Object *o = SCHEME_CAR(a[midpt].mod); + Scheme_Object *o = SCHEME_CAR(a[midpt].bundle); intptr_t len; len = SCHEME_BYTE_STRLEN_VAL(o); print_number(pp, len); print_this_string(pp, SCHEME_BYTE_STR_VAL(o), 0, len); print_number(pp, SCHEME_INT_VAL(a[midpt].offset)); - print_number(pp, SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[midpt].mod))); + print_number(pp, SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[midpt].bundle))); offset += 20 + len; if (midpt > start) @@ -2036,9 +1896,9 @@ print_number(pp, 0); if (midpt > start) - offset = write_module_tree(pp, a, subtrees, start, midpt - start, offset); + offset = write_bundle_tree(pp, a, subtrees, start, midpt - start, offset); if (count) - offset = write_module_tree(pp, a, subtrees, midpt + 1, count, offset); + offset = write_bundle_tree(pp, a, subtrees, midpt + 1, count, offset); return offset; } @@ -2088,6 +1948,9 @@ || SCHEME_STRUCT_TYPEP(obj) || SCHEME_EOFP(obj) || SAME_OBJ(scheme_undefined, obj) + || SAME_OBJ(scheme_parameterization_key, obj) + || SAME_OBJ(scheme_break_enabled_key, obj) + || SAME_OBJ(scheme_exn_handler_key, obj) || SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj)) @@ -2095,10 +1958,11 @@ || SAME_OBJ(scheme_app_mark_impersonator_property, obj))) { /* Check whether this is a global constant */ Scheme_Object *val; - val = scheme_hash_get(global_constants_ht, obj); + val = scheme_hash_get(scheme_startup_env->primitive_ids_table, obj); if (val) { - /* val is a scheme_variable_type object, instead of something else */ - obj = val; + print_compact(pp, CPT_REFERENCE); + print_compact_number(pp, SCHEME_INT_VAL(val)); + return 1; } } @@ -2525,6 +2389,52 @@ { print_compact(pp, CPT_VOID); } + else if (compact && SCHEME_CHAPERONE_STRUCTP(obj) && scheme_is_location(obj)) + { + /* Support srclocs in marshaled form with special treatment + of paths */ + int i; + Scheme_Object *src, *rel_src, *dir; + + src = scheme_struct_ref(obj, 0); + if (SCHEME_PATHP(src)) { + /* To make paths portable and to avoid full paths, check + whether the path can be made relative, in which case it is + turned into a list of byte strings. If not, convert to a + string using only the last couple of path elements. */ + dir = scheme_get_param(scheme_current_config(), + MZCONFIG_WRITE_DIRECTORY); + if (SCHEME_TRUEP(dir)) + rel_src = scheme_extract_relative_to(src, dir, mt->path_cache); + else + rel_src = src; + if (SCHEME_PATHP(rel_src)) { + src = scheme_hash_get(mt->path_cache, scheme_box(rel_src)); + if (!src) { + src = srcloc_path_to_string(rel_src); + scheme_hash_set(mt->path_cache, scheme_box(rel_src), src); + } + } else { + /* let the printer make it relative when recurring */ + } + } else if (SCHEME_FALSEP(src) + || SCHEME_CHAR_STRINGP(src) + || SCHEME_BYTE_STRINGP(src) + || SCHEME_SYMBOLP(src) + || SCHEME_GENERAL_PATHP(src)) { + /* ok */ + } else { + cannot_print(pp, notdisplay, obj, ht, compact); + } + + print_compact(pp, CPT_SRCLOC); + print(src, notdisplay, compact, ht, mt, pp); + for (i = 1; i < 5; i++) { + print(scheme_struct_ref(obj, i), notdisplay, compact, ht, mt, pp); + } + + closed = 1; + } else if (SCHEME_CHAPERONE_STRUCTP(obj)) { if (compact && SCHEME_PREFABP(obj)) { @@ -2697,44 +2607,6 @@ } } } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)) - { - if (compact || !pp->print_unreadable) { - cannot_print(pp, notdisplay, obj, ht, compact); - } else { - int is_sym, is_sub; - Scheme_Object *rp; - - if (notdisplay) - print_utf8_string(pp, "#", 0, 1); - } - closed = notdisplay; - } else if (SCHEME_PRIMP(obj) && ((Scheme_Primitive_Proc *)obj)->name) { if (compact || !pp->print_unreadable) { @@ -2847,7 +2719,7 @@ } else { print_utf8_string(pp, "struct-type-property", 0, 21); } - PRINTADDRESS(pp, obj); + PRINTADDRESS(pp, obj); print_utf8_string(pp, ">", 0, 1); } } @@ -2862,34 +2734,6 @@ print_utf8_string(pp, ">", 0, 1); } } - else if (SCHEME_NAMESPACEP(obj)) - { - if (compact || !pp->print_unreadable) { - cannot_print(pp, notdisplay, obj, ht, compact); - } else { - char s[10]; - - print_utf8_string(pp, "#module) { - Scheme_Object *modname; - int is_sym; - - modname = ((Scheme_Env *)obj)->module->modname; - is_sym = !SCHEME_PATHP(SCHEME_PTR_VAL(modname)); - print_utf8_string(pp, (is_sym ? "'" : "\""), 0, 1); - print(SCHEME_PTR_VAL(modname), 0, 0, ht, mt, pp); - PRINTADDRESS(pp, modname); - if (!is_sym) - print_utf8_string(pp, "\"" , 0, 1); - print_utf8_string(pp, ":", 0, 1); - } - - sprintf(s, "%" PRIdPTR "", ((Scheme_Env *)obj)->phase); - print_utf8_string(pp, s, 0, -1); - print_utf8_string(pp, ">", 0, 1); - } - } else if (SCHEME_INPORTP(obj)) { if (compact || !pp->print_unreadable) { @@ -2998,16 +2842,10 @@ } else if (SCHEME_STXP(obj)) { - if (compact && !pp->printing_quoted) { - print_compact(pp, CPT_STX); - - /* "2" in scheme_syntax_to_datum() call preserves wraps. */ - closed = print(scheme_syntax_to_datum(obj, 2, mt), - notdisplay, 1, ht, mt, pp); - } else if (pp->print_unreadable) { + if (pp->print_unreadable) { Scheme_Stx *stx = (Scheme_Stx *)obj; if (stx->srcloc && ((stx->srcloc->line >= 0) || (stx->srcloc->pos >= 0))) { - print_utf8_string(pp, "#srcloc->src && SCHEME_PATHP(stx->srcloc->src)) { print_utf8_string(pp, SCHEME_BYTE_STR_VAL(stx->srcloc->src), 0, SCHEME_BYTE_STRLEN_VAL(stx->srcloc->src)); print_utf8_string(pp, ":", 0, 1); @@ -3022,13 +2860,13 @@ stx->srcloc->pos); print_utf8_string(pp, quick_buffer, 0, -1); } else - print_utf8_string(pp, "#print_syntax) { intptr_t slen; char *str; int rel; print_utf8_string(pp, " ", 0, 1); - str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx, 0, NULL), + str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx), &slen, 1, NULL, pp->print_syntax, NULL, &rel); print_utf8_string(pp, str, 0, slen); if (rel && !quick_print_buffer) @@ -3039,151 +2877,54 @@ cannot_print(pp, notdisplay, obj, ht, compact); } } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_inspector_type)) - { - /* For use by syntax objects, we map each inspector to an uninterned symbol */ - Scheme_Object *sym; - if (!mt->identity_map) { - Scheme_Hash_Table *id_map; - id_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->identity_map = id_map; - } - sym = scheme_hash_get(mt->identity_map, obj); - if (!sym) { - int id = mt->inspector_counter++; - char buf[32]; - sprintf(buf, "insp%d", id); - sym = scheme_make_symbol(buf); /* uninterned */ - scheme_hash_set(mt->identity_map, obj, sym); - } - closed = print(sym, notdisplay, 1, ht, mt, pp); - } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_scope_type) - && (compact || pp->print_unreadable)) + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type))) { - if (compact) { - Scheme_Object *idx; + int flags, pos, depth; - idx = scheme_stx_root_scope(); - if (SAME_OBJ(idx, obj)) { - print_compact(pp, CPT_ROOT_SCOPE); - } else { - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - print_compact(pp, CPT_SCOPE); - print_symtab_set(pp, mt, obj); - idx = get_symtab_idx(mt, obj); - if (mt->reachable_scopes) { - idx = scheme_hash_get(mt->reachable_scopes, obj); - if (!idx) - scheme_signal_error("internal error: found supposedly unreachable scope"); - } else - idx = scheme_make_integer(0); - print_compact_number(pp, SCHEME_INT_VAL(idx)); - print(scheme_scope_marshal_content(obj, mt), notdisplay, 1, ht, mt, pp); - } - } - } else { - print_utf8_string(pp, "#", 0, 1); - } + print_compact(pp, CPT_TOPLEVEL); + + flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); + pos = SCHEME_TOPLEVEL_POS(obj); + depth = SCHEME_TOPLEVEL_DEPTH(obj); + + print_compact_number(pp, flags); + print_compact_number(pp, pos); + print_compact_number(pp, depth); } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_static_toplevel_type))) { - Scheme_Object *idx; + int flags, pos; - if (compact) { - obj = intern_modidx(mt->intern_map, obj); - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - print_compact(pp, CPT_MODULE_INDEX); - print(((Scheme_Modidx *)obj)->path, notdisplay, 1, ht, mt, pp); - print(((Scheme_Modidx *)obj)->base, notdisplay, 1, ht, mt, pp); - if (SCHEME_FALSEP(((Scheme_Modidx *)obj)->path) - && SCHEME_FALSEP(((Scheme_Modidx *)obj)->base)) - print(scheme_modidx_submodule(obj), notdisplay, 1, ht, mt, pp); - symtab_set(pp, mt, obj); - } - } else { - Scheme_Object *l = scheme_null; - Scheme_Modidx *modidx = (Scheme_Modidx *)obj; - print_utf8_string(pp, "#path)) { - l = scheme_make_pair(modidx->path, l); - if (SCHEME_FALSEP(modidx->base)) - break; - else if (SAME_TYPE(SCHEME_TYPE(modidx->base), scheme_resolved_module_path_type)) { - l = scheme_make_pair(modidx->base, l); - break; - } - modidx = (Scheme_Modidx *)modidx->base; - } - if (0 && SCHEME_FALSEP(modidx->path)) { - /* use hash code as identity of ending "self": */ - uintptr_t key; - key = scheme_hash_key((Scheme_Object *)modidx); - l = scheme_make_pair(scheme_make_integer_value_from_unsigned(key), - l); - } - l = scheme_reverse(l); - print(l, 1, 0, ht, mt, pp); - print_utf8_string(pp, ">", 0, 1); - } + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_static_toplevel_type); + + flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); + pos = SCHEME_TOPLEVEL_POS(obj); + + print_compact_number(pp, flags); + print_compact_number(pp, pos); + + closed = print((Scheme_Object *)SCHEME_STATIC_TOPLEVEL_PREFIX(obj), notdisplay, 1, NULL, mt, pp); } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type)) + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_prefix_type))) { + /* Should only get here for a prefix referenced by a linklet or static toplevel */ Scheme_Object *idx; + if (compact) + idx = get_symtab_idx(mt, obj); + else + idx = NULL; - idx = get_symtab_idx(mt, obj); if (idx) { print_symtab_ref(pp, idx); - } else { - Module_Variable *mv = (Module_Variable *)obj; - int flags = SCHEME_MODVAR_FLAGS(mv); - - print_compact(pp, CPT_MODULE_VAR); - if (SAME_TYPE(SCHEME_TYPE(mv->modidx), scheme_resolved_module_path_type) - && SCHEME_SYMBOLP(SCHEME_PTR_VAL(mv->modidx))) { - print(SCHEME_PTR_VAL(mv->modidx), notdisplay, 1, ht, mt, pp); - } else { - print(mv->modidx, notdisplay, 1, ht, mt, pp); - } - print(mv->sym, notdisplay, 1, ht, mt, pp); - print(mv->shape ? mv->shape : scheme_false, notdisplay, 1, ht, mt, pp); - if (flags & 0x3) { - print_compact_number(pp, -3-(flags&0x3)); - } - if (mv->mod_phase) { - print_compact_number(pp, -2); - print_compact_number(pp, mv->mod_phase); - } - print_compact_number(pp, mv->pos); + } else if (compact) { + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_prefix_type); + print_compact_number(pp, ((Scheme_Prefix *)obj)->num_slots); symtab_set(pp, mt, obj); } } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_variable_type) - && (((Scheme_Bucket_With_Flags *)obj)->flags & GLOB_HAS_REF_ID)) - { - int pos; - pos = ((Scheme_Bucket_With_Ref_Id *)obj)->id; - print_compact(pp, CPT_REFERENCE); - print_compact_number(pp, pos); - } else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type))) @@ -3255,6 +2996,61 @@ print(scheme_protect_quote(app->rand1), notdisplay, 1, NULL, mt, pp); closed = print(scheme_protect_quote(app->rand2), notdisplay, 1, NULL, mt, pp); } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type) + || SAME_TYPE(SCHEME_TYPE(obj), scheme_begin0_sequence_type))) + { + int i, count; + + print_compact(pp, (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type) + ? CPT_BEGIN + : CPT_BEGIN0)); + count = ((Scheme_Sequence *)obj)->count; + print_compact_number(pp, count); + + for (i = 0; i < count; i++) { + closed = print(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), notdisplay, 1, NULL, mt, pp); + } + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_let_value_type))) + { + Scheme_Let_Value *lv; + + lv = (Scheme_Let_Value *)obj; + + print_compact(pp, CPT_LET_VALUE); + print_compact_number(pp, lv->count); + print_compact_number(pp, lv->position); + print_compact_number(pp, (SCHEME_LET_VALUE_AUTOBOX(lv) ? 1 : 0)); + print(scheme_protect_quote(lv->value), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(lv->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_let_void_type))) + { + Scheme_Let_Void *lv; + + lv = (Scheme_Let_Void *)obj; + + print_compact(pp, CPT_LET_VOID); + print_compact_number(pp, lv->count); + print_compact_number(pp, (SCHEME_LET_VOID_AUTOBOX(lv) ? 1 : 0)); + closed = print(scheme_protect_quote(lv->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_letrec_type))) + { + Scheme_Letrec *lr = (Scheme_Letrec *)obj; + int i, count; + + count = lr->count; + + print_compact(pp, CPT_LETREC); + print_compact_number(pp, count); + + for (i = 0; i < count; i++) { + print(scheme_protect_quote(lr->procs[i]), notdisplay, 1, NULL, mt, pp); + } + + closed = print(scheme_protect_quote(lr->body), notdisplay, 1, NULL, mt, pp); + } else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_let_one_type)) { Scheme_Let_One *lo; @@ -3283,6 +3079,134 @@ print(scheme_protect_quote(b->tbranch), notdisplay, 1, NULL, mt, pp); closed = print(scheme_protect_quote(b->fbranch), notdisplay, 1, NULL, mt, pp); } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_with_cont_mark_type)) + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; + + print_compact(pp, CPT_WCM); + print(scheme_protect_quote(wcm->key), notdisplay, 1, NULL, mt, pp); + print(scheme_protect_quote(wcm->val), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(wcm->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_define_values_type)) + { + Scheme_Object *e; + + print_compact(pp, CPT_DEFINE_VALUES); + + obj = scheme_clone_vector(obj, 0, 0); + e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); + SCHEME_VEC_ELS(obj)[0] = e; + + closed = print(obj, notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_set_bang_type)) + { + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; + + print_compact(pp, CPT_SET_BANG); + print_compact_number(pp, sb->set_undef ? 1 : 0); + print(sb->var, notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(sb->val), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_boxenv_type)) + { + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_boxenv_type); + + print(SCHEME_PTR1_VAL(obj), notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_PTR2_VAL(obj), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_varref_form_type)) + { + print_compact(pp, CPT_VARREF); + + print_compact_number(pp, SCHEME_VARREF_FLAGS(obj) & VARREF_FLAGS_MASK); + print(SCHEME_PTR1_VAL(obj), notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_PTR2_VAL(obj), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_apply_values_type)) + { + print_compact(pp, CPT_APPLY_VALUES); + + print(scheme_protect_quote(SCHEME_PTR1_VAL(obj)), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(SCHEME_PTR2_VAL(obj)), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_with_immed_mark_type)) + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_with_immed_mark_type); + + print(wcm->key, notdisplay, 1, NULL, mt, pp); + print(wcm->val, notdisplay, 1, NULL, mt, pp); + closed = print(wcm->body, notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_inline_variant_type)) + { + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_inline_variant_type); + + print(SCHEME_VEC_ELS(obj)[0], notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_VEC_ELS(obj)[1], notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_case_lambda_sequence_type)) + { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; + int i, count; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_case_lambda_sequence_type); + + count = cl->count; + print_compact_number(pp, count); + + print(scheme_closure_marshal_name(cl->name), notdisplay, 1, NULL, mt, pp); + + for (i = 0; i < count; i++) { + closed = print(cl->array[i], notdisplay, 1, NULL, mt, pp); + } + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_lambda_type)) + { + Scheme_Lambda *data = (Scheme_Lambda *)obj; + Scheme_Object *name, *ds, *closure_map, *tl_map; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_lambda_type); + + scheme_write_lambda(obj, &name, &ds, &closure_map, &tl_map); + + print_compact_number(pp, SCHEME_LAMBDA_FLAGS(data) & 0x7F); + if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) + print_compact_number(pp, data->closure_size); + print_compact_number(pp, data->num_params); + print_compact_number(pp, data->max_let_depth); + + print(name, notdisplay, 1, NULL, mt, pp); + print(ds, notdisplay, 1, NULL, mt, pp); + print(closure_map, notdisplay, 1, NULL, mt, pp); + closed = print(tl_map, notdisplay, 1, NULL, mt, pp); + } +#ifdef MZ_PRECISE_GC + else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_rt_delay_load_info)) + { + Scheme_Load_Delay *ld; + int l; + ld = (Scheme_Load_Delay *)obj; + print_utf8_string(pp, "#path)) { + l = SCHEME_PATH_LEN(ld->path); + print_this_string(pp, SCHEME_PATH_VAL(ld->path), 0, l); + } + else { + print_utf8_string(pp, "???", 0, 3); + } + print_utf8_string(pp, ">", 0, 1); + + } +#endif else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_quote_compilation_type)) { Scheme_Hash_Table *q_ht; @@ -3378,161 +3302,100 @@ set_symtab_shared(mt, obj); } } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_marshal_share_type)) + else if (!compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_directory_type)) { - if (compact) { - Scheme_Object *idx; - - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - int l; - l = add_symtab(mt, obj); - obj = SCHEME_PTR_VAL(obj); - if (l) - print_general_symtab_ref(pp, scheme_make_integer(l), CPT_SHARED); - print(obj, notdisplay, 1, ht, mt, pp); - } - } else { - print(SCHEME_PTR_VAL(obj), notdisplay, 0, ht, mt, pp); - } - } - else if (!compact - && SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type) - && SAME_TYPE(SCHEME_TYPE(((Scheme_Compilation_Top *)obj)->code), scheme_module_type) - && ((((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->pre_submodules - && !SCHEME_NULLP(((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->pre_submodules)) - || (((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->post_submodules - && !SCHEME_NULLP(((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->post_submodules)))) - { - /* Write a module group with an initial directory */ - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; - Scheme_Object *mods, *p; - Module_And_Offset *a, *orig_a; + /* Write directory content with an index at the beginning */ + Scheme_Object *p, *accum_l; + Bundle_And_Offset *a; intptr_t *subtrees, offset, init_offset; int count, i; init_offset = 2 + 1 + strlen(MZSCHEME_VERSION) + 1 + 4; - mods = write_modules_to_strings(scheme_null, - (Scheme_Module *)top->code, - top->prefix); - mods = scheme_reverse(mods); /* write order == valid declaration order */ + accum_l = write_bundles_to_strings(scheme_null, obj, scheme_null); - for (p = mods, count = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + for (p = accum_l, count = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { count++; } - a = MALLOC_N(Module_And_Offset, count); - orig_a = MALLOC_N(Module_And_Offset, count); - for (p = mods, i = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p), i++) { - a[i].mod = SCHEME_CAR(p); - orig_a[i].mod = a[i].mod; + a = MALLOC_N(Bundle_And_Offset, count); + for (p = accum_l, i = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p), i++) { + a[i].bundle = SCHEME_CAR(p); } + my_qsort(a, count, sizeof(Bundle_And_Offset), compare_bundles); offset = init_offset; for (i = 0; i < count; i++) { - offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(a[i].mod)) + 20; + offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(a[i].bundle)) + 20; } for (i = 0; i < count; i++) { a[i].offset = scheme_make_integer(offset); - offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].mod)); + offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle)); } - my_qsort(a, count, sizeof(Module_And_Offset), compare_modules); - /* orig_a is in declaration order, a in sorted (for btree) order */ + /* a is in sorted (for btree) order */ subtrees = MALLOC_N_ATOMIC(intptr_t, count); - (void)compute_module_subtrees(a, subtrees, 0, count, init_offset); + (void)compute_bundle_subtrees(a, subtrees, 0, count, init_offset); print_this_string(pp, "#~", 0, 2); print_one_byte(pp, strlen(MZSCHEME_VERSION)); print_this_string(pp, MZSCHEME_VERSION, 0, -1); - /* "D" means "directory": */ + /* "D" means "linklet directory": */ print_this_string(pp, "D", 0, 1); print_number(pp, count); - /* Write the module directory as a binary search tree. */ - (void)write_module_tree(pp, a, subtrees, 0, count, init_offset); + /* Write the bundle directory as a binary search tree. */ + (void)write_bundle_tree(pp, a, subtrees, 0, count, init_offset); - /* Write the modules: */ + /* Write the bundles: */ for (i = 0; i < count; i++) { print_this_string(pp, - SCHEME_BYTE_STR_VAL(SCHEME_CDR(orig_a[i].mod)), + SCHEME_BYTE_STR_VAL(SCHEME_CDR(a[i].bundle)), 0, - SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(orig_a[i].mod))); + SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle))); } } - else if (SCHEME_TYPE(obj) <= _scheme_last_type_ && scheme_type_writers[SCHEME_TYPE(obj)] - && (compact || SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type))) + else if ((compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_type)) + || SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type)) { - Scheme_Type t = SCHEME_TYPE(obj); - Scheme_Object *v; - intptr_t slen; - - if (t >= _scheme_last_type_) { - /* Doesn't happen: */ - scheme_signal_error("internal error: bad type with writer"); - return 0; - } - if (compact) { - if (t < CPT_RANGE(SMALL_MARSHALLED)) { - unsigned char s[1]; - s[0] = t + CPT_SMALL_MARSHALLED_START; - print_this_string(pp, (char *)s, 0, 1); - } else { - print_compact(pp, CPT_MARSHALLED); - print_compact_number(pp, t); - } - } else { - print_this_string(pp, "#~", 0, 2); - } + Scheme_Object *v; - { - Scheme_Type_Writer writer; - writer = scheme_type_writers[t]; - v = writer(obj); - } + print_compact(pp, CPT_LINKLET); - if (compact) + if (((Scheme_Linklet *)obj)->static_prefix) { + print_compact_number(pp, 1); + print((Scheme_Object *)((Scheme_Linklet *)obj)->static_prefix, notdisplay, 1, NULL, mt, pp); + } else + print_compact_number(pp, 0); + + v = scheme_write_linklet(obj); + closed = print(v, notdisplay, 1, NULL, mt, pp); - else { - Scheme_Hash_Table *st_refs, *symtab, *reachable_scopes, *intern_map, *path_cache; + } else { + Scheme_Hash_Table *st_refs, *symtab, *intern_map, *path_cache; + Scheme_Object *v; intptr_t *shared_offsets; intptr_t st_len, j, shared_offset, start_offset; + intptr_t slen; + + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type)); + v = SCHEME_PTR_VAL(obj); /* extract hash table from a linklet bundle */ + + print_this_string(pp, "#~", 0, 2); mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); scheme_current_thread->current_mt = mt; - - /* We need to compare a modidx using `eq?`, because shifting - is based on `eq`ness. */ - intern_map = scheme_make_hash_table_equal_modix_eq(); + + intern_map = scheme_make_hash_table(SCHEME_hash_ptr); mt->intern_map = intern_map; - /* "Print" the string once to find out which scopes are reachable; - dropping unreachable scopes drops potentialy large binding tables. */ - mt->pass = -1; - reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr); - mt->conditionally_reachable_scopes = reachable_scopes; - reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr); - mt->reachable_scopes = reachable_scopes; - mt->reachable_scope_stack = scheme_null; symtab = make_hash_table_symtab(); mt->symtab = symtab; path_cache = scheme_make_hash_table_equal(); mt->path_cache = path_cache; - print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); - scheme_iterate_reachable_scopes(mt); - mt->pending_reachable_ids = NULL; - - mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); - SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); scheme_current_thread->current_mt = mt; - mt->reachable_scopes = reachable_scopes; - mt->intern_map = intern_map; - mt->path_cache = path_cache; /* Track which shared values are referenced: */ st_refs = make_hash_table_symtab(); @@ -3551,7 +3414,6 @@ print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); sort_referenced_keys(mt); - mt->rn_saved = NULL; /* "Print" again, now that we know which values are actually shared. On this pass, shared values that reference other shared values @@ -3560,7 +3422,6 @@ mt->shared_offsets = shared_offsets; symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 1; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 1, &st_len); @@ -3568,7 +3429,6 @@ /* "Print" the string again to get a measurement and symtab size. */ symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 2; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, -1, &st_len); @@ -3577,7 +3437,7 @@ print_one_byte(pp, strlen(MZSCHEME_VERSION)); print_this_string(pp, MZSCHEME_VERSION, 0, -1); - print_this_string(pp, "T", 0, 1); /* "T" means "top" */ + print_this_string(pp, "B", 0, 1); /* "B" means "bundle" */ /* Leave space for a module hash code */ print_this_string(pp, "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 0, 20); @@ -3608,7 +3468,6 @@ for the final print: */ symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 3; start_offset = pp->print_offset; @@ -4446,6 +4305,40 @@ flush_from_byte_port(SCHEME_VEC_ELS(vec)[4], orig_pp); } +static Scheme_Object *srcloc_path_to_string(Scheme_Object *p) +{ + Scheme_Object *base, *name, *dir_name; + int isdir; + + name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); + if ((SCHEME_PATHP(name) || SCHEME_SYMBOLP(name)) && SCHEME_PATHP(base)) { + dir_name = scheme_split_path(SCHEME_PATH_VAL(base), SCHEME_PATH_LEN(base), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); + if (SCHEME_FALSEP(base)) { + /* Path is file at root, so just keep the whole path */ + return scheme_path_to_char_string(p); + } + if (SCHEME_PATHP(name)) + name = scheme_path_to_char_string(name); + else { + /* convert "." or ".." */ + if (!strcmp(SCHEME_SYM_VAL(name), "up")) + name = scheme_make_utf8_string(".."); + else + name = scheme_make_utf8_string("."); + } + if (SCHEME_PATHP(dir_name)) + name = scheme_append_strings(scheme_path_to_char_string(dir_name), + scheme_append_strings(scheme_make_utf8_string("/"), + name)); + return scheme_append_strings(scheme_make_utf8_string(".../"), name); + } else if (SCHEME_PATHP(name)) + return scheme_path_to_char_string(name); + else { + /* original path is a root, ".", or ".." */ + return scheme_path_to_char_string(p); + } +} + /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/racket/src/read.c racket-7.0+ppa1/src/racket/src/read.c --- racket-6.12+ppa1/src/racket/src/read.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/read.c 2018-07-27 22:12:02.000000000 +0000 @@ -1,4 +1,4 @@ - /* +/* Racket Copyright (c) 2004-2018 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt @@ -61,12 +61,11 @@ SHARED_OK int scheme_curly_braces_are_parens = 1; /* global flag set from environment variable */ SHARED_OK static int use_perma_cache = 1; +SHARED_OK static int validate_loaded_linklet = 0; -THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects); - +THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects = 0); /* read-only global symbols */ -SHARED_OK static char *builtin_fast; SHARED_OK static unsigned char delim[128]; SHARED_OK static unsigned char cpt_branch[256]; @@ -82,33 +81,13 @@ ROSYM static Scheme_Object *unsyntax_symbol; ROSYM static Scheme_Object *unsyntax_splicing_symbol; ROSYM static Scheme_Object *quasisyntax_symbol; -ROSYM static Scheme_Object *brackets_symbol; -ROSYM static Scheme_Object *braces_symbol; -ROSYM static Scheme_Object *dot_symbol; -ROSYM static Scheme_Object *terminating_macro_symbol; -ROSYM static Scheme_Object *non_terminating_macro_symbol; -ROSYM static Scheme_Object *dispatch_macro_symbol; -/* For recoginizing unresolved hash tables and commented-out graph introductions: */ -ROSYM static Scheme_Object *unresolved_uninterned_symbol; -ROSYM static Scheme_Object *tainted_uninterned_symbol; +ROSYM static Scheme_Object *hash_code_symbol; +ROSYM static Scheme_Object *pre_symbol; +ROSYM static Scheme_Object *post_symbol; /* local function prototypes */ static Scheme_Object *read_case_sensitive(int, Scheme_Object *[]); -static Scheme_Object *read_bracket_as_paren(int, Scheme_Object *[]); -static Scheme_Object *read_brace_as_paren(int, Scheme_Object *[]); -static Scheme_Object *read_bracket_with_tag(int, Scheme_Object *[]); -static Scheme_Object *read_brace_with_tag(int, Scheme_Object *[]); -static Scheme_Object *read_cdot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_graph(int, Scheme_Object *[]); -static Scheme_Object *read_accept_compiled(int, Scheme_Object *[]); -static Scheme_Object *read_accept_box(int, Scheme_Object *[]); static Scheme_Object *read_accept_pipe_quote(int, Scheme_Object *[]); -static Scheme_Object *read_decimal_as_inexact(int, Scheme_Object *[]); -static Scheme_Object *read_accept_dot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_infix_dot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_quasi(int, Scheme_Object *[]); -static Scheme_Object *read_accept_reader(int, Scheme_Object *[]); -static Scheme_Object *read_accept_lang(int, Scheme_Object *[]); #ifdef LOAD_ON_DEMAND static Scheme_Object *read_delay_load(int, Scheme_Object *[]); #endif @@ -127,28 +106,10 @@ #define NOT_EOF_OR_SPECIAL(x) ((x) >= 0) -#define mzSPAN(port, pos) () - -#define NOT_ENABLED_str " not enabled in the current context" - #define isdigit_ascii(n) ((n >= '0') && (n <= '9')) #define scheme_isxdigit(n) (isdigit_ascii(n) || ((n >= 'a') && (n <= 'f')) || ((n >= 'A') && (n <= 'F'))) -#define RETURN_FOR_SPECIAL_COMMENT 0x1 -#define RETURN_FOR_HASH_COMMENT 0x2 -#define RETURN_FOR_DELIM 0x4 -#define RETURN_FOR_COMMENT 0x8 - -static MZ_INLINE intptr_t SPAN(Scheme_Object *port, intptr_t pos) { - intptr_t cpos; - scheme_tell_all(port, NULL, NULL, &cpos); - return cpos - pos + 1; -} - -/* For cases where we'd rather report the location as just the relevant prefix: */ -#define MINSPAN(port, pos, span) (span) - #define mz_shape_cons 0 #define mz_shape_vec 1 #define mz_shape_hash_list 2 @@ -157,250 +118,77 @@ #define mz_shape_fl_vec 5 #define mz_shape_fx_vec 6 -typedef struct Readtable { - Scheme_Object so; - Scheme_Hash_Table *mapping; /* pos int -> (cons int proc-or-char); neg int -> proc */ - char *fast_mapping; - Scheme_Object *symbol_parser; /* NULL or a Racket function */ - char **names; /* error-message names */ -} Readtable; +#define MAX_GRAPH_ID_DIGITS 8 typedef struct ReadParams { MZTAG_IF_REQUIRED - char can_read_compiled; - char can_read_unsafe; - char can_read_pipe_quote; - char can_read_box; - char can_read_graph; - char can_read_reader; - char can_read_lang; - char case_sensitive; - char square_brackets_are_parens; - char curly_braces_are_parens; - char square_brackets_are_tagged; - char curly_braces_are_tagged; - char read_cdot; - char read_decimal_inexact; - char can_read_dot; - char can_read_infix_dot; - char can_read_quasi; char skip_zo_vers_check; - Readtable *table; - Scheme_Object *magic_sym, *magic_val; + char can_read_unsafe; Scheme_Object *delay_load_info; Scheme_Object *read_relative_path; + Scheme_Hash_Table *graph_ht; } ReadParams; #define THREAD_FOR_LOCALS scheme_current_thread -static Scheme_Object *read_list(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_list(Scheme_Object *port, int opener, int closer, int shape, int use_stack, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + ReadParams *params); static Scheme_Object *read_string(int is_byte, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, + Scheme_Object *port, + ReadParams *params, int err_ok); -static Scheme_Object *read_here_string(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params); static Scheme_Object *read_quote(char *who, Scheme_Object *quote_symbol, int len, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, + Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_vector(Scheme_Object *port, int opener, char closer, - intptr_t reqLen, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, + ReadParams *params, int allow_infix); -static Scheme_Object *read_flvector (Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix); -static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix); +static Scheme_Object *read_number_or_symbol(int init_ch, Scheme_Object *port, + int is_float, int is_not_float, + int radix, int radix_set, + int is_symbol, int is_kw, + ReadParams *params); static Scheme_Object *read_number(int init_ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, + Scheme_Object *port, int, int, int, int, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); -static Scheme_Object *read_symbol(int init_ch, int skip_rt, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + ReadParams *params); +static Scheme_Object *read_symbol(int init_ch, + Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_keyword(int init_ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_delimited_constant(int ch, const mzchar *str, Scheme_Object *v, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params, Readtable *table); -static Scheme_Object *read_character(Scheme_Object *port, Scheme_Object *stcsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, + ReadParams *params); +static Scheme_Object *read_character(Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_box(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, +static Scheme_Object *read_box(Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_hash(Scheme_Object *port, int opener, char closer, int kind, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table); -static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params); -static Scheme_Object *read_lang(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int init_ch); -static Scheme_Object *read_compiled(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, + ReadParams *params); +static Scheme_Object *read_compiled(Scheme_Object *port, ReadParams *params); static void unexpected_closer(int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params); -static Scheme_Object *expected_lang(const char *prefix, int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_info); -static void pop_indentation(Scheme_Object *indentation); -static int next_is_delim(Scheme_Object *port, - ReadParams *params, - int brackets, - int braces); - -static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - Scheme_Object **prefetched); - -static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, Scheme_Object *modpath_stx); -static Scheme_Object *read_flonum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); -static Scheme_Object *read_fixnum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); -static Scheme_Object *read_number_literal(Scheme_Object *port, - Scheme_Object *stxsrc, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); - -#define READTABLE_WHITESPACE 0x1 -#define READTABLE_CONTINUING 0x2 -#define READTABLE_TERMINATING 0x4 -#define READTABLE_SINGLE_ESCAPE 0x8 -#define READTABLE_MULTIPLE_ESCAPE 0x10 -#define READTABLE_MAPPED 0x20 -static int readtable_kind(Readtable *t, int ch, ReadParams *params); -static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht); -static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht); -static int readtable_effective_char(Readtable *t, int ch); -static Scheme_Object *make_readtable(int argc, Scheme_Object **argv); -static Scheme_Object *readtable_p(int argc, Scheme_Object **argv); -static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv); -static Scheme_Object *current_readtable(int argc, Scheme_Object **argv); -static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv); + Scheme_Object *port); +static int next_is_delim(Scheme_Object *port); +static int read_graph_index(Scheme_Object *port, int *ch); +static int skip_whitespace_comments(Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_intern(int argc, Scheme_Object **argv); -/* A list stack is used to speed up the creation of intermediate lists - during .zo reading. */ - -#define NUM_CELLS_PER_STACK 500 - #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -typedef struct { - Scheme_Type type; - char closer; /* expected close parent, bracket, etc. */ - char suspicious_closer; /* expected closer when suspicious line found */ - char multiline; /* set to 1 if the match attempt spans a line */ - intptr_t start_line; /* opener's line */ - intptr_t last_line; /* current line, already checked the identation */ - intptr_t suspicious_line; /* non-0 => first suspicious line since opener */ - intptr_t max_indent; /* max indentation encountered so far since opener, - not counting indentation brackets by a more neseted - opener */ - intptr_t suspicious_quote; /* non-0 => first suspicious quote whose closer - is on a different line */ -} Scheme_Indent; - #define SCHEME_OK 0x1 -#define is_lang_nonsep_char(ch) (scheme_isalpha(ch) \ - || scheme_isdigit(ch) \ - || ((ch) == '-') \ - || ((ch) == '+') \ - || ((ch) == '_')) - #define NEXT_LINE_CHAR 0x85 #define LINE_SEPARATOR_CHAR 0x2028 #define PARAGRAPH_SEPARATOR_CHAR 0x2029 @@ -413,7 +201,7 @@ /* initialization */ /*========================================================================*/ -void scheme_init_read(Scheme_Env *env) +void scheme_init_read(Scheme_Startup_Env *env) { REGISTER_SO(quote_symbol); REGISTER_SO(quasiquote_symbol); @@ -424,16 +212,9 @@ REGISTER_SO(unsyntax_splicing_symbol); REGISTER_SO(quasisyntax_symbol); - REGISTER_SO(brackets_symbol); - REGISTER_SO(braces_symbol); - REGISTER_SO(dot_symbol); - - REGISTER_SO(unresolved_uninterned_symbol); - REGISTER_SO(tainted_uninterned_symbol); - REGISTER_SO(terminating_macro_symbol); - REGISTER_SO(non_terminating_macro_symbol); - REGISTER_SO(dispatch_macro_symbol); - REGISTER_SO(builtin_fast); + REGISTER_SO(hash_code_symbol); + REGISTER_SO(pre_symbol); + REGISTER_SO(post_symbol); quote_symbol = scheme_intern_symbol("quote"); quasiquote_symbol = scheme_intern_symbol("quasiquote"); @@ -444,40 +225,9 @@ unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing"); quasisyntax_symbol = scheme_intern_symbol("quasisyntax"); - brackets_symbol = scheme_intern_symbol("#%brackets"); - braces_symbol = scheme_intern_symbol("#%braces"); - dot_symbol = scheme_intern_symbol("#%dot"); - - unresolved_uninterned_symbol = scheme_make_symbol("unresolved"); - tainted_uninterned_symbol = scheme_make_symbol("tainted"); - - terminating_macro_symbol = scheme_intern_symbol("terminating-macro"); - non_terminating_macro_symbol = scheme_intern_symbol("non-terminating-macro"); - dispatch_macro_symbol = scheme_intern_symbol("dispatch-macro"); - - /* initialize builtin_fast */ - { - int i; - builtin_fast = scheme_malloc_atomic(128); - memset(builtin_fast, READTABLE_CONTINUING, 128); - for (i = 0; i < 128; i++) { - if (scheme_isspace(i)) - builtin_fast[i] = READTABLE_WHITESPACE; - } - builtin_fast[';'] = READTABLE_TERMINATING; - builtin_fast['\''] = READTABLE_TERMINATING; - builtin_fast['`'] = READTABLE_TERMINATING; - builtin_fast[','] = READTABLE_TERMINATING; - builtin_fast['"'] = READTABLE_TERMINATING; - builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE; - builtin_fast['\\'] = READTABLE_SINGLE_ESCAPE; - builtin_fast['('] = READTABLE_TERMINATING; - builtin_fast['['] = READTABLE_TERMINATING; - builtin_fast['{'] = READTABLE_TERMINATING; - builtin_fast[')'] = READTABLE_TERMINATING; - builtin_fast[']'] = READTABLE_TERMINATING; - builtin_fast['}'] = READTABLE_TERMINATING; - } + hash_code_symbol = scheme_intern_symbol("hash-code"); + pre_symbol = scheme_intern_symbol("pre"); + post_symbol = scheme_intern_symbol("post"); /* initialize cpt_branch */ { @@ -493,7 +243,6 @@ } FILL_IN(SMALL_NUMBER); FILL_IN(SMALL_SYMBOL); - FILL_IN(SMALL_MARSHALLED); FILL_IN(SMALL_LIST); FILL_IN(SMALL_PROPER_LIST); FILL_IN(SMALL_LOCAL); @@ -528,49 +277,30 @@ register_traversers(); #endif - GLOBAL_PARAMETER("current-readtable", current_readtable, MZCONFIG_READTABLE, env); - GLOBAL_PARAMETER("current-reader-guard", current_reader_guard, MZCONFIG_READER_GUARD, env); - GLOBAL_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env); - GLOBAL_PARAMETER("read-square-bracket-as-paren", read_bracket_as_paren, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, env); - GLOBAL_PARAMETER("read-curly-brace-as-paren", read_brace_as_paren, MZCONFIG_CURLY_BRACES_ARE_PARENS, env); - GLOBAL_PARAMETER("read-square-bracket-with-tag", read_bracket_with_tag, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, env); - GLOBAL_PARAMETER("read-curly-brace-with-tag", read_brace_with_tag, MZCONFIG_CURLY_BRACES_ARE_TAGGED, env); - GLOBAL_PARAMETER("read-cdot", read_cdot, MZCONFIG_READ_CDOT, env); - GLOBAL_PARAMETER("read-accept-graph", read_accept_graph, MZCONFIG_CAN_READ_GRAPH, env); - GLOBAL_PARAMETER("read-accept-compiled", read_accept_compiled, MZCONFIG_CAN_READ_COMPILED, env); - GLOBAL_PARAMETER("read-accept-box", read_accept_box, MZCONFIG_CAN_READ_BOX, env); - GLOBAL_PARAMETER("read-accept-bar-quote", read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE, env); - GLOBAL_PARAMETER("read-decimal-as-inexact", read_decimal_as_inexact,MZCONFIG_READ_DECIMAL_INEXACT, env); - GLOBAL_PARAMETER("read-accept-dot", read_accept_dot, MZCONFIG_CAN_READ_DOT, env); - GLOBAL_PARAMETER("read-accept-infix-dot", read_accept_infix_dot, MZCONFIG_CAN_READ_INFIX_DOT, env); - GLOBAL_PARAMETER("read-accept-quasiquote", read_accept_quasi, MZCONFIG_CAN_READ_QUASI, env); - GLOBAL_PARAMETER("read-accept-reader", read_accept_reader, MZCONFIG_CAN_READ_READER, env); - GLOBAL_PARAMETER("read-accept-lang", read_accept_lang, MZCONFIG_CAN_READ_LANG, env); + ADD_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env); + ADD_PARAMETER("read-accept-bar-quote", read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE, env); #ifdef LOAD_ON_DEMAND - GLOBAL_PARAMETER("read-on-demand-source", read_delay_load, MZCONFIG_DELAY_LOAD_INFO, env); + ADD_PARAMETER("read-on-demand-source", read_delay_load, MZCONFIG_DELAY_LOAD_INFO, env); #endif - GLOBAL_PARAMETER("print-graph", print_graph, MZCONFIG_PRINT_GRAPH, env); - GLOBAL_PARAMETER("print-struct", print_struct, MZCONFIG_PRINT_STRUCT, env); - GLOBAL_PARAMETER("print-box", print_box, MZCONFIG_PRINT_BOX, env); - GLOBAL_PARAMETER("print-vector-length", print_vec_shorthand, MZCONFIG_PRINT_VEC_SHORTHAND, env); - GLOBAL_PARAMETER("print-hash-table", print_hash_table, MZCONFIG_PRINT_HASH_TABLE, env); - GLOBAL_PARAMETER("print-unreadable", print_unreadable, MZCONFIG_PRINT_UNREADABLE, env); - GLOBAL_PARAMETER("print-pair-curly-braces", print_pair_curly, MZCONFIG_PRINT_PAIR_CURLY, env); - GLOBAL_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env); - GLOBAL_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env); - GLOBAL_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env); - GLOBAL_PARAMETER("print-boolean-long-form", print_long_bool, MZCONFIG_PRINT_LONG_BOOLEAN, env); - GLOBAL_PARAMETER("print-as-expression", print_as_qq, MZCONFIG_PRINT_AS_QQ, env); - - GLOBAL_PRIM_W_ARITY("make-readtable", make_readtable, 1, -1, env); - GLOBAL_FOLDING_PRIM("readtable?", readtable_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("readtable-mapping", readtable_mapping, 2, 2, 3, 3, env); + ADD_PARAMETER("print-graph", print_graph, MZCONFIG_PRINT_GRAPH, env); + ADD_PARAMETER("print-struct", print_struct, MZCONFIG_PRINT_STRUCT, env); + ADD_PARAMETER("print-box", print_box, MZCONFIG_PRINT_BOX, env); + ADD_PARAMETER("print-vector-length", print_vec_shorthand, MZCONFIG_PRINT_VEC_SHORTHAND, env); + ADD_PARAMETER("print-hash-table", print_hash_table, MZCONFIG_PRINT_HASH_TABLE, env); + ADD_PARAMETER("print-unreadable", print_unreadable, MZCONFIG_PRINT_UNREADABLE, env); + ADD_PARAMETER("print-pair-curly-braces", print_pair_curly, MZCONFIG_PRINT_PAIR_CURLY, env); + ADD_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env); + ADD_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env); + ADD_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env); + ADD_PARAMETER("print-boolean-long-form", print_long_bool, MZCONFIG_PRINT_LONG_BOOLEAN, env); + ADD_PARAMETER("print-as-expression", print_as_qq, MZCONFIG_PRINT_AS_QQ, env); - GLOBAL_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env); + ADD_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env); - if (getenv("PLT_DELAY_FROM_ZO")) { + if (getenv("PLT_DELAY_FROM_ZO")) use_perma_cache = 0; - } + if (getenv("PLT_VALIDATE_LOAD")) + validate_loaded_linklet = 0; } void scheme_init_variable_references_constants() @@ -579,27 +309,12 @@ variable_references = scheme_make_builtin_references_table(&unsafe_variable_references_start); } - -static void track_indentation(Scheme_Object *indentation, int line, int col) +Scheme_Object *scheme_position_to_builtin(int l) { - if (!SCHEME_NULLP(indentation)) { - Scheme_Indent *indt = (Scheme_Indent *)SCHEME_CAR(indentation); - /* Already checked this line? */ - if (line > indt->last_line) { - indt->last_line = line; - indt->multiline = 1; - /* At least as indented as before? */ - if (col >= indt->max_indent) - indt->max_indent = col; - else if (!indt->suspicious_line) { - /* Not as indented, and no suspicious line found - already. Suspect that the closer should have - appeared earlier. */ - indt->suspicious_closer = indt->closer; - indt->suspicious_line = line; - } - } - } + if (l < EXPECTED_PRIM_COUNT) + return variable_references[l]; + else + return NULL; } /*========================================================================*/ @@ -616,96 +331,12 @@ } static Scheme_Object * -read_bracket_as_paren(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-square-bracket-as-paren", MZCONFIG_SQUARE_BRACKETS_ARE_PARENS); -} - -static Scheme_Object * -read_brace_as_paren(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-curly-brace-as-paren", MZCONFIG_CURLY_BRACES_ARE_PARENS); -} - -static Scheme_Object * -read_bracket_with_tag(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-square-bracket-with-tag", MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); -} - -static Scheme_Object * -read_brace_with_tag(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-curly-brace-with-tag", MZCONFIG_CURLY_BRACES_ARE_TAGGED); -} - -static Scheme_Object * -read_cdot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-cdot", MZCONFIG_READ_CDOT); -} - -static Scheme_Object * -read_accept_graph(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-graph", MZCONFIG_CAN_READ_GRAPH); -} - -static Scheme_Object * -read_accept_compiled(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-compiled", MZCONFIG_CAN_READ_COMPILED); -} - -static Scheme_Object * -read_accept_box(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-box", MZCONFIG_CAN_READ_BOX); -} - -static Scheme_Object * read_accept_pipe_quote(int argc, Scheme_Object *argv[]) { DO_CHAR_PARAM("read-accept-pipe-quote", MZCONFIG_CAN_READ_PIPE_QUOTE); } static Scheme_Object * -read_decimal_as_inexact(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-decimal-as-inexact", MZCONFIG_READ_DECIMAL_INEXACT); -} - -static Scheme_Object * -read_accept_dot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-dot", MZCONFIG_CAN_READ_DOT); -} - -static Scheme_Object * -read_accept_infix_dot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-infix-dot", MZCONFIG_CAN_READ_INFIX_DOT); -} - -static Scheme_Object * -read_accept_quasi(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-quasiquote", MZCONFIG_CAN_READ_QUASI); -} - -static Scheme_Object * -read_accept_reader(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-reader", MZCONFIG_CAN_READ_READER); -} - -static Scheme_Object * -read_accept_lang(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-lang", MZCONFIG_CAN_READ_LANG); -} - -static Scheme_Object * print_graph(int argc, Scheme_Object *argv[]) { DO_CHAR_PARAM("print-graph", MZCONFIG_PRINT_GRAPH); @@ -828,172 +459,29 @@ /* main read loop */ /*========================================================================*/ -#ifdef DO_STACK_CHECK - -static Scheme_Object *read_inner_inner_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode, - int pre_char, - Readtable *init_readtable, - int get_info); -static Scheme_Object *read_inner_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode, - int pre_char, - Readtable *init_readtable, - int get_info); -static Scheme_Object *read_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); - -static void set_need_copy(Scheme_Hash_Table **ht) -{ - /* Set indicator in *ht that we need to copy: */ - if (!*ht) { - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } - scheme_hash_set(*ht, tainted_uninterned_symbol, scheme_true); -} +static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char); -static Scheme_Object *read_inner_inner_inner_k(void) +static Scheme_Object *read_inner_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Hash_Table **ht = (Scheme_Hash_Table **)p->ku.k.p2; - Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *indentation = SCHEME_CAR((Scheme_Object *)p->ku.k.p4); ReadParams *params = (ReadParams *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); - Readtable *table = (Readtable *)p->ku.k.p5; p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - return read_inner_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, - table, p->ku.k.i3); + return read_inner(o, params, p->ku.k.i2); } -#endif - -#define MAX_GRAPH_ID_DIGITS 8 -static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mzchar *tagbuf, mzchar *vecbuf, int *vector_length, int *digits, int *overflow) +static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char) { - int i = 0, j = 0, nch; - *vector_length = -1; - *overflow = 0; - *digits = 0; - - while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) { - if (*digits <= MAX_GRAPH_ID_DIGITS) - (*digits)++; - - /* For vector error msgs, want to drop leading zeros: */ - if (j || ((*ch) != '0')) { - if (j < 60) { - vecbuf[j++] = (*ch); - } else if (j == 60) { - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j] = 0; - } - } - - /* For tag error msgs, want to keep zeros: */ - if (i < 60) { - tagbuf[i++] = (*ch); - } else if (i == 60) { - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i] = 0; - } - - if (!(*overflow)) { - uintptr_t old_len; - uintptr_t new_len; - - if (*vector_length < 0) - *vector_length = 0; - - old_len = *vector_length; - new_len = *vector_length; - new_len = ((new_len) * 10) + ((*ch) - 48); - *vector_length = new_len; - if ((*vector_length < 0) || ((new_len / 10) != old_len)) { - *overflow = 1; - } - } - nch = scheme_getc_special_ok(port); - (*ch) = nch; - } - - if (*overflow) - *vector_length = -2; - vecbuf[j] = 0; - tagbuf[i] = 0; - - if (!j) { - vecbuf[j] = '0'; - vecbuf[0] = 0; - } - - return readtable_effective_char(table, (*ch)); -} - -static Scheme_Object * -read_plus_minus_period_leading_number(Scheme_Object *port, Scheme_Object *stxsrc, - int ch, intptr_t line, intptr_t col, intptr_t pos, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, - Readtable *table) -{ - int ch2; - Scheme_Object *special_value; - ch2 = scheme_peekc_special_ok(port); - if ((NOT_EOF_OR_SPECIAL(ch2) && isdigit_ascii(ch2)) || (ch2 == '.') - || ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */ - || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ )) { - /* read_number tries to get a number, but produces a symbol if number parsing doesn't work, - unless `is_float' or `is_not_float': */ - special_value = read_number(ch, port, stxsrc, line, col, pos, - is_float, is_not_float, 10, 0, ht, indentation, params, table); - } else { - special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); - } - return special_value; -} - - -static Scheme_Object * -read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode, int pre_char, Readtable *table, - int get_info) -{ - int ch, ch2, depth, dispatch_ch, special_value_need_copy = 0; - intptr_t line = 0, col = 0, pos = 0; - Scheme_Object *special_value; + int ch, ch2; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - Scheme_Object *pr; ReadParams *params2; /* params may be on the stack, so move it to the heap: */ @@ -1004,18 +492,9 @@ #endif p->ku.k.p1 = (void *)port; - p->ku.k.p2 = (void *)ht; - p->ku.k.p3 = (void *)stxsrc; - - pr = scheme_make_pair(indentation, (Scheme_Object *)params2); - p->ku.k.p4 = (void *)pr; - - p->ku.k.p5 = (void *)table; - - p->ku.k.i1 = comment_mode; + p->ku.k.p4 = (void *)params2; p->ku.k.i2 = pre_char; - p->ku.k.i3 = get_info; - return scheme_handle_stack_overflow(read_inner_inner_inner_k); + return scheme_handle_stack_overflow(read_inner_k); } } #endif @@ -1024,406 +503,139 @@ SCHEME_USE_FUEL(1); + /* Skip whitespace */ while (1) { if (pre_char >= 0) { ch = pre_char; pre_char = -1; } else - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch)) { - if (table) { - if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) - break; - } else if (!scheme_isspace(ch)) + if (!scheme_isspace(ch)) break; } else break; } - scheme_tell_all(port, &line, &col, &pos); - - /* Found non-whitespace. Track indentation: */ - if (col >= 0) { - if (SCHEME_PAIRP(indentation)) { - int effective_ch; - effective_ch = readtable_effective_char(table, ch); - /* Ignore if it's a comment start or spurious closer: */ - if ((effective_ch != ';') - && !((effective_ch == '#') && (scheme_peekc_special_ok(port) == '|')) - && (effective_ch != ')') - && ((effective_ch != '}') || !params->curly_braces_are_parens) - && ((effective_ch != ']') || !params->square_brackets_are_parens)) { - track_indentation(indentation, line, col); - } - } - } - - special_value = NULL; - if (table && NOT_EOF_OR_SPECIAL(ch)) { - Scheme_Object *v; - int use_default, ch2 = ch; - v = readtable_handle(table, &ch2, &use_default, params, - port, stxsrc, line, col, pos, ht); - if (!use_default) { - dispatch_ch = SCHEME_SPECIAL; - special_value = v; - } else - dispatch_ch = ch2; - } else - dispatch_ch = ch; - - if (get_info && (dispatch_ch != '#') && (dispatch_ch != ';')) { - /* If ch is EOF, then col or pos wasn't incremented by reading ch. - The col and pos might be used in an error message, which expects - to subtract one from each --- so counteract by adding one here. */ - if (ch == EOF) { - if (pos >= 0) pos++; - if (col >= 0) col++; - } - return expected_lang("", ch, port, stxsrc, line, col, pos, get_info); - } - - switch ( dispatch_ch ) + switch (ch) { case EOF: return scheme_eof; - case SCHEME_SPECIAL: - { - if (!special_value) { - special_value = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); - special_value_need_copy = 1; - } - break; - } case ']': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close square bracket"); - return NULL; - } else { - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); - return NULL; - } + unexpected_closer(ch, port); + return NULL; case '}': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close curly brace"); - return NULL; - } else { - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); - return NULL; - } + unexpected_closer(ch, port); + return NULL; case ')': - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); + unexpected_closer(ch, port); return NULL; case '(': - return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, ')', mz_shape_cons, 0, params); case '[': - if (!params->square_brackets_are_parens && !params->square_brackets_are_tagged) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket"); - return NULL; - } else - return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, ']', mz_shape_cons, 0, params); case '{': - if (!params->curly_braces_are_parens && !params->curly_braces_are_tagged) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace"); - return NULL; - } else - return read_list(port, stxsrc, line, col, pos, ch, '}', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, '}', mz_shape_cons, 0, params); case '|': - special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_symbol(ch, port, params); case '"': - return read_string(0, port, stxsrc, line, col, pos, ht, indentation, params, table, 1); + return read_string(0, port, params, 1); case '\'': - return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("quoting '", quote_symbol, 1, port, params); case '`': - if (!params->can_read_quasi) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of backquote"); - return NULL; - } else - return read_quote("quasiquoting `", quasiquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("quasiquoting `", quasiquote_symbol, 1, port, params); case ',': - if (!params->can_read_quasi) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of comma"); - return NULL; - } else { - if (scheme_peekc_special_ok(port) == '@') { + { + if (scheme_peekc(port) == '@') { ch = scheme_getc(port); /* must be '@' */ - return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, params); } else - return read_quote("unquoting ,", unquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting ,", unquote_symbol, 1, port, params); } case ';': { - while (((ch = scheme_getc_special_ok(port)) != '\n') + while (((ch = scheme_getc(port)) != '\n') && !is_line_comment_end(ch)) { - if (ch == EOF) { - if (comment_mode & RETURN_FOR_COMMENT) - return NULL; - if (get_info) - return expected_lang("", ch, port, stxsrc, line, col, pos, get_info); - return scheme_eof; - } - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + if (ch == EOF) + return scheme_eof; } - if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; goto start_over; } - case '+': - case '-': - case '.': /* ^^^ fallthrough ^^^ */ - special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, 0, 0, ht, indentation, params, table); - break; case '#': - ch = scheme_getc_special_ok(port); - - if (get_info && (ch != '|') && (ch != '!') && (ch != 'l') && (ch != ';')) { - return expected_lang("#", ch, port, stxsrc, line, col, pos, get_info); - } - - if (table) { - Scheme_Object *v; - int use_default; - v = readtable_handle_hash(table, ch, &use_default, params, - port, stxsrc, line, col, pos, ht); - if (!use_default) { - if (v) - return v; - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - } - - special_value = NULL; + ch = scheme_getc(port); switch (ch) { case EOF: - case SCHEME_SPECIAL: - scheme_read_err(port, stxsrc, line, col, pos, 1, ch, indentation, "read: bad syntax `#'"); - break; + scheme_read_err(port, "read: bad syntax `#'"); + return NULL; case ';': { Scheme_Object *skipped; - skipped = read_inner(port, stxsrc, ht, indentation, params, 0); + skipped = read_inner(port, params, -1); if (SCHEME_EOFP(skipped)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: expected a commented-out element for `#;' (found end-of-file)"); - /* For resolving graphs introduced in #; : */ - if (*ht) { - Scheme_Object *v; - v = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (!v) - v = scheme_null; - v = scheme_make_pair(skipped, v); - scheme_hash_set(*ht, unresolved_uninterned_symbol, v); - } - - if ((comment_mode & RETURN_FOR_HASH_COMMENT) - || (table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; - + scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)"); goto start_over; } - break; case '%': scheme_ungetc('%', port); - special_value = read_symbol('#', 1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_symbol('#', port, params); case ':': - return read_keyword(-1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_keyword(-1, port, params); case '(': - return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, table, 0); - break; + return read_vector(port, ch, ')', params, 0); case '[': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['"); - return NULL; - } else - return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, table, 0); - break; + return read_vector(port, ch, ']', params, 0); case '{': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'"); - return NULL; - } else - return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, table, 0); + return read_vector(port, ch, '}', params, 0); case '\\': - { - Scheme_Object *chr; - chr = read_character(port, stxsrc, line, col, pos, ht, indentation, params); - if (stxsrc) - chr = scheme_make_stx_w_offset(chr, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return chr; - } - break; + return read_character(port, params); case 'T': case 't': - if (next_is_delim(port, params, 1, 1)) { + if (next_is_delim(port)) { /* found delimited `#t' */ - return (stxsrc - ? scheme_make_stx_w_offset(scheme_true, line, col, pos, 2, stxsrc, STX_SRCTAG) - : scheme_true); + return scheme_true; } else { GC_CAN_IGNORE const mzchar str[] = { 't', 'r', 'u', 'e', 0 }; - return read_delimited_constant(ch, str, scheme_true, port, stxsrc, line, col, pos, - indentation, params, table); + return read_delimited_constant(ch, str, scheme_true, port, params); } case 'F': case 'f': - if (next_is_delim(port, params, 1, 1)) { + if (next_is_delim(port)) { /* found delimited `#f' */ - return (stxsrc - ? scheme_make_stx_w_offset(scheme_false, line, col, pos, 2, stxsrc, STX_SRCTAG) - : scheme_false); + return scheme_false; } else { - int next; - next = scheme_peekc_special_ok(port); - switch (next) { - case 'l': - case 'x': - { - int vector_length = -1; - int overflow = 0, digits = 0, effective_ch; - mzchar tagbuf[64], vecbuf[64]; /* just for errors */ - int ch; - - if (stxsrc) { - scheme_read_err(port, stxsrc, line, col, pos, 3, 0, indentation, - "read-syntax: literal f%cvectors not allowed", next); - return NULL; - } - - ch = scheme_getc_special_ok(port); - ch = scheme_getc_special_ok(port); - if (isdigit_ascii(ch)) - effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); - else - effective_ch = ch; - switch (effective_ch) { - case '(': - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - case '[': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c['", next); - return NULL; - } else - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - case '{': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c{'", next); - return NULL; - } else - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 3, effective_ch, indentation, - "read: expected `(' `[' or `{' after #f%c", next); - } - } - default: - { - GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; - return read_delimited_constant(ch, str, scheme_false, port, stxsrc, line, col, pos, - indentation, params, table); - } - } + GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; + return read_delimited_constant(ch, str, scheme_false, port, params); } - case 'c': - case 'C': - { - Scheme_Object *v; - int sens = 0; - int save_sens; - - ch = scheme_getc_special_ok(port); - switch ( ch ) { - case 'i': - case 'I': - sens = 0; - break; - case 's': - case 'S': - sens = 1; - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: expected `s' or `i' after #c"); - return NULL; - } - - - save_sens = params->case_sensitive; - params->case_sensitive = sens; - - v = read_inner(port, stxsrc, ht, indentation, params, 0); - - params->case_sensitive = save_sens; - - if (SCHEME_EOFP(v)) { - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: end-of-file after #c%c", - sens ? 's' : 'i'); - return NULL; - } - - return v; - } - break; case 's': case 'S': { - int orig_ch = ch, effective_ch; - ch = scheme_getc_special_ok(port); - if (NOT_EOF_OR_SPECIAL(ch)) - effective_ch = readtable_effective_char(params->table, ch); - else - effective_ch = ch; + int orig_ch = ch; + ch = scheme_getc(port); if ((orig_ch == 's') - && ((effective_ch == '(') - || (effective_ch == '[' && params->square_brackets_are_parens) - || (effective_ch == '{' && params->curly_braces_are_parens))) { + && ((ch == '(') + || (ch == '[') + || (ch == '{'))) { Scheme_Object *v; Scheme_Struct_Type *st; - if (effective_ch == '(') + if (ch == '(') ch = ')'; - else if (effective_ch == '[') + else if (ch == '[') ch = ']'; - else if (effective_ch == '{') + else if (ch == '{') ch = '}'; - v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, table, 1); - if (stxsrc) - v = SCHEME_STX_VAL(v); - - if (SCHEME_VEC_SIZE(v)) { - Scheme_Object *key; - key = SCHEME_VEC_ELS(v)[0]; - if (stxsrc) - key = scheme_syntax_to_datum(key, 0, NULL); - st = scheme_lookup_prefab_type(key, SCHEME_VEC_SIZE(v) - 1); - } else + v = read_vector(port, orig_ch, ch, params, 1); + + if (SCHEME_VEC_SIZE(v)) + st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1); + else st = NULL; if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1))) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, (SCHEME_VEC_SIZE(v) ? (st ? ("read: mismatch between structure description" @@ -1433,19 +645,11 @@ return NULL; } - if (stxsrc && !(MZ_OPT_HASH_KEY(&st->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: cannot read mutable `#s' form as syntax"); - } - v = scheme_make_prefab_struct_instance(st, v); - if (stxsrc) - v = scheme_make_stx_w_offset(v, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return v; } else { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: expected `x'%s after `#%c'", (orig_ch == 's' ? "or `('" : ""), orig_ch); @@ -1454,66 +658,43 @@ } case 'X': case 'x': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 16, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 16, 1, params); case 'B': case 'b': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 2, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 2, 1, params); case 'O': case 'o': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 8, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 8, 1, params); case 'D': case 'd': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 10, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 10, 1, params); case 'E': case 'e': - return read_number(-1, port, stxsrc, line, col, pos, 0, 1, 10, 0, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 1, 10, 0, params); case 'I': case 'i': - return read_number(-1, port, stxsrc, line, col, pos, 1, 0, 10, 0, ht, indentation, params, table); - break; + return read_number(-1, port, 1, 0, 10, 0, params); case '\'': - return read_quote("quoting #'", syntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("quoting #'", syntax_symbol, 2, port, params); case '`': - return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, params); case ',': - if (scheme_peekc_special_ok(port) == '@') { + if (scheme_peekc(port) == '@') { ch = scheme_getc(port); /* must be '@' */ - return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, params); } else - return read_quote("unquoting #`", unsyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("unquoting #`", unsyntax_symbol, 2, port, params); case '~': - if (params->can_read_compiled) { - Scheme_Object *cpld; - cpld = read_compiled(port, stxsrc, line, col, pos, ht, params); - if (stxsrc) - cpld = scheme_make_stx_w_offset(cpld, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return cpld; - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #~ compiled expressions" NOT_ENABLED_str); - return NULL; - } - break; + return read_compiled(port, params); case '^': - if (params->read_relative_path) { - ch = scheme_getc_special_ok(port); + { + ch = scheme_getc(port); if (ch == '#') { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == '"') { Scheme_Object *str; - intptr_t sline = 0, scol = 0, spos = 0; - scheme_tell_all(port, &sline, &scol, &spos); - - str = read_string(1, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1); + str = read_string(1, port, params, 1); str->type = SCHEME_PLATFORM_PATH_KIND; @@ -1530,39 +711,29 @@ } return str; + } else { + scheme_read_err(port, "read: bad syntax `#^#%c'", ch); + return NULL; } } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: bad syntax `#^#%c'", - ch); + scheme_read_err(port, "read: bad syntax `#^%c'", ch); + return NULL; } - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: bad syntax `#^%c'", - ch); } break; case '|': { - /* FIXME: integer overflow possible */ - depth = 0; + intptr_t depth = 0; ch2 = 0; do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: end of file in #| comment"); - else if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + scheme_read_err(port, "read: end of file in #| comment"); if ((ch2 == '|') && (ch == '#')) { - if (!(depth--)) { - if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; + if (!(depth--)) goto start_over; - } ch = 0; /* So we don't count '#' toward an opening "#|" */ } else if ((ch2 == '#') && (ch == '|')) { depth++; @@ -1573,64 +744,7 @@ } break; case '&': - if (params->can_read_box) - return read_box(port, stxsrc, line, col, pos, ht, indentation, params); - else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #& expressions" NOT_ENABLED_str); - return NULL; - } - break; - case 'l': - { - mzchar found[5]; - int fl = 1; - found[0] = 'l'; - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'a') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'n') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'g') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == ' ') { - /* #lang */ - Scheme_Object *v; - if (!params->can_read_reader - || !params->can_read_lang) { - scheme_read_err(port, stxsrc, line, col, pos, 6, 0, indentation, - "read: #lang" NOT_ENABLED_str); - return NULL; - } - v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, 0); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; - } else { - if (ch == EOF) --fl; - scheme_read_err(port, stxsrc, line, col, pos, 6, ch, indentation, - "read%s: expected a single space after `#lang'", - (get_info ? "-language" : "")); - return NULL; - } - } - } - } - if (ch == EOF) --fl; - scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation, - "read%s: bad input: `#%u'", - (get_info ? "-language" : ""), - found, (intptr_t)fl); - return NULL; - } - break; + return read_box(port, params); case 'r': case 'p': { @@ -1638,73 +752,33 @@ int cnt = 0, is_byte = 0; char *expect; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == 'x') { expect = "x#"; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); cnt++; if (ch == '#') { is_byte = 1; cnt++; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } if (ch == '"') { Scheme_Object *str; int is_err; - intptr_t sline = 0, scol = 0, spos = 0; - - /* Skip #rx[#]: */ - scheme_tell_all(port, &sline, &scol, &spos); - - str = read_string(is_byte, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1); - if (stxsrc) - str = SCHEME_STX_VAL(str); + str = read_string(is_byte, port, params, 1); str = scheme_make_regexp(str, is_byte, (orig_ch == 'p'), &is_err); if (is_err) { - scheme_read_err(port, stxsrc, sline, scol, spos, 2, 0, indentation, - "read: bad %sregexp string: %s", + scheme_read_err(port, "read: bad %sregexp string `%s`", (orig_ch == 'r') ? "" : "p", (char *)str); return NULL; } - if (stxsrc) { - str = scheme_intern_literal_string(str); - str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - return str; } - } else if ((orig_ch == 'r') && (ch == 'e')) { - expect = "eader"; - cnt++; - while (expect[cnt]) { - ch = scheme_getc_special_ok(port); - if (ch != expect[cnt]) - break; - cnt++; - } - if (!expect[cnt]) { - /* Found #reader. Read an S-exp. */ - Scheme_Object *v; - - if (!params->can_read_reader) { - scheme_read_err(port, stxsrc, line, col, pos, 7, 0, indentation, - "read: #reader" NOT_ENABLED_str); - return NULL; - } - - v = read_reader(port, stxsrc, line, col, pos, ht, indentation, params); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; - } } else expect = ""; @@ -1719,9 +793,7 @@ a[cnt++] = ch; } - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, - "read: bad syntax `#%c%u'", + scheme_read_err(port, "read: bad syntax `#%c%u`", orig_ch, a, (intptr_t)cnt); return NULL; } @@ -1729,26 +801,23 @@ break; case 'h': { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch != 'a') { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: expected `a' after #h"); + scheme_read_err(port, "read: expected `a` after `#h`"); return NULL; } else { GC_CAN_IGNORE const mzchar str[] = { 's', 'h', 'e', 'q', 'v', 0 }; int scanpos = 0, failed = 0; do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((mzchar)ch == str[scanpos]) { scanpos++; } else { if ((scanpos == 2) || (scanpos == 4)) { - int effective_ch; - effective_ch = readtable_effective_char(table, ch); - if (!(effective_ch == '(') - && !(effective_ch == '[' && params->square_brackets_are_parens) - && !(effective_ch == '{' && params->curly_braces_are_parens)) + if (!(ch == '(') + && !(ch == '[') + && !(ch == '{')) failed = 1; } else failed = 1; @@ -1758,13 +827,11 @@ if (!failed) { /* Found recognized tag. Look for open paren... */ - int effective_ch, kind; + int kind; if (scanpos > 4) - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); - effective_ch = readtable_effective_char(table, ch); - if (scanpos == 4) kind = 0; else if (scanpos == 2) @@ -1772,12 +839,12 @@ else kind = 2; - if (effective_ch == '(') - return read_hash(port, stxsrc, line, col, pos, ch, ')', kind, ht, indentation, params, table); - if (effective_ch == '[' && params->square_brackets_are_parens) - return read_hash(port, stxsrc, line, col, pos, ch, ']', kind, ht, indentation, params, table); - if (effective_ch == '{' && params->curly_braces_are_parens) - return read_hash(port, stxsrc, line, col, pos, ch, '}', kind, ht, indentation, params, table); + if (ch == '(') + return read_hash(port, ch, ')', kind, params); + if (ch == '[') + return read_hash(port, ch, ']', kind, params); + if (ch == '{') + return read_hash(port, ch, '}', kind, params); } /* Report an error. So far, we read 'ha', then scanpos chars of str, then ch. */ @@ -1792,9 +859,7 @@ } else one_more[0] = 0; - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, - "read: bad syntax `#ha%5%u'", + scheme_read_err(port, "read: bad syntax `#ha%5%u'", str_part, one_more, (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0)); return NULL; @@ -1803,294 +868,63 @@ } break; case '"': - return read_string(1, port, stxsrc, line, col, pos, ht, indentation, params, table, 1); - break; - case '<': - if (scheme_peekc_special_ok(port) == '<') { - /* Here-string */ - ch = scheme_getc_special_ok(port); - return read_here_string(port, stxsrc, line, col, pos,indentation, params); - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#<'"); - return NULL; - } - break; - case '!': - ch = scheme_getc_special_ok(port); - if ((ch == ' ') || (ch == '/')) { - /* line comment, with '\' as a continuation */ - int was_backslash = 0, was_backslash_cr = 0; - while(1) { - was_backslash_cr = 0; - ch = scheme_getc_special_ok(port); - if (ch == EOF) { - break; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - } else if (ch == '\r') { - if (was_backslash) { - was_backslash_cr = 1; - } else - break; - } else if (ch == '\n') { - if (!was_backslash && !was_backslash_cr) - break; + return read_string(1, port, params, 1); + default: + if (ch == '(') + return read_vector(port, ch, ')', params, 0); + else if (ch == '[') + return read_vector(port, ch, ']', params, 0); + else if (ch == '{') + return read_vector(port, ch, '}', params, 0); + else if (isdigit_ascii(ch)) { + /* graph definition or reference */ + int nch = ch, index; + Scheme_Object *val; + + index = read_graph_index(port, &nch); + switch (nch) { + case '#': + if (params->graph_ht) + val = scheme_hash_get(params->graph_ht, scheme_make_integer(index)); + else + val = NULL; + if (!val) + scheme_read_err(port, + "read: no value for `#%d#`", + index); + return val; + case '=': + if (!params->graph_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + params->graph_ht = ht; } - was_backslash = (ch == '\\'); - } - if (comment_mode & RETURN_FOR_COMMENT) - return NULL; - goto start_over; - } else if ((ch < 128) && is_lang_nonsep_char(ch)) { - Scheme_Object *v; - if (!params->can_read_reader - || !params->can_read_lang) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #!" NOT_ENABLED_str); + if (scheme_hash_get(params->graph_ht, scheme_make_integer(index))) + scheme_read_err(port, + "read: duplicate `#%d=` definition", + index); + val = read_inner(port, params, -1); + scheme_hash_set(params->graph_ht, scheme_make_integer(index), val); + return val; + default: + scheme_read_err(port, + "read: expected `=` or `#` after `#%d`, found `%c`", + index, nch); return NULL; } - v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, ch); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; + } else { - if (NOT_EOF_OR_SPECIAL(ch)) - scheme_read_err(port, stxsrc, line, col, pos, 3, - ch, indentation, "read: bad syntax `#!%c'", ch); - else - scheme_read_err(port, stxsrc, line, col, pos, 2, - ch, indentation, "read: bad syntax `#!'", ch); + scheme_read_err(port, "read: bad syntax `#%c`", ch); return NULL; } - break; - default: - { - int vector_length = -1; - int overflow = 0, digits = 0, effective_ch; - mzchar tagbuf[64], vecbuf[64]; /* just for errors */ - effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); - - if (effective_ch == '(') - return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - if (effective_ch == '[' && params->square_brackets_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - if (effective_ch == '{' && params->curly_braces_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - - if (ch == '#' && (vector_length != -1)) { - /* Not a vector after all: a graph reference */ - Scheme_Object *ph; - - if (stxsrc) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..# expressions not allowed in read-syntax mode"); - - if (!params->can_read_graph) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..# expressions" NOT_ENABLED_str); - - if (digits > MAX_GRAPH_ID_DIGITS) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: graph id too long in #%5#", - tagbuf); - - if (*ht) - ph = (Scheme_Object *)scheme_hash_get(*ht, scheme_make_integer(vector_length)); - else - ph = NULL; - - if (!ph) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: no #%d= preceding #%d#", - vector_length, vector_length); - return scheme_void; - } - return ph; - } - if (ch == '=' && (vector_length != -1)) { - /* Not a vector after all: a graph definition */ - Scheme_Object *v, *ph; - intptr_t in_pos; - - if (stxsrc) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..= expressions not allowed in read-syntax mode"); - - if (!params->can_read_graph) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..= expressions" NOT_ENABLED_str); - - if (digits > MAX_GRAPH_ID_DIGITS) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: graph id too long in #%s=", - tagbuf); - - if (*ht) { - if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: multiple #%d= tags", - vector_length); - return NULL; - } - } else { - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } - ph = scheme_alloc_small_object(); - ph->type = scheme_placeholder_type; - - scheme_hash_set(*ht, scheme_make_integer(vector_length), (void *)ph); - - scheme_tell_all(port, NULL, NULL, &in_pos); - - v = read_inner(port, stxsrc, ht, indentation, params, 0); - if (SCHEME_EOFP(v)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, in_pos-pos), EOF, indentation, - "read: expected an element for graph (found end-of-file)"); - SCHEME_PTR_VAL(ph) = v; - - return v; - } - - { - char *lbuffer; - int pch = ch, ulen, blen; - - if ((pch == EOF) || (pch == SCHEME_SPECIAL)) - pch = 0; - - ulen = scheme_char_strlen(tagbuf); - blen = scheme_utf8_encode_all(tagbuf, ulen, NULL); - lbuffer = (char *)scheme_malloc_atomic(blen + MAX_UTF8_CHAR_BYTES + 1); - scheme_utf8_encode_all(tagbuf, ulen, (unsigned char *)lbuffer); - blen += scheme_utf8_encode((mzchar *)&pch, 0, 1, - (unsigned char *)lbuffer, blen, - 0); - lbuffer[blen] = 0; - - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: bad syntax `#%s'", - lbuffer); - - return NULL; - } - } - break; } - break; default: - if (isdigit_ascii(ch)) - special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table); - else - special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; - } - - /* We get here after reading a "symbol". Check for a comment. */ - { - Scheme_Object *v = special_value; - - if (scheme_special_comment_value(v)) { - /* a "comment" */ - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - else { - special_value_need_copy = 0; - goto start_over; - } - } else if (SCHEME_STXP(v)) { - if (!stxsrc) - v = scheme_syntax_to_datum(v, 0, NULL); - } else if (stxsrc) { - Scheme_Object *s; - s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - v = scheme_datum_to_syntax(v, s, scheme_false, 1, 0); - } - if (special_value_need_copy && !stxsrc) { - set_need_copy(ht); - } - return v; - } -} - -static Scheme_Object * -read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode, int pre_char, Readtable *table, - int get_info) -{ - intptr_t rline = 0, rcol = 0, rpos = 0; - intptr_t dline = 0, dcol = 0, dpos = 0; - Scheme_Object *ret; - int read_cdot, next, found_dot; - - read_cdot = params->read_cdot; - - scheme_tell_all(port, &rline, &rcol, &rpos); - ret = read_inner_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); - - if (!read_cdot) { return ret; } - - // read in zero or more . sequences in a left-associative way - // X.Y should be read as (#%dot X Y) - // X.Y.Z should be read as (#%dot (#%dot X Y) Z) - while ( 1 ) { - found_dot = 0; - while ( 1 ) { - next = scheme_peekc_special_ok(port); - if ( next == EOF ) { break; } - if ( (table && readtable_kind(table, next, params) & READTABLE_WHITESPACE) - || (!table && scheme_isspace(next)) ) { - scheme_getc_special_ok(port); continue; } - if ( (table && readtable_effective_char(table, next) == '.') - || (!table && next == '.') ) { - scheme_getc_special_ok(port); found_dot = 1; break; } - break; - } - - if ( !found_dot ) { - return ret; - } else { - Scheme_Object *dot, *next; - - scheme_tell_all(port, &dline, &dcol, &dpos); - dot = dot_symbol; - if (stxsrc) { - dot = scheme_make_stx_w_offset(dot, dline, dcol, dpos, SPAN(port,dpos), stxsrc, STX_SRCTAG); - } - next = read_inner_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); - if (SCHEME_EOFP(next)) { - scheme_read_err(port, stxsrc, dline, dcol, dpos, 1, EOF, indentation, - "read: expected a datum after cdot, found end-of-file"); - return NULL; - } else { - ret = scheme_make_pair( dot, scheme_make_pair( ret, scheme_make_pair( next, scheme_null ) ) ); - } - if (stxsrc) { - ret = scheme_make_stx_w_offset(ret, rline, rcol, rpos, SPAN(port,rpos), stxsrc, STX_SRCTAG); - } + return read_number_or_symbol(ch, port, 0, 0, 10, 0, 0, 0, params); } - - // look for more dots after this - continue; - } -} - -static Scheme_Object * -read_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode) -{ - return read_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, -1, params->table, 0); } #ifdef DO_STACK_CHECK static Scheme_Object *resolve_references(Scheme_Object *obj, - Scheme_Object *port, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, @@ -2102,24 +936,21 @@ { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *port = (Scheme_Object *)p->ku.k.p2; Scheme_Object *top = (Scheme_Object *)p->ku.k.p5; Scheme_Hash_Table *dht = (Scheme_Hash_Table *)p->ku.k.p3; Scheme_Hash_Table *tht = (Scheme_Hash_Table *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4); Scheme_Hash_Table *self_contained_ht = (Scheme_Hash_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - return resolve_references(o, port, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2); + return resolve_references(o, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2); } #endif static Scheme_Object *resolve_references(Scheme_Object *obj, - Scheme_Object *port, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, @@ -2135,7 +966,6 @@ { Scheme_Thread *p = scheme_current_thread; p->ku.k.p1 = (void *)obj; - p->ku.k.p2 = (void *)port; p->ku.k.p5 = (void *)top; p->ku.k.p3 = (void *)dht; result = scheme_make_pair((Scheme_Object *)tht, @@ -2155,15 +985,10 @@ while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) { obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); if (SAME_OBJ(start, obj)) { - if (port) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read: illegal placeholder cycle"); - else { - scheme_contract_error("make-reader-graph", - "illegal placeholder cycle in value", - "value", 1, top, - NULL); - } + scheme_contract_error("make-reader-graph", + "illegal placeholder cycle in value", + "value", 1, top, + NULL); return NULL; } } @@ -2192,13 +1017,13 @@ result = scheme_make_pair(scheme_false, scheme_false); scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_CAR(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_CAR(obj), top, dht, tht, self_contained_ht, clone, tail_depth + 1); SCHEME_CAR(result) = rr; scheme_hash_set(tht, result, scheme_make_integer(tail_depth)); - rr = resolve_references(SCHEME_CDR(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_CDR(obj), top, dht, tht, self_contained_ht, clone, tail_depth); SCHEME_CDR(result) = rr; @@ -2221,7 +1046,7 @@ } scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_BOX_VAL(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_BOX_VAL(obj), top, dht, tht, self_contained_ht, clone, tail_depth + 1); SCHEME_BOX_VAL(result) = rr; @@ -2254,7 +1079,7 @@ rr = prev_rr; } else { prev_v = SCHEME_VEC_ELS(obj)[i]; - rr = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + rr = resolve_references(prev_v, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (!SAME_OBJ(prev_v, rr)) diff = 1; @@ -2308,7 +1133,7 @@ result = (Scheme_Object *)t; scheme_hash_set(dht, obj, result); - lst = resolve_references(lst, port, top, dht, tht, self_contained_ht, + lst = resolve_references(lst, top, dht, tht, self_contained_ht, clone, tail_depth + 1); for (; SCHEME_PAIRP(lst); lst = SCHEME_CDR(lst)) { @@ -2341,7 +1166,7 @@ } orig_l = l; - l = resolve_references(l, port, top, dht, tht, self_contained_ht, + l = resolve_references(l, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (SAME_OBJ(l, orig_l)) { @@ -2377,7 +1202,7 @@ diff = 0; for (i = 0; i < c; i++) { prev_v = ((Scheme_Structure *)result)->slots[i]; - v = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + v = resolve_references(prev_v, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (!SAME_OBJ(prev_v, v)) diff = 1; @@ -2395,152 +1220,37 @@ } static Scheme_Object * -_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fail, - int recur, int expose_comment, int extra_char, - Scheme_Object *init_readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, - Scheme_Object *delay_load_info, int get_info) +_internal_read(Scheme_Object *port, int crc, int cant_fail, + int extra_char, + Scheme_Object *delay_load_info) { Scheme_Object *v, *v2; - Scheme_Config *config; - Scheme_Hash_Table **ht = NULL; ReadParams params; - config = scheme_current_config(); - - if (get_info) { - params.table = NULL; - } else { - v = scheme_get_param(config, MZCONFIG_READTABLE); - if (SCHEME_TRUEP(v)) - params.table = (Readtable *)v; - else - params.table = NULL; - } if (crc >= 0) { - params.can_read_compiled = crc; params.can_read_unsafe = 1; } else { - v = scheme_get_param(scheme_current_config(), MZCONFIG_CAN_READ_COMPILED); - params.can_read_compiled = SCHEME_TRUEP(v); - if (v) { - v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - v2 = scheme_get_initial_inspector(); - params.can_read_unsafe = SAME_OBJ(v, v2); - } else - params.can_read_unsafe = 0; + v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v2 = scheme_get_initial_inspector(); + params.can_read_unsafe = SAME_OBJ(v, v2); } - v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE); - params.can_read_pipe_quote = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_BOX); - params.can_read_box = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_GRAPH); - params.can_read_graph = SCHEME_TRUEP(v); - if ((crc > 0) || get_info) { - params.can_read_reader = 1; - params.can_read_lang = 1; - } else { - v = scheme_get_param(config, MZCONFIG_CAN_READ_READER); - params.can_read_reader = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_LANG); - params.can_read_lang = SCHEME_TRUEP(v); - } - v = scheme_get_param(config, MZCONFIG_CASE_SENS); - params.case_sensitive = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS); - params.square_brackets_are_parens = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_PARENS); - params.curly_braces_are_parens = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); - params.square_brackets_are_tagged = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED); - params.curly_braces_are_tagged = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_READ_CDOT); - params.read_cdot = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_READ_DECIMAL_INEXACT); - params.read_decimal_inexact = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_QUASI); - params.can_read_quasi = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_DOT); - params.can_read_dot = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_INFIX_DOT); - params.can_read_infix_dot = SCHEME_TRUEP(v); params.read_relative_path = NULL; if (!delay_load_info) - delay_load_info = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO); + delay_load_info = scheme_get_param(scheme_current_config(), MZCONFIG_DELAY_LOAD_INFO); if (SCHEME_TRUEP(delay_load_info)) params.delay_load_info = delay_load_info; else params.delay_load_info = NULL; params.skip_zo_vers_check = cant_fail; - params.magic_sym = magic_sym; - params.magic_val = magic_val; - - ht = NULL; - if (recur) { - /* Check whether this is really a recursive call. If so, - we get a pointer to a hash table for cycles: */ - v = scheme_extract_one_cc_mark(NULL, unresolved_uninterned_symbol); - if (v && SCHEME_RPAIRP(v)) { - if (SCHEME_FALSEP(SCHEME_CDR(v)) == !stxsrc) - ht = (Scheme_Hash_Table **)SCHEME_CAR(v); - } - } - if (!ht) { - ht = MALLOC_N(Scheme_Hash_Table *, 1); - recur = 0; - } - - do { - v = read_inner_inner(port, stxsrc, ht, scheme_null, ¶ms, - (RETURN_FOR_HASH_COMMENT - | (expose_comment ? (RETURN_FOR_COMMENT | RETURN_FOR_SPECIAL_COMMENT) : 0)), - extra_char, - (init_readtable - ? (SCHEME_FALSEP(init_readtable) - ? NULL - : (Readtable *)init_readtable) - : params.table), - get_info); - - extra_char = -1; - - if (*ht && !recur) { - /* Resolve placeholders: */ - int clone = 0; - Scheme_Hash_Table *dht, *tht; - - if (stxsrc) - scheme_signal_error("internal error: read-syntax has graph references"); - - /* If we ever called an external reader, - then we need to clone everything. */ - if (scheme_hash_get(*ht, tainted_uninterned_symbol)) - clone = 1; - - dht = scheme_make_hash_table(SCHEME_hash_ptr); - tht = scheme_make_hash_table(SCHEME_hash_ptr); - - if (v) - v = resolve_references(v, port, NULL, dht, tht, NULL, clone, 0); - - /* In case some placeholders were introduced by #;: */ - v2 = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (v2) - resolve_references(v2, port, NULL, dht, tht, NULL, clone, 0); - - if (!v) - *ht = NULL; - } + params.graph_ht = NULL; - if (!v && expose_comment) { - /* Return to indicate comment: */ - v = scheme_alloc_small_object(); - v->type = scheme_special_comment_type; - SCHEME_PTR_VAL(v) = scheme_false; - return v; - } - } while (!v); + v = read_inner(port, ¶ms, extra_char); + + if (params.graph_ht) + v = resolve_references(v, NULL, + scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + NULL, 0, 0); return v; } @@ -2549,52 +1259,28 @@ { Scheme_Thread *p = scheme_current_thread; Scheme_Object *port = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *init_readtable = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *magic_sym = (Scheme_Object *)p->ku.k.p4; - Scheme_Object *magic_val = NULL; Scheme_Object *delay_load_info = (Scheme_Object *)p->ku.k.p5; p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - if (magic_sym) { - magic_val = SCHEME_CDR(magic_sym); - magic_sym = SCHEME_CAR(magic_sym); - } - - return (void *)_internal_read(port, stxsrc, p->ku.k.i1, 0, - p->ku.k.i3 & 0x2, p->ku.k.i3 & 0x1, - p->ku.k.i4, init_readtable, - magic_sym, magic_val, delay_load_info, 0); + return (void *)_internal_read(port, p->ku.k.i1, 0, p->ku.k.i4, delay_load_info); } Scheme_Object * -scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, - int recur, int expose_comment, int pre_char, - Scheme_Object *init_readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, +scheme_internal_read(Scheme_Object *port, int crc, int cantfail, + int pre_char, Scheme_Object *delay_load_info) { Scheme_Thread *p = scheme_current_thread; if (cantfail) { - return _internal_read(port, stxsrc, crc, cantfail, recur, expose_comment, -1, NULL, - magic_sym, magic_val, delay_load_info, 0); + return _internal_read(port, crc, cantfail, -1, delay_load_info); } else { - if (magic_sym) - magic_sym = scheme_make_pair(magic_sym, magic_val); - p->ku.k.p1 = (void *)port; - p->ku.k.p2 = (void *)stxsrc; p->ku.k.i1 = crc; - p->ku.k.i3 = ((recur ? 0x2 : 0) | (expose_comment ? 0x1 : 0)); p->ku.k.i4 = pre_char; - p->ku.k.p3 = (void *)init_readtable; - p->ku.k.p4 = (void *)magic_sym; p->ku.k.p5 = (void *)delay_load_info; return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0); @@ -2603,17 +1289,24 @@ Scheme_Object *scheme_read(Scheme_Object *port) { - return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); + Scheme_Object *read_proc, *a[1]; + read_proc = scheme_get_startup_export("read"); + a[0] = port; + return scheme_apply(read_proc, 1, a); } Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc) { - return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); + Scheme_Object *read_syntax_proc, *a[2]; + read_syntax_proc = scheme_get_startup_export("read-syntax"); + a[0] = stxsrc; + a[1] = port; + return scheme_apply(read_syntax_proc, 2, a); } Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj) { - return resolve_references(obj, NULL, obj, + return resolve_references(obj, obj, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), NULL, @@ -2624,312 +1317,80 @@ /* list reader */ /*========================================================================*/ -static Scheme_Object *attach_shape_property(Scheme_Object *list, - Scheme_Object *stxsrc, - ReadParams *params, - int closer); - -static Scheme_Object *attach_shape_tag(Scheme_Object *list, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *stxsrc, - ReadParams *params, - int closer, int shape); - -static int next_is_delim(Scheme_Object *port, - ReadParams *params, - int brackets, - int braces) +static int next_is_delim(Scheme_Object *port) { int next; - next = scheme_peekc_special_ok(port); + next = scheme_peekc(port); return ((next == EOF) || (next == SCHEME_SPECIAL) - || (!params->table - && (scheme_isspace(next) - || (next == '(') - || (next == ')') - || (next == '"') - || (next == ';') - || (next == '\'') - || (next == '`') - || (next == ',') - || ((next == '[') && brackets) - || ((next == '{') && braces) - || ((next == ']') && brackets) - || ((next == '}') && braces))) - || (params->table - && (readtable_kind(params->table, next, params) - & (READTABLE_WHITESPACE | READTABLE_TERMINATING)))); -} - -static const char *mapping_name(ReadParams *params, int ch, const char *def, int name_pos) -{ - if (params->table) { - int i; - char *buf = ""; - Scheme_Object *v; - Scheme_Hash_Table *mapping; - - if (params->table->names) { - if (params->table->names[name_pos]) - return params->table->names[name_pos]; - } - - mapping = params->table->mapping; - if (!scheme_hash_get(mapping, scheme_make_integer(ch))) { - buf = (char *)scheme_malloc_atomic(4); - sprintf(buf, "`%c'", ch); - } - - for (i = mapping->size; i--; ) { - if (mapping->vals[i]) { - v = mapping->vals[i]; - if ((SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) - && (SCHEME_INT_VAL(SCHEME_CDR(v)) == ch)) { - int len; - mzchar a[2]; - char *naya, utf8_buf[MAX_UTF8_CHAR_BYTES + 1]; - - v = mapping->keys[i]; - a[0] = (mzchar)SCHEME_INT_VAL(v); - len = scheme_utf8_encode_all(a, 1, (unsigned char *)utf8_buf); - utf8_buf[len] = 0; - - naya = (char *)scheme_malloc_atomic(len + 5 + strlen(buf)); - sprintf(naya, "`%s'", utf8_buf); - if (*buf) { - sprintf(naya XFORM_OK_PLUS len + 2, " or %s", buf); - } - buf = naya; - } - } - } - - if (!params->table->names) { - char **a; - a = MALLOC_N(char*, 7); - params->table->names = a; - } - params->table->names[name_pos] = buf; - - return buf; - } else - return def; -} - -static const char *closer_name(ReadParams *params, int closer) -{ - int pos; - const char *def; - - switch (closer) { - case ')': - pos = 0; - def = "`)'"; - break; - case ']': - pos = 1; - def = "`]'"; - break; - case '}': - default: - pos = 2; - def = "`}'"; - break; - } - - return mapping_name(params, closer, def, pos); -} - -static const char *opener_name(ReadParams *params, int opener) -{ - int pos; - const char *def; - - switch (opener) { - case '(': - pos = 3; - def = "`('"; - break; - case '[': - pos = 4; - def = "`['"; - break; - case '{': - default: - pos = 5; - def = "`{'"; - break; - } - - return mapping_name(params, opener, def, pos); -} - -static const char *dot_name(ReadParams *params) -{ - return mapping_name(params, '.', "`.'", 6); + || (scheme_isspace(next) + || (next == '(') + || (next == ')') + || (next == '"') + || (next == ';') + || (next == '\'') + || (next == '`') + || (next == ',') + || ((next == '[')) + || ((next == '{')) + || ((next == ']')) + || ((next == '}')))); } /* "(" (or other opener) has already been read */ static Scheme_Object * read_list(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, int opener, int closer, int shape, int use_stack, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) -{ - Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL; - int ch = 0, got_ch_already = 0, effective_ch; - int brackets = params->square_brackets_are_parens || params->square_brackets_are_tagged; - int braces = params->curly_braces_are_parens || params->curly_braces_are_tagged; - intptr_t start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col, init_span; - - scheme_tell_all(port, &startline, &startcol, &start); - init_span = 1; - - if (stxsrc) { - /* Push onto the indentation stack: */ - Scheme_Indent *indt; - indt = (Scheme_Indent *)scheme_malloc_atomic_tagged(sizeof(Scheme_Indent)); - indt->type = scheme_indent_type; - - indt->closer = closer; - indt->max_indent = startcol + 1; - indt->multiline = 0; - indt->suspicious_line = 0; - indt->suspicious_quote = 0; - indt->start_line = startline; - indt->last_line = startline; - - indentation = scheme_make_pair((Scheme_Object *)indt, indentation); - } + ReadParams *params) +{ + Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL; + int ch = 0, got_ch_already = 0; while (1) { - if (prefetched) - ch = 0; - else if (got_ch_already) + if (got_ch_already) got_ch_already = 0; else - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); + ch = skip_whitespace_comments(port, params); if ((ch == EOF) && (closer != EOF)) { - char *suggestion = ""; - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - if (indt->suspicious_line) { - suggestion = scheme_malloc_atomic(100); - sprintf(suggestion, - "\n possible cause: indentation suggests a missing %s before line %" PRIdPTR, - closer_name(params, indt->suspicious_closer), - indt->suspicious_line); - } - } - - scheme_read_err(port, stxsrc, startline, startcol, start, MINSPAN(port, start, init_span), EOF, indentation, - "read: expected a %s to close `%c'%s", - closer_name(params, closer), - opener, - suggestion); + scheme_read_err(port, "read: expected a `%c` to close `%c`", closer, opener); return NULL; } - effective_ch = readtable_effective_char(table, ch); - - if (effective_ch == closer) { + if (ch == closer) { if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected hash pair (with key and value separated by %s) before `%c'", - dot_name(params), - ch); + scheme_read_err(port, "read: expected hash pair (with key and value separated by `.`) before `%c`", ch); return NULL; } if (!list) list = scheme_null; - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; } if (shape == mz_shape_hash_list) { /* Make sure we found a parenthesized something. */ - if (!(effective_ch == '(') - && !(effective_ch == '[' && params->square_brackets_are_parens) - && !(effective_ch == '{' && params->curly_braces_are_parens)) { - intptr_t xl, xc, xp; - const char *sbname, *cbname; - - /* If it's a special or we have a readtable, we need to read ahead - to make sure that it's not a comment. For consistency, always - read ahead. */ - scheme_ungetc(ch, port); - prefetched = read_inner(port, stxsrc, ht, indentation, params, - RETURN_FOR_SPECIAL_COMMENT); - if (!prefetched) - continue; /* It was a comment; try again. */ - - sbname = (params->square_brackets_are_parens ? opener_name(params, '[') : ""); - cbname = (params->curly_braces_are_parens ? opener_name(params, '{') : ""); - - scheme_tell_all(port, &xl, &xc, &xp); - scheme_read_err(port, stxsrc, xl, xc, xp, 1, - ch, indentation, - "read: expected %s%s%s%s%s to start a hash pair", - opener_name(params, '('), - params->square_brackets_are_parens ? " or " : "", - sbname, - params->curly_braces_are_parens ? " or " : "", - cbname); + if (!(ch == '(') + && !(ch == '[') + && !(ch == '{')) { + scheme_read_err(port, "read: expected `(`, `[`, or `{` to start a hash pair"); return NULL; } else { /* Found paren. Use read_list directly so we can specify mz_shape_hash_elem. */ - intptr_t xl, xc, xp; - scheme_tell_all(port, &xl, &xc, &xp); - car = read_list(port, stxsrc, xl, xc, xp, - ch, ((effective_ch == '(') ? ')' : ((effective_ch == '[') ? ']' : '}')), - mz_shape_hash_elem, use_stack, ht, indentation, params, table); + car = read_list(port, + ch, ((ch == '(') ? ')' : ((ch == '[') ? ']' : '}')), + mz_shape_hash_elem, use_stack, params); /* car is guaranteed to have an appropriate shape */ } } else { - if (prefetched) { - car = prefetched; - prefetched = NULL; - } else { - scheme_ungetc(ch, port); - switch (shape) { - case mz_shape_fl_vec: - car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - MZ_ASSERT(SCHEME_DBLP(car)); - break; - case mz_shape_fx_vec: - car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - MZ_ASSERT(SCHEME_INTP(car)); - break; - default: - car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - } - if (!car) continue; /* special was a comment */ - } + car = read_inner(port, params, ch); /* can't be eof, due to check above */ } pair = scheme_make_pair(car, scheme_null); - retry_before_dot: - - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == closer) { + ch = skip_whitespace_comments(port, params); + if (ch == closer) { if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s and value for hash before `%c'", - dot_name(params), - ch); + scheme_read_err(port, "read: expected `.` and value for hash before `%c`", ch); return NULL; } @@ -2940,58 +1401,32 @@ SCHEME_CDR(last) = cdr; if (infixed) { - /* Assert: we're not using the list stack */ list = scheme_make_pair(infixed, list); } - - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; - } else if (params->can_read_dot - && (effective_ch == '.') - && next_is_delim(port, params, brackets, braces)) { - int dot_ch = ch; - - scheme_tell_all(port, &dotline, &dotcol, &dotpos); - - track_indentation(indentation, dotline, dotcol); - + } else if ((ch == '.') + && next_is_delim(port)) { if (((shape != mz_shape_cons) && (shape != mz_shape_hash_elem) && (shape != mz_shape_vec_plus_infix)) || infixed) { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, 0, indentation, - "read: illegal use of `%c'", - dot_ch); + scheme_read_err(port, "read: illegal use of `.`"); return NULL; } /* can't be eof, due to check above: */ - cdr = read_inner(port, stxsrc, ht, indentation, params, 0); - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); - effective_ch = readtable_effective_char(table, ch); - if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { - if (params->can_read_infix_dot - && (effective_ch == '.') - && next_is_delim(port, params, brackets, braces)) { + cdr = read_inner(port, params, -1); + ch = skip_whitespace_comments(port, params); + if ((ch != closer) || (shape == mz_shape_vec_plus_infix)) { + if ((ch == '.') + && next_is_delim(port)) { /* Parse as infix: */ if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s after hash value", - closer_name(params, closer)); + scheme_read_err(port, "read: expected `%c` after hash value", closer); return NULL; } - { - scheme_tell_all(port, &dot2line, &dot2col, &dot2pos); - track_indentation(indentation, dot2line, dot2col); - } - infixed = cdr; if (!list) @@ -3001,19 +1436,14 @@ last = pair; /* Make sure there's not a closing paren immediately after the dot: */ - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); - effective_ch = readtable_effective_char(table, ch); - if ((effective_ch == closer) || (ch == EOF)) { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, - "read: illegal use of `%c'", ch); + ch = skip_whitespace_comments(port, params); + if ((ch == closer) || (ch == EOF)) { + scheme_read_err(port, "read: illegal use of `%c`", ch); return NULL; } - if (!prefetched) - got_ch_already = 1; + got_ch_already = 1; } else { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, - "read: illegal use of `%c'", - dot_ch); + scheme_read_err(port, "read: illegal use of `.`"); return NULL; } } else { @@ -3025,43 +1455,13 @@ SCHEME_CDR(last) = cdr; /* Assert: infixed is NULL (otherwise we raised an exception above) */ - - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; } } else { - if ((ch == SCHEME_SPECIAL) - || (table - && (ch != EOF) - && (shape != mz_shape_hash_list) - && (shape != mz_shape_fl_vec) - && (shape != mz_shape_fx_vec))) { - /* We have to try the read, because it might be a comment. */ - scheme_ungetc(ch, port); - prefetched = read_inner(port, stxsrc, ht, indentation, params, - RETURN_FOR_SPECIAL_COMMENT); - if (!prefetched) - goto retry_before_dot; - if ((shape == mz_shape_fl_vec) && !SCHEME_DBLP(prefetched)) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: stream produced a non-flonum for flvector"); - } else if ((shape == mz_shape_fx_vec) && !SCHEME_INTP(prefetched)) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: stream produced a non-fixnum for fxvector"); - } - } else { - got_ch_already = 1; - } + got_ch_already = 1; if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s and value for hash", - dot_name(params)); + scheme_read_err(port, "read: expected `.` and value for hash"); return NULL; } @@ -3075,196 +1475,40 @@ } } -static Scheme_Object *attach_shape_property(Scheme_Object *list, - Scheme_Object *stxsrc, - ReadParams *params, - int closer) -{ - if ((closer != ')') && stxsrc) { - Scheme_Object *opener; - opener = ((closer == '}') - ? scheme_paren_shape_preserve_curly - : scheme_paren_shape_preserve_square); - return scheme_stx_property(list, scheme_paren_shape_symbol, opener); - } - return list; -} - -static Scheme_Object *attach_shape_tag(Scheme_Object *list, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *stxsrc, - ReadParams *params, - int closer, int shape) -{ - Scheme_Object *tag; - tag = NULL; - - if (params->square_brackets_are_tagged && closer == ']') { - tag = brackets_symbol; - } else if (params->curly_braces_are_tagged && closer == '}') { - tag = braces_symbol; - } - - if (tag && shape == mz_shape_cons) { - if (stxsrc) { - tag = scheme_make_stx_w_offset(tag, line, col, pos, span, stxsrc, STX_SRCTAG); - } - list = scheme_make_pair(tag, list); - } - - return list; -} - -static Scheme_Object *read_flonum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - intptr_t line = 0, col = 0, pos = 0; - intptr_t line2 = 0, col2 = 0, pos2 = 0; - Scheme_Object *n; - scheme_tell_all(port, &line, &col, &pos); - n = read_number_literal(port, stxsrc, 1, 0, ht, indentation, params, comment_mode); - if (SCHEME_DBLP(n)) - return n; - scheme_tell_all(port, &line2, &col2, &pos2); - scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected flonum, got %V", n); - return NULL; -} - -static Scheme_Object *read_fixnum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - intptr_t line = 0, col = 0, pos = 0; - intptr_t line2 = 0, col2 = 0, pos2 = 0; - Scheme_Object *n; - scheme_tell_all(port, &line, &col, &pos); - n = read_number_literal(port, stxsrc, 0, 1, ht, indentation, params, comment_mode); - if (SCHEME_INTP(n)) - return n; - scheme_tell_all(port, &line2, &col2, &pos2); - scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected fixnum, got %V", n); - return NULL; -} - -static Scheme_Object *read_number_literal(Scheme_Object *port, - Scheme_Object *stxsrc, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - int ch; - intptr_t line = 0, col = 0, pos = 0; - Scheme_Object *special_value = NULL; - Readtable *table; - - table = params->table; - scheme_tell_all(port, &line, &col, &pos); - ch = scheme_getc_special_ok(port); - switch (ch) { - case '+': - case '-': - case '.': /* ^^^ fallthrough ^^^ */ - special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, is_float, is_not_float, ht, indentation, params, table); - break; - case '#': - ch = scheme_getc_special_ok(port); - switch (ch ) { - case 'X': - case 'x': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 16, 1, ht, indentation, params, table); - break; - case 'B': - case 'b': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 2, 1, ht, indentation, params, table); - break; - case 'O': - case 'o': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 8, 1, ht, indentation, params, table); - break; - case 'D': - case 'd': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 1, ht, indentation, params, table); - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected `x', `X', `b', `B', `o', `O', `d', or `D'"); - } - default: - if (isdigit_ascii(ch)) - special_value = read_number(ch, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 0, ht, indentation, params, table); - else - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected a digit, `+', `-', `.', or `#'"); - } - return special_value; -} - /*========================================================================*/ /* string reader */ /*========================================================================*/ /* '"' has already been read */ static Scheme_Object * -read_string(int is_byte, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table, - int err_ok) +read_string(int is_byte, Scheme_Object *port, ReadParams *params, int err_ok) { mzchar *buf, *oldbuf, onstack[32]; - int i, j, n, n1, ch, effective_ch, closer = '"'; - intptr_t size = 31, oldsize, in_pos, init_span; + int i, j, n, n1, ch, closer = '"'; + intptr_t size = 31, oldsize; Scheme_Object *result; - scheme_tell_all(port, NULL, NULL, &in_pos); - init_span = in_pos - pos + 1; - i = 0; buf = onstack; while (1) { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == closer) + ch = scheme_getc(port); + if (ch == closer) break; if (ch == EOF) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation, - "read: expected a closing %s%s", + scheme_read_err(port, "read: expected a closing %s%s", "'\"'", (ch == EOF) ? "" : " after one character"); return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character while reading a %s", - "string"); - return NULL; } /* Note: errors will tend to leave junk on the port, with an open \". */ /* Escape-sequence handling by Eli Barzilay. */ if (ch == '\\') { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation, - "read: expected a closing %s", - "'\"'"); - return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character while reading a %s", - "string"); + scheme_read_err(port, "read: expected a closing %s", "'\"'"); return NULL; } switch ( ch ) { @@ -3278,28 +1522,24 @@ case 't': ch = '\t'; break; case 'v': ch = '\v'; break; case '\r': - if (scheme_peekc_special_ok(port) == '\n') + if (scheme_peekc(port) == '\n') scheme_getc(port); continue; /* <---------- !!!! */ case '\n': continue; /* <---------- !!!! */ case 'x': - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10); - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); scheme_getc(port); /* must be ch */ } ch = n; } else { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: no hex digit following \\x in %s", - "string"); + scheme_read_err(port, "read: no hex digit following \\x in string"); return NULL; } break; @@ -3308,13 +1548,13 @@ if (!is_byte) { int maxc = ((ch == 'u') ? 4 : 8); char initial[9]; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { int count = 1; initial[0] = ch; n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10); while (count < maxc) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { initial[count] = ch; n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); @@ -3329,26 +1569,26 @@ the next part is "\uD..." */ int n2 = -1, sndp = 0; mzchar snd[7]; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == '\\') { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == 'u') { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((ch == 'd') || (ch == 'D')) { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { snd[sndp++] = ch; n2 = (scheme_toupper(ch)-'A'+10); if ((n2 >= 12) && (n2 <= 15)) { n2 = 0xD000 | (n2 << 8); - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { snd[sndp++] = ch; n2 |= ((ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)) << 4); - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n2 |= (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); n = (((n - 0xD800) << 10) + (n2 - 0xDC00)) + 0x10000; @@ -3363,13 +1603,11 @@ } } if (n2 < 0) { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); - else if (NOT_EOF_OR_SPECIAL(ch)) + if (NOT_EOF_OR_SPECIAL(ch)) snd[sndp++] = ch; snd[sndp] = 0; if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: bad or incomplete surrogate-style encoding at `\\u%s%5'", initial, snd); @@ -3384,10 +1622,8 @@ ch = n; } } else { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: no hex digit following \\%c in %s", ((maxc == 4) ? 'u' : 'U'), "string"); @@ -3401,14 +1637,14 @@ n1 = 8*n + ch - '0'; if (n1 > 255) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: escape sequence \\%o out of range in %s", n1, "string"); return NULL; } n = n1; if (j < 2) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (!((ch >= '0') && (ch <= '7'))) { break; } else { @@ -3419,7 +1655,7 @@ ch = n; } else { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: unknown escape sequence \\%c in %s%s", ch, is_byte ? "byte " : "", "string"); @@ -3427,21 +1663,9 @@ } break; } - } else if ((ch == '\n') || (ch == '\r')) { - /* Suspicious string... remember the line */ - if (line > 0) { - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - /* Only remember if there's no earlier suspcious string line: */ - if (!indt->suspicious_quote) { - indt->suspicious_quote = line; - } - } - } } else if (is_byte && (ch > 255)) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: out-of-range character in byte string: %c", ch); return NULL; @@ -3449,7 +1673,7 @@ if (ch < 0) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: out-of-range character in %sstring", is_byte ? "byte " : ""); return NULL; @@ -3480,10 +1704,6 @@ s[i] = 0; result = scheme_make_immutable_sized_byte_string(s, i, 0); } - if (stxsrc) { - result = scheme_intern_literal_string(result); - result = scheme_make_stx_w_offset(result, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } return result; } @@ -3491,170 +1711,42 @@ Scheme_Object *scheme_read_byte_string(Scheme_Object *port) /* used by GRacket */ { - return read_string(1, port, - NULL, 0, 0, 0, - NULL, - NULL, NULL, NULL, - 0); + return read_string(1, port, NULL, 0); } -static Scheme_Object * -read_here_string(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params) - /* #<< has been read already */ -{ - int tlen = 0, len = 0, size = 12; - mzchar *tag, *naya, *s, buf[12], c; - intptr_t in_pos, init_span; - Scheme_Object *str; - - scheme_tell_all(port, NULL, NULL, &in_pos); - init_span = in_pos - pos + 1; - - tag = buf; - while (1) { - c = scheme_getc(port); - if (c == '\n') { - break; - } else if (c == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, 3 + tlen, EOF, indentation, - "read: found end-of-file after #<< and before first and-of-line"); - return NULL; - } else { - if (tlen >= size) { - size *= 2; - naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - memcpy(naya, tag, tlen * sizeof(mzchar)); - tag = naya; - } - tag[tlen++] = c; - } - } - if (!tlen) { - scheme_read_err(port, stxsrc, line, col, pos, 3, 0, indentation, - "read: no characters after #<< before and-of-line"); - return NULL; - } - - size = 10 + tlen; - s = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - while (1) { - c = scheme_getc(port); - if (c == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation, - "read: found end-of-file before terminating %u%s", - tag, - (intptr_t)((tlen > 50) ? 50 : tlen), - (tlen > 50) ? "..." : ""); - return NULL; - } - if (len >= size) { - size *= 2; - naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - memcpy(naya, s, len * sizeof(mzchar)); - s = naya; - } - s[len++] = c; - if ((len >= tlen) - && ((len == tlen) - || (s[len - tlen - 1] == '\n')) - && !memcmp(s XFORM_OK_PLUS (len - tlen), tag, sizeof(mzchar) * tlen)) { - c = scheme_peekc(port); - if ((c == '\r') || (c == '\n') || (c == EOF)) - break; - } - } - - len -= (tlen + 1); - if (len < 0) - len = 0; - - str = scheme_make_immutable_sized_char_string(s, len, 1); - - if (stxsrc) { - str = scheme_intern_literal_string(str); - str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - - return str; -} +/*========================================================================*/ +/* vector reader */ +/*========================================================================*/ -char *scheme_extract_indentation_suggestions(Scheme_Object *indentation) -{ - intptr_t suspicious_quote = 0; - char *suspicions = ""; +/* "#(" has been read */ +static Scheme_Object * +read_vector (Scheme_Object *port, + int opener, char closer, + ReadParams *params, + int allow_infix) +{ + Scheme_Object *lresult, *obj; + Scheme_Object *vec; + int len, i; + + lresult = read_list(port, opener, closer, + (allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec), + 1, params); - /* search back through indentation records to find the - first suspicious quote */ - while (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - indentation = SCHEME_CDR(indentation); - if (indt->suspicious_quote) { - suspicious_quote = indt->suspicious_quote; - } - } + obj = lresult; - if (suspicious_quote) { - suspicions = (char *)scheme_malloc_atomic(64); - sprintf(suspicions, - "newline within %s suggests a missing %s on line %" PRIdPTR, - "string", - "'\"'", - suspicious_quote); + len = scheme_list_length(obj); + + vec = (Scheme_Object *) scheme_make_vector(len, NULL); + for (i = 0; i < len ; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); } - return suspicions; + return vec; } /*========================================================================*/ -/* vector reader */ -/*========================================================================*/ -#define FUNC_NAME read_vector -#define VTYPE_STR "vector" -#define VEC_TYPE Scheme_Object -#define ELMS_TYPE Scheme_Object ** -#define ELM_TYPE Scheme_Object * -#define MZ_SHAPE allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec -#define MK_VEC() (Scheme_Object *) scheme_make_vector(requestLength, NULL) -#define ELMS_SELECTOR SCHEME_VEC_ELS -#define ELM_SELECTOR -#define ELM_MAKE_ZERO scheme_make_integer(0) -#define ELM_STX(elm) scheme_make_stx_w_offset(elm, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); -#define VEC_SIZE SCHEME_VEC_SIZE -#include "read_vector.inc" - -#define FUNC_NAME read_fxvector -#define VTYPE_STR "fxvector" -#define VEC_TYPE Scheme_Object -#define ELMS_TYPE Scheme_Object ** -#define ELM_TYPE Scheme_Object * -#define MZ_SHAPE mz_shape_fx_vec -#define MK_VEC() (Scheme_Object *) scheme_alloc_fxvector(requestLength) -#define ELMS_SELECTOR SCHEME_FXVEC_ELS -#define ELM_SELECTOR -#define ELM_MAKE_ZERO scheme_make_integer(0) -#define ELM_STX(elm) elm -#define VEC_SIZE SCHEME_FXVEC_SIZE -#include "read_vector.inc" - -#define FUNC_NAME read_flvector -#define VTYPE_STR "flvector" -#define VEC_TYPE Scheme_Double_Vector -#define ELMS_TYPE double * -#define ELM_TYPE double -#define MZ_SHAPE mz_shape_fl_vec -#define MK_VEC() scheme_alloc_flvector(requestLength) -#define ELMS_SELECTOR SCHEME_FLVEC_ELS -#define ELM_SELECTOR SCHEME_DBL_VAL -#define ELM_MAKE_ZERO 0.0 -#define ELM_STX(elm) elm -#define VEC_SIZE SCHEME_FLVEC_SIZE -#include "read_vector.inc" - -/*========================================================================*/ /* symbol reader */ /*========================================================================*/ @@ -3665,85 +1757,51 @@ /* nothing has been read, except maybe some flags */ static Scheme_Object * -read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, +read_number_or_symbol(int init_ch, Scheme_Object *port, int is_float, int is_not_float, int radix, int radix_set, - int is_symbol, int is_kw, int pipe_quote, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + int is_symbol, int is_kw, + ReadParams *params) { mzchar *buf, *oldbuf, onstack[MAX_QUICK_SYMBOL_SIZE]; int size, oldsize; - int i, ch, quoted, quoted_ever = 0, running_quote = 0; + int i, ch, quoted_ever = 0, running_quote = 0; int running_quote_ch = 0; - intptr_t rq_pos = 0, rq_col = 0, rq_line = 0; - int case_sens = params->case_sensitive; - int decimal_inexact = params->read_decimal_inexact; - int read_cdot = params->read_cdot; Scheme_Object *o; int delim_ok; int ungetc_ok; int far_char_ok; - int single_escape, multiple_escape, norm_count = 0; - Getc_Fun_r getc_special_ok_fun; - - if (!skip_rt && table) { - /* If the readtable provides a "symbol" reader, then use it: */ - if (table->symbol_parser) { - return readtable_call(1, init_ch, table->symbol_parser, params, - port, stxsrc, line, col, pos, 0, ht, NULL); - /* Special-comment result is handled in main loop. */ - } - } + int single_escape, multiple_escape; + Getc_Fun_r getc_fun; ungetc_ok = scheme_peekc_is_ungetc(port); - if (ungetc_ok) { - getc_special_ok_fun = scheme_getc_special_ok; - } else { - getc_special_ok_fun = scheme_peekc_special_ok; - } + if (ungetc_ok) + getc_fun = scheme_getc; + else + getc_fun = scheme_peekc; i = 0; size = MAX_QUICK_SYMBOL_SIZE - 1; buf = onstack; if (init_ch < 0) - ch = getc_special_ok_fun(port); + ch = getc_fun(port); else { /* Assert: this one won't need to be ungotten */ ch = init_ch; } - if (table) { - far_char_ok = 0; - delim_ok = 0; - } else { - delim_ok = SCHEME_OK; - far_char_ok = 1; - } + delim_ok = SCHEME_OK; + far_char_ok = 1; while (NOT_EOF_OR_SPECIAL(ch) && (running_quote - || (!table - && !scheme_isspace(ch) + || (!scheme_isspace(ch) && (((ch < 128) && (delim[ch] & delim_ok)) - || ((ch >= 128) && far_char_ok)) - && !(!is_float && !is_not_float && !radix_set && read_cdot && ch == '.')) - || (table - && !(!is_float && !is_not_float && !radix_set && read_cdot && readtable_effective_char(table, ch) == '.')))) { - if (table) { - int v; - v = readtable_kind(table, ch, params); - if (!running_quote && (v & (READTABLE_TERMINATING | READTABLE_WHITESPACE))) - break; - single_escape = (v & READTABLE_SINGLE_ESCAPE); - multiple_escape = (v & READTABLE_MULTIPLE_ESCAPE); - } else { - single_escape = (ch == '\\'); - multiple_escape = ((ch == '|') && pipe_quote); - } + || ((ch >= 128) && far_char_ok))))) { + single_escape = (ch == '\\'); + multiple_escape = (ch == '|'); if (!ungetc_ok) { if (init_ch < 0) scheme_getc(port); /* must be a character */ @@ -3752,31 +1810,20 @@ } if (single_escape && !running_quote) { int esc_ch = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, - "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); - return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: non-character following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); + scheme_read_err(port, "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); return NULL; } - quoted = 1; quoted_ever = 1; } else if (multiple_escape && (!running_quote || (ch == running_quote_ch))) { quoted_ever = 1; running_quote = !running_quote; running_quote_ch = ch; - quoted = 0; - - scheme_tell_all(port, &rq_line, &rq_col, &rq_pos); - ch = getc_special_ok_fun(port); + ch = getc_fun(port); continue; /* <-- !!! */ - } else - quoted = 0; + } if (i >= size) { oldsize = size; @@ -3787,76 +1834,25 @@ memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); } - if (!case_sens && !quoted && !running_quote) - norm_count++; - else if (norm_count) { - /* case-normalize the last norm_count characters */ - mzchar *s; - int newlen; - s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen); - if (s != buf) { - if ((i + newlen - norm_count) >= size) { - oldsize = size; - oldbuf = buf; - - size *= 2; - if (size <= (i + newlen - norm_count)) - size = 2 * (i + (newlen - norm_count)); - buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar)); - memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); - } - memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen); - } - i += (newlen - norm_count); - norm_count = 0; - } - buf[i++] = ch; - ch = getc_special_ok_fun(port); - } - - if (running_quote && (ch == SCHEME_SPECIAL)) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: non-character following `%c' in %s", running_quote_ch, - is_kw ? "keyword" : "symbol"); + ch = getc_fun(port); } if (ungetc_ok) scheme_ungetc(ch, port); if (running_quote) { - scheme_read_err(port, stxsrc, rq_line, rq_col, rq_pos, SPAN(port, rq_pos), EOF, indentation, - "read: unbalanced `%c'", running_quote_ch); + scheme_read_err(port, "read: unbalanced `%c`", running_quote_ch); return NULL; } - if (norm_count) { - /* case-normalize the last norm_count characters */ - mzchar *s; - int newlen; - s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen); - if (s != buf) { - oldsize = size; - oldbuf = buf; - size = i + (newlen - norm_count) + 1; - buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar)); - memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); - memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen); - } - i += (newlen - norm_count); - } - buf[i] = '\0'; - if (!quoted_ever && (i == 1) - && (readtable_effective_char(params->table, buf[0]) == '.')) { + if (!quoted_ever && (i == 1) && (buf[0] == '.')) { intptr_t xl, xc, xp; scheme_tell_all(port, &xl, &xc, &xp); - scheme_read_err(port, stxsrc, xl, xc, xp, - 1, 0, indentation, - "read: illegal use of `.'"); + scheme_read_err(port, "read: illegal use of `.'"); return NULL; } @@ -3864,13 +1860,9 @@ o = scheme_false; else { o = scheme_read_number(buf, i, - is_float, is_not_float, decimal_inexact, + is_float, is_not_float, 1 /* decimal_inexact */, radix, radix_set, - port, NULL, 0, - stxsrc, line, col, pos, SPAN(port, pos), - indentation); - if (!SCHEME_INTP(o) && stxsrc) - o = scheme_intern_literal_number(o); + port, NULL, 0); } if (SAME_OBJ(o, scheme_false)) { @@ -3880,72 +1872,57 @@ o = scheme_intern_exact_char_symbol(buf, i); } - if (stxsrc) - o = scheme_make_stx_w_offset(o, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return o; } static Scheme_Object * read_number(int init_ch, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, int is_float, int is_not_float, int radix, int radix_set, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, init_ch < 0, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, is_float, is_not_float, radix, radix_set, 0, 0, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_symbol(int init_ch, - int skip_rt, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, skip_rt, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, 0, 0, 10, 0, 1, 0, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_keyword(int init_ch, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, 1, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, 0, 0, 10, 0, 1, 1, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_delimited_constant(int ch, const mzchar *str, Scheme_Object *v, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params) { int first_ch = ch; int scanpos = 1; if (ch == str[0]) { /* might be `T' instead of `t', for example */ do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((mzchar)ch == str[scanpos]) { scanpos++; } else { @@ -3954,16 +1931,16 @@ } while (str[scanpos]); } else { /* need to show next character to show why it's wrong: */ - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } if (str[scanpos] - || !next_is_delim(port, params, 1, 1)) { + || !next_is_delim(port)) { mzchar str_part[7], one_more[2]; if (!str[scanpos]) { /* get non-delimiter again: */ - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } memcpy(str_part, str XFORM_OK_PLUS 1, (scanpos - 1) * sizeof(mzchar)); @@ -3974,8 +1951,7 @@ } else one_more[0] = 0; - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, + scheme_read_err(port, "read: bad syntax `#%c%5%u'", first_ch, str_part, @@ -3984,9 +1960,7 @@ return NULL; } - return (stxsrc - ? scheme_make_stx_w_offset(v, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : v); + return v; } /*========================================================================*/ @@ -4005,11 +1979,11 @@ return 0; } -static Scheme_Object *make_interned_char(int ch, Scheme_Object *stxsrc) +static Scheme_Object *make_interned_char(int ch, int intern) { if (ch < 256) return scheme_make_character(ch); - else if (stxsrc) + else if (intern) return scheme_intern_literal_number(scheme_make_char(ch)); else return scheme_make_char(ch); @@ -4018,34 +1992,25 @@ /* "#\" has been read */ static Scheme_Object * read_character(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) + ReadParams *params) { int ch, next; - ch = scheme_getc_special_ok(port); - - if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character after #\\"); - return NULL; - } + ch = scheme_getc(port); - next = scheme_peekc_special_ok(port); + next = scheme_peekc(port); if ((ch >= '0' && ch <= '7') && (next >= '0' && next <= '7')) { /* a is the same as next */ int last; - last = (scheme_getc(port) /* is char */, scheme_peekc_special_ok(port)); + last = (scheme_getc(port) /* is char */, scheme_peekc(port)); if (last != SCHEME_SPECIAL) scheme_getc(port); /* must be last */ if (last < '0' || last > '7' || ch > '3') { - scheme_read_err(port, stxsrc, line, col, pos, ((last == EOF) || (last == SCHEME_SPECIAL)) ? 3 : 4, last, indentation, + scheme_read_err(port, "read: bad character constant #\\%c%c%c", ch, next, ((last == EOF) || (last == SCHEME_SPECIAL)) ? ' ' : last); return NULL; @@ -4053,13 +2018,13 @@ ch = ((ch - '0') << 6) + ((next - '0') << 3) + (last - '0'); - return make_interned_char(ch, stxsrc); + return make_interned_char(ch, 0); } if (((ch == 'u') || (ch == 'U')) && NOT_EOF_OR_SPECIAL(next) && scheme_isxdigit(next)) { int count = 0, n = 0, nbuf[10], maxc = ((ch == 'u') ? 4 : 8); while (count < maxc) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { nbuf[count] = ch; n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); @@ -4072,7 +2037,7 @@ if ((n < 0) || ((n >= 0xD800) && (n <= 0xDFFF)) || (n > 0x10FFFF)) { - scheme_read_err(port, stxsrc, line, col, pos, count + 2, 0, indentation, + scheme_read_err(port, "read: bad character constant #\\%c%u", (maxc == 4) ? 'u' : 'U', nbuf, (intptr_t)count); @@ -4088,7 +2053,7 @@ i = 1; buf = onstack; buf[0] = ch; - while ((ch = scheme_peekc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) { + while ((ch = scheme_peekc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) { scheme_getc(port); /* is alpha character */ if (i >= size) { oldsize = size; @@ -4143,17 +2108,13 @@ break; } - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: bad character constant: #\\%5", - buf); + scheme_read_err(port, "read: bad character constant: #\\%5", buf); } - if (ch == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: expected a character after #\\"); - } + if (ch == EOF) + scheme_read_err(port, "read: expected a character after #\\"); - return make_interned_char(ch, stxsrc); + return make_interned_char(ch, 0); } /*========================================================================*/ @@ -4163,49 +2124,30 @@ /* "'", etc. has been read */ static Scheme_Object * read_quote(char *who, Scheme_Object *quote_symbol, int len, - Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) + Scheme_Object *port, ReadParams *params) { Scheme_Object *obj, *ret; - obj = read_inner(port, stxsrc, ht, indentation, params, 0); + obj = read_inner(port, params, -1); if (SCHEME_EOFP(obj)) - scheme_read_err(port, stxsrc, line, col, pos, len, EOF, indentation, - "read: expected an element for %s (found end-of-file)", - who); - ret = (stxsrc - ? scheme_make_stx_w_offset(quote_symbol, line, col, pos, len, stxsrc, STX_SRCTAG) - : quote_symbol); + scheme_read_err(port, "read: expected an element for %s (found end-of-file)", who); + ret = quote_symbol; ret = scheme_make_pair(ret, scheme_make_pair(obj, scheme_null)); - if (stxsrc) { - ret = scheme_make_stx_w_offset(ret, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } return ret; } /* "#&" has been read */ -static Scheme_Object *read_box(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) +static Scheme_Object *read_box(Scheme_Object *port, ReadParams *params) { Scheme_Object *o, *bx; - o = read_inner(port, stxsrc, ht, indentation, params, 0); + o = read_inner(port, params, -1); if (SCHEME_EOFP(o)) - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: expected an element for #& box (found end-of-file)"); + scheme_read_err(port, "read: expected an element for #& box (found end-of-file)"); bx = scheme_box(o); - if (stxsrc) { - SCHEME_SET_BOX_IMMUTABLE(bx); - bx = scheme_make_stx_w_offset(bx, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - return bx; } @@ -4214,53 +2156,30 @@ /*========================================================================*/ /* "(" has been read */ -static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_hash(Scheme_Object *port, int opener, char closer, int kind, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params) { Scheme_Object *l; + Scheme_Object *key, *val; + Scheme_Hash_Tree *t; /* using mz_shape_hash_list ensures that l is a list of pairs */ - l = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_hash_list, 0, ht, indentation, params, table); + l = read_list(port, opener, closer, mz_shape_hash_list, 0, params); - if (stxsrc) { - Scheme_Object *key, *val; - Scheme_Hash_Tree *t; - - t = scheme_make_hash_tree(kind); - - for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - val = SCHEME_STX_CAR(l); - key = SCHEME_STX_CAR(val); - key = scheme_syntax_to_datum(key, 0, NULL); - val = SCHEME_STX_CDR(val); - - t = scheme_hash_tree_set(t, key, val); - } - - return scheme_make_stx_w_offset((Scheme_Object *)t, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } else { - /* Wait for placeholders to be resolved before mapping keys to - values, because a placeholder may be used in a key. */ - Scheme_Object *ph; - - ph = scheme_alloc_object(); - ph->type = scheme_table_placeholder_type; - SCHEME_IPTR_VAL(ph) = l; - SCHEME_PINT_VAL(ph) = kind; - - if (!*ht) { - /* So that resolve_references is called to build the table: */ - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } + t = scheme_make_hash_tree(kind); - return ph; + for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + val = SCHEME_STX_CAR(l); + key = SCHEME_STX_CAR(val); + key = scheme_syntax_to_datum(key); + key = scheme_expander_syntax_to_datum(key); + val = SCHEME_STX_CDR(val); + + t = scheme_hash_tree_set(t, key, val); } + + return (Scheme_Object *)t; } /*========================================================================*/ @@ -4301,112 +2220,56 @@ /*========================================================================*/ static int -skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table, - Scheme_Object **_prefetched) -/* If `_prefetched` is non_NULL, then a SCHEME_SPECIAL result means that - the special value has already been read, and it wasn't a comment. */ +skip_whitespace_comments(Scheme_Object *port, + ReadParams *params) { - int ch, effective_ch; - int blockc_1, blockc_2; - - blockc_1 = '#'; - blockc_2 = '|'; + int ch; start_over: - if (table) { - while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch))) { - if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) - break; - } - } else { - while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} - } + while ((ch = scheme_getc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == ';') { + if (ch == ';') { do { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); - } while (!is_line_comment_end(effective_ch) && (effective_ch != EOF)); + ch = scheme_getc(port); + } while (!is_line_comment_end(ch) && (ch != EOF)); goto start_over; } - if ((effective_ch == blockc_1) - && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == blockc_2)) { + if ((ch == '#') + && (scheme_peekc(port) == '|')) { int depth = 0; int ch2 = 0; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); (void)scheme_getc(port); /* re-read '|' */ do { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); + ch = scheme_getc(port); - if (effective_ch == EOF) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: end of file in #| comment"); - else if (effective_ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + if (ch == EOF) + scheme_read_err(port, "read: end of file in #| comment"); - if ((ch2 == blockc_2) && (effective_ch == blockc_1)) { + if ((ch2 == '|') && (ch == '#')) { if (!(depth--)) goto start_over; - effective_ch = 0; /* So we don't count '#' toward an opening "#|" */ - } else if ((ch2 == blockc_1) && (ch == blockc_2)) { + ch = 0; /* So we don't count '#' toward an opening "#|" */ + } else if ((ch2 == '#') && (ch == '|')) { depth++; - effective_ch = 0; /* So we don't count '|' toward a closing "|#" */ + ch = 0; /* So we don't count '|' toward a closing "|#" */ } - ch2 = effective_ch; + ch2 = ch; } while (1); goto start_over; } - if ((effective_ch == '#') - && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == ';')) { + if ((ch == '#') + && (scheme_peekc(port) == ';')) { Scheme_Object *skipped; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); - - track_indentation(indentation, line, col); (void)scheme_getc(port); /* re-read ';' */ - skipped = read_inner(port, stxsrc, ht, indentation, params, 0); + skipped = read_inner(port, params, -1); if (SCHEME_EOFP(skipped)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: expected a commented-out element for `#;' (found end-of-file)"); - - /* For resolving graphs introduced in #; : */ - if (*ht) { - Scheme_Object *v; - v = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (!v) - v = scheme_null; - v = scheme_make_pair(skipped, v); - scheme_hash_set(*ht, unresolved_uninterned_symbol, v); - } - - goto start_over; - } - - if ((ch == SCHEME_SPECIAL) && _prefetched) { - Scheme_Object *v; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); - v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); - if (!scheme_special_comment_value(v)) { - *_prefetched = v; - return SCHEME_SPECIAL; - } + scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)"); goto start_over; } @@ -4414,125 +2277,32 @@ return ch; } -static void unexpected_closer(int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params) -{ - char *suggestion = "", *found = "unexpected"; - - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - int opener; - char *missing; - - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - - found = scheme_malloc_atomic(100); - - if (indt->closer == '}') - opener = '{'; - else if (indt->closer == ']') - opener = '['; - else - opener = '('; +static void unexpected_closer(int ch, Scheme_Object *port) +{ + scheme_read_err(port, "read: unexpected `%c`", ch); +} - /* Missing intermediate closers, or just need something else entirely? */ - { - Scheme_Object *l; - Scheme_Indent *indt2; +static int read_graph_index(Scheme_Object *port, int *ch) +{ + int digits = 0, val = 0, nch; - missing = "expected"; - for (l = SCHEME_CDR(indentation); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - indt2 = (Scheme_Indent *)SCHEME_CAR(l); - if (indt2->closer == ch) { - missing = "missing"; - } - } - } + while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) { + if (digits >= MAX_GRAPH_ID_DIGITS) + scheme_read_err(port, "too many digits after `#%d`", val); + digits++; - if (ch == indt->closer) { - sprintf(found, "unexpected"); - } else if (indt->multiline) { - sprintf(found, - "%s %s to close %s on line %" PRIdPTR ", found instead", - missing, - closer_name(params, indt->closer), - opener_name(params, opener), - indt->start_line); - } else { - sprintf(found, - "%s %s to close preceding %s, found instead", - missing, - closer_name(params, indt->closer), - opener_name(params, opener)); - } - - if (indt->suspicious_line) { - suggestion = scheme_malloc_atomic(100); - sprintf(suggestion, - "; indentation suggests a missing %s before line %" PRIdPTR, - closer_name(params, indt->suspicious_closer), - indt->suspicious_line); - } + val = ((val) * 10) + ((*ch) - 48); + nch = scheme_getc(port); + (*ch) = nch; } - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: %s `%c'%s", - found, ch, suggestion); -} - -static void pop_indentation(Scheme_Object *indentation) -{ - /* Pop off indentation stack, and propagate - suspicions if none found earlier. */ - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - indentation = SCHEME_CDR(indentation); - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *old_indt; - old_indt = (Scheme_Indent *)SCHEME_CAR(indentation); - - if (!old_indt->suspicious_line) { - if (indt->suspicious_line) { - old_indt->suspicious_line = indt->suspicious_line; - old_indt->suspicious_closer = indt->suspicious_closer; - } - } - if (!old_indt->suspicious_quote) { - if (indt->suspicious_quote) { - old_indt->suspicious_quote = indt->suspicious_quote; - } - } - } - } + return val; } /*========================================================================*/ /* .zo reader */ /*========================================================================*/ -typedef struct Scheme_Load_Delay { - MZTAG_IF_REQUIRED - Scheme_Object *path; - intptr_t file_offset, size; - uintptr_t symtab_size; - Scheme_Object **symtab; - intptr_t *shared_offsets; - Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ - Scheme_Object *relto; - Scheme_Unmarshal_Tables *ut; - struct CPort *current_rp; - int perma_cache; - unsigned char *cached; - Scheme_Object *cached_port; - struct Scheme_Load_Delay *clear_bytes_prev; - struct Scheme_Load_Delay *clear_bytes_next; - int unsafe_ok; - mzlonglong bytecode_hash; -} Scheme_Load_Delay; - #define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port); #define RANGE_CHECK(x, y) ZO_CHECK (x y) #define RANGE_POS_CHECK(x, y) ZO_CHECK ((x > 0) && (x y)) @@ -4551,16 +2321,17 @@ Scheme_Unmarshal_Tables *ut; Scheme_Object **symtab; Scheme_Hash_Table *symtab_entries; - Scheme_Object *magic_sym, *magic_val; Scheme_Object *relto; intptr_t *shared_offsets; Scheme_Load_Delay *delay_info; mzlonglong bytecode_hash; } CPort; #define CP_GETC(cp) ((int)(cp->start[cp->pos++])) +#define CP_UNGETC(cp) --cp->pos #define CP_TELL(port) (port->pos + port->base) -static Scheme_Object *read_marshalled(int type, CPort *port); +typedef void *(*GC_Alloc_Proc)(size_t); + static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port); static Scheme_Object *read_compact_quote(CPort *port, int embedded); @@ -4571,7 +2342,6 @@ ) { scheme_read_err(port ? port->orig_port : NULL, - NULL, -1, -1, port ? CP_TELL(port) : 0, -1, 0, NULL, "read (compiled): ill-formed code" #if TRACK_ILL_FORMED_CATCH_LINES " [%s:%d]", file, line @@ -4579,17 +2349,9 @@ ); } -static void unsafe_disallowed(struct CPort *port) -{ - scheme_read_err(port ? port->orig_port : NULL, - NULL, -1, -1, port ? CP_TELL(port) : 0, -1, 0, NULL, - "read (compiled): unsafe values disallowed"); -} - static void make_ut(CPort *port) { Scheme_Unmarshal_Tables *ut; - Scheme_Hash_Table *rht; char *decoded; ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables); @@ -4604,40 +2366,6 @@ ut->decoded = decoded; ut->bytecode_hash = port->bytecode_hash; - - rht = scheme_make_hash_table(SCHEME_hash_ptr); - port->ut->rns = rht; - - rht = scheme_make_hash_table(SCHEME_hash_ptr); - port->ut->multi_scope_pairs = rht; -} - -static void prepare_current_unmarshal(Scheme_Unmarshal_Tables *ut) -{ - /* in case a previous unmarshal was interrupted: */ - ut->current_rns = NULL; - ut->current_multi_scope_pairs = NULL; -} - -static void merge_ht(Scheme_Hash_Table *f, Scheme_Hash_Table *t) -{ - int i; - for (i = f->size; i--; ) { - if (f->vals[i]) - scheme_hash_set(t, f->keys[i], f->vals[i]); - } -} - -static void complete_current_unmarshal(Scheme_Unmarshal_Tables *ut) -{ - if (ut->current_rns) { - merge_ht(ut->current_rns, ut->rns); - ut->current_rns = NULL; - } - if (ut->current_multi_scope_pairs) { - merge_ht(ut->current_multi_scope_pairs, ut->multi_scope_pairs); - ut->current_multi_scope_pairs = NULL; - } } /* Since read_compact_number is called often, we want it to be @@ -4746,34 +2474,32 @@ static Scheme_Object *read_escape_from_string(char *s, intptr_t len, Scheme_Object *rel_to, - Scheme_Hash_Table **ht) + Scheme_Hash_Table **ht, + Scheme_Object *orig_port) { - Scheme_Object *ep; + Scheme_Object *ep, *v; ReadParams params; + Scheme_Input_Port *ep_ip; ep = scheme_make_sized_byte_string_input_port(s, len); - - params.can_read_compiled = 1; - params.can_read_pipe_quote = 1; - params.can_read_box = 1; - params.can_read_graph = 1; - /* Use startup value of case sensitivity so legacy code will work. */ - params.case_sensitive = scheme_case_sensitive; - params.square_brackets_are_parens = 1; - params.curly_braces_are_parens = 1; - params.square_brackets_are_tagged = 0; - params.curly_braces_are_tagged = 0; - params.read_cdot = 0; - params.read_decimal_inexact = 1; - params.can_read_dot = 1; - params.can_read_infix_dot = 1; - params.can_read_quasi = 1; - params.skip_zo_vers_check = 0; - params.table = NULL; + if (orig_port) { + v = scheme_input_port_record(orig_port)->name; + if (v) { + ep_ip = scheme_input_port_record(ep); + ep_ip->name = v; + } + } + + params.skip_zo_vers_check = 0; params.read_relative_path = rel_to; + params.graph_ht = *ht; - return read_inner(ep, NULL, ht, scheme_null, ¶ms, 0); + v = read_inner(ep, ¶ms, -1); + + *ht = params.graph_ht; + + return v; } static Scheme_Object *read_compact_escape(CPort *port) @@ -4799,7 +2525,7 @@ len = -len; /* no alloc in sized_byte_string_input_port */ #endif - return read_escape_from_string(s, len, port->relto, port->ht); + return read_escape_from_string(s, len, port->relto, port->ht, port->orig_port); } static void record_symtab_self_contained(Scheme_Hash_Table *symtab_entries, Scheme_Object *v) @@ -4826,12 +2552,12 @@ if (v) { v = scheme_make_pair(v, port->symtab_refs); - v = resolve_references(v, port->orig_port, NULL, + v = resolve_references(v, port->orig_port, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), port->symtab_entries, 0, 0); - + l = SCHEME_CDR(v); } else l = port->symtab_refs; @@ -4904,9 +2630,6 @@ if (!valid_utf8(s, l)) scheme_ill_formed_code(port); v = scheme_intern_exact_symbol(s, l); - - if (SAME_OBJ(v, port->magic_sym)) - v = port->magic_val; break; case CPT_SYMREF: l = read_compact_number(port); @@ -4984,7 +2707,7 @@ break; case CPT_CHAR: l = read_compact_number(port); - return make_interned_char(l, scheme_true); + return make_interned_char(l, 1); break; case CPT_INT: return scheme_make_integer(read_compact_number(port)); @@ -5039,88 +2762,65 @@ break; case CPT_HASH_TABLE: { - Scheme_Object *l; + Scheme_Hash_Tree *ht; int kind, len; Scheme_Object *k; kind = read_compact_number(port); len = read_compact_number(port); - - l = scheme_null; + + ht = scheme_make_hash_tree(kind); while (len--) { k = read_compact(port, 0); v = read_compact(port, 0); - /* We can't always hash directly, because a key or value - might have a graph reference inside it. */ - l = scheme_make_pair(scheme_make_pair(k, v), l); + ht = scheme_hash_tree_set(ht, k, v); } - if (!(*port->ht)) { - /* So that resolve_references is called to build the table: */ - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *(port->ht) = tht; - } - - /* Let resolve_references complete the table construction: */ - v = scheme_alloc_object(); - v->type = scheme_table_placeholder_type; - SCHEME_PINT_VAL(v) = kind; - SCHEME_IPTR_VAL(v) = l; + v = (Scheme_Object *)ht; } break; - case CPT_STX: + case CPT_LINKLET: { - Scheme_Hash_Table *save_ht; - - if (!port->ut) - make_ut(port); + int has_prefix; + Scheme_Prefix *pf; - save_ht = *port->ht; - *port->ht = NULL; - - prepare_current_unmarshal(port->ut); - v = read_compact(port, 1); + has_prefix = read_compact_number(port); + if (has_prefix) + pf = (Scheme_Prefix *)read_compact(port, 0); + else + pf = NULL; - if (!SCHEME_NULLP(port->symtab_refs)) - v = resolve_symtab_refs(v, port); - else if (*port->ht) { - *port->ht = NULL; - v = resolve_references(v, port->orig_port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - port->symtab_entries, - 0, 0); - } + v = read_compact(port, 1); + v = scheme_read_linklet(v, port->unsafe_ok); + if (!v) scheme_ill_formed_code(port); - *port->ht = save_ht; + ((Scheme_Linklet *)v)->static_prefix = pf; - v = scheme_unmarshal_datum_to_syntax(v, port->ut, 0); - scheme_num_read_syntax_objects++; - if (!v) - scheme_ill_formed_code(port); - complete_current_unmarshal(port->ut); + return v; } break; - case CPT_MARSHALLED: - v = read_marshalled(read_compact_number(port), port); - break; case CPT_QUOTE: v = read_compact_quote(port, 1); break; case CPT_REFERENCE: l = read_compact_number(port); - RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT - + EXPECTED_UNSAFE_COUNT - + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT - + EXPECTED_FUTURES_COUNT - + EXPECTED_FOREIGN_COUNT)); - if ((l >= unsafe_variable_references_start) - && !port->unsafe_ok) - unsafe_disallowed(port); + RANGE_CHECK(l, < EXPECTED_PRIM_COUNT); return variable_references[l]; break; + case CPT_TOPLEVEL: + { + int flags, pos, depth; + + flags = read_compact_number(port); + pos = read_compact_number(port); + depth = read_compact_number(port); + + if ((depth < 0) || (pos < 0)) + scheme_ill_formed_code(port); + + return scheme_make_toplevel(depth, pos, flags & SCHEME_TOPLEVEL_FLAGS_MASK); + } + break; case CPT_LOCAL: { int p, flags; @@ -5169,6 +2869,102 @@ return (Scheme_Object *)a; } break; + case CPT_BEGIN: + case CPT_BEGIN0: + { + Scheme_Sequence *seq; + int i, count; + + count = read_compact_number(port); + if (count <= 0) scheme_ill_formed_code(port); + seq = scheme_malloc_sequence(count); + seq->so.type = ((ch == CPT_BEGIN) ? scheme_sequence_type : scheme_begin0_sequence_type); + seq->count = count; + + for (i = 0; i < count; i++) { + v = read_compact(port, 1); + seq->array[i] = v; + } + + return (Scheme_Object *)seq; + } + break; + case CPT_LET_VALUE: + { + Scheme_Let_Value *lv; + int c, p; + + lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); + lv->iso.so.type = scheme_let_value_type; + + c = read_compact_number(port); + p = read_compact_number(port); + if ((c < 0) || (p < 0)) scheme_ill_formed_code(port); + + lv->count = c; + lv->position = p; + if (read_compact_number(port)) + SCHEME_LET_VALUE_AUTOBOX(lv) = 1; + v = read_compact(port, 1); + lv->value = v; + v = read_compact(port, 1); + lv->body = v; + + return (Scheme_Object *)lv; + } + break; + case CPT_LET_VOID: + { + Scheme_Let_Void *lv; + int c; + + lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); + lv->iso.so.type = scheme_let_void_type; + + c = read_compact_number(port); + if (c < 0) scheme_ill_formed_code(port); + + lv->count = c; + if (read_compact_number(port)) + SCHEME_LET_VOID_AUTOBOX(lv) = 1; + v = read_compact(port, 1); + lv->body = v; + + return (Scheme_Object *)lv; + } + break; + case CPT_LETREC: + { + Scheme_Letrec *lr; + Scheme_Object **sa; + int i, c; + + lr = MALLOC_ONE_TAGGED(Scheme_Letrec); + lr->so.type = scheme_letrec_type; + + c = read_compact_number(port); + if (c < 0) scheme_ill_formed_code(port); + + lr->count = c; + if (c < 4096) + sa = MALLOC_N(Scheme_Object*, c); + else { + sa = scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(c, sizeof(Scheme_Object *), 0)); + if (!sa) scheme_signal_error("out of memory allocating letrec bytecode"); + } + lr->procs = sa; + + for (i = 0; i < c; i++) { + v = read_compact(port, 1); + sa[i] = v; + } + + v = read_compact(port, 1); + lr->body = v; + + return (Scheme_Object *)lr; + } + break; case CPT_LET_ONE: case CPT_LET_ONE_TYPED: case CPT_LET_ONE_UNUSED: @@ -5204,131 +3000,385 @@ return scheme_make_branch(test, tbranch, fbranch); } break; - case CPT_MODULE_INDEX: - { - Scheme_Object *path, *base; - - path = read_compact(port, 0); - base = read_compact(port, 0); - if (SCHEME_FALSEP(path) - && SCHEME_FALSEP(base)) { - path = read_compact(port, 0); - if (SCHEME_FALSEP(path)) - return scheme_make_modidx(scheme_false, scheme_false, scheme_false); - else - return scheme_get_submodule_empty_self_modidx(path, 0); - } else - return scheme_make_modidx(path, base, scheme_false); - } - break; - case CPT_MODULE_VAR: + case CPT_WCM: { - Module_Variable *mv; - Scheme_Object *mod, *var, *shape; - int pos; - - mod = read_compact(port, 0); - var = read_compact(port, 0); - shape = read_compact(port, 0); - pos = read_compact_number(port); - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - if (SCHEME_SYMBOLP(mod)) - mod = scheme_intern_resolved_module_path(mod); - mv->modidx = mod; - mv->sym = var; - mv->shape = shape; - if (pos < -3) { - pos = -(pos + 3); - SCHEME_MODVAR_FLAGS(mv) = pos; - pos = read_compact_number(port); - } - if (pos == -2) { - pos = read_compact_number(port); - mv->mod_phase = pos; - pos = read_compact_number(port); - mv->pos = pos; - } else - mv->pos = pos; + Scheme_With_Continuation_Mark *wcm; + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_cont_mark_type; - return (Scheme_Object *)mv; + v = read_compact(port, 1); + wcm->key = v; + v = read_compact(port, 1); + wcm->val = v; + v = read_compact(port, 1); + wcm->body = v; + + return (Scheme_Object *)wcm; } break; - case CPT_PATH: + case CPT_DEFINE_VALUES: { - l = read_compact_number(port); - RANGE_CHECK_GETS(l); - if (l) { - s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l); - v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE); - } else { - Scheme_Object *elems; - elems = read_compact(port, 0); - if (SCHEME_PATHP(port->relto)) { - /* Resolve relative path using the current load-relative directory: */ - v = port->relto; - } else - v = scheme_maybe_build_path(NULL, scheme_false); - while (SCHEME_PAIRP(elems)) { - v = scheme_maybe_build_path(v, SCHEME_CAR(elems)); - elems = SCHEME_CDR(elems); + v = read_compact(port, 1); + if (!SCHEME_VECTORP(v)) scheme_ill_formed_code(port); + { + int i, c = SCHEME_VEC_SIZE(v); + if (c < 1) scheme_ill_formed_code(port); + for (i = 1; i < c; i++) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(v)[i]), scheme_toplevel_type) + && !SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(v)[i]), scheme_static_toplevel_type)) + scheme_ill_formed_code(port); } } + v->type = scheme_define_values_type; + return v; } break; - case CPT_CLOSURE: + case CPT_SET_BANG: { - Scheme_Closure *cl; - l = read_compact_number(port); - RANGE_CHECK(l, < port->symtab_size); - cl = scheme_malloc_empty_closure(); - port->symtab[l] = (Scheme_Object *)cl; - v = read_compact(port, 0); - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type) - || !((Scheme_Closure *)v)->code - || ((Scheme_Closure *)v)->code->closure_size) { + Scheme_Set_Bang *sb; + + sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + sb->so.type = scheme_set_bang_type; + + if (read_compact_number(port)) + sb->set_undef = 1; + + v = read_compact(port, 1); + sb->var = v; + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type) + && !SAME_TYPE(SCHEME_TYPE(v), scheme_static_toplevel_type)) scheme_ill_formed_code(port); - return NULL; - } - cl->code = ((Scheme_Closure *)v)->code; - return (Scheme_Object *)cl; - break; + v = read_compact(port, 1); + sb->val = v; + + return (Scheme_Object *)sb; } - case CPT_DELAY_REF: + break; + case CPT_OTHER_FORM: { - l = read_compact_number(port); - RANGE_POS_CHECK(l, < port->symtab_size); - v = port->symtab[l]; - if (!v) { - if (port->delay_info) { - /* This is where we construct information for - loading the syntax object on demand. */ - v = scheme_make_raw_pair(scheme_make_integer(l), - (Scheme_Object *)port->delay_info); - } else { - intptr_t save_pos = port->pos; - port->symtab[l] = SYMTAB_IN_PROGRESS; /* avoid cycles if marshaled form is broken: */ - port->pos = port->shared_offsets[l - 1]; - v = read_compact(port, 0); - port->pos = save_pos; - port->symtab[l] = v; + switch (read_compact_number(port)) { + case scheme_static_toplevel_type: + { + Scheme_Object *tl = scheme_false; + Scheme_Prefix *pf; + intptr_t flags, pos, i; + + flags = read_compact_number(port); + pos = read_compact_number(port); + + /* Avoid recur on very common case of a reference to the prefix: */ + ch = CP_GETC(port); + if (ch == CPT_SYMREF) { + l = read_compact_number(port); + RANGE_POS_CHECK(l, < port->symtab_size); + pf = (Scheme_Prefix *)port->symtab[l]; + } else { + CP_UNGETC(port); + pf = (Scheme_Prefix *)read_compact(port, 0); + } + + if (!SAME_TYPE(SCHEME_TYPE(pf), scheme_prefix_type) || (pos < 0) || (pos >= pf->num_slots)) + scheme_ill_formed_code(port); + + flags &= SCHEME_TOPLEVEL_FLAGS_MASK; + i = ((pos << SCHEME_LOG_TOPLEVEL_FLAG_MASK) | flags); + if ((i < 0) || (i >= (pf->num_slots * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)))) + scheme_ill_formed_code(port); + + tl = ((Scheme_Object **)pf->a[pf->num_slots-1])[i]; + if (!tl) { + tl = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Toplevel); + tl->type = scheme_static_toplevel_type; + SCHEME_STATIC_TOPLEVEL_PREFIX(tl) = pf; + SCHEME_TOPLEVEL_POS(tl) = pos; + SCHEME_TOPLEVEL_FLAGS(tl) |= flags; + ((Scheme_Object **)pf->a[pf->num_slots-1])[i] = tl; + } + + return tl; } - } else if (v == SYMTAB_IN_PROGRESS) { - /* there is a cycle */ - scheme_ill_formed_code(port); - } - return v; - break; - } - case CPT_PREFAB: - { - Scheme_Struct_Type *st; - v = read_compact(port, 0); - if (!SCHEME_VECTORP(v) || !SCHEME_VEC_SIZE(v)) - v = NULL; - else { - st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1); + break; + case scheme_prefix_type: + { + intptr_t prefix_size; + Scheme_Object **a; + + prefix_size = read_compact_number(port); + if (prefix_size <= 0) scheme_ill_formed_code(port); + if (prefix_size < 4096) + v = (Scheme_Object *)scheme_allocate_prefix(prefix_size); + else + v = scheme_malloc_fail_ok((GC_Alloc_Proc)scheme_allocate_prefix, prefix_size); + + /* Last prefix slot is a cache of Scheme_Toplevel values */ + a = MALLOC_N(Scheme_Object *, prefix_size * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); + ((Scheme_Prefix *)v)->a[prefix_size-1] = (Scheme_Object *)a; + + return v; + } + case scheme_boxenv_type: + { + Scheme_Object *data; + + data = scheme_alloc_object(); + data->type = scheme_boxenv_type; + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + + return data; + } + break; + case scheme_with_immed_mark_type: + { + Scheme_With_Continuation_Mark *wcm; + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_immed_mark_type; + + v = read_compact(port, 1); + wcm->key = v; + v = read_compact(port, 1); + wcm->val = v; + v = read_compact(port, 1); + wcm->body = v; + + return (Scheme_Object *)wcm; + } + case scheme_inline_variant_type: + { + Scheme_Object *data; + + data = scheme_make_vector(3, scheme_false); + data->type = scheme_inline_variant_type; + + v = read_compact(port, 1); + SCHEME_VEC_ELS(data)[0] = v; + v = read_compact(port, 1); + SCHEME_VEC_ELS(data)[1] = v; + /* third slot is filled when linklet->accessible table is made */ + + return data; + } + case scheme_case_lambda_sequence_type: + { + int count, i, all_closed = 1; + Scheme_Case_Lambda *cl; + + count = read_compact_number(port); + if (count < 0) scheme_ill_formed_code(port); + + if (count < 4096) + cl = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *)); + else { + intptr_t sz; + sz = scheme_check_overflow((count - mzFLEX_DELTA), sizeof(Scheme_Object *), sizeof(Scheme_Case_Lambda)); + cl = (Scheme_Case_Lambda *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz); + if (!cl) scheme_signal_error("out of memory allocating procedure bytecode"); + } + + cl->so.type = scheme_case_lambda_sequence_type; + cl->count = count; + + v = read_compact(port, 1); + if (SCHEME_NULLP(v)) + cl->name = NULL; + else + cl->name = v; + + for (i = 0; i < count; i++) { + v = read_compact(port, 1); + cl->array[i] = v; + if (!SCHEME_PROCP(v)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type)) + scheme_ill_formed_code(port); + all_closed = 0; + } else if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type)) + scheme_ill_formed_code(port); + } + + if (all_closed) { + /* Empty closure: produce procedure value directly. + (We assume that this was generated by a direct write of + a case-lambda data record in print.c, and that it's not + in a CASE_LAMBDA_EXPD syntax record.) */ + return scheme_case_lambda_execute((Scheme_Object *)cl); + } + + return (Scheme_Object *)cl; + } + break; + case scheme_lambda_type: + { + Scheme_Object *name, *ds, *closure_map, *tl_map; + int flags, closure_size, num_params, max_let_depth; + + flags = read_compact_number(port); + if (flags & LAMBDA_HAS_TYPED_ARGS) + closure_size = read_compact_number(port); + else + closure_size = -1; + num_params = read_compact_number(port); + max_let_depth = read_compact_number(port); + + name = read_compact(port, 1); + ds = read_compact(port, 1); + closure_map = read_compact(port, 1); + tl_map = read_compact(port, 1); + + v = scheme_read_lambda(flags, closure_size, num_params, max_let_depth, + name, ds, closure_map, tl_map); + if (!v) scheme_ill_formed_code(port); + + return v; + } + default: + scheme_ill_formed_code(port); + return NULL; + break; + } + } + break; + case CPT_VARREF: + { + Scheme_Object *data; + int flags; + + data = scheme_alloc_object(); + data->type = scheme_varref_form_type; + + flags = read_compact_number(port); + SCHEME_VARREF_FLAGS(data) |= (flags & VARREF_FLAGS_MASK); + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + if (!SCHEME_SYMBOLP(v) + && !SCHEME_FALSEP(v) + && !SAME_OBJ(v, scheme_true) + && !SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)) + scheme_ill_formed_code(port); + + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + if (!SCHEME_FALSEP(v) + && !SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)) + scheme_ill_formed_code(port); + + return data; + } + break; + case CPT_APPLY_VALUES: + { + Scheme_Object *data; + + data = scheme_alloc_object(); + data->type = scheme_apply_values_type; + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + + return data; + } + break; + case CPT_PATH: + { + l = read_compact_number(port); + RANGE_CHECK_GETS(l); + if (l) { + s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l); + v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE); + } else { + Scheme_Object *elems; + elems = read_compact(port, 0); + if (SCHEME_PATHP(port->relto)) { + /* Resolve relative path using the current load-relative directory: */ + v = port->relto; + } else + v = scheme_maybe_build_path(NULL, scheme_false); + while (SCHEME_PAIRP(elems)) { + v = scheme_maybe_build_path(v, SCHEME_CAR(elems)); + elems = SCHEME_CDR(elems); + } + } + } + break; + case CPT_SRCLOC: + { + Scheme_Object *r; + r = scheme_unsafe_make_location(); + /* No checking of field values, so a corrupt ".zo" can + create bad srclocs (but won't crash while reading) */ + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[0] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[1] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[2] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[3] = v; + v = read_compact(port, 0); + ((Scheme_Structure *)r)->slots[4] = v; + return r; + } + break; + case CPT_CLOSURE: + { + Scheme_Closure *cl; + l = read_compact_number(port); + RANGE_CHECK(l, < port->symtab_size); + cl = scheme_malloc_empty_closure(); + port->symtab[l] = (Scheme_Object *)cl; + v = read_compact(port, 0); + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type) + || !((Scheme_Closure *)v)->code + || ((Scheme_Closure *)v)->code->closure_size) { + scheme_ill_formed_code(port); + return NULL; + } + cl->code = ((Scheme_Closure *)v)->code; + return (Scheme_Object *)cl; + break; + } + case CPT_DELAY_REF: + { + l = read_compact_number(port); + RANGE_POS_CHECK(l, < port->symtab_size); + v = port->symtab[l]; + if (!v) { + if (port->delay_info) { + /* This is where we construct information for + loading the lamda form on demand. */ + v = scheme_make_raw_pair(scheme_make_integer(l), + (Scheme_Object *)port->delay_info); + } else { + intptr_t save_pos = port->pos; + port->symtab[l] = SYMTAB_IN_PROGRESS; /* avoid cycles if marshaled form is broken: */ + port->pos = port->shared_offsets[l - 1]; + v = read_compact(port, 0); + port->pos = save_pos; + port->symtab[l] = v; + } + } else if (v == SYMTAB_IN_PROGRESS) { + /* there is a cycle */ + scheme_ill_formed_code(port); + } + return v; + break; + } + case CPT_PREFAB: + { + Scheme_Struct_Type *st; + v = read_compact(port, 0); + if (!SCHEME_VECTORP(v) || !SCHEME_VEC_SIZE(v)) + v = NULL; + else { + st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1); if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1))) v = NULL; else { @@ -5352,12 +3402,6 @@ return scheme_make_local(type, ch, 0); } break; - case CPT_SMALL_MARSHALLED_START: - { - l = ch - CPT_SMALL_MARSHALLED_START; - v = read_marshalled(l, port); - } - break; case CPT_SMALL_SYMBOL_START: { l = ch - CPT_SMALL_SYMBOL_START; @@ -5366,9 +3410,6 @@ if (!valid_utf8(s, l)) scheme_ill_formed_code(port); v = scheme_intern_exact_symbol(s, l); - - if (SAME_OBJ(v, port->magic_sym)) - v = port->magic_val; } break; case CPT_SMALL_NUMBER_START: @@ -5463,32 +3504,6 @@ return (Scheme_Object *)app; } break; - case CPT_SCOPE: - { - Scheme_Object *v2; - - if (!port->ut) - make_ut(port); - - v = scheme_box(scheme_false); - l = read_compact_number(port); - - if (l) { - RANGE_POS_CHECK(l, < port->symtab_size); - port->symtab[l] = v; - } - - l = read_compact_number(port); - - v2 = read_compact(port, 0); - v2 = scheme_make_pair(scheme_make_integer(l), v2); - SCHEME_BOX_VAL(v) = v2; - - return v; - } - break; - case CPT_ROOT_SCOPE: - return scheme_stx_root_scope(); case CPT_SHARED: { Scheme_Object *ph; @@ -5574,7 +3589,7 @@ port->ht = old_ht; if (*q_ht) - v = resolve_references(v, port->orig_port, NULL, + v = resolve_references(v, port->orig_port, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), port->symtab_entries, @@ -5583,31 +3598,6 @@ return v; } -static Scheme_Object *read_marshalled(int type, CPort *port) -{ - Scheme_Object *l; - Scheme_Type_Reader reader; - - l = read_compact(port, 1); - - if ((type < 0) || (type >= _scheme_last_type_)) { - scheme_ill_formed_code(port); - } - - reader = scheme_type_readers[type]; - - if (!reader) { - scheme_ill_formed_code(port); - } - - l = reader(l); - - if (!l) - scheme_ill_formed_code(port); - - return l; -} - static intptr_t read_simple_number_from_port(Scheme_Object *port) { intptr_t a, b, c, d; @@ -5642,7 +3632,7 @@ rp->bytecode_hash = l; } -char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len) +char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len) { Scheme_Object *pr; intptr_t len = 0, l; @@ -5679,7 +3669,7 @@ return (char *)s; } -Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len) +Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len) { unsigned char *s = (unsigned char *)_s; char *e, buffer[32]; @@ -5716,21 +3706,20 @@ return first ? first : scheme_null; } -static void read_module_directory(Scheme_Object *port, Scheme_Hash_Table *ht, int depth) +/* Installs into `ht` a mapping of offset -> (listof symbol) */ +static void read_linklet_directory(Scheme_Object *port, Scheme_Hash_Table *ht, int depth, intptr_t bundle_pos) { char *s; Scheme_Object *v, *p; int len, left, right; - intptr_t got; + intptr_t got, offset; if (depth > 32) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): multi-module directory tree is imbalanced"); + scheme_read_err(port, "read (compiled): linklet-module directory tree is imbalanced"); len = read_simple_number_from_port(port); if (len < 0) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): directory module name read failed"); + scheme_read_err(port, "read (compiled): linklet-bundle name read failed"); s = scheme_malloc_atomic(len + 1); got = scheme_get_bytes(port, len, s, 0); @@ -5739,7 +3728,7 @@ v = NULL; else { s[len] = 0; - v = scheme_string_to_submodule_path(s, len); + v = scheme_string_to_symbol_path(s, len); for (p = v; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) { v = NULL; @@ -5751,33 +3740,109 @@ } if (!v) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): directory module name read failed"); - - scheme_hash_set(ht, v, scheme_null); + scheme_read_err(port, "read (compiled): linklet-bundle name read failed"); - (void)read_simple_number_from_port(port); /* offset */ + offset = read_simple_number_from_port(port); /* offset */ (void)read_simple_number_from_port(port); /* length */ + scheme_hash_set(ht, scheme_make_integer(offset+bundle_pos), v); + left = read_simple_number_from_port(port); right = read_simple_number_from_port(port); if (left) - read_module_directory(port, ht, depth+1); + read_linklet_directory(port, ht, depth+1, bundle_pos); if (right) - read_module_directory(port, ht, depth+1); + read_linklet_directory(port, ht, depth+1, bundle_pos); +} + +Scheme_Object *wrap_as_linklet_directory(Scheme_Hash_Tree *ht) +{ + Scheme_Object *v; + v = scheme_alloc_small_object(); + v->type = scheme_linklet_directory_type; + SCHEME_PTR_VAL(v) = (Scheme_Object *)ht; + return v; +} + +static Scheme_Object *bundle_list_to_hierarchical_directory(Scheme_Object *bundles) +{ + Scheme_Hash_Tree *accum, *next; + Scheme_Object *p, *v, *path, *stack; + int len, prev_len, i; + + /* The bundles list is in post-order, so we can build directories + bottom-up */ + + prev_len = 0; + stack = scheme_null; + accum = scheme_make_hash_tree(0); + + while (1) { + MZ_ASSERT(SCHEME_PAIRP(bundles)); + p = SCHEME_CAR(bundles); + path = SCHEME_CAR(p); + v = SCHEME_CDR(p); + + MZ_ASSERT(SCHEME_FALSEP(v) || SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + + len = scheme_list_length(path); + + if (len < prev_len) + return NULL; + + while (len > prev_len + 1) { + stack = scheme_make_pair((Scheme_Object *)accum, stack); + prev_len++; + accum = scheme_make_hash_tree(0); + } + + for (i = 0; i < prev_len - 1; i++) { + path = SCHEME_CDR(path); + } + + if (len == prev_len) { + if (!SCHEME_FALSEP(v)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + accum = scheme_hash_tree_set(accum, scheme_false, v); + } + + if (!len) + return wrap_as_linklet_directory(accum); + + next = (Scheme_Hash_Tree *)SCHEME_CAR(stack); + stack = SCHEME_CDR(stack); + next = scheme_hash_tree_set(next, SCHEME_CAR(path), wrap_as_linklet_directory(accum)); + prev_len--; + accum = next; + } else { + MZ_ASSERT(len == prev_len + 1); + if (prev_len) + path = SCHEME_CDR(path); + next = scheme_make_hash_tree(0); + if (!SCHEME_FALSEP(v)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + next = scheme_hash_tree_set(next, scheme_false, v); + } + accum = scheme_hash_tree_set(accum, SCHEME_CAR(path), wrap_as_linklet_directory(next)); + } + + bundles = SCHEME_CDR(bundles); + if (SCHEME_NULLP(bundles)) + return NULL; + } } /* "#~" has been read */ static Scheme_Object *read_compiled(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, ReadParams *params) { - Scheme_Hash_Table *directory = NULL; + Scheme_Hash_Table *directory = NULL; /* position -> symbol-path */ + Scheme_Object *bundles = scheme_null; /* list of (cons symbol-path bundle-or-#f) */ + intptr_t bundle_pos; + int bundles_to_read = 0; Scheme_Object *result; - intptr_t size, shared_size, got, offset, directory_count = 0; + intptr_t size, shared_size, got, offset; CPort *rp; intptr_t symtabsize; Scheme_Object **symtab; @@ -5791,6 +3856,8 @@ char hash_code[20]; while (1) { + bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#~" */ + /* Check version: */ size = scheme_get_byte(port); { @@ -5804,7 +3871,7 @@ if (!params->skip_zo_vers_check) if (strcmp(buf, MZSCHEME_VERSION)) - scheme_read_err(port, stxsrc, line, col, pos, got, 0, NULL, + scheme_read_err(port, "read (compiled): wrong version for compiled code\n" " compiled version: %s\n" " expected version: %s", @@ -5813,16 +3880,17 @@ mode = scheme_get_byte(port); if (mode == 'D') { - /* a module with submodules, starting with a directory */ + /* a linklet directory */ if (directory) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found multi-module directory after directory"); + scheme_read_err(port, + "read (compiled): found unexpected linklet directory nesting"); (void)read_simple_number_from_port(port); /* count */ directory = scheme_make_hash_table_equal(); - read_module_directory(port, directory, 0); - } else if (mode == 'T') { + read_linklet_directory(port, directory, 0, bundle_pos); + bundles_to_read = directory->count; + } else if (mode == 'B') { /* single module or other top-level form */ - + /* Allow delays? */ if (params->delay_load_info) { delay_info = MALLOC_ONE_RT(Scheme_Load_Delay); @@ -5845,12 +3913,12 @@ so = (intptr_t *)scheme_malloc_fail_ok(scheme_malloc_atomic, scheme_check_overflow(symtabsize, sizeof(intptr_t), 0)); if (!so) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): could not allocate symbol table of size %" PRIdPTR, symtabsize); if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0)) != ((all_short ? 2 : 4) * (symtabsize - 1))) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (bad table count: %" PRIdPTR " != %" PRIdPTR ")", got, (all_short ? 2 : 4) * (symtabsize - 1)); { @@ -5878,7 +3946,7 @@ size = read_simple_number_from_port(port); if (shared_size >= size) { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (shared size %ld >= total size %ld)", shared_size, size); } @@ -5900,7 +3968,7 @@ rp->orig_port = port; rp->size = size; if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (bad count: %ld != %ld" ", started at %ld)", got, size, rp->base); @@ -5928,9 +3996,6 @@ dir = scheme_path_to_directory_path(dir); rp->relto = dir; - rp->magic_sym = params->magic_sym; - rp->magic_val = params->magic_val; - install_byecode_hash_code(rp, hash_code); rp->shared_offsets = so; @@ -5981,29 +4046,36 @@ } /* Read main body: */ - result = read_marshalled(scheme_compilation_top_type, rp); + result = read_compact(rp, 1); - if (delay_info) + if (delay_info) { if (delay_info->ut) delay_info->ut->rp = NULL; /* clean up */ - - if (*local_ht) { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): ill-formed code (unexpected graph structure)"); - return NULL; } - if (SAME_TYPE(SCHEME_TYPE(result), scheme_compilation_top_type)) { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result; + if (*local_ht) + scheme_read_err(port, "read (compiled): unexpected graph structure"); + + if (!SCHEME_HASHTRP(result)) + scheme_read_err(port, "read (compiled): bundle content is not an immutable hash"); - scheme_validate_code(rp, top->code, - top->max_let_depth, - top->prefix->num_toplevels, - top->prefix->num_stxes, - top->prefix->num_lifts, - NULL, - NULL, - 0); + { + mzlonglong i; + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)result; + Scheme_Object *key, *val; + + if (!scheme_starting_up) { + i = scheme_hash_tree_next(t, -1); + while (i != -1) { + scheme_hash_tree_index(t, i, &key, &val); + if (validate_loaded_linklet + && SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type) + && !((Scheme_Linklet *)val)->reject_eval) + scheme_validate_linklet(rp, (Scheme_Linklet *)val); + i = scheme_hash_tree_next(t, i); + } + } + /* If no exception, the resulting code is ok. */ /* Install module hash code, if any. This code is used to register @@ -6016,96 +4088,120 @@ } if (i < 20) { - Scheme_Module *m; - m = scheme_extract_compiled_module(result); - if (m) { - Scheme_Object *hc; - hc = scheme_make_sized_byte_string(hash_code, 20, 1); - hc = scheme_make_pair(hc, dir); - - m->code_key = hc; - } + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, + hash_code_symbol, + scheme_make_sized_byte_string(hash_code, 20, 1)); } } - } else - scheme_ill_formed_code(rp); - + } + + if (!directory) { + /* Since we're loading an individual bundle, strip submodule references */ + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, pre_symbol, NULL); + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, post_symbol, NULL); + } + + { + Scheme_Object *v; + v = scheme_alloc_small_object(); + v->type = scheme_linklet_bundle_type; + SCHEME_PTR_VAL(v) = result; + result = v; + } + if (directory) { - Scheme_Module *m, *m2; Scheme_Object *v; - m = scheme_extract_compiled_module(result); - if (m) { - v = scheme_hash_get(directory, m->submodule_path); - if (v && (SCHEME_NULLP(v) || SCHEME_PAIRP(v))) { - directory_count++; - v = scheme_reverse(v); - m->pre_submodules = v; - scheme_hash_set(directory, m->submodule_path, result); - if (!SCHEME_NULLP(m->submodule_path)) { - /* find parent: */ - v = scheme_reverse(m->submodule_path); - v = scheme_reverse(SCHEME_CDR(v)); - result = scheme_hash_get(directory, v); - if (!result) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): no parent module found in multi-module stream"); - if (SCHEME_NULLP(result) || SCHEME_PAIRP(result)) { - /* this is a pre-submodule */ - result = scheme_make_pair((Scheme_Object *)m, result); - scheme_hash_set(directory, v, result); - } else { - /* this is a post-submodule */ - m2 = scheme_extract_compiled_module(result); - v = m2->post_submodules ? m2->post_submodules : scheme_null; - v = scheme_make_pair((Scheme_Object *)m, v); - m2->post_submodules = v; - } - } - if (directory->count == directory_count) { - /* need to reverse post-submodule lists in all modules: */ - int i; - for (i = 0; i < directory->size; i++) { - if (directory->vals[i]) { - m = scheme_extract_compiled_module(directory->vals[i]); - if (m->post_submodules) { - v = scheme_reverse(m->post_submodules); - m->post_submodules = v; - } - } - } - /* return the root module: */ - return scheme_hash_get(directory, scheme_null); - } - /* otherwise, keep reading modules */ - } else - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found unrecognized or duplicate module after multi-module directory: %V", - m->submodule_path); - } else - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found non-module code after multi-module directory"); + /* Find bundle's symbol path by its starting position */ + v = scheme_hash_get(directory, scheme_make_integer(bundle_pos)); + if (!v) + scheme_read_err(port, "read (compiled): cannot match bundle position to linklet-directory path"); + + bundles = scheme_make_pair(scheme_make_pair(v, result), bundles); + bundles_to_read--; + + if (!bundles_to_read) { + /* convert flattened directory into hierarchical form */ + v = bundle_list_to_hierarchical_directory(bundles); + if (!v) + scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree"); + return v; + } + /* otherwise, continue reading bundles */ } else return result; } else { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found bad mode"); + scheme_read_err(port, "read (compiled): found bad mode"); } - - - if ((scheme_get_byte(port) != '#') - || (scheme_get_byte(port) != '~')) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): no `#~' for next module in multi-module stream"); - } -} -THREAD_LOCAL_DECL(static Scheme_Load_Delay *clear_bytes_chain); + while (1) { + int c1, c2; -void scheme_clear_delayed_load_cache() -{ - Scheme_Load_Delay *next; + c1 = scheme_get_byte(port); + c2 = scheme_get_byte(port); + + if ((c1 != '#') || ((c2 != '~') && (c2 != 'f'))) + scheme_read_err(port, + "read (compiled): no `#~' for next linklet (%d to go) in a linklet directory", + bundles_to_read); + + if (c2 == 'f') { + /* Got #f in place of a bundle */ + Scheme_Object *v; + + bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#f" */ + v = scheme_hash_get(directory, scheme_make_integer(bundle_pos)); + if (!v) + scheme_read_err(port, "read (compiled): cannot match empty-bundle position to linklet-directory path"); + + bundles = scheme_make_pair(scheme_make_pair(v, scheme_false), bundles); + bundles_to_read--; + + if (!bundles_to_read) { + /* convert flattened directory into hierarchical form */ + v = bundle_list_to_hierarchical_directory(bundles); + if (!v) + scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree"); + return v; + } + } else { + /* continue outer loop to read next bundle */ + break; + } + } + } +} + +Scheme_Object *scheme_read_compiled(Scheme_Object *port) +{ + Scheme_Config *config; + Scheme_Object *v, *v2; + ReadParams params; + + config = scheme_current_config(); + + params.skip_zo_vers_check = 0; + + v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v2 = scheme_get_initial_inspector(); + params.can_read_unsafe = SAME_OBJ(v, v2); + + v = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO); + if (SCHEME_TRUEP(v)) + params.delay_load_info = v; + else + params.delay_load_info = NULL; + + return read_compiled(port, ¶ms); +} + + +THREAD_LOCAL_DECL(static Scheme_Load_Delay *clear_bytes_chain); + +void scheme_clear_delayed_load_cache() +{ + Scheme_Load_Delay *next; while (clear_bytes_chain) { next = clear_bytes_chain->clear_bytes_next; @@ -6170,7 +4266,7 @@ scheme_set_file_position(port, delay_info->file_offset); if ((got = scheme_get_bytes(port, size, (char *)st, 0)) != size) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "on-demand load: ill-formed code (bad count: %ld != %ld" ", started at %ld)", got, size, 0); @@ -6224,9 +4320,6 @@ rp->pos = delay_info->shared_offsets[which - 1]; - if (delay_info->ut) - prepare_current_unmarshal(delay_info->ut); - /* Perform the read, catching escapes so we can clean up: */ savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; @@ -6237,6 +4330,9 @@ } else { v = read_compact(rp, 0); v_exn = NULL; + if (*ht) { + scheme_read_err(rp->orig_port, "read (compiled): unexpected graph structure"); + } } scheme_current_thread->error_buf = savebuf; scheme_current_thread->reading_delayed = NULL; @@ -6245,10 +4341,8 @@ v = resolve_symtab_refs(v, rp); delay_info->current_rp = old_rp; - if (delay_info->ut) { + if (delay_info->ut) delay_info->ut->rp = old_rp; - complete_current_unmarshal(delay_info->ut); - } if (!old_rp && !delay_info->perma_cache) { /* No one using the cache, to register it to be cleaned up */ @@ -6261,17 +4355,10 @@ scheme_end_atomic_no_swap(); if (v) { - if (*ht) { - v = resolve_references(v, port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - delay_info->symtab_entries, - 0, 0); - } - - delay_info->symtab[which] = v; - record_symtab_self_contained(delay_info->symtab_entries, v); - + /* Although `which` is a symbol-table index for `v`, + we don't actually record v, because the delayed + reference is now complete (and we'd like to be + able to GC it if it's otherwise unused). */ return v; } else { if (v_exn && !scheme_current_thread->cjs.is_kill) @@ -6323,738 +4410,6 @@ } /*========================================================================*/ -/* readtable support */ -/*========================================================================*/ - -Scheme_Object *scheme_make_default_readtable() -{ - return scheme_false; -} - -static int readtable_kind(Readtable *t, int ch, ReadParams *params) -{ - int k; - Scheme_Object *v; - - if (ch < 128) - k = t->fast_mapping[ch]; - else { - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - if (!v) { - if (scheme_isspace(ch)) - k = READTABLE_WHITESPACE; - else - k = READTABLE_CONTINUING; - } else - k = SCHEME_INT_VAL(SCHEME_CAR(v)); - } - - if (k == READTABLE_MAPPED) { - /* ch is mapped to a default behavior: */ - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - ch = SCHEME_INT_VAL(SCHEME_CDR(v)); - if (ch < 128) - k = builtin_fast[ch]; - else if (scheme_isspace(ch)) - k = READTABLE_WHITESPACE; - else - k = READTABLE_CONTINUING; - } - - if (k == READTABLE_MULTIPLE_ESCAPE) { - /* This is the only one sensitive to params. */ - if (!params->can_read_pipe_quote) - return READTABLE_CONTINUING; - } - - return k; -} - -static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, Scheme_Object *modpath_stx) -{ - int cnt, add_srcloc = 0; - Scheme_Object *a[7], *v; - Scheme_Cont_Frame_Data cframe; - - if (w_char) { - a[0] = scheme_make_character(ch); - a[1] = port; - a[2] = proc; - if (!src && scheme_check_proc_arity(NULL, 2, 2, 3, a)) { - cnt = 2; - } else { - cnt = 6; - a[2] = (src ? src : scheme_false); - add_srcloc = 3; - } - } else { - if (src) { - a[0] = src; - a[1] = port; - if (modpath_stx) { - a[2] = modpath_stx; - add_srcloc = 3; - cnt = 6; - } else - cnt = 2; - } else { - a[0] = port; - if (modpath_stx) { - a[1] = modpath_stx; - add_srcloc = 2; - cnt = 5; - } else - cnt = 1; - } - } - - if (add_srcloc) { - a[add_srcloc + 0] = (line > 0) ? scheme_make_integer(line) : scheme_false; - a[add_srcloc + 1] = (col > 0) ? scheme_make_integer(col-1) : scheme_false; - a[add_srcloc + 2] = (pos > 0) ? scheme_make_integer(pos) : scheme_false; - } - - if (src) { - /* fresh ht in case nested uses recursive `read' instead of recursive `read-syntax': */ - ht = MALLOC_N(Scheme_Hash_Table *, 1); - } - - if (!get_info) { - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(src, ht); - } - - v = scheme_apply(proc, cnt, a); - - if (get_info) { - a[0] = v; - if (!scheme_check_proc_arity(NULL, 2, 0, 1, a)) { - scheme_wrong_contract("read-language", "(any/c any/c . -> . any)", -1, -1, a); - } - } - - if (!get_info) { - scheme_pop_continuation_frame(&cframe); - } - - if (!get_info && !scheme_special_comment_value(v)) { - if (SCHEME_STXP(v)) { - if (!src) - v = scheme_syntax_to_datum(v, 0, NULL); - } else if (src) { - Scheme_Object *s; - - if (*ht) { - /* resolve references from recursive `read': */ - v = resolve_references(v, port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - NULL, - 1, 0); - } - - s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), src, STX_SRCTAG); - v = scheme_datum_to_syntax(v, s, scheme_false, 1, 1); - } - - if (!src) - set_need_copy(ht); - } - - return v; -} - -void scheme_set_in_read_mark(Scheme_Object *src, Scheme_Hash_Table **ht) -{ - Scheme_Object *v; - - if (ht) - v = scheme_make_raw_pair((Scheme_Object *)ht, - (src ? scheme_true : scheme_false)); - else - v = scheme_false; - scheme_set_cont_mark(unresolved_uninterned_symbol, v); -} - -static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht) -{ - int ch = *_ch; - Scheme_Object *v; - - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - - if (!v) { - *_use_default = 1; - return NULL; - } - - if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) { - *_ch = SCHEME_INT_VAL(SCHEME_CDR(v)); - *_use_default = 1; - return NULL; - } - - *_use_default = 0; - - v = SCHEME_CDR(v); - - v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL); - - return v; -} - -static int readtable_effective_char(Readtable *t, int ch) -{ - Scheme_Object *v; - - if (!t) return ch; - - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - - if (v) { - if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) - return SCHEME_INT_VAL(SCHEME_CDR(v)); - return 0; /* not equivalent to any standard char mapping */ - } else - return ch; -} - -static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht) -{ - Scheme_Object *v; - - v = scheme_hash_get(t->mapping, scheme_make_integer(-ch)); - - if (!v) { - *_use_default = 1; - return NULL; - } - - *_use_default = 0; - - v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL); - - if (scheme_special_comment_value(v)) - return NULL; - else - return v; -} - -static void check_proc_either_arity(const char *who, int a1, int a2, int which, int argc, Scheme_Object **argv) -{ - if (!scheme_check_proc_arity(NULL, a1, which, argc, argv) - && !scheme_check_proc_arity(NULL, a2, which, argc, argv)) { - char buffer[256]; - sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2); - scheme_wrong_contract(who, buffer, which, argc, argv); - } -} - -static Scheme_Object *make_readtable(int argc, Scheme_Object **argv) -{ - Scheme_Object *sym, *val; - Readtable *t, *orig_t; - Scheme_Hash_Table *ht; - char *fast; - int i, ch; - - if (SCHEME_FALSEP(argv[0])) - orig_t = NULL; - else { - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) { - scheme_wrong_contract("make-readtable", "(or/c readtable? #f)", 0, argc, argv); - return NULL; - } - orig_t = (Readtable *)argv[0]; - } - - t = MALLOC_ONE_TAGGED(Readtable); - t->so.type = scheme_readtable_type; - if (orig_t) - ht = scheme_clone_hash_table(orig_t->mapping); - else - ht = scheme_make_hash_table(SCHEME_hash_ptr); - t->mapping = ht; - fast = scheme_malloc_atomic(128); - memcpy(fast, (orig_t ? orig_t->fast_mapping : builtin_fast), 128); - t->fast_mapping = fast; - t->symbol_parser = (orig_t ? orig_t->symbol_parser : NULL); - - for (i = 1; i < argc; i += 3) { - if (!SCHEME_FALSEP(argv[i]) && !SCHEME_CHARP(argv[i])) { - scheme_wrong_contract("make-readtable", "(or/c char? #f)", i, argc, argv); - return NULL; - } - - if (i + 1 >= argc) { - if (SCHEME_FALSEP(argv[i])) - scheme_contract_error("make-readtable", - "expected 'non-terminating-macro after #f", - NULL); - else - scheme_contract_error("make-readtable", - "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro," - " or character argument after character argument", - "character", 1, argv[i], - NULL); - } - - sym = argv[i + 1]; - if (!SAME_OBJ(sym, terminating_macro_symbol) - && !SAME_OBJ(sym, non_terminating_macro_symbol) - && !SAME_OBJ(sym, dispatch_macro_symbol) - && !SCHEME_CHARP(sym)) { - scheme_wrong_contract("make-readtable", - "(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)", - i+1, argc, argv); - return NULL; - } - if (SCHEME_FALSEP(argv[i]) - && !SAME_OBJ(sym, non_terminating_macro_symbol)) { - scheme_contract_error("make-readtable", - "expected 'non-terminating-macro after #f", - "given", 1, sym, - NULL); - } - - if (i + 2 >= argc) { - scheme_contract_error("make-readtable", - (SCHEME_CHARP(sym) - ? "expected readtable or #f argument after character argument" - : "expected procedure argument after symbol argument"), - "given", 1, argv[i+1], - NULL); - } - - if (SCHEME_FALSEP(argv[i])) { - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - t->symbol_parser = argv[i + 2]; - } else if (SAME_OBJ(sym, dispatch_macro_symbol)) { - ch = SCHEME_CHAR_VAL(argv[i]); - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]); - } else { - if (SCHEME_CHARP(sym)) { - Readtable *src; - int sch; - - if (SCHEME_FALSEP(argv[i+2])) { - src = NULL; - } else { - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[i+2]))) { - scheme_wrong_contract("make-readtable", "(or/c readtable? #f)", i+2, argc, argv); - return NULL; - } - src = (Readtable *)(argv[i+2]); - } - sch = SCHEME_CHAR_VAL(argv[i+1]); - if (!src) - val = NULL; /* use default */ - else - val = scheme_hash_get(src->mapping, scheme_make_integer(sch)); - if (!val) - val = scheme_make_pair(scheme_make_integer(READTABLE_MAPPED), scheme_make_integer(sch)); - } else { - int kind; - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - kind = (SAME_OBJ(sym, non_terminating_macro_symbol) - ? READTABLE_CONTINUING - : READTABLE_TERMINATING); - val = scheme_make_pair(scheme_make_integer(kind), argv[i+2]); - } - - ch = SCHEME_CHAR_VAL(argv[i]); - if (!val) { - scheme_hash_set(t->mapping, scheme_make_integer(ch), NULL); - if (ch < 128) - t->fast_mapping[ch] = 0; - } else { - scheme_hash_set(t->mapping, scheme_make_integer(ch), val); - if (ch < 128) - t->fast_mapping[ch] = (char)SCHEME_INT_VAL(SCHEME_CAR(val)); - } - } - } - - return (Scheme_Object *)t; -} - -static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv) -{ - Scheme_Object *v1, *v2, *a[3]; - Readtable *t; - int ch; - - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) { - scheme_wrong_contract("readtable-mapping", "readtable?", 0, argc, argv); - return NULL; - } - if (!SCHEME_CHARP(argv[1])) { - scheme_wrong_contract("readtable-mapping", "character?", 1, argc, argv); - return NULL; - } - - t = (Readtable *)argv[0]; - ch = SCHEME_CHAR_VAL(argv[1]); - - v1 = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - v2 = scheme_hash_get(t->mapping, scheme_make_integer(-ch)); - - a[0] = argv[1]; - a[1] = scheme_false; - if (v1) { - int v; - v = SCHEME_INT_VAL(SCHEME_CAR(v1)); - if (v & READTABLE_MAPPED) { - v = SCHEME_INT_VAL(SCHEME_CDR(v1)); - a[0] = scheme_make_character(v); - a[1] = scheme_false; - } else if (v & READTABLE_CONTINUING) { - a[0] = non_terminating_macro_symbol; - a[1] = SCHEME_CDR(v1); - } else if (v & READTABLE_TERMINATING) { - a[0] = terminating_macro_symbol; - a[1] = SCHEME_CDR(v1); - } - } - a[2] = scheme_false; - if (v2) { - a[2] = v2; - } - - return scheme_values(3, a); -} - -static Scheme_Object *readtable_p(int argc, Scheme_Object **argv) -{ - return (SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0])) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *readtable_or_false_p(int argc, Scheme_Object **argv) -{ - if (SCHEME_FALSEP(argv[0])) - return scheme_true; - return readtable_p(argc, argv); -} - -static Scheme_Object *current_readtable(int argc, Scheme_Object **argv) -{ - return scheme_param_config2("current-readtable", - scheme_make_integer(MZCONFIG_READTABLE), - argc, argv, - -1, readtable_or_false_p, "readtable?", 0); -} - -static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv) -{ - return scheme_param_config2("current-reader-guard", - scheme_make_integer(MZCONFIG_READER_GUARD), - argc, argv, - 1, NULL, NULL, 0); -} - -static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv) -{ - return (Scheme_Object *)d; -} - -static Scheme_Object *do_reader(Scheme_Object *try_modpath, - Scheme_Object *modpath_stx, - Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) -{ - Scheme_Object *modpath, *name, *a[3], *proc, *v, *no_val; - int num_a; - Scheme_Env *env; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - int pop_frame; - - if (stxsrc) - modpath = scheme_syntax_to_datum(modpath_stx, 0, NULL); - else - modpath = modpath_stx; - - proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD); - - if (try_modpath) { - a[0] = try_modpath; - try_modpath = scheme_apply(proc, 1, a); - - if (scheme_module_is_declared(try_modpath, 1)) - modpath = try_modpath; - else - try_modpath = NULL; - } - - if (!try_modpath) { - a[0] = modpath; - modpath = scheme_apply(proc, 1, a); - } - - a[0] = modpath; - if (get_info) - name = scheme_intern_symbol("get-info"); - else if (stxsrc) - name = scheme_intern_symbol("read-syntax"); - else - name = scheme_intern_symbol("read"); - a[1] = name; - if (get_info) { - no_val = scheme_make_pair(scheme_false, scheme_false); - a[2] = scheme_make_closed_prim(no_val_thunk, no_val); - num_a = 3; - } else { - no_val = NULL; - num_a = 2; - } - - if (get_info) - pop_frame = 0; - else { - config = scheme_current_config(); - env = scheme_get_env(config); - - if (env->reader_env) { - config = scheme_extend_config(config, - MZCONFIG_ENV, - (Scheme_Object *)env->reader_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - pop_frame = 1; - } else - pop_frame = 0; - } - - proc = scheme_dynamic_require(num_a, a); - if (get_info) { - proc = scheme_force_value(proc); - } - - if (get_info && SAME_OBJ(proc, no_val)) { - v = scheme_false; - } else { - a[0] = proc; - if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) { - /* provide modpath_stx to reader */ - } else if (!get_info && scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) { - /* don't provide modpath_stx to reader */ - modpath_stx = NULL; - } else { - scheme_wrong_contract("#reader", - (stxsrc ? "(or/c (any/c any/c . -> . any) (procedure-arity-includes/c 6))" - : (get_info - ? "(procedure-arity-includes/c 5)" - : "(or/c (any/c . -> . any) (procedure-arity-includes/c 5))")), - -1, -1, a); - return NULL; - } - - v = readtable_call(0, 0, proc, params, - port, stxsrc, line, col, pos, - get_info, ht, modpath_stx); - - if (!get_info && scheme_special_comment_value(v)) - v = NULL; - } - - if (pop_frame) - scheme_pop_continuation_frame(&cframe); - - return v; -} - -/* "#reader" has been read */ -static Scheme_Object *read_reader(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) -{ - Scheme_Object *modpath; - - if (stxsrc) - modpath = scheme_read_syntax(port, stxsrc); - else - modpath = scheme_read(port); - - if (SCHEME_EOFP(modpath)) { - scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, - "read: expected a datum after #reader, found end-of-file"); - return NULL; - } - - return do_reader(NULL, modpath, port, stxsrc, line, col, pos, 0, ht, indentation, params); -} - -/* "#lang " has been read */ -static Scheme_Object *read_lang(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int init_ch) -{ - int size, len; - GC_CAN_IGNORE char *sfx; - char *buf, *naya; - int ch = 0; - Scheme_Object *modpath, *subm_modpath; - intptr_t name_line = -1, name_col = -1, name_pos = -1; - - size = 32; - buf = MALLOC_N_ATOMIC(char, size); - len = 0; - - if (init_ch) { - ch = init_ch; - } else { - ch = scheme_getc_special_ok(port); - } - scheme_tell_all(port, &name_line, &name_col, &name_pos); - - while (1) { - /* ch was only peeked at this point (except for the first iteration), so we - can leave the input immediately after the language spec */ - if (ch == EOF) { - break; - } else if (ch == SCHEME_SPECIAL) { - ch = scheme_getc_special_ok(port); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: found non-character while reading `#lang'"); - } else if (scheme_isspace(ch)) { - break; - } else { - if (len) ch = scheme_getc_special_ok(port); - if ((ch < 128) - && (is_lang_nonsep_char(ch) - || (ch == '/'))) { - if (len + 1 >= size) { - size *= 2; - naya = MALLOC_N_ATOMIC(char, size); - memcpy(naya, buf, len * sizeof(char)); - buf = naya; - } - buf[len++] = ch; - } else { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected only alphanumeric, `-', `+', `_', or `/'" - " characters for `#%s', found %c", - init_ch ? "!" : "lang", - ch); - return NULL; - } - } - ch = scheme_peekc_special_ok(port); - } - - if (!len) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - (((ch == ' ') && !init_ch) - ? "read: expected a single space after `#lang'" - : "read: expected a non-empty sequence of alphanumeric, `-', `+', `_', or `/' after `#%s'"), - init_ch ? "!" : "lang "); - return NULL; - } - if (buf[0] == '/') { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected a name that does not start `/' after `#lang'"); - return NULL; - } - if (buf[len - 1] == '/') { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected a name that does not end `/' after `#%s'", - init_ch ? "!" : "lang"); - return NULL; - } - - if (len + 16 >= size) { - size += 16; - naya = MALLOC_N_ATOMIC(char, size * sizeof(char)); - memcpy(naya, buf, len * sizeof(char)); - buf = naya; - } - buf[len] = 0; - subm_modpath = scheme_intern_symbol(buf); - - sfx = "/lang/reader"; - while (*sfx) { - buf[len++] = *(sfx++); - } - buf[len] = 0; - - modpath = scheme_intern_symbol(buf); - if (stxsrc) { - intptr_t span; - span = SPAN(port, name_pos); - modpath = scheme_make_stx_w_offset(modpath, name_line, name_col, name_pos, - span, - stxsrc, STX_SRCTAG); - } - - subm_modpath = scheme_make_pair(scheme_intern_symbol("submod"), - scheme_make_pair(subm_modpath, - scheme_make_pair(scheme_intern_symbol("reader"), - scheme_null))); - - return do_reader(subm_modpath, modpath, port, stxsrc, line, col, pos, get_info, ht, indentation, params); -} - -Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok) -{ - return _internal_read(port, NULL, 0, 0, 0, 0, -1, - NULL, NULL, NULL, NULL, nonlang_ok ? 2 : 1); -} - -static Scheme_Object *expected_lang(const char *prefix, int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_lang) -{ - if (get_lang > 1) { - return scheme_void; - } else { - mzchar chs[2]; - char *more; - - chs[0] = 0; - chs[1] = 0; - - if (ch == EOF) - more = "an end-of-file"; - else if (ch == SCHEME_SPECIAL) - more = "a non-character"; - else { - chs[0] = ch; - more = ""; - } - - scheme_read_err(port, stxsrc, line, col, pos, 1, ch, NULL, - "read-language: expected (after whitespace and comments)" - " `#lang ' or `#!' followed" - " immediately by a language name, found %s%s%5%s%s%s", - (*prefix || *chs) ? "`" : "", - prefix, chs, - (*prefix || *chs) ? "`" : "", - ((*prefix || *chs) && *more) ? " followed by " : "", - more); - - return NULL; - } -} - -/*========================================================================*/ /* precise GC traversers g*/ /*========================================================================*/ @@ -7068,7 +4423,6 @@ { GC_REG_TRAV(scheme_indent_type, mark_indent); GC_REG_TRAV(scheme_rt_compact_port, mark_cport); - GC_REG_TRAV(scheme_readtable_type, mark_readtable); GC_REG_TRAV(scheme_rt_read_params, mark_read_params); GC_REG_TRAV(scheme_rt_delay_load_info, mark_delay_load); GC_REG_TRAV(scheme_rt_unmarshal_info, mark_unmarshal_tables); diff -Nru racket-6.12+ppa1/src/racket/src/read_vector.inc racket-7.0+ppa1/src/racket/src/read_vector.inc --- racket-6.12+ppa1/src/racket/src/read_vector.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/read_vector.inc 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -/* "#(" has been read */ -/* or "#fl(" has been read */ -/* or "#fx(" has been read */ -static Scheme_Object * -FUNC_NAME (Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix) -/* requestLength == -1 => no request - requestLength == -2 => overflow */ -{ - Scheme_Object *lresult, *obj; - VEC_TYPE *vec; - ELMS_TYPE els; - ELM_TYPE elm; - int len, i; - char *vtype_str; - - vtype_str = VTYPE_STR; - - lresult = read_list(port, stxsrc, line, col, pos, opener, closer, - MZ_SHAPE, - 1, ht, indentation, params, table); - - if (requestLength == -2) { - scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer); - return NULL; - } - - if (stxsrc) - obj = ((Scheme_Stx *)lresult)->val; - else - obj = lresult; - - len = scheme_list_length(obj); - if (requestLength >= 0 && len > requestLength) { - char buffer[20]; - sprintf(buffer, "%" PRIdPTR, requestLength); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: %s length %ld is too small, " - "%d values provided", - vtype_str, requestLength, len); - return NULL; - } - if (requestLength < 0) - requestLength = len; - - vec = MK_VEC(); - els = ELMS_SELECTOR(vec); - for (i = 0; i < len ; i++) { - els[i] = ELM_SELECTOR(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - } - els = NULL; - if (i < requestLength) { - if (len) - elm = ELMS_SELECTOR(vec)[len - 1]; - else { - elm = ELM_MAKE_ZERO; - if (stxsrc) - elm = ELM_STX(elm); - } - - els = ELMS_SELECTOR(vec); - for (; i < requestLength; i++) { - els[i] = elm; - } - els = NULL; - } - - if (stxsrc) { - if (VEC_SIZE(vec) > 0) - SCHEME_SET_VECTOR_IMMUTABLE(vec); - ((Scheme_Stx *)lresult)->val = (Scheme_Object *) vec; - return lresult; - } else - return (Scheme_Object *) vec; -} -#undef FUNC_NAME -#undef VTYPE_STR -#undef VEC_TYPE -#undef ELMS_TYPE -#undef ELM_TYPE -#undef MZ_SHAPE -#undef MK_VEC -#undef ELMS_SELECTOR -#undef ELM_SELECTOR -#undef ELM_MAKE_ZERO -#undef ELM_STX -#undef VEC_SIZE - -/* vim: ft=c -*/ diff -Nru racket-6.12+ppa1/src/racket/src/regexp.c racket-7.0+ppa1/src/racket/src/regexp.c --- racket-6.12+ppa1/src/racket/src/regexp.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/regexp.c 2018-07-27 22:12:02.000000000 +0000 @@ -198,7 +198,7 @@ regbackdepends = NULL; regerrorproc = handler; regerrorval = NULL; - regc(MAGIC); + regc((char)MAGIC); if (reg(0, &flags, 0, 0, PARSE_CASE_SENS | PARSE_SINGLE_LINE | (pcre ? PARSE_PCRE : 0)) == 0) { if (regerrorval) return NULL; @@ -243,7 +243,7 @@ regcodemax = 0; regbackknown = NULL; regbackdepends = NULL; - regc(MAGIC); + regc((char)MAGIC); if (reg(0, &flags, 0, 0, PARSE_CASE_SENS | PARSE_SINGLE_LINE | (pcre ? PARSE_PCRE : 0)) == 0) { FAIL("unknown regexp failure (late)"); } @@ -6032,7 +6032,7 @@ END_XFORM_SKIP; #endif -void scheme_regexp_initialize(Scheme_Env *env) +void scheme_regexp_initialize(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC GC_REG_TRAV(scheme_regexp_type, mark_regexp); @@ -6043,30 +6043,30 @@ REGISTER_SO(empty_byte_string); empty_byte_string = scheme_alloc_byte_string(0, 0); - GLOBAL_PRIM_W_ARITY("byte-regexp", make_regexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("regexp", make_utf8_regexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("byte-pregexp", make_pregexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("pregexp", make_utf8_pregexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("regexp-match", compare, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match/end", compare_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match-positions", positions, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-positions/end", positions_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match?", compare_bool, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek", compare_peek, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions", positions_peek, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions/end", positions_peek_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-immediate", compare_peek_nonblock, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions-immediate", positions_peek_nonblock, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions-immediate/end", positions_peek_nonblock_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-replace", replace, 3, 4, env); - GLOBAL_PRIM_W_ARITY("regexp-replace*", replace_star, 3, 4, env); - - GLOBAL_FOLDING_PRIM("regexp?", regexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("byte-regexp?", byte_regexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("pregexp?", pregexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("byte-pregexp?", byte_pregexp_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("byte-regexp", make_regexp, 1, 2, env); + ADD_PRIM_W_ARITY("regexp", make_utf8_regexp, 1, 2, env); + ADD_PRIM_W_ARITY("byte-pregexp", make_pregexp, 1, 2, env); + ADD_PRIM_W_ARITY("pregexp", make_utf8_pregexp, 1, 2, env); + ADD_PRIM_W_ARITY("regexp-match", compare, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match/end", compare_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match-positions", positions, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-positions/end", positions_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match?", compare_bool, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek", compare_peek, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions", positions_peek, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions/end", positions_peek_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match-peek-immediate", compare_peek_nonblock, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions-immediate", positions_peek_nonblock, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions-immediate/end", positions_peek_nonblock_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-replace", replace, 3, 4, env); + ADD_PRIM_W_ARITY("regexp-replace*", replace_star, 3, 4, env); + + ADD_FOLDING_PRIM("regexp?", regexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("byte-regexp?", byte_regexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("pregexp?", pregexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("byte-pregexp?", byte_pregexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("regexp-max-lookbehind", regexp_lookbehind, 1, 1, 1, env); + ADD_FOLDING_PRIM("regexp-max-lookbehind", regexp_lookbehind, 1, 1, 1, env); } void scheme_init_regexp_places() diff -Nru racket-6.12+ppa1/src/racket/src/resolve.c racket-7.0+ppa1/src/racket/src/resolve.c --- racket-6.12+ppa1/src/racket/src/resolve.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/resolve.c 2018-07-27 22:12:02.000000000 +0000 @@ -44,7 +44,7 @@ struct Resolve_Info { MZTAG_IF_REQUIRED - char use_jit, in_module, in_proc, enforce_const, no_lift; + char in_module, in_proc, enforce_const, no_lift, need_instance_access; int current_depth; /* tracks the stack depth, so variables can be resolved relative to it; this depth is reset on entry to `lambda` forms */ @@ -53,25 +53,48 @@ for sorting */ int max_let_depth; /* filled in by sub-expressions to track the maximum stack depth experienced so far */ - Resolve_Prefix *prefix; - Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */ + Scheme_Linklet *linklet; mzshort toplevel_pos; /* tracks where the run-time prefix will be, relative to the current stack depth */ void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ - int stx_count; /* tracks the number of literal syntax objects used */ + struct Resolve_Info *top; /* for merging tl_map from lifted uses */ + Scheme_Hash_Tree *redirects; /* maps variables that will be from the closure to their stack depths for the enclosing `lambda` */ Scheme_Object *lifts; /* tracks functions lifted by closure conversion */ struct Resolve_Info *next; + + int num_toplevels; /* number of toplevels, initially, in `linklet`, + taking into account that some imports may be + dropped; lifting adds more */ + int *toplevel_starts; /* position within toplevels array where an + import instance or set of definitions + starts; add 1 to an import instance + position, and use 0 for definitions (which, + both cases, corresponds to adding 1 to + `instance_pos` in an + `Scheme_IR_Topelevel`). */ + int *toplevel_deltas; /* shifts for toplevels in the import range to + accomodate removals */ + + Scheme_Hash_Table *toplevel_defns; /* for pruning unused definitions, if + some definitions are unexported + resolved position -> definition + definition -> #f - not yet used + #t - enqueued + list - resolved with lifts + NULL - used or has side effect */ + + Scheme_Hash_Table *static_mode; /* defn pos or ref (cons pos flags) -> static-toplevel */ }; #define cons(a,b) scheme_make_pair(a,b) -static Scheme_Object * -resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, - int can_lift, int convert, int just_compute_lift, - Scheme_Object *precomputed_lift); +static Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info); +static Scheme_Object *resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, + int can_lift, int convert, int just_compute_lift, + Scheme_Object *precomputed_lift); static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda); static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v); static int resolve_info_lookup(Resolve_Info *resolve, Scheme_IR_Local *var, Scheme_Object **lifted, @@ -79,11 +102,10 @@ static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *var, int convert_shift); static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos); static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info); -static Scheme_Object *resolve_generate_stub_lift(void); +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info); +static Scheme_Object *resolve_generate_stub_lift(Resolve_Info *info); static int resolve_toplevel_pos(Resolve_Info *info); -static int resolve_quote_syntax_offset(int i, Resolve_Info *info); -static int resolve_quote_syntax_pos(Resolve_Info *info); -static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready); +static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int as_reference); static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info); static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl); static Scheme_Object *shift_lifted_reference(Scheme_Object *tl, Resolve_Info *info, int delta); @@ -92,6 +114,14 @@ static int resolve_is_inside_proc(Resolve_Info *info); static int resolve_has_toplevel(Resolve_Info *info); static void set_tl_pos_used(Resolve_Info *info, int pos); +static void install_static_prefix(Scheme_Linklet *linket, Resolve_Info *ri); +static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start); +static void enable_expression_resolve_lifts(Resolve_Info *ri); +static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts); +static void prune_unused_imports(Scheme_Linklet *linklet); +static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv); +static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet); +static Resolve_Info *resolve_info_create(Scheme_Linklet *rp, int enforce_const, int static_mode); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -232,7 +262,7 @@ if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->args[i], info); + le = resolve_expr(app->args[i], info); app->args[i] = le; } } @@ -315,13 +345,13 @@ info = resolve_info_extend(orig_info, 1, 0); if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rator, info); + le = resolve_expr(app->rator, info); app->rator = le; } else already_resolved_arg_count--; if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rand, info); + le = resolve_expr(app->rand, info); app->rand = le; } else already_resolved_arg_count--; @@ -422,21 +452,21 @@ if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rator, info); + le = resolve_expr(app->rator, info); app->rator = le; } if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rand1, info); + le = resolve_expr(app->rand1, info); app->rand1 = le; } if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rand2, info); + le = resolve_expr(app->rand2, info); app->rand2 = le; } @@ -469,9 +499,9 @@ b = (Scheme_Branch_Rec *)o; - t = scheme_resolve_expr(b->test, info); - tb = scheme_resolve_expr(b->tbranch, info); - fb = scheme_resolve_expr(b->fbranch, info); + t = resolve_expr(b->test, info); + tb = resolve_expr(b->tbranch, info); + fb = resolve_expr(b->fbranch, info); b->test = t; b->tbranch = tb; @@ -485,9 +515,9 @@ Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_resolve_expr(wcm->key, info); - v = scheme_resolve_expr(wcm->val, info); - b = scheme_resolve_expr(wcm->body, info); + k = resolve_expr(wcm->key, info); + v = resolve_expr(wcm->val, info); + b = resolve_expr(wcm->body, info); wcm->key = k; wcm->val = v; wcm->body = b; @@ -562,7 +592,7 @@ for (i = s->count; i--; ) { Scheme_Object *le; - le = scheme_resolve_expr(s->array[i], info); + le = resolve_expr(s->array[i], info); s->array[i] = le; } @@ -576,50 +606,37 @@ static Scheme_Object * define_values_resolve(Scheme_Object *data, Resolve_Info *rslv) { - intptr_t cnt = 0; - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0], *l, *a; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1], *vec; + intptr_t i, cnt = SCHEME_DEFN_VAR_COUNT(data); + Scheme_Object *val, *a; + Scheme_IR_Toplevel *var; - /* If this is a module-level definition: for each variable, if the - defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then + /* If a defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then resolve to a top-level reference with SCHEME_TOPLEVEL_SEAL, so - that we know to set GLOS_IS_IMMUTATED at run time. */ - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (rslv->in_module - && rslv->enforce_const - && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) { - a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_SEAL); - } - a = resolve_toplevel(rslv, a, 0); - SCHEME_CAR(l) = a; - cnt++; - } + that we know to set GLOB_IS_IMMUTATED at run time. */ - vec = scheme_make_vector(cnt + 1, NULL); - cnt = 1; - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l); + for (i = 0; i < cnt; i++) { + var = SCHEME_DEFN_VAR(data, i); + a = resolve_toplevel(rslv, (Scheme_Object *)var, 0); + if (rslv->enforce_const + && (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_MUTATED))) + a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_SEAL); + SCHEME_DEFN_VAR_(data, i) = a; } - val = scheme_resolve_expr(val, rslv); - SCHEME_VEC_ELS(vec)[0] = val; + val = resolve_expr(SCHEME_DEFN_RHS(data), rslv); + SCHEME_DEFN_RHS(data) = val; - vec->type = scheme_define_values_type; - return vec; + return data; } static void resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs) { Scheme_Object *decl, *vec, *pr; - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = rhs; - SCHEME_VEC_ELS(vec)[1] = var; - - vec->type = scheme_define_values_type; - - decl = vec; + decl = scheme_make_vector(2, NULL); + decl->type = scheme_define_values_type; + SCHEME_DEFN_RHS(decl) = rhs; + SCHEME_DEFN_VAR_(decl, 0) = var; vec = info->lifts; pr = cons(decl, SCHEME_VEC_ELS(vec)[0]); @@ -633,7 +650,7 @@ char no_lift; a = SCHEME_VEC_ELS(data)[0]; - a = scheme_resolve_expr(a, rslv); + a = resolve_expr(a, rslv); SCHEME_VEC_ELS(data)[0] = a; /* Don't lift closures in the inline variant, since that @@ -642,7 +659,7 @@ a = SCHEME_VEC_ELS(data)[1]; no_lift = rslv->no_lift; rslv->no_lift = 1; - a = scheme_resolve_expr(a, rslv); + a = resolve_expr(a, rslv); rslv->no_lift = no_lift; SCHEME_VEC_ELS(data)[1] = a; @@ -658,7 +675,7 @@ var = sb->var; val = sb->val; - val = scheme_resolve_expr(val, rslv); + val = resolve_expr(val, rslv); if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { Scheme_Let_Value *lv; @@ -681,7 +698,7 @@ return (Scheme_Object *)lv; } - var = scheme_resolve_expr(var, rslv); + var = resolve_expr(var, rslv); sb->var = var; sb->val = val; @@ -694,22 +711,22 @@ { Scheme_Object *v; - v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv); + v = resolve_expr(SCHEME_PTR2_VAL(data), rslv); SCHEME_PTR2_VAL(data) = v; v = SCHEME_PTR1_VAL(data); - if (SAME_OBJ(v, scheme_true) - || SAME_OBJ(v, scheme_false)) { + if (SCHEME_SYMBOLP(v) /* => primitive instance */ + || SAME_OBJ(v, scheme_false) /* => anonymous variable */ + || SAME_OBJ(v, scheme_true)) { /* simplified local */ if (SCHEME_TRUEP(v)) SCHEME_VARREF_FLAGS(data) |= 0x1; /* => constant */ - v = SCHEME_PTR2_VAL(data); } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { - v = scheme_resolve_expr(v, rslv); + v = resolve_expr(v, rslv); if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) SCHEME_VARREF_FLAGS(data) |= 0x1; /* because mutable would be unbox */ - v = SCHEME_PTR2_VAL(data); + v = scheme_true; } else - v = scheme_resolve_expr(v, rslv); + v = resolve_expr(v, rslv); SCHEME_PTR1_VAL(data) = v; return data; @@ -723,8 +740,8 @@ f = SCHEME_PTR1_VAL(data); e = SCHEME_PTR2_VAL(data); - f = scheme_resolve_expr(f, rslv); - e = scheme_resolve_expr(e, rslv); + f = resolve_expr(f, rslv); + e = resolve_expr(e, rslv); SCHEME_PTR1_VAL(data) = f; SCHEME_PTR2_VAL(data) = e; @@ -747,10 +764,10 @@ Scheme_IR_Local *var; Resolve_Info *rslv = orig_rslv; - e = scheme_resolve_expr(wcm->key, rslv); + e = resolve_expr(wcm->key, rslv); wcm->key = e; - e = scheme_resolve_expr(wcm->val, rslv); + e = resolve_expr(wcm->val, rslv); wcm->val = e; rslv = resolve_info_extend(rslv, 1, 0); @@ -760,7 +777,17 @@ var->resolve.co_depth = rslv->current_depth; var->resolve.lex_depth = rslv->current_lex_depth; - e = scheme_resolve_expr(SCHEME_CDR(wcm->body), rslv); + e = resolve_expr(SCHEME_CDR(wcm->body), rslv); + + if (var->mutated) { + Scheme_Object *bcode; + bcode = scheme_alloc_object(); + bcode->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(bcode) = scheme_make_integer(0); + SCHEME_PTR2_VAL(bcode) = e; + e = bcode; + } + wcm->body = e; merge_resolve(orig_rslv, rslv); @@ -791,95 +818,6 @@ return expr; } -static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) -{ - Comp_Prefix *cp; - Resolve_Prefix *rp; - Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec; - Resolve_Info *einfo; - int len; - - cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; - dummy = SCHEME_VEC_ELS(data)[1]; - names = SCHEME_VEC_ELS(data)[2]; - val = SCHEME_VEC_ELS(data)[3]; - - rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); - - dummy = scheme_resolve_expr(dummy, info); - - einfo = scheme_resolve_info_create(rp); - - val = scheme_resolve_expr(val, einfo); - - rp = scheme_remap_prefix(rp, einfo); - - base_stack_depth = scheme_make_integer(einfo->max_let_depth); - - len = scheme_list_length(names); - - vec = scheme_make_vector(len + 4, NULL); - SCHEME_VEC_ELS(vec)[0] = val; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[2] = base_stack_depth; - SCHEME_VEC_ELS(vec)[3] = dummy; - - len = 4; - while (SCHEME_PAIRP(names)) { - SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names); - names = SCHEME_CDR(names); - } - - vec->type = scheme_define_syntaxes_type; - - return vec; -} - -static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) -{ - return do_define_syntaxes_resolve(data, info); -} - -static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info *info) -{ - Comp_Prefix *cp; - Resolve_Prefix *rp; - Scheme_Object *l, *p, *a, *base_stack_depth, *dummy, *vec; - Resolve_Info *einfo; - - cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; - dummy = SCHEME_VEC_ELS(data)[1]; - l = SCHEME_VEC_ELS(data)[2]; - - rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); - - dummy = scheme_resolve_expr(dummy, info); - - einfo = scheme_resolve_info_create(rp); - - p = scheme_null; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - a = scheme_resolve_expr(a, einfo); - p = scheme_make_pair(a, p); - l = SCHEME_CDR(l); - } - l = scheme_reverse(p); - - rp = scheme_remap_prefix(rp, einfo); - - base_stack_depth = scheme_make_integer(einfo->max_let_depth); - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = l; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[2] = base_stack_depth; - SCHEME_VEC_ELS(vec)[3] = dummy; - vec->type = scheme_begin_for_syntax_type; - - return vec; -} - /*========================================================================*/ /* let, let-values, letrec, etc. */ /*========================================================================*/ @@ -890,9 +828,12 @@ if (SCHEME_RPAIRP(v)) return 1; - return (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type) - && ((SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_FLAGS_MASK) - >= SCHEME_TOPLEVEL_CONST)); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(v), scheme_static_toplevel_type)) + return ((SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_FLAGS_MASK) + >= SCHEME_TOPLEVEL_CONST); + + return 0; } static int is_closed_reference(Scheme_Object *v) @@ -1075,7 +1016,7 @@ && SAME_TYPE(SCHEME_TYPE(irlv->value), scheme_ir_lambda_type)) le = resolve_lambda(irlv->value, linfo, 1, 1, 0, NULL); else - le = scheme_resolve_expr(irlv->value, linfo); + le = resolve_expr(irlv->value, linfo); if (is_lifted_reference(le)) { MZ_ASSERT(!info->no_lift); @@ -1108,7 +1049,7 @@ } } - body = scheme_resolve_expr(body, linfo); + body = resolve_expr(body, linfo); if (last) ((Scheme_Let_One *)last)->body = body; else @@ -1206,7 +1147,7 @@ if (resolve_phase == 0) lift = scheme_resolve_generate_stub_closure(); else if (resolve_phase == 1) - lift = resolve_generate_stub_lift(); + lift = resolve_generate_stub_lift(info); else lift = NULL; MZ_ASSERT(!info->no_lift || !lift); @@ -1390,7 +1331,7 @@ `resolve_omittable` fields. */ if (all_unused_and_omittable(head)) { /* All unused and omittable */ - return scheme_resolve_expr(body, info); + return resolve_expr(body, info); } } } @@ -1473,7 +1414,7 @@ /* Change a `[() (begin expr (values))]' clause, which can be generated by internal-definition expansion, into a `begin' */ - expr = scheme_resolve_expr(expr, linfo); + expr = resolve_expr(expr, linfo); expr = scheme_make_sequence_compilation(scheme_make_pair(expr, scheme_make_pair(scheme_false, scheme_null)), @@ -1492,7 +1433,7 @@ last_body = NULL; last_seq = expr; } else { - expr = scheme_resolve_expr(irlv->value, linfo); + expr = resolve_expr(irlv->value, linfo); lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); if (last) @@ -1554,7 +1495,7 @@ } /* Resolve body: */ - body = scheme_resolve_expr((Scheme_Object *)irlv, linfo); + body = resolve_expr((Scheme_Object *)irlv, linfo); while (SCHEME_PAIRP(boxes)) { /* See bangboxenv... */ @@ -1680,7 +1621,9 @@ if (!lifted) return 1; if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type) - || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)) + || SAME_TYPE(SCHEME_TYPE(lifted), scheme_static_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_static_toplevel_type)) return 1; } } @@ -1742,7 +1685,7 @@ cl->arg_types = NULL; } - has_tl = cl->has_tl; + has_tl = (info->static_mode ? 0 : cl->has_tl); /* Add original closure content to `captured`, pruning variables that are lifted (so the closure might get smaller). The @@ -1763,7 +1706,8 @@ if (lifted) { /* Drop lifted binding from closure. */ if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type) - || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)) { + || (SCHEME_RPAIRP(lifted) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type))) { /* Former local variable is now a top-level variable. */ has_tl = 1; } @@ -1800,6 +1744,7 @@ Scheme_IR_Local *var = (Scheme_IR_Local *)SCHEME_VEC_ELS(vec)[j+1]; if (!scheme_hash_get(captured, (Scheme_Object *)var)) { /* Need to capture an extra binding: */ + MZ_ASSERT(!var->resolve.lifted); scheme_hash_set(captured, (Scheme_Object *)var, scheme_make_integer(captured->count)); if (HAS_UNBOXABLE_TYPE(var)) need_type_map = 1; @@ -1961,7 +1906,7 @@ /* Resolve the closure body: */ { Scheme_Object *code; - code = scheme_resolve_expr(lam->body, new_info); + code = resolve_expr(lam->body, new_info); lam->body = code; } @@ -2022,7 +1967,7 @@ if (just_compute_lift > 1) result = resolve_invent_toplevel(info); else - result = resolve_generate_stub_lift(); + result = resolve_generate_stub_lift(info); } else { Scheme_Object *tl, *defn_tl; if (precomputed_lift) { @@ -2037,6 +1982,7 @@ if (has_tl) closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */ result = tl; + merge_resolve_tl_map(new_info->top, new_info); } } else if (!just_compute_lift) { merge_resolve(info, new_info); @@ -2075,157 +2021,282 @@ } /*========================================================================*/ -/* module */ +/* linklet */ /*========================================================================*/ -static int has_syntax_constants(Scheme_Module *m) -{ - int i, j; - Scheme_Object *e; - Resolve_Prefix *rp; - - if (m->prefix->num_stxes) - return 1; - - for (j = m->num_phases; j-- > 1; ) { - for (i = SCHEME_VEC_SIZE(m->bodies[j]); i--; ) { - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - if (rp->num_stxes) - return 1; - } - } - - return 0; -} - -static Scheme_Object * -module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) +Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *linklet, int enforce_const, int static_mode) { - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *b, *lift_vec, *body = scheme_null; - Resolve_Prefix *rp; + Scheme_Object *lift_vec, *body = scheme_null, *new_bodies; Resolve_Info *rslv; - int i, cnt; + int i, cnt, num_lifts; - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; + rslv = resolve_info_create(linklet, enforce_const, static_mode); + enable_expression_resolve_lifts(rslv); + + if (linklet->num_exports < SCHEME_VEC_SIZE(linklet->defns)) { + /* Some definitions are not exported, so resolve in a way + that lets us GC unused definitions */ + prepare_definition_queue(linklet, rslv); } - rp = scheme_resolve_prefix(0, m->comp_prefix, m->insp); - m->comp_prefix = NULL; + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + Scheme_Object *e; - b = scheme_resolve_expr(m->dummy, old_rslv); - m->dummy = b; + e = SCHEME_VEC_ELS(linklet->bodies)[i]; - rslv = scheme_resolve_info_create(rp); - rslv->enforce_const = old_rslv->enforce_const; - rslv->in_module = 1; - scheme_enable_expression_resolve_lifts(rslv); + if (!rslv->toplevel_defns || !scheme_hash_get(rslv->toplevel_defns, e)) { + e = resolve_expr(e, rslv); - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - for (i = 0; i < cnt; i++) { - Scheme_Object *e; - e = scheme_resolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], rslv); - - /* add lift just before the expression that introduced it; - this ordering is needed for bytecode validation of - constantness for top-level references */ - lift_vec = rslv->lifts; - if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { - body = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], body); - SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + /* add lift just before the expression that introduced it; + this ordering is needed for bytecode validation of + constantness for top-level references */ + lift_vec = rslv->lifts; + if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { + body = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], body); + SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + } } body = scheme_make_pair(e, body); } - m->max_let_depth = rslv->max_let_depth; + /* If we're pruning unused definitions, handle the stack of pending definitions */ + if (rslv->toplevel_defns) { + Scheme_Object *l, *e; + + /* Loop while the definition stack is non-empty */ + while (1) { + l = scheme_hash_get(rslv->toplevel_defns, scheme_null); + if (SCHEME_NULLP(l)) + break; + scheme_hash_set(rslv->toplevel_defns, scheme_null, SCHEME_CDR(l)); + + l = SCHEME_CAR(l); + e = scheme_make_pair(resolve_expr(l, rslv), scheme_null); + lift_vec = rslv->lifts; + if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { + e = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], e); + SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + } + scheme_hash_set(rslv->toplevel_defns, l, e); + } + + /* Update the body list, flattening lifts as we go */ + for (l = body, body = scheme_null; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + e = scheme_hash_get(rslv->toplevel_defns, SCHEME_CAR(l)); + if (e) { + if (SCHEME_PAIRP(e)) + body = scheme_append(e, body); + else { + /* Never reached, so just drop it */ + remove_definition_names(SCHEME_CAR(l), linklet); + } + } else + body = scheme_make_pair(SCHEME_CAR(l), body); + } + } else + body = scheme_reverse(body); + + linklet->max_let_depth = rslv->max_let_depth; + linklet->need_instance_access = rslv->need_instance_access; lift_vec = rslv->lifts; - rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); + num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); + + /* Recompute body array: */ + cnt = scheme_list_length(body); + new_bodies = scheme_make_vector(cnt, scheme_false); + for (i = 0; i < cnt; i++, body = SCHEME_CDR(body)) { + SCHEME_VEC_ELS(new_bodies)[i] = SCHEME_CAR(body); + } + + linklet->bodies = new_bodies; + + if (num_lifts) { + /* Adjust the `exports` array to take into account lifted + definitions */ + extend_linklet_defns(linklet, num_lifts); + } + + /* Adjust the imports vector of vectors to drop unused imports at + the level of variables */ + prune_unused_imports(linklet); + + if (static_mode) + install_static_prefix(linklet, rslv); + + return linklet; +} - body = scheme_list_to_vector(scheme_reverse(body)); - m->bodies[0] = body; +static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv) +{ + Scheme_Hash_Table *ht; + Scheme_Object *e, *var; + int i, j, cnt, vcnt; - rp = scheme_remap_prefix(rp, rslv); + ht = scheme_make_hash_table(SCHEME_hash_ptr); + rslv->toplevel_defns = ht; - m->prefix = rp; + /* Queue is initially empty: */ + scheme_hash_set(rslv->toplevel_defns, scheme_null, scheme_null); - /* Exp-time body was resolved during compilation */ - - /* If there are no syntax objects in the module, then there are no - macros that can reach bindings in the bindings table whose marks - are not a subset of the module context. */ - if (m->rn_stx && SCHEME_STXP(m->rn_stx) && !has_syntax_constants(m)) { - if (m->binding_names) { - b = scheme_prune_bindings_table(m->binding_names, m->rn_stx, scheme_make_integer(0)); - m->binding_names = b; - } - if (m->et_binding_names) { - b = scheme_prune_bindings_table(m->et_binding_names, m->rn_stx, scheme_make_integer(1)); - m->et_binding_names = b; - } - if (m->other_binding_names) { - intptr_t i; - Scheme_Object *k, *val; - Scheme_Hash_Tree *ht; - - ht = scheme_make_hash_tree(SCHEME_hashtr_equal); - - if (SCHEME_HASHTRP(m->other_binding_names)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)m->other_binding_names; - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &val); - val = scheme_prune_bindings_table(val, m->rn_stx, k); - ht = scheme_hash_tree_set(ht, k, val); + cnt = SCHEME_VEC_SIZE(linklet->bodies); + + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(linklet->bodies)[i]; + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + vcnt = SCHEME_DEFN_VAR_COUNT(e); + if (SCHEME_DEFN_CAN_OMITP(e) + || scheme_omittable_expr(SCHEME_DEFN_RHS(e), vcnt, 5, 0, NULL, NULL)) { + for (j = 0; j < vcnt; j++) { + var = SCHEME_DEFN_VAR_(e, j); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)); + if (SCHEME_IR_TOPLEVEL_POS(var) < (SCHEME_LINKLET_PREFIX_PREFIX + + linklet->num_total_imports + + linklet->num_exports)) { + /* variable is exported */ + break; + } } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)m->other_binding_names; - for (i = t->size; i--; ) { - if (t->vals[i]) { - k = t->keys[i]; - val = t->vals[i]; - val = scheme_prune_bindings_table(val, m->rn_stx, k); - ht = scheme_hash_tree_set(ht, k, val); + if (j >= vcnt) { + scheme_hash_set(rslv->toplevel_defns, e, scheme_true); + for (j = 0; j < vcnt; j++) { + int tl_pos; + var = SCHEME_DEFN_VAR_(e, j); + tl_pos = SCHEME_IR_TOPLEVEL_POS(var) + 1 + linklet->num_total_imports; + scheme_hash_set(rslv->toplevel_defns, scheme_make_integer(tl_pos), e); } } } - - m->other_binding_names = (Scheme_Object *)ht; } } +} +static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet) +{ + int i, cnt; + Scheme_Object *var, *name; + Scheme_Hash_Tree *source_names; - { - /* resolve submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - scheme_resolve_expr(SCHEME_CAR(p), old_rslv); - p = SCHEME_CDR(p); - } - } + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(defn), scheme_define_values_type)); + + cnt = SCHEME_DEFN_VAR_COUNT(defn); + for (i = 0; i < cnt; i++) { + var = SCHEME_DEFN_VAR_(defn, i); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)); + + name = SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)]; + + if (linklet->source_names) { + source_names = scheme_hash_tree_set(linklet->source_names, name, NULL); + linklet->source_names = source_names; } + + SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)] = scheme_false; } +} - return data; +static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts) +{ + int cnt, i; + Scheme_Object *new_defns, *b; + Scheme_Hash_Table *names; + + linklet->num_lifts = num_lifts; + cnt = SCHEME_VEC_SIZE(linklet->defns) + num_lifts; + new_defns = scheme_make_vector(cnt, scheme_false); + names = scheme_make_hash_table(SCHEME_hash_ptr); + + for (i = 0; i < SCHEME_VEC_SIZE(linklet->defns); i++) { + SCHEME_VEC_ELS(new_defns)[i] = SCHEME_VEC_ELS(linklet->defns)[i]; + scheme_hash_set(names, SCHEME_VEC_ELS(new_defns)[i], scheme_true); + } + + for (; i < cnt; i++) { + b = generate_lifted_name(names, i - SCHEME_VEC_SIZE(linklet->defns)); + SCHEME_VEC_ELS(new_defns)[i] = b; + } + + linklet->defns = new_defns; } -static Scheme_Object * -top_level_require_resolve(Scheme_Object *data, Resolve_Info *rslv) +static void prune_unused_imports(Scheme_Linklet *linklet) { - Scheme_Object *dummy = SCHEME_PTR1_VAL(data); + int i, new_i = 0, j; + int num_total_imports; + Scheme_Object *vec, *new_vec, *new_importss; + + for (i = SCHEME_VEC_SIZE(linklet->importss); i--; ) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) + new_i++; + } + if (new_i != SCHEME_VEC_SIZE(linklet->importss)) { + new_importss = scheme_make_vector(new_i, NULL); + new_i = 0; + } else + new_importss = NULL; + + num_total_imports = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + int drop = 0, len, drop_all = 0; + vec = SCHEME_VEC_ELS(linklet->importss)[i]; + if (SCHEME_INTP(vec)) { + len = SCHEME_INT_VAL(vec); + num_total_imports += len; + drop = len; + drop_all = 1; + } else { + len = SCHEME_VEC_SIZE(vec); + num_total_imports += len; + for (j = 0; j < len; j++) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j])) + drop++; + } + } + if (drop) { + num_total_imports -= drop; + drop = len - drop; + if (!drop_all) { + new_vec = scheme_make_vector(drop, NULL); + for (j = len; j--; ) { + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j])) { + SCHEME_VEC_ELS(new_vec)[--drop] = SCHEME_VEC_ELS(vec)[j]; + } + } + MZ_ASSERT(!drop); + SCHEME_VEC_ELS(linklet->importss)[i] = new_vec; + } + } + if (!drop_all && new_importss) + SCHEME_VEC_ELS(new_importss)[new_i++] = SCHEME_VEC_ELS(linklet->importss)[i]; + } - dummy = scheme_resolve_expr(dummy, rslv); + if (new_importss) { + MZ_ASSERT(new_i == SCHEME_VEC_SIZE(new_importss)); + linklet->importss = new_importss; + } - SCHEME_PTR1_VAL(data) = dummy; + linklet->num_total_imports = num_total_imports; - return data; + MZ_ASSERT(!linklet->import_shapes || (linklet->num_total_imports == SCHEME_VEC_SIZE(linklet->import_shapes))); +} + +static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start) +{ + char buf[32]; + Scheme_Object *n; + + while (1) { + sprintf(buf, "?lifted.%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + if (!scheme_hash_get(used_names, n)) { + scheme_hash_set(used_names, n, scheme_true); + return n; + } + search_start++; + } } /*========================================================================*/ @@ -2241,10 +2312,10 @@ p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_resolve_expr(expr, info); + return resolve_expr(expr, info); } -Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) +Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info) { Scheme_Type type = SCHEME_TYPE(expr); @@ -2289,7 +2360,6 @@ return resolve_application3(expr, info, 0); case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: return resolve_sequence(expr, info); case scheme_branch_type: return resolve_branch(expr, info); @@ -2301,42 +2371,15 @@ return scheme_resolve_lets(expr, info); case scheme_ir_toplevel_type: return resolve_toplevel(info, expr, 1); - case scheme_ir_quote_syntax_type: - { - Scheme_Quote_Syntax *qs; - int i, c, p; - - i = SCHEME_LOCAL_POS(expr); - i = resolve_quote_syntax_offset(i, info); - c = resolve_toplevel_pos(info); - p = resolve_quote_syntax_pos(info); - - set_tl_pos_used(info, i+p+1); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; - } case scheme_variable_type: - case scheme_module_variable_type: scheme_signal_error("got top-level in wrong place"); return 0; case scheme_define_values_type: return define_values_resolve(expr, info); case scheme_inline_variant_type: return inline_variant_resolve(expr, info); - case scheme_define_syntaxes_type: - return define_syntaxes_resolve(expr, info); - case scheme_begin_for_syntax_type: - return begin_for_syntax_resolve(expr, info); case scheme_set_bang_type: return set_resolve(expr, info); - case scheme_require_form_type: - return top_level_require_resolve(expr, info); case scheme_varref_form_type: return ref_resolve(expr, info); case scheme_apply_values_type: @@ -2345,8 +2388,6 @@ return with_immed_mark_resolve(expr, info); case scheme_case_lambda_sequence_type: return case_lambda_resolve(expr, info); - case scheme_module_type: - return module_expr_resolve(expr, info); case scheme_boxenv_type: scheme_signal_error("internal error: no boxenv resolve"); default: @@ -2354,28 +2395,6 @@ } } -Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info) -{ - Scheme_Object *first = scheme_null, *last = NULL; - - while (SCHEME_PAIRP(expr)) { - Scheme_Object *pr; - - pr = scheme_make_pair(scheme_resolve_expr(SCHEME_CAR(expr), info), - scheme_null); - - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - expr = SCHEME_CDR(expr); - } - - return first; -} - static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *v, int convert_shift) { /* If a variable added as an argument for closure conversion is mutable, @@ -2404,18 +2423,15 @@ int pos = SCHEME_TOPLEVEL_POS(tl); int depth; + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)); + depth = resolve_toplevel_pos(info); tl = scheme_make_toplevel(depth + delta, pos, - 1, SCHEME_TOPLEVEL_CONST); /* register if non-stub: */ - if (pos >= (info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes - ? 1 - : 0))) + if (pos >= info->num_toplevels) set_tl_pos_used(info, pos); return tl; @@ -2425,122 +2441,62 @@ /* compile-time env for resolve */ /*========================================================================*/ -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc) -{ - Resolve_Prefix *rp; - Scheme_Object **tls, **stxes, *m; - Scheme_Hash_Table *ht; - int i; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = cp->num_toplevels; - rp->num_stxes = cp->num_stxes; - - if (rp->num_toplevels) - tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); - else - tls = NULL; - if (rp->num_stxes) - stxes = MALLOC_N(Scheme_Object*, rp->num_stxes); - else - stxes = NULL; - - rp->toplevels = tls; - rp->stxes = stxes; - - ht = cp->toplevels; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - m = ht->keys[i]; - if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base) - && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) { - /* Reduce self-referece to just a symbol: */ - m = ((Module_Variable *)m)->sym; - } - } - tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; - } - } - } - - ht = cp->stxes; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i]; - } - } - } - - rp->src_insp_desc = insp_desc; - - return rp; -} - -Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri) -{ - /* Rewrite stxes list based on actual uses at resolve pass. - If we have no lifts, we can just drop unused stxes. - Otherwise, if any stxes go unused, we just have to replace them - with NULL. */ - int i, cnt; - Scheme_Object **new_stxes, *v; - - if (!rp->num_stxes) - return rp; - - if (rp->num_lifts) - cnt = rp->num_stxes; - else - cnt = (int)ri->stx_map->count; - - new_stxes = MALLOC_N(Scheme_Object *, cnt); - - for (i = 0; i < rp->num_stxes; i++) { - if (ri->stx_map) - v = scheme_hash_get(ri->stx_map, scheme_make_integer(i)); - else - v = NULL; - if (v) { - new_stxes[SCHEME_INT_VAL(v)] = rp->stxes[i]; - } - } - - rp->stxes = new_stxes; - rp->num_stxes = cnt; - - return rp; -} - -Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp) +static Resolve_Info *resolve_info_create(Scheme_Linklet *linklet, int enforce_const, int static_mode) { Resolve_Info *naya; - Scheme_Object *b; - Scheme_Hash_Table *ht; - + int *toplevel_starts, pos, dpos, i, j; + int *toplevel_deltas; + naya = MALLOC_ONE_RT(Resolve_Info); #ifdef MZTAG_REQUIRED naya->type = scheme_rt_resolve_info; #endif - naya->prefix = rp; naya->current_depth = 1; /* initial slot for prefix */ naya->max_let_depth = naya->current_depth; naya->current_lex_depth = 0; naya->next = NULL; + naya->enforce_const = enforce_const; + naya->linklet = linklet; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - naya->stx_map = ht; + if (static_mode) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_equal(); + naya->static_mode = ht; + } + + toplevel_starts = MALLOC_N_ATOMIC(int, SCHEME_VEC_SIZE(linklet->importss) + 1); + toplevel_deltas = MALLOC_N_ATOMIC(int, (linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX)); + pos = SCHEME_LINKLET_PREFIX_PREFIX; + dpos = pos; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + toplevel_starts[i+1] = pos; + if (SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + /* This import is getting dropped */ + pos += SCHEME_INT_VAL(SCHEME_VEC_ELS(linklet->importss)[i]); + } else { + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++) { + toplevel_deltas[pos] = (dpos - pos); + if (SCHEME_FALSEP(SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j])) + toplevel_deltas[pos] = 0xFFFFFF; /* shouldn't be used */ + else + dpos++; + pos++; + } + } + } + toplevel_starts[0] = dpos; - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - naya->use_jit = SCHEME_TRUEP(b); + naya->num_toplevels = (dpos + SCHEME_VEC_SIZE(linklet->defns)); + + naya->toplevel_starts = toplevel_starts; + naya->toplevel_deltas = toplevel_deltas; + + naya->top = naya; return naya; } -void scheme_enable_expression_resolve_lifts(Resolve_Info *ri) +static void enable_expression_resolve_lifts(Resolve_Info *ri) { Scheme_Object *lift_vec; @@ -2550,46 +2506,6 @@ ri->lifts = lift_vec; } -Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri) -{ - Scheme_Object *lift_vec, *lifts; - Scheme_Sequence *s; - int n, i; - - lift_vec = ri->lifts; - n = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); - if (n) { - rp->num_lifts = n; - lifts = SCHEME_VEC_ELS(lift_vec)[0]; - - s = scheme_malloc_sequence(n + 1); - s->so.type = scheme_sequence_type; - s->count = n + 1; - for (i = 0; i < n; i++, lifts = SCHEME_CDR(lifts)) { - s->array[i] = SCHEME_CAR(lifts); - } - s->array[i] = expr; - - return (Scheme_Object *)s; - } else - return expr; -} - -void scheme_resolve_info_enforce_const(Resolve_Info *ri, int enforce_const) -{ - ri->enforce_const = enforce_const; -} - -int scheme_resolve_info_use_jit(Resolve_Info *ri) -{ - return ri->use_jit; -} - -int scheme_resolve_info_max_let_depth(Resolve_Info *ri) -{ - return ri->max_let_depth; -} - static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda) /* size = number of appended items in run-time frame */ { @@ -2599,11 +2515,10 @@ #ifdef MZTAG_REQUIRED naya->type = scheme_rt_resolve_info; #endif - naya->prefix = info->prefix; - naya->stx_map = info->stx_map; + naya->linklet = info->linklet; naya->next = (lambda ? NULL : info); - naya->use_jit = info->use_jit; naya->enforce_const = info->enforce_const; + naya->static_mode = info->static_mode; naya->current_depth = (lambda ? 0 : info->current_depth) + size; naya->current_lex_depth = info->current_lex_depth + size; naya->toplevel_pos = (lambda @@ -2616,6 +2531,11 @@ naya->max_let_depth = naya->current_depth; naya->in_proc = lambda || info->in_proc; naya->lifts = info->lifts; + naya->num_toplevels = info->num_toplevels; + naya->toplevel_starts = info->toplevel_starts; + naya->toplevel_deltas = info->toplevel_deltas; + naya->top = info->top; + naya->toplevel_defns = info->toplevel_defns; return naya; } @@ -2658,31 +2578,46 @@ return old_tl_map; } -static void set_tl_pos_used(Resolve_Info *info, int pos) +static void set_tl_pos_used(Resolve_Info *info, int tl_pos) { - int tl_pos; void *tl_map; - /* Fixnum-like bit packing avoids allocation in the common case of a - small prefix. We use 31 fixnum-like bits (even on a 64-bit - platform, and even though fixnums are only 30 bits). There's one - bit for each normal top-level, one bit for all syntax objects, - and one bit for each lifted top-level. */ - - if (pos > (info->prefix->num_toplevels + info->prefix->num_stxes)) - tl_pos = pos - info->prefix->num_stxes; /* lifted */ - else if (pos >= info->prefix->num_toplevels) - tl_pos = info->prefix->num_toplevels; /* any syntax object */ - else - tl_pos = pos; /* normal top level */ + if (!info->static_mode) { + /* Fixnum-like bit packing avoids allocation in the common case of a + small prefix. We use 31 fixnum-like bits (even on a 64-bit + platform, and even though fixnums are only 30 bits). There's one + bit for each normal top-level, one bit for all syntax objects, + and one bit for each lifted top-level. */ + + tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1); + info->tl_map = tl_map; - tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1); - info->tl_map = tl_map; + if ((uintptr_t)info->tl_map & 0x1) + info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1))); + else + ((int *)tl_map)[1 + (tl_pos / 32)] |= ((unsigned)1 << (tl_pos & 31)); + } - if ((uintptr_t)info->tl_map & 0x1) - info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1))); - else - ((int *)tl_map)[1 + (tl_pos / 32)] |= ((unsigned)1 << (tl_pos & 31)); + /* If we're pruning unused definitions, then ensure a newly referenced definition */ + if (info->toplevel_defns + && (tl_pos >= (SCHEME_LINKLET_PREFIX_PREFIX + + info->linklet->num_total_imports + + info->linklet->num_exports))) { + Scheme_Object *defn; + defn = scheme_hash_get(info->toplevel_defns, scheme_make_integer(tl_pos)); + if (defn) { + if (SAME_OBJ(scheme_true, scheme_hash_get(info->toplevel_defns, defn))) { + /* Enqueue the defn for traversal: */ + scheme_hash_set(info->toplevel_defns, + scheme_null, + scheme_make_pair(defn, + scheme_hash_get(info->toplevel_defns, scheme_null))); + /* Add to indicate that it's enqueued */ + scheme_hash_set(info->toplevel_defns, defn, scheme_false); + } + scheme_hash_set(info->toplevel_defns, scheme_make_integer(tl_pos), NULL); + } + } } static void *merge_tl_map(void *tl_map, void *new_tl_map) @@ -2708,12 +2643,8 @@ } } -static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info) +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info) { - if (new_info->next /* NULL => lambda */ - && (new_info->max_let_depth > info->max_let_depth)) - info->max_let_depth = new_info->max_let_depth; - if (!new_info->tl_map) { /* nothing to do */ } else { @@ -2721,13 +2652,25 @@ tl_map = merge_tl_map(info->tl_map, new_info->tl_map); info->tl_map = tl_map; } + + if (new_info->need_instance_access) + info->need_instance_access = 1; } -static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v) +static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info) { - Scheme_Hash_Tree *ht; + if (new_info->next /* NULL => lambda */ + && (new_info->max_let_depth > info->max_let_depth)) + info->max_let_depth = new_info->max_let_depth; - if (!info->redirects) { + merge_resolve_tl_map(info, new_info); +} + +static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v) +{ + Scheme_Hash_Tree *ht; + + if (!info->redirects) { ht = scheme_make_hash_tree(SCHEME_hashtr_eq); info->redirects = ht; } @@ -2775,9 +2718,51 @@ return info->current_depth - depth + convert_shift; } -static Scheme_Object *resolve_generate_stub_lift() +static Scheme_Object *make_static_toplevel(Scheme_Hash_Table *static_mode, int pos, int flags, int as_ref) +{ + Scheme_Object *key, *tl; + + if (as_ref) + key = scheme_make_pair(scheme_make_integer(pos), scheme_make_integer(flags)); + else + key = scheme_make_integer(pos); + + tl = scheme_hash_get(static_mode, key); + if (!tl) { + tl = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Toplevel); + tl->type = scheme_static_toplevel_type; + SCHEME_TOPLEVEL_POS(tl) = pos; + SCHEME_TOPLEVEL_FLAGS(tl) |= flags; + scheme_hash_set(static_mode, key, tl); + } + + return tl; +} + +static void install_static_prefix(Scheme_Linklet *linklet, Resolve_Info *ri) +{ + Scheme_Prefix *pf; + int i; + Scheme_Hash_Table *ht = ri->static_mode; + + /* Allocate prefix with one extra slot, which is used when + reading bytecode to cache Scheme_Toplevel values */ + pf = scheme_allocate_linklet_prefix(linklet, 1); + linklet->static_prefix = pf; + + for (i = 0; i < ht->size; i++) { + if (ht->vals[i]) { + SCHEME_STATIC_TOPLEVEL_PREFIX(ht->vals[i]) = pf; + } + } +} + +static Scheme_Object *resolve_generate_stub_lift(Resolve_Info *info) { - return scheme_make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST); + if (info->static_mode) + return make_static_toplevel(info->static_mode, 0, SCHEME_TOPLEVEL_CONST, 0); + else + return scheme_make_toplevel(0, 0, SCHEME_TOPLEVEL_CONST); } static int resolve_toplevel_pos(Resolve_Info *info) @@ -2793,51 +2778,46 @@ static int resolve_has_toplevel(Resolve_Info *info) { - return info->toplevel_pos >= 0; + return (info->toplevel_pos >= 0) || info->static_mode; } -static int resolve_quote_syntax_offset(int i, Resolve_Info *info) -{ - Scheme_Hash_Table *ht; - Scheme_Object *v; - - ht = info->stx_map; - - v = scheme_hash_get(ht, scheme_make_integer(i)); - if (!v) { - v = scheme_make_integer(ht->count); - scheme_hash_set(ht, scheme_make_integer(i), v); - } - - return (int)SCHEME_INT_VAL(v); -} - -static int resolve_quote_syntax_pos(Resolve_Info *info) -{ - return info->prefix->num_toplevels; -} - static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int as_reference) { int skip, pos; - skip = resolve_toplevel_pos(info); + if (info->static_mode) + skip = 0; + else + skip = resolve_toplevel_pos(info); - pos = SCHEME_TOPLEVEL_POS(expr); + if (SCHEME_IR_TOPLEVEL_INSTANCE(expr) == -1) { + if (SCHEME_IR_TOPLEVEL_POS(expr) == -1) { + /* (-1, -1) is the instance-access prefix slot */ + pos = 0; + info->need_instance_access = 1; + } else + pos = info->toplevel_starts[0] + SCHEME_IR_TOPLEVEL_POS(expr); + } else { + pos = (info->toplevel_starts[SCHEME_IR_TOPLEVEL_INSTANCE(expr) + 1] + SCHEME_IR_TOPLEVEL_POS(expr)); + pos += info->toplevel_deltas[pos]; + } - set_tl_pos_used(info, pos); + if (as_reference) + set_tl_pos_used(info, pos); - return scheme_make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */ - pos, - 1, - SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); + if (info->static_mode) + return make_static_toplevel(info->static_mode, pos, + SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)expr) & SCHEME_TOPLEVEL_FLAGS_MASK, + as_reference); + else + return scheme_make_toplevel(skip, pos, + SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)expr) & SCHEME_TOPLEVEL_FLAGS_MASK); } static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta) { return scheme_make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta, SCHEME_TOPLEVEL_POS(expr), - 1, SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); } @@ -2849,27 +2829,28 @@ skip = resolve_toplevel_pos(info); count = SCHEME_VEC_ELS(info->lifts)[1]; - pos = (int)(SCHEME_INT_VAL(count) - + info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes ? 1 : 0)); + pos = (int)(SCHEME_INT_VAL(count) + info->num_toplevels); count = scheme_make_integer(SCHEME_INT_VAL(count) + 1); SCHEME_VEC_ELS(info->lifts)[1] = count; set_tl_pos_used(info, pos); - return scheme_make_toplevel(skip, - pos, - 1, - SCHEME_TOPLEVEL_CONST); + if (info->static_mode) + return make_static_toplevel(info->static_mode, pos, SCHEME_TOPLEVEL_CONST, 0); + else + return scheme_make_toplevel(skip, + pos, + SCHEME_TOPLEVEL_CONST); } static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl) { - return scheme_make_toplevel(0, - SCHEME_TOPLEVEL_POS(tl), - 1, - SCHEME_TOPLEVEL_CONST); + if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)) + return scheme_make_toplevel(0, + SCHEME_TOPLEVEL_POS(tl), + SCHEME_TOPLEVEL_CONST); + else + return tl; } /*========================================================================*/ @@ -2890,50 +2871,39 @@ typedef struct Unresolve_Info { MZTAG_IF_REQUIRED + int comp_flags; int stack_pos; /* stack in resolved coordinates */ int depth; /* stack in unresolved coordinates */ int stack_size; Scheme_IR_Local **vars; - Resolve_Prefix *prefix; + + /* For cross-linklet inlining: */ + Scheme_Linklet *linklet; + Scheme_Object *linklet_key; + Optimize_Info *opt_info; + Scheme_Hash_Table *closures; /* handle cycles */ int has_non_leaf, has_tl, body_size; - int comp_flags; int inlining; - Scheme_Module *module; - Comp_Prefix *comp_prefix; /* Top-level and syntax-constant info for - top-level unresolved. This prefix is - the unresolved from of the original - resolved prefix. - - When unresolving a single lambda for - inlining, this prefix is NULL, and - tenattive additions are added to - `new_toplevels`, instead. */ - - Scheme_Hash_Table *new_toplevels; /* toplevels to add to an optimiation context */ - int new_toplevel_offset; /* the number of toplevels already registered in the - optimization context */ - Scheme_Object *from_modidx, *to_modidx; /* non-NULL => shift for adding to `new_toplevels` */ - intptr_t toplevel_ref_phase; - Scheme_Env *opt_env; - Scheme_Object *opt_insp; - Scheme_Object *inline_variants; + int num_toplevels; /* compute imports + defns for linklet */ + int num_defns; /* initial defns for linklet */ + int num_extra_toplevels; /* created toplevels for cyclic lambdas */ - Scheme_Hash_Table *toplevels; + Scheme_IR_Toplevel **toplevels; Scheme_Object *definitions; - int lift_offset, lift_to_local; + int lift_offset; Scheme_Hash_Table *ref_lifts; } Unresolve_Info; static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator); -static Comp_Prefix *unresolve_prefix(Resolve_Prefix *rp, Unresolve_Info *ui); static void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui); static Scheme_IR_Let_Header *make_let_header(int count); static Scheme_IR_Let_Value *make_ir_let_value(int count); -static Unresolve_Info *new_unresolve_info(Resolve_Prefix *prefix, int comp_flags) +static Unresolve_Info *new_unresolve_info(Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info, + int comp_flags) { Unresolve_Info *ui; Scheme_IR_Local **vars; @@ -2942,15 +2912,15 @@ ui = MALLOC_ONE_RT(Unresolve_Info); SET_REQUIRED_TAG(ui->type = scheme_rt_unresolve_info); - ui->prefix = prefix; + ui->linklet = linklet; + ui->linklet_key = linklet_key; + ui->opt_info = opt_info; ui->stack_pos = 0; ui->stack_size = 10; vars = MALLOC_N(Scheme_IR_Local *, ui->stack_size); ui->vars = vars; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ui->toplevels = ht; ui->definitions = scheme_null; ht = scheme_make_hash_table(SCHEME_hash_ptr); ui->ref_lifts = ht; @@ -2959,6 +2929,13 @@ ui->comp_flags = comp_flags; + ui->num_defns = SCHEME_VEC_SIZE(linklet->defns); + ui->num_toplevels = (SCHEME_LINKLET_PREFIX_PREFIX + + linklet->num_total_imports + + ui->num_defns); + ui->lift_offset = (ui->num_toplevels + - linklet->num_lifts); + return ui; } @@ -3121,157 +3098,75 @@ ui->has_non_leaf = 1; } -static int unresolve_toplevel_pos(int pos, Unresolve_Info *ui) -{ - LOG_UNRESOLVE(printf("pos before = %d\n", pos)); - if (ui->prefix->num_stxes - && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { - /* shift lifted reference down to toplevel range */ - pos -= ui->prefix->num_stxes + 1; /* extra slot for lazy syntax */ - } - LOG_UNRESOLVE(printf("pos = %d\n", pos)); - - return pos; -} - static Scheme_Object *unresolve_toplevel(Scheme_Object *rdata, Unresolve_Info *ui) { Scheme_Object *v; + int pos = SCHEME_TOPLEVEL_POS(rdata); + int flags; + + /* Create a reference that works for the optimization context. */ + + MZ_ASSERT(pos < ui->num_toplevels); + + if (ui->inlining && (pos > (SCHEME_LINKLET_PREFIX_PREFIX + + ui->linklet->num_total_imports + + ui->linklet->num_exports))) { + /* Cannot refer to an unexported variable across a module boundary. */ + return_NULL; + } if (ui->inlining) { - /* Create a reference that works for the optimization context. */ - int pos = SCHEME_TOPLEVEL_POS(rdata); - if (ui->prefix->num_stxes - && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { - /* Cannot refer to a lift across a module boundary. */ - return_NULL; + /* Can we introduce a new top-level reference while inlining + across a module boundary? */ + if (pos >= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX)) { + /* no new instance needed, but maybe a new symbol from that instance */ + pos -= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX); + return scheme_optimize_add_import_variable(ui->opt_info, ui->linklet_key, + SCHEME_VEC_ELS(ui->linklet->defns)[pos]); } else { - Scheme_Object *hv, *modidx, *mod_constant, *sym, *npos, *shape; - int flags, is_constant; - int sym_pos; - intptr_t mod_defn_phase; - - flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK; - switch (flags) { - case SCHEME_TOPLEVEL_CONST: - is_constant = 2; - break; - case SCHEME_TOPLEVEL_FIXED: - is_constant = 1; - break; - case SCHEME_TOPLEVEL_READY: - default: - /* Since we're referencing from an imported context, the - variable is now at least ready: */ - flags = SCHEME_TOPLEVEL_READY; - is_constant = 0; - } - - v = ui->prefix->toplevels[pos]; - if (SCHEME_MPAIRP(v)) { - /* Simplified version was installed by link_module_variable; original is in CDR */ - v = SCHEME_CDR(v); - } - - if (SCHEME_SYMBOLP(v)) { - mod_defn_phase = ui->toplevel_ref_phase; - modidx = ui->to_modidx; - sym_pos = -1; - sym = v; - } else { - Module_Variable *mv = (Module_Variable *)v; - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)); - mod_defn_phase = mv->mod_phase; - modidx = scheme_modidx_shift(mv->modidx, ui->from_modidx, ui->to_modidx); - sym = mv->sym; - sym_pos = mv->pos; - } - - mod_constant = NULL; - npos = scheme_check_accessible_in_module_name(modidx, mod_defn_phase, ui->opt_env, - sym, sym_pos, - ui->opt_insp, NULL, - &mod_constant); - if (!npos) - return_NULL; - - if (sym_pos < 0) - sym_pos = SCHEME_INT_VAL(npos); - - shape = NULL; - if (mod_constant) { - if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) - shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) - shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); - } - - hv = scheme_hash_module_variable(ui->opt_env, modidx, - sym, ui->opt_insp, - sym_pos, mod_defn_phase, is_constant, - shape); - - /* Check whether this variable is already known in the optimzation context: */ - v = scheme_hash_get(ui->comp_prefix->toplevels, hv); - if (!v) { - /* Not already in optimization context; check/extend tentative additions */ - if (!ui->new_toplevels) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ui->new_toplevels = ht; - } - - v = scheme_hash_get(ui->new_toplevels, hv); - if (!v) { - int new_pos = ui->new_toplevel_offset + ui->new_toplevels->count; - v = scheme_make_toplevel(0, new_pos, 0, flags); - scheme_hash_set(ui->new_toplevels, hv, v); - - if (mod_constant - && ui->comp_prefix->inline_variants) { - if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { - Scheme_Object *shiftable; - shiftable = scheme_make_vector(4, scheme_false); - SCHEME_VEC_ELS(shiftable)[0] = mod_constant; - SCHEME_VEC_ELS(shiftable)[1] = ui->from_modidx; - SCHEME_VEC_ELS(shiftable)[2] = ui->to_modidx; - SCHEME_VEC_ELS(shiftable)[3] = scheme_make_integer(mod_defn_phase); - mod_constant = shiftable; - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { - /* keep it */ - } else - mod_constant = NULL; - - if (mod_constant) { - mod_constant = scheme_make_pair(scheme_make_pair(scheme_make_integer(new_pos), - mod_constant), - ui->inline_variants); - ui->inline_variants = mod_constant; - } - } - } + /* Find import: */ + int instance_pos = 0; + pos -= SCHEME_LINKLET_PREFIX_PREFIX; + while (pos >= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])) { + pos -= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos]); + instance_pos++; + } + MZ_ASSERT(instance_pos < SCHEME_VEC_SIZE(ui->linklet->importss)); + + /* Getting this imported linklet's import's key may add an import to the + linklet being optimized: */ + v = scheme_optimize_get_import_key(ui->opt_info, ui->linklet_key, instance_pos); + if (v) { + /* Can add relevant linklet import (or already have it) */ + return scheme_optimize_add_import_variable(ui->opt_info, v, + SCHEME_VEC_ELS(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])[pos]); } - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); } - } else { - /* If needed, shift top-level position to account for moving - lifts to toplevels. */ - Scheme_Object *opos; - int pos; - - pos = unresolve_toplevel_pos(SCHEME_TOPLEVEL_POS(rdata), ui); - opos = scheme_make_integer(pos); - v = scheme_hash_get(ui->toplevels, opos); - if (!v) { - v = scheme_make_toplevel(0, - pos, - 0, - SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK); - scheme_hash_set(ui->toplevels, opos, v); + + return_NULL; + } + + flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK; + switch (flags) { + case SCHEME_TOPLEVEL_CONST: + break; + case SCHEME_TOPLEVEL_FIXED: + break; + case SCHEME_TOPLEVEL_READY: + default: + if (ui->inlining) { + /* Since we're referencing from an imported context, the + variable is now at least ready: */ + flags = SCHEME_TOPLEVEL_READY; } - LOG_UNRESOLVE(printf("flags for %d: %d\n", pos, SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK)); } + + v = (Scheme_Object *)ui->toplevels[pos]; + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); + if (flags) + v = scheme_ir_toplevel_to_flagged_toplevel(v, flags); + ui->has_tl = 1; return v; @@ -3300,120 +3195,22 @@ static Scheme_Object *unresolve_define_values(Scheme_Object *e, Unresolve_Info *ui) { - Scheme_Object *vars = scheme_null; Scheme_Object *vec, *val, *tl; int i; + vec = scheme_make_vector(SCHEME_VEC_SIZE(e), NULL); + vec->type = scheme_define_values_type; + LOG_UNRESOLVE(printf("define-values-size!!!: %d\n", (int)SCHEME_VEC_SIZE(e))); for (i = SCHEME_VEC_SIZE(e); --i;) { LOG_UNRESOLVE(printf("define-values: %d\n", SCHEME_TYPE(SCHEME_VEC_ELS(e)[i]))); tl = unresolve_toplevel(SCHEME_VEC_ELS(e)[i], ui); - if (!tl) return_NULL; /* TODO: does this check need to be here? */ - vars = cons(tl, vars); + if (!tl) return_NULL; + SCHEME_VEC_ELS(vec)[i] = tl; } val = unresolve_expr(SCHEME_VEC_ELS(e)[0], ui, 0); if (!val) return_NULL; - - vec = scheme_make_vector(2, NULL); - vec->type = scheme_define_values_type; - SCHEME_VEC_ELS(vec)[0] = vars; - SCHEME_VEC_ELS(vec)[1] = val; - return vec; -} - -static Scheme_Object *unresolve_define_or_begin_syntaxes(int def, Scheme_Object *e, Unresolve_Info *ui) -{ - Resolve_Prefix *prefix; - Comp_Prefix *comp_prefix; - Scheme_Object *names, *dummy, *val, *vec; - Unresolve_Info *nui; - int i, closures_count; - - prefix = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[1]; - dummy = SCHEME_VEC_ELS(e)[3]; - val = SCHEME_VEC_ELS(e)[0]; - - if (def) { - names = scheme_null; - for (i = SCHEME_VEC_SIZE(e); i-- > 4; ) { - names = scheme_make_pair(SCHEME_VEC_ELS(e)[i], names); - } - } else - names = NULL; - - nui = new_unresolve_info(prefix, ui->comp_flags); - nui->lift_to_local = 1; - - dummy = unresolve_expr(dummy, ui, 0); - comp_prefix = unresolve_prefix(prefix, nui); - nui->comp_prefix = comp_prefix; - - if (def) { - locate_cyclic_closures(val, nui); - val = unresolve_expr(val, nui, 0); - } else { - for (e = val; !SCHEME_NULLP(e); e = SCHEME_CDR(e)) { - locate_cyclic_closures(SCHEME_CAR(e), nui); - } - e = val; - val = scheme_null; - for (; !SCHEME_NULLP(e); e = SCHEME_CDR(e)) { - val = scheme_make_pair(unresolve_expr(SCHEME_CAR(e), nui, 0), - val); - } - val = scheme_reverse(val); - } - - vec = scheme_make_vector(4, NULL); - vec->type = (def ? scheme_define_syntaxes_type : scheme_begin_for_syntax_type); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)comp_prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - if (def) { - SCHEME_VEC_ELS(vec)[2] = names; - SCHEME_VEC_ELS(vec)[3] = val; - } else { - SCHEME_VEC_ELS(vec)[2] = val; - } - - closures_count = 0; - if (nui->closures && nui->closures->count) { - for (i = 0; i < nui->closures->size; i++) { - if (nui->closures->vals[i] && !SAME_OBJ(nui->closures->vals[i], scheme_true)) - closures_count++; - } - } - - if (closures_count) { - Scheme_IR_Let_Header *head; - Scheme_IR_Let_Value *irlv, *prev_irlv = NULL; - Scheme_IR_Local **vars; - - head = make_let_header(closures_count); - head->num_clauses = closures_count; - SCHEME_LET_FLAGS(head) = SCHEME_LET_RECURSIVE; - - for (i = 0; i < nui->closures->size; i++) { - if (nui->closures->vals[i] && !SAME_OBJ(nui->closures->vals[i], scheme_true)) { - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(nui->closures->vals[i]), scheme_ir_local_type)); - irlv = make_ir_let_value(1); - vars = MALLOC_N(Scheme_IR_Local *, 1); - vars[0] = SCHEME_VAR(nui->closures->vals[i]); - irlv->vars = vars; - - if (prev_irlv) - prev_irlv->body = (Scheme_Object *)irlv; - else - head->body = (Scheme_Object *)irlv; - prev_irlv = irlv; - } - } - - MZ_ASSERT(prev_irlv); - prev_irlv->body = vec; - - return (Scheme_Object *)head; - } - + SCHEME_VEC_ELS(vec)[0] = val; return vec; } @@ -3591,26 +3388,6 @@ return (Scheme_Object *)lh; } -static Scheme_Object *unresolve_prefix_symbol(Scheme_Object *s, Unresolve_Info *ui) -{ - if (!ui->module) { - return s; - } else { - Module_Variable *mv; - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - - mv->modidx = ui->module->self_modidx; - mv->sym = s; - mv->insp = ui->module->insp; - mv->pos = -1; - mv->mod_phase = 0; - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_FIXED; - return (Scheme_Object *)mv; - } -} - static Scheme_Object *unresolve_closure(Scheme_Object *e, Unresolve_Info *ui) { Scheme_Object *r, *c; @@ -3629,356 +3406,17 @@ ui->closures = ht; } scheme_hash_set(ui->closures, e, scheme_true); - } else { - if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_ir_toplevel_type)) - return c; - } - - r = unresolve_lambda(SCHEME_CLOSURE_CODE(e), ui); - - if (ui->inlining) - scheme_hash_set(ui->closures, e, NULL); - - return r; -} - -static Comp_Prefix *unresolve_prefix(Resolve_Prefix *rp, Unresolve_Info *ui) -{ - Comp_Prefix *cp; - Scheme_Object *o; - int i; - cp = MALLOC_ONE_TAGGED(Comp_Prefix); - SET_REQUIRED_TAG(cp->type = scheme_rt_comp_prefix); - cp->num_toplevels = 0; - cp->toplevels = NULL; - ui->lift_offset = rp->num_toplevels; - for (i = 0; i < rp->num_toplevels; i++) { - if (SCHEME_SYMBOLP(rp->toplevels[i])) { - Scheme_Object *mv; - mv = unresolve_prefix_symbol(rp->toplevels[i], ui); - o = scheme_register_toplevel_in_comp_prefix(mv, cp, 0, NULL); - } else { - o = scheme_register_toplevel_in_comp_prefix(rp->toplevels[i], cp, ui->module ? 1 : 0, NULL); - } - scheme_hash_set(ui->toplevels, scheme_make_integer(SCHEME_TOPLEVEL_POS(o)), o); - } - for (i = 0; i < rp->num_lifts; i++) { - Scheme_Object *mv, *sym; - sym = scheme_make_symbol("lift"); - sym = scheme_gensym(sym); - mv = unresolve_prefix_symbol(sym, ui); - o = scheme_register_toplevel_in_comp_prefix(mv, cp, 0, NULL); - scheme_hash_set(ui->toplevels, scheme_make_integer(SCHEME_TOPLEVEL_POS(o)), o); - } - cp->stxes = NULL; - for (i = 0; i < rp->num_stxes; i++) { - if (rp->stxes[i]) { - scheme_register_stx_in_comp_prefix(rp->stxes[i], cp); - } else { - cp->num_stxes++; - } - } - cp->inline_variants = NULL; - cp->unbound = NULL; - return cp; -} - -void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui) -{ - switch(SCHEME_TYPE(e)) { - case scheme_sequence_type: - case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)e; - int i; - for (i = 0; i < seq->count; i++) { - locate_cyclic_closures(seq->array[i], ui); - } - } - break; - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)e; - int i; - for (i = 0; i < app->num_args + 1; i++) { - locate_cyclic_closures(app->args[i], ui); - } - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; - locate_cyclic_closures(app->rator, ui); - locate_cyclic_closures(app->rand, ui); - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; - locate_cyclic_closures(app->rator, ui); - locate_cyclic_closures(app->rand1, ui); - locate_cyclic_closures(app->rand2, ui); - } - break; - case scheme_branch_type: - { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; - locate_cyclic_closures(b->test, ui); - locate_cyclic_closures(b->tbranch, ui); - locate_cyclic_closures(b->fbranch, ui); - } - break; - case scheme_with_cont_mark_type: - case scheme_with_immed_mark_type: - { - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e; - locate_cyclic_closures(wcm->key, ui); - locate_cyclic_closures(wcm->val, ui); - locate_cyclic_closures(wcm->body, ui); - } - break; - case scheme_let_void_type: - { - Scheme_Let_Void *lv = (Scheme_Let_Void *)e; - locate_cyclic_closures(lv->body, ui); - } - break; - case scheme_letrec_type: - { - Scheme_Letrec *lr = (Scheme_Letrec *)e; - int i; - for (i = 0; i < lr->count; i++) { - locate_cyclic_closures(lr->procs[i], ui); - } - locate_cyclic_closures(lr->body, ui); - } - break; - case scheme_let_one_type: - { - Scheme_Let_One *lo = (Scheme_Let_One *)e; - locate_cyclic_closures(lo->value, ui); - locate_cyclic_closures(lo->body, ui); - } - break; - case scheme_closure_type: - { - Scheme_Object *c; - c = scheme_hash_get(ui->closures, e); - - if (SAME_OBJ(c, scheme_true)) { - Scheme_Object *s, *mv, *tl; - s = scheme_make_symbol("cyclic"); - s = scheme_gensym(s); - if (!ui->lift_to_local) { - mv = unresolve_prefix_symbol(s, ui); - tl = scheme_register_toplevel_in_comp_prefix(mv, ui->comp_prefix, 0, NULL); - } else { - Scheme_IR_Local *var; - abort(); - var = MALLOC_ONE_TAGGED(Scheme_IR_Local); - var->so.type = scheme_ir_local_type; - var->name = s; - tl = (Scheme_Object *)var; - } - scheme_hash_set(ui->closures, e, tl); - } else if (c) { - /* do nothing */ - } else { - Scheme_Closure *cl = (Scheme_Closure *)e; - scheme_hash_set(ui->closures, e, scheme_true); - locate_cyclic_closures((Scheme_Object *)cl->code, ui); - } - } - break; - case scheme_lambda_type: - { - Scheme_Lambda *cd = (Scheme_Lambda *)e; - locate_cyclic_closures(cd->body, ui); - } - break; - case scheme_inline_variant_type: - { - Scheme_Object *a; - a = SCHEME_VEC_ELS(e)[0]; - locate_cyclic_closures(a, ui); - } - break; - case scheme_define_values_type: - { - if (SCHEME_VEC_SIZE(e) == 2) { - int pos = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(e)[1]); - if (pos >= ui->lift_offset) { - Scheme_Lambda *lam = (Scheme_Lambda *)SCHEME_VEC_ELS(e)[0]; - if (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS) { - scheme_hash_set(ui->ref_lifts, scheme_make_integer(pos), (Scheme_Object *)lam); - } - } - } - - locate_cyclic_closures(SCHEME_VEC_ELS(e)[0], ui); - } - break; - case scheme_set_bang_type: - { - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e; - locate_cyclic_closures(sb->var, ui); - locate_cyclic_closures(sb->val, ui); - } - break; - case scheme_varref_form_type: - case scheme_apply_values_type: - { - Scheme_Object *a, *b; - a = SCHEME_PTR1_VAL(e); - locate_cyclic_closures(a, ui); - b = SCHEME_PTR2_VAL(e); - locate_cyclic_closures(b, ui); - } - break; - case scheme_boxenv_type: - { - locate_cyclic_closures(SCHEME_PTR2_VAL(e), ui); - } - break; - case scheme_case_lambda_sequence_type: - { - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e; - int i; - for (i = 0; i < cl->count; i++) { - locate_cyclic_closures(cl->array[i], ui); - } - } - break; - case scheme_let_value_type: - { - Scheme_Let_Value *lv = (Scheme_Let_Value *)e; - locate_cyclic_closures(lv->value, ui); - locate_cyclic_closures(lv->body, ui); - } - break; - default: - break; - } -} - -static void convert_closures_to_definitions(Unresolve_Info *ui) -{ - Scheme_Object *d, *vars, *val; - Scheme_Lambda *lam; - int i; - - for (i = 0; i < ui->closures->size; i++) { - if (ui->closures->vals[i] && !SAME_OBJ(ui->closures->vals[i], scheme_true)) { - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(ui->closures->vals[i]), scheme_ir_toplevel_type)); - d = scheme_make_vector(2, NULL); - d->type = scheme_define_values_type; - vars = cons(ui->closures->vals[i], scheme_null); - lam = SCHEME_CLOSURE_CODE(ui->closures->keys[i]); - val = unresolve_lambda(lam, ui); - SCHEME_VEC_ELS(d)[0] = vars; - SCHEME_VEC_ELS(d)[1] = val; - d = cons(d, ui->definitions); - ui->definitions = d; - } - } -} - -Scheme_Object *unresolve_module(Scheme_Object *e, Unresolve_Info *ui_in) -{ - Scheme_Module *m = (Scheme_Module *)e, *nm; - Scheme_Object *dummy, *bs, *bs2, *ds, **bss; - Comp_Prefix *cp; - Unresolve_Info *ui; - int i, cnt, len; - - ui = new_unresolve_info(m->prefix, ui_in->comp_flags); - - ui->module = m; - cp = unresolve_prefix(m->prefix, ui); - if (!cp) return_NULL; - ui->comp_prefix = cp; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - bs = scheme_make_vector(cnt, NULL); - - for (i = 0; i < cnt; i++) { - locate_cyclic_closures(SCHEME_VEC_ELS(m->bodies[0])[i], ui); - } - - convert_closures_to_definitions(ui); - - for (i = 0; i < cnt; i++) { - Scheme_Object *b; - b = unresolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], ui, 0); - if (!b) return_NULL; - SCHEME_VEC_ELS(bs)[i] = b; - } - len = scheme_list_length(ui->definitions); - ds = ui->definitions; - bs2 = scheme_make_vector(cnt + len, NULL); - for (i = 0; SCHEME_PAIRP(ds); ds = SCHEME_CDR(ds), i++) { - SCHEME_VEC_ELS(bs2)[i] = SCHEME_CAR(ds); - } - for (i = 0; i < cnt; i++) { - SCHEME_VEC_ELS(bs2)[i + len] = SCHEME_VEC_ELS(bs)[i]; - } - - dummy = unresolve_expr(m->dummy, ui_in, 0); - - nm = MALLOC_ONE_TAGGED(Scheme_Module); - nm->so.type = scheme_module_type; - nm->predefined = m->predefined; - - nm->modname = m->modname; - nm->modsrc = m->modsrc; - - nm->et_requires = m->et_requires; - nm->requires = m->requires; - nm->tt_requires = m->tt_requires; - nm->dt_requires = m->dt_requires; - nm->other_requires = m->other_requires; - - bss = MALLOC_N(Scheme_Object*, m->num_phases); - nm->bodies = bss; - nm->bodies[0] = bs2; - /* Other phases are left as-is (and resolve doesn't traverse them): */ - for (i = 1; i < m->num_phases; i++) { - nm->bodies[i] = m->bodies[i]; + } else { + if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_ir_toplevel_type)) + return c; } + + r = unresolve_lambda(SCHEME_CLOSURE_CODE(e), ui); - nm->me = m->me; - - nm->num_phases = m->num_phases; - - nm->exp_infos = m->exp_infos; - - nm->self_modidx = m->self_modidx; - nm->insp = m->prefix->src_insp_desc; - - nm->lang_info = m->lang_info; - - nm->comp_prefix = cp; - nm->max_let_depth = 0; - nm->prefix = NULL; - nm->dummy = dummy; - nm->rn_stx = m->rn_stx; - - nm->phaseless = m->phaseless; - - nm->binding_names = m->binding_names; - nm->et_binding_names = m->et_binding_names; - nm->other_binding_names = m->other_binding_names; - - /* leave submodules alone (and resolve doesn't traverse them): */ - nm->submodule_path = m->submodule_path; - nm->pre_submodules = m->pre_submodules; - nm->post_submodules = m->post_submodules; - nm->pre_submodule_names = m->pre_submodule_names; - nm->submodule_ancestry = m->submodule_ancestry; - /* the `supermodule` field is only for instantiated modules */ + if (ui->inlining) + scheme_hash_set(ui->closures, e, NULL); - return (Scheme_Object *)nm; + return r; } static Scheme_Object *unresolve_let_value(Scheme_Let_Value *lv, Unresolve_Info *ui, @@ -4047,7 +3485,8 @@ if (SAME_TYPE(SCHEME_TYPE(rator), scheme_closure_type) && (SCHEME_LAMBDA_FLAGS((SCHEME_CLOSURE_CODE(rator))) & LAMBDA_HAS_TYPED_ARGS)) { lam = SCHEME_CLOSURE_CODE(rator); - } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type)) { + } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(rator), scheme_static_toplevel_type)) { lam = (Scheme_Lambda *)scheme_hash_get(ui->ref_lifts, scheme_make_integer(SCHEME_TOPLEVEL_POS(rator))); } @@ -4229,7 +3668,6 @@ } case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)e, *seq2; int i; @@ -4461,22 +3899,10 @@ if (!a) return_NULL; return a; } - case scheme_module_type: - { - return unresolve_module(e, ui); - } case scheme_define_values_type: { return unresolve_define_values(e, ui); } - case scheme_define_syntaxes_type: - { - return unresolve_define_or_begin_syntaxes(1, e, ui); - } - case scheme_begin_for_syntax_type: - { - return unresolve_define_or_begin_syntaxes(0, e, ui); - } case scheme_set_bang_type: { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e, *sb2; @@ -4484,8 +3910,11 @@ var = unresolve_expr(sb->var, ui, 0); if (!var) return_NULL; if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) { - if (ui->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; + if (((Scheme_IR_Toplevel *)var)->instance_pos != -1) { + /* Cannot inline a `set!` of another linklet's variable */ + return_NULL; + } + SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_TOPLEVEL_MUTATED; } val = unresolve_expr(sb->val, ui, 0); if (!val) return_NULL; @@ -4508,12 +3937,20 @@ LOG_UNRESOLVE(printf("unresolve_varref: (a) %d %d\n", e->type, a->type)); if (SAME_TYPE(SCHEME_TYPE(a), scheme_ir_toplevel_type)) { - SCHEME_TOPLEVEL_FLAGS(a) |= SCHEME_TOPLEVEL_MUTATED; + SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)a) |= SCHEME_TOPLEVEL_MUTATED; } b = SCHEME_PTR2_VAL(e); + MZ_ASSERT(SCHEME_FALSEP(b) + || (SAME_TYPE(SCHEME_TYPE(b), scheme_toplevel_type) + && !SCHEME_TOPLEVEL_POS(b)) + || (SAME_TYPE(SCHEME_TYPE(b), scheme_static_toplevel_type) + && !SCHEME_TOPLEVEL_POS(b))); b = unresolve_expr(b, ui, 0); if (!b) return_NULL; + MZ_ASSERT(SCHEME_FALSEP(b) || (SAME_TYPE(SCHEME_TYPE(b), scheme_ir_toplevel_type) + && (((Scheme_IR_Toplevel *)b)->instance_pos == -1) + && (((Scheme_IR_Toplevel *)b)->variable_pos == -1))); LOG_UNRESOLVE(printf(" (b) %d\n", b->type)); o = scheme_alloc_object(); @@ -4531,6 +3968,7 @@ return unresolve_expr(SCHEME_PTR2_VAL(e), ui, 0); } case scheme_toplevel_type: + case scheme_static_toplevel_type: { return unresolve_toplevel(e, ui); } @@ -4576,32 +4014,6 @@ return unresolve_let_value(lv, ui, val, body); } - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)e; - Scheme_Local *cqs; - - if (ui->inlining) return_NULL; - - cqs = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - cqs->iso.so.type = scheme_ir_quote_syntax_type; - cqs->position = qs->position; - return (Scheme_Object *)cqs; - } - case scheme_require_form_type: - { - Scheme_Object *dummy = SCHEME_PTR1_VAL(e), *req; - - dummy = unresolve_expr(dummy, ui, 0); - - req = scheme_alloc_object(); - req->type = scheme_require_form_type; - SCHEME_PTR1_VAL(req) = dummy; - SCHEME_PTR2_VAL(req) = SCHEME_PTR2_VAL(e); - - return req; - } - break; default: if (SCHEME_TYPE(e) > _scheme_values_types_) { if (scheme_ir_duplicate_ok(e, 1) || !ui->inlining) @@ -4615,52 +4027,269 @@ } } -Scheme_Object *scheme_unresolve_top(Scheme_Object* o, Comp_Prefix **cp, int comp_flags) +void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui) +{ + switch(SCHEME_TYPE(e)) { + case scheme_sequence_type: + case scheme_begin0_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)e; + int i; + for (i = 0; i < seq->count; i++) { + locate_cyclic_closures(seq->array[i], ui); + } + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + int i; + for (i = 0; i < app->num_args + 1; i++) { + locate_cyclic_closures(app->args[i], ui); + } + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; + locate_cyclic_closures(app->rator, ui); + locate_cyclic_closures(app->rand, ui); + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + locate_cyclic_closures(app->rator, ui); + locate_cyclic_closures(app->rand1, ui); + locate_cyclic_closures(app->rand2, ui); + } + break; + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; + locate_cyclic_closures(b->test, ui); + locate_cyclic_closures(b->tbranch, ui); + locate_cyclic_closures(b->fbranch, ui); + } + break; + case scheme_with_cont_mark_type: + case scheme_with_immed_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e; + locate_cyclic_closures(wcm->key, ui); + locate_cyclic_closures(wcm->val, ui); + locate_cyclic_closures(wcm->body, ui); + } + break; + case scheme_let_void_type: + { + Scheme_Let_Void *lv = (Scheme_Let_Void *)e; + locate_cyclic_closures(lv->body, ui); + } + break; + case scheme_letrec_type: + { + Scheme_Letrec *lr = (Scheme_Letrec *)e; + int i; + for (i = 0; i < lr->count; i++) { + locate_cyclic_closures(lr->procs[i], ui); + } + locate_cyclic_closures(lr->body, ui); + } + break; + case scheme_let_one_type: + { + Scheme_Let_One *lo = (Scheme_Let_One *)e; + locate_cyclic_closures(lo->value, ui); + locate_cyclic_closures(lo->body, ui); + } + break; + case scheme_closure_type: + { + Scheme_Object *c; + c = scheme_hash_get(ui->closures, e); + + if (SAME_OBJ(c, scheme_true)) { + Scheme_IR_Toplevel *tl; + + tl = scheme_make_ir_toplevel(-1, ui->num_defns + ui->num_extra_toplevels, 0); + ui->num_extra_toplevels++; + + scheme_hash_set(ui->closures, e, (Scheme_Object *)tl); + } else if (c) { + /* do nothing */ + } else { + Scheme_Closure *cl = (Scheme_Closure *)e; + scheme_hash_set(ui->closures, e, scheme_true); + locate_cyclic_closures((Scheme_Object *)cl->code, ui); + } + } + break; + case scheme_lambda_type: + { + Scheme_Lambda *cd = (Scheme_Lambda *)e; + locate_cyclic_closures(cd->body, ui); + } + break; + case scheme_inline_variant_type: + { + Scheme_Object *a; + a = SCHEME_VEC_ELS(e)[0]; + locate_cyclic_closures(a, ui); + } + break; + case scheme_define_values_type: + { + if (SCHEME_VEC_SIZE(e) == 2) { + int pos = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(e)[1]); + if (pos >= ui->lift_offset) { + Scheme_Lambda *lam = (Scheme_Lambda *)SCHEME_VEC_ELS(e)[0]; + if (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS) { + scheme_hash_set(ui->ref_lifts, scheme_make_integer(pos), (Scheme_Object *)lam); + } + } + } + + locate_cyclic_closures(SCHEME_VEC_ELS(e)[0], ui); + } + break; + case scheme_set_bang_type: + { + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e; + locate_cyclic_closures(sb->var, ui); + locate_cyclic_closures(sb->val, ui); + } + break; + case scheme_varref_form_type: + case scheme_apply_values_type: + { + Scheme_Object *a, *b; + a = SCHEME_PTR1_VAL(e); + locate_cyclic_closures(a, ui); + b = SCHEME_PTR2_VAL(e); + locate_cyclic_closures(b, ui); + } + break; + case scheme_boxenv_type: + { + locate_cyclic_closures(SCHEME_PTR2_VAL(e), ui); + } + break; + case scheme_case_lambda_sequence_type: + { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e; + int i; + for (i = 0; i < cl->count; i++) { + locate_cyclic_closures(cl->array[i], ui); + } + } + break; + case scheme_let_value_type: + { + Scheme_Let_Value *lv = (Scheme_Let_Value *)e; + locate_cyclic_closures(lv->value, ui); + locate_cyclic_closures(lv->body, ui); + } + break; + default: + break; + } +} + +static void convert_closures_to_definitions(Unresolve_Info *ui) +{ + Scheme_Object *d, *var, *val; + Scheme_Lambda *lam; + int i; + + for (i = 0; i < ui->closures->size; i++) { + if (ui->closures->vals[i] && !SAME_OBJ(ui->closures->vals[i], scheme_true)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(ui->closures->vals[i]), scheme_ir_toplevel_type)); + d = scheme_make_vector(2, NULL); + d->type = scheme_define_values_type; + var = ui->closures->vals[i]; + lam = SCHEME_CLOSURE_CODE(ui->closures->keys[i]); + val = unresolve_lambda(lam, ui); + SCHEME_VEC_ELS(d)[0] = val; + SCHEME_VEC_ELS(d)[1] = var; + d = cons(d, ui->definitions); + ui->definitions = d; + } + } +} + +Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *linklet, int comp_flags) /* Convert from "resolved" form back to the intermediate representation used by the optimizer. Unresolving generates an intermediate-representation prefix (for top levels and syntax literals) in addition to the code. */ { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)o; - Scheme_Object *code = top->code, *defns; - Resolve_Prefix *rp = top->prefix; - Comp_Prefix *c; + Scheme_Linklet *new_linklet; + Scheme_Object *bs, *bs2, *ds, *imports; Unresolve_Info *ui; - int len, i; + Scheme_IR_Toplevel **toplevels, *tl; + int i, j, cnt, len; - ui = new_unresolve_info(rp, comp_flags); + new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + memcpy(new_linklet, linklet, sizeof(Scheme_Linklet)); - c = unresolve_prefix(rp, ui); - ui->comp_prefix = c; - *cp = c; + ui = new_unresolve_info(new_linklet, NULL, NULL, comp_flags); - locate_cyclic_closures(code, ui); - convert_closures_to_definitions(ui); + cnt = ui->num_toplevels; + toplevels = MALLOC_N(Scheme_IR_Toplevel *, cnt); + tl = scheme_make_ir_toplevel(-1, -1, 0); + i = 0; + toplevels[i++] = tl; + for (j = 0; j < SCHEME_VEC_SIZE(linklet->importss); j++) { + int k; + imports = SCHEME_VEC_ELS(linklet->importss)[j]; + for (k = 0; k < SCHEME_VEC_SIZE(imports); k++) { + tl = scheme_make_ir_toplevel(j, k, 0); + toplevels[i++] = tl; + } + } + for (j = 0; i < cnt; j++) { + tl = scheme_make_ir_toplevel(-1, j, 0); + toplevels[i++] = tl; + } + ui->toplevels = toplevels; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + bs = scheme_make_vector(cnt, NULL); - code = unresolve_expr(code, ui, 0); - if (!code) return_NULL; + for (i = 0; i < cnt; i++) { + locate_cyclic_closures(SCHEME_VEC_ELS(linklet->bodies)[i], ui); + } + + convert_closures_to_definitions(ui); + for (i = 0; i < cnt; i++) { + Scheme_Object *b; + b = unresolve_expr(SCHEME_VEC_ELS(linklet->bodies)[i], ui, 0); + if (!b) return_NULL; + SCHEME_VEC_ELS(bs)[i] = b; + } len = scheme_list_length(ui->definitions); - if (len) { - Scheme_Sequence *seq; - seq = scheme_malloc_sequence(len+1); - seq->so.type = scheme_sequence_type; - seq->count = len+1; - - defns = ui->definitions; - for (i = 0; i < len; i++) { - seq->array[i] = SCHEME_CAR(defns); - defns = SCHEME_CDR(defns); - } - seq->array[len] = code; - code = (Scheme_Object *)seq; + ds = ui->definitions; + bs2 = scheme_make_vector(cnt + len, NULL); + for (i = 0; SCHEME_PAIRP(ds); ds = SCHEME_CDR(ds), i++) { + SCHEME_VEC_ELS(bs2)[i] = SCHEME_CAR(ds); + } + for (i = 0; i < cnt; i++) { + SCHEME_VEC_ELS(bs2)[i + len] = SCHEME_VEC_ELS(bs)[i]; } - return code; + new_linklet->bodies = bs2; + + if (ui->num_extra_toplevels) { + /* Extend defn-name array to extra toplevels: */ + extend_linklet_defns(new_linklet, ui->num_extra_toplevels); + } + + return new_linklet; } Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, - Scheme_Object *from_modidx, Scheme_Object *to_modidx) + Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info) /* Convert a single function from "resolved" form back to the intermediate representation used by the optimizer. Unresolving can add new items to the intermediate-representation prefix for top levels. */ @@ -4704,43 +4333,12 @@ if (!lam) return_NULL; - ui = new_unresolve_info((Resolve_Prefix *)SCHEME_VEC_ELS(iv)[2], 0); + ui = new_unresolve_info(linklet, linklet_key, opt_info, 0); ui->inlining = 1; - ui->from_modidx = from_modidx; - ui->to_modidx = to_modidx; - ui->new_toplevel_offset = cp->num_toplevels; - ui->comp_prefix = cp; - ui->opt_env = env; - ui->opt_insp = insp; - ui->toplevel_ref_phase = ref_phase; - ui->inline_variants = scheme_null; /* convert an optimized & resolved closure back to compiled form: */ o = unresolve_lambda(lam, ui); - if (o) { - /* Added any toplevels? */ - if (ui->new_toplevels) { - int i; - Scheme_Object *l; - - for (i = ui->new_toplevels->size; i--; ) { - if (ui->new_toplevels->vals[i]) { - scheme_hash_set(cp->toplevels, - ui->new_toplevels->keys[i], - ui->new_toplevels->vals[i]); - cp->num_toplevels++; - } - } - - for (l = ui->inline_variants; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - scheme_hash_set(ui->comp_prefix->inline_variants, - SCHEME_CAR(SCHEME_CAR(l)), - SCHEME_CDR(SCHEME_CAR(l))); - } - } - } - return o; } diff -Nru racket-6.12+ppa1/src/racket/src/salloc.c racket-7.0+ppa1/src/racket/src/salloc.c --- racket-6.12+ppa1/src/racket/src/salloc.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/salloc.c 2018-07-27 22:12:02.000000000 +0000 @@ -74,6 +74,8 @@ int scheme_tls_index; # elif defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS_FUNC) DWORD scheme_thread_local_key; +# elif defined(IMPLEMENT_THREAD_LOCAL_VIA_OFFSET) +SHARED_OK THREAD_LOCAL Thread_Local_Variables scheme_thread_locals_space; # else SHARED_OK THREAD_LOCAL Thread_Local_Variables scheme_thread_locals; # endif @@ -107,6 +109,11 @@ static void init_allocation_callback(void); #endif +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER +static void install_w_xor_x_handler(); +static void register_as_executable(void *p, size_t len, int can_exec); +#endif + SHARED_OK static int use_registered_statics; /************************************************************************/ @@ -153,6 +160,13 @@ init_allocation_callback(); # endif #endif + +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER + install_w_xor_x_handler(); +# if defined(USE_SENORA_GC) && !defined(MZ_PRECISE_GC) + GC_register_as_executable_callback = register_as_executable; +# endif +#endif } void scheme_set_current_os_thread_stack_base(void *base) @@ -193,6 +207,8 @@ return scheme_main_stack_setup(no_auto_statics, call_with_basic, &d); } +extern int _tls_index; + static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) { void *stack_start; @@ -232,6 +248,19 @@ { return scheme_get_thread_local_variables(); } +#elif defined(IMPLEMENT_THREAD_LOCAL_VIA_OFFSET) +int scheme_tls_delta; +extern int _tls_index; +void scheme_register_tls_space(void *tls_space, int tls_index) XFORM_SKIP_PROC +{ + if (_tls_index == 0) { + /* The Racket DLL didn't get its own index, which means that it's + being instantiated in-memory instead of loaded from a ".dll" file. + Use space reserved by the application for thread-local variables. */ + scheme_tls_delta = ((char *)tls_space - (char *)&scheme_thread_locals_space); + } else + scheme_tls_delta = 0; +} #else void scheme_register_tls_space(void *tls_space, int tls_index) XFORM_SKIP_PROC { @@ -710,7 +739,7 @@ { intptr_t v; - v = (n * m) + a; + v = (intptr_t)(((uintptr_t)n * (uintptr_t)m) + (uintptr_t)a); if ((v < n) || (v < m) || (v < a) || (((v - a) / n) != m)) scheme_signal_error("allocation size overflow"); @@ -919,6 +948,12 @@ static int fd, fd_created; #endif +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER +# define MAYBE_PROT_EXEC 0 +#else +# define MAYBE_PROT_EXEC PROT_EXEC +#endif + #define LOG_CODE_MALLOC(lvl, s) /* if (lvl > 1) s */ #define CODE_PAGE_OF(p) ((void *)(((uintptr_t)p) & ~(page_size - 1))) @@ -993,13 +1028,13 @@ } #else # ifdef MAP_ANON - r = mmap(NULL, size, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE | MAP_ANON, -1, 0); + r = mmap(NULL, size, PROT_READ | PROT_WRITE | MAYBE_PROT_EXEC, MAP_PRIVATE | MAP_ANON, -1, 0); # else if (!fd_created) { fd_created = 1; fd = open("/dev/zero", O_RDWR); } - r = mmap(NULL, size, PROT_READ | PROT_WRITE | PROT_EXEC, MAP_PRIVATE, fd, 0); + r = mmap(NULL, size, PROT_READ | PROT_WRITE | MAYBE_PROT_EXEC, MAP_PRIVATE, fd, 0); # endif if (r == (void *)-1) r = NULL; @@ -1008,6 +1043,10 @@ if (!r) scheme_raise_out_of_memory(NULL, NULL); +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER + register_as_executable(r, size, 1); +#endif + return r; } @@ -1020,6 +1059,9 @@ VirtualFree(p, 0, MEM_RELEASE); #else munmap(p, size); +# ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER + register_as_executable(p, size, 0); +# endif #endif } @@ -1362,7 +1404,7 @@ # else { int r; - r = mprotect ((void *) page, length, PROT_READ | PROT_WRITE | PROT_EXEC); + r = mprotect ((void *) page, length, PROT_READ | PROT_WRITE | MAYBE_PROT_EXEC); if (r == -1) { scheme_log_abort("mprotect for generate-code page failed; aborting"); } @@ -1400,6 +1442,185 @@ } #endif +#ifdef IMPLEMENT_WRITE_XOR_EXECUTE_BY_SIGNAL_HANDLER + +/* We abide by W^X for generated code by following the letter of the + law, but not the sprirt. Pages are mapped without execute mode. + When the process crashes by trying to execute code from those + pages, we switch the page from writable to executable --- or vice + versa if the process changes back to writing. */ + +# include +# include +static intptr_t wx_page_size; +static int wx_log_page_size; +static void (*previous_fault_handler)(int sn, siginfo_t *si, void *ctx); + +typedef char exec_state_t; +#define EXEC_STATE_NONE 0 +#define EXEC_STATE_WRITE 1 +#define EXEC_STATE_EXEC 2 +static exec_state_t ***exec_page_map; + +#ifdef MZ_USE_MZRT +static mzrt_mutex *exec_page_mutex = NULL; +#endif + +#ifdef SIXTY_FOUR_BIT_INTEGERS +# define EXEC_PAGEMAP_LEVEL_BITS 22 +#else +# define EXEC_PAGEMAP_LEVEL_BITS 8 +#endif + +static void exec_state_lock() +{ + /* We assume that allocation functions that manipulate the + executable-state table will not themselves trip into + execute--write mismatches that would deadlock via the signal + handler. */ +#ifdef MZ_USE_MZRT + mzrt_mutex_lock(exec_page_mutex); +#endif +} + +static void exec_state_unlock() +{ +#ifdef MZ_USE_MZRT + mzrt_mutex_unlock(exec_page_mutex); +#endif +} + +/* Call with lock: */ +static void exec_pagemap_set(void *p, exec_state_t es) { + uintptr_t addr, pos; + exec_state_t **p1, *p2; + + addr = ((uintptr_t)p) >> wx_log_page_size; + + if (!exec_page_map) + exec_page_map = calloc(sizeof(exec_state_t**), ((sizeof(void*) << 3) - wx_log_page_size - (2 * EXEC_PAGEMAP_LEVEL_BITS))); + + pos = addr >> (2 * EXEC_PAGEMAP_LEVEL_BITS); + p1 = exec_page_map[pos]; + if (!p1) { + p1 = calloc(sizeof(exec_state_t*), (1 << EXEC_PAGEMAP_LEVEL_BITS)); + exec_page_map[pos] = p1; + } + + pos = (addr >> EXEC_PAGEMAP_LEVEL_BITS) & ((1 << EXEC_PAGEMAP_LEVEL_BITS) - 1); + p2 = p1[pos]; + if (!p2) { + p2 = calloc(sizeof(exec_state_t), (1 << EXEC_PAGEMAP_LEVEL_BITS)); + p1[pos] = p2; + } + + pos = addr & ((1 << EXEC_PAGEMAP_LEVEL_BITS) - 1); + p2[pos] = es; +} + +/* Call with lock: */ +static exec_state_t exec_pagemap_get(void *p) { + uintptr_t addr, pos; + exec_state_t **p1, *p2; + + addr = ((uintptr_t)p) >> wx_log_page_size; + + if (!exec_page_map) return EXEC_STATE_NONE; + + pos = addr >> (2 * EXEC_PAGEMAP_LEVEL_BITS); + p1 = exec_page_map[pos]; + if (!p1) return EXEC_STATE_NONE; + + pos = (addr >> EXEC_PAGEMAP_LEVEL_BITS) & ((1 << EXEC_PAGEMAP_LEVEL_BITS) - 1); + p2 = p1[pos]; + if (!p2) return EXEC_STATE_NONE; + + pos = addr & ((1 << EXEC_PAGEMAP_LEVEL_BITS) - 1); + return p2[pos]; +} + +static void register_as_executable(void *p, size_t len, int can_exec) +{ + exec_state_lock(); + while (len > 0) { + exec_pagemap_set(p, (can_exec ? EXEC_STATE_WRITE : EXEC_STATE_NONE)); + p = ((char *)p) + wx_page_size; + len -= wx_page_size; + } + exec_state_unlock(); +} + +static void fault_handler(int sn, siginfo_t *si, void *ctx) +{ + void *addr = si->si_addr; + exec_state_t es; + int fail = 0; + +#ifdef MZ_PRECISE_GC + /* For precise GC, defer to its handler for GC-managed pages, which + are never intended to be executable pages */ + if (GC_is_on_allocated_page(addr)) { + previous_fault_handler(sn, si, ctx); + return; + } +#endif + + addr = (char *)addr - ((intptr_t)addr & (wx_page_size - 1)); + + exec_state_lock(); + es = exec_pagemap_get(addr); + + if (es == EXEC_STATE_NONE) { + fail = 1; + } else if (es == EXEC_STATE_WRITE) { + exec_pagemap_set(addr, EXEC_STATE_EXEC); + if (mprotect(addr, wx_page_size, PROT_READ | PROT_EXEC)) + fail = 1; + } else { + exec_pagemap_set(addr, EXEC_STATE_WRITE); + if (mprotect(addr, wx_page_size, PROT_READ | PROT_WRITE)) + fail = 1; + } + exec_state_unlock(); + + if (fail) { + fprintf(stderr, "SIGSEGV at %p\n", si->si_addr); + abort(); + } +} + +#ifdef OS_X +# define SIG_W_XOR_X SIGBUS +#else +# define SIG_W_XOR_X SIGSEGV +#endif + +static void install_w_xor_x_handler() +{ + wx_page_size = sysconf (_SC_PAGESIZE); + while (1 << wx_log_page_size < wx_page_size) + wx_log_page_size++; + +#ifdef MZ_USE_MZRT + mzrt_mutex_create(&exec_page_mutex); +#endif + + { + struct sigaction act, oact; + memset(&act, 0, sizeof(act)); + act.sa_sigaction = fault_handler; + sigemptyset(&act.sa_mask); + sigaddset(&act.sa_mask, SIGINT); + sigaddset(&act.sa_mask, SIGCHLD); + act.sa_flags = SA_SIGINFO; + sigaction(SIG_W_XOR_X, &act, &oact); + previous_fault_handler = oact.sa_sigaction; + } + +} + +#endif + #ifdef MZ_PRECISE_GC END_XFORM_SKIP; #endif @@ -1984,6 +2205,35 @@ static int print_all_traced(void *p) { return 1; } +static int record_nth_counter, record_nth_target; +static GC_record_traced_filter_proc record_nth_traced_filter; +static int record_nth_traced(void *p) { + if (!record_nth_traced_filter(p)) + return 0; + record_nth_counter++; + if (record_nth_counter == record_nth_target) { + record_nth_counter = 0; + return 1; + } + return 0; +} + +/* A vector with keywords is interesting, because serialized + syntax-object literals have that shape. */ +static int vector_has_keywords(void *p) +{ + Scheme_Object *vec = (Scheme_Object *)p; + int i; + + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + if (SCHEME_VEC_ELS(vec)[i]) + if (SCHEME_KEYWORDP(SCHEME_VEC_ELS(vec)[i])) + return 1; + } + + return 0; +} + static int traced_buffer_counter, traced_buffer_size; static void **traced_buffer; @@ -1996,7 +2246,8 @@ : 512); if (!traced_buffer) REGISTER_SO(traced_buffer); b2 = scheme_malloc(sizeof(void*) * new_size); - memcpy(b2, traced_buffer, sizeof(void*)*traced_buffer_size); + if (traced_buffer) + memcpy(b2, traced_buffer, sizeof(void*)*traced_buffer_size); traced_buffer = b2; traced_buffer_size = new_size; } @@ -2018,6 +2269,16 @@ return record_traced(p); } +static char struct_name_to_match[64]; +static int record_if_matching_struct_name(void *p) +{ + Scheme_Struct_Type *stype = ((Scheme_Structure *)p)->stype; + if (!strcmp(SCHEME_SYM_VAL(stype->name), struct_name_to_match)) + return 1; + else + return 0; +} + static void record_allocated_object(void *p, intptr_t size, int tagged, int atomic) { if (tagged) { @@ -2156,33 +2417,23 @@ memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; - } else if (!scheme_strncmp(type, "#phase, - ((Scheme_Env *)v)->mod_phase, - (((Scheme_Env *)v)->module - ? scheme_write_to_string(((Scheme_Env *)v)->module->modname, NULL) - : "(toplevel)")); - - len2 = strlen(buffer); - t2 = (char *)scheme_malloc_atomic(len + len2 + 1); - memcpy(t2, type, len); - memcpy(t2 + len, buffer, len2 + 1); - len += len2; - type = t2; } else if (!scheme_strncmp(type, "#key; char *t2; int len2; - len2 = SCHEME_SYM_LEN(bsym); + if (SCHEME_FALSEP(bsym)) + len2 = 2; + else + len2 = SCHEME_SYM_LEN(bsym); + t2 = scheme_malloc_atomic(len + len2 + 3); memcpy(t2, type, len); - memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2); + if (SCHEME_FALSEP(bsym)) + memcpy(t2 + len + 1, "#f", len2); + else + memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2); t2[len] = '['; t2[len + 1 + len2] = ']'; t2[len + 1 + len2 + 1] = 0; @@ -2304,6 +2555,7 @@ int dump_flags = 0; GC_for_each_found_proc for_each_found = NULL; GC_print_traced_filter_proc maybe_print_traced_filter = NULL; + GC_record_traced_filter_proc record_traced_filter = NULL; # else # define skip_summary 0 # define dump_flags 0 @@ -2323,6 +2575,7 @@ #if defined(MZ_PRECISE_GC) && MZ_PRECISE_GC_TRACE maybe_print_traced_filter = print_all_traced; + record_traced_filter = print_all_traced; #endif #if 0 @@ -2404,7 +2657,7 @@ && SCHEME_SYMBOLP(p[1]) && !strcmp(SCHEME_SYM_VAL(p[1]), "objects")); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, s)) { if (just_objects) @@ -2591,7 +2844,7 @@ && SCHEME_SYMBOLP(p[1])) { int i, maxpos; maxpos = scheme_num_types(); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn; tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, SCHEME_SYM_VAL(p[1]))) { @@ -2619,20 +2872,22 @@ maxpos = scheme_num_types(); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn; tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, s)) { trace_for_tag = i; dump_flags |= GC_DUMP_SHOW_TRACE; - if ((c > 1) - && SCHEME_SYMBOLP(p[1]) - && !strcmp(SCHEME_SYM_VAL(p[1]), "new")) - maybe_print_traced_filter = record_traced_and_print_new; - break; + break; } } + if (!strcmp("kw-vec", s)) { + trace_for_tag = scheme_vector_type; + dump_flags |= GC_DUMP_SHOW_TRACE; + record_traced_filter = vector_has_keywords; + } + if (!strcmp("fnl", s)) dump_flags |= GC_DUMP_SHOW_FINALS; @@ -2671,6 +2926,17 @@ scheme_end_atomic(); return scheme_make_integer_value((intptr_t)p[1]); } + } else if (c + && SCHEME_PAIRP(p[0]) + && SCHEME_PAIRP(SCHEME_CDR(p[0])) + && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p[0]))) + && SCHEME_SYMBOLP(SCHEME_CAR(p[0])) + && SCHEME_SYMBOLP(SCHEME_CADR(p[0])) + && !strcmp(SCHEME_SYM_VAL(SCHEME_CAR(p[0])), "struct")) { + trace_for_tag = scheme_structure_type; + dump_flags |= GC_DUMP_SHOW_TRACE; + record_traced_filter = record_if_matching_struct_name; + strncpy(struct_name_to_match, SCHEME_SYM_VAL(SCHEME_CADR(p[0])), sizeof(struct_name_to_match)); } else if (c && SCHEME_INTP(p[0])) { trace_for_tag = SCHEME_INT_VAL(p[0]); dump_flags |= GC_DUMP_SHOW_TRACE; @@ -2703,13 +2969,25 @@ return scheme_void; } - if ((c > 1) && SCHEME_INTP(p[1])) + + if ((c > 1) + && SCHEME_SYMBOLP(p[1]) + && !strcmp(SCHEME_SYM_VAL(p[1]), "new")) + maybe_print_traced_filter = record_traced_and_print_new; + else if ((c > 1) && SCHEME_INTP(p[1])) path_length_limit = SCHEME_INT_VAL(p[1]); else if ((c > 1) && SCHEME_SYMBOLP(p[1]) && !strcmp("cons", SCHEME_SYM_VAL(p[1]))) { for_each_found = cons_onto_list; cons_accum_result = scheme_null; dump_flags -= (dump_flags & GC_DUMP_SHOW_TRACE); } + + if ((c > 2) && SCHEME_INTP(p[2])) { + record_nth_target = SCHEME_INT_VAL(p[2]); + record_nth_counter = 0; + record_nth_traced_filter = record_traced_filter; + record_traced_filter = record_nth_traced; + } #endif if (!skip_summary) @@ -2720,6 +2998,7 @@ scheme_get_type_name_or_null, for_each_found, trace_for_tag, trace_for_tag, + record_traced_filter, maybe_print_traced_filter, print_tagged_value, path_length_limit, @@ -2732,6 +3011,7 @@ #if MZ_PRECISE_GC_TRACE if (for_each_struct) { scheme_console_printf("Begin Struct\n"); + cons_accum_result = scheme_add_builtin_struct_types(cons_accum_result); while (SCHEME_PAIRP(cons_accum_result)) { Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_CAR(cons_accum_result); if (stype->total_instance_count) { @@ -2795,11 +3075,11 @@ } scheme_console_printf("Begin Help\n"); - scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n"); - scheme_console_printf(" Examples: (dump-memory-stats '), (dump-memory-stats 'frame).\n"); - scheme_console_printf(" If sym is 'stack, prints paths to thread stacks.\n"); - scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym.\n"); - scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first.\n"); + scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym\n"); + scheme_console_printf(" Examples: (dump-memory-stats '), (dump-memory-stats 'frame)\n"); + scheme_console_printf(" If sym is 'stack, prints paths to thread stacks\n"); + scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym\n"); + scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first\n"); scheme_console_printf("End Help\n"); if (obj_type >= 0) { @@ -2813,22 +3093,28 @@ if (!skip_summary) { #ifdef MZ_PRECISE_GC scheme_console_printf("Begin Help\n"); - scheme_console_printf(" (dump-memory-stats 'count sym) - return number of instances of type named by sym.\n"); +# if MZ_PRECISE_GC_TRACE + scheme_console_printf(" (dump-memory-stats 'struct) - show counts for specific structure types\n"); + scheme_console_printf(" (dump-memory-stats spec) - prints path to instances, where spec is\n"); + scheme_console_printf(" sym : prints paths to objects of type named by sym\n"); + scheme_console_printf(" Example: (dump-memory-stats ')\n"); + scheme_console_printf(" num : prints paths to objects with tag num\n"); + scheme_console_printf(" -num : prints paths to objects of size num\n"); + scheme_console_printf(" (list 'struct sym) : print paths to structs of type named by sym\n"); + scheme_console_printf(" ** Backtraces depend on the most recent major GC **\n"); + scheme_console_printf(" (dump-memory-stats spec 'new) - show only objects new since last dump\n"); + scheme_console_printf(" (dump-memory-stats spec num) - limits backtrace path length to num\n"); + scheme_console_printf(" (dump-memory-stats spec 'cons) - builds list instead of showing paths\n"); + scheme_console_printf(" (dump-memory-stats spec any num) - record only each numth object\n"); +#endif + scheme_console_printf(" (dump-memory-stats 'count sym) - return number of instances of type named by sym\n"); scheme_console_printf(" Example: (dump-memory-stats 'count ')\n"); # if MZ_PRECISE_GC_TRACE - scheme_console_printf(" (dump-memory-stats sym ['new]) - prints paths to instances of type named by sym.\n"); - scheme_console_printf(" Example: (dump-memory-stats ')\n"); - scheme_console_printf(" If 'new, all will be retrined, only new paths will be shown\n"); - scheme_console_printf(" (dump-memory-stats 'struct) - show counts for specific structure types.\n"); - scheme_console_printf(" (dump-memory-stats 'fnl) - prints not-yet-finalized objects.\n"); - scheme_console_printf(" (dump-memory-stats num) - prints paths to objects with tag num.\n"); - scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n"); - scheme_console_printf(" (dump-memory-stats sym/num len) - limits path to size len.\n"); - scheme_console_printf(" (dump-memory-stats sym/num 'cons) - builds list instead of showing paths.\n"); - scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, v otherwise.\n"); - scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f.\n"); - scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v.\n"); - scheme_console_printf(" (dump-memory-stats thread) - shows information about the thread.\n"); + scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, else v\n"); + scheme_console_printf(" (dump-memory-stats 'fnl) - prints not-yet-finalized objects\n"); + scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f\n"); + scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v\n"); + scheme_console_printf(" (dump-memory-stats thread) - shows information about the thread\n"); # endif scheme_console_printf("End Help\n"); #endif @@ -3208,33 +3494,6 @@ } } break; - case scheme_namespace_type: - { - Scheme_Env *env = (Scheme_Env *)root; - - s = sizeof(Scheme_Env); -#if FORCE_KNOWN_SUBPARTS - e = COUNT(env->toplevel); -#endif - } - break; - case scheme_config_type: - { - s = sizeof(Scheme_Config) + (sizeof(Scheme_Object *) * __MZCONFIG_BUILTIN_COUNT__); -#if FORCE_SUBPARTS - { - Scheme_Config *c = (Scheme_Config *)root; - int i; - - e = COUNT(c->extensions) + COUNT(c->base); - - for (i = 0; i < __MZCONFIG_BUILTIN_COUNT__; i++) { - e += COUNT(*c->configs[i]); - } - } -#endif - } - break; case scheme_proc_struct_type: case scheme_structure_type: { @@ -3266,9 +3525,6 @@ case scheme_sema_type: s = sizeof(Scheme_Sema); break; - case scheme_compilation_top_type: - s = sizeof(Scheme_Compilation_Top); - break; case scheme_hash_table_type: { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)root; diff -Nru racket-6.12+ppa1/src/racket/src/schcpt.h racket-7.0+ppa1/src/racket/src/schcpt.h --- racket-6.12+ppa1/src/racket/src/schcpt.h 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schcpt.h 2018-07-27 22:12:02.000000000 +0000 @@ -18,10 +18,9 @@ CPT_LIST, CPT_VECTOR, CPT_HASH_TABLE, - CPT_STX, CPT_LET_ONE_TYPED, - CPT_MARSHALLED, /* 20 */ - CPT_QUOTE, + CPT_LINKLET, + CPT_QUOTE, /* 20 */ CPT_REFERENCE, CPT_LOCAL, CPT_LOCAL_UNBOX, @@ -29,27 +28,33 @@ CPT_APPLICATION, CPT_LET_ONE, CPT_BRANCH, - CPT_MODULE_INDEX, - CPT_MODULE_VAR, /* 30 */ CPT_PATH, CPT_CLOSURE, - CPT_DELAY_REF, + CPT_DELAY_REF, /* 30 */ CPT_PREFAB, CPT_LET_ONE_UNUSED, - CPT_SCOPE, - CPT_ROOT_SCOPE, CPT_SHARED, + CPT_TOPLEVEL, + CPT_BEGIN, + CPT_BEGIN0, + CPT_LET_VALUE, + CPT_LET_VOID, + CPT_LETREC, + CPT_WCM, /* 40 */ + CPT_DEFINE_VALUES, + CPT_SET_BANG, + CPT_VARREF, + CPT_APPLY_VALUES, + CPT_OTHER_FORM, + CPT_SRCLOC, _CPT_COUNT_ }; -#define CPT_SMALL_NUMBER_START 39 -#define CPT_SMALL_NUMBER_END 62 +#define CPT_SMALL_NUMBER_START 47 +#define CPT_SMALL_NUMBER_END 74 -#define CPT_SMALL_SYMBOL_START 62 -#define CPT_SMALL_SYMBOL_END 80 - -#define CPT_SMALL_MARSHALLED_START 80 -#define CPT_SMALL_MARSHALLED_END 92 +#define CPT_SMALL_SYMBOL_START 74 +#define CPT_SMALL_SYMBOL_END 92 #define _SMALL_LIST_MAX_ 50 diff -Nru racket-6.12+ppa1/src/racket/src/schemef.h racket-7.0+ppa1/src/racket/src/schemef.h --- racket-6.12+ppa1/src/racket/src/schemef.h 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schemef.h 2018-07-27 22:12:02.000000000 +0000 @@ -386,17 +386,6 @@ /* Internal */ MZ_EXTERN Scheme_Object *scheme_do_eval(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); - -MZ_EXTERN Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx); -MZ_EXTERN Scheme_Object *scheme_load_compiled_stx_string(const char *str, intptr_t len); -MZ_EXTERN Scheme_Object *scheme_compiled_stx_symbol(Scheme_Object *stx); - -MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env); -MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_symbol, Scheme_Object *magic_val, - int multi_ok); - MZ_EXTERN void scheme_detach_multple_array(Scheme_Object **a); /*========================================================================*/ @@ -1023,39 +1012,36 @@ MZ_EXTERN void scheme_add_global(const char *name, Scheme_Object *val, Scheme_Env *env); MZ_EXTERN void scheme_add_global_symbol(Scheme_Object *name, Scheme_Object *val, - Scheme_Env *env); + Scheme_Env *env); MZ_EXTERN Scheme_Object *scheme_make_envunbox(Scheme_Object *value); MZ_EXTERN Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env); -MZ_EXTERN Scheme_Bucket *scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); MZ_EXTERN Scheme_Object *scheme_builtin_value(const char *name); /* convenience */ MZ_EXTERN void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val, int set_undef); -MZ_EXTERN void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v); - -MZ_EXTERN void scheme_save_initial_module_set(Scheme_Env *env); MZ_EXTERN Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env); MZ_EXTERN void scheme_finish_primitive_module(Scheme_Env *env); MZ_EXTERN void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless); MZ_EXTERN void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name); MZ_EXTERN Scheme_Object *scheme_make_modidx(Scheme_Object *path, - Scheme_Object *base, - Scheme_Object *resolved); - -MZ_EXTERN Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env); + Scheme_Object *base, + Scheme_Object *resolved); MZ_EXTERN Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]); +MZ_EXTERN Scheme_Object *scheme_dynamic_require_reader(int argc, Scheme_Object *argv[]); MZ_EXTERN Scheme_Object *scheme_namespace_require(Scheme_Object *); MZ_EXTERN int scheme_is_module_path(Scheme_Object *); +MZ_EXTERN int scheme_is_module_path_index(Scheme_Object *); +MZ_EXTERN int scheme_is_resolved_module_path(Scheme_Object *); MZ_EXTERN Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *e); diff -Nru racket-6.12+ppa1/src/racket/src/schemex.h racket-7.0+ppa1/src/racket/src/schemex.h --- racket-6.12+ppa1/src/racket/src/schemex.h 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schemex.h 2018-07-27 22:12:02.000000000 +0000 @@ -300,14 +300,6 @@ Scheme_Object *prompt_tag); /* Internal */ Scheme_Object *(*scheme_do_eval)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); -Scheme_Object *(*scheme_eval_compiled_stx_string)(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx); -Scheme_Object *(*scheme_load_compiled_stx_string)(const char *str, intptr_t len); -Scheme_Object *(*scheme_compiled_stx_symbol)(Scheme_Object *stx); -Scheme_Object *(*scheme_eval_compiled_sized_string)(const char *str, int len, Scheme_Env *env); -Scheme_Object *(*scheme_eval_compiled_sized_string_with_magic)(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_symbol, Scheme_Object *magic_val, - int multi_ok); void (*scheme_detach_multple_array)(Scheme_Object **a); /*========================================================================*/ /* memory management */ @@ -845,28 +837,23 @@ Scheme_Object *(*scheme_make_namespace)(int argc, Scheme_Object *argv[]); void (*scheme_add_global)(const char *name, Scheme_Object *val, Scheme_Env *env); void (*scheme_add_global_symbol)(Scheme_Object *name, Scheme_Object *val, - Scheme_Env *env); + Scheme_Env *env); Scheme_Object *(*scheme_make_envunbox)(Scheme_Object *value); Scheme_Object *(*scheme_lookup_global)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env); -Scheme_Bucket *(*scheme_global_keyword_bucket)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); Scheme_Object *(*scheme_builtin_value)(const char *name); /* convenience */ void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val, int set_undef); -void (*scheme_install_macro)(Scheme_Bucket *b, Scheme_Object *v); -void (*scheme_save_initial_module_set)(Scheme_Env *env); -Scheme_Env *(*scheme_primitive_module)(Scheme_Object *name, Scheme_Env *for_env); -void (*scheme_finish_primitive_module)(Scheme_Env *env); -void (*scheme_set_primitive_module_phaseless)(Scheme_Env *env, int phaseless); -void (*scheme_protect_primitive_provide)(Scheme_Env *env, Scheme_Object *name); Scheme_Object *(*scheme_make_modidx)(Scheme_Object *path, - Scheme_Object *base, - Scheme_Object *resolved); -Scheme_Object *(*scheme_apply_for_syntax_in_env)(Scheme_Object *proc, Scheme_Env *env); + Scheme_Object *base, + Scheme_Object *resolved); Scheme_Object *(*scheme_dynamic_require)(int argc, Scheme_Object *argv[]); +Scheme_Object *(*scheme_dynamic_require_reader)(int argc, Scheme_Object *argv[]); Scheme_Object *(*scheme_namespace_require)(Scheme_Object *); int (*scheme_is_module_path)(Scheme_Object *); +int (*scheme_is_module_path_index)(Scheme_Object *); +int (*scheme_is_resolved_module_path)(Scheme_Object *); Scheme_Object *(*scheme_datum_to_kernel_stx)(Scheme_Object *e); int (*scheme_module_is_declared)(Scheme_Object *name, int try_load); /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/racket/src/schemex.inc racket-7.0+ppa1/src/racket/src/schemex.inc --- racket-6.12+ppa1/src/racket/src/schemex.inc 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schemex.inc 2018-07-27 22:12:02.000000000 +0000 @@ -211,11 +211,6 @@ scheme_extension_table->scheme_extract_one_cc_mark = scheme_extract_one_cc_mark; scheme_extension_table->scheme_extract_one_cc_mark_to_tag = scheme_extract_one_cc_mark_to_tag; scheme_extension_table->scheme_do_eval = scheme_do_eval; - scheme_extension_table->scheme_eval_compiled_stx_string = scheme_eval_compiled_stx_string; - scheme_extension_table->scheme_load_compiled_stx_string = scheme_load_compiled_stx_string; - scheme_extension_table->scheme_compiled_stx_symbol = scheme_compiled_stx_symbol; - scheme_extension_table->scheme_eval_compiled_sized_string = scheme_eval_compiled_sized_string; - scheme_extension_table->scheme_eval_compiled_sized_string_with_magic = scheme_eval_compiled_sized_string_with_magic; scheme_extension_table->scheme_detach_multple_array = scheme_detach_multple_array; #ifndef SCHEME_NO_GC # ifndef SCHEME_NO_GC_PROTO @@ -615,21 +610,16 @@ scheme_extension_table->scheme_make_envunbox = scheme_make_envunbox; scheme_extension_table->scheme_lookup_global = scheme_lookup_global; scheme_extension_table->scheme_global_bucket = scheme_global_bucket; - scheme_extension_table->scheme_global_keyword_bucket = scheme_global_keyword_bucket; scheme_extension_table->scheme_module_bucket = scheme_module_bucket; scheme_extension_table->scheme_builtin_value = scheme_builtin_value; scheme_extension_table->scheme_set_global_bucket = scheme_set_global_bucket; - scheme_extension_table->scheme_install_macro = scheme_install_macro; - scheme_extension_table->scheme_save_initial_module_set = scheme_save_initial_module_set; - scheme_extension_table->scheme_primitive_module = scheme_primitive_module; - scheme_extension_table->scheme_finish_primitive_module = scheme_finish_primitive_module; - scheme_extension_table->scheme_set_primitive_module_phaseless = scheme_set_primitive_module_phaseless; - scheme_extension_table->scheme_protect_primitive_provide = scheme_protect_primitive_provide; scheme_extension_table->scheme_make_modidx = scheme_make_modidx; - scheme_extension_table->scheme_apply_for_syntax_in_env = scheme_apply_for_syntax_in_env; scheme_extension_table->scheme_dynamic_require = scheme_dynamic_require; + scheme_extension_table->scheme_dynamic_require_reader = scheme_dynamic_require_reader; scheme_extension_table->scheme_namespace_require = scheme_namespace_require; scheme_extension_table->scheme_is_module_path = scheme_is_module_path; + scheme_extension_table->scheme_is_module_path_index = scheme_is_module_path_index; + scheme_extension_table->scheme_is_resolved_module_path = scheme_is_resolved_module_path; scheme_extension_table->scheme_datum_to_kernel_stx = scheme_datum_to_kernel_stx; scheme_extension_table->scheme_module_is_declared = scheme_module_is_declared; scheme_extension_table->scheme_intern_symbol = scheme_intern_symbol; diff -Nru racket-6.12+ppa1/src/racket/src/schemexm.h racket-7.0+ppa1/src/racket/src/schemexm.h --- racket-6.12+ppa1/src/racket/src/schemexm.h 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schemexm.h 2018-07-27 22:12:02.000000000 +0000 @@ -211,11 +211,6 @@ #define scheme_extract_one_cc_mark (scheme_extension_table->scheme_extract_one_cc_mark) #define scheme_extract_one_cc_mark_to_tag (scheme_extension_table->scheme_extract_one_cc_mark_to_tag) #define scheme_do_eval (scheme_extension_table->scheme_do_eval) -#define scheme_eval_compiled_stx_string (scheme_extension_table->scheme_eval_compiled_stx_string) -#define scheme_load_compiled_stx_string (scheme_extension_table->scheme_load_compiled_stx_string) -#define scheme_compiled_stx_symbol (scheme_extension_table->scheme_compiled_stx_symbol) -#define scheme_eval_compiled_sized_string (scheme_extension_table->scheme_eval_compiled_sized_string) -#define scheme_eval_compiled_sized_string_with_magic (scheme_extension_table->scheme_eval_compiled_sized_string_with_magic) #define scheme_detach_multple_array (scheme_extension_table->scheme_detach_multple_array) #ifndef SCHEME_NO_GC # ifndef SCHEME_NO_GC_PROTO @@ -615,21 +610,16 @@ #define scheme_make_envunbox (scheme_extension_table->scheme_make_envunbox) #define scheme_lookup_global (scheme_extension_table->scheme_lookup_global) #define scheme_global_bucket (scheme_extension_table->scheme_global_bucket) -#define scheme_global_keyword_bucket (scheme_extension_table->scheme_global_keyword_bucket) #define scheme_module_bucket (scheme_extension_table->scheme_module_bucket) #define scheme_builtin_value (scheme_extension_table->scheme_builtin_value) #define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket) -#define scheme_install_macro (scheme_extension_table->scheme_install_macro) -#define scheme_save_initial_module_set (scheme_extension_table->scheme_save_initial_module_set) -#define scheme_primitive_module (scheme_extension_table->scheme_primitive_module) -#define scheme_finish_primitive_module (scheme_extension_table->scheme_finish_primitive_module) -#define scheme_set_primitive_module_phaseless (scheme_extension_table->scheme_set_primitive_module_phaseless) -#define scheme_protect_primitive_provide (scheme_extension_table->scheme_protect_primitive_provide) #define scheme_make_modidx (scheme_extension_table->scheme_make_modidx) -#define scheme_apply_for_syntax_in_env (scheme_extension_table->scheme_apply_for_syntax_in_env) #define scheme_dynamic_require (scheme_extension_table->scheme_dynamic_require) +#define scheme_dynamic_require_reader (scheme_extension_table->scheme_dynamic_require_reader) #define scheme_namespace_require (scheme_extension_table->scheme_namespace_require) #define scheme_is_module_path (scheme_extension_table->scheme_is_module_path) +#define scheme_is_module_path_index (scheme_extension_table->scheme_is_module_path_index) +#define scheme_is_resolved_module_path (scheme_extension_table->scheme_is_resolved_module_path) #define scheme_datum_to_kernel_stx (scheme_extension_table->scheme_datum_to_kernel_stx) #define scheme_module_is_declared (scheme_extension_table->scheme_module_is_declared) #define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol) diff -Nru racket-6.12+ppa1/src/racket/src/schexn.h racket-7.0+ppa1/src/racket/src/schexn.h --- racket-6.12+ppa1/src/racket/src/schexn.h 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schexn.h 2018-07-27 22:12:02.000000000 +0000 @@ -10,9 +10,6 @@ MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT, MZEXN_FAIL_CONTRACT_CONTINUATION, MZEXN_FAIL_CONTRACT_VARIABLE, - MZEXN_FAIL_SYNTAX, - MZEXN_FAIL_SYNTAX_UNBOUND, - MZEXN_FAIL_SYNTAX_MISSING_MODULE, MZEXN_FAIL_READ, MZEXN_FAIL_READ_EOF, MZEXN_FAIL_READ_NON_CHAR, @@ -20,7 +17,6 @@ MZEXN_FAIL_FILESYSTEM_EXISTS, MZEXN_FAIL_FILESYSTEM_VERSION, MZEXN_FAIL_FILESYSTEM_ERRNO, - MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, MZEXN_FAIL_NETWORK, MZEXN_FAIL_NETWORK_ERRNO, MZEXN_FAIL_OUT_OF_MEMORY, @@ -35,7 +31,7 @@ #ifdef _MZEXN_TABLE -#define MZEXN_MAXARGS 4 +#define MZEXN_MAXARGS 3 #ifdef GLOBAL_EXN_ARRAY static exn_rec exn_table[] = { @@ -49,23 +45,19 @@ { 3, NULL, NULL, 0, NULL, 2 }, { 3, NULL, NULL, 0, NULL, 1 }, { 3, NULL, NULL, 0, NULL, 8 }, - { 4, NULL, NULL, 0, NULL, 8 }, - { 3, NULL, NULL, 0, NULL, 1 }, - { 3, NULL, NULL, 0, NULL, 11 }, - { 3, NULL, NULL, 0, NULL, 11 }, + { 3, NULL, NULL, 0, NULL, 8 }, { 2, NULL, NULL, 0, NULL, 1 }, - { 2, NULL, NULL, 0, NULL, 14 }, - { 2, NULL, NULL, 0, NULL, 14 }, - { 3, NULL, NULL, 0, NULL, 14 }, - { 3, NULL, NULL, 0, NULL, 14 }, + { 2, NULL, NULL, 0, NULL, 11 }, + { 2, NULL, NULL, 0, NULL, 11 }, + { 3, NULL, NULL, 0, NULL, 11 }, { 2, NULL, NULL, 0, NULL, 1 }, - { 3, NULL, NULL, 0, NULL, 19 }, + { 3, NULL, NULL, 0, NULL, 15 }, { 2, NULL, NULL, 0, NULL, 1 }, { 2, NULL, NULL, 0, NULL, 1 }, { 2, NULL, NULL, 0, NULL, 1 }, { 3, NULL, NULL, 0, NULL, 0 }, - { 3, NULL, NULL, 0, NULL, 24 }, - { 3, NULL, NULL, 0, NULL, 24 } + { 3, NULL, NULL, 0, NULL, 20 }, + { 3, NULL, NULL, 0, NULL, 20 } }; #else static exn_rec *exn_table; @@ -85,9 +77,6 @@ exn_table[MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT].args = 2; exn_table[MZEXN_FAIL_CONTRACT_CONTINUATION].args = 2; exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].args = 3; - exn_table[MZEXN_FAIL_SYNTAX].args = 3; - exn_table[MZEXN_FAIL_SYNTAX_UNBOUND].args = 3; - exn_table[MZEXN_FAIL_SYNTAX_MISSING_MODULE].args = 4; exn_table[MZEXN_FAIL_READ].args = 3; exn_table[MZEXN_FAIL_READ_EOF].args = 3; exn_table[MZEXN_FAIL_READ_NON_CHAR].args = 3; @@ -95,7 +84,6 @@ exn_table[MZEXN_FAIL_FILESYSTEM_EXISTS].args = 2; exn_table[MZEXN_FAIL_FILESYSTEM_VERSION].args = 2; exn_table[MZEXN_FAIL_FILESYSTEM_ERRNO].args = 3; - exn_table[MZEXN_FAIL_FILESYSTEM_MISSING_MODULE].args = 3; exn_table[MZEXN_FAIL_NETWORK].args = 2; exn_table[MZEXN_FAIL_NETWORK_ERRNO].args = 3; exn_table[MZEXN_FAIL_OUT_OF_MEMORY].args = 2; @@ -111,48 +99,38 @@ #ifdef _MZEXN_DECL_FIELDS static const char *MZEXN_FIELDS[2] = { "message", "continuation-marks" }; static const char *MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS[1] = { "id" }; - static const char *MZEXN_FAIL_SYNTAX_FIELDS[1] = { "exprs" }; - static const char *MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS[1] = { "path" }; static const char *MZEXN_FAIL_READ_FIELDS[1] = { "srclocs" }; static const char *MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS[1] = { "errno" }; - static const char *MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS[1] = { "path" }; static const char *MZEXN_FAIL_NETWORK_ERRNO_FIELDS[1] = { "errno" }; static const char *MZEXN_BREAK_FIELDS[1] = { "continuation" }; #endif #ifdef _MZEXN_DECL_PROPS -# define MZEXN_FAIL_SYNTAX_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_syntax_locations)), scheme_null) -# define MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_3)), scheme_null) -# define MZEXN_FAIL_READ_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_read_locations)), scheme_null) -# define MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_2)), scheme_null) +# define MZEXN_FAIL_READ_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)), scheme_null) #endif #ifdef _MZEXN_SETUP - SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS, scheme_null, scheme_make_prim(exn_field_check)) + SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS, scheme_null, scheme_make_prim_w_arity(exn_field_check, "exn_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL, EXN_PARENT(MZEXN), "exn:fail", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT, EXN_PARENT(MZEXN_FAIL), "exn:fail:contract", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_ARITY, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:arity", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:divide-by-zero", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:non-fixnum-result", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_CONTINUATION, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:continuation", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_CONTRACT_VARIABLE, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:variable", 1, MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS, scheme_null, scheme_make_prim(variable_field_check)) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX, EXN_PARENT(MZEXN_FAIL), "exn:fail:syntax", 1, MZEXN_FAIL_SYNTAX_FIELDS, MZEXN_FAIL_SYNTAX_PROPS, scheme_make_prim(syntax_field_check)) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX_UNBOUND, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:unbound", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:missing-module", 1, MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS, MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_3)) - SETUP_STRUCT(MZEXN_FAIL_READ, EXN_PARENT(MZEXN_FAIL), "exn:fail:read", 1, MZEXN_FAIL_READ_FIELDS, MZEXN_FAIL_READ_PROPS, scheme_make_prim(read_field_check)) + SETUP_STRUCT(MZEXN_FAIL_CONTRACT_VARIABLE, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:variable", 1, MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS, scheme_null, scheme_make_prim_w_arity(variable_field_check, "variable_field_check" , 0, -1)) + SETUP_STRUCT(MZEXN_FAIL_READ, EXN_PARENT(MZEXN_FAIL), "exn:fail:read", 1, MZEXN_FAIL_READ_FIELDS, MZEXN_FAIL_READ_PROPS, scheme_make_prim_w_arity(read_field_check, "read_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_READ_EOF, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:eof", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_READ_NON_CHAR, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:non-char", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM, EXN_PARENT(MZEXN_FAIL), "exn:fail:filesystem", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_EXISTS, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:exists", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_VERSION, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:version", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_ERRNO, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:errno", 1, MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check)) - SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:missing-module", 1, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_2)) + SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_ERRNO, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:errno", 1, MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS, scheme_null, scheme_make_prim_w_arity(errno_field_check, "errno_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_NETWORK, EXN_PARENT(MZEXN_FAIL), "exn:fail:network", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_NETWORK_ERRNO, EXN_PARENT(MZEXN_FAIL_NETWORK), "exn:fail:network:errno", 1, MZEXN_FAIL_NETWORK_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check)) + SETUP_STRUCT(MZEXN_FAIL_NETWORK_ERRNO, EXN_PARENT(MZEXN_FAIL_NETWORK), "exn:fail:network:errno", 1, MZEXN_FAIL_NETWORK_ERRNO_FIELDS, scheme_null, scheme_make_prim_w_arity(errno_field_check, "errno_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_OUT_OF_MEMORY, EXN_PARENT(MZEXN_FAIL), "exn:fail:out-of-memory", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_UNSUPPORTED, EXN_PARENT(MZEXN_FAIL), "exn:fail:unsupported", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_USER, EXN_PARENT(MZEXN_FAIL), "exn:fail:user", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_BREAK, EXN_PARENT(MZEXN), "exn:break", 1, MZEXN_BREAK_FIELDS, scheme_null, scheme_make_prim(break_field_check)) + SETUP_STRUCT(MZEXN_BREAK, EXN_PARENT(MZEXN), "exn:break", 1, MZEXN_BREAK_FIELDS, scheme_null, scheme_make_prim_w_arity(break_field_check, "break_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_BREAK_HANG_UP, EXN_PARENT(MZEXN_BREAK), "exn:break:hang-up", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_BREAK_TERMINATE, EXN_PARENT(MZEXN_BREAK), "exn:break:terminate", 0, NULL, scheme_null, NULL) #endif diff -Nru racket-6.12+ppa1/src/racket/src/schexpobs.h racket-7.0+ppa1/src/racket/src/schexpobs.h --- racket-6.12+ppa1/src/racket/src/schexpobs.h 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schexpobs.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,204 +0,0 @@ - -#ifndef __mzscheme_expobs__ -#define __mzscheme_expobs__ - -#define SCHEME_EXPAND_OBSERVE_ENABLE - -extern void scheme_call_expand_observe(Scheme_Object *obs, int signal, Scheme_Object *argument); -extern Scheme_Object *scheme_expand_observe_renames(Scheme_Object *env_pair); -extern void scheme_init_expand_observe(Scheme_Env *); -extern Scheme_Object *scheme_get_expand_observe(); - - -#ifdef SCHEME_EXPAND_OBSERVE_ENABLE -# define _SCHEME_EXPOBS(observer, signal, argument) \ - if (observer) { scheme_call_expand_observe(observer, signal, argument); } else {} -#endif - -#ifndef SCHEME_EXPAND_OBSERVE_ENABLE -#define _SCHEME_EXPOBS(observer, signal, argument) \ - ((void)0) -#endif - -/* Individual signals */ - -#define SCHEME_EXPAND_OBSERVE_VISIT(observer,stx) _SCHEME_EXPOBS(observer,0,stx) -#define SCHEME_EXPAND_OBSERVE_RESOLVE(observer,stx) _SCHEME_EXPOBS(observer,1,stx) -#define SCHEME_EXPAND_OBSERVE_RETURN(observer,stx) _SCHEME_EXPOBS(observer,2,stx) -#define SCHEME_EXPAND_OBSERVE_NEXT(observer) _SCHEME_EXPOBS(observer,3,NULL) -#define SCHEME_EXPAND_OBSERVE_ENTER_LIST(observer,stx) _SCHEME_EXPOBS(observer,4,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LIST(observer,stx) _SCHEME_EXPOBS(observer,5,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer,stx) _SCHEME_EXPOBS(observer,6,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,stx) _SCHEME_EXPOBS(observer,7,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_MACRO(observer,stx) _SCHEME_EXPOBS(observer,8,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_MACRO(observer,stx) _SCHEME_EXPOBS(observer,9,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(observer,stx) _SCHEME_EXPOBS(observer,10,stx) -#define SCHEME_EXPAND_OBSERVE_SPLICE(observer,stx) _SCHEME_EXPOBS(observer,11,stx) -#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(observer,stx) _SCHEME_EXPOBS(observer,12,stx) -#define SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer) _SCHEME_EXPOBS(observer,13,NULL) -#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(observer,stx) _SCHEME_EXPOBS(observer,14,stx) -#define SCHEME_EXPAND_OBSERVE_LET_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,16, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,17, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,18, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(observer,sbinds,vbinds,body) \ - _SCHEME_EXPOBS(observer,19, scheme_make_pair(sbinds, scheme_make_pair(vbinds, body))) -#define SCHEME_EXPAND_OBSERVE_PHASE_UP(observer) _SCHEME_EXPOBS(observer,20,NULL) - -#define SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(observer,stx) _SCHEME_EXPOBS(observer,21,stx) -#define SCHEME_EXPAND_OBSERVE_MACRO_POST_X(observer,stx,orig_stx) \ - _SCHEME_EXPOBS(observer,22,scheme_make_pair(stx, orig_stx)) - -#define SCHEME_EXPAND_OBSERVE_MODULE_BODY(observer,list) _SCHEME_EXPOBS(observer,23,list) -#define SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(observer,old,new) \ - _SCHEME_EXPOBS(observer,24, scheme_make_pair(old, new)) - -/* Prim signals */ -#define SCHEME_EXPAND_OBSERVE_PRIM_STOP(observer) \ - _SCHEME_EXPOBS(observer,100,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE(observer) \ - _SCHEME_EXPOBS(observer,101,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(observer) \ - _SCHEME_EXPOBS(observer,102,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer) \ - _SCHEME_EXPOBS(observer,103,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer) \ - _SCHEME_EXPOBS(observer,104,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_IF(observer) \ - _SCHEME_EXPOBS(observer,105,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_WCM(observer) \ - _SCHEME_EXPOBS(observer,106,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(observer) \ - _SCHEME_EXPOBS(observer,107,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(observer) \ - _SCHEME_EXPOBS(observer,108,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_APP(observer) \ - _SCHEME_EXPOBS(observer,109,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(observer) \ - _SCHEME_EXPOBS(observer,110,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(observer) \ - _SCHEME_EXPOBS(observer,111,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(observer) \ - _SCHEME_EXPOBS(observer,112,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(observer) \ - _SCHEME_EXPOBS(observer,113,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(observer) \ - _SCHEME_EXPOBS(observer,114,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DATUM(observer) \ - _SCHEME_EXPOBS(observer,115,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_TOP(observer) \ - _SCHEME_EXPOBS(observer,116,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(observer) \ - _SCHEME_EXPOBS(observer,117,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,118,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer) \ - _SCHEME_EXPOBS(observer,119,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,120,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer) \ - _SCHEME_EXPOBS(observer,121,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer) \ - _SCHEME_EXPOBS(observer,122,NULL) - -#define SCHEME_EXPAND_OBSERVE_PRIM_SET(observer) \ - _SCHEME_EXPOBS(observer,123,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(observer) \ - _SCHEME_EXPOBS(observer,124,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(obs) \ - _SCHEME_EXPOBS(obs,138,scheme_false) -#define SCHEME_EXPAND_OBSERVE_PRIM_VARREF(obs) \ - _SCHEME_EXPOBS(obs,149,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(observer) \ - _SCHEME_EXPOBS(observer,155,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,156,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer) \ - _SCHEME_EXPOBS(observer,158,scheme_false) -#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer) \ - _SCHEME_EXPOBS(observer,159,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ - _SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2)) - -#define SCHEME_EXPAND_OBSERVE_ENTER_CHECK(observer,stx) \ - _SCHEME_EXPOBS(observer,126,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_CHECK(observer,stx) \ - _SCHEME_EXPOBS(observer,127,stx) - -#define SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,128,stx) -#define SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,136,stx) -#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer,stxs) \ - _SCHEME_EXPOBS(observer,137,stxs) -#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,135,stx) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(obs,ids,stx) \ - _SCHEME_EXPOBS(obs,129,scheme_make_pair(ids,stx)) -#define SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(obs,stx) \ - _SCHEME_EXPOBS(obs,134,stx) -#define SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(obs,req,form,mform) \ - _SCHEME_EXPOBS(obs,150,scheme_make_pair(req,scheme_make_pair(form,mform))) -#define SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(obs,form) \ - _SCHEME_EXPOBS(obs,151,form) - -#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(obs,stx) \ - _SCHEME_EXPOBS(obs,130,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(obs,stx) \ - _SCHEME_EXPOBS(obs,131,stx) -#define SCHEME_EXPAND_OBSERVE_LOCAL_PRE(obs,stx) \ - _SCHEME_EXPOBS(obs,132,stx) -#define SCHEME_EXPAND_OBSERVE_LOCAL_POST(obs,stx) \ - _SCHEME_EXPOBS(obs,133,stx) - -#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL_EXPR(obs,stx) \ - _SCHEME_EXPOBS(obs,139,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_EXPR(obs,stx,opaque) \ - _SCHEME_EXPOBS(obs,140,scheme_make_pair(stx,opaque)) - -#define SCHEME_EXPAND_OBSERVE_START_EXPAND(obs) \ - _SCHEME_EXPOBS(obs,141,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_TAG(obs,stx) \ - _SCHEME_EXPOBS(obs,142,stx) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_BIND(obs,ids) \ - _SCHEME_EXPOBS(obs,143,ids) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_BIND(obs) \ - _SCHEME_EXPOBS(obs,160,scheme_false); -#define SCHEME_EXPAND_OBSERVE_ENTER_BIND(obs) \ - _SCHEME_EXPOBS(obs,144,scheme_false) -#define SCHEME_EXPAND_OBSERVE_EXIT_BIND(obs) \ - _SCHEME_EXPOBS(obs,145,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(obs,val) \ - _SCHEME_EXPOBS(obs,146,val) - -#define SCHEME_EXPAND_OBSERVE_RENAME_LIST(obs,vals) \ - _SCHEME_EXPOBS(obs,147,vals) - -#define SCHEME_EXPAND_OBSERVE_RENAME_ONE(obs,val) \ - _SCHEME_EXPOBS(obs,148,val) - -#define SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(obs,pre,post) \ - _SCHEME_EXPOBS(obs,152,scheme_make_pair(pre,post)) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(obs,id) \ - _SCHEME_EXPOBS(obs,153,id) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(obs,bound) \ - _SCHEME_EXPOBS(obs,154,bound) - -#define SCHEME_EXPAND_OBSERVE_PREPARE_ENV(obs) \ - _SCHEME_EXPOBS(obs,157,scheme_false) - -/* next: 161 */ - -#endif diff -Nru racket-6.12+ppa1/src/racket/src/schminc.h racket-7.0+ppa1/src/racket/src/schminc.h --- racket-6.12+ppa1/src/racket/src/schminc.h 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schminc.h 2018-07-27 22:12:02.000000000 +0000 @@ -14,24 +14,9 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1161 -#define EXPECTED_UNSAFE_COUNT 157 -#define EXPECTED_FLFXNUM_COUNT 69 -#define EXPECTED_EXTFL_COUNT 45 -#define EXPECTED_FUTURES_COUNT 15 -#define EXPECTED_FOREIGN_COUNT 79 +#define EXPECTED_PRIM_COUNT 1431 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP # define USE_COMPILED_STARTUP 0 #endif - -#if defined(__MWERKS__) && !defined(powerc) -#define MZCOMPILED_STRING_FAR far -#else -#define MZCOMPILED_STRING_FAR /**/ -#endif - -#if USE_COMPILED_STARTUP -extern Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env); -#endif diff -Nru racket-6.12+ppa1/src/racket/src/schpriv.h racket-7.0+ppa1/src/racket/src/schpriv.h --- racket-6.12+ppa1/src/racket/src/schpriv.h 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schpriv.h 2018-07-27 22:12:02.000000000 +0000 @@ -123,8 +123,13 @@ /* indicates a primitive that produces a real number when given real-number arguments: */ #define SCHEME_PRIM_CLOSED_ON_REALS (1 << 21) +/* indicates the presence of an ad-hoc optimization + in one of the application optimization passes */ +#define SCHEME_PRIM_AD_HOC_OPT (1 << 22) +/* a primitive that produces a booeal or errors: */ +#define SCHEME_PRIM_PRODUCES_BOOL (1 << 23) -#define SCHEME_PRIM_OPT_TYPE_SHIFT 22 +#define SCHEME_PRIM_OPT_TYPE_SHIFT 24 #define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT) #define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT) @@ -300,6 +305,8 @@ THREAD_LOCAL_DECL(extern int scheme_starting_up); +typedef struct Scheme_Startup_Env Scheme_Startup_Env; + void scheme_init_finalization(void); void scheme_init_portable_case(void); void scheme_init_stack_check(void); @@ -315,7 +322,7 @@ void scheme_init_process_globals(void); void scheme_init_true_false(void); void scheme_init_symbol_table(void); -void scheme_init_symbol_type(Scheme_Env *env); +void scheme_init_symbol_type(Scheme_Startup_Env *env); void scheme_init_type(); void scheme_init_custodian_extractors(); void scheme_init_bignum(); @@ -328,68 +335,68 @@ void scheme_init_port_wait(); void scheme_init_logger_wait(); void scheme_init_struct_wait(); -void scheme_init_list(Scheme_Env *env); -void scheme_init_unsafe_list(Scheme_Env *env); -void scheme_init_unsafe_hash(Scheme_Env *env); -void scheme_init_stx(Scheme_Env *env); -void scheme_init_module(Scheme_Env *env); +void scheme_init_list(Scheme_Startup_Env *env); +void scheme_init_unsafe_list(Scheme_Startup_Env *env); +void scheme_init_unsafe_hash(Scheme_Startup_Env *env); +void scheme_init_stx(Scheme_Startup_Env *env); +void scheme_init_module(Scheme_Startup_Env *env); void scheme_init_module_path_table(void); -void scheme_init_port(Scheme_Env *env); -void scheme_init_port_fun(Scheme_Env *env); -void scheme_init_network(Scheme_Env *env); -void scheme_init_file(Scheme_Env *env); -void scheme_init_proc(Scheme_Env *env); -void scheme_init_vector(Scheme_Env *env); -void scheme_init_unsafe_vector(Scheme_Env *env); -void scheme_init_string(Scheme_Env *env); -void scheme_init_number(Scheme_Env *env); -void scheme_init_flfxnum_number(Scheme_Env *env); -void scheme_init_extfl_number(Scheme_Env *env); -void scheme_init_unsafe_number(Scheme_Env *env); -void scheme_init_extfl_unsafe_number(Scheme_Env *env); -void scheme_init_numarith(Scheme_Env *env); -void scheme_init_flfxnum_numarith(Scheme_Env *env); -void scheme_init_extfl_numarith(Scheme_Env *env); -void scheme_init_unsafe_numarith(Scheme_Env *env); -void scheme_init_extfl_unsafe_numarith(Scheme_Env *env); -void scheme_init_numcomp(Scheme_Env *env); -void scheme_init_flfxnum_numcomp(Scheme_Env *env); -void scheme_init_extfl_numcomp(Scheme_Env *env); -void scheme_init_unsafe_numcomp(Scheme_Env *env); -void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env); -void scheme_init_numstr(Scheme_Env *env); -void scheme_init_extfl_numstr(Scheme_Env *env); -void scheme_init_eval(Scheme_Env *env); -void scheme_init_promise(Scheme_Env *env); -void scheme_init_struct(Scheme_Env *env); -void scheme_init_reduced_proc_struct(Scheme_Env *env); -void scheme_init_fun(Scheme_Env *env); -void scheme_init_unsafe_fun(Scheme_Env *env); -void scheme_init_compile(Scheme_Env *env); -void scheme_init_symbol(Scheme_Env *env); +void scheme_init_port(Scheme_Startup_Env *env); +void scheme_init_port_fun(Scheme_Startup_Env *env); +void scheme_init_network(Scheme_Startup_Env *env); +void scheme_init_file(Scheme_Startup_Env *env); +void scheme_init_proc(Scheme_Startup_Env *env); +void scheme_init_vector(Scheme_Startup_Env *env); +void scheme_init_unsafe_vector(Scheme_Startup_Env *env); +void scheme_init_string(Scheme_Startup_Env *env); +void scheme_init_number(Scheme_Startup_Env *env); +void scheme_init_flfxnum_number(Scheme_Startup_Env *env); +void scheme_init_extfl_number(Scheme_Startup_Env *env); +void scheme_init_unsafe_number(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env); +void scheme_init_numarith(Scheme_Startup_Env *env); +void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env); +void scheme_init_extfl_numarith(Scheme_Startup_Env *env); +void scheme_init_unsafe_numarith(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env); +void scheme_init_numcomp(Scheme_Startup_Env *env); +void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env); +void scheme_init_extfl_numcomp(Scheme_Startup_Env *env); +void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env); +void scheme_init_numstr(Scheme_Startup_Env *env); +void scheme_init_extfl_numstr(Scheme_Startup_Env *env); +void scheme_init_eval(Scheme_Startup_Env *env); +void scheme_init_promise(Scheme_Startup_Env *env); +void scheme_init_struct(Scheme_Startup_Env *env); +void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env); +void scheme_init_fun(Scheme_Startup_Env *env); +void scheme_init_unsafe_fun(Scheme_Startup_Env *env); +void scheme_init_compile(Scheme_Startup_Env *env); +void scheme_init_symbol(Scheme_Startup_Env *env); void scheme_init_char_constants(void); -void scheme_init_char(Scheme_Env *env); -void scheme_init_bool(Scheme_Env *env); -void scheme_init_syntax(Scheme_Env *env); -void scheme_init_marshal(Scheme_Env *env); -void scheme_init_error(Scheme_Env *env); +void scheme_init_char(Scheme_Startup_Env *env); +void scheme_init_bool(Scheme_Startup_Env *env); +void scheme_init_syntax(Scheme_Startup_Env *env); +void scheme_init_marshal(Scheme_Startup_Env *env); +void scheme_init_error(Scheme_Startup_Env *env); #ifndef NO_SCHEME_EXNS -void scheme_init_exn(Scheme_Env *env); +void scheme_init_exn(Scheme_Startup_Env *env); #endif -void scheme_init_debug(Scheme_Env *env); -void scheme_init_thread(Scheme_Env *env); -void scheme_init_unsafe_thread(Scheme_Env *env); -void scheme_init_unsafe_port(Scheme_Env *env); -void scheme_init_read(Scheme_Env *env); -void scheme_init_print(Scheme_Env *env); +void scheme_init_debug(Scheme_Startup_Env *env); +void scheme_init_thread(Scheme_Startup_Env *env); +void scheme_init_unsafe_port(Scheme_Startup_Env *env); +void scheme_init_unsafe_thread(Scheme_Startup_Env *env); +void scheme_init_read(Scheme_Startup_Env *env); +void scheme_init_print(Scheme_Startup_Env *env); #ifndef NO_SCHEME_THREADS -void scheme_init_sema(Scheme_Env *env); +void scheme_init_sema(Scheme_Startup_Env *env); #endif -void scheme_init_dynamic_extension(Scheme_Env *env); +void scheme_init_dynamic_extension(Scheme_Startup_Env *env); #ifndef NO_REGEXP_UTILS -extern void scheme_regexp_initialize(Scheme_Env *env); +extern void scheme_regexp_initialize(Scheme_Startup_Env *env); #endif -void scheme_init_paramz(Scheme_Env *env); +void scheme_init_paramz(Scheme_Startup_Env *env); void scheme_init_parameterization(); void scheme_init_getenv(void); void scheme_init_inspector(void); @@ -400,18 +407,21 @@ #ifndef DONT_USE_FOREIGN void scheme_init_foreign_globals(); #endif -void scheme_init_foreign(Scheme_Env *env); -void scheme_init_place(Scheme_Env *env); +void scheme_init_foreign(Scheme_Startup_Env *env); +void scheme_init_place(Scheme_Startup_Env *env); +void scheme_init_place_per_place(); void scheme_init_places_once(); -void scheme_init_futures(Scheme_Env *env); +void scheme_init_futures(Scheme_Startup_Env *env); void scheme_init_futures_once(); void scheme_init_futures_per_place(); void scheme_end_futures_per_place(); -void scheme_init_linklet(Scheme_Env *env); +void scheme_init_linklet(Scheme_Startup_Env *env); +void scheme_init_unsafe_linklet(Scheme_Startup_Env *env); void scheme_init_print_buffers_places(void); void scheme_init_string_places(void); void scheme_init_thread_places(void); +void scheme_init_linklet_places(void); void scheme_init_eval_places(void); void scheme_init_compile_places(void); void scheme_init_compenv_places(void); @@ -421,7 +431,6 @@ void scheme_init_fun_places(void); void scheme_init_sema_places(void); void scheme_init_gmp_places(void); -void scheme_init_print_global_constants(void); void scheme_init_variable_references_constants(void); void scheme_init_logger(void); void scheme_init_logging_once(void); @@ -442,12 +451,19 @@ XFORM_NONGCING int scheme_is_multithreaded(int now); -/* Type readers & writers for compiled code data */ -typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); -typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj); - -extern Scheme_Type_Reader *scheme_type_readers; -extern Scheme_Type_Writer *scheme_type_writers; +Scheme_Object *scheme_closure_marshal_name(Scheme_Object *name); +void scheme_write_lambda(Scheme_Object *obj, + Scheme_Object **_name, + Scheme_Object **_ds, + Scheme_Object **_closure_map, + Scheme_Object **_tl_map); +Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, int max_let_depth, + Scheme_Object *name, + Scheme_Object *ds, + Scheme_Object *closure_map, + Scheme_Object *tl_map); +Scheme_Object *scheme_write_linklet(Scheme_Object *obj); +Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok); extern Scheme_Equal_Proc *scheme_type_equals; extern Scheme_Primary_Hash_Proc *scheme_type_hash1s; @@ -455,6 +471,7 @@ void scheme_init_port_config(void); void scheme_init_port_fun_config(void); +void scheme_init_resolver_config(void); Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *c); void scheme_init_error_config(void); #ifndef NO_SCHEME_EXNS @@ -465,7 +482,7 @@ #endif void scheme_init_module_resolver(void); -void scheme_finish_kernel(Scheme_Env *env); +void scheme_finish_kernel(Scheme_Startup_Env *env); void scheme_init_syntax_bindings(void); @@ -480,16 +497,23 @@ Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start); Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags); -void scheme_add_embedded_builtins(Scheme_Env *env); -void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, - Scheme_Object *obj, int constant, - int primitive); +Scheme_Object *scheme_position_to_builtin(int l); + +typedef struct Scheme_Instance Scheme_Instance; +typedef struct Scheme_Linklet Scheme_Linklet; + +void scheme_init_startup(void); /* across places */ +void scheme_init_startup_instance(Scheme_Instance *i); void *scheme_get_os_thread_like(); void scheme_init_os_thread_like(void *); void scheme_done_os_thread(); int scheme_is_place_main_os_thread(); +Scheme_Object *scheme_get_startup_export(const char *s); + +extern int scheme_init_load_on_demand; + /*========================================================================*/ /* constants */ /*========================================================================*/ @@ -522,6 +546,8 @@ extern Scheme_Object *scheme_unsafe_mcar_proc; extern Scheme_Object *scheme_unsafe_mcdr_proc; extern Scheme_Object *scheme_unsafe_unbox_proc; +extern Scheme_Object *scheme_unsafe_unbox_star_proc; +extern Scheme_Object *scheme_unsafe_set_box_star_proc; extern Scheme_Object *scheme_car_proc; extern Scheme_Object *scheme_cdr_proc; extern Scheme_Object *scheme_cons_proc; @@ -532,14 +558,24 @@ extern Scheme_Object *scheme_list_pair_p_proc; extern Scheme_Object *scheme_vector_proc; extern Scheme_Object *scheme_vector_p_proc; +extern Scheme_Object *scheme_vector_length_proc; +extern Scheme_Object *scheme_vector_star_length_proc; extern Scheme_Object *scheme_make_vector_proc; extern Scheme_Object *scheme_vector_immutable_proc; extern Scheme_Object *scheme_vector_ref_proc; +extern Scheme_Object *scheme_vector_star_ref_proc; +extern Scheme_Object *scheme_unsafe_vector_star_ref_proc; +extern Scheme_Object *scheme_unsafe_vector_star_set_proc; extern Scheme_Object *scheme_vector_set_proc; +extern Scheme_Object *scheme_vector_star_set_proc; +extern Scheme_Object *scheme_vector_cas_proc; extern Scheme_Object *scheme_list_to_vector_proc; extern Scheme_Object *scheme_unsafe_vector_length_proc; +extern Scheme_Object *scheme_unsafe_vector_star_length_proc; extern Scheme_Object *scheme_unsafe_struct_ref_proc; extern Scheme_Object *scheme_unsafe_struct_star_ref_proc; +extern Scheme_Object *scheme_unsafe_struct_set_proc; +extern Scheme_Object *scheme_unsafe_struct_star_set_proc; extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_box_p_proc; extern Scheme_Object *scheme_box_proc; @@ -555,16 +591,22 @@ extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_make_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; +extern Scheme_Object *scheme_varref_unsafe_p_proc; extern Scheme_Object *scheme_unsafe_fxnot_proc; extern Scheme_Object *scheme_unsafe_fxand_proc; extern Scheme_Object *scheme_unsafe_fxior_proc; extern Scheme_Object *scheme_unsafe_fxxor_proc; extern Scheme_Object *scheme_unsafe_fxrshift_proc; +extern Scheme_Object *scheme_unsafe_pure_proc; extern Scheme_Object *scheme_string_p_proc; extern Scheme_Object *scheme_unsafe_string_length_proc; +extern Scheme_Object *scheme_unsafe_string_set_proc; +extern Scheme_Object *scheme_unsafe_string_ref_proc; extern Scheme_Object *scheme_byte_string_p_proc; extern Scheme_Object *scheme_unsafe_byte_string_length_proc; +extern Scheme_Object *scheme_unsafe_bytes_ref_proc; +extern Scheme_Object *scheme_unsafe_bytes_set_proc; extern Scheme_Object *scheme_unsafe_real_add1_proc; extern Scheme_Object *scheme_unsafe_real_sub1_proc; @@ -592,10 +634,9 @@ extern Scheme_Object *scheme_unsafe_fx_gt_eq_proc; extern Scheme_Object *scheme_unsafe_fx_min_proc; extern Scheme_Object *scheme_unsafe_fx_max_proc; - -extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; -extern Scheme_Object *scheme_lambda_syntax; -extern Scheme_Object *scheme_begin_syntax; +extern Scheme_Object *scheme_unsafe_fx_plus_proc; +extern Scheme_Object *scheme_unsafe_fx_minus_proc; +extern Scheme_Object *scheme_unsafe_fx_times_proc; extern Scheme_Object *scheme_not_proc; extern Scheme_Object *scheme_true_object_p_proc; @@ -605,6 +646,9 @@ extern Scheme_Object *scheme_equal_proc; extern Scheme_Object *scheme_def_exit_proc; +extern Scheme_Object *scheme_system_type_proc; + +extern Scheme_Object *scheme_unsafe_poller_proc; extern Scheme_Object *scheme_unsafe_poller_proc; @@ -620,17 +664,6 @@ extern Scheme_Object *scheme_date; -extern Scheme_Object *scheme_liberal_def_ctx_type; - -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_modulestar_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_begin_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_values_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_syntaxes_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_for_syntax_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_top_stx); - extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; extern Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol; @@ -913,7 +946,7 @@ Scheme_Custodian* scheme_custodian_extract_reference(Scheme_Custodian_Reference *mr); /*========================================================================*/ -/* hash tables and globals */ +/* hash tables and linklet instances */ /*========================================================================*/ /* a primitive constant: */ @@ -940,12 +973,12 @@ typedef struct { Scheme_Bucket_With_Ref_Id bucket; - Scheme_Object *home_link; /* weak to Scheme_Env *, except when GLOB_STRONG_HOME_LINK */ + Scheme_Object *home_link; /* weak to Scheme_Instance *, except when GLOB_STRONG_HOME_LINK */ } Scheme_Bucket_With_Home; -Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b); -void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e); -Scheme_Object *scheme_get_home_weak_link(Scheme_Env *e); +XFORM_NONGCING Scheme_Instance *scheme_get_bucket_home(Scheme_Bucket *b); +void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Instance *e); +Scheme_Object *scheme_get_home_weak_link(Scheme_Instance *e); Scheme_Object * scheme_get_primitive_global(Scheme_Object *var, Scheme_Env *env, @@ -1014,6 +1047,11 @@ int scheme_is_hash_tree_equal(Scheme_Object *o); int scheme_is_hash_tree_eqv(Scheme_Object *o); +Scheme_Object *scheme_chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key); +void scheme_chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap); + /*========================================================================*/ /* structs */ /*========================================================================*/ @@ -1041,6 +1079,7 @@ mzshort num_islots; /* initialized + parent-initialized */ mzshort name_pos; char authentic; /* 1 => chaperones/impersonators disallowed */ + char nonfail_constructor; /* 1 => constructor never fails */ Scheme_Object *name; @@ -1141,7 +1180,7 @@ int num_islots, Scheme_Object *uninit_val, char *immutable_pos_list); -Scheme_Object *scheme_prefab_struct_key(Scheme_Object *s); +XFORM_NONGCING Scheme_Object *scheme_prefab_struct_key(Scheme_Object *s); #ifdef MZ_USE_PLACES Scheme_Object *scheme_make_serialized_struct_instance(Scheme_Object *s, int num_slots); #endif @@ -1155,6 +1194,10 @@ Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); +#if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) +Scheme_Object *scheme_add_builtin_struct_types(Scheme_Object *accum); +#endif + typedef struct Scheme_Chaperone { Scheme_Inclhash_Object iso; /* 0x1 => impersonator, rather than a checking chaperone */ Scheme_Object *val; /* root object */ @@ -1236,7 +1279,8 @@ /* syntax objects */ /*========================================================================*/ -#define MZ_LABEL_PHASE 30000 +/* The internal variant of a syntax object just has a source location + and other properties. */ typedef struct Scheme_Stx_Srcloc { MZTAG_IF_REQUIRED @@ -1244,40 +1288,13 @@ Scheme_Object *src; } Scheme_Stx_Srcloc; -#define STX_SUBSTX_FLAG 0x1 -#define STX_ARMED_FLAG 0x2 - -typedef struct Scheme_Scope_Set Scheme_Scope_Set; - -typedef struct Scheme_Scope_Table { - Scheme_Object so; /* scheme_scope_table_type or scheme_propagate_table_type */ - Scheme_Scope_Set *simple_scopes; /* scopes that span all phases */ - Scheme_Object *multi_scopes; /* list of (cons multi-scope phase-shift) or fallback chain */ -} Scheme_Scope_Table; - typedef struct Scheme_Stx { - Scheme_Inclhash_Object iso; /* 0x1 and 0x2 of keyex used */ + Scheme_Object so; Scheme_Object *val; Scheme_Stx_Srcloc *srcloc; - Scheme_Scope_Table *scopes; - union { - Scheme_Scope_Table *to_propagate; - Scheme_Object *cache; - } u; - Scheme_Object *shifts; /* or (vector ) */ - Scheme_Object *taints; /* taint or taint-arming */ Scheme_Hash_Tree *props; } Scheme_Stx; -typedef struct Scheme_Stx_Offset { - Scheme_Object so; - intptr_t line, col, pos; - Scheme_Object *src; -} Scheme_Stx_Offset; - -struct Scheme_Marshal_Tables; -struct Scheme_Unmarshal_Tables; - Scheme_Object *scheme_make_stx(Scheme_Object *val, Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree *props); @@ -1286,188 +1303,19 @@ Scheme_Object *src, Scheme_Hash_Tree *props); -Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int cangraph, int copyprops); -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, - struct Scheme_Marshal_Tables *mt); -Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, - struct Scheme_Unmarshal_Tables *ut, - int can_graph); - -Scheme_Object *scheme_stx_track(Scheme_Object *naya, - Scheme_Object *old, - Scheme_Object *origin); - -int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase); - -int scheme_syntax_is_original(Scheme_Object *_stx); -Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx); - -XFORM_NONGCING Scheme_Object *scheme_stx_root_scope(); -Scheme_Object *scheme_new_scope(int kind); -Scheme_Object *scheme_scope_printed_form(Scheme_Object *m); -Scheme_Object *scheme_stx_scope(Scheme_Object *o, Scheme_Object *m, int mode); - -#define SCHEME_STX_MODULE_SCOPE 0 -#define SCHEME_STX_MODULE_MULTI_SCOPE 1 -#define SCHEME_STX_MACRO_SCOPE 2 -#define SCHEME_STX_LOCAL_BIND_SCOPE 3 -#define SCHEME_STX_INTDEF_SCOPE 4 -#define SCHEME_STX_USE_SITE_SCOPE 5 - -#define SCHEME_STX_SCOPE_KIND_SHIFT 3 -#define SCHEME_STX_SCOPE_KIND_MASK ((1 << SCHEME_STX_SCOPE_KIND_SHIFT) - 1) - -#define SCHEME_STX_ADD 0 -#define SCHEME_STX_REMOVE 1 -#define SCHEME_STX_FLIP 2 -#define SCHEME_STX_PUSH 4 -#define SCHEME_STX_MUTATE 16 /* or'ed */ -#define SCHEME_STX_PROPONLY 32 /* or'ed, internal */ -Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode); - -Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc); -Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes); -void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope); -Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); - -Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope); -Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope); -Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *intdef_scope); - -Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); -Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift); -Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *shift); -Scheme_Object *scheme_stx_shift(Scheme_Object *stx, - Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); - -Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); -int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv); - -struct Scheme_Module_Phase_Exports; /* forward declaration */ - -Scheme_Object *scheme_make_module_context(Scheme_Object *insp, - Scheme_Object *shift_or_shifts, - Scheme_Object *name); -Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase); - -Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_remove_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode); -Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc); - -Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc); - -Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src); -Scheme_Object *scheme_stx_to_module_context(Scheme_Object *stx); - -Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc); -Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc); - -void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped); - -XFORM_NONGCING void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context); - -void scheme_extend_module_context(Scheme_Object *mc, Scheme_Object *ctx, Scheme_Object *modidx, - Scheme_Object *locname, Scheme_Object *exname, - Scheme_Object *nominal_src, Scheme_Object *nominal_ex, - intptr_t mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase); -void scheme_extend_module_context_with_shared(Scheme_Object *mc, Scheme_Object *modidx, - struct Scheme_Module_Phase_Exports *pt, - Scheme_Object *prefix, - Scheme_Hash_Tree *excepts, - Scheme_Object *src_phase_index, - Scheme_Object *context, - Scheme_Object *replace_at); - -void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, - Scheme_Object *context, - Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, - Scheme_Object *prefix, - Scheme_Hash_Tree *excepts, - Scheme_Hash_Table *export_registry, - Scheme_Object *insp, Scheme_Object *req_insp, - Scheme_Object *replace_at); - -int scheme_stx_equal_module_context(Scheme_Object *stx, Scheme_Object *mc_as_stx); - -Scheme_Object *scheme_stx_content(Scheme_Object *o); -Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); - -int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase); - -int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase); -int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase); -int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase); -Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); - -void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym); -void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *inspector, - Scheme_Object *sym, Scheme_Object *defn_phase); -void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, - Scheme_Object *inspector, - Scheme_Object *nominal_mod, Scheme_Object *nominal_name, - Scheme_Object *nominal_import_phase, - Scheme_Object *nominal_export_phase, - struct Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table); -void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase); - -Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase); -Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match); -Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase); -Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, - int stop_at_free_eq, - int *_exact_match, int *_ambiguous, - Scheme_Scope_Set **_binding_scopes, - Scheme_Object **insp, /* access-granting inspector */ - Scheme_Object **nominal_modidx, /* how it was imported */ - Scheme_Object **nominal_name, /* imported as name */ - Scheme_Object **src_phase, /* phase level of import from nominal modidx */ - Scheme_Object **nominal_src_phase); /* phase level of export from nominal modidx */ - -int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase); +#define DTS_COPY_PROPS 0x1 +#define DTS_CAN_GRAPH 0x2 +#define DTS_RECUR 0x4 -Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); -Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); +Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, int flags); -Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source); +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx); -char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always); +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_stx_property(Scheme_Object *_stx, Scheme_Object *key, Scheme_Object *val); -Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val, - int preserve); int scheme_stx_list_length(Scheme_Object *list); int scheme_stx_proper_list_length(Scheme_Object *list); @@ -1477,55 +1325,22 @@ #define SCHEME_STX_VAL(s) ((Scheme_Stx *)s)->val #define SCHEME_STX_PAIRP(o) (SCHEME_PAIRP(o) || (SCHEME_STXP(o) && SCHEME_PAIRP(SCHEME_STX_VAL(o)))) -#define SCHEME_STX_SYMBOLP(o) (SCHEME_SYMBOLP(o) || (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o)))) +#define SCHEME_STX_SYMBOLP(o) (SCHEME_SYMBOLP(o) || ((SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))))) #define SCHEME_STX_NULLP(o) (SCHEME_NULLP(o) || (SCHEME_STXP(o) && SCHEME_NULLP(SCHEME_STX_VAL(o)))) -#define SCHEME_STX_CAR(o) (SCHEME_PAIRP(o) ? SCHEME_CAR(o) : SCHEME_CAR(scheme_stx_content(o))) -#define SCHEME_STX_CDR(o) (SCHEME_PAIRP(o) ? SCHEME_CDR(o) : SCHEME_CDR(scheme_stx_content(o))) +#define SCHEME_STX_CAR(o) (SCHEME_PAIRP(o) ? SCHEME_CAR(o) : SCHEME_CAR(SCHEME_STX_VAL(o))) +#define SCHEME_STX_CDR(o) (SCHEME_PAIRP(o) ? SCHEME_CDR(o) : SCHEME_CDR(SCHEME_STX_VAL(o))) +#define SCHEME_STX_CADR(o) (SCHEME_PAIRP(o) ? SCHEME_STX_CAR(SCHEME_CDR(o)) : SCHEME_STX_CAR(SCHEME_CDR(SCHEME_STX_VAL(o)))) #define SCHEME_STX_SYM(o) (SCHEME_STXP(o) ? SCHEME_STX_VAL(o) : o) Scheme_Object *scheme_source_to_name(Scheme_Object *code); #define STX_SRCTAG scheme_source_stx_props -Scheme_Object *scheme_stx_taint(Scheme_Object *o); -Scheme_Object *scheme_stx_taint_arm(Scheme_Object *o, Scheme_Object *insp); -Scheme_Object *scheme_stx_taint_rearm(Scheme_Object *o, Scheme_Object *arm_from); -int scheme_stx_is_tainted(Scheme_Object *id); -int scheme_stx_is_clean(Scheme_Object *id); -int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp); -Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp); - -/* variants that use 'taint-mode and look up inspector: */ -Scheme_Object *scheme_syntax_taint_arm(Scheme_Object *stx, Scheme_Object *insp, int use_mode); -Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *o, Scheme_Object *arm_from); -Scheme_Object *scheme_syntax_taint_disarm(Scheme_Object *o, Scheme_Object *insp); - -Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i); - -struct Resolve_Prefix; -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i); - -Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx); - -Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht); -void scheme_populate_pt_ht(struct Scheme_Module_Phase_Exports * pt); - Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from); int scheme_is_predefined_module_p(Scheme_Object *name); -Scheme_Object *scheme_get_kernel_modidx(void); - -Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, struct Scheme_Marshal_Tables *mt); -void scheme_iterate_reachable_scopes(struct Scheme_Marshal_Tables *mt); - -void scheme_stx_debug_print(Scheme_Object *stx, Scheme_Object *phase, int level); - -Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, struct Scheme_Comp_Env *env); - -Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv); - /*========================================================================*/ /* syntax run-time structures */ /*========================================================================*/ @@ -1594,6 +1409,11 @@ /* `mode` determines which union is active: */ union { struct { + /* To detect uses on right-hand sides in `letrec` */ + int *use_box; + int use_position; + } compile; + struct { /* Maps the variable into the letrec-check pass's frames: */ struct Letrec_Check_Frame *frame; int frame_pos; @@ -1643,6 +1463,30 @@ #define SCHEME_VAR_MODE_OPTIMIZE 3 #define SCHEME_VAR_MODE_RESOLVE 4 +/* Definition and references share the same object during the + "compile" pass, and SCHEME_IR_TOPLEVEL_MUTATED is set in that pass. + During the "optimize" pass, references may be cloned to set + SCHEME_TOPLEVEL_CONST, etc. */ +typedef struct Scheme_IR_Toplevel +{ + Scheme_Inclhash_Object iso; /* scheme_import_export_variable_type; not hashable */ + int instance_pos; /* import instance position, or -1 for exported and internal */ + int variable_pos; /* position within import instance or definition sequence */ +} Scheme_IR_Toplevel; + +/* See also SCHEME_TOPLEVEL_... */ +#define SCHEME_IR_TOPLEVEL_MUTATED 0x4 + +#define SCHEME_IR_TOPLEVEL_FLAGS(var) MZ_OPT_HASH_KEY(&(var)->iso) +#define SCHEME_IR_TOPLEVEL_INSTANCE(var) (((Scheme_IR_Toplevel *)var)->instance_pos) +#define SCHEME_IR_TOPLEVEL_POS(var) (((Scheme_IR_Toplevel *)var)->variable_pos) + +/* Number of runstack slots before imports: */ +#define SCHEME_LINKLET_PREFIX_PREFIX 1 + +Scheme_IR_Toplevel *scheme_make_ir_toplevel(int instance_pos, int variable_pos, int flags); +Scheme_Object *scheme_ir_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); + typedef struct { Scheme_Inclhash_Object iso; /* keyex used for flags */ mzshort num_args; /* doesn't include rator, so arguments are at args[1]...args[num_args] */ @@ -1703,15 +1547,6 @@ Scheme_Object *fbranch; } Scheme_Branch_Rec; -typedef struct { - Scheme_Inclhash_Object iso; /* keyex used to disable module table */ - mzshort max_let_depth; - Scheme_Object *code; - struct Resolve_Prefix *prefix; /* NULL => a wrapper for a JITted module in `code' */ - Scheme_Object *binding_namess; /* list of to hash of to ; - additions to the top-level bindings table */ -} Scheme_Compilation_Top; - /* A `let' or `letrec' form is compiled to the intermediate format (used during the optimization pass) as a Scheme_IR_Let_Header with a chain of Scheme_IR_Let_Value records as its body, @@ -1774,11 +1609,15 @@ typedef struct Scheme_Toplevel { Scheme_Inclhash_Object iso; /* keyex used for flags (and can't be hashed) */ - mzshort depth; + union { + mzshort depth; /* normal mode */ + struct Scheme_Prefix *prefix; /* for a linklet that is only instantiated once */ + } u; int position; } Scheme_Toplevel; -#define SCHEME_TOPLEVEL_DEPTH(obj) (((Scheme_Toplevel *)(obj))->depth) +#define SCHEME_TOPLEVEL_DEPTH(obj) (((Scheme_Toplevel *)(obj))->u.depth) +#define SCHEME_STATIC_TOPLEVEL_PREFIX(obj) (((Scheme_Toplevel *)(obj))->u.prefix) #define SCHEME_TOPLEVEL_POS(obj) (((Scheme_Toplevel *)(obj))->position) #define SCHEME_TOPLEVEL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Toplevel *)(obj))->iso) @@ -1786,6 +1625,7 @@ FIXED, READY, or UNKNOWN) or one of the two levels for a definition (SEAL or not) */ #define SCHEME_TOPLEVEL_FLAGS_MASK 0x3 +#define SCHEME_LOG_TOPLEVEL_FLAG_MASK 2 /* CONST means that a toplevel is READY and always has the "same" value, even for different instantiations or phases. "Same" means that the result @@ -1925,22 +1765,8 @@ void scheme_flush_stack_copy_cache(void); #endif -typedef struct Scheme_Dynamic_State { - struct Scheme_Comp_Env * volatile current_local_env; - Scheme_Object * volatile scope; - Scheme_Object * volatile use_scope; - Scheme_Object * volatile name; - Scheme_Object * volatile modidx; - Scheme_Env * volatile menv; -} Scheme_Dynamic_State; - -void scheme_set_dynamic_state(Scheme_Dynamic_State *state, struct Scheme_Comp_Env *env, - Scheme_Object *scope, Scheme_Object *use_scope, - Scheme_Object *name, - Scheme_Env *menv, - Scheme_Object *modidx); void *scheme_top_level_do(void *(*k)(void), int eb); -void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread, Scheme_Dynamic_State *dyn_state); +void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread); Scheme_Object *scheme_call_ec(int argc, Scheme_Object *argv[]); @@ -2183,9 +2009,6 @@ void scheme_about_to_move_C_stack(void); -Scheme_Object *scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); -Scheme_Object *scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); - Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack, int can_ec); @@ -2194,6 +2017,8 @@ XFORM_NONGCING Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); +void scheme_clear_prompt_cache(void); + /*========================================================================*/ /* semaphores and locks */ /*========================================================================*/ @@ -2603,9 +2428,7 @@ int radix, int radix_set, Scheme_Object *port, int *div_by_zero, - int test_only, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation); + int test_only); Scheme_Object *scheme_bin_gcd(const Scheme_Object *n1, const Scheme_Object *n2); Scheme_Object *scheme_bin_quotient(const Scheme_Object *n1, const Scheme_Object *n2); @@ -2724,7 +2547,7 @@ typedef struct Scheme_Prefix { Scheme_Inclhash_Object iso; /* scheme_prefix_type; 0x1 => incremental-mode fixup chain */ - int num_slots, num_toplevels, num_stxes; + int num_slots, saw_num_slots; #ifdef MZ_PRECISE_GC struct Scheme_Prefix *next_final; /* for special GC handling */ struct Scheme_Object *fixup_chain; /* for special GC handling */ @@ -2741,6 +2564,9 @@ #define PREFIX_TO_USE_BITS(pf) \ (int *)((char *)pf + sizeof(Scheme_Prefix) + ((pf->num_slots - mzFLEX_DELTA) * sizeof(Scheme_Object *))) +Scheme_Prefix *scheme_allocate_prefix(intptr_t n); +Scheme_Prefix *scheme_allocate_linklet_prefix(Scheme_Linklet *linklet, int extra); + #define LOAD_ON_DEMAND void scheme_clear_delayed_load_cache(); @@ -2752,16 +2578,18 @@ Scheme_Object *scheme_eval_linked_expr(Scheme_Object *expr); Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *expr); -Scheme_Object *scheme_eval_linked_expr_multi_with_dynamic_state(Scheme_Object *obj, Scheme_Dynamic_State *dyn_state); Scheme_Object *_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands); -Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, - int recur, int expose_comment, int pre_char, Scheme_Object *readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, +Scheme_Object *scheme_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt); + +Scheme_Object *scheme_internal_read(Scheme_Object *port, int crc, int cantfail, + int pre_char, Scheme_Object *delay_load_info); void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port); void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port); @@ -2769,6 +2597,8 @@ Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok); +Scheme_Object *scheme_read_compiled(Scheme_Object *port); + #define _scheme_eval_linked_expr(obj) scheme_do_eval(obj,-1,NULL,1) #define _scheme_eval_linked_expr_multi(obj) scheme_do_eval(obj,-1,NULL,-1) #define _scheme_eval_linked_expr_wp(obj, p) scheme_do_eval_w_thread(obj,-1,NULL,1,p) @@ -2782,8 +2612,6 @@ #define _scheme_make_char(ch) scheme_make_character(ch) -Scheme_Object *scheme_default_eval_handler(int, Scheme_Object *[]); -Scheme_Object *scheme_default_compile_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_print_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_prompt_read_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_read_input_port_handler(int argc, Scheme_Object *[]); @@ -2792,10 +2620,6 @@ extern Scheme_Object *scheme_eof_object_p_proc; extern Scheme_Object *scheme_default_global_print_handler; -/* Type readers & writers for compiled code data */ -void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f); -void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f); - Scheme_Object *scheme_make_default_readtable(void); Scheme_Object *scheme_read_intern(Scheme_Object *o); @@ -2825,65 +2649,25 @@ /* compile and link */ /*========================================================================*/ -typedef struct Comp_Prefix -{ - MZTAG_IF_REQUIRED - int num_toplevels, num_stxes, non_phaseless; - Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */ - Scheme_Hash_Table *inline_variants; /* position -> inline_variant */ - Scheme_Object *unbound; /* identifiers (and lists of phase-1 shifted unbounds) that were unbound at compile */ - Scheme_Hash_Table *stxes; /* syntax objects */ -} Comp_Prefix; - -typedef Scheme_Object *(*Scheme_Expand_Result_Adjust_Proc)(Scheme_Object *stx, Scheme_Object *arg); - typedef struct Scheme_Comp_Env { MZTAG_IF_REQUIRED - short flags; /* used for expanding/compiling */ - Scheme_Env *genv; /* top-level environment */ - Scheme_Object *insp; /* code inspector for checking protected */ - Comp_Prefix *prefix; /* stack base info: globals and stxes */ - - Scheme_Object *scopes; /* can be NULL, a scope, a scope set, or (cons scope-set nobind-scope) */ - + int flags; + Scheme_Hash_Tree *vars; /* symbol -> Scheme_IR_Local */ Scheme_Object *value_name; /* propagated down */ - Scheme_Object *observer; /* parameter's value (to avoid looking up every time) */ - - /* local bindings; */ - mzshort num_bindings; /* number of `values' slots */ - Scheme_Object **binders; /* identifiers */ - Scheme_Object **bindings; /* symbols */ - Scheme_Object **vals; /* compile-time values */ - Scheme_Object **shadower_deltas; - Scheme_IR_Local **vars; - int *use; - int max_use, any_use; - - Scheme_Object *lifts; - - Scheme_Hash_Table *binding_namess; /* -> ( -> ); additions to the environment's - bindings table made during a particular compilation */ - - mzshort rename_var_count; /* number of non-NULL `values' when `renames' was computed */ - mzshort rename_rstart; /* leftover rstart from previous round; see env.c */ - Scheme_Hash_Table *dup_check; /* table for finding colliding symbols in `values' */ - - Scheme_Object *intdef_name; /* syntax-local-context name for INTDEF frames */ - - Scheme_Object *in_modidx; /* during lookup/expand in macro */ - - Scheme_Hash_Tree *skip_table; /* for jumping ahead in the chain */ - int skip_depth; /* depth in simple frames, used to trigger skip_table creation */ - - Scheme_Expand_Result_Adjust_Proc expand_result_adjust; - Scheme_Object *expand_result_adjust_arg; - - struct Scheme_Comp_Env *next; - struct Scheme_Comp_Env *use_scopes_next; /* fast-forward for use-site scope revert */ - struct Scheme_Comp_Env *intdef_next; /* when `next` = NULL, can be non-null to continue binding search */ + Scheme_Linklet *linklet; } Scheme_Comp_Env; +#define COMP_ENV_CHECKING_CONSTANT 0x1 +#define COMP_ENV_DONT_COUNT_AS_USE 0x2 +#define COMP_ENV_ALLOW_SET_UNDEFINED 0x4 + +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Linklet *linklet, int flags); +Scheme_Comp_Env *scheme_extend_comp_env(Scheme_Comp_Env *env, Scheme_Object *id, Scheme_Object *var, + int mutate, int check_dups); +Scheme_Comp_Env *scheme_set_comp_env_flags(Scheme_Comp_Env *env, int flags); +Scheme_Comp_Env *scheme_set_comp_env_name(Scheme_Comp_Env *env, Scheme_Object *name); + #define LAMBDA_HAS_REST 1 #define LAMBDA_HAS_TYPED_ARGS 2 #define LAMBDA_PRESERVES_MARKS 4 @@ -2895,40 +2679,11 @@ #define LAMBDA_SFS 256 /* BITS 8-15 (overlaps LAMBDA_SFS) used by write_lambda() */ -typedef struct Scheme_Compile_Expand_Info -{ - /* allocated as atomic */ - short comp; - short comp_flags; - char dont_mark_local_use; - char resolve_module_ids; - char pre_unwrapped; - char testing_constantness; - char substitute_bindings; - int depth; - int env_already; -} Scheme_Compile_Expand_Info; - -#define COMP_ALLOW_SET_UNDEFINED 0x1 -#define COMP_CAN_INLINE 0x2 -#define COMP_ENFORCE_CONSTS 0x4 - -typedef Scheme_Compile_Expand_Info Scheme_Compile_Info; -typedef Scheme_Compile_Expand_Info Scheme_Expand_Info; - -typedef struct Resolve_Prefix -{ - Scheme_Object so; - int num_toplevels, num_stxes, num_lifts; - Scheme_Object **toplevels; - Scheme_Object **stxes; /* simplified */ - Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */ - /* An inspector or symbol to identify bindings that are created as - part of the module's expansion, so that a suitable inspector can - be associated with those bindings (through a syntax-object - "shift") when the code is re-loaded. */ - Scheme_Object *src_insp_desc; -} Resolve_Prefix; +#define COMP_ALLOW_SET_UNDEFINED 0x1 +#define COMP_CAN_INLINE 0x2 +#define COMP_ENFORCE_CONSTS 0x4 +#define COMP_TESTING_CONSTANTNESS 0x8 +#define RESOLVE_MODULE_IDS 0x10 typedef struct Resolve_Info Resolve_Info; @@ -2951,14 +2706,6 @@ typedef struct Optimize_Info Optimize_Info; -typedef struct Scheme_Object * -(Scheme_Syntax)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -typedef struct Scheme_Object * -(Scheme_Syntax_Expander)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, - Scheme_Expand_Info *rec, int drec); - typedef struct CPort Mz_CPort; typedef struct Scheme_Lambda @@ -3114,15 +2861,7 @@ int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation *captured, Scheme_Cont_Frame_Data *d); -#define scheme_new_frame(n) scheme_new_special_frame(n, 0) -#define scheme_extend_env(f, e) (f->basic.next = e, f) -#define scheme_next_frame(e) ((e)->basic.next) -#define scheme_settable_frame(f, s) ((f)->basic.has_set_bang = (s)) -#define scheme_get_frame_settable(f) ((f)->basic.has_set_bang) -#define scheme_get_binding(f, n) ((f)->values[n]) - -int scheme_is_module_begin_env(Scheme_Comp_Env *env); -Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags); +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int flags); #define MAX_CONST_LOCAL_POS 64 #define MAX_CONST_LOCAL_TYPES 2 @@ -3133,63 +2872,19 @@ #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); +Scheme_IR_Local *scheme_make_ir_local(Scheme_Object *id); Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, Scheme_Object **_id, int *_use_map); -Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated); -Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos, - int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env); - -void scheme_check_identifier(const char *formname, Scheme_Object *id, - const char *where, - Scheme_Comp_Env *env, - Scheme_Object *form); -Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, - Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *erec, int drec, - Scheme_Object **current_val, - int keep_name); - -Scheme_Object *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, - Scheme_Object *f, Scheme_Object *code, - Scheme_Comp_Env *env, Scheme_Object *boundname, - Scheme_Compile_Expand_Info *rec, int drec, - int for_set, - int scope_macro_use); - -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, - Scheme_Object *scope, - Scheme_Comp_Env *env); -void scheme_add_compilation_binding(int index, Scheme_Object *val, - Scheme_Comp_Env *frame); -void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *frame, - Scheme_Object *use_site_scope); -void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *frame, - Scheme_Object *intdef_scope); -Scheme_Comp_Env *scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, - Scheme_Comp_Env *env, int flags); - -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env); - -Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags, - Scheme_Object *in_modidx, - Scheme_Env **_menv, int *_protected, - Scheme_Object **_local_binder, int *_need_macro_scope, - Scheme_Object **_inline_variant); + +/* Flags used with scheme_compile_lookup */ +#define SCHEME_APP_POS 2 +#define SCHEME_SETTING 4 +#define SCHEME_NULL_FOR_UNBOUND 512 +#define SCHEME_REFERENCING 4096 + +Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags); int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env); Scheme_Object *scheme_extract_unsafe(Scheme_Object *o); @@ -3198,36 +2893,6 @@ Scheme_Object *scheme_extract_futures(Scheme_Object *o); Scheme_Object *scheme_extract_foreign(Scheme_Object *o); -typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *); -void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, - Scheme_Object *end_stmts, Scheme_Object *context_key, - Scheme_Object *require_lifts, Scheme_Object *provide_lifts, - Scheme_Object *module_lifts); -void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_end_modules(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_generate_lifts_key(void); -Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env); - -Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, - intptr_t phase, - Scheme_Comp_Env *cenv, - Scheme_Object *scope); -Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, - intptr_t phase, - Scheme_Object *scope, - void *data, - Scheme_Object **_ref_expr, - struct Scheme_Comp_Env *cenv); - -void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); -void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env, int replace_value); - Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type); Scheme_Object *scheme_make_closure(Scheme_Thread *p, @@ -3245,48 +2910,13 @@ void scheme_delay_load_closure(Scheme_Lambda *data); -Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef); - -#define scheme_add_good_binding(i,v,f) (f->values[i] = v) - Scheme_Object *scheme_compiled_void(void); -int scheme_check_top_identifier_bound(Scheme_Object *symbol, Scheme_Env *genv, int disallow_unbound); - -Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int imported, Scheme_Object *inline_variant); -Scheme_Object *scheme_register_toplevel_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp, - int imported, Scheme_Object *inline_variant); -void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id); -Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp); -void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - Scheme_Env *menv); void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env); -void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, - Scheme_Env *exp_env, Scheme_Object *insp, - Scheme_Compile_Expand_Info *rec, int drec, Scheme_Object *observer, - Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib, int replace_value); -int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); - typedef struct SFS_Info SFS_Info; -SFS_Info *scheme_new_sfs_info(int depth); -Scheme_Object *scheme_sfs(Scheme_Object *expr, SFS_Info *info, int max_let_depth); -Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *si, int self_pos); - -void scheme_sfs_used(SFS_Info *info, int pos); -void scheme_sfs_push(SFS_Info *info, int count, int track); -void scheme_sfs_start_sequence(SFS_Info *si, int cnt, int last_is_tail); - -Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre); - -typedef struct Scheme_Object *(*Scheme_Syntax_SFSer)(Scheme_Object *data, SFS_Info *info); +Scheme_Linklet *scheme_sfs_linklet(Scheme_Linklet *linklet); typedef struct Scheme_Set_Bang { Scheme_Object so; @@ -3296,9 +2926,11 @@ Scheme_Object *scheme_protect_quote(Scheme_Object *expr); -Scheme_Object *scheme_letrec_check_expr(Scheme_Object *); +Scheme_Linklet *scheme_letrec_check_linklet(Scheme_Linklet *linklet); -Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context); +Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode, + Scheme_Object **_import_keys, Scheme_Object *get_import); /* Context uses result as a boolean: */ #define OPT_CONTEXT_BOOLEAN 0x1 @@ -3321,12 +2953,15 @@ Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e); Scheme_Object *scheme_optimize_extract_tail_inside(Scheme_Object *t2); -Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *); -Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *); +Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *, int enforce_const, int static_mode); Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, - Scheme_Object *from_modidx, Scheme_Object *to_modidx); -Scheme_Object *scheme_unresolve_top(Scheme_Object *, Comp_Prefix **, int comp_flags); + Scheme_Linklet *linklet, Scheme_Object *linklet_key, + Optimize_Info *opt_info); +Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *, int comp_flags); + +/* Callbacks from unresolver to optimizer: */ +Scheme_Object *scheme_optimize_add_import_variable(Optimize_Info *info, Scheme_Object *linklet_key, Scheme_Object *symbol); +Scheme_Object *scheme_optimize_get_import_key(Optimize_Info *info, Scheme_Object *linklet_key, int instance_pos); int scheme_check_leaf_rator(Scheme_Object *le); @@ -3334,22 +2969,6 @@ Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info); -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc); -Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri); - -Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp); -void scheme_resolve_info_enforce_const(Resolve_Info *, int enforce_const); -int scheme_resolve_info_max_let_depth(Resolve_Info *ri); -int scheme_resolve_info_use_jit(Resolve_Info *ri); - -void scheme_enable_expression_resolve_lifts(Resolve_Info *ri); -Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri); - -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger); -void scheme_optimize_info_enforce_const(Optimize_Info *, int enforce_const); -void scheme_optimize_info_set_context(Optimize_Info *, Scheme_Object *ctx); -void scheme_optimize_info_never_inline(Optimize_Info *); - char *scheme_optimize_info_context(Optimize_Info *); Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *); @@ -3357,36 +2976,8 @@ int scheme_expr_produces_local_type(Scheme_Object *expr, int *_involves_k_cross); -Scheme_Object *scheme_make_primitive_syntax(Scheme_Syntax *syntax, - Scheme_Syntax_Expander *exp); - -Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -Scheme_Object *scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, - Scheme_Comp_Env *env); -Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, - Scheme_Object *orig_form, int comp_rev); - -void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env); - -void scheme_default_compile_rec(Scheme_Compile_Info *src, int drec); -void scheme_compile_rec_done_local(Scheme_Compile_Info *src, int drec); -void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n); -void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n); -void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec); -void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec); - - -void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, - Scheme_Expand_Info *dest, int n); +Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name); +Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys); Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list, int strip_values, @@ -3397,7 +2988,7 @@ Scheme_Sequence *scheme_malloc_sequence(int count); -Scheme_Object *scheme_jit_expr(Scheme_Object *); +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *, int step); Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Object *context); void scheme_jit_fill_threadlocal_table(); @@ -3408,76 +2999,20 @@ struct Start_Module_Args; #ifdef MZ_USE_JIT -void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); -void *scheme_module_exprun_start(Scheme_Env *menv, int phase_plus_set_ns, Scheme_Object *name); -void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); -#endif -void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); -void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns); -void *scheme_module_start_finish(struct Start_Module_Args *a); +Scheme_Object *scheme_linklet_run_start(Scheme_Linklet* linklet, Scheme_Instance *instance, Scheme_Object *name); +#endif +Scheme_Object *scheme_linklet_run_finish(Scheme_Linklet* linklet, Scheme_Instance *instance, int use_prompt); Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *env); -#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj) -#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj) - -int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame); -int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos); -void scheme_mark_all_use(Scheme_Comp_Env *frame); -void scheme_env_make_variables(Scheme_Comp_Env *frame); -void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_IR_Local **vars, - int pos, int count); - /* flags reported by scheme_resolve_info_flags */ #define SCHEME_INFO_BOXED 0x1 #define SCHEME_INFO_TYPED_VAL_SHIFT 4 #define SCHEME_INFO_TYPED_VAL_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_INFO_TYPED_VAL_SHIFT) -/* flags used with scheme_new_frame */ -#define SCHEME_TOPLEVEL_FRAME (1 << 0) -#define SCHEME_MODULE_FRAME (1 << 1) -#define SCHEME_MODULE_BEGIN_FRAME (1 << 2) -#define SCHEME_LAMBDA_FRAME (1 << 3) -#define SCHEME_INTDEF_FRAME (1 << 4) -#define SCHEME_USE_SCOPES_TO_NEXT (1 << 5) -#define SCHEME_CAPTURE_WITHOUT_RENAME (1 << 6) -#define SCHEME_FOR_STOPS (1 << 7) -#define SCHEME_FOR_INTDEF (1 << 8) -#define SCHEME_CAPTURE_LIFTED (1 << 9) -#define SCHEME_INTDEF_SHADOW (1 << 10) -#define SCHEME_POST_BIND_FRAME (1 << 11) -#define SCHEME_NESTED_MODULE_FRAME (1 << 12) -#define SCHEME_KEEP_SCOPES_FRAME (1 << 13) -#define SCHEME_TMP_TL_BIND_FRAME (1 << 14) - -#define SCHEME_REC_BINDING_FRAME (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_BEGIN_FRAME \ - | SCHEME_INTDEF_FRAME | SCHEME_FOR_INTDEF) - -/* Flags used with scheme_static_distance */ -#define SCHEME_ELIM_CONST 1 -#define SCHEME_APP_POS 2 -#define SCHEME_SETTING 4 -#define SCHEME_ENV_CONSTANTS_OK 8 -#define SCHEME_GLOB_ALWAYS_REFERENCE 16 -#define SCHEME_MUST_INDRECT 32 -#define SCHEME_LINKING_REF 64 -#define SCHEME_DONT_MARK_USE 128 -#define SCHEME_OUT_OF_CONTEXT_OK 256 -#define SCHEME_NULL_FOR_UNBOUND 512 -#define SCHEME_RESOLVE_MODIDS 1024 -#define SCHEME_NO_CERT_CHECKS 2048 -#define SCHEME_REFERENCING 4096 -#define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 -#define SCHEME_STOP_AT_FREE_EQ 16384 - Scheme_Hash_Table *scheme_map_constants_to_globals(void); const char *scheme_look_for_primitive(void *code); -Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -Scheme_Object *scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); - Scheme_Object *scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto); Scheme_Object *scheme_make_svector(mzshort v, mzshort *a); @@ -3491,18 +3026,10 @@ Scheme_Object *tbranch, Scheme_Object *fbranch); -int scheme_is_toplevel(Scheme_Comp_Env *env); -int scheme_is_nested_module(Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env); - Scheme_Env *scheme_make_empty_env(void); void scheme_prepare_exp_env(Scheme_Env *env); void scheme_prepare_template_env(Scheme_Env *env); void scheme_prepare_label_env(Scheme_Env *env); -void scheme_prepare_env_stx_context(Scheme_Env *env); - -XFORM_NONGCING Scheme_Object *scheme_env_phase(Scheme_Env *env); -Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, Optimize_Info *opt_info, Optimize_Info *warn_info); @@ -3524,27 +3051,27 @@ int normal_ops; /* are selectors and predicates in the usual order? */ int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */ int authentic; /* conservatively 0 is ok */ + int nonfail_constructor; int num_gets, num_sets; + int setter_fields; /* if indexed, bitmap for first 32 fields to indicate which have setters */ } Simple_Struct_Type_Info; Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags, int *_auto_e_depth, Simple_Struct_Type_Info *_stinfo, Scheme_Object **_parent_identity, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, Scheme_Object **_name, int fuel); int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int flags, int *_has_guard, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int fuel); #define CHECK_STRUCT_TYPE_RESOLVED 0x1 #define CHECK_STRUCT_TYPE_ALWAYS_SUCCEED 0x2 @@ -3560,8 +3087,9 @@ #define STRUCT_PROC_SHAPE_SETTER 4 #define STRUCT_PROC_SHAPE_OTHER 5 #define STRUCT_PROC_SHAPE_MASK 0xF -#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10 -#define STRUCT_PROC_SHAPE_SHIFT 5 +#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10 +#define STRUCT_PROC_SHAPE_NONFAIL_CONSTR 0x20 +#define STRUCT_PROC_SHAPE_SHIFT 6 typedef struct Scheme_Struct_Proc_Shape { Scheme_Object so; @@ -3580,10 +3108,10 @@ #define STRUCT_PROP_PROC_SHAPE_GETTER 3 #define SCHEME_PROP_PROC_SHAPE_MODE(obj) ((Scheme_Small_Object *)obj)->u.int_val -Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected); -int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise); +intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); -int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); +intptr_t scheme_get_or_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); int scheme_decode_struct_prop_shape(Scheme_Object *shape, intptr_t *_v); int scheme_closure_preserves_marks(Scheme_Object *p); int scheme_native_closure_preserves_marks(Scheme_Object *p); @@ -3595,48 +3123,18 @@ Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info); int scheme_is_foldable_prim(Scheme_Object *f); -Scheme_Object *scheme_get_stop_expander(void); - void scheme_define_parse(Scheme_Object *form, Scheme_Object **vars, Scheme_Object **val, - int defmacro, - Scheme_Comp_Env *env, - int no_toplevel_check); - -void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var); -void scheme_binding_names_from_module(Scheme_Env *menv); -void scheme_install_binding_names(Scheme_Object *binding_namess, Scheme_Env *env); -Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env); - -int scheme_prefix_depth(Resolve_Prefix *rp); -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, - Scheme_Object *src_modix, Scheme_Object *now_modix, - int src_phase, int now_phase, - Scheme_Env *dummy_env, Scheme_Object *insp); -void scheme_pop_prefix(Scheme_Object **rs); -Scheme_Object *scheme_suspend_prefix(Scheme_Object **rs); -Scheme_Object **scheme_resume_prefix(Scheme_Object *v); - -Scheme_Object *scheme_eval_clone(Scheme_Object *expr); -Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp); -Scheme_Object *scheme_module_eval_clone(Scheme_Object *data); -Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *form); - -Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env); -Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy); - -void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, - int depth, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object **toplevels, - int code_vec); + Scheme_Comp_Env *env); + +void scheme_validate_linklet(Mz_CPort *port, Scheme_Linklet *linklet); typedef mzshort **Validate_TLS; struct Validate_Clearing; void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, char *closure_stack, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int self_pos_in_closure, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht); @@ -3650,8 +3148,6 @@ # define scheme_ill_formed_code(port) scheme_ill_formed(port) #endif -Scheme_Object *scheme_check_name_property(Scheme_Object *stx, Scheme_Object *current_name); - Scheme_Object *scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env); typedef struct Scheme_Marshal_Tables { @@ -3660,62 +3156,47 @@ Scheme_Hash_Table *symtab; Scheme_Hash_Table *st_refs; Scheme_Object *st_ref_stack; - Scheme_Hash_Table *reachable_scopes; /* filled on -1 pass */ - Scheme_Object *reachable_scope_stack; /* used on -1 pass */ - Scheme_Hash_Table *pending_reachable_ids; /* use on -1 pass */ - Scheme_Hash_Table *conditionally_reachable_scopes; /* filled/used on -1 pass */ Scheme_Hash_Table *intern_map; /* filled on first pass */ - Scheme_Hash_Table *identity_map; /* filled on first pass */ - Scheme_Hash_Table *top_map; /* used on every pass */ Scheme_Hash_Table *key_map; /* set after first pass, used on later passes */ Scheme_Hash_Table *delay_map; /* set during first pass, used on later passes */ - Scheme_Hash_Table *rn_saved; /* maps each original object to generated marshaling */ Scheme_Object **cdata_map; /* for delay-load wrappers */ int cdata_counter; /* used with cdata_map */ intptr_t *shared_offsets; /* set in second pass */ Scheme_Hash_Table *path_cache; /* cache for path-to-relative resolution */ intptr_t sorted_keys_count; - intptr_t inspector_counter; /* for deterministic symbol allocation */ Scheme_Object **sorted_keys; } Scheme_Marshal_Tables; -void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *key); -Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *a); -Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *a, Scheme_Object *v); -void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt); -void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep); - typedef struct Scheme_Unmarshal_Tables { MZTAG_IF_REQUIRED - Scheme_Hash_Table *rns; - Scheme_Hash_Table *current_rns; /* in-progress unmarshal, commit to `rns` at end */ - Scheme_Hash_Table *multi_scope_pairs; /* records conversions */ - Scheme_Hash_Table *current_multi_scope_pairs; /* commit to `multi_scope_pairs` at end */ struct CPort *rp; char *decoded; mzlonglong bytecode_hash; } Scheme_Unmarshal_Tables; -Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut, - Scheme_Object *wraps_key, - int *_decoded); -void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, - Scheme_Object *wraps_key, - Scheme_Object *v); -Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); +typedef struct Scheme_Load_Delay { + MZTAG_IF_REQUIRED + Scheme_Object *path; + intptr_t file_offset, size; + uintptr_t symtab_size; + Scheme_Object **symtab; + intptr_t *shared_offsets; + Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ + Scheme_Object *relto; + Scheme_Unmarshal_Tables *ut; + struct CPort *current_rp; + int perma_cache; + unsigned char *cached; + Scheme_Object *cached_port; + struct Scheme_Load_Delay *clear_bytes_prev; + struct Scheme_Load_Delay *clear_bytes_next; + int unsafe_ok; + mzlonglong bytecode_hash; +} Scheme_Load_Delay; -int scheme_is_rename_transformer(Scheme_Object *o); -int scheme_is_binding_rename_transformer(Scheme_Object *o); -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *env); -int scheme_is_set_transformer(Scheme_Object *o); -Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); - -int scheme_is_expansion_context_symbol(Scheme_Object *v); -int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx); -Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags); +Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); -Scheme_Object *scheme_top_level_require_execute(Scheme_Object *data); Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr); Scheme_Object *scheme_module_jit(Scheme_Object *data); @@ -3723,344 +3204,140 @@ Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr); /*========================================================================*/ -/* namespaces and modules */ +/* linklet instance and environment */ /*========================================================================*/ -typedef struct Scheme_Module_Registry { - Scheme_Object so; /* scheme_module_registry_type */ - Scheme_Hash_Table *loaded; /* symbol -> module ; loaded modules, - shared with modules in same space */ - Scheme_Hash_Table *exports; /* symbol -> module-exports */ -} Scheme_Module_Registry; - +/* A Scheme_Env acts as a wrapper for namespaces, which are externally + implemented (via `scheme_startup_instance`). */ struct Scheme_Env { - Scheme_Object so; /* scheme_namespace_type */ - - signed char disallow_unbound, rename_set_ready; + Scheme_Object so; /* scheme_env_type */ + Scheme_Object *namespace; + Scheme_Instance *instance; + /* Used for setting up "extensions" */ + int cross_phase; + Scheme_Hash_Tree *protected; +}; - struct Scheme_Module *module; /* NULL => top-level */ +/* A Scheme_Startup_Env holds tables of primitives */ +struct Scheme_Startup_Env { + Scheme_Object so; /* scheme_startup_env_type */ + Scheme_Hash_Table *current_table; /* used during startup */ + Scheme_Hash_Table *primitive_tables; /* symbol -> hash table */ + Scheme_Hash_Table *all_primitives_table; + Scheme_Hash_Table *primitive_ids_table; /* value -> integer */ +}; - Scheme_Module_Registry *module_registry; - Scheme_Module_Registry *module_pre_registry; /* for expanding submodules */ - Scheme_Object *guard_insp; /* instantiation-time inspector, for granting - protected access */ - Scheme_Object *access_insp; /* for gaining protected access */ - - Scheme_Object *stx_context; /* encapsulates scopes, shifts, etc. */ - Scheme_Object *tmp_bind_scope; /* for compiling top-level definitions */ - - Scheme_Bucket_Table *syntax; - struct Scheme_Env *exp_env; - struct Scheme_Env *template_env; - struct Scheme_Env *label_env; - struct Scheme_Env *instance_env; /* shortcut to env where module is instantiated */ - struct Scheme_Env *reader_env; /* namespace to use for #reader or #lang */ - - Scheme_Hash_Table *shadowed_syntax; /* top level only */ - - Scheme_Object *lift_key; /* for `syntax-local-lift-context' */ - - /* Per-instance: */ - intptr_t phase, mod_phase; - Scheme_Object *link_midx; - Scheme_Object *require_names, *et_require_names, *tt_require_names, *dt_require_names; /* resolved */ - Scheme_Hash_Table *other_require_names; - char *running; /* array of size `num_phases' if `module' and `mod_phase==0' */ - char attached, ran; - Scheme_Object *did_starts; - Scheme_Object *available_next[2]; - - Scheme_Bucket_Table *toplevel; - Scheme_Object *modchain; /* Vector of: - 1. symbol -> env ; running modules, - shared with instances in same phase - 2. modchain for next phase (or #f) - 3. modchain for previous phase (or #f) */ +extern Scheme_Startup_Env * scheme_startup_env; - Scheme_Hash_Table *modvars; /* for scheme_module_variable_type hashing */ +/* A Scheme_Instance is a linklet instance */ +struct Scheme_Instance { + Scheme_Inclhash_Object iso; /* 0x1 => inline only imprecise info into clients */ + union { + Scheme_Bucket **a; /* for a small, predefined number of keys */ + Scheme_Bucket_Table *bt; /* general case */ + } variables; + int array_size; /* 0 => hash mode */ + Scheme_Object *weak_self_link; /* for Scheme_Bucket_With_Home */ - /* The `binding_names` table can be an immutable or mutable hash table: */ - Scheme_Object *binding_names; /* maps symbols to identifiers */ - short binding_names_need_shift; /* => binding names are from module, and need a shift */ - short interactive_bindings; /* => module namespace is interactive and shadowing is needed */ - - int id_counter; + Scheme_Hash_Tree *source_names; /* bucket symbol -> source symbol; initially copied from linklet */ + + Scheme_Object *name; /* for reporting purposes */ + Scheme_Object *data; }; -/* A module access path (or "idx") is a pair: sexp * symbol-or-#f - The symbol is the resolved module name, or #f if it's not - yet resolved. */ +#define SCHEME_INSTANCE_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) +#define SCHEME_INSTANCE_USE_IMPRECISE 0x1 -/* A Scheme_Module corresponds to a module declaration. A module - instantiation is reprsented by a Scheme_Env */ - -typedef struct Scheme_Module_Export_Info { - MZTAG_IF_REQUIRED - char *provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **indirect_provides; /* symbols (internal names) */ - int num_indirect_provides; - - /* Only if needed to reconstruct the renaming: */ - Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ - int num_indirect_syntax_provides; +Scheme_Instance *scheme_make_instance(Scheme_Object *name, Scheme_Object *data); +Scheme_Bucket *scheme_instance_variable_bucket(Scheme_Object *symbol, Scheme_Instance *inst); +Scheme_Bucket *scheme_instance_variable_bucket_or_null(Scheme_Object *symbol, Scheme_Instance *inst); - Scheme_Hash_Table *accessible; /* (symbol -> ...) */ -} Scheme_Module_Export_Info; - -typedef struct Scheme_Module +struct Scheme_Linklet { - Scheme_Object so; /* scheme_module_type */ - short predefined; - - Scheme_Object *phaseless; /* NULL, #t, or shared `toplevel' hash table */ - - Scheme_Object *code_key; - - Scheme_Object *modname; - Scheme_Object *modsrc; - - Scheme_Object *et_requires; /* list of symbol-or-module-path-index */ - Scheme_Object *requires; /* list of symbol-or-module-path-index */ - Scheme_Object *tt_requires; /* list of symbol-or-module-path-index */ - Scheme_Object *dt_requires; /* list of symbol-or-module-path-index */ - Scheme_Hash_Table *other_requires; /* phase to list of symbol-or-module-path-index */ - - Scheme_Invoke_Proc prim_body; - Scheme_Invoke_Proc prim_et_body; - - Scheme_Object **bodies; /* array `num_phases' long */ - - struct Scheme_Module_Exports *me; - - int num_phases; - Scheme_Module_Export_Info **exp_infos; /* array `num_phases' long */ + Scheme_Object so; /* scheme_linklet_type */ - Scheme_Object *self_modidx; + Scheme_Object *name; /* for reporting purposes; FIXME: doesn't belong here? */ - /* These tables are unshifted, so they are relative to self_modidx - and must be shifted as they are installed into an environment. - The tables can be immutable or immutable hash tables, or they can - be a vectors that should be converted to an immutable hash - table. */ - Scheme_Object *binding_names; /* maps symbols to identifiers */ - Scheme_Object *et_binding_names; /* maps symbols to identifiers */ - Scheme_Object *other_binding_names; /* maps phases to maps symbols to identifiers */ - - Scheme_Object *insp; /* declaration-time inspector, for module instantiation - and enabling access to protected imports */ - - Scheme_Object *lang_info; /* NULL or vector */ - - Scheme_Object *hints; /* set by expansion; moved to properties */ - Scheme_Object *ii_src; /* set by compile, temporary */ - Comp_Prefix *comp_prefix; /* set by body compile, temporary */ - void **super_bxs_info; /* set by expansion; temporary */ - Scheme_Object **sub_iidx_ptrs; /* set by expansion; temporary */ + Scheme_Object *importss; /* vector of vector of symbol (extenal names) */ + Scheme_Object *import_shapes; /* optional flattened vector of values; records compiler assumptions */ + int num_total_imports; /* total number of symbols in `importss` */ + + /* The symbols in the `defns` arracy correspond to external names + for the first `num_exports` entries. The remaining (non-exported) + names should be adjusted on instantiation to avoid conflicts with + any existing names; a #f value indicates an unused variable whose + definition has been pruned. Unreadable symbols starting with "?" were + generated for resolve-pass lifts. */ + Scheme_Object *defns; /* vector of symbol-or-#f */ + int num_exports; /* this many in the prefix of `defns` are exported */ + int num_lifts; /* this many at the tail of `exports` are from resolve lifts */ + + /* For error reporting, we can recover the source name from the + symbol that is used in the bucket; this table is merged to the + one in the instance, updating symbols as changed to avoid + conflicts. */ + Scheme_Hash_Tree *source_names; /* symbol (external name) -> symbol (internal or source name) */ + + Scheme_Object *bodies; /* vector of definition or expression */ int max_let_depth; - Resolve_Prefix *prefix; - - Scheme_Object *dummy; /* for accessing the environment */ - - Scheme_Env *primitive; - - Scheme_Object *rn_stx; /* NULL, #t, a stx for a rename, a vector of stxes, or a pair to delay shifts */ - - Scheme_Object *submodule_path; /* path to this module relative to enclosing top-level module */ - Scheme_Object *pre_submodules, *post_submodules; /* list of modules (when compiled or loaded as a group) */ - Scheme_Object *pre_submodule_names; /* list of symbols (in expand mode) */ - Scheme_Object *supermodule; /* supermodule for which this is in {pre,post}_submodules */ - Scheme_Object *submodule_ancestry; /* set by compile/expand, temporary */ -} Scheme_Module; - -typedef struct Scheme_Module_Phase_Exports -{ - Scheme_Object so; - - Scheme_Object *phase_index; + int need_instance_access; /* whether the instance-access toplevel is needed */ - Scheme_Object *src_modidx; /* same as in enclosing Scheme_Module_Exports */ + char jit_ready; /* true if the linklet is in has been prepared for the JIT */ + char reject_eval; /* true when loaded without the root inspector, for example */ - Scheme_Object **provides; /* symbols (extenal names) */ - Scheme_Object **provide_srcs; /* module access paths, #f for self */ - Scheme_Object **provide_src_names; /* symbols (original internal names) */ - Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ - int *provide_src_phases; /* NULL, or src phase for for-syntax import */ - int num_provides; - int num_var_provides; /* non-syntax listed first in provides */ + Scheme_Hash_Table *constants; /* holds info about the linklet's body for inlining */ - Scheme_Hash_Table *ht; /* maps external names to array indices; created lazily */ -} Scheme_Module_Phase_Exports; - -typedef struct Scheme_Module_Exports -{ - /* Scheme_Module_Exports is separate from Scheme_Module - so that we can create a global table mapping export - keys to exports. This mapping is used to lazily - unmarshal syntax-object context. */ - MZTAG_IF_REQUIRED - - /* Most common phases: */ - Scheme_Module_Phase_Exports *rt; /* run time? phase 0*/ - Scheme_Module_Phase_Exports *et; /* expansion time? phase 1 */ - Scheme_Module_Phase_Exports *dt; /* */ - - /* All others: */ - Scheme_Hash_Table *other_phases; - - Scheme_Object *src_modidx; /* the one used in marshalled syntax */ - Scheme_Object *modsrc; /* module source as loaded */ -} Scheme_Module_Exports; - -typedef struct Scheme_Modidx { - Scheme_Object so; /* scheme_module_index_type */ - - Scheme_Object *path; - Scheme_Object *base; - Scheme_Object *resolved; - Scheme_Object *shift_cache; /* vector */ - struct Scheme_Modidx *cache_next; -} Scheme_Modidx; - -typedef struct Module_Variable { - Scheme_Inclhash_Object iso; /* see SCHEME_MODVAR_... flags */ - Scheme_Object *modidx; - Scheme_Object *sym; - Scheme_Object *insp; /* for checking protected/unexported access */ - Scheme_Object *shape; /* NULL or a symbol encoding "type" information */ - int pos, mod_phase; -} Module_Variable; - -/* See SCHEME_TOPLEVEL_...: */ -#define SCHEME_MODVAR_CONST 0x1 -#define SCHEME_MODVAR_FIXED 0x2 + Scheme_Prefix *static_prefix; /* non-NULL for a linklet compiled in static mode */ +}; -#define SCHEME_MODVAR_FLAGS(pr) MZ_OPT_HASH_KEY(&((Module_Variable *)pr)->iso) +#define SCHEME_DEFN_VAR_COUNT(d) (SCHEME_VEC_SIZE(d)-1) +#define SCHEME_DEFN_RHS(d) (SCHEME_VEC_ELS(d)[0]) +#define SCHEME_DEFN_VAR_(d, pos) (SCHEME_VEC_ELS(d)[(pos)+1]) +#define SCHEME_DEFN_VAR(d, pos) ((Scheme_IR_Toplevel *)SCHEME_DEFN_VAR_(d, pos)) + +/* Recycle some vector flags to use on definitions for the compiler, + optimizer, and resolver to commuincate: */ +#define SCHEME_DEFN_ALWAYS_INLINEP(d) SCHEME_IMMUTABLEP(d) +#define SCHEME_SET_DEFN_ALWAYS_INLINE(d) SCHEME_SET_IMMUTABLE(d) +#define SCHEME_DEFN_CAN_OMITP(d) SHARED_ALLOCATEDP(d) +#define SCHEME_SET_DEFN_CAN_OMIT(d) SHARED_ALLOCATED_SET(d) #define SCHEME_VARREF_FLAGS(pr) MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)pr)->iso) +#define VARREF_IS_CONSTANT 0x1 +#define VARREF_FROM_UNSAFE 0x2 +#define VARREF_FLAGS_MASK (VARREF_IS_CONSTANT | VARREF_FROM_UNSAFE) + +void scheme_addto_prim_instance(const char *name, Scheme_Object *obj, Scheme_Startup_Env *env); +void scheme_addto_primitive_instance_by_symbol(Scheme_Object *name, Scheme_Object *obj, Scheme_Startup_Env *env); +void scheme_switch_prim_instance(Scheme_Startup_Env *env, const char *name); +void scheme_restore_prim_instance(Scheme_Startup_Env *env); + +#define ADD_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_addto_prim_instance(name, scheme_make_folding_prim(func, name, a1, a2, a3), env) +#define ADD_IMMED_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_immed_prim(func, name, a1, a2), env) +#define ADD_PARAMETER(name, func, constant, env) scheme_addto_prim_instance(name, scheme_register_parameter(func, name, constant), env) +#define ADD_PRIM_W_ARITY(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity(func, name, a1, a2), env) +#define ADD_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env) +#define ADD_NONCM_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_noncm_prim(func, name, a1, a2), env) -void scheme_add_global_keyword(const char *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); - -#define GLOBAL_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_add_global_constant(name, scheme_make_folding_prim(func, name, a1, a2, a3), env) -#define GLOBAL_IMMED_PRIM(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_immed_prim(func, name, a1, a2), env) -#define GLOBAL_PARAMETER(name, func, constant, env) scheme_add_global_constant(name, scheme_register_parameter(func, name, constant), env) -#define GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_prim_w_arity(func, name, a1, a2), env) -#define GLOBAL_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_add_global_constant(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env) -#define GLOBAL_NONCM_PRIM(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_noncm_prim(func, name, a1, a2), env) - -#define GLOBAL_FOLDING_PRIM_UNARY_INLINED(name, func, a1, a2, a3, env) do {\ +#define ADD_FOLDING_PRIM_UNARY_INLINED(name, func, a1, a2, a3, env) do {\ Scheme_Object *p; \ p = scheme_make_folding_prim(func, name, a1, a2, a3); \ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); \ - scheme_add_global_constant(name, p, env); \ + scheme_addto_prim_instance(name, p, env); \ } while(0) -Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env, int for_top_level); -Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env); - -Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); -Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase); - -THREAD_LOCAL_DECL(extern Scheme_Bucket_Table *scheme_module_code_cache); -Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv); - -Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, - int new_exp_module_tree, int new_pre_registry); -int scheme_is_module_env(Scheme_Comp_Env *env); - -Scheme_Env *scheme_make_env_like(Scheme_Env *base); +THREAD_LOCAL_DECL(extern Scheme_Bucket_Table *scheme_namespace_to_env); +Scheme_Env *scheme_get_current_namespace_as_env(); +void scheme_set_current_namespace_as_env(Scheme_Env *env); -Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it); -Scheme_Env *scheme_module_access(Scheme_Object *modname, Scheme_Env *env, intptr_t rev_mod_phase); - -int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname); - -Scheme_Module_Exports *scheme_make_module_exports(); - -Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, - Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, int *_would_complain, - Scheme_Object **_is_constant); -Scheme_Object *scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, - Scheme_Object *symbol, int position, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object **_is_constant); -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name, int mod_phase); - -Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, - Scheme_Object *shift_from_modidx, - Scheme_Object *shift_to_modidx); - -Scheme_Object *scheme_modidx_submodule(Scheme_Object *modidx); -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache); - -#define SCHEME_RMPP(o) (SAME_TYPE(SCHEME_TYPE((o)), scheme_resolved_module_path_type)) -#define SCHEME_MODNAMEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)) - -Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o); -Scheme_Object *scheme_resolved_module_path_value(Scheme_Object *rmp); -int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o); - -Scheme_Object *scheme_resolved_module_path_to_modidx(Scheme_Object *rmp); - -Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, - Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant, - Scheme_Object *shape); - - -Scheme_Env *scheme_get_kernel_env(); -int scheme_is_kernel_env(); -Scheme_Env *scheme_get_unsafe_env(); -Scheme_Env *scheme_get_flfxnum_env(); -Scheme_Env *scheme_get_extfl_env(); -Scheme_Env *scheme_get_futures_env(); -Scheme_Env *scheme_get_foreign_env(); - -void scheme_install_initial_module_set(Scheme_Env *env); Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home); -Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone); - -Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o); - -int scheme_is_kernel_modname(Scheme_Object *modname); -int scheme_is_unsafe_modname(Scheme_Object *modname); -int scheme_is_flfxnum_modname(Scheme_Object *modname); -int scheme_is_extfl_modname(Scheme_Object *modname); -int scheme_is_futures_modname(Scheme_Object *modname); -int scheme_is_foreign_modname(Scheme_Object *modname); - -void scheme_clear_modidx_cache(void); -void scheme_clear_shift_cache(void); -void scheme_clear_prompt_cache(void); - -Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath, - Scheme_Object *mode); -Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *genv); - -void scheme_prepare_compile_env(Scheme_Env *env); - -Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env); -void scheme_prep_namespace_rename(Scheme_Env *menv); - -Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len); -char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len); - -Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int incl_star); - -Scheme_Object *scheme_get_modsrc(Scheme_Module *m); - -Scheme_Object *scheme_prune_bindings_table(Scheme_Object *bindings, Scheme_Object *rn_stx, Scheme_Object *phase); +Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len); +char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len); /*========================================================================*/ /* errors and exceptions */ @@ -4068,39 +3345,19 @@ #define NOT_SUPPORTED_STR "unsupported on this platform" +intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...); + int scheme_last_error_is_racket(int errid); -void scheme_read_err(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t column, intptr_t pos, intptr_t span, - int is_eof, Scheme_Object *indentation, - const char *detail, ...); -Scheme_Object *scheme_numr_err(Scheme_Object *complain, - Scheme_Object *stxsrc, - intptr_t line, intptr_t column, intptr_t pos, intptr_t span, - Scheme_Object *indentation, - const char *detail, ...); +void scheme_read_err(Scheme_Object *port, const char *detail, ...); +Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...); + char *scheme_extract_indentation_suggestions(Scheme_Object *indentation); void scheme_wrong_syntax(const char *where, Scheme_Object *local_form, Scheme_Object *form, const char *detail, ...); -void scheme_unbound_syntax(const char *where, - Scheme_Object *local_form, - Scheme_Object *form, - const char *detail, ...); -void scheme_wrong_syntax_with_more_sources(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - Scheme_Object *extra_sources, - const char *detail, ...); -extern const char *scheme_compile_stx_string; -extern const char *scheme_expand_stx_string; -extern const char *scheme_application_stx_string; -extern const char *scheme_set_stx_string; -extern const char *scheme_var_ref_string; -extern const char *scheme_begin_stx_string; void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv); @@ -4155,16 +3412,15 @@ MZTAG_IF_REQUIRED Scheme_Object *syms[5]; int count; - intptr_t phase; Scheme_Hash_Table *ht; } DupCheckRecord; -void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *e); +void scheme_begin_dup_symbol_check(DupCheckRecord *r); void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, Scheme_Object *symbol, char *what, Scheme_Object *form); - -Scheme_Object *scheme_special_comment_value(Scheme_Object *o); +void scheme_check_identifier(const char *formname, Scheme_Object *id, + const char *where, Scheme_Object *form); Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set); @@ -4183,6 +3439,7 @@ intptr_t local_timestamp; /* determines when want_level is up-to-date */ Scheme_Object *syslog_level; /* (list* ... ) */ Scheme_Object *stderr_level; + Scheme_Object *stdout_level; Scheme_Object *propagate_level; /* can be NULL */ Scheme_Object *readers; /* list of (cons (make-weak-box ) ) */ }; @@ -4243,8 +3500,6 @@ const mzchar *format, int flen, int fpos, int offset, int argc, Scheme_Object **argv); -Scheme_Object *scheme_load_with_clrd(int argc, Scheme_Object *argv[], char *who, int handler_param); - Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv); Scheme_Object *scheme_remove_current_directory_prefix(Scheme_Object *fn); @@ -4445,6 +3700,8 @@ Scheme_Object *scheme_checked_set_mcdr (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_vector_star_ref(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_vector_star_set(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_cas(int argc, Scheme_Object **argv); Scheme_Object *scheme_string_length(Scheme_Object *v); Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); @@ -4454,8 +3711,8 @@ Scheme_Object *scheme_byte_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_vector_length(Scheme_Object *v); +Scheme_Object *scheme_vector_star_length(Scheme_Object *v); Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv); Scheme_Object *scheme_flvector_length(Scheme_Object *v); @@ -4473,9 +3730,15 @@ Scheme_Object *scheme_checked_flimag_part (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_make_flrectangular (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_char_to_integer (int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_integer_to_char (int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_make_vector (int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_char_to_integer(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_integer_to_char(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_symbol_interned_p(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_make_vector(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_unbox_star(Scheme_Object *b); +void scheme_set_box_star(Scheme_Object *b, Scheme_Object *v); Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]); @@ -4483,10 +3746,16 @@ Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj); Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj); +typedef Scheme_Object *(*Hash_Table_Element_Filter_Proc)(Scheme_Object *); +Scheme_Object *scheme_chaperone_hash_table_filtered_copy(Scheme_Object *obj, + Hash_Table_Element_Filter_Proc filter); + void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec, intptr_t bottom, intptr_t len); +Scheme_Object *scheme_weak_box_value(Scheme_Object *obj); + Scheme_Bucket_Table *scheme_make_weak_equal_table(void); Scheme_Bucket_Table *scheme_make_weak_eqv_table(void); Scheme_Bucket_Table *scheme_make_nonlock_equal_bucket_table(void); @@ -4514,15 +3783,14 @@ void scheme_set_root_param(int p, Scheme_Object *v); -int scheme_equal_modix_eq(Scheme_Object *obj1, Scheme_Object *obj2); -Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq(); - Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, uintptr_t len); Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); Scheme_Object *scheme_copy_list(Scheme_Object *l); Scheme_Object *scheme_append_strings(Scheme_Object *s1, Scheme_Object *s2); +Scheme_Object *scheme_unsafe_make_location(void); + void scheme_reset_hash_table(Scheme_Hash_Table *ht, int *history); XFORM_NONGCING void scheme_set_distinct_eq_hash(Scheme_Object *var2); @@ -4713,8 +3981,17 @@ void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo); Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch); #endif - +int scheme_is_predefined_module_path(Scheme_Object *v); + void scheme_process_global_lock(void); void scheme_process_global_unlock(void); +Scheme_Object *scheme_expander_syntax_to_datum(Scheme_Object *v); +int scheme_is_syntax(Scheme_Object *v); + +#ifdef DOS_FILE_SYSTEM +HANDLE scheme_dll_load_library(const char *s, const wchar_t *ws, int *_mode); +void *scheme_dll_get_proc_address(HANDLE m, const char *name, int dll_mode); +#endif + #endif /* __mzscheme_private__ */ diff -Nru racket-6.12+ppa1/src/racket/src/schvers.h racket-7.0+ppa1/src/racket/src/schvers.h --- racket-6.12+ppa1/src/racket/src/schvers.h 2018-01-26 20:27:37.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/schvers.h 2018-07-27 22:12:02.000000000 +0000 @@ -13,10 +13,10 @@ consistently.) */ -#define MZSCHEME_VERSION "6.12" +#define MZSCHEME_VERSION "7.0" -#define MZSCHEME_VERSION_X 6 -#define MZSCHEME_VERSION_Y 12 +#define MZSCHEME_VERSION_X 7 +#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_W 0 diff -Nru racket-6.12+ppa1/src/racket/src/sema.c racket-7.0+ppa1/src/racket/src/sema.c --- racket-6.12+ppa1/src/racket/src/sema.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/sema.c 2018-07-27 22:12:02.000000000 +0000 @@ -86,7 +86,7 @@ return SCHEME_PTR_VAL(s); } -void scheme_init_sema(Scheme_Env *env) +void scheme_init_sema(Scheme_Startup_Env *env) { Scheme_Object *o; @@ -94,112 +94,112 @@ register_traversers(); #endif - scheme_add_global_constant("make-semaphore", + scheme_addto_prim_instance("make-semaphore", scheme_make_prim_w_arity(make_sema, "make-semaphore", 0, 1), env); - scheme_add_global_constant("semaphore?", + scheme_addto_prim_instance("semaphore?", scheme_make_folding_prim(semap, "semaphore?", 1, 1, 1), env); - scheme_add_global_constant("semaphore-post", + scheme_addto_prim_instance("semaphore-post", scheme_make_prim_w_arity(hit_sema, "semaphore-post", 1, 1), env); - scheme_add_global_constant("semaphore-try-wait?", + scheme_addto_prim_instance("semaphore-try-wait?", scheme_make_prim_w_arity(block_sema_p, "semaphore-try-wait?", 1, 1), env); - scheme_add_global_constant("semaphore-wait", + scheme_addto_prim_instance("semaphore-wait", scheme_make_prim_w_arity(block_sema, "semaphore-wait", 1, 1), env); - scheme_add_global_constant("semaphore-wait/enable-break", + scheme_addto_prim_instance("semaphore-wait/enable-break", scheme_make_prim_w_arity(block_sema_breakable, "semaphore-wait/enable-break", 1, 1), env); - scheme_add_global_constant("semaphore-peek-evt", + scheme_addto_prim_instance("semaphore-peek-evt", scheme_make_prim_w_arity(make_sema_repost, "semaphore-peek-evt", 1, 1), env); - scheme_add_global_constant("semaphore-peek-evt?", + scheme_addto_prim_instance("semaphore-peek-evt?", scheme_make_folding_prim(is_sema_repost, "semaphore-peek-evt?", 1, 1, 1), env); - scheme_add_global_constant("make-channel", + scheme_addto_prim_instance("make-channel", scheme_make_prim_w_arity(make_channel, "make-channel", 0, 0), env); - scheme_add_global_constant("channel-put-evt", + scheme_addto_prim_instance("channel-put-evt", scheme_make_prim_w_arity(make_channel_put, "channel-put-evt", 2, 2), env); - scheme_add_global_constant("channel?", + scheme_addto_prim_instance("channel?", scheme_make_folding_prim(channel_p, "channel?", 1, 1, 1), env); - scheme_add_global_constant("channel-put-evt?", + scheme_addto_prim_instance("channel-put-evt?", scheme_make_folding_prim(channel_put_p, "channel-put-evt?", 1, 1, 1), env); - scheme_add_global_constant("chaperone-channel", + scheme_addto_prim_instance("chaperone-channel", scheme_make_prim_w_arity(chaperone_channel, "chaperone-channel", 3, -1), env); - scheme_add_global_constant("impersonate-channel", + scheme_addto_prim_instance("impersonate-channel", scheme_make_prim_w_arity(impersonate_channel, "impersonate-channel", 3, -1), env); - scheme_add_global_constant("thread-send", + scheme_addto_prim_instance("thread-send", scheme_make_prim_w_arity(thread_send, "thread-send", 2, 3), env); - scheme_add_global_constant("thread-receive", + scheme_addto_prim_instance("thread-receive", scheme_make_prim_w_arity(thread_receive, "thread-receive", 0, 0), env); - scheme_add_global_constant("thread-try-receive", + scheme_addto_prim_instance("thread-try-receive", scheme_make_prim_w_arity(thread_try_receive, "thread-try-receive", 0, 0), env); - scheme_add_global_constant("thread-receive-evt", + scheme_addto_prim_instance("thread-receive-evt", scheme_make_prim_w_arity(thread_receive_evt, "thread-receive-evt", 0, 0), env); - scheme_add_global_constant("thread-rewind-receive", + scheme_addto_prim_instance("thread-rewind-receive", scheme_make_prim_w_arity(thread_rewind_receive, "thread-rewind-receive", 1, 1), env); - scheme_add_global_constant("alarm-evt", + scheme_addto_prim_instance("alarm-evt", scheme_make_prim_w_arity(make_alarm, "alarm-evt", 1, 1), env); - scheme_add_global_constant("system-idle-evt", + scheme_addto_prim_instance("system-idle-evt", scheme_make_prim_w_arity(make_sys_idle, "system-idle-evt", 0, 0), @@ -208,11 +208,11 @@ REGISTER_SO(scheme_always_ready_evt); scheme_always_ready_evt = scheme_alloc_small_object(); scheme_always_ready_evt->type = scheme_always_evt_type; - scheme_add_global_constant("always-evt", scheme_always_ready_evt, env); + scheme_addto_prim_instance("always-evt", scheme_always_ready_evt, env); o = scheme_alloc_small_object(); o->type = scheme_never_evt_type; - scheme_add_global_constant("never-evt", o, env); + scheme_addto_prim_instance("never-evt", o, env); REGISTER_SO(thread_recv_evt); o = scheme_alloc_small_object(); diff -Nru racket-6.12+ppa1/src/racket/src/sfs.c racket-7.0+ppa1/src/racket/src/sfs.c --- racket-6.12+ppa1/src/racket/src/sfs.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/sfs.c 2018-07-27 22:12:02.000000000 +0000 @@ -30,11 +30,10 @@ #include "schpriv.h" #include "schrunst.h" #include "schmach.h" -#include "schexpobs.h" struct SFS_Info { MZTAG_IF_REQUIRED - int for_mod, pass; + int for_linklet, pass; int tail_pos; /* in tail position? */ int depth, stackpos, tlpos; /* stack shape */ int selfpos, selfstart, selflen; /* tracks self calls */ @@ -49,6 +48,18 @@ Scheme_Object *saved; }; +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info); +static Scheme_Object *sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos); +static SFS_Info *new_sfs_info(int depth); + +static void sfs_used(SFS_Info *info, int pos); +static void sfs_push(SFS_Info *info, int count, int track); +static void sfs_start_sequence(SFS_Info *si, int cnt, int last_is_tail); +static Scheme_Object *sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre); + +static Scheme_Object *sfs_passes(Scheme_Object *e, SFS_Info *info); +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info); + #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif @@ -67,15 +78,18 @@ #define SFS_LOG(x) /* nothing */ -Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) +Scheme_Linklet *scheme_sfs_linklet(Scheme_Linklet *linklet) { - int init, i; + SFS_Info *info; - SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o))); + info = new_sfs_info(linklet->max_let_depth); - if (!info) { - info = scheme_new_sfs_info(max_let_depth); - } + return (Scheme_Linklet *)sfs_passes((Scheme_Object *)linklet, info); +} + +static Scheme_Object *sfs_passes(Scheme_Object *o, SFS_Info *info) +{ + int init, i; info->pass = 0; info->ip = 1; @@ -85,7 +99,11 @@ info->max_touch = -1; info->tail_pos = 1; init = info->stackpos; - o = scheme_sfs_expr(o, info, -1); + + if (SAME_TYPE(SCHEME_TYPE(o), scheme_linklet_type)) + linklet_sfs((Scheme_Linklet *)o, info); + else + o = sfs_expr(o, info, -1); if (info->seqn) scheme_signal_error("ended in the middle of an expression?"); @@ -111,12 +129,29 @@ info->abs_ip = 1; info->tail_pos = 1; info->stackpos = init; - o = scheme_sfs_expr(o, info, -1); + if (SAME_TYPE(SCHEME_TYPE(o), scheme_linklet_type)) + linklet_sfs((Scheme_Linklet *)o, info); + else + o = sfs_expr(o, info, -1); return o; } -SFS_Info *scheme_new_sfs_info(int depth) +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info) +{ + Scheme_Object *e; + int i, cnt; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + sfs_start_sequence(info, cnt, 0); + + for (i = 0; i < cnt; i++) { + e = sfs_expr(SCHEME_VEC_ELS(linklet->bodies)[i], info, -1); + SCHEME_VEC_ELS(linklet->bodies)[i] = e; + } +} + +static SFS_Info *new_sfs_info(int depth) { SFS_Info *info; int *max_used, *max_calls; @@ -162,12 +197,12 @@ return v; } -void scheme_sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) +static void sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) { info->seqn += (cnt - (last_is_tail ? 1 : 0)); } -void scheme_sfs_push(SFS_Info *info, int cnt, int track) +static void sfs_push(SFS_Info *info, int cnt, int track) { info->stackpos -= cnt; @@ -178,12 +213,12 @@ if (track) { while (cnt--) { - scheme_sfs_used(info, cnt); + sfs_used(info, cnt); } } } -void scheme_sfs_used(SFS_Info *info, int pos) +static void sfs_used(SFS_Info *info, int pos) { if (info->pass) return; @@ -212,7 +247,7 @@ info->max_used[pos] = info->ip; } -Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) +static Scheme_Object *sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) { int len, i; Scheme_Object *loc; @@ -268,7 +303,7 @@ int i; for (i = info->selflen; i--; ) { if ((info->selfstart + i) != info->tlpos) - scheme_sfs_used(info, (info->selfstart - info->stackpos) + i); + sfs_used(info, (info->selfstart - info->stackpos) + i); } tail_ok = 1; } @@ -290,12 +325,12 @@ app = (Scheme_App_Rec *)o; n = app->num_args + 1; - scheme_sfs_start_sequence(info, n, 0); - scheme_sfs_push(info, n-1, 0); + sfs_start_sequence(info, n, 0); + sfs_push(info, n-1, 0); for (i = 0; i < n; i++) { orig = app->args[i]; - naya = scheme_sfs_expr(orig, info, -1); + naya = sfs_expr(orig, info, -1); app->args[i] = naya; } @@ -313,11 +348,11 @@ app = (Scheme_App2_Rec *)o; - scheme_sfs_start_sequence(info, 2, 0); - scheme_sfs_push(info, 1, 0); + sfs_start_sequence(info, 2, 0); + sfs_push(info, 1, 0); - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand = scheme_sfs_expr(app->rand, info, -1); + nrator = sfs_expr(app->rator, info, -1); + nrand = sfs_expr(app->rand, info, -1); app->rator = nrator; app->rand = nrand; @@ -335,12 +370,12 @@ app = (Scheme_App3_Rec *)o; - scheme_sfs_start_sequence(info, 3, 0); - scheme_sfs_push(info, 2, 0); + sfs_start_sequence(info, 3, 0); + sfs_push(info, 2, 0); - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand1 = scheme_sfs_expr(app->rand1, info, -1); - nrand2 = scheme_sfs_expr(app->rand2, info, -1); + nrator = sfs_expr(app->rator, info, -1); + nrand1 = sfs_expr(app->rand1, info, -1); + nrand2 = sfs_expr(app->rand2, info, -1); app->rator = nrator; app->rand1 = nrand1; @@ -400,11 +435,11 @@ seq = (Scheme_Sequence *)o; n = seq->count; - scheme_sfs_start_sequence(info, n, 1); + sfs_start_sequence(info, n, 1); for (i = 0; i < n; i++) { orig = seq->array[i]; - naya = scheme_sfs_expr(orig, info, -2); + naya = sfs_expr(orig, info, -2); seq->array[i] = naya; } @@ -467,7 +502,8 @@ else_end_abs = SCHEME_INT_VAL(o); SFS_LOG(printf(" %d %d %d %d %d\n", nt, ip, b_end, else_end_abs, info->abs_max_nontail)); if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */ - || (else_end_abs < info->abs_max_nontail)) { /* => non-tail call after branches */ + || (!info->tail_pos + && (else_end_abs < info->abs_max_nontail))) { /* => non-tail call after branches */ SFS_LOG(printf(" other\n")); o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W]; t_min_t = SCHEME_INT_VAL(o); @@ -505,7 +541,7 @@ stackpos = info->stackpos; - tbranch = scheme_sfs_expr(tbranch, info, -1); + tbranch = sfs_expr(tbranch, info, -1); if (info->pass) info->max_nontail = save_nt; @@ -516,7 +552,7 @@ } # endif - tbranch = scheme_sfs_add_clears(tbranch, clears, 1); + tbranch = sfs_add_clears(tbranch, clears, 1); if (!info->pass) { t_min_t = info->min_touch; @@ -587,9 +623,9 @@ b = (Scheme_Branch_Rec *)o; - scheme_sfs_start_sequence(info, 1, 0); + sfs_start_sequence(info, 1, 0); - t = scheme_sfs_expr(b->test, info, -1); + t = sfs_expr(b->test, info, -1); ip = info->ip; info->ip++; @@ -658,16 +694,16 @@ Scheme_Object *body, *rhs, *clears = scheme_null; int i, pos; - scheme_sfs_start_sequence(info, 2, 1); + sfs_start_sequence(info, 2, 1); - rhs = scheme_sfs_expr(lv->value, info, -1); + rhs = sfs_expr(lv->value, info, -1); if (!info->pass || (info->ip < info->max_nontail)) { for (i = 0; i < lv->count; i++) { pos = lv->position + i; if (!info->pass) - scheme_sfs_used(info, pos); + sfs_used(info, pos); else { int spos; spos = pos + info->stackpos; @@ -683,9 +719,9 @@ } } - body = scheme_sfs_expr(lv->body, info, -1); + body = sfs_expr(lv->body, info, -1); - body = scheme_sfs_add_clears(body, clears, 1); + body = sfs_add_clears(body, clears, 1); lv->value = rhs; lv->body = body; @@ -700,9 +736,9 @@ int pos, save_mnt, ip, et; int unused = 0; - scheme_sfs_start_sequence(info, 2, 1); + sfs_start_sequence(info, 2, 1); - scheme_sfs_push(info, 1, 1); + sfs_push(info, 1, 1); ip = info->ip; pos = info->stackpos; save_mnt = info->max_nontail; @@ -723,8 +759,8 @@ info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); } - rhs = scheme_sfs_expr(lo->value, info, -1); - body = scheme_sfs_expr(lo->body, info, -1); + rhs = sfs_expr(lo->value, info, -1); + body = sfs_expr(lo->body, info, -1); # if MAX_SFS_CLEARING if (!info->pass) @@ -753,7 +789,8 @@ if (scheme_omittable_expr(rhs, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) { rhs = scheme_false; } else if ((ip < info->max_calls[pos]) - && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { + && (SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(rhs), scheme_static_toplevel_type))) { /* Unusual case: we can't just drop the global-variable access, because it might be undefined, but we don't need the value, and we want to avoid an SFS clear in the interpreter loop. @@ -789,7 +826,7 @@ int i, pos, save_mnt; Scheme_Object *vec; - scheme_sfs_push(info, lv->count, 1); + sfs_push(info, lv->count, 1); pos = info->stackpos; save_mnt = info->max_nontail; @@ -807,7 +844,7 @@ info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); } - body = scheme_sfs_expr(lv->body, info, -1); + body = sfs_expr(lv->body, info, -1); # if MAX_SFS_CLEARING if (!info->pass) @@ -838,12 +875,12 @@ count = lr->count; - scheme_sfs_start_sequence(info, count + 1, 1); + sfs_start_sequence(info, count + 1, 1); procs = lr->procs; for (i = 0; i < count; i++) { - v = scheme_sfs_expr(procs[i], info, i); + v = sfs_expr(procs[i], info, i); if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. @@ -860,9 +897,9 @@ procs[i] = v; } - v = scheme_sfs_expr(lr->body, info, -1); + v = sfs_expr(lr->body, info, -1); - v = scheme_sfs_add_clears(v, clears, 1); + v = sfs_add_clears(v, clears, 1); lr->body = v; @@ -874,11 +911,11 @@ Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - scheme_sfs_start_sequence(info, 3, 1); + sfs_start_sequence(info, 3, 1); - k = scheme_sfs_expr(wcm->key, info, -1); - v = scheme_sfs_expr(wcm->val, info, -1); - b = scheme_sfs_expr(wcm->body, info, -1); + k = sfs_expr(wcm->key, info, -1); + v = sfs_expr(wcm->val, info, -1); + b = sfs_expr(wcm->body, info, -1); wcm->key = k; wcm->val = v; @@ -895,9 +932,9 @@ define_values_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; - scheme_sfs_start_sequence(info, 1, 0); - e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); - SCHEME_VEC_ELS(data)[0] = e; + sfs_start_sequence(info, 1, 0); + e = sfs_expr(SCHEME_DEFN_RHS(data), info, -1); + SCHEME_DEFN_RHS(data) = e; return data; } @@ -905,8 +942,8 @@ inline_variant_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; - scheme_sfs_start_sequence(info, 1, 0); - e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); + sfs_start_sequence(info, 1, 0); + e = sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); SCHEME_VEC_ELS(data)[0] = e; /* we don't bother with inlinable variant, since it isn't called directly */ return data; @@ -921,10 +958,10 @@ var = sb->var; val = sb->val; - scheme_sfs_start_sequence(info, 2, 0); + sfs_start_sequence(info, 2, 0); - val = scheme_sfs_expr(val, info, -1); - var = scheme_sfs_expr(var, info, -1); + val = sfs_expr(val, info, -1); + var = sfs_expr(var, info, -1); sb->var = var; sb->val = val; @@ -938,9 +975,9 @@ Scheme_Object *a_naya; Scheme_Object *b_naya; - scheme_sfs_start_sequence(info, 1, 0); - a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1); - b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + sfs_start_sequence(info, 1, 0); + a_naya = sfs_expr(SCHEME_PTR1_VAL(data), info, -1); + b_naya = sfs_expr(SCHEME_PTR2_VAL(data), info, -1); SCHEME_PTR1_VAL(data) = a_naya; SCHEME_PTR2_VAL(data) = b_naya; @@ -955,10 +992,10 @@ f = SCHEME_PTR1_VAL(data); e = SCHEME_PTR2_VAL(data); - scheme_sfs_start_sequence(info, 2, 0); + sfs_start_sequence(info, 2, 0); - f = scheme_sfs_expr(f, info, -1); - e = scheme_sfs_expr(e, info, -1); + f = sfs_expr(f, info, -1); + e = sfs_expr(e, info, -1); SCHEME_PTR1_VAL(data) = f; SCHEME_PTR2_VAL(data) = e; @@ -972,12 +1009,12 @@ Scheme_Object *k, *v, *b, *vec; int pos, save_mnt; - scheme_sfs_start_sequence(info, 3, 1); + sfs_start_sequence(info, 3, 1); - k = scheme_sfs_expr(wcm->key, info, -1); - v = scheme_sfs_expr(wcm->val, info, -1); + k = sfs_expr(wcm->key, info, -1); + v = sfs_expr(wcm->val, info, -1); - scheme_sfs_push(info, 1, 1); + sfs_push(info, 1, 1); pos = info->stackpos; save_mnt = info->max_nontail; @@ -994,7 +1031,7 @@ info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); } - b = scheme_sfs_expr(wcm->body, info, -1); + b = sfs_expr(wcm->body, info, -1); wcm->key = k; wcm->val = v; @@ -1027,11 +1064,11 @@ Scheme_Object *le, *clears = scheme_null; int i; - scheme_sfs_start_sequence(info, seq->count, 0); + sfs_start_sequence(info, seq->count, 0); for (i = 0; i < seq->count; i++) { le = seq->array[i]; - le = scheme_sfs_expr(le, info, -1); + le = sfs_expr(le, info, -1); if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ @@ -1055,7 +1092,7 @@ } if (!SCHEME_NULLP(clears)) { - return scheme_sfs_add_clears(expr, clears, 0); + return sfs_add_clears(expr, clears, 0); } else return expr; } @@ -1074,7 +1111,7 @@ else drop = 0; - e = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + e = sfs_expr(SCHEME_PTR2_VAL(data), info, -1); if (drop) return e; @@ -1129,11 +1166,11 @@ cnt = ((Scheme_Sequence *)obj)->count; - scheme_sfs_start_sequence(info, cnt, 0); + sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { Scheme_Object *le; - le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); + le = sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); ((Scheme_Sequence *)obj)->array[i] = le; } @@ -1143,45 +1180,6 @@ return obj; } -static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *e; - - if (!info->pass) { - int depth; - depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); - info = scheme_new_sfs_info(depth); - e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth); - SCHEME_VEC_ELS(data)[0] = e; - } - - return data; -} - -static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - return do_define_syntaxes_sfs(data, info); -} - -static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *l, *a; - - if (!info->pass) { - int depth; - depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); - - for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - info = scheme_new_sfs_info(depth); - a = scheme_sfs(a, info, depth); - SCHEME_CAR(l) = a; - } - } - - return data; -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -1202,7 +1200,7 @@ if (!info->pass) { for (i = size; i--; ) { - scheme_sfs_used(info, data->closure_map[i]); + sfs_used(info, data->closure_map[i]); } } else { /* Check whether we need to zero out any stack positions @@ -1225,13 +1223,13 @@ } } - return scheme_sfs_add_clears(expr, clears, 0); + return sfs_add_clears(expr, clears, 0); } if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) { SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS; - info = scheme_new_sfs_info(data->max_let_depth); - scheme_sfs_push(info, data->closure_size + data->num_params, 1); + info = new_sfs_info(data->max_let_depth); + sfs_push(info, data->closure_size + data->num_params, 1); if (has_tl) info->tlpos = info->stackpos + data->closure_size - 1; @@ -1266,7 +1264,7 @@ } } - code = scheme_sfs(data->body, info, data->max_let_depth); + code = sfs_passes(data->body, info); /* If any arguments go unused, and if there's a non-tail, non-immediate call in the body, then we flush the @@ -1288,7 +1286,7 @@ } if (SCHEME_PAIRP(clears)) - code = scheme_sfs_add_clears(code, clears, 1); + code = sfs_add_clears(code, clears, 1); if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR; @@ -1301,63 +1299,6 @@ } /*========================================================================*/ -/* module */ -/*========================================================================*/ - -static Scheme_Object * -module_sfs(Scheme_Object *data, SFS_Info *old_info) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *ex; - SFS_Info *info; - int i, j, cnt, let_depth; - - if (!old_info->for_mod) { - if (old_info->pass) - return data; - - info = scheme_new_sfs_info(m->max_let_depth); - info->for_mod = 1; - scheme_sfs(data, info, m->max_let_depth); - return data; - } - - info = old_info; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - scheme_sfs_start_sequence(info, cnt, 0); - - for (i = 0; i < cnt; i++) { - e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1); - SCHEME_VEC_ELS(m->bodies[0])[i] = e; - } - - if (!info->pass) { - for (j = m->num_phases; j-- > 1; ) { - cnt = SCHEME_VEC_SIZE(m->bodies[j]); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - ex = SCHEME_VEC_ELS(e)[1]; - - info = scheme_new_sfs_info(let_depth); - ex = scheme_sfs(ex, info, let_depth); - SCHEME_VEC_ELS(e)[1] = ex; - } - } - } - - return data; -} - -static Scheme_Object * -top_level_require_sfs(Scheme_Object *data, SFS_Info *rslv) -{ - return data; -} - -/*========================================================================*/ /* expressions */ /*========================================================================*/ @@ -1370,10 +1311,10 @@ p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_sfs_expr(e, info, p->ku.k.i1); + return sfs_expr(e, info, p->ku.k.i1); } -Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) +static Scheme_Object *sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) /* closure_self_pos == -2 => immediately in sequence */ { Scheme_Type type = SCHEME_TYPE(expr); @@ -1409,7 +1350,7 @@ case scheme_local_type: case scheme_local_unbox_type: if (!info->pass) - scheme_sfs_used(info, SCHEME_LOCAL_POS(expr)); + sfs_used(info, SCHEME_LOCAL_POS(expr)); else if (!SCHEME_GET_LOCAL_TYPE(expr)) { int pos, at_ip; pos = SCHEME_LOCAL_POS(expr); @@ -1441,9 +1382,6 @@ case scheme_sequence_type: expr = sfs_sequence(expr, info, closure_self_pos != -2); break; - case scheme_splice_sequence_type: - expr = sfs_sequence(expr, info, 0); - break; case scheme_branch_type: expr = sfs_branch(expr, info); break; @@ -1489,6 +1427,8 @@ scheme_signal_error("toplevel access not at expected place"); } break; + case scheme_static_toplevel_type: + break; case scheme_case_closure_type: { /* FIXME: maybe need to handle eagerly created closure */ @@ -1497,12 +1437,6 @@ case scheme_define_values_type: expr = define_values_sfs(expr, info); break; - case scheme_define_syntaxes_type: - expr = define_syntaxes_sfs(expr, info); - break; - case scheme_begin_for_syntax_type: - expr = begin_for_syntax_sfs(expr, info); - break; case scheme_set_bang_type: expr = set_sfs(expr, info); break; @@ -1512,9 +1446,6 @@ case scheme_begin0_sequence_type: expr = begin0_sfs(expr, info); break; - case scheme_require_form_type: - expr = top_level_require_sfs(expr, info); - break; case scheme_varref_form_type: expr = ref_sfs(expr, info); break; @@ -1527,9 +1458,6 @@ case scheme_case_lambda_sequence_type: expr = case_lambda_sfs(expr, info); break; - case scheme_module_type: - expr = module_sfs(expr, info); - break; case scheme_inline_variant_type: expr = inline_variant_sfs(expr, info); break; diff -Nru racket-6.12+ppa1/src/racket/src/sort.c racket-7.0+ppa1/src/racket/src/sort.c --- racket-6.12+ppa1/src/racket/src/sort.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/sort.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,170 @@ +/* + Racket + Copyright (c) 2004-2016 PLT Design Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" + +#ifdef MZ_XFORM +START_XFORM_SKIP; +#endif +#include "../gc2/my_qsort.c" +#ifdef MZ_XFORM +END_XFORM_SKIP; +#endif + +static int compare_syms(const void *_a, const void *_b) +{ + Scheme_Object *a = *(Scheme_Object **)_a; + Scheme_Object *b = *(Scheme_Object **)_b; + intptr_t l = SCHEME_SYM_LEN(a), i; + + MZ_ASSERT(SCHEME_SYMBOLP(a)); + MZ_ASSERT(SCHEME_SYMBOLP(b)); + + if (SCHEME_SYM_LEN(b) < l) + l = SCHEME_SYM_LEN(b); + + for (i = 0; i < l; i++) { + if (SCHEME_SYM_VAL(a)[i] != SCHEME_SYM_VAL(b)[i]) + return (SCHEME_SYM_VAL(a)[i] - SCHEME_SYM_VAL(b)[i]); + } + + return SCHEME_SYM_LEN(a) - SCHEME_SYM_LEN(b); +} + +static void sort_symbol_array(Scheme_Object **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_Object *), compare_syms); +} + +static int compare_nums(const void *_a, const void *_b) +/* also allow #fs */ +{ + Scheme_Object *a = *(Scheme_Object **)_a; + Scheme_Object *b = *(Scheme_Object **)_b; + + if (SCHEME_FALSEP(a)) + return -1; + else if (SCHEME_FALSEP(b)) + return 1; + + MZ_ASSERT(SCHEME_REALP(a)); + MZ_ASSERT(SCHEME_REALP(b)); + + if (scheme_bin_lt(a, b)) + return -1; + else if (scheme_bin_lt(b, a)) + return 1; + else + return 0; +} + +static void sort_number_array(Scheme_Object **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_Object *), compare_nums); +} + +static int compare_vars_at_resolve(const void *_a, const void *_b) +{ + Scheme_IR_Local *a = *(Scheme_IR_Local **)_a; + Scheme_IR_Local *b = *(Scheme_IR_Local **)_b; + return a->resolve.lex_depth - b->resolve.lex_depth; +} + +void scheme_sort_resolve_ir_local_array(Scheme_IR_Local **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_IR_Local *), compare_vars_at_resolve); +} + +/**************************************************************/ + +static int all_symbols(Scheme_Object **a, int c) +{ + while (c--) { + if (!SCHEME_SYMBOLP(a[c])) + return 0; + } + return 1; +} + +static int all_reals(Scheme_Object **a, int c) +{ + while (c--) { + if (!SCHEME_REALP(a[c])) + return 0; + } + return 1; +} + +Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *tree) +{ + intptr_t j, i, count; + Scheme_Object **a, *key; + + if (SCHEME_HASHTRP(tree)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)tree; + + count = ht->count; + if (!count) + return NULL; + + a = MALLOC_N(Scheme_Object *, count); + + j = -1; + i = 0; + while ((j = scheme_hash_tree_next(ht, j)) != -1) { + scheme_hash_tree_index(ht, j, &key, NULL); + a[i++] = key; + } + + MZ_ASSERT(i == count); + } else { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)tree; + + count = t->count; + + if (!count) + return NULL; + + a = MALLOC_N(Scheme_Object *, count); + j = 0; + + for (i = t->size; i--; ) { + if (t->vals[i]) { + a[j++] = t->keys[i]; + } + } + + MZ_ASSERT(j == count); + } + + if (SCHEME_SYMBOLP(a[0]) && all_symbols(a, count)) + sort_symbol_array(a, count); + else if (all_reals(a, count)) + sort_number_array(a, count); + else + return NULL; + + return a; +} diff -Nru racket-6.12+ppa1/src/racket/src/sstoinc.rkt racket-7.0+ppa1/src/racket/src/sstoinc.rkt --- racket-6.12+ppa1/src/racket/src/sstoinc.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/sstoinc.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ - -#lang racket/base - -(define to-zo? (member "--zo" (vector->list (current-command-line-arguments)))) - -(define DIGS-PER-LINE 20) - -(namespace-require ''#%kernel) - -(call-with-output-file (vector-ref (current-command-line-arguments) 0) #:exists 'replace - (lambda (outfile) - -(let loop () - (let ([expr (read)]) - (unless (eof-object? expr) - (let ([c (compile expr)] - [p (open-output-bytes)]) - (write c p) - (let ([s (get-output-bytes p)]) - (fprintf outfile " {\n SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {") - (let loop ([chars (bytes->list s)][pos 0]) - (unless (null? chars) - (let ([char (car chars)]) - (fprintf outfile "~a," char)) - (loop (cdr chars) - (if (= pos DIGS-PER-LINE) - (begin - (newline outfile) - 0) - (add1 pos))))) - (fprintf outfile "0};\n EVAL_ONE_SIZED_STR((char *)expr, ~a);\n" (bytes-length s)) - (fprintf outfile " }\n"))) - (loop)))))) diff -Nru racket-6.12+ppa1/src/racket/src/sstoinct.rkt racket-7.0+ppa1/src/racket/src/sstoinct.rkt --- racket-6.12+ppa1/src/racket/src/sstoinct.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/sstoinct.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -#lang racket/base - -(define (brackets->parens l) - (regexp-replace* #rx"\\[" - (regexp-replace* #rx"\\]" l ")") - "(")) - -(let loop ([ready? #f] [parens 0]) - (let ([l (read-line)]) - (cond - [(eof-object? l) - (when ready? - (printf ");\n"))] - [(regexp-match? #px"^\\s*$" l) - ;; just spaces; do nothing - (loop ready? parens)] - [(regexp-match #px"^\\s*;" l) - ;; comment; do nothing - (loop ready? parens)] - [else - (unless ready? - (printf " EVAL_ONE_STR(\n")) - (let* ([l (if (regexp-match? #rx"\"[^\"]*\\[[^\"]*\"" l) - l - (brackets->parens l))] - [l (regexp-replace* #rx"\\\\" l "\\\\\\\\")] - [l (regexp-replace* #rx"\"" l "\\\\\"")] - [l (regexp-replace* #rx"\t" l " ")] - [l (regexp-replace* #rx" +" l " ")] - [l (if (regexp-match? #rx"\"" l) - ;; Has a string - can't safely delete more spaces - l - (regexp-replace* #rx" \\(" l "("))] - [l - ;; Check for comments: - (if (regexp-match? #rx"[\"\\]" l) - ;; If there's a comment char, add a newline, - ;; just in case: - (if (regexp-match? #rx";" l) - (string-append l "\\n") - l) - (regexp-replace #rx";.*$" l ""))]) - (printf "\"~a\"\n" l) - (let* ([l - ;; Remove strings before counting parens: - (regexp-replace* - #rx"\"[^\"]*\"" - (regexp-replace* - #rx"\\\"" l "") - "")] - [l - ;; Convert sq brackets to parens and remove escaped - (regexp-replace* #rx"\\[()]" - (brackets->parens l) - "")]) - (let ([parens (for/fold ([parens parens]) ([c (in-string l)]) - (case c - [(#\() (+ parens 1)] - [(#\)) (- parens 1)] - [else parens]))]) - (if (zero? parens) - (begin - (printf ");\n") - (loop #f 0)) - (loop #t parens)))))]))) diff -Nru racket-6.12+ppa1/src/racket/src/startup.c racket-7.0+ppa1/src/racket/src/startup.c --- racket-6.12+ppa1/src/racket/src/startup.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/startup.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,74 @@ +/* + Racket + Copyright (c) 2004-2018 PLT Design Inc. + Copyright (c) 2000-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schvers.h" +#include "schminc.h" + +/* Generated by the build process in the build area; might simply + redirect to "startup.inc": */ +#include "cstartup.inc" + +#ifndef SCHEME_STARTUP_DEFINED + +static Scheme_Linklet *eval_linklet_string(const char *str, intptr_t len, int extract) +{ + Scheme_Object *port, *expr; + + if (len < 0) + len = strlen(str); + port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */ + + expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false); + + if (extract) { + /* expr is a linklet bundle; 'startup is mapped to the linklet */ + return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)SCHEME_PTR_VAL(expr), + scheme_intern_symbol("startup")); + } else { + return scheme_compile_and_optimize_linklet(scheme_datum_to_syntax(expr, scheme_false, 0), + scheme_intern_symbol("startup")); + } +} + +static Scheme_Linklet *startup_linklet() +{ +#define EVAL_ONE_STR(str) return eval_linklet_string(str, -1, 0) +#define EVAL_ONE_SIZED_STR(str, len) return eval_linklet_string(str, len, 1) + EVAL_STARTUP; +} + +void scheme_init_startup(void) +{ + /* called once (not per-place) */ +} + +void scheme_init_startup_instance(Scheme_Instance *inst) +{ + /* called per-places */ + scheme_instantiate_linklet_multi(startup_linklet(), inst, 0, NULL, 0); +} + +#endif diff -Nru racket-6.12+ppa1/src/racket/src/startup-glue.inc racket-7.0+ppa1/src/racket/src/startup-glue.inc --- racket-6.12+ppa1/src/racket/src/startup-glue.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/startup-glue.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,811 @@ +/* This file is #included by expander.inc when it is built via cify */ +#include "schmach.h" + +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +/* Disable the use of source or bytecode: */ +#define SCHEME_STARTUP_DEFINED + +#ifdef c_VALIDATE_DEBUG +static Scheme_Object *c_validate(Scheme_Object *s); +#endif + +THREAD_LOCAL_DECL(static struct startup_instance_top_t *c_startup_instance_top); + +typedef struct c_saved_mark_stack_t { + MZ_MARK_POS_TYPE pos; + MZ_MARK_STACK_TYPE stack; +} c_saved_mark_stack_t; + +/* Pulling the address of the thread-local table into a local variable + can have a big effect on compile time (not so much on run time) if + the the thread-local implementation is opqaue to the compiler. */ +#ifdef PREFER_TO_CACHE_THREAD_LOCAL +# define c_LINK_THREAD_LOCAL Thread_Local_Variables *c_racket_tls = scheme_get_thread_local_variables(); +# define c_current_runstack (c_racket_tls)->scheme_current_runstack_ +# define c_current_runstack_start (c_racket_tls)->scheme_current_runstack_start_ +# define c_current_thread (c_racket_tls)->scheme_current_thread_ +# define c__startup_instance_top (c_racket_tls)->c_startup_instance_top_ +# define c_scheme_fuel_counter (c_racket_tls)->scheme_fuel_counter_ +static c_saved_mark_stack_t c__push_mark_stack(Thread_Local_Variables *c_racket_tls) +{ + c_saved_mark_stack_t s; + s.pos = c_racket_tls->scheme_current_cont_mark_pos_; + s.stack = c_racket_tls->scheme_current_cont_mark_stack_; + c_racket_tls->scheme_current_cont_mark_pos_ = s.pos + 2; + return s; +} +# define c_push_mark_stack() c__push_mark_stack(c_racket_tls) +static void c__pop_mark_stack(Thread_Local_Variables *c_racket_tls, c_saved_mark_stack_t s) +{ + c_racket_tls->scheme_current_cont_mark_pos_ = s.pos; + c_racket_tls->scheme_current_cont_mark_stack_ = s.stack; +} +# define c_pop_mark_stack(s) c__pop_mark_stack(c_racket_tls, s) +#else +# define c_LINK_THREAD_LOCAL /* empty */ +# define c_current_runstack MZ_RUNSTACK +# define c_current_runstack_start MZ_RUNSTACK_START +# define c_current_thread scheme_current_thread +# define c__startup_instance_top c_startup_instance_top +# define c_scheme_fuel_counter scheme_fuel_counter +static c_saved_mark_stack_t c_push_mark_stack() +{ + c_saved_mark_stack_t s; + s.pos = MZ_CONT_MARK_POS; + s.stack = MZ_CONT_MARK_STACK; + MZ_CONT_MARK_POS = s.pos + 2; + return s; +} +static void c_pop_mark_stack(c_saved_mark_stack_t s) +{ + MZ_CONT_MARK_POS = s.pos; + MZ_CONT_MARK_STACK = s.stack; +} +#endif + +#define c_use_fuel() if (DECREMENT_FUEL(c_scheme_fuel_counter, 1) <= 0) scheme_out_of_fuel(); + + +#define c_RUNSTACK_INIT_VAL NULL + +static void scheme_instance_add(Scheme_Instance *inst, const char *name, Scheme_Object *val) +{ + Scheme_Bucket *b; + b = scheme_instance_variable_bucket(scheme_intern_symbol(name), inst); + b->val = val; + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST | GLOB_IS_CONSISTENT; +} + +#define c_check_runstack_space(max_depth, runstack, runstack_start) \ + ((runstack - runstack_start) < (max_depth + SCHEME_TAIL_COPY_THRESHOLD)) + +static int c_check_overflow_or_runstack_space(int max_depth, Scheme_Object **runstack, Scheme_Object **runstack_start) +{ +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + return 1; + } + } +#endif + return c_check_runstack_space(max_depth, runstack, runstack_start); +} + +static void c_check_top_runstack_depth(int max_depth) +{ + if (c_check_runstack_space(max_depth, MZ_RUNSTACK, MZ_RUNSTACK_START)) { + scheme_log_abort("initial runstack is too small to start up"); + abort(); + } +} + + +static Scheme_Object *do_apply_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + + if (c_check_runstack_space(p->ku.k.i2, MZ_RUNSTACK, MZ_RUNSTACK_START)) { + return (Scheme_Object *)scheme_enlarge_runstack(p->ku.k.i2, (void *(*)())do_apply_k); + } else { + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2; + +#ifdef c_VALIDATE_DEBUG + { + int i; + c_validate(o); + for (i = 0; i < p->ku.k.i1; i++) + c_validate(argv[i]); + } +#endif + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return _scheme_apply_multi(o, p->ku.k.i1, argv); + } +} + +static Scheme_Object *c_handle_overflow_or_space(Scheme_Object *proc, int argc, Scheme_Object **argv, int runstack_space) +{ + Scheme_Thread *p; + Scheme_Object **argv2; + + /* stash before allocation: */ + p = scheme_current_thread; + p->ku.k.p1 = (void *)proc; + p->ku.k.i1 = argc; + p->ku.k.i2 = runstack_space; + p->ku.k.p2 = (void *)argv; + + argv2 = MALLOC_N(Scheme_Object*, argc); + + p = scheme_current_thread; + argv = (Scheme_Object **)p->ku.k.p2; + + memcpy(argv2, argv, sizeof(Scheme_Object *) * argc); + if (argv == MZ_RUNSTACK) + memset(argv, 0, sizeof(Scheme_Object *) * argc); /* space safety */ + + p->ku.k.p2 = (void *)argv2; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + return scheme_handle_stack_overflow(do_apply_k); + } +#endif + + return (Scheme_Object *)scheme_enlarge_runstack(runstack_space, (void *(*)())do_apply_k); +} + +static Scheme_Object *c_ensure_args_in_place_rest(int argc, Scheme_Object **argv, Scheme_Object **runbase, + int direct_args, int rest_args, int rest_arg_used, + Scheme_Object *self) +{ + Scheme_Object **runstack = runbase - direct_args - rest_args; + int i; + + if (argc == direct_args) { + /* Copy into runbase. If there's a rest arg not supplied, then the + copy may be shifting down, and we need to add a `null` value + for the rest arg. */ + for (i = 0; i < direct_args; i++) + runstack[i] = argv[i]; + if (rest_args) + runstack[direct_args] = scheme_null; + } else { + /* Need to build a list and then copy or shift up */ + Scheme_Object *l = scheme_null; + if (rest_arg_used) { + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, argv); + MZ_GC_VAR_IN_REG(1, self); + MZ_GC_REG(); + for (i = argc; i-- > direct_args; ) + l = scheme_make_pair(argv[i], l); + MZ_GC_UNREG(); + } + + runstack[direct_args] = l; + for (i = direct_args; i--; ) + runstack[i] = argv[i]; + } + + return self; +} + +#define c_ensure_args_in_place(argc, argv, runbase) \ + if (argv != (runbase - argc)) (void)c_ensure_args_in_place_rest(argc, argv, runbase, argc, 0, 0, NULL) +#define c_rest_arg_used 1 +#define c_rest_arg_unused 0 + + +static Scheme_Object *c_wrong_arity(const char *name, int argc, Scheme_Object **argv) +{ + scheme_wrong_count(name, -2, 0, argc, argv); + return NULL; +} + +static mzshort *convert_arities(int mina, const char *a) +{ + /* FIXME: On a big-endian machine, we need to reverse the byte order in arities */ + return (mzshort *)a; +} + +static Scheme_Object *scheme_make_prim_w_case_arity(Scheme_Prim *prim, const char *name, mzshort mina, const char *arities) +{ + Scheme_Object *p; + mzshort *a; + p = scheme_make_prim_w_arity(prim, name, 0, 0); + ((Scheme_Primitive_Proc *)p)->mina = mina; + a = convert_arities(mina, arities); + ((Scheme_Primitive_Proc *)p)->mu.cases = a; + return p; +} + +static Scheme_Object *scheme_make_prim_closure_w_case_arity(Scheme_Primitive_Closure_Proc *prim, + int size, Scheme_Object **vals, + const char *name, + mzshort mina, const char *arities) +{ + Scheme_Object *p; + mzshort *a; + p = scheme_make_prim_closure_w_arity(prim, size, vals, name, 0, 0); + ((Scheme_Primitive_Proc *)p)->mina = mina; + a = convert_arities(mina, arities); + ((Scheme_Primitive_Proc *)p)->mu.cases = a; + return p; +} + +#define c_extract_prim(o) ((Scheme_Prim *)((Scheme_Primitive_Proc *)o)->prim_val) + +static MZ_INLINE int c_same_obj(Scheme_Object *a, Scheme_Object *b) +{ + return SAME_OBJ(a, b); +} + +static MZ_INLINE Scheme_Object *c_malloc_struct(int c) +{ + return scheme_malloc_tagged(sizeof(Scheme_Structure) + (((c) - mzFLEX_DELTA) * sizeof(Scheme_Object *))); +} + +static MZ_INLINE void c_struct_set_type(Scheme_Object *s, Scheme_Object *_st) +{ + Scheme_Struct_Type *stype = (Scheme_Struct_Type *)_st; + s->type = (stype->proc_attr ? scheme_proc_struct_type : scheme_structure_type); + ((Scheme_Structure *)s)->stype = stype; +} + +#define c_STRUCT_ELS(o) (((Scheme_Structure *)(o))->slots) + +static MZ_INLINE int c_is_struct_instance(Scheme_Object *v, Scheme_Object *_st) +{ + Scheme_Struct_Type *st = (Scheme_Struct_Type *)_st; + if (SCHEME_CHAPERONEP(v)) + v = SCHEME_CHAPERONE_VAL(v); + return (SCHEME_STRUCTP(v) + && (((Scheme_Structure *)v)->stype->parent_types[st->name_pos] == st)); +} + +static MZ_INLINE int c_is_authentic_struct_instance(Scheme_Object *v, Scheme_Object *_st) +{ + Scheme_Struct_Type *st = (Scheme_Struct_Type *)_st; + return (SCHEME_STRUCTP(v) + && (((Scheme_Structure *)v)->stype->parent_types[st->name_pos] == st)); +} + +static MZ_INLINE Scheme_Object *c_struct_ref(Scheme_Object *v, int pos) +{ + if (SCHEME_CHAPERONEP(v)) + return scheme_struct_ref(v, pos); + else + return ((Scheme_Structure *)v)->slots[pos]; +} + +static MZ_INLINE Scheme_Object *c_authentic_struct_ref(Scheme_Object *v, int pos) +{ + return ((Scheme_Structure *)v)->slots[pos]; +} + +static MZ_INLINE Scheme_Object *c_struct_set(Scheme_Object *v, Scheme_Object *a, int pos) +{ + if (SCHEME_CHAPERONEP(v)) + scheme_struct_set(v, pos, a); + else + ((Scheme_Structure *)v)->slots[pos] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_authentic_struct_set(Scheme_Object *v, Scheme_Object *a, int pos) +{ + ((Scheme_Structure *)v)->slots[pos] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_struct_property_ref(Scheme_Object *v, Scheme_Object *prop) +{ + return scheme_chaperone_struct_type_property_ref(prop, v); +} + +static MZ_INLINE int c_int_lt(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_INT_VAL(a) < SCHEME_INT_VAL(b); +} + +static MZ_INLINE int c_int_gt(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_INT_VAL(a) > SCHEME_INT_VAL(b); +} + +static MZ_INLINE Scheme_Object *c_int_add(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) + SCHEME_INT_VAL(b)); +} + +static MZ_INLINE Scheme_Object *c_int_sub(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) - SCHEME_INT_VAL(b)); +} + +#if 0 +static MZ_INLINE Scheme_Object *c_int_mult(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) * SCHEME_INT_VAL(b)); +} +#endif + +static MZ_INLINE Scheme_Object *c_int_and(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) & SCHEME_INT_VAL(b)); +} + +static MZ_INLINE Scheme_Object *c_int_rshift(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) >> SCHEME_INT_VAL(b)); +} + +/* Can GC if not in fixnum range */ +static Scheme_Object *c_number_add1(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) { + intptr_t v; + v = SCHEME_INT_VAL(a); + if (v < 0x3FFFFFFF) + return scheme_make_integer(v + 1); + } + + return scheme_bin_plus(a, scheme_make_integer(1)); +} + +/* Can GC if not in fixnum range */ +static Scheme_Object *c_number_sub1(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) { + intptr_t v; + v = SCHEME_INT_VAL(a); + if (v > -0x3FFFFFFF) + return scheme_make_integer(v - 1); + } + + return scheme_bin_minus(a, scheme_make_integer(1)); +} + +#define c_SCHEME_BIN_NUMBER_COMP(id, op, scheme_id) \ + static MZ_INLINE int id(Scheme_Object *a, Scheme_Object *b) { \ + if (SCHEME_INTP(a) && SCHEME_INTP(b)) \ + return (SCHEME_INT_VAL(a) op SCHEME_INT_VAL(b)); \ + return scheme_id(a, b); \ + } +c_SCHEME_BIN_NUMBER_COMP(c_number_eq, ==, scheme_bin_eq) +c_SCHEME_BIN_NUMBER_COMP(c_number_gt, >, scheme_bin_gt) +c_SCHEME_BIN_NUMBER_COMP(c_number_lt, <, scheme_bin_lt) +c_SCHEME_BIN_NUMBER_COMP(c_number_gt_eq, >=, scheme_bin_gt_eq) +c_SCHEME_BIN_NUMBER_COMP(c_number_lt_eq, <=, scheme_bin_lt_eq) + +static int c_number_zerop(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) + return SCHEME_INT_VAL(a) == 0; + else + return scheme_is_zero(a); +} + +#define c_SCHEME_PREDFUNC(id, ID) static MZ_INLINE int id(Scheme_Object *v) { return ID(v); } + +c_SCHEME_PREDFUNC(c_scheme_truep, SCHEME_TRUEP) +c_SCHEME_PREDFUNC(c_scheme_falsep, SCHEME_FALSEP) +c_SCHEME_PREDFUNC(c_scheme_nullp, SCHEME_NULLP) +c_SCHEME_PREDFUNC(c_scheme_eof_objectp, SCHEME_EOFP) +c_SCHEME_PREDFUNC(c_scheme_voidp, SCHEME_VOIDP) +c_SCHEME_PREDFUNC(c_scheme_boolp, SCHEME_BOOLP) +c_SCHEME_PREDFUNC(c_scheme_pairp, SCHEME_PAIRP) +c_SCHEME_PREDFUNC(c_scheme_numberp, SCHEME_NUMBERP) +c_SCHEME_PREDFUNC(c_scheme_charp, SCHEME_CHARP) +c_SCHEME_PREDFUNC(c_scheme_chaperone_vectorp, SCHEME_CHAPERONE_VECTORP) +c_SCHEME_PREDFUNC(c_scheme_chaperone_boxp, SCHEME_CHAPERONE_BOXP) +c_SCHEME_PREDFUNC(c_scheme_symbolp, SCHEME_SYMBOLP) +c_SCHEME_PREDFUNC(c_scheme_keywordp, SCHEME_KEYWORDP) +c_SCHEME_PREDFUNC(c_scheme_char_stringp, SCHEME_CHAR_STRINGP) +c_SCHEME_PREDFUNC(c_scheme_byte_stringp, SCHEME_BYTE_STRINGP) +c_SCHEME_PREDFUNC(c_scheme_pathp, SCHEME_PATHP) + +static MZ_INLINE int c_scheme_hashp(Scheme_Object *v) +{ + if (SCHEME_NP_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return SCHEME_HASHTRP(v) || SCHEME_HASHTP(v) || SCHEME_BUCKTP(v); +} + +/* GC *not* possible during scheme_is_list */ +static MZ_INLINE int c_scheme_listp(Scheme_Object *v) +{ + return scheme_is_list(v); +} + +static MZ_INLINE int c_scheme_char_eq(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_CHAR_VAL(a) == SCHEME_CHAR_VAL(b); +} + +static MZ_INLINE int c_scheme_char_whitespacep(Scheme_Object *c) +{ + return scheme_isspace(SCHEME_CHAR_VAL(c)); +} + +static MZ_INLINE Scheme_Object *c_authentic_vector_ref(Scheme_Object *v, Scheme_Object *i) +{ + return SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]; +} + +static MZ_INLINE Scheme_Object *c_vector_ref(Scheme_Object *v, Scheme_Object *i) +{ + if (SCHEME_NP_CHAPERONEP(v)) + return scheme_chaperone_vector_ref(v, SCHEME_INT_VAL(i)); + else + return SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]; +} + +static MZ_INLINE Scheme_Object *c_vector_set(Scheme_Object *v, Scheme_Object *i, Scheme_Object *a) +{ + if (SCHEME_NP_CHAPERONEP(v)) + scheme_chaperone_vector_set(v, SCHEME_INT_VAL(i), a); + SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_vector_length(Scheme_Object *v) +{ + if (SCHEME_NP_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return scheme_make_integer(SCHEME_VEC_SIZE(v)); +} + +static MZ_INLINE Scheme_Object *c_string_ref(Scheme_Object *v, Scheme_Object *i) +{ + mzchar c = SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]; + return scheme_make_character(c); +} + +static MZ_INLINE Scheme_Object *c_bytes_ref(Scheme_Object *v, Scheme_Object *i) +{ + int c = SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]; + return scheme_make_integer(c); +} + +static MZ_INLINE Scheme_Object *c_box_ref(Scheme_Object *b) +{ + if (SCHEME_NP_CHAPERONEP(b)) + return scheme_unbox(b); + else + return SCHEME_BOX_VAL(b); +} + +static MZ_INLINE Scheme_Object *c_box_set(Scheme_Object *b, Scheme_Object *a) +{ + if (SCHEME_NP_CHAPERONEP(b)) + scheme_set_box(b, a); + else + SCHEME_BOX_VAL(b) = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_weak_box_value(Scheme_Object *o) +{ + o = SCHEME_BOX_VAL(o); + if (!o) + return scheme_false; + return o; +} + +#if 0 +static MZ_INLINE Scheme_Object *c_weak_box_value2(Scheme_Object *o, Scheme_Object *defval) +{ + o = SCHEME_BOX_VAL(o); + if (!o) + return defval; + return o; +} +#endif + +static Scheme_Object *c_make_list1(Scheme_Object *v) +{ + return scheme_make_pair(v, scheme_null); +} + +static Scheme_Object *c_make_list2(Scheme_Object *v1, Scheme_Object *v2) +{ + /* A trick to avoid GC registration: put v1 in the wrong place, then move it */ + Scheme_Object *p = scheme_make_pair(v2, v1); + p = scheme_make_pair(scheme_null, p); + SCHEME_CAR(p) = SCHEME_CDR(SCHEME_CDR(p)); + SCHEME_CDR(SCHEME_CDR(p)) = scheme_null; + return p; +} + +static MZ_INLINE Scheme_Object *c_pair_car(Scheme_Object *p) +{ + return SCHEME_CAR(p); +} + +static MZ_INLINE Scheme_Object *c_pair_cdr(Scheme_Object *p) +{ + return SCHEME_CDR(p); +} + +static MZ_INLINE Scheme_Object *c_pair_caar(Scheme_Object *p) +{ + return SCHEME_CAR(SCHEME_CAR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cdar(Scheme_Object *p) +{ + return SCHEME_CDR(SCHEME_CAR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cadr(Scheme_Object *p) +{ + return SCHEME_CAR(SCHEME_CDR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cddr(Scheme_Object *p) +{ + return SCHEME_CDR(SCHEME_CDR(p)); +} + +/* Only when `default` is definitely not a procedure */ +/* Can GC */ +static Scheme_Object *c_hash_ref(Scheme_Object *ht, Scheme_Object *key, Scheme_Object *defval) +{ + Scheme_Object *v; + + /* The fast path doesn't trigger any GCs: */ + if (SCHEME_HASHTP(ht)) { + if (!((Scheme_Hash_Table *)ht)->make_hash_indices) { + v = scheme_eq_hash_get((Scheme_Hash_Table *)ht, key); + if (v) + return v; + else + return defval; + } + } else if (SCHEME_HASHTRP(ht)) { + if (SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(ht))) { + v = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)ht, key); + if (v) + return v; + else + return defval; + } + } + + { + Scheme_Object *argv[3]; + MZ_GC_DECL_REG(3); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_VAR_IN_REG(2, argv[2]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + argv[2] = defval; + + v = scheme_checked_hash_ref(3, argv); + + MZ_GC_UNREG(); + + return v; + } +} + +/* Can GC */ +static Scheme_Object *c_hash_ref2(Scheme_Object *ht, Scheme_Object *key) +{ + Scheme_Object *argv[2], *v; + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + + v = scheme_checked_hash_ref(2, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC */ +static Scheme_Object *c_hash_set(Scheme_Object *ht, Scheme_Object *key, Scheme_Object *val) +{ + Scheme_Object *argv[3], *v; + MZ_GC_DECL_REG(3); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_VAR_IN_REG(2, argv[2]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + argv[2] = val; + + v = scheme_hash_table_put(3, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC in the general case */ +static Scheme_Object *c_hash_count(Scheme_Object *ht) +{ + if (SCHEME_CHAPERONEP(ht)) + ht = SCHEME_CHAPERONE_VAL(ht); + + if (SCHEME_HASHTP(ht)) { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht; + return scheme_make_integer(t->count); + } else if (SCHEME_HASHTRP(ht)) { + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht; + return scheme_make_integer(t->count); + } else { + Scheme_Object *argv[1], *v; + MZ_GC_DECL_REG(1); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_REG(); + + argv[0] = ht; + + v = scheme_checked_hash_count(1, argv); + + MZ_GC_UNREG(); + + return v; + } +} + +/* Can GC */ +static Scheme_Object *c_hash_iterate_first(Scheme_Object *ht) +{ + Scheme_Object *argv[1], *v; + MZ_GC_DECL_REG(1); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_REG(); + + argv[0] = ht; + + v = scheme_hash_table_iterate_start(1, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_first(Scheme_Object *ht) +{ + if (SCHEME_NP_CHAPERONEP(ht)) ht = SCHEME_CHAPERONE_VAL(ht); + return scheme_unsafe_hash_tree_start((Scheme_Hash_Tree *)ht); +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_next(Scheme_Object *ht, Scheme_Object *i) +{ + if (SCHEME_NP_CHAPERONEP(ht)) ht = SCHEME_CHAPERONE_VAL(ht); + return scheme_unsafe_hash_tree_next((Scheme_Hash_Tree *)ht, i); +} + +/* Can GC in case of chaperone */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_key(Scheme_Object *ht, Scheme_Object *idx) +{ + Scheme_Object *key; + Scheme_Hash_Tree *subtree; + int i; + + scheme_unsafe_hash_tree_subtree(ht, idx, &subtree, &i); + key = subtree->els[i]; + + if (SCHEME_NP_CHAPERONEP(ht)) + return scheme_chaperone_hash_key("unsafe-immutable-hash-iterate-key", ht, idx); + else + return key; +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_key_value(Scheme_Object *ht, Scheme_Object *idx) +{ + Scheme_Object *key, *res[2], *v; + Scheme_Hash_Tree *subtree; + int i; + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, res[0]); + MZ_GC_VAR_IN_REG(1, res[1]); + MZ_GC_REG(); + + scheme_unsafe_hash_tree_subtree(ht, idx, &subtree, &i); + key = subtree->els[i]; + + if (SCHEME_NP_CHAPERONEP(ht)) { + scheme_chaperone_hash_key_value("unsafe-immutable-hash-iterate-key+value", + ht, subtree->els[i], &res[0], &res[1], 0); + } else { + res[0] = key; + res[1] = scheme_unsafe_hash_tree_access(subtree, i); + } + + v = scheme_values(2, res); + + MZ_GC_UNREG(); + + return v; +} + +static MZ_INLINE Scheme_Object *c_prefab_struct_key(Scheme_Object *v) +{ + return scheme_prefab_struct_key(v); +} + +static Scheme_Object *c_zero_values() +{ + Scheme_Thread *p = scheme_current_thread; + p->ku.multiple.count = 0; + p->ku.multiple.array = NULL; + return SCHEME_MULTIPLE_VALUES; +} + +static MZ_INLINE Scheme_Object *c_last_use(Scheme_Object **r, int i) +{ + Scheme_Object *v = r[i]; + r[i] = NULL; + return v; +} + +/* static MZ_INLINE void c_no_use(Scheme_Object **r, int i) { r[i] = NULL; } */ +#define c_no_use(r, i) r[i] = NULL + +#ifndef c_VALIDATE_DEBUG + +# define SCHEME_UNBOX_VARIABLE(var) (*(Scheme_Object **)(var)) +# define SCHEME_UNBOX_VARIABLE_LHS(var) SCHEME_UNBOX_VARIABLE(var) + +static Scheme_Object *scheme_box_variable(Scheme_Object *v) +{ + Scheme_Object **b; + b = MALLOC_ONE(Scheme_Object *); + b[0] = v; + return (Scheme_Object *)b; +} + +#else + +# define SCHEME_UNBOX_VARIABLE(var) SCHEME_BOX_VAL(var) +# define SCHEME_UNBOX_VARIABLE_LHS(var) SCHEME_BOX_VAL(var) + +static Scheme_Object *scheme_box_variable(Scheme_Object *v) +{ + return scheme_box(v); +} + +static Scheme_Object *c_validate(Scheme_Object *s) +{ + if ((SCHEME_TYPE(s) < 0) || (SCHEME_TYPE(s) > _scheme_last_type_)) + abort(); + return s; +} + +#endif + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif diff -Nru racket-6.12+ppa1/src/racket/src/startup.inc racket-7.0+ppa1/src/racket/src/startup.inc --- racket-6.12+ppa1/src/racket/src/startup.inc 2016-10-07 19:56:36.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/startup.inc 2018-07-27 22:12:02.000000000 +0000 @@ -1,1491 +1,78748 @@ - EVAL_ONE_STR( -"(module #%min-stx '#%kernel" -"(#%require '#%paramz" -"(for-syntax '#%kernel))" -"(#%provide unless when" -" and or" -" cond" -" let let* letrec" -" let*-values" -" parameterize" -" define)" -"(begin-for-syntax " -"(define-values(here-stx)(quote-syntax here)))" -"(define-syntaxes(unless)" -"(lambda(stx)" -"(let-values(((s)(syntax->list stx)))" -"(datum->syntax here-stx" -"(list 'if(cadr s)" -"(void)" -"(cons 'begin(cddr s)))))))" -"(define-syntaxes(when)" -"(lambda(stx)" -"(let-values(((s)(syntax->list stx)))" -"(datum->syntax here-stx" -"(list 'if(cadr s)" -"(cons 'begin(cddr s))" -"(void))))))" -"(define-syntaxes(and)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax #t)" -"(if(null?(cdr s))" -"(car s)" -"(datum->syntax here-stx" -"(list 'if(car s)(cons 'and(cdr s)) #f)))))))" -"(define-syntaxes(or)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax #f)" -"(if(null?(cdr s))" -"(car s)" -"(datum->syntax here-stx" -"(list 'let-values(list(list(list 'x)" -"(car s)))" -"(list 'if 'x 'x(cons 'or(cdr s))))))))))" -"(define-syntaxes(let)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(if(symbol?(syntax-e(car s)))" -"(let-values(((clauses)" -"(map(lambda(c)" -"(syntax->list c))" -"(syntax->list(cadr s)))))" -"(list 'letrec-values(list(list(list(car s))" -"(list* 'lambda" -"(map car clauses)" -"(cddr s))))" -"(cons(car s)(map cadr clauses))))" -"(list* 'let-values(map(lambda(c)" -"(let-values(((c)(syntax->list c)))" -"(cons(list(car c))" -"(cdr c))))" -"(syntax->list(car s)))" -"(cdr s)))))))" -"(define-syntaxes(letrec)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(list* 'letrec-values(map(lambda(c)" -"(let-values(((c)(syntax->list c)))" -"(cons(list(car c))" -"(cdr c))))" -"(syntax->list(car s)))" -"(cdr s))))))" -"(define-syntaxes(let*)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((fst)(syntax->list(car s))))" -"(datum->syntax " -" here-stx" -"(if(null? fst)" -"(list* 'let-values()(cdr s))" -"(list 'let(list(car fst))" -"(list* 'let*(cdr fst)(cdr s)))))))))" -"(define-syntaxes(let*-values)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((fst)(syntax->list(car s))))" -"(datum->syntax " -" here-stx" -"(if(null? fst)" -"(list* 'let-values()(cdr s))" -"(list 'let-values(list(car fst))" -"(list* 'let*-values(cdr fst)(cdr s)))))))))" -"(define-syntaxes(parameterize)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((bindings)(apply append" -"(map syntax->list(syntax->list(car s))))))" -"(syntax-arm" -"(datum->syntax " -" here-stx" -"(list 'with-continuation-mark" -" 'parameterization-key" -"(list* 'extend-parameterization" -" '(continuation-mark-set-first #f parameterization-key)" -" bindings)" -"(list* 'let-values()" -"(cdr s)))))))))" -"(define-syntaxes(cond)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax(void))" -"(datum->syntax " -" here-stx" -"(let-values(((a)(syntax->list(car s))))" -"(if(eq? '=>(syntax-e(cadr a)))" -"(list 'let-values(list(list '(v)(car a)))" -"(list* 'cond" -"(list 'v(list(caddr a) 'v))" -"(cdr s)))" -"(list 'if(if(eq?(syntax-e(car a)) 'else)" -" #t" -"(car a))" -"(list* 'let-values '()(cdr a))" -"(cons 'cond(cdr s))))))))))" -"(define-syntaxes(define)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(if(symbol?(syntax-e(car s)))" -"(list 'define-values(list(car s))(cadr s))" -"(let-values(((a)(syntax-e(car s))))" -"(list 'define-values(list(car a))" -"(list* 'lambda(cdr a)" -"(cdr s))))))))))" -); - EVAL_ONE_STR( -"(module #%utils '#%kernel" -"(#%require '#%min-stx '#%paramz)" -"(#%provide path-string?" -" normal-case-path" -" path-replace-extension" -" path-add-extension" -" reroot-path" -" find-col-file" -" collection-path" -" collection-file-path" -" find-library-collection-paths" -" find-library-collection-links" -" path-list-string->path-list" -" find-executable-path" -" load/use-compiled" -" embedded-load" -" call-with-default-reading-parameterization" -" find-main-collects" -" find-main-config)" -"(define-values(path-string?)" -"(lambda(s)" -"(or(path? s) " -"(and(string? s)" -"(or(relative-path? s)" -"(absolute-path? s))))))" -"(define-values(bsbs)(string #\\u5C #\\u5C))" -"(define-values(normal-case-path)" -"(lambda(s)" -"(unless(or(path-for-some-system? s)" -"(path-string? s))" -" (raise-argument-error 'normal-path-case \"(or/c path-for-some-system? path-string?)\" s))" -"(cond" -"((if(path-for-some-system? s)" -"(eq?(path-convention-type s) 'windows)" -"(eq?(system-type) 'windows))" -"(let((str(if(string? s) s(bytes->string/locale(path->bytes s)))))" -" (if (regexp-match? #rx\"^[\\u5C][\\u5C][?][\\u5C]\" str)" -"(if(string? s)" -"(string->path s)" -" s)" -"(let((s(string-locale-downcase str)))" -"(bytes->path " -"(string->bytes/locale" -" (regexp-replace* #rx\"/\" " -" (if (regexp-match? #rx\"[/\\u5C][. ]+[/\\u5C]*$\" s)" -" s" -" (regexp-replace* #rx\"\\u5B .\\u5D+([/\\u5C]*)$\" s \"\\u005C1\"))" -" bsbs))" -" 'windows)))))" -"((string? s)(string->path s))" -"(else s))))" -"(define-values(reroot-path)" -"(lambda(p root)" -"(unless(or(path-string? p)(path-for-some-system? p))" -" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 0 p root))" -"(unless(or(path-string? root)(path-for-some-system? root))" -" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 1 p root))" -"(define conv(if(path-for-some-system? p)" -"(path-convention-type p)" -"(system-path-convention-type)))" -"(unless(or(complete-path? p)" -"(eq?(system-path-convention-type) conv))" -"(raise-arguments-error 'reroot-path" -" \"path is not complete and not the platform's convention\"" -" \"path\" p" -" \"platform convention type\" (system-path-convention-type)))" -"(unless(eq?(if(path-for-some-system? root)" -"(path-convention-type root)" -"(system-path-convention-type))" -" conv)" -"(raise-arguments-error 'reroot-path" -" \"given paths use different conventions\"" -" \"path\" p" -" \"root path\" root))" -"(define c-p(normal-case-path(cleanse-path(if(complete-path? p)" -" p" -"(path->complete-path p)))))" -"(define bstr(path->bytes c-p))" -"(cond " -"((eq? conv 'unix) " -" (if (bytes=? bstr #\"/\")" -"(if(path-for-some-system? root)" -" root" -"(string->path root))" -"(build-path root(bytes->path(subbytes(path->bytes c-p) 1) conv))))" -"((eq? conv 'windows)" -"(build-path" -" root" -"(bytes->path" -"(cond" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\[a-z]:\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4 5) #\"\\\\\" (subbytes bstr 6)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\\" bstr)" -" (bytes-append #\"UNC\\\\\" (subbytes bstr 2)))" -" ((regexp-match? #rx\"^[a-z]:\" bstr)" -"(bytes-append(subbytes bstr 0 1)(subbytes bstr 2))))" -" conv))))))" -"(define-values(find-executable-path)" -"(case-lambda " -"((program libpath reverse?)" -"(unless(path-string? program) " -" (raise-argument-error 'find-executable-path \"path-string?\" program))" -"(unless(or(not libpath)(and(path-string? libpath) " -"(relative-path? libpath)))" -" (raise-argument-error 'find-executable-path \"(or/c #f (and/c path-string? relative-path?))\" libpath))" -"(letrec((found-exec" -"(lambda(exec-name)" -"(if libpath" -"(let-values(((base name isdir?)(split-path exec-name)))" -"(let((next" -"(lambda()" -"(let((resolved(resolve-path exec-name)))" -"(cond" -"((equal? resolved exec-name) #f)" -"((relative-path? resolved)" -"(found-exec(build-path base resolved)))" -"(else(found-exec resolved)))))))" -"(or(and reverse?(next))" -"(if(path? base)" -"(let((lib(build-path base libpath)))" -"(and(or(directory-exists? lib) " -"(file-exists? lib))" -" lib))" -" #f)" -"(and(not reverse?)(next)))))" -" exec-name))))" -"(if(and(relative-path? program)" -"(let-values(((base name dir?)(split-path program)))" -"(eq? base 'relative)))" -"(let((paths-str(environment-variables-ref(current-environment-variables)" -" #\"PATH\"))" -"(win-add(lambda(s)(if(eq?(system-type) 'windows) " -" (cons (bytes->path #\".\") s) " -" s))))" -"(let loop((paths(win-add " -"(if paths-str" -"(path-list-string->path-list(bytes->string/locale paths-str #\\?)" -" null)" -" null))))" -"(if(null? paths)" -" #f" -"(let*((base(path->complete-path(car paths)))" -"(name(build-path base program)))" -"(if(file-exists? name)" -"(found-exec name)" -"(loop(cdr paths)))))))" -"(let((p(path->complete-path program)))" -"(and(file-exists? p)(found-exec p))))))" -"((program libpath)(find-executable-path program libpath #f))" -"((program)(find-executable-path program #f #f))))" -"(define-values(path-list-string->path-list)" -"(let((r(byte-regexp(string->bytes/utf-8" -"(let((sep(if(eq?(system-type) 'windows)" -" \";\"\n" -" \":\")))" -" (format \"([^~a]*)~a(.*)\" sep sep)))))" -"(cons-path(lambda(default s l) " -"(let((s(if(eq?(system-type) 'windows)" -" (regexp-replace* #rx#\"\\\"\" s #\"\")" -" s)))" -" (if (bytes=? s #\"\")" -"(append default l)" -"(cons(bytes->path s)" -" l))))))" -"(lambda(s default)" -"(unless(or(bytes? s)" -"(string? s))" -" (raise-argument-error 'path-list-string->path-list \"(or/c bytes? string?)\" s))" -"(unless(and(list? default)" -"(andmap path? default))" -" (raise-argument-error 'path-list-string->path-list \"(listof path?)\" default))" -"(let loop((s(if(string? s)" -"(string->bytes/utf-8 s)" -" s)))" -"(let((m(regexp-match r s)))" -"(if m" -"(cons-path default(cadr m)(loop(caddr m)))" -"(cons-path default s null)))))))" -"(define(call-with-default-reading-parameterization thunk)" -"(if(and(procedure? thunk)" -"(procedure-arity-includes? thunk 0))" -"(parameterize((read-case-sensitive #t)" -"(read-square-bracket-as-paren #t)" -"(read-curly-brace-as-paren #t)" -"(read-square-bracket-with-tag #f)" -"(read-curly-brace-with-tag #f)" -"(read-accept-box #t)" -"(read-accept-compiled #f)" -"(read-accept-bar-quote #t)" -"(read-accept-graph #t)" -"(read-decimal-as-inexact #t)" -"(read-cdot #f)" -"(read-accept-dot #t)" -"(read-accept-infix-dot #t)" -"(read-accept-quasiquote #t)" -"(read-accept-reader #f)" -"(read-accept-lang #t)" -"(current-readtable #f))" -"(thunk))" -"(raise-argument-error 'call-with-default-reading-parameterization" -" \"(procedure-arity-includes/c 0)\"" -" thunk)))" -"(define-values(-check-relpath)" -"(lambda(who s)" -"(unless(path-string? s)" -" (raise-argument-error who \"path-string?\" s))" -"(unless(relative-path? s)" -"(raise-arguments-error who" -" \"invalid relative path\"" -" \"path\" s))))" -"(define-values(-check-collection)" -"(lambda(who collection collection-path)" -"(-check-relpath who collection) " -"(for-each(lambda(p)(-check-relpath who p)) collection-path)))" -"(define-values(-check-fail)" -"(lambda(who fail)" -"(unless(and(procedure? fail)" -"(procedure-arity-includes? fail 1))" -" (raise-argument-error who \"(any/c . -> . any)\" fail))))" -"(define-values(collection-path)" -"(lambda(fail collection collection-path) " -"(-check-collection 'collection-path collection collection-path)" -"(-check-fail 'collection-path fail)" -"(find-col-file fail" -" collection collection-path" -" #f" -" #f)))" -"(define-values(collection-file-path)" -"(lambda(fail check-compiled? file-name collection collection-path) " -"(-check-relpath 'collection-file-path file-name)" -"(-check-collection 'collection-file-path collection collection-path)" -"(-check-fail 'collection-file-path fail)" -"(find-col-file fail" -" collection collection-path" -" file-name" -" check-compiled?)))" -"(define-values(find-main-collects)" -"(lambda()" -"(cache-configuration" -" 0" -"(lambda()" -"(exe-relative-path->complete-path(find-system-path 'collects-dir))))))" -"(define-values(find-main-config)" -"(lambda()" -"(cache-configuration" -" 1" -"(lambda()" -"(exe-relative-path->complete-path(find-system-path 'config-dir))))))" -"(define-values(get-config-table)" -"(lambda(d)" -" (let ((p (and d (build-path d \"config.rktd\"))))" -"(or(and p" -"(file-exists? p)" -"(with-input-from-file p" -"(lambda()" -"(let((v(call-with-default-reading-parameterization read)))" -"(and(hash? v)" -" v)))))" -" #hash()))))" -"(define-values(get-installation-name)" -"(lambda(config-table)" -"(hash-ref config-table" -" 'installation-name " -"(version))))" -"(define-values(coerce-to-path)" -"(lambda(p)" -"(cond" -"((string? p)(collects-relative-path->complete-path(string->path p)))" -"((bytes? p)(collects-relative-path->complete-path(bytes->path p)))" -"((path? p)(collects-relative-path->complete-path p))" -"(else p))))" -"(define-values(collects-relative-path->complete-path)" -"(lambda(p)" -"(cond" -"((complete-path? p) p)" -"(else" -"(path->complete-path p(or(find-main-collects)" -"(current-directory)))))))" -"(define-values(exe-relative-path->complete-path)" -"(lambda(collects-path)" -"(cond" -"((complete-path? collects-path)(simplify-path collects-path))" -"((absolute-path? collects-path)" -"(let((exec(path->complete-path" -"(find-executable-path(find-system-path 'exec-file))" -"(find-system-path 'orig-dir))))" -"(let-values(((base name dir?)(split-path exec)))" -"(simplify-path(path->complete-path collects-path base)))))" -"(else" -"(let((p(find-executable-path(find-system-path 'exec-file) collects-path #t)))" -"(and p(simplify-path p)))))))" -"(define-values(add-config-search)" -"(lambda(ht key orig-l)" -"(let((l(hash-ref ht key #f)))" -"(if l" -"(let loop((l l))" -"(cond" -"((null? l) null)" -"((not(car l))(append orig-l(loop(cdr l))))" -"(else(cons(coerce-to-path(car l))(loop(cdr l))))))" -" orig-l))))" -"(define-values(find-library-collection-links)" -"(lambda()" -"(let*((ht(get-config-table(find-main-config)))" -"(lf(coerce-to-path" -"(or(hash-ref ht 'links-file #f)" -"(build-path(or(hash-ref ht 'share-dir #f)" -" (build-path 'up \"share\"))" -" \"links.rktd\")))))" -"(append" -"(list #f)" -"(if(and(use-user-specific-search-paths)" -"(use-collection-link-paths))" -"(list(build-path(find-system-path 'addon-dir)" -"(get-installation-name ht)" -" \"links.rktd\"))" -" null)" -"(if(use-collection-link-paths)" -"(add-config-search" -" ht" -" 'links-search-files" -"(list lf))" -" null)))))" -"(define-values(links-cache)(make-weak-hash))" -"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))" -"(define-values(file->stamp)" -"(lambda(path old-stamp)" -"(cond" -"((and old-stamp" -"(cdr old-stamp)" -"(not(sync/timeout 0(cdr old-stamp))))" -" old-stamp)" -"(else" -"(call-with-continuation-prompt" -"(lambda()" +#define EVAL_STARTUP EVAL_ONE_STR(startup_source) +static const char *startup_source = +"(linklet" +"()" +"((boot boot)" +"(1/bound-identifier=? bound-identifier=?)" +"(1/compile compile)" +"(compile-to-linklets compile-to-linklets)" +"(1/current-compile current-compile)" +"(1/current-compiled-file-roots current-compiled-file-roots)" +"(1/current-eval current-eval)" +"(1/current-library-collection-links current-library-collection-links)" +"(1/current-library-collection-paths current-library-collection-paths)" +"(1/current-load current-load)" +"(1/current-load/use-compiled current-load/use-compiled)" +"(1/current-namespace current-namespace)" +"(datum->kernel-syntax datum->kernel-syntax)" +"(1/datum->syntax datum->syntax)" +"(declare-primitive-module! declare-primitive-module!)" +"(1/dynamic-require dynamic-require)" +"(embedded-load embedded-load)" +"(1/eval eval)" +"(eval$1 eval-top-level)" +"(expand$1 expand)" +"(1/find-library-collection-links find-library-collection-links)" +"(1/find-library-collection-paths find-library-collection-paths)" +"(find-main-config find-main-config)" +"(1/identifier-binding identifier-binding)" +"(identifier? identifier?)" +"(1/load load)" +"(1/load-extension load-extension)" +"(1/load/use-compiled load/use-compiled)" +"(make-namespace make-namespace)" +"(maybe-raise-missing-module maybe-raise-missing-module)" +"(maybe-syntax->datum maybe-syntax->datum)" +"(1/module->language-info module->language-info)" +"(1/module-compiled-exports module-compiled-exports)" +"(1/module-compiled-indirect-exports module-compiled-indirect-exports)" +"(1/module-declared? module-declared?)" +"(1/module-path-index-join module-path-index-join)" +"(1/module-path-index? module-path-index?)" +"(1/module-path? module-path?)" +"(1/module-predefined? module-predefined?)" +"(namespace->instance namespace->instance)" +"(1/namespace-attach-module namespace-attach-module)" +"(1/namespace-attach-module-declaration namespace-attach-module-declaration)" +"(namespace-datum-introduce namespace-datum-introduce)" +"(1/namespace-mapped-symbols namespace-mapped-symbols)" +"(1/namespace-module-identifier namespace-module-identifier)" +"(1/namespace-require namespace-require)" +"(1/namespace-syntax-introduce namespace-syntax-introduce)" +"(1/read read)" +"(1/read-accept-compiled read-accept-compiled)" +"(1/read-syntax read-syntax)" +"(1/resolved-module-path? resolved-module-path?)" +"(seal seal)" +"(1/syntax->datum syntax->datum)" +"(1/syntax-debug-info syntax-debug-info)" +"(1/syntax-e syntax-e)" +"(syntax-property$1 syntax-property)" +"(1/syntax-shift-phase-level syntax-shift-phase-level)" +"(syntax?$1 syntax?)" +"(1/use-collection-link-paths use-collection-link-paths)" +"(1/use-compiled-file-check use-compiled-file-check)" +"(1/use-compiled-file-paths use-compiled-file-paths)" +"(1/use-user-specific-search-paths use-user-specific-search-paths))" +"(define-values" +"(qq-append)" +" (lambda (a_0 b_0) (begin (if (list? a_0) (append a_0 b_0) (raise-argument-error 'unquote-splicing \"list?\" a_0)))))" +"(define-values(call/ec) call-with-escape-continuation)" +"(define-values" +"(bad-list$1)" +" (lambda (who_0 orig-l_0) (begin 'bad-list (raise-mismatch-error who_0 \"not a proper list: \" orig-l_0))))" +"(define-values" +"(memq memv member)" +"(let-values()" +"(let-values()" +"(values" +"(let-values(((memq_0)" +"(lambda(v_0 orig-l_1)" +"(begin" +" 'memq" +"((letrec-values(((loop_0)" +"(lambda(ls_0)" +"(begin" +" 'loop" +"(if(null? ls_0)" +"(let-values() #f)" +"(if(not(pair? ls_0))" +"(let-values()(bad-list$1 'memq orig-l_1))" +"(if(eq? v_0(car ls_0))" +"(let-values() ls_0)" +"(let-values()(loop_0(cdr ls_0))))))))))" +" loop_0)" +" orig-l_1)))))" +" memq_0)" +"(let-values(((memv_0)" +"(lambda(v_1 orig-l_2)" +"(begin" +" 'memv" +"((letrec-values(((loop_1)" +"(lambda(ls_1)" +"(begin" +" 'loop" +"(if(null? ls_1)" +"(let-values() #f)" +"(if(not(pair? ls_1))" +"(let-values()(bad-list$1 'memv orig-l_2))" +"(if(eqv? v_1(car ls_1))" +"(let-values() ls_1)" +"(let-values()(loop_1(cdr ls_1))))))))))" +" loop_1)" +" orig-l_2)))))" +" memv_0)" +"(let-values(((default_0)" +"(let-values(((member_0)" +"(lambda(v_2 orig-l_3)" +"(begin" +" 'member" +"((letrec-values(((loop_2)" +"(lambda(ls_2)" +"(begin" +" 'loop" +"(if(null? ls_2)" +"(let-values() #f)" +"(if(not(pair? ls_2))" +"(let-values()(bad-list$1 'member orig-l_3))" +"(if(equal? v_2(car ls_2))" +"(let-values() ls_2)" +"(let-values()(loop_2(cdr ls_2))))))))))" +" loop_2)" +" orig-l_3)))))" +" member_0)))" +"(let-values(((member_1)" +"(case-lambda" +"((v_3 orig-l_4)(begin 'member(default_0 v_3 orig-l_4)))" +"((v_4 orig-l_5 eq?_0)" +"(begin" +"(if(if(procedure? eq?_0)(procedure-arity-includes? eq?_0 2) #f)" +"(void)" +" (raise-argument-error 'member \"(procedure-arity-includes/c 2)\" eq?_0))" +"((let-values(((member_2)" +"(lambda(v_5 orig-l_6)" +"(begin" +" 'member" +"((letrec-values(((loop_3)" +"(lambda(ls_3)" +"(begin" +" 'loop" +"(if(null? ls_3)" +"(let-values() #f)" +"(if(not(pair? ls_3))" +"(let-values()(bad-list$1 'member orig-l_6))" +"(if(eq?_0 v_5(car ls_3))" +"(let-values() ls_3)" +"(let-values()(loop_3(cdr ls_3))))))))))" +" loop_3)" +" orig-l_6)))))" +" member_2)" +" v_4" +" orig-l_5))))))" +" member_1))))))" +"(define-values" +"(current-parameterization)" +"(lambda()(begin(extend-parameterization(continuation-mark-set-first #f parameterization-key)))))" +"(define-values" +"(call-with-parameterization)" +"(lambda(paramz_0 thunk_0)" +"(begin" +"(begin" +"(if(parameterization? paramz_0)" +"(void)" +" (let-values () (raise-argument-error 'call-with-parameterization \"parameterization?\" 0 paramz_0 thunk_0)))" +"(if(if(procedure? thunk_0)(procedure-arity-includes? thunk_0 0) #f)" +"(void)" +" (let-values () (raise-argument-error 'call-with-parameterization \"(-> any)\" 1 paramz_0 thunk_0)))" +"(with-continuation-mark parameterization-key paramz_0(thunk_0))))))" +"(define-values" +"(struct:break-paramz make-break-paramz break-paramz? break-paramz-ref break-paramz-set!)" +"(make-struct-type 'break-parameterization #f 1 0 #f))" +"(define-values" +"(current-break-parameterization)" +"(lambda()(begin(make-break-paramz(continuation-mark-set-first #f break-enabled-key)))))" +"(define-values" +"(call-with-break-parameterization)" +"(lambda(paramz_1 thunk_1)" +"(begin" +"(begin" +"(if(break-paramz? paramz_1)" +"(void)" +"(let-values()" +" (raise-argument-error 'call-with-break-parameterization \"break-parameterization?\" 0 paramz_1 thunk_1)))" +"(if(if(procedure? thunk_1)(procedure-arity-includes? thunk_1 0) #f)" +"(void)" +" (let-values () (raise-argument-error 'call-with-parameterization \"(-> any)\" 1 paramz_1 thunk_1)))" +"(begin0" +"(with-continuation-mark break-enabled-key(break-paramz-ref paramz_1 0)(begin(check-for-break)(thunk_1)))" +"(check-for-break))))))" +"(define-values" +"(select-handler/no-breaks)" +"(lambda(e_0 bpz_0 l_0)" +"(begin" "(with-continuation-mark" -" exception-handler-key" -"(lambda(exn)" -"(abort-current-continuation " -" stamp-prompt-tag" -"(if(exn:fail:filesystem? exn)" -"(lambda() #f)" -"(lambda()(raise exn)))))" -"(let((dir-evt" -"(and(vector-ref(system-type 'fs-change) 2) " -"(let loop((path path))" -"(let-values(((base name dir?)(split-path path)))" -"(and(path? base)" -"(if(directory-exists? base)" -"(filesystem-change-evt base(lambda() #f))" -"(loop base))))))))" -"(if(not(file-exists? path))" -"(cons #f dir-evt)" -"(let((evt(and(vector-ref(system-type 'fs-change) 2) " -"(filesystem-change-evt path(lambda() #f)))))" -"(when dir-evt(filesystem-change-evt-cancel dir-evt))" -"(cons" -"(let((p(open-input-file path)))" -"(dynamic-wind" -" void" -"(lambda()" -"(let((bstr(read-bytes 8192 p)))" -"(if(and(bytes? bstr)" -"((bytes-length bstr) . >= . 8192))" -"(apply" -" bytes-append" -"(cons" -" bstr" -"(let loop()" -"(let((bstr(read-bytes 8192 p)))" -"(if(eof-object? bstr)" -" null" -"(cons bstr(loop)))))))" -" bstr)))" -"(lambda()(close-input-port p))))" -" evt))))))" -" stamp-prompt-tag)))))" -"(define-values(no-file-stamp?)" -"(lambda(a)" -"(or(not a)" -"(not(car a)))))" -"(define-values(get-linked-collections)" -"(lambda(links-path)" -"(call-with-escape-continuation" -"(lambda(esc)" -"(define-values(make-handler)" -"(lambda(ts)" -"(lambda(exn)" -"(if(exn:fail? exn)" -"(let((l(current-logger)))" -"(when(log-level? l 'error)" -"(log-message l 'error" -"(format" -" \"error reading collection links file ~s: ~a\"" -" links-path" -"(exn-message exn))" -"(current-continuation-marks))))" -"(void))" -"(when ts" -"(hash-set! links-cache links-path(cons ts #hasheq())))" -"(if(exn:fail? exn)" -"(esc(make-hasheq))" -" exn))))" +" break-enabled-key" +"(make-thread-cell #f)" +"((letrec-values(((loop_4)" +"(lambda(l_1)" +"(begin" +" 'loop" +"(if(null? l_1)" +"(let-values()(raise e_0))" +"(if((caar l_1) e_0)" +"(let-values()" +"(begin0" +"((cdar l_1) e_0)" +"(with-continuation-mark break-enabled-key bpz_0(check-for-break))))" +"(let-values()(loop_4(cdr l_1)))))))))" +" loop_4)" +" l_0)))))" +"(define-values(false-thread-cell)(make-thread-cell #f))" +"(define-values(handler-prompt-key)(make-continuation-prompt-tag 'handler-prompt-tag))" +"(define-values" +"(call-handled-body)" +"(lambda(bpz_1 handle-proc_0 body-thunk_0)" +"(begin" "(with-continuation-mark" -" exception-handler-key" -"(make-handler #f)" -"(let*((links-stamp+cache(hash-ref links-cache links-path '(#f . #hasheq())))" -"(a-links-stamp(car links-stamp+cache))" -"(ts(file->stamp links-path a-links-stamp)))" -"(if(not(equal? ts a-links-stamp))" +" break-enabled-key" +" false-thread-cell" +"(call-with-continuation-prompt" +"(lambda(bpz_2 body-thunk_1)" +"(with-continuation-mark" +" break-enabled-key" +" bpz_2" "(with-continuation-mark" " exception-handler-key" -"(make-handler ts)" -"(call-with-default-reading-parameterization" -"(lambda()" -"(let((v(if(no-file-stamp? ts)" -" null" -"(let((p(open-input-file links-path 'binary)))" -"(dynamic-wind" -" void" -"(lambda() " -"(begin0" -"(read p)" -"(unless(eof-object?(read p))" -" (error \"expected a single S-expression\"))))" -"(lambda()(close-input-port p)))))))" -"(unless(and(list? v)" -"(andmap(lambda(p)" -"(and(list? p)" -"(or(= 2(length p))" -"(= 3(length p)))" -"(or(string?(car p))" -"(eq? 'root(car p))" -"(eq? 'static-root(car p)))" -"(path-string?(cadr p))" -"(or(null?(cddr p))" -"(regexp?(caddr p)))))" -" v))" -" (error \"ill-formed content\"))" -"(let((ht(make-hasheq))" -"(dir(let-values(((base name dir?)(split-path links-path)))" -" base)))" -"(for-each" -"(lambda(p)" -"(when(or(null?(cddr p))" -"(regexp-match?(caddr p)(version)))" -"(let((dir(simplify-path" -"(path->complete-path(cadr p) dir))))" -"(cond" -"((eq?(car p) 'static-root)" -"(for-each" -"(lambda(sub)" -"(when(directory-exists?(build-path dir sub))" -"(let((k(string->symbol(path->string sub))))" -"(hash-set! ht k(cons dir(hash-ref ht k null))))))" -"(directory-list dir)))" -"((eq?(car p) 'root)" -"(unless(hash-ref ht #f #f)" -"(hash-set! ht #f null))" -"(hash-for-each" -" ht" -"(lambda(k v)" -"(hash-set! ht k(cons dir v)))))" -"(else" -"(let((s(string->symbol(car p))))" -"(hash-set! ht s(cons(box dir)" -"(hash-ref ht s null)))))))))" -" v)" -"(hash-for-each" -" ht" -"(lambda(k v)(hash-set! ht k(reverse v))))" -"(hash-set! links-cache links-path(cons ts ht))" -" ht)))))" -"(cdr links-stamp+cache))))))))" -"(define-values(normalize-collection-reference)" -"(lambda(collection collection-path)" -"(cond" -"((string? collection)" -" (let ((m (regexp-match-positions #rx\"/+\" collection)))" -"(if m" -"(cond" -"((=(caar m)(sub1(string-length collection)))" -"(values(substring collection 0(caar m)) collection-path))" -"(else" -"(values(substring collection 0(caar m))" -"(cons(substring collection(cdar m))" -" collection-path))))" -"(values collection collection-path))))" -"(else" -"(let-values(((base name dir?)(split-path collection)))" -"(if(eq? base 'relative)" -"(values name collection-path)" -"(normalize-collection-reference base(cons name collection-path))))))))" -"(define-values(find-col-file)" -"(lambda(fail collection collection-path file-name check-compiled?)" -"(let-values(((collection collection-path)" -"(normalize-collection-reference collection collection-path)))" -"(let((all-paths(let((sym(string->symbol " -"(if(path? collection)" -"(path->string collection)" -" collection))))" -"(let loop((l(current-library-collection-links)))" -"(cond" -"((null? l) null)" -"((not(car l))" -"(append " -"(current-library-collection-paths)" -"(loop(cdr l))))" -"((hash?(car l))" -"(append" -"(map box(hash-ref(car l) sym null))" -"(hash-ref(car l) #f null)" -"(loop(cdr l))))" -"(else" -"(let((ht(get-linked-collections(car l))))" -"(append " -"(hash-ref ht sym null)" -"(hash-ref ht #f null)" -"(loop(cdr l))))))))))" -"(define-values(done)" -"(lambda(p)" -"(if file-name(build-path p file-name) p)))" -"(define-values(*build-path-rep)" -"(lambda(p c)" -"(if(path? p)" -"(build-path p c)" -"(unbox p))))" -"(define-values(*directory-exists?)" -"(lambda(orig p)" -"(if(path? orig)" -"(directory-exists? p)" -" #t)))" -"(define-values(to-string)(lambda(p)(if(path? p)(path->string p) p)))" -"(let cloop((paths all-paths)(found-col #f))" -"(if(null? paths)" -"(if found-col" -"(done found-col)" -"(let((rest-coll" -"(if(null? collection-path)" -" \"\"" -"(apply" -" string-append" -"(let loop((cp collection-path))" -"(if(null?(cdr cp))" -"(list(to-string(car cp)))" -" (list* (to-string (car cp)) \"/\" (loop (cdr cp)))))))))" -"(define-values(filter)" -"(lambda(f l)" -"(if(null? l)" -" null" -"(if(f(car l))" -"(cons(car l)(filter f(cdr l)))" -"(filter f(cdr l))))))" -"(fail" -" (format \"collection not found\\n collection: ~s\\n in collection directories:~a~a\" " -"(if(null? collection-path)" -"(to-string collection)" -" (string-append (to-string collection) \"/\" rest-coll))" -"(apply" -" string-append" -"(map(lambda(p)" -" (format \"\\n ~a ~a\" \" \" p))" -"(let((len(length all-paths))" -"(clen(length(current-library-collection-paths))))" -"(if((- len clen) . < . 5)" -" all-paths" -"(append(current-library-collection-paths)" -" (list (format \"... [~a additional linked and package directories]\"" -"(- len clen))))))))" -"(if(ormap box? all-paths)" -" (format \"\\n sub-collection: ~s\\n in parent directories:~a\"" -" rest-coll " -"(apply" -" string-append" -"(map(lambda(p)" -" (format \"\\n ~a\" (unbox p)))" -"(filter box? all-paths))))" -" \"\")))))" -"(let((dir(*build-path-rep(car paths) collection)))" -"(if(*directory-exists?(car paths) dir)" -"(let((cpath(apply build-path dir collection-path)))" -"(if(if(null? collection-path)" -" #t" -"(directory-exists? cpath))" -"(if file-name" -"(if(or(file-exists?/maybe-compiled cpath file-name" -" check-compiled?)" -"(let((alt-file-name" -"(let*((file-name(if(path? file-name)" -"(path->string file-name)" -" file-name))" -"(len(string-length file-name)))" -"(and(len . >= . 4)" -" (string=? \".rkt\" (substring file-name (- len 4)))" -" (string-append (substring file-name 0 (- len 4)) \".ss\")))))" -"(and alt-file-name" -"(file-exists?/maybe-compiled cpath alt-file-name" -" check-compiled?))))" -"(done cpath)" -"(cloop(cdr paths)(or found-col cpath)))" -"(done cpath))" -"(cloop(cdr paths) found-col)))" -"(cloop(cdr paths) found-col)))))))))" -"(define-values(file-exists?/maybe-compiled)" -"(lambda(dir path check-compiled?)" -"(or(file-exists?(build-path dir path))" -"(and check-compiled?" -" (let ((try-path (path-add-extension path #\".zo\"))" -"(modes(use-compiled-file-paths))" -"(roots(current-compiled-file-roots)))" -"(ormap(lambda(d)" -"(ormap(lambda(mode)" -"(file-exists?" -"(let((p(build-path dir mode try-path)))" -"(cond" -"((eq? d 'same) p)" -"((relative-path? d)(build-path p d))" -"(else(reroot-path p d))))))" -" modes))" -" roots))))))" -"(define-values(check-extension-call)" -"(lambda(s sfx who)" -"(unless(or(path-for-some-system? s)" -"(path-string? s))" -" (raise-argument-error who \"(or/c path-for-some-system? path-string?)\" 0 s sfx))" -"(unless(or(string? sfx)(bytes? sfx))" -" (raise-argument-error who \"(or/c string? bytes?)\" 1 s sfx))" -"(let-values(((base name dir?)(split-path s)))" -"(when(not base)" -" (raise-mismatch-error who \"cannot add an extension to a root path: \" s))" -"(values base name))))" -"(define-values(path-adjust-extension)" -"(lambda(name sep rest-bytes s sfx)" -"(let-values(((base name)(check-extension-call s sfx name)))" -"(define bs(path-element->bytes name))" -"(define finish" -"(lambda(i sep i2)" +"(lambda(e_1)(abort-current-continuation handler-prompt-key e_1))" +"(body-thunk_1))))" +" handler-prompt-key" +" handle-proc_0" +" bpz_1" +" body-thunk_0)))))" +"(define-values" +"(call-with-exception-handler)" +"(lambda(exnh_0 thunk_2)(begin(begin0(with-continuation-mark exception-handler-key exnh_0(thunk_2))(void)))))" +"(define-values(not-there)(gensym))" +"(define-values" +"(do-hash-update)" +"(lambda(who_1 mut?_0 set_0 ht_0 key_0 xform_0 default_1)" +"(begin" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()" +"(begin" +"(if(if(hash? ht_0)(if mut?_0(not(immutable? ht_0))(immutable? ht_0)) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_1" +" (if mut?_0 \"(and/c hash? (not/c immutable?))\" \"(and/c hash? immutable?)\")" +" ht_0)))" +"(if(if(procedure? xform_0)(procedure-arity-includes? xform_0 1) #f)" +"(void)" +" (let-values () (raise-argument-error who_1 \"(any/c . -> . any/c)\" xform_0))))))" +"(let-values(((v_6)(hash-ref ht_0 key_0 default_1)))" +"(if(eq? v_6 not-there)" +" (raise-mismatch-error who_1 \"no value found for key: \" key_0)" +"(set_0 ht_0 key_0(xform_0 v_6))))))))" +"(define-values" +"(hash-update)" +"(case-lambda" +"((ht_1 key_1 xform_1 default_2)(begin(do-hash-update 'hash-update #f hash-set ht_1 key_1 xform_1 default_2)))" +"((ht_2 key_2 xform_2)(hash-update ht_2 key_2 xform_2 not-there))))" +"(define-values" +"(hash-update!)" +"(case-lambda" +"((ht_3 key_3 xform_3 default_3)(begin(do-hash-update 'hash-update! #t hash-set! ht_3 key_3 xform_3 default_3)))" +"((ht_4 key_4 xform_4)(hash-update! ht_4 key_4 xform_4 not-there))))" +"(define-values" +"(hash-ref!)" +"(lambda(ht_5 key_5 new_0)" +"(begin" +"(begin" +"(if(if(hash? ht_5)(not(immutable? ht_5)) #f)" +"(void)" +" (let-values () (raise-argument-error 'hash-ref! \"(and/c hash? (not/c immutable?))\" 0 ht_5 key_5 new_0)))" +"(let-values(((v_7)(hash-ref ht_5 key_5 not-there)))" +"(if(eq? not-there v_7)" +"(let-values(((n_0)(if(procedure? new_0)(new_0) new_0)))(begin(hash-set! ht_5 key_5 n_0) n_0))" +" v_7))))))" +"(define-values" +"(path-string?)" +"(lambda(s_0)" +"(begin" +"(let-values(((or-part_0)(path? s_0)))" +"(if or-part_0" +" or-part_0" +"(if(string? s_0)" +"(let-values(((or-part_1)(relative-path? s_0)))(if or-part_1 or-part_1(absolute-path? s_0)))" +" #f))))))" +"(define-values(bsbs)(string '#\\\\ '#\\\\))" +"(define-values" +"(normal-case-path)" +"(lambda(s_1)" +"(begin" +"(begin" +"(if(let-values(((or-part_2)(path-for-some-system? s_1)))(if or-part_2 or-part_2(path-string? s_1)))" +"(void)" +" (let-values () (raise-argument-error 'normal-path-case \"(or/c path-for-some-system? path-string?)\" s_1)))" +"(if(if(path-for-some-system? s_1)(eq?(path-convention-type s_1) 'windows)(eq?(system-type) 'windows))" +"(let-values()" +"(let-values(((str_0)(if(string? s_1) s_1(bytes->string/locale(path->bytes s_1)))))" +" (if (regexp-match? '#rx\"^[\\\\][\\\\][?][\\\\]\" str_0)" +"(if(string? s_1)(string->path s_1) s_1)" +"(let-values(((s_2)(string-locale-downcase str_0)))" +"(bytes->path" +"(string->bytes/locale" +"(regexp-replace*" +" '#rx\"/\"" +" (if (regexp-match? '#rx\"[/\\\\][. ]+[/\\\\]*$\" s_2)" +" s_2" +" (regexp-replace* '#rx\"[ .]+([/\\\\]*)$\" s_2 \"\\\\1\"))" +" bsbs))" +" 'windows)))))" +"(if(string? s_1)(let-values()(string->path s_1))(let-values() s_1)))))))" +"(define-values" +"(check-extension-call)" +"(lambda(s_3 sfx_0 who_2 sep_0 trust-sep?_0)" +"(begin" +"(begin" +"(let-values(((err-msg_0 err-index_0)" +"(if(not" +"(let-values(((or-part_3)(path-for-some-system? s_3)))" +"(if or-part_3 or-part_3(path-string? s_3))))" +" (let-values () (values \"(or/c path-for-some-system? path-string?)\" 0))" +"(if(not(let-values(((or-part_4)(string? sfx_0)))(if or-part_4 or-part_4(bytes? sfx_0))))" +" (let-values () (values \"(or/c string? bytes?)\" 1))" +"(if(not" +"(let-values(((or-part_5) trust-sep?_0))" +"(if or-part_5" +" or-part_5" +"(let-values(((or-part_6)(string? sep_0)))" +"(if or-part_6 or-part_6(bytes? sep_0))))))" +" (let-values () (values \"(or/c string? bytes?)\" 2))" +"(let-values()(values #f #f)))))))" +"(if err-msg_0" +"(let-values()" +"(if trust-sep?_0" +"(raise-argument-error who_2 err-msg_0 err-index_0 s_3 sfx_0)" +"(raise-argument-error who_2 err-msg_0 err-index_0 s_3 sfx_0 sep_0)))" +"(void)))" +"(let-values(((base_0 name_0 dir?_0)(split-path s_3)))" +"(begin" +"(if(not base_0)" +" (let-values () (raise-mismatch-error who_2 \"cannot add an extension to a root path: \" s_3))" +"(void))" +"(values base_0 name_0)))))))" +"(define-values" +"(path-adjust-extension)" +"(lambda(name_1 sep_1 rest-bytes_0 s_4 sfx_1 trust-sep?_1)" +"(begin" +"(let-values(((base_1 name_2)(check-extension-call s_4 sfx_1 name_1 sep_1 trust-sep?_1)))" +"(let-values(((bs_0)(path-element->bytes name_2)))" +"(let-values(((finish_0)" +"(lambda(i_0 sep_2 i2_0)" +"(begin" +" 'finish" "(bytes->path-element" "(bytes-append" -"(subbytes bs 0 i)" -" sep" -"(rest-bytes bs i2)" -"(if(string? sfx)" -"(string->bytes/locale sfx(char->integer #\\?))" -" sfx))" -"(if(path-for-some-system? s)" -"(path-convention-type s)" -"(system-path-convention-type)))))" -"(let((new-name(letrec-values(((loop)" -"(lambda(i)" -"(if(zero? i)" -" (finish (bytes-length bs) #\"\" (bytes-length bs))" -"(let-values(((i)(sub1 i)))" -"(if(and(not(zero? i))" -"(eq?(char->integer #\\.)(bytes-ref bs i)))" -"(finish i sep(add1 i))" -"(loop i)))))))" -"(loop(bytes-length bs)))))" -"(if(path-for-some-system? base)" -"(build-path base new-name)" -" new-name)))))" -"(define-values(path-replace-extension)" -"(lambda(s sfx)" -" (path-adjust-extension 'path-replace-extension #\"\" (lambda (bs i) #\"\") s sfx)))" -"(define-values(path-add-extension)" -"(lambda(s sfx)" -" (path-adjust-extension 'path-add-extension #\"_\" subbytes s sfx)))" -"(define-values(load/use-compiled)" -"(lambda(f)((current-load/use-compiled) f #f)))" -"(define-values(find-library-collection-paths)" -"(case-lambda" -"(()(find-library-collection-paths null null))" -"((extra-collects-dirs)(find-library-collection-paths extra-collects-dirs null))" -"((extra-collects-dirs post-collects-dirs)" -"(let((user-too?(use-user-specific-search-paths))" -"(cons-if(lambda(f r)(if f(cons f r) r)))" -"(config-table(get-config-table(find-main-config))))" -"(path-list-string->path-list" -"(if user-too?" -"(let((c(environment-variables-ref(current-environment-variables)" -" #\"PLTCOLLECTS\")))" -"(if c" -"(bytes->string/locale c #\\?)" -" \"\"))" -" \"\")" -"(add-config-search" -" config-table" -" 'collects-search-dirs" -"(cons-if" -"(and user-too?" -"(build-path(find-system-path 'addon-dir)" -"(get-installation-name config-table)" -" \"collects\"))" -"(let loop((l(append" -" extra-collects-dirs" -"(list(find-system-path 'collects-dir))" -" post-collects-dirs)))" -"(if(null? l)" -" null" -"(let*((collects-path(car l))" -"(v(exe-relative-path->complete-path collects-path)))" -"(if v" -"(cons(simplify-path(path->complete-path v(current-directory)))" -"(loop(cdr l)))" -"(loop(cdr l)))))))))))))" -"(define(embedded-load start end str)" -"(let*((s(if str" -" str" -"(let*((sp(find-system-path 'exec-file)) " -"(exe(find-executable-path sp #f))" -"(start(or(string->number start) 0))" -"(end(or(string->number end) 0)))" -"(with-input-from-file exe " -"(lambda()" -"(file-position(current-input-port) start)" -"(read-bytes(max 0(- end start))))))))" -"(p(open-input-bytes s)))" -"(let loop()" -"(let((e(parameterize((read-accept-compiled #t)" -"(read-accept-reader #t)" -"(read-accept-lang #t)" -"(read-on-demand-source #t))" -"(read p))))" -"(unless(eof-object? e)" -"(eval e)" -"(loop)))))))" -); - EVAL_ONE_STR( -"(module #%place-struct '#%kernel" -"(define-values(struct:TH-place-channel TH-place-channel TH-place-channel? " -" TH-place-channel-ref TH-place-channel-set!)" -"(make-struct-type 'TH-place-channel #f 2 0 #f(list(cons prop:evt(lambda(x)(TH-place-channel-ref x 0))))))" -"(define-values(TH-place-channel-in TH-place-channel-out) " -"(values" -"(lambda(x)(TH-place-channel-ref x 0))" -"(lambda(x)(TH-place-channel-ref x 1))))" -"(#%provide " -" struct:TH-place-channel" -" TH-place-channel " -" TH-place-channel? " -" TH-place-channel-in" -" TH-place-channel-out))" -); - EVAL_ONE_STR( -"(module #%boot '#%kernel" -"(#%require '#%min-stx '#%utils '#%paramz)" -"(#%provide boot seal orig-paramz)" -"(define-values(dll-suffix)" -"(system-type 'so-suffix))" -"(define-values(default-load/use-compiled)" -"(let*((resolve(lambda(s)" -"(if(complete-path? s)" -" s" -"(let((d(current-load-relative-directory)))" -"(if d(path->complete-path s d) s)))))" -"(use-seconds?(eq?(use-compiled-file-check) 'modify-seconds))" -"(date-of-1(lambda(a)" -"(let((v(file-or-directory-modify-seconds a #f(lambda() #f))))" -"(and v(cons a(if use-seconds? v 0))))))" -"(date-of(lambda(a modes roots)" -"(ormap(lambda(root-dir)" -"(ormap" -"(lambda(compiled-dir)" -"(let((a(a root-dir compiled-dir)))" -"(date-of-1 a)))" -" modes))" -" roots)))" -"(date>=?" -"(lambda(modes roots a bm)" -"(and a" -"(let((am(date-of a modes roots)))" -"(or(and(not bm) am) " -"(and am bm(>=(cdr am)(cdr bm)) am))))))" -"(with-dir*(lambda(base t) " -"(parameterize((current-load-relative-directory " -"(if(path? base) " -" base " -"(current-directory))))" -"(t)))))" -"(lambda(path expect-module)" -"(unless(path-string? path)" -" (raise-argument-error 'load/use-compiled \"path-string?\" path))" -"(unless(or(not expect-module)" -"(symbol? expect-module)" -"(and(list? expect-module)" -"((length expect-module) . > . 1)" -"(or(symbol?(car expect-module))" -"(not(car expect-module)))" -"(andmap symbol?(cdr expect-module))))" -" (raise-argument-error 'load/use-compiled \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\" path))" -"(define name(and expect-module(current-module-declare-name)))" -"(define ns-hts(and name" -"(hash-ref -module-hash-table-table" -"(namespace-module-registry(current-namespace))" -" #f)))" -"(define use-path/src(and ns-hts(hash-ref(cdr ns-hts) name #f)))" -"(if use-path/src" -"(parameterize((current-module-declare-source(cadr use-path/src)))" -"(with-dir*(caddr use-path/src)" -"(lambda()((current-load)(car use-path/src) expect-module))))" -"(let*-values(((orig-path)(resolve path))" -"((base orig-file dir?)(split-path path))" -"((file alt-file)(if expect-module" -"(let*((b(path->bytes orig-file))" -"(len(bytes-length b)))" -"(cond" -"((and(len . >= . 4)" -" (bytes=? #\".rkt\" (subbytes b (- len 4))))" -"(values orig-file" -" (bytes->path (bytes-append (subbytes b 0 (- len 4)) #\".ss\"))))" -"(else" -"(values orig-file #f))))" -"(values orig-file #f)))" -"((path)(if(eq? file orig-file)" -" orig-path" -"(build-path base file)))" -"((alt-path)(and alt-file" -"(if(eq? alt-file orig-file)" -" orig-path" -"(build-path base alt-file))))" -"((base)(if(eq? base 'relative) 'same base))" -"((modes)(use-compiled-file-paths))" -"((roots)(current-compiled-file-roots))" -"((reroot)(lambda(p d)" -"(cond" -"((eq? d 'same) p)" -"((relative-path? d)(build-path p d))" -"(else(reroot-path p d))))))" -"(let*((main-path-d(date-of-1 path))" -"(alt-path-d(and alt-path " -"(not main-path-d)" -"(date-of-1 alt-path)))" -"(path-d(or main-path-d alt-path-d))" -"(get-so(lambda(file rep-sfx?)" -"(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" \"native\"" -"(system-library-subpath)" -"(if rep-sfx?" -"(path-add-extension" -" file" -" dll-suffix)" -" file)))))" -"(zo(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" (path-add-extension file #\".zo\"))))" -"(alt-zo(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" (path-add-extension alt-file #\".zo\"))))" -"(so(get-so file #t))" -"(alt-so(get-so alt-file #t))" -"(try-main?(or main-path-d(not alt-path-d)))" -"(try-alt?(and alt-file(or alt-path-d(not main-path-d))))" -"(with-dir(lambda(t)(with-dir* base t))))" -"(cond" -"((and try-main?" -"(date>=? modes roots so path-d))" -" =>(lambda(so-d)" -"(parameterize((current-module-declare-source #f))" -"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))" -"((and try-alt?" -"(date>=? modes roots alt-so alt-path-d))" -" =>(lambda(so-d)" -"(parameterize((current-module-declare-source alt-path))" -"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))" -"((and try-main?" -"(date>=? modes roots zo path-d))" -" =>(lambda(zo-d)" -"(register-zo-path name ns-hts(car zo-d) #f base)" -"(parameterize((current-module-declare-source #f))" -"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))" -"((and try-alt?" -"(date>=? modes roots alt-zo path-d))" -" =>(lambda(zo-d)" -"(register-zo-path name ns-hts(car zo-d) alt-path base)" -"(parameterize((current-module-declare-source alt-path))" -"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))" -"((or(not(pair? expect-module))" -"(car expect-module))" -"(let((p(if try-main? path alt-path)))" -"(unless(and(pair? expect-module)" -"(not(file-exists? p)))" -"(parameterize((current-module-declare-source(and expect-module " -"(not try-main?)" -" p)))" -"(with-dir(lambda()((current-load) p expect-module))))))))))))))" -"(define(register-zo-path name ns-hts path src-path base)" -"(when ns-hts" -"(hash-set!(cdr ns-hts) name(list path src-path base))))" -"(define-values(default-reader-guard)" -"(lambda(path) path))" -"(define-values(-module-hash-table-table)(make-weak-hasheq)) " -"(define CACHE-N 512)" -"(define-values(-path-cache)(make-vector CACHE-N #f)) " -"(define(path-cache-get p)" -"(let*((i(modulo(abs(equal-hash-code p)) CACHE-N))" -"(w(vector-ref -path-cache i))" -"(l(and w(weak-box-value w))))" -"(and l" -"(let((a(assoc p l)))" -"(and a(cdr a))))))" -"(define(path-cache-set! p v)" -"(let*((i(modulo(abs(equal-hash-code p)) CACHE-N))" -"(w(vector-ref -path-cache i))" -"(l(and w(weak-box-value w))))" -"(vector-set! -path-cache i(make-weak-box(cons(cons p v)(or l null))))))" -"(define-values(-loading-filename)(gensym))" -"(define-values(-loading-prompt-tag)(make-continuation-prompt-tag 'module-loading))" -"(define-values(-prev-relto) #f)" -"(define-values(-prev-relto-dir) #f)" -"(define(split-relative-string s coll-mode?)" -"(let((l(let loop((s s))" -"(let((len(string-length s)))" -"(let iloop((i 0))" -"(cond" -"((= i len)(list s))" -"((char=? #\\/(string-ref s i))" -"(cons(substring s 0 i)" -"(loop(substring s(add1 i)))))" -"(else(iloop(add1 i)))))))))" -"(if coll-mode?" -" l" -"(let loop((l l))" -"(if(null?(cdr l))" -"(values null(car l))" -"(let-values(((c f)(loop(cdr l))))" -"(values(cons(car l) c) f)))))))" -"(define(format-source-location stx)" -"(srcloc->string(srcloc(syntax-source stx)" -"(syntax-line stx)" -"(syntax-column stx)" -"(syntax-position stx)" -"(syntax-span stx))))" -"(define-values(orig-paramz) #f)" -"(define-values(standard-module-name-resolver)" +"(subbytes bs_0 0 i_0)" +"(if(string? sep_2)(string->bytes/locale sep_2(char->integer '#\\?)) sep_2)" +"(rest-bytes_0 bs_0 i2_0)" +"(if(string? sfx_1)(string->bytes/locale sfx_1(char->integer '#\\?)) sfx_1))" +"(if(path-for-some-system? s_4)" +"(path-convention-type s_4)" +"(system-path-convention-type)))))))" +"(let-values(((new-name_0)" +"(letrec-values(((loop_5)" +"(lambda(i_1)" +"(begin" +" 'loop" +"(if(zero? i_1)" +" (finish_0 (bytes-length bs_0) #\"\" (bytes-length bs_0))" +"(let-values(((i_2)(sub1 i_1)))" +"(if(if(not(zero? i_2))" +"(eq?(char->integer '#\\.)(bytes-ref bs_0 i_2))" +" #f)" +"(finish_0 i_2 sep_1(add1 i_2))" +"(loop_5 i_2))))))))" +"(loop_5(bytes-length bs_0)))))" +"(if(path-for-some-system? base_1)(build-path base_1 new-name_0) new-name_0))))))))" +"(define-values" +"(path-replace-extension)" +" (lambda (s_5 sfx_2) (begin (path-adjust-extension 'path-replace-extension #\"\" (lambda (bs_1 i_3) #\"\") s_5 sfx_2 #t))))" +"(define-values" +"(path-add-extension)" +"(case-lambda" +" ((s_6 sfx_3) (begin (path-adjust-extension 'path-add-extension #\"_\" subbytes s_6 sfx_3 #t)))" +"((s_7 sfx_4 sep_3)(path-adjust-extension 'path-add-extension sep_3 subbytes s_7 sfx_4 #f))))" +"(define-values" +"(reroot-path)" +"(lambda(p_0 root_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_7)(path-string? p_0)))" +"(if or-part_7 or-part_7(path-for-some-system? p_0)))" +"(void)" +"(let-values()" +" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 0 p_0 root_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_8)(path-string? root_0)))" +"(if or-part_8 or-part_8(path-for-some-system? root_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'reroot-path" +" \"(or/c path-string? path-for-some-system?)\"" +" 1" +" p_0" +" root_0)))" +"(values))))" +"(let-values(((conv_0)" +"(if(path-for-some-system? p_0)(path-convention-type p_0)(system-path-convention-type))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_9)(complete-path? p_0)))" +"(if or-part_9 or-part_9(eq?(system-path-convention-type) conv_0)))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'reroot-path" +" \"path is not complete and not the platform's convention\"" +" \"path\"" +" p_0" +" \"platform convention type\"" +"(system-path-convention-type))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?" +"(if(path-for-some-system? root_0)" +"(path-convention-type root_0)" +"(system-path-convention-type))" +" conv_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'reroot-path" +" \"given paths use different conventions\"" +" \"path\"" +" p_0" +" \"root path\"" +" root_0)))" +"(values))))" +"(let-values(((c-p_0)" +"(normal-case-path" +"(cleanse-path(if(complete-path? p_0) p_0(path->complete-path p_0))))))" +"(let-values(((bstr_0)(path->bytes c-p_0)))" +"(if(eq? conv_0 'unix)" "(let-values()" -"(define-values(planet-resolver) #f)" -"(define-values(prep-planet-resolver!)" +" (if (bytes=? bstr_0 #\"/\")" +"(if(path-for-some-system? root_0) root_0(string->path root_0))" +"(build-path root_0(bytes->path(subbytes(path->bytes c-p_0) 1) conv_0))))" +"(if(eq? conv_0 'windows)" +"(let-values()" +"(build-path" +" root_0" +"(bytes->path" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\[a-z]:\" bstr_0)" +"(let-values()" +" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4 5) #\"\\\\\" (subbytes bstr_0 6)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"UNC\\\\\" (subbytes bstr_0 2)))" +" (if (regexp-match? '#rx\"^[a-z]:\" bstr_0)" +"(let-values()(bytes-append(subbytes bstr_0 0 1)(subbytes bstr_0 2)))" +"(void))))))" +" conv_0)))" +"(void)))))))))))))" +"(define-values" +"(path-list-string->path-list)" +"(let-values(((r_0) #f)" +"((cons-path_0)" +"(lambda(default_4 s_1 l_2)" +"(begin" +" 'cons-path" +" (let-values (((s_8) (if (eq? (system-type) 'windows) (regexp-replace* '#rx#\"\\\"\" s_1 #\"\") s_1)))" +" (if (bytes=? s_8 #\"\") (append default_4 l_2) (cons (bytes->path s_8) l_2)))))))" +"(lambda(s_2 default_5)" +"(begin" +"(begin" +"(if r_0" +"(void)" +"(let-values()" +"(set! r_0" +"(byte-regexp" +"(string->bytes/utf-8" +" (let-values (((sep_4) (if (eq? (system-type) 'windows) \";\" \":\")))" +" (format \"([^~a]*)~a(.*)\" sep_4 sep_4)))))))" +"(if(let-values(((or-part_10)(bytes? s_2)))(if or-part_10 or-part_10(string? s_2)))" +"(void)" +" (let-values () (raise-argument-error 'path-list-string->path-list \"(or/c bytes? string?)\" s_2)))" +"(if(if(list? default_5)(andmap path? default_5) #f)" +"(void)" +" (let-values () (raise-argument-error 'path-list-string->path-list \"(listof path?)\" default_5)))" +"((letrec-values(((loop_6)" +"(lambda(s_9)" +"(begin" +" 'loop" +"(let-values(((m_0)(regexp-match r_0 s_9)))" +"(if m_0" +"(cons-path_0 default_5(cadr m_0)(loop_6(caddr m_0)))" +"(cons-path_0 default_5 s_9 null)))))))" +" loop_6)" +"(if(string? s_2)(string->bytes/utf-8 s_2) s_2)))))))" +"(define-values" +"(find-executable-path)" +"(case-lambda" +"((program_0 libpath_0 reverse?_0)" +"(begin" +"(begin" +"(if(path-string? program_0)" +"(void)" +" (let-values () (raise-argument-error 'find-executable-path \"path-string?\" program_0)))" +"(if(let-values(((or-part_11)(not libpath_0)))" +"(if or-part_11 or-part_11(if(path-string? libpath_0)(relative-path? libpath_0) #f)))" +"(void)" +"(let-values()" +" (raise-argument-error 'find-executable-path \"(or/c #f (and/c path-string? relative-path?))\" libpath_0)))" +"(letrec-values(((found-exec_0)" +"(lambda(exec-name_0)" +"(begin" +" 'found-exec" +"(if libpath_0" +"(let-values(((base_2 name_3 isdir?_0)(split-path exec-name_0)))" +"(let-values(((next_0)" "(lambda()" -"(unless planet-resolver" +"(begin" +" 'next" +"(let-values(((resolved_0)(resolve-path exec-name_0)))" +"(if(equal? resolved_0 exec-name_0)" +"(let-values() #f)" +"(if(relative-path? resolved_0)" +"(let-values()(found-exec_0(build-path base_2 resolved_0)))" +"(let-values()(found-exec_0 resolved_0)))))))))" +"(let-values(((or-part_12)(if reverse?_0(next_0) #f)))" +"(if or-part_12" +" or-part_12" +"(let-values(((or-part_13)" +"(if(path? base_2)" +"(let-values(((lib_0)(build-path base_2 libpath_0)))" +"(if(let-values(((or-part_3)(directory-exists? lib_0)))" +"(if or-part_3 or-part_3(file-exists? lib_0)))" +" lib_0" +" #f))" +" #f)))" +"(if or-part_13 or-part_13(if(not reverse?_0)(next_0) #f)))))))" +" exec-name_0)))))" +"(if(if(relative-path? program_0)" +"(let-values(((base_3 name_4 dir?_1)(split-path program_0)))(eq? base_3 'relative))" +" #f)" +" (let-values (((paths-str_0) (environment-variables-ref (current-environment-variables) #\"PATH\"))" +"((win-add_0)" +"(lambda(s_10)" +" (begin 'win-add (if (eq? (system-type) 'windows) (cons (bytes->path #\".\") s_10) s_10)))))" +"((letrec-values(((loop_7)" +"(lambda(paths_0)" +"(begin" +" 'loop" +"(if(null? paths_0)" +" #f" +"(let-values(((base_4)(path->complete-path(car paths_0))))" +"(let-values(((name_5)(build-path base_4 program_0)))" +"(if(file-exists? name_5)(found-exec_0 name_5)(loop_7(cdr paths_0))))))))))" +" loop_7)" +"(win-add_0" +"(if paths-str_0(path-list-string->path-list(bytes->string/locale paths-str_0 '#\\?) null) null))))" +"(let-values(((p_1)(path->complete-path program_0)))(if(file-exists? p_1)(found-exec_0 p_1) #f)))))))" +"((program_1 libpath_1)(find-executable-path program_1 libpath_1 #f))" +"((program_2)(find-executable-path program_2 #f #f))))" +"(define-values" +"(call-with-default-reading-parameterization)" +"(lambda(thunk_3)" +"(begin" +"(if(if(procedure? thunk_3)(procedure-arity-includes? thunk_3 0) #f)" "(with-continuation-mark" " parameterization-key" -" orig-paramz" -" (set! planet-resolver (dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver))))))" -"(define-values(standard-module-name-resolver)" -"(case-lambda " -"((s from-namespace) " -"(unless(resolved-module-path? s)" -"(raise-argument-error 'standard-module-name-resolver" -" \"resolved-module-path?\"" -" s))" -"(unless(or(not from-namespace)(namespace? from-namespace))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f namespace?)\"" -" from-namespace))" -"(when planet-resolver" -"(planet-resolver s))" -"(let((hts(or(hash-ref -module-hash-table-table" -"(namespace-module-registry(current-namespace))" -" #f)" -"(let((hts(cons(make-hasheq)(make-hasheq))))" -"(hash-set! -module-hash-table-table" -"(namespace-module-registry(current-namespace))" -" hts)" -" hts))))" -"(hash-set!(car hts) s 'declared)" -"(when from-namespace" -"(let((root-name(if(pair?(resolved-module-path-name s))" -"(make-resolved-module-path(car(resolved-module-path-name s)))" -" s))" -"(from-hts(hash-ref -module-hash-table-table" -"(namespace-module-registry from-namespace)" -" #f)))" -"(when from-hts" -"(let((use-path/src(hash-ref(cdr from-hts) root-name #f)))" -"(when use-path/src" -"(hash-set!(cdr hts) root-name use-path/src))))))))" -"((s relto stx) " -"(log-message(current-logger) 'error" -" \"default module name resolver called with three arguments (deprecated)\"" -" #f)" -"(standard-module-name-resolver s relto stx #t)) " -"((s relto stx load?)" -"(unless(module-path? s)" -"(if(syntax? stx)" -"(raise-syntax-error #f" -" \"bad module path\"" -" stx)" -"(raise-argument-error 'standard-module-name-resolver" -" \"module-path?\"" -" s)))" -"(unless(or(not relto)(resolved-module-path? relto))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f resolved-module-path?)\"" -" relto))" -"(unless(or(not stx)(syntax? stx))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f syntax?)\"" -" stx))" -"(define(flatten-sub-path base orig-l)" -"(let loop((a null)(l orig-l))" -"(cond" -"((null? l)(if(null? a)" -" base" -"(cons base(reverse a))))" -" ((equal? (car l) \"..\")" -"(if(null? a)" -"(error" -" 'standard-module-name-resolver" -" \"too many \\\"..\\\"s in submodule path: ~.s\"" -"(list* 'submod" -" (if (equal? base \".\") " -" base " -"(if(path? base)" -" base" -"(list(if(symbol? base) 'quote 'file) base)))" -" orig-l))" -"(loop(cdr a)(cdr l))))" -"(else(loop(cons(car l) a)(cdr l))))))" -"(cond" -"((and(pair? s)(eq?(car s) 'quote))" -"(make-resolved-module-path(cadr s)))" -"((and(pair? s)(eq?(car s) 'submod)" -"(pair?(cadr s))(eq?(caadr s) 'quote))" -"(make-resolved-module-path(flatten-sub-path(cadadr s)(cddr s))))" -"((and(pair? s)(eq?(car s) 'submod)" -" (or (equal? (cadr s) \".\")" -" (equal? (cadr s) \"..\"))" -"(and relto" -"(let((p(resolved-module-path-name relto)))" -"(or(symbol? p)" -"(and(pair? p)(symbol?(car p)))))))" -"(define rp(resolved-module-path-name relto))" -"(make-resolved-module-path(flatten-sub-path(if(pair? rp)(car rp) rp)" -" (let ((r (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))" -"(if(pair? rp)" -"(append(cdr rp) r)" -" r)))))" -"((and(pair? s)(eq?(car s) 'planet))" -"(prep-planet-resolver!)" -"(planet-resolver s relto stx load? #f orig-paramz))" -"((and(pair? s)" -"(eq?(car s) 'submod)" -"(pair?(cadr s))" -"(eq?(caadr s) 'planet))" -"(prep-planet-resolver!)" -"(planet-resolver(cadr s) relto stx load?(cddr s) orig-paramz))" -"(else" -"(let((get-dir(lambda()" -"(or(and relto" -"(if(eq? relto -prev-relto)" -" -prev-relto-dir" -"(let((p(resolved-module-path-name relto)))" -"(let((p(if(pair? p)(car p) p)))" -"(and(path? p)" -"(let-values(((base n d?)(split-path p)))" -"(set! -prev-relto relto)" -"(set! -prev-relto-dir base)" -" base))))))" -"(current-load-relative-directory)" -"(current-directory))))" -"(get-reg(lambda()" -"(namespace-module-registry(current-namespace))))" -"(show-collection-err(lambda(msg)" -"(let((msg(string-append" -"(or(and stx" -"(error-print-source-location)" -"(format-source-location stx))" -" \"standard-module-name-resolver\")" -" \": \"" -" (regexp-replace #rx\"\\n\" " -" msg" -" (format \"\\n for module path: ~s\\n\"" -" s)))))" -"(raise" -"(if stx" -"(exn:fail:syntax:missing-module" -" msg" -"(current-continuation-marks)" -"(list stx)" -" s)" -"(exn:fail:filesystem:missing-module" -" msg" -"(current-continuation-marks)" -" s))))))" -"(ss->rkt(lambda(s)" -"(let((len(string-length s)))" -"(if(and(len . >= . 3)" -"(equal? #\\.(string-ref s(- len 3)))" -"(equal? #\\s(string-ref s(- len 2)))" -"(equal? #\\s(string-ref s(- len 1))))" -" (string-append (substring s 0 (- len 3)) \".rkt\")" -" s))))" -"(path-ss->rkt(lambda(p)" -"(let-values(((base name dir?)(split-path p)))" -" (if (regexp-match #rx\"[.]ss$\" (path->bytes name))" -" (path-replace-extension p #\".rkt\")" -" p))))" -"(s(if(and(pair? s)(eq? 'submod(car s)))" -"(let((v(cadr s)))" -" (if (or (equal? v \".\")" -" (equal? v \"..\"))" -"(if relto" -"(let((p(resolved-module-path-name relto)))" -"(if(pair? p)" -"(car p)" -" p))" -"(error 'standard-module-name-resolver" -" \"no base path for relative submodule path: ~.s\"" -" s))" -" v))" -" s))" -"(subm-path(if(and(pair? s)(eq? 'submod(car s)))" -" (let ((p (if (and (or (equal? (cadr s) \".\")" -" (equal? (cadr s) \"..\"))" -" relto)" -"(let((p(resolved-module-path-name relto))" -" (r (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))" -"(if(pair? p)" -"(flatten-sub-path(car p)(append(cdr p) r))" -"(flatten-sub-path p r)))" -" (flatten-sub-path \".\" " -" (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))))" -"(if(pair? p)" -"(cdr p)" -" #f))" -" #f)))" -"(let((s-parsed" -"(cond" -"((symbol? s)" -"(or(path-cache-get(cons s(get-reg)))" -"(let-values(((cols file)(split-relative-string(symbol->string s) #f)))" -"(let*((f-file(if(null? cols)" -" \"main.rkt\"" -" (string-append file \".rkt\"))))" -"(find-col-file show-collection-err" -"(if(null? cols) file(car cols))" -"(if(null? cols) null(cdr cols))" -" f-file" -" #t)))))" -"((string? s)" -"(let*((dir(get-dir)))" -"(or(path-cache-get(cons s dir))" -"(let-values(((cols file)(split-relative-string s #f)))" -"(if(null? cols)" -"(build-path dir(ss->rkt file))" -"(apply build-path " -" dir" -"(append" -"(map(lambda(s)" -"(cond" -" ((string=? s \".\") 'same)" -" ((string=? s \"..\") 'up)" -"(else s)))" -" cols)" -"(list(ss->rkt file)))))))))" -"((path? s) " -"(path-ss->rkt(simplify-path(if(complete-path? s)" -" s" -"(path->complete-path s(get-dir))))))" -"((eq?(car s) 'lib)" -"(or(path-cache-get(cons s(get-reg)))" -"(let*-values(((cols file)(split-relative-string(cadr s) #f))" -"((old-style?)(if(null?(cddr s))" -"(and(null? cols)" -" (regexp-match? #rx\"[.]\" file))" -" #t)))" -"(let*((f-file(if old-style?" -"(ss->rkt file)" -"(if(null? cols)" -" \"main.rkt\"" -" (if (regexp-match? #rx\"[.]\" file)" -"(ss->rkt file)" -" (string-append file \".rkt\"))))))" -"(let-values(((cols)" -"(if old-style?" -"(append(if(null?(cddr s))" -" '(\"mzlib\")" -"(apply append" -"(map(lambda(p)" -"(split-relative-string p #t))" -"(cddr s))))" -" cols)" -"(if(null? cols)" -"(list file)" -" cols))))" -"(find-col-file show-collection-err" -"(car cols)" -"(cdr cols)" -" f-file" -" #t))))))" -"((eq?(car s) 'file)" -"(path-ss->rkt " -"(simplify-path(path->complete-path(expand-user-path(cadr s))(get-dir))))))))" -"(unless(or(path? s-parsed)" -"(vector? s-parsed))" -"(if stx" -"(raise-syntax-error" -" 'require" -" (format \"bad module path~a\" (if s-parsed" -"(car s-parsed)" -" \"\"))" -" stx)" -"(raise-argument-error " -" 'standard-module-name-resolver" -" \"module-path?\"" -" s)))" -"(let*((filename(if(vector? s-parsed)" -"(vector-ref s-parsed 0)" -"(simplify-path(cleanse-path s-parsed) #f)))" -"(normal-filename(if(vector? s-parsed)" -"(vector-ref s-parsed 1)" -"(normal-case-path filename))))" -"(let-values(((base name dir?)(if(vector? s-parsed)" -"(values 'ignored(vector-ref s-parsed 2) 'ignored)" -"(split-path filename))))" -"(let*((no-sfx(if(vector? s-parsed)" -"(vector-ref s-parsed 3)" -" (path-replace-extension name #\"\"))))" -"(let*((root-modname(if(vector? s-parsed)" -"(vector-ref s-parsed 4)" -"(make-resolved-module-path filename)))" -"(hts(or(hash-ref -module-hash-table-table" -"(get-reg)" -" #f)" -"(let((hts(cons(make-hasheq)(make-hasheq))))" -"(hash-set! -module-hash-table-table" -"(get-reg)" -" hts)" -" hts)))" -"(modname(if subm-path" -"(make-resolved-module-path " -"(cons(resolved-module-path-name root-modname)" -" subm-path))" -" root-modname)))" -"(when load?" -"(let((got(hash-ref(car hts) modname #f)))" -"(unless got" -"(let((loading" -"(let((tag(if(continuation-prompt-available? -loading-prompt-tag)" -" -loading-prompt-tag" -"(default-continuation-prompt-tag))))" -"(continuation-mark-set-first" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" read-case-sensitive" +" #t" +" 1/read-square-bracket-as-paren" +" #t" +" 1/read-curly-brace-as-paren" +" #t" +" 1/read-square-bracket-with-tag" " #f" -" -loading-filename" -" null" -" tag)))" -"(nsr(get-reg)))" -"(for-each" -"(lambda(s)" -"(when(and(equal?(cdr s) normal-filename)" -"(eq?(car s) nsr))" -"(error" -" 'standard-module-name-resolver" -" \"cycle in loading\\n at path: ~a\\n paths:~a\"" -" filename" -"(apply string-append" -"(let loop((l(reverse loading)))" -"(if(null? l)" -" '()" -" (list* \"\\n \" (path->string (cdar l)) (loop (cdr l)))))))))" -" loading)" -"((if(continuation-prompt-available? -loading-prompt-tag)" -"(lambda(f)(f))" -"(lambda(f)(call-with-continuation-prompt f -loading-prompt-tag)))" -"(lambda()" -"(with-continuation-mark -loading-filename(cons(cons nsr normal-filename)" -" loading)" -"(parameterize((current-module-declare-name root-modname)" -"(current-module-path-for-load" -"((if stx" -"(lambda(p)(datum->syntax #f p stx))" -" values)" -"(cond" -"((symbol? s) s)" -"((and(pair? s)(eq?(car s) 'lib)) s)" -"(else(if(resolved-module-path? root-modname)" -"(let((src(resolved-module-path-name root-modname)))" -"(if(symbol? src)" -"(list 'quote src)" -" src))" -" root-modname))))))" -"((current-load/use-compiled) " -" filename " -"(let((sym(string->symbol(path->string no-sfx))))" -"(if subm-path" -"(if(hash-ref(car hts) root-modname #f)" -"(cons #f subm-path)" -"(cons sym subm-path))" -" sym)))))))))))" -"(when(and(not(vector? s-parsed))" -" load?" -"(or(string? s)" -"(symbol? s)" -"(and(pair? s)" -"(eq?(car s) 'lib))))" -"(path-cache-set!(if(string? s)" -"(cons s(get-dir))" -"(cons s(get-reg)))" -"(vector filename" -" normal-filename" -" name" -" no-sfx" -" root-modname)))" -" modname)))))))))))" -" standard-module-name-resolver))" -"(define-values(boot)" -"(lambda()" -"(seal)" -"(current-module-name-resolver standard-module-name-resolver)" -"(current-load/use-compiled default-load/use-compiled)" -"(current-reader-guard default-reader-guard)))" -"(define-values(seal)" -"(lambda()" -"(set! orig-paramz" -"(reparameterize " -"(continuation-mark-set-first #f parameterization-key))))))" -); - EVAL_ONE_STR( -"(module #%builtin '#%kernel" -"(#%require '#%expobs" -"(only '#%foreign) " -"(only '#%unsafe) " -"(only '#%flfxnum) " -" '#%boot" -" '#%place-struct" -" '#%paramz" -" '#%network" -" '#%utils" -"(only '#%place)" -"(only '#%futures)" -"(only '#%linklet)))" -); +" 1/read-curly-brace-with-tag" +" #f" +" 1/read-accept-box" +" #t" +" 1/read-accept-compiled" +" #f" +" read-accept-bar-quote" +" #t" +" 1/read-accept-graph" +" #t" +" 1/read-decimal-as-inexact" +" #t" +" 1/read-cdot" +" #f" +" 1/read-accept-dot" +" #t" +" 1/read-accept-infix-dot" +" #t" +" 1/read-accept-quasiquote" +" #t" +" 1/read-accept-reader" +" #f" +" 1/read-accept-lang" +" #t" +" 1/current-readtable" +" #f)" +"(let-values()(thunk_3)))" +" (raise-argument-error 'call-with-default-reading-parameterization \"(procedure-arity-includes/c 0)\" thunk_3)))))" +"(define-values" +"(prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref)" +"(make-struct-type-property 'keyword-impersonator))" +"(define-values" +"(keyword-procedure-impersonator-of)" +"(lambda(v_8)" +"(begin(if(keyword-impersonator? v_8)(let-values()((keyword-impersonator-ref v_8) v_8))(let-values() #f)))))" +"(define-values" +"(struct:keyword-procedure mk-kw-proc keyword-procedure? keyword-procedure-ref keyword-procedure-set!)" +"(make-struct-type" +" 'keyword-procedure" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:checked-procedure #t)(cons prop:impersonator-of keyword-procedure-impersonator-of))" +"(current-inspector)" +" #f" +" '(0 1 2 3)))" +"(define-values(keyword-procedure-required)(make-struct-field-accessor keyword-procedure-ref 2))" +"(define-values(keyword-procedure-allowed)(make-struct-field-accessor keyword-procedure-ref 3))" +"(define-values" +"(prop:procedure-accessor procedure-accessor? procedure-accessor-ref)" +"(make-struct-type-property" +" 'procedure" +"(lambda(v_9 info-l_0)(if(exact-integer? v_9)(make-struct-field-accessor(list-ref info-l_0 3) v_9) #f))))" +"(define-values" +"(new-prop:procedure new-procedure? new-procedure-ref)" +"(make-struct-type-property" +" 'procedure" +" #f" +"(list(cons prop:procedure values)(cons prop:procedure-accessor values))" +" #t))" +"(define-values" +"(procedure-keywords)" +"(lambda(p_2)" +"(begin" +"(if(keyword-procedure? p_2)" +"(let-values()(values(keyword-procedure-required p_2)(keyword-procedure-allowed p_2)))" +"(if(procedure? p_2)" +"(let-values()" +"(if(new-procedure? p_2)" +"(let-values(((v_10)(new-procedure-ref p_2)))" +"(if(procedure? v_10)" +"(procedure-keywords v_10)" +"(let-values(((a_1)(procedure-accessor-ref p_2)))" +"(if a_1(procedure-keywords(a_1 p_2))(values null null)))))" +"(values null null)))" +" (let-values () (raise-argument-error 'procedure-keywords \"procedure?\" p_2)))))))" +"(define-values" +"(reverse$1)" +"(lambda(l_3)" +"(begin" +" 'reverse" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +" (if (list? l_3) (void) (raise-argument-error 'reverse \"list?\" l_3)))" +"(letrec-values(((loop_8)" +"(lambda(a_2 l_4)(begin 'loop(if(null? l_4) a_2(loop_8(cons(car l_4) a_2)(cdr l_4)))))))" +"(loop_8 null l_3))))))" +"(define-values" +"(sort vector-sort vector-sort!)" +"(let-values()" +"(let-values(((generic-sort_0)" +"(lambda(A_0 less-than?_0 n_1)" +"(begin" +" 'generic-sort" +"(let-values()" +"(let-values()" +"(let-values(((n/2-_0)(unsafe-fxrshift n_1 1)))" +"(let-values(((n/2+_0)(unsafe-fx- n_1 n/2-_0)))" +"(letrec-values(((copying-mergesort_0)" +"(lambda(Alo_0 Blo_0 n_2)" +"(begin" +" 'copying-mergesort" +"(if(unsafe-fx= n_2 1)" +"(let-values()" +"(unsafe-vector-set! A_0 Blo_0(unsafe-vector-ref A_0 Alo_0)))" +"(if(unsafe-fx= n_2 2)" +"(let-values()" +"(let-values(((x_0)(unsafe-vector-ref A_0 Alo_0))" +"((y_0)" +"(unsafe-vector-ref A_0(unsafe-fx+ Alo_0 1))))" +"(if(less-than?_0 y_0 x_0)" +"(begin" +"(unsafe-vector-set! A_0 Blo_0 y_0)" +"(unsafe-vector-set! A_0(unsafe-fx+ Blo_0 1) x_0))" +"(begin" +"(unsafe-vector-set! A_0 Blo_0 x_0)" +"(unsafe-vector-set! A_0(unsafe-fx+ Blo_0 1) y_0)))))" +"(if(unsafe-fx< n_2 16)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" Blo_0" +"(unsafe-vector-ref A_0 Alo_0))" +"((letrec-values(((iloop_0)" +"(lambda(i_4)" +"(begin" +" 'iloop" +"(if(unsafe-fx< i_4 n_2)" +"(let-values()" +"(let-values(((ref-i_0)" +"(unsafe-vector-ref" +" A_0" +"(unsafe-fx+" +" Alo_0" +" i_4))))" +"((letrec-values(((jloop_0)" +"(lambda(j_0)" +"(begin" +" 'jloop" +"(let-values(((ref-j-1_0)" +"(unsafe-vector-ref" +" A_0" +"(unsafe-fx-" +" j_0" +" 1))))" +"(if(if(unsafe-fx<" +" Blo_0" +" j_0)" +"(less-than?_0" +" ref-i_0" +" ref-j-1_0)" +" #f)" +"(begin" +"(unsafe-vector-set!" +" A_0" +" j_0" +" ref-j-1_0)" +"(jloop_0" +"(unsafe-fx-" +" j_0" +" 1)))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" j_0" +" ref-i_0)" +"(iloop_0" +"(unsafe-fx+" +" i_4" +" 1)))))))))" +" jloop_0)" +"(unsafe-fx+ Blo_0 i_4))))" +"(void))))))" +" iloop_0)" +" 1)))" +"(let-values()" +"(let-values(((n/2-_1)(unsafe-fxrshift n_2 1)))" +"(let-values(((n/2+_1)(unsafe-fx- n_2 n/2-_1)))" +"(let-values(((Amid1_0)(unsafe-fx+ Alo_0 n/2-_1))" +"((Amid2_0)(unsafe-fx+ Alo_0 n/2+_1))" +"((Bmid1_0)(unsafe-fx+ Blo_0 n/2-_1)))" +"(begin" +"(copying-mergesort_0 Amid1_0 Bmid1_0 n/2+_1)" +"(copying-mergesort_0 Alo_0 Amid2_0 n/2-_1)" +"(let-values(((b2_0)(unsafe-fx+ Blo_0 n_2)))" +"((letrec-values(((loop_9)" +"(lambda(a1_0 b1_0 c1_0)" +"(begin" +" 'loop" +"(let-values(((x_1)" +"(unsafe-vector-ref" +" A_0" +" a1_0))" +"((y_1)" +"(unsafe-vector-ref" +" A_0" +" b1_0)))" +"(if(not" +"(less-than?_0" +" y_1" +" x_1))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_0" +" x_1)" +"(let-values(((a1_1)" +"(unsafe-fx+" +" a1_0" +" 1))" +"((c1_1)" +"(unsafe-fx+" +" c1_0" +" 1)))" +"(if(unsafe-fx<" +" c1_1" +" b1_0)" +"(let-values()" +"(loop_9" +" a1_1" +" b1_0" +" c1_1))" +"(void))))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_0" +" y_1)" +"(let-values(((b1_1)" +"(unsafe-fx+" +" b1_0" +" 1))" +"((c1_2)" +"(unsafe-fx+" +" c1_0" +" 1)))" +"(if(unsafe-fx<=" +" b2_0" +" b1_1)" +"((letrec-values(((loop_10)" +"(lambda(a1_2" +" c1_3)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_3" +" b1_1)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_3" +"(unsafe-vector-ref" +" A_0" +" a1_2))" +"(loop_10" +"(unsafe-fx+" +" a1_2" +" 1)" +"(unsafe-fx+" +" c1_3" +" 1))))" +"(void))))))" +" loop_10)" +" a1_0" +" c1_2)" +"(loop_9" +" a1_0" +" b1_1" +" c1_2))))))))))" +" loop_9)" +" Amid2_0" +" Bmid1_0" +" Blo_0))))))))))))))" +"(let-values(((Alo_1) 0)" +"((Amid1_1) n/2-_0)" +"((Amid2_1) n/2+_0)" +"((Ahi_0) n_1)" +"((B1lo_0) n_1))" +"(begin" +"(copying-mergesort_0 Amid1_1 B1lo_0 n/2+_0)" +"(if(zero? n/2-_0)" +"(void)" +"(let-values()(copying-mergesort_0 Alo_1 Amid2_1 n/2-_0)))" +"(let-values(((b2_1) Ahi_0))" +"((letrec-values(((loop_11)" +"(lambda(a1_3 b1_2 c1_4)" +"(begin" +" 'loop" +"(let-values(((x_2)(unsafe-vector-ref A_0 a1_3))" +"((y_2)(unsafe-vector-ref A_0 b1_2)))" +"(if(less-than?_0 x_2 y_2)" +"(begin" +"(unsafe-vector-set! A_0 c1_4 x_2)" +"(let-values(((a1_4)(unsafe-fx+ a1_3 1))" +"((c1_5)(unsafe-fx+ c1_4 1)))" +"(if(unsafe-fx< c1_5 b1_2)" +"(let-values()(loop_11 a1_4 b1_2 c1_5))" +"(void))))" +"(begin" +"(unsafe-vector-set! A_0 c1_4 y_2)" +"(let-values(((b1_3)(unsafe-fx+ b1_2 1))" +"((c1_6)(unsafe-fx+ c1_4 1)))" +"(if(unsafe-fx<= b2_1 b1_3)" +"((letrec-values(((loop_12)" +"(lambda(a1_5 c1_7)" +"(begin" +" 'loop" +"(if(unsafe-fx< c1_7 b1_3)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_7" +"(unsafe-vector-ref" +" A_0" +" a1_5))" +"(loop_12" +"(unsafe-fx+ a1_5 1)" +"(unsafe-fx+" +" c1_7" +" 1))))" +"(void))))))" +" loop_12)" +" a1_3" +" c1_6)" +"(loop_11 a1_3 b1_3 c1_6))))))))))" +" loop_11)" +" B1lo_0" +" Amid2_1" +" Alo_1)))))))))))))" +"(let-values(((generic-sort/key_0)" +"(lambda(A_1 less-than?_1 n_3 key_6)" +"(begin" +" 'generic-sort/key" +"(let-values()" +"(let-values()" +"(let-values(((n/2-_2)(unsafe-fxrshift n_3 1)))" +"(let-values(((n/2+_2)(unsafe-fx- n_3 n/2-_2)))" +"(letrec-values(((copying-mergesort_1)" +"(lambda(Alo_2 Blo_1 n_4)" +"(begin" +" 'copying-mergesort" +"(if(unsafe-fx= n_4 1)" +"(let-values()" +"(unsafe-vector-set! A_1 Blo_1(unsafe-vector-ref A_1 Alo_2)))" +"(if(unsafe-fx= n_4 2)" +"(let-values()" +"(let-values(((x_3)(unsafe-vector-ref A_1 Alo_2))" +"((y_3)" +"(unsafe-vector-ref A_1(unsafe-fx+ Alo_2 1))))" +"(if(if key_6" +"(less-than?_1(key_6 y_3)(key_6 x_3))" +"(less-than?_1 y_3 x_3))" +"(begin" +"(unsafe-vector-set! A_1 Blo_1 y_3)" +"(unsafe-vector-set! A_1(unsafe-fx+ Blo_1 1) x_3))" +"(begin" +"(unsafe-vector-set! A_1 Blo_1 x_3)" +"(unsafe-vector-set! A_1(unsafe-fx+ Blo_1 1) y_3)))))" +"(if(unsafe-fx< n_4 16)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" Blo_1" +"(unsafe-vector-ref A_1 Alo_2))" +"((letrec-values(((iloop_1)" +"(lambda(i_5)" +"(begin" +" 'iloop" +"(if(unsafe-fx< i_5 n_4)" +"(let-values()" +"(let-values(((ref-i_1)" +"(unsafe-vector-ref" +" A_1" +"(unsafe-fx+" +" Alo_2" +" i_5))))" +"((letrec-values(((jloop_1)" +"(lambda(j_1)" +"(begin" +" 'jloop" +"(let-values(((ref-j-1_1)" +"(unsafe-vector-ref" +" A_1" +"(unsafe-fx-" +" j_1" +" 1))))" +"(if(if(unsafe-fx<" +" Blo_1" +" j_1)" +"(if key_6" +"(less-than?_1" +"(key_6" +" ref-i_1)" +"(key_6" +" ref-j-1_1))" +"(less-than?_1" +" ref-i_1" +" ref-j-1_1))" +" #f)" +"(begin" +"(unsafe-vector-set!" +" A_1" +" j_1" +" ref-j-1_1)" +"(jloop_1" +"(unsafe-fx-" +" j_1" +" 1)))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" j_1" +" ref-i_1)" +"(iloop_1" +"(unsafe-fx+" +" i_5" +" 1)))))))))" +" jloop_1)" +"(unsafe-fx+ Blo_1 i_5))))" +"(void))))))" +" iloop_1)" +" 1)))" +"(let-values()" +"(let-values(((n/2-_3)(unsafe-fxrshift n_4 1)))" +"(let-values(((n/2+_3)(unsafe-fx- n_4 n/2-_3)))" +"(let-values(((Amid1_2)(unsafe-fx+ Alo_2 n/2-_3))" +"((Amid2_2)(unsafe-fx+ Alo_2 n/2+_3))" +"((Bmid1_1)(unsafe-fx+ Blo_1 n/2-_3)))" +"(begin" +"(copying-mergesort_1 Amid1_2 Bmid1_1 n/2+_3)" +"(copying-mergesort_1 Alo_2 Amid2_2 n/2-_3)" +"(let-values(((b2_2)(unsafe-fx+ Blo_1 n_4)))" +"((letrec-values(((loop_13)" +"(lambda(a1_6 b1_4 c1_8)" +"(begin" +" 'loop" +"(let-values(((x_4)" +"(unsafe-vector-ref" +" A_1" +" a1_6))" +"((y_4)" +"(unsafe-vector-ref" +" A_1" +" b1_4)))" +"(if(not" +"(if key_6" +"(less-than?_1" +"(key_6 y_4)" +"(key_6 x_4))" +"(less-than?_1" +" y_4" +" x_4)))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_8" +" x_4)" +"(let-values(((a1_7)" +"(unsafe-fx+" +" a1_6" +" 1))" +"((c1_9)" +"(unsafe-fx+" +" c1_8" +" 1)))" +"(if(unsafe-fx<" +" c1_9" +" b1_4)" +"(let-values()" +"(loop_13" +" a1_7" +" b1_4" +" c1_9))" +"(void))))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_8" +" y_4)" +"(let-values(((b1_5)" +"(unsafe-fx+" +" b1_4" +" 1))" +"((c1_10)" +"(unsafe-fx+" +" c1_8" +" 1)))" +"(if(unsafe-fx<=" +" b2_2" +" b1_5)" +"((letrec-values(((loop_14)" +"(lambda(a1_8" +" c1_11)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_11" +" b1_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_11" +"(unsafe-vector-ref" +" A_1" +" a1_8))" +"(loop_14" +"(unsafe-fx+" +" a1_8" +" 1)" +"(unsafe-fx+" +" c1_11" +" 1))))" +"(void))))))" +" loop_14)" +" a1_6" +" c1_10)" +"(loop_13" +" a1_6" +" b1_5" +" c1_10))))))))))" +" loop_13)" +" Amid2_2" +" Bmid1_1" +" Blo_1))))))))))))))" +"(let-values(((Alo_3) 0)" +"((Amid1_3) n/2-_2)" +"((Amid2_3) n/2+_2)" +"((Ahi_1) n_3)" +"((B1lo_1) n_3))" +"(begin" +"(copying-mergesort_1 Amid1_3 B1lo_1 n/2+_2)" +"(if(zero? n/2-_2)" +"(void)" +"(let-values()(copying-mergesort_1 Alo_3 Amid2_3 n/2-_2)))" +"(let-values(((b2_3) Ahi_1))" +"((letrec-values(((loop_15)" +"(lambda(a1_9 b1_6 c1_12)" +"(begin" +" 'loop" +"(let-values(((x_5)(unsafe-vector-ref A_1 a1_9))" +"((y_5)(unsafe-vector-ref A_1 b1_6)))" +"(if(if key_6" +"(less-than?_1(key_6 x_5)(key_6 y_5))" +"(less-than?_1 x_5 y_5))" +"(begin" +"(unsafe-vector-set! A_1 c1_12 x_5)" +"(let-values(((a1_10)(unsafe-fx+ a1_9 1))" +"((c1_13)(unsafe-fx+ c1_12 1)))" +"(if(unsafe-fx< c1_13 b1_6)" +"(let-values()(loop_15 a1_10 b1_6 c1_13))" +"(void))))" +"(begin" +"(unsafe-vector-set! A_1 c1_12 y_5)" +"(let-values(((b1_7)(unsafe-fx+ b1_6 1))" +"((c1_14)(unsafe-fx+ c1_12 1)))" +"(if(unsafe-fx<= b2_3 b1_7)" +"((letrec-values(((loop_16)" +"(lambda(a1_11 c1_15)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_15" +" b1_7)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_15" +"(unsafe-vector-ref" +" A_1" +" a1_11))" +"(loop_16" +"(unsafe-fx+" +" a1_11" +" 1)" +"(unsafe-fx+" +" c1_15" +" 1))))" +"(void))))))" +" loop_16)" +" a1_9" +" c1_14)" +"(loop_15 a1_9 b1_7 c1_14))))))))))" +" loop_15)" +" B1lo_1" +" Amid2_3" +" Alo_3)))))))))))))" +"(values" +"(case-lambda" +"((lst_0 less-than?_2)" +"(let-values(((n_5)(length lst_0)))" +"(let-values()" +"(if(unsafe-fx= n_5 0)" +"(let-values() lst_0)" +"(if((letrec-values(((loop_17)" +"(lambda(last_0 next_1)" +"(begin" +" 'loop" +"(let-values(((or-part_14)(null? next_1)))" +"(if or-part_14" +" or-part_14" +"(if(not(less-than?_2(unsafe-car next_1) last_0))" +"(loop_17(unsafe-car next_1)(unsafe-cdr next_1))" +" #f)))))))" +" loop_17)" +"(car lst_0)" +"(cdr lst_0))" +"(let-values() lst_0)" +"(if(unsafe-fx<= n_5 3)" +"(let-values()" +"(if(unsafe-fx= n_5 1)" +"(let-values() lst_0)" +"(if(unsafe-fx= n_5 2)" +"(let-values()(list(cadr lst_0)(car lst_0)))" +"(let-values()" +"(let-values(((a_3)(car lst_0))((b_1)(cadr lst_0))((c_0)(caddr lst_0)))" +"(if(less-than?_2 b_1 a_3)" +"(if(less-than?_2 c_0 b_1)" +"(list c_0 b_1 a_3)" +"(if(less-than?_2 c_0 a_3)(list b_1 c_0 a_3)(list b_1 a_3 c_0)))" +"(if(less-than?_2 c_0 a_3)(list c_0 a_3 b_1)(list a_3 c_0 b_1))))))))" +"(let-values()" +"(let-values(((vec_0)(make-vector(+ n_5(ceiling(/ n_5 2))))))" +"(begin" +"((letrec-values(((loop_18)" +"(lambda(i_6 lst_1)" +"(begin" +" 'loop" +"(if(pair? lst_1)" +"(let-values()" +"(begin" +"(vector-set! vec_0 i_6(car lst_1))" +"(loop_18(add1 i_6)(cdr lst_1))))" +"(void))))))" +" loop_18)" +" 0" +" lst_0)" +"(generic-sort_0 vec_0 less-than?_2 n_5)" +"((letrec-values(((loop_19)" +"(lambda(i_7 r_1)" +"(begin" +" 'loop" +"(let-values(((i_8)(sub1 i_7)))" +"(if(< i_8 0)" +" r_1" +"(loop_19 i_8(cons(vector-ref vec_0 i_8) r_1))))))))" +" loop_19)" +" n_5" +" '()))))))))))" +"((lst_2 less-than?_3 getkey_0)" +"(if(if getkey_0(not(eq? values getkey_0)) #f)" +"(sort lst_2 less-than?_3 getkey_0 #f)" +"(sort lst_2 less-than?_3)))" +"((lst_3 less-than?_4 getkey_1 cache-keys?_0)" +"(if(if getkey_1(not(eq? values getkey_1)) #f)" +"(let-values(((n_6)(length lst_3)))" +"(let-values()" +"(if(unsafe-fx= n_6 0)" +"(let-values() lst_3)" +"(if cache-keys?_0" +"(let-values()" +"(let-values(((vec_1)(make-vector(+ n_6(ceiling(/ n_6 2))))))" +"(begin" +"((letrec-values(((loop_20)" +"(lambda(i_9 lst_4)" +"(begin" +" 'loop" +"(if(pair? lst_4)" +"(let-values()" +"(let-values(((x_6)(car lst_4)))" +"(begin" +"(unsafe-vector-set! vec_1 i_9(cons(getkey_1 x_6) x_6))" +"(loop_20(unsafe-fx+ i_9 1)(cdr lst_4)))))" +"(void))))))" +" loop_20)" +" 0" +" lst_3)" +"(generic-sort/key_0 vec_1 less-than?_4 n_6 unsafe-car)" +"((letrec-values(((loop_21)" +"(lambda(i_10 r_2)" +"(begin" +" 'loop" +"(let-values(((i_11)(unsafe-fx- i_10 1)))" +"(if(unsafe-fx< i_11 0)" +" r_2" +"(loop_21" +" i_11" +"(cons(unsafe-cdr(unsafe-vector-ref vec_1 i_11)) r_2))))))))" +" loop_21)" +" n_6" +" '()))))" +"(if((letrec-values(((loop_22)" +"(lambda(last_1 next_2)" +"(begin" +" 'loop" +"(let-values(((or-part_15)(null? next_2)))" +"(if or-part_15" +" or-part_15" +"(if(not" +"(if getkey_1" +"(less-than?_4" +"(getkey_1(unsafe-car next_2))" +"(getkey_1 last_1))" +"(less-than?_4(unsafe-car next_2) last_1)))" +"(loop_22(unsafe-car next_2)(unsafe-cdr next_2))" +" #f)))))))" +" loop_22)" +"(car lst_3)" +"(cdr lst_3))" +"(let-values() lst_3)" +"(if(unsafe-fx<= n_6 3)" +"(let-values()" +"(if(unsafe-fx= n_6 1)" +"(let-values() lst_3)" +"(if(unsafe-fx= n_6 2)" +"(let-values()(list(cadr lst_3)(car lst_3)))" +"(let-values()" +"(let-values(((a_4)(car lst_3))((b_2)(cadr lst_3))((c_1)(caddr lst_3)))" +"(if(if getkey_1(less-than?_4(getkey_1 b_2)(getkey_1 a_4))(less-than?_4 b_2 a_4))" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 b_2))" +"(less-than?_4 c_1 b_2))" +"(list c_1 b_2 a_4)" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 a_4))" +"(less-than?_4 c_1 a_4))" +"(list b_2 c_1 a_4)" +"(list b_2 a_4 c_1)))" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 a_4))" +"(less-than?_4 c_1 a_4))" +"(list c_1 a_4 b_2)" +"(list a_4 c_1 b_2))))))))" +"(let-values()" +"(let-values(((vec_2)(make-vector(+ n_6(ceiling(/ n_6 2))))))" +"(begin" +"((letrec-values(((loop_23)" +"(lambda(i_12 lst_5)" +"(begin" +" 'loop" +"(if(pair? lst_5)" +"(let-values()" +"(begin" +"(vector-set! vec_2 i_12(car lst_5))" +"(loop_23(add1 i_12)(cdr lst_5))))" +"(void))))))" +" loop_23)" +" 0" +" lst_3)" +"(generic-sort/key_0 vec_2 less-than?_4 n_6 getkey_1)" +"((letrec-values(((loop_24)" +"(lambda(i_13 r_3)" +"(begin" +" 'loop" +"(let-values(((i_14)(sub1 i_13)))" +"(if(< i_14 0)" +" r_3" +"(loop_24 i_14(cons(vector-ref vec_2 i_14) r_3))))))))" +" loop_24)" +" n_6" +" '()))))))))))" +"(sort lst_3 less-than?_4))))" +"(case-lambda" +"((vec_3 less-than?_5 start_0 end_0)" +"(let-values(((n_7)(- end_0 start_0)))" +"(let-values(((dst-vec_0)(make-vector n_7)))" +"(let-values(((dst-start_0) 0))" +"(begin" +"(if(unsafe-fx= n_7 0)" +"(let-values()(void))" +"(if((letrec-values(((loop_25)" +"(lambda(prev-val_0 next-index_0)" +"(begin" +" 'loop" +"(let-values(((or-part_16)(unsafe-fx= next-index_0 end_0)))" +"(if or-part_16" +" or-part_16" +"(let-values(((next-val_0)(unsafe-vector-ref vec_3 next-index_0)))" +"(if(not(less-than?_5 next-val_0 prev-val_0))" +"(loop_25 next-val_0(unsafe-fx+ next-index_0 1))" +" #f))))))))" +" loop_25)" +"(unsafe-vector-ref vec_3 start_0)" +"(unsafe-fx+ start_0 1))" +"(let-values()(let-values()(vector-copy! dst-vec_0 dst-start_0 vec_3 start_0 end_0)))" +"(if(unsafe-fx<= n_7 3)" +"(let-values()" +"(begin" +"(let-values()(vector-copy! dst-vec_0 dst-start_0 vec_3 start_0 end_0))" +"(if(unsafe-fx= n_7 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_7 2)" +"(let-values()" +"(let-values(((tmp_0)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_0" +"(unsafe-fx+ dst-start_0 0)" +"(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 1)))" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) tmp_0))))" +"(let-values()" +"(let-values(((a_5)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 0)))" +"((b_3)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 1)))" +"((c_2)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 2))))" +"(if(less-than?_5 b_3 a_5)" +"(let-values()" +"(if(less-than?_5 c_2 b_3)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) a_5)))" +"(if(less-than?_5 c_2 a_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) b_3)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) a_5)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) b_3)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) a_5))))))" +"(if(less-than?_5 c_2 a_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) a_5)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) b_3)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) b_3)))))))))))" +"(let-values()" +"(let-values(((work-vec_0)(make-vector(+ n_7(ceiling(/ n_7 2))) #f)))" +"(begin" +"(vector-copy! work-vec_0 0 vec_3 start_0 end_0)" +"(generic-sort_0 work-vec_0 less-than?_5 n_7)" +"(vector-copy! dst-vec_0 dst-start_0 work-vec_0 0 n_7)))))))" +" dst-vec_0)))))" +"((vec_4 less-than?_6 start_1 end_1 getkey_2 cache-keys?_1)" +"(if(if getkey_2(not(eq? values getkey_2)) #f)" +"(let-values(((n_8)(- end_1 start_1)))" +"(let-values(((dst-vec_1)(make-vector n_8)))" +"(let-values(((dst-start_1) 0))" +"(begin" +"(if(unsafe-fx= n_8 0)" +"(let-values()(void))" +"(if cache-keys?_1" +"(let-values()" +"(let-values(((work-vec_1)(make-vector(+ n_8(ceiling(/ n_8 2))) #t)))" +"(begin" +"((letrec-values(((loop_26)" +"(lambda(i_15)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_15 n_8)" +"(let-values()" +"(begin" +"(let-values(((x_7)" +"(unsafe-vector-ref" +" vec_4" +"(unsafe-fx+ i_15 start_1))))" +"(unsafe-vector-set!" +" work-vec_1" +" i_15" +"(cons(getkey_2 x_7) x_7)))" +"(loop_26(unsafe-fx+ i_15 1))))" +"(void))))))" +" loop_26)" +" 0)" +"(generic-sort/key_0 work-vec_1 less-than?_6 n_8 unsafe-car)" +"((letrec-values(((loop_27)" +"(lambda(i_16)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_16 n_8)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" dst-vec_1" +"(unsafe-fx+ i_16 dst-start_1)" +"(unsafe-cdr(unsafe-vector-ref work-vec_1 i_16)))" +"(loop_27(unsafe-fx+ i_16 1))))" +"(void))))))" +" loop_27)" +" 0))))" +"(if((letrec-values(((loop_28)" +"(lambda(prev-val_1 next-index_1)" +"(begin" +" 'loop" +"(let-values(((or-part_17)(unsafe-fx= next-index_1 end_1)))" +"(if or-part_17" +" or-part_17" +"(let-values(((next-val_1)" +"(unsafe-vector-ref vec_4 next-index_1)))" +"(if(not" +"(if getkey_2" +"(less-than?_6" +"(getkey_2 next-val_1)" +"(getkey_2 prev-val_1))" +"(less-than?_6 next-val_1 prev-val_1)))" +"(loop_28 next-val_1(unsafe-fx+ next-index_1 1))" +" #f))))))))" +" loop_28)" +"(unsafe-vector-ref vec_4 start_1)" +"(unsafe-fx+ start_1 1))" +"(let-values()(let-values()(vector-copy! dst-vec_1 dst-start_1 vec_4 start_1 end_1)))" +"(if(unsafe-fx<= n_8 3)" +"(let-values()" +"(begin" +"(let-values()(vector-copy! dst-vec_1 dst-start_1 vec_4 start_1 end_1))" +"(if(unsafe-fx= n_8 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_8 2)" +"(let-values()" +"(let-values(((tmp_1)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_1" +"(unsafe-fx+ dst-start_1 0)" +"(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 1)))" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) tmp_1))))" +"(let-values()" +"(let-values(((a_6)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 0)))" +"((b_4)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 1)))" +"((c_3)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 2))))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 b_4)(getkey_2 a_6))" +"(less-than?_6 b_4 a_6))" +"(let-values()" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 b_4))" +"(less-than?_6 c_3 b_4))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) a_6)))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 a_6))" +"(less-than?_6 c_3 a_6))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) b_4)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) a_6)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) b_4)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) a_6))))))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 a_6))" +"(less-than?_6 c_3 a_6))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) a_6)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) b_4)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) b_4)))))))))))" +"(let-values()" +"(let-values(((work-vec_2)(make-vector(+ n_8(ceiling(/ n_8 2))) #f)))" +"(begin" +"(vector-copy! work-vec_2 0 vec_4 start_1 end_1)" +"(generic-sort/key_0 work-vec_2 less-than?_6 n_8 getkey_2)" +"(vector-copy! dst-vec_1 dst-start_1 work-vec_2 0 n_8))))))))" +" dst-vec_1))))" +"(vector-sort vec_4 less-than?_6 start_1 end_1))))" +"(case-lambda" +"((vec_5 less-than?_7 start_2 end_2)" +"(let-values(((n_9)(- end_2 start_2)))" +"(let-values(((dst-vec_2) vec_5))" +"(let-values(((dst-start_2) start_2))" +"(begin" +"(if(unsafe-fx= n_9 0)" +"(let-values()(void))" +"(if((letrec-values(((loop_29)" +"(lambda(prev-val_2 next-index_2)" +"(begin" +" 'loop" +"(let-values(((or-part_18)(unsafe-fx= next-index_2 end_2)))" +"(if or-part_18" +" or-part_18" +"(let-values(((next-val_2)(unsafe-vector-ref vec_5 next-index_2)))" +"(if(not(less-than?_7 next-val_2 prev-val_2))" +"(loop_29 next-val_2(unsafe-fx+ next-index_2 1))" +" #f))))))))" +" loop_29)" +"(unsafe-vector-ref vec_5 start_2)" +"(unsafe-fx+ start_2 1))" +"(let-values()(void))" +"(if(unsafe-fx<= n_9 3)" +"(let-values()" +"(begin" +"(void)" +"(if(unsafe-fx= n_9 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_9 2)" +"(let-values()" +"(let-values(((tmp_2)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_2" +"(unsafe-fx+ dst-start_2 0)" +"(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 1)))" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) tmp_2))))" +"(let-values()" +"(let-values(((a_7)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 0)))" +"((b_5)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 1)))" +"((c_4)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 2))))" +"(if(less-than?_7 b_5 a_7)" +"(let-values()" +"(if(less-than?_7 c_4 b_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) a_7)))" +"(if(less-than?_7 c_4 a_7)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) b_5)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) a_7)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) b_5)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) a_7))))))" +"(if(less-than?_7 c_4 a_7)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) a_7)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) b_5)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) b_5)))))))))))" +"(let-values()" +"(let-values(((work-vec_3)(make-vector(+ n_9(ceiling(/ n_9 2))) #f)))" +"(begin" +"(vector-copy! work-vec_3 0 vec_5 start_2 end_2)" +"(generic-sort_0 work-vec_3 less-than?_7 n_9)" +"(vector-copy! dst-vec_2 dst-start_2 work-vec_3 0 n_9)))))))" +"(void))))))" +"((vec_6 less-than?_8 start_3 end_3 getkey_3 cache-keys?_2)" +"(if(if getkey_3(not(eq? values getkey_3)) #f)" +"(let-values(((n_10)(- end_3 start_3)))" +"(let-values(((dst-vec_3) vec_6))" +"(let-values(((dst-start_3) start_3))" +"(begin" +"(if(unsafe-fx= n_10 0)" +"(let-values()(void))" +"(if cache-keys?_2" +"(let-values()" +"(let-values(((work-vec_4)(make-vector(+ n_10(ceiling(/ n_10 2))) #t)))" +"(begin" +"((letrec-values(((loop_30)" +"(lambda(i_17)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_17 n_10)" +"(let-values()" +"(begin" +"(let-values(((x_8)" +"(unsafe-vector-ref" +" vec_6" +"(unsafe-fx+ i_17 start_3))))" +"(unsafe-vector-set!" +" work-vec_4" +" i_17" +"(cons(getkey_3 x_8) x_8)))" +"(loop_30(unsafe-fx+ i_17 1))))" +"(void))))))" +" loop_30)" +" 0)" +"(generic-sort/key_0 work-vec_4 less-than?_8 n_10 unsafe-car)" +"((letrec-values(((loop_31)" +"(lambda(i_18)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_18 n_10)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" dst-vec_3" +"(unsafe-fx+ i_18 dst-start_3)" +"(unsafe-cdr(unsafe-vector-ref work-vec_4 i_18)))" +"(loop_31(unsafe-fx+ i_18 1))))" +"(void))))))" +" loop_31)" +" 0))))" +"(if((letrec-values(((loop_32)" +"(lambda(prev-val_3 next-index_3)" +"(begin" +" 'loop" +"(let-values(((or-part_19)(unsafe-fx= next-index_3 end_3)))" +"(if or-part_19" +" or-part_19" +"(let-values(((next-val_3)" +"(unsafe-vector-ref vec_6 next-index_3)))" +"(if(not" +"(if getkey_3" +"(less-than?_8" +"(getkey_3 next-val_3)" +"(getkey_3 prev-val_3))" +"(less-than?_8 next-val_3 prev-val_3)))" +"(loop_32 next-val_3(unsafe-fx+ next-index_3 1))" +" #f))))))))" +" loop_32)" +"(unsafe-vector-ref vec_6 start_3)" +"(unsafe-fx+ start_3 1))" +"(let-values()(void))" +"(if(unsafe-fx<= n_10 3)" +"(let-values()" +"(begin" +"(void)" +"(if(unsafe-fx= n_10 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_10 2)" +"(let-values()" +"(let-values(((tmp_3)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_3" +"(unsafe-fx+ dst-start_3 0)" +"(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 1)))" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) tmp_3))))" +"(let-values()" +"(let-values(((a_8)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 0)))" +"((b_6)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 1)))" +"((c_5)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 2))))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 b_6)(getkey_3 a_8))" +"(less-than?_8 b_6 a_8))" +"(let-values()" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 b_6))" +"(less-than?_8 c_5 b_6))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) a_8)))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 a_8))" +"(less-than?_8 c_5 a_8))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) b_6)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) a_8)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) b_6)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) a_8))))))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 a_8))" +"(less-than?_8 c_5 a_8))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) a_8)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) b_6)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) b_6)))))))))))" +"(let-values()" +"(let-values(((work-vec_5)(make-vector(+ n_10(ceiling(/ n_10 2))) #f)))" +"(begin" +"(vector-copy! work-vec_5 0 vec_6 start_3 end_3)" +"(generic-sort/key_0 work-vec_5 less-than?_8 n_10 getkey_3)" +"(vector-copy! dst-vec_3 dst-start_3 work-vec_5 0 n_10))))))))" +"(void)))))" +"(vector-sort! vec_6 less-than?_8 start_3 end_3)))))))))" +"(define-values" +"(prop:stream stream-via-prop? stream-ref)" +"(make-struct-type-property" +" 'stream" +"(lambda(v_11 si_0)" +"(begin" +"(if(if(vector? v_11)" +"(if(= 3(vector-length v_11))" +"(if(procedure?(vector-ref v_11 0))" +"(if(procedure-arity-includes?(vector-ref v_11 0) 1)" +"(if(procedure?(vector-ref v_11 1))" +"(if(procedure-arity-includes?(vector-ref v_11 1) 1)" +"(if(procedure?(vector-ref v_11 2))(procedure-arity-includes?(vector-ref v_11 2) 1) #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:stream" +"(string-append" +" \"(vector/c (procedure-arity-includes/c 1)\\n\"" +" \" (procedure-arity-includes/c 1)\\n\"" +" \" (procedure-arity-includes/c 1))\")" +" v_11)))" +"(vector->immutable-vector v_11)))))" +"(define-values" +"(prop:gen-sequence sequence-via-prop? sequence-ref)" +"(make-struct-type-property" +" 'sequence" +"(lambda(v_12 si_1)" +"(begin" +"(if(if(procedure? v_12)(procedure-arity-includes? v_12 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'guard-for-prop:sequence \"(procedure-arity-includes/c 1)\" v_12)))" +" v_12))))" +"(define-values" +"(struct:range make-range range? range-ref range-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons" +" prop:stream" +"(vector" +"(lambda(v_13)(let-values(((cont?_0)(range-ref v_13 2)))(if cont?_0(not(cont?_0(range-ref v_13 0))) #f)))" +"(lambda(v_14)(range-ref v_14 0))" +"(lambda(v_15)(make-range((range-ref v_15 1)(range-ref v_15 0))(range-ref v_15 1)(range-ref v_15 2)))))" +"(cons" +" prop:gen-sequence" +"(lambda(v_16)(values values #f(range-ref v_16 1)(range-ref v_16 0)(range-ref v_16 2) #f #f))))))" +"(define-values" +"(check-range)" +"(lambda(a_9 b_7 step_0)" +"(begin" +"(begin" +" (if (real? a_9) (void) (let-values () (raise-argument-error 'in-range \"real?\" a_9)))" +" (if (real? b_7) (void) (let-values () (raise-argument-error 'in-range \"real?\" b_7)))" +" (if (real? step_0) (void) (let-values () (raise-argument-error 'in-range \"real?\" step_0)))))))" +"(define-values" +"(check-naturals)" +"(lambda(n_11)" +"(begin" +"(if(if(integer? n_11)(if(exact? n_11)(>= n_11 0) #f) #f)" +"(void)" +" (let-values () (raise-argument-error 'in-naturals \"exact-nonnegative-integer?\" n_11))))))" +"(define-values" +"(struct:list-stream make-list-stream list-stream? list-stream-ref list-stream-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:stream" +"(vector" +"(lambda(v_17)(not(pair?(list-stream-ref v_17 0))))" +"(lambda(v_18)(car(list-stream-ref v_18 0)))" +"(lambda(v_19)(make-list-stream(cdr(list-stream-ref v_19 0))))))" +"(cons prop:gen-sequence(lambda(v_20)(values car cdr values(list-stream-ref v_20 0) pair? #f #f))))))" +"(define-values" +"(check-list)" +" (lambda (l_5) (begin (if (list? l_5) (void) (let-values () (raise-argument-error 'in-list \"list?\" l_5))))))" +"(define-values" +"(check-in-hash)" +"(lambda(ht_6)" +"(begin" +" (if ((lambda (ht_7) (hash? ht_7)) ht_6) (void) (let-values () (raise-argument-error 'in-hash \"hash?\" ht_6))))))" +"(define-values" +"(check-in-immutable-hash)" +"(lambda(ht_8)" +"(begin" +"(if((lambda(ht_9)(if(hash? ht_9)(immutable? ht_9) #f)) ht_8)" +"(void)" +" (let-values () (raise-argument-error 'in-immutable-hash \"(and/c hash? immutable?)\" ht_8))))))" +"(define-values" +"(check-in-hash-keys)" +"(lambda(ht_10)" +"(begin" +"(if((lambda(ht_11)(hash? ht_11)) ht_10)" +"(void)" +" (let-values () (raise-argument-error 'in-hash-keys \"hash?\" ht_10))))))" +"(define-values" +"(check-in-immutable-hash-keys)" +"(lambda(ht_12)" +"(begin" +"(if((lambda(ht_13)(if(hash? ht_13)(immutable? ht_13) #f)) ht_12)" +"(void)" +" (let-values () (raise-argument-error 'in-immutable-hash-keys \"(and/c hash? immutable?)\" ht_12))))))" +"(define-values" +"(check-in-hash-values)" +"(lambda(ht_14)" +"(begin" +"(if((lambda(ht_15)(hash? ht_15)) ht_14)" +"(void)" +" (let-values () (raise-argument-error 'in-hash-values \"hash?\" ht_14))))))" +"(define-values" +"(check-ranges)" +"(lambda(who_3 vec_7 start_4 stop_0 step_1 len_0)" +"(begin" +"(begin" +"(if(if(exact-nonnegative-integer? start_4)" +"(let-values(((or-part_20)(< start_4 len_0)))(if or-part_20 or-part_20(= len_0 start_4 stop_0)))" +" #f)" +"(void)" +" (let-values () (raise-range-error who_3 \"vector\" \"starting \" start_4 vec_7 0 (sub1 len_0))))" +"(if(if(exact-integer? stop_0)(if(<= -1 stop_0)(<= stop_0 len_0) #f) #f)" +"(void)" +" (let-values () (raise-range-error who_3 \"vector\" \"stopping \" stop_0 vec_7 -1 len_0)))" +"(if(if(exact-integer? step_1)(not(zero? step_1)) #f)" +"(void)" +" (let-values () (raise-argument-error who_3 \"(and/c exact-integer? (not/c zero?))\" step_1)))" +"(if(if(< start_4 stop_0)(< step_1 0) #f)" +"(let-values()" +"(raise-arguments-error" +" who_3" +" \"starting index less than stopping index, but given a negative step\"" +" \"starting index\"" +" start_4" +" \"stopping index\"" +" stop_0" +" \"step\"" +" step_1))" +"(void))" +"(if(if(< stop_0 start_4)(> step_1 0) #f)" +"(let-values()" +"(raise-arguments-error" +" who_3" +" \"starting index more than stopping index, but given a positive step\"" +" \"starting index\"" +" start_4" +" \"stopping index\"" +" stop_0" +" \"step\"" +" step_1))" +"(void))))))" +"(define-values" +"(normalise-inputs)" +"(lambda(who_4 type-name_0 vector?_0 unsafe-vector-length_0 vec_8 start_5 stop_1 step_2)" +"(begin" +"(begin" +"(if(vector?_0 vec_8)(void)(let-values()(raise-argument-error who_4 type-name_0 vec_8)))" +"(let-values(((len_1)(unsafe-vector-length_0 vec_8)))" +"(let-values(((stop*_0)(if stop_1 stop_1 len_1)))" +"(begin(check-ranges who_4 vec_8 start_5 stop*_0 step_2 len_1)(values vec_8 start_5 stop*_0 step_2))))))))" +"(define-values" +"(check-vector)" +" (lambda (v_21) (begin (if (vector? v_21) (void) (let-values () (raise-argument-error 'in-vector \"vector\" v_21))))))" +"(define-values" +"(check-string)" +" (lambda (v_22) (begin (if (string? v_22) (void) (let-values () (raise-argument-error 'in-string \"string\" v_22))))))" +"(define-values" +"(check-bytes)" +" (lambda (v_23) (begin (if (bytes? v_23) (void) (let-values () (raise-argument-error 'in-bytes \"bytes\" v_23))))))" +"(define-values" +"(struct:do-stream make-do-stream do-stream? do-stream-ref do-stream-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons" +" prop:stream" +"(vector" +"(lambda(v_24)((do-stream-ref v_24 0)))" +"(lambda(v_25)((do-stream-ref v_25 1)))" +"(lambda(v_26)((do-stream-ref v_26 2))))))))" +"(define-values(empty-stream)(make-do-stream(lambda() #t) void void))" +"(define-values" +"(grow-vector)" +"(lambda(vec_9)" +"(begin" +"(let-values(((n_12)(vector-length vec_9)))" +"(let-values(((new-vec_0)(make-vector(* 2 n_12))))" +"(begin(vector-copy! new-vec_0 0 vec_9 0 n_12) new-vec_0))))))" +"(define-values" +"(shrink-vector)" +"(lambda(vec_10 i_19)" +"(begin(let-values(((new-vec_1)(make-vector i_19)))(begin(vector-copy! new-vec_1 0 vec_10 0 i_19) new-vec_1)))))" +"(define-values" +"(map2)" +"(let-values(((map_0)" +"(case-lambda" +"((f_0 l_6)" +"(begin" +" 'map" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_0)(if(procedure-arity-includes? f_0 1)(list? l_6) #f) #f))" +"((letrec-values(((loop_33)" +"(lambda(l_7)" +"(begin" +" 'loop" +"(if(null? l_7)" +"(let-values() null)" +"(let-values()" +"(let-values(((r_4)(cdr l_7)))" +"(cons(f_0(car l_7))(loop_33 r_4)))))))))" +" loop_33)" +" l_6)" +"(gen-map f_0(list l_6)))))" +"((f_1 l1_0 l2_0)" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_1)" +"(if(procedure-arity-includes? f_1 2)" +"(if(list? l1_0)(if(list? l2_0)(=(length l1_0)(length l2_0)) #f) #f)" +" #f)" +" #f))" +"((letrec-values(((loop_34)" +"(lambda(l1_1 l2_1)" +"(begin" +" 'loop" +"(if(null? l1_1)" +"(let-values() null)" +"(let-values()" +"(let-values(((r1_0)(cdr l1_1))((r2_0)(cdr l2_1)))" +"(cons(f_1(car l1_1)(car l2_1))(loop_34 r1_0 r2_0)))))))))" +" loop_34)" +" l1_0" +" l2_0)" +"(gen-map f_1(list l1_0 l2_0))))" +"((f_2 l_8 . args_0)(gen-map f_2(cons l_8 args_0))))))" +" map_0))" +"(define-values" +"(for-each2)" +"(let-values(((for-each_0)" +"(case-lambda" +"((f_3 l_9)" +"(begin" +" 'for-each" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_3)(if(procedure-arity-includes? f_3 1)(list? l_9) #f) #f))" +"((letrec-values(((loop_35)" +"(lambda(l_10)" +"(begin" +" 'loop" +"(if(null? l_10)" +"(let-values()(void))" +"(let-values()" +"(let-values(((r_5)(cdr l_10)))" +"(begin(f_3(car l_10))(loop_35 r_5)))))))))" +" loop_35)" +" l_9)" +"(gen-for-each f_3(list l_9)))))" +"((f_4 l1_2 l2_2)" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_4)" +"(if(procedure-arity-includes? f_4 2)" +"(if(list? l1_2)(if(list? l2_2)(=(length l1_2)(length l2_2)) #f) #f)" +" #f)" +" #f))" +"((letrec-values(((loop_36)" +"(lambda(l1_3 l2_3)" +"(begin" +" 'loop" +"(if(null? l1_3)" +"(let-values()(void))" +"(let-values()" +"(let-values(((r1_1)(cdr l1_3))((r2_1)(cdr l2_3)))" +"(begin(f_4(car l1_3)(car l2_3))(loop_36 r1_1 r2_1)))))))))" +" loop_36)" +" l1_2" +" l2_2)" +"(gen-for-each f_4(list l1_2 l2_2))))" +"((f_5 l_11 . args_1)(gen-for-each f_5(cons l_11 args_1))))))" +" for-each_0))" +"(define-values" +"(andmap2)" +"(let-values(((andmap_0)" +"(case-lambda" +"((f_6 l_12)" +"(begin" +" 'andmap" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_6)(if(procedure-arity-includes? f_6 1)(list? l_12) #f) #f))" +"(if(null? l_12)" +" #t" +"((letrec-values(((loop_37)" +"(lambda(l_13)" +"(begin" +" 'loop" +"(if(null?(cdr l_13))" +"(let-values()(f_6(car l_13)))" +"(let-values()" +"(let-values(((r_6)(cdr l_13)))" +"(if(f_6(car l_13))(loop_37 r_6) #f))))))))" +" loop_37)" +" l_12))" +"(gen-andmap f_6(list l_12)))))" +"((f_7 l1_4 l2_4)" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_7)" +"(if(procedure-arity-includes? f_7 2)" +"(if(list? l1_4)(if(list? l2_4)(=(length l1_4)(length l2_4)) #f) #f)" +" #f)" +" #f))" +"(if(null? l1_4)" +" #t" +"((letrec-values(((loop_38)" +"(lambda(l1_5 l2_5)" +"(begin" +" 'loop" +"(if(null?(cdr l1_5))" +"(let-values()(f_7(car l1_5)(car l2_5)))" +"(let-values()" +"(let-values(((r1_2)(cdr l1_5))((r2_2)(cdr l2_5)))" +"(if(f_7(car l1_5)(car l2_5))(loop_38 r1_2 r2_2) #f))))))))" +" loop_38)" +" l1_4" +" l2_4))" +"(gen-andmap f_7(list l1_4 l2_4))))" +"((f_8 l_14 . args_2)(gen-andmap f_8(cons l_14 args_2))))))" +" andmap_0))" +"(define-values" +"(ormap2)" +"(let-values(((ormap_0)" +"(case-lambda" +"((f_9 l_15)" +"(begin" +" 'ormap" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_9)(if(procedure-arity-includes? f_9 1)(list? l_15) #f) #f))" +"(if(null? l_15)" +" #f" +"((letrec-values(((loop_39)" +"(lambda(l_16)" +"(begin" +" 'loop" +"(if(null?(cdr l_16))" +"(let-values()(f_9(car l_16)))" +"(let-values()" +"(let-values(((r_7)(cdr l_16)))" +"(let-values(((or-part_21)(f_9(car l_16))))" +"(if or-part_21 or-part_21(loop_39 r_7))))))))))" +" loop_39)" +" l_15))" +"(gen-ormap f_9(list l_15)))))" +"((f_10 l1_6 l2_6)" +"(if(if(variable-reference-from-unsafe?(#%variable-reference))" +" #t" +"(if(procedure? f_10)" +"(if(procedure-arity-includes? f_10 2)" +"(if(list? l1_6)(if(list? l2_6)(=(length l1_6)(length l2_6)) #f) #f)" +" #f)" +" #f))" +"(if(null? l1_6)" +" #f" +"((letrec-values(((loop_40)" +"(lambda(l1_7 l2_7)" +"(begin" +" 'loop" +"(if(null?(cdr l1_7))" +"(let-values()(f_10(car l1_7)(car l2_7)))" +"(let-values()" +"(let-values(((r1_3)(cdr l1_7))((r2_3)(cdr l2_7)))" +"(let-values(((or-part_22)(f_10(car l1_7)(car l2_7))))" +"(if or-part_22 or-part_22(loop_40 r1_3 r2_3))))))))))" +" loop_40)" +" l1_6" +" l2_6))" +"(gen-ormap f_10(list l1_6 l2_6))))" +"((f_11 l_17 . args_3)(gen-ormap f_11(cons l_17 args_3))))))" +" ormap_0))" +"(define-values" +"(check-args)" +"(lambda(who_5 f_12 ls_4)" +"(begin" +"(begin" +" (if (procedure? f_12) (void) (let-values () (raise-argument-error who_5 \"procedure?\" f_12)))" +"((letrec-values(((loop_41)" +"(lambda(prev-len_0 ls_5 i_20)" +"(begin" +" 'loop" +"(if(null? ls_5)" +"(void)" +"(let-values()" +"(let-values(((l_18)(car ls_5)))" +"(begin" +" (if (list? l_18) (void) (let-values () (raise-argument-error who_5 \"list?\" l_18)))" +"(let-values(((len_2)(length l_18)))" +"(begin" +"(if(if prev-len_0(not(= len_2 prev-len_0)) #f)" +"(let-values()" +"(raise-arguments-error" +" who_5" +" \"all lists must have same size\"" +" \"first list length\"" +" prev-len_0" +" \"other list length\"" +" len_2" +" \"procedure\"" +" f_12))" +"(void))" +"(loop_41 len_2(cdr ls_5)(add1 i_20))))))))))))" +" loop_41)" +" #f" +" ls_4" +" 1)" +"(if(procedure-arity-includes? f_12(length ls_4))" +"(void)" +"(let-values()" +"(let-values(((required-keywords_0 optional-keywords_0)(procedure-keywords f_12)))" +"(apply" +" raise-arguments-error" +" who_5" +"(if(pair? required-keywords_0)" +" (string-append \"argument mismatch;\\n\" \" the given procedure expects keyword arguments\")" +"(string-append" +" \"argument mismatch;\\n\"" +" \" the given procedure's expected number of arguments does not match\"" +" \" the given number of lists\"))" +" \"given procedure\"" +"(unquoted-printing-string" +"(let-values(((or-part_23)" +"(let-values(((n_13)(object-name f_12)))(if(symbol? n_13)(symbol->string n_13) #f))))" +" (if or-part_23 or-part_23 \"#\")))" +"(append" +"(let-values(((a_10)(procedure-arity f_12)))" +"(if(pair? required-keywords_0)" +"(let-values() null)" +"(if(integer? a_10)" +" (let-values () (list \"expected\" a_10))" +"(if(arity-at-least? a_10)" +"(let-values()" +"(list" +" \"expected\"" +"(unquoted-printing-string" +" (string-append \"at least \" (number->string (arity-at-least-value a_10))))))" +"(let-values() null)))))" +" (if (pair? required-keywords_0) (let-values () null) (let-values () (list \"given\" (length ls_4))))" +"(if(pair? required-keywords_0)" +"(let-values()" +"(list" +" \"required keywords\"" +"(unquoted-printing-string" +"(apply" +" string-append" +"(cdr" +"((letrec-values(((loop_42)" +"(lambda(kws_0)" +"(begin" +" 'loop" +"(if(null? kws_0)" +"(let-values() null)" +"(let-values()" +"(list*" +" \" \"" +" (string-append \"#:\" (keyword->string (car kws_0)))" +"(loop_42(cdr kws_0)))))))))" +" loop_42)" +" required-keywords_0))))))" +"(let-values() null))" +"(let-values(((w_0)(quotient(error-print-width)(length ls_4))))" +"(if(> w_0 10)" +"(list" +" \"argument lists...\"" +"(unquoted-printing-string" +"(apply" +" string-append" +"((letrec-values(((loop_43)" +"(lambda(ls_6)" +"(begin" +" 'loop" +"(if(null? ls_6)" +"(let-values() null)" +"(let-values()" +"(cons" +" (string-append \"\\n \" ((error-value->string-handler) (car ls_6) w_0))" +"(loop_43(cdr ls_6)))))))))" +" loop_43)" +" ls_4))))" +" null)))))))))))" +"(define-values" +"(gen-map)" +"(lambda(f_13 ls_7)" +"(begin" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference)) #t(check-args 'map f_13 ls_7))" +"((letrec-values(((loop_44)" +"(lambda(ls_8)" +"(begin" +" 'loop" +"(if(null?(car ls_8))" +"(let-values() null)" +"(let-values()" +"(let-values(((next-ls_0)(map2 cdr ls_8)))" +"(cons(apply f_13(map2 car ls_8))(loop_44 next-ls_0)))))))))" +" loop_44)" +" ls_7)))))" +"(define-values" +"(gen-for-each)" +"(lambda(f_14 ls_9)" +"(begin" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference)) #t(check-args 'for-each f_14 ls_9))" +"((letrec-values(((loop_45)" +"(lambda(ls_10)" +"(begin" +" 'loop" +"(if(null?(car ls_10))" +"(void)" +"(let-values()" +"(let-values(((next-ls_1)(map2 cdr ls_10)))" +"(begin(apply f_14(map2 car ls_10))(loop_45 next-ls_1)))))))))" +" loop_45)" +" ls_9)))))" +"(define-values" +"(gen-andmap)" +"(lambda(f_15 ls_11)" +"(begin" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference)) #t(check-args 'andmap f_15 ls_11))" +"((letrec-values(((loop_46)" +"(lambda(ls_12)" +"(begin" +" 'loop" +"(if(null?(car ls_12))" +"(let-values() #t)" +"(if(null?(cdar ls_12))" +"(let-values()(apply f_15(map2 car ls_12)))" +"(let-values()" +"(let-values(((next-ls_2)(map2 cdr ls_12)))" +"(if(apply f_15(map2 car ls_12))(loop_46 next-ls_2) #f)))))))))" +" loop_46)" +" ls_11)))))" +"(define-values" +"(gen-ormap)" +"(lambda(f_16 ls_13)" +"(begin" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference)) #t(check-args 'ormap f_16 ls_13))" +"((letrec-values(((loop_47)" +"(lambda(ls_14)" +"(begin" +" 'loop" +"(if(null?(car ls_14))" +"(let-values() #f)" +"(if(null?(cdar ls_14))" +"(let-values()(apply f_16(map2 car ls_14)))" +"(let-values()" +"(let-values(((next-ls_3)(map2 cdr ls_14)))" +"(let-values(((or-part_24)(apply f_16(map2 car ls_14))))" +"(if or-part_24 or-part_24(loop_47 next-ls_3)))))))))))" +" loop_47)" +" ls_13)))))" +"(define-values" +"(hash-keys)" +"(lambda(h_0)" +"(begin" +"((letrec-values(((loop_8)" +"(lambda(pos_0)" +"(begin" +" 'loop" +"(if pos_0" +"(cons(hash-iterate-key h_0 pos_0)(loop_8(hash-iterate-next h_0 pos_0)))" +" null)))))" +" loop_8)" +"(hash-iterate-first h_0)))))" +"(define-values" +"(sort7.1)" +"(lambda(cache-keys?2_0 key1_0 lst5_0 less?6_0)" +"(begin" +" 'sort7" +"(let-values(((lst_6) lst5_0))" +"(let-values(((less?_0) less?6_0))" +"(let-values(((getkey_4) key1_0))" +"(let-values(((cache-keys?_3) cache-keys?2_0))" +"(let-values()" +"(begin" +" (if (list? lst_6) (void) (let-values () (raise-argument-error 'sort \"list?\" lst_6)))" +"(if(if(procedure? less?_0)(procedure-arity-includes? less?_0 2) #f)" +"(void)" +" (let-values () (raise-argument-error 'sort \"(any/c any/c . -> . any/c)\" less?_0)))" +"(if(if getkey_4(not(if(procedure? getkey_4)(procedure-arity-includes? getkey_4 1) #f)) #f)" +" (let-values () (raise-argument-error 'sort \"(any/c . -> . any/c)\" getkey_4))" +"(void))" +"(if getkey_4(sort lst_6 less?_0 getkey_4 cache-keys?_3)(sort lst_6 less?_0)))))))))))" +"(define-values" +"(bad-list)" +" (lambda (who_5 orig-l_7) (begin (raise-mismatch-error who_5 \"not a proper list: \" orig-l_7))))" +"(define-values" +"(bad-item)" +" (lambda (who_6 a_11 orig-l_8) (begin (raise-mismatch-error who_6 \"non-pair found in list: \" a_11 \" in \" orig-l_8))))" +"(define-values" +"(1/assq 1/assv 1/assoc assf)" +"(let-values()" +"(let-values()" +"(let-values(((assq_0)" +"(lambda(x_9 l_19)" +"(begin" +" 'assq" +"((letrec-values(((loop_48)" +"(lambda(l_20 t_0)" +"(begin" +" 'loop" +"(if(pair? l_20)" +"(let-values()" +"(let-values(((a_12)(unsafe-car l_20)))" +"(if(pair? a_12)" +"(if(eq? x_9(unsafe-car a_12))" +" a_12" +"(let-values(((l_21)(unsafe-cdr l_20)))" +"(if(pair? l_21)" +"(let-values()" +"(let-values(((a_0)(unsafe-car l_21)))" +"(if(pair? a_0)" +"(if(eq? x_9(unsafe-car a_0))" +" a_0" +"(let-values(((t_1)(unsafe-cdr t_0))" +"((l_22)(unsafe-cdr l_21)))" +"(if(eq? l_22 t_1)" +"(bad-list 'assq l_19)" +"(loop_48 l_22 t_1))))" +"(bad-item 'assq a_0 l_19))))" +"(if(null? l_21)" +"(let-values() #f)" +"(let-values()(bad-list 'assq l_19))))))" +"(bad-item 'assq a_12 l_19))))" +"(if(null? l_20)" +"(let-values() #f)" +"(let-values()(bad-list 'assq l_19))))))))" +" loop_48)" +" l_19" +" l_19))))" +"((assv_0)" +"(lambda(x_10 l_23)" +"(begin" +" 'assv" +"((letrec-values(((loop_49)" +"(lambda(l_24 t_2)" +"(begin" +" 'loop" +"(if(pair? l_24)" +"(let-values()" +"(let-values(((a_13)(unsafe-car l_24)))" +"(if(pair? a_13)" +"(if(eqv? x_10(unsafe-car a_13))" +" a_13" +"(let-values(((l_25)(unsafe-cdr l_24)))" +"(if(pair? l_25)" +"(let-values()" +"(let-values(((a_14)(unsafe-car l_25)))" +"(if(pair? a_14)" +"(if(eqv? x_10(unsafe-car a_14))" +" a_14" +"(let-values(((t_3)(unsafe-cdr t_2))" +"((l_26)(unsafe-cdr l_25)))" +"(if(eq? l_26 t_3)" +"(bad-list 'assv l_23)" +"(loop_49 l_26 t_3))))" +"(bad-item 'assv a_14 l_23))))" +"(if(null? l_25)" +"(let-values() #f)" +"(let-values()(bad-list 'assv l_23))))))" +"(bad-item 'assv a_13 l_23))))" +"(if(null? l_24)" +"(let-values() #f)" +"(let-values()(bad-list 'assv l_23))))))))" +" loop_49)" +" l_23" +" l_23))))" +"((assoc_0)" +"(case-lambda" +"((x_11 l_27)" +"(begin" +" 'assoc" +"((letrec-values(((loop_50)" +"(lambda(l_28 t_4)" +"(begin" +" 'loop" +"(if(pair? l_28)" +"(let-values()" +"(let-values(((a_15)(unsafe-car l_28)))" +"(if(pair? a_15)" +"(if(equal? x_11(unsafe-car a_15))" +" a_15" +"(let-values(((l_29)(unsafe-cdr l_28)))" +"(if(pair? l_29)" +"(let-values()" +"(let-values(((a_16)(unsafe-car l_29)))" +"(if(pair? a_16)" +"(if(equal? x_11(unsafe-car a_16))" +" a_16" +"(let-values(((t_5)(unsafe-cdr t_4))" +"((l_30)(unsafe-cdr l_29)))" +"(if(eq? l_30 t_5)" +"(bad-list 'assoc l_27)" +"(loop_50 l_30 t_5))))" +"(bad-item 'assoc a_16 l_27))))" +"(if(null? l_29)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_27))))))" +"(bad-item 'assoc a_15 l_27))))" +"(if(null? l_28)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_27))))))))" +" loop_50)" +" l_27" +" l_27)))" +"((x_12 l_31 is-equal?_0)" +"(begin" +"(if(if(procedure? is-equal?_0)(procedure-arity-includes? is-equal?_0 2) #f)" +"(void)" +" (let-values () (raise-argument-error 'assoc \"(any/c any/c . -> . any/c)\" is-equal?_0)))" +"((letrec-values(((loop_51)" +"(lambda(l_32 t_6)" +"(begin" +" 'loop" +"(if(pair? l_32)" +"(let-values()" +"(let-values(((a_17)(unsafe-car l_32)))" +"(if(pair? a_17)" +"(if(is-equal?_0 x_12(unsafe-car a_17))" +" a_17" +"(let-values(((l_33)(unsafe-cdr l_32)))" +"(if(pair? l_33)" +"(let-values()" +"(let-values(((a_18)(unsafe-car l_33)))" +"(if(pair? a_18)" +"(if(is-equal?_0 x_12(unsafe-car a_18))" +" a_18" +"(let-values(((t_7)(unsafe-cdr t_6))" +"((l_34)(unsafe-cdr l_33)))" +"(if(eq? l_34 t_7)" +"(bad-list 'assoc l_31)" +"(loop_51 l_34 t_7))))" +"(bad-item 'assoc a_18 l_31))))" +"(if(null? l_33)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_31))))))" +"(bad-item 'assoc a_17 l_31))))" +"(if(null? l_32)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_31))))))))" +" loop_51)" +" l_31" +" l_31)))))" +"((assf_0)" +"(lambda(f_17 l_35)" +"(begin" +" 'assf" +"(begin" +"(if(if(procedure? f_17)(procedure-arity-includes? f_17 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'assf \"(any/c any/c . -> . any/c)\" f_17)))" +"((letrec-values(((loop_52)" +"(lambda(l_36 t_8)" +"(begin" +" 'loop" +"(if(pair? l_36)" +"(let-values()" +"(let-values(((a_19)(unsafe-car l_36)))" +"(if(pair? a_19)" +"(if((lambda(__0 a_20)(f_17 a_20)) #f(unsafe-car a_19))" +" a_19" +"(let-values(((l_37)(unsafe-cdr l_36)))" +"(if(pair? l_37)" +"(let-values()" +"(let-values(((a_21)(unsafe-car l_37)))" +"(if(pair? a_21)" +"(if((lambda(__1 a_22)(f_17 a_22))" +" #f" +"(unsafe-car a_21))" +" a_21" +"(let-values(((t_9)(unsafe-cdr t_8))" +"((l_38)(unsafe-cdr l_37)))" +"(if(eq? l_38 t_9)" +"(bad-list 'assf l_35)" +"(loop_52 l_38 t_9))))" +"(bad-item 'assf a_21 l_35))))" +"(if(null? l_37)" +"(let-values() #f)" +"(let-values()(bad-list 'assf l_35))))))" +"(bad-item 'assf a_19 l_35))))" +"(if(null? l_36)" +"(let-values() #f)" +"(let-values()(bad-list 'assf l_35))))))))" +" loop_52)" +" l_35" +" l_35))))))" +"(values assq_0 assv_0 assoc_0 assf_0)))))" +"(define-values" +"(filter)" +"(lambda(f_18 list_0)" +"(begin" +"(begin" +"(if(if(procedure? f_18)(procedure-arity-includes? f_18 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'filter \"(any/c . -> . any/c)\" f_18)))" +" (if (list? list_0) (void) (let-values () (raise-argument-error 'filter \"list?\" list_0)))" +"((letrec-values(((loop_53)" +"(lambda(l_39 result_0)" +"(begin" +" 'loop" +"(if(null? l_39)" +"(reverse$1 result_0)" +"(loop_53(cdr l_39)(if(f_18(car l_39))(cons(car l_39) result_0) result_0)))))))" +" loop_53)" +" list_0" +" null)))))" +"(define-values(no-empty-edge-table)(make-hash))" +" (define-values (binary-or-text-desc) \"(or/c 'binary 'text)\")" +"(define-values" +"(open-input-file6.1)" +"(lambda(for-module?2_0 mode1_0 path5_0)" +"(begin" +" 'open-input-file6" +"(let-values(((path_0) path5_0))" +"(let-values(((mode_0) mode1_0))" +"(let-values(((for-module?_0) for-module?2_0))" +"(let-values()" +"(begin" +"(if(path-string? path_0)" +"(void)" +" (let-values () (raise-argument-error 'open-input-file \"path-string?\" path_0)))" +"(if(memq mode_0 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'open-input-file binary-or-text-desc mode_0)))" +"(open-input-file path_0 mode_0(if for-module?_0 'module 'none))))))))))" +"(define-values" +"(with-input-from-file45.1)" +"(lambda(mode41_0 path43_0 proc44_0)" +"(begin" +" 'with-input-from-file45" +"(let-values(((path_1) path43_0))" +"(let-values(((proc_0) proc44_0))" +"(let-values(((mode_1) mode41_0))" +"(let-values()" +"(begin" +"(if(path-string? path_1)" +"(void)" +" (let-values () (raise-argument-error 'with-input-from-file \"path-string?\" path_1)))" +"(if(if(procedure? proc_0)(procedure-arity-includes? proc_0 0) #f)" +"(void)" +" (let-values () (raise-argument-error 'with-input-from-file \"(-> any)\" proc_0)))" +"(if(memq mode_1 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'with-input-from-file binary-or-text-desc mode_1)))" +"(with-input-from-file path_1 proc_0 mode_1)))))))))" +"(define-values" +"(call-with-input-file*61.1)" +"(lambda(mode57_0 path59_0 proc60_0)" +"(begin" +" 'call-with-input-file*61" +"(let-values(((path_2) path59_0))" +"(let-values(((proc_1) proc60_0))" +"(let-values(((mode_2) mode57_0))" +"(let-values()" +"(begin" +"(if(path-string? path_2)" +"(void)" +" (let-values () (raise-argument-error 'call-with-input-file* \"path-string?\" path_2)))" +"(if(if(procedure? proc_1)(procedure-arity-includes? proc_1 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'call-with-input-file* \"(input-port? . -> . any)\" proc_1)))" +"(if(memq mode_2 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'call-with-input-file* binary-or-text-desc mode_2)))" +"(let-values(((p_3)(open-input-file path_2 mode_2)))" +"(dynamic-wind void(lambda()(proc_1 p_3))(lambda()(close-input-port p_3))))))))))))" +"(define-values(the-empty-hash) '#hash())" +"(define-values(the-empty-hasheq) '#hasheq())" +"(define-values(the-empty-hasheqv) '#hasheqv())" +"(define-values" +"(set)" +"(case-lambda" +"(()(begin the-empty-hash))" +"(l_40" +"(let-values(((lst_7) l_40))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_7)))" +"((letrec-values(((for-loop_0)" +"(lambda(s_11 lst_8)" +"(begin" +" 'for-loop" +"(if(pair? lst_8)" +"(let-values(((e_2)(unsafe-car lst_8))((rest_0)(unsafe-cdr lst_8)))" +"(let-values(((s_12)" +"(let-values(((s_13) s_11))" +"(let-values(((s_14)(let-values()(hash-set s_13 e_2 #t))))" +"(values s_14)))))" +"(if(not #f)(for-loop_0 s_12 rest_0) s_12)))" +" s_11)))))" +" for-loop_0)" +" the-empty-hash" +" lst_7))))))" +"(define-values" +"(seteq)" +"(case-lambda" +"(()(begin the-empty-hasheq))" +"(l_41" +"(let-values(((lst_9) l_41))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_9)))" +"((letrec-values(((for-loop_1)" +"(lambda(s_15 lst_10)" +"(begin" +" 'for-loop" +"(if(pair? lst_10)" +"(let-values(((e_3)(unsafe-car lst_10))((rest_1)(unsafe-cdr lst_10)))" +"(let-values(((s_16)" +"(let-values(((s_17) s_15))" +"(let-values(((s_18)(let-values()(hash-set s_17 e_3 #t))))" +"(values s_18)))))" +"(if(not #f)(for-loop_1 s_16 rest_1) s_16)))" +" s_15)))))" +" for-loop_1)" +" the-empty-hasheq" +" lst_9))))))" +"(define-values(seteqv)(lambda()(begin the-empty-hasheqv)))" +"(define-values(set?)(lambda(s_19)(begin(hash? s_19))))" +"(define-values(set-empty?)(lambda(s_20)(begin(zero?(hash-count s_20)))))" +"(define-values(set-member?)(lambda(s_21 e_4)(begin(hash-ref s_21 e_4 #f))))" +"(define-values(set-count)(lambda(s_22)(begin(hash-count s_22))))" +"(define-values(set-add)(lambda(s_23 e_5)(begin(hash-set s_23 e_5 #t))))" +"(define-values(set-remove)(lambda(s_24 e_6)(begin(hash-remove s_24 e_6))))" +"(define-values(set-first)(lambda(s_25)(begin(hash-iterate-key s_25(hash-iterate-first s_25)))))" +"(define-values(subset?)(lambda(s1_0 s2_0)(begin(hash-keys-subset? s1_0 s2_0))))" +"(define-values" +"(set=?)" +"(lambda(s1_1 s2_1)" +"(begin" +"(let-values(((or-part_25)(eq? s1_1 s2_1)))" +"(if or-part_25 or-part_25(if(=(hash-count s1_1)(hash-count s2_1))(hash-keys-subset? s1_1 s2_1) #f))))))" +"(define-values" +"(set-subtract)" +"(lambda(s1_2 s2_2)" +"(begin" +"(let-values(((ht_16) s2_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_16)))" +"((letrec-values(((for-loop_2)" +"(lambda(s1_3 i_21)" +"(begin" +" 'for-loop" +"(if i_21" +"(let-values(((k_0)(unsafe-immutable-hash-iterate-key ht_16 i_21)))" +"(let-values(((s1_4)" +"(let-values(((s1_5) s1_3))" +"(let-values(((s1_6)(let-values()(hash-remove s1_5 k_0))))" +"(values s1_6)))))" +"(if(not #f)" +"(for-loop_2 s1_4(unsafe-immutable-hash-iterate-next ht_16 i_21))" +" s1_4)))" +" s1_3)))))" +" for-loop_2)" +" s1_2" +"(unsafe-immutable-hash-iterate-first ht_16)))))))" +"(define-values" +"(set-union)" +"(lambda(s1_7 s2_3)" +"(begin" +"(if(<(set-count s1_7)(set-count s2_3))" +"(set-union s2_3 s1_7)" +"(let-values(((ht_17) s2_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_17)))" +"((letrec-values(((for-loop_3)" +"(lambda(s1_8 i_22)" +"(begin" +" 'for-loop" +"(if i_22" +"(let-values(((k_1)(unsafe-immutable-hash-iterate-key ht_17 i_22)))" +"(let-values(((s1_9)" +"(let-values(((s1_10) s1_8))" +"(let-values(((s1_11)(let-values()(hash-set s1_10 k_1 #t))))" +"(values s1_11)))))" +"(if(not #f)" +"(for-loop_3 s1_9(unsafe-immutable-hash-iterate-next ht_17 i_22))" +" s1_9)))" +" s1_8)))))" +" for-loop_3)" +" s1_7" +"(unsafe-immutable-hash-iterate-first ht_17))))))))" +"(define-values" +"(set-intersect)" +"(lambda(s1_12 s2_4)" +"(begin" +"(if(<(set-count s1_12)(set-count s2_4))" +"(set-intersect s2_4 s1_12)" +"(let-values(((ht_18) s2_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_18)))" +"((letrec-values(((for-loop_4)" +"(lambda(s_26 i_23)" +"(begin" +" 'for-loop" +"(if i_23" +"(let-values(((k_2)(unsafe-immutable-hash-iterate-key ht_18 i_23)))" +"(let-values(((s_27)" +"(let-values(((s_28) s_26))" +"(let-values(((s_29)" +"(let-values()" +"(if(hash-ref s1_12 k_2 #f)" +" s_28" +"(hash-remove s_28 k_2)))))" +"(values s_29)))))" +"(if(not #f)" +"(for-loop_4 s_27(unsafe-immutable-hash-iterate-next ht_18 i_23))" +" s_27)))" +" s_26)))))" +" for-loop_4)" +" s2_4" +"(unsafe-immutable-hash-iterate-first ht_18))))))))" +"(define-values" +"(set-partition)" +"(lambda(s_30 pred_0 empty-y-set_0 empty-n-set_0)" +"(begin" +"(let-values(((ht_19) s_30))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_19)))" +"((letrec-values(((for-loop_5)" +"(lambda(y_6 n_14 i_24)" +"(begin" +" 'for-loop" +"(if i_24" +"(let-values(((v_27)(unsafe-immutable-hash-iterate-key ht_19 i_24)))" +"(let-values(((y_7 n_15)" +"(let-values(((y_8) y_6)((n_16) n_14))" +"(let-values(((y_9 n_17)" +"(let-values()" +"(if(pred_0 v_27)" +"(values(set-add y_8 v_27) n_16)" +"(values y_8(set-add n_16 v_27))))))" +"(values y_9 n_17)))))" +"(if(not #f)" +"(for-loop_5 y_7 n_15(unsafe-immutable-hash-iterate-next ht_19 i_24))" +"(values y_7 n_15))))" +"(values y_6 n_14))))))" +" for-loop_5)" +" empty-y-set_0" +" empty-n-set_0" +"(unsafe-immutable-hash-iterate-first ht_19)))))))" +"(define-values" +"(set->list)" +"(lambda(s_31)" +"(begin" +"(reverse$1" +"(let-values(((ht_20) s_31))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_20)))" +"((letrec-values(((for-loop_6)" +"(lambda(fold-var_0 i_25)" +"(begin" +" 'for-loop" +"(if i_25" +"(let-values(((k_3)(unsafe-immutable-hash-iterate-key ht_20 i_25)))" +"(let-values(((fold-var_1)" +"(let-values(((fold-var_2) fold-var_0))" +"(let-values(((fold-var_3)" +"(let-values()" +"(cons(let-values() k_3) fold-var_2))))" +"(values fold-var_3)))))" +"(if(not #f)" +"(for-loop_6 fold-var_1(unsafe-immutable-hash-iterate-next ht_20 i_25))" +" fold-var_1)))" +" fold-var_0)))))" +" for-loop_6)" +" null" +"(unsafe-immutable-hash-iterate-first ht_20))))))))" +"(define-values" +"(list->set)" +"(lambda(l_42)" +"(begin" +"(let-values(((lst_11) l_42))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_11)))" +"((letrec-values(((for-loop_7)" +"(lambda(table_0 lst_12)" +"(begin" +" 'for-loop" +"(if(pair? lst_12)" +"(let-values(((k_4)(unsafe-car lst_12))((rest_2)(unsafe-cdr lst_12)))" +"(let-values(((table_1)" +"(let-values(((table_2) table_0))" +"(let-values(((table_3)" +"(let-values()" +"(let-values(((key_7 val_0)" +"(let-values()" +"(values(let-values() k_4) #t))))" +"(hash-set table_2 key_7 val_0)))))" +"(values table_3)))))" +"(if(not #f)(for-loop_7 table_1 rest_2) table_1)))" +" table_0)))))" +" for-loop_7)" +" '#hash()" +" lst_11))))))" +"(define-values" +"(list->seteq)" +"(lambda(l_43)" +"(begin" +"(let-values(((lst_13) l_43))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_13)))" +"((letrec-values(((for-loop_8)" +"(lambda(table_4 lst_14)" +"(begin" +" 'for-loop" +"(if(pair? lst_14)" +"(let-values(((k_5)(unsafe-car lst_14))((rest_3)(unsafe-cdr lst_14)))" +"(let-values(((table_5)" +"(let-values(((table_6) table_4))" +"(let-values(((table_7)" +"(let-values()" +"(let-values(((key_8 val_1)" +"(let-values()" +"(values(let-values() k_5) #t))))" +"(hash-set table_6 key_8 val_1)))))" +"(values table_7)))))" +"(if(not #f)(for-loop_8 table_5 rest_3) table_5)))" +" table_4)))))" +" for-loop_8)" +" '#hasheq()" +" lst_13))))))" +"(define-values(start-atomic)(lambda()(begin(unsafe-start-atomic))))" +"(define-values(end-atomic)(lambda()(begin(unsafe-end-atomic))))" +"(define-values(start-breakable-atomic)(lambda()(begin(unsafe-start-breakable-atomic))))" +"(define-values(end-breakable-atomic)(lambda()(begin(unsafe-end-breakable-atomic))))" +"(define-values(monitor-owner) #f)" +"(define-values" +"(entered-err-string-handler)" +"(lambda(s_0 n_18)(begin(call-as-nonatomic(lambda()((error-value->string-handler) s_0 n_18))))))" +"(define-values(old-paramz) #f)" +"(define-values(old-break-paramz) #f)" +"(define-values(extra-atomic-depth) 0)" +"(define-values(exited-key)(gensym 'as-exit))" +"(define-values(lock-tag)(make-continuation-prompt-tag 'lock))" +"(define-values" +"(call-as-atomic)" +"(lambda(f_19)" +"(begin" +"(begin" +"(if(if(procedure? f_19)(procedure-arity-includes? f_19 0) #f)" +"(void)" +" (let-values () (raise-type-error 'call-as-atomic \"procedure (arity 0)\" f_19)))" +"(if(eq? monitor-owner(current-thread))" +"(let-values()" +"(dynamic-wind" +"(lambda()(begin(start-breakable-atomic)(set! extra-atomic-depth(add1 extra-atomic-depth))))" +" f_19" +"(lambda()(begin(set! extra-atomic-depth(sub1 extra-atomic-depth))(end-breakable-atomic)))))" +"(let-values()" +"(with-continuation-mark" +" exited-key" +" #f" +"(call-with-continuation-prompt" +"(lambda()" +"(dynamic-wind" +"(lambda()(begin(start-breakable-atomic)(set! monitor-owner(current-thread))))" +"(lambda()" +"(begin" +"(set! old-paramz(current-parameterization))" +"(set! old-break-paramz(current-break-parameterization))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" error-value->string-handler" +" entered-err-string-handler)" +"(let-values()" +"(with-continuation-mark" +" break-enabled-key" +"(make-thread-cell #f)" +"(begin" +"(check-for-break)" +"(let-values()" +"(call-with-exception-handler" +"(lambda(exn_0)" +"(if(continuation-mark-set-first #f exited-key)" +" exn_0" +"(abort-current-continuation lock-tag(lambda()(raise exn_0)))))" +" f_19))))))))" +"(lambda()" +"(begin" +"(set! monitor-owner #f)" +"(set! old-paramz #f)" +"(set! old-break-paramz #f)" +"(end-breakable-atomic)))))" +" lock-tag" +"(lambda(t_10)(t_10))))))))))" +"(define-values" +"(call-as-nonatomic)" +"(lambda(f_20)" +"(begin" +"(begin" +"(if(if(procedure? f_20)(procedure-arity-includes? f_20 0) #f)" +"(void)" +" (let-values () (raise-type-error 'call-as-nonatomic \"procedure (arity 0)\" f_20)))" +"(if(eq? monitor-owner(current-thread))" +"(void)" +" (let-values () (error 'call-as-nonatomic \"not in atomic area for ~e\" f_20)))" +"(let-values(((paramz_2) old-paramz)((break-paramz_0) old-break-paramz)((extra-depth_0) extra-atomic-depth))" +"(with-continuation-mark" +" exited-key" +" #t" +"(call-with-parameterization" +" paramz_2" +"(lambda()" +"(call-with-break-parameterization" +" break-paramz_0" +"(lambda()" +"(dynamic-wind" +"(lambda()" +"(begin" +"(set! monitor-owner #f)" +"(set! extra-atomic-depth 0)" +"(end-breakable-atomic)" +"((letrec-values(((loop_54)" +"(lambda(i_26)" +"(begin" +" 'loop" +"(if(zero? i_26)" +"(void)" +"(let-values()(begin(end-breakable-atomic)(loop_54(sub1 i_26)))))))))" +" loop_54)" +" extra-depth_0)))" +" f_20" +"(lambda()" +"(begin" +"(start-breakable-atomic)" +"(set! old-paramz paramz_2)" +"(set! old-break-paramz break-paramz_0)" +"((letrec-values(((loop_55)" +"(lambda(i_27)" +"(begin" +" 'loop" +"(if(zero? i_27)" +"(void)" +"(let-values()" +"(begin(start-breakable-atomic)(loop_55(sub1 i_27)))))))))" +" loop_55)" +" extra-depth_0)" +"(set! extra-atomic-depth extra-depth_0)" +"(set! monitor-owner(current-thread)))))))))))))))" +"(define-values(prop:serialize serialize? serialize-ref)(make-struct-type-property 'serialize))" +"(define-values" +"(prop:serialize-fill! serialize-fill!? serialize-fill!-ref)" +"(make-struct-type-property 'serialize-fill!))" +"(define-values(prop:reach-scopes reach-scopes? reach-scopes-ref)(make-struct-type-property 'reach-scopes))" +"(define-values" +"(prop:scope-with-bindings scope-with-bindings? scope-with-bindings-ref)" +"(make-struct-type-property 'scope-with-bindings))" +"(define-values" +"(prop:binding-reach-scopes binding-reach-scopes? binding-reach-scopes-ref)" +"(make-struct-type-property 'binding-reach-scopes))" +"(define-values" +"(1/module-path?)" +"(lambda(v_28)" +"(begin" +" 'module-path?" +"(let-values(((or-part_0)(if(pair? v_28)(if(eq?(car v_28) 'submod)(submodule-module-path? v_28) #f) #f)))" +"(if or-part_0 or-part_0(root-module-path? v_28))))))" +"(define-values" +"(root-module-path?)" +"(lambda(v_29)" +"(begin" +"(let-values(((or-part_11)(path? v_29)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(if(string? v_29)(string-module-path? v_29) #f)))" +"(if or-part_2" +" or-part_2" +"(let-values(((or-part_26)(if(symbol? v_29)(symbol-module-path? v_29) #f)))" +"(if or-part_26" +" or-part_26" +"(if(pair? v_29)" +"(let-values(((tmp_4)(car v_29)))" +"(if(equal? tmp_4 'quote)" +"(let-values()(if(pair?(cdr v_29))(if(symbol?(cadr v_29))(null?(cddr v_29)) #f) #f))" +"(if(equal? tmp_4 'lib)" +"(let-values()(lib-module-path? v_29))" +"(if(equal? tmp_4 'file)" +"(let-values()" +"(if(pair?(cdr v_29))" +"(if(string?(cadr v_29))(if(path-string?(cadr v_29))(null?(cddr v_29)) #f) #f)" +" #f))" +"(if(equal? tmp_4 'planet)" +"(let-values()(planet-module-path? v_29))" +"(let-values() #f))))))" +" #f))))))))))" +"(define-values" +"(submodule-module-path?)" +"(lambda(v_30)" +"(begin" +"(if(pair?(cdr v_30))" +"(if(list? v_30)" +" (if (let-values (((or-part_27) (equal? (cadr v_30) \"..\")))" +"(if or-part_27" +" or-part_27" +" (let-values (((or-part_10) (equal? (cadr v_30) \".\")))" +"(if or-part_10 or-part_10(root-module-path?(cadr v_30))))))" +"(let-values(((lst_15)(cddr v_30)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_15)))" +"((letrec-values(((for-loop_9)" +"(lambda(result_1 lst_16)" +"(begin" +" 'for-loop" +"(if(pair? lst_16)" +"(let-values(((e_7)(unsafe-car lst_16))((rest_4)(unsafe-cdr lst_16)))" +"(let-values(((result_2)" +"(let-values()" +"(let-values(((result_3)" +"(let-values()" +"(let-values()" +"(let-values(((or-part_28)" +" (equal? e_7 \"..\")))" +"(if or-part_28" +" or-part_28" +"(symbol? e_7)))))))" +"(values result_3)))))" +"(if(if(not((lambda x_13(not result_2)) e_7))(not #f) #f)" +"(for-loop_9 result_2 rest_4)" +" result_2)))" +" result_1)))))" +" for-loop_9)" +" #t" +" lst_15)))" +" #f)" +" #f)" +" #f))))" +"(define-values" +"(string-module-path?)" +"(lambda(v_31)" +"(begin" +"(let-values(((v13_0) v_31)((temp14_0) #t)((temp15_0) #t)((temp16_0) #t))" +"(module-path-string?10.1 temp14_0 temp16_0 #f temp15_0 v13_0)))))" +"(define-values" +"(symbol-module-path?)" +"(lambda(v_32)" +"(begin(let-values(((temp17_0)(symbol->string v_32)))(module-path-string?10.1 #f #f #f #f temp17_0)))))" +"(define-values" +"(lib-module-path?)" +"(lambda(v_33)" +"(begin" +"(if(list? v_33)" +"(if(pair?(cdr v_33))" +"((letrec-values(((loop_56)" +"(lambda(v_34 first?_0)" +"(begin" +" 'loop" +"(let-values(((or-part_29)(null? v_34)))" +"(if or-part_29" +" or-part_29" +"(if(string?(car v_34))" +"(if(let-values(((temp18_0)(car v_34))" +"((first?19_0) first?_0)" +"((first?20_0) first?_0))" +"(module-path-string?10.1 #f first?20_0 #f first?19_0 temp18_0))" +"(loop_56(cdr v_34) #f)" +" #f)" +" #f)))))))" +" loop_56)" +"(cdr v_33)" +" #t)" +" #f)" +" #f))))" +"(define-values" +"(planet-module-path?)" +"(lambda(v_35)" +"(begin" +"(if(list? v_35)" +"(let-values(((tmp_5)(length v_35)))" +"(if(equal? tmp_5 1)" +"(let-values() #f)" +"(if(equal? tmp_5 2)" +"(let-values()" +"(let-values(((e_8)(cadr v_35)))" +"(if(string? e_8)" +"(let-values()" +"(let-values(((e21_0) e_8)((temp22_0) #t)((temp23_0) #t))" +"(module-path-string?10.1 #f temp23_0 temp22_0 #f e21_0)))" +"(if(symbol? e_8)" +"(let-values()" +"(let-values(((temp24_0)(symbol->string e_8))((temp25_0) #t))" +"(module-path-string?10.1 #f #f temp25_0 #f temp24_0)))" +"(let-values() #f)))))" +"(let-values()" +"(let-values(((file_0)(cadr v_35)))" +"(let-values(((pkg_0)(caddr v_35)))" +"(let-values(((subs_0)(cdddr v_35)))" +"(if file_0" +"(if(let-values(((file26_0) file_0)((temp27_0) #t)((temp28_0) #t))" +"(module-path-string?10.1 #f temp28_0 #f temp27_0 file26_0))" +"(if(if(list? pkg_0)" +"(if(<= 2(length pkg_0) 4)" +"(if(planet-user/pkg-string?(car pkg_0))" +"(if(planet-user/pkg-string?(cadr pkg_0))" +"(let-values(((or-part_30)(null?(cddr pkg_0))))" +"(if or-part_30" +" or-part_30" +"(let-values(((or-part_31)(planet-version-number?(caddr pkg_0))))" +"(if or-part_31" +" or-part_31" +"(let-values(((or-part_32)(null?(cddr pkg_0))))" +"(if or-part_32" +" or-part_32" +"(planet-version-minor-spec?(cadddr pkg_0))))))))" +" #f)" +" #f)" +" #f)" +" #f)" +"(let-values(((lst_17) subs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(result_4 lst_18)" +"(begin" +" 'for-loop" +"(if(pair? lst_18)" +"(let-values(((sub_0)(unsafe-car lst_18))" +"((rest_5)(unsafe-cdr lst_18)))" +"(let-values(((result_5)" +"(let-values()" +"(let-values(((result_6)" +"(let-values()" +"(let-values()" +"(let-values(((sub29_0)" +" sub_0))" +"(module-path-string?10.1" +" #f" +" #f" +" #f" +" #f" +" sub29_0))))))" +"(values result_6)))))" +"(if(if(not((lambda x_14(not result_5)) sub_0))" +"(not #f)" +" #f)" +"(for-loop_10 result_5 rest_5)" +" result_5)))" +" result_4)))))" +" for-loop_10)" +" #t" +" lst_17)))" +" #f)" +" #f)" +" #f))))))))" +" #f))))" +"(define-values(planet-version-number?)(lambda(v_36)(begin(exact-nonnegative-integer? v_36))))" +"(define-values" +"(planet-version-minor-spec?)" +"(lambda(v_37)" +"(begin" +"(let-values(((or-part_33)(planet-version-number? v_37)))" +"(if or-part_33" +" or-part_33" +"(if(pair? v_37)" +"(if(list? v_37)" +"(if(= 2(length v_37))" +"(let-values(((tmp_6)(car v_37)))" +"(if(if(equal? tmp_6 '=) #t(if(equal? tmp_6 '+) #t(equal? tmp_6 '-)))" +"(let-values()(planet-version-number?(cadr v_37)))" +"(let-values()(if(planet-version-number?(car v_37))(planet-version-number?(cadr v_37)) #f))))" +" #f)" +" #f)" +" #f))))))" +"(define-values" +"(module-path-string?10.1)" +"(lambda(dots-dir-ok?2_0 file-end-ok?4_0 for-planet?1_0 just-file-ok?3_0 v9_0)" +"(begin" +" 'module-path-string?10" +"(let-values(((v_38) v9_0))" +"(let-values(((for-planet?_0) for-planet?1_0))" +"(let-values(((dots-dir-ok?_0) dots-dir-ok?2_0))" +"(let-values(((just-file-ok?_0) just-file-ok?3_0))" +"(let-values(((file-end-ok?_0) file-end-ok?4_0))" +"(let-values()" +"(let-values(((len_3)(string-length v_38)))" +"(if(positive? len_3)" +"(if(not(char=? '#\\/(string-ref v_38 0)))" +"(if(not(char=? '#\\/(string-ref v_38(sub1 len_3))))" +"(let-values(((start-package-version-pos_0 end-package-version-pos_0)" +"(if for-planet?_0(check-planet-part v_38 len_3)(values 0 0))))" +"(if start-package-version-pos_0" +"((letrec-values(((loop_57)" +"(lambda(i_28 prev-was-slash?_0 saw-slash?_0 saw-dot?_0)" +"(begin" +" 'loop" +"(if(not(negative? i_28))" +"(let-values()" +"(let-values(((c_6)(string-ref v_38 i_28)))" +"(if(char=? c_6 '#\\/)" +"(let-values()" +"(if(not prev-was-slash?_0)" +"(loop_57(sub1 i_28) #t #t saw-dot?_0)" +" #f))" +"(if(char=? c_6 '#\\.)" +"(let-values()" +"(if(if(<(add1 i_28) len_3)" +"(if(not" +"(char=?(string-ref v_38(add1 i_28)) '#\\/))" +"(not" +"(char=?(string-ref v_38(add1 i_28)) '#\\.))" +" #f)" +" #f)" +"(if(not saw-slash?_0)" +"(loop_57(sub1 i_28) #f saw-slash?_0 #t)" +" #f)" +"(loop_57(sub1 i_28) #f saw-slash?_0 saw-dot?_0)))" +"(if(let-values(((or-part_34)(plain-char? c_6)))" +"(if or-part_34" +" or-part_34" +"(if(char=? c_6 '#\\%)" +"(if(<(+ i_28 2) len_3)" +"(hex-sequence? v_38(add1 i_28))" +" #f)" +" #f)))" +"(let-values()" +"(loop_57(sub1 i_28) #f saw-slash?_0 saw-dot?_0))" +"(if(if(>= i_28 start-package-version-pos_0)" +"(< i_28 end-package-version-pos_0)" +" #f)" +"(let-values()" +"(loop_57(sub1 i_28) #f saw-slash?_0 saw-dot?_0))" +"(let-values() #f)))))))" +"(let-values()" +"(if(not" +"(if(not just-file-ok?_0)" +"(if saw-dot?_0(not saw-slash?_0) #f)" +" #f))" +"(let-values(((or-part_35) dots-dir-ok?_0))" +"(if or-part_35" +" or-part_35" +"((letrec-values(((loop_44)" +"(lambda(i_29)" +"(begin" +" 'loop" +"(if(= i_29 len_3)" +"(let-values() #t)" +"(if(char=?" +"(string-ref v_38 i_29)" +" '#\\.)" +"(let-values()" +"(if(not" +"(let-values(((or-part_36)" +"(=" +" len_3" +"(add1" +" i_29))))" +"(if or-part_36" +" or-part_36" +"(char=?" +"(string-ref" +" v_38" +"(add1 i_29))" +" '#\\/))))" +"(if(not" +"(if(char=?" +"(string-ref" +" v_38" +"(add1 i_29))" +" '#\\.)" +"(let-values(((or-part_37)" +"(=" +" len_3" +"(+" +" i_29" +" 2))))" +"(if or-part_37" +" or-part_37" +"(char=?" +"(string-ref" +" v_38" +"(+ i_29 2))" +" '#\\/)))" +" #f))" +"(loop_44" +"((letrec-values(((loop_58)" +"(lambda(i_30)" +"(begin" +" 'loop" +"(if(char=?" +" '#\\." +"(string-ref" +" v_38" +" i_30))" +"(loop_58" +"(add1" +" i_30))" +" i_30)))))" +" loop_58)" +" i_29))" +" #f)" +" #f))" +"(let-values()" +"(loop_44(add1 i_29)))))))))" +" loop_44)" +" 0)))" +" #f)))))))" +" loop_57)" +"(sub1 len_3)" +" #f" +"(not file-end-ok?_0)" +" #f)" +" #f))" +" #f)" +" #f)" +" #f)))))))))))" +"(define-values" +"(planet-user/pkg-string?)" +"(lambda(v_39)" +"(begin" +"(if(string? v_39)" +"(let-values(((len_4)(string-length v_39)))" +"(if(positive? len_4)" +"(let-values(((vec_11 len_5)" +"(let-values(((vec_12) v_39))" +"(begin(check-string vec_12)(values vec_12(unsafe-string-length vec_12)))))" +"((start_6) 0))" +"(begin" +" #f" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_6)))" +"((letrec-values(((for-loop_11)" +"(lambda(result_7 pos_1 pos_2)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< pos_1 len_5) #t #f)" +"(let-values(((c_7)(string-ref vec_11 pos_1))((i_31) pos_2))" +"(let-values(((result_8)" +"(let-values()" +"(let-values(((result_9)" +"(let-values()" +"(let-values()" +"(let-values(((or-part_38)" +"(plain-char? c_7)))" +"(if or-part_38" +" or-part_38" +"(let-values(((or-part_39)" +"(char=? '#\\. c_7)))" +"(if or-part_39" +" or-part_39" +"(if(char=? '#\\% c_7)" +"(if(< i_31(- len_4 2))" +"(hex-sequence? v_39(add1 i_31))" +" #f)" +" #f)))))))))" +"(values result_9)))))" +"(if(if(not((lambda x_15(not result_8)) c_7))" +"(if(not((lambda x_16(not result_8)) i_31))(not #f) #f)" +" #f)" +"(for-loop_11 result_8(unsafe-fx+ 1 pos_1)(+ pos_2 1))" +" result_8)))" +" result_7)))))" +" for-loop_11)" +" #t" +" 0" +" start_6)))" +" #f))" +" #f))))" +"(define-values" +"(plain-char?)" +"(lambda(c_8)" +"(begin" +"(let-values(((or-part_40)(char<=? '#\\a c_8 '#\\z)))" +"(if or-part_40" +" or-part_40" +"(let-values(((or-part_41)(char<=? '#\\A c_8 '#\\Z)))" +"(if or-part_41" +" or-part_41" +"(let-values(((or-part_42)(char<=? '#\\0 c_8 '#\\9)))" +"(if or-part_42" +" or-part_42" +"(let-values(((or-part_43)(char=? '#\\- c_8)))" +"(if or-part_43" +" or-part_43" +"(let-values(((or-part_44)(char=? '#\\_ c_8)))" +"(if or-part_44 or-part_44(char=? '#\\+ c_8))))))))))))))" +"(define-values" +"(hex-sequence?)" +"(lambda(s_32 i_32)" +"(begin" +"(let-values(((c1_16)(string-ref s_32 i_32)))" +"(let-values(((c2_0)(string-ref s_32(add1 i_32))))" +"(if(hex-char? c1_16)" +"(if(hex-char? c2_0)" +"(let-values(((c_9)(integer->char(+(*(hex-char->integer c1_16) 16)(hex-char->integer c2_0)))))" +"(not(plain-char? c_9)))" +" #f)" +" #f))))))" +"(define-values" +"(hex-char?)" +"(lambda(c_10)" +"(begin(let-values(((or-part_45)(char<=? '#\\a c_10 '#\\f)))(if or-part_45 or-part_45(char<=? '#\\0 c_10 '#\\9))))))" +"(define-values" +"(hex-char->integer)" +"(lambda(c_11)" +"(begin" +"(if(char<=? '#\\a c_11 '#\\f)" +"(let-values()(-(char->integer c_11)(+ 10(char->integer '#\\a))))" +"(if(char<=? '#\\A c_11 '#\\F)" +"(let-values()(-(char->integer c_11)(+ 10(char->integer '#\\A))))" +"(let-values()(-(char->integer c_11)(char->integer '#\\0))))))))" +"(define-values" +"(check-planet-part)" +"(lambda(v_40 len_6)" +"(begin" +"(let-values(((start-package-version-pos_1 end-package-version-pos_1 colon1-pos_0 colon2-pos_0)" +"((letrec-values(((loop_59)" +"(lambda(j_2" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" colon2-pos_1)" +"(begin" +" 'loop" +"(if(= j_2 len_6)" +"(let-values()" +"(values" +" start-package-version-pos_2" +"(let-values(((or-part_46) end-package-version-pos_2))" +"(if or-part_46 or-part_46 j_2))" +" colon1-pos_1" +" colon2-pos_1))" +"(let-values()" +"(let-values(((tmp_7)(string-ref v_40 j_2)))" +"(if(equal? tmp_7 '#\\/)" +"(let-values()" +"(loop_59" +"(add1 j_2)" +"(let-values(((or-part_47) start-package-version-pos_2))" +"(if or-part_47 or-part_47(add1 j_2)))" +"(if start-package-version-pos_2" +"(let-values(((or-part_48) end-package-version-pos_2))" +"(if or-part_48 or-part_48 j_2))" +" #f)" +" colon1-pos_1" +" colon2-pos_1))" +"(if(equal? tmp_7 '#\\:)" +"(let-values()" +"(if colon2-pos_1" +"(let-values()(values #f #f #f #f))" +"(if colon1-pos_1" +"(let-values()" +"(loop_59" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" j_2))" +"(let-values()" +"(loop_59" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" j_2" +" #f)))))" +"(let-values()" +"(loop_59" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" colon2-pos_1)))))))))))" +" loop_59)" +" 0" +" #f" +" #f" +" #f" +" #f)))" +"(if(if start-package-version-pos_1" +"(if(> end-package-version-pos_1 start-package-version-pos_1)" +"(let-values(((or-part_49)(not colon2-pos_0)))" +"(if or-part_49 or-part_49(<(add1 colon2-pos_0) end-package-version-pos_1)))" +" #f)" +" #f)" +"(let-values()" +"(if colon1-pos_0" +"(let-values()" +"(let-values(((colon1-end_0)" +"(let-values(((or-part_50) colon2-pos_0))" +"(if or-part_50 or-part_50 end-package-version-pos_1))))" +"(if(if(integer-sequence? v_40(add1 colon1-pos_0) colon1-end_0)" +"(let-values(((or-part_51)(not colon2-pos_0)))" +"(if or-part_51" +" or-part_51" +"(let-values(((tmp_8)(string-ref v_40(add1 colon2-pos_0))))" +"(if(equal? tmp_8 '#\\=)" +"(let-values()(integer-sequence? v_40(+ 2 colon2-pos_0) end-package-version-pos_1))" +"(if(if(equal? tmp_8 '#\\>) #t(equal? tmp_8 '#\\<))" +"(let-values()" +"(if(if(<(+ 2 colon2-pos_0) end-package-version-pos_1)" +"(char=? '#\\=(string-ref v_40(+ colon2-pos_0 2)))" +" #f)" +"(let-values()" +"(integer-sequence? v_40(+ 3 colon2-pos_0) end-package-version-pos_1))" +"(let-values()" +"(integer-sequence? v_40(+ 2 colon2-pos_0) end-package-version-pos_1))))" +"(let-values()" +"(integer-range-sequence? v_40(add1 colon2-pos_0) end-package-version-pos_1)))))))" +" #f)" +"(let-values()(values colon1-pos_0 end-package-version-pos_1))" +"(let-values()(values #f #f)))))" +"(let-values()(values 0 0))))" +"(let-values()(values #f #f)))))))" +"(define-values" +"(integer-sequence?)" +"(lambda(s_33 start_7 end_4)" +"(begin" +"(if(< start_7 end_4)" +"(let-values(((start_8) start_7)((end_5) end_4)((inc_0) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_8 end_5 inc_0)))" +"((letrec-values(((for-loop_12)" +"(lambda(result_10 pos_3)" +"(begin" +" 'for-loop" +"(if(< pos_3 end_5)" +"(let-values(((i_33) pos_3))" +"(let-values(((result_0)" +"(let-values()" +"(let-values(((result_11)" +"(let-values()" +"(let-values()" +"(char<=? '#\\0(string-ref s_33 i_33) '#\\9)))))" +"(values result_11)))))" +"(if(if(not((lambda x_17(not result_0)) i_33))(not #f) #f)" +"(for-loop_12 result_0(+ pos_3 inc_0))" +" result_0)))" +" result_10)))))" +" for-loop_12)" +" #t" +" start_8)))" +" #f))))" +"(define-values" +"(integer-range-sequence?)" +"(lambda(s_34 start_9 end_6)" +"(begin" +"(if(< start_9 end_6)" +"(if(let-values(((start_10) start_9)((end_7) end_6)((inc_1) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_10 end_7 inc_1)))" +"((letrec-values(((for-loop_13)" +"(lambda(result_12 pos_4)" +"(begin" +" 'for-loop" +"(if(< pos_4 end_7)" +"(let-values(((i_34) pos_4))" +"(let-values(((result_13)" +"(let-values()" +"(let-values(((result_14)" +"(let-values()" +"(let-values()" +"(let-values(((c_12)" +"(string-ref s_34 i_34)))" +"(let-values(((or-part_52)" +"(char=? c_12 '#\\-)))" +"(if or-part_52" +" or-part_52" +"(char<=? '#\\0 c_12 '#\\9))))))))" +"(values result_14)))))" +"(if(if(not((lambda x_18(not result_13)) i_34))(not #f) #f)" +"(for-loop_13 result_13(+ pos_4 inc_1))" +" result_13)))" +" result_12)))))" +" for-loop_13)" +" #t" +" start_10)))" +"(>=" +" 1" +"(let-values(((start_11) start_9)((end_8) end_6)((inc_2) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_11 end_8 inc_2)))" +"((letrec-values(((for-loop_14)" +"(lambda(result_15 pos_5)" +"(begin" +" 'for-loop" +"(if(< pos_5 end_8)" +"(let-values(((i_35) pos_5))" +"(let-values(((result_16)" +"(let-values(((result_17) result_15))" +"(let-values(((result_18)" +"(let-values()" +"(+" +" result_17" +"(let-values()" +"(if(char=?(string-ref s_34 i_35) '#\\-)" +" 1" +" 0))))))" +"(values result_18)))))" +"(if(not #f)(for-loop_14 result_16(+ pos_5 inc_2)) result_16)))" +" result_15)))))" +" for-loop_14)" +" 0" +" start_11))))" +" #f)" +" #f))))" +"(define-values" +"(struct:weak-intern-table weak-intern-table1.1 weak-intern-table? weak-intern-table-box)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'weak-intern-table" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'weak-intern-table)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'box))))" +"(define-values" +"(struct:table table2.1 table? table-ht table-count table-prune-at)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'table" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'table)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'ht)" +"(make-struct-field-accessor -ref_1 1 'count)" +"(make-struct-field-accessor -ref_1 2 'prune-at))))" +"(define-values(make-weak-intern-table)(lambda()(begin(weak-intern-table1.1(box(table2.1(hasheqv) 0 128))))))" +"(define-values" +"(weak-intern!)" +"(lambda(tt_0 v_41)" +"(begin" +"(let-values(((b_8)(weak-intern-table-box tt_0)))" +"(let-values(((t_11)(unbox b_8)))" +"(let-values(((code_0)(equal-hash-code v_41)))" +"(let-values(((vals_0)(hash-ref(table-ht t_11) code_0 null)))" +"(let-values(((or-part_31)" +"(let-values(((lst_19) vals_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_19)))" +"((letrec-values(((for-loop_15)" +"(lambda(result_19 lst_20)" +"(begin" +" 'for-loop" +"(if(pair? lst_20)" +"(let-values(((b_9)(unsafe-car lst_20))" +"((rest_6)(unsafe-cdr lst_20)))" +"(let-values(((result_20)" +"(let-values()" +"(let-values(((result_21)" +"(let-values()" +"(let-values()" +"(let-values(((bv_0)" +"(weak-box-value" +" b_9)))" +"(if(equal? bv_0 v_41)" +" bv_0" +" #f))))))" +"(values result_21)))))" +"(if(if(not((lambda x_19 result_20) b_9))(not #f) #f)" +"(for-loop_15 result_20 rest_6)" +" result_20)))" +" result_19)))))" +" for-loop_15)" +" #f" +" lst_19)))))" +"(if or-part_31" +" or-part_31" +"(let-values(((pruned-t_0)(if(=(table-count t_11)(table-prune-at t_11))(prune-table t_11) t_11)))" +"(let-values(((ht_21)(table-ht pruned-t_0)))" +"(let-values(((new-t_0)" +"(table2.1" +"(hash-set ht_21 code_0(cons(make-weak-box v_41)(hash-ref ht_21 code_0 null)))" +"(add1(table-count pruned-t_0))" +"(table-prune-at pruned-t_0))))" +"(let-values(((or-part_33)(if(box-cas! b_8 t_11 new-t_0) v_41 #f)))" +"(if or-part_33 or-part_33(weak-intern! tt_0 v_41)))))))))))))))" +"(define-values" +"(prune-table)" +"(lambda(t_12)" +"(begin" +"(let-values(((new-ht_0)" +"(let-values(((ht_22)(table-ht t_12)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_22)))" +"((letrec-values(((for-loop_16)" +"(lambda(table_8 i_36)" +"(begin" +" 'for-loop" +"(if i_36" +"(let-values(((k_6 vals_1)(hash-iterate-key+value ht_22 i_36)))" +"(let-values(((table_9)" +"(let-values(((new-vals_0)" +"(reverse$1" +"(let-values(((lst_21) vals_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_21)))" +"((letrec-values(((for-loop_17)" +"(lambda(fold-var_4" +" lst_9)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_9)" +"(let-values(((b_10)" +"(unsafe-car" +" lst_9))" +"((rest_7)" +"(unsafe-cdr" +" lst_9)))" +"(let-values(((fold-var_5)" +"(let-values(((fold-var_6)" +" fold-var_4))" +"(if(weak-box-value" +" b_10)" +"(let-values(((fold-var_7)" +" fold-var_6))" +"(let-values(((fold-var_8)" +"(let-values()" +"(cons" +"(let-values()" +" b_10)" +" fold-var_7))))" +"(values" +" fold-var_8)))" +" fold-var_6))))" +"(if(not" +" #f)" +"(for-loop_17" +" fold-var_5" +" rest_7)" +" fold-var_5)))" +" fold-var_4)))))" +" for-loop_17)" +" null" +" lst_21))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_18)" +"(lambda(table_10)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_11)" +"(let-values(((table_12)" +" table_10))" +"(if(pair?" +" new-vals_0)" +"(let-values(((table_13)" +" table_12))" +"(let-values(((table_14)" +"(let-values()" +"(let-values(((key_9" +" val_2)" +"(let-values()" +"(values" +" k_6" +" new-vals_0))))" +"(hash-set" +" table_13" +" key_9" +" val_2)))))" +"(values" +" table_14)))" +" table_12))))" +" table_11))))))" +" for-loop_18)" +" table_8)))))" +"(if(not #f)" +"(for-loop_16 table_9(hash-iterate-next ht_22 i_36))" +" table_9)))" +" table_8)))))" +" for-loop_16)" +" '#hash()" +"(hash-iterate-first ht_22))))))" +"(let-values(((count_0)" +"(let-values(((ht_23) new-ht_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_23)))" +"((letrec-values(((for-loop_19)" +"(lambda(result_22 i_37)" +"(begin" +" 'for-loop" +"(if i_37" +"(let-values(((k_7 vals_2)(hash-iterate-key+value ht_23 i_37)))" +"(let-values(((result_23)" +"(let-values(((result_24) result_22))" +"(let-values(((result_25)" +"(let-values()" +"(+" +" result_24" +"(let-values()(length vals_2))))))" +"(values result_25)))))" +"(if(not #f)" +"(for-loop_19 result_23(hash-iterate-next ht_23 i_37))" +" result_23)))" +" result_22)))))" +" for-loop_19)" +" 0" +"(hash-iterate-first ht_23))))))" +"(table2.1 new-ht_0 count_0(max 128(* 2 count_0))))))))" +"(define-values" +"(struct:resolved-module-path resolved-module-path1.1 1/resolved-module-path? 1/resolved-module-path-name)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'resolved-module-path" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(r_8 ser-push!_0 state_0)" +"(begin" +"(ser-push!_0 'tag '#:resolved-module-path)" +"(ser-push!_0(1/resolved-module-path-name r_8)))))" +"(cons" +" prop:custom-write" +"(lambda(r_9 port_0 mode_3)" +"(begin" +" (if mode_3 (let-values () (write-string \"#\" port_0)) (void)))))" +"(cons" +" prop:equal+hash" +"(list" +"(lambda(a_23 b_11 eql?_0)" +"(eql?_0(1/resolved-module-path-name a_23)(1/resolved-module-path-name b_11)))" +"(lambda(a_24 hash-code_0)(hash-code_0(1/resolved-module-path-name a_24)))" +"(lambda(a_25 hash-code_1)(hash-code_1(1/resolved-module-path-name a_25))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'resolved-module-path)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'name))))" +"(define-values" +"(format-resolved-module-path-name)" +"(lambda(p_4)" +"(begin" +"(if(path? p_4)" +" (let-values () (string-append \"\\\"\" (path->string p_4) \"\\\"\"))" +"(if(symbol? p_4)" +"(let-values()(format-symbol p_4))" +"(let-values()(format-submod(format-resolved-module-path-name(car p_4))(cdr p_4))))))))" +"(define-values" +"(format-symbol)" +" (lambda (p_5) (begin (format \"'~s~a\" p_5 (if (symbol-interned? p_5) \"\" (format \"[~a]\" (eq-hash-code p_5)))))))" +"(define-values" +"(format-submod)" +"(lambda(base_5 syms_0)" +"(begin" +"(format" +" \"(submod ~a~a)\"" +" base_5" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_22) syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_22)))" +"((letrec-values(((for-loop_20)" +"(lambda(fold-var_9 lst_23)" +"(begin" +" 'for-loop" +"(if(pair? lst_23)" +"(let-values(((i_38)(unsafe-car lst_23))((rest_8)(unsafe-cdr lst_23)))" +"(let-values(((fold-var_10)" +"(let-values(((fold-var_11) fold-var_9))" +"(let-values(((fold-var_12)" +"(let-values()" +"(cons" +" (let-values () (format \" ~s\" i_38))" +" fold-var_11))))" +"(values fold-var_12)))))" +"(if(not #f)(for-loop_20 fold-var_10 rest_8) fold-var_10)))" +" fold-var_9)))))" +" for-loop_20)" +" null" +" lst_22)))))))))" +"(define-values" +"(resolved-module-path-root-name)" +"(lambda(r_10)" +"(begin(let-values(((name_6)(1/resolved-module-path-name r_10)))(if(pair? name_6)(car name_6) name_6)))))" +"(define-values(resolved-module-paths)(make-weak-intern-table))" +"(define-values" +"(1/make-resolved-module-path)" +"(lambda(p_6)" +"(begin" +" 'make-resolved-module-path" +"(begin" +"(if(let-values(((or-part_53)(symbol? p_6)))" +"(if or-part_53" +" or-part_53" +"(let-values(((or-part_54)(if(path? p_6)(complete-path? p_6) #f)))" +"(if or-part_54" +" or-part_54" +"(if(pair? p_6)" +"(if(pair?(cdr p_6))" +"(if(list? p_6)" +"(if(let-values(((or-part_7)(symbol?(car p_6))))" +"(if or-part_7 or-part_7(if(path?(car p_6))(complete-path?(car p_6)) #f)))" +"(let-values(((lst_24)(cdr p_6)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_24)))" +"((letrec-values(((for-loop_21)" +"(lambda(result_26 lst_25)" +"(begin" +" 'for-loop" +"(if(pair? lst_25)" +"(let-values(((s_35)(unsafe-car lst_25))" +"((rest_9)(unsafe-cdr lst_25)))" +"(let-values(((result_19)" +"(let-values()" +"(let-values(((result_27)" +"(let-values()" +"(let-values()" +"(symbol? s_35)))))" +"(values result_27)))))" +"(if(if(not((lambda x_20(not result_19)) s_35))" +"(not #f)" +" #f)" +"(for-loop_21 result_19 rest_9)" +" result_19)))" +" result_26)))))" +" for-loop_21)" +" #t" +" lst_24)))" +" #f)" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-resolved-module-path" +"(string-append" +" \"(or/c symbol?\\n\"" +" \" (and/c path? complete-path?)\\n\"" +" \" (cons/c (or/c symbol?\\n\"" +" \" (and/c path? complete-path?))\\n\"" +" \" (non-empty-listof symbol?)))\")" +" p_6)))" +"(weak-intern! resolved-module-paths(resolved-module-path1.1 p_6))))))" +"(define-values" +"(resolved-module-path->module-path)" +"(lambda(r_11)" +"(begin" +"(let-values(((name_7)(1/resolved-module-path-name r_11)))" +"(let-values(((root-name_0)(if(pair? name_7)(car name_7) name_7)))" +"(let-values(((root-mod-path_0)(if(path? root-name_0) root-name_0(list 'quote root-name_0))))" +"(if(pair? name_7)(list* 'submod root-mod-path_0(cdr name_7)) root-mod-path_0)))))))" +"(define-values" +"(struct:module-path-index" +" module-path-index2.1" +" 1/module-path-index?" +" module-path-index-path" +" module-path-index-base" +" module-path-index-resolved" +" module-path-index-shift-cache" +" set-module-path-index-resolved!" +" set-module-path-index-shift-cache!)" +"(let-values(((struct:_2 make-_2 ?_2 -ref_2 -set!_2)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-path-index" +" #f" +" 4" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:custom-write" +"(lambda(r_12 port_1 mode_4)" +"(begin" +" (write-string \"#\" port_1))))" +"(cons" +" prop:equal+hash" +"(list" +"(lambda(a_26 b_12 eql?_1)" +"(if(eql?_1(module-path-index-path a_26)(module-path-index-path b_12))" +"(eql?_1(module-path-index-base a_26)(module-path-index-base b_12))" +" #f))" +"(lambda(a_27 hash-code_2)" +"(+(hash-code_2(module-path-index-path a_27))(hash-code_2(module-path-index-base a_27))))" +"(lambda(a_28 hash-code_3)" +"(+" +"(hash-code_3(module-path-index-path a_28))" +"(hash-code_3(module-path-index-base a_28)))))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-path-index)))))" +"(values" +" struct:_2" +" make-_2" +" ?_2" +"(make-struct-field-accessor -ref_2 0 'path)" +"(make-struct-field-accessor -ref_2 1 'base)" +"(make-struct-field-accessor -ref_2 2 'resolved)" +"(make-struct-field-accessor -ref_2 3 'shift-cache)" +"(make-struct-field-mutator -set!_2 2 'resolved)" +"(make-struct-field-mutator -set!_2 3 'shift-cache))))" +"(define-values" +"(deserialize-module-path-index)" +"(case-lambda" +"((path_3 base_6)(begin(1/module-path-index-join path_3 base_6)))" +"((name_8)(make-self-module-path-index(1/make-resolved-module-path name_8)))" +"(() top-level-module-path-index)))" +"(define-values" +"(1/module-path-index-resolve)" +"(let-values(((module-path-index-resolve5_0)" +"(lambda(mpi4_0 load?3_0)" +"(begin" +" 'module-path-index-resolve5" +"(let-values(((mpi_0) mpi4_0))" +"(let-values(((load?_0) load?3_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/module-path-index? mpi_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-path-index-resolve \"module-path-index?\" mpi_0)))" +"(let-values(((or-part_55)(module-path-index-resolved mpi_0)))" +"(if or-part_55" +" or-part_55" +"(let-values(((mod-name_0)" +"((1/current-module-name-resolver)" +"(module-path-index-path mpi_0)" +"(module-path-index-resolve/maybe" +"(module-path-index-base mpi_0)" +" load?_0)" +" #f" +" load?_0)))" +"(begin" +"(if(1/resolved-module-path? mod-name_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-resolve" +" \"current module name resolver's result is not a resolved module path\"" +" \"result\"" +" mod-name_0)))" +"(set-module-path-index-resolved! mpi_0 mod-name_0)" +" mod-name_0))))))))))))))" +"(case-lambda" +"((mpi_1)(begin 'module-path-index-resolve(module-path-index-resolve5_0 mpi_1 #f)))" +"((mpi_2 load?3_1)(module-path-index-resolve5_0 mpi_2 load?3_1)))))" +"(define-values" +"(module-path-index-unresolve)" +"(lambda(mpi_3)" +"(begin" +"(if(module-path-index-resolved mpi_3)" +"(let-values()" +"(let-values(((path_4 base_7)(1/module-path-index-split mpi_3)))(1/module-path-index-join path_4 base_7)))" +"(let-values() mpi_3)))))" +"(define-values" +"(1/module-path-index-join)" +"(let-values(((module-path-index-join10_0)" +"(lambda(mod-path8_0 base9_0 submod7_0)" +"(begin" +" 'module-path-index-join10" +"(let-values(((mod-path_0) mod-path8_0))" +"(let-values(((base_8) base9_0))" +"(let-values(((submod_0) submod7_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if((lambda(x_21)" +"(let-values(((or-part_40)(not x_21)))" +"(if or-part_40 or-part_40(1/module-path? x_21))))" +" mod-path_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-path-index-join" +" \"(or/c #f module-path?)\"" +" mod-path_0)))" +"(if(let-values(((or-part_41)(not base_8)))" +"(if or-part_41" +" or-part_41" +"(let-values(((or-part_42)(1/resolved-module-path? base_8)))" +"(if or-part_42 or-part_42(1/module-path-index? base_8)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-path-index-join" +" \"(or/c #f resolved-module-path? module-path-index?)\"" +" base_8)))" +"(if(let-values(((or-part_43)(not submod_0)))" +"(if or-part_43" +" or-part_43" +"(if(pair? submod_0)(if(list? submod_0)(andmap2 symbol? submod_0) #f) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-path-index-join" +" \"(or/c #f (non-empty-listof symbol?))\"" +" submod_0)))" +"(if(if(not mod-path_0) base_8 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-join" +" \"cannot combine #f path with non-#f base\"" +" \"given base\"" +" base_8))" +"(void))" +"(if(if submod_0 mod-path_0 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-join" +" \"cannot combine #f submodule list with non-#f module path\"" +" \"given module path\"" +" mod-path_0" +" \"given submodule list\"" +" submod_0))" +"(void))" +"(if submod_0" +"(let-values()" +"(make-self-module-path-index" +"(1/make-resolved-module-path(cons generic-module-name submod_0))))" +"(let-values()" +"(let-values(((keep-base_0)" +"((letrec-values(((loop_62)" +"(lambda(mod-path_1)" +"(begin" +" 'loop" +"(if(path? mod-path_1)" +"(let-values() #f)" +"(if(if(pair? mod-path_1)" +"(eq? 'quote(car mod-path_1))" +" #f)" +"(let-values() #f)" +"(if(symbol? mod-path_1)" +"(let-values() #f)" +"(if(if(pair? mod-path_1)" +"(eq? 'submod(car mod-path_1))" +" #f)" +"(let-values()" +"(loop_62(cadr mod-path_1)))" +"(let-values() base_8)))))))))" +" loop_62)" +" mod-path_0)))" +"(module-path-index2.1 mod-path_0 keep-base_0 #f #f)))))))))))))))" +"(case-lambda" +"((mod-path_2 base_9)(begin 'module-path-index-join(module-path-index-join10_0 mod-path_2 base_9 #f)))" +"((mod-path_3 base_10 submod7_1)(module-path-index-join10_0 mod-path_3 base_10 submod7_1)))))" +"(define-values" +"(module-path-index-resolve/maybe)" +"(lambda(base_11 load?_1)" +"(begin(if(1/module-path-index? base_11)(1/module-path-index-resolve base_11 load?_1) base_11))))" +"(define-values" +"(1/module-path-index-split)" +"(lambda(mpi_4)" +"(begin" +" 'module-path-index-split" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/module-path-index? mpi_4)" +"(void)" +" (let-values () (raise-argument-error 'module-path-index-split \"module-path-index?\" mpi_4)))" +"(values(module-path-index-path mpi_4)(module-path-index-base mpi_4))))))))" +"(define-values" +"(1/module-path-index-submodule)" +"(lambda(mpi_5)" +"(begin" +" 'module-path-index-submodule" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/module-path-index? mpi_5)" +"(void)" +" (let-values () (raise-argument-error 'module-path-index-submodule \"module-path-index?\" mpi_5)))" +"(if(not(module-path-index-path mpi_5))" +"(let-values(((r_14)(module-path-index-resolved mpi_5)))" +"(if r_14(let-values(((p_7)(1/resolved-module-path-name r_14)))(if(pair? p_7)(cdr p_7) #f)) #f))" +" #f)))))))" +"(define-values" +"(make-self-module-path-index)" +"(case-lambda" +"((name_9)(begin(module-path-index2.1 #f #f name_9 #f)))" +"((name_10 enclosing_0)" +"(make-self-module-path-index" +"(let-values(((name25_0) name_10)((temp26_0)(if enclosing_0(1/module-path-index-resolve enclosing_0) #f)))" +"(build-module-name16.1 unsafe-undefined name25_0 temp26_0))))))" +"(define-values(generic-self-mpis)(make-weak-hash))" +"(define-values(generic-module-name) '|expanded module|)" +"(define-values" +"(make-generic-self-module-path-index)" +"(lambda(self_0)" +"(begin" +"(let-values(((r_15)(resolved-module-path-to-generic-resolved-module-path(module-path-index-resolved self_0))))" +"(begin" +"(start-atomic)" +"(begin0" +"(let-values(((or-part_47)" +"(let-values(((e_9)(hash-ref generic-self-mpis r_15 #f)))" +"(if e_9(ephemeron-value e_9) #f))))" +"(if or-part_47" +" or-part_47" +"(let-values(((mpi_6)(module-path-index2.1 #f #f r_15 #f)))" +"(begin(hash-set! generic-self-mpis r_15(make-ephemeron r_15 mpi_6)) mpi_6))))" +"(end-atomic)))))))" +"(define-values" +"(resolved-module-path-to-generic-resolved-module-path)" +"(lambda(r_16)" +"(begin" +"(let-values(((name_11)(1/resolved-module-path-name r_16)))" +"(1/make-resolved-module-path" +"(if(symbol? name_11) generic-module-name(cons generic-module-name(cdr name_11))))))))" +"(define-values" +"(imitate-generic-module-path-index!)" +"(lambda(mpi_7)" +"(begin" +"(let-values(((r_17)(module-path-index-resolved mpi_7)))" +"(if r_17" +"(let-values()" +"(set-module-path-index-resolved! mpi_7(resolved-module-path-to-generic-resolved-module-path r_17)))" +"(void))))))" +"(define-values" +"(module-path-index-shift)" +"(lambda(mpi_8 from-mpi_0 to-mpi_0)" +"(begin" +"(if(eq? mpi_8 from-mpi_0)" +"(let-values() to-mpi_0)" +"(let-values()" +"(let-values(((base_12)(module-path-index-base mpi_8)))" +"(if(not base_12)" +"(let-values() mpi_8)" +"(let-values()" +"(let-values(((shifted-base_0)(module-path-index-shift base_12 from-mpi_0 to-mpi_0)))" +"(if(eq? shifted-base_0 base_12)" +"(let-values() mpi_8)" +"(let-values(((c1_17)(shift-cache-ref(module-path-index-shift-cache shifted-base_0) mpi_8)))" +"(if c1_17" +" c1_17" +"(let-values()" +"(let-values(((shifted-mpi_0)" +"(module-path-index2.1(module-path-index-path mpi_8) shifted-base_0 #f #f)))" +"(begin" +"(shift-cache-set!(module-path-index-shift-cache! shifted-base_0) mpi_8 shifted-mpi_0)" +" shifted-mpi_0)))))))))))))))" +"(define-values" +"(module-path-index-shift-cache!)" +"(lambda(mpi_9)" +"(begin" +"(let-values(((or-part_56)" +"(let-values(((cache_0)(module-path-index-shift-cache mpi_9)))" +"(if cache_0(if(weak-box-value cache_0) cache_0 #f) #f))))" +"(if or-part_56" +" or-part_56" +"(let-values(((cache_1)(make-weak-box(box '#hasheq()))))" +"(begin(set-module-path-index-shift-cache! mpi_9 cache_1) cache_1)))))))" +"(define-values" +"(shift-cache-ref)" +"(lambda(cache_2 v_43)" +"(begin" +"(if cache_2(let-values(((b_13)(weak-box-value cache_2)))(if b_13(hash-ref(unbox b_13) v_43 #f) #f)) #f))))" +"(define-values" +"(shift-cache-set!)" +"(lambda(cache_3 v_44 r_18)" +"(begin" +"(let-values(((b_14)(weak-box-value cache_3)))" +"(if b_14(let-values()(set-box! b_14(hash-set(unbox b_14) v_44 r_18)))(void))))))" +"(define-values(top-level-module-path-index)(make-self-module-path-index(1/make-resolved-module-path 'top-level)))" +"(define-values(top-level-module-path-index?)(lambda(mpi_10)(begin(eq? top-level-module-path-index mpi_10))))" +"(define-values(non-self-module-path-index?)(lambda(mpi_11)(begin(if(module-path-index-path mpi_11) #t #f))))" +"(define-values" +"(core-module-name-resolver)" +"(case-lambda" +"((name_12 from-namespace_0)(begin(void)))" +"((p_8 enclosing_1 source-stx-stx_0 load?_2)" +"(begin" +"(if(1/module-path? p_8)" +"(void)" +" (let-values () (raise-argument-error 'core-module-name-resolver \"module-path?\" p_8)))" +"(if(let-values(((or-part_52)(not enclosing_1)))" +"(if or-part_52 or-part_52(1/resolved-module-path? enclosing_1)))" +"(void)" +" (let-values () (raise-argument-error 'core-module-name-resolver \"resolved-module-path?\" enclosing_1)))" +"(if(if(list? p_8)(if(=(length p_8) 2)(if(eq? 'quote(car p_8))(symbol?(cadr p_8)) #f) #f) #f)" +"(let-values()(1/make-resolved-module-path(cadr p_8)))" +" (if (if (list? p_8) (if (eq? 'submod (car p_8)) (equal? \"..\" (cadr p_8)) #f) #f)" +"(let-values()" +"(let-values(((lst_28)(cdr p_8)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_28)))" +"((letrec-values(((for-loop_23)" +"(lambda(enclosing_2 lst_29)" +"(begin" +" 'for-loop" +"(if(pair? lst_29)" +"(let-values(((s_36)(unsafe-car lst_29))((rest_11)(unsafe-cdr lst_29)))" +"(let-values(((enclosing_3)" +"(let-values(((enclosing_4) enclosing_2))" +"(let-values(((enclosing_5)" +"(let-values()" +"(let-values(((s27_0) s_36)" +"((enclosing28_0) enclosing_4)" +"((p29_0) p_8))" +"(build-module-name16.1" +" p29_0" +" s27_0" +" enclosing28_0)))))" +"(values enclosing_5)))))" +"(if(not #f)(for-loop_23 enclosing_3 rest_11) enclosing_3)))" +" enclosing_2)))))" +" for-loop_23)" +" enclosing_1" +" lst_28))))" +" (if (if (list? p_8) (if (eq? 'submod (car p_8)) (equal? \".\" (cadr p_8)) #f) #f)" +"(let-values()" +"(let-values(((lst_30)(cddr p_8)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_30)))" +"((letrec-values(((for-loop_24)" +"(lambda(enclosing_6 lst_31)" +"(begin" +" 'for-loop" +"(if(pair? lst_31)" +"(let-values(((s_37)(unsafe-car lst_31))((rest_12)(unsafe-cdr lst_31)))" +"(let-values(((enclosing_7)" +"(let-values(((enclosing_8) enclosing_6))" +"(let-values(((enclosing_9)" +"(let-values()" +"(let-values(((s30_0) s_37)" +"((enclosing31_0) enclosing_8)" +"((p32_0) p_8))" +"(build-module-name16.1" +" p32_0" +" s30_0" +" enclosing31_0)))))" +"(values enclosing_9)))))" +"(if(not #f)(for-loop_24 enclosing_7 rest_12) enclosing_7)))" +" enclosing_6)))))" +" for-loop_24)" +" enclosing_1" +" lst_30))))" +"(if(if(list? p_8)(eq? 'submod(car p_8)) #f)" +"(let-values()" +"(let-values(((base_13)((1/current-module-name-resolver)(cadr p_8) enclosing_1 #f #f)))" +"(let-values(((lst_32)(cddr p_8)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_32)))" +"((letrec-values(((for-loop_25)" +"(lambda(enclosing_10 lst_33)" +"(begin" +" 'for-loop" +"(if(pair? lst_33)" +"(let-values(((s_38)(unsafe-car lst_33))((rest_13)(unsafe-cdr lst_33)))" +"(let-values(((enclosing_11)" +"(let-values(((enclosing_12) enclosing_10))" +"(let-values(((enclosing_13)" +"(let-values()" +"(let-values(((s33_0) s_38)" +"((enclosing34_0)" +" enclosing_12)" +"((p35_0) p_8))" +"(build-module-name16.1" +" p35_0" +" s33_0" +" enclosing34_0)))))" +"(values enclosing_13)))))" +"(if(not #f)(for-loop_25 enclosing_11 rest_13) enclosing_11)))" +" enclosing_10)))))" +" for-loop_25)" +" base_13" +" lst_32)))))" +" (let-values () (error 'core-module-name-resolver \"not a supported module path: ~v\" p_8))))))))))" +"(define-values" +"(build-module-name16.1)" +"(lambda(original12_0 name14_0 enclosing15_0)" +"(begin" +" 'build-module-name16" +"(let-values(((name_13) name14_0))" +"(let-values(((enclosing_14) enclosing15_0))" +"(let-values(((orig-name_0)(if(eq? original12_0 unsafe-undefined) name_13 original12_0)))" +"(let-values()" +"(let-values(((enclosing-module-name_0)(if enclosing_14(1/resolved-module-path-name enclosing_14) #f)))" +"(1/make-resolved-module-path" +"(if(not enclosing-module-name_0)" +"(let-values() name_13)" +"(if(symbol? enclosing-module-name_0)" +"(let-values()(list enclosing-module-name_0 name_13))" +" (if (equal? name_13 \"..\")" +"(let-values()" +"(if(symbol? enclosing-module-name_0)" +" (let-values () (error \"too many \\\"..\\\"s:\" orig-name_0))" +"(if(= 2(length enclosing-module-name_0))" +"(let-values()(car enclosing-module-name_0))" +"(let-values()(reverse$1(cdr(reverse$1 enclosing-module-name_0)))))))" +"(let-values()(append enclosing-module-name_0(list name_13)))))))))))))))" +"(define-values" +"(1/current-module-name-resolver)" +"(make-parameter" +" core-module-name-resolver" +"(lambda(v_45)" +"(begin" +"(if(if(procedure? v_45)(if(procedure-arity-includes? v_45 2)(procedure-arity-includes? v_45 4) #f) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-module-name-resolver" +" \"(and/c (procedure-arity-includes/c 2) (procedure-arity-includes/c 4))\"" +" v_45)))" +" v_45))))" +"(define-values" +"(1/current-module-declare-name)" +"(make-parameter" +" #f" +"(lambda(r_19)" +"(begin" +"(if(let-values(((or-part_57)(not r_19)))(if or-part_57 or-part_57(1/resolved-module-path? r_19)))" +"(void)" +" (let-values () (raise-argument-error 'current-module-declare-name \"(or/c #f resolved-module-path?)\" r_19)))" +" r_19))))" +"(define-values" +"(1/current-module-declare-source)" +"(make-parameter" +" #f" +"(lambda(s_39)" +"(begin" +"(if(let-values(((or-part_58)(not s_39)))" +"(if or-part_58" +" or-part_58" +"(let-values(((or-part_59)(symbol? s_39)))" +"(if or-part_59 or-part_59(if(path? s_39)(complete-path? s_39) #f)))))" +"(void)" +"(let-values()" +" (raise-argument-error 'current-module-declare-source \"(or/c #f symbol? (and/c path? complete-path?))\" s_39)))" +" s_39))))" +"(define-values" +"(substitute-module-declare-name)" +"(lambda(default-name_0)" +"(begin" +"(let-values(((current-name_0)(1/current-module-declare-name)))" +"(let-values(((root-name_1)" +"(if current-name_0" +"(resolved-module-path-root-name current-name_0)" +"(if(pair? default-name_0)(car default-name_0) default-name_0))))" +"(1/make-resolved-module-path" +"(if(pair? default-name_0)(cons root-name_1(cdr default-name_0)) root-name_1)))))))" +"(define-values" +"(force/composable)" +"(lambda(root_1)" +"(begin" +"(let-values(((v_46)(unsafe-struct-ref root_1 0)))" +"(if(procedure? v_46)" +"(let-values()" +"(begin" +"(unsafe-struct-set! root_1 0(make-running(object-name v_46)))" +"(call-with-exception-handler" +"(lambda(e_5)(begin(unsafe-struct-set! root_1 0(make-reraise e_5)) e_5))" +"(lambda()" +"((letrec-values(((loop_63)" +"(lambda(v_47)" +"(begin" +" 'loop" +"(if(composable-promise? v_47)" +"(let-values()" +"(let-values(((v*_0)(unsafe-struct-ref v_47 0)))" +"(begin" +"(unsafe-struct-set! v_47 0 root_1)" +"(if(procedure? v*_0)" +"(let-values()(loop_63(v*_0)))" +"(if(pair? v*_0)" +"(let-values()" +"(begin(unsafe-struct-set! root_1 0 v*_0)(unsafe-car v*_0)))" +"(let-values()(loop_63 v*_0)))))))" +"(if(promise? v_47)" +"(let-values()(begin(unsafe-struct-set! root_1 0 v_47)(force v_47)))" +"(let-values()(begin(unsafe-struct-set! root_1 0(list v_47)) v_47))))))))" +" loop_63)" +"(v_46))))))" +"(if(pair? v_46)" +"(let-values()(if(null?(unsafe-cdr v_46))(unsafe-car v_46)(apply values v_46)))" +"(if(composable-promise? v_46)" +"(let-values()(force/composable v_46))" +"(if(null? v_46)" +"(let-values()(values))" +"(if(promise? v_46)" +"(let-values()(force v_46))" +" (let-values () (error 'force \"composable promise with invalid contents: ~e\" v_46)))))))))))" +"(define-values" +"(reify-result)" +"(lambda(v_48)" +"(begin" +"(if(pair? v_48)" +"(let-values()(if(null?(unsafe-cdr v_48))(unsafe-car v_48)(apply values v_48)))" +"(if(null? v_48)" +"(let-values()(values))" +"(if(reraise? v_48)" +"(let-values()(v_48))" +" (let-values () (error 'force \"promise with invalid contents: ~e\" v_48))))))))" +"(define-values" +"(force/generic)" +"(lambda(promise_0)" +"(begin" +"(reify-result" +"(let-values(((v_49)(unsafe-struct-ref promise_0 0)))" +"(if(procedure? v_49)" +"(begin" +"(unsafe-struct-set! promise_0 0(make-running(object-name v_49)))" +"(call-with-exception-handler" +"(lambda(e_10)(begin(unsafe-struct-set! promise_0 0(make-reraise e_10)) e_10))" +"(lambda()" +"(let-values(((vs_0)(call-with-values v_49 list)))" +"(begin(unsafe-struct-set! promise_0 0 vs_0) vs_0)))))" +" v_49))))))" +"(define-values" +"(force)" +"(lambda(promise_1)(begin(if(promise? promise_1)((promise-forcer promise_1) promise_1) promise_1))))" +"(define-values" +"(promise-printer)" +"(lambda(promise_2 port_2 write?_0)" +"(begin" +"((letrec-values(((loop_64)" +"(lambda(v_50)" +"(begin" +" 'loop" +"(if(reraise? v_50)" +"(let-values()" +"(let-values(((r_20)(reraise-val v_50)))" +"(if(exn? r_20)" +"(fprintf" +" port_2" +" (if write?_0 \"#\" \"#\")" +"(exn-message r_20))" +" (fprintf port_2 (if write?_0 \"#\" \"#\") r_20))))" +"(if(running? v_50)" +"(let-values()" +"(let-values(((r_21)(running-name v_50)))" +"(if r_21" +" (fprintf port_2 \"#\" r_21)" +" (fprintf port_2 \"#\"))))" +"(if(procedure? v_50)" +"(let-values()" +"(let-values(((c1_18)(object-name v_50)))" +"(if c1_18" +" ((lambda (n_19) (fprintf port_2 \"#\" n_19)) c1_18)" +" (let-values () (display \"#\" port_2)))))" +"(if(promise? v_50)" +"(let-values()(loop_64(unsafe-struct-ref v_50 0)))" +"(if(null? v_50)" +" (let-values () (fprintf port_2 \"#\"))" +"(if(null?(cdr v_50))" +"(let-values()" +" (fprintf port_2 (if write?_0 \"#\" \"#\") (car v_50)))" +"(let-values()" +"(begin" +" (display \"#\" port_2)))))))))))))" +" loop_64)" +"(unsafe-struct-ref promise_2 0)))))" +"(define-values" +"(prop:force promise-forcer)" +"(let-values(((prop_0 pred?_0 get_0)" +"(make-struct-type-property" +" 'forcer" +"(lambda(v_51 info_0)" +"(begin" +"(if(if(procedure? v_51)(procedure-arity-includes? v_51 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'prop:force \"(any/c . -> . any)\" v_51)))" +" v_51))" +" null" +" #t)))" +"(values prop_0 get_0)))" +"(define-values" +"(struct:promise make-promise promise? promise-val set-promise-val!)" +"(let-values(((struct:_3 make-_3 ?_3 -ref_3 -set!_3)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:force force/generic)(cons prop:custom-write promise-printer))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise)))))" +"(values" +" struct:_3" +" make-_3" +" ?_3" +"(make-struct-field-accessor -ref_3 0 'val)" +"(make-struct-field-mutator -set!_3 0 'val))))" +"(define-values" +"(struct:composable-promise make-composable-promise composable-promise?)" +"(let-values(((struct:_4 make-_4 ?_4 -ref_4 -set!_4)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'composable-promise" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force force/composable))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'composable-promise)))))" +"(values struct:_4 make-_4 ?_4)))" +"(define-values(delay) make-promise)" +"(define-values" +"(struct:reraise make-reraise reraise? reraise-val)" +"(let-values(((struct:_5 make-_5 ?_5 -ref_5 -set!_5)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'reraise" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:procedure(lambda(this_0)(raise(reraise-val this_0)))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'reraise)))))" +"(values struct:_5 make-_5 ?_5(make-struct-field-accessor -ref_5 0 'val))))" +"(define-values" +"(struct:running make-running running? running-name)" +"(let-values(((struct:_6 make-_6 ?_6 -ref_6 -set!_6)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'running" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(this_1 port_3 write?_1)" +" (fprintf port_3 (if write?_1 \"#\" \"#\") (running-name this_1))))" +"(cons" +" prop:procedure" +"(lambda(this_2)" +"(let-values(((name_14)(running-name this_2)))" +"(if name_14" +" (error 'force \"reentrant promise `~.s'\" name_14)" +" (error 'force \"reentrant promise\"))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'running)))))" +"(values struct:_6 make-_6 ?_6(make-struct-field-accessor -ref_6 0 'name))))" +"(define-values" +"(struct:promise/name make-promise/name promise/name?)" +"(let-values(((struct:_7 make-_7 ?_7 -ref_7 -set!_7)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/name" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force(lambda(p_9)((unsafe-struct-ref p_9 0)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/name)))))" +"(values struct:_7 make-_7 ?_7)))" +"(define-values" +"(struct:promise/strict make-promise/strict promise/strict?)" +"(let-values(((struct:_8 make-_8 ?_8 -ref_8 -set!_8)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/strict" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force(lambda(p_10)(reify-result(unsafe-struct-ref p_10 0)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/strict)))))" +"(values struct:_8 make-_8 ?_8)))" +"(define-values" +"(struct:running-thread make-running-thread running-thread? running-thread-thread)" +"(let-values(((struct:_9 make-_9 ?_9 -ref_9 -set!_9)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'running-thread" +" struct:running" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'running-thread)))))" +"(values struct:_9 make-_9 ?_9(make-struct-field-accessor -ref_9 0 'thread))))" +"(define-values" +"(struct:syncinfo" +" make-syncinfo" +" syncinfo?" +" syncinfo-thunk" +" syncinfo-done-evt" +" syncinfo-done-sema" +" syncinfo-access-sema" +" set-syncinfo-thunk!)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'syncinfo" +" #f" +" 4" +" 0" +" #f" +"(list(cons new-prop:procedure(case-lambda)))" +"(current-inspector)" +" #f" +" '(1 2 3)" +" #f" +" 'syncinfo)))))" +"(values" +" struct:_10" +" make-_10" +" ?_10" +"(make-struct-field-accessor -ref_10 0 'thunk)" +"(make-struct-field-accessor -ref_10 1 'done-evt)" +"(make-struct-field-accessor -ref_10 2 'done-sema)" +"(make-struct-field-accessor -ref_10 3 'access-sema)" +"(make-struct-field-mutator -set!_10 0 'thunk))))" +"(define-values" +"(struct:promise/sync make-promise/sync promise/sync?)" +"(let-values(((struct:_11 make-_11 ?_11 -ref_11 -set!_11)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/sync" +" struct:promise" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:evt" +"(lambda(p_11)" +"(let-values(((v_52)(unsafe-struct-ref p_11 0)))" +"(wrap-evt(if(syncinfo? v_52)(syncinfo-done-evt v_52) always-evt) void))))" +"(cons" +" prop:force" +"(lambda(p_12)" +"(let-values(((v_53)(unsafe-struct-ref p_12 0)))" +"(reify-result" +"(if(not(syncinfo? v_53))" +"(let-values() v_53)" +"(if(running-thread?(syncinfo-thunk v_53))" +"(let-values()" +"(let-values(((r_22)(syncinfo-thunk v_53)))" +"(if(eq?(running-thread-thread r_22)(current-thread))" +"(r_22)" +"(begin(sync(syncinfo-done-evt v_53))(unsafe-struct-ref p_12 0)))))" +"(let-values()" +"(begin" +"(call-with-semaphore" +"(syncinfo-access-sema v_53)" +"(lambda(p_13 v_54)" +"(let-values(((thunk_4)(syncinfo-thunk v_54)))" +"(let-values(((done_0)(syncinfo-done-sema v_54)))" +"(if(running-thread? thunk_4)" +"(void)" +"(let-values()" +"(begin" +"(set-syncinfo-thunk!" +" v_54" +"(make-running-thread(object-name thunk_4)(current-thread)))" +"(call-with-exception-handler" +"(lambda(e_11)" +"(begin" +"(unsafe-struct-set! p_13 0(make-reraise e_11))" +"(semaphore-post done_0)" +" e_11))" +"(lambda()" +"(begin" +"(unsafe-struct-set! p_13 0(call-with-values thunk_4 list))" +"(semaphore-post done_0))))))))))" +" #f" +" p_12" +" v_53)" +"(unsafe-struct-ref p_12 0)))))))))" +"(cons" +" prop:custom-write" +"(lambda(p_14 port_4 write?_2)" +"(let-values(((v_55)(unsafe-struct-ref p_14 0)))" +"(promise-printer" +"(if(syncinfo? v_55)(make-promise(syncinfo-thunk v_55)) p_14)" +" port_4" +" write?_2)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/sync)))))" +"(values struct:_11 make-_11 ?_11)))" +"(define-values" +"(struct:promise/thread make-promise/thread promise/thread?)" +"(let-values(((struct:_12 make-_12 ?_12 -ref_12 -set!_12)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/thread" +" struct:promise" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:evt" +"(lambda(p_15)" +"(let-values(((v_56)(unsafe-struct-ref p_15 0)))" +"(wrap-evt(if(running? v_56)(running-thread-thread v_56) always-evt) void))))" +"(cons" +" prop:force" +"(lambda(p_16)" +"(let-values(((v_57)(unsafe-struct-ref p_16 0)))" +"(reify-result" +"(if(running-thread? v_57)" +"(let-values(((t_13)(running-thread-thread v_57)))" +"(let-values((()(begin(thread-wait t_13)(values))))" +"(let-values(((v_58)(unsafe-struct-ref p_16 0)))" +"(if(running-thread? v_58)" +"(error" +" 'force" +" \"promise's thread terminated ~a\\n promise: ~e\"" +" \"without result or exception\"" +" p_16)" +" v_58))))" +" v_57))))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/thread)))))" +"(values struct:_12 make-_12 ?_12)))" +"(define-values" +"(struct:promise/idle make-promise/idle promise/idle?)" +"(let-values(((struct:_13 make-_13 ?_13 -ref_13 -set!_13)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/idle" +" struct:promise/thread" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:force" +"(lambda(p_17)" +"(let-values(((v_59)(unsafe-struct-ref p_17 0)))" +"(reify-result" +"(if(procedure? v_59)" +"(let-values(((controller_0)" +"(if(running-thread? v_59)(running-thread-thread v_59)(v_59))))" +"(begin" +"(thread-send controller_0 'force!)" +"(thread-wait controller_0)" +"(unsafe-struct-ref p_17 0)))" +" v_59))))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/idle)))))" +"(values struct:_13 make-_13 ?_13)))" +"(define-values" +"(phase?)" +"(lambda(v_28)(begin(let-values(((or-part_0)(not v_28)))(if or-part_0 or-part_0(exact-integer? v_28))))))" +"(define-values(phase+)(lambda(a_2 b_15)(begin(if a_2(if b_15(+ a_2 b_15) #f) #f))))" +"(define-values(phase-)(lambda(a_29 b_16)(begin(if a_29(if b_16(- a_29 b_16) #f) #f))))" +"(define-values" +"(phaseimmutable-vector" +"(let-values(((len_7)(vector-length s_7)))" +"(begin" +"(if(exact-nonnegative-integer? len_7)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_7)))" +"(let-values(((v_62)(make-vector len_7 0)))" +"(begin" +"(if(zero? len_7)" +"(void)" +"(let-values()" +"(let-values(((vec_14 len_8)" +"(let-values(((vec_15) s_7))" +"(begin" +"(check-vector vec_15)" +"(values" +" vec_15" +"(unsafe-vector-length vec_15))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_21)" +"(lambda(i_40 pos_6)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_6 len_8)" +"(let-values(((e_12)" +"(unsafe-vector-ref" +" vec_14" +" pos_6)))" +"(let-values(((i_41)" +"(let-values(((i_42)" +" i_40))" +"(let-values(((i_43)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_62" +" i_42" +"(let-values()" +"(loop_65" +" #f" +" e_12" +" seen_1)))" +"(unsafe-fx+" +" 1" +" i_42)))))" +"(values i_43)))))" +"(if(if(not" +"((lambda x_23" +"(unsafe-fx=" +" i_41" +" len_7))" +" e_12))" +"(not #f)" +" #f)" +"(for-loop_21" +" i_41" +"(unsafe-fx+ 1 pos_6))" +" i_41)))" +" i_40)))))" +" for-loop_21)" +" 0" +" 0)))))" +" v_62)))))))" +"(if(box? s_7)" +"(let-values()(f_21 #f(box-immutable(loop_65 #f(unbox s_7) seen_1))))" +"(let-values(((c1_20)(immutable-prefab-struct-key s_7)))" +"(if c1_20" +"((lambda(key_12)" +"(f_21" +" #f" +"(apply" +" make-prefab-struct" +" key_12" +"(reverse$1" +"(let-values(((v*_1 start*_0 stop*_1 step*_0)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_14)(vector? x_14))" +"(lambda(x_24)(unsafe-vector-length x_24))" +"(struct->vector s_7)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_26)" +"(lambda(fold-var_17 idx_0)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_0 stop*_1)" +"(let-values(((e_13)" +"(unsafe-vector-ref" +" v*_1" +" idx_0)))" +"(let-values(((fold-var_18)" +"(let-values(((fold-var_19)" +" fold-var_17))" +"(let-values(((fold-var_20)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_65" +" #f" +" e_13" +" seen_1))" +" fold-var_19))))" +"(values" +" fold-var_20)))))" +"(if(not #f)" +"(for-loop_26" +" fold-var_18" +"(unsafe-fx+ idx_0 1))" +" fold-var_18)))" +" fold-var_17)))))" +" for-loop_26)" +" null" +" start*_0)))))))" +" c1_20)" +"(if(if(hash? s_7)(immutable? s_7) #f)" +"(let-values()" +"(if(hash-eq? s_7)" +"(let-values()" +"(f_21" +" #f" +"(let-values(((ht_26) s_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_26)))" +"((letrec-values(((for-loop_27)" +"(lambda(table_15 i_44)" +"(begin" +" 'for-loop" +"(if i_44" +"(let-values(((k_10 v_63)" +"(hash-iterate-key+value" +" ht_26" +" i_44)))" +"(let-values(((table_16)" +"(let-values(((table_17)" +" table_15))" +"(let-values(((table_18)" +"(let-values()" +"(let-values(((key_13" +" val_4)" +"(let-values()" +"(values" +" k_10" +"(loop_65" +" #f" +" v_63" +" seen_1)))))" +"(hash-set" +" table_17" +" key_13" +" val_4)))))" +"(values" +" table_18)))))" +"(if(not #f)" +"(for-loop_27" +" table_16" +"(hash-iterate-next ht_26 i_44))" +" table_16)))" +" table_15)))))" +" for-loop_27)" +" '#hasheq()" +"(hash-iterate-first ht_26))))))" +"(if(hash-eqv? s_7)" +"(let-values()" +"(f_21" +" #f" +"(let-values(((ht_27) s_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_27)))" +"((letrec-values(((for-loop_28)" +"(lambda(table_19 i_45)" +"(begin" +" 'for-loop" +"(if i_45" +"(let-values(((k_11 v_64)" +"(hash-iterate-key+value" +" ht_27" +" i_45)))" +"(let-values(((table_10)" +"(let-values(((table_11)" +" table_19))" +"(let-values(((table_12)" +"(let-values()" +"(let-values(((key_14" +" val_5)" +"(let-values()" +"(values" +" k_11" +"(loop_65" +" #f" +" v_64" +" seen_1)))))" +"(hash-set" +" table_11" +" key_14" +" val_5)))))" +"(values" +" table_12)))))" +"(if(not #f)" +"(for-loop_28" +" table_10" +"(hash-iterate-next" +" ht_27" +" i_45))" +" table_10)))" +" table_19)))))" +" for-loop_28)" +" '#hasheqv()" +"(hash-iterate-first ht_27))))))" +"(let-values()" +"(f_21" +" #f" +"(let-values(((ht_25) s_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_25)))" +"((letrec-values(((for-loop_29)" +"(lambda(table_20 i_46)" +"(begin" +" 'for-loop" +"(if i_46" +"(let-values(((k_12 v_65)" +"(hash-iterate-key+value" +" ht_25" +" i_46)))" +"(let-values(((table_21)" +"(let-values(((table_22)" +" table_20))" +"(let-values(((table_23)" +"(let-values()" +"(let-values(((key_15" +" val_6)" +"(let-values()" +"(values" +" k_12" +"(loop_65" +" #f" +" v_65" +" seen_1)))))" +"(hash-set" +" table_22" +" key_15" +" val_6)))))" +"(values" +" table_23)))))" +"(if(not #f)" +"(for-loop_29" +" table_21" +"(hash-iterate-next" +" ht_25" +" i_46))" +" table_21)))" +" table_20)))))" +" for-loop_29)" +" '#hash()" +"(hash-iterate-first ht_25)))))))))" +"(let-values()(f_21 #f s_7)))))))))))))))" +" loop_65)" +" tail?_0" +" s_40" +" seen_0))))" +"(define-values" +"(datum-has-elements?)" +"(lambda(d_0)" +"(begin" +"(let-values(((or-part_69)(pair? d_0)))" +"(if or-part_69" +" or-part_69" +"(let-values(((or-part_24)(vector? d_0)))" +"(if or-part_24" +" or-part_24" +"(let-values(((or-part_70)(box? d_0)))" +"(if or-part_70" +" or-part_70" +"(let-values(((or-part_71)(immutable-prefab-struct-key d_0)))" +"(if or-part_71" +" or-part_71" +"(if(hash? d_0)(if(immutable? d_0)(positive?(hash-count d_0)) #f) #f))))))))))))" +"(define-values" +"(struct:preserved-property-value" +" preserved-property-value1.1" +" preserved-property-value?" +" preserved-property-value-content)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'preserved-property-value" +" #f" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'preserved-property-value)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'content))))" +"(define-values" +"(plain-property-value)" +"(lambda(v_66)(begin(if(preserved-property-value? v_66)(preserved-property-value-content v_66) v_66))))" +"(define-values" +"(check-value-to-preserve)" +"(lambda(v_67 syntax?_0)" +"(begin" +"(let-values(((check-preserve_0)" +"(lambda(tail?_2 v_68)" +"(begin" +" 'check-preserve" +"(begin" +"(if(let-values(((or-part_72)(null? v_68)))" +"(if or-part_72" +" or-part_72" +"(let-values(((or-part_73)(boolean? v_68)))" +"(if or-part_73" +" or-part_73" +"(let-values(((or-part_74)(symbol? v_68)))" +"(if or-part_74" +" or-part_74" +"(let-values(((or-part_75)(number? v_68)))" +"(if or-part_75" +" or-part_75" +"(let-values(((or-part_76)(char? v_68)))" +"(if or-part_76" +" or-part_76" +"(let-values(((or-part_77)(string? v_68)))" +"(if or-part_77" +" or-part_77" +"(let-values(((or-part_29)(bytes? v_68)))" +"(if or-part_29" +" or-part_29" +"(let-values(((or-part_78)(regexp? v_68)))" +"(if or-part_78" +" or-part_78" +"(let-values(((or-part_79)(syntax?_0 v_68)))" +"(if or-part_79" +" or-part_79" +"(let-values(((or-part_80)(pair? v_68)))" +"(if or-part_80" +" or-part_80" +"(let-values(((or-part_81)(vector? v_68)))" +"(if or-part_81" +" or-part_81" +"(let-values(((or-part_82)(box? v_68)))" +"(if or-part_82" +" or-part_82" +"(let-values(((or-part_83)(hash? v_68)))" +"(if or-part_83" +" or-part_83" +"(immutable-prefab-struct-key" +" v_68)))))))))))))))))))))))))))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'write" +" \"disallowed value in preserved syntax property\"" +" \"value\"" +" v_68)))" +" v_68)))))" +"(let-values(((s_41) v_67)((f_22) check-preserve_0)((gf_0) check-preserve_0)((seen_2) disallow-cycles$1))" +"((letrec-values(((loop_66)" +"(lambda(tail?_3 s_42 prev-depth_0)" +"(begin" +" 'loop" +"(let-values(((depth_0)(fx+ 1 prev-depth_0)))" +"(if(if seen_2(fx> depth_0 32) #f)" +"(let-values()" +"(datum-map-slow tail?_3 s_42(lambda(tail?_4 s_43)(gf_0 tail?_4 s_43)) seen_2))" +"(if(null? s_42)" +"(let-values()(f_22 tail?_3 s_42))" +"(if(pair? s_42)" +"(let-values()" +"(f_22" +" tail?_3" +"(cons(loop_66 #f(car s_42) depth_0)(loop_66 #t(cdr s_42) depth_0))))" +"(if(symbol? s_42)" +"(let-values()(f_22 #f s_42))" +"(if(boolean? s_42)" +"(let-values()(f_22 #f s_42))" +"(if(number? s_42)" +"(let-values()(f_22 #f s_42))" +"(if(let-values(((or-part_54)(vector? s_42)))" +"(if or-part_54" +" or-part_54" +"(let-values(((or-part_7)(box? s_42)))" +"(if or-part_7" +" or-part_7" +"(let-values(((or-part_8)(prefab-struct-key s_42)))" +"(if or-part_8 or-part_8(hash? s_42)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_3" +" s_42" +"(lambda(tail?_5 s_44)(gf_0 tail?_5 s_44))" +" seen_2))" +"(let-values()(gf_0 #f s_42))))))))))))))" +" loop_66)" +" #f" +" s_41" +" 0))))))" +"(define-values" +"(disallow-cycles$1)" +"(hash" +" 'cycle-fail" +" (lambda (v_69) (raise-arguments-error 'write \"disallowed cycle in preserved syntax property\" \"at\" v_69))))" +"(define-values" +"(tamper?)" +"(lambda(v_28)" +"(begin" +"(let-values(((or-part_0)(not v_28)))" +"(if or-part_0 or-part_0(let-values(((or-part_1)(symbol? v_28)))(if or-part_1 or-part_1(set? v_28))))))))" +"(define-values(tamper-tainted?)(lambda(v_70)(begin(symbol? v_70))))" +"(define-values(tamper-armed?)(lambda(v_71)(begin(set? v_71))))" +"(define-values(tamper-clean?)(lambda(v_72)(begin(not v_72))))" +"(define-values" +"(tamper-tainted-for-content)" +"(lambda(v_73)(begin(if(datum-has-elements? v_73) 'tainted/need-propagate 'tainted))))" +"(define-values(tamper-needs-propagate?)(lambda(t_14)(begin(eq? t_14 'tainted/need-propagate))))" +"(define-values(tamper-propagated)(lambda(t_15)(begin(if(eq? t_15 'tainted/need-propagate) 'tainted t_15))))" +"(define-values(serialize-tamper)(lambda(t_16)(begin(if(tamper-armed? t_16) 'armed t_16))))" +"(define-values(current-arm-inspectors)(make-parameter(seteq)))" +"(define-values(deserialize-tamper)(lambda(t_17)(begin(if(eq? t_17 'armed)(current-arm-inspectors) t_17))))" +"(define-values" +"(struct:syntax" +" syntax1.1" +" syntax?$1" +" syntax-content" +" syntax-scopes" +" syntax-shifted-multi-scopes" +" syntax-scope-propagations+tamper" +" syntax-mpi-shifts" +" syntax-srcloc" +" syntax-props" +" syntax-inspector" +" set-syntax-content!" +" set-syntax-scope-propagations+tamper!)" +"(let-values(((struct:_14 make-_14 ?_14 -ref_14 -set!_14)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'syntax" +" #f" +" 8" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:reach-scopes" +"(lambda(s_45 reach_0)" +"(let-values(((prop_1)(syntax-scope-propagations+tamper s_45)))" +"(begin" +"(reach_0" +"(if(propagation?$1 prop_1)((propagation-ref prop_1) s_45)(syntax-content s_45)))" +"(reach_0(syntax-scopes s_45))" +"(reach_0(syntax-shifted-multi-scopes s_45))" +"(let-values(((ht_17)(syntax-props s_45)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_17)))" +"((letrec-values(((for-loop_3)" +"(lambda(i_47)" +"(begin" +" 'for-loop" +"(if i_47" +"(let-values(((k_13 v_74)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_17" +" i_47)))" +"(let-values((()" +"(let-values()" +"(if(preserved-property-value? v_74)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(reach_0" +"(plain-property-value" +" v_74)))" +"(values)))))" +"(values)))" +"(values)))))" +"(if(not #f)" +"(for-loop_3" +"(unsafe-immutable-hash-iterate-next ht_17 i_47))" +"(values))))" +"(values))))))" +" for-loop_3)" +"(unsafe-immutable-hash-iterate-first ht_17))))" +"(void)" +"(reach_0(syntax-srcloc s_45))))))" +"(cons" +" prop:serialize" +"(lambda(s_46 ser-push!_1 state_10)" +"(let-values(((prop_2)(syntax-scope-propagations+tamper s_46)))" +"(let-values(((content_0)" +"(if(propagation?$1 prop_2)" +"((propagation-ref prop_2) s_46)" +"(syntax-content s_46))))" +"(let-values(((properties_0)" +"(intern-properties" +"(syntax-props s_46)" +"(lambda()" +"(let-values(((ht_28)(syntax-props s_46)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_28)))" +"((letrec-values(((for-loop_30)" +"(lambda(table_24 i_48)" +"(begin" +" 'for-loop" +"(if i_48" +"(let-values(((k_14 v_75)" +"(hash-iterate-key+value" +" ht_28" +" i_48)))" +"(let-values(((table_25)" +"(let-values(((table_26)" +" table_24))" +"(if(preserved-property-value?" +" v_75)" +"(let-values(((table_27)" +" table_26))" +"(let-values(((table_28)" +"(let-values()" +"(let-values(((key_16" +" val_7)" +"(let-values()" +"(values" +" k_14" +"(check-value-to-preserve" +"(plain-property-value" +" v_75)" +" syntax?$1)))))" +"(hash-set" +" table_27" +" key_16" +" val_7)))))" +"(values table_28)))" +" table_26))))" +"(if(not #f)" +"(for-loop_30" +" table_25" +"(hash-iterate-next ht_28 i_48))" +" table_25)))" +" table_24)))))" +" for-loop_30)" +" '#hasheq()" +"(hash-iterate-first ht_28)))))" +" state_10)))" +"(let-values(((tamper_0)(serialize-tamper(syntax-tamper s_46))))" +"(let-values(((context-triple_0)" +"(intern-context-triple" +"(intern-scopes(syntax-scopes s_46) state_10)" +"(intern-shifted-multi-scopes" +"(syntax-shifted-multi-scopes s_46)" +" state_10)" +"(intern-mpi-shifts(syntax-mpi-shifts s_46) state_10)" +" state_10)))" +"(let-values(((stx-state_0)(get-syntax-context state_10)))" +"(if(let-values(((or-part_39) properties_0))(if or-part_39 or-part_39 tamper_0))" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:syntax+props)" +"(push-syntax-context! state_10 #f)" +"(ser-push!_1 content_0)" +"(pop-syntax-context! state_10)" +"(ser-push!_1 'reference context-triple_0)" +"(ser-push!_1 'reference(syntax-srcloc s_46))" +"(ser-push!_1 properties_0)" +"(ser-push!_1 tamper_0)" +"(if stx-state_0" +"(let-values()(set-syntax-state-all-sharing?! stx-state_0 #f))" +"(void))))" +"(let-values()" +"(let-values(((sharing-mode_0)" +"(hash-ref" +"(serialize-state-sharing-syntaxes state_10)" +" s_46" +" 'unknown)))" +"(begin" +"(if(eq? sharing-mode_0 'share)" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:datum->syntax)" +"(ser-push!_1(syntax->datum$1 s_46))))" +"(if(eq? sharing-mode_0 'unknown)" +"(let-values()" +"(let-values((()(begin(ser-push!_1 'tag '#:syntax)(values))))" +"(let-values(((this-state_0)" +"(if(no-pair-syntax-in-cdr? content_0)" +"(syntax-state17.1" +" #t" +" context-triple_0" +"(syntax-srcloc s_46))" +" #f)))" +"(let-values((()" +"(begin" +"(push-syntax-context! state_10 this-state_0)" +"(values))))" +"(let-values((()(begin(ser-push!_1 content_0)(values))))" +"(let-values((()" +"(begin" +"(pop-syntax-context! state_10)" +"(values))))" +"(let-values(((new-sharing-mode_0)" +"(if(if this-state_0" +"(syntax-state-all-sharing?" +" this-state_0)" +" #f)" +" 'share" +" 'none)))" +"(begin" +"(hash-set!" +"(serialize-state-sharing-syntaxes state_10)" +" s_46" +"(if(datum-has-elements? content_0)" +" new-sharing-mode_0" +" 'none))" +"(if(if stx-state_0(eq? new-sharing-mode_0 'none) #f)" +"(let-values()" +"(set-syntax-state-all-sharing?! stx-state_0 #f))" +"(void))))))))))" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:syntax)" +"(push-syntax-context! state_10 #f)" +"(ser-push!_1 content_0)" +"(pop-syntax-context! state_10)))))" +"(ser-push!_1 'reference context-triple_0)" +"(ser-push!_1 'reference(syntax-srcloc s_46))" +"(if stx-state_0" +"(let-values()" +"(if(if(eq?" +" context-triple_0" +"(syntax-state-context-triple stx-state_0))" +"(equal?(syntax-srcloc s_46)(syntax-state-srcloc stx-state_0))" +" #f)" +"(void)" +"(let-values()(set-syntax-state-all-sharing?! stx-state_0 #f))))" +"(void))))))))))))))" +"(cons" +" prop:custom-write" +"(lambda(s_47 port_5 mode_5)" +" (let-values ((() (begin (write-string \"#string srcloc_0)))" +" (if srcloc-str_0 (let-values () (fprintf port_5 \":~a\" srcloc-str_0)) (void))))" +"(void))" +" (fprintf port_5 \" ~.s\" (syntax->datum$1 s_47))" +" (write-string \">\" port_5)))))))" +"(current-inspector)" +" #f" +" '(1 2 4 5 6 7)" +" #f" +" 'syntax)))))" +"(values" +" struct:_14" +" make-_14" +" ?_14" +"(make-struct-field-accessor -ref_14 0 'content)" +"(make-struct-field-accessor -ref_14 1 'scopes)" +"(make-struct-field-accessor -ref_14 2 'shifted-multi-scopes)" +"(make-struct-field-accessor -ref_14 3 'scope-propagations+tamper)" +"(make-struct-field-accessor -ref_14 4 'mpi-shifts)" +"(make-struct-field-accessor -ref_14 5 'srcloc)" +"(make-struct-field-accessor -ref_14 6 'props)" +"(make-struct-field-accessor -ref_14 7 'inspector)" +"(make-struct-field-mutator -set!_14 0 'content)" +"(make-struct-field-mutator -set!_14 3 'scope-propagations+tamper))))" +"(define-values(prop:propagation propagation?$1 propagation-ref)(make-struct-type-property 'propagation))" +"(define-values" +"(prop:propagation-tamper propagation-tamper? propagation-tamper-ref)" +"(make-struct-type-property 'propagation-tamper))" +"(define-values" +"(prop:propagation-set-tamper propagation-set-tamper? propagation-set-tamper-ref)" +"(make-struct-type-property 'propagation-set-tamper))" +"(define-values" +"(syntax-tamper)" +"(lambda(s_32)" +"(begin" +"(let-values(((v_76)(syntax-scope-propagations+tamper s_32)))" +"(if(tamper? v_76) v_76((propagation-tamper-ref v_76) v_76))))))" +"(define-values(empty-scopes)(seteq))" +"(define-values(empty-shifted-multi-scopes)(seteq))" +"(define-values(empty-mpi-shifts) null)" +"(define-values(empty-props) '#hasheq())" +"(define-values" +"(empty-syntax)" +"(syntax1.1 #f empty-scopes empty-shifted-multi-scopes #f empty-mpi-shifts #f empty-props #f))" +"(define-values(identifier?)(lambda(s_48)(begin(if(syntax?$1 s_48)(symbol?(syntax-content s_48)) #f))))" +"(define-values(syntax-identifier?)(lambda(s_49)(begin(symbol?(syntax-content s_49)))))" +"(define-values" +"(syntax->datum$1)" +"(lambda(s_50)" +"(begin" +" 'syntax->datum" +"(let-values(((s_51) s_50)" +"((f_23)(lambda(tail?_6 x_25)(begin 'f x_25)))" +"((d->s_0)(lambda(s_52 d_1)(begin 'd->s d_1)))" +"((s-e_0) syntax-content)" +"((seen_3) #f))" +"((letrec-values(((loop_59)" +"(lambda(s_53)" +"(begin" +" 'loop" +"(let-values(((s_54) s_53)" +"((f_24) f_23)" +"((gf_1)" +"(lambda(tail?_7 v_77)" +"(begin" +" 'gf" +"(if(syntax?$1 v_77)" +"(let-values()(d->s_0 v_77(loop_59(s-e_0 v_77))))" +"(let-values()(f_23 tail?_7 v_77))))))" +"((seen_4) seen_3))" +"((letrec-values(((loop_67)" +"(lambda(tail?_8 s_55 prev-depth_1)" +"(begin" +" 'loop" +"(let-values(((depth_1)(fx+ 1 prev-depth_1)))" +"(if(if seen_4(fx> depth_1 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_8" +" s_55" +"(lambda(tail?_9 s_56)(gf_1 tail?_9 s_56))" +" seen_4))" +"(if(null? s_55)" +"(let-values()(f_24 tail?_8 s_55))" +"(if(pair? s_55)" +"(let-values()" +"(f_24" +" tail?_8" +"(cons" +"(loop_67 #f(car s_55) depth_1)" +"(loop_67 #t(cdr s_55) depth_1))))" +"(if(symbol? s_55)" +"(let-values()(f_24 #f s_55))" +"(if(boolean? s_55)" +"(let-values()(f_24 #f s_55))" +"(if(number? s_55)" +"(let-values()(f_24 #f s_55))" +"(if(let-values(((or-part_84)(vector? s_55)))" +"(if or-part_84" +" or-part_84" +"(let-values(((or-part_85)(box? s_55)))" +"(if or-part_85" +" or-part_85" +"(let-values(((or-part_86)" +"(prefab-struct-key s_55)))" +"(if or-part_86" +" or-part_86" +"(hash? s_55)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_8" +" s_55" +"(lambda(tail?_10 s_57)(gf_1 tail?_10 s_57))" +" seen_4))" +"(let-values()(gf_1 #f s_55))))))))))))))" +" loop_67)" +" #f" +" s_54" +" 0))))))" +" loop_59)" +" s_51)))))" +"(define-values" +"(datum->syntax$1)" +"(let-values(((datum->syntax6_0)" +"(lambda(stx-c4_0 s5_0 stx-l2_0 stx-p3_0)" +"(begin" +" 'datum->syntax6" +"(let-values(((stx-c_0) stx-c4_0))" +"(let-values(((s_58) s5_0))" +"(let-values(((stx-l_0) stx-l2_0))" +"(let-values(((stx-p_0) stx-p3_0))" +"(let-values()" +"(if(syntax?$1 s_58)" +"(let-values() s_58)" +"(let-values()" +"(let-values(((wrap_0)" +"(lambda(content_1)" +"(begin" +" 'wrap" +"(syntax1.1" +" content_1" +"(if stx-c_0(syntax-scopes stx-c_0) empty-scopes)" +"(if stx-c_0" +"(syntax-shifted-multi-scopes stx-c_0)" +" empty-shifted-multi-scopes)" +"(if stx-c_0" +"(if(syntax-tamper stx-c_0)" +"(tamper-tainted-for-content content_1)" +" #f)" +" #f)" +"(if stx-c_0(syntax-mpi-shifts stx-c_0) empty-mpi-shifts)" +"(if stx-l_0(syntax-srcloc stx-l_0) #f)" +" empty-props" +"(if stx-c_0(syntax-inspector stx-c_0) #f))))))" +"(let-values(((result-s_0)" +"(let-values(((s_59) s_58)" +"((f_25)" +"(lambda(tail?_11 x_26)" +"(begin 'f(if tail?_11 x_26(wrap_0 x_26)))))" +"((s->_0)(lambda(s_60)(begin 's-> s_60)))" +"((seen_5) disallow-cycles))" +"(let-values(((s_61) s_59)" +"((f_26) f_25)" +"((gf_2)" +"(lambda(tail?_12 v_78)" +"(begin" +" 'gf" +"(if(syntax?$1 v_78)" +"(let-values()(s->_0 v_78))" +"(let-values()(f_25 tail?_12 v_78))))))" +"((seen_6) seen_5))" +"((letrec-values(((loop_68)" +"(lambda(tail?_13 s_62 prev-depth_2)" +"(begin" +" 'loop" +"(let-values(((depth_2)" +"(fx+ 1 prev-depth_2)))" +"(if(if seen_6(fx> depth_2 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_13" +" s_62" +"(lambda(tail?_14 s_63)" +"(gf_2 tail?_14 s_63))" +" seen_6))" +"(if(null? s_62)" +"(let-values()(f_26 tail?_13 s_62))" +"(if(pair? s_62)" +"(let-values()" +"(f_26" +" tail?_13" +"(cons" +"(loop_68 #f(car s_62) depth_2)" +"(loop_68" +" #t" +"(cdr s_62)" +" depth_2))))" +"(if(symbol? s_62)" +"(let-values()(f_26 #f s_62))" +"(if(boolean? s_62)" +"(let-values()(f_26 #f s_62))" +"(if(number? s_62)" +"(let-values()(f_26 #f s_62))" +"(if(let-values(((or-part_87)" +"(vector?" +" s_62)))" +"(if or-part_87" +" or-part_87" +"(let-values(((or-part_88)" +"(box?" +" s_62)))" +"(if or-part_88" +" or-part_88" +"(let-values(((or-part_89)" +"(prefab-struct-key" +" s_62)))" +"(if or-part_89" +" or-part_89" +"(hash?" +" s_62)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_13" +" s_62" +"(lambda(tail?_15 s_64)" +"(gf_2 tail?_15 s_64))" +" seen_6))" +"(let-values()" +"(gf_2" +" #f" +" s_62))))))))))))))" +" loop_68)" +" #f" +" s_61" +" 0)))))" +"(if(if stx-p_0(not(eq?(syntax-props stx-p_0) empty-props)) #f)" +"(let-values(((the-struct_0) result-s_0))" +"(if(syntax?$1 the-struct_0)" +"(let-values(((props19_0)(syntax-props stx-p_0)))" +"(syntax1.1" +"(syntax-content the-struct_0)" +"(syntax-scopes the-struct_0)" +"(syntax-shifted-multi-scopes the-struct_0)" +"(syntax-scope-propagations+tamper the-struct_0)" +"(syntax-mpi-shifts the-struct_0)" +"(syntax-srcloc the-struct_0)" +" props19_0" +"(syntax-inspector the-struct_0)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_0)))" +" result-s_0))))))))))))))" +"(case-lambda" +"((stx-c_1 s_65)(begin 'datum->syntax(datum->syntax6_0 stx-c_1 s_65 #f #f)))" +"((stx-c_2 s_66 stx-l_1 stx-p3_1)(datum->syntax6_0 stx-c_2 s_66 stx-l_1 stx-p3_1))" +"((stx-c_3 s_67 stx-l2_1)(datum->syntax6_0 stx-c_3 s_67 stx-l2_1 #f)))))" +"(define-values" +"(disallow-cycles)" +"(hasheq" +" 'cycle-fail" +" (lambda (s_68) (raise-arguments-error 'datum->syntax \"cannot create syntax from cyclic datum\" \"datum\" s_68))))" +"(define-values" +"(struct:syntax-state" +" syntax-state17.1" +" syntax-state?" +" syntax-state-all-sharing?" +" syntax-state-context-triple" +" syntax-state-srcloc" +" set-syntax-state-all-sharing?!)" +"(let-values(((struct:_15 make-_15 ?_15 -ref_15 -set!_15)" +"(let-values()" +"(let-values()" +"(make-struct-type 'syntax-state #f 3 0 #f null(current-inspector) #f '(1 2) #f 'syntax-state)))))" +"(values" +" struct:_15" +" make-_15" +" ?_15" +"(make-struct-field-accessor -ref_15 0 'all-sharing?)" +"(make-struct-field-accessor -ref_15 1 'context-triple)" +"(make-struct-field-accessor -ref_15 2 'srcloc)" +"(make-struct-field-mutator -set!_15 0 'all-sharing?))))" +"(define-values" +"(no-pair-syntax-in-cdr?)" +"(lambda(content_2)" +"(begin" +"(if(pair? content_2)" +"(let-values()" +"((letrec-values(((loop_69)" +"(lambda(content_3)" +"(begin" +" 'loop" +"(if(if(syntax?$1 content_3)(pair?(syntax-content content_3)) #f)" +"(let-values() #f)" +"(if(pair? content_3)" +"(let-values()(loop_69(cdr content_3)))" +"(let-values() #t)))))))" +" loop_69)" +"(cdr content_2)))" +"(let-values() #t)))))" +"(define-values" +"(deserialize-syntax)" +"(lambda(content_4 context-triple_1 srcloc_1 props_0 tamper_1 inspector_0)" +"(begin" +"(syntax1.1" +" content_4" +"(vector*-ref context-triple_1 0)" +"(vector*-ref context-triple_1 1)" +"(deserialize-tamper tamper_1)" +"(vector*-ref context-triple_1 2)" +" srcloc_1" +"(if props_0" +"(let-values(((ht_29) props_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_29)))" +"((letrec-values(((for-loop_31)" +"(lambda(table_29 i_49)" +"(begin" +" 'for-loop" +"(if i_49" +"(let-values(((k_15 v_79)(unsafe-immutable-hash-iterate-key+value ht_29 i_49)))" +"(let-values(((table_30)" +"(let-values(((table_31) table_29))" +"(let-values(((table_32)" +"(let-values()" +"(let-values(((key_17 val_8)" +"(let-values()" +"(values" +" k_15" +"(preserved-property-value1.1" +" v_79)))))" +"(hash-set table_31 key_17 val_8)))))" +"(values table_32)))))" +"(if(not #f)" +"(for-loop_31 table_30(unsafe-immutable-hash-iterate-next ht_29 i_49))" +" table_30)))" +" table_29)))))" +" for-loop_31)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_29))))" +" empty-props)" +" inspector_0))))" +"(define-values" +"(deserialize-datum->syntax)" +"(lambda(content_5 context-triple_2 srcloc_2 inspector_1)" +"(begin" +"(let-values(((s_69)(deserialize-syntax #f context-triple_2 srcloc_2 #f #f inspector_1)))" +"(datum->syntax$1 s_69 content_5 s_69 s_69)))))" +"(define-values" +"(struct:full-binding full-binding1.1 full-binding? full-binding-frame-id full-binding-free=id)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-binding" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:binding-reach-scopes(lambda(b_21)(binding-free=id b_21))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'full-binding)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'frame-id)" +"(make-struct-field-accessor -ref_0 1 'free=id))))" +"(define-values(binding-frame-id)(lambda(b_22)(begin(if(full-binding? b_22)(full-binding-frame-id b_22) #f))))" +"(define-values(binding-free=id)(lambda(b_11)(begin(if(full-binding? b_11)(full-binding-free=id b_11) #f))))" +"(define-values" +"(make-module-binding22.1)" +"(lambda(extra-inspector8_0" +" extra-nominal-bindings9_0" +" frame-id6_0" +" free=id7_0" +" nominal-module2_0" +" nominal-phase3_0" +" nominal-require-phase5_0" +" nominal-sym4_0" +" wrt1_0" +" module19_0" +" phase20_0" +" sym21_0)" +"(begin" +" 'make-module-binding22" +"(let-values(((module_0) module19_0))" +"(let-values(((phase_0) phase20_0))" +"(let-values(((sym_0) sym21_0))" +"(let-values()" +"(let-values(((nominal-module_0)" +"(if(eq? nominal-module2_0 unsafe-undefined) module_0 nominal-module2_0)))" +"(let-values(((nominal-phase_0)(if(eq? nominal-phase3_0 unsafe-undefined) phase_0 nominal-phase3_0)))" +"(let-values(((nominal-sym_0)(if(eq? nominal-sym4_0 unsafe-undefined) sym_0 nominal-sym4_0)))" +"(let-values(((nominal-require-phase_0) nominal-require-phase5_0))" +"(let-values(((frame-id_0) frame-id6_0))" +"(let-values(((free=id_0) free=id7_0))" +"(let-values(((extra-inspector_0) extra-inspector8_0))" +"(let-values(((extra-nominal-bindings_0) extra-nominal-bindings9_0))" +"(let-values()" +"(if(let-values(((or-part_90) frame-id_0))" +"(if or-part_90" +" or-part_90" +"(let-values(((or-part_91) free=id_0))" +"(if or-part_91" +" or-part_91" +"(let-values(((or-part_92) extra-inspector_0))" +"(if or-part_92" +" or-part_92" +"(not" +"(if(eqv? nominal-phase_0 phase_0)" +"(if(eq? nominal-sym_0 sym_0)" +"(if(eqv? nominal-require-phase_0 0)" +"(null? extra-nominal-bindings_0)" +" #f)" +" #f)" +" #f))))))))" +"(let-values()" +"(full-module-binding51.1" +" frame-id_0" +" free=id_0" +" module_0" +" phase_0" +" sym_0" +" nominal-module_0" +" nominal-phase_0" +" nominal-sym_0" +" nominal-require-phase_0" +" extra-inspector_0" +" extra-nominal-bindings_0))" +"(let-values()" +"(simple-module-binding52.1" +" module_0" +" phase_0" +" sym_0" +" nominal-module_0)))))))))))))))))))" +"(define-values" +"(module-binding-update48.1)" +"(lambda(extra-inspector34_0" +" extra-nominal-bindings35_0" +" frame-id32_0" +" free=id33_0" +" module25_0" +" nominal-module28_0" +" nominal-phase29_0" +" nominal-require-phase31_0" +" nominal-sym30_0" +" phase26_0" +" sym27_0" +" b47_0)" +"(begin" +" 'module-binding-update48" +"(let-values(((b_23) b47_0))" +"(let-values(((module_1)(if(eq? module25_0 unsafe-undefined)(module-binding-module b_23) module25_0)))" +"(let-values(((phase_1)(if(eq? phase26_0 unsafe-undefined)(module-binding-phase b_23) phase26_0)))" +"(let-values(((sym_1)(if(eq? sym27_0 unsafe-undefined)(module-binding-sym b_23) sym27_0)))" +"(let-values(((nominal-module_1)" +"(if(eq? nominal-module28_0 unsafe-undefined)" +"(module-binding-nominal-module b_23)" +" nominal-module28_0)))" +"(let-values(((nominal-phase_1)" +"(if(eq? nominal-phase29_0 unsafe-undefined)" +"(module-binding-nominal-phase b_23)" +" nominal-phase29_0)))" +"(let-values(((nominal-sym_1)" +"(if(eq? nominal-sym30_0 unsafe-undefined)" +"(module-binding-nominal-sym b_23)" +" nominal-sym30_0)))" +"(let-values(((nominal-require-phase_1)" +"(if(eq? nominal-require-phase31_0 unsafe-undefined)" +"(module-binding-nominal-require-phase b_23)" +" nominal-require-phase31_0)))" +"(let-values(((frame-id_1)" +"(if(eq? frame-id32_0 unsafe-undefined)(binding-frame-id b_23) frame-id32_0)))" +"(let-values(((free=id_1)" +"(if(eq? free=id33_0 unsafe-undefined)(binding-free=id b_23) free=id33_0)))" +"(let-values(((extra-inspector_1)" +"(if(eq? extra-inspector34_0 unsafe-undefined)" +"(module-binding-extra-inspector b_23)" +" extra-inspector34_0)))" +"(let-values(((extra-nominal-bindings_1)" +"(if(eq? extra-nominal-bindings35_0 unsafe-undefined)" +"(module-binding-extra-nominal-bindings b_23)" +" extra-nominal-bindings35_0)))" +"(let-values()" +"(let-values(((module53_0) module_1)" +"((phase54_0) phase_1)" +"((sym55_0) sym_1)" +"((nominal-module56_0) nominal-module_1)" +"((nominal-phase57_0) nominal-phase_1)" +"((nominal-sym58_0) nominal-sym_1)" +"((nominal-require-phase59_0) nominal-require-phase_1)" +"((frame-id60_0) frame-id_1)" +"((free=id61_0) free=id_1)" +"((extra-inspector62_0) extra-inspector_1)" +"((extra-nominal-bindings63_0) extra-nominal-bindings_1))" +"(make-module-binding22.1" +" extra-inspector62_0" +" extra-nominal-bindings63_0" +" frame-id60_0" +" free=id61_0" +" nominal-module56_0" +" nominal-phase57_0" +" nominal-require-phase59_0" +" nominal-sym58_0" +" unsafe-undefined" +" module53_0" +" phase54_0" +" sym55_0))))))))))))))))))" +"(define-values" +"(module-binding?)" +"(lambda(b_24)" +"(begin" +"(let-values(((or-part_93)(simple-module-binding? b_24)))" +"(if or-part_93 or-part_93(full-module-binding? b_24))))))" +"(define-values" +"(struct:full-module-binding" +" full-module-binding51.1" +" full-module-binding?" +" full-module-binding-module" +" full-module-binding-phase" +" full-module-binding-sym" +" full-module-binding-nominal-module" +" full-module-binding-nominal-phase" +" full-module-binding-nominal-sym" +" full-module-binding-nominal-require-phase" +" full-module-binding-extra-inspector" +" full-module-binding-extra-nominal-bindings)" +"(let-values(((struct:_16 make-_16 ?_16 -ref_16 -set!_16)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-module-binding" +" struct:full-binding" +" 9" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_25 ser-push!_2 state_11)" +"(let-values(((simplified-b_0)" +"(if(full-binding-frame-id b_25)" +"(let-values(((b65_0) b_25)((temp66_0) #f))" +"(module-binding-update48.1" +" unsafe-undefined" +" unsafe-undefined" +" temp66_0" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" b65_0))" +" b_25)))" +"(if(full-module-binding? simplified-b_0)" +"(let-values()" +"(begin" +"(ser-push!_2 'tag '#:module-binding)" +"(ser-push!_2(full-module-binding-module b_25))" +"(ser-push!_2(full-module-binding-sym b_25))" +"(ser-push!_2(full-module-binding-phase b_25))" +"(ser-push!_2(full-module-binding-nominal-module b_25))" +"(ser-push!_2(full-module-binding-nominal-phase b_25))" +"(ser-push!_2(full-module-binding-nominal-sym b_25))" +"(ser-push!_2(full-module-binding-nominal-require-phase b_25))" +"(ser-push!_2(full-binding-free=id b_25))" +"(if(full-module-binding-extra-inspector b_25)" +"(ser-push!_2 'tag '#:inspector)" +"(ser-push!_2 #f))" +"(ser-push!_2(full-module-binding-extra-nominal-bindings b_25))))" +"(let-values()(ser-push!_2 simplified-b_0)))))))" +" #f" +" #f" +" '(0 1 2 3 4 5 6 7 8)" +" #f" +" 'full-module-binding)))))" +"(values" +" struct:_16" +" make-_16" +" ?_16" +"(make-struct-field-accessor -ref_16 0 'module)" +"(make-struct-field-accessor -ref_16 1 'phase)" +"(make-struct-field-accessor -ref_16 2 'sym)" +"(make-struct-field-accessor -ref_16 3 'nominal-module)" +"(make-struct-field-accessor -ref_16 4 'nominal-phase)" +"(make-struct-field-accessor -ref_16 5 'nominal-sym)" +"(make-struct-field-accessor -ref_16 6 'nominal-require-phase)" +"(make-struct-field-accessor -ref_16 7 'extra-inspector)" +"(make-struct-field-accessor -ref_16 8 'extra-nominal-bindings))))" +"(define-values" +"(struct:simple-module-binding" +" simple-module-binding52.1" +" simple-module-binding?" +" simple-module-binding-module" +" simple-module-binding-phase" +" simple-module-binding-sym" +" simple-module-binding-nominal-module)" +"(let-values(((struct:_17 make-_17 ?_17 -ref_17 -set!_17)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'simple-module-binding" +" #f" +" 4" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_26 ser-push!_3 state_12)" +"(begin" +"(ser-push!_3 'tag '#:simple-module-binding)" +"(ser-push!_3(simple-module-binding-module b_26))" +"(ser-push!_3(simple-module-binding-sym b_26))" +"(ser-push!_3(simple-module-binding-phase b_26))" +"(ser-push!_3(simple-module-binding-nominal-module b_26))))))" +" #f" +" #f" +" '(0 1 2 3)" +" #f" +" 'simple-module-binding)))))" +"(values" +" struct:_17" +" make-_17" +" ?_17" +"(make-struct-field-accessor -ref_17 0 'module)" +"(make-struct-field-accessor -ref_17 1 'phase)" +"(make-struct-field-accessor -ref_17 2 'sym)" +"(make-struct-field-accessor -ref_17 3 'nominal-module))))" +"(define-values" +"(deserialize-full-module-binding)" +"(lambda(module_2" +" sym_2" +" phase_2" +" nominal-module_2" +" nominal-phase_2" +" nominal-sym_2" +" nominal-require-phase_2" +" free=id_2" +" extra-inspector_2" +" extra-nominal-bindings_2)" +"(begin" +"(let-values(((module68_0) module_2)" +"((phase69_0) phase_2)" +"((sym70_0) sym_2)" +"((nominal-module71_0) nominal-module_2)" +"((nominal-phase72_0) nominal-phase_2)" +"((nominal-sym73_0) nominal-sym_2)" +"((nominal-require-phase74_0) nominal-require-phase_2)" +"((free=id75_0) free=id_2)" +"((extra-inspector76_0) extra-inspector_2)" +"((extra-nominal-bindings77_0) extra-nominal-bindings_2))" +"(make-module-binding22.1" +" extra-inspector76_0" +" extra-nominal-bindings77_0" +" #f" +" free=id75_0" +" nominal-module71_0" +" nominal-phase72_0" +" nominal-require-phase74_0" +" nominal-sym73_0" +" unsafe-undefined" +" module68_0" +" phase69_0" +" sym70_0)))))" +"(define-values" +"(deserialize-simple-module-binding)" +"(lambda(module_3 sym_3 phase_3 nominal-module_3)" +"(begin(simple-module-binding52.1 module_3 phase_3 sym_3 nominal-module_3))))" +"(define-values" +"(module-binding-module)" +"(lambda(b_27)" +"(begin(if(simple-module-binding? b_27)(simple-module-binding-module b_27)(full-module-binding-module b_27)))))" +"(define-values" +"(module-binding-phase)" +"(lambda(b_28)" +"(begin(if(simple-module-binding? b_28)(simple-module-binding-phase b_28)(full-module-binding-phase b_28)))))" +"(define-values" +"(module-binding-sym)" +"(lambda(b_29)" +"(begin(if(simple-module-binding? b_29)(simple-module-binding-sym b_29)(full-module-binding-sym b_29)))))" +"(define-values" +"(module-binding-nominal-module)" +"(lambda(b_30)" +"(begin" +"(if(simple-module-binding? b_30)" +"(simple-module-binding-nominal-module b_30)" +"(full-module-binding-nominal-module b_30)))))" +"(define-values" +"(module-binding-nominal-phase)" +"(lambda(b_31)" +"(begin" +"(if(simple-module-binding? b_31)(simple-module-binding-phase b_31)(full-module-binding-nominal-phase b_31)))))" +"(define-values" +"(module-binding-nominal-sym)" +"(lambda(b_32)" +"(begin(if(simple-module-binding? b_32)(simple-module-binding-sym b_32)(full-module-binding-nominal-sym b_32)))))" +"(define-values" +"(module-binding-nominal-require-phase)" +"(lambda(b_33)(begin(if(simple-module-binding? b_33) 0(full-module-binding-nominal-require-phase b_33)))))" +"(define-values" +"(module-binding-extra-inspector)" +"(lambda(b_34)(begin(if(simple-module-binding? b_34) #f(full-module-binding-extra-inspector b_34)))))" +"(define-values" +"(module-binding-extra-nominal-bindings)" +"(lambda(b_35)(begin(if(simple-module-binding? b_35) null(full-module-binding-extra-nominal-bindings b_35)))))" +"(define-values(empty-binding-table) '#hasheq())" +"(define-values" +"(struct:table-with-bulk-bindings" +" table-with-bulk-bindings1.1" +" table-with-bulk-bindings?" +" table-with-bulk-bindings-syms" +" table-with-bulk-bindings-syms/serialize" +" table-with-bulk-bindings-bulk-bindings)" +"(let-values(((struct:_18 make-_18 ?_18 -ref_18 -set!_18)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'table-with-bulk-bindings" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(twbb_0 ser-push!_4 state_13)" +"(begin" +"(ser-push!_4 'tag '#:table-with-bulk-bindings)" +"(ser-push!_4(table-with-bulk-bindings-syms/serialize twbb_0))" +"(ser-push!_4(table-with-bulk-bindings-bulk-bindings twbb_0))))))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'table-with-bulk-bindings)))))" +"(values" +" struct:_18" +" make-_18" +" ?_18" +"(make-struct-field-accessor -ref_18 0 'syms)" +"(make-struct-field-accessor -ref_18 1 'syms/serialize)" +"(make-struct-field-accessor -ref_18 2 'bulk-bindings))))" +"(define-values" +"(deserialize-table-with-bulk-bindings)" +"(lambda(syms_1 bulk-bindings_0)(begin(table-with-bulk-bindings1.1 syms_1 syms_1 bulk-bindings_0))))" +"(define-values" +"(struct:bulk-binding-at bulk-binding-at2.1 bulk-binding-at? bulk-binding-at-scopes bulk-binding-at-bulk)" +"(let-values(((struct:_19 make-_19 ?_19 -ref_19 -set!_19)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-at" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +" (cons prop:reach-scopes (lambda (sms_2 reach_1) (error \"shouldn't get here\")))" +"(cons" +" prop:serialize" +"(lambda(bba_0 ser-push!_5 state_14)" +"(begin" +"(ser-push!_5 'tag '#:bulk-binding-at)" +"(ser-push!_5(bulk-binding-at-scopes bba_0))" +"(ser-push!_5(bulk-binding-at-bulk bba_0))))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'bulk-binding-at)))))" +"(values" +" struct:_19" +" make-_19" +" ?_19" +"(make-struct-field-accessor -ref_19 0 'scopes)" +"(make-struct-field-accessor -ref_19 1 'bulk))))" +"(define-values(deserialize-bulk-binding-at)(lambda(scopes_0 bulk_0)(begin(bulk-binding-at2.1 scopes_0 bulk_0))))" +"(define-values(prop:bulk-binding bulk-binding?$1 bulk-binding-ref)(make-struct-type-property 'bulk-binding))" +"(define-values" +"(struct:bulk-binding-class" +" bulk-binding-class3.1" +" bulk-binding-class?" +" bulk-binding-class-get-symbols" +" bulk-binding-class-create)" +"(let-values(((struct:_20 make-_20 ?_20 -ref_20 -set!_20)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-class" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'bulk-binding-class)))))" +"(values" +" struct:_20" +" make-_20" +" ?_20" +"(make-struct-field-accessor -ref_20 0 'get-symbols)" +"(make-struct-field-accessor -ref_20 1 'create))))" +"(define-values" +"(bulk-binding-symbols)" +"(lambda(b_36 s_70 extra-shifts_0)" +"(begin" +"((bulk-binding-class-get-symbols(bulk-binding-ref b_36))" +" b_36" +"(append extra-shifts_0(if s_70(syntax-mpi-shifts s_70) null))))))" +"(define-values(bulk-binding-create)(lambda(b_37)(begin(bulk-binding-class-create(bulk-binding-ref b_37)))))" +"(define-values(binding-table-empty?)(lambda(bt_0)(begin(if(hash? bt_0)(zero?(hash-count bt_0)) #f))))" +"(define-values" +"(binding-table-add)" +"(lambda(bt_1 scopes_1 sym_4 binding_0 just-for-nominal?_0)" +"(begin" +"(if(hash? bt_1)" +"(let-values()(hash-set bt_1 sym_4(hash-set(hash-ref bt_1 sym_4 '#hash()) scopes_1 binding_0)))" +"(let-values()" +"(let-values(((new-syms_0)" +"(binding-table-add" +"(table-with-bulk-bindings-syms bt_1)" +" scopes_1" +" sym_4" +" binding_0" +" just-for-nominal?_0)))" +"(let-values(((new-syms/serialize_0)" +"(if just-for-nominal?_0" +"(let-values()(table-with-bulk-bindings-syms/serialize bt_1))" +"(if(eq?" +"(table-with-bulk-bindings-syms bt_1)" +"(table-with-bulk-bindings-syms/serialize bt_1))" +"(let-values() new-syms_0)" +"(let-values()" +"(binding-table-add" +"(table-with-bulk-bindings-syms/serialize bt_1)" +" scopes_1" +" sym_4" +" binding_0" +" #f))))))" +"(let-values(((the-struct_1) bt_1))" +"(if(table-with-bulk-bindings? the-struct_1)" +"(let-values(((syms32_0) new-syms_0)((syms/serialize33_0) new-syms/serialize_0))" +"(table-with-bulk-bindings1.1" +" syms32_0" +" syms/serialize33_0" +"(table-with-bulk-bindings-bulk-bindings the-struct_1)))" +" (raise-argument-error 'struct-copy \"table-with-bulk-bindings?\" the-struct_1))))))))))" +"(define-values" +"(prop:implicitly-reachable implicitly-reachable? implicitly-reachable-ref)" +"(make-struct-type-property 'implicitly-reachable))" +"(define-values" +"(binding-table-add-bulk9.1)" +"(lambda(shadow-except4_0 bt6_0 scopes7_0 bulk8_0)" +"(begin" +" 'binding-table-add-bulk9" +"(let-values(((bt_2) bt6_0))" +"(let-values(((scopes_2) scopes7_0))" +"(let-values(((bulk_1) bulk8_0))" +"(let-values(((shadow-except_0) shadow-except4_0))" +"(let-values()" +"(if(table-with-bulk-bindings? bt_2)" +"(let-values()" +"(let-values(((new-syms_1)" +"(let-values(((temp34_0)(table-with-bulk-bindings-syms bt_2))" +"((scopes35_0) scopes_2)" +"((bulk36_0) bulk_1)" +"((shadow-except37_0) shadow-except_0))" +"(remove-matching-bindings17.1 shadow-except37_0 temp34_0 scopes35_0 bulk36_0))))" +"(let-values(((new-syms/serialize_1)" +"(if(eq?" +"(table-with-bulk-bindings-syms bt_2)" +"(table-with-bulk-bindings-syms/serialize bt_2))" +" new-syms_1" +"(let-values(((temp38_0)(table-with-bulk-bindings-syms/serialize bt_2))" +"((scopes39_0) scopes_2)" +"((bulk40_0) bulk_1)" +"((shadow-except41_0) shadow-except_0))" +"(remove-matching-bindings17.1" +" shadow-except41_0" +" temp38_0" +" scopes39_0" +" bulk40_0)))))" +"(table-with-bulk-bindings1.1" +" new-syms_1" +" new-syms/serialize_1" +"(cons(bulk-binding-at2.1 scopes_2 bulk_1)(table-with-bulk-bindings-bulk-bindings bt_2))))))" +"(let-values()" +"(let-values(((temp42_0)(table-with-bulk-bindings1.1 bt_2 bt_2 null))" +"((scopes43_0) scopes_2)" +"((bulk44_0) bulk_1))" +"(binding-table-add-bulk9.1 #f temp42_0 scopes43_0 bulk44_0))))))))))))" +"(define-values" +"(remove-matching-bindings17.1)" +"(lambda(except12_0 syms14_0 scopes15_0 bulk16_0)" +"(begin" +" 'remove-matching-bindings17" +"(let-values(((syms_2) syms14_0))" +"(let-values(((scopes_3) scopes15_0))" +"(let-values(((bulk_2) bulk16_0))" +"(let-values(((except_0) except12_0))" +"(let-values()" +"(let-values(((bulk-symbols_0)(bulk-binding-symbols bulk_2 #f null)))" +"(if(<(hash-count syms_2)(hash-count bulk-symbols_0))" +"(let-values()" +"(let-values(((ht_30) syms_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_30)))" +"((letrec-values(((for-loop_32)" +"(lambda(syms_3 i_34)" +"(begin" +" 'for-loop" +"(if i_34" +"(let-values(((sym_5 sym-bindings_0)" +"(unsafe-immutable-hash-iterate-key+value ht_30 i_34)))" +"(let-values(((syms_4)" +"(let-values(((syms_5) syms_3))" +"(let-values(((syms_6)" +"(let-values()" +"(if(hash-ref" +" bulk-symbols_0" +" sym_5" +" #f)" +"(let-values(((syms45_0) syms_5)" +"((sym46_0) sym_5)" +"((sym-bindings47_0)" +" sym-bindings_0)" +"((scopes48_0)" +" scopes_3)" +"((except49_0)" +" except_0))" +"(remove-matching-binding26.1" +" except49_0" +" syms45_0" +" sym46_0" +" sym-bindings47_0" +" scopes48_0))" +" syms_5))))" +"(values syms_6)))))" +"(if(not #f)" +"(for-loop_32" +" syms_4" +"(unsafe-immutable-hash-iterate-next ht_30 i_34))" +" syms_4)))" +" syms_3)))))" +" for-loop_32)" +" syms_2" +"(unsafe-immutable-hash-iterate-first ht_30)))))" +"(let-values()" +"(let-values(((ht_31) bulk-symbols_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_31)))" +"((letrec-values(((for-loop_33)" +"(lambda(syms_7 i_50)" +"(begin" +" 'for-loop" +"(if i_50" +"(let-values(((sym_6)(unsafe-immutable-hash-iterate-key ht_31 i_50)))" +"(let-values(((syms_8)" +"(let-values(((syms_9) syms_7))" +"(let-values(((syms_10)" +"(let-values()" +"(let-values(((sym-bindings_1)" +"(hash-ref" +" syms_9" +" sym_6" +" #f)))" +"(if sym-bindings_1" +"(let-values(((syms50_0) syms_9)" +"((sym51_0) sym_6)" +"((sym-bindings52_0)" +" sym-bindings_1)" +"((scopes53_0)" +" scopes_3)" +"((except54_0)" +" except_0))" +"(remove-matching-binding26.1" +" except54_0" +" syms50_0" +" sym51_0" +" sym-bindings52_0" +" scopes53_0))" +" syms_9)))))" +"(values syms_10)))))" +"(if(not #f)" +"(for-loop_33" +" syms_8" +"(unsafe-immutable-hash-iterate-next ht_31 i_50))" +" syms_8)))" +" syms_7)))))" +" for-loop_33)" +" syms_2" +"(unsafe-immutable-hash-iterate-first ht_31)))))))))))))))" +"(define-values" +"(remove-matching-binding26.1)" +"(lambda(except20_0 syms22_0 sym23_0 sym-bindings24_0 scopes25_0)" +"(begin" +" 'remove-matching-binding26" +"(let-values(((syms_11) syms22_0))" +"(let-values(((sym_7) sym23_0))" +"(let-values(((sym-bindings_2) sym-bindings24_0))" +"(let-values(((scopes_4) scopes25_0))" +"(let-values(((except_1) except20_0))" +"(let-values()" +"(if(if except_1" +"(let-values(((b_38)(hash-ref sym-bindings_2 scopes_4 #f)))" +"(if(module-binding? b_38)(eq? except_1(module-binding-module b_38)) #f))" +" #f)" +"(let-values() syms_11)" +"(let-values()(hash-set syms_11 sym_7(hash-remove sym-bindings_2 scopes_4)))))))))))))" +"(define-values" +"(next-state-in-full-binding-table)" +"(lambda(sym-ht_0 sym-i_0)" +"(begin" +"(if sym-i_0" +"(let-values(((ht_32)(hash-iterate-value sym-ht_0 sym-i_0)))" +"(let-values(((i_51)(hash-iterate-first ht_32)))" +"(if i_51" +"(cons(vector sym-i_0(hash-iterate-key sym-ht_0 sym-i_0) ht_32) i_51)" +"(next-state-in-full-binding-table(hash-iterate-next sym-ht_0 sym-i_0)))))" +" '(#f . #f)))))" +"(define-values" +"(binding-table-symbols)" +"(lambda(table_33 scs_2 s_71 extra-shifts_1)" +"(begin" +"(let-values(((ht_33 bulk-bindings_1)" +"(if(hash? table_33)" +"(values table_33 null)" +"(values" +"(table-with-bulk-bindings-syms table_33)" +"(table-with-bulk-bindings-bulk-bindings table_33)))))" +"(set-union" +"(let-values(((ht_34) ht_33))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_34)))" +"((letrec-values(((for-loop_34)" +"(lambda(table_34 i_52)" +"(begin" +" 'for-loop" +"(if i_52" +"(let-values(((sym_8 at-sym_0)(hash-iterate-key+value ht_34 i_52)))" +"(let-values(((table_35)" +"(let-values(((table_36) table_34))" +"(if(let-values(((ht_35) at-sym_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_35)))" +"((letrec-values(((for-loop_35)" +"(lambda(result_28 i_53)" +"(begin" +" 'for-loop" +"(if i_53" +"(let-values(((an-scs_0)" +"(hash-iterate-key" +" ht_35" +" i_53)))" +"(let-values(((result_29)" +"(let-values()" +"(let-values(((result_30)" +"(let-values()" +"(let-values()" +"(subset?" +" an-scs_0" +" scs_2)))))" +"(values" +" result_30)))))" +"(if(if(not" +"((lambda x_27" +" result_29)" +" an-scs_0))" +"(not #f)" +" #f)" +"(for-loop_35" +" result_29" +"(hash-iterate-next" +" ht_35" +" i_53))" +" result_29)))" +" result_28)))))" +" for-loop_35)" +" #f" +"(hash-iterate-first ht_35))))" +"(let-values(((table_37) table_36))" +"(let-values(((table_38)" +"(let-values()" +"(let-values(((key_18 val_9)" +"(let-values()" +"(values" +"(let-values() sym_8)" +" #t))))" +"(hash-set table_37 key_18 val_9)))))" +"(values table_38)))" +" table_36))))" +"(if(not #f)(for-loop_34 table_35(hash-iterate-next ht_34 i_52)) table_35)))" +" table_34)))))" +" for-loop_34)" +" '#hasheq()" +"(hash-iterate-first ht_34))))" +"(let-values(((lst_34) bulk-bindings_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_34)))" +"((letrec-values(((for-loop_36)" +"(lambda(table_39 lst_35)" +"(begin" +" 'for-loop" +"(if(pair? lst_35)" +"(let-values(((bba_1)(unsafe-car lst_35))((rest_14)(unsafe-cdr lst_35)))" +"(let-values(((table_40)" +"(let-values(((table_41) table_39))" +"(if(subset?(bulk-binding-at-scopes bba_1) scs_2)" +"(let-values(((ht_36)" +"(bulk-binding-symbols" +"(bulk-binding-at-bulk bba_1)" +" s_71" +" extra-shifts_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_36)))" +"((letrec-values(((for-loop_37)" +"(lambda(table_42 i_5)" +"(begin" +" 'for-loop" +"(if i_5" +"(let-values(((sym_9)" +"(hash-iterate-key" +" ht_36" +" i_5)))" +"(let-values(((table_43)" +"(let-values(((table_44)" +" table_42))" +"(let-values(((table_45)" +"(let-values()" +"(let-values(((key_19" +" val_10)" +"(let-values()" +"(values" +"(let-values()" +" sym_9)" +" #t))))" +"(hash-set" +" table_44" +" key_19" +" val_10)))))" +"(values" +" table_45)))))" +"(if(not #f)" +"(for-loop_37" +" table_43" +"(hash-iterate-next" +" ht_36" +" i_5))" +" table_43)))" +" table_42)))))" +" for-loop_37)" +" table_41" +"(hash-iterate-first ht_36))))" +" table_41))))" +"(if(not #f)(for-loop_36 table_40 rest_14) table_40)))" +" table_39)))))" +" for-loop_36)" +" '#hasheq()" +" lst_34))))))))" +"(define-values" +"(binding-table-prune-to-reachable)" +"(lambda(bt_3 state_15)" +"(begin" +"(let-values(((or-part_94)(hash-ref(serialize-state-bindings-intern state_15) bt_3 #f)))" +"(if or-part_94" +" or-part_94" +"(let-values(((reachable-scopes_1)(serialize-state-reachable-scopes state_15)))" +"(let-values(((new-syms_2)" +"(let-values(((ht_37)(if(hash? bt_3) bt_3(table-with-bulk-bindings-syms/serialize bt_3))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_37)))" +"((letrec-values(((for-loop_38)" +"(lambda(table_46 i_54)" +"(begin" +" 'for-loop" +"(if i_54" +"(let-values(((sym_10 bindings-for-sym_0)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_37" +" i_54)))" +"(let-values(((table_47)" +"(let-values(((new-bindings-for-sym_0)" +"(let-values(((ht_38)" +" bindings-for-sym_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash" +" ht_38)))" +"((letrec-values(((for-loop_39)" +"(lambda(table_48" +" i_55)" +"(begin" +" 'for-loop" +"(if i_55" +"(let-values(((scopes_5" +" binding_1)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_38" +" i_55)))" +"(let-values(((table_49)" +"(let-values(((table_50)" +" table_48))" +"(if(subset?" +" scopes_5" +" reachable-scopes_1)" +"(let-values(((table_51)" +" table_50))" +"(let-values(((table_52)" +"(let-values()" +"(let-values(((key_20" +" val_11)" +"(let-values()" +"(values" +"(intern-scopes" +" scopes_5" +" state_15)" +" binding_1))))" +"(hash-set" +" table_51" +" key_20" +" val_11)))))" +"(values" +" table_52)))" +" table_50))))" +"(if(not" +" #f)" +"(for-loop_39" +" table_49" +"(unsafe-immutable-hash-iterate-next" +" ht_38" +" i_55))" +" table_49)))" +" table_48)))))" +" for-loop_39)" +" '#hash()" +"(unsafe-immutable-hash-iterate-first" +" ht_38))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_40)" +"(lambda(table_53)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_54)" +"(let-values(((table_55)" +" table_53))" +"(if(positive?" +"(hash-count" +" new-bindings-for-sym_0))" +"(let-values(((table_56)" +" table_55))" +"(let-values(((table_57)" +"(let-values()" +"(let-values(((key_21" +" val_12)" +"(let-values()" +"(values" +" sym_10" +" new-bindings-for-sym_0))))" +"(hash-set" +" table_56" +" key_21" +" val_12)))))" +"(values" +" table_57)))" +" table_55))))" +" table_54))))))" +" for-loop_40)" +" table_46)))))" +"(if(not #f)" +"(for-loop_38" +" table_47" +"(unsafe-immutable-hash-iterate-next ht_37 i_54))" +" table_47)))" +" table_46)))))" +" for-loop_38)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_37))))))" +"(let-values(((new-bulk-bindings_0)" +"(if(hash? bt_3)" +" null" +"(reverse$1" +"(let-values(((lst_36)(table-with-bulk-bindings-bulk-bindings bt_3)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_36)))" +"((letrec-values(((for-loop_41)" +"(lambda(fold-var_21 lst_37)" +"(begin" +" 'for-loop" +"(if(pair? lst_37)" +"(let-values(((bba_2)(unsafe-car lst_37))" +"((rest_15)(unsafe-cdr lst_37)))" +"(let-values(((fold-var_22)" +"(let-values(((fold-var_23) fold-var_21))" +"(if(subset?" +"(bulk-binding-at-scopes bba_2)" +" reachable-scopes_1)" +"(let-values(((fold-var_24) fold-var_23))" +"(let-values(((fold-var_25)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((the-struct_2)" +" bba_2))" +"(if(bulk-binding-at?" +" the-struct_2)" +"(let-values(((scopes55_0)" +"(intern-scopes" +"(bulk-binding-at-scopes" +" bba_2)" +" state_15)))" +"(bulk-binding-at2.1" +" scopes55_0" +"(bulk-binding-at-bulk" +" the-struct_2)))" +"(raise-argument-error" +" 'struct-copy" +" \"bulk-binding-at?\"" +" the-struct_2))))" +" fold-var_24))))" +"(values fold-var_25)))" +" fold-var_23))))" +"(if(not #f)" +"(for-loop_41 fold-var_22 rest_15)" +" fold-var_22)))" +" fold-var_21)))))" +" for-loop_41)" +" null" +" lst_36)))))))" +"(let-values(((new-bt_0)" +"(if(pair? new-bulk-bindings_0)" +"(table-with-bulk-bindings1.1 new-syms_2 new-syms_2 new-bulk-bindings_0)" +" new-syms_2)))" +"(begin(hash-set!(serialize-state-bulk-bindings-intern state_15) bt_3 new-bt_0) new-bt_0))))))))))" +"(define-values" +"(binding-table-register-reachable)" +"(lambda(bt_4 get-reachable-scopes_0 reach_2 register-trigger_0)" +"(begin" +"(begin" +"(let-values(((ht_39)(if(hash? bt_4) bt_4(table-with-bulk-bindings-syms/serialize bt_4))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_39)))" +"((letrec-values(((for-loop_42)" +"(lambda(i_56)" +"(begin" +" 'for-loop" +"(if i_56" +"(let-values(((sym_11 bindings-for-sym_1)" +"(unsafe-immutable-hash-iterate-key+value ht_39 i_56)))" +"(let-values((()" +"(let-values(((ht_40) bindings-for-sym_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_40)))" +"((letrec-values(((for-loop_43)" +"(lambda(i_57)" +"(begin" +" 'for-loop" +"(if i_57" +"(let-values(((scopes_6 binding_2)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_40" +" i_57)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((v_80)" +"(if(binding-reach-scopes?" +" binding_2)" +"((binding-reach-scopes-ref" +" binding_2)" +" binding_2)" +" #f)))" +"(scopes-register-reachable" +" scopes_6" +" v_80" +" get-reachable-scopes_0" +" reach_2" +" register-trigger_0)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_43" +"(unsafe-immutable-hash-iterate-next" +" ht_40" +" i_57))" +"(values))))" +"(values))))))" +" for-loop_43)" +"(unsafe-immutable-hash-iterate-first ht_40))))))" +"(if(not #f)" +"(for-loop_42(unsafe-immutable-hash-iterate-next ht_39 i_56))" +"(values))))" +"(values))))))" +" for-loop_42)" +"(unsafe-immutable-hash-iterate-first ht_39))))" +"(void)" +"(if(table-with-bulk-bindings? bt_4)" +"(let-values()" +"(begin" +"(let-values(((lst_38)(table-with-bulk-bindings-bulk-bindings bt_4)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_38)))" +"((letrec-values(((for-loop_44)" +"(lambda(lst_39)" +"(begin" +" 'for-loop" +"(if(pair? lst_39)" +"(let-values(((bba_3)(unsafe-car lst_39))((rest_16)(unsafe-cdr lst_39)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(scopes-register-reachable" +"(bulk-binding-at-scopes bba_3)" +" #f" +" get-reachable-scopes_0" +" reach_2" +" register-trigger_0))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_44 rest_16)(values))))" +"(values))))))" +" for-loop_44)" +" lst_38)))" +"(void)))" +"(void))))))" +"(define-values" +"(scopes-register-reachable)" +"(lambda(scopes_7 v_81 get-reachable-scopes_1 reach_3 register-trigger_1)" +"(begin" +"(let-values(((reachable-scopes_2)(get-reachable-scopes_1)))" +"(if(subset? scopes_7 reachable-scopes_2)" +"(let-values()(reach_3 v_81))" +"(let-values()" +"(let-values(((pending-scopes_0)" +"(let-values(((ht_41) scopes_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_41)))" +"((letrec-values(((for-loop_45)" +"(lambda(table_58 i_58)" +"(begin" +" 'for-loop" +"(if i_58" +"(let-values(((sc_0)" +"(unsafe-immutable-hash-iterate-key ht_41 i_58)))" +"(let-values(((table_59)" +"(let-values(((table_60) table_58))" +"(if(let-values(((or-part_95)" +"(set-member?" +" reachable-scopes_2" +" sc_0)))" +"(if or-part_95" +" or-part_95" +"(implicitly-reachable? sc_0)))" +" table_60" +"(let-values(((table_61) table_60))" +"(let-values(((table_62)" +"(let-values()" +"(let-values(((key_22" +" val_13)" +"(let-values()" +"(values" +"(let-values()" +" sc_0)" +" #t))))" +"(hash-set" +" table_61" +" key_22" +" val_13)))))" +"(values table_62)))))))" +"(if(not #f)" +"(for-loop_45" +" table_59" +"(unsafe-immutable-hash-iterate-next ht_41 i_58))" +" table_59)))" +" table_58)))))" +" for-loop_45)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_41))))))" +"(let-values(((check-trigger_0)" +"(lambda(reach_4)" +"(begin" +" 'check-trigger" +"(if(zero?(hash-count pending-scopes_0))" +"(let-values()" +"(begin" +"(reach_4 v_81)" +"(let-values(((ht_42) scopes_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_42)))" +"((letrec-values(((for-loop_46)" +"(lambda(i_59)" +"(begin" +" 'for-loop" +"(if i_59" +"(let-values(((sc_1)" +"(unsafe-immutable-hash-iterate-key" +" ht_42" +" i_59)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(implicitly-reachable?" +" sc_1)" +"(let-values()" +"(reach_4" +" sc_1))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_46" +"(unsafe-immutable-hash-iterate-next" +" ht_42" +" i_59))" +"(values))))" +"(values))))))" +" for-loop_46)" +"(unsafe-immutable-hash-iterate-first ht_42))))" +"(void)))" +"(void))))))" +"(begin" +"(let-values(((ht_43) pending-scopes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_43)))" +"((letrec-values(((for-loop_47)" +"(lambda(i_60)" +"(begin" +" 'for-loop" +"(if i_60" +"(let-values(((sc_2)(unsafe-immutable-hash-iterate-key ht_43 i_60)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(register-trigger_1" +" sc_2" +"(lambda(reach_5)" +"(begin" +"(set! pending-scopes_0" +"(hash-remove" +" pending-scopes_0" +" sc_2))" +"(check-trigger_0 reach_5)))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_47(unsafe-immutable-hash-iterate-next ht_43 i_60))" +"(values))))" +"(values))))))" +" for-loop_47)" +"(unsafe-immutable-hash-iterate-first ht_43))))" +"(void)" +"(check-trigger_0 reach_3))))))))))" +"(define-values" +"(syntax-property$1)" +"(let-values()" +"(let-values()" +"(case-lambda" +"((s_72 key_23)" +"(begin" +" 'syntax-property" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_72)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_72)))" +"(values))))" +"(let-values(((v_70)(hash-ref(syntax-props s_72) key_23 #f)))(plain-property-value v_70)))))" +"((s_73 key_24 val_14)" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_73)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_73)))" +"(values))))" +"(let-values(((pval_0)(if(eq? key_24 'paren-shape)(preserved-property-value1.1 val_14) val_14)))" +"(let-values(((the-struct_3) s_73))" +"(if(syntax?$1 the-struct_3)" +"(let-values(((props2_0)(hash-set(syntax-props s_73) key_24 pval_0)))" +"(syntax1.1" +"(syntax-content the-struct_3)" +"(syntax-scopes the-struct_3)" +"(syntax-shifted-multi-scopes the-struct_3)" +"(syntax-scope-propagations+tamper the-struct_3)" +"(syntax-mpi-shifts the-struct_3)" +"(syntax-srcloc the-struct_3)" +" props2_0" +"(syntax-inspector the-struct_3)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_3))))))" +"((s_74 key_25 val_15 preserved?_0)" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_74)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_74)))" +"(values))))" +"(let-values((()" +"(begin" +"(if preserved?_0" +"(let-values()" +"(if(if(symbol? key_25)(symbol-interned? key_25) #f)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-property" +" \"key for a perserved property must be an interned symbol\"" +" \"given key\"" +" key_25" +" \"given value\"" +" val_15))))" +"(void))" +"(values))))" +"(let-values(((pval_1)(if preserved?_0(preserved-property-value1.1 val_15) val_15)))" +"(let-values(((the-struct_4) s_74))" +"(if(syntax?$1 the-struct_4)" +"(let-values(((props3_0)(hash-set(syntax-props s_74) key_25 pval_1)))" +"(syntax1.1" +"(syntax-content the-struct_4)" +"(syntax-scopes the-struct_4)" +"(syntax-shifted-multi-scopes the-struct_4)" +"(syntax-scope-propagations+tamper the-struct_4)" +"(syntax-mpi-shifts the-struct_4)" +"(syntax-srcloc the-struct_4)" +" props3_0" +"(syntax-inspector the-struct_4)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_4)))))))))))" +"(define-values" +"(1/syntax-property-preserved?)" +"(lambda(s_75 key_26)" +"(begin" +" 'syntax-property-preserved?" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_75)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property-preserved? \"syntax?\" s_75)))" +"(if(if(symbol? key_26)(symbol-interned? key_26) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-property-preserved? \"(and/c symbol? symbol-interned?)\" key_26)))" +"(preserved-property-value?(hash-ref(syntax-props s_75) key_26 #f))))))))" +"(define-values" +"(1/syntax-property-symbol-keys)" +"(lambda(s_10)" +"(begin" +" 'syntax-property-symbol-keys" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_10)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property-symbol-keys \"syntax\" s_10)))" +"(reverse$1" +"(let-values(((ht_44)(syntax-props s_10)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_44)))" +"((letrec-values(((for-loop_48)" +"(lambda(fold-var_26 i_61)" +"(begin" +" 'for-loop" +"(if i_61" +"(let-values(((k_16 v_32)" +"(unsafe-immutable-hash-iterate-key+value ht_44 i_61)))" +"(let-values(((fold-var_27)" +"(let-values(((fold-var_28) fold-var_26))" +"(if(if(symbol? k_16)(symbol-interned? k_16) #f)" +"(let-values(((fold-var_29) fold-var_28))" +"(let-values(((fold-var_30)" +"(let-values()" +"(cons" +"(let-values() k_16)" +" fold-var_29))))" +"(values fold-var_30)))" +" fold-var_28))))" +"(if(not #f)" +"(for-loop_48 fold-var_27(unsafe-immutable-hash-iterate-next ht_44 i_61))" +" fold-var_27)))" +" fold-var_26)))))" +" for-loop_48)" +" null" +"(unsafe-immutable-hash-iterate-first ht_44)))))))))))" +"(define-values" +"(1/syntax-property-remove)" +"(lambda(s_76 key_27)" +"(begin" +" 'syntax-property-remove" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_76) (void) (let-values () (raise-argument-error 'syntax-property-remove \"syntax?\" s_76)))" +"(if(hash-ref(syntax-props s_76) key_27 #f)" +"(let-values(((the-struct_5) s_76))" +"(if(syntax?$1 the-struct_5)" +"(let-values(((props7_0)(hash-remove(syntax-props s_76) key_27)))" +"(syntax1.1" +"(syntax-content the-struct_5)" +"(syntax-scopes the-struct_5)" +"(syntax-shifted-multi-scopes the-struct_5)" +"(syntax-scope-propagations+tamper the-struct_5)" +"(syntax-mpi-shifts the-struct_5)" +"(syntax-srcloc the-struct_5)" +" props7_0" +"(syntax-inspector the-struct_5)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_5)))" +" s_76)))))))" +"(define-values" +"(taint-content)" +"(lambda(d_2)" +"(begin" +"(let-values(((s_74) d_2)" +"((f_27)(lambda(tail?_16 x_28)(begin 'f x_28)))" +"((s->_1)" +"(lambda(sub-s_0)" +"(begin" +" 's->" +"(if(tamper-tainted?(syntax-tamper sub-s_0))" +"(let-values() sub-s_0)" +"(let-values()" +"(let-values(((stx_0) sub-s_0))" +"(let-values(((the-struct_6) stx_0))" +"(if(syntax?$1 the-struct_6)" +"(let-values(((scope-propagations+tamper5_0)" +"(let-values(((t_18)" +"(tamper-tainted-for-content(syntax-content sub-s_0)))" +"((p_20)(syntax-scope-propagations+tamper stx_0)))" +"(if(tamper? p_20)" +" t_18" +"((propagation-set-tamper-ref p_20) p_20 t_18)))))" +"(syntax1.1" +"(syntax-content the-struct_6)" +"(syntax-scopes the-struct_6)" +"(syntax-shifted-multi-scopes the-struct_6)" +" scope-propagations+tamper5_0" +"(syntax-mpi-shifts the-struct_6)" +"(syntax-srcloc the-struct_6)" +"(syntax-props the-struct_6)" +"(syntax-inspector the-struct_6)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_6)))))))))" +"((seen_7) #f))" +"(let-values(((s_77) s_74)" +"((f_28) f_27)" +"((gf_3)" +"(lambda(tail?_17 v_32)" +"(begin" +" 'gf" +"(if(syntax?$1 v_32)(let-values()(s->_1 v_32))(let-values()(f_27 tail?_17 v_32))))))" +"((seen_8) seen_7))" +"((letrec-values(((loop_70)" +"(lambda(tail?_18 s_78 prev-depth_3)" +"(begin" +" 'loop" +"(let-values(((depth_3)(fx+ 1 prev-depth_3)))" +"(if(if seen_8(fx> depth_3 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_18" +" s_78" +"(lambda(tail?_19 s_79)(gf_3 tail?_19 s_79))" +" seen_8))" +"(if(null? s_78)" +"(let-values()(f_28 tail?_18 s_78))" +"(if(pair? s_78)" +"(let-values()" +"(f_28" +" tail?_18" +"(cons(loop_70 #f(car s_78) depth_3)(loop_70 #t(cdr s_78) depth_3))))" +"(if(symbol? s_78)" +"(let-values()(f_28 #f s_78))" +"(if(boolean? s_78)" +"(let-values()(f_28 #f s_78))" +"(if(number? s_78)" +"(let-values()(f_28 #f s_78))" +"(if(let-values(((or-part_79)(vector? s_78)))" +"(if or-part_79" +" or-part_79" +"(let-values(((or-part_80)(box? s_78)))" +"(if or-part_80" +" or-part_80" +"(let-values(((or-part_81)(prefab-struct-key s_78)))" +"(if or-part_81 or-part_81(hash? s_78)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_18" +" s_78" +"(lambda(tail?_0 s_40)(gf_3 tail?_0 s_40))" +" seen_8))" +"(let-values()(gf_3 #f s_78))))))))))))))" +" loop_70)" +" #f" +" s_77" +" 0))))))" +"(define-values(syntax-tainted?$1)(lambda(s_41)(begin 'syntax-tainted?(tamper-tainted?(syntax-tamper s_41)))))" +"(define-values(syntax-clean?)(lambda(s_80)(begin(tamper-clean?(syntax-tamper s_80)))))" +"(define-values" +"(syntax-arm$1)" +"(lambda(s_6 insp_0)" +"(begin" +" 'syntax-arm" +"(let-values(((t_19)(syntax-tamper s_6)))" +"(if(tamper-tainted? t_19)" +"(let-values() s_6)" +"(if(if t_19" +"(let-values(((or-part_96)(set-member? t_19 insp_0)))" +"(if or-part_96" +" or-part_96" +"(let-values(((ht_45) t_19))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_45)))" +"((letrec-values(((for-loop_49)" +"(lambda(result_31 i_62)" +"(begin" +" 'for-loop" +"(if i_62" +"(let-values(((already-insp_0)" +"(unsafe-immutable-hash-iterate-key ht_45 i_62)))" +"(let-values(((result_32)" +"(let-values()" +"(let-values(((result_33)" +"(let-values()" +"(let-values()" +"(inspector-superior-or-same?" +" already-insp_0" +" insp_0)))))" +"(values result_33)))))" +"(if(if(not((lambda x_29 result_32) already-insp_0))(not #f) #f)" +"(for-loop_49" +" result_32" +"(unsafe-immutable-hash-iterate-next ht_45 i_62))" +" result_32)))" +" result_31)))))" +" for-loop_49)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_45))))))" +" #f)" +"(let-values() s_6)" +"(let-values()" +"(let-values(((stx_1) s_6))" +"(let-values(((the-struct_7) stx_1))" +"(if(syntax?$1 the-struct_7)" +"(let-values(((scope-propagations+tamper6_0)" +"(let-values(((t_20)(set-add(if t_19(remove-inferior t_19 insp_0)(seteq)) insp_0))" +"((p_21)(syntax-scope-propagations+tamper stx_1)))" +"(if(tamper? p_21) t_20((propagation-set-tamper-ref p_21) p_21 t_20)))))" +"(syntax1.1" +"(syntax-content the-struct_7)" +"(syntax-scopes the-struct_7)" +"(syntax-shifted-multi-scopes the-struct_7)" +" scope-propagations+tamper6_0" +"(syntax-mpi-shifts the-struct_7)" +"(syntax-srcloc the-struct_7)" +"(syntax-props the-struct_7)" +"(syntax-inspector the-struct_7)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_7)))))))))))" +"(define-values" +"(remove-inferior)" +"(lambda(t_21 insp_1)" +"(begin" +"(let-values(((ht_46) t_21))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_46)))" +"((letrec-values(((for-loop_50)" +"(lambda(table_63 i_63)" +"(begin" +" 'for-loop" +"(if i_63" +"(let-values(((already-insp_1)(unsafe-immutable-hash-iterate-key ht_46 i_63)))" +"(let-values(((table_64)" +"(let-values(((table_65) table_63))" +"(if(inspector-superior-or-same? insp_1 already-insp_1)" +" table_65" +"(let-values(((table_66) table_65))" +"(let-values(((table_67)" +"(let-values()" +"(let-values(((key_28 val_16)" +"(let-values()" +"(values" +"(let-values() already-insp_1)" +" #t))))" +"(hash-set table_66 key_28 val_16)))))" +"(values table_67)))))))" +"(if(not #f)" +"(for-loop_50 table_64(unsafe-immutable-hash-iterate-next ht_46 i_63))" +" table_64)))" +" table_63)))))" +" for-loop_50)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_46)))))))" +"(define-values" +"(syntax-disarm$1)" +"(let-values(((syntax-disarm3_0)" +"(lambda(s2_5 insp1_0)" +"(begin" +" 'syntax-disarm3" +"(let-values(((s_81) s2_5))" +"(let-values(((insp_2) insp1_0))" +"(let-values()" +"(let-values(((t_22)(syntax-tamper s_81)))" +"(if(not(tamper-armed? t_22))" +"(let-values() s_81)" +"(if(not insp_2)" +"(let-values()" +"(let-values(((stx_2) s_81))" +"(let-values(((the-struct_8) stx_2))" +"(if(syntax?$1 the-struct_8)" +"(let-values(((scope-propagations+tamper7_0)" +"(let-values(((t_23) #f)" +"((p_22)(syntax-scope-propagations+tamper stx_2)))" +"(if(tamper? p_22)" +" t_23" +"((propagation-set-tamper-ref p_22) p_22 t_23)))))" +"(syntax1.1" +"(syntax-content the-struct_8)" +"(syntax-scopes the-struct_8)" +"(syntax-shifted-multi-scopes the-struct_8)" +" scope-propagations+tamper7_0" +"(syntax-mpi-shifts the-struct_8)" +"(syntax-srcloc the-struct_8)" +"(syntax-props the-struct_8)" +"(syntax-inspector the-struct_8)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_8)))))" +"(let-values()" +"(let-values(((new-t_1)(remove-inferior t_22 insp_2)))" +"(let-values(((stx_3) s_81))" +"(let-values(((the-struct_9) stx_3))" +"(if(syntax?$1 the-struct_9)" +"(let-values(((scope-propagations+tamper8_0)" +"(let-values(((t_24)(if(not(set-empty? new-t_1)) new-t_1 #f))" +"((p_23)(syntax-scope-propagations+tamper stx_3)))" +"(if(tamper? p_23)" +" t_24" +"((propagation-set-tamper-ref p_23) p_23 t_24)))))" +"(syntax1.1" +"(syntax-content the-struct_9)" +"(syntax-scopes the-struct_9)" +"(syntax-shifted-multi-scopes the-struct_9)" +" scope-propagations+tamper8_0" +"(syntax-mpi-shifts the-struct_9)" +"(syntax-srcloc the-struct_9)" +"(syntax-props the-struct_9)" +"(syntax-inspector the-struct_9)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_9))))))))))))))))" +"(case-lambda" +"((s_82)(begin 'syntax-disarm(syntax-disarm3_0 s_82 #f)))" +"((s_83 insp1_1)(syntax-disarm3_0 s_83 insp1_1)))))" +"(define-values" +"(syntax-rearm$1)" +"(lambda(s_17 from-s_0)" +"(begin" +" 'syntax-rearm" +"(let-values(((t_25)(syntax-tamper s_17)))" +"(if(tamper-tainted? t_25)" +"(let-values() s_17)" +"(let-values()" +"(let-values(((from-t_0)(syntax-tamper from-s_0)))" +"(if(tamper-clean? from-t_0)" +"(let-values() s_17)" +"(if(tamper-tainted? from-t_0)" +"(let-values()" +"(let-values(((stx_4) s_17))" +"(let-values(((the-struct_10) stx_4))" +"(if(syntax?$1 the-struct_10)" +"(let-values(((scope-propagations+tamper9_0)" +"(let-values(((t_26)(tamper-tainted-for-content(syntax-content s_17)))" +"((p_24)(syntax-scope-propagations+tamper stx_4)))" +"(if(tamper? p_24) t_26((propagation-set-tamper-ref p_24) p_24 t_26)))))" +"(syntax1.1" +"(syntax-content the-struct_10)" +"(syntax-scopes the-struct_10)" +"(syntax-shifted-multi-scopes the-struct_10)" +" scope-propagations+tamper9_0" +"(syntax-mpi-shifts the-struct_10)" +"(syntax-srcloc the-struct_10)" +"(syntax-props the-struct_10)" +"(syntax-inspector the-struct_10)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_10)))))" +"(if(tamper-clean? t_25)" +"(let-values()" +"(let-values(((stx_5) s_17))" +"(let-values(((the-struct_11) stx_5))" +"(if(syntax?$1 the-struct_11)" +"(let-values(((scope-propagations+tamper10_0)" +"(let-values(((t_27) from-t_0)" +"((p_25)(syntax-scope-propagations+tamper stx_5)))" +"(if(tamper? p_25) t_27((propagation-set-tamper-ref p_25) p_25 t_27)))))" +"(syntax1.1" +"(syntax-content the-struct_11)" +"(syntax-scopes the-struct_11)" +"(syntax-shifted-multi-scopes the-struct_11)" +" scope-propagations+tamper10_0" +"(syntax-mpi-shifts the-struct_11)" +"(syntax-srcloc the-struct_11)" +"(syntax-props the-struct_11)" +"(syntax-inspector the-struct_11)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_11)))))" +"(let-values()" +"(let-values(((stx_6) s_17))" +"(let-values(((the-struct_12) stx_6))" +"(if(syntax?$1 the-struct_12)" +"(let-values(((scope-propagations+tamper11_0)" +"(let-values(((t_28)" +"(let-values(((ht_16) from-t_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_16)))" +"((letrec-values(((for-loop_2)" +"(lambda(t_29 i_21)" +"(begin" +" 'for-loop" +"(if i_21" +"(let-values(((from-i_0)" +"(unsafe-immutable-hash-iterate-key" +" ht_16" +" i_21)))" +"(let-values(((t_30)" +"(let-values(((t_31)" +" t_29))" +"(let-values(((t_32)" +"(let-values()" +"(if(set-member?" +" t_31" +" from-i_0)" +"(let-values()" +" t_31)" +"(if(any-superior?" +" t_31" +" from-i_0)" +"(let-values()" +" t_31)" +"(let-values()" +"(set-add" +"(remove-inferior" +" t_31" +" from-i_0)" +" from-i_0)))))))" +"(values" +" t_32)))))" +"(if(not #f)" +"(for-loop_2" +" t_30" +"(unsafe-immutable-hash-iterate-next" +" ht_16" +" i_21))" +" t_30)))" +" t_29)))))" +" for-loop_2)" +" t_25" +"(unsafe-immutable-hash-iterate-first ht_16)))))" +"((p_19)(syntax-scope-propagations+tamper stx_6)))" +"(if(tamper? p_19) t_28((propagation-set-tamper-ref p_19) p_19 t_28)))))" +"(syntax1.1" +"(syntax-content the-struct_12)" +"(syntax-scopes the-struct_12)" +"(syntax-shifted-multi-scopes the-struct_12)" +" scope-propagations+tamper11_0" +"(syntax-mpi-shifts the-struct_12)" +"(syntax-srcloc the-struct_12)" +"(syntax-props the-struct_12)" +"(syntax-inspector the-struct_12)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_12)))))))))))))))" +"(define-values" +"(syntax-taint$1)" +"(lambda(s_84)" +"(begin" +" 'syntax-taint" +"(if(tamper-tainted?(syntax-tamper s_84))" +" s_84" +"(let-values(((stx_7) s_84))" +"(let-values(((the-struct_13) stx_7))" +"(if(syntax?$1 the-struct_13)" +"(let-values(((scope-propagations+tamper12_0)" +"(let-values(((t_33)(tamper-tainted-for-content(syntax-content s_84)))" +"((p_26)(syntax-scope-propagations+tamper stx_7)))" +"(if(tamper? p_26) t_33((propagation-set-tamper-ref p_26) p_26 t_33)))))" +"(syntax1.1" +"(syntax-content the-struct_13)" +"(syntax-scopes the-struct_13)" +"(syntax-shifted-multi-scopes the-struct_13)" +" scope-propagations+tamper12_0" +"(syntax-mpi-shifts the-struct_13)" +"(syntax-srcloc the-struct_13)" +"(syntax-props the-struct_13)" +"(syntax-inspector the-struct_13)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_13))))))))" +"(define-values" +"(any-superior?)" +"(lambda(t_5 from-i_1)" +"(begin" +"(let-values(((ht_47) t_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_47)))" +"((letrec-values(((for-loop_51)" +"(lambda(result_34 i_64)" +"(begin" +" 'for-loop" +"(if i_64" +"(let-values(((i_65)(unsafe-immutable-hash-iterate-key ht_47 i_64)))" +"(let-values(((result_35)" +"(let-values()" +"(let-values(((result_36)" +"(let-values()" +"(let-values()" +"(inspector-superior-or-same? i_65 from-i_1)))))" +"(values result_36)))))" +"(if(if(not((lambda x_30 result_35) i_65))(not #f) #f)" +"(for-loop_51 result_35(unsafe-immutable-hash-iterate-next ht_47 i_64))" +" result_35)))" +" result_34)))))" +" for-loop_51)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_47)))))))" +"(define-values" +"(inspector-superior-or-same?)" +"(lambda(sup-i_0 i_66)" +"(begin" +"(let-values(((or-part_97)(eq? sup-i_0 i_66)))(if or-part_97 or-part_97(inspector-superior? sup-i_0 i_66))))))" +"(define-values" +"(struct:fallback fallback1.1 fallback? fallback-search-list)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()(make-struct-type 'fallback #f 1 0 #f null 'prefab #f '(0) #f 'fallback)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'search-list))))" +"(define-values" +"(fallback-first)" +"(lambda(smss_0)(begin(if(fallback? smss_0)(car(fallback-search-list smss_0)) smss_0))))" +"(define-values" +"(fallback-rest)" +"(lambda(smss_1)" +"(begin" +"(let-values(((l_9)(cdr(fallback-search-list smss_1))))(if(null?(cdr l_9))(car l_9)(fallback1.1 l_9))))))" +"(define-values" +"(fallback-push)" +"(lambda(smss_2 smss/maybe-fallback_0)" +"(begin" +"(fallback1.1" +"(cons" +" smss_2" +"(if(fallback? smss/maybe-fallback_0)" +"(fallback-search-list smss/maybe-fallback_0)" +"(list smss/maybe-fallback_0)))))))" +"(define-values" +"(fallback-update-first)" +"(lambda(smss_3 f_4)" +"(begin" +"(if(fallback? smss_3)" +"(let-values(((l_45)(fallback-search-list smss_3)))(fallback1.1(cons(f_4(car l_45))(cdr l_45))))" +"(f_4 smss_3)))))" +"(define-values" +"(fallback-map)" +"(lambda(smss_4 f_29)" +"(begin" +"(if(fallback? smss_4)" +"(fallback1.1" +"(reverse$1" +"(let-values(((lst_40)(fallback-search-list smss_4)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_40)))" +"((letrec-values(((for-loop_52)" +"(lambda(fold-var_31 lst_41)" +"(begin" +" 'for-loop" +"(if(pair? lst_41)" +"(let-values(((smss_5)(unsafe-car lst_41))((rest_17)(unsafe-cdr lst_41)))" +"(let-values(((fold-var_32)" +"(let-values(((fold-var_33) fold-var_31))" +"(let-values(((fold-var_34)" +"(let-values()" +"(cons" +"(let-values()(f_29 smss_5))" +" fold-var_33))))" +"(values fold-var_34)))))" +"(if(not #f)(for-loop_52 fold-var_32 rest_17) fold-var_32)))" +" fold-var_31)))))" +" for-loop_52)" +" null" +" lst_40)))))" +"(f_29 smss_4)))))" +"(define-values" +"(fallback->list)" +"(lambda(smss_6)(begin(if(fallback? smss_6)(fallback-search-list smss_6)(list smss_6)))))" +"(define-values(cache)(box(make-weak-box #f)))" +"(define-values" +"(clear-resolve-cache!)" +"(case-lambda" +"((sym_12)" +"(begin" +"(let-values(((c_13)(weak-box-value(unbox* cache))))" +"(begin(if c_13(let-values()(hash-remove! c_13 sym_12))(void))(set-box*! shifted-cache #f)))))" +"(()" +"(let-values(((c_14)(weak-box-value(unbox* cache))))" +"(begin(if c_14(let-values()(hash-clear! c_14))(void))(set-box*! shifted-cache #f))))))" +"(define-values" +"(struct:entry entry1.1 entry? entry-scs entry-smss entry-phase entry-binding)" +"(let-values(((struct:_21 make-_21 ?_21 -ref_21 -set!_21)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'entry" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'entry)))))" +"(values" +" struct:_21" +" make-_21" +" ?_21" +"(make-struct-field-accessor -ref_21 0 'scs)" +"(make-struct-field-accessor -ref_21 1 'smss)" +"(make-struct-field-accessor -ref_21 2 'phase)" +"(make-struct-field-accessor -ref_21 3 'binding))))" +"(define-values" +"(resolve-cache-get)" +"(lambda(sym_13 phase_4 scs_3 smss_7)" +"(begin" +"(let-values(((c_15)(weak-box-value(unbox* cache))))" +"(if c_15" +"(let-values(((v_82)(hash-ref c_15 sym_13 #f)))" +"(if v_82" +"(if(eqv? phase_4(entry-phase v_82))" +"(if(set=? scs_3(entry-scs v_82))(if(set=? smss_7(entry-smss v_82))(entry-binding v_82) #f) #f)" +" #f)" +" #f))" +" #f)))))" +"(define-values" +"(resolve-cache-set!)" +"(lambda(sym_14 phase_5 scs_4 smss_8 b_39)" +"(begin" +"(let-values(((wb_0)(unbox* cache)))" +"(let-values(((c_16)(weak-box-value wb_0)))" +"(if(not c_16)" +"(let-values()" +"(begin" +"(box-cas! cache wb_0(make-weak-box(make-hasheq)))" +"(resolve-cache-set! sym_14 phase_5 scs_4 smss_8 b_39)))" +"(let-values()(hash-set! c_16 sym_14(entry1.1 scs_4 smss_8 phase_5 b_39)))))))))" +"(define-values(SHIFTED-CACHE-SIZE) 16)" +"(define-values(shifted-cache)(box #f))" +"(define-values(shifted-cache-pos) 0)" +"(define-values" +"(struct:shifted-entry shifted-entry2.1 shifted-entry? shifted-entry-s shifted-entry-phase shifted-entry-binding)" +"(let-values(((struct:_22 make-_22 ?_22 -ref_22 -set!_22)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'shifted-entry" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'shifted-entry)))))" +"(values" +" struct:_22" +" make-_22" +" ?_22" +"(make-struct-field-accessor -ref_22 0 's)" +"(make-struct-field-accessor -ref_22 1 'phase)" +"(make-struct-field-accessor -ref_22 2 'binding))))" +"(define-values" +"(shifted-cache-vector)" +"(lambda()" +"(begin" +"(let-values(((wb_1)(unbox* shifted-cache)))" +"(let-values(((c1_21)(if wb_1(weak-box-value wb_1) #f)))" +"(if c1_21" +"((lambda(vec_16) vec_16) c1_21)" +"(let-values()" +"(let-values(((vec_17)(make-vector SHIFTED-CACHE-SIZE #f)))" +"(begin(set-box*! shifted-cache(make-weak-box vec_17)) vec_17)))))))))" +"(define-values" +"(resolve+shift-cache-get)" +"(lambda(s_23 phase_6)" +"(begin" +"(let-values(((vec_18)(shifted-cache-vector)))" +"(let-values(((vec_13 len_9)" +"(let-values(((vec_19) vec_18))" +"(begin(check-vector vec_19)(values vec_19(unsafe-vector-length vec_19))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_53)" +"(lambda(result_23 pos_7)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_7 len_9)" +"(let-values(((e_14)(unsafe-vector-ref vec_13 pos_7)))" +"(let-values(((result_37)" +"(let-values()" +"(let-values(((result_38)" +"(let-values()" +"(let-values()" +"(if e_14" +"(if(eq? s_23(shifted-entry-s e_14))" +"(if(eqv?" +" phase_6" +"(shifted-entry-phase e_14))" +"(shifted-entry-binding e_14)" +" #f)" +" #f)" +" #f)))))" +"(values result_38)))))" +"(if(if(not((lambda x_31 result_37) e_14))(not #f) #f)" +"(for-loop_53 result_37(unsafe-fx+ 1 pos_7))" +" result_37)))" +" result_23)))))" +" for-loop_53)" +" #f" +" 0)))))))" +"(define-values" +"(resolve+shift-cache-set!)" +"(lambda(s_85 phase_7 b_19)" +"(begin" +"(let-values(((vec_20)(shifted-cache-vector)))" +"(let-values(((p_27) shifted-cache-pos))" +"(begin" +"(vector*-set! vec_20 p_27(shifted-entry2.1 s_85 phase_7 b_19))" +"(set! shifted-cache-pos(fxand(fx+ 1 p_27)(fx- SHIFTED-CACHE-SIZE 1)))))))))" +"(define-values(NUM-CACHE-SLOTS) 8)" +"(define-values(cached-sets)(make-weak-box(make-vector NUM-CACHE-SLOTS #f)))" +"(define-values(cached-sets-pos) 0)" +"(define-values(cached-hashes)(make-weak-box(make-vector NUM-CACHE-SLOTS #f)))" +"(define-values(cached-hashes-pos) 0)" +"(define-values" +"(cache-or-reuse-set)" +"(lambda(s_45)" +"(begin" +"(let-values(((vec_21)" +"(let-values(((or-part_98)(weak-box-value cached-sets)))" +"(if or-part_98" +" or-part_98" +"(let-values(((vec_22)(make-vector NUM-CACHE-SLOTS #f)))" +"(begin(set! cached-sets(make-weak-box vec_22)) vec_22))))))" +"(let-values(((or-part_99)" +"(let-values(((vec_23 len_10)" +"(let-values(((vec_24) vec_21))" +"(begin(check-vector vec_24)(values vec_24(unsafe-vector-length vec_24))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_54)" +"(lambda(result_39 pos_8)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_8 len_10)" +"(let-values(((s2_6)(unsafe-vector-ref vec_23 pos_8)))" +"(let-values(((result_40)" +"(let-values()" +"(let-values(((result_35)" +"(let-values()" +"(let-values()" +"(if s2_6" +"(if(set=? s_45 s2_6) s2_6 #f)" +" #f)))))" +"(values result_35)))))" +"(if(if(not((lambda x_32 result_40) s2_6))(not #f) #f)" +"(for-loop_54 result_40(unsafe-fx+ 1 pos_8))" +" result_40)))" +" result_39)))))" +" for-loop_54)" +" #f" +" 0)))))" +"(if or-part_99" +" or-part_99" +"(begin" +"(vector*-set! vec_21 cached-sets-pos s_45)" +"(set! cached-sets-pos(fxand(fx+ 1 cached-sets-pos)(fx- NUM-CACHE-SLOTS 1)))" +" s_45)))))))" +"(define-values" +"(cache-or-reuse-hash)" +"(lambda(s_86)" +"(begin" +"(let-values(((vec_25)" +"(let-values(((or-part_100)(weak-box-value cached-hashes)))" +"(if or-part_100" +" or-part_100" +"(let-values(((vec_26)(make-vector NUM-CACHE-SLOTS #f)))" +"(begin(set! cached-hashes(make-weak-box vec_26)) vec_26))))))" +"(let-values(((or-part_97)" +"(let-values(((vec_27 len_11)" +"(let-values(((vec_28) vec_25))" +"(begin(check-vector vec_28)(values vec_28(unsafe-vector-length vec_28))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_55)" +"(lambda(result_8 pos_9)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_9 len_11)" +"(let-values(((s2_7)(unsafe-vector-ref vec_27 pos_9)))" +"(let-values(((result_41)" +"(let-values()" +"(let-values(((result_42)" +"(let-values()" +"(let-values()" +"(if s2_7" +"(if(equal? s_86 s2_7) s2_7 #f)" +" #f)))))" +"(values result_42)))))" +"(if(if(not((lambda x_16 result_41) s2_7))(not #f) #f)" +"(for-loop_55 result_41(unsafe-fx+ 1 pos_9))" +" result_41)))" +" result_8)))))" +" for-loop_55)" +" #f" +" 0)))))" +"(if or-part_97" +" or-part_97" +"(begin" +"(vector*-set! vec_25 cached-hashes-pos s_86)" +"(set! cached-hashes-pos(fxand(fx+ 1 cached-hashes-pos)(fx- NUM-CACHE-SLOTS 1)))" +" s_86)))))))" +"(define-values" +"(struct:scope scope1.1 scope? scope-id scope-kind scope-binding-table set-scope-binding-table!)" +"(let-values(((struct:_23 make-_23 ?_23 -ref_23 -set!_23)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'scope" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:scope-with-bindings" +"(lambda(s_87 get-reachable-scopes_2 reach_6 register-trigger_2)" +"(binding-table-register-reachable" +"(scope-binding-table s_87)" +" get-reachable-scopes_2" +" reach_6" +" register-trigger_2)))" +"(cons prop:reach-scopes(lambda(s_88 reach_7)(void)))" +"(cons" +" prop:serialize-fill!" +"(lambda(s_89 ser-push!_6 state_16)" +"(if(binding-table-empty?(scope-binding-table s_89))" +"(let-values()(ser-push!_6 'tag #f))" +"(let-values()" +"(begin" +"(ser-push!_6 'tag '#:scope-fill!)" +"(ser-push!_6(binding-table-prune-to-reachable(scope-binding-table s_89) state_16)))))))" +"(cons" +" prop:serialize" +"(lambda(s_90 ser-push!_7 state_17)" +"(begin" +"(if(set-member?(serialize-state-reachable-scopes state_17) s_90)" +"(void)" +" (let-values () (error \"internal error: found supposedly unreachable scope\")))" +"(if(eq? s_90 top-level-common-scope)" +"(let-values()(ser-push!_7 'tag '#:scope))" +"(let-values()" +"(begin(ser-push!_7 'tag '#:scope+kind)(ser-push!_7(scope-kind s_90))))))))" +"(cons" +" prop:custom-write" +"(lambda(sc_3 port_6 mode_6)" +"(begin" +" (write-string \"#\" port_6)))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'scope)))))" +"(values" +" struct:_23" +" make-_23" +" ?_23" +"(make-struct-field-accessor -ref_23 0 'id)" +"(make-struct-field-accessor -ref_23 1 'kind)" +"(make-struct-field-accessor -ref_23 2 'binding-table)" +"(make-struct-field-mutator -set!_23 2 'binding-table))))" +"(define-values" +"(deserialize-scope)" +"(case-lambda" +"(()(begin top-level-common-scope))" +"((kind_0)(scope1.1(new-deserialize-scope-id!) kind_0 empty-binding-table))))" +"(define-values(deserialize-scope-fill!)(lambda(s_91 bt_5)(begin(set-scope-binding-table! s_91 bt_5))))" +"(define-values" +"(struct:interned-scope interned-scope2.1 interned-scope? interned-scope-key)" +"(let-values(((struct:_24 make-_24 ?_24 -ref_24 -set!_24)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'interned-scope" +" struct:scope" +" 1" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(s_92 ser-push!_8 state_18)" +"(begin" +"(if(set-member?(serialize-state-reachable-scopes state_18) s_92)" +"(void)" +" (let-values () (error \"internal error: found supposedly unreachable scope\")))" +"(ser-push!_8 'tag '#:interned-scope)" +"(ser-push!_8(interned-scope-key s_92)))))" +"(cons" +" prop:custom-write" +"(lambda(sc_4 port_7 mode_7)" +"(begin" +" (write-string \"#\" port_7)))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'interned-scope)))))" +"(values struct:_24 make-_24 ?_24(make-struct-field-accessor -ref_24 0 'key))))" +"(define-values" +"(struct:multi-scope" +" multi-scope3.1" +" multi-scope?" +" multi-scope-id" +" multi-scope-name" +" multi-scope-scopes" +" multi-scope-shifted" +" multi-scope-label-shifted)" +"(let-values(((struct:_25 make-_25 ?_25 -ref_25 -set!_25)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'multi-scope" +" #f" +" 5" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:scope-with-bindings" +"(lambda(ms_0 get-reachable-scopes_3 reach_8 register-trigger_3)" +"(begin" +"(let-values(((ht_48)(multi-scope-scopes ms_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-values ht_48)))" +"((letrec-values(((for-loop_56)" +"(lambda(i_67)" +"(begin" +" 'for-loop" +"(if i_67" +"(let-values(((sc_5)(hash-iterate-value ht_48 i_67)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(binding-table-empty?" +"(scope-binding-table" +" sc_5))" +"(void)" +"(let-values()" +"(reach_8 sc_5))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_56(hash-iterate-next ht_48 i_67))" +"(values))))" +"(values))))))" +" for-loop_56)" +"(hash-iterate-first ht_48))))" +"(void))))" +"(cons prop:reach-scopes(lambda(s_86 reach_9)(void)))" +"(cons" +" prop:serialize" +"(lambda(ms_1 ser-push!_9 state_19)" +"(let-values((()(begin(ser-push!_9 'tag '#:multi-scope)(values))))" +"(let-values((()(begin(ser-push!_9(multi-scope-name ms_1))(values))))" +"(let-values(((multi-scope-tables_0)(serialize-state-multi-scope-tables state_19)))" +"(ser-push!_9" +"(let-values(((or-part_101)" +"(hash-ref multi-scope-tables_0(multi-scope-scopes ms_1) #f)))" +"(if or-part_101" +" or-part_101" +"(let-values(((ht_49)(make-hasheqv)))" +"(begin" +"(let-values(((ht_50)(multi-scope-scopes ms_1)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_50)))" +"((letrec-values(((for-loop_57)" +"(lambda(i_68)" +"(begin" +" 'for-loop" +"(if i_68" +"(let-values(((phase_8 sc_6)" +"(hash-iterate-key+value ht_50 i_68)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(set-member?" +"(serialize-state-reachable-scopes" +" state_19)" +" sc_6)" +"(let-values()" +"(hash-set!" +" ht_49" +" phase_8" +" sc_6))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_57(hash-iterate-next ht_50 i_68))" +"(values))))" +"(values))))))" +" for-loop_57)" +"(hash-iterate-first ht_50))))" +"(void)" +"(hash-set! multi-scope-tables_0(multi-scope-scopes ms_1) ht_49)" +" ht_49)))))))))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4)" +" #f" +" 'multi-scope)))))" +"(values" +" struct:_25" +" make-_25" +" ?_25" +"(make-struct-field-accessor -ref_25 0 'id)" +"(make-struct-field-accessor -ref_25 1 'name)" +"(make-struct-field-accessor -ref_25 2 'scopes)" +"(make-struct-field-accessor -ref_25 3 'shifted)" +"(make-struct-field-accessor -ref_25 4 'label-shifted))))" +"(define-values" +"(deserialize-multi-scope)" +"(lambda(name_15 scopes_8)" +"(begin(multi-scope3.1(new-deserialize-scope-id!) name_15 scopes_8(box(hasheqv))(box(hash))))))" +"(define-values" +"(struct:representative-scope" +" representative-scope4.1" +" representative-scope?" +" representative-scope-owner" +" representative-scope-phase" +" set-representative-scope-owner!" +" set-representative-scope-phase!)" +"(let-values(((struct:_26 make-_26 ?_26 -ref_26 -set!_26)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'representative-scope" +" struct:scope" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:implicitly-reachable #t)" +"(cons prop:reach-scopes(lambda(s_93 reach_10)(reach_10(representative-scope-owner s_93))))" +"(cons" +" prop:serialize-fill!" +"(lambda(s_94 ser-push!_10 state_20)" +"(begin" +"(ser-push!_10 'tag '#:representative-scope-fill!)" +"(ser-push!_10(binding-table-prune-to-reachable(scope-binding-table s_94) state_20))" +"(ser-push!_10(representative-scope-owner s_94)))))" +"(cons" +" prop:serialize" +"(lambda(s_95 ser-push!_11 state_21)" +"(begin" +"(ser-push!_11 'tag '#:representative-scope)" +"(ser-push!_11(scope-kind s_95))" +"(ser-push!_11(representative-scope-phase s_95)))))" +"(cons" +" prop:custom-write" +"(lambda(sc_7 port_8 mode_8)" +"(begin" +" (write-string \"#\" port_8)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'representative-scope)))))" +"(values" +" struct:_26" +" make-_26" +" ?_26" +"(make-struct-field-accessor -ref_26 0 'owner)" +"(make-struct-field-accessor -ref_26 1 'phase)" +"(make-struct-field-mutator -set!_26 0 'owner)" +"(make-struct-field-mutator -set!_26 1 'phase))))" +"(define-values" +"(deserialize-representative-scope)" +"(lambda(kind_1 phase_9)" +"(begin(let-values(((v_83)(representative-scope4.1(new-deserialize-scope-id!) kind_1 #f #f phase_9))) v_83))))" +"(define-values" +"(deserialize-representative-scope-fill!)" +"(lambda(s_96 bt_6 owner_0)" +"(begin(begin(deserialize-scope-fill! s_96 bt_6)(set-representative-scope-owner! s_96 owner_0)))))" +"(define-values" +"(struct:shifted-multi-scope" +" shifted-multi-scope5.1" +" shifted-multi-scope?" +" shifted-multi-scope-phase" +" shifted-multi-scope-multi-scope)" +"(let-values(((struct:_27 make-_27 ?_27 -ref_27 -set!_27)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'shifted-multi-scope" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:reach-scopes" +"(lambda(sms_3 reach_11)(reach_11(shifted-multi-scope-multi-scope sms_3))))" +"(cons" +" prop:serialize" +"(lambda(sms_4 ser-push!_12 state_22)" +"(begin" +"(ser-push!_12 'tag '#:shifted-multi-scope)" +"(ser-push!_12(shifted-multi-scope-phase sms_4))" +"(ser-push!_12(shifted-multi-scope-multi-scope sms_4)))))" +"(cons" +" prop:custom-write" +"(lambda(sms_5 port_9 mode_9)" +"(begin" +" (write-string \"#\" port_9)))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'shifted-multi-scope)))))" +"(values" +" struct:_27" +" make-_27" +" ?_27" +"(make-struct-field-accessor -ref_27 0 'phase)" +"(make-struct-field-accessor -ref_27 1 'multi-scope))))" +"(define-values" +"(deserialize-shifted-multi-scope)" +"(lambda(phase_10 multi-scope_0)(begin(intern-shifted-multi-scope phase_10 multi-scope_0))))" +"(define-values" +"(intern-shifted-multi-scope)" +"(lambda(phase_11 multi-scope_1)" +"(begin" +"(letrec-values(((transaction-loop_0)" +"(lambda(boxed-table_0 key_29 make_0)" +"(begin" +" 'transaction-loop" +"(let-values(((or-part_102)(hash-ref(unbox boxed-table_0) phase_11 #f)))" +"(if or-part_102" +" or-part_102" +"(let-values(((val_17)(make_0)))" +"(let-values(((current_0)(unbox boxed-table_0)))" +"(let-values(((next_3)(hash-set current_0 key_29 val_17)))" +"(if(box-cas! boxed-table_0 current_0 next_3)" +" val_17" +"(transaction-loop_0 boxed-table_0 key_29 make_0)))))))))))" +"(if(phase? phase_11)" +"(let-values()" +"(let-values(((or-part_103)(hash-ref(unbox(multi-scope-shifted multi-scope_1)) phase_11 #f)))" +"(if or-part_103" +" or-part_103" +"(transaction-loop_0" +"(multi-scope-shifted multi-scope_1)" +" phase_11" +"(lambda()(shifted-multi-scope5.1 phase_11 multi-scope_1))))))" +"(let-values()" +"(let-values(((or-part_104)(hash-ref(unbox(multi-scope-label-shifted multi-scope_1)) phase_11 #f)))" +"(if or-part_104" +" or-part_104" +"(transaction-loop_0" +"(multi-scope-label-shifted multi-scope_1)" +" phase_11" +"(lambda()(shifted-multi-scope5.1 phase_11 multi-scope_1)))))))))))" +"(define-values" +"(struct:shifted-to-label-phase shifted-to-label-phase6.1 shifted-to-label-phase? shifted-to-label-phase-from)" +"(let-values(((struct:_28 make-_28 ?_28 -ref_28 -set!_28)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'shifted-to-label-phase" +" #f" +" 1" +" 0" +" #f" +" null" +" 'prefab" +" #f" +" '(0)" +" #f" +" 'shifted-to-label-phase)))))" +"(values struct:_28 make-_28 ?_28(make-struct-field-accessor -ref_28 0 'from))))" +"(define-values(id-counter) 0)" +"(define-values(new-scope-id!)(lambda()(begin(begin(set! id-counter(add1 id-counter)) id-counter))))" +"(define-values(new-deserialize-scope-id!)(lambda()(begin(-(new-scope-id!)))))" +"(define-values(deserialized-scope-id?)(lambda(scope-id_0)(begin(negative? scope-id_0))))" +"(define-values(top-level-common-scope)(scope1.1 0 'module empty-binding-table))" +"(define-values(new-scope)(lambda(kind_2)(begin(scope1.1(new-scope-id!) kind_2 empty-binding-table))))" +"(define-values(interned-scopes-table)(make-weak-hasheq))" +"(define-values" +"(make-interned-scope)" +"(lambda(sym_15)" +"(begin" +"(let-values(((make_1)" +"(lambda()" +"(begin" +" 'make" +"(make-ephemeron" +" sym_15" +"(interned-scope2.1(-(new-scope-id!)) 'interned empty-binding-table sym_15))))))" +"(call-as-atomic" +"(lambda()" +"(let-values(((or-part_105)(ephemeron-value(hash-ref! interned-scopes-table sym_15 make_1))))" +"(if or-part_105" +" or-part_105" +"(let-values(((new_1)(make_1)))" +"(begin(hash-set! interned-scopes-table sym_15 new_1)(ephemeron-value new_1)))))))))))" +"(define-values" +"(new-multi-scope)" +"(let-values(((new-multi-scope8_0)" +"(lambda(name7_0)" +"(begin" +" 'new-multi-scope8" +"(let-values(((name_16) name7_0))" +"(let-values()" +"(intern-shifted-multi-scope" +" 0" +"(multi-scope3.1(new-scope-id!) name_16(make-hasheqv)(box(hasheqv))(box(hash))))))))))" +"(case-lambda(()(begin(new-multi-scope8_0 #f)))((name7_1)(new-multi-scope8_0 name7_1)))))" +"(define-values" +"(multi-scope-to-scope-at-phase)" +"(lambda(ms_2 phase_12)" +"(begin" +"(let-values(((or-part_106)(hash-ref(multi-scope-scopes ms_2) phase_12 #f)))" +"(if or-part_106" +" or-part_106" +"(let-values(((s_97)" +"(representative-scope4.1" +"(if(deserialized-scope-id?(multi-scope-id ms_2))(new-deserialize-scope-id!)(new-scope-id!))" +" 'module" +" empty-binding-table" +" ms_2" +" phase_12)))" +"(begin(hash-set!(multi-scope-scopes ms_2) phase_12 s_97) s_97)))))))" +"(define-values(scope>?)(lambda(sc1_0 sc2_0)(begin(>(scope-id sc1_0)(scope-id sc2_0)))))" +"(define-values(scope_2)" +"(lambda(sub-s_1)" +"(begin" +" 's->" +"(if(propagation? prop_3)" +"(let-values(((the-struct_14) sub-s_1))" +"(if(syntax?$1 the-struct_14)" +"(let-values(((scopes49_0)" +"(propagation-apply prop_3(syntax-scopes sub-s_1) s_98))" +"((shifted-multi-scopes50_0)" +"(propagation-apply-shifted" +" prop_3" +"(syntax-shifted-multi-scopes sub-s_1)" +" s_98))" +"((mpi-shifts51_0)" +"(propagation-apply-mpi-shifts" +" prop_3" +"(syntax-mpi-shifts sub-s_1)" +" s_98))" +"((inspector52_0)" +"(propagation-apply-inspector" +" prop_3" +"(syntax-inspector sub-s_1)))" +"((scope-propagations+tamper53_0)" +"(propagation-merge" +"(syntax-content sub-s_1)" +" prop_3" +"(syntax-scope-propagations+tamper sub-s_1)" +"(syntax-scopes sub-s_1)" +"(syntax-shifted-multi-scopes sub-s_1)" +"(syntax-mpi-shifts sub-s_1))))" +"(syntax1.1" +"(syntax-content the-struct_14)" +" scopes49_0" +" shifted-multi-scopes50_0" +" scope-propagations+tamper53_0" +" mpi-shifts51_0" +"(syntax-srcloc the-struct_14)" +"(syntax-props the-struct_14)" +" inspector52_0))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_14)))" +"(let-values(((stx_8) sub-s_1))" +"(let-values(((the-struct_15) stx_8))" +"(if(syntax?$1 the-struct_15)" +"(let-values(((scope-propagations+tamper54_0)" +"(let-values(((t_34)" +"(tamper-tainted-for-content" +"(syntax-content sub-s_1)))" +"((p_28)" +"(syntax-scope-propagations+tamper stx_8)))" +"(if(tamper? p_28)" +" t_34" +"((propagation-set-tamper-ref p_28) p_28 t_34)))))" +"(syntax1.1" +"(syntax-content the-struct_15)" +"(syntax-scopes the-struct_15)" +"(syntax-shifted-multi-scopes the-struct_15)" +" scope-propagations+tamper54_0" +"(syntax-mpi-shifts the-struct_15)" +"(syntax-srcloc the-struct_15)" +"(syntax-props the-struct_15)" +"(syntax-inspector the-struct_15)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_15))))))))" +"((seen_9) #f))" +"(let-values(((s_100) s_99)" +"((f_31) f_30)" +"((gf_4)" +"(lambda(tail?_21 v_84)" +"(begin" +" 'gf" +"(if(syntax?$1 v_84)" +"(let-values()(s->_2 v_84))" +"(let-values()(f_30 tail?_21 v_84))))))" +"((seen_10) seen_9))" +"((letrec-values(((loop_71)" +"(lambda(tail?_22 s_101 prev-depth_4)" +"(begin" +" 'loop" +"(let-values(((depth_4)(fx+ 1 prev-depth_4)))" +"(if(if seen_10(fx> depth_4 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_22" +" s_101" +"(lambda(tail?_23 s_102)(gf_4 tail?_23 s_102))" +" seen_10))" +"(if(null? s_101)" +"(let-values()(f_31 tail?_22 s_101))" +"(if(pair? s_101)" +"(let-values()" +"(f_31" +" tail?_22" +"(cons" +"(loop_71 #f(car s_101) depth_4)" +"(loop_71 #t(cdr s_101) depth_4))))" +"(if(symbol? s_101)" +"(let-values()(f_31 #f s_101))" +"(if(boolean? s_101)" +"(let-values()(f_31 #f s_101))" +"(if(number? s_101)" +"(let-values()(f_31 #f s_101))" +"(if(let-values(((or-part_108)(vector? s_101)))" +"(if or-part_108" +" or-part_108" +"(let-values(((or-part_109)(box? s_101)))" +"(if or-part_109" +" or-part_109" +"(let-values(((or-part_110)" +"(prefab-struct-key s_101)))" +"(if or-part_110" +" or-part_110" +"(hash? s_101)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_22" +" s_101" +"(lambda(tail?_24 s_103)(gf_4 tail?_24 s_103))" +" seen_10))" +"(let-values()(gf_4 #f s_101))))))))))))))" +" loop_71)" +" #f" +" s_100" +" 0)))))" +"(begin" +"(set-syntax-content! s_98 new-content_0)" +"(set-syntax-scope-propagations+tamper!" +" s_98" +"(tamper-propagated(if(propagation? prop_3)(propagation-tamper prop_3) prop_3)))" +" new-content_0))" +"(syntax-content s_98))))))" +"(define-values" +"(syntax-e$1)" +"(lambda(s_104)" +"(begin" +" 'syntax-e" +"(let-values(((e_15)(syntax-content s_104)))" +"(if(symbol? e_15)" +"(let-values() e_15)" +"(let-values()" +"(let-values(((content_6)(syntax-e/no-taint s_104)))" +"(if(not(tamper-armed?(syntax-scope-propagations+tamper s_104)))" +"(let-values() content_6)" +"(if(datum-has-elements? content_6)" +"(let-values()(taint-content content_6))" +"(let-values() content_6))))))))))" +"(define-values" +"(generalize-scope)" +"(lambda(sc_8)" +"(begin" +"(if(representative-scope? sc_8)" +"(intern-shifted-multi-scope(representative-scope-phase sc_8)(representative-scope-owner sc_8))" +" sc_8))))" +"(define-values" +"(add-scope)" +"(lambda(s_105 sc_9)" +"(begin" +"(let-values(((s_106) s_105)((sc_10)(generalize-scope sc_9))((op_0) set-add)((prop-op_0) propagation-add))" +"(if(shifted-multi-scope? sc_10)" +"(let-values(((the-struct_16) s_106))" +"(if(syntax?$1 the-struct_16)" +"(let-values(((shifted-multi-scopes55_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_106)" +"(lambda(smss_9)(op_0(fallback-first smss_9) sc_10))))" +"((scope-propagations+tamper56_0)" +"(if(datum-has-elements?(syntax-content s_106))" +"(prop-op_0" +"(syntax-scope-propagations+tamper s_106)" +" sc_10" +"(syntax-scopes s_106)" +"(syntax-shifted-multi-scopes s_106)" +"(syntax-mpi-shifts s_106))" +"(syntax-scope-propagations+tamper s_106))))" +"(syntax1.1" +"(syntax-content the-struct_16)" +"(syntax-scopes the-struct_16)" +" shifted-multi-scopes55_0" +" scope-propagations+tamper56_0" +"(syntax-mpi-shifts the-struct_16)" +"(syntax-srcloc the-struct_16)" +"(syntax-props the-struct_16)" +"(syntax-inspector the-struct_16)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_16)))" +"(let-values(((the-struct_17) s_106))" +"(if(syntax?$1 the-struct_17)" +"(let-values(((scopes57_0)(op_0(syntax-scopes s_106) sc_10))" +"((scope-propagations+tamper58_0)" +"(if(datum-has-elements?(syntax-content s_106))" +"(prop-op_0" +"(syntax-scope-propagations+tamper s_106)" +" sc_10" +"(syntax-scopes s_106)" +"(syntax-shifted-multi-scopes s_106)" +"(syntax-mpi-shifts s_106))" +"(syntax-scope-propagations+tamper s_106))))" +"(syntax1.1" +"(syntax-content the-struct_17)" +" scopes57_0" +"(syntax-shifted-multi-scopes the-struct_17)" +" scope-propagations+tamper58_0" +"(syntax-mpi-shifts the-struct_17)" +"(syntax-srcloc the-struct_17)" +"(syntax-props the-struct_17)" +"(syntax-inspector the-struct_17)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_17))))))))" +"(define-values" +"(add-scopes)" +"(lambda(s_107 scs_5)" +"(begin" +"(let-values(((lst_42) scs_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_42)))" +"((letrec-values(((for-loop_58)" +"(lambda(s_108 lst_43)" +"(begin" +" 'for-loop" +"(if(pair? lst_43)" +"(let-values(((sc_11)(unsafe-car lst_43))((rest_18)(unsafe-cdr lst_43)))" +"(let-values(((s_109)" +"(let-values(((s_110) s_108))" +"(let-values(((s_111)(let-values()(add-scope s_110 sc_11))))" +"(values s_111)))))" +"(if(not #f)(for-loop_58 s_109 rest_18) s_109)))" +" s_108)))))" +" for-loop_58)" +" s_107" +" lst_42))))))" +"(define-values" +"(remove-scope)" +"(lambda(s_112 sc_12)" +"(begin" +"(let-values(((s_113) s_112)" +"((sc_13)(generalize-scope sc_12))" +"((op_1) set-remove)" +"((prop-op_1) propagation-remove))" +"(if(shifted-multi-scope? sc_13)" +"(let-values(((the-struct_18) s_113))" +"(if(syntax?$1 the-struct_18)" +"(let-values(((shifted-multi-scopes59_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_113)" +"(lambda(smss_10)(op_1(fallback-first smss_10) sc_13))))" +"((scope-propagations+tamper60_0)" +"(if(datum-has-elements?(syntax-content s_113))" +"(prop-op_1" +"(syntax-scope-propagations+tamper s_113)" +" sc_13" +"(syntax-scopes s_113)" +"(syntax-shifted-multi-scopes s_113)" +"(syntax-mpi-shifts s_113))" +"(syntax-scope-propagations+tamper s_113))))" +"(syntax1.1" +"(syntax-content the-struct_18)" +"(syntax-scopes the-struct_18)" +" shifted-multi-scopes59_0" +" scope-propagations+tamper60_0" +"(syntax-mpi-shifts the-struct_18)" +"(syntax-srcloc the-struct_18)" +"(syntax-props the-struct_18)" +"(syntax-inspector the-struct_18)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_18)))" +"(let-values(((the-struct_19) s_113))" +"(if(syntax?$1 the-struct_19)" +"(let-values(((scopes61_0)(op_1(syntax-scopes s_113) sc_13))" +"((scope-propagations+tamper62_0)" +"(if(datum-has-elements?(syntax-content s_113))" +"(prop-op_1" +"(syntax-scope-propagations+tamper s_113)" +" sc_13" +"(syntax-scopes s_113)" +"(syntax-shifted-multi-scopes s_113)" +"(syntax-mpi-shifts s_113))" +"(syntax-scope-propagations+tamper s_113))))" +"(syntax1.1" +"(syntax-content the-struct_19)" +" scopes61_0" +"(syntax-shifted-multi-scopes the-struct_19)" +" scope-propagations+tamper62_0" +"(syntax-mpi-shifts the-struct_19)" +"(syntax-srcloc the-struct_19)" +"(syntax-props the-struct_19)" +"(syntax-inspector the-struct_19)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_19))))))))" +"(define-values" +"(remove-scopes)" +"(lambda(s_114 scs_6)" +"(begin" +"(let-values(((lst_44) scs_6))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_44)))" +"((letrec-values(((for-loop_59)" +"(lambda(s_115 lst_45)" +"(begin" +" 'for-loop" +"(if(pair? lst_45)" +"(let-values(((sc_14)(unsafe-car lst_45))((rest_19)(unsafe-cdr lst_45)))" +"(let-values(((s_116)" +"(let-values(((s_117) s_115))" +"(let-values(((s_118)(let-values()(remove-scope s_117 sc_14))))" +"(values s_118)))))" +"(if(not #f)(for-loop_59 s_116 rest_19) s_116)))" +" s_115)))))" +" for-loop_59)" +" s_114" +" lst_44))))))" +"(define-values" +"(set-flip)" +"(lambda(s_119 e_16)(begin(if(set-member? s_119 e_16)(set-remove s_119 e_16)(set-add s_119 e_16)))))" +"(define-values" +"(flip-scope)" +"(lambda(s_120 sc_15)" +"(begin" +"(let-values(((s_121) s_120)((sc_16)(generalize-scope sc_15))((op_2) set-flip)((prop-op_2) propagation-flip))" +"(if(shifted-multi-scope? sc_16)" +"(let-values(((the-struct_20) s_121))" +"(if(syntax?$1 the-struct_20)" +"(let-values(((shifted-multi-scopes63_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_121)" +"(lambda(smss_11)(op_2(fallback-first smss_11) sc_16))))" +"((scope-propagations+tamper64_0)" +"(if(datum-has-elements?(syntax-content s_121))" +"(prop-op_2" +"(syntax-scope-propagations+tamper s_121)" +" sc_16" +"(syntax-scopes s_121)" +"(syntax-shifted-multi-scopes s_121)" +"(syntax-mpi-shifts s_121))" +"(syntax-scope-propagations+tamper s_121))))" +"(syntax1.1" +"(syntax-content the-struct_20)" +"(syntax-scopes the-struct_20)" +" shifted-multi-scopes63_0" +" scope-propagations+tamper64_0" +"(syntax-mpi-shifts the-struct_20)" +"(syntax-srcloc the-struct_20)" +"(syntax-props the-struct_20)" +"(syntax-inspector the-struct_20)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_20)))" +"(let-values(((the-struct_21) s_121))" +"(if(syntax?$1 the-struct_21)" +"(let-values(((scopes65_0)(op_2(syntax-scopes s_121) sc_16))" +"((scope-propagations+tamper66_0)" +"(if(datum-has-elements?(syntax-content s_121))" +"(prop-op_2" +"(syntax-scope-propagations+tamper s_121)" +" sc_16" +"(syntax-scopes s_121)" +"(syntax-shifted-multi-scopes s_121)" +"(syntax-mpi-shifts s_121))" +"(syntax-scope-propagations+tamper s_121))))" +"(syntax1.1" +"(syntax-content the-struct_21)" +" scopes65_0" +"(syntax-shifted-multi-scopes the-struct_21)" +" scope-propagations+tamper66_0" +"(syntax-mpi-shifts the-struct_21)" +"(syntax-srcloc the-struct_21)" +"(syntax-props the-struct_21)" +"(syntax-inspector the-struct_21)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_21))))))))" +"(define-values" +"(flip-scopes)" +"(lambda(s_122 scs_7)" +"(begin" +"(let-values(((lst_46) scs_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_46)))" +"((letrec-values(((for-loop_43)" +"(lambda(s_123 lst_47)" +"(begin" +" 'for-loop" +"(if(pair? lst_47)" +"(let-values(((sc_17)(unsafe-car lst_47))((rest_20)(unsafe-cdr lst_47)))" +"(let-values(((s_124)" +"(let-values(((s_125) s_123))" +"(let-values(((s_126)(let-values()(flip-scope s_125 sc_17))))" +"(values s_126)))))" +"(if(not #f)(for-loop_43 s_124 rest_20) s_124)))" +" s_123)))))" +" for-loop_43)" +" s_122" +" lst_46))))))" +"(define-values" +"(push-scope)" +"(lambda(s_127 sms_6)" +"(begin" +"(let-values(((smss/maybe-fallbacks67_0) #f))" +"(let-values(((prev-result_0) #f))" +"(let-values(((push_0)" +"(lambda(smss/maybe-fallbacks_0)" +"(begin" +" 'push" +"(if(eq? smss/maybe-fallbacks67_0 smss/maybe-fallbacks_0)" +"(let-values() prev-result_0)" +"(let-values()" +"(let-values(((r_23)" +"(let-values()" +"(let-values(((smss_12)(fallback-first smss/maybe-fallbacks_0)))" +"(if(set-empty? smss_12)" +"(let-values()(set-add smss_12 sms_6))" +"(if(set-member? smss_12 sms_6)" +"(let-values() smss/maybe-fallbacks_0)" +"(let-values()" +"(fallback-push" +"(set-add smss_12 sms_6)" +" smss/maybe-fallbacks_0))))))))" +"(begin" +"(set! smss/maybe-fallbacks67_0 smss/maybe-fallbacks_0)" +"(set! prev-result_0 r_23)" +" r_23))))))))" +"(let-values(((s_128) s_127)" +"((f_32)(lambda(tail?_25 x_34)(begin 'f x_34)))" +"((d->s_1)" +"(lambda(s_129 d_3)" +"(begin" +" 'd->s" +"(let-values(((the-struct_22) s_129))" +"(if(syntax?$1 the-struct_22)" +"(let-values(((content68_0) d_3)" +"((shifted-multi-scopes69_0)" +"(push_0(syntax-shifted-multi-scopes s_129))))" +"(syntax1.1" +" content68_0" +"(syntax-scopes the-struct_22)" +" shifted-multi-scopes69_0" +"(syntax-scope-propagations+tamper the-struct_22)" +"(syntax-mpi-shifts the-struct_22)" +"(syntax-srcloc the-struct_22)" +"(syntax-props the-struct_22)" +"(syntax-inspector the-struct_22)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_22))))))" +"((s-e_1) syntax-e/no-taint)" +"((seen_11) #f))" +"((letrec-values(((loop_72)" +"(lambda(s_130)" +"(begin" +" 'loop" +"(let-values(((s_131) s_130)" +"((f_33) f_32)" +"((gf_5)" +"(lambda(tail?_26 v_85)" +"(begin" +" 'gf" +"(if(syntax?$1 v_85)" +"(let-values()(d->s_1 v_85(loop_72(s-e_1 v_85))))" +"(let-values()(f_32 tail?_26 v_85))))))" +"((seen_12) seen_11))" +"((letrec-values(((loop_73)" +"(lambda(tail?_27 s_132 prev-depth_5)" +"(begin" +" 'loop" +"(let-values(((depth_5)(fx+ 1 prev-depth_5)))" +"(if(if seen_12(fx> depth_5 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_27" +" s_132" +"(lambda(tail?_28 s_133)(gf_5 tail?_28 s_133))" +" seen_12))" +"(if(null? s_132)" +"(let-values()(f_33 tail?_27 s_132))" +"(if(pair? s_132)" +"(let-values()" +"(f_33" +" tail?_27" +"(cons" +"(loop_73 #f(car s_132) depth_5)" +"(loop_73 #t(cdr s_132) depth_5))))" +"(if(symbol? s_132)" +"(let-values()(f_33 #f s_132))" +"(if(boolean? s_132)" +"(let-values()(f_33 #f s_132))" +"(if(number? s_132)" +"(let-values()(f_33 #f s_132))" +"(if(let-values(((or-part_111)" +"(vector? s_132)))" +"(if or-part_111" +" or-part_111" +"(let-values(((or-part_112)" +"(box? s_132)))" +"(if or-part_112" +" or-part_112" +"(let-values(((or-part_113)" +"(prefab-struct-key" +" s_132)))" +"(if or-part_113" +" or-part_113" +"(hash? s_132)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_27" +" s_132" +"(lambda(tail?_29 s_134)" +"(gf_5 tail?_29 s_134))" +" seen_12))" +"(let-values()(gf_5 #f s_132))))))))))))))" +" loop_73)" +" #f" +" s_131" +" 0))))))" +" loop_72)" +" s_128))))))))" +"(define-values" +"(struct:propagation" +" propagation14.1" +" propagation?" +" propagation-prev-scs" +" propagation-prev-smss" +" propagation-scope-ops" +" propagation-prev-mss" +" propagation-add-mpi-shifts" +" propagation-inspector" +" propagation-tamper)" +"(let-values(((struct:_29 make-_29 ?_29 -ref_29 -set!_29)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'propagation" +" #f" +" 7" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:propagation-set-tamper(lambda(p_29 v_86)(propagation-set-tamper p_29 v_86)))" +"(cons prop:propagation-tamper(lambda(p_30)(propagation-tamper p_30)))" +"(cons prop:propagation syntax-e$1))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'propagation)))))" +"(values" +" struct:_29" +" make-_29" +" ?_29" +"(make-struct-field-accessor -ref_29 0 'prev-scs)" +"(make-struct-field-accessor -ref_29 1 'prev-smss)" +"(make-struct-field-accessor -ref_29 2 'scope-ops)" +"(make-struct-field-accessor -ref_29 3 'prev-mss)" +"(make-struct-field-accessor -ref_29 4 'add-mpi-shifts)" +"(make-struct-field-accessor -ref_29 5 'inspector)" +"(make-struct-field-accessor -ref_29 6 'tamper))))" +"(define-values" +"(propagation-add)" +"(lambda(prop_4 sc_18 prev-scs_0 prev-smss_0 prev-mss_0)" +"(begin" +"(if(propagation? prop_4)" +"(let-values(((the-struct_23) prop_4))" +"(if(propagation? the-struct_23)" +"(let-values(((scope-ops71_0)(hash-set(propagation-scope-ops prop_4) sc_18 'add)))" +"(propagation14.1" +"(propagation-prev-scs the-struct_23)" +"(propagation-prev-smss the-struct_23)" +" scope-ops71_0" +"(propagation-prev-mss the-struct_23)" +"(propagation-add-mpi-shifts the-struct_23)" +"(propagation-inspector the-struct_23)" +"(propagation-tamper the-struct_23)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_23)))" +"(propagation14.1 prev-scs_0 prev-smss_0(hasheq sc_18 'add) prev-mss_0 #f #f prop_4)))))" +"(define-values" +"(propagation-remove)" +"(lambda(prop_5 sc_19 prev-scs_1 prev-smss_1 prev-mss_1)" +"(begin" +"(if(propagation? prop_5)" +"(let-values(((the-struct_24) prop_5))" +"(if(propagation? the-struct_24)" +"(let-values(((scope-ops72_0)(hash-set(propagation-scope-ops prop_5) sc_19 'remove)))" +"(propagation14.1" +"(propagation-prev-scs the-struct_24)" +"(propagation-prev-smss the-struct_24)" +" scope-ops72_0" +"(propagation-prev-mss the-struct_24)" +"(propagation-add-mpi-shifts the-struct_24)" +"(propagation-inspector the-struct_24)" +"(propagation-tamper the-struct_24)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_24)))" +"(propagation14.1 prev-scs_1 prev-smss_1(hasheq sc_19 'remove) prev-mss_1 #f #f prop_5)))))" +"(define-values" +"(propagation-flip)" +"(lambda(prop_6 sc_20 prev-scs_2 prev-smss_2 prev-mss_2)" +"(begin" +"(if(propagation? prop_6)" +"(let-values(((ops_0)(propagation-scope-ops prop_6)))" +"(let-values(((current-op_0)(hash-ref ops_0 sc_20 #f)))" +"(if(if(eq? current-op_0 'flip)" +"(if(= 1(hash-count ops_0))" +"(if(not(propagation-inspector prop_6))(not(propagation-add-mpi-shifts prop_6)) #f)" +" #f)" +" #f)" +"(let-values() #f)" +"(let-values()" +"(let-values(((the-struct_25) prop_6))" +"(if(propagation? the-struct_25)" +"(let-values(((scope-ops73_0)" +"(if(eq? current-op_0 'flip)" +"(hash-remove ops_0 sc_20)" +"(hash-set" +" ops_0" +" sc_20" +"(let-values(((tmp_9) current-op_0))" +"(if(equal? tmp_9 'add)" +"(let-values() 'remove)" +"(if(equal? tmp_9 'remove)(let-values() 'add)(let-values() 'flip))))))))" +"(propagation14.1" +"(propagation-prev-scs the-struct_25)" +"(propagation-prev-smss the-struct_25)" +" scope-ops73_0" +"(propagation-prev-mss the-struct_25)" +"(propagation-add-mpi-shifts the-struct_25)" +"(propagation-inspector the-struct_25)" +"(propagation-tamper the-struct_25)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_25)))))))" +"(propagation14.1 prev-scs_2 prev-smss_2(hasheq sc_20 'flip) prev-mss_2 #f #f prop_6)))))" +"(define-values" +"(propagation-mpi-shift)" +"(lambda(prop_7 add_0 inspector_2 prev-scs_3 prev-smss_3 prev-mss_3)" +"(begin" +"(if(propagation? prop_7)" +"(let-values(((the-struct_26) prop_7))" +"(if(propagation? the-struct_26)" +"(let-values(((add-mpi-shifts74_0)" +"(let-values(((base-add_0)(propagation-add-mpi-shifts prop_7)))" +"(if(if add_0 base-add_0 #f)" +"(lambda(mss_0)(begin 'add-mpi-shifts74(add_0(base-add_0 mss_0))))" +"(let-values(((or-part_114) add_0))(if or-part_114 or-part_114 base-add_0)))))" +"((inspector75_0)" +"(let-values(((or-part_115)(propagation-inspector prop_7)))" +"(if or-part_115 or-part_115 inspector_2))))" +"(propagation14.1" +"(propagation-prev-scs the-struct_26)" +"(propagation-prev-smss the-struct_26)" +"(propagation-scope-ops the-struct_26)" +"(propagation-prev-mss the-struct_26)" +" add-mpi-shifts74_0" +" inspector75_0" +"(propagation-tamper the-struct_26)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_26)))" +"(propagation14.1 prev-scs_3 prev-smss_3 '#hasheq() prev-mss_3 add_0 inspector_2 prop_7)))))" +"(define-values" +"(propagation-apply)" +"(lambda(prop_8 scs_8 parent-s_0)" +"(begin" +"(if(eq?(propagation-prev-scs prop_8) scs_8)" +"(let-values()(syntax-scopes parent-s_0))" +"(let-values()" +"(let-values(((new-scs_0)" +"(let-values(((ht_51)(propagation-scope-ops prop_8)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_51)))" +"((letrec-values(((for-loop_60)" +"(lambda(scs_9 i_69)" +"(begin" +" 'for-loop" +"(if i_69" +"(let-values(((sc_21 op_3)" +"(unsafe-immutable-hash-iterate-key+value ht_51 i_69)))" +"(let-values(((scs_10)" +"(let-values(((scs_11) scs_9))" +"(if(not(shifted-multi-scope? sc_21))" +"(let-values(((scs_12) scs_11))" +"(let-values(((scs_13)" +"(let-values()" +"(let-values(((tmp_10) op_3))" +"(if(equal? tmp_10 'add)" +"(let-values()" +"(set-add scs_12 sc_21))" +"(if(equal?" +" tmp_10" +" 'remove)" +"(let-values()" +"(set-remove" +" scs_12" +" sc_21))" +"(let-values()" +"(set-flip" +" scs_12" +" sc_21))))))))" +"(values scs_13)))" +" scs_11))))" +"(if(not #f)" +"(for-loop_60" +" scs_10" +"(unsafe-immutable-hash-iterate-next ht_51 i_69))" +" scs_10)))" +" scs_9)))))" +" for-loop_60)" +" scs_8" +"(unsafe-immutable-hash-iterate-first ht_51))))))" +"(if(set=? new-scs_0(syntax-scopes parent-s_0))" +"(syntax-scopes parent-s_0)" +"(cache-or-reuse-set new-scs_0))))))))" +"(define-values" +"(propagation-apply-shifted)" +"(lambda(prop_9 smss_13 parent-s_1)" +"(begin" +"(if(eq?(propagation-prev-smss prop_9) smss_13)" +"(let-values()(syntax-shifted-multi-scopes parent-s_1))" +"(let-values()" +"(let-values(((new-smss_0)" +"(let-values(((ht_52)(propagation-scope-ops prop_9)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_52)))" +"((letrec-values(((for-loop_61)" +"(lambda(smss_14 i_70)" +"(begin" +" 'for-loop" +"(if i_70" +"(let-values(((sms_7 op_4)" +"(unsafe-immutable-hash-iterate-key+value ht_52 i_70)))" +"(let-values(((smss_15)" +"(let-values(((smss_16) smss_14))" +"(if(shifted-multi-scope? sms_7)" +"(let-values(((smss_17) smss_16))" +"(let-values(((smss_18)" +"(let-values()" +"(fallback-update-first" +" smss_17" +"(lambda(smss_19)" +"(let-values(((tmp_11)" +" op_4))" +"(if(equal? tmp_11 'add)" +"(let-values()" +"(set-add" +" smss_19" +" sms_7))" +"(if(equal?" +" tmp_11" +" 'remove)" +"(let-values()" +"(set-remove" +" smss_19" +" sms_7))" +"(let-values()" +"(set-flip" +" smss_19" +" sms_7))))))))))" +"(values smss_18)))" +" smss_16))))" +"(if(not #f)" +"(for-loop_61" +" smss_15" +"(unsafe-immutable-hash-iterate-next ht_52 i_70))" +" smss_15)))" +" smss_14)))))" +" for-loop_61)" +" smss_13" +"(unsafe-immutable-hash-iterate-first ht_52))))))" +"(let-values(((parent-smss_0)(syntax-shifted-multi-scopes parent-s_1)))" +"(if(if(set? new-smss_0)(if(set? parent-smss_0)(set=? new-smss_0 parent-smss_0) #f) #f)" +" parent-smss_0" +"(cache-or-reuse-hash new-smss_0)))))))))" +"(define-values" +"(propagation-apply-mpi-shifts)" +"(lambda(prop_10 mss_1 parent-s_2)" +"(begin" +"(if(eq?(propagation-prev-mss prop_10) mss_1)" +"(let-values()(syntax-mpi-shifts parent-s_2))" +"(let-values()(let-values(((add_1)(propagation-add-mpi-shifts prop_10)))(if add_1(add_1 mss_1) mss_1)))))))" +"(define-values" +"(propagation-apply-inspector)" +"(lambda(prop_11 i_71)" +"(begin(let-values(((or-part_116) i_71))(if or-part_116 or-part_116(propagation-inspector prop_11))))))" +"(define-values" +"(propagation-set-tamper)" +"(lambda(prop_12 t_35)" +"(begin" +"(if(propagation? prop_12)" +"(let-values(((the-struct_27) prop_12))" +"(if(propagation? the-struct_27)" +"(let-values(((tamper76_0) t_35))" +"(propagation14.1" +"(propagation-prev-scs the-struct_27)" +"(propagation-prev-smss the-struct_27)" +"(propagation-scope-ops the-struct_27)" +"(propagation-prev-mss the-struct_27)" +"(propagation-add-mpi-shifts the-struct_27)" +"(propagation-inspector the-struct_27)" +" tamper76_0))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_27)))" +" t_35))))" +"(define-values" +"(propagation-merge)" +"(lambda(content_7 prop_13 base-prop_0 prev-scs_4 prev-smss_4 prev-mss_4)" +"(begin" +"(if(not(datum-has-elements? content_7))" +"(let-values()(if(tamper-tainted?(propagation-tamper prop_13)) 'tainted base-prop_0))" +"(if(not(propagation? base-prop_0))" +"(let-values()" +"(if(if(eq?(propagation-prev-scs prop_13) prev-scs_4)" +"(if(eq?(propagation-prev-smss prop_13) prev-smss_4)" +"(if(eq?(propagation-prev-mss prop_13) prev-mss_4)" +"(eq?(propagation-tamper prop_13) base-prop_0)" +" #f)" +" #f)" +" #f)" +"(let-values() prop_13)" +"(let-values()" +"(propagation14.1" +" prev-scs_4" +" prev-smss_4" +"(propagation-scope-ops prop_13)" +" prev-mss_4" +"(propagation-add-mpi-shifts prop_13)" +"(propagation-inspector prop_13)" +"(if(tamper-tainted?(propagation-tamper prop_13)) 'tainted/need-propagate base-prop_0)))))" +"(let-values()" +"(let-values(((new-ops_0)" +"(let-values(((ht_53)(propagation-scope-ops prop_13)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_53)))" +"((letrec-values(((for-loop_62)" +"(lambda(ops_1 i_72)" +"(begin" +" 'for-loop" +"(if i_72" +"(let-values(((sc_22 op_5)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_53" +" i_72)))" +"(let-values(((ops_2)" +"(let-values(((ops_3) ops_1))" +"(let-values(((ops_4)" +"(let-values()" +"(let-values(((tmp_12) op_5))" +"(if(equal? tmp_12 'add)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_22" +" 'add))" +"(if(equal? tmp_12 'remove)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_22" +" 'remove))" +"(let-values()" +"(let-values(((current-op_1)" +"(hash-ref" +" ops_3" +" sc_22" +" #f)))" +"(let-values(((tmp_13)" +" current-op_1))" +"(if(equal?" +" tmp_13" +" 'add)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_22" +" 'remove))" +"(if(equal?" +" tmp_13" +" 'remove)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_22" +" 'add))" +"(if(equal?" +" tmp_13" +" 'flip)" +"(let-values()" +"(hash-remove" +" ops_3" +" sc_22))" +"(let-values()" +"(hash-set" +" ops_3" +" sc_22" +" 'flip))))))))))))))" +"(values ops_4)))))" +"(if(not #f)" +"(for-loop_62" +" ops_2" +"(unsafe-immutable-hash-iterate-next ht_53 i_72))" +" ops_2)))" +" ops_1)))))" +" for-loop_62)" +"(propagation-scope-ops base-prop_0)" +"(unsafe-immutable-hash-iterate-first ht_53))))))" +"(let-values(((add_2)(propagation-add-mpi-shifts prop_13)))" +"(let-values(((base-add_1)(propagation-add-mpi-shifts base-prop_0)))" +"(let-values(((new-tamper_0)" +"(if(let-values(((or-part_117)(tamper-tainted?(propagation-tamper prop_13))))" +"(if or-part_117 or-part_117(tamper-tainted?(propagation-tamper base-prop_0))))" +" 'tainted/need-propagate" +"(propagation-tamper base-prop_0))))" +"(if(if(zero?(hash-count new-ops_0))" +"(if(not add_2)" +"(if(not base-add_1)" +"(if(not(propagation-inspector prop_13))(not(propagation-inspector base-prop_0)) #f)" +" #f)" +" #f)" +" #f)" +" new-tamper_0" +"(let-values(((the-struct_28) base-prop_0))" +"(if(propagation? the-struct_28)" +"(let-values(((scope-ops77_0) new-ops_0)" +"((add-mpi-shifts78_0)" +"(if(if add_2 base-add_1 #f)" +"(lambda(mss_2)(begin 'add-mpi-shifts78(add_2(base-add_1 mss_2))))" +"(let-values(((or-part_118) add_2))(if or-part_118 or-part_118 base-add_1))))" +"((inspector79_0)" +"(let-values(((or-part_119)(propagation-inspector base-prop_0)))" +"(if or-part_119 or-part_119(propagation-inspector prop_13))))" +"((tamper80_0) new-tamper_0))" +"(propagation14.1" +"(propagation-prev-scs the-struct_28)" +"(propagation-prev-smss the-struct_28)" +" scope-ops77_0" +"(propagation-prev-mss the-struct_28)" +" add-mpi-shifts78_0" +" inspector79_0" +" tamper80_0))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_28))))))))))))))" +"(define-values" +"(shift-multi-scope)" +"(lambda(sms_8 delta_0)" +"(begin" +"(if(zero-phase? delta_0)" +"(let-values() sms_8)" +"(if(label-phase? delta_0)" +"(let-values()" +"(if(shifted-to-label-phase?(shifted-multi-scope-phase sms_8))" +"(let-values() #f)" +"(let-values()" +"(intern-shifted-multi-scope" +"(shifted-to-label-phase6.1(phase- 0(shifted-multi-scope-phase sms_8)))" +"(shifted-multi-scope-multi-scope sms_8)))))" +"(if(shifted-to-label-phase?(shifted-multi-scope-phase sms_8))" +"(let-values() sms_8)" +"(let-values()" +"(intern-shifted-multi-scope" +"(phase+ delta_0(shifted-multi-scope-phase sms_8))" +"(shifted-multi-scope-multi-scope sms_8)))))))))" +"(define-values" +"(syntax-shift-phase-level$1)" +"(lambda(s_135 phase_13)" +"(begin" +" 'syntax-shift-phase-level" +"(if(eqv? phase_13 0)" +" s_135" +"(let-values()" +"(let-values(((smss81_0) #f))" +"(let-values(((prev-result_1) #f))" +"(let-values(((shift-all_0)" +"(lambda(smss_20)" +"(begin" +" 'shift-all" +"(if(eq? smss81_0 smss_20)" +"(let-values() prev-result_1)" +"(let-values()" +"(let-values(((r_24)" +"(let-values()" +"(fallback-map" +" smss_20" +"(lambda(smss_21)" +"(let-values(((ht_54) smss_21))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_54)))" +"((letrec-values(((for-loop_63)" +"(lambda(table_68 i_73)" +"(begin" +" 'for-loop" +"(if i_73" +"(let-values(((sms_9)" +"(unsafe-immutable-hash-iterate-key" +" ht_54" +" i_73)))" +"(let-values(((table_69)" +"(let-values(((new-sms_0)" +"(shift-multi-scope" +" sms_9" +" phase_13)))" +"(begin" +" #t" +"((letrec-values(((for-loop_64)" +"(lambda(table_70)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_71)" +"(let-values(((table_72)" +" table_70))" +"(if new-sms_0" +"(let-values(((table_73)" +" table_72))" +"(let-values(((table_74)" +"(let-values()" +"(let-values(((key_30" +" val_18)" +"(let-values()" +"(values" +"(let-values()" +" new-sms_0)" +" #t))))" +"(hash-set" +" table_73" +" key_30" +" val_18)))))" +"(values" +" table_74)))" +" table_72))))" +" table_71))))))" +" for-loop_64)" +" table_68)))))" +"(if(not #f)" +"(for-loop_63" +" table_69" +"(unsafe-immutable-hash-iterate-next" +" ht_54" +" i_73))" +" table_69)))" +" table_68)))))" +" for-loop_63)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_54)))))))))" +"(begin(set! smss81_0 smss_20)(set! prev-result_1 r_24) r_24))))))))" +"(let-values(((s_136) s_135)" +"((f_34)(lambda(tail?_30 d_4)(begin 'f d_4)))" +"((d->s_2)" +"(lambda(s_137 d_5)" +"(begin" +" 'd->s" +"(let-values(((the-struct_29) s_137))" +"(if(syntax?$1 the-struct_29)" +"(let-values(((content82_0) d_5)" +"((shifted-multi-scopes83_0)" +"(shift-all_0(syntax-shifted-multi-scopes s_137))))" +"(syntax1.1" +" content82_0" +"(syntax-scopes the-struct_29)" +" shifted-multi-scopes83_0" +"(syntax-scope-propagations+tamper the-struct_29)" +"(syntax-mpi-shifts the-struct_29)" +"(syntax-srcloc the-struct_29)" +"(syntax-props the-struct_29)" +"(syntax-inspector the-struct_29)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_29))))))" +"((s-e_2) syntax-e/no-taint)" +"((seen_13) #f))" +"((letrec-values(((loop_74)" +"(lambda(s_138)" +"(begin" +" 'loop" +"(let-values(((s_139) s_138)" +"((f_35) f_34)" +"((gf_6)" +"(lambda(tail?_31 v_87)" +"(begin" +" 'gf" +"(if(syntax?$1 v_87)" +"(let-values()(d->s_2 v_87(loop_74(s-e_2 v_87))))" +"(let-values()(f_34 tail?_31 v_87))))))" +"((seen_14) seen_13))" +"((letrec-values(((loop_75)" +"(lambda(tail?_32 s_140 prev-depth_6)" +"(begin" +" 'loop" +"(let-values(((depth_6)(fx+ 1 prev-depth_6)))" +"(if(if seen_14(fx> depth_6 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_32" +" s_140" +"(lambda(tail?_33 s_141)(gf_6 tail?_33 s_141))" +" seen_14))" +"(if(null? s_140)" +"(let-values()(f_35 tail?_32 s_140))" +"(if(pair? s_140)" +"(let-values()" +"(f_35" +" tail?_32" +"(cons" +"(loop_75 #f(car s_140) depth_6)" +"(loop_75 #t(cdr s_140) depth_6))))" +"(if(symbol? s_140)" +"(let-values()(f_35 #f s_140))" +"(if(boolean? s_140)" +"(let-values()(f_35 #f s_140))" +"(if(number? s_140)" +"(let-values()(f_35 #f s_140))" +"(if(let-values(((or-part_120)" +"(vector? s_140)))" +"(if or-part_120" +" or-part_120" +"(let-values(((or-part_121)" +"(box? s_140)))" +"(if or-part_121" +" or-part_121" +"(let-values(((or-part_122)" +"(prefab-struct-key" +" s_140)))" +"(if or-part_122" +" or-part_122" +"(hash? s_140)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_32" +" s_140" +"(lambda(tail?_34 s_142)" +"(gf_6 tail?_34 s_142))" +" seen_14))" +"(let-values()" +"(gf_6 #f s_140))))))))))))))" +" loop_75)" +" #f" +" s_139" +" 0))))))" +" loop_74)" +" s_136))))))))))" +"(define-values" +"(syntax-swap-scopes)" +"(lambda(s_143 src-scopes_0 dest-scopes_0)" +"(begin" +"(if(equal? src-scopes_0 dest-scopes_0)" +" s_143" +"(let-values(((src-smss_0 src-scs_0)" +"(set-partition" +"(let-values(((ht_55) src-scopes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_55)))" +"((letrec-values(((for-loop_65)" +"(lambda(table_75 i_74)" +"(begin" +" 'for-loop" +"(if i_74" +"(let-values(((sc_23)" +"(unsafe-immutable-hash-iterate-key ht_55 i_74)))" +"(let-values(((table_76)" +"(let-values(((table_77) table_75))" +"(let-values(((table_78)" +"(let-values()" +"(let-values(((key_31 val_19)" +"(let-values()" +"(values" +"(let-values()" +"(generalize-scope" +" sc_23))" +" #t))))" +"(hash-set" +" table_77" +" key_31" +" val_19)))))" +"(values table_78)))))" +"(if(not #f)" +"(for-loop_65" +" table_76" +"(unsafe-immutable-hash-iterate-next ht_55 i_74))" +" table_76)))" +" table_75)))))" +" for-loop_65)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_55))))" +" shifted-multi-scope?" +"(seteq)" +"(seteq)))" +"((dest-smss_0 dest-scs_0)" +"(set-partition" +"(let-values(((ht_56) dest-scopes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_56)))" +"((letrec-values(((for-loop_66)" +"(lambda(table_79 i_75)" +"(begin" +" 'for-loop" +"(if i_75" +"(let-values(((sc_24)" +"(unsafe-immutable-hash-iterate-key ht_56 i_75)))" +"(let-values(((table_80)" +"(let-values(((table_81) table_79))" +"(let-values(((table_82)" +"(let-values()" +"(let-values(((key_32 val_20)" +"(let-values()" +"(values" +"(let-values()" +"(generalize-scope" +" sc_24))" +" #t))))" +"(hash-set" +" table_81" +" key_32" +" val_20)))))" +"(values table_82)))))" +"(if(not #f)" +"(for-loop_66" +" table_80" +"(unsafe-immutable-hash-iterate-next ht_56 i_75))" +" table_80)))" +" table_79)))))" +" for-loop_66)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_56))))" +" shifted-multi-scope?" +"(seteq)" +"(seteq))))" +"(let-values(((scs84_0) #f))" +"(let-values(((prev-result_2) #f))" +"(let-values(((swap-scs_0)" +"(lambda(scs_14)" +"(begin" +" 'swap-scs" +"(if(eq? scs84_0 scs_14)" +"(let-values() prev-result_2)" +"(let-values()" +"(let-values(((r_25)" +"(let-values()" +"(if(subset? src-scs_0 scs_14)" +"(set-union(set-subtract scs_14 src-scs_0) dest-scs_0)" +" scs_14))))" +"(begin(set! scs84_0 scs_14)(set! prev-result_2 r_25) r_25))))))))" +"(let-values(((smss85_0) #f))" +"(let-values(((prev-result_3) #f))" +"(let-values(((swap-smss_0)" +"(lambda(smss_22)" +"(begin" +" 'swap-smss" +"(if(eq? smss85_0 smss_22)" +"(let-values() prev-result_3)" +"(let-values()" +"(let-values(((r_26)" +"(let-values()" +"(fallback-update-first" +" smss_22" +"(lambda(smss_23)" +"(if(subset? src-smss_0 smss_23)" +"(set-union(set-subtract smss_23 src-smss_0) dest-smss_0)" +" smss_23))))))" +"(begin(set! smss85_0 smss_22)(set! prev-result_3 r_26) r_26))))))))" +"(let-values(((s_144) s_143)" +"((f_36)(lambda(tail?_35 d_6)(begin 'f d_6)))" +"((d->s_3)" +"(lambda(s_145 d_7)" +"(begin" +" 'd->s" +"(let-values(((the-struct_30) s_145))" +"(if(syntax?$1 the-struct_30)" +"(let-values(((content86_0) d_7)" +"((scopes87_0)(swap-scs_0(syntax-scopes s_145)))" +"((shifted-multi-scopes88_0)" +"(swap-smss_0(syntax-shifted-multi-scopes s_145))))" +"(syntax1.1" +" content86_0" +" scopes87_0" +" shifted-multi-scopes88_0" +"(syntax-scope-propagations+tamper the-struct_30)" +"(syntax-mpi-shifts the-struct_30)" +"(syntax-srcloc the-struct_30)" +"(syntax-props the-struct_30)" +"(syntax-inspector the-struct_30)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_30))))))" +"((s-e_3) syntax-e/no-taint)" +"((seen_15) #f))" +"((letrec-values(((loop_76)" +"(lambda(s_146)" +"(begin" +" 'loop" +"(let-values(((s_147) s_146)" +"((f_37) f_36)" +"((gf_7)" +"(lambda(tail?_36 v_88)" +"(begin" +" 'gf" +"(if(syntax?$1 v_88)" +"(let-values()(d->s_3 v_88(loop_76(s-e_3 v_88))))" +"(let-values()(f_36 tail?_36 v_88))))))" +"((seen_16) seen_15))" +"((letrec-values(((loop_77)" +"(lambda(tail?_37 s_148 prev-depth_7)" +"(begin" +" 'loop" +"(let-values(((depth_7)(fx+ 1 prev-depth_7)))" +"(if(if seen_16(fx> depth_7 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_37" +" s_148" +"(lambda(tail?_38 s_149)" +"(gf_7 tail?_38 s_149))" +" seen_16))" +"(if(null? s_148)" +"(let-values()(f_37 tail?_37 s_148))" +"(if(pair? s_148)" +"(let-values()" +"(f_37" +" tail?_37" +"(cons" +"(loop_77 #f(car s_148) depth_7)" +"(loop_77 #t(cdr s_148) depth_7))))" +"(if(symbol? s_148)" +"(let-values()(f_37 #f s_148))" +"(if(boolean? s_148)" +"(let-values()(f_37 #f s_148))" +"(if(number? s_148)" +"(let-values()(f_37 #f s_148))" +"(if(let-values(((or-part_123)" +"(vector? s_148)))" +"(if or-part_123" +" or-part_123" +"(let-values(((or-part_124)" +"(box? s_148)))" +"(if or-part_124" +" or-part_124" +"(let-values(((or-part_125)" +"(prefab-struct-key" +" s_148)))" +"(if or-part_125" +" or-part_125" +"(hash? s_148)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_37" +" s_148" +"(lambda(tail?_39 s_150)" +"(gf_7 tail?_39 s_150))" +" seen_16))" +"(let-values()" +"(gf_7 #f s_148))))))))))))))" +" loop_77)" +" #f" +" s_147" +" 0))))))" +" loop_76)" +" s_144)))))))))))))" +"(define-values" +"(syntax-scope-set)" +"(lambda(s_151 phase_14)" +"(begin(scope-set-at-fallback s_151(fallback-first(syntax-shifted-multi-scopes s_151)) phase_14))))" +"(define-values" +"(scope-set-at-fallback)" +"(lambda(s_152 smss_24 phase_15)" +"(begin" +"(let-values(((ht_57) smss_24))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_57)))" +"((letrec-values(((for-loop_67)" +"(lambda(scopes_9 i_76)" +"(begin" +" 'for-loop" +"(if i_76" +"(let-values(((sms_10)(unsafe-immutable-hash-iterate-key ht_57 i_76)))" +"(let-values(((scopes_10)" +"(let-values(((scopes_11) scopes_9))" +"(if(let-values(((or-part_126)(label-phase? phase_15)))" +"(if or-part_126" +" or-part_126" +"(not" +"(shifted-to-label-phase?" +"(shifted-multi-scope-phase sms_10)))))" +"(let-values(((scopes_12) scopes_11))" +"(let-values(((scopes_13)" +"(let-values()" +"(set-add" +" scopes_12" +"(multi-scope-to-scope-at-phase" +"(shifted-multi-scope-multi-scope sms_10)" +"(let-values(((ph_0)" +"(shifted-multi-scope-phase" +" sms_10)))" +"(if(shifted-to-label-phase? ph_0)" +"(shifted-to-label-phase-from ph_0)" +"(phase- ph_0 phase_15))))))))" +"(values scopes_13)))" +" scopes_11))))" +"(if(not #f)" +"(for-loop_67 scopes_10(unsafe-immutable-hash-iterate-next ht_57 i_76))" +" scopes_10)))" +" scopes_9)))))" +" for-loop_67)" +"(syntax-scopes s_152)" +"(unsafe-immutable-hash-iterate-first ht_57)))))))" +"(define-values" +"(find-max-scope)" +"(lambda(scopes_14)" +"(begin" +"(begin" +" (if (set-empty? scopes_14) (let-values () (error \"cannot bind in empty scope set\")) (void))" +"(let-values(((ht_58) scopes_14))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_58)))" +"((letrec-values(((for-loop_68)" +"(lambda(max-sc_0 i_77)" +"(begin" +" 'for-loop" +"(if i_77" +"(let-values(((sc_25)(unsafe-immutable-hash-iterate-key ht_58 i_77)))" +"(let-values(((max-sc_1)" +"(let-values(((max-sc_2) max-sc_0))" +"(let-values(((max-sc_3)" +"(let-values()" +"(if(scope>? sc_25 max-sc_2) sc_25 max-sc_2))))" +"(values max-sc_3)))))" +"(if(not #f)" +"(for-loop_68 max-sc_1(unsafe-immutable-hash-iterate-next ht_58 i_77))" +" max-sc_1)))" +" max-sc_0)))))" +" for-loop_68)" +"(set-first scopes_14)" +"(unsafe-immutable-hash-iterate-first ht_58))))))))" +"(define-values" +"(add-binding-in-scopes!20.1)" +"(lambda(just-for-nominal?15_0 scopes17_0 sym18_0 binding19_0)" +"(begin" +" 'add-binding-in-scopes!20" +"(let-values(((scopes_15) scopes17_0))" +"(let-values(((sym_16) sym18_0))" +"(let-values(((binding_3) binding19_0))" +"(let-values(((just-for-nominal?_1) just-for-nominal?15_0))" +"(let-values()" +"(let-values(((max-sc_4)(find-max-scope scopes_15)))" +"(let-values(((bt_7)" +"(binding-table-add" +"(scope-binding-table max-sc_4)" +" scopes_15" +" sym_16" +" binding_3" +" just-for-nominal?_1)))" +"(begin(set-scope-binding-table! max-sc_4 bt_7)(clear-resolve-cache! sym_16))))))))))))" +"(define-values" +"(add-bulk-binding-in-scopes!27.1)" +"(lambda(shadow-except23_0 scopes25_1 bulk-binding26_0)" +"(begin" +" 'add-bulk-binding-in-scopes!27" +"(let-values(((scopes_16) scopes25_1))" +"(let-values(((bulk-binding_0) bulk-binding26_0))" +"(let-values(((shadow-except_1) shadow-except23_0))" +"(let-values()" +"(let-values(((max-sc_5)(find-max-scope scopes_16)))" +"(let-values(((bt_8)" +"(let-values(((temp89_0)(scope-binding-table max-sc_5))" +"((scopes90_0) scopes_16)" +"((bulk-binding91_0) bulk-binding_0)" +"((shadow-except92_0) shadow-except_1))" +"(binding-table-add-bulk9.1 shadow-except92_0 temp89_0 scopes90_0 bulk-binding91_0))))" +"(begin(set-scope-binding-table! max-sc_5 bt_8)(clear-resolve-cache!)))))))))))" +"(define-values" +"(syntax-any-macro-scopes?)" +"(lambda(s_153)" +"(begin" +"(let-values(((ht_59)(syntax-scopes s_153)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_59)))" +"((letrec-values(((for-loop_69)" +"(lambda(result_43 i_78)" +"(begin" +" 'for-loop" +"(if i_78" +"(let-values(((sc_26)(unsafe-immutable-hash-iterate-key ht_59 i_78)))" +"(let-values(((result_44)" +"(let-values()" +"(let-values(((result_45)" +"(let-values()" +"(let-values()(eq?(scope-kind sc_26) 'macro)))))" +"(values result_45)))))" +"(if(if(not((lambda x_35 result_44) sc_26))(not #f) #f)" +"(for-loop_69 result_44(unsafe-immutable-hash-iterate-next ht_59 i_78))" +" result_44)))" +" result_43)))))" +" for-loop_69)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_59)))))))" +"(define-values" +"(resolve40.1)" +"(lambda(ambiguous-value30_0 exactly?31_0 extra-shifts33_0 get-scopes?32_0 s38_0 phase39_0)" +"(begin" +" 'resolve40" +"(let-values(((s_154) s38_0))" +"(let-values(((phase_16) phase39_0))" +"(let-values(((ambiguous-value_0) ambiguous-value30_0))" +"(let-values(((exactly?_0) exactly?31_0))" +"(let-values(((get-scopes?_0) get-scopes?32_0))" +"(let-values(((extra-shifts_2) extra-shifts33_0))" +"(let-values()" +"(let-values(((sym_17)(syntax-content s_154)))" +"((letrec-values(((fallback-loop_0)" +"(lambda(smss_25)" +"(begin" +" 'fallback-loop" +"(let-values(((c1_22)" +"(if(not exactly?_0)" +"(if(not get-scopes?_0)" +"(resolve-cache-get" +" sym_17" +" phase_16" +"(syntax-scopes s_154)" +"(fallback-first smss_25))" +" #f)" +" #f)))" +"(if c1_22" +"((lambda(b_40)" +"(if(eq? b_40 '#:none)" +"(let-values()" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" #f))" +"(let-values() b_40)))" +" c1_22)" +"(let-values()" +"(let-values(((scopes_17)" +"(scope-set-at-fallback" +" s_154" +"(fallback-first smss_25)" +" phase_16)))" +"(let-values(((best-scopes_0 best-binding_0)" +"(let-values(((ht_60) scopes_17))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys ht_60)))" +"((letrec-values(((for-loop_70)" +"(lambda(best-scopes_1" +" best-binding_1" +" i_79)" +"(begin" +" 'for-loop" +"(if i_79" +"(let-values(((sc_27)" +"(unsafe-immutable-hash-iterate-key" +" ht_60" +" i_79)))" +"(let-values(((best-scopes_2" +" best-binding_2)" +"(let-values(((ht_61" +" bulk-bindings_2)" +"(let-values(((table_83)" +"(scope-binding-table" +" sc_27)))" +"(if(hash?" +" table_83)" +"(values" +"(hash-ref" +" table_83" +" sym_17" +" '#hash())" +" null)" +"(values" +"(hash-ref" +"(table-with-bulk-bindings-syms" +" table_83)" +" sym_17" +" '#hash())" +"(table-with-bulk-bindings-bulk-bindings" +" table_83)))))" +"((s_155)" +" s_154)" +"((extra-shifts_3)" +" extra-shifts_2))" +"(begin" +" #t" +"((letrec-values(((for-loop_71)" +"(lambda(best-scopes_3" +" best-binding_3" +" i_80)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" i_80))" +"(let-values(((b-scopes_0)" +"(if(pair?" +" i_80)" +"(let-values()" +"(bulk-binding-at-scopes" +"(car" +" i_80)))" +"(let-values()" +"(hash-iterate-key" +" ht_61" +" i_80))))" +"((binding_4)" +"(if(pair?" +" i_80)" +"(let-values()" +"(let-values(((bulk_3)" +"(bulk-binding-at-bulk" +"(car" +" i_80))))" +"(let-values(((b-info_0)" +"(if(symbol-interned?" +" sym_17)" +"(hash-ref" +"(bulk-binding-symbols" +" bulk_3" +" s_155" +" extra-shifts_3)" +" sym_17" +" #f)" +" #f)))" +"(if b-info_0" +"((bulk-binding-create" +" bulk_3)" +" bulk_3" +" b-info_0" +" sym_17)" +" #f))))" +"(let-values()" +"(hash-iterate-value" +" ht_61" +" i_80)))))" +"(let-values(((best-scopes_4" +" best-binding_4)" +"(let-values(((best-scopes_5)" +" best-scopes_3)" +"((best-binding_5)" +" best-binding_3))" +"(if(if b-scopes_0" +"(if binding_4" +"(subset?" +" b-scopes_0" +" scopes_17)" +" #f)" +" #f)" +"(let-values(((best-scopes_6)" +" best-scopes_5)" +"((best-binding_6)" +" best-binding_5))" +"(let-values(((best-scopes_7" +" best-binding_7)" +"(let-values()" +"(if(pair?" +" best-scopes_6)" +"(let-values()" +"(if(let-values(((lst_48)" +" best-scopes_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_48)))" +"((letrec-values(((for-loop_72)" +"(lambda(result_46" +" lst_49)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_49)" +"(let-values(((amb-scopes_0)" +"(unsafe-car" +" lst_49))" +"((rest_21)" +"(unsafe-cdr" +" lst_49)))" +"(let-values(((result_47)" +"(let-values()" +"(let-values(((result_48)" +"(let-values()" +"(let-values()" +"(subset?" +" amb-scopes_0" +" b-scopes_0)))))" +"(values" +" result_48)))))" +"(if(if(not" +"((lambda x_36" +"(not" +" result_47))" +" amb-scopes_0))" +"(not" +" #f)" +" #f)" +"(for-loop_72" +" result_47" +" rest_21)" +" result_47)))" +" result_46)))))" +" for-loop_72)" +" #t" +" lst_48)))" +"(let-values()" +"(values" +" b-scopes_0" +" binding_4))" +"(let-values()" +"(values" +"(cons" +" b-scopes_0" +" best-scopes_6)" +" #f))))" +"(if(not" +" best-scopes_6)" +"(let-values()" +"(values" +" b-scopes_0" +" binding_4))" +"(if(subset?" +" b-scopes_0" +" best-scopes_6)" +"(let-values()" +"(values" +" best-scopes_6" +" best-binding_6))" +"(if(subset?" +" best-scopes_6" +" b-scopes_0)" +"(let-values()" +"(values" +" b-scopes_0" +" binding_4))" +"(let-values()" +"(values" +"(list" +" best-scopes_6" +" b-scopes_0)" +" #f)))))))))" +"(values" +" best-scopes_7" +" best-binding_7)))" +"(values" +" best-scopes_5" +" best-binding_5)))))" +"(if(not" +" #f)" +"(for-loop_71" +" best-scopes_4" +" best-binding_4" +"(if(pair?" +" i_80)" +"(let-values()" +"(cdr" +" i_80))" +"(let-values()" +"(let-values(((or-part_127)" +"(hash-iterate-next" +" ht_61" +" i_80)))" +"(if or-part_127" +" or-part_127" +" bulk-bindings_2)))))" +"(values" +" best-scopes_4" +" best-binding_4))))" +"(values" +" best-scopes_3" +" best-binding_3))))))" +" for-loop_71)" +" best-scopes_1" +" best-binding_1" +"(let-values(((or-part_128)" +"(hash-iterate-first" +" ht_61)))" +"(if or-part_128" +" or-part_128" +" bulk-bindings_2)))))))" +"(if(not #f)" +"(for-loop_70" +" best-scopes_2" +" best-binding_2" +"(unsafe-immutable-hash-iterate-next" +" ht_60" +" i_79))" +"(values" +" best-scopes_2" +" best-binding_2))))" +"(values" +" best-scopes_1" +" best-binding_1))))))" +" for-loop_70)" +" #f" +" #f" +"(unsafe-immutable-hash-iterate-first ht_60))))))" +"(if(pair? best-scopes_0)" +"(let-values()" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" ambiguous-value_0))" +"(if best-scopes_0" +"(let-values()" +"(begin" +"(resolve-cache-set!" +" sym_17" +" phase_16" +"(syntax-scopes s_154)" +"(fallback-first smss_25)" +" best-binding_0)" +"(if(let-values(((or-part_129)(not exactly?_0)))" +"(if or-part_129" +" or-part_129" +"(eqv?" +"(set-count scopes_17)" +"(set-count best-scopes_0))))" +"(if get-scopes?_0 best-scopes_0 best-binding_0)" +" #f)))" +"(let-values()" +"(begin" +"(resolve-cache-set!" +" sym_17" +" phase_16" +"(syntax-scopes s_154)" +"(fallback-first smss_25)" +" '#:none)" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" #f))))))))))))))" +" fallback-loop_0)" +"(syntax-shifted-multi-scopes s_154)))))))))))))" +"(define-values" +"(bound-identifier=?$1)" +"(lambda(a_33 b_41 phase_17)" +"(begin" +" 'bound-identifier=?" +"(if(eq?(syntax-e$1 a_33)(syntax-e$1 b_41))" +"(equal?(syntax-scope-set a_33 phase_17)(syntax-scope-set b_41 phase_17))" +" #f))))" +"(define-values" +"(local-binding?)" +"(lambda(b_42)" +"(begin(let-values(((or-part_0)(full-local-binding? b_42)))(if or-part_0 or-part_0(symbol? b_42))))))" +"(define-values" +"(struct:full-local-binding full-local-binding1.1 full-local-binding? full-local-binding-key)" +"(let-values(((struct:_30 make-_30 ?_30 -ref_30 -set!_30)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-local-binding" +" struct:full-binding" +" 1" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_43 ser-push!_13 state_23)" +"(begin" +"(ser-push!_13 'tag '#:local-binding)" +"(ser-push!_13(full-local-binding-key b_43))" +"(ser-push!_13(full-binding-free=id b_43))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'full-local-binding)))))" +"(values struct:_30 make-_30 ?_30(make-struct-field-accessor -ref_30 0 'key))))" +"(define-values" +"(deserialize-full-local-binding)" +"(lambda(key_33 free=id_3)(begin(full-local-binding1.1 #f free=id_3 key_33))))" +"(define-values" +"(make-local-binding7.1)" +"(lambda(frame-id2_0 free=id3_0 key6_0)" +"(begin" +" 'make-local-binding7" +"(let-values(((key_34) key6_0))" +"(let-values(((frame-id_2) frame-id2_0))" +"(let-values(((free=id_4) free=id3_0))" +"(let-values()" +"(if(if(not frame-id_2)(not free=id_4) #f)" +"(let-values() key_34)" +"(let-values()(full-local-binding1.1 frame-id_2 free=id_4 key_34))))))))))" +"(define-values" +"(local-binding-update17.1)" +"(lambda(frame-id11_0 free=id12_0 key10_0 b16_0)" +"(begin" +" 'local-binding-update17" +"(let-values(((b_44) b16_0))" +"(let-values(((key_35)(if(eq? key10_0 unsafe-undefined)(local-binding-key b_44) key10_0)))" +"(let-values(((frame-id_3)(if(eq? frame-id11_0 unsafe-undefined)(binding-frame-id b_44) frame-id11_0)))" +"(let-values(((free=id_5)(if(eq? free=id12_0 unsafe-undefined)(binding-free=id b_44) free=id12_0)))" +"(let-values()" +"(let-values(((key21_0) key_35)((frame-id22_0) frame-id_3)((free=id23_0) free=id_5))" +"(make-local-binding7.1 frame-id22_0 free=id23_0 key21_0))))))))))" +"(define-values" +"(local-binding-key)" +"(lambda(b_45)(begin(if(full-local-binding? b_45)(full-local-binding-key b_45) b_45))))" +"(define-values" +"(1/prop:rename-transformer 1/rename-transformer? rename-transformer-value)" +"(make-struct-type-property" +" 'rename-transformer" +"(lambda(v_28 info_1)" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)(exact-nonnegative-integer? v_28)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(identifier? v_28)))" +"(if or-part_2 or-part_2(if(procedure? v_28)(procedure-arity-includes? v_28 1) #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:rename-transformer" +"(string-append" +" \"(or/c exact-nonnegative-integer?\\n\"" +" \" identifier?\\n\"" +" \" (procedure-arity-includes? proc 1))\")" +" v_28)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? v_28)" +"(let-values()" +"(begin" +"(if(<= v_28(list-ref info_1 1))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:rename-transformer" +" \"field index >= initialized-field count for structure type\"" +" \"field index\"" +" v_28" +" \"initialized-field count\"" +"(list-ref info_1 1))))" +"(if(member v_28(list-ref info_1 5))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:rename-transformer" +" \"field index not declared immutable\"" +" \"field index\"" +" v_28)))))" +"(void))" +"(values))))" +"(let-values(((ref_0)(list-ref info_1 3)))" +"(if(identifier? v_28)" +"(let-values()(lambda(t_36) v_28))" +"(if(integer? v_28)" +"(let-values()" +"(lambda(t_37)" +"(let-values(((val_21)(ref_0 t_37 v_28)))" +"(if(identifier? val_21) val_21(datum->syntax$1 #f '?)))))" +"(let-values()" +"(lambda(t_15)" +"(let-values(((id_0)(call-with-continuation-prompt(lambda()(v_28 t_15)))))" +"(begin" +"(if(identifier? id_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'prop:rename-transformer" +" \"contract violation for given value; expected an identifier\"" +" \"given\"" +" id_0)))" +" id_0))))))))))))" +"(define-values" +"(struct:id-rename-transformer id-rename-transformer1.1 id-rename-transformer? id-rename-transformer-id)" +"(let-values(((struct:_31 make-_31 ?_31 -ref_31 -set!_31)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'rename-transformer" +" #f" +" 1" +" 0" +" #f" +"(list(cons 1/prop:rename-transformer 0))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'id-rename-transformer)))))" +"(values struct:_31 make-_31 ?_31(make-struct-field-accessor -ref_31 0 'id))))" +"(define-values" +"(1/make-rename-transformer)" +"(lambda(id_1)" +"(begin" +" 'make-rename-transformer" +"(begin" +"(if(identifier? id_1)" +"(void)" +" (let-values () (raise-argument-error 'make-rename-transformer \"identifier?\" id_1)))" +"(id-rename-transformer1.1 id_1)))))" +"(define-values" +"(1/rename-transformer-target)" +"(lambda(t_38)(begin 'rename-transformer-target((rename-transformer-value t_38) t_38))))" +"(define-values" +"(free-identifier=?$1)" +"(lambda(a_34 b_46 a-phase_0 b-phase_0)" +"(begin" +" 'free-identifier=?" +"(let-values(((ab_0)" +"(toplevel-as-symbol" +"(let-values(((a51_0) a_34)((a-phase52_0) a-phase_0)((temp53_0) #t))" +"(resolve+shift28.1 #f #f null unsafe-undefined temp53_0 a51_0 a-phase52_0)))))" +"(let-values(((bb_0)" +"(toplevel-as-symbol" +"(let-values(((b54_0) b_46)((b-phase55_0) b-phase_0)((temp56_0) #t))" +"(resolve+shift28.1 #f #f null unsafe-undefined temp56_0 b54_0 b-phase55_0)))))" +"(if(let-values(((or-part_3)(symbol? ab_0)))(if or-part_3 or-part_3(symbol? bb_0)))" +"(let-values()(eq? ab_0 bb_0))" +"(let-values()(same-binding? ab_0 bb_0))))))))" +"(define-values" +"(toplevel-as-symbol)" +"(lambda(b_47)" +"(begin" +"(if(if(module-binding? b_47)(top-level-module-path-index?(module-binding-module b_47)) #f)" +"(module-binding-sym b_47)" +" b_47))))" +"(define-values" +"(same-binding?)" +"(lambda(ab_1 bb_1)" +"(begin" +"(if(module-binding? ab_1)" +"(let-values()" +"(if(module-binding? bb_1)" +"(if(eq?(module-binding-sym ab_1)(module-binding-sym bb_1))" +"(if(eqv?(module-binding-phase ab_1)(module-binding-phase bb_1))" +"(eq?" +"(1/module-path-index-resolve(module-binding-module ab_1))" +"(1/module-path-index-resolve(module-binding-module bb_1)))" +" #f)" +" #f)" +" #f))" +"(if(local-binding? ab_1)" +"(let-values()(if(local-binding? bb_1)(eq?(local-binding-key ab_1)(local-binding-key bb_1)) #f))" +" (let-values () (error \"bad binding\" ab_1)))))))" +"(define-values" +"(same-binding-nominals?)" +"(lambda(ab_2 bb_2)" +"(begin" +"(if(eq?" +"(1/module-path-index-resolve(module-binding-nominal-module ab_2))" +"(1/module-path-index-resolve(module-binding-nominal-module bb_2)))" +"(if(eqv?(module-binding-nominal-require-phase ab_2)(module-binding-nominal-require-phase bb_2))" +"(eqv?(module-binding-nominal-sym ab_2)(module-binding-nominal-sym bb_2))" +" #f)" +" #f))))" +"(define-values" +"(identifier-binding-symbol$1)" +"(lambda(id_2 phase_18)" +"(begin" +" 'identifier-binding-symbol" +"(let-values(((b_43)" +"(let-values(((id57_0) id_2)((phase58_0) phase_18)((temp59_0) #t))" +"(resolve+shift28.1 #f #f null unsafe-undefined temp59_0 id57_0 phase58_0))))" +"(if(symbol? b_43)" +"(let-values() b_43)" +"(if(module-binding? b_43)" +"(let-values()(module-binding-sym b_43))" +"(if(local-binding? b_43)(let-values()(local-binding-key b_43))(let-values()(syntax-e$1 id_2)))))))))" +"(define-values" +"(identifier-binding$1)" +"(let-values(((identifier-binding4_0)" +"(lambda(id2_0 phase3_0 top-level-symbol?1_0)" +"(begin" +" 'identifier-binding4" +"(let-values(((id_3) id2_0))" +"(let-values(((phase_19) phase3_0))" +"(let-values(((top-level-symbol?_0) top-level-symbol?1_0))" +"(let-values()" +"(let-values(((b_48)" +"(let-values(((id60_0) id_3)((phase61_0) phase_19))" +"(resolve+shift28.1 #f #f null unsafe-undefined #f id60_0 phase61_0))))" +"(if(module-binding? b_48)" +"(let-values()" +"(if(top-level-module-path-index?(module-binding-module b_48))" +"(if top-level-symbol?_0(list(module-binding-nominal-sym b_48)) #f)" +"(list" +"(module-binding-module b_48)" +"(module-binding-sym b_48)" +"(module-binding-nominal-module b_48)" +"(module-binding-nominal-sym b_48)" +"(module-binding-phase b_48)" +"(module-binding-nominal-require-phase b_48)" +"(module-binding-nominal-phase b_48))))" +"(if(local-binding? b_48)(let-values() 'lexical)(let-values() #f))))))))))))" +"(case-lambda" +"((id_4 phase_20)(begin 'identifier-binding(identifier-binding4_0 id_4 phase_20 #f)))" +"((id_5 phase_21 top-level-symbol?1_1)(identifier-binding4_0 id_5 phase_21 top-level-symbol?1_1)))))" +"(define-values" +"(maybe-install-free=id!)" +"(lambda(val_22 id_6 phase_22)" +"(begin" +"(if(1/rename-transformer? val_22)" +"(let-values()" +"(let-values(((free=id_6)(1/rename-transformer-target val_22)))" +"(if(syntax-property$1 free=id_6 'not-free-identifier=?)" +"(void)" +"(let-values()" +"(let-values(((b_49)" +"(let-values(((id65_0) id_6)((phase66_0) phase_22)((temp67_0) #t)((temp68_0) #t))" +"(resolve+shift28.1 #f temp67_0 null temp68_0 #f id65_0 phase66_0))))" +"(let-values(((temp62_0)(syntax-scope-set id_6 phase_22))" +"((temp63_0)(syntax-e$1 id_6))" +"((temp64_0)(binding-set-free=id b_49 free=id_6)))" +"(add-binding-in-scopes!20.1 #f temp62_0 temp63_0 temp64_0)))))))" +"(void)))))" +"(define-values" +"(binding-set-free=id)" +"(lambda(b_50 free=id_7)" +"(begin" +"(if(module-binding? b_50)" +"(let-values()" +"(let-values(((b69_0) b_50)((free=id70_0) free=id_7))" +"(module-binding-update48.1" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" free=id70_0" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" b69_0)))" +"(if(local-binding? b_50)" +"(let-values()" +"(let-values(((b71_0) b_50)((free=id72_0) free=id_7))" +"(local-binding-update17.1 unsafe-undefined free=id72_0 unsafe-undefined b71_0)))" +" (let-values () (error \"bad binding for free=id:\" b_50)))))))" +"(define-values" +"(struct:non-source-shift non-source-shift6.1 non-source-shift? non-source-shift-from non-source-shift-to)" +"(let-values(((struct:_32 make-_32 ?_32 -ref_32 -set!_32)" +"(let-values()" +"(let-values()" +"(make-struct-type 'non-source-shift #f 2 0 #f null 'prefab #f '(0 1) #f 'non-source-shift)))))" +"(values" +" struct:_32" +" make-_32" +" ?_32" +"(make-struct-field-accessor -ref_32 0 'from)" +"(make-struct-field-accessor -ref_32 1 'to))))" +"(define-values(shift-from)(lambda(s_15)(begin(if(pair? s_15)(car s_15)(non-source-shift-from s_15)))))" +"(define-values(shift-to)(lambda(s_156)(begin(if(pair? s_156)(cdr s_156)(non-source-shift-to s_156)))))" +"(define-values" +"(syntax-module-path-index-shift13.1)" +"(lambda(non-source?7_0 s10_0 from-mpi11_0 to-mpi12_0 inspector9_0)" +"(begin" +" 'syntax-module-path-index-shift13" +"(let-values(((s_19) s10_0))" +"(let-values(((from-mpi_1) from-mpi11_0))" +"(let-values(((to-mpi_1) to-mpi12_0))" +"(let-values(((inspector_3) inspector9_0))" +"(let-values(((non-source?_0) non-source?7_0))" +"(let-values()" +"(if(eq? from-mpi_1 to-mpi_1)" +"(let-values()(if inspector_3(syntax-set-inspector s_19 inspector_3) s_19))" +"(let-values()" +"(let-values(((shift_0)" +"(if non-source?_0" +"(non-source-shift6.1 from-mpi_1 to-mpi_1)" +"(cons from-mpi_1 to-mpi_1))))" +"(let-values(((the-struct_31) s_19))" +"(if(syntax?$1 the-struct_31)" +"(let-values(((mpi-shifts74_0)(shift-cons shift_0(syntax-mpi-shifts s_19)))" +"((inspector75_1)" +"(let-values(((or-part_130)(syntax-inspector s_19)))" +"(if or-part_130 or-part_130 inspector_3)))" +"((scope-propagations+tamper76_0)" +"(if(datum-has-elements?(syntax-content s_19))" +"(propagation-mpi-shift" +"(syntax-scope-propagations+tamper s_19)" +"(lambda(s_157)(shift-cons shift_0 s_157))" +" inspector_3" +"(syntax-scopes s_19)" +"(syntax-shifted-multi-scopes s_19)" +"(syntax-mpi-shifts s_19))" +"(syntax-scope-propagations+tamper s_19))))" +"(syntax1.1" +"(syntax-content the-struct_31)" +"(syntax-scopes the-struct_31)" +"(syntax-shifted-multi-scopes the-struct_31)" +" scope-propagations+tamper76_0" +" mpi-shifts74_0" +"(syntax-srcloc the-struct_31)" +"(syntax-props the-struct_31)" +" inspector75_1))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_31)))))))))))))))" +"(define-values" +"(shift-cons)" +"(lambda(shift_1 shifts_0)" +"(begin" +"(if(if(pair? shifts_0)(eq?(shift-from shift_1)(shift-from(car shifts_0))) #f)" +"(let-values() shifts_0)" +"(let-values()(cons shift_1 shifts_0))))))" +"(define-values" +"(resolve+shift28.1)" +"(lambda(ambiguous-value16_0 exactly?17_0 extra-shifts20_0 immediate?18_0 unbound-sym?19_0 s26_0 phase27_0)" +"(begin" +" 'resolve+shift28" +"(let-values(((s_158) s26_0))" +"(let-values(((phase_23) phase27_0))" +"(let-values(((ambiguous-value_1) ambiguous-value16_0))" +"(let-values(((exactly?_1) exactly?17_0))" +"(let-values(((immediate?_0)(if(eq? immediate?18_0 unsafe-undefined) exactly?_1 immediate?18_0)))" +"(let-values(((unbound-sym?_0) unbound-sym?19_0))" +"(let-values(((extra-shifts_4) extra-shifts20_0))" +"(let-values()" +"(let-values(((can-cache?_0)" +"(if(not exactly?_1)(if(not immediate?_0)(null? extra-shifts_4) #f) #f)))" +"(let-values(((c1_23)(if can-cache?_0(resolve+shift-cache-get s_158 phase_23) #f)))" +"(if c1_23" +"((lambda(b_51)(if(eq? b_51 '#:none)(if unbound-sym?_0(syntax-content s_158) #f) b_51))" +" c1_23)" +"(let-values()" +"(let-values(((immediate-b_0)" +"(let-values(((s77_0) s_158)" +"((phase78_0) phase_23)" +"((ambiguous-value79_0) ambiguous-value_1)" +"((exactly?80_0) exactly?_1)" +"((extra-shifts81_0) extra-shifts_4))" +"(resolve40.1" +" ambiguous-value79_0" +" exactly?80_0" +" extra-shifts81_0" +" #f" +" s77_0" +" phase78_0))))" +"(let-values(((b_52)" +"(if(if immediate-b_0" +"(if(not immediate?_0)(binding-free=id immediate-b_0) #f)" +" #f)" +"(let-values(((temp82_0)(binding-free=id immediate-b_0))" +"((phase83_0) phase_23)" +"((temp84_0)" +"(append extra-shifts_4(syntax-mpi-shifts s_158)))" +"((ambiguous-value85_0) ambiguous-value_1)" +"((exactly?86_0) exactly?_1)" +"((unbound-sym?87_0) unbound-sym?_0))" +"(resolve+shift28.1" +" ambiguous-value85_0" +" exactly?86_0" +" temp84_0" +" unsafe-undefined" +" unbound-sym?87_0" +" temp82_0" +" phase83_0))" +" immediate-b_0)))" +"(if(module-binding? b_52)" +"(let-values()" +"(let-values(((mpi-shifts_2)(syntax-mpi-shifts s_158)))" +"(if(null? mpi-shifts_2)" +"(let-values() b_52)" +"(let-values()" +"(let-values(((mod_0)(module-binding-module b_52)))" +"(let-values(((shifted-mod_0)(apply-syntax-shifts mod_0 mpi-shifts_2)))" +"(let-values(((nominal-mod_0)(module-binding-nominal-module b_52)))" +"(let-values(((shifted-nominal-mod_0)" +"(if(eq? mod_0 nominal-mod_0)" +" shifted-mod_0" +"(apply-syntax-shifts nominal-mod_0 mpi-shifts_2))))" +"(let-values(((result-b_0)" +"(if(if(eq? mod_0 shifted-mod_0)" +"(if(eq? nominal-mod_0 shifted-nominal-mod_0)" +"(if(not(binding-free=id b_52))" +"(null?" +"(module-binding-extra-nominal-bindings" +" b_52))" +" #f)" +" #f)" +" #f)" +" b_52" +"(let-values(((b88_0) b_52)" +"((shifted-mod89_0) shifted-mod_0)" +"((shifted-nominal-mod90_0)" +" shifted-nominal-mod_0)" +"((temp91_0)" +"(if(binding-free=id b_52)" +"(let-values(((temp93_0)" +"(binding-free=id" +" b_52))" +"((s94_0) s_158))" +"(syntax-transfer-shifts36.1" +" #f" +" temp93_0" +" s94_0" +" #f))" +" #f))" +"((temp92_0)" +"(reverse$1" +"(let-values(((lst_50)" +"(module-binding-extra-nominal-bindings" +" b_52)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_50)))" +"((letrec-values(((for-loop_73)" +"(lambda(fold-var_35" +" lst_51)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_51)" +"(let-values(((b_53)" +"(unsafe-car" +" lst_51))" +"((rest_22)" +"(unsafe-cdr" +" lst_51)))" +"(let-values(((fold-var_36)" +"(let-values(((fold-var_37)" +" fold-var_35))" +"(let-values(((fold-var_38)" +"(let-values()" +"(cons" +"(let-values()" +"(apply-syntax-shifts-to-binding" +" b_53" +" mpi-shifts_2))" +" fold-var_37))))" +"(values" +" fold-var_38)))))" +"(if(not" +" #f)" +"(for-loop_73" +" fold-var_36" +" rest_22)" +" fold-var_36)))" +" fold-var_35)))))" +" for-loop_73)" +" null" +" lst_50))))))" +"(module-binding-update48.1" +" unsafe-undefined" +" temp92_0" +" unsafe-undefined" +" temp91_0" +" shifted-mod89_0" +" shifted-nominal-mod90_0" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" b88_0)))))" +"(begin" +"(if can-cache?_0" +"(let-values()" +"(resolve+shift-cache-set! s_158 phase_23 result-b_0))" +"(void))" +" result-b_0))))))))))" +"(let-values()" +"(begin" +"(if can-cache?_0" +"(let-values()" +"(resolve+shift-cache-set!" +" s_158" +" phase_23" +"(let-values(((or-part_131) b_52))(if or-part_131 or-part_131 '#:none))))" +"(void))" +"(let-values(((or-part_132) b_52))" +"(if or-part_132" +" or-part_132" +"(if unbound-sym?_0(syntax-content s_158) #f)))))))))))))))))))))))" +"(define-values" +"(apply-syntax-shifts)" +"(lambda(mpi_12 shifts_1)" +"(begin" +"(if(null? shifts_1)" +"(let-values() mpi_12)" +"(let-values()" +"(let-values(((shifted-mpi_1)(apply-syntax-shifts mpi_12(cdr shifts_1))))" +"(let-values(((shift_2)(car shifts_1)))" +"(module-path-index-shift shifted-mpi_1(shift-from shift_2)(shift-to shift_2)))))))))" +"(define-values" +"(apply-syntax-shifts-to-binding)" +"(lambda(b_54 shifts_2)" +"(begin" +"(if(null? shifts_2)" +"(let-values() b_54)" +"(let-values()" +"(let-values(((shifted-b_0)(apply-syntax-shifts-to-binding b_54(cdr shifts_2))))" +"(let-values(((shift_3)(car shifts_2)))" +"(binding-module-path-index-shift shifted-b_0(shift-from shift_3)(shift-to shift_3)))))))))" +"(define-values" +"(binding-module-path-index-shift)" +"(lambda(b_55 from-mpi_2 to-mpi_2)" +"(begin" +"(if(module-binding? b_55)" +"(let-values()" +"(let-values(((b95_0) b_55)" +"((temp96_0)(module-path-index-shift(module-binding-module b_55) from-mpi_2 to-mpi_2))" +"((temp97_0)(module-path-index-shift(module-binding-nominal-module b_55) from-mpi_2 to-mpi_2))" +"((temp98_0)" +"(reverse$1" +"(let-values(((lst_52)(module-binding-extra-nominal-bindings b_55)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_52)))" +"((letrec-values(((for-loop_74)" +"(lambda(fold-var_39 lst_53)" +"(begin" +" 'for-loop" +"(if(pair? lst_53)" +"(let-values(((b_56)(unsafe-car lst_53))" +"((rest_23)(unsafe-cdr lst_53)))" +"(let-values(((fold-var_40)" +"(let-values(((fold-var_41) fold-var_39))" +"(let-values(((fold-var_42)" +"(let-values()" +"(cons" +"(let-values()" +"(binding-module-path-index-shift" +" b_56" +" from-mpi_2" +" to-mpi_2))" +" fold-var_41))))" +"(values fold-var_42)))))" +"(if(not #f)(for-loop_74 fold-var_40 rest_23) fold-var_40)))" +" fold-var_39)))))" +" for-loop_74)" +" null" +" lst_52))))))" +"(module-binding-update48.1" +" unsafe-undefined" +" temp98_0" +" unsafe-undefined" +" unsafe-undefined" +" temp96_0" +" temp97_0" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" b95_0)))" +"(let-values() b_55)))))" +"(define-values" +"(syntax-transfer-shifts36.1)" +"(lambda(non-source?31_0 to-s34_0 from-s35_0 inspector33_0)" +"(begin" +" 'syntax-transfer-shifts36" +"(let-values(((to-s_0) to-s34_0))" +"(let-values(((from-s_1) from-s35_0))" +"(let-values(((inspector_4) inspector33_0))" +"(let-values(((non-source?_1) non-source?31_0))" +"(let-values()" +"(let-values(((to-s99_0) to-s_0)" +"((temp100_0)(syntax-mpi-shifts from-s_1))" +"((inspector101_0) inspector_4)" +"((non-source?102_0) non-source?_1))" +"(syntax-add-shifts44.1 non-source?102_0 to-s99_0 temp100_0 inspector101_0))))))))))" +"(define-values" +"(syntax-add-shifts44.1)" +"(lambda(non-source?39_0 to-s42_0 shifts43_0 inspector41_0)" +"(begin" +" 'syntax-add-shifts44" +"(let-values(((to-s_1) to-s42_0))" +"(let-values(((shifts_3) shifts43_0))" +"(let-values(((inspector_5) inspector41_0))" +"(let-values(((non-source?_2) non-source?39_0))" +"(let-values()" +"(if(if(null? shifts_3) inspector_5 #f)" +"(let-values()(syntax-set-inspector to-s_1 inspector_5))" +"(let-values()" +"(let-values(((lst_54)(reverse$1 shifts_3))((start_12) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_54)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_12)))" +"((letrec-values(((for-loop_75)" +"(lambda(s_159 lst_55 pos_10)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_55) #t #f)" +"(let-values(((shift_4)(unsafe-car lst_55))" +"((rest_24)(unsafe-cdr lst_55))" +"((i_81) pos_10))" +"(let-values(((s_160)" +"(let-values(((s_103) s_159))" +"(let-values(((s_104)" +"(let-values()" +"(let-values(((s103_0) s_103)" +"((temp104_0)" +"(shift-from shift_4))" +"((temp105_0)" +"(shift-to shift_4))" +"((temp106_0)" +"(if(zero? i_81)" +" inspector_5" +" #f))" +"((non-source?107_0)" +" non-source?_2))" +"(syntax-module-path-index-shift13.1" +" non-source?107_0" +" s103_0" +" temp104_0" +" temp105_0" +" temp106_0)))))" +"(values s_104)))))" +"(if(not #f)(for-loop_75 s_160 rest_24(+ pos_10 1)) s_160)))" +" s_159)))))" +" for-loop_75)" +" to-s_1" +" lst_54" +" start_12)))))))))))))" +"(define-values" +"(syntax-set-inspector)" +"(lambda(s_161 insp_3)" +"(begin" +"(let-values(((the-struct_32) s_161))" +"(if(syntax?$1 the-struct_32)" +"(let-values(((inspector108_0)" +"(let-values(((or-part_133)(syntax-inspector s_161)))(if or-part_133 or-part_133 insp_3)))" +"((scope-propagations+tamper109_0)" +"(if(datum-has-elements?(syntax-content s_161))" +"(propagation-mpi-shift" +"(syntax-scope-propagations+tamper s_161)" +" #f" +" insp_3" +"(syntax-scopes s_161)" +"(syntax-shifted-multi-scopes s_161)" +"(syntax-mpi-shifts s_161))" +"(syntax-scope-propagations+tamper s_161))))" +"(syntax1.1" +"(syntax-content the-struct_32)" +"(syntax-scopes the-struct_32)" +"(syntax-shifted-multi-scopes the-struct_32)" +" scope-propagations+tamper109_0" +"(syntax-mpi-shifts the-struct_32)" +"(syntax-srcloc the-struct_32)" +"(syntax-props the-struct_32)" +" inspector108_0))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_32))))))" +"(define-values" +"(1/syntax-source-module)" +"(let-values(((syntax-source-module49_0)" +"(lambda(s48_0 source?47_0)" +"(begin" +" 'syntax-source-module49" +"(let-values(((s_162) s48_0))" +"(let-values(((source?_0) source?47_0))" +"(let-values()" +"(begin" +"(if(syntax?$1 s_162)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" s_162)))" +"(let-values(((lst_56)(reverse$1(syntax-mpi-shifts s_162))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_56)))" +"((letrec-values(((for-loop_76)" +"(lambda(result_49 lst_57)" +"(begin" +" 'for-loop" +"(if(pair? lst_57)" +"(let-values(((shift_5)(unsafe-car lst_57))" +"((rest_25)(unsafe-cdr lst_57)))" +"(let-values(((result_50)" +"(let-values(((result_51) result_49))" +"(if(non-source-shift? shift_5)" +" result_51" +"(let-values()" +"(let-values(((result_52)" +"(let-values()" +"(let-values()" +"(let-values(((from-mpi_3)" +"(car" +" shift_5)))" +"(let-values(((path_5" +" base_14)" +"(1/module-path-index-split" +" from-mpi_3)))" +"(if(not path_5)" +"(if(module-path-index-resolved" +" from-mpi_3)" +"(let-values(((mpi_13)" +"(apply-syntax-shifts" +" from-mpi_3" +"(syntax-mpi-shifts" +" s_162))))" +"(if source?_0" +"(1/resolved-module-path-name" +"(1/module-path-index-resolve" +" mpi_13" +" #f))" +" mpi_13))" +" #f)" +" #f)))))))" +"(values result_52)))))))" +"(if(if(not((lambda x_37 result_50) shift_5))(not #f) #f)" +"(for-loop_76 result_50 rest_25)" +" result_50)))" +" result_49)))))" +" for-loop_76)" +" #f" +" lst_56)))))))))))" +"(case-lambda" +"((s_163)(begin 'syntax-source-module(syntax-source-module49_0 s_163 #f)))" +"((s_164 source?47_1)(syntax-source-module49_0 s_164 source?47_1)))))" +"(define-values" +"(1/identifier-prune-to-source-module)" +"(lambda(id_7)" +"(begin" +" 'identifier-prune-to-source-module" +"(begin" +"(if(identifier? id_7)" +"(void)" +" (let-values () (raise-argument-error 'identifier-prune-to-source-module \"identifier?\" id_7)))" +"(let-values(((the-struct_33)(datum->syntax$1 #f(syntax-e$1 id_7) id_7 id_7)))" +"(if(syntax?$1 the-struct_33)" +"(let-values(((mpi-shifts110_0)(syntax-mpi-shifts id_7)))" +"(syntax1.1" +"(syntax-content the-struct_33)" +"(syntax-scopes the-struct_33)" +"(syntax-shifted-multi-scopes the-struct_33)" +"(syntax-scope-propagations+tamper the-struct_33)" +" mpi-shifts110_0" +"(syntax-srcloc the-struct_33)" +"(syntax-props the-struct_33)" +"(syntax-inspector the-struct_33)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_33)))))))" +"(define-values" +"(struct:provided provided1.1 provided? provided-binding provided-protected? provided-syntax?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'provided" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(p_31 ser-push!_14 state_24)" +"(begin" +"(ser-push!_14 'tag '#:provided)" +"(ser-push!_14(provided-binding p_31))" +"(ser-push!_14(provided-protected? p_31))" +"(ser-push!_14(provided-syntax? p_31))))))" +" #f" +" #f" +" '(0 1 2)" +" #f" +" 'provided)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'binding)" +"(make-struct-field-accessor -ref_0 1 'protected?)" +"(make-struct-field-accessor -ref_0 2 'syntax?))))" +"(define-values(provided-as-binding)(lambda(v_89)(begin(if(provided? v_89)(provided-binding v_89) v_89))))" +"(define-values(provided-as-protected?)(lambda(v_5)(begin(if(provided? v_5)(provided-protected? v_5) #f))))" +"(define-values(provided-as-transformer?)(lambda(v_90)(begin(if(provided? v_90)(provided-syntax? v_90) #f))))" +"(define-values" +"(deserialize-provided)" +"(lambda(binding_5 protected?_0 syntax?_1)(begin(provided1.1 binding_5 protected?_0 syntax?_1))))" +"(define-values" +"(provide-binding-to-require-binding11.1)" +"(lambda(mpi2_0 phase-shift4_0 provide-phase-level3_0 self1_0 binding/p9_0 sym10_0)" +"(begin" +" 'provide-binding-to-require-binding11" +"(let-values(((binding/p_0) binding/p9_0))" +"(let-values(((sym_18) sym10_0))" +"(let-values(((self_1) self1_0))" +"(let-values(((mpi_14) mpi2_0))" +"(let-values(((provide-phase-level_0) provide-phase-level3_0))" +"(let-values(((phase-shift_0) phase-shift4_0))" +"(let-values()" +"(let-values(((binding_6)(provided-as-binding binding/p_0)))" +"(let-values(((from-mod_0)(module-binding-module binding_6)))" +"(let-values(((binding17_0) binding_6)" +"((temp18_1)(module-path-index-shift from-mod_0 self_1 mpi_14))" +"((mpi19_0) mpi_14)" +"((provide-phase-level20_0) provide-phase-level_0)" +"((sym21_1) sym_18)" +"((phase-shift22_0) phase-shift_0)" +"((temp23_1) #f)" +"((temp24_1)" +"(if(not(provided-as-protected? binding/p_0))" +"(module-binding-extra-inspector binding_6)" +" #f))" +"((null25_0) null))" +"(module-binding-update48.1" +" temp24_1" +" null25_0" +" temp23_1" +" unsafe-undefined" +" temp18_1" +" mpi19_0" +" provide-phase-level20_0" +" phase-shift22_0" +" sym21_1" +" unsafe-undefined" +" unsafe-undefined" +" binding17_0))))))))))))))" +"(define-values" +"(struct:bulk-binding" +" bulk-binding14.1" +" bulk-binding?" +" bulk-binding-provides" +" bulk-binding-prefix" +" bulk-binding-excepts" +" bulk-binding-self" +" bulk-binding-mpi" +" bulk-binding-provide-phase-level" +" bulk-binding-phase-shift" +" bulk-binding-bulk-binding-registry" +" set-bulk-binding-provides!" +" set-bulk-binding-self!)" +"(let-values(((struct:_33 make-_33 ?_33 -ref_33 -set!_33)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding" +" #f" +" 8" +" 0" +" #f" +"(list" +"(cons" +" prop:serialize" +"(lambda(b_18 ser-push!_15 reachable-scopes_3)" +"(begin" +"(ser-push!_15 'tag '#:bulk-binding)" +"(ser-push!_15(bulk-binding-prefix b_18))" +"(ser-push!_15(bulk-binding-excepts b_18))" +"(ser-push!_15(bulk-binding-mpi b_18))" +"(ser-push!_15(bulk-binding-provide-phase-level b_18))" +"(ser-push!_15(bulk-binding-phase-shift b_18))" +"(ser-push!_15 'tag '#:bulk-binding-registry))))" +"(cons" +" prop:bulk-binding" +"(bulk-binding-class3.1" +"(lambda(b_57 mpi-shifts_3)" +"(let-values(((or-part_134)(bulk-binding-provides b_57)))" +"(if or-part_134" +" or-part_134" +"(let-values(((mod-name_1)" +"(1/module-path-index-resolve" +"(apply-syntax-shifts(bulk-binding-mpi b_57) mpi-shifts_3))))" +"(let-values((()" +"(begin" +"(if(bulk-binding-bulk-binding-registry b_57)" +"(void)" +"(let-values()" +"(error" +" \"namespace mismatch: no bulk-binding registry available:\"" +" mod-name_1)))" +"(values))))" +"(let-values(((table_84)" +"(bulk-binding-registry-table" +"(bulk-binding-bulk-binding-registry b_57))))" +"(let-values(((bulk-provide_0)(hash-ref table_84 mod-name_1 #f)))" +"(let-values((()" +"(begin" +"(if bulk-provide_0" +"(void)" +"(let-values()" +"(error" +" \"namespace mismatch: bulk bindings not found in registry for module:\"" +" mod-name_1)))" +"(values))))" +"(let-values((()" +"(begin" +"(set-bulk-binding-self! b_57(bulk-provide-self bulk-provide_0))" +"(values))))" +"(let-values(((provides_0)" +"(hash-ref" +"(bulk-provide-provides bulk-provide_0)" +"(bulk-binding-provide-phase-level b_57))))" +"(let-values(((excepts_0)(bulk-binding-excepts b_57)))" +"(let-values(((prefix_0)(bulk-binding-prefix b_57)))" +"(let-values(((adjusted-provides_0)" +"(if(let-values(((or-part_135) prefix_0))" +"(if or-part_135" +" or-part_135" +"(positive?(hash-count excepts_0))))" +"(let-values()" +"(bulk-provides-add-prefix-remove-exceptions" +" provides_0" +" prefix_0" +" excepts_0))" +"(let-values() provides_0))))" +"(begin" +"(set-bulk-binding-provides! b_57 adjusted-provides_0)" +" adjusted-provides_0))))))))))))))" +"(lambda(b_58 binding_7 sym_19)" +"(let-values(((binding27_0) binding_7)" +"((temp28_1)" +"(if(bulk-binding-prefix b_58)" +"(string->symbol" +"(substring" +"(symbol->string sym_19)" +"(string-length(symbol->string(bulk-binding-prefix b_58)))))" +" sym_19))" +"((temp29_0)(bulk-binding-self b_58))" +"((temp30_0)(bulk-binding-mpi b_58))" +"((temp31_0)(bulk-binding-provide-phase-level b_58))" +"((temp32_0)(bulk-binding-phase-shift b_58)))" +"(provide-binding-to-require-binding11.1" +" temp30_0" +" temp32_0" +" temp31_0" +" temp29_0" +" binding27_0" +" temp28_1))))))" +"(current-inspector)" +" #f" +" '(1 2 4 5 6 7)" +" #f" +" 'bulk-binding)))))" +"(values" +" struct:_33" +" make-_33" +" ?_33" +"(make-struct-field-accessor -ref_33 0 'provides)" +"(make-struct-field-accessor -ref_33 1 'prefix)" +"(make-struct-field-accessor -ref_33 2 'excepts)" +"(make-struct-field-accessor -ref_33 3 'self)" +"(make-struct-field-accessor -ref_33 4 'mpi)" +"(make-struct-field-accessor -ref_33 5 'provide-phase-level)" +"(make-struct-field-accessor -ref_33 6 'phase-shift)" +"(make-struct-field-accessor -ref_33 7 'bulk-binding-registry)" +"(make-struct-field-mutator -set!_33 0 'provides)" +"(make-struct-field-mutator -set!_33 3 'self))))" +"(define-values" +"(deserialize-bulk-binding)" +"(lambda(prefix_1 excepts_1 mpi_3 provide-phase-level_1 phase-shift_1 bulk-binding-registry_0)" +"(begin" +"(bulk-binding14.1 #f prefix_1 excepts_1 #f mpi_3 provide-phase-level_1 phase-shift_1 bulk-binding-registry_0))))" +"(define-values" +"(bulk-provides-add-prefix-remove-exceptions)" +"(lambda(provides_1 prefix_2 excepts_2)" +"(begin" +"(let-values(((ht_62) provides_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_62)))" +"((letrec-values(((for-loop_77)" +"(lambda(table_85 i_82)" +"(begin" +" 'for-loop" +"(if i_82" +"(let-values(((sym_20 val_23)(hash-iterate-key+value ht_62 i_82)))" +"(let-values(((table_86)" +"(let-values(((table_87) table_85))" +"(if(hash-ref excepts_2 sym_20 #f)" +" table_87" +"(let-values(((table_88) table_87))" +"(if(symbol-interned? sym_20)" +"(let-values(((table_89) table_88))" +"(let-values(((table_90)" +"(let-values()" +"(let-values(((key_36 val_24)" +"(let-values()" +"(values" +"(if prefix_2" +"(string->symbol" +"(format" +" \"~a~a\"" +" prefix_2" +" sym_20))" +" sym_20)" +" val_23))))" +"(hash-set table_89 key_36 val_24)))))" +"(values table_90)))" +" table_88))))))" +"(if(not #f)(for-loop_77 table_86(hash-iterate-next ht_62 i_82)) table_86)))" +" table_85)))))" +" for-loop_77)" +" '#hash()" +"(hash-iterate-first ht_62)))))))" +"(define-values" +"(struct:bulk-provide bulk-provide15.1 bulk-provide? bulk-provide-self bulk-provide-provides)" +"(let-values(((struct:_34 make-_34 ?_34 -ref_34 -set!_34)" +"(let-values()" +"(let-values()" +"(make-struct-type 'bulk-provide #f 2 0 #f null(current-inspector) #f '(0 1) #f 'bulk-provide)))))" +"(values" +" struct:_34" +" make-_34" +" ?_34" +"(make-struct-field-accessor -ref_34 0 'self)" +"(make-struct-field-accessor -ref_34 1 'provides))))" +"(define-values" +"(struct:bulk-binding-registry bulk-binding-registry16.1 bulk-binding-registry? bulk-binding-registry-table)" +"(let-values(((struct:_35 make-_35 ?_35 -ref_35 -set!_35)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-registry" +" #f" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'bulk-binding-registry)))))" +"(values struct:_35 make-_35 ?_35(make-struct-field-accessor -ref_35 0 'table))))" +"(define-values(make-bulk-binding-registry)(lambda()(begin(bulk-binding-registry16.1(make-hasheq)))))" +"(define-values" +"(register-bulk-provide!)" +"(lambda(bulk-binding-registry_1 mod-name_2 self_2 provides_2)" +"(begin" +"(hash-set!" +"(bulk-binding-registry-table bulk-binding-registry_1)" +" mod-name_2" +"(bulk-provide15.1 self_2 provides_2)))))" +"(define-values" +"(registered-bulk-provide?)" +"(lambda(bulk-binding-registry_2 mod-name_3)" +"(begin(if(hash-ref(bulk-binding-registry-table bulk-binding-registry_2) mod-name_3 #f) #t #f))))" +"(define-values(generate-lift-key)(lambda()(begin(gensym 'lift))))" +"(define-values" +"(struct:root-expand-context/outer" +" root-expand-context/outer1.1" +" root-expand-context/outer?" +" root-expand-context/outer-inner" +" root-expand-context/outer-post-expansion" +" root-expand-context/outer-use-site-scopes" +" root-expand-context/outer-frame-id)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'root-expand-context" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'root-expand-context/outer)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'inner)" +"(make-struct-field-accessor -ref_36 1 'post-expansion)" +"(make-struct-field-accessor -ref_36 2 'use-site-scopes)" +"(make-struct-field-accessor -ref_36 3 'frame-id))))" +"(define-values" +"(struct:root-expand-context/inner" +" root-expand-context/inner2.1" +" root-expand-context/inner?" +" root-expand-context/inner-self-mpi" +" root-expand-context/inner-module-scopes" +" root-expand-context/inner-top-level-bind-scope" +" root-expand-context/inner-all-scopes-stx" +" root-expand-context/inner-defined-syms" +" root-expand-context/inner-counter" +" root-expand-context/inner-lift-key)" +"(let-values(((struct:_9 make-_9 ?_9 -ref_9 -set!_9)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'root-expand-context/inner" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'root-expand-context/inner)))))" +"(values" +" struct:_9" +" make-_9" +" ?_9" +"(make-struct-field-accessor -ref_9 0 'self-mpi)" +"(make-struct-field-accessor -ref_9 1 'module-scopes)" +"(make-struct-field-accessor -ref_9 2 'top-level-bind-scope)" +"(make-struct-field-accessor -ref_9 3 'all-scopes-stx)" +"(make-struct-field-accessor -ref_9 4 'defined-syms)" +"(make-struct-field-accessor -ref_9 5 'counter)" +"(make-struct-field-accessor -ref_9 6 'lift-key))))" +"(define-values" +"(root-expand-context/make)" +"(lambda(self-mpi_0" +" module-scopes_0" +" post-expansion_0" +" top-level-bind-scope_0" +" all-scopes-stx_0" +" use-site-scopes_0" +" defined-syms_0" +" frame-id_4" +" counter_0" +" lift-key_0)" +"(begin" +"(root-expand-context/outer1.1" +"(root-expand-context/inner2.1" +" self-mpi_0" +" module-scopes_0" +" top-level-bind-scope_0" +" all-scopes-stx_0" +" defined-syms_0" +" counter_0" +" lift-key_0)" +" post-expansion_0" +" use-site-scopes_0" +" frame-id_4))))" +"(define-values" +"(root-expand-context-post-expansion)" +"(lambda(v_91)(begin(root-expand-context/outer-post-expansion v_91))))" +"(define-values" +"(root-expand-context-use-site-scopes)" +"(lambda(v_92)(begin(root-expand-context/outer-use-site-scopes v_92))))" +"(define-values(root-expand-context-frame-id)(lambda(v_47)(begin(root-expand-context/outer-frame-id v_47))))" +"(define-values" +"(root-expand-context-self-mpi)" +"(lambda(v_65)(begin(root-expand-context/inner-self-mpi(root-expand-context/outer-inner v_65)))))" +"(define-values" +"(root-expand-context-module-scopes)" +"(lambda(v_48)(begin(root-expand-context/inner-module-scopes(root-expand-context/outer-inner v_48)))))" +"(define-values" +"(root-expand-context-top-level-bind-scope)" +"(lambda(v_93)(begin(root-expand-context/inner-top-level-bind-scope(root-expand-context/outer-inner v_93)))))" +"(define-values" +"(root-expand-context-all-scopes-stx)" +"(lambda(v_49)(begin(root-expand-context/inner-all-scopes-stx(root-expand-context/outer-inner v_49)))))" +"(define-values" +"(root-expand-context-defined-syms)" +"(lambda(v_94)(begin(root-expand-context/inner-defined-syms(root-expand-context/outer-inner v_94)))))" +"(define-values" +"(root-expand-context-counter)" +"(lambda(v_42)(begin(root-expand-context/inner-counter(root-expand-context/outer-inner v_42)))))" +"(define-values" +"(root-expand-context-lift-key)" +"(lambda(v_95)(begin(root-expand-context/inner-lift-key(root-expand-context/outer-inner v_95)))))" +"(define-values" +"(make-root-expand-context13.1)" +"(lambda(all-scopes-stx7_0 initial-scopes4_0 outside-scope5_0 post-expansion-scope6_0 self-mpi3_0)" +"(begin" +" 'make-root-expand-context13" +"(let-values(((self-mpi_1) self-mpi3_0))" +"(let-values(((initial-scopes_0) initial-scopes4_0))" +"(let-values(((outside-scope_0)" +"(if(eq? outside-scope5_0 unsafe-undefined) top-level-common-scope outside-scope5_0)))" +"(let-values(((post-expansion-scope_0)" +"(if(eq? post-expansion-scope6_0 unsafe-undefined)" +"(new-multi-scope 'top-level)" +" post-expansion-scope6_0)))" +"(let-values(((all-scopes-stx_1) all-scopes-stx7_0))" +"(let-values()" +"(let-values(((module-scopes_1)(list* post-expansion-scope_0 outside-scope_0 initial-scopes_0)))" +"(root-expand-context/make" +" self-mpi_1" +" module-scopes_1" +" post-expansion-scope_0" +"(new-scope 'module)" +"(let-values(((or-part_136) all-scopes-stx_1))" +"(if or-part_136 or-part_136(add-scopes empty-syntax module-scopes_1)))" +"(box null)" +"(make-hasheqv)" +" (string->uninterned-symbol \"root-frame\")" +"(box 0)" +"(generate-lift-key))))))))))))" +"(define-values" +"(apply-post-expansion)" +"(lambda(pe_0 s_165)" +"(begin" +"(if(not pe_0)" +"(let-values() s_165)" +"(if(shifted-multi-scope? pe_0)" +"(let-values()(push-scope s_165 pe_0))" +"(if(pair? pe_0)" +"(let-values()" +"(let-values(((temp18_2)(push-scope s_165(car pe_0)))((temp19_0)(cdr pe_0)))" +"(syntax-add-shifts44.1 #f temp18_2 temp19_0 #f)))" +"(let-values()(pe_0 s_165))))))))" +"(define-values" +"(post-expansion-scope)" +"(lambda(pe_1)" +"(begin" +"(if(shifted-multi-scope? pe_1)" +"(let-values() pe_1)" +"(if(pair? pe_1)" +"(let-values()(car pe_1))" +" (let-values () (error 'post-expansion-scope \"internal error: cannot extract scope from ~s\" pe_1)))))))" +"(define-values" +"(root-expand-context-encode-for-module)" +"(lambda(ctx_0 orig-self_0 new-self_0)" +"(begin" +"(datum->syntax$1" +" #f" +"(vector" +"(add-scopes empty-syntax(root-expand-context-module-scopes ctx_0))" +"(apply-post-expansion(root-expand-context-post-expansion ctx_0) empty-syntax)" +"(let-values(((temp20_0)(root-expand-context-all-scopes-stx ctx_0))" +"((orig-self21_0) orig-self_0)" +"((new-self22_0) new-self_0))" +"(syntax-module-path-index-shift13.1 #f temp20_0 orig-self21_0 new-self22_0 #f))" +"(add-scopes empty-syntax(unbox(root-expand-context-use-site-scopes ctx_0)))" +"(let-values(((ht_63)(root-expand-context-defined-syms ctx_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_63)))" +"((letrec-values(((for-loop_78)" +"(lambda(table_91 i_83)" +"(begin" +" 'for-loop" +"(if i_83" +"(let-values(((phase_24 ht_64)(hash-iterate-key+value ht_63 i_83)))" +"(let-values(((table_92)" +"(let-values(((table_93) table_91))" +"(let-values(((table_94)" +"(let-values()" +"(let-values(((key_37 val_25)" +"(let-values()" +"(values phase_24 ht_64))))" +"(hash-set table_93 key_37 val_25)))))" +"(values table_94)))))" +"(if(not #f)(for-loop_78 table_92(hash-iterate-next ht_63 i_83)) table_92)))" +" table_91)))))" +" for-loop_78)" +" '#hasheqv()" +"(hash-iterate-first ht_63))))" +"(root-expand-context-frame-id ctx_0)" +"(unbox(root-expand-context-counter ctx_0)))))))" +"(define-values" +"(root-expand-context-decode-for-module)" +"(lambda(vec-s_0 self_3)" +"(begin" +"(let-values(((vec_29)(if(syntax?$1 vec-s_0)(syntax-e$1 vec-s_0) #f)))" +"(begin" +"(if(if(vector? vec_29)" +"(if(=(vector-length vec_29) 7)" +"(if(syntax?$1(vector-ref vec_29 0))" +"(if(syntax-with-one-scope?(vector-ref vec_29 1))" +"(if(syntax?$1(vector-ref vec_29 2))" +"(if(syntax?$1(vector-ref vec_29 3))" +"(if(defined-syms-hash?(syntax-e$1(vector-ref vec_29 4)))" +"(if(symbol?(syntax-e$1(vector-ref vec_29 5)))" +"(exact-nonnegative-integer?(syntax-e$1(vector-ref vec_29 6)))" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +"(void)" +" (let-values () (error 'root-expand-context-decode-for-module \"bad encoding: ~s\" vec-s_0)))" +"(root-expand-context/make" +" self_3" +"(extract-scope-list(vector-ref vec_29 0))" +"(cons(extract-scope(vector-ref vec_29 1))(extract-shifts(vector-ref vec_29 1)))" +"(new-scope 'module)" +"(vector-ref vec_29 2)" +"(box(extract-scope-list(vector-ref vec_29 3)))" +"(unpack-defined-syms(vector-ref vec_29 4))" +"(syntax-e$1(vector-ref vec_29 5))" +"(box(syntax-e$1(vector-ref vec_29 6)))" +"(generate-lift-key)))))))" +"(define-values" +"(defined-syms-hash?)" +"(lambda(v_96)" +"(begin" +"(let-values(((ht_65) v_96))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_65)))" +"((letrec-values(((for-loop_79)" +"(lambda(result_53 i_84)" +"(begin" +" 'for-loop" +"(if i_84" +"(let-values(((phase_25 ht-s_0)(hash-iterate-key+value ht_65 i_84)))" +"(let-values(((result_54)" +"(let-values()" +"(let-values(((result_55)" +"(let-values()" +"(let-values()" +"(if(phase? phase_25)" +"(if(hash?(syntax-e$1 ht-s_0))" +"(let-values(((ht_66)(syntax-e$1 ht-s_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_66)))" +"((letrec-values(((for-loop_80)" +"(lambda(result_56 i_85)" +"(begin" +" 'for-loop" +"(if i_85" +"(let-values(((sym_21" +" id_8)" +"(hash-iterate-key+value" +" ht_66" +" i_85)))" +"(let-values(((result_57)" +"(let-values()" +"(let-values(((result_58)" +"(let-values()" +"(let-values()" +"(if(symbol?" +" sym_21)" +"(identifier?" +" id_8)" +" #f)))))" +"(values" +" result_58)))))" +"(if(if(not" +"((lambda x_38" +"(not" +" result_57))" +" sym_21" +" id_8))" +"(not #f)" +" #f)" +"(for-loop_80" +" result_57" +"(hash-iterate-next" +" ht_66" +" i_85))" +" result_57)))" +" result_56)))))" +" for-loop_80)" +" #t" +"(hash-iterate-first ht_66))))" +" #f)" +" #f)))))" +"(values result_55)))))" +"(if(if(not((lambda x_39(not result_54)) phase_25 ht-s_0))(not #f) #f)" +"(for-loop_79 result_54(hash-iterate-next ht_65 i_84))" +" result_54)))" +" result_53)))))" +" for-loop_79)" +" #t" +"(hash-iterate-first ht_65)))))))" +"(define-values" +"(extract-scope-list)" +"(lambda(stx_9)(begin(map2 generalize-scope(set->list(syntax-scope-set stx_9 0))))))" +"(define-values" +"(syntax-with-one-scope?)" +"(lambda(stx_10)(begin(if(syntax?$1 stx_10)(= 1(set-count(syntax-scope-set stx_10 0))) #f))))" +"(define-values" +"(extract-scope)" +"(lambda(stx_11)(begin(let-values(((s_58)(syntax-scope-set stx_11 0)))(generalize-scope(set-first s_58))))))" +"(define-values(extract-shifts)(lambda(stx_12)(begin(syntax-mpi-shifts stx_12))))" +"(define-values" +"(unpack-defined-syms)" +"(lambda(v_97)" +"(begin" +"(hash-copy" +"(let-values(((ht_67)(syntax-e$1 v_97)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_67)))" +"((letrec-values(((for-loop_81)" +"(lambda(table_95 i_86)" +"(begin" +" 'for-loop" +"(if i_86" +"(let-values(((phase_26 ht-s_1)(hash-iterate-key+value ht_67 i_86)))" +"(let-values(((table_96)" +"(let-values(((table_97) table_95))" +"(let-values(((table_98)" +"(let-values()" +"(let-values(((key_38 val_26)" +"(let-values()" +"(values" +" phase_26" +"(hash-copy" +"(let-values(((ht_68)" +"(syntax-e$1" +" ht-s_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_68)))" +"((letrec-values(((for-loop_82)" +"(lambda(table_99" +" i_87)" +"(begin" +" 'for-loop" +"(if i_87" +"(let-values(((sym_22" +" id_9)" +"(hash-iterate-key+value" +" ht_68" +" i_87)))" +"(let-values(((table_100)" +"(let-values(((table_101)" +" table_99))" +"(let-values(((table_102)" +"(let-values()" +"(let-values(((key_39" +" val_27)" +"(let-values()" +"(values" +" sym_22" +" id_9))))" +"(hash-set" +" table_101" +" key_39" +" val_27)))))" +"(values" +" table_102)))))" +"(if(not" +" #f)" +"(for-loop_82" +" table_100" +"(hash-iterate-next" +" ht_68" +" i_87))" +" table_100)))" +" table_99)))))" +" for-loop_82)" +" '#hash()" +"(hash-iterate-first" +" ht_68)))))))))" +"(hash-set table_97 key_38 val_26)))))" +"(values table_98)))))" +"(if(not #f)(for-loop_81 table_96(hash-iterate-next ht_67 i_86)) table_96)))" +" table_95)))))" +" for-loop_81)" +" '#hasheqv()" +"(hash-iterate-first ht_67))))))))" +"(define-values(1/primitive-table) primitive-table)" +"(define-values(1/primitive->compiled-position) primitive->compiled-position)" +"(define-values(1/compiled-position->primitive) compiled-position->primitive)" +"(define-values(1/primitive-in-category?) primitive-in-category?)" +"(define-values(1/linklet?) linklet?)" +"(define-values(1/compile-linklet) compile-linklet)" +"(define-values(1/recompile-linklet) recompile-linklet)" +"(define-values(1/eval-linklet) eval-linklet)" +"(define-values(1/read-compiled-linklet) read-compiled-linklet)" +"(define-values(1/instantiate-linklet) instantiate-linklet)" +"(define-values(1/linklet-import-variables) linklet-import-variables)" +"(define-values(1/linklet-export-variables) linklet-export-variables)" +"(define-values(1/instance?) instance?)" +"(define-values(1/make-instance) make-instance)" +"(define-values(1/instance-name) instance-name)" +"(define-values(1/instance-data) instance-data)" +"(define-values(1/instance-variable-names) instance-variable-names)" +"(define-values(1/instance-variable-value) instance-variable-value)" +"(define-values(1/instance-set-variable-value!) instance-set-variable-value!)" +"(define-values(1/instance-unset-variable!) instance-unset-variable!)" +"(define-values(1/linklet-directory?) linklet-directory?)" +"(define-values(1/hash->linklet-directory) hash->linklet-directory)" +"(define-values(1/linklet-directory->hash) linklet-directory->hash)" +"(define-values(1/linklet-bundle?) linklet-bundle?)" +"(define-values(1/hash->linklet-bundle) hash->linklet-bundle)" +"(define-values(1/linklet-bundle->hash) linklet-bundle->hash)" +"(define-values(1/variable-reference?) variable-reference?)" +"(define-values(1/variable-reference->instance) variable-reference->instance)" +"(define-values(1/variable-reference-constant?) variable-reference-constant?)" +"(define-values(1/variable-reference-from-unsafe?) variable-reference-from-unsafe?)" +"(void" +"(if 1/variable-reference-constant?" +"(void)" +" (let-values () (error \"broken '#%linklet primitive table; maybe you need to use \\\"bootstrap-run.rkt\\\"\"))))" +"(define-values" +"(struct:module-registry module-registry1.1 module-registry? module-registry-declarations module-registry-lock-box)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-registry" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-registry)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'declarations)" +"(make-struct-field-accessor -ref_0 1 'lock-box))))" +"(define-values(make-module-registry)(lambda()(begin(module-registry1.1(make-hasheq)(box #f)))))" +"(define-values" +"(registry-call-with-lock)" +"(lambda(r_5 proc_2)" +"(begin" +"(let-values(((lock-box_0)(module-registry-lock-box r_5)))" +"((letrec-values(((loop_70)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((v_33)(unbox lock-box_0)))" +"(if(let-values(((or-part_75)(not v_33)))" +"(if or-part_75 or-part_75(sync/timeout 0(car v_33)(cdr v_33))))" +"(let-values()" +"(let-values(((sema_0)(make-semaphore)))" +"(let-values(((lock_0)(cons(semaphore-peek-evt sema_0)(current-thread))))" +"((dynamic-wind" +" void" +"(lambda()" +"(if(box-cas! lock-box_0 v_33 lock_0)" +"(let-values()(begin(proc_2) void))" +"(let-values()(lambda()(loop_70)))))" +"(lambda()(semaphore-post sema_0)))))))" +"(if(eq?(current-thread)(cdr v_33))" +"(let-values()(proc_2))" +"(let-values()(begin(sync(car v_33)(cdr v_33))(loop_70))))))))))" +" loop_70))))))" +"(define-values" +"(struct:namespace" +" namespace1.1" +" 1/namespace?" +" namespace-mpi" +" namespace-source-name" +" namespace-root-expand-ctx" +" namespace-phase" +" namespace-0-phase" +" namespace-phase-to-namespace" +" namespace-phase-level-to-definitions" +" namespace-module-registry$1" +" namespace-bulk-binding-registry" +" namespace-submodule-declarations" +" namespace-root-namespace" +" namespace-declaration-inspector" +" namespace-inspector" +" namespace-available-module-instances" +" namespace-module-instances" +" set-namespace-inspector!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'namespace" +" #f" +" 15" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:custom-write" +"(lambda(ns_0 port_10 mode_10)" +" (let-values ((() (begin (write-string \"#name ns_0)))" +"(void))" +"(values))))" +"(let-values(((0-phase_0)(namespace-0-phase ns_0)))" +"(let-values(((phase-level_0)(phase-(namespace-phase ns_0) 0-phase_0)))" +"(begin" +"(if(zero-phase? phase-level_0)" +"(void)" +" (let-values () (fprintf port_10 \":~s\" phase-level_0)))" +"(if(zero-phase? 0-phase_0)" +"(void)" +"(let-values()" +" (fprintf port_10 \"~a~s\" (if (positive? 0-phase_0) \"+\" \"\") 0-phase_0)))" +" (write-string \">\" port_10))))))))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 13 14)" +" #f" +" 'namespace)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'mpi)" +"(make-struct-field-accessor -ref_0 1 'source-name)" +"(make-struct-field-accessor -ref_0 2 'root-expand-ctx)" +"(make-struct-field-accessor -ref_0 3 'phase)" +"(make-struct-field-accessor -ref_0 4 '0-phase)" +"(make-struct-field-accessor -ref_0 5 'phase-to-namespace)" +"(make-struct-field-accessor -ref_0 6 'phase-level-to-definitions)" +"(make-struct-field-accessor -ref_0 7 'module-registry)" +"(make-struct-field-accessor -ref_0 8 'bulk-binding-registry)" +"(make-struct-field-accessor -ref_0 9 'submodule-declarations)" +"(make-struct-field-accessor -ref_0 10 'root-namespace)" +"(make-struct-field-accessor -ref_0 11 'declaration-inspector)" +"(make-struct-field-accessor -ref_0 12 'inspector)" +"(make-struct-field-accessor -ref_0 13 'available-module-instances)" +"(make-struct-field-accessor -ref_0 14 'module-instances)" +"(make-struct-field-mutator -set!_0 12 'inspector))))" +"(define-values" +"(struct:definitions definitions2.1 definitions? definitions-variables definitions-transformers)" +"(let-values(((struct:_37 make-_37 ?_37 -ref_37 -set!_37)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'definitions" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'definitions)))))" +"(values" +" struct:_37" +" make-_37" +" ?_37" +"(make-struct-field-accessor -ref_37 0 'variables)" +"(make-struct-field-accessor -ref_37 1 'transformers))))" +"(define-values(make-namespace)(lambda()(begin(let-values()(new-namespace8.1 #t unsafe-undefined #f)))))" +"(define-values" +"(new-namespace8.1)" +"(lambda(register?4_0 root-expand-ctx3_0 share-from-ns7_0)" +"(begin" +" 'new-namespace8" +"(let-values(((share-from-ns_0) share-from-ns7_0))" +"(let-values(((root-expand-ctx_0)" +"(if(eq? root-expand-ctx3_0 unsafe-undefined)" +"(let-values(((top-level-module-path-index20_0) top-level-module-path-index))" +"(make-root-expand-context13.1" +" #f" +" null" +" unsafe-undefined" +" unsafe-undefined" +" top-level-module-path-index20_0))" +" root-expand-ctx3_0)))" +"(let-values(((register?_0) register?4_0))" +"(let-values()" +"(let-values(((phase_27)(if share-from-ns_0(namespace-phase share-from-ns_0) 0)))" +"(let-values(((ns_1)" +"(namespace1.1" +" top-level-module-path-index" +" #f" +"(box root-expand-ctx_0)" +" phase_27" +" phase_27" +"(make-small-hasheqv)" +"(make-small-hasheqv)" +"(if share-from-ns_0(namespace-module-registry$1 share-from-ns_0)(make-module-registry))" +"(if share-from-ns_0" +"(namespace-bulk-binding-registry share-from-ns_0)" +"(make-bulk-binding-registry))" +"(make-small-hasheq)" +"(if share-from-ns_0" +"(let-values(((or-part_137)(namespace-root-namespace share-from-ns_0)))" +"(if or-part_137 or-part_137 share-from-ns_0))" +" #f)" +" #f" +"(make-inspector(current-code-inspector))" +"(if share-from-ns_0" +"(namespace-available-module-instances share-from-ns_0)" +"(make-hasheqv))" +"(if share-from-ns_0(namespace-module-instances share-from-ns_0)(make-hasheqv)))))" +"(begin" +"(if register?_0" +"(let-values()(small-hash-set!(namespace-phase-to-namespace ns_1) phase_27 ns_1))" +"(void))" +" ns_1))))))))))" +"(define-values" +"(1/current-namespace)" +"(make-parameter" +"(make-namespace)" +"(lambda(v_98)" +"(begin" +" (if (1/namespace? v_98) (void) (let-values () (raise-argument-error 'current-namespace \"namespace?\" v_98)))" +" v_98))))" +"(define-values" +"(namespace-get-root-expand-ctx)" +"(lambda(ns_2)(begin(force(unbox(namespace-root-expand-ctx ns_2))))))" +"(define-values" +"(namespace-set-root-expand-ctx!)" +"(lambda(ns_3 root-ctx_0)(begin(set-box!(namespace-root-expand-ctx ns_3) root-ctx_0))))" +"(define-values" +"(namespace-self-mpi)" +"(lambda(ns_4)(begin(root-expand-context-self-mpi(namespace-get-root-expand-ctx ns_4)))))" +"(define-values" +"(namespace->module)" +"(lambda(ns_5 name_17)" +"(begin" +"(let-values(((or-part_138)(small-hash-ref(namespace-submodule-declarations ns_5) name_17 #f)))" +"(if or-part_138" +" or-part_138" +"(hash-ref(module-registry-declarations(namespace-module-registry$1 ns_5)) name_17 #f))))))" +"(define-values" +"(namespace->namespace-at-phase)" +"(lambda(ns_6 phase_24)" +"(begin" +"(let-values(((or-part_139)(small-hash-ref(namespace-phase-to-namespace ns_6) phase_24 #f)))" +"(if or-part_139" +" or-part_139" +"(let-values(((p-ns_0)" +"(let-values(((the-struct_34) ns_6))" +"(if(1/namespace? the-struct_34)" +"(let-values(((phase21_0) phase_24))" +"(namespace1.1" +"(namespace-mpi the-struct_34)" +"(namespace-source-name the-struct_34)" +"(namespace-root-expand-ctx the-struct_34)" +" phase21_0" +"(namespace-0-phase the-struct_34)" +"(namespace-phase-to-namespace the-struct_34)" +"(namespace-phase-level-to-definitions the-struct_34)" +"(namespace-module-registry$1 the-struct_34)" +"(namespace-bulk-binding-registry the-struct_34)" +"(namespace-submodule-declarations the-struct_34)" +"(namespace-root-namespace the-struct_34)" +"(namespace-declaration-inspector the-struct_34)" +"(namespace-inspector the-struct_34)" +"(namespace-available-module-instances the-struct_34)" +"(namespace-module-instances the-struct_34)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_34)))))" +"(begin(small-hash-set!(namespace-phase-to-namespace ns_6) phase_24 p-ns_0) p-ns_0)))))))" +"(define-values" +"(namespace->name)" +"(lambda(ns_7)" +"(begin" +"(let-values(((n_21)(namespace-source-name ns_7)))" +"(let-values(((s_166)" +"(if(not n_21)" +"(let-values() 'top-level)" +"(if(symbol? n_21)" +" (let-values () (format \"'~s\" n_21))" +" (let-values () (string-append \"\\\"\" (path->string n_21) \"\\\"\"))))))" +"(let-values(((r_27)(1/resolved-module-path-name(1/module-path-index-resolve(namespace-mpi ns_7)))))" +" (if (pair? r_27) (string-append \"(submod \" s_166 \" \" (substring (format \"~s\" (cdr r_27)) 1)) s_166)))))))" +"(define-values" +"(namespace->definitions)" +"(lambda(ns_8 phase-level_1)" +"(begin" +"(let-values(((d_8)(small-hash-ref(namespace-phase-level-to-definitions ns_8) phase-level_1 #f)))" +"(let-values(((or-part_140) d_8))" +"(if or-part_140" +" or-part_140" +"(let-values()" +"(let-values(((p-ns_1)" +"(namespace->namespace-at-phase ns_8(phase+(namespace-0-phase ns_8) phase-level_1))))" +"(let-values(((d_9)(definitions2.1(1/make-instance(namespace->name p-ns_1) p-ns_1)(make-hasheq))))" +"(begin(small-hash-set!(namespace-phase-level-to-definitions ns_8) phase-level_1 d_9) d_9))))))))))" +"(define-values" +"(namespace-set-variable!)" +"(let-values(((namespace-set-variable!16_0)" +"(lambda(ns12_0 phase-level13_0 name14_1 val15_0 as-constant?11_0)" +"(begin" +" 'namespace-set-variable!16" +"(let-values(((ns_9) ns12_0))" +"(let-values(((phase-level_2) phase-level13_0))" +"(let-values(((name_18) name14_1))" +"(let-values(((val_28) val15_0))" +"(let-values(((as-constant?_0) as-constant?11_0))" +"(let-values()" +"(let-values(((d_10)(namespace->definitions ns_9 phase-level_2)))" +"(1/instance-set-variable-value!" +"(definitions-variables d_10)" +" name_18" +" val_28" +"(if as-constant?_0 'constant #f)))))))))))))" +"(case-lambda" +"((ns_10 phase-level_3 name_19 val_29)(begin(namespace-set-variable!16_0 ns_10 phase-level_3 name_19 val_29 #f)))" +"((ns_11 phase-level_4 name_20 val_30 as-constant?11_1)" +"(namespace-set-variable!16_0 ns_11 phase-level_4 name_20 val_30 as-constant?11_1)))))" +"(define-values" +"(namespace-set-consistent!)" +"(lambda(ns_12 phase-level_5 name_21 val_31)" +"(begin" +"(let-values(((d_11)(namespace->definitions ns_12 phase-level_5)))" +"(1/instance-set-variable-value!(definitions-variables d_11) name_21 val_31 'consistent)))))" +"(define-values" +"(namespace-unset-variable!)" +"(lambda(ns_13 phase-level_6 name_22)" +"(begin" +"(let-values(((d_12)(namespace->definitions ns_13 phase-level_6)))" +"(1/instance-unset-variable!(definitions-variables d_12) name_22)))))" +"(define-values" +"(namespace-set-transformer!)" +"(lambda(ns_14 phase-level_7 name_23 val_32)" +"(begin" +"(let-values(((d_13)(namespace->definitions ns_14(add1 phase-level_7))))" +"(hash-set!(definitions-transformers d_13) name_23 val_32)))))" +"(define-values" +"(namespace-unset-transformer!)" +"(lambda(ns_15 phase-level_8 name_24)" +"(begin" +"(let-values(((d_14)(namespace->definitions ns_15(add1 phase-level_8))))" +"(hash-remove!(definitions-transformers d_14) name_24)))))" +"(define-values" +"(namespace-get-variable)" +"(lambda(ns_16 phase-level_9 name_25 fail-k_0)" +"(begin" +"(let-values(((d_15)(namespace->definitions ns_16 phase-level_9)))" +"(1/instance-variable-value(definitions-variables d_15) name_25 fail-k_0)))))" +"(define-values" +"(namespace-get-transformer)" +"(lambda(ns_17 phase-level_10 name_26 fail-k_1)" +"(begin" +"(let-values(((d_16)(namespace->definitions ns_17(add1 phase-level_10))))" +"(hash-ref(definitions-transformers d_16) name_26 fail-k_1)))))" +"(define-values" +"(namespace->instance)" +"(lambda(ns_18 phase-shift_2)(begin(definitions-variables(namespace->definitions ns_18 phase-shift_2)))))" +"(define-values" +"(namespace-same-instance?)" +"(lambda(a-ns_0 b-ns_0)" +"(begin" +"(eq?" +"(small-hash-ref(namespace-phase-level-to-definitions a-ns_0) 0 'no-a)" +"(small-hash-ref(namespace-phase-level-to-definitions b-ns_0) 0 'no-b)))))" +"(define-values(original-property-sym)(gensym 'original))" +"(define-values" +"(syntax->list$1)" +"(lambda(s_0)" +"(begin" +" 'syntax->list" +"(let-values(((l_46)" +"((letrec-values(((loop_78)" +"(lambda(s_1)" +"(begin" +" 'loop" +"(if(pair? s_1)" +"(let-values()(cons(car s_1)(loop_78(cdr s_1))))" +"(if(syntax?$1 s_1)" +"(let-values()(loop_78(syntax-e$1 s_1)))" +"(let-values() s_1)))))))" +" loop_78)" +" s_0)))" +"(if(list? l_46) l_46 #f)))))" +"(define-values(missing$1)(gensym))" +"(define-values" +"(syntax-track-origin$1)" +"(let-values(((syntax-track-origin4_0)" +"(lambda(new-stx2_0 old-stx3_0 id1_0)" +"(begin" +" 'syntax-track-origin4" +"(let-values(((new-stx_0) new-stx2_0))" +"(let-values(((old-stx_0) old-stx3_0))" +"(let-values(((id_10)" +"(if(eq? id1_0 unsafe-undefined)" +"(if(identifier? old-stx_0)" +" old-stx_0" +"(let-values(((v_30)(syntax-e/no-taint old-stx_0)))" +"(if(pair? v_30)(car v_30) #f)))" +" id1_0)))" +"(let-values()" +"(let-values(((old-props_0)(syntax-props old-stx_0)))" +"(if(zero?(hash-count old-props_0))" +"(let-values()" +"(if id_10" +"(syntax-property$1" +" new-stx_0" +" 'origin" +"(cons id_10(hash-ref(syntax-props new-stx_0) 'origin null)))" +" new-stx_0))" +"(let-values()" +"(let-values(((new-props_0)(syntax-props new-stx_0)))" +"(if(zero?(hash-count new-props_0))" +"(let-values()" +"(if id_10" +"(let-values()" +"(let-values(((old-origin_0)" +"(plain-property-value" +"(hash-ref old-props_0 'origin missing$1))))" +"(let-values(((origin_0)" +"(if(eq? old-origin_0 missing$1)" +"(list id_10)" +"(cons id_10 old-origin_0))))" +"(let-values(((the-struct_35) new-stx_0))" +"(if(syntax?$1 the-struct_35)" +"(let-values(((props6_0)(hash-set old-props_0 'origin origin_0)))" +"(syntax1.1" +"(syntax-content the-struct_35)" +"(syntax-scopes the-struct_35)" +"(syntax-shifted-multi-scopes the-struct_35)" +"(syntax-scope-propagations+tamper the-struct_35)" +"(syntax-mpi-shifts the-struct_35)" +"(syntax-srcloc the-struct_35)" +" props6_0" +"(syntax-inspector the-struct_35)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_35))))))" +"(let-values()" +"(let-values(((the-struct_36) new-stx_0))" +"(if(syntax?$1 the-struct_36)" +"(let-values(((props7_1) old-props_0))" +"(syntax1.1" +"(syntax-content the-struct_36)" +"(syntax-scopes the-struct_36)" +"(syntax-shifted-multi-scopes the-struct_36)" +"(syntax-scope-propagations+tamper the-struct_36)" +"(syntax-mpi-shifts the-struct_36)" +"(syntax-srcloc the-struct_36)" +" props7_1" +"(syntax-inspector the-struct_36)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_36))))))" +"(let-values()" +"(let-values(((old-props-with-origin_0)" +"(if id_10" +"(hash-set" +" old-props_0" +" 'origin" +"(cons id_10(hash-ref old-props_0 'origin null)))" +" old-props_0)))" +"(let-values(((updated-props_0)" +"(if(<" +"(hash-count old-props-with-origin_0)" +"(hash-count new-props_0))" +"(let-values()" +"(let-values(((ht_69) old-props-with-origin_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_69)))" +"((letrec-values(((for-loop_83)" +"(lambda(new-props_1 i_88)" +"(begin" +" 'for-loop" +"(if i_88" +"(let-values(((k_17 v_2)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_69" +" i_88)))" +"(let-values(((new-props_2)" +"(let-values(((new-props_3)" +" new-props_1))" +"(let-values(((new-props_4)" +"(let-values()" +"(let-values(((new-v_0)" +"(hash-ref" +" new-props_3" +" k_17" +" missing$1)))" +"(hash-set" +" new-props_3" +" k_17" +"(if(eq?" +" new-v_0" +" missing$1)" +" v_2" +"(cons/preserve" +" new-v_0" +" v_2)))))))" +"(values" +" new-props_4)))))" +"(if(not #f)" +"(for-loop_83" +" new-props_2" +"(unsafe-immutable-hash-iterate-next" +" ht_69" +" i_88))" +" new-props_2)))" +" new-props_1)))))" +" for-loop_83)" +" new-props_0" +"(unsafe-immutable-hash-iterate-first ht_69)))))" +"(let-values()" +"(let-values(((ht_70) new-props_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_70)))" +"((letrec-values(((for-loop_84)" +"(lambda(old-props_1 i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((k_18 v_89)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_70" +" i_0)))" +"(let-values(((old-props_2)" +"(let-values(((old-props_3)" +" old-props_1))" +"(let-values(((old-props_4)" +"(let-values()" +"(let-values(((old-v_0)" +"(hash-ref" +" old-props_3" +" k_18" +" missing$1)))" +"(hash-set" +" old-props_3" +" k_18" +"(if(eq?" +" old-v_0" +" missing$1)" +" v_89" +"(cons/preserve" +" v_89" +" old-v_0)))))))" +"(values" +" old-props_4)))))" +"(if(not #f)" +"(for-loop_84" +" old-props_2" +"(unsafe-immutable-hash-iterate-next" +" ht_70" +" i_0))" +" old-props_2)))" +" old-props_1)))))" +" for-loop_84)" +" old-props-with-origin_0" +"(unsafe-immutable-hash-iterate-first ht_70))))))))" +"(let-values(((the-struct_37) new-stx_0))" +"(if(syntax?$1 the-struct_37)" +"(let-values(((props8_0) updated-props_0))" +"(syntax1.1" +"(syntax-content the-struct_37)" +"(syntax-scopes the-struct_37)" +"(syntax-shifted-multi-scopes the-struct_37)" +"(syntax-scope-propagations+tamper the-struct_37)" +"(syntax-mpi-shifts the-struct_37)" +"(syntax-srcloc the-struct_37)" +" props8_0" +"(syntax-inspector the-struct_37)))" +"(raise-argument-error" +" 'struct-copy" +" \"syntax?\"" +" the-struct_37)))))))))))))))))))" +"(case-lambda" +"((new-stx_1 old-stx_1)(begin 'syntax-track-origin(syntax-track-origin4_0 new-stx_1 old-stx_1 unsafe-undefined)))" +"((new-stx_2 old-stx_2 id1_1)(syntax-track-origin4_0 new-stx_2 old-stx_2 id1_1)))))" +"(define-values" +"(cons/preserve)" +"(lambda(a_35 b_49)" +"(begin" +"(if(let-values(((or-part_67)(preserved-property-value? a_35)))" +"(if or-part_67 or-part_67(preserved-property-value? b_49)))" +"(preserved-property-value1.1(cons(plain-property-value a_35)(plain-property-value b_49)))" +"(cons a_35 b_49)))))" +"(define-values" +"(syntax-track-origin*)" +"(lambda(old-stxes_0 new-stx_3)" +"(begin" +"(let-values(((lst_58) old-stxes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_58)))" +"((letrec-values(((for-loop_85)" +"(lambda(new-stx_4 lst_24)" +"(begin" +" 'for-loop" +"(if(pair? lst_24)" +"(let-values(((old-stx_3)(unsafe-car lst_24))((rest_26)(unsafe-cdr lst_24)))" +"(let-values(((new-stx_5)" +"(let-values(((new-stx_6) new-stx_4))" +"(let-values(((new-stx_7)" +"(let-values()" +"(syntax-track-origin$1 new-stx_6 old-stx_3))))" +"(values new-stx_7)))))" +"(if(not #f)(for-loop_85 new-stx_5 rest_26) new-stx_5)))" +" new-stx_4)))))" +" for-loop_85)" +" new-stx_3" +" lst_58))))))" +"(define-values" +"(1/struct:exn:fail:syntax make-exn:fail:syntax$1 1/exn:fail:syntax? 1/exn:fail:syntax-exprs)" +"(let-values(((struct:_30 make-_30 ?_30 -ref_30 -set!_30)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax" +" struct:exn:fail" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:exn:srclocs" +"(lambda(e_17)(filter values(map2 syntax-srcloc(1/exn:fail:syntax-exprs e_17))))))" +" #f" +" #f" +" '(0)" +"(lambda(str_1 cm_0 exprs_0 info_2)" +"(begin" +"(if(if(list? exprs_0)(andmap2 syntax?$1 exprs_0) #f)" +"(void)" +" (let-values () (raise-argument-error 'exn:fail:syntax \"(listof syntax?)\" exprs_0)))" +"(values str_1 cm_0 exprs_0)))" +" 'exn:fail:syntax)))))" +"(values struct:_30 make-_30 ?_30(make-struct-field-accessor -ref_30 0 'exprs))))" +"(define-values" +"(1/struct:exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1 1/exn:fail:syntax:unbound?)" +"(let-values(((struct:_38 make-_38 ?_38 -ref_38 -set!_38)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax:unbound" +" 1/struct:exn:fail:syntax" +" 0" +" 0" +" #f" +" null" +" #f" +" #f" +" '()" +" #f" +" 'exn:fail:syntax:unbound)))))" +"(values struct:_38 make-_38 ?_38)))" +"(define-values" +"(raise-syntax-error$1)" +"(let-values(((raise-syntax-error7_0)" +"(lambda(given-name5_0 message6_0 expr1_0 sub-expr2_0 extra-sources3_0 message-suffix4_0)" +"(begin" +" 'raise-syntax-error7" +"(let-values(((given-name_0) given-name5_0))" +"(let-values(((message_0) message6_0))" +"(let-values(((expr_0) expr1_0))" +"(let-values(((sub-expr_0) sub-expr2_0))" +"(let-values(((extra-sources_0) extra-sources3_0))" +"(let-values(((message-suffix_0) message-suffix4_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(do-raise-syntax-error" +" 'raise-syntax-error" +" make-exn:fail:syntax$1" +" given-name_0" +" message_0" +" expr_0" +" sub-expr_0" +" extra-sources_0" +" message-suffix_0))))))))))))))" +"(case-lambda" +" ((given-name_1 message_1) (begin 'raise-syntax-error (raise-syntax-error7_0 given-name_1 message_1 #f #f null \"\")))" +"((given-name_2 message_2 expr_1 sub-expr_1 extra-sources_1 message-suffix4_1)" +"(raise-syntax-error7_0 given-name_2 message_2 expr_1 sub-expr_1 extra-sources_1 message-suffix4_1))" +"((given-name_3 message_3 expr_2 sub-expr_2 extra-sources3_1)" +" (raise-syntax-error7_0 given-name_3 message_3 expr_2 sub-expr_2 extra-sources3_1 \"\"))" +"((given-name_4 message_4 expr_3 sub-expr2_1)" +" (raise-syntax-error7_0 given-name_4 message_4 expr_3 sub-expr2_1 null \"\"))" +" ((given-name_5 message_5 expr1_1) (raise-syntax-error7_0 given-name_5 message_5 expr1_1 #f null \"\")))))" +"(define-values" +"(raise-unbound-syntax-error)" +"(let-values(((raise-unbound-syntax-error15_0)" +"(lambda(given-name13_0 message14_0 expr9_0 sub-expr10_0 extra-sources11_0 message-suffix12_0)" +"(begin" +" 'raise-unbound-syntax-error15" +"(let-values(((given-name_6) given-name13_0))" +"(let-values(((message_6) message14_0))" +"(let-values(((expr_4) expr9_0))" +"(let-values(((sub-expr_3) sub-expr10_0))" +"(let-values(((extra-sources_2) extra-sources11_0))" +"(let-values(((message-suffix_1) message-suffix12_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(do-raise-syntax-error" +" 'raise-unbound-syntax-error" +" make-exn:fail:syntax:unbound$1" +" given-name_6" +" message_6" +" expr_4" +" sub-expr_3" +" extra-sources_2" +" message-suffix_1))))))))))))))" +"(case-lambda" +" ((given-name_7 message_7) (begin (raise-unbound-syntax-error15_0 given-name_7 message_7 #f #f null \"\")))" +"((given-name_8 message_8 expr_5 sub-expr_4 extra-sources_3 message-suffix12_1)" +"(raise-unbound-syntax-error15_0 given-name_8 message_8 expr_5 sub-expr_4 extra-sources_3 message-suffix12_1))" +"((given-name_9 message_9 expr_6 sub-expr_5 extra-sources11_1)" +" (raise-unbound-syntax-error15_0 given-name_9 message_9 expr_6 sub-expr_5 extra-sources11_1 \"\"))" +"((given-name_10 message_10 expr_7 sub-expr10_1)" +" (raise-unbound-syntax-error15_0 given-name_10 message_10 expr_7 sub-expr10_1 null \"\"))" +"((given-name_11 message_11 expr9_1)" +" (raise-unbound-syntax-error15_0 given-name_11 message_11 expr9_1 #f null \"\")))))" +"(define-values" +"(do-raise-syntax-error)" +"(lambda(who_8 exn:fail:syntax_0 given-name_12 message_12 expr_8 sub-expr_6 extra-sources_4 message-suffix_2)" +"(begin" +"(let-values((()" +"(begin" +"(if((lambda(x_40)" +"(let-values(((or-part_99)(not x_40)))(if or-part_99 or-part_99(symbol? x_40))))" +" given-name_12)" +"(void)" +" (let-values () (raise-argument-error who_8 \"(or/c symbol? #f)\" given-name_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(string? message_12)" +"(void)" +" (let-values () (raise-argument-error who_8 \"string?\" message_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(if(list? extra-sources_4)(andmap2 syntax?$1 extra-sources_4) #f)" +"(void)" +" (let-values () (raise-argument-error who_8 \"(listof syntax?)\" extra-sources_4)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(string? message-suffix_2)" +"(void)" +" (let-values () (raise-argument-error who_8 \"string?\" message-suffix_2)))" +"(values))))" +"(let-values(((name_27)" +"(format" +" \"~a\"" +"(let-values(((or-part_136) given-name_12))" +"(if or-part_136" +" or-part_136" +"(let-values(((or-part_141)(extract-form-name expr_8)))" +"(if or-part_141 or-part_141 '?)))))))" +"(let-values(((at-message_0)" +"(let-values(((or-part_142)" +"(if sub-expr_6" +"(if(error-print-source-location)" +" (format \"\\n at: ~.s\" (syntax->datum$1 (datum->syntax$1 #f sub-expr_6)))" +" #f)" +" #f)))" +" (if or-part_142 or-part_142 \"\"))))" +"(let-values(((in-message_0)" +"(let-values(((or-part_135)" +"(if expr_8" +"(if(error-print-source-location)" +" (format \"\\n in: ~.s\" (syntax->datum$1 (datum->syntax$1 #f expr_8)))" +" #f)" +" #f)))" +" (if or-part_135 or-part_135 \"\"))))" +"(let-values(((src-loc-str_0)" +"(let-values(((or-part_143)" +"(if(error-print-source-location)" +"(let-values(((or-part_144)(extract-source-location sub-expr_6)))" +"(if or-part_144 or-part_144(extract-source-location expr_8)))" +" #f)))" +" (if or-part_143 or-part_143 \"\"))))" +"(raise" +"(exn:fail:syntax_0" +" (string-append src-loc-str_0 name_27 \": \" message_12 at-message_0 in-message_0 message-suffix_2)" +"(current-continuation-marks)" +"(map2" +" syntax-taint$1" +"(if(let-values(((or-part_145) sub-expr_6))(if or-part_145 or-part_145 expr_8))" +"(cons" +"(datum->syntax$1" +" #f" +"(let-values(((or-part_137) sub-expr_6))(if or-part_137 or-part_137 expr_8)))" +" extra-sources_4)" +" extra-sources_4)))))))))))))))" +"(define-values" +"(extract-form-name)" +"(lambda(s_70)" +"(begin" +"(if(syntax?$1 s_70)" +"(let-values()" +"(let-values(((e_18)(syntax-e$1 s_70)))" +"(if(symbol? e_18)" +"(let-values() e_18)" +"(if(if(pair? e_18)(identifier?(car e_18)) #f)" +"(let-values()(syntax-e$1(car e_18)))" +"(let-values() #f)))))" +"(let-values() #f)))))" +"(define-values" +"(extract-source-location)" +"(lambda(s_26)" +"(begin" +"(if(syntax?$1 s_26)" +"(if(syntax-srcloc s_26)" +" (let-values (((str_2) (srcloc->string (syntax-srcloc s_26)))) (if str_2 (string-append str_2 \": \") #f))" +" #f)" +" #f))))" +"(define-values" +"(struct:module-use module-use1.1 module-use? module-use-module module-use-phase)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-use" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons" +" prop:equal+hash" +"(list" +"(lambda(a_36 b_22 eql?_2)" +"(let-values(((a-mod_0)(module-use-module a_36)))" +"(let-values(((b-mod_0)(module-use-module b_22)))" +"(if(eql?_2 a-mod_0 b-mod_0)" +"(if(eql?_2(module-use-phase a_36)(module-use-phase b_22))" +"(let-values(((a-path_0 a-base_0)(1/module-path-index-split a-mod_0))" +"((b-path_0 b-base_0)(1/module-path-index-split b-mod_0)))" +"(let-values(((or-part_78) a-path_0))" +"(if or-part_78" +" or-part_78" +"(let-values(((or-part_79) b-path_0))" +"(if or-part_79" +" or-part_79" +"(eq?" +"(module-path-index-resolved a-mod_0)" +"(module-path-index-resolved b-mod_0)))))))" +" #f)" +" #f))))" +"(lambda(a_37 hash-code_4)" +"(+(hash-code_4(module-use-module a_37))(hash-code_4(module-use-phase a_37))))" +"(lambda(a_38 hash-code_5)" +"(+(hash-code_5(module-use-module a_38))(hash-code_5(module-use-phase a_38)))))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-use)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'module)" +"(make-struct-field-accessor -ref_0 1 'phase))))" +"(define-values" +"(struct:module" +" module1.1" +" module?" +" module-source-name" +" module-self" +" module-requires" +" module-provides" +" module-access" +" module-language-info" +" module-min-phase-level" +" module-max-phase-level" +" module-phase-level-linklet-info-callback" +" module-force-bulk-binding" +" module-prepare-instance" +" module-instantiate-phase" +" module-primitive?" +" module-is-predefined?" +" module-cross-phase-persistent?" +" module-no-protected?" +" module-inspector" +" module-submodule-names" +" module-supermodule-name" +" module-get-all-variables" +" set-module-access!)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module" +" #f" +" 20" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)" +" #f" +" 'module)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'source-name)" +"(make-struct-field-accessor -ref_1 1 'self)" +"(make-struct-field-accessor -ref_1 2 'requires)" +"(make-struct-field-accessor -ref_1 3 'provides)" +"(make-struct-field-accessor -ref_1 4 'access)" +"(make-struct-field-accessor -ref_1 5 'language-info)" +"(make-struct-field-accessor -ref_1 6 'min-phase-level)" +"(make-struct-field-accessor -ref_1 7 'max-phase-level)" +"(make-struct-field-accessor -ref_1 8 'phase-level-linklet-info-callback)" +"(make-struct-field-accessor -ref_1 9 'force-bulk-binding)" +"(make-struct-field-accessor -ref_1 10 'prepare-instance)" +"(make-struct-field-accessor -ref_1 11 'instantiate-phase)" +"(make-struct-field-accessor -ref_1 12 'primitive?)" +"(make-struct-field-accessor -ref_1 13 'is-predefined?)" +"(make-struct-field-accessor -ref_1 14 'cross-phase-persistent?)" +"(make-struct-field-accessor -ref_1 15 'no-protected?)" +"(make-struct-field-accessor -ref_1 16 'inspector)" +"(make-struct-field-accessor -ref_1 17 'submodule-names)" +"(make-struct-field-accessor -ref_1 18 'supermodule-name)" +"(make-struct-field-accessor -ref_1 19 'get-all-variables)" +"(make-struct-field-mutator -set!_1 4 'access))))" +"(define-values" +"(struct:module-linklet-info" +" module-linklet-info2.1" +" module-linklet-info?" +" module-linklet-info-linklet-or-instance" +" module-linklet-info-module-uses" +" module-linklet-info-self" +" module-linklet-info-inspector" +" module-linklet-info-extra-inspector" +" module-linklet-info-extra-inspectorsss)" +"(let-values(((struct:_39 make-_39 ?_39 -ref_39 -set!_39)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-linklet-info" +" #f" +" 6" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '(0 1 2 3 4 5)" +" #f" +" 'module-linklet-info)))))" +"(values" +" struct:_39" +" make-_39" +" ?_39" +"(make-struct-field-accessor -ref_39 0 'linklet-or-instance)" +"(make-struct-field-accessor -ref_39 1 'module-uses)" +"(make-struct-field-accessor -ref_39 2 'self)" +"(make-struct-field-accessor -ref_39 3 'inspector)" +"(make-struct-field-accessor -ref_39 4 'extra-inspector)" +"(make-struct-field-accessor -ref_39 5 'extra-inspectorsss))))" +"(define-values" +"(make-module39.1)" +"(lambda(cross-phase-persistent?16_0" +" force-bulk-binding-callback10_0" +" get-all-variables20_0" +" instantiate-phase-callback9_0" +" language-info13_0" +" max-phase-level8_0" +" min-phase-level7_0" +" no-protected?17_0" +" phase-level-linklet-info-callback12_0" +" predefined?15_0" +" prepare-instance-callback11_0" +" primitive?14_0" +" provides6_0" +" requires5_0" +" self4_0" +" source-name3_0" +" submodule-names18_0" +" supermodule-name19_0)" +"(begin" +" 'make-module39" +"(let-values(((source-name_0) source-name3_0))" +"(let-values(((self_4) self4_0))" +"(let-values(((requires_0) requires5_0))" +"(let-values(((provides_3) provides6_0))" +"(let-values(((min-phase-level_0) min-phase-level7_0))" +"(let-values(((max-phase-level_0) max-phase-level8_0))" +"(let-values(((instantiate-phase_0) instantiate-phase-callback9_0))" +"(let-values(((force-bulk-binding_0)" +"(if(eq? force-bulk-binding-callback10_0 unsafe-undefined)" +" void" +" force-bulk-binding-callback10_0)))" +"(let-values(((prepare-instance_0)" +"(if(eq? prepare-instance-callback11_0 unsafe-undefined)" +" void" +" prepare-instance-callback11_0)))" +"(let-values(((phase-level-linklet-info-callback_0)" +"(if(eq? phase-level-linklet-info-callback12_0 unsafe-undefined)" +"(lambda(phase-level_11 ns_19 insp_4)" +"(begin 'phase-level-linklet-info-callback #f))" +" phase-level-linklet-info-callback12_0)))" +"(let-values(((language-info_0) language-info13_0))" +"(let-values(((primitive?_0) primitive?14_0))" +"(let-values(((predefined?_0) predefined?15_0))" +"(let-values(((cross-phase-persistent?_0)" +"(if(eq? cross-phase-persistent?16_0 unsafe-undefined)" +" primitive?_0" +" cross-phase-persistent?16_0)))" +"(let-values(((no-protected?_0) no-protected?17_0))" +"(let-values(((submodule-names_0) submodule-names18_0))" +"(let-values(((supermodule-name_0) supermodule-name19_0))" +"(let-values(((get-all-variables_0)" +"(if(eq? get-all-variables20_0 unsafe-undefined)" +"(lambda()(begin 'get-all-variables null))" +" get-all-variables20_0)))" +"(let-values()" +"(module1.1" +" source-name_0" +" self_4" +"(unresolve-requires requires_0)" +" provides_3" +" #f" +" language-info_0" +" min-phase-level_0" +" max-phase-level_0" +" phase-level-linklet-info-callback_0" +" force-bulk-binding_0" +" prepare-instance_0" +" instantiate-phase_0" +" primitive?_0" +" predefined?_0" +" cross-phase-persistent?_0" +" no-protected?_0" +"(current-code-inspector)" +" submodule-names_0" +" supermodule-name_0" +" get-all-variables_0)))))))))))))))))))))))" +"(define-values" +"(struct:module-instance" +" module-instance42.1" +" module-instance?" +" module-instance-namespace" +" module-instance-module" +" module-instance-shifted-requires" +" module-instance-phase-level-to-state" +" module-instance-made-available?" +" module-instance-attached?" +" module-instance-data-box" +" set-module-instance-shifted-requires!" +" set-module-instance-made-available?!" +" set-module-instance-attached?!)" +"(let-values(((struct:_40 make-_40 ?_40 -ref_40 -set!_40)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-instance" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 3 6)" +" #f" +" 'module-instance)))))" +"(values" +" struct:_40" +" make-_40" +" ?_40" +"(make-struct-field-accessor -ref_40 0 'namespace)" +"(make-struct-field-accessor -ref_40 1 'module)" +"(make-struct-field-accessor -ref_40 2 'shifted-requires)" +"(make-struct-field-accessor -ref_40 3 'phase-level-to-state)" +"(make-struct-field-accessor -ref_40 4 'made-available?)" +"(make-struct-field-accessor -ref_40 5 'attached?)" +"(make-struct-field-accessor -ref_40 6 'data-box)" +"(make-struct-field-mutator -set!_40 2 'shifted-requires)" +"(make-struct-field-mutator -set!_40 4 'made-available?)" +"(make-struct-field-mutator -set!_40 5 'attached?))))" +"(define-values" +"(make-module-instance)" +"(lambda(m-ns_0 m_1)(begin(module-instance42.1 m-ns_0 m_1 #f(make-small-hasheqv) #f #f(box #f)))))" +"(define-values" +"(make-module-namespace50.1)" +"(lambda(for-submodule?45_0 mpi43_0 root-expand-context44_0 ns49_0)" +"(begin" +" 'make-module-namespace50" +"(let-values(((ns_20) ns49_0))" +"(let-values(((name-mpi_0) mpi43_0))" +"(let-values(((root-expand-ctx_1) root-expand-context44_0))" +"(let-values(((for-submodule?_0) for-submodule?45_0))" +"(let-values()" +"(let-values(((phase_28) 0))" +"(let-values(((name_28)(1/module-path-index-resolve name-mpi_0)))" +"(let-values(((m-ns_1)" +"(let-values(((the-struct_38)" +"(let-values(((ns158_0) ns_20)" +"((root-expand-ctx159_0) root-expand-ctx_1)" +"((temp160_0) #f))" +"(new-namespace8.1 temp160_0 root-expand-ctx159_0 ns158_0))))" +"(if(1/namespace? the-struct_38)" +"(let-values(((mpi150_0) name-mpi_0)" +"((source-name151_0)(resolved-module-path-root-name name_28))" +"((phase152_0) phase_28)" +"((0-phase153_0) phase_28)" +"((submodule-declarations154_0)" +"(if for-submodule?_0" +"(namespace-submodule-declarations ns_20)" +"(make-small-hasheq)))" +"((available-module-instances155_0)(make-hasheqv))" +"((module-instances156_0)(make-hasheqv))" +"((declaration-inspector157_0)(current-code-inspector)))" +"(namespace1.1" +" mpi150_0" +" source-name151_0" +"(namespace-root-expand-ctx the-struct_38)" +" phase152_0" +" 0-phase153_0" +"(namespace-phase-to-namespace the-struct_38)" +"(namespace-phase-level-to-definitions the-struct_38)" +"(namespace-module-registry$1 the-struct_38)" +"(namespace-bulk-binding-registry the-struct_38)" +" submodule-declarations154_0" +"(namespace-root-namespace the-struct_38)" +" declaration-inspector157_0" +"(namespace-inspector the-struct_38)" +" available-module-instances155_0" +" module-instances156_0))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_38)))))" +"(let-values((()" +"(begin" +"(small-hash-set!(namespace-phase-to-namespace m-ns_1) phase_28 m-ns_1)" +"(values))))" +"(let-values(((at-phase_0)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances m-ns_1) phase_28 at-phase_0)" +"(hash-set! at-phase_0 name_28(make-module-instance m-ns_1 #f))" +" m-ns_1))))))))))))))" +"(define-values" +"(declare-module!58.1)" +"(lambda(with-submodules?53_0 ns55_0 m56_0 mod-name57_0)" +"(begin" +" 'declare-module!58" +"(let-values(((ns_21) ns55_0))" +"(let-values(((m_2) m56_0))" +"(let-values(((mod-name_4) mod-name57_0))" +"(let-values(((with-submodules?_0) with-submodules?53_0))" +"(let-values()" +"(let-values(((prior-m_0)" +"(if with-submodules?_0" +"(hash-ref" +"(module-registry-declarations(namespace-module-registry$1 ns_21))" +" mod-name_4" +" #f)" +" #f)))" +"(let-values(((prior-mi_0)" +"(if prior-m_0" +"(if(not(eq? m_2 prior-m_0))" +"(let-values(((ns161_0) ns_21)" +"((mod-name162_0) mod-name_4)" +"((temp163_0)(namespace-phase ns_21)))" +"(namespace->module-instance70.1" +" #f" +" #f" +" unsafe-undefined" +" ns161_0" +" mod-name162_0" +" temp163_0))" +" #f)" +" #f)))" +"(begin" +"(if(if prior-m_0(not(eq? m_2 prior-m_0)) #f)" +"(let-values()(check-redeclaration-ok prior-m_0 prior-mi_0 mod-name_4))" +"(void))" +"(if with-submodules?_0" +"(hash-set!(module-registry-declarations(namespace-module-registry$1 ns_21)) mod-name_4 m_2)" +"(small-hash-set!(namespace-submodule-declarations ns_21) mod-name_4 m_2))" +"(if with-submodules?_0" +"(let-values()" +"(begin" +"(register-bulk-provide!" +"(namespace-bulk-binding-registry ns_21)" +" mod-name_4" +"(module-self m_2)" +"(module-provides m_2))" +"((1/current-module-name-resolver) mod-name_4 #f)))" +"(void))" +"(if prior-mi_0" +"(let-values()" +"(let-values(((m-ns_2)(module-instance-namespace prior-mi_0)))" +"(let-values(((states_0)(module-instance-phase-level-to-state prior-mi_0)))" +"(let-values(((phase_29)(namespace-phase ns_21)))" +"(let-values(((visit?_0)(eq? 'started(small-hash-ref states_0(add1 phase_29) #f))))" +"(let-values(((run?_0)(eq? 'started(small-hash-ref states_0 phase_29 #f))))" +"(let-values(((at-phase_1)(hash-ref(namespace-module-instances ns_21) phase_29)))" +"(begin" +"(hash-set! at-phase_1 mod-name_4(make-module-instance m-ns_2 m_2))" +"(if visit?_0" +"(let-values()" +"(let-values(((ns164_0) ns_21)" +"((temp165_0)(namespace-mpi m-ns_2))" +"((phase166_0) phase_29))" +"(namespace-module-visit!104.1" +" unsafe-undefined" +" ns164_0" +" temp165_0" +" phase166_0)))" +"(void))" +"(if run?_0" +"(let-values()" +"(let-values(((ns167_0) ns_21)" +"((temp168_0)(namespace-mpi m-ns_2))" +"((phase169_0) phase_29))" +"(namespace-module-instantiate!96.1" +" #t" +" unsafe-undefined" +" unsafe-undefined" +" #f" +" ns167_0" +" temp168_0" +" phase169_0)))" +"(void))))))))))" +"(void)))))))))))))" +"(define-values" +"(check-redeclaration-ok)" +"(lambda(prior-m_1 prior-mi_1 mod-name_5)" +"(begin" +"(begin" +"(if(module-cross-phase-persistent? prior-m_1)" +"(let-values()" +" (raise-arguments-error 'module \"cannot redeclare cross-phase persistent module\" \"module name\" mod-name_5))" +"(void))" +"(if(if prior-mi_1" +"(let-values(((or-part_146)(module-instance-attached? prior-mi_1)))" +"(if or-part_146" +" or-part_146" +"(not" +"(inspector-superior?" +"(current-code-inspector)" +"(namespace-inspector(module-instance-namespace prior-mi_1))))))" +" #f)" +"(let-values()" +" (raise-arguments-error 'module \"current code inspector cannot redeclare module\" \"module name\" mod-name_5))" +"(void))))))" +"(define-values" +"(raise-unknown-module-error)" +" (lambda (who_9 mod-name_6) (begin (raise-arguments-error who_9 \"unknown module\" \"module name\" mod-name_6))))" +"(define-values" +"(namespace->module-linklet-info)" +"(lambda(ns_22 name_29 phase-level_12)" +"(begin" +"(let-values(((m_3)(namespace->module ns_22 name_29)))" +"(if m_3((module-phase-level-linklet-info-callback m_3) phase-level_12 ns_22(module-inspector m_3)) #f)))))" +"(define-values" +"(namespace->module-instance70.1)" +"(lambda(check-available-at-phase-level62_0" +" complain-on-failure?61_0" +" unavailable-callback63_0" +" ns67_0" +" name68_0" +" 0-phase69_0)" +"(begin" +" 'namespace->module-instance70" +"(let-values(((ns_23) ns67_0))" +"(let-values(((name_30) name68_0))" +"(let-values(((0-phase_1) 0-phase69_0))" +"(let-values(((complain-on-failure?_0) complain-on-failure?61_0))" +"(let-values(((check-available-at-phase-level_0) check-available-at-phase-level62_0))" +"(let-values(((unavailable-callback_0)" +"(if(eq? unavailable-callback63_0 unsafe-undefined) void unavailable-callback63_0)))" +"(let-values()" +"(let-values(((mi_0)" +"(let-values(((or-part_147)" +"(hash-ref" +"(hash-ref(namespace-module-instances ns_23) 0-phase_1 '#hasheq())" +" name_30" +" #f)))" +"(if or-part_147" +" or-part_147" +"(let-values(((or-part_148)" +"(let-values(((c-ns_0)" +"(let-values(((or-part_149)" +"(namespace-root-namespace ns_23)))" +"(if or-part_149 or-part_149 ns_23))))" +"(hash-ref(namespace-module-instances c-ns_0) name_30 #f))))" +"(if or-part_148" +" or-part_148" +"(if complain-on-failure?_0" +" (error \"no module instance found:\" name_30 0-phase_1)" +" #f)))))))" +"(if(if mi_0 check-available-at-phase-level_0 #f)" +"(check-availablilty mi_0 check-available-at-phase-level_0 unavailable-callback_0)" +" mi_0))))))))))))" +"(define-values" +"(namespace-install-module-namespace!)" +"(lambda(ns_24 name_31 0-phase_2 m_4 existing-m-ns_0)" +"(begin" +"(let-values(((m-ns_3)" +"(let-values(((the-struct_39) ns_24))" +"(if(1/namespace? the-struct_39)" +"(let-values(((mpi170_0)(namespace-mpi existing-m-ns_0))" +"((source-name171_0)(namespace-source-name existing-m-ns_0))" +"((root-expand-ctx172_0)(box(unbox(namespace-root-expand-ctx existing-m-ns_0))))" +"((phase173_0)(namespace-phase existing-m-ns_0))" +"((0-phase174_0)(namespace-0-phase existing-m-ns_0))" +"((phase-to-namespace175_0)(make-small-hasheqv))" +"((phase-level-to-definitions176_0)" +"(if(module-cross-phase-persistent? m_4)" +"(namespace-phase-level-to-definitions existing-m-ns_0)" +"(make-small-hasheqv)))" +"((declaration-inspector177_0)(module-inspector m_4))" +"((inspector178_0)(namespace-inspector existing-m-ns_0)))" +"(namespace1.1" +" mpi170_0" +" source-name171_0" +" root-expand-ctx172_0" +" phase173_0" +" 0-phase174_0" +" phase-to-namespace175_0" +" phase-level-to-definitions176_0" +"(namespace-module-registry$1 the-struct_39)" +"(namespace-bulk-binding-registry the-struct_39)" +"(namespace-submodule-declarations the-struct_39)" +"(namespace-root-namespace the-struct_39)" +" declaration-inspector177_0" +" inspector178_0" +"(namespace-available-module-instances the-struct_39)" +"(namespace-module-instances the-struct_39)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_39)))))" +"(let-values(((mi_1)(make-module-instance m-ns_3 m_4)))" +"(if(module-cross-phase-persistent? m_4)" +"(let-values()" +"(begin" +"(small-hash-set!(namespace-phase-to-namespace m-ns_3) 0 m-ns_3)" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 0" +"(namespace->definitions existing-m-ns_0 0))" +"(small-hash-set!(namespace-phase-to-namespace m-ns_3) 1(namespace->namespace-at-phase m-ns_3 1))" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 1" +"(namespace->definitions existing-m-ns_0 1))" +"(hash-set!" +"(namespace-module-instances" +"(let-values(((or-part_150)(namespace-root-namespace ns_24)))(if or-part_150 or-part_150 ns_24)))" +" name_31" +" mi_1)" +"(small-hash-set!(module-instance-phase-level-to-state mi_1) 0 'started)))" +"(let-values()" +"(let-values((()" +"(begin(small-hash-set!(namespace-phase-to-namespace m-ns_3) 0-phase_2 m-ns_3)(values))))" +"(let-values((()" +"(begin" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 0" +"(namespace->definitions existing-m-ns_0 0))" +"(values))))" +"(let-values((()" +"(begin" +"(small-hash-set!(module-instance-phase-level-to-state mi_1) 0 'started)" +"(values))))" +"(let-values(((at-phase_2)" +"(let-values(((or-part_151)" +"(hash-ref(namespace-module-instances ns_24) 0-phase_2 #f)))" +"(if or-part_151" +" or-part_151" +"(let-values(((at-phase_3)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances ns_24) 0-phase_2 at-phase_3)" +" at-phase_3))))))" +"(hash-set! at-phase_2 name_31 mi_1))))))))))))" +"(define-values" +"(namespace-create-module-instance!)" +"(lambda(ns_25 name_32 0-phase_3 m_5 mpi_15)" +"(begin" +"(let-values(((m-ns_4)" +"(let-values(((the-struct_40) ns_25))" +"(if(1/namespace? the-struct_40)" +"(let-values(((mpi179_0) mpi_15)" +"((source-name180_0)" +"(let-values(((or-part_152)(module-source-name m_5)))" +"(if or-part_152" +" or-part_152" +"(resolved-module-path-root-name(1/module-path-index-resolve mpi_15)))))" +"((root-expand-ctx181_0)(box #f))" +"((phase182_0) 0-phase_3)" +"((0-phase183_0) 0-phase_3)" +"((phase-to-namespace184_0)(make-small-hasheqv))" +"((phase-level-to-definitions185_0)(make-small-hasheqv))" +"((declaration-inspector186_0)(module-inspector m_5))" +"((inspector187_0)(make-inspector(module-inspector m_5))))" +"(namespace1.1" +" mpi179_0" +" source-name180_0" +" root-expand-ctx181_0" +" phase182_0" +" 0-phase183_0" +" phase-to-namespace184_0" +" phase-level-to-definitions185_0" +"(namespace-module-registry$1 the-struct_40)" +"(namespace-bulk-binding-registry the-struct_40)" +"(namespace-submodule-declarations the-struct_40)" +"(namespace-root-namespace the-struct_40)" +" declaration-inspector186_0" +" inspector187_0" +"(namespace-available-module-instances the-struct_40)" +"(namespace-module-instances the-struct_40)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_40)))))" +"(let-values((()(begin(small-hash-set!(namespace-phase-to-namespace m-ns_4) 0-phase_3 m-ns_4)(values))))" +"(let-values(((mi_2)(make-module-instance m-ns_4 m_5)))" +"(begin" +"(if(module-cross-phase-persistent? m_5)" +"(hash-set!(namespace-module-instances ns_25) name_32 mi_2)" +"(let-values(((at-phase_4)" +"(let-values(((or-part_153)(hash-ref(namespace-module-instances ns_25) 0-phase_3 #f)))" +"(if or-part_153" +" or-part_153" +"(let-values(((at-phase_5)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances ns_25) 0-phase_3 at-phase_5)" +" at-phase_5))))))" +"(hash-set! at-phase_4 name_32 mi_2)))" +" mi_2)))))))" +"(define-values" +"(check-availablilty)" +"(lambda(mi_3 check-available-at-phase-level_1 unavailable-callback_1)" +"(begin" +"(let-values(((m_6)(module-instance-module mi_3)))" +"(if(if m_6" +"(if(<=(module-min-phase-level m_6)(add1 check-available-at-phase-level_1)(module-max-phase-level m_6))" +"(not" +"(small-hash-ref" +"(module-instance-phase-level-to-state mi_3)" +"(add1 check-available-at-phase-level_1)" +" #f))" +" #f)" +" #f)" +"(unavailable-callback_1 mi_3)" +" mi_3)))))" +"(define-values" +"(namespace->module-namespace82.1)" +"(lambda(check-available-at-phase-level74_0" +" complain-on-failure?73_0" +" unavailable-callback75_0" +" ns79_0" +" name80_0" +" 0-phase81_0)" +"(begin" +" 'namespace->module-namespace82" +"(let-values(((ns_26) ns79_0))" +"(let-values(((name_33) name80_0))" +"(let-values(((0-phase_4) 0-phase81_0))" +"(let-values(((complain-on-failure?_1) complain-on-failure?73_0))" +"(let-values(((check-available-at-phase-level_2) check-available-at-phase-level74_0))" +"(let-values(((unavailable-callback_2)" +"(if(eq? unavailable-callback75_0 unsafe-undefined) void unavailable-callback75_0)))" +"(let-values()" +"(let-values(((mi_4)" +"(let-values(((ns188_0) ns_26)" +"((name189_0) name_33)" +"((0-phase190_0) 0-phase_4)" +"((complain-on-failure?191_0) complain-on-failure?_1)" +"((check-available-at-phase-level192_0) check-available-at-phase-level_2)" +"((unavailable-callback193_0) unavailable-callback_2))" +"(namespace->module-instance70.1" +" check-available-at-phase-level192_0" +" complain-on-failure?191_0" +" unavailable-callback193_0" +" ns188_0" +" name189_0" +" 0-phase190_0))))" +"(if mi_4(module-instance-namespace mi_4) #f))))))))))))" +"(define-values" +"(namespace-record-module-instance-attached!)" +"(lambda(ns_27 mod-name_7 phase_30)" +"(begin" +"(let-values(((mi_5)" +"(let-values(((ns194_0) ns_27)((mod-name195_0) mod-name_7)((phase196_0) phase_30))" +"(namespace->module-instance70.1 #f #f unsafe-undefined ns194_0 mod-name195_0 phase196_0))))" +"(set-module-instance-attached?! mi_5 #t)))))" +"(define-values" +"(module-force-bulk-binding!)" +"(lambda(m_7 ns_28)(begin((module-force-bulk-binding m_7)(namespace-bulk-binding-registry ns_28)))))" +"(define-values" +"(namespace-module-instantiate!96.1)" +"(lambda(otherwise-available?87_0 run-phase85_0 seen88_0 skip-run?86_0 ns93_0 mpi94_0 instance-phase95_0)" +"(begin" +" 'namespace-module-instantiate!96" +"(let-values(((ns_29) ns93_0))" +"(let-values(((mpi_16) mpi94_0))" +"(let-values(((instance-phase_0) instance-phase95_0))" +"(let-values(((run-phase_0)" +"(if(eq? run-phase85_0 unsafe-undefined)(namespace-phase ns_29) run-phase85_0)))" +"(let-values(((skip-run?_0) skip-run?86_0))" +"(let-values(((otherwise-available?_0) otherwise-available?87_0))" +"(let-values(((seen_17)(if(eq? seen88_0 unsafe-undefined) '#hasheq() seen88_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/module-path-index? mpi_16)" +"(void)" +" (let-values () (error \"not a module path index:\" mpi_16)))" +"(values))))" +"(let-values(((name_34)(1/module-path-index-resolve mpi_16 #t)))" +"(let-values(((m_8)(namespace->module ns_29 name_34)))" +"(let-values((()" +"(begin" +"(if m_8" +"(void)" +"(let-values()(raise-unknown-module-error 'instantiate name_34)))" +"(values))))" +"(let-values(((instantiate!_0)" +"(lambda(instance-phase_1 run-phase_1 ns_30)" +"(begin" +" 'instantiate!" +"(let-values(((mi_6)" +"(let-values(((or-part_154)" +"(let-values(((ns203_0) ns_30)" +"((name204_0) name_34)" +"((instance-phase205_0)" +" instance-phase_1))" +"(namespace->module-instance70.1" +" #f" +" #f" +" unsafe-undefined" +" ns203_0" +" name204_0" +" instance-phase205_0))))" +"(if or-part_154" +" or-part_154" +"(namespace-create-module-instance!" +" ns_30" +" name_34" +" instance-phase_1" +" m_8" +" mpi_16)))))" +"(let-values(((mi197_0) mi_6)" +"((ns198_0) ns_30)" +"((run-phase199_0) run-phase_1)" +"((skip-run?200_0) skip-run?_0)" +"((otherwise-available?201_0) otherwise-available?_0)" +"((seen202_0) seen_17))" +"(run-module-instance!125.1" +" otherwise-available?201_0" +" run-phase199_0" +" seen202_0" +" skip-run?200_0" +" mi197_0" +" ns198_0)))))))" +"(if(module-cross-phase-persistent? m_8)" +"(let-values()" +"(instantiate!_0" +" 0" +" 0" +"(let-values(((or-part_155)(namespace-root-namespace ns_29)))" +"(if or-part_155 or-part_155 ns_29))))" +"(let-values()(instantiate!_0 instance-phase_0 run-phase_0 ns_29)))))))))))))))))))" +"(define-values" +"(namespace-module-visit!104.1)" +"(lambda(visit-phase99_0 ns101_0 mpi102_0 instance-phase103_0)" +"(begin" +" 'namespace-module-visit!104" +"(let-values(((ns_31) ns101_0))" +"(let-values(((mpi_17) mpi102_0))" +"(let-values(((instance-phase_2) instance-phase103_0))" +"(let-values(((visit-phase_0)" +"(if(eq? visit-phase99_0 unsafe-undefined)(namespace-phase ns_31) visit-phase99_0)))" +"(let-values()" +"(let-values(((ns206_0) ns_31)" +"((mpi207_0) mpi_17)" +"((instance-phase208_0) instance-phase_2)" +"((temp209_0)(add1 visit-phase_0)))" +"(namespace-module-instantiate!96.1" +" #t" +" temp209_0" +" unsafe-undefined" +" #f" +" ns206_0" +" mpi207_0" +" instance-phase208_0))))))))))" +"(define-values" +"(namespace-module-make-available!112.1)" +"(lambda(visit-phase107_0 ns109_0 mpi110_0 instance-phase111_0)" +"(begin" +" 'namespace-module-make-available!112" +"(let-values(((ns_32) ns109_0))" +"(let-values(((mpi_18) mpi110_0))" +"(let-values(((instance-phase_3) instance-phase111_0))" +"(let-values(((visit-phase_1)" +"(if(eq? visit-phase107_0 unsafe-undefined)(namespace-phase ns_32) visit-phase107_0)))" +"(let-values()" +"(let-values(((ns210_0) ns_32)" +"((mpi211_0) mpi_18)" +"((instance-phase212_0) instance-phase_3)" +"((temp213_0)(add1 visit-phase_1))" +"((temp214_0) #t))" +"(namespace-module-instantiate!96.1" +" #t" +" temp213_0" +" unsafe-undefined" +" temp214_0" +" ns210_0" +" mpi211_0" +" instance-phase212_0))))))))))" +"(define-values" +"(run-module-instance!125.1)" +"(lambda(otherwise-available?117_0 run-phase115_0 seen118_0 skip-run?116_0 mi123_0 ns124_0)" +"(begin" +" 'run-module-instance!125" +"(let-values(((mi_7) mi123_0))" +"(let-values(((ns_33) ns124_0))" +"(let-values(((run-phase_2) run-phase115_0))" +"(let-values(((skip-run?_1) skip-run?116_0))" +"(let-values(((otherwise-available?_1) otherwise-available?117_0))" +"(let-values(((seen_18)(if(eq? seen118_0 unsafe-undefined) '#hasheq() seen118_0)))" +"(let-values()" +"(let-values()" +"(let-values(((m-ns_5)(module-instance-namespace mi_7)))" +"(let-values(((instance-phase_4)(namespace-0-phase m-ns_5)))" +"(let-values(((run-phase-level_0)(phase- run-phase_2 instance-phase_4)))" +"(if(if(let-values(((or-part_156) skip-run?_1))" +"(if or-part_156" +" or-part_156" +"(eq?" +" 'started" +"(small-hash-ref" +"(module-instance-phase-level-to-state mi_7)" +" run-phase-level_0" +" #f))))" +"(let-values(((or-part_157)(not otherwise-available?_1)))" +"(if or-part_157 or-part_157(module-instance-made-available? mi_7)))" +" #f)" +"(void)" +"(let-values()" +"(let-values(((m_9)(module-instance-module mi_7)))" +"(let-values((()" +"(begin" +"(if m_9" +"(void)" +"(let-values()" +"(error" +" 'require" +" \"import cycle detected; trying to run module being expanded\")))" +"(values))))" +"(let-values(((mpi_19)(namespace-mpi m-ns_5)))" +"(let-values(((phase-shift_3) instance-phase_4))" +"(let-values(((bulk-binding-registry_3)" +"(namespace-bulk-binding-registry m-ns_5)))" +"(begin" +"(if(hash-ref seen_18 mi_7 #f)" +"(let-values()" +" (error 'require \"import cycle detected during module instantiation\"))" +"(void))" +"(if(module-instance-shifted-requires mi_7)" +"(void)" +"(let-values()" +"(set-module-instance-shifted-requires!" +" mi_7" +"(reverse$1" +"(let-values(((lst_59)(module-requires m_9)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_59)))" +"((letrec-values(((for-loop_86)" +"(lambda(fold-var_43 lst_60)" +"(begin" +" 'for-loop" +"(if(pair? lst_60)" +"(let-values(((phase+mpis_0)" +"(unsafe-car lst_60))" +"((rest_27)" +"(unsafe-cdr lst_60)))" +"(let-values(((fold-var_44)" +"(let-values(((fold-var_45)" +" fold-var_43))" +"(let-values(((fold-var_46)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +"(car" +" phase+mpis_0)" +"(reverse$1" +"(let-values(((lst_61)" +"(cdr" +" phase+mpis_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_61)))" +"((letrec-values(((for-loop_87)" +"(lambda(fold-var_47" +" lst_62)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_62)" +"(let-values(((req-mpi_0)" +"(unsafe-car" +" lst_62))" +"((rest_28)" +"(unsafe-cdr" +" lst_62)))" +"(let-values(((fold-var_48)" +"(let-values(((fold-var_49)" +" fold-var_47))" +"(let-values(((fold-var_50)" +"(let-values()" +"(cons" +"(let-values()" +"(module-path-index-shift" +" req-mpi_0" +"(module-self" +" m_9)" +" mpi_19))" +" fold-var_49))))" +"(values" +" fold-var_50)))))" +"(if(not" +" #f)" +"(for-loop_87" +" fold-var_48" +" rest_28)" +" fold-var_48)))" +" fold-var_47)))))" +" for-loop_87)" +" null" +" lst_61))))))" +" fold-var_45))))" +"(values" +" fold-var_46)))))" +"(if(not #f)" +"(for-loop_86 fold-var_44 rest_27)" +" fold-var_44)))" +" fold-var_43)))))" +" for-loop_86)" +" null" +" lst_59)))))))" +"(let-values(((lst_63)(module-instance-shifted-requires mi_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_63)))" +"((letrec-values(((for-loop_88)" +"(lambda(lst_64)" +"(begin" +" 'for-loop" +"(if(pair? lst_64)" +"(let-values(((phase+mpis_1)" +"(unsafe-car lst_64))" +"((rest_29)(unsafe-cdr lst_64)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((req-phase_0)" +"(car" +" phase+mpis_1)))" +"(begin" +"(let-values(((lst_65)" +"(cdr" +" phase+mpis_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_65)))" +"((letrec-values(((for-loop_89)" +"(lambda(lst_66)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_66)" +"(let-values(((req-mpi_1)" +"(unsafe-car" +" lst_66))" +"((rest_30)" +"(unsafe-cdr" +" lst_66)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((ns215_0)" +" ns_33)" +"((req-mpi216_0)" +" req-mpi_1)" +"((temp217_0)" +"(phase+" +" instance-phase_4" +" req-phase_0))" +"((run-phase218_0)" +" run-phase_2)" +"((skip-run?219_0)" +" skip-run?_1)" +"((otherwise-available?220_0)" +" otherwise-available?_1)" +"((temp221_0)" +"(hash-set" +" seen_18" +" mi_7" +" #t)))" +"(namespace-module-instantiate!96.1" +" otherwise-available?220_0" +" run-phase218_0" +" temp221_0" +" skip-run?219_0" +" ns215_0" +" req-mpi216_0" +" temp217_0)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_89" +" rest_30)" +"(values))))" +"(values))))))" +" for-loop_89)" +" lst_65)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_88 rest_29)" +"(values))))" +"(values))))))" +" for-loop_88)" +" lst_63)))" +"(void)" +"(if(label-phase? instance-phase_4)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((start_13)(module-max-phase-level m_9))" +"((end_9)(sub1(module-min-phase-level m_9)))" +"((inc_3) -1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_13 end_9 inc_3)))" +"((letrec-values(((for-loop_90)" +"(lambda(pos_11)" +"(begin" +" 'for-loop" +"(if(> pos_11 end_9)" +"(let-values(((phase-level_13) pos_11))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_31)" +"(phase+" +" phase-level_13" +" phase-shift_3)))" +"(if(if(not" +" skip-run?_1)" +"(eqv?" +" phase_31" +" run-phase_2)" +" #f)" +"(let-values()" +"(if(eq?" +" 'started" +"(small-hash-ref" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_13" +" #f))" +"(void)" +"(let-values()" +"(let-values((()" +"(begin" +"(small-hash-set!" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_13" +" 'started)" +"(values))))" +"(let-values((()" +"(begin" +"(void" +"(namespace->definitions" +" m-ns_5" +" phase-level_13))" +"(values))))" +"(let-values(((p-ns_2)" +"(namespace->namespace-at-phase" +" m-ns_5" +" phase_31)))" +"(let-values(((insp_5)" +"(module-inspector" +" m_9)))" +"(let-values(((data-box_0)" +"(module-instance-data-box" +" mi_7)))" +"(let-values(((prep_0)" +"(module-prepare-instance" +" m_9)))" +"(let-values(((go_0)" +"(module-instantiate-phase" +" m_9)))" +"(begin" +"(prep_0" +" data-box_0" +" p-ns_2" +" phase-shift_3" +" mpi_19" +" bulk-binding-registry_3" +" insp_5)" +"(go_0" +" data-box_0" +" p-ns_2" +" phase-shift_3" +" phase-level_13" +" mpi_19" +" bulk-binding-registry_3" +" insp_5))))))))))))" +"(if(if otherwise-available?_1" +"(if(not" +"(negative?" +" run-phase_2))" +"(not" +"(small-hash-ref" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_13" +" #f))" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(hash-update!" +"(namespace-available-module-instances" +" ns_33)" +" phase_31" +"(lambda(l_47)" +"(cons" +" mi_7" +" l_47))" +" null)" +"(small-hash-set!" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_13" +" 'available)))" +"(void)))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_90(+ pos_11 inc_3))" +"(values))))" +"(values))))))" +" for-loop_90)" +" start_13)))" +"(void))))" +"(if otherwise-available?_1" +"(let-values()(set-module-instance-made-available?! mi_7 #t))" +"(void))" +"(if skip-run?_1" +"(void)" +"(let-values()" +"(small-hash-set!" +"(module-instance-phase-level-to-state mi_7)" +" run-phase-level_0" +" 'started)))))))))))))))))))))))))" +"(define-values" +"(namespace-visit-available-modules!)" +"(let-values(((namespace-visit-available-modules!130_0)" +"(lambda(ns129_0 run-phase128_0)" +"(begin" +" 'namespace-visit-available-modules!130" +"(let-values(((ns_34) ns129_0))" +"(let-values(((run-phase_3)" +"(if(eq? run-phase128_0 unsafe-undefined)(namespace-phase ns_34) run-phase128_0)))" +"(let-values()(namespace-run-available-modules! ns_34(add1 run-phase_3)))))))))" +"(case-lambda" +"((ns_35)(begin(namespace-visit-available-modules!130_0 ns_35 unsafe-undefined)))" +"((ns_36 run-phase128_1)(namespace-visit-available-modules!130_0 ns_36 run-phase128_1)))))" +"(define-values" +"(namespace-run-available-modules!)" +"(let-values(((namespace-run-available-modules!134_0)" +"(lambda(ns133_0 run-phase132_0)" +"(begin" +" 'namespace-run-available-modules!134" +"(let-values(((ns_37) ns133_0))" +"(let-values(((run-phase_4)" +"(if(eq? run-phase132_0 unsafe-undefined)(namespace-phase ns_37) run-phase132_0)))" +"(let-values()" +"(registry-call-with-lock" +"(namespace-module-registry$1 ns_37)" +"(lambda()" +"((letrec-values(((loop_79)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((mis_0)" +"(hash-ref" +"(namespace-available-module-instances ns_37)" +" run-phase_4" +" null)))" +"(if(null? mis_0)" +"(void)" +"(let-values()" +"(begin" +"(hash-set!" +"(namespace-available-module-instances ns_37)" +" run-phase_4" +" null)" +"(let-values(((lst_67)(reverse$1 mis_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_67)))" +"((letrec-values(((for-loop_91)" +"(lambda(lst_68)" +"(begin" +" 'for-loop" +"(if(pair? lst_68)" +"(let-values(((mi_8)" +"(unsafe-car" +" lst_68))" +"((rest_31)" +"(unsafe-cdr" +" lst_68)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((mi222_0)" +" mi_8)" +"((ns223_0)" +" ns_37)" +"((run-phase224_0)" +" run-phase_4)" +"((temp225_0)" +" #f)" +"((temp226_0)" +" #f))" +"(run-module-instance!125.1" +" temp226_0" +" run-phase224_0" +" unsafe-undefined" +" temp225_0" +" mi222_0" +" ns223_0)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_91 rest_31)" +"(values))))" +"(values))))))" +" for-loop_91)" +" lst_67)))" +"(void)" +"(loop_79)))))))))" +" loop_79)))))))))))" +"(case-lambda" +"((ns_38)(begin(namespace-run-available-modules!134_0 ns_38 unsafe-undefined)))" +"((ns_39 run-phase132_1)(namespace-run-available-modules!134_0 ns_39 run-phase132_1)))))" +"(define-values" +"(namespace-primitive-module-visit!)" +"(lambda(ns_40 name_35)" +"(begin" +"(let-values(((mi_9)(hash-ref(namespace-module-instances ns_40)(1/make-resolved-module-path name_35))))" +"(let-values(((mi227_0) mi_9)((ns228_0) ns_40)((temp229_0) 1)((temp230_0) #f)((temp231_0) #t))" +"(run-module-instance!125.1 temp231_0 temp229_0 unsafe-undefined temp230_0 mi227_0 ns228_0))))))" +"(define-values" +"(namespace-module-use->module+linklet-instances144.1)" +"(lambda(phase-shift138_0 shift-from136_0 shift-to137_0 ns142_0 mu143_0)" +"(begin" +" 'namespace-module-use->module+linklet-instances144" +"(let-values(((ns_41) ns142_0))" +"(let-values(((mu_0) mu143_0))" +"(let-values(((shift-from_0) shift-from136_0))" +"(let-values(((shift-to_0) shift-to137_0))" +"(let-values(((phase-shift_4) phase-shift138_0))" +"(let-values()" +"(let-values(((mod_1)(module-use-module mu_0)))" +"(let-values(((mi_10)" +"(let-values(((ns232_0) ns_41)" +"((temp233_0)" +"(1/module-path-index-resolve" +"(if shift-from_0" +"(module-path-index-shift mod_1 shift-from_0 shift-to_0)" +" mod_1)))" +"((phase-shift234_0) phase-shift_4)" +"((temp235_0) #t))" +"(namespace->module-instance70.1" +" #f" +" temp235_0" +" unsafe-undefined" +" ns232_0" +" temp233_0" +" phase-shift234_0))))" +"(let-values(((m-ns_6)(module-instance-namespace mi_10)))" +"(let-values(((d_17)" +"(small-hash-ref" +"(namespace-phase-level-to-definitions m-ns_6)" +"(module-use-phase mu_0)" +" #f)))" +"(if d_17" +"(values mi_10(definitions-variables d_17))" +"(error" +" 'eval" +"(string-append" +" \"namespace mismatch: phase level not found;\\n\"" +" \" module: ~a\\n\"" +" \" phase level: ~a\\n\"" +" \" found phase levels: ~a\")" +" mod_1" +"(module-use-phase mu_0)" +"(small-hash-keys(namespace-phase-level-to-definitions m-ns_6)))))))))))))))))" +"(define-values" +"(unresolve-requires)" +"(lambda(requires_1)" +"(begin" +"(reverse$1" +"(let-values(((lst_69) requires_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_69)))" +"((letrec-values(((for-loop_92)" +"(lambda(fold-var_51 lst_70)" +"(begin" +" 'for-loop" +"(if(pair? lst_70)" +"(let-values(((phase+mpis_2)(unsafe-car lst_70))((rest_32)(unsafe-cdr lst_70)))" +"(let-values(((fold-var_52)" +"(let-values(((fold-var_53) fold-var_51))" +"(let-values(((fold-var_54)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +"(car phase+mpis_2)" +"(reverse$1" +"(let-values(((lst_71)(cdr phase+mpis_2)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_71)))" +"((letrec-values(((for-loop_93)" +"(lambda(fold-var_55" +" lst_72)" +"(begin" +" 'for-loop" +"(if(pair? lst_72)" +"(let-values(((req-mpi_2)" +"(unsafe-car" +" lst_72))" +"((rest_33)" +"(unsafe-cdr" +" lst_72)))" +"(let-values(((fold-var_56)" +"(let-values(((fold-var_57)" +" fold-var_55))" +"(let-values(((fold-var_58)" +"(let-values()" +"(cons" +"(let-values()" +"(module-path-index-unresolve" +" req-mpi_2))" +" fold-var_57))))" +"(values" +" fold-var_58)))))" +"(if(not #f)" +"(for-loop_93" +" fold-var_56" +" rest_33)" +" fold-var_56)))" +" fold-var_55)))))" +" for-loop_93)" +" null" +" lst_71))))))" +" fold-var_53))))" +"(values fold-var_54)))))" +"(if(not #f)(for-loop_92 fold-var_52 rest_32) fold-var_52)))" +" fold-var_51)))))" +" for-loop_92)" +" null" +" lst_69)))))))" +"(define-values" +"(module-compute-access!)" +"(lambda(m_10)" +"(begin" +"(let-values(((access_0)" +"(let-values(((ht_71)(module-provides m_10)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_71)))" +"((letrec-values(((for-loop_94)" +"(lambda(table_103 i_89)" +"(begin" +" 'for-loop" +"(if i_89" +"(let-values(((phase_32 at-phase_6)" +"(hash-iterate-key+value ht_71 i_89)))" +"(let-values(((table_104)" +"(let-values(((table_105) table_103))" +"(let-values(((table_106)" +"(let-values()" +"(let-values(((key_40 val_33)" +"(let-values()" +"(values" +" phase_32" +"(let-values(((ht_72)" +" at-phase_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_72)))" +"((letrec-values(((for-loop_95)" +"(lambda(table_107" +" i_90)" +"(begin" +" 'for-loop" +"(if i_90" +"(let-values(((sym_23" +" binding/p_1)" +"(hash-iterate-key+value" +" ht_72" +" i_90)))" +"(let-values(((table_108)" +"(let-values(((table_109)" +" table_107))" +"(let-values(((table_110)" +"(let-values()" +"(let-values(((key_41" +" val_34)" +"(let-values()" +"(values" +"(module-binding-sym" +"(provided-as-binding" +" binding/p_1))" +"(if(provided-as-protected?" +" binding/p_1)" +" 'protected" +" 'provided)))))" +"(hash-set" +" table_109" +" key_41" +" val_34)))))" +"(values" +" table_110)))))" +"(if(not" +" #f)" +"(for-loop_95" +" table_108" +"(hash-iterate-next" +" ht_72" +" i_90))" +" table_108)))" +" table_107)))))" +" for-loop_95)" +" '#hash()" +"(hash-iterate-first" +" ht_72))))))))" +"(hash-set" +" table_105" +" key_40" +" val_33)))))" +"(values table_106)))))" +"(if(not #f)" +"(for-loop_94 table_104(hash-iterate-next ht_71 i_89))" +" table_104)))" +" table_103)))))" +" for-loop_94)" +" '#hasheqv()" +"(hash-iterate-first ht_71))))))" +"(begin(set-module-access! m_10 access_0) access_0)))))" +"(define-values" +"(binding->module-instance)" +"(lambda(b_42 ns_42 phase_33 id_11)" +"(begin" +"(let-values(((at-phase_7)(phase- phase_33(module-binding-phase b_42))))" +"(let-values(((mi_11)" +"(let-values(((ns1_0) ns_42)" +"((temp2_0)(1/module-path-index-resolve(module-binding-module b_42)))" +"((at-phase3_0) at-phase_7)" +"((temp4_0)(module-binding-phase b_42))" +"((temp5_0)(lambda(mi_12) 'unavailable)))" +"(namespace->module-instance70.1 temp4_0 #f temp5_0 ns1_0 temp2_0 at-phase3_0))))" +"(begin" +"(if(eq? mi_11 'unavailable)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(format" +"(string-append" +" \"module mismatch;\\n\"" +" \" attempted to use a module that is not available\\n\"" +" \" possible cause:\\n\"" +" \" using (dynamic-require .... #f)\\n\"" +" \" but need (dynamic-require .... 0)\\n\"" +" \" module: ~s\\n\"" +" \" phase: ~s\")" +"(module-binding-module b_42)" +"(phase+ at-phase_7(module-binding-phase b_42)))" +" id_11))" +"(void))" +"(if mi_11" +"(void)" +"(let-values()" +"(error" +" 'expand" +"(string-append" +" \"namespace mismatch; cannot locate module instance\\n\"" +" \" module: ~s\\n\"" +" \" use phase: ~a\\n\"" +" \" definition phase: ~a\\n\"" +" \" for identifier: ~s\")" +"(module-binding-module b_42)" +" phase_33" +"(module-binding-phase b_42)" +" id_11)))" +" mi_11))))))" +"(define-values" +"(check-access)" +"(lambda(b_42 mi_13 id_12 in-s_0 what_0)" +"(begin" +"(let-values(((m_11)(module-instance-module mi_13)))" +"(if(if m_11(not(module-no-protected? m_11)) #f)" +"(let-values()" +"(let-values(((access_1)" +"(let-values(((or-part_27)(module-access m_11)))" +"(if or-part_27 or-part_27(module-compute-access! m_11)))))" +"(let-values(((a_39)" +"(hash-ref" +"(hash-ref access_1(module-binding-phase b_42) '#hasheq())" +"(module-binding-sym b_42)" +" 'unexported)))" +"(if(let-values(((or-part_10)(eq? a_39 'unexported)))" +"(if or-part_10 or-part_10(eq? a_39 'protected)))" +"(let-values()" +"(begin" +"(if(let-values(((or-part_158)" +"(inspector-superior?" +"(let-values(((or-part_12)(syntax-inspector id_12)))" +"(if or-part_12 or-part_12(current-code-inspector)))" +"(namespace-inspector(module-instance-namespace mi_13)))))" +"(if or-part_158" +" or-part_158" +"(if(module-binding-extra-inspector b_42)" +"(inspector-superior?" +"(module-binding-extra-inspector b_42)" +"(namespace-inspector(module-instance-namespace mi_13)))" +" #f)))" +"(void)" +"(let-values()" +"(let-values(((complain-id_0)" +"(let-values(((c-id_0)" +"(let-values(((or-part_3) in-s_0))" +"(if or-part_3 or-part_3(module-binding-sym b_42)))))" +"(if(not" +"(eq?" +"(if(syntax?$1 c-id_0)(syntax-content c-id_0) c-id_0)" +"(syntax-content id_12)))" +" c-id_0" +" #f))))" +"(raise-syntax-error$1" +" #f" +"(format" +" \"access disallowed by code inspector to ~a ~a\\n from module: ~a\"" +" a_39" +" what_0" +"(1/module-path-index-resolve(namespace-mpi(module-instance-namespace mi_13))))" +" complain-id_0" +" id_12" +" null))))" +" #t))" +"(let-values() #f)))))" +"(let-values() #f))))))" +"(define-values" +"(resolve+shift/extra-inspector)" +"(lambda(id_13 phase_34 ns_43)" +"(begin" +"((letrec-values(((loop_80)" +"(lambda(id_14 in-s_1)" +"(begin" +" 'loop" +"(let-values(((b_59)" +"(let-values(((id1_2) id_14)((phase2_0) phase_34)((temp3_0) #t))" +"(resolve+shift28.1 #f #f null temp3_0 #f id1_2 phase2_0))))" +"(let-values(((c1_24)(binding-free=id b_59)))" +"(if c1_24" +"((lambda(next-id_0)" +"(let-values((()" +"(begin" +"(if(if(module-binding? b_59)" +"(not" +"(top-level-module-path-index?(module-binding-module b_59)))" +" #f)" +"(let-values()" +"(let-values(((mi_14)" +"(binding->module-instance" +" b_59" +" ns_43" +" phase_34" +" id_14)))" +" (check-access b_59 mi_14 id_14 in-s_1 \"provided binding\")))" +"(void))" +"(values))))" +"(let-values(((next-b_0)" +"(loop_80" +" next-id_0" +"(let-values(((or-part_75) in-s_1))" +"(if or-part_75 or-part_75 id_14)))))" +"(if(not next-b_0)" +"(let-values() b_59)" +"(if(if(module-binding? next-b_0)" +"(if(not(module-binding-extra-inspector next-b_0))" +"(syntax-inspector id_14)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((next-b4_0) next-b_0)((temp5_1)(syntax-inspector id_14)))" +"(module-binding-update48.1" +" temp5_1" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" next-b4_0)))" +"(let-values() next-b_0))))))" +" c1_24)" +"(let-values() b_59))))))))" +" loop_80)" +" id_13" +" #f))))" +"(define-values" +"(1/prop:set!-transformer 1/set!-transformer? set!-transformer-value)" +"(make-struct-type-property" +" 'set!-transformer" +"(lambda(v_28 info_1)" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)" +"(if(procedure? v_28)" +"(let-values(((or-part_2)(procedure-arity-includes? v_28 1)))" +"(if or-part_2 or-part_2(procedure-arity-includes? v_28 2)))" +" #f)))" +"(if or-part_11 or-part_11(exact-nonnegative-integer? v_28)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:set!-transformer" +"(string-append" +" \"(or/c (procedure-arity-includes? proc 1)\\n\"" +" \" (procedure-arity-includes? proc 2)\\n\"" +" \" exact-nonnegative-integer?)\")" +" v_28)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? v_28)" +"(let-values()" +"(begin" +"(if(<= v_28(list-ref info_1 1))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:set!-transformer" +" \"field index >= initialized-field count for structure type\"" +" \"field index\"" +" v_28" +" \"initialized-field count\"" +"(list-ref info_1 1))))" +"(if(member v_28(list-ref info_1 5))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:set!-transformer" +" \"field index not declared immutable\"" +" \"field index\"" +" v_28)))))" +"(void))" +"(values))))" +"(let-values(((ref_0)(list-ref info_1 3)))" +"(if(integer? v_28)" +"(let-values()" +"(lambda(t_36)" +"(let-values(((p_32)(ref_0 t_36 v_28)))" +"(if(if(procedure? p_32)(procedure-arity-includes? p_32 1) #f)" +" p_32" +" (lambda (s_3) (error \"bad syntax:\" s_3))))))" +"(let-values()(lambda(t_15) v_28)))))))))" +"(define-values" +"(1/make-set!-transformer)" +"(let-values()" +"(let-values(((struct:set!-transformer_0 set!-transformer1_0 set!-transformer?_0 set!-transformer-proc_0)" +"(let-values(((struct:_41 make-_41 ?_41 -ref_41 -set!_41)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'set!-transformer" +" #f" +" 1" +" 0" +" #f" +"(list(cons 1/prop:set!-transformer 0))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'set!-transformer)))))" +"(values struct:_41 make-_41 ?_41(make-struct-field-accessor -ref_41 0 'proc)))))" +"(lambda(proc_3)" +"(begin" +" 'make-set!-transformer" +"(begin" +"(if(if(procedure? proc_3)(procedure-arity-includes? proc_3 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'make-set!-transformer \"(procedure-arity-includes/c 1)\" proc_3)))" +"(set!-transformer1_0 proc_3)))))))" +"(define-values" +"(1/set!-transformer-procedure)" +"(lambda(t_39)" +"(begin" +" 'set!-transformer-procedure" +"(let-values(((v_99)((set!-transformer-value t_39) t_39)))" +"(if(procedure-arity-includes? v_99 1) v_99(lambda(s_167)(v_99 t_39 s_167)))))))" +"(define-values(empty-env) '#hasheq())" +"(define-values(env-extend)(lambda(env_0 key_42 val_21)(begin(hash-set env_0 key_42 val_21))))" +"(define-values(variable)(gensym 'variable))" +"(define-values" +"(variable?)" +"(lambda(t_15)" +"(begin(let-values(((or-part_10)(eq? t_15 variable)))(if or-part_10 or-part_10(local-variable? t_15))))))" +"(define-values" +"(struct:local-variable local-variable1.1 local-variable? local-variable-id)" +"(let-values(((struct:_31 make-_31 ?_31 -ref_31 -set!_31)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'local-variable" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'local-variable)))))" +"(values struct:_31 make-_31 ?_31(make-struct-field-accessor -ref_31 0 'id))))" +"(define-values" +"(substitute-variable6.1)" +"(lambda(no-stops?2_0 id4_0 t5_0)" +"(begin" +" 'substitute-variable6" +"(let-values(((id_5) id4_0))" +"(let-values(((t_40) t5_0))" +"(let-values(((no-stops?_0) no-stops?2_0))" +"(let-values()" +"(if(if no-stops?_0(local-variable? t_40) #f)" +"(let-values(((bind-id_0)(local-variable-id t_40)))" +"(syntax-rearm$1(datum->syntax$1(syntax-disarm$1 bind-id_0)(syntax-e$1 bind-id_0) id_5 id_5) id_5))" +" id_5))))))))" +"(define-values(missing)(gensym 'missing))" +"(define-values" +"(transformer?)" +"(lambda(t_41)" +"(begin" +"(let-values(((or-part_32)(procedure? t_41)))" +"(if or-part_32" +" or-part_32" +"(let-values(((or-part_159)(1/set!-transformer? t_41)))" +"(if or-part_159 or-part_159(1/rename-transformer? t_41))))))))" +"(define-values" +"(transformer->procedure)" +"(lambda(t_42)" +"(begin" +"(if(1/set!-transformer? t_42)" +"(let-values()(1/set!-transformer-procedure t_42))" +"(if(1/rename-transformer? t_42)(let-values()(lambda(s_168) s_168))(let-values() t_42))))))" +"(define-values" +"(struct:core-form core-form9.1 core-form? core-form-expander core-form-name)" +"(let-values(((struct:_24 make-_24 ?_24 -ref_24 -set!_24)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'core-form" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '(0 1)" +" #f" +" 'core-form)))))" +"(values" +" struct:_24" +" make-_24" +" ?_24" +"(make-struct-field-accessor -ref_24 0 'expander)" +"(make-struct-field-accessor -ref_24 1 'name))))" +"(define-values" +"(add-binding!17.1)" +"(lambda(in10_0 just-for-nominal?11_0 id14_0 binding15_0 phase16_0)" +"(begin" +" 'add-binding!17" +"(let-values(((id_15) id14_0))" +"(let-values(((binding_8) binding15_0))" +"(let-values(((phase_35) phase16_0))" +"(let-values(((in-s_2) in10_0))" +"(let-values(((just-for-nominal?_2) just-for-nominal?11_0))" +"(let-values()" +"(begin" +"(check-id-taint id_15 in-s_2)" +"(let-values(((temp55_0)(syntax-scope-set id_15 phase_35))" +"((temp56_1)(syntax-e$1 id_15))" +"((binding57_0) binding_8)" +"((just-for-nominal?58_0) just-for-nominal?_2))" +"(add-binding-in-scopes!20.1 just-for-nominal?58_0 temp55_0 temp56_1 binding57_0))))))))))))" +"(define-values" +"(add-bulk-binding!27.1)" +"(lambda(in20_0 shadow-except21_0 s24_0 binding25_0 phase26_1)" +"(begin" +" 'add-bulk-binding!27" +"(let-values(((s_70) s24_0))" +"(let-values(((binding_9) binding25_0))" +"(let-values(((phase_36) phase26_1))" +"(let-values(((in-s_3) in20_0))" +"(let-values(((shadow-except_2) shadow-except21_0))" +"(let-values()" +"(begin" +"(if(syntax-tainted?$1 s_70)" +" (let-values () (raise-syntax-error$1 #f \"cannot bind from tainted syntax\" in-s_3 s_70))" +"(void))" +"(let-values(((temp59_1)(syntax-scope-set s_70 phase_36))" +"((binding60_0) binding_9)" +"((shadow-except61_0) shadow-except_2))" +"(add-bulk-binding-in-scopes!27.1 shadow-except61_0 temp59_1 binding60_0))))))))))))" +"(define-values" +"(add-local-binding!37.1)" +"(lambda(frame-id30_0 in31_0 id34_0 phase35_0 counter36_0)" +"(begin" +" 'add-local-binding!37" +"(let-values(((id_16) id34_0))" +"(let-values(((phase_37) phase35_0))" +"(let-values(((counter_1) counter36_0))" +"(let-values(((frame-id_5) frame-id30_0))" +"(let-values(((in-s_4) in31_0))" +"(let-values()" +"(let-values((()(begin(check-id-taint id_16 in-s_4)(values))))" +"(let-values((()(begin(set-box! counter_1(add1(unbox counter_1)))(values))))" +"(let-values(((key_43)" +" (string->uninterned-symbol (format \"~a_~a\" (syntax-e$1 id_16) (unbox counter_1)))))" +"(begin" +"(let-values(((temp62_1)(syntax-scope-set id_16 phase_37))" +"((temp63_1)(syntax-e$1 id_16))" +"((temp64_1)" +"(let-values(((key65_0) key_43)((frame-id66_0) frame-id_5))" +"(make-local-binding7.1 frame-id66_0 #f key65_0))))" +"(add-binding-in-scopes!20.1 #f temp62_1 temp63_1 temp64_1))" +" key_43)))))))))))))" +"(define-values" +"(check-id-taint)" +"(lambda(id_17 in-s_5)" +"(begin" +"(if(syntax-tainted?$1 id_17)" +" (let-values () (raise-syntax-error$1 #f \"cannot bind tainted identifier\" in-s_5 id_17))" +"(void)))))" +"(define-values" +"(binding-lookup50.1)" +"(lambda(in40_0 out-of-context-as-variable?41_0 b44_0 env45_0 lift-envs46_0 ns47_0 phase48_0 id49_0)" +"(begin" +" 'binding-lookup50" +"(let-values(((b_60) b44_0))" +"(let-values(((env_1) env45_0))" +"(let-values(((lift-envs_0) lift-envs46_0))" +"(let-values(((ns_44) ns47_0))" +"(let-values(((phase_38) phase48_0))" +"(let-values(((id_18) id49_0))" +"(let-values(((in-s_6) in40_0))" +"(let-values(((out-of-context-as-variable?_0) out-of-context-as-variable?41_0))" +"(let-values()" +"(if(module-binding? b_60)" +"(let-values()" +"(let-values(((top-level?_0)(top-level-module-path-index?(module-binding-module b_60))))" +"(let-values(((mi_15)" +"(if(not top-level?_0)" +"(binding->module-instance b_60 ns_44 phase_38 id_18)" +" #f)))" +"(let-values(((m_12)(if mi_15(module-instance-module mi_15) #f)))" +"(let-values(((primitive?_1)(if m_12(module-primitive? m_12) #f)))" +"(let-values(((m-ns_7)" +"(if top-level?_0" +" ns_44" +"(if mi_15(module-instance-namespace mi_15) #f))))" +"(let-values((()(begin(check-taint id_18)(values))))" +"(let-values(((t_43)" +"(namespace-get-transformer" +" m-ns_7" +"(module-binding-phase b_60)" +"(module-binding-sym b_60)" +" variable)))" +"(let-values(((protected?_1)" +"(if mi_15" +"(check-access" +" b_60" +" mi_15" +" id_18" +" in-s_6" +" (if (variable? t_43) \"variable\" \"transformer\"))" +" #f)))" +"(let-values(((insp_6)" +"(if mi_15" +"(if(module-instance-module mi_15)" +"(module-inspector(module-instance-module mi_15))" +" #f)" +" #f)))" +"(values t_43 primitive?_1 insp_6 protected?_1)))))))))))" +"(if(local-binding? b_60)" +"(let-values()" +"(let-values(((t_44)(hash-ref env_1(local-binding-key b_60) missing)))" +"(if(eq? t_44 missing)" +"(let-values()" +"(values" +"(let-values(((or-part_103)" +"(let-values(((lst_73) lift-envs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_73)))" +"((letrec-values(((for-loop_96)" +"(lambda(result_59 lst_74)" +"(begin" +" 'for-loop" +"(if(pair? lst_74)" +"(let-values(((lift-env_0)" +"(unsafe-car lst_74))" +"((rest_34)" +"(unsafe-cdr lst_74)))" +"(let-values(((result_60)" +"(let-values()" +"(let-values(((result_61)" +"(let-values()" +"(let-values()" +"(hash-ref" +"(unbox" +" lift-env_0)" +"(local-binding-key" +" b_60)" +" #f)))))" +"(values" +" result_61)))))" +"(if(if(not" +"((lambda x_41 result_60)" +" lift-env_0))" +"(not #f)" +" #f)" +"(for-loop_96 result_60 rest_34)" +" result_60)))" +" result_59)))))" +" for-loop_96)" +" #f" +" lst_73)))))" +"(if or-part_103" +" or-part_103" +"(if out-of-context-as-variable?_0" +" variable" +" (error \"identifier used out of context:\" id_18))))" +" #f" +" #f" +" #f))" +"(let-values()(begin(check-taint id_18)(values t_44 #f #f #f))))))" +" (let-values () (error \"internal error: unknown binding for lookup:\" b_60))))))))))))))))" +"(define-values" +"(check-taint)" +"(lambda(id_19)" +"(begin" +"(if(syntax-tainted?$1 id_19)" +" (let-values () (raise-syntax-error$1 #f \"cannot use identifier tainted by macro transformation\" id_19))" +"(void)))))" +"(define-values(cons-ish)(lambda(a_40 b_61)(begin(if(null? b_61) a_40(cons a_40 b_61)))))" +"(define-values" +"(free-id-set)" +"(lambda(phase_39 ids_0)" +"(begin" +"(let-values(((lst_75) ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_75)))" +"((letrec-values(((for-loop_97)" +"(lambda(ht_73 lst_76)" +"(begin" +" 'for-loop" +"(if(pair? lst_76)" +"(let-values(((id_10)(unsafe-car lst_76))((rest_35)(unsafe-cdr lst_76)))" +"(let-values(((ht_74)" +"(let-values(((ht_75) ht_73))" +"(let-values(((ht_76)" +"(let-values()" +"(let-values(((sym_24)" +"(identifier-binding-symbol$1" +" id_10" +" phase_39)))" +"(hash-set" +" ht_75" +" sym_24" +"(cons-ish" +" id_10" +"(hash-ref ht_75 sym_24 null)))))))" +"(values ht_76)))))" +"(if(not #f)(for-loop_97 ht_74 rest_35) ht_74)))" +" ht_73)))))" +" for-loop_97)" +" '#hasheq()" +" lst_75))))))" +"(define-values(empty-free-id-set)(free-id-set 0 null))" +"(define-values(free-id-set-empty?)(lambda(fs_0)(begin(eq? fs_0 empty-free-id-set))))" +"(define-values" +"(free-id-set-member?)" +"(lambda(fs_1 phase_40 given-id_0)" +"(begin" +"(if(free-id-set-empty? fs_1)" +" #f" +"(let-values(((lst_77)(hash-ref fs_1(identifier-binding-symbol$1 given-id_0 phase_40) null)))" +"(begin" +"(void)" +"((letrec-values(((for-loop_98)" +"(lambda(result_3 lst_78)" +"(begin" +" 'for-loop" +"(if(not(null? lst_78))" +"(let-values(((id_2)(if(pair? lst_78)(car lst_78) lst_78))" +"((rest_36)(if(pair? lst_78)(cdr lst_78) null)))" +"(let-values(((result_62)" +"(let-values()" +"(let-values(((result_63)" +"(let-values()" +"(let-values()" +"(free-identifier=?$1" +" id_2" +" given-id_0" +" phase_40" +" phase_40)))))" +"(values result_63)))))" +"(if(if(not((lambda x_42 result_62) id_2))(not #f) #f)" +"(for-loop_98 result_62 rest_36)" +" result_62)))" +" result_3)))))" +" for-loop_98)" +" #f" +" lst_77)))))))" +"(define-values" +"(free-id-set-empty-or-just-module*?)" +"(lambda(fs_2)(begin(let-values(((c_17)(hash-count fs_2)))(<= c_17 1)))))" +"(define-values" +"(struct:expand-context/outer" +" expand-context/outer1.1" +" expand-context/outer?" +" expand-context/outer-context" +" expand-context/outer-env" +" expand-context/outer-scopes" +" expand-context/outer-def-ctx-scopes" +" expand-context/outer-binding-layer" +" expand-context/outer-reference-records" +" expand-context/outer-only-immediate?" +" expand-context/outer-need-eventually-defined" +" expand-context/outer-current-introduction-scopes" +" expand-context/outer-current-use-scopes" +" expand-context/outer-name)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expand-context" +" struct:root-expand-context/outer" +" 11" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10)" +" #f" +" 'expand-context/outer)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'context)" +"(make-struct-field-accessor -ref_36 1 'env)" +"(make-struct-field-accessor -ref_36 2 'scopes)" +"(make-struct-field-accessor -ref_36 3 'def-ctx-scopes)" +"(make-struct-field-accessor -ref_36 4 'binding-layer)" +"(make-struct-field-accessor -ref_36 5 'reference-records)" +"(make-struct-field-accessor -ref_36 6 'only-immediate?)" +"(make-struct-field-accessor -ref_36 7 'need-eventually-defined)" +"(make-struct-field-accessor -ref_36 8 'current-introduction-scopes)" +"(make-struct-field-accessor -ref_36 9 'current-use-scopes)" +"(make-struct-field-accessor -ref_36 10 'name))))" +"(define-values" +"(struct:expand-context/inner" +" expand-context/inner2.1" +" expand-context/inner?" +" expand-context/inner-to-parsed?" +" expand-context/inner-phase" +" expand-context/inner-namespace" +" expand-context/inner-just-once?" +" expand-context/inner-module-begin-k" +" expand-context/inner-allow-unbound?" +" expand-context/inner-in-local-expand?" +" expand-context/inner-keep-#%expression?" +" expand-context/inner-stops" +" expand-context/inner-declared-submodule-names" +" expand-context/inner-lifts" +" expand-context/inner-lift-envs" +" expand-context/inner-module-lifts" +" expand-context/inner-require-lifts" +" expand-context/inner-to-module-lifts" +" expand-context/inner-requires+provides" +" expand-context/inner-observer" +" expand-context/inner-for-serializable?" +" expand-context/inner-should-not-encounter-macros?)" +"(let-values(((struct:_42 make-_42 ?_42 -ref_42 -set!_42)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expand-context/inner" +" struct:root-expand-context/inner" +" 19" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18)" +" #f" +" 'expand-context/inner)))))" +"(values" +" struct:_42" +" make-_42" +" ?_42" +"(make-struct-field-accessor -ref_42 0 'to-parsed?)" +"(make-struct-field-accessor -ref_42 1 'phase)" +"(make-struct-field-accessor -ref_42 2 'namespace)" +"(make-struct-field-accessor -ref_42 3 'just-once?)" +"(make-struct-field-accessor -ref_42 4 'module-begin-k)" +"(make-struct-field-accessor -ref_42 5 'allow-unbound?)" +"(make-struct-field-accessor -ref_42 6 'in-local-expand?)" +"(make-struct-field-accessor -ref_42 7 'keep-#%expression?)" +"(make-struct-field-accessor -ref_42 8 'stops)" +"(make-struct-field-accessor -ref_42 9 'declared-submodule-names)" +"(make-struct-field-accessor -ref_42 10 'lifts)" +"(make-struct-field-accessor -ref_42 11 'lift-envs)" +"(make-struct-field-accessor -ref_42 12 'module-lifts)" +"(make-struct-field-accessor -ref_42 13 'require-lifts)" +"(make-struct-field-accessor -ref_42 14 'to-module-lifts)" +"(make-struct-field-accessor -ref_42 15 'requires+provides)" +"(make-struct-field-accessor -ref_42 16 'observer)" +"(make-struct-field-accessor -ref_42 17 'for-serializable?)" +"(make-struct-field-accessor -ref_42 18 'should-not-encounter-macros?))))" +"(define-values" +"(expand-context/make)" +"(lambda(self-mpi_2" +" module-scopes_2" +" post-expansion_1" +" top-level-bind-scope_1" +" all-scopes-stx_2" +" use-site-scopes_1" +" defined-syms_1" +" frame-id_6" +" counter_2" +" lift-key_1" +" to-parsed?_0" +" context_0" +" phase_41" +" namespace_0" +" env_2" +" scopes_18" +" def-ctx-scopes_0" +" binding-layer_0" +" reference-records_0" +" only-immediate?_0" +" just-once?_0" +" module-begin-k_0" +" need-eventually-defined_0" +" allow-unbound?_0" +" in-local-expand?_0" +" keep-#%expression?_0" +" stops_0" +" current-introduction-scopes_0" +" current-use-scopes_0" +" declared-submodule-names_0" +" lifts_0" +" lift-envs_1" +" module-lifts_0" +" require-lifts_0" +" to-module-lifts_0" +" requires+provides_0" +" name_36" +" observer_0" +" for-serializable?_0" +" should-not-encounter-macros?_0)" +"(begin" +"(expand-context/outer1.1" +"(expand-context/inner2.1" +" self-mpi_2" +" module-scopes_2" +" top-level-bind-scope_1" +" all-scopes-stx_2" +" defined-syms_1" +" counter_2" +" lift-key_1" +" to-parsed?_0" +" phase_41" +" namespace_0" +" just-once?_0" +" module-begin-k_0" +" allow-unbound?_0" +" in-local-expand?_0" +" keep-#%expression?_0" +" stops_0" +" declared-submodule-names_0" +" lifts_0" +" lift-envs_1" +" module-lifts_0" +" require-lifts_0" +" to-module-lifts_0" +" requires+provides_0" +" observer_0" +" for-serializable?_0" +" should-not-encounter-macros?_0)" +" post-expansion_1" +" use-site-scopes_1" +" frame-id_6" +" context_0" +" env_2" +" scopes_18" +" def-ctx-scopes_0" +" binding-layer_0" +" reference-records_0" +" only-immediate?_0" +" need-eventually-defined_0" +" current-introduction-scopes_0" +" current-use-scopes_0" +" name_36))))" +"(define-values(expand-context-context)(lambda(v_100)(begin(expand-context/outer-context v_100))))" +"(define-values(expand-context-env)(lambda(v_101)(begin(expand-context/outer-env v_101))))" +"(define-values(expand-context-scopes)(lambda(v_102)(begin(expand-context/outer-scopes v_102))))" +"(define-values(expand-context-def-ctx-scopes)(lambda(v_103)(begin(expand-context/outer-def-ctx-scopes v_103))))" +"(define-values(expand-context-binding-layer)(lambda(v_104)(begin(expand-context/outer-binding-layer v_104))))" +"(define-values" +"(expand-context-reference-records)" +"(lambda(v_105)(begin(expand-context/outer-reference-records v_105))))" +"(define-values(expand-context-only-immediate?)(lambda(v_106)(begin(expand-context/outer-only-immediate? v_106))))" +"(define-values" +"(expand-context-need-eventually-defined)" +"(lambda(v_107)(begin(expand-context/outer-need-eventually-defined v_107))))" +"(define-values" +"(expand-context-current-introduction-scopes)" +"(lambda(v_108)(begin(expand-context/outer-current-introduction-scopes v_108))))" +"(define-values" +"(expand-context-current-use-scopes)" +"(lambda(v_109)(begin(expand-context/outer-current-use-scopes v_109))))" +"(define-values(expand-context-name)(lambda(v_110)(begin(expand-context/outer-name v_110))))" +"(define-values" +"(expand-context-to-parsed?)" +"(lambda(v_111)(begin(expand-context/inner-to-parsed?(root-expand-context/outer-inner v_111)))))" +"(define-values" +"(expand-context-phase)" +"(lambda(v_112)(begin(expand-context/inner-phase(root-expand-context/outer-inner v_112)))))" +"(define-values" +"(expand-context-namespace)" +"(lambda(v_113)(begin(expand-context/inner-namespace(root-expand-context/outer-inner v_113)))))" +"(define-values" +"(expand-context-just-once?)" +"(lambda(v_114)(begin(expand-context/inner-just-once?(root-expand-context/outer-inner v_114)))))" +"(define-values" +"(expand-context-module-begin-k)" +"(lambda(v_115)(begin(expand-context/inner-module-begin-k(root-expand-context/outer-inner v_115)))))" +"(define-values" +"(expand-context-allow-unbound?)" +"(lambda(v_116)(begin(expand-context/inner-allow-unbound?(root-expand-context/outer-inner v_116)))))" +"(define-values" +"(expand-context-in-local-expand?)" +"(lambda(v_117)(begin(expand-context/inner-in-local-expand?(root-expand-context/outer-inner v_117)))))" +"(define-values" +"(expand-context-keep-#%expression?)" +"(lambda(v_118)(begin(expand-context/inner-keep-#%expression?(root-expand-context/outer-inner v_118)))))" +"(define-values" +"(expand-context-stops)" +"(lambda(v_119)(begin(expand-context/inner-stops(root-expand-context/outer-inner v_119)))))" +"(define-values" +"(expand-context-declared-submodule-names)" +"(lambda(v_120)(begin(expand-context/inner-declared-submodule-names(root-expand-context/outer-inner v_120)))))" +"(define-values" +"(expand-context-lifts)" +"(lambda(v_121)(begin(expand-context/inner-lifts(root-expand-context/outer-inner v_121)))))" +"(define-values" +"(expand-context-lift-envs)" +"(lambda(v_122)(begin(expand-context/inner-lift-envs(root-expand-context/outer-inner v_122)))))" +"(define-values" +"(expand-context-module-lifts)" +"(lambda(v_123)(begin(expand-context/inner-module-lifts(root-expand-context/outer-inner v_123)))))" +"(define-values" +"(expand-context-require-lifts)" +"(lambda(v_124)(begin(expand-context/inner-require-lifts(root-expand-context/outer-inner v_124)))))" +"(define-values" +"(expand-context-to-module-lifts)" +"(lambda(v_125)(begin(expand-context/inner-to-module-lifts(root-expand-context/outer-inner v_125)))))" +"(define-values" +"(expand-context-requires+provides)" +"(lambda(v_126)(begin(expand-context/inner-requires+provides(root-expand-context/outer-inner v_126)))))" +"(define-values" +"(expand-context-observer)" +"(lambda(v_127)(begin(expand-context/inner-observer(root-expand-context/outer-inner v_127)))))" +"(define-values" +"(expand-context-for-serializable?)" +"(lambda(v_128)(begin(expand-context/inner-for-serializable?(root-expand-context/outer-inner v_128)))))" +"(define-values" +"(expand-context-should-not-encounter-macros?)" +"(lambda(v_129)(begin(expand-context/inner-should-not-encounter-macros?(root-expand-context/outer-inner v_129)))))" +"(define-values" +"(make-expand-context10.1)" +"(lambda(for-serializable?4_0 observer5_0 to-parsed?3_0 ns9_0)" +"(begin" +" 'make-expand-context10" +"(let-values(((ns_45) ns9_0))" +"(let-values(((to-parsed?_1) to-parsed?3_0))" +"(let-values(((for-serializable?_1) for-serializable?4_0))" +"(let-values(((observer_1) observer5_0))" +"(let-values()" +"(let-values(((root-ctx_1)(namespace-get-root-expand-ctx ns_45)))" +"(expand-context/make" +"(root-expand-context-self-mpi root-ctx_1)" +"(root-expand-context-module-scopes root-ctx_1)" +"(root-expand-context-post-expansion root-ctx_1)" +"(root-expand-context-top-level-bind-scope root-ctx_1)" +"(root-expand-context-all-scopes-stx root-ctx_1)" +"(root-expand-context-use-site-scopes root-ctx_1)" +"(root-expand-context-defined-syms root-ctx_1)" +"(root-expand-context-frame-id root-ctx_1)" +"(root-expand-context-counter root-ctx_1)" +"(root-expand-context-lift-key root-ctx_1)" +" to-parsed?_1" +" 'top-level" +"(namespace-phase ns_45)" +" ns_45" +" empty-env" +" null" +" #f" +"(root-expand-context-frame-id root-ctx_1)" +" null" +" #f" +" #f" +" #f" +" #f" +" #t" +" #f" +" #f" +" empty-free-id-set" +" null" +" null" +" '#hasheq()" +" #f" +" '()" +" #f" +" #f" +" #f" +" #f" +" #f" +" observer_1" +" for-serializable?_1" +" #f))))))))))" +"(define-values" +"(copy-root-expand-context)" +"(lambda(ctx_1 root-ctx_2)" +"(begin" +"(let-values(((v_130) ctx_1))" +"(let-values(((the-struct_14) v_130))" +"(if(expand-context/outer? the-struct_14)" +"(let-values(((post-expansion27_0)(root-expand-context-post-expansion root-ctx_2))" +"((use-site-scopes28_0)(root-expand-context-use-site-scopes root-ctx_2))" +"((frame-id29_0)(root-expand-context-frame-id root-ctx_2))" +"((binding-layer30_0)(root-expand-context-frame-id root-ctx_2))" +"((inner31_0)" +"(let-values(((the-struct_41)(root-expand-context/outer-inner v_130)))" +"(if(expand-context/inner? the-struct_41)" +"(let-values(((self-mpi32_0)(root-expand-context-self-mpi root-ctx_2))" +"((module-scopes33_0)(root-expand-context-module-scopes root-ctx_2))" +"((top-level-bind-scope34_0)" +"(root-expand-context-top-level-bind-scope root-ctx_2))" +"((all-scopes-stx35_0)(root-expand-context-all-scopes-stx root-ctx_2))" +"((defined-syms36_0)(root-expand-context-defined-syms root-ctx_2))" +"((counter37_0)(root-expand-context-counter root-ctx_2))" +"((lift-key38_0)(root-expand-context-lift-key root-ctx_2)))" +"(expand-context/inner2.1" +" self-mpi32_0" +" module-scopes33_0" +" top-level-bind-scope34_0" +" all-scopes-stx35_0" +" defined-syms36_0" +" counter37_0" +" lift-key38_0" +"(expand-context/inner-to-parsed? the-struct_41)" +"(expand-context/inner-phase the-struct_41)" +"(expand-context/inner-namespace the-struct_41)" +"(expand-context/inner-just-once? the-struct_41)" +"(expand-context/inner-module-begin-k the-struct_41)" +"(expand-context/inner-allow-unbound? the-struct_41)" +"(expand-context/inner-in-local-expand? the-struct_41)" +"(expand-context/inner-keep-#%expression? the-struct_41)" +"(expand-context/inner-stops the-struct_41)" +"(expand-context/inner-declared-submodule-names the-struct_41)" +"(expand-context/inner-lifts the-struct_41)" +"(expand-context/inner-lift-envs the-struct_41)" +"(expand-context/inner-module-lifts the-struct_41)" +"(expand-context/inner-require-lifts the-struct_41)" +"(expand-context/inner-to-module-lifts the-struct_41)" +"(expand-context/inner-requires+provides the-struct_41)" +"(expand-context/inner-observer the-struct_41)" +"(expand-context/inner-for-serializable? the-struct_41)" +"(expand-context/inner-should-not-encounter-macros? the-struct_41)))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_41)))))" +"(expand-context/outer1.1" +" inner31_0" +" post-expansion27_0" +" use-site-scopes28_0" +" frame-id29_0" +"(expand-context/outer-context the-struct_14)" +"(expand-context/outer-env the-struct_14)" +"(expand-context/outer-scopes the-struct_14)" +"(expand-context/outer-def-ctx-scopes the-struct_14)" +" binding-layer30_0" +"(expand-context/outer-reference-records the-struct_14)" +"(expand-context/outer-only-immediate? the-struct_14)" +"(expand-context/outer-need-eventually-defined the-struct_14)" +"(expand-context/outer-current-introduction-scopes the-struct_14)" +"(expand-context/outer-current-use-scopes the-struct_14)" +"(expand-context/outer-name the-struct_14)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_14)))))))" +"(define-values(current-expand-context)(make-parameter #f))" +"(define-values" +"(get-current-expand-context16.1)" +"(lambda(fail-ok?13_0 who15_0)" +"(begin" +" 'get-current-expand-context16" +"(let-values(((who_10) who15_0))" +"(let-values(((fail-ok?_0) fail-ok?13_0))" +"(let-values()" +"(let-values(((or-part_160)(force(current-expand-context))))" +"(if or-part_160" +" or-part_160" +" (if fail-ok?_0 #f (raise-arguments-error who_10 \"not currently expanding\"))))))))))" +"(define-values" +"(current-expand-observe)" +"(make-parameter" +" #f" +"(lambda(v_131)" +"(begin" +"(if(let-values(((or-part_161)(not v_131)))" +"(if or-part_161 or-part_161(if(procedure? v_131)(procedure-arity-includes? v_131 2) #f)))" +"(void)" +"(let-values()" +" (raise-argument-error 'current-expand-observe \"(or/c (procedure-arity-includes/c 2) #f)\" v_131)))" +" v_131))))" +"(define-values" +"(as-expression-context)" +"(lambda(ctx_2)" +"(begin" +"(if(if(eq? 'expression(expand-context-context ctx_2))(not(expand-context-name ctx_2)) #f)" +"(let-values() ctx_2)" +"(let-values()" +"(let-values(((v_132) ctx_2))" +"(let-values(((the-struct_16) v_132))" +"(if(expand-context/outer? the-struct_16)" +"(let-values(((context39_0) 'expression)" +"((name40_0) #f)" +"((post-expansion41_0) #f)" +"((inner42_0)(root-expand-context/outer-inner v_132)))" +"(expand-context/outer1.1" +" inner42_0" +" post-expansion41_0" +"(root-expand-context/outer-use-site-scopes the-struct_16)" +"(root-expand-context/outer-frame-id the-struct_16)" +" context39_0" +"(expand-context/outer-env the-struct_16)" +"(expand-context/outer-scopes the-struct_16)" +"(expand-context/outer-def-ctx-scopes the-struct_16)" +"(expand-context/outer-binding-layer the-struct_16)" +"(expand-context/outer-reference-records the-struct_16)" +"(expand-context/outer-only-immediate? the-struct_16)" +"(expand-context/outer-need-eventually-defined the-struct_16)" +"(expand-context/outer-current-introduction-scopes the-struct_16)" +"(expand-context/outer-current-use-scopes the-struct_16)" +" name40_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_16)))))))))" +"(define-values" +"(as-begin-expression-context)" +"(lambda(ctx_3)" +"(begin" +"(if(not(expand-context-name ctx_3))" +"(let-values() ctx_3)" +"(let-values()" +"(let-values(((v_133) ctx_3))" +"(let-values(((the-struct_42) v_133))" +"(if(expand-context/outer? the-struct_42)" +"(let-values(((name43_0) #f)((inner44_0)(root-expand-context/outer-inner v_133)))" +"(expand-context/outer1.1" +" inner44_0" +"(root-expand-context/outer-post-expansion the-struct_42)" +"(root-expand-context/outer-use-site-scopes the-struct_42)" +"(root-expand-context/outer-frame-id the-struct_42)" +"(expand-context/outer-context the-struct_42)" +"(expand-context/outer-env the-struct_42)" +"(expand-context/outer-scopes the-struct_42)" +"(expand-context/outer-def-ctx-scopes the-struct_42)" +"(expand-context/outer-binding-layer the-struct_42)" +"(expand-context/outer-reference-records the-struct_42)" +"(expand-context/outer-only-immediate? the-struct_42)" +"(expand-context/outer-need-eventually-defined the-struct_42)" +"(expand-context/outer-current-introduction-scopes the-struct_42)" +"(expand-context/outer-current-use-scopes the-struct_42)" +" name43_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_42)))))))))" +"(define-values" +"(as-tail-context22.1)" +"(lambda(wrt19_0 ctx21_0)" +"(begin" +" 'as-tail-context22" +"(let-values(((ctx_4) ctx21_0))" +"(let-values(((wrt-ctx_0) wrt19_0))" +"(let-values()" +"(if(expand-context-name wrt-ctx_0)" +"(let-values()" +"(let-values(((v_134) ctx_4))" +"(let-values(((the-struct_43) v_134))" +"(if(expand-context/outer? the-struct_43)" +"(let-values(((name45_0)(expand-context-name wrt-ctx_0))" +"((inner46_0)(root-expand-context/outer-inner v_134)))" +"(expand-context/outer1.1" +" inner46_0" +"(root-expand-context/outer-post-expansion the-struct_43)" +"(root-expand-context/outer-use-site-scopes the-struct_43)" +"(root-expand-context/outer-frame-id the-struct_43)" +"(expand-context/outer-context the-struct_43)" +"(expand-context/outer-env the-struct_43)" +"(expand-context/outer-scopes the-struct_43)" +"(expand-context/outer-def-ctx-scopes the-struct_43)" +"(expand-context/outer-binding-layer the-struct_43)" +"(expand-context/outer-reference-records the-struct_43)" +"(expand-context/outer-only-immediate? the-struct_43)" +"(expand-context/outer-need-eventually-defined the-struct_43)" +"(expand-context/outer-current-introduction-scopes the-struct_43)" +"(expand-context/outer-current-use-scopes the-struct_43)" +" name45_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_43)))))" +"(let-values() ctx_4))))))))" +"(define-values" +"(as-named-context)" +"(lambda(ctx_5 ids_1)" +"(begin" +"(if(if(pair? ids_1)(null?(cdr ids_1)) #f)" +"(let-values()" +"(let-values(((v_135) ctx_5))" +"(let-values(((the-struct_44) v_135))" +"(if(expand-context/outer? the-struct_44)" +"(let-values(((name47_0)(car ids_1))((inner48_0)(root-expand-context/outer-inner v_135)))" +"(expand-context/outer1.1" +" inner48_0" +"(root-expand-context/outer-post-expansion the-struct_44)" +"(root-expand-context/outer-use-site-scopes the-struct_44)" +"(root-expand-context/outer-frame-id the-struct_44)" +"(expand-context/outer-context the-struct_44)" +"(expand-context/outer-env the-struct_44)" +"(expand-context/outer-scopes the-struct_44)" +"(expand-context/outer-def-ctx-scopes the-struct_44)" +"(expand-context/outer-binding-layer the-struct_44)" +"(expand-context/outer-reference-records the-struct_44)" +"(expand-context/outer-only-immediate? the-struct_44)" +"(expand-context/outer-need-eventually-defined the-struct_44)" +"(expand-context/outer-current-introduction-scopes the-struct_44)" +"(expand-context/outer-current-use-scopes the-struct_44)" +" name47_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_44)))))" +"(let-values() ctx_5)))))" +"(define-values" +"(as-to-parsed-context)" +"(lambda(ctx_6)" +"(begin" +"(let-values(((v_136) ctx_6))" +"(let-values(((the-struct_45) v_136))" +"(if(expand-context/outer? the-struct_45)" +"(let-values(((inner49_0)" +"(let-values(((the-struct_46)(root-expand-context/outer-inner v_136)))" +"(if(expand-context/inner? the-struct_46)" +"(let-values(((to-parsed?50_0) #t)" +"((observer51_0) #f)" +"((should-not-encounter-macros?52_0) #t))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_46)" +"(root-expand-context/inner-module-scopes the-struct_46)" +"(root-expand-context/inner-top-level-bind-scope the-struct_46)" +"(root-expand-context/inner-all-scopes-stx the-struct_46)" +"(root-expand-context/inner-defined-syms the-struct_46)" +"(root-expand-context/inner-counter the-struct_46)" +"(root-expand-context/inner-lift-key the-struct_46)" +" to-parsed?50_0" +"(expand-context/inner-phase the-struct_46)" +"(expand-context/inner-namespace the-struct_46)" +"(expand-context/inner-just-once? the-struct_46)" +"(expand-context/inner-module-begin-k the-struct_46)" +"(expand-context/inner-allow-unbound? the-struct_46)" +"(expand-context/inner-in-local-expand? the-struct_46)" +"(expand-context/inner-keep-#%expression? the-struct_46)" +"(expand-context/inner-stops the-struct_46)" +"(expand-context/inner-declared-submodule-names the-struct_46)" +"(expand-context/inner-lifts the-struct_46)" +"(expand-context/inner-lift-envs the-struct_46)" +"(expand-context/inner-module-lifts the-struct_46)" +"(expand-context/inner-require-lifts the-struct_46)" +"(expand-context/inner-to-module-lifts the-struct_46)" +"(expand-context/inner-requires+provides the-struct_46)" +" observer51_0" +"(expand-context/inner-for-serializable? the-struct_46)" +" should-not-encounter-macros?52_0))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_46)))))" +"(expand-context/outer1.1" +" inner49_0" +"(root-expand-context/outer-post-expansion the-struct_45)" +"(root-expand-context/outer-use-site-scopes the-struct_45)" +"(root-expand-context/outer-frame-id the-struct_45)" +"(expand-context/outer-context the-struct_45)" +"(expand-context/outer-env the-struct_45)" +"(expand-context/outer-scopes the-struct_45)" +"(expand-context/outer-def-ctx-scopes the-struct_45)" +"(expand-context/outer-binding-layer the-struct_45)" +"(expand-context/outer-reference-records the-struct_45)" +"(expand-context/outer-only-immediate? the-struct_45)" +"(expand-context/outer-need-eventually-defined the-struct_45)" +"(expand-context/outer-current-introduction-scopes the-struct_45)" +"(expand-context/outer-current-use-scopes the-struct_45)" +"(expand-context/outer-name the-struct_45)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_45)))))))" +"(define-values" +"(to-syntax-list.1)" +"(lambda(s_169)" +"(begin" +" 'to-syntax-list" +"(if(list? s_169)" +"(let-values() s_169)" +"(if(pair? s_169)" +"(let-values()(let-values(((r_28)(to-syntax-list.1(cdr s_169))))(if r_28(cons(car s_169) r_28) #f)))" +"(if(syntax?$1 s_169)(let-values()(to-syntax-list.1(syntax-e$1 s_169)))(let-values() #f)))))))" +"(define-values(core-scope)(new-multi-scope))" +"(define-values(core-stx)(add-scope empty-syntax core-scope))" +"(define-values(core-module-name)(1/make-resolved-module-path '#%core))" +"(define-values(core-mpi)(1/module-path-index-join ''#%core #f))" +"(define-values(id-cache-0)(make-hasheq))" +"(define-values(id-cache-1)(make-hasheq))" +"(define-values" +"(core-id)" +"(lambda(sym_12 phase_34)" +"(begin" +"(if(eqv? phase_34 0)" +"(let-values()" +"(let-values(((or-part_6)(hash-ref id-cache-0 sym_12 #f)))" +"(if or-part_6" +" or-part_6" +"(let-values(((s_170)(datum->syntax$1 core-stx sym_12)))" +"(begin(hash-set! id-cache-0 sym_12 s_170) s_170)))))" +"(if(eq? phase_34 1)" +"(let-values()" +"(let-values(((or-part_28)(hash-ref id-cache-1 sym_12 #f)))" +"(if or-part_28" +" or-part_28" +"(let-values(((s_10)(datum->syntax$1(syntax-shift-phase-level$1 core-stx 1) sym_12)))" +"(begin(hash-set! id-cache-1 sym_12 s_10) s_10)))))" +"(let-values()(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_34) sym_12)))))))" +"(define-values(core-forms) '#hasheq())" +"(define-values(core-primitives) '#hasheq())" +"(define-values" +"(add-core-form!*)" +"(lambda(sym_25 proc_4)" +"(begin(begin(add-core-binding! sym_25)(set! core-forms(hash-set core-forms sym_25 proc_4))))))" +"(define-values" +"(add-core-primitive!)" +"(lambda(sym_26 val_35)" +"(begin(begin(add-core-binding! sym_26)(set! core-primitives(hash-set core-primitives sym_26 val_35))))))" +"(define-values" +"(add-core-binding!)" +"(lambda(sym_27)" +"(begin" +"(let-values(((temp1_0)(datum->syntax$1 core-stx sym_27))" +"((temp2_1)" +"(let-values(((core-mpi4_0) core-mpi)((temp5_2) 0)((sym6_0) sym_27))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" core-mpi4_0" +" temp5_2" +" sym6_0)))" +"((temp3_1) 0))" +"(add-binding!17.1 #f #f temp1_0 temp2_1 temp3_1)))))" +"(define-values" +"(declare-core-module!)" +"(lambda(ns_46)" +"(begin" +"(let-values(((ns7_0) ns_46)" +"((temp8_0)" +"(let-values(((temp10_0) #t)" +"((temp11_0) #t)" +"((temp12_0) #t)" +"((core-mpi13_0) core-mpi)" +"((temp14_1)" +"(hasheqv" +" 0" +"(let-values(((lst_79)(list core-primitives core-forms))((lst_80) '(#f #t)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_79)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_80)))" +"((letrec-values(((for-loop_99)" +"(lambda(table_111 lst_81 lst_82)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_81)(pair? lst_82) #f)" +"(let-values(((syms_12)(unsafe-car lst_81))" +"((rest_37)(unsafe-cdr lst_81))" +"((syntax?_2)(unsafe-car lst_82))" +"((rest_38)(unsafe-cdr lst_82)))" +"(let-values(((table_112)" +"(let-values(((table_113) table_111))" +"(let-values(((ht_77) syms_12))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys ht_77)))" +"((letrec-values(((for-loop_100)" +"(lambda(table_114" +" i_42)" +"(begin" +" 'for-loop" +"(if i_42" +"(let-values(((sym_28)" +"(hash-iterate-key" +" ht_77" +" i_42)))" +"(let-values(((table_115)" +"(let-values(((table_116)" +" table_114))" +"(let-values(((table_117)" +"(let-values()" +"(let-values(((key_44" +" val_36)" +"(let-values()" +"(let-values(((b_62)" +"(let-values(((core-mpi17_0)" +" core-mpi)" +"((temp18_3)" +" 0)" +"((sym19_0)" +" sym_28))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" core-mpi17_0" +" temp18_3" +" sym19_0))))" +"(values" +" sym_28" +"(if syntax?_2" +"(provided1.1" +" b_62" +" #f" +" #t)" +" b_62))))))" +"(hash-set" +" table_116" +" key_44" +" val_36)))))" +"(values" +" table_117)))))" +"(if(not" +" #f)" +"(for-loop_100" +" table_115" +"(hash-iterate-next" +" ht_77" +" i_42))" +" table_115)))" +" table_114)))))" +" for-loop_100)" +" table_113" +"(hash-iterate-first ht_77)))))))" +"(if(not #f)" +"(for-loop_99 table_112 rest_37 rest_38)" +" table_112)))" +" table_111)))))" +" for-loop_99)" +" '#hasheq()" +" lst_79" +" lst_80)))))" +"((temp15_1)" +"(lambda(phase-level_14 ns_47 insp_7)" +"(if(zero? phase-level_14)" +"(let-values(((ns_48)" +"(let-values(((ns20_0) ns_47)" +"((core-module-name21_0) core-module-name)" +"((temp22_1) 0))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" ns20_0" +" core-module-name21_0" +" temp22_1))))" +"(if ns_48" +"(module-linklet-info2.1(namespace->instance ns_48 0) #f core-mpi #f #f #f)" +" #f))" +" #f)))" +"((temp16_1)" +"(lambda(data-box_1" +" ns_49" +" phase_42" +" phase-level_15" +" self_5" +" bulk-binding-registry_4" +" insp_8)" +"(let-values(((tmp_14) phase-level_15))" +"(if(equal? tmp_14 0)" +"(let-values()" +"(begin" +"(let-values(((ht_78) core-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_78)))" +"((letrec-values(((for-loop_101)" +"(lambda(i_28)" +"(begin" +" 'for-loop" +"(if i_28" +"(let-values(((sym_29 val_37)" +"(hash-iterate-key+value" +" ht_78" +" i_28)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-consistent!" +" ns_49" +" 0" +" sym_29" +" val_37))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_101" +"(hash-iterate-next ht_78 i_28))" +"(values))))" +"(values))))))" +" for-loop_101)" +"(hash-iterate-first ht_78))))" +"(void)" +"(let-values(((ht_79) core-forms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_79)))" +"((letrec-values(((for-loop_102)" +"(lambda(i_91)" +"(begin" +" 'for-loop" +"(if i_91" +"(let-values(((sym_30 proc_5)" +"(hash-iterate-key+value" +" ht_79" +" i_91)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-transformer!" +" ns_49" +" 0" +" sym_30" +"(if(procedure-arity-includes?" +" proc_5" +" 2)" +"(core-form9.1" +" proc_5" +" sym_30)" +" proc_5)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_102" +"(hash-iterate-next ht_79 i_91))" +"(values))))" +"(values))))))" +" for-loop_102)" +"(hash-iterate-first ht_79))))" +"(void)))" +"(let-values()(void)))))))" +"(make-module39.1" +" temp10_0" +" unsafe-undefined" +" unsafe-undefined" +" temp16_1" +" #f" +" 0" +" 0" +" temp11_0" +" temp15_1" +" temp12_0" +" unsafe-undefined" +" #f" +" temp14_1" +" null" +" core-mpi13_0" +" #f" +" null" +" #f)))" +"((core-module-name9_0) core-module-name))" +"(declare-module!58.1 #t ns7_0 temp8_0 core-module-name9_0)))))" +"(define-values" +"(core-form-sym)" +"(lambda(s_19 phase_43)" +"(begin" +"(let-values(((ok?_0 id23_0 _24_0)" +"(let-values(((s_171) s_19))" +"(if(let-values(((s_85)(if(syntax?$1 s_171)(syntax-e$1 s_171) s_171)))" +"(if(pair? s_85)" +"(if(let-values(((s_172)(car s_85)))" +"(let-values(((or-part_162)(if(syntax?$1 s_172)(symbol?(syntax-e$1 s_172)) #f)))" +"(if or-part_162 or-part_162(symbol? s_172))))" +"(let-values(((s_173)(cdr s_85))) #t)" +" #f)" +" #f))" +"(let-values()" +"(let-values(((id23_1 _24_1)" +"(let-values(((s_174)(if(syntax?$1 s_171)(syntax-e$1 s_171) s_171)))" +"(let-values(((id25_0)(let-values(((s_175)(car s_174))) s_175))" +"((_26_0)(let-values(((s_176)(cdr s_174))) s_176)))" +"(values id25_0 _26_0)))))" +"(values #t id23_1 _24_1)))" +"(values #f #f #f)))))" +"(if ok?_0" +"(let-values(((b_63)" +"(let-values(((temp27_1) id23_0)((phase28_0) phase_43))" +"(resolve+shift28.1 #f #f null unsafe-undefined #f temp27_1 phase28_0))))" +"(if(module-binding? b_63)" +"(if(eq? core-module-name(1/module-path-index-resolve(module-binding-module b_63)))" +"(module-binding-sym b_63)" +" #f)" +" #f))" +" #f)))))" +"(define-values" +"(taint-dispatch)" +"(lambda(s_0 proc_6 phase_33)" +"(begin" +"((letrec-values(((loop_81)" +"(lambda(s_73 mode_11)" +"(begin" +" 'loop" +"(let-values(((tmp_4) mode_11))" +"(if(equal? tmp_4 'none)" +"(let-values() s_73)" +"(if(equal? tmp_4 'opaque)" +"(let-values()(proc_6 s_73))" +"(if(equal? tmp_4 'transparent)" +"(let-values()" +"(let-values(((c_18)" +"(let-values(((s_177)" +"(let-values(((or-part_13)(syntax->list$1 s_73)))" +"(if or-part_13 or-part_13(syntax-e$1 s_73))))" +"((f_1)(lambda(tail?_40 d_18)(begin 'f d_18)))" +"((s->_3)" +"(lambda(s_178)" +"(begin" +" 's->" +"(loop_81" +" s_178" +"(syntax-taint-mode-property s_178)))))" +"((seen_19) #f))" +"(let-values(((s_179) s_177)" +"((f_2) f_1)" +"((gf_8)" +"(lambda(tail?_41 v_31)" +"(begin" +" 'gf" +"(if(syntax?$1 v_31)" +"(let-values()(s->_3 v_31))" +"(let-values()(f_1 tail?_41 v_31))))))" +"((seen_20) seen_19))" +"((letrec-values(((loop_82)" +"(lambda(tail?_42 s_4 prev-depth_8)" +"(begin" +" 'loop" +"(let-values(((depth_8)" +"(fx+ 1 prev-depth_8)))" +"(if(if seen_20(fx> depth_8 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_42" +" s_4" +"(lambda(tail?_43 s_180)" +"(gf_8 tail?_43 s_180))" +" seen_20))" +"(if(null? s_4)" +"(let-values()(f_2 tail?_42 s_4))" +"(if(pair? s_4)" +"(let-values()" +"(f_2" +" tail?_42" +"(cons" +"(loop_82 #f(car s_4) depth_8)" +"(loop_82" +" #t" +"(cdr s_4)" +" depth_8))))" +"(if(symbol? s_4)" +"(let-values()(f_2 #f s_4))" +"(if(boolean? s_4)" +"(let-values()(f_2 #f s_4))" +"(if(number? s_4)" +"(let-values()(f_2 #f s_4))" +"(if(let-values(((or-part_74)" +"(vector?" +" s_4)))" +"(if or-part_74" +" or-part_74" +"(let-values(((or-part_75)" +"(box?" +" s_4)))" +"(if or-part_75" +" or-part_75" +"(let-values(((or-part_76)" +"(prefab-struct-key" +" s_4)))" +"(if or-part_76" +" or-part_76" +"(hash?" +" s_4)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_42" +" s_4" +"(lambda(tail?_44" +" s_181)" +"(gf_8" +" tail?_44" +" s_181))" +" seen_20))" +"(let-values()" +"(gf_8" +" #f" +" s_4))))))))))))))" +" loop_82)" +" #f" +" s_179" +" 0)))))" +"(datum->syntax$1" +" #f" +" c_18" +" s_73" +"(if(syntax-any-macro-scopes? s_73)" +"(1/syntax-property-remove s_73 original-property-sym)" +" s_73))))" +"(if(equal? tmp_4 'transparent-binding)" +"(let-values()" +"(let-values(((c_19)(syntax-e$1 s_73)))" +"(if(pair? c_19)" +"(let-values()" +"(let-values(((cd_0)(cdr c_19)))" +"(if(let-values(((or-part_80)(pair? cd_0)))" +"(if or-part_80" +" or-part_80" +"(if(syntax?$1 cd_0)(pair?(syntax-e$1 cd_0)) #f)))" +"(let-values()" +"(let-values(((d_19)(if(syntax?$1 cd_0)(syntax-e$1 cd_0) cd_0)))" +"(datum->syntax$1" +" #f" +"(cons" +"(loop_81(car c_19)(syntax-taint-mode-property(car c_19)))" +"(cons" +"(loop_81(car d_19) 'transparent)" +"(let-values(((s_5)" +"(let-values(((or-part_163)" +"(syntax->list$1(cdr d_19))))" +"(if or-part_163 or-part_163(cdr d_19))))" +"((f_38)(lambda(tail?_1 d_20)(begin 'f d_20)))" +"((s->_4)" +"(lambda(s_182)" +"(begin" +" 's->" +"(loop_81" +" s_182" +"(syntax-taint-mode-property s_182)))))" +"((seen_0) #f))" +"(let-values(((s_42) s_5)" +"((f_39) f_38)" +"((gf_9)" +"(lambda(tail?_45 v_41)" +"(begin" +" 'gf" +"(if(syntax?$1 v_41)" +"(let-values()(s->_4 v_41))" +"(let-values()(f_38 tail?_45 v_41))))))" +"((seen_21) seen_0))" +"((letrec-values(((loop_83)" +"(lambda(tail?_46 s_183 prev-depth_9)" +"(begin" +" 'loop" +"(let-values(((depth_9)" +"(fx+ 1 prev-depth_9)))" +"(if(if seen_21" +"(fx> depth_9 32)" +" #f)" +"(let-values()" +"(datum-map-slow" +" tail?_46" +" s_183" +"(lambda(tail?_47 s_184)" +"(gf_9 tail?_47 s_184))" +" seen_21))" +"(if(null? s_183)" +"(let-values()" +"(f_39 tail?_46 s_183))" +"(if(pair? s_183)" +"(let-values()" +"(f_39" +" tail?_46" +"(cons" +"(loop_83" +" #f" +"(car s_183)" +" depth_9)" +"(loop_83" +" #t" +"(cdr s_183)" +" depth_9))))" +"(if(symbol? s_183)" +"(let-values()" +"(f_39 #f s_183))" +"(if(boolean? s_183)" +"(let-values()" +"(f_39 #f s_183))" +"(if(number? s_183)" +"(let-values()" +"(f_39 #f s_183))" +"(if(let-values(((or-part_164)" +"(vector?" +" s_183)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_21)" +"(box?" +" s_183)))" +"(if or-part_21" +" or-part_21" +"(let-values(((or-part_165)" +"(prefab-struct-key" +" s_183)))" +"(if or-part_165" +" or-part_165" +"(hash?" +" s_183)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_46" +" s_183" +"(lambda(tail?_48" +" s_185)" +"(gf_9" +" tail?_48" +" s_185))" +" seen_21))" +"(let-values()" +"(gf_9" +" #f" +" s_183))))))))))))))" +" loop_83)" +" #f" +" s_42" +" 0)))))" +" s_73" +"(if(syntax-any-macro-scopes? s_73)" +"(1/syntax-property-remove s_73 original-property-sym)" +" s_73))))" +"(let-values()(loop_81 s_73 'transparent)))))" +"(let-values()(loop_81 s_73 'transparent)))))" +"(let-values()" +"(let-values(((c_20)(syntax-e$1 s_73)))" +"(let-values(((tmp_15)(core-form-sym c_20 phase_33)))" +"(if(if(equal? tmp_15 'begin)" +" #t" +"(if(equal? tmp_15 'begin-for-syntax)" +" #t" +"(equal? tmp_15 '#%module-begin)))" +"(let-values()(loop_81 s_73 'transparent))" +"(if(if(equal? tmp_15 'define-values)" +" #t" +"(equal? tmp_15 'define-syntaxes))" +"(let-values()(loop_81 s_73 'transparent-binding))" +"(let-values()(loop_81 s_73 'opaque))))))))))))))))" +" loop_81)" +" s_0" +"(syntax-taint-mode-property s_0)))))" +"(define-values" +"(syntax-taint-mode-property)" +"(lambda(s_186)" +"(begin" +"(let-values(((or-part_166)(syntax-property$1 s_186 'taint-mode)))" +"(if or-part_166 or-part_166(syntax-property$1 s_186 'certify-mode))))))" +"(define-values" +"(syntax-remove-taint-dispatch-properties)" +"(lambda(s_187)(begin(1/syntax-property-remove(1/syntax-property-remove s_187 'taint-mode) 'certify-mode))))" +"(define-values(current-module-code-inspector)(make-parameter #f))" +"(define-values" +"(syntax-debug-info$1)" +"(lambda(s_0 phase_44 all-bindings?_0)" +"(begin" +" 'syntax-debug-info" +"(let-values(((hts_0)" +"(reverse$1" +"(let-values(((lst_76)(fallback->list(syntax-shifted-multi-scopes s_0))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_76)))" +"((letrec-values(((for-loop_103)" +"(lambda(fold-var_59 lst_83)" +"(begin" +" 'for-loop" +"(if(pair? lst_83)" +"(let-values(((smss_26)(unsafe-car lst_83))" +"((rest_39)(unsafe-cdr lst_83)))" +"(let-values(((fold-var_60)" +"(let-values(((fold-var_61) fold-var_59))" +"(let-values(((fold-var_62)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((init-ht_0)" +"(if(identifier?" +" s_0)" +"(hasheq" +" 'name" +"(syntax-e$1 s_0))" +" '#hasheq())))" +"(let-values(((s-scs_0)" +"(scope-set-at-fallback" +" s_0" +" smss_26" +" phase_44)))" +"(let-values(((context_1)" +"(scope-set->context" +" s-scs_0)))" +"(let-values(((context-ht_0)" +"(hash-set" +" init-ht_0" +" 'context" +" context_1)))" +"(let-values(((sym_18)" +"(syntax-e$1" +" s_0)))" +"(let-values(((classify-binding_0)" +"(lambda(b_43)" +"(begin" +" 'classify-binding" +"(if(local-binding?" +" b_43)" +" 'local" +" 'module)))))" +"(let-values(((extract-binding_0)" +"(lambda(b_64)" +"(begin" +" 'extract-binding" +"(if(local-binding?" +" b_64)" +"(local-binding-key" +" b_64)" +"(vector" +"(module-binding-sym" +" b_64)" +"(module-binding-module" +" b_64)" +"(module-binding-phase" +" b_64)))))))" +"(let-values(((bindings_0)" +"(append" +"(if(identifier?" +" s_0)" +"(let-values()" +"(let-values(((bindings_1" +" covered-scopess_0)" +"(let-values(((ht_80)" +" s-scs_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys" +" ht_80)))" +"((letrec-values(((for-loop_104)" +"(lambda(bindings_2" +" covered-scope-sets_0" +" i_92)" +"(begin" +" 'for-loop" +"(if i_92" +"(let-values(((sc_28)" +"(unsafe-immutable-hash-iterate-key" +" ht_80" +" i_92)))" +"(let-values(((bindings_3" +" covered-scope-sets_1)" +"(let-values(((ht_81" +" bulk-bindings_3)" +"(let-values(((table_118)" +"(scope-binding-table" +" sc_28)))" +"(if(hash?" +" table_118)" +"(values" +"(hash-ref" +" table_118" +" sym_18" +" '#hash())" +" null)" +"(values" +"(hash-ref" +"(table-with-bulk-bindings-syms" +" table_118)" +" sym_18" +" '#hash())" +"(table-with-bulk-bindings-bulk-bindings" +" table_118)))))" +"((s_188)" +" s_0)" +"((extra-shifts_5)" +" null))" +"(begin" +" #t" +"((letrec-values(((for-loop_20)" +"(lambda(bindings_4" +" covered-scope-sets_2" +" i_38)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" i_38))" +"(let-values(((scs_15)" +"(if(pair?" +" i_38)" +"(let-values()" +"(bulk-binding-at-scopes" +"(car" +" i_38)))" +"(let-values()" +"(hash-iterate-key" +" ht_81" +" i_38))))" +"((b_65)" +"(if(pair?" +" i_38)" +"(let-values()" +"(let-values(((bulk_4)" +"(bulk-binding-at-bulk" +"(car" +" i_38))))" +"(let-values(((b-info_1)" +"(if(symbol-interned?" +" sym_18)" +"(hash-ref" +"(bulk-binding-symbols" +" bulk_4" +" s_188" +" extra-shifts_5)" +" sym_18" +" #f)" +" #f)))" +"(if b-info_1" +"((bulk-binding-create" +" bulk_4)" +" bulk_4" +" b-info_1" +" sym_18)" +" #f))))" +"(let-values()" +"(hash-iterate-value" +" ht_81" +" i_38)))))" +"(let-values(((bindings_5" +" covered-scope-sets_3)" +"(let-values(((bindings_6)" +" bindings_4)" +"((covered-scope-sets_4)" +" covered-scope-sets_2))" +"(if(if scs_15" +"(if b_65" +"(not" +"(set-member?" +" covered-scope-sets_4" +" scs_15))" +" #f)" +" #f)" +"(let-values(((bindings_7)" +" bindings_6)" +"((covered-scope-sets_5)" +" covered-scope-sets_4))" +"(let-values(((bindings_8" +" covered-scope-sets_6)" +"(let-values()" +"(values" +"(cons" +"(hasheq" +" 'name" +"(syntax-e$1" +" s_0)" +" 'context" +"(scope-set->context" +" scs_15)" +" 'match?" +"(subset?" +" scs_15" +" s-scs_0)" +"(classify-binding_0" +" b_65)" +"(extract-binding_0" +" b_65))" +" bindings_7)" +"(set-add" +" covered-scope-sets_5" +" scs_15)))))" +"(values" +" bindings_8" +" covered-scope-sets_6)))" +"(values" +" bindings_6" +" covered-scope-sets_4)))))" +"(if(not" +" #f)" +"(for-loop_20" +" bindings_5" +" covered-scope-sets_3" +"(if(pair?" +" i_38)" +"(let-values()" +"(cdr" +" i_38))" +"(let-values()" +"(let-values(((or-part_30)" +"(hash-iterate-next" +" ht_81" +" i_38)))" +"(if or-part_30" +" or-part_30" +" bulk-bindings_3)))))" +"(values" +" bindings_5" +" covered-scope-sets_3))))" +"(values" +" bindings_4" +" covered-scope-sets_2))))))" +" for-loop_20)" +" bindings_2" +" covered-scope-sets_0" +"(let-values(((or-part_31)" +"(hash-iterate-first" +" ht_81)))" +"(if or-part_31" +" or-part_31" +" bulk-bindings_3)))))))" +"(if(not" +" #f)" +"(for-loop_104" +" bindings_3" +" covered-scope-sets_1" +"(unsafe-immutable-hash-iterate-next" +" ht_80" +" i_92))" +"(values" +" bindings_3" +" covered-scope-sets_1))))" +"(values" +" bindings_2" +" covered-scope-sets_0))))))" +" for-loop_104)" +" null" +"(set)" +"(unsafe-immutable-hash-iterate-first" +" ht_80))))))" +" bindings_1))" +"(let-values()" +" null))" +"(if all-bindings?_0" +"(let-values()" +"(reverse$1" +"(let-values(((ht_82)" +" s-scs_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys" +" ht_82)))" +"((letrec-values(((for-loop_15)" +"(lambda(fold-var_63" +" i_43)" +"(begin" +" 'for-loop" +"(if i_43" +"(let-values(((sc_29)" +"(unsafe-immutable-hash-iterate-key" +" ht_82" +" i_43)))" +"(let-values(((fold-var_64)" +"(let-values(((sym-ht_1)" +"(let-values(((table_63)" +"(scope-binding-table" +" sc_29)))" +"(if(hash?" +" table_63)" +" table_63" +"(table-with-bulk-bindings-syms" +" table_63)))))" +"(begin" +" #t" +"((letrec-values(((for-loop_105)" +"(lambda(fold-var_65" +" state_25)" +"(begin" +" 'for-loop" +"(if(car" +" state_25)" +"(let-values(((o-sym_0)" +"(vector-ref" +"(car" +" state_25)" +" 1))" +"((scs_16)" +"(hash-iterate-key" +"(vector-ref" +"(car" +" state_25)" +" 2)" +"(cdr" +" state_25)))" +"((b_66)" +"(hash-iterate-value" +"(vector-ref" +"(car" +" state_25)" +" 2)" +"(cdr" +" state_25))))" +"(let-values(((fold-var_17)" +"(let-values(((fold-var_66)" +" fold-var_65))" +"(if(eq?" +" o-sym_0" +" sym_18)" +" fold-var_66" +"(let-values(((fold-var_67)" +" fold-var_66))" +"(let-values(((fold-var_18)" +"(let-values()" +"(cons" +"(let-values()" +"(hasheq" +" 'name" +" o-sym_0" +" 'context" +"(scope-set->context" +" scs_16)" +" 'match?" +" #f" +"(classify-binding_0" +" b_66)" +"(extract-binding_0" +" b_66)))" +" fold-var_67))))" +"(values" +" fold-var_18)))))))" +"(if(not" +" #f)" +"(for-loop_105" +" fold-var_17" +"(let-values(((ht_22)" +"(vector-ref" +"(car" +" state_25)" +" 2)))" +"(let-values(((i_93)" +"(hash-iterate-next" +" ht_22" +"(cdr" +" state_25))))" +"(if i_93" +"(cons" +"(car" +" state_25)" +" i_93)" +"(next-state-in-full-binding-table" +" sym-ht_1" +"(hash-iterate-next" +" sym-ht_1" +"(vector-ref" +"(car" +" state_25)" +" 0)))))))" +" fold-var_17)))" +" fold-var_65)))))" +" for-loop_105)" +" fold-var_63" +"((letrec-values(((loop_84)" +"(lambda(sym-i_1)" +"(begin" +" 'loop" +"(if sym-i_1" +"(next-state-in-full-binding-table" +" sym-ht_1" +" sym-i_1)" +" '(#f" +" ." +" #f))))))" +" loop_84)" +"(hash-iterate-first" +" sym-ht_1)))))))" +"(if(not" +" #f)" +"(for-loop_15" +" fold-var_64" +"(unsafe-immutable-hash-iterate-next" +" ht_82" +" i_43))" +" fold-var_64)))" +" fold-var_63)))))" +" for-loop_15)" +" null" +"(unsafe-immutable-hash-iterate-first" +" ht_82))))))" +"(let-values()" +" null)))))" +"(if(null?" +" bindings_0)" +" context-ht_0" +"(hash-set" +" context-ht_0" +" 'bindings" +" bindings_0)))))))))))" +" fold-var_61))))" +"(values fold-var_62)))))" +"(if(not #f)(for-loop_103 fold-var_60 rest_39) fold-var_60)))" +" fold-var_59)))))" +" for-loop_103)" +" null" +" lst_76))))))" +"(let-values(((ht_73)(car hts_0)))(if(null?(cdr hts_0)) ht_73(hash-set ht_73 'fallbacks(cdr hts_0))))))))" +"(define-values" +"(scope-set->context)" +"(lambda(scs_17)" +"(begin" +"(let-values(((temp1_1)" +"(reverse$1" +"(let-values(((ht_83) scs_17))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_83)))" +"((letrec-values(((for-loop_106)" +"(lambda(fold-var_68 i_28)" +"(begin" +" 'for-loop" +"(if i_28" +"(let-values(((sc_30)(unsafe-immutable-hash-iterate-key ht_83 i_28)))" +"(let-values(((fold-var_5)" +"(let-values(((fold-var_6) fold-var_68))" +"(let-values(((fold-var_7)" +"(let-values()" +"(cons" +"(let-values()" +"(if(interned-scope? sc_30)" +"(let-values()" +"(vector" +"(scope-id sc_30)" +"(scope-kind sc_30)" +"(interned-scope-key sc_30)))" +"(if(representative-scope?" +" sc_30)" +"(let-values()" +"(vector" +"(scope-id sc_30)" +"(scope-kind sc_30)" +"(multi-scope-name" +"(representative-scope-owner" +" sc_30))))" +"(let-values()" +"(vector" +"(scope-id sc_30)" +"(scope-kind sc_30))))))" +" fold-var_6))))" +"(values fold-var_7)))))" +"(if(not #f)" +"(for-loop_106" +" fold-var_5" +"(unsafe-immutable-hash-iterate-next ht_83 i_28))" +" fold-var_5)))" +" fold-var_68)))))" +" for-loop_106)" +" null" +"(unsafe-immutable-hash-iterate-first ht_83))))))" +"((<2_0) <)" +"((temp3_2)(lambda(v_137)(vector-ref v_137 0))))" +"(sort7.1 #f temp3_2 temp1_1 <2_0)))))" +"(define-values" +"(raise-ambiguous-error)" +"(lambda(id_20 ctx_7)" +"(begin" +"(raise-syntax-error$1" +" #f" +" \"identifier's binding is ambiguous\"" +" id_20" +" #f" +" null" +"(syntax-debug-info-string id_20 ctx_7)))))" +"(define-values" +"(syntax-debug-info-string)" +"(lambda(s_189 ctx_8)" +"(begin" +"(let-values(((info_3)(syntax-debug-info$1 s_189(expand-context-phase ctx_8) #f)))" +"(if(not" +"(let-values(((or-part_26)(pair?(hash-ref info_3 'bindings null))))" +"(if or-part_26" +" or-part_26" +"(let-values(((lst_84)(hash-ref info_3 'fallbacks null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_84)))" +"((letrec-values(((for-loop_107)" +"(lambda(result_64 lst_85)" +"(begin" +" 'for-loop" +"(if(pair? lst_85)" +"(let-values(((fb-info_0)(unsafe-car lst_85))" +"((rest_40)(unsafe-cdr lst_85)))" +"(let-values(((result_1)" +"(let-values()" +"(let-values(((result_65)" +"(let-values()" +"(let-values()" +"(pair?" +"(hash-ref" +" fb-info_0" +" 'bindings" +" null))))))" +"(values result_65)))))" +"(if(if(not((lambda x_28 result_1) fb-info_0))(not #f) #f)" +"(for-loop_107 result_1 rest_40)" +" result_1)))" +" result_64)))))" +" for-loop_107)" +" #f" +" lst_84))))))" +" (let-values () \"\")" +"(let-values()" +"(let-values(((relevant-scope-sets_0)" +"((letrec-values(((loop_80)" +"(lambda(info_4 layer_0)" +"(begin" +" 'loop" +"(apply" +" append" +"(cons" +"(hash-ref info_4 'context)" +"(reverse$1" +"(let-values(((lst_86)(hash-ref info_4 'bindings null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_86)))" +"((letrec-values(((for-loop_108)" +"(lambda(fold-var_69 lst_87)" +"(begin" +" 'for-loop" +"(if(pair? lst_87)" +"(let-values(((b_21)(unsafe-car lst_87))" +"((rest_41)" +"(unsafe-cdr lst_87)))" +"(let-values(((fold-var_70)" +"(let-values(((fold-var_27)" +" fold-var_69))" +"(let-values(((fold-var_28)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" b_21" +" 'context))" +" fold-var_27))))" +"(values" +" fold-var_28)))))" +"(if(not #f)" +"(for-loop_108 fold-var_70 rest_41)" +" fold-var_70)))" +" fold-var_69)))))" +" for-loop_108)" +" null" +" lst_86)))))" +"(let-values(((fallbacks_0)(hash-ref info_4 'fallbacks null)))" +"(reverse$1" +"(let-values(((lst_88) fallbacks_0)((start_14)(add1 layer_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_88)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_14)))" +"((letrec-values(((for-loop_109)" +"(lambda(fold-var_71 lst_89 pos_12)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_89) #t #f)" +"(let-values(((fallback_0)" +"(unsafe-car lst_89))" +"((rest_42)" +"(unsafe-cdr lst_89))" +"((layer_1) pos_12))" +"(let-values(((fold-var_9)" +"(let-values(((fold-var_72)" +" fold-var_71))" +"(let-values(((fold-var_73)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_80" +" fallback_0" +" layer_1))" +" fold-var_72))))" +"(values" +" fold-var_73)))))" +"(if(not #f)" +"(for-loop_109" +" fold-var_9" +" rest_42" +"(+ pos_12 1))" +" fold-var_9)))" +" fold-var_71)))))" +" for-loop_109)" +" null" +" lst_88" +" start_14))))))))))" +" loop_80)" +" info_3" +" 0)))" +"(let-values(((common-scopes_0)" +"(if(null? relevant-scope-sets_0)" +"(set)" +"(let-values(((lst_90) relevant-scope-sets_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_90)))" +"((letrec-values(((for-loop_110)" +"(lambda(s_182 lst_91)" +"(begin" +" 'for-loop" +"(if(pair? lst_91)" +"(let-values(((l_48)(unsafe-car lst_91))" +"((rest_43)(unsafe-cdr lst_91)))" +"(let-values(((s_89)" +"(let-values(((s_43) s_182))" +"(let-values(((s_190)" +"(let-values()" +"(set-intersect" +" s_43" +"(list->set l_48)))))" +"(values s_190)))))" +"(if(not #f)(for-loop_110 s_89 rest_43) s_89)))" +" s_182)))))" +" for-loop_110)" +"(list->set(car relevant-scope-sets_0))" +" lst_90))))))" +"(string-append" +"((letrec-values(((loop_83)" +"(lambda(info_5 layer_2)" +"(begin" +" 'loop" +"(string-append" +" \"\\n context\"" +"(layer->string layer_2)" +" \"...:\"" +"(describe-context(hash-ref info_5 'context) common-scopes_0)" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_92)" +"(let-values(((temp1_2)(hash-ref info_5 'bindings null))" +"((temp2_2)" +"(lambda(a_41 b_67)" +"(begin" +" 'temp2" +"(if(hash-ref a_41 'match? #f)" +"(not(hash-ref b_67 'match? #f))" +" #f)))))" +"(sort7.1 #f #f temp1_2 temp2_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_92)))" +"((letrec-values(((for-loop_111)" +"(lambda(fold-var_74 lst_93)" +"(begin" +" 'for-loop" +"(if(pair? lst_93)" +"(let-values(((b_39)(unsafe-car lst_93))" +"((rest_44)(unsafe-cdr lst_93)))" +"(let-values(((fold-var_75)" +"(let-values(((fold-var_65)" +" fold-var_74))" +"(let-values(((fold-var_76)" +"(let-values()" +"(cons" +"(let-values()" +"(string-append" +" \"\\n \"" +"(if(hash-ref" +" b_39" +" 'match?" +" #f)" +" \"matching\"" +" \"other\")" +" \" binding\"" +"(layer->string" +" layer_2)" +" \"...:\"" +" \"\\n \"" +"(if(hash-ref" +" b_39" +" 'local" +" #f)" +" \"local\"" +"(format" +" \"~a\"" +"(hash-ref" +" b_39" +" 'module" +" #f)))" +"(describe-context" +"(hash-ref" +" b_39" +" 'context)" +" common-scopes_0)))" +" fold-var_65))))" +"(values fold-var_76)))))" +"(if(not #f)" +"(for-loop_111 fold-var_75 rest_44)" +" fold-var_75)))" +" fold-var_74)))))" +" for-loop_111)" +" null" +" lst_92)))))" +"(let-values(((fallbacks_1)(hash-ref info_5 'fallbacks null)))" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_94) fallbacks_1)((start_15)(add1 layer_2)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_94)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_15)))" +"((letrec-values(((for-loop_112)" +"(lambda(fold-var_66 lst_95 pos_13)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_95) #t #f)" +"(let-values(((fallback_1)(unsafe-car lst_95))" +"((rest_45)(unsafe-cdr lst_95))" +"((layer_3) pos_13))" +"(let-values(((fold-var_77)" +"(let-values(((fold-var_78)" +" fold-var_66))" +"(let-values(((fold-var_79)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_83" +" fallback_1" +" layer_3))" +" fold-var_78))))" +"(values fold-var_79)))))" +"(if(not #f)" +"(for-loop_112" +" fold-var_77" +" rest_45" +"(+ pos_13 1))" +" fold-var_77)))" +" fold-var_66)))))" +" for-loop_112)" +" null" +" lst_94" +" start_15)))))))))))" +" loop_83)" +" info_3" +" 0)" +"(if(set-empty? common-scopes_0)" +" \"\"" +"(string-append" +" \"\\n common scopes...:\"" +"(describe-context" +"(reverse$1" +"(let-values(((lst_96)(hash-ref info_3 'context)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_96)))" +"((letrec-values(((for-loop_113)" +"(lambda(fold-var_80 lst_97)" +"(begin" +" 'for-loop" +"(if(pair? lst_97)" +"(let-values(((s_191)(unsafe-car lst_97))" +"((rest_46)(unsafe-cdr lst_97)))" +"(let-values(((fold-var_81)" +"(let-values(((fold-var_82) fold-var_80))" +"(if(set-member? common-scopes_0 s_191)" +"(let-values(((fold-var_5) fold-var_82))" +"(let-values(((fold-var_6)" +"(let-values()" +"(cons" +"(let-values() s_191)" +" fold-var_5))))" +"(values fold-var_6)))" +" fold-var_82))))" +"(if(not #f)(for-loop_113 fold-var_81 rest_46) fold-var_81)))" +" fold-var_80)))))" +" for-loop_113)" +" null" +" lst_96))))" +"(set)))))))))))))" +"(define-values" +"(describe-context)" +"(lambda(scopes_19 common-scopes_1)" +"(begin" +"(let-values(((strs_0)" +"((letrec-values(((loop_44)" +"(lambda(strs_1 scopes_20)" +"(begin" +" 'loop" +"(if(null? scopes_20)" +"(let-values()(reverse$1 strs_1))" +"(let-values()" +" (let-values (((str_3) (format \" ~a\" (car scopes_20))))" +"(if(if(pair? strs_1)" +"(<(+(string-length str_3)(string-length(car strs_1))) 72)" +" #f)" +"(loop_44" +"(cons(string-append(car strs_1) str_3)(cdr strs_1))" +"(cdr scopes_20))" +"(loop_44(cons str_3 strs_1)(cdr scopes_20))))))))))" +" loop_44)" +" null" +"(if(set-empty? common-scopes_1)" +" scopes_19" +"(append" +"(reverse$1" +"(let-values(((lst_98) scopes_19))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_98)))" +"((letrec-values(((for-loop_114)" +"(lambda(fold-var_83 lst_99)" +"(begin" +" 'for-loop" +"(if(pair? lst_99)" +"(let-values(((s_24)(unsafe-car lst_99))" +"((rest_47)(unsafe-cdr lst_99)))" +"(let-values(((fold-var_84)" +"(let-values(((fold-var_85) fold-var_83))" +"(if(not(set-member? common-scopes_1 s_24))" +"(let-values(((fold-var_86) fold-var_85))" +"(let-values(((fold-var_87)" +"(let-values()" +"(cons" +"(let-values() s_24)" +" fold-var_86))))" +"(values fold-var_87)))" +" fold-var_85))))" +"(if(not #f)(for-loop_114 fold-var_84 rest_47) fold-var_84)))" +" fold-var_83)))))" +" for-loop_114)" +" null" +" lst_98))))" +" (list \"[common scopes]\"))))))" +"(if(null? strs_0)" +" (let-values () \"\\n [empty]\")" +"(let-values()" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_100) strs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_100)))" +"((letrec-values(((for-loop_115)" +"(lambda(fold-var_88 lst_101)" +"(begin" +" 'for-loop" +"(if(pair? lst_101)" +"(let-values(((str_4)(unsafe-car lst_101))((rest_48)(unsafe-cdr lst_101)))" +"(let-values(((fold-var_89)" +"(let-values(((fold-var_90) fold-var_88))" +"(let-values(((fold-var_14)" +"(let-values()" +"(cons" +"(let-values()" +" (string-append \"\\n \" str_4))" +" fold-var_90))))" +"(values fold-var_14)))))" +"(if(not #f)(for-loop_115 fold-var_89 rest_48) fold-var_89)))" +" fold-var_88)))))" +" for-loop_115)" +" null" +" lst_100)))))))))))" +" (define-values (layer->string) (lambda (layer_4) (begin (if (zero? layer_4) \"\" (format \" at layer ~a\" layer_4)))))" +"(define-values" +"(raise-syntax-implicit-error)" +"(lambda(s_0 sym_31 trigger-id_0 ctx_8)" +"(begin" +"(let-values(((phase_45)(expand-context-phase ctx_8)))" +"(let-values(((what_1)" +"(let-values(((tmp_16) sym_31))" +"(if(equal? tmp_16 '#%app)" +" (let-values () \"function application\")" +"(if(equal? tmp_16 '#%datum)" +" (let-values () \"literal data\")" +"(if(equal? tmp_16 '#%top)" +"(let-values()" +"(if(expand-context-allow-unbound? ctx_8)" +" \"reference to a top-level identifier\"" +" \"reference to an unbound identifier\"))" +"(let-values()(void))))))))" +"(let-values(((unbound?_0)" +"(if trigger-id_0" +"(not" +"(let-values(((trigger-id1_0) trigger-id_0)((phase2_1) phase_45))" +"(resolve40.1 #f #f null #f trigger-id1_0 phase2_1)))" +" #f)))" +"(let-values(((unbound-form_0)" +"(if unbound?_0(if(not(eq?(syntax-e$1 s_0)(syntax-e$1 trigger-id_0))) s_0 #f) #f)))" +"(raise-syntax-error$1" +" #f" +"(format" +"(if unbound?_0" +" \"unbound identifier;\\n also, no ~a syntax transformer is bound~a\"" +" (string-append what_1 \" is not allowed;\\n no ~a syntax transformer is bound~a\"))" +" sym_31" +"(let-values(((tmp_17) phase_45))" +"(if(equal? tmp_17 0)" +" (let-values () \"\")" +"(if(equal? tmp_17 1)" +" (let-values () \" in the transformer phase\")" +" (let-values () (format \" at phase ~a\" phase_45))))))" +"(if unbound?_0(let-values(((or-part_13) unbound-form_0))(if or-part_13 or-part_13 trigger-id_0)) #f)" +"(if unbound?_0(if unbound-form_0 trigger-id_0 #f) s_0)" +" null" +" (if unbound?_0 (syntax-debug-info-string trigger-id_0 ctx_8) \"\")))))))))" +"(define-values(make-check-no-duplicate-table)(lambda()(begin '#hasheq())))" +"(define-values" +"(check-no-duplicate-ids7.1)" +"(lambda(what1_0 ids4_0 phase5_0 s6_0 ht3_0)" +"(begin" +" 'check-no-duplicate-ids7" +"(let-values(((ids_2) ids4_0))" +"(let-values(((phase_46) phase5_0))" +"(let-values(((s_3) s6_0))" +"(let-values(((ht_74)(if(eq? ht3_0 unsafe-undefined)(make-check-no-duplicate-table) ht3_0)))" +" (let-values (((what_2) (if (eq? what1_0 unsafe-undefined) \"binding name\" what1_0)))" +"(let-values()" +"((letrec-values(((loop_6)" +"(lambda(v_138 ht_84)" +"(begin" +" 'loop" +"(if(identifier? v_138)" +"(let-values()" +"(let-values(((l_49)(hash-ref ht_84(syntax-e$1 v_138) null)))" +"(begin" +"(let-values(((lst_102) l_49))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_102)))" +"((letrec-values(((for-loop_116)" +"(lambda(lst_77)" +"(begin" +" 'for-loop" +"(if(pair? lst_77)" +"(let-values(((id_21)(unsafe-car lst_77))" +"((rest_49)" +"(unsafe-cdr lst_77)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(bound-identifier=?$1" +" id_21" +" v_138" +" phase_46)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(string-append" +" \"duplicate \"" +" what_2)" +" s_3" +" v_138))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_116 rest_49)" +"(values))))" +"(values))))))" +" for-loop_116)" +" lst_102)))" +"(void)" +"(hash-set ht_84(syntax-e$1 v_138)(cons v_138 l_49)))))" +"(if(pair? v_138)" +"(let-values()(loop_6(cdr v_138)(loop_6(car v_138) ht_84)))" +"(let-values() ht_84)))))))" +" loop_6)" +" ids_2" +" ht_74))))))))))" +"(define-values" +"(remove-use-site-scopes)" +"(lambda(s_0 ctx_7)" +"(begin" +"(let-values(((use-sites_0)(root-expand-context-use-site-scopes ctx_7)))" +"(if(if use-sites_0(pair?(unbox use-sites_0)) #f)" +"(if(syntax?$1 s_0)" +"(remove-scopes s_0(unbox use-sites_0))" +"(reverse$1" +"(let-values(((lst_103) s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_103)))" +"((letrec-values(((for-loop_117)" +"(lambda(fold-var_91 lst_84)" +"(begin" +" 'for-loop" +"(if(pair? lst_84)" +"(let-values(((id_22)(unsafe-car lst_84))((rest_50)(unsafe-cdr lst_84)))" +"(let-values(((fold-var_92)" +"(let-values(((fold-var_93) fold-var_91))" +"(let-values(((fold-var_60)" +"(let-values()" +"(cons" +"(let-values()" +"(remove-scopes id_22(unbox use-sites_0)))" +" fold-var_93))))" +"(values fold-var_60)))))" +"(if(not #f)(for-loop_117 fold-var_92 rest_50) fold-var_92)))" +" fold-var_91)))))" +" for-loop_117)" +" null" +" lst_103)))))" +" s_0)))))" +"(define-values" +"(struct:compile-context" +" compile-context1.1" +" compile-context?" +" compile-context-namespace" +" compile-context-phase" +" compile-context-self" +" compile-context-module-self" +" compile-context-full-module-name" +" compile-context-lazy-syntax-literals?" +" compile-context-header)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'compile-context" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'compile-context)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'namespace)" +"(make-struct-field-accessor -ref_0 1 'phase)" +"(make-struct-field-accessor -ref_0 2 'self)" +"(make-struct-field-accessor -ref_0 3 'module-self)" +"(make-struct-field-accessor -ref_0 4 'full-module-name)" +"(make-struct-field-accessor -ref_0 5 'lazy-syntax-literals?)" +"(make-struct-field-accessor -ref_0 6 'header))))" +"(define-values" +"(make-compile-context14.1)" +"(lambda(full-module-name6_0 lazy-syntax-literals?7_0 module-self5_0 namespace2_0 phase3_1 self4_1)" +"(begin" +" 'make-compile-context14" +"(let-values(((namespace_1)(if(eq? namespace2_0 unsafe-undefined)(1/current-namespace) namespace2_0)))" +"(let-values(((phase_47)(if(eq? phase3_1 unsafe-undefined)(namespace-phase namespace_1) phase3_1)))" +"(let-values(((self_6)(if(eq? self4_1 unsafe-undefined)(namespace-self-mpi namespace_1) self4_1)))" +"(let-values(((module-self_0) module-self5_0))" +"(let-values(((full-module-name_0) full-module-name6_0))" +"(let-values(((lazy-syntax-literals?_0)" +"(if(eq? lazy-syntax-literals?7_0 unsafe-undefined)" +"(if module-self_0 #t #f)" +" lazy-syntax-literals?7_0)))" +"(let-values()" +"(begin" +"(if(if module-self_0(not full-module-name_0) #f)" +" (let-values () (error \"internal error: module-self provided without full name\"))" +"(void))" +"(compile-context1.1" +" namespace_1" +" phase_47" +" self_6" +" module-self_0" +" full-module-name_0" +" lazy-syntax-literals?_0" +" #f))))))))))))" +"(define-values" +"(struct:mpi-intern-table mpi-intern-table1.1 mpi-intern-table? mpi-intern-table-normal mpi-intern-table-fast)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'mpi-intern-table" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'mpi-intern-table)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'normal)" +"(make-struct-field-accessor -ref_0 1 'fast))))" +"(define-values" +"(make-module-path-index-intern-table)" +"(lambda()(begin(mpi-intern-table1.1(make-hash)(make-hasheq)))))" +"(define-values" +"(intern-module-path-index!)" +"(lambda(t_45 mpi_20)" +"(begin" +"(let-values(((or-part_72)(hash-ref(mpi-intern-table-fast t_45) mpi_20 #f)))" +"(if or-part_72" +" or-part_72" +"(let-values(((name_2 base_15)(1/module-path-index-split mpi_20)))" +"(if(not name_2)" +"(let-values()(begin(hash-set!(mpi-intern-table-fast t_45) mpi_20 mpi_20) mpi_20))" +"(let-values()" +"(let-values(((interned-base_0)(if base_15(intern-module-path-index! t_45 base_15) #f)))" +"(let-values(((at-name_0)" +"(let-values(((or-part_29)(hash-ref(mpi-intern-table-normal t_45) name_2 #f)))" +"(if or-part_29" +" or-part_29" +"(let-values(((at-name_1)(make-hasheq)))" +"(begin(hash-set!(mpi-intern-table-normal t_45) name_2 at-name_1) at-name_1))))))" +"(let-values(((i-mpi_0)" +"(let-values(((or-part_79)(hash-ref at-name_0 interned-base_0 #f)))" +"(if or-part_79" +" or-part_79" +"(let-values(((mpi_21)" +"(if(eq? base_15 interned-base_0)" +" mpi_20" +"(let-values(((the-struct_47) mpi_20))" +"(if(1/module-path-index? the-struct_47)" +"(let-values(((base3_0) interned-base_0))" +"(module-path-index2.1" +"(module-path-index-path the-struct_47)" +" base3_0" +"(module-path-index-resolved the-struct_47)" +"(module-path-index-shift-cache the-struct_47)))" +"(raise-argument-error" +" 'struct-copy" +" \"module-path-index?\"" +" the-struct_47))))))" +"(begin(hash-set! at-name_0 interned-base_0 mpi_21) mpi_21))))))" +"(begin(hash-set!(mpi-intern-table-fast t_45) mpi_20 i-mpi_0) i-mpi_0))))))))))))" +"(define-values(built-in-symbols)(make-hasheq))" +"(define-values(register-built-in-symbol!)(lambda(s_0)(begin(hash-set! built-in-symbols s_0 #t))))" +"(define-values(built-in-symbol?)(lambda(s_72)(begin(hash-ref built-in-symbols s_72 #f))))" +"(define-values" +"(make-built-in-symbol!)" +"(lambda(s_189)" +"(begin" +" (let-values (((built-in-s_0) (string->symbol (format \".~s\" s_189))))" +"(begin(register-built-in-symbol! built-in-s_0) built-in-s_0)))))" +"(void" +"(begin" +"(for-each2" +" register-built-in-symbol!" +" '(lambda case-lambda" +" if" +" begin" +" begin0" +" let-values" +" letrec-values" +" set!" +" quote" +" with-continuation-mark" +" #%variable-reference))" +"(for-each2" +" register-built-in-symbol!" +" '(check-not-undefined" +" instance-variable-box" +" variable-reference" +" variable-reference?" +" variable-reference->instance" +" variable-reference-constant?" +" variable-reference-from-unsafe?))" +"(for-each2" +" register-built-in-symbol!" +" '(let letrec* define" +" or" +" and" +" pariah" +" variable-set!" +" variable-ref" +" variable-ref/no-check" +" make-instance-variable-reference" +" annotation?" +" annotation-expression" +" #%app" +" #%call-with-values" +" make-pthread-parameter))))" +"(define-values(phase-shift-id)(make-built-in-symbol! 'phase))" +"(define-values(dest-phase-id)(make-built-in-symbol! 'dest-phase))" +"(define-values(ns-id)(make-built-in-symbol! 'namespace))" +"(define-values(self-id)(make-built-in-symbol! 'self))" +"(define-values(syntax-literals-id)(make-built-in-symbol! 'syntax-literals))" +"(define-values(get-syntax-literal!-id)(make-built-in-symbol! 'get-syntax-literal!))" +"(define-values(bulk-binding-registry-id)(make-built-in-symbol! 'bulk-binding-registry))" +"(define-values(inspector-id)(make-built-in-symbol! 'inspector))" +"(define-values(deserialize-syntax-id)(make-built-in-symbol! 'deserialize-syntax))" +"(define-values(deserialized-syntax-vector-id)(make-built-in-symbol! 'deserialized-syntax-vector))" +"(define-values(set-transformer!-id)(make-built-in-symbol! 'set-transformer!))" +"(define-values(top-level-bind!-id)(make-built-in-symbol! 'top-level-bind!))" +"(define-values(top-level-require!-id)(make-built-in-symbol! 'top-level-require!))" +"(define-values(mpi-vector-id)(make-built-in-symbol! 'mpi-vector))" +"(define-values" +"(struct:module-path-index-table" +" module-path-index-table1.1" +" module-path-index-table?" +" module-path-index-table-positions" +" module-path-index-table-intern)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-path-index-table" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-path-index-table)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'positions)" +"(make-struct-field-accessor -ref_0 1 'intern))))" +"(define-values" +"(make-module-path-index-table)" +"(lambda()(begin(module-path-index-table1.1(make-hasheq)(make-module-path-index-intern-table)))))" +"(define-values" +"(add-module-path-index!)" +"(lambda(mpis_0 mpi_20)" +"(begin" +"(let-values(((pos_14)(add-module-path-index!/pos mpis_0 mpi_20)))" +"(if pos_14(list 'unsafe-vector*-ref mpi-vector-id pos_14) #f)))))" +"(define-values" +"(add-module-path-index!/pos)" +"(lambda(mpis_1 mpi_22)" +"(begin" +"(if(not mpi_22)" +"(let-values() #f)" +"(if mpi_22" +"(let-values()" +"(let-values(((mpi_23)(intern-module-path-index!(module-path-index-table-intern mpis_1) mpi_22))" +"((positions_0)(module-path-index-table-positions mpis_1)))" +"(let-values(((or-part_77)(hash-ref positions_0 mpi_23 #f)))" +"(if or-part_77" +" or-part_77" +"(let-values(((pos_15)(hash-count positions_0)))" +"(begin(hash-set! positions_0 mpi_23 pos_15) pos_15))))))" +"(void))))))" +"(define-values" +"(generate-module-path-index-deserialize)" +"(lambda(mpis_2)" +"(begin" +"(let-values(((unique-list_0)" +"(lambda(v_139)" +"(begin" +" 'unique-list" +"(if(pair? v_139)" +"(reverse$1" +"(let-values(((lst_104) v_139))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_104)))" +"((letrec-values(((for-loop_118)" +"(lambda(fold-var_10 lst_80)" +"(begin" +" 'for-loop" +"(if(pair? lst_80)" +"(let-values(((i_94)(unsafe-car lst_80))" +"((rest_51)(unsafe-cdr lst_80)))" +"(let-values(((fold-var_94)" +"(let-values(((fold-var_95) fold-var_10))" +"(let-values(((fold-var_96)" +"(let-values()" +"(cons" +"(let-values() i_94)" +" fold-var_95))))" +"(values fold-var_96)))))" +"(if(not #f)" +"(for-loop_118 fold-var_94 rest_51)" +" fold-var_94)))" +" fold-var_10)))))" +" for-loop_118)" +" null" +" lst_104))))" +" v_139)))))" +"(let-values(((positions_1)(module-path-index-table-positions mpis_2)))" +"(let-values(((gen-order_0)(make-hasheqv)))" +"(let-values(((rev-positions_0)" +"(let-values(((ht_85) positions_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_85)))" +"((letrec-values(((for-loop_119)" +"(lambda(table_119 i_95)" +"(begin" +" 'for-loop" +"(if i_95" +"(let-values(((k_19 v_69)(hash-iterate-key+value ht_85 i_95)))" +"(let-values(((table_120)" +"(let-values(((table_114) table_119))" +"(let-values(((table_121)" +"(let-values()" +"(let-values(((key_45 val_38)" +"(let-values()" +"(values" +" v_69" +" k_19))))" +"(hash-set" +" table_114" +" key_45" +" val_38)))))" +"(values table_121)))))" +"(if(not #f)" +"(for-loop_119 table_120(hash-iterate-next ht_85 i_95))" +" table_120)))" +" table_119)))))" +" for-loop_119)" +" '#hasheqv()" +"(hash-iterate-first ht_85))))))" +"(let-values((()" +"(begin" +"(let-values(((start_16) 0)((end_10)(hash-count rev-positions_0))((inc_4) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_16 end_10 inc_4)))" +"((letrec-values(((for-loop_105)" +"(lambda(pos_16)" +"(begin" +" 'for-loop" +"(if(< pos_16 end_10)" +"(let-values(((i_96) pos_16))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((mpi_24)" +"(hash-ref" +" rev-positions_0" +" i_96)))" +"((letrec-values(((loop_85)" +"(lambda(mpi_25)" +"(begin" +" 'loop" +"(if(hash-ref" +" gen-order_0" +" mpi_25" +" #f)" +"(void)" +"(let-values()" +"(let-values(((name_37" +" base_16)" +"(1/module-path-index-split" +" mpi_25)))" +"(begin" +"(if base_16" +"(let-values()" +"(loop_85" +" base_16))" +"(void))" +"(hash-set!" +" gen-order_0" +" mpi_25" +"(hash-count" +" gen-order_0))))))))))" +" loop_85)" +" mpi_24)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_105(+ pos_16 inc_4))(values))))" +"(values))))))" +" for-loop_105)" +" start_16)))" +"(values))))" +"(let-values()" +"(let-values(((rev-gen-order_0)" +"(let-values(((ht_86) gen-order_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_86)))" +"((letrec-values(((for-loop_120)" +"(lambda(table_122 i_93)" +"(begin" +" 'for-loop" +"(if i_93" +"(let-values(((k_20 v_38)" +"(hash-iterate-key+value ht_86 i_93)))" +"(let-values(((table_15)" +"(let-values(((table_123) table_122))" +"(let-values(((table_9)" +"(let-values()" +"(let-values(((key_46" +" val_39)" +"(let-values()" +"(values" +" v_38" +" k_20))))" +"(hash-set" +" table_123" +" key_46" +" val_39)))))" +"(values table_9)))))" +"(if(not #f)" +"(for-loop_120 table_15(hash-iterate-next ht_86 i_93))" +" table_15)))" +" table_122)))))" +" for-loop_120)" +" '#hasheqv()" +"(hash-iterate-first ht_86))))))" +"(let-values(((gens_0)" +"(let-values(((len_12)(hash-count gen-order_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_12)" +"(void)" +"(let-values()" +" (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_12)))" +"(let-values(((v_140)(make-vector len_12 0)))" +"(begin" +"(if(zero? len_12)" +"(void)" +"(let-values()" +"(let-values(((start_17) 0)" +"((end_11)(hash-count gen-order_0))" +"((inc_5) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_17 end_11 inc_5)))" +"((letrec-values(((for-loop_28)" +"(lambda(i_97 pos_17)" +"(begin" +" 'for-loop" +"(if(< pos_17 end_11)" +"(let-values(((i_91) pos_17))" +"(let-values(((i_98)" +"(let-values(((i_99) i_97))" +"(let-values(((i_29)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_140" +" i_99" +"(let-values()" +"(let-values(((mpi_26)" +"(hash-ref" +" rev-gen-order_0" +" i_91)))" +"(let-values(((path_6" +" base_17)" +"(1/module-path-index-split" +" mpi_26)))" +"(if(top-level-module-path-index?" +" mpi_26)" +"(let-values()" +" 'top)" +"(if(not" +" path_6)" +"(let-values()" +"(box" +"(let-values(((or-part_167)" +"(unique-list_0" +"(1/resolved-module-path-name" +"(module-path-index-resolved" +" mpi_26)))))" +"(if or-part_167" +" or-part_167" +" 'self))))" +"(if(not" +" base_17)" +"(let-values()" +"(vector" +" path_6))" +"(if base_17" +"(let-values()" +"(vector" +" path_6" +"(hash-ref" +" gen-order_0" +" base_17)))" +"(void)))))))))" +"(unsafe-fx+" +" 1" +" i_99)))))" +"(values i_29)))))" +"(if(if(not" +"((lambda x_43" +"(unsafe-fx= i_98 len_12))" +" i_91))" +"(not #f)" +" #f)" +"(for-loop_28 i_98(+ pos_17 inc_5))" +" i_98)))" +" i_97)))))" +" for-loop_28)" +" 0" +" start_17)))))" +" v_140))))))" +"(list" +" 'deserialize-module-path-indexes" +"(list 'quote gens_0)" +"(list" +" 'quote" +"(let-values(((vec_30 i_46)" +"(let-values(((start_18) 0)((end_12)(hash-count rev-positions_0))((inc_6) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_18 end_12 inc_6)))" +"((letrec-values(((for-loop_53)" +"(lambda(vec_31 i_100 pos_18)" +"(begin" +" 'for-loop" +"(if(< pos_18 end_12)" +"(let-values(((i_101) pos_18))" +"(let-values(((vec_32 i_102)" +"(let-values(((vec_33) vec_31)" +"((i_39) i_100))" +"(let-values(((vec_34 i_103)" +"(let-values()" +"(let-values(((new-vec_2)" +"(if(eq?" +" i_39" +"(unsafe-vector*-length" +" vec_33))" +"(grow-vector" +" vec_33)" +" vec_33)))" +"(begin" +"(unsafe-vector*-set!" +" new-vec_2" +" i_39" +"(let-values()" +"(hash-ref" +" gen-order_0" +"(hash-ref" +" rev-positions_0" +" i_101))))" +"(values" +" new-vec_2" +"(unsafe-fx+" +" i_39" +" 1)))))))" +"(values vec_34 i_103)))))" +"(if(not #f)" +"(for-loop_53 vec_32 i_102(+ pos_18 inc_6))" +"(values vec_32 i_102))))" +"(values vec_31 i_100))))))" +" for-loop_53)" +"(make-vector 16)" +" 0" +" start_18)))))" +"(shrink-vector vec_30 i_46)))))))))))))))" +"(define-values" +"(deserialize-module-path-indexes)" +"(lambda(gen-vec_0 order-vec_0)" +"(begin" +"(let-values(((gen_0)(make-vector(vector-length gen-vec_0) #f)))" +"(begin" +"(let-values(((vec_35 len_13)" +"(let-values(((vec_23) gen-vec_0))" +"(begin(check-vector vec_23)(values vec_23(unsafe-vector-length vec_23)))))" +"((start_19) 0))" +"(begin" +" #f" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_19)))" +"((letrec-values(((for-loop_121)" +"(lambda(pos_19 pos_20)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< pos_19 len_13) #t #f)" +"(let-values(((d_21)(unsafe-vector-ref vec_35 pos_19))((i_104) pos_20))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set!" +" gen_0" +" i_104" +"(if(eq? d_21 'top)" +"(let-values()" +"(deserialize-module-path-index))" +"(if(box? d_21)" +"(let-values()" +"(deserialize-module-path-index" +"(unbox d_21)))" +"(let-values()" +"(deserialize-module-path-index" +"(vector*-ref d_21 0)" +"(if(>(vector*-length d_21) 1)" +"(vector*-ref" +" gen_0" +"(vector*-ref d_21 1))" +" #f)))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_121(unsafe-fx+ 1 pos_19)(+ pos_20 1))(values))))" +"(values))))))" +" for-loop_121)" +" 0" +" start_19)))" +"(void)" +"(let-values(((len_14)(vector-length order-vec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_14)" +"(void)" +" (let-values () (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_14)))" +"(let-values(((v_141)(make-vector len_14 0)))" +"(begin" +"(if(zero? len_14)" +"(void)" +"(let-values()" +"(let-values(((vec_36 len_4)" +"(let-values(((vec_11) order-vec_0))" +"(begin(check-vector vec_11)(values vec_11(unsafe-vector-length vec_11))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_122)" +"(lambda(i_105 pos_21)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_21 len_4)" +"(let-values(((p_33)(unsafe-vector-ref vec_36 pos_21)))" +"(let-values(((i_48)" +"(let-values(((i_106) i_105))" +"(let-values(((i_107)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_141" +" i_106" +"(let-values()" +"(vector*-ref gen_0 p_33)))" +"(unsafe-fx+ 1 i_106)))))" +"(values i_107)))))" +"(if(if(not((lambda x_44(unsafe-fx= i_48 len_14)) p_33))" +"(not #f)" +" #f)" +"(for-loop_122 i_48(unsafe-fx+ 1 pos_21))" +" i_48)))" +" i_105)))))" +" for-loop_122)" +" 0" +" 0)))))" +" v_141)))))))))" +"(define-values" +"(mpis-as-vector)" +"(lambda(mpis_3)" +"(begin" +"(let-values(((positions_2)(module-path-index-table-positions mpis_3)))" +"(let-values(((vec_37)(make-vector(hash-count positions_2) #f)))" +"(begin" +"(let-values(((ht_87) positions_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_87)))" +"((letrec-values(((for-loop_123)" +"(lambda(i_24)" +"(begin" +" 'for-loop" +"(if i_24" +"(let-values(((mpi_27 pos_22)(hash-iterate-key+value ht_87 i_24)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set! vec_37 pos_22 mpi_27))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_123(hash-iterate-next ht_87 i_24))(values))))" +"(values))))))" +" for-loop_123)" +"(hash-iterate-first ht_87))))" +"(void)" +" vec_37))))))" +"(define-values" +"(serialize-module-uses)" +"(lambda(mus_0 mpis_4)" +"(begin" +"(reverse$1" +"(let-values(((lst_105) mus_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_105)))" +"((letrec-values(((for-loop_124)" +"(lambda(fold-var_97 lst_11)" +"(begin" +" 'for-loop" +"(if(pair? lst_11)" +"(let-values(((mu_1)(unsafe-car lst_11))((rest_52)(unsafe-cdr lst_11)))" +"(let-values(((fold-var_98)" +"(let-values(((fold-var_99) fold-var_97))" +"(let-values(((fold-var_100)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" 'module-use" +"(add-module-path-index!" +" mpis_4" +"(module-use-module mu_1))" +"(module-use-phase mu_1)))" +" fold-var_99))))" +"(values fold-var_100)))))" +"(if(not #f)(for-loop_124 fold-var_98 rest_52) fold-var_98)))" +" fold-var_97)))))" +" for-loop_124)" +" null" +" lst_105)))))))" +"(define-values" +"(interned-literal?)" +"(lambda(v_142)" +"(begin" +"(let-values(((or-part_168)(null? v_142)))" +"(if or-part_168" +" or-part_168" +"(let-values(((or-part_169)(boolean? v_142)))" +"(if or-part_169" +" or-part_169" +"(let-values(((or-part_140)" +"(if(fixnum? v_142)(if(< v_142(sub1(expt 2 30)))(> v_142(-(expt 2 30))) #f) #f)))" +"(if or-part_140" +" or-part_140" +"(let-values(((or-part_170)(symbol? v_142)))" +"(if or-part_170" +" or-part_170" +"(let-values(((or-part_46)(char? v_142)))(if or-part_46 or-part_46(keyword? v_142))))))))))))))" +"(define-values" +"(serialize-phase-to-link-module-uses)" +"(lambda(phase-to-link-module-uses_0 mpis_5)" +"(begin" +"(let-values(((phases-in-order_0)" +"(let-values(((temp10_1)(hash-keys phase-to-link-module-uses_0))((<11_0) <))" +"(sort7.1 #f #f temp10_1 <11_0))))" +"(list*" +" 'hasheqv" +"(apply" +" append" +"(reverse$1" +"(let-values(((lst_106) phases-in-order_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_106)))" +"((letrec-values(((for-loop_80)" +"(lambda(fold-var_101 lst_50)" +"(begin" +" 'for-loop" +"(if(pair? lst_50)" +"(let-values(((phase_9)(unsafe-car lst_50))((rest_53)(unsafe-cdr lst_50)))" +"(let-values(((fold-var_102)" +"(let-values(((fold-var_103) fold-var_101))" +"(let-values(((fold-var_104)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" phase_9" +"(list*" +" 'list" +"(serialize-module-uses" +"(hash-ref" +" phase-to-link-module-uses_0" +" phase_9)" +" mpis_5))))" +" fold-var_103))))" +"(values fold-var_104)))))" +"(if(not #f)(for-loop_80 fold-var_102 rest_53) fold-var_102)))" +" fold-var_101)))))" +" for-loop_80)" +" null" +" lst_106))))))))))" +"(define-values" +"(generate-deserialize6.1)" +"(lambda(syntax-support?2_0 v4_0 mpis5_0)" +"(begin" +" 'generate-deserialize6" +"(let-values(((v_143) v4_0))" +"(let-values(((mpis_6) mpis5_0))" +"(let-values(((syntax-support?_0) syntax-support?2_0))" +"(let-values()" +"(let-values(((reachable-scopes_4)(find-reachable-scopes v_143)))" +"(let-values(((state_26)(make-serialize-state reachable-scopes_4)))" +"(let-values(((mutables_0)(make-hasheq)))" +"(let-values(((objs_0)(make-hasheq)))" +"(let-values(((shares_0)(make-hasheq)))" +"(let-values(((obj-step_0) 0))" +"(let-values(((frontier_0) null))" +"(letrec-values(((add-frontier!_0)" +"(case-lambda" +"((v_144)(begin 'add-frontier!(set! frontier_0(cons v_144 frontier_0))))" +"((kind_3 v_100)(add-frontier!_0 v_100)))))" +"(let-values((()" +"(begin" +"((letrec-values(((frontier-loop_0)" +"(lambda(v_102)" +"(begin" +" 'frontier-loop" +"(begin" +"((letrec-values(((loop_11)" +"(lambda(v_104)" +"(begin" +" 'loop" +"(if(let-values(((or-part_171)" +"(interned-literal?" +" v_104)))" +"(if or-part_171" +" or-part_171" +"(1/module-path-index?" +" v_104)))" +"(let-values()(void))" +"(if(hash-ref" +" objs_0" +" v_104" +" #f)" +"(let-values()" +"(if(hash-ref" +" mutables_0" +" v_104" +" #f)" +"(void)" +"(let-values()" +"(hash-set!" +" shares_0" +" v_104" +" #t))))" +"(let-values()" +"(begin" +"(if(serialize-fill!?" +" v_104)" +"(let-values()" +"(begin" +"(hash-set!" +" mutables_0" +" v_104" +"(hash-count" +" mutables_0))" +"((serialize-fill!-ref" +" v_104)" +" v_104" +" add-frontier!_0" +" state_26)))" +"(if(serialize?" +" v_104)" +"(let-values()" +"((serialize-ref" +" v_104)" +" v_104" +"(case-lambda" +"((sub-v_0)" +"(loop_11" +" sub-v_0))" +"((kind_4" +" sub-v_1)" +"(loop_11" +" sub-v_1)))" +" state_26))" +"(if(pair?" +" v_104)" +"(let-values()" +"(begin" +"(loop_11" +"(car" +" v_104))" +"(loop_11" +"(cdr" +" v_104))))" +"(if(vector?" +" v_104)" +"(let-values()" +"(if(let-values(((or-part_172)" +"(immutable?" +" v_104)))" +"(if or-part_172" +" or-part_172" +"(zero?" +"(vector-length" +" v_104))))" +"(begin" +"(let-values(((vec_38" +" len_15)" +"(let-values(((vec_39)" +" v_104))" +"(begin" +"(check-vector" +" vec_39)" +"(values" +" vec_39" +"(unsafe-vector-length" +" vec_39))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_96)" +"(lambda(pos_23)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_23" +" len_15)" +"(let-values(((e_19)" +"(unsafe-vector-ref" +" vec_38" +" pos_23)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_11" +" e_19))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_96" +"(unsafe-fx+" +" 1" +" pos_23))" +"(values))))" +"(values))))))" +" for-loop_96)" +" 0)))" +"(void))" +"(begin" +"(hash-set!" +" mutables_0" +" v_104" +"(hash-count" +" mutables_0))" +"(begin" +"(let-values(((vec_40" +" len_16)" +"(let-values(((vec_41)" +" v_104))" +"(begin" +"(check-vector" +" vec_41)" +"(values" +" vec_41" +"(unsafe-vector-length" +" vec_41))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_125)" +"(lambda(pos_24)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_24" +" len_16)" +"(let-values(((e_20)" +"(unsafe-vector-ref" +" vec_40" +" pos_24)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(add-frontier!_0" +" e_20))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_125" +"(unsafe-fx+" +" 1" +" pos_24))" +"(values))))" +"(values))))))" +" for-loop_125)" +" 0)))" +"(void)))))" +"(if(box?" +" v_104)" +"(let-values()" +"(if(immutable?" +" v_104)" +"(loop_11" +"(unbox" +" v_104))" +"(begin" +"(hash-set!" +" mutables_0" +" v_104" +"(hash-count" +" mutables_0))" +"(add-frontier!_0" +"(unbox" +" v_104)))))" +"(if(hash?" +" v_104)" +"(let-values()" +"(if(immutable?" +" v_104)" +"(begin" +"(let-values(((lst_107)" +"(sorted-hash-keys" +" v_104)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_107)))" +"((letrec-values(((for-loop_126)" +"(lambda(lst_108)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_108)" +"(let-values(((k_21)" +"(unsafe-car" +" lst_108))" +"((rest_54)" +"(unsafe-cdr" +" lst_108)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(loop_11" +" k_21)" +"(loop_11" +"(hash-ref" +" v_104" +" k_21))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_126" +" rest_54)" +"(values))))" +"(values))))))" +" for-loop_126)" +" lst_107)))" +"(void))" +"(begin" +"(hash-set!" +" mutables_0" +" v_104" +"(hash-count" +" mutables_0))" +"(begin" +"(let-values(((lst_109)" +"(sorted-hash-keys" +" v_104)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_109)))" +"((letrec-values(((for-loop_127)" +"(lambda(lst_110)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_110)" +"(let-values(((k_22)" +"(unsafe-car" +" lst_110))" +"((rest_55)" +"(unsafe-cdr" +" lst_110)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(add-frontier!_0" +" k_22)" +"(add-frontier!_0" +"(hash-ref" +" v_104" +" k_22))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_127" +" rest_55)" +"(values))))" +"(values))))))" +" for-loop_127)" +" lst_109)))" +"(void)))))" +"(if(prefab-struct-key" +" v_104)" +"(let-values()" +"(begin" +"(let-values(((v*_2" +" start*_1" +" stop*_2" +" step*_1)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_45)" +"(vector?" +" x_45))" +"(lambda(x_46)" +"(unsafe-vector-length" +" x_46))" +"(struct->vector" +" v_104)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_128)" +"(lambda(idx_1)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_1" +" stop*_2)" +"(let-values(((e_21)" +"(unsafe-vector-ref" +" v*_2" +" idx_1)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_11" +" e_21))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_128" +"(unsafe-fx+" +" idx_1" +" 1))" +"(values))))" +"(values))))))" +" for-loop_128)" +" start*_1)))" +"(void)))" +"(if(srcloc?" +" v_104)" +"(let-values()" +"(if(path?" +"(srcloc-source" +" v_104))" +"(void)" +"(let-values()" +"(begin" +"(let-values(((v*_3" +" start*_2" +" stop*_3" +" step*_2)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_47)" +"(vector?" +" x_47))" +"(lambda(x_48)" +"(unsafe-vector-length" +" x_48))" +"(struct->vector" +" v_104)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_129)" +"(lambda(idx_2)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_2" +" stop*_3)" +"(let-values(((e_22)" +"(unsafe-vector-ref" +" v*_3" +" idx_2)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_11" +" e_22))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_129" +"(unsafe-fx+" +" idx_2" +" 1))" +"(values))))" +"(values))))))" +" for-loop_129)" +" start*_2)))" +"(void)))))" +"(let-values()" +"(void))))))))))" +"(hash-set!" +" objs_0" +" v_104" +" obj-step_0)" +"(set! obj-step_0" +"(add1" +" obj-step_0))))))))))" +" loop_11)" +" v_102)" +"(if(null? frontier_0)" +"(void)" +"(let-values()" +"(let-values(((l_50) frontier_0))" +"(begin" +"(set! frontier_0 null)" +"(let-values(((lst_111) l_50))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_111)))" +"((letrec-values(((for-loop_130)" +"(lambda(lst_112)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_112)" +"(let-values(((v_145)" +"(unsafe-car" +" lst_112))" +"((rest_56)" +"(unsafe-cdr" +" lst_112)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(frontier-loop_0" +" v_145))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_130" +" rest_56)" +"(values))))" +"(values))))))" +" for-loop_130)" +" lst_111)))" +"(void))))))))))" +" frontier-loop_0)" +" v_143)" +"(values))))" +"(let-values(((num-mutables_0)(hash-count mutables_0)))" +"(let-values(((share-step-positions_0)" +"(let-values(((share-steps_0)" +"(reverse$1" +"(let-values(((ht_88) shares_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_88)))" +"((letrec-values(((for-loop_131)" +"(lambda(fold-var_105 i_108)" +"(begin" +" 'for-loop" +"(if i_108" +"(let-values(((obj_0)" +"(hash-iterate-key" +" ht_88" +" i_108)))" +"(let-values(((fold-var_106)" +"(let-values(((fold-var_107)" +" fold-var_105))" +"(let-values(((fold-var_108)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" objs_0" +" obj_0))" +" fold-var_107))))" +"(values" +" fold-var_108)))))" +"(if(not #f)" +"(for-loop_131" +" fold-var_106" +"(hash-iterate-next" +" ht_88" +" i_108))" +" fold-var_106)))" +" fold-var_105)))))" +" for-loop_131)" +" null" +"(hash-iterate-first ht_88)))))))" +"(let-values(((lst_113)" +"(let-values(((share-steps12_0) share-steps_0)" +"((<13_0) <))" +"(sort7.1 #f #f share-steps12_0 <13_0)))" +"((start_20) num-mutables_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_113)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_20)))" +"((letrec-values(((for-loop_132)" +"(lambda(table_124 lst_114 pos_25)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_114) #t #f)" +"(let-values(((step_3)" +"(unsafe-car lst_114))" +"((rest_57)" +"(unsafe-cdr lst_114))" +"((pos_26) pos_25))" +"(let-values(((table_125)" +"(let-values(((table_35)" +" table_124))" +"(let-values(((table_36)" +"(let-values()" +"(let-values(((key_47" +" val_40)" +"(let-values()" +"(values" +" step_3" +" pos_26))))" +"(hash-set" +" table_35" +" key_47" +" val_40)))))" +"(values table_36)))))" +"(if(not #f)" +"(for-loop_132" +" table_125" +" rest_57" +"(+ pos_25 1))" +" table_125)))" +" table_124)))))" +" for-loop_132)" +" '#hasheqv()" +" lst_113" +" start_20))))))" +"(let-values(((stream_0) null))" +"(let-values(((stream-size_0) 0))" +"(let-values(((next-push-position_0)" +"(lambda()(begin 'next-push-position stream-size_0))))" +"(let-values(((quoted?_0)" +"(lambda(pos_27)" +"(begin" +" 'quoted?" +"(let-values(((v_146)" +"(list-ref" +" stream_0" +"(- stream-size_0(add1 pos_27)))))" +"(let-values(((or-part_173)(not(keyword? v_146))))" +"(if or-part_173 or-part_173(eq? '#:quote v_146))))))))" +"(let-values(((ser-reset!_0)" +"(lambda(pos_28)" +"(begin" +" 'ser-reset!" +"(begin" +"(set! stream_0" +"(list-tail stream_0(- stream-size_0 pos_28)))" +"(set! stream-size_0 pos_28))))))" +"(let-values(((reap-stream!_0)" +"(lambda()" +"(begin" +" 'reap-stream!" +"(begin0" +"(list->vector(reverse$1 stream_0))" +"(set! stream_0 null)" +"(set! stream-size_0 0))))))" +"(letrec-values(((ser-push!_16)" +"(case-lambda" +"((v_147)" +"(begin" +" 'ser-push!" +"(if(hash-ref shares_0 v_147 #f)" +"(let-values()" +"(let-values(((n_22)" +"(hash-ref" +" share-step-positions_0" +"(hash-ref objs_0 v_147))))" +"(begin" +"(ser-push!_16 'tag '#:ref)" +"(ser-push!_16 'exact n_22))))" +"(let-values(((c1_25)" +"(hash-ref mutables_0 v_147 #f)))" +"(if c1_25" +"((lambda(n_23)" +"(begin" +"(ser-push!_16 'tag '#:ref)" +"(ser-push!_16 'exact n_23)))" +" c1_25)" +"(let-values()" +"(ser-push-encoded!_0 v_147)))))))" +"((kind_5 v_148)" +"(let-values(((tmp_18) kind_5))" +"(if(equal? tmp_18 'exact)" +"(let-values()" +"(begin" +"(set! stream_0(cons v_148 stream_0))" +"(set! stream-size_0(add1 stream-size_0))))" +"(if(equal? tmp_18 'tag)" +"(let-values()(ser-push!_16 'exact v_148))" +"(if(equal? tmp_18 'reference)" +"(let-values()" +"(if(hash-ref shares_0 v_148 #f)" +"(let-values()" +"(let-values(((n_24)" +"(hash-ref" +" share-step-positions_0" +"(hash-ref" +" objs_0" +" v_148))))" +"(ser-push!_16 'exact n_24)))" +"(let-values(((c2_1)" +"(hash-ref" +" mutables_0" +" v_148" +" #f)))" +"(if c2_1" +"((lambda(n_25)" +"(ser-push!_16 'exact n_25))" +" c2_1)" +"(let-values()" +"(ser-push!_16 v_148))))))" +"(let-values()(ser-push!_16 v_148)))))))))" +"((ser-push-encoded!_0)" +"(lambda(v_149)" +"(begin" +" 'ser-push-encoded!" +"(if(keyword? v_149)" +"(let-values()" +"(begin" +"(ser-push!_16 'tag '#:quote)" +"(ser-push!_16 'exact v_149)))" +"(if(1/module-path-index? v_149)" +"(let-values()" +"(begin" +"(ser-push!_16 'tag '#:mpi)" +"(ser-push!_16" +" 'exact" +"(add-module-path-index!/pos" +" mpis_6" +" v_149))))" +"(if(serialize? v_149)" +"(let-values()" +"((serialize-ref v_149)" +" v_149" +" ser-push!_16" +" state_26))" +"(if(if(list? v_149)" +"(if(pair? v_149)" +"(pair?(cdr v_149))" +" #f)" +" #f)" +"(let-values()" +"(let-values(((start-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:list)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +"(length v_149))" +"(values))))" +"(let-values(((all-quoted?_0)" +"(let-values(((lst_115)" +" v_149))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_115)))" +"((letrec-values(((for-loop_133)" +"(lambda(all-quoted?_1" +" lst_116)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_116)" +"(let-values(((i_109)" +"(unsafe-car" +" lst_116))" +"((rest_58)" +"(unsafe-cdr" +" lst_116)))" +"(let-values(((all-quoted?_2)" +"(let-values(((all-quoted?_3)" +" all-quoted?_1))" +"(let-values(((all-quoted?_4)" +"(let-values()" +"(let-values(((i-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_16" +" i_109)" +"(if all-quoted?_3" +"(quoted?_0" +" i-pos_0)" +" #f))))))" +"(values" +" all-quoted?_4)))))" +"(if(not" +" #f)" +"(for-loop_133" +" all-quoted?_2" +" rest_58)" +" all-quoted?_2)))" +" all-quoted?_1)))))" +" for-loop_133)" +" #t" +" lst_115)))))" +"(if all-quoted?_0" +"(let-values()" +"(begin" +"(ser-reset!_0 start-pos_0)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))" +"(if(pair? v_149)" +"(let-values()" +"(let-values(((start-pos_1)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:cons)" +"(values))))" +"(let-values(((a-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +"(car v_149))" +"(values))))" +"(let-values(((d-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_16(cdr v_149))" +"(if(if(quoted?_0 a-pos_0)" +"(quoted?_0 d-pos_0)" +" #f)" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_1)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))))" +"(if(box? v_149)" +"(let-values()" +"(let-values(((start-pos_2)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:box)" +"(values))))" +"(let-values(((v-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_16(unbox v_149))" +"(if(quoted?_0 v-pos_0)" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_2)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))" +"(if(vector? v_149)" +"(let-values()" +"(let-values(((start-pos_3)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:vector)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +"(vector-length" +" v_149))" +"(values))))" +"(let-values(((all-quoted?_5)" +"(let-values(((vec_42" +" len_17)" +"(let-values(((vec_43)" +" v_149))" +"(begin" +"(check-vector" +" vec_43)" +"(values" +" vec_43" +"(unsafe-vector-length" +" vec_43))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_38)" +"(lambda(all-quoted?_6" +" pos_29)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_29" +" len_17)" +"(let-values(((i_110)" +"(unsafe-vector-ref" +" vec_42" +" pos_29)))" +"(let-values(((all-quoted?_7)" +"(let-values(((all-quoted?_8)" +" all-quoted?_6))" +"(let-values(((all-quoted?_9)" +"(let-values()" +"(let-values(((i-pos_1)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_16" +" i_110)" +"(if all-quoted?_8" +"(quoted?_0" +" i-pos_1)" +" #f))))))" +"(values" +" all-quoted?_9)))))" +"(if(not" +" #f)" +"(for-loop_38" +" all-quoted?_7" +"(unsafe-fx+" +" 1" +" pos_29))" +" all-quoted?_7)))" +" all-quoted?_6)))))" +" for-loop_38)" +" #t" +" 0)))))" +"(if all-quoted?_5" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_3)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))" +"(if(hash? v_149)" +"(let-values()" +"(let-values(((start-pos_4)" +"(next-push-position_0)))" +"(let-values(((as-set?_0)" +"(let-values(((ht_89)" +" v_149))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-values" +" ht_89)))" +"((letrec-values(((for-loop_134)" +"(lambda(result_66" +" i_111)" +"(begin" +" 'for-loop" +"(if i_111" +"(let-values(((val_41)" +"(hash-iterate-value" +" ht_89" +" i_111)))" +"(let-values(((result_67)" +"(let-values()" +"(let-values(((result_68)" +"(let-values()" +"(let-values()" +"(eq?" +" val_41" +" #t)))))" +"(values" +" result_68)))))" +"(if(if(not" +"((lambda x_49" +"(not" +" result_67))" +" val_41))" +"(not" +" #f)" +" #f)" +"(for-loop_134" +" result_67" +"(hash-iterate-next" +" ht_89" +" i_111))" +" result_67)))" +" result_66)))))" +" for-loop_134)" +" #t" +"(hash-iterate-first" +" ht_89))))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +"(if as-set?_0" +"(if(hash-eq?" +" v_149)" +"(let-values()" +" '#:seteq)" +"(if(hash-eqv?" +" v_149)" +"(let-values()" +" '#:seteqv)" +"(let-values()" +" '#:set)))" +"(if(hash-eq?" +" v_149)" +"(let-values()" +" '#:hasheq)" +"(if(hash-eqv?" +" v_149)" +"(let-values()" +" '#:hasheqv)" +"(let-values()" +" '#:hash)))))" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +"(hash-count" +" v_149))" +"(values))))" +"(let-values(((ks_0)" +"(sorted-hash-keys" +" v_149)))" +"(let-values(((all-quoted?_10)" +"(let-values(((lst_117)" +" ks_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_117)))" +"((letrec-values(((for-loop_135)" +"(lambda(all-quoted?_11" +" lst_118)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_118)" +"(let-values(((k_23)" +"(unsafe-car" +" lst_118))" +"((rest_59)" +"(unsafe-cdr" +" lst_118)))" +"(let-values(((all-quoted?_12)" +"(let-values(((all-quoted?_13)" +" all-quoted?_11))" +"(let-values(((all-quoted?_14)" +"(let-values()" +"(let-values(((k-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" k_23)" +"(values))))" +"(let-values(((v-pos_1)" +"(next-push-position_0)))" +"(begin" +"(if as-set?_0" +"(void)" +"(let-values()" +"(ser-push!_16" +"(hash-ref" +" v_149" +" k_23))))" +"(if all-quoted?_13" +"(if(quoted?_0" +" k-pos_0)" +"(let-values(((or-part_174)" +" as-set?_0))" +"(if or-part_174" +" or-part_174" +"(quoted?_0" +" v-pos_1)))" +" #f)" +" #f))))))))" +"(values" +" all-quoted?_14)))))" +"(if(not" +" #f)" +"(for-loop_135" +" all-quoted?_12" +" rest_59)" +" all-quoted?_12)))" +" all-quoted?_11)))))" +" for-loop_135)" +" #t" +" lst_117)))))" +"(if all-quoted?_10" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_4)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))))" +"(let-values(((c3_0)" +"(prefab-struct-key" +" v_149)))" +"(if c3_0" +"((lambda(k_24)" +"(let-values(((vec_44)" +"(struct->vector" +" v_149)))" +"(let-values(((start-pos_5)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:prefab)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +" k_24)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +"(sub1" +"(vector-length" +" vec_44)))" +"(values))))" +"(let-values(((all-quoted?_15)" +"(let-values(((v*_4" +" start*_3" +" stop*_4" +" step*_3)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_50)" +"(vector?" +" x_50))" +"(lambda(x_51)" +"(unsafe-vector-length" +" x_51))" +" vec_44" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_42)" +"(lambda(all-quoted?_16" +" idx_3)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_3" +" stop*_4)" +"(let-values(((i_112)" +"(unsafe-vector-ref" +" v*_4" +" idx_3)))" +"(let-values(((all-quoted?_17)" +"(let-values(((all-quoted?_18)" +" all-quoted?_16))" +"(let-values(((all-quoted?_19)" +"(let-values()" +"(let-values(((i-pos_2)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_16" +" i_112)" +"(if all-quoted?_18" +"(quoted?_0" +" i-pos_2)" +" #f))))))" +"(values" +" all-quoted?_19)))))" +"(if(not" +" #f)" +"(for-loop_42" +" all-quoted?_17" +"(unsafe-fx+" +" idx_3" +" 1))" +" all-quoted?_17)))" +" all-quoted?_16)))))" +" for-loop_42)" +" #t" +" start*_3)))))" +"(if all-quoted?_15" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_5)" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(void)))))))))" +" c3_0)" +"(if(srcloc? v_149)" +"(let-values()" +"(if(path?" +"(srcloc-source v_149))" +"(let-values()" +"(begin" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))" +"(let-values()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:srcloc)" +"(ser-push!_16" +"(srcloc-source" +" v_149))" +"(ser-push!_16" +"(srcloc-line v_149))" +"(ser-push!_16" +"(srcloc-column" +" v_149))" +"(ser-push!_16" +"(srcloc-position" +" v_149))" +"(ser-push!_16" +"(srcloc-span" +" v_149))))))" +"(let-values()" +"(begin" +"(ser-push-optional-quote!_0)" +"(ser-push!_16" +" 'exact" +" v_149)))))))))))))))))" +"((ser-push-optional-quote!_0)" +"(lambda()(begin 'ser-push-optional-quote!(void)))))" +"(let-values(((ser-shell!_0)" +"(lambda(v_150)" +"(begin" +" 'ser-shell!" +"(if(serialize-fill!? v_150)" +"(let-values()" +"((serialize-ref v_150)" +" v_150" +" ser-push!_16" +" state_26))" +"(if(box? v_150)" +"(let-values()(ser-push!_16 'tag '#:box))" +"(if(vector? v_150)" +"(let-values()" +"(begin" +"(ser-push!_16 'tag '#:vector)" +"(ser-push!_16" +" 'exact" +"(vector-length v_150))))" +"(if(hash? v_150)" +"(let-values()" +"(ser-push!_16" +" 'tag" +"(if(hash-eq? v_150)" +"(let-values() '#:hasheq)" +"(if(hash-eqv? v_150)" +"(let-values() '#:hasheqv)" +"(let-values() '#:hash)))))" +"(let-values()" +"(error" +" 'ser-shell" +" \"unknown mutable: ~e\"" +" v_150))))))))))" +"(let-values(((ser-shell-fill!_0)" +"(lambda(v_80)" +"(begin" +" 'ser-shell-fill!" +"(if(serialize-fill!? v_80)" +"(let-values()" +"((serialize-fill!-ref v_80)" +" v_80" +" ser-push!_16" +" state_26))" +"(if(box? v_80)" +"(let-values()" +"(begin" +"(ser-push!_16 'tag '#:set-box!)" +"(ser-push!_16(unbox v_80))))" +"(if(vector? v_80)" +"(let-values()" +"(begin" +"(ser-push!_16 'tag '#:set-vector!)" +"(ser-push!_16" +" 'exact" +"(vector-length v_80))" +"(let-values(((vec_45 len_18)" +"(let-values(((vec_46)" +" v_80))" +"(begin" +"(check-vector vec_46)" +"(values" +" vec_46" +"(unsafe-vector-length" +" vec_46))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_136)" +"(lambda(pos_30)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_30" +" len_18)" +"(let-values(((v_151)" +"(unsafe-vector-ref" +" vec_45" +" pos_30)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-push!_16" +" v_151))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_136" +"(unsafe-fx+" +" 1" +" pos_30))" +"(values))))" +"(values))))))" +" for-loop_136)" +" 0)))" +"(void)))" +"(if(hash? v_80)" +"(let-values()" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'tag" +" '#:set-hash!)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_16" +" 'exact" +"(hash-count v_80))" +"(values))))" +"(let-values(((ks_1)" +"(sorted-hash-keys" +" v_80)))" +"(begin" +"(let-values(((lst_119) ks_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_119)))" +"((letrec-values(((for-loop_137)" +"(lambda(lst_120)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_120)" +"(let-values(((k_25)" +"(unsafe-car" +" lst_120))" +"((rest_60)" +"(unsafe-cdr" +" lst_120)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(ser-push!_16" +" k_25)" +"(ser-push!_16" +"(hash-ref" +" v_80" +" k_25))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_137" +" rest_60)" +"(values))))" +"(values))))))" +" for-loop_137)" +" lst_119)))" +"(void))))))" +"(let-values()" +"(error" +" 'ser-shell-fill" +" \"unknown mutable: ~e\"" +" v_80))))))))))" +"(let-values(((rev-mutables_0)" +"(let-values(((ht_90) mutables_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_90)))" +"((letrec-values(((for-loop_138)" +"(lambda(table_126 i_113)" +"(begin" +" 'for-loop" +"(if i_113" +"(let-values(((k_26" +" v_152)" +"(hash-iterate-key+value" +" ht_90" +" i_113)))" +"(let-values(((table_59)" +"(let-values(((table_60)" +" table_126))" +"(let-values(((table_127)" +"(let-values()" +"(let-values(((key_48" +" val_42)" +"(let-values()" +"(values" +" v_152" +" k_26))))" +"(hash-set" +" table_60" +" key_48" +" val_42)))))" +"(values" +" table_127)))))" +"(if(not #f)" +"(for-loop_138" +" table_59" +"(hash-iterate-next" +" ht_90" +" i_113))" +" table_59)))" +" table_126)))))" +" for-loop_138)" +" '#hasheqv()" +"(hash-iterate-first ht_90))))))" +"(let-values(((mutable-shell-bindings_0)" +"(begin" +"(begin" +"(let-values(((start_21) 0)" +"((end_13)" +"(hash-count mutables_0))" +"((inc_7) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_21 end_13 inc_7)))" +"((letrec-values(((for-loop_139)" +"(lambda(pos_31)" +"(begin" +" 'for-loop" +"(if(<" +" pos_31" +" end_13)" +"(let-values(((i_59)" +" pos_31))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-shell!_0" +"(hash-ref" +" rev-mutables_0" +" i_59)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_139" +"(+" +" pos_31" +" inc_7))" +"(values))))" +"(values))))))" +" for-loop_139)" +" start_21)))" +"(void))" +"(reap-stream!_0))))" +"(let-values(((rev-shares_0)" +"(let-values(((ht_91) shares_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys ht_91)))" +"((letrec-values(((for-loop_140)" +"(lambda(table_128 i_60)" +"(begin" +" 'for-loop" +"(if i_60" +"(let-values(((obj_1)" +"(hash-iterate-key" +" ht_91" +" i_60)))" +"(let-values(((table_129)" +"(let-values(((table_130)" +" table_128))" +"(let-values(((table_131)" +"(let-values()" +"(let-values(((key_49" +" val_43)" +"(let-values()" +"(values" +"(hash-ref" +" share-step-positions_0" +"(hash-ref" +" objs_0" +" obj_1))" +" obj_1))))" +"(hash-set" +" table_130" +" key_49" +" val_43)))))" +"(values" +" table_131)))))" +"(if(not #f)" +"(for-loop_140" +" table_129" +"(hash-iterate-next" +" ht_91" +" i_60))" +" table_129)))" +" table_128)))))" +" for-loop_140)" +" '#hasheqv()" +"(hash-iterate-first ht_91))))))" +"(let-values(((shared-bindings_0)" +"(begin" +"(begin" +"(let-values(((start_22) num-mutables_0)" +"((end_14)" +"(+" +" num-mutables_0" +"(hash-count shares_0)))" +"((inc_8) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range" +" start_22" +" end_14" +" inc_8)))" +"((letrec-values(((for-loop_141)" +"(lambda(pos_32)" +"(begin" +" 'for-loop" +"(if(<" +" pos_32" +" end_14)" +"(let-values(((i_114)" +" pos_32))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-push-encoded!_0" +"(hash-ref" +" rev-shares_0" +" i_114)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_141" +"(+" +" pos_32" +" inc_8))" +"(values))))" +"(values))))))" +" for-loop_141)" +" start_22)))" +"(void))" +"(reap-stream!_0))))" +"(let-values(((mutable-fills_0)" +"(begin" +"(begin" +"(let-values(((start_23) 0)" +"((end_15)" +"(hash-count mutables_0))" +"((inc_9) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range" +" start_23" +" end_15" +" inc_9)))" +"((letrec-values(((for-loop_142)" +"(lambda(pos_33)" +"(begin" +" 'for-loop" +"(if(<" +" pos_33" +" end_15)" +"(let-values(((i_115)" +" pos_33))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-shell-fill!_0" +"(hash-ref" +" rev-mutables_0" +" i_115)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_142" +"(+" +" pos_33" +" inc_9))" +"(values))))" +"(values))))))" +" for-loop_142)" +" start_23)))" +"(void))" +"(reap-stream!_0))))" +"(list" +" 'deserialize" +" mpi-vector-id" +"(if syntax-support?_0 inspector-id #f)" +"(if syntax-support?_0 bulk-binding-registry-id #f)" +"(list 'quote(hash-count mutables_0))" +"(list 'quote mutable-shell-bindings_0)" +"(list 'quote(hash-count shares_0))" +"(list 'quote shared-bindings_0)" +"(list 'quote mutable-fills_0)" +"(list" +" 'quote" +"(begin" +"(ser-push!_16 v_143)" +"(reap-stream!_0))))))))))))))))))))))))))))))))))))" +"(define-values" +"(sorted-hash-keys)" +"(lambda(ht_92)" +"(begin" +"(let-values(((ks_2)(hash-keys ht_92)))" +"(if(null? ks_2)" +"(let-values() ks_2)" +"(if(null?(cdr ks_2))" +"(let-values() ks_2)" +"(if(andmap2 symbol? ks_2)" +"(let-values()" +"(let-values(((ks14_0) ks_2)((symbolsyntax . 5)" +"(#:syntax+props . 6)" +"(#:representative-scope . 23))" +" tmp_20" +"(lambda() 0))" +" 0)))" +"(if(unsafe-fx< index_0 14)" +"(if(unsafe-fx< index_0 6)" +"(if(unsafe-fx< index_0 2)" +"(if(unsafe-fx< index_0 1)" +"(let-values()(values(vector*-ref vec_50 pos_51)(add1 pos_51)))" +"(let-values()(values(vector*-ref shared_2(vector*-ref vec_50(add1 pos_51)))(+ pos_51 2))))" +"(if(unsafe-fx< index_0 3)" +"(let-values()(values inspector_8(add1 pos_51)))" +"(if(unsafe-fx< index_0 4)" +"(let-values()(values bulk-binding-registry_7(add1 pos_51)))" +"(if(unsafe-fx< index_0 5)" +"(let-values()" +"(let-values(((content_8 next-pos_2)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((context_2 next-pos_3)" +"(let-values(((i_118)(vector*-ref vec_50 next-pos_2)))" +"(if(exact-integer? i_118)" +"(values(vector*-ref shared_2 i_118)(add1 next-pos_2))" +"(decode" +" vec_50" +" next-pos_2" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_3 next-pos_4)" +"(let-values(((i_119)(vector*-ref vec_50 next-pos_3)))" +"(if(exact-integer? i_119)" +"(values(vector*-ref shared_2 i_119)(add1 next-pos_3))" +"(decode" +" vec_50" +" next-pos_3" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(values" +"(deserialize-syntax content_8 context_2 srcloc_3 #f #f inspector_8)" +" next-pos_4)))))" +"(let-values()" +"(let-values(((content_9 next-pos_5)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((context_3 next-pos_6)" +"(let-values(((i_120)(vector*-ref vec_50 next-pos_5)))" +"(if(exact-integer? i_120)" +"(values(vector*-ref shared_2 i_120)(add1 next-pos_5))" +"(decode" +" vec_50" +" next-pos_5" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_4 next-pos_7)" +"(let-values(((i_121)(vector*-ref vec_50 next-pos_6)))" +"(if(exact-integer? i_121)" +"(values(vector*-ref shared_2 i_121)(add1 next-pos_6))" +"(decode" +" vec_50" +" next-pos_6" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(values" +"(deserialize-datum->syntax content_9 context_3 srcloc_4 inspector_8)" +" next-pos_7)))))))))" +"(if(unsafe-fx< index_0 9)" +"(if(unsafe-fx< index_0 7)" +"(let-values()" +"(let-values(((content_10 next-pos_8)" +"(decode vec_50(add1 pos_51) mpis_9 inspector_8 bulk-binding-registry_7 shared_2)))" +"(let-values(((context_4 next-pos_9)" +"(let-values(((i_122)(vector*-ref vec_50 next-pos_8)))" +"(if(exact-integer? i_122)" +"(values(vector*-ref shared_2 i_122)(add1 next-pos_8))" +"(decode" +" vec_50" +" next-pos_8" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_5 next-pos_10)" +"(let-values(((i_123)(vector*-ref vec_50 next-pos_9)))" +"(if(exact-integer? i_123)" +"(values(vector*-ref shared_2 i_123)(add1 next-pos_9))" +"(decode" +" vec_50" +" next-pos_9" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((props_1 next-pos_11)" +"(decode" +" vec_50" +" next-pos_10" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((tamper_2 next-pos_12)" +"(decode" +" vec_50" +" next-pos_11" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-syntax content_10 context_4 srcloc_5 props_1 tamper_2 inspector_8)" +" next-pos_12)))))))" +"(if(unsafe-fx< index_0 8)" +"(let-values()" +"(let-values(((source_0 next-pos_13)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((line_0 next-pos_14)" +"(decode" +" vec_50" +" next-pos_13" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((column_0 next-pos_15)" +"(decode" +" vec_50" +" next-pos_14" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((position_0 next-pos_16)" +"(decode" +" vec_50" +" next-pos_15" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((span_0 next-pos_17)" +"(decode" +" vec_50" +" next-pos_16" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(srcloc source_0 line_0 column_0 position_0 span_0) next-pos_17)))))))" +"(let-values()(values(vector*-ref vec_50(add1 pos_51))(+ pos_51 2)))))" +"(if(unsafe-fx< index_0 11)" +"(if(unsafe-fx< index_0 10)" +"(let-values()(values(vector*-ref mpis_9(vector*-ref vec_50(add1 pos_51)))(+ pos_51 2)))" +"(let-values()" +"(let-values(((v_154 next-pos_18)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(box-immutable v_154) next-pos_18))))" +"(if(unsafe-fx< index_0 12)" +"(let-values()" +"(let-values(((a_42 next-pos_19)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((d_24 next-pos_20)" +"(decode" +" vec_50" +" next-pos_19" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(cons a_42 d_24) next-pos_20))))" +"(if(unsafe-fx< index_0 13)" +"(let-values()" +"(let-values(((len_20)(vector*-ref vec_50(add1 pos_51))))" +"(let-values(((r_29)(make-vector len_20)))" +"(let-values(((next-pos_21)" +"(let-values(((start_27) 0)((end_19) len_20)((inc_13) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_27 end_19 inc_13)))" +"((letrec-values(((for-loop_146)" +"(lambda(pos_52 pos_53)" +"(begin" +" 'for-loop" +"(if(< pos_53 end_19)" +"(let-values(((i_124) pos_53))" +"(let-values(((pos_54)" +"(let-values(((pos_55) pos_52))" +"(let-values(((pos_56)" +"(let-values()" +"(let-values(((v_155" +" next-pos_22)" +"(let-values(((v_156" +" next-pos_23)" +"(decode" +" vec_50" +" pos_55" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +" v_156" +" next-pos_23))))" +"(begin" +"(vector-set!" +" r_29" +" i_124" +" v_155)" +" next-pos_22)))))" +"(values pos_56)))))" +"(if(not #f)" +"(for-loop_146 pos_54(+ pos_53 inc_13))" +" pos_54)))" +" pos_52)))))" +" for-loop_146)" +"(+ pos_51 2)" +" start_27)))))" +"(values" +"(if(eq?(vector*-ref vec_50 pos_51) '#:list)" +"(vector->list r_29)" +"(vector->immutable-vector r_29))" +" next-pos_21)))))" +"(let-values()" +"(let-values(((ht_55)" +"(let-values(((tmp_21)(vector*-ref vec_50 pos_51)))" +"(if(equal? tmp_21 '#:hash)" +"(let-values()(hash))" +"(if(equal? tmp_21 '#:hasheq)" +"(let-values()(hasheq))" +"(if(equal? tmp_21 '#:hasheqv)" +"(let-values()(hasheqv))" +"(let-values()(void))))))))" +"(let-values(((len_21)(vector*-ref vec_50(add1 pos_51))))" +"(let-values(((start_28) 0)((end_20) len_21)((inc_14) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_28 end_20 inc_14)))" +"((letrec-values(((for-loop_147)" +"(lambda(ht_93 pos_57 pos_58)" +"(begin" +" 'for-loop" +"(if(< pos_58 end_20)" +"(let-values()" +"(let-values(((ht_94 pos_59)" +"(let-values(((ht_95) ht_93)" +"((pos_60) pos_57))" +"(let-values(((ht_96 pos_61)" +"(let-values()" +"(let-values(((k_27" +" next-pos_24)" +"(decode" +" vec_50" +" pos_60" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((v_157" +" next-pos_25)" +"(decode" +" vec_50" +" next-pos_24" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(hash-set" +" ht_95" +" k_27" +" v_157)" +" next-pos_25))))))" +"(values ht_96 pos_61)))))" +"(if(not #f)" +"(for-loop_147 ht_94 pos_59(+ pos_58 inc_14))" +"(values ht_94 pos_59))))" +"(values ht_93 pos_57))))))" +" for-loop_147)" +" ht_55" +"(+ pos_51 2)" +" start_28)))))))))))" +"(if(unsafe-fx< index_0 21)" +"(if(unsafe-fx< index_0 17)" +"(if(unsafe-fx< index_0 15)" +"(let-values()" +"(let-values(((s_192)" +"(let-values(((tmp_22)(vector*-ref vec_50 pos_51)))" +"(if(equal? tmp_22 '#:set)" +"(let-values()(set))" +"(if(equal? tmp_22 '#:seteq)" +"(let-values()(seteq))" +"(if(equal? tmp_22 '#:seteqv)" +"(let-values()(seteqv))" +"(let-values()(void))))))))" +"(let-values(((len_22)(vector*-ref vec_50(add1 pos_51))))" +"(let-values(((start_29) 0)((end_21) len_22)((inc_15) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_29 end_21 inc_15)))" +"((letrec-values(((for-loop_148)" +"(lambda(s_193 pos_62 pos_63)" +"(begin" +" 'for-loop" +"(if(< pos_63 end_21)" +"(let-values()" +"(let-values(((s_194 pos_64)" +"(let-values(((s_195) s_193)((pos_65) pos_62))" +"(let-values(((s_196 pos_66)" +"(let-values()" +"(let-values(((k_28 next-pos_26)" +"(decode" +" vec_50" +" pos_65" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(set-add s_195 k_28)" +" next-pos_26)))))" +"(values s_196 pos_66)))))" +"(if(not #f)" +"(for-loop_148 s_194 pos_64(+ pos_63 inc_15))" +"(values s_194 pos_64))))" +"(values s_193 pos_62))))))" +" for-loop_148)" +" s_192" +"(+ pos_51 2)" +" start_29))))))" +"(if(unsafe-fx< index_0 16)" +"(let-values()" +"(let-values(((key_50 next-pos_27)" +"(let-values(((k_29 next-pos_28)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values k_29 next-pos_28))))" +"(let-values(((len_23)(vector*-ref vec_50 next-pos_27)))" +"(let-values(((r_30 done-pos_1)" +"(let-values(((start_30) 0)((end_22) len_23)((inc_16) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_30 end_22 inc_16)))" +"((letrec-values(((for-loop_149)" +"(lambda(r_31 pos_67 pos_68)" +"(begin" +" 'for-loop" +"(if(< pos_68 end_22)" +"(let-values()" +"(let-values(((r_32 pos_69)" +"(let-values(((r_33) r_31)" +"((pos_70) pos_67))" +"(let-values(((r_34 pos_71)" +"(let-values()" +"(let-values(((v_158" +" next-pos_29)" +"(decode" +" vec_50" +" pos_70" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(cons" +" v_158" +" r_33)" +" next-pos_29)))))" +"(values r_34 pos_71)))))" +"(if(not #f)" +"(for-loop_149 r_32 pos_69(+ pos_68 inc_16))" +"(values r_32 pos_69))))" +"(values r_31 pos_67))))))" +" for-loop_149)" +" null" +"(add1 next-pos_27)" +" start_30)))))" +"(values(apply make-prefab-struct key_50(reverse$1 r_30)) done-pos_1)))))" +"(let-values()(values(deserialize-scope)(add1 pos_51)))))" +"(if(unsafe-fx< index_0 18)" +"(let-values()" +"(let-values(((kind_6 next-pos_30)" +"(decode vec_50(add1 pos_51) mpis_9 inspector_8 bulk-binding-registry_7 shared_2)))" +"(values(deserialize-scope kind_6) next-pos_30)))" +"(if(unsafe-fx< index_0 19)" +"(let-values()" +"(let-values(((id_23 next-pos_31)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(make-interned-scope id_23) next-pos_31)))" +"(if(unsafe-fx< index_0 20)" +"(let-values()" +"(let-values(((name_38 next-pos_32)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((scopes_21 next-pos_33)" +"(decode" +" vec_50" +" next-pos_32" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-multi-scope name_38 scopes_21) next-pos_33))))" +"(let-values()" +"(let-values(((phase_48 next-pos_34)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((multi-scope_2 next-pos_35)" +"(decode" +" vec_50" +" next-pos_34" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-shifted-multi-scope phase_48 multi-scope_2) next-pos_35))))))))" +"(if(unsafe-fx< index_0 24)" +"(if(unsafe-fx< index_0 22)" +"(let-values()" +"(let-values(((syms_13 next-pos_36)" +"(decode vec_50(add1 pos_51) mpis_9 inspector_8 bulk-binding-registry_7 shared_2)))" +"(let-values(((bulk-bindings_4 next-pos_37)" +"(decode vec_50 next-pos_36 mpis_9 inspector_8 bulk-binding-registry_7 shared_2)))" +"(values(deserialize-table-with-bulk-bindings syms_13 bulk-bindings_4) next-pos_37))))" +"(if(unsafe-fx< index_0 23)" +"(let-values()" +"(let-values(((scopes_22 next-pos_38)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((bulk_5 next-pos_39)" +"(decode" +" vec_50" +" next-pos_38" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-bulk-binding-at scopes_22 bulk_5) next-pos_39))))" +"(let-values()" +"(let-values(((kind_7 next-pos_40)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_49 next-pos_41)" +"(decode" +" vec_50" +" next-pos_40" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-representative-scope kind_7 phase_49) next-pos_41))))))" +"(if(unsafe-fx< index_0 26)" +"(if(unsafe-fx< index_0 25)" +"(let-values()" +"(let-values(((module_4 next-pos_42)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((sym_32 next-pos_43)" +"(decode" +" vec_50" +" next-pos_42" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_50 next-pos_44)" +"(decode" +" vec_50" +" next-pos_43" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-module_4 next-pos_45)" +"(decode" +" vec_50" +" next-pos_44" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-phase_3 next-pos_46)" +"(decode" +" vec_50" +" next-pos_45" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-sym_3 next-pos_47)" +"(decode" +" vec_50" +" next-pos_46" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-require-phase_3 next-pos_48)" +"(decode" +" vec_50" +" next-pos_47" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((free=id_8 next-pos_49)" +"(decode" +" vec_50" +" next-pos_48" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((extra-inspector_3 next-pos_50)" +"(decode" +" vec_50" +" next-pos_49" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((extra-nominal-bindings_3 next-pos_51)" +"(decode" +" vec_50" +" next-pos_50" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-full-module-binding" +" module_4" +" sym_32" +" phase_50" +" nominal-module_4" +" nominal-phase_3" +" nominal-sym_3" +" nominal-require-phase_3" +" free=id_8" +" extra-inspector_3" +" extra-nominal-bindings_3)" +" next-pos_51))))))))))))" +"(let-values()" +"(let-values(((module_5 next-pos_52)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((sym_33 next-pos_53)" +"(decode" +" vec_50" +" next-pos_52" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_51 next-pos_54)" +"(decode" +" vec_50" +" next-pos_53" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-module_5 next-pos_55)" +"(decode" +" vec_50" +" next-pos_54" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-simple-module-binding module_5 sym_33 phase_51 nominal-module_5)" +" next-pos_55)))))))" +"(if(unsafe-fx< index_0 27)" +"(let-values()" +"(let-values(((key_51 next-pos_56)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((free=id_9 next-pos_57)" +"(decode" +" vec_50" +" next-pos_56" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-full-local-binding key_51 free=id_9) next-pos_57))))" +"(if(unsafe-fx< index_0 28)" +"(let-values()" +"(let-values(((prefix_3 next-pos_58)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((excepts_3 next-pos_59)" +"(decode" +" vec_50" +" next-pos_58" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((mpi_28 next-pos_60)" +"(decode" +" vec_50" +" next-pos_59" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((provide-phase-level_2 next-pos_61)" +"(decode" +" vec_50" +" next-pos_60" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase-shift_5 next-pos_62)" +"(decode" +" vec_50" +" next-pos_61" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((bulk-binding-registry_8 next-pos_63)" +"(decode" +" vec_50" +" next-pos_62" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-bulk-binding" +" prefix_3" +" excepts_3" +" mpi_28" +" provide-phase-level_2" +" phase-shift_5" +" bulk-binding-registry_8)" +" next-pos_63))))))))" +"(let-values()" +"(let-values(((binding_10 next-pos_64)" +"(decode" +" vec_50" +"(add1 pos_51)" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((protected?_2 next-pos_65)" +"(decode" +" vec_50" +" next-pos_64" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((syntax?_3 next-pos_66)" +"(decode" +" vec_50" +" next-pos_65" +" mpis_9" +" inspector_8" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-provided binding_10 protected?_2 syntax?_3)" +" next-pos_66)))))))))))))))))" +"(define-values" +"(decode-fill!)" +"(lambda(v_159 vec_51 pos_72 mpis_10 inspector_9 bulk-binding-registry_9 shared_3)" +"(begin" +"(let-values(((tmp_23)(vector*-ref vec_51 pos_72)))" +"(if(equal? tmp_23 #f)" +"(let-values()(add1 pos_72))" +"(if(equal? tmp_23 '#:set-box!)" +"(let-values()" +"(let-values(((c_21 next-pos_67)" +"(decode vec_51(add1 pos_72) mpis_10 inspector_9 bulk-binding-registry_9 shared_3)))" +"(begin(set-box! v_159 c_21) next-pos_67)))" +"(if(equal? tmp_23 '#:set-vector!)" +"(let-values()" +"(let-values(((len_24)(vector*-ref vec_51(add1 pos_72))))" +"(let-values(((start_31) 0)((end_23) len_24)((inc_17) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_31 end_23 inc_17)))" +"((letrec-values(((for-loop_150)" +"(lambda(pos_73 pos_74)" +"(begin" +" 'for-loop" +"(if(< pos_74 end_23)" +"(let-values(((i_78) pos_74))" +"(let-values(((pos_75)" +"(let-values(((pos_76) pos_73))" +"(let-values(((pos_77)" +"(let-values()" +"(let-values(((c_22 next-pos_68)" +"(decode" +" vec_51" +" pos_76" +" mpis_10" +" inspector_9" +" bulk-binding-registry_9" +" shared_3)))" +"(begin" +"(vector-set! v_159 i_78 c_22)" +" next-pos_68)))))" +"(values pos_77)))))" +"(if(not #f)(for-loop_150 pos_75(+ pos_74 inc_17)) pos_75)))" +" pos_73)))))" +" for-loop_150)" +"(+ pos_72 2)" +" start_31)))))" +"(if(equal? tmp_23 '#:set-hash!)" +"(let-values()" +"(let-values(((len_25)(vector*-ref vec_51(add1 pos_72))))" +"(let-values(((start_32) 0)((end_24) len_25)((inc_18) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_32 end_24 inc_18)))" +"((letrec-values(((for-loop_151)" +"(lambda(pos_78 pos_79)" +"(begin" +" 'for-loop" +"(if(< pos_79 end_24)" +"(let-values()" +"(let-values(((pos_80)" +"(let-values(((pos_81) pos_78))" +"(let-values(((pos_82)" +"(let-values()" +"(let-values(((key_52 next-pos_69)" +"(decode" +" vec_51" +" pos_81" +" mpis_10" +" inspector_9" +" bulk-binding-registry_9" +" shared_3)))" +"(let-values(((val_44 done-pos_2)" +"(decode" +" vec_51" +" next-pos_69" +" mpis_10" +" inspector_9" +" bulk-binding-registry_9" +" shared_3)))" +"(begin" +"(hash-set! v_159 key_52 val_44)" +" done-pos_2))))))" +"(values pos_82)))))" +"(if(not #f)(for-loop_151 pos_80(+ pos_79 inc_18)) pos_80)))" +" pos_78)))))" +" for-loop_151)" +"(+ pos_72 2)" +" start_32)))))" +"(if(equal? tmp_23 '#:scope-fill!)" +"(let-values()" +"(let-values(((c_23 next-pos_70)" +"(decode vec_51(add1 pos_72) mpis_10 inspector_9 bulk-binding-registry_9 shared_3)))" +"(begin(deserialize-scope-fill! v_159 c_23) next-pos_70)))" +"(if(equal? tmp_23 '#:representative-scope-fill!)" +"(let-values()" +"(let-values(((a_43 next-pos_71)" +"(decode vec_51(add1 pos_72) mpis_10 inspector_9 bulk-binding-registry_9 shared_3)))" +"(let-values(((d_25 done-pos_3)" +"(decode vec_51 next-pos_71 mpis_10 inspector_9 bulk-binding-registry_9 shared_3)))" +"(begin(deserialize-representative-scope-fill! v_159 a_43 d_25) done-pos_3))))" +" (let-values () (error 'deserialize \"bad fill encoding: ~v\" (vector*-ref vec_51 pos_72)))))))))))))" +"(define-values" +"(find-reachable-scopes)" +"(lambda(v_160)" +"(begin" +"(let-values(((seen_22)(make-hasheq)))" +"(let-values(((reachable-scopes_5)(seteq)))" +"(let-values(((get-reachable-scopes_4)(lambda()(begin 'get-reachable-scopes reachable-scopes_5))))" +"(let-values(((scope-triggers_0)(make-hasheq)))" +"(begin" +"((letrec-values(((loop_86)" +"(lambda(v_161)" +"(begin" +" 'loop" +"(if(interned-literal? v_161)" +"(let-values()(void))" +"(if(hash-ref seen_22 v_161 #f)" +"(let-values()(void))" +"(let-values()" +"(begin" +"(hash-set! seen_22 v_161 #t)" +"(if(scope-with-bindings? v_161)" +"(let-values()" +"(begin" +"(set! reachable-scopes_5(set-add reachable-scopes_5 v_161))" +"((reach-scopes-ref v_161) v_161 loop_86)" +"(let-values(((lst_68)(hash-ref scope-triggers_0 v_161 null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_68)))" +"((letrec-values(((for-loop_152)" +"(lambda(lst_121)" +"(begin" +" 'for-loop" +"(if(pair? lst_121)" +"(let-values(((proc_7)" +"(unsafe-car lst_121))" +"((rest_61)" +"(unsafe-cdr lst_121)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(proc_7" +" loop_86))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_152 rest_61)" +"(values))))" +"(values))))))" +" for-loop_152)" +" lst_68)))" +"(void)" +"(hash-remove! scope-triggers_0 v_161)" +"((scope-with-bindings-ref v_161)" +" v_161" +" get-reachable-scopes_4" +" loop_86" +"(lambda(sc-unreachable_0 b_68)" +"(hash-update!" +" scope-triggers_0" +" sc-unreachable_0" +"(lambda(l_51)(cons b_68 l_51))" +" null)))))" +"(if(reach-scopes? v_161)" +"(let-values()((reach-scopes-ref v_161) v_161 loop_86))" +"(if(pair? v_161)" +"(let-values()(begin(loop_86(car v_161))(loop_86(cdr v_161))))" +"(if(vector? v_161)" +"(let-values()" +"(begin" +"(let-values(((vec_52 len_26)" +"(let-values(((vec_53) v_161))" +"(begin" +"(check-vector vec_53)" +"(values" +" vec_53" +"(unsafe-vector-length vec_53))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_153)" +"(lambda(pos_83)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_83 len_26)" +"(let-values(((e_23)" +"(unsafe-vector-ref" +" vec_52" +" pos_83)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_86" +" e_23))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_153" +"(unsafe-fx+ 1 pos_83))" +"(values))))" +"(values))))))" +" for-loop_153)" +" 0)))" +"(void)))" +"(if(box? v_161)" +"(let-values()(loop_86(unbox v_161)))" +"(if(hash? v_161)" +"(let-values()" +"(begin" +"(let-values(((ht_97) v_161))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_97)))" +"((letrec-values(((for-loop_154)" +"(lambda(i_125)" +"(begin" +" 'for-loop" +"(if i_125" +"(let-values(((k_30 v_162)" +"(hash-iterate-key+value" +" ht_97" +" i_125)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(loop_86" +" k_30)" +"(loop_86" +" v_162)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_154" +"(hash-iterate-next" +" ht_97" +" i_125))" +"(values))))" +"(values))))))" +" for-loop_154)" +"(hash-iterate-first ht_97))))" +"(void)))" +"(if(prefab-struct-key v_161)" +"(let-values()" +"(begin" +"(let-values(((v*_5 start*_4 stop*_5 step*_4)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_52)(vector? x_52))" +"(lambda(x_53)" +"(unsafe-vector-length x_53))" +"(struct->vector v_161)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_155)" +"(lambda(idx_4)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_4 stop*_5)" +"(let-values(((e_24)" +"(unsafe-vector-ref" +" v*_5" +" idx_4)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_86" +" e_24))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_155" +"(unsafe-fx+ idx_4 1))" +"(values))))" +"(values))))))" +" for-loop_155)" +" start*_4)))" +"(void)))" +"(if(srcloc? v_161)" +"(let-values()(loop_86(srcloc-source v_161)))" +"(let-values()(void))))))))))))))))))" +" loop_86)" +" v_160)" +" reachable-scopes_5))))))))" +"(define-values" +"(deserialize-imports)" +" '(deserialize-module-path-indexes syntax-module-path-index-shift syntax-shift-phase-level module-use deserialize))" +"(define-values" +"(syntax-module-path-index-shift/no-keywords)" +"(let-values(((syntax-module-path-index-shift_0)" +"(let-values(((core26_0)" +"(lambda(s23_0 from-mpi24_0 to-mpi25_0 inspector22_0)" +"(begin" +" 'core26" +"(let-values(((s_197) s23_0))" +"(let-values(((from-mpi_4) from-mpi24_0))" +"(let-values(((to-mpi_3) to-mpi25_0))" +"(let-values(((inspector_10) inspector22_0))" +"(let-values()" +"(let-values(((s28_0) s_197)" +"((from-mpi29_0) from-mpi_4)" +"((to-mpi30_0) to-mpi_3)" +"((inspector31_0) inspector_10))" +"(syntax-module-path-index-shift13.1" +" #f" +" s28_0" +" from-mpi29_0" +" to-mpi30_0" +" inspector31_0)))))))))))" +"(case-lambda" +"((s_198 from-mpi_5 to-mpi_4)" +"(begin 'syntax-module-path-index-shift(core26_0 s_198 from-mpi_5 to-mpi_4 #f)))" +"((s_199 from-mpi_6 to-mpi_5 inspector22_1)(core26_0 s_199 from-mpi_6 to-mpi_5 inspector22_1))))))" +" syntax-module-path-index-shift_0))" +"(define-values" +"(deserialize-instance)" +"(1/make-instance" +" 'deserialize" +" #f" +" 'constant" +" 'deserialize-module-path-indexes" +" deserialize-module-path-indexes" +" 'syntax-module-path-index-shift" +" syntax-module-path-index-shift/no-keywords" +" 'syntax-shift-phase-level" +" syntax-shift-phase-level$1" +" 'module-use" +" module-use1.1" +" 'deserialize" +" deserialize))" +"(define-values" +"(struct:parsed parsed1.1 parsed? parsed-s)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'parsed #f 1 0 #f(list(cons prop:authentic #t)) #f #f '(0) #f 'parsed)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 's))))" +"(define-values" +"(struct:parsed-id parsed-id2.1 parsed-id? parsed-id-binding parsed-id-inspector)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-id" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-id)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'binding)" +"(make-struct-field-accessor -ref_1 1 'inspector))))" +"(define-values" +"(struct:parsed-primitive-id parsed-primitive-id3.1 parsed-primitive-id?)" +"(let-values(((struct:_43 make-_43 ?_43 -ref_43 -set!_43)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-primitive-id" +" struct:parsed-id" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-primitive-id)))))" +"(values struct:_43 make-_43 ?_43)))" +"(define-values" +"(struct:parsed-top-id parsed-top-id4.1 parsed-top-id?)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-top-id" +" struct:parsed-id" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-top-id)))))" +"(values struct:_10 make-_10 ?_10)))" +"(define-values" +"(struct:parsed-lambda parsed-lambda5.1 parsed-lambda? parsed-lambda-keys parsed-lambda-body)" +"(let-values(((struct:_42 make-_42 ?_42 -ref_42 -set!_42)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-lambda" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-lambda)))))" +"(values" +" struct:_42" +" make-_42" +" ?_42" +"(make-struct-field-accessor -ref_42 0 'keys)" +"(make-struct-field-accessor -ref_42 1 'body))))" +"(define-values" +"(struct:parsed-case-lambda parsed-case-lambda6.1 parsed-case-lambda? parsed-case-lambda-clauses)" +"(let-values(((struct:_44 make-_44 ?_44 -ref_44 -set!_44)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-case-lambda" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-case-lambda)))))" +"(values struct:_44 make-_44 ?_44(make-struct-field-accessor -ref_44 0 'clauses))))" +"(define-values" +"(struct:parsed-app parsed-app7.1 parsed-app? parsed-app-rator parsed-app-rands)" +"(let-values(((struct:_45 make-_45 ?_45 -ref_45 -set!_45)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-app" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-app)))))" +"(values" +" struct:_45" +" make-_45" +" ?_45" +"(make-struct-field-accessor -ref_45 0 'rator)" +"(make-struct-field-accessor -ref_45 1 'rands))))" +"(define-values" +"(struct:parsed-if parsed-if8.1 parsed-if? parsed-if-tst parsed-if-thn parsed-if-els)" +"(let-values(((struct:_46 make-_46 ?_46 -ref_46 -set!_46)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-if" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-if)))))" +"(values" +" struct:_46" +" make-_46" +" ?_46" +"(make-struct-field-accessor -ref_46 0 'tst)" +"(make-struct-field-accessor -ref_46 1 'thn)" +"(make-struct-field-accessor -ref_46 2 'els))))" +"(define-values" +"(struct:parsed-set! parsed-set!9.1 parsed-set!? parsed-set!-id parsed-set!-rhs)" +"(let-values(((struct:_47 make-_47 ?_47 -ref_47 -set!_47)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-set!" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-set!)))))" +"(values" +" struct:_47" +" make-_47" +" ?_47" +"(make-struct-field-accessor -ref_47 0 'id)" +"(make-struct-field-accessor -ref_47 1 'rhs))))" +"(define-values" +"(struct:parsed-with-continuation-mark" +" parsed-with-continuation-mark10.1" +" parsed-with-continuation-mark?" +" parsed-with-continuation-mark-key" +" parsed-with-continuation-mark-val" +" parsed-with-continuation-mark-body)" +"(let-values(((struct:_48 make-_48 ?_48 -ref_48 -set!_48)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-with-continuation-mark" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-with-continuation-mark)))))" +"(values" +" struct:_48" +" make-_48" +" ?_48" +"(make-struct-field-accessor -ref_48 0 'key)" +"(make-struct-field-accessor -ref_48 1 'val)" +"(make-struct-field-accessor -ref_48 2 'body))))" +"(define-values" +"(struct:parsed-#%variable-reference" +" parsed-#%variable-reference11.1" +" parsed-#%variable-reference?" +" parsed-#%variable-reference-id)" +"(let-values(((struct:_49 make-_49 ?_49 -ref_49 -set!_49)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%variable-reference" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-#%variable-reference)))))" +"(values struct:_49 make-_49 ?_49(make-struct-field-accessor -ref_49 0 'id))))" +"(define-values" +"(struct:parsed-begin parsed-begin12.1 parsed-begin? parsed-begin-body)" +"(let-values(((struct:_50 make-_50 ?_50 -ref_50 -set!_50)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin)))))" +"(values struct:_50 make-_50 ?_50(make-struct-field-accessor -ref_50 0 'body))))" +"(define-values" +"(struct:parsed-begin0 parsed-begin013.1 parsed-begin0? parsed-begin0-body)" +"(let-values(((struct:_51 make-_51 ?_51 -ref_51 -set!_51)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin0" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin0)))))" +"(values struct:_51 make-_51 ?_51(make-struct-field-accessor -ref_51 0 'body))))" +"(define-values" +"(struct:parsed-quote parsed-quote14.1 parsed-quote? parsed-quote-datum)" +"(let-values(((struct:_52 make-_52 ?_52 -ref_52 -set!_52)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-quote" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-quote)))))" +"(values struct:_52 make-_52 ?_52(make-struct-field-accessor -ref_52 0 'datum))))" +"(define-values" +"(struct:parsed-quote-syntax parsed-quote-syntax15.1 parsed-quote-syntax? parsed-quote-syntax-datum)" +"(let-values(((struct:_53 make-_53 ?_53 -ref_53 -set!_53)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-quote-syntax" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-quote-syntax)))))" +"(values struct:_53 make-_53 ?_53(make-struct-field-accessor -ref_53 0 'datum))))" +"(define-values" +"(struct:parsed-let_-values" +" parsed-let_-values16.1" +" parsed-let_-values?" +" parsed-let_-values-idss" +" parsed-let_-values-clauses" +" parsed-let_-values-body)" +"(let-values(((struct:_54 make-_54 ?_54 -ref_54 -set!_54)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-let_-values" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-let_-values)))))" +"(values" +" struct:_54" +" make-_54" +" ?_54" +"(make-struct-field-accessor -ref_54 0 'idss)" +"(make-struct-field-accessor -ref_54 1 'clauses)" +"(make-struct-field-accessor -ref_54 2 'body))))" +"(define-values" +"(struct:parsed-let-values parsed-let-values17.1 parsed-let-values?)" +"(let-values(((struct:_55 make-_55 ?_55 -ref_55 -set!_55)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-let-values" +" struct:parsed-let_-values" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-let-values)))))" +"(values struct:_55 make-_55 ?_55)))" +"(define-values" +"(struct:parsed-letrec-values parsed-letrec-values18.1 parsed-letrec-values?)" +"(let-values(((struct:_56 make-_56 ?_56 -ref_56 -set!_56)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-letrec-values" +" struct:parsed-let_-values" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-letrec-values)))))" +"(values struct:_56 make-_56 ?_56)))" +"(define-values" +"(struct:parsed-define-values" +" parsed-define-values19.1" +" parsed-define-values?" +" parsed-define-values-ids" +" parsed-define-values-syms" +" parsed-define-values-rhs)" +"(let-values(((struct:_57 make-_57 ?_57 -ref_57 -set!_57)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-define-values" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-define-values)))))" +"(values" +" struct:_57" +" make-_57" +" ?_57" +"(make-struct-field-accessor -ref_57 0 'ids)" +"(make-struct-field-accessor -ref_57 1 'syms)" +"(make-struct-field-accessor -ref_57 2 'rhs))))" +"(define-values" +"(struct:parsed-define-syntaxes" +" parsed-define-syntaxes20.1" +" parsed-define-syntaxes?" +" parsed-define-syntaxes-ids" +" parsed-define-syntaxes-syms" +" parsed-define-syntaxes-rhs)" +"(let-values(((struct:_58 make-_58 ?_58 -ref_58 -set!_58)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-define-syntaxes" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-define-syntaxes)))))" +"(values" +" struct:_58" +" make-_58" +" ?_58" +"(make-struct-field-accessor -ref_58 0 'ids)" +"(make-struct-field-accessor -ref_58 1 'syms)" +"(make-struct-field-accessor -ref_58 2 'rhs))))" +"(define-values" +"(struct:parsed-begin-for-syntax parsed-begin-for-syntax21.1 parsed-begin-for-syntax? parsed-begin-for-syntax-body)" +"(let-values(((struct:_59 make-_59 ?_59 -ref_59 -set!_59)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin-for-syntax" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin-for-syntax)))))" +"(values struct:_59 make-_59 ?_59(make-struct-field-accessor -ref_59 0 'body))))" +"(define-values" +"(struct:parsed-#%declare parsed-#%declare22.1 parsed-#%declare?)" +"(let-values(((struct:_60 make-_60 ?_60 -ref_60 -set!_60)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%declare" +" struct:parsed" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-#%declare)))))" +"(values struct:_60 make-_60 ?_60)))" +"(define-values" +"(struct:parsed-require parsed-require23.1 parsed-require?)" +"(let-values(((struct:_61 make-_61 ?_61 -ref_61 -set!_61)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-require" +" struct:parsed" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-require)))))" +"(values struct:_61 make-_61 ?_61)))" +"(define-values" +"(struct:parsed-#%module-begin parsed-#%module-begin24.1 parsed-#%module-begin? parsed-#%module-begin-body)" +"(let-values(((struct:_62 make-_62 ?_62 -ref_62 -set!_62)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%module-begin" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-#%module-begin)))))" +"(values struct:_62 make-_62 ?_62(make-struct-field-accessor -ref_62 0 'body))))" +"(define-values" +"(struct:parsed-module" +" parsed-module25.1" +" parsed-module?" +" parsed-module-star?" +" parsed-module-name-id" +" parsed-module-self" +" parsed-module-requires" +" parsed-module-provides" +" parsed-module-root-ctx-simple?" +" parsed-module-encoded-root-ctx" +" parsed-module-body" +" parsed-module-compiled-module" +" parsed-module-compiled-submodules)" +"(let-values(((struct:_63 make-_63 ?_63 -ref_63 -set!_63)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-module" +" struct:parsed" +" 10" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9)" +" #f" +" 'parsed-module)))))" +"(values" +" struct:_63" +" make-_63" +" ?_63" +"(make-struct-field-accessor -ref_63 0 'star?)" +"(make-struct-field-accessor -ref_63 1 'name-id)" +"(make-struct-field-accessor -ref_63 2 'self)" +"(make-struct-field-accessor -ref_63 3 'requires)" +"(make-struct-field-accessor -ref_63 4 'provides)" +"(make-struct-field-accessor -ref_63 5 'root-ctx-simple?)" +"(make-struct-field-accessor -ref_63 6 'encoded-root-ctx)" +"(make-struct-field-accessor -ref_63 7 'body)" +"(make-struct-field-accessor -ref_63 8 'compiled-module)" +"(make-struct-field-accessor -ref_63 9 'compiled-submodules))))" +"(define-values" +"(module-path->mpi5.1)" +"(lambda(declared-submodule-names1_0 mod-path3_0 self4_2)" +"(begin" +" 'module-path->mpi5" +"(let-values(((mod-path_4) mod-path3_0))" +"(let-values(((self_7) self4_2))" +"(let-values(((declared-submodule-names_1)" +"(if(eq? declared-submodule-names1_0 unsafe-undefined) '#hasheq() declared-submodule-names1_0)))" +"(let-values()" +"(if(if(list? mod-path_4)" +"(if(= 2(length mod-path_4))" +"(if(eq? 'quote(car mod-path_4))" +"(if(symbol?(cadr mod-path_4))(hash-ref declared-submodule-names_1(cadr mod-path_4) #f) #f)" +" #f)" +" #f)" +" #f)" +" (let-values () (1/module-path-index-join (list 'submod \".\" (cadr mod-path_4)) self_7))" +"(if(if(list? mod-path_4)" +"(if(eq? 'submod(car mod-path_4))" +"(let-values(((mod-path_5)(cadr mod-path_4)))" +"(if(list? mod-path_5)" +"(if(= 2(length mod-path_5))" +"(if(eq? 'quote(car mod-path_5))" +"(if(symbol?(cadr mod-path_5))" +"(hash-ref declared-submodule-names_1(cadr mod-path_5) #f)" +" #f)" +" #f)" +" #f)" +" #f))" +" #f)" +" #f)" +"(let-values()" +" (1/module-path-index-join (list* 'submod \".\" (cadr (cadr mod-path_4)) (cddr mod-path_4)) self_7))" +"(let-values()(1/module-path-index-join mod-path_4 self_7)))))))))))" +"(define-values" +"(module-path->mpi/context)" +"(lambda(mod-path_6 ctx_9)" +"(begin" +"(let-values(((mod-path8_1) mod-path_6)" +"((temp9_0)(namespace-mpi(expand-context-namespace ctx_9)))" +"((temp10_2)(expand-context-declared-submodule-names ctx_9)))" +"(module-path->mpi5.1 temp10_2 mod-path8_1 temp9_0)))))" +"(define-values" +"(syntax-mapped-names)" +"(lambda(s_0 phase_44)" +"(begin" +"(let-values(((s-scs_1)(syntax-scope-set s_0 phase_44)))" +"(let-values(((ht_98) s-scs_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_98)))" +"((letrec-values(((for-loop_117)" +"(lambda(syms_14 i_126)" +"(begin" +" 'for-loop" +"(if i_126" +"(let-values(((sc_31)(unsafe-immutable-hash-iterate-key ht_98 i_126)))" +"(let-values(((syms_15)" +"(let-values(((syms_16) syms_14))" +"(let-values(((syms_17)" +"(let-values()" +"(set-union" +" syms_16" +"(binding-table-symbols" +"(scope-binding-table sc_31)" +" s-scs_1" +" s_0" +" null)))))" +"(values syms_17)))))" +"(if(not #f)" +"(for-loop_117 syms_15(unsafe-immutable-hash-iterate-next ht_98 i_126))" +" syms_15)))" +" syms_14)))))" +" for-loop_117)" +"(seteq)" +"(unsafe-immutable-hash-iterate-first ht_98))))))))" +"(define-values" +"(struct:requires+provides" +" requires+provides1.1" +" requires+provides?" +" requires+provides-self" +" requires+provides-require-mpis" +" requires+provides-require-mpis-in-order" +" requires+provides-requires" +" requires+provides-provides" +" requires+provides-phase-to-defined-syms" +" requires+provides-also-required" +" requires+provides-can-cross-phase-persistent?" +" requires+provides-all-bindings-simple?" +" set-requires+provides-can-cross-phase-persistent?!" +" set-requires+provides-all-bindings-simple?!)" +"(let-values(((struct:_64 make-_64 ?_64 -ref_64 -set!_64)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'requires+provides" +" #f" +" 9" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'requires+provides)))))" +"(values" +" struct:_64" +" make-_64" +" ?_64" +"(make-struct-field-accessor -ref_64 0 'self)" +"(make-struct-field-accessor -ref_64 1 'require-mpis)" +"(make-struct-field-accessor -ref_64 2 'require-mpis-in-order)" +"(make-struct-field-accessor -ref_64 3 'requires)" +"(make-struct-field-accessor -ref_64 4 'provides)" +"(make-struct-field-accessor -ref_64 5 'phase-to-defined-syms)" +"(make-struct-field-accessor -ref_64 6 'also-required)" +"(make-struct-field-accessor -ref_64 7 'can-cross-phase-persistent?)" +"(make-struct-field-accessor -ref_64 8 'all-bindings-simple?)" +"(make-struct-field-mutator -set!_64 7 'can-cross-phase-persistent?)" +"(make-struct-field-mutator -set!_64 8 'all-bindings-simple?))))" +"(define-values" +"(struct:required required2.1 required? required-id required-phase required-can-be-shadowed? required-as-transformer?)" +"(let-values(((struct:_11 make-_11 ?_11 -ref_11 -set!_11)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'required" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'required)))))" +"(values" +" struct:_11" +" make-_11" +" ?_11" +"(make-struct-field-accessor -ref_11 0 'id)" +"(make-struct-field-accessor -ref_11 1 'phase)" +"(make-struct-field-accessor -ref_11 2 'can-be-shadowed?)" +"(make-struct-field-accessor -ref_11 3 'as-transformer?))))" +"(define-values" +"(struct:nominal nominal3.1 nominal? nominal-module nominal-provide-phase nominal-require-phase nominal-sym)" +"(let-values(((struct:_65 make-_65 ?_65 -ref_65 -set!_65)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'nominal" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '(0 1 2 3)" +" #f" +" 'nominal)))))" +"(values" +" struct:_65" +" make-_65" +" ?_65" +"(make-struct-field-accessor -ref_65 0 'module)" +"(make-struct-field-accessor -ref_65 1 'provide-phase)" +"(make-struct-field-accessor -ref_65 2 'require-phase)" +"(make-struct-field-accessor -ref_65 3 'sym))))" +"(define-values" +"(struct:bulk-required" +" bulk-required4.1" +" bulk-required?" +" bulk-required-provides" +" bulk-required-prefix-len" +" bulk-required-s" +" bulk-required-provide-phase-level" +" bulk-required-can-be-shadowed?)" +"(let-values(((struct:_66 make-_66 ?_66 -ref_66 -set!_66)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-required" +" #f" +" 5" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4)" +" #f" +" 'bulk-required)))))" +"(values" +" struct:_66" +" make-_66" +" ?_66" +"(make-struct-field-accessor -ref_66 0 'provides)" +"(make-struct-field-accessor -ref_66 1 'prefix-len)" +"(make-struct-field-accessor -ref_66 2 's)" +"(make-struct-field-accessor -ref_66 3 'provide-phase-level)" +"(make-struct-field-accessor -ref_66 4 'can-be-shadowed?))))" +"(define-values" +"(make-requires+provides8.1)" +"(lambda(copy-requires5_0 self7_0)" +"(begin" +" 'make-requires+provides8" +"(let-values(((self_2) self7_0))" +"(let-values(((copy-r+p_0) copy-requires5_0))" +"(let-values()" +"(requires+provides1.1" +" self_2" +"(if copy-r+p_0(requires+provides-require-mpis copy-r+p_0)(make-module-path-index-intern-table))" +"(if copy-r+p_0(hash-copy(requires+provides-require-mpis-in-order copy-r+p_0))(make-hasheqv))" +"(make-hasheq)" +"(make-hasheqv)" +"(make-hasheqv)" +"(make-hasheq)" +" #t" +" #t)))))))" +"(define-values" +"(requires+provides-reset!)" +"(lambda(r+p_0)" +"(begin" +"(begin" +"(hash-clear!(requires+provides-requires r+p_0))" +"(hash-clear!(requires+provides-provides r+p_0))" +"(hash-clear!(requires+provides-phase-to-defined-syms r+p_0))" +"(hash-clear!(requires+provides-also-required r+p_0))))))" +"(define-values" +"(intern-mpi)" +"(lambda(r+p_1 mpi_29)(begin(intern-module-path-index!(requires+provides-require-mpis r+p_1) mpi_29))))" +"(define-values" +"(add-required-module!)" +"(lambda(r+p_2 mod-name_8 phase-shift_2 is-cross-phase-persistent?_0)" +"(begin" +"(let-values(((mpi_30)(intern-mpi r+p_2 mod-name_8)))" +"(begin" +"(if(hash-ref(hash-ref(requires+provides-requires r+p_2) mpi_30 '#hasheqv()) phase-shift_2 #f)" +"(void)" +"(let-values()" +"(begin" +"(hash-update!" +"(requires+provides-require-mpis-in-order r+p_2)" +" phase-shift_2" +"(lambda(l_52)(cons mpi_30 l_52))" +" null)" +"(hash-set!" +"(hash-ref!(requires+provides-requires r+p_2) mpi_30 make-hasheqv)" +" phase-shift_2" +"(make-hasheq)))))" +"(if is-cross-phase-persistent?_0" +"(void)" +"(let-values()(set-requires+provides-can-cross-phase-persistent?! r+p_2 #f)))" +" mpi_30)))))" +"(define-values" +"(add-defined-or-required-id!19.1)" +"(lambda(as-transformer?12_0 can-be-shadowed?11_0 r+p15_0 id16_0 phase17_0 binding18_0)" +"(begin" +" 'add-defined-or-required-id!19" +"(let-values(((r+p_3) r+p15_0))" +"(let-values(((id_24) id16_0))" +"(let-values(((phase_52) phase17_0))" +"(let-values(((binding_11) binding18_0))" +"(let-values(((can-be-shadowed?_0) can-be-shadowed?11_0))" +"(let-values(((as-transformer?_0) as-transformer?12_0))" +"(let-values()" +"(begin" +"(if(equal?" +" phase_52" +"(phase+" +"(module-binding-nominal-phase binding_11)" +"(module-binding-nominal-require-phase binding_11)))" +"(void)" +" (let-values () (error \"internal error: binding phase does not match nominal info\")))" +"(let-values(((r+p124_0) r+p_3)" +"((id125_0) id_24)" +"((phase126_0) phase_52)" +"((temp127_0)(module-binding-nominal-module binding_11))" +"((temp128_0)(module-binding-nominal-require-phase binding_11))" +"((can-be-shadowed?129_0) can-be-shadowed?_0)" +"((as-transformer?130_0) as-transformer?_0))" +"(add-defined-or-required-id-at-nominal!33.1" +" as-transformer?130_0" +" can-be-shadowed?129_0" +" temp127_0" +" temp128_0" +" r+p124_0" +" id125_0" +" phase126_0)))))))))))))" +"(define-values" +"(add-defined-or-required-id-at-nominal!33.1)" +"(lambda(as-transformer?25_0" +" can-be-shadowed?24_0" +" nominal-module22_0" +" nominal-require-phase23_0" +" r+p30_0" +" id31_0" +" phase32_0)" +"(begin" +" 'add-defined-or-required-id-at-nominal!33" +"(let-values(((r+p_4) r+p30_0))" +"(let-values(((id_25) id31_0))" +"(let-values(((phase_53) phase32_0))" +"(let-values(((nominal-module_6) nominal-module22_0))" +"(let-values(((nominal-require-phase_4) nominal-require-phase23_0))" +"(let-values(((can-be-shadowed?_1) can-be-shadowed?24_0))" +"(let-values(((as-transformer?_1) as-transformer?25_0))" +"(let-values()" +"(let-values(((at-mod_0)" +"(hash-ref!" +"(requires+provides-requires r+p_4)" +"(intern-mpi r+p_4 nominal-module_6)" +" make-hasheqv)))" +"(let-values(((sym-to-reqds_0)(hash-ref! at-mod_0 nominal-require-phase_4 make-hasheq)))" +"(let-values(((sym_34)(syntax-e$1 id_25)))" +"(hash-set!" +" sym-to-reqds_0" +" sym_34" +"(cons-ish" +"(required2.1 id_25 phase_53 can-be-shadowed?_1 as-transformer?_1)" +"(hash-ref sym-to-reqds_0 sym_34 null)))))))))))))))))" +"(define-values" +"(add-bulk-required-ids!59.1)" +"(lambda(accum-update-nominals42_0" +" can-be-shadowed?40_0" +" check-and-remove?41_0" +" excepts37_0" +" in39_0" +" prefix36_0" +" symbols-accum38_0" +" who43_0" +" r+p52_0" +" s53_0" +" self54_0" +" nominal-module55_0" +" phase-shift56_0" +" provides57_0" +" provide-phase-level58_0)" +"(begin" +" 'add-bulk-required-ids!59" +"(let-values(((r+p_5) r+p52_0))" +"(let-values(((s_114) s53_0))" +"(let-values(((self_8) self54_0))" +"(let-values(((nominal-module_7) nominal-module55_0))" +"(let-values(((phase-shift_6) phase-shift56_0))" +"(let-values(((provides_4) provides57_0))" +"(let-values(((provide-phase-level_3) provide-phase-level58_0))" +"(let-values(((bulk-prefix_0) prefix36_0))" +"(let-values(((bulk-excepts_0) excepts37_0))" +"(let-values(((symbols-accum_0) symbols-accum38_0))" +"(let-values(((orig-s_0) in39_0))" +"(let-values(((can-be-shadowed?_2) can-be-shadowed?40_0))" +"(let-values(((check-and-remove?_0) check-and-remove?41_0))" +"(let-values(((accum-update-nominals_0) accum-update-nominals42_0))" +"(let-values(((who_11) who43_0))" +"(let-values()" +"(let-values(((phase_54)(phase+ provide-phase-level_3 phase-shift_6)))" +"(let-values(((shortcut-table_0)" +"(if check-and-remove?_0" +"(if(>(hash-count provides_4) 64)" +"(syntax-mapped-names s_114 phase_54)" +" #f)" +" #f)))" +"(let-values(((mpi_13)(intern-mpi r+p_5 nominal-module_7)))" +"(let-values(((at-mod_1)" +"(hash-ref!" +"(requires+provides-requires r+p_5)" +" mpi_13" +" make-hasheqv)))" +"(let-values(((sym-to-reqds_1)" +"(hash-ref! at-mod_1 phase-shift_6 make-hasheq)))" +"(let-values(((prefix-len_0)" +"(if bulk-prefix_0" +"(string-length(symbol->string bulk-prefix_0))" +" 0)))" +"(let-values(((br_0)" +"(bulk-required4.1" +" provides_4" +" prefix-len_0" +" s_114" +" provide-phase-level_3" +" can-be-shadowed?_2)))" +"(let-values(((ht_99) provides_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_99)))" +"((letrec-values(((for-loop_156)" +"(lambda(result_70 i_127)" +"(begin" +" 'for-loop" +"(if i_127" +"(let-values(((out-sym_0 binding/p_2)" +"(hash-iterate-key+value" +" ht_99" +" i_127)))" +"(let-values(((result_71)" +"(let-values(((result_72)" +" result_70))" +"(if(not" +"(symbol-interned?" +" out-sym_0))" +" result_72" +"(let-values()" +"(let-values(((result_73)" +"(let-values()" +"(let-values()" +"(begin" +"(if symbols-accum_0" +"(let-values()" +"(hash-set!" +" symbols-accum_0" +" out-sym_0" +" #t))" +"(void))" +"(if(hash-ref" +" bulk-excepts_0" +" out-sym_0" +" #f)" +"(let-values()" +" #f)" +"(let-values()" +"(let-values(((sym_35)" +"(if(not" +" bulk-prefix_0)" +"(let-values()" +" out-sym_0)" +"(let-values()" +"(string->symbol" +"(format" +" \"~a~a\"" +" bulk-prefix_0" +" out-sym_0))))))" +"(let-values(((already-defined?_0)" +"(if(if check-and-remove?_0" +"(let-values(((or-part_175)" +"(not" +" shortcut-table_0)))" +"(if or-part_175" +" or-part_175" +"(hash-ref" +" shortcut-table_0" +" sym_35" +" #f)))" +" #f)" +"(let-values()" +"(let-values(((temp131_0)" +" #t)" +"((temp132_0)" +" #t)" +"((r+p133_0)" +" r+p_5)" +"((temp134_0)" +"(datum->syntax$1" +" s_114" +" sym_35" +" s_114))" +"((phase135_0)" +" phase_54)" +"((orig-s136_0)" +" orig-s_0)" +"((temp137_0)" +"(lambda()" +"(let-values(((binding/p141_0)" +" binding/p_2)" +"((sym142_0)" +" sym_35)" +"((self143_0)" +" self_8)" +"((mpi144_0)" +" mpi_13)" +"((provide-phase-level145_0)" +" provide-phase-level_3)" +"((phase-shift146_0)" +" phase-shift_6))" +"(provide-binding-to-require-binding11.1" +" mpi144_0" +" phase-shift146_0" +" provide-phase-level145_0" +" self143_0" +" binding/p141_0" +" sym142_0))))" +"((temp138_0)" +" #t)" +"((accum-update-nominals139_0)" +" accum-update-nominals_0)" +"((who140_0)" +" who_11))" +"(check-not-defined95.1" +" accum-update-nominals139_0" +" temp132_0" +" temp131_0" +" orig-s136_0" +" temp138_0" +" temp137_0" +" who140_0" +" r+p133_0" +" temp134_0" +" phase135_0)))" +"(let-values()" +" #f))))" +"(begin" +"(if already-defined?_0" +"(void)" +"(let-values()" +"(hash-set!" +" sym-to-reqds_1" +" sym_35" +"(cons-ish" +" br_0" +"(hash-ref" +" sym-to-reqds_1" +" sym_35" +" null)))))" +" already-defined?_0))))))))))" +"(values" +" result_73)))))))" +"(if(if(not" +"((lambda x_54 result_71)" +" out-sym_0" +" binding/p_2))" +"(not #f)" +" #f)" +"(for-loop_156" +" result_71" +"(hash-iterate-next ht_99 i_127))" +" result_71)))" +" result_70)))))" +" for-loop_156)" +" #f" +"(hash-iterate-first ht_99))))))))))))))))))))))))))))))" +"(define-values" +"(bulk-required->required)" +"(lambda(br_1 nominal-module_8 phase_55 sym_36)" +"(begin" +"(let-values(((prefix-len_1)(bulk-required-prefix-len br_1)))" +"(let-values(((out-sym_1)" +"(if(zero? prefix-len_1)" +" sym_36" +"(string->symbol(substring(symbol->string sym_36) prefix-len_1)))))" +"(let-values(((binding/p_3)(hash-ref(bulk-required-provides br_1) out-sym_1)))" +"(required2.1" +"(datum->syntax$1(bulk-required-s br_1) sym_36)" +"(phase+ phase_55(bulk-required-provide-phase-level br_1))" +"(bulk-required-can-be-shadowed? br_1)" +"(provided-as-transformer? binding/p_3))))))))" +"(define-values" +"(normalize-required)" +"(lambda(r_35 mod-name_9 phase_56 sym_37)" +"(begin(if(bulk-required? r_35)(bulk-required->required r_35 mod-name_9 phase_56 sym_37) r_35))))" +"(define-values" +"(add-enclosing-module-defined-and-required!67.1)" +"(lambda(enclosing-requires+provides62_0 r+p64_0 enclosing-mod65_0 phase-shift66_0)" +"(begin" +" 'add-enclosing-module-defined-and-required!67" +"(let-values(((r+p_6) r+p64_0))" +"(let-values(((enclosing-r+p_0) enclosing-requires+provides62_0))" +"(let-values(((enclosing-mod_0) enclosing-mod65_0))" +"(let-values(((phase-shift_7) phase-shift66_0))" +"(let-values()" +"(begin" +"(set-requires+provides-all-bindings-simple?! r+p_6 #f)" +"(let-values(((ht_100)(requires+provides-requires enclosing-r+p_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_100)))" +"((letrec-values(((for-loop_157)" +"(lambda(i_128)" +"(begin" +" 'for-loop" +"(if i_128" +"(let-values(((mod-name_10 at-mod_2)" +"(hash-iterate-key+value ht_100 i_128)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((ht_101) at-mod_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_101)))" +"((letrec-values(((for-loop_158)" +"(lambda(i_129)" +"(begin" +" 'for-loop" +"(if i_129" +"(let-values(((phase_57" +" at-phase_8)" +"(hash-iterate-key+value" +" ht_101" +" i_129)))" +"(let-values((()" +"(let-values(((ht_102)" +" at-phase_8))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_102)))" +"((letrec-values(((for-loop_159)" +"(lambda(i_117)" +"(begin" +" 'for-loop" +"(if i_117" +"(let-values(((sym_38" +" reqds_0)" +"(hash-iterate-key+value" +" ht_102" +" i_117)))" +"(let-values((()" +"(let-values(((lst_122)" +" reqds_0))" +"(begin" +"(void)" +"((letrec-values(((for-loop_160)" +"(lambda(lst_123)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" lst_123))" +"(let-values(((reqd/maybe-bulk_0)" +"(if(pair?" +" lst_123)" +"(car" +" lst_123)" +" lst_123))" +"((rest_62)" +"(if(pair?" +" lst_123)" +"(cdr" +" lst_123)" +" null)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((reqd_0)" +"(normalize-required" +" reqd/maybe-bulk_0" +" mod-name_10" +" phase_57" +" sym_38)))" +"(let-values(((r+p147_0)" +" r+p_6)" +"((temp148_0)" +"(syntax-shift-phase-level$1" +"(let-values(((temp154_0)" +"(required-id" +" reqd_0))" +"((temp155_0)" +"(requires+provides-self" +" enclosing-r+p_0))" +"((enclosing-mod156_0)" +" enclosing-mod_0))" +"(syntax-module-path-index-shift13.1" +" #f" +" temp154_0" +" temp155_0" +" enclosing-mod156_0" +" #f))" +" phase-shift_7))" +"((temp149_0)" +"(phase+" +"(required-phase" +" reqd_0)" +" phase-shift_7))" +"((enclosing-mod150_0)" +" enclosing-mod_0)" +"((phase-shift151_0)" +" phase-shift_7)" +"((temp152_0)" +" #t)" +"((temp153_0)" +"(required-as-transformer?" +" reqd_0)))" +"(add-defined-or-required-id-at-nominal!33.1" +" temp153_0" +" temp152_0" +" enclosing-mod150_0" +" phase-shift151_0" +" r+p147_0" +" temp148_0" +" temp149_0))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_160" +" rest_62)" +"(values))))" +"(values))))))" +" for-loop_160)" +" lst_122)))))" +"(if(not" +" #f)" +"(for-loop_159" +"(hash-iterate-next" +" ht_102" +" i_117))" +"(values))))" +"(values))))))" +" for-loop_159)" +"(hash-iterate-first" +" ht_102))))))" +"(if(not" +" #f)" +"(for-loop_158" +"(hash-iterate-next" +" ht_101" +" i_129))" +"(values))))" +"(values))))))" +" for-loop_158)" +"(hash-iterate-first" +" ht_101))))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_157(hash-iterate-next ht_100 i_128))" +"(values))))" +"(values))))))" +" for-loop_157)" +"(hash-iterate-first ht_100))))" +"(void))))))))))" +"(define-values" +"(remove-required-id!75.1)" +"(lambda(unless-matches70_0 r+p72_0 id73_0 phase74_0)" +"(begin" +" 'remove-required-id!75" +"(let-values(((r+p_7) r+p72_0))" +"(let-values(((id_26) id73_0))" +"(let-values(((phase_58) phase74_0))" +"(let-values(((binding_12) unless-matches70_0))" +"(let-values()" +"(let-values(((b_69)" +"(let-values(((id157_0) id_26)((phase158_0) phase_58)((temp159_0) #t))" +"(resolve+shift28.1 #f temp159_0 null unsafe-undefined #f id157_0 phase158_0))))" +"(if b_69" +"(let-values()" +"(let-values(((mpi_31)(intern-mpi r+p_7(module-binding-nominal-module b_69))))" +"(let-values(((at-mod_3)(hash-ref(requires+provides-requires r+p_7) mpi_31 #f)))" +"(if at-mod_3" +"(let-values()" +"(let-values(((nominal-phase_4)(module-binding-nominal-require-phase b_69)))" +"(let-values(((sym-to-reqds_2)(hash-ref at-mod_3 nominal-phase_4 #f)))" +"(if sym-to-reqds_2" +"(let-values()" +"(let-values(((sym_39)(syntax-e$1 id_26)))" +"(let-values(((l_53)(hash-ref sym-to-reqds_2 sym_39 null)))" +"(if(null? l_53)" +"(void)" +"(let-values()" +"(if(same-binding? b_69 binding_12)" +"(void)" +"(let-values()" +"(hash-set!" +" sym-to-reqds_2" +" sym_39" +"(remove-non-matching-requireds" +" l_53" +" id_26" +" phase_58" +" mpi_31" +" nominal-phase_4" +" sym_39)))))))))" +"(void)))))" +"(void)))))" +"(void)))))))))))" +"(define-values" +"(remove-non-matching-requireds)" +"(lambda(reqds_1 id_27 phase_59 mpi_32 nominal-phase_5 sym_40)" +"(begin" +"(reverse$1" +"(let-values(((lst_124) reqds_1))" +"(begin" +"(void)" +"((letrec-values(((for-loop_161)" +"(lambda(fold-var_109 lst_125)" +"(begin" +" 'for-loop" +"(if(not(null? lst_125))" +"(let-values(((r_36)(if(pair? lst_125)(car lst_125) lst_125))" +"((rest_63)(if(pair? lst_125)(cdr lst_125) null)))" +"(let-values(((fold-var_110)" +"(let-values(((r_37)" +"(normalize-required" +" r_36" +" mpi_32" +" nominal-phase_5" +" sym_40)))" +"(begin" +" #t" +"((letrec-values(((for-loop_162)" +"(lambda(fold-var_111)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_112)" +"(let-values(((fold-var_113)" +" fold-var_111))" +"(if(if(eqv?" +" phase_59" +"(required-phase" +" r_37))" +"(free-identifier=?$1" +"(required-id r_37)" +" id_27" +" phase_59" +" phase_59)" +" #f)" +" fold-var_113" +"(let-values(((fold-var_114)" +" fold-var_113))" +"(let-values(((fold-var_115)" +"(let-values()" +"(cons" +"(let-values()" +" r_37)" +" fold-var_114))))" +"(values" +" fold-var_115)))))))" +" fold-var_112))))))" +" for-loop_162)" +" fold-var_109)))))" +"(if(not #f)(for-loop_161 fold-var_110 rest_63) fold-var_110)))" +" fold-var_109)))))" +" for-loop_161)" +" null" +" lst_124)))))))" +"(define-values" +"(check-not-defined95.1)" +"(lambda(accum-update-nominals83_0" +" allow-defined?79_0" +" check-not-required?78_0" +" in80_0" +" remove-shadowed!?82_0" +" unless-matches81_0" +" who84_0" +" r+p92_0" +" id93_0" +" phase94_0)" +"(begin" +" 'check-not-defined95" +"(let-values(((check-not-required?_0) check-not-required?78_0))" +"(let-values(((allow-defined?_0) allow-defined?79_0))" +"(let-values(((r+p_8) r+p92_0))" +"(let-values(((id_28) id93_0))" +"(let-values(((phase_60) phase94_0))" +"(let-values(((orig-s_1) in80_0))" +"(let-values(((ok-binding/delayed_0) unless-matches81_0))" +"(let-values(((remove-shadowed!?_0) remove-shadowed!?82_0))" +"(let-values(((accum-update-nominals_1) accum-update-nominals83_0))" +"(let-values(((who_12) who84_0))" +"(let-values()" +"(let-values(((b_70)" +"(let-values(((id160_0) id_28)((phase161_0) phase_60)((temp162_0) #t))" +"(resolve+shift28.1" +" #f" +" temp162_0" +" null" +" unsafe-undefined" +" #f" +" id160_0" +" phase161_0))))" +"(if(not b_70)" +"(let-values() #f)" +"(if(not(module-binding? b_70))" +" (let-values () (raise-syntax-error$1 #f \"identifier out of context\" id_28))" +"(let-values()" +"(let-values(((defined?_0)" +"(if b_70" +"(eq?(requires+provides-self r+p_8)(module-binding-module b_70))" +" #f)))" +"(if(if defined?_0" +"(not" +"(hash-ref" +"(hash-ref" +"(requires+provides-phase-to-defined-syms r+p_8)" +" phase_60" +" '#hasheq())" +"(module-binding-sym b_70)" +" #f))" +" #f)" +"(let-values() #f)" +"(let-values()" +"(let-values(((define-shadowing-require?_0)" +"(if(not defined?_0)(not check-not-required?_0) #f)))" +"(let-values(((mpi_33)" +"(intern-mpi r+p_8(module-binding-nominal-module b_70))))" +"(let-values(((at-mod_4)" +"(hash-ref(requires+provides-requires r+p_8) mpi_33 #f)))" +"(let-values(((ok-binding_0)" +"(if(not define-shadowing-require?_0)" +"(if(procedure? ok-binding/delayed_0)" +"(ok-binding/delayed_0)" +" ok-binding/delayed_0)" +" #f)))" +"(let-values(((raise-already-bound_0)" +"(lambda(defined?_1)" +"(begin" +" 'raise-already-bound" +"(raise-syntax-error$1" +" who_12" +"(string-append" +" \"identifier already \"" +" (if defined?_1 \"defined\" \"required\")" +"(if(zero-phase? phase_60)" +" (let-values () \"\")" +"(if(label-phase? phase_60)" +" (let-values () \" for label\")" +"(if(= 1 phase_60)" +" (let-values () \" for syntax\")" +"(let-values()" +" (format \" for phase ~a\" phase_60))))))" +" orig-s_1" +" id_28)))))" +"(if(if(not at-mod_4)(not define-shadowing-require?_0) #f)" +"(let-values() #f)" +"(if(if ok-binding_0(same-binding? b_70 ok-binding_0) #f)" +"(let-values()" +"(begin" +"(if(same-binding-nominals? b_70 ok-binding_0)" +"(void)" +"(let-values()" +"(let-values(((update!_0)" +"(lambda()" +"(begin" +" 'update!" +"(let-values(((temp163_1) #t)" +"((id164_0) id_28)" +"((temp165_1)" +"(let-values(((ok-binding167_0)" +" ok-binding_0)" +"((temp168_1)" +"(cons" +" b_70" +"(module-binding-extra-nominal-bindings" +" b_70))))" +"(module-binding-update48.1" +" unsafe-undefined" +" temp168_1" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" ok-binding167_0)))" +"((phase166_1) phase_60))" +"(add-binding!17.1" +" #f" +" temp163_1" +" id164_0" +" temp165_1" +" phase166_1))))))" +"(if accum-update-nominals_1" +"(let-values()" +"(set-box!" +" accum-update-nominals_1" +"(cons" +" update!_0" +"(unbox accum-update-nominals_1))))" +"(let-values()(update!_0))))))" +" defined?_0))" +"(if(if defined?_0 allow-defined?_0 #f)" +"(let-values()" +"(let-values(((also-required_0)" +"(requires+provides-also-required r+p_8)))" +"(let-values(((prev-b_0)" +"(hash-ref" +" also-required_0" +"(module-binding-sym b_70)" +" #f)))" +"(begin" +"(if(if prev-b_0" +"(not(same-binding? ok-binding_0 prev-b_0))" +" #f)" +"(let-values()(raise-already-bound_0 #f))" +"(void))" +"(hash-set!" +" also-required_0" +"(module-binding-sym b_70)" +" ok-binding_0)" +"(set-requires+provides-all-bindings-simple?! r+p_8 #f)" +" #t))))" +"(let-values()" +"(let-values(((nominal-phase_6)" +"(module-binding-nominal-require-phase b_70)))" +"(let-values(((sym-to-reqds_3)" +"(hash-ref" +" at-mod_4" +" nominal-phase_6" +" '#hasheq())))" +"(let-values(((reqds_2)" +"(hash-ref" +" sym-to-reqds_3" +"(syntax-e$1 id_28)" +" null)))" +"(let-values(((only-can-can-shadow-require?_0)" +"(let-values(((lst_126) reqds_2))" +"(begin" +"(void)" +"((letrec-values(((for-loop_163)" +"(lambda(only-can-can-shadow-require?_1" +" lst_127)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" lst_127))" +"(let-values(((r_38)" +"(if(pair?" +" lst_127)" +"(car" +" lst_127)" +" lst_127))" +"((rest_64)" +"(if(pair?" +" lst_127)" +"(cdr" +" lst_127)" +" null)))" +"(let-values(((only-can-can-shadow-require?_2)" +"(let-values(((only-can-can-shadow-require?_3)" +" only-can-can-shadow-require?_1))" +"(let-values(((only-can-can-shadow-require?_4)" +"(let-values()" +"(if(if(bulk-required?" +" r_38)" +"(bulk-required-can-be-shadowed?" +" r_38)" +"(required-can-be-shadowed?" +" r_38))" +"(let-values()" +"(begin" +"(set-requires+provides-all-bindings-simple?!" +" r+p_8" +" #f)" +" only-can-can-shadow-require?_3))" +"(if define-shadowing-require?_0" +"(let-values()" +" #f)" +"(let-values()" +"(raise-already-bound_0" +" defined?_0)))))))" +"(values" +" only-can-can-shadow-require?_4)))))" +"(if(not" +" #f)" +"(for-loop_163" +" only-can-can-shadow-require?_2" +" rest_64)" +" only-can-can-shadow-require?_2)))" +" only-can-can-shadow-require?_1)))))" +" for-loop_163)" +" #t" +" lst_126)))))" +"(begin" +"(if define-shadowing-require?_0" +"(let-values()" +"(begin" +"(set-requires+provides-all-bindings-simple?!" +" r+p_8" +" #f)" +"(if only-can-can-shadow-require?_0" +"(void)" +"(let-values()" +"(hash-set!" +"(requires+provides-also-required r+p_8)" +"(module-binding-sym b_70)" +" b_70)))))" +"(let-values()" +"(if(if remove-shadowed!?_0" +"(not(null? reqds_2))" +" #f)" +"(let-values()" +"(hash-set!" +" sym-to-reqds_3" +"(syntax-e$1 id_28)" +"(remove-non-matching-requireds" +" reqds_2" +" id_28" +" phase_60" +" mpi_33" +" nominal-phase_6" +"(syntax-e$1 id_28))))" +"(void))))" +" #f)))))))))))))))))))))))))))))))))))" +"(define-values" +"(add-defined-syms!103.1)" +"(lambda(as-transformer?98_0 r+p100_0 syms101_0 phase102_0)" +"(begin" +" 'add-defined-syms!103" +"(let-values(((r+p_9) r+p100_0))" +"(let-values(((syms_18) syms101_0))" +"(let-values(((phase_61) phase102_0))" +"(let-values(((as-transformer?_2) as-transformer?98_0))" +"(let-values()" +"(let-values(((phase-to-defined-syms_0)(requires+provides-phase-to-defined-syms r+p_9)))" +"(let-values(((defined-syms_2)(hash-ref phase-to-defined-syms_0 phase_61 '#hasheq())))" +"(let-values(((new-defined-syms_0)" +"(let-values(((lst_128) syms_18))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_128)))" +"((letrec-values(((for-loop_164)" +"(lambda(defined-syms_3 lst_129)" +"(begin" +" 'for-loop" +"(if(pair? lst_129)" +"(let-values(((sym_41)(unsafe-car lst_129))" +"((rest_65)(unsafe-cdr lst_129)))" +"(let-values(((defined-syms_4)" +"(let-values(((defined-syms_5)" +" defined-syms_3))" +"(let-values(((defined-syms_6)" +"(let-values()" +"(hash-set" +" defined-syms_5" +" sym_41" +"(if as-transformer?_2" +" 'transformer" +" 'variable)))))" +"(values defined-syms_6)))))" +"(if(not #f)" +"(for-loop_164 defined-syms_4 rest_65)" +" defined-syms_4)))" +" defined-syms_3)))))" +" for-loop_164)" +" defined-syms_2" +" lst_128)))))" +"(hash-set! phase-to-defined-syms_0 phase_61 new-defined-syms_0))))))))))))" +"(define-values" +"(defined-sym-kind)" +"(lambda(r+p_10 sym_42 phase_62)" +"(begin" +"(let-values(((phase-to-defined-syms_1)(requires+provides-phase-to-defined-syms r+p_10)))" +"(let-values(((defined-syms_7)(hash-ref phase-to-defined-syms_1 phase_62 '#hasheq())))" +"(hash-ref defined-syms_7 sym_42 #f))))))" +"(define-values" +"(extract-module-requires)" +"(lambda(r+p_11 mod-name_11 phase_63)" +"(begin" +"(let-values(((mpi_34)(intern-mpi r+p_11 mod-name_11)))" +"(let-values(((at-mod_5)(hash-ref(requires+provides-requires r+p_11) mpi_34 #f)))" +"(if at-mod_5" +"(reverse$1" +"(let-values(((ht_103)(hash-ref at-mod_5 phase_63 '#hasheq())))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_103)))" +"((letrec-values(((for-loop_165)" +"(lambda(fold-var_116 i_130)" +"(begin" +" 'for-loop" +"(if i_130" +"(let-values(((sym_43 reqds_3)(hash-iterate-key+value ht_103 i_130)))" +"(let-values(((fold-var_117)" +"(let-values(((lst_130) reqds_3))" +"(begin" +"(void)" +"((letrec-values(((for-loop_166)" +"(lambda(fold-var_118 lst_131)" +"(begin" +" 'for-loop" +"(if(not(null? lst_131))" +"(let-values(((reqd_1)" +"(if(pair? lst_131)" +"(car lst_131)" +" lst_131))" +"((rest_66)" +"(if(pair? lst_131)" +"(cdr lst_131)" +" null)))" +"(let-values(((fold-var_119)" +"(let-values(((fold-var_120)" +" fold-var_118))" +"(let-values(((fold-var_121)" +"(let-values()" +"(cons" +"(let-values()" +"(normalize-required" +" reqd_1" +" mpi_34" +" phase_63" +" sym_43))" +" fold-var_120))))" +"(values" +" fold-var_121)))))" +"(if(not #f)" +"(for-loop_166" +" fold-var_119" +" rest_66)" +" fold-var_119)))" +" fold-var_118)))))" +" for-loop_166)" +" fold-var_116" +" lst_130)))))" +"(if(not #f)" +"(for-loop_165 fold-var_117(hash-iterate-next ht_103 i_130))" +" fold-var_117)))" +" fold-var_116)))))" +" for-loop_165)" +" null" +"(hash-iterate-first ht_103)))))" +" #f))))))" +"(define-values" +"(extract-module-definitions)" +"(lambda(r+p_12)" +"(begin" +"(let-values(((or-part_176)(extract-module-requires r+p_12(requires+provides-self r+p_12) 0)))" +"(if or-part_176 or-part_176 null)))))" +"(define-values" +"(extract-all-module-requires)" +"(lambda(r+p_13 mod-name_12 phase_64)" +"(begin" +"(let-values(((self_9)(requires+provides-self r+p_13)))" +"(let-values(((requires_2)(requires+provides-requires r+p_13)))" +"(call/ec" +"(lambda(esc_0)" +"(reverse$1" +"(let-values(((lst_132)(if mod-name_12(list(intern-mpi r+p_13 mod-name_12))(hash-keys requires_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_132)))" +"((letrec-values(((for-loop_167)" +"(lambda(fold-var_46 lst_61)" +"(begin" +" 'for-loop" +"(if(pair? lst_61)" +"(let-values(((mod-name_13)(unsafe-car lst_61))" +"((rest_67)(unsafe-cdr lst_61)))" +"(let-values(((fold-var_122)" +"(let-values(((fold-var_123) fold-var_46))" +"(if(eq? mod-name_13 self_9)" +" fold-var_123" +"(let-values(((phase-to-requireds_0)" +"(hash-ref" +" requires_2" +" mod-name_13" +" '#hasheqv())))" +"(begin" +" #t" +"((letrec-values(((for-loop_168)" +"(lambda(fold-var_49)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_50)" +"(let-values(((lst_63)" +"(if(eq?" +" phase_64" +" 'all)" +"(hash-keys" +" phase-to-requireds_0)" +"(list" +" phase_64))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_63)))" +"((letrec-values(((for-loop_88)" +"(lambda(fold-var_124" +" lst_133)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_133)" +"(let-values(((phase_65)" +"(unsafe-car" +" lst_133))" +"((rest_68)" +"(unsafe-cdr" +" lst_133)))" +"(let-values(((fold-var_125)" +"(let-values(((ht_104)" +"(hash-ref" +" phase-to-requireds_0" +" phase_65" +"(lambda()" +"(esc_0" +" #f)))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_104)))" +"((letrec-values(((for-loop_169)" +"(lambda(fold-var_126" +" i_131)" +"(begin" +" 'for-loop" +"(if i_131" +"(let-values(((sym_44" +" reqds_4)" +"(hash-iterate-key+value" +" ht_104" +" i_131)))" +"(let-values(((fold-var_127)" +"(let-values(((lst_134)" +" reqds_4))" +"(begin" +"(void)" +"((letrec-values(((for-loop_170)" +"(lambda(fold-var_128" +" lst_135)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" lst_135))" +"(let-values(((reqd_2)" +"(if(pair?" +" lst_135)" +"(car" +" lst_135)" +" lst_135))" +"((rest_69)" +"(if(pair?" +" lst_135)" +"(cdr" +" lst_135)" +" null)))" +"(let-values(((fold-var_129)" +"(let-values(((fold-var_130)" +" fold-var_128))" +"(let-values(((fold-var_131)" +"(let-values()" +"(cons" +"(let-values()" +"(normalize-required" +" reqd_2" +" mod-name_13" +" phase_65" +" sym_44))" +" fold-var_130))))" +"(values" +" fold-var_131)))))" +"(if(not" +" #f)" +"(for-loop_170" +" fold-var_129" +" rest_69)" +" fold-var_129)))" +" fold-var_128)))))" +" for-loop_170)" +" fold-var_126" +" lst_134)))))" +"(if(not" +" #f)" +"(for-loop_169" +" fold-var_127" +"(hash-iterate-next" +" ht_104" +" i_131))" +" fold-var_127)))" +" fold-var_126)))))" +" for-loop_169)" +" fold-var_124" +"(hash-iterate-first" +" ht_104))))))" +"(if(not" +" #f)" +"(for-loop_88" +" fold-var_125" +" rest_68)" +" fold-var_125)))" +" fold-var_124)))))" +" for-loop_88)" +" fold-var_49" +" lst_63)))))" +" fold-var_50))))))" +" for-loop_168)" +" fold-var_123)))))))" +"(if(not #f)(for-loop_167 fold-var_122 rest_67) fold-var_122)))" +" fold-var_46)))))" +" for-loop_167)" +" null" +" lst_132)))))))))))" +"(define-values" +"(add-provide!117.1)" +"(lambda(as-protected?106_0" +" as-transformer?107_0" +" r+p110_0" +" sym111_0" +" phase112_0" +" binding113_0" +" immed-binding114_0" +" id115_0" +" orig-s116_0)" +"(begin" +" 'add-provide!117" +"(let-values(((r+p_14) r+p110_0))" +"(let-values(((sym_45) sym111_0))" +"(let-values(((phase_66) phase112_0))" +"(let-values(((binding_13) binding113_0))" +"(let-values(((immed-binding_0) immed-binding114_0))" +"(let-values(((id_29) id115_0))" +"(let-values(((orig-s_2) orig-s116_0))" +"(let-values(((as-protected?_0) as-protected?106_0))" +"(let-values(((as-transformer?_3) as-transformer?107_0))" +"(let-values()" +"(begin" +"(if(if as-protected?_0" +"(not(eq?(module-binding-module immed-binding_0)(requires+provides-self r+p_14)))" +" #f)" +"(let-values()" +" (raise-syntax-error$1 #f \"cannot protect required identifier in re-provide\" sym_45))" +"(void))" +"(hash-update!" +"(requires+provides-provides r+p_14)" +" phase_66" +"(lambda(at-phase_9)" +"(let-values(((b/p_0)(hash-ref at-phase_9 sym_45 #f)))" +"(let-values(((b_71)(provided-as-binding b/p_0)))" +"(if(not b_71)" +"(let-values()" +"(let-values(((plain-binding_0)" +"(if(binding-free=id binding_13)" +"(let-values(((binding169_0) binding_13)((temp170_0) #f))" +"(module-binding-update48.1" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" temp170_0" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" unsafe-undefined" +" binding169_0))" +" binding_13)))" +"(hash-set" +" at-phase_9" +" sym_45" +"(if(let-values(((or-part_177) as-protected?_0))" +"(if or-part_177 or-part_177 as-transformer?_3))" +"(provided1.1 plain-binding_0 as-protected?_0 as-transformer?_3)" +" plain-binding_0))))" +"(if(same-binding? b_71 binding_13)" +"(let-values() at-phase_9)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"identifier already provided (as a different binding)\"" +" orig-s_2" +" id_29)))))))" +" '#hasheq())))))))))))))))" +"(define-values" +"(extract-requires-and-provides)" +"(lambda(r+p_15 old-self_0 new-self_1)" +"(begin" +"(let-values(((extract-requires_0)" +"(lambda()" +"(begin" +" 'extract-requires" +"(let-values(((phase-to-mpis-in-order_0)(requires+provides-require-mpis-in-order r+p_15)))" +"(let-values(((phases-in-order_1)" +"(let-values(((temp171_0)(hash-keys phase-to-mpis-in-order_0))" +"((phasesym-set" +" id148_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'prefix)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_8" +" prefix155_0" +" id:prefix156_0" +" spec157_0)" +"(let-values(((s_129)" +" req_0))" +"(let-values(((orig-s_10)" +" s_129))" +"(let-values(((prefix155_1" +" id:prefix156_1" +" spec157_1)" +"(let-values(((s_229)" +"(if(syntax?$1" +" s_129)" +"(syntax-e$1" +" s_129)" +" s_129)))" +"(if(pair?" +" s_229)" +"(let-values(((prefix158_0)" +"(let-values(((s_230)" +"(car" +" s_229)))" +" s_230))" +"((id:prefix159_0" +" spec160_0)" +"(let-values(((s_231)" +"(cdr" +" s_229)))" +"(let-values(((s_232)" +"(if(syntax?$1" +" s_231)" +"(syntax-e$1" +" s_231)" +" s_231)))" +"(if(pair?" +" s_232)" +"(let-values(((id:prefix161_0)" +"(let-values(((s_233)" +"(car" +" s_232)))" +"(if(let-values(((or-part_185)" +"(if(syntax?$1" +" s_233)" +"(symbol?" +"(syntax-e$1" +" s_233))" +" #f)))" +"(if or-part_185" +" or-part_185" +"(symbol?" +" s_233)))" +" s_233" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_10" +" s_233))))" +"((spec162_0)" +"(let-values(((s_234)" +"(cdr" +" s_232)))" +"(let-values(((s_235)" +"(if(syntax?$1" +" s_234)" +"(syntax-e$1" +" s_234)" +" s_234)))" +"(if(pair?" +" s_235)" +"(let-values(((spec163_0)" +"(let-values(((s_133)" +"(car" +" s_235)))" +" s_133))" +"(()" +"(let-values(((s_236)" +"(cdr" +" s_235)))" +"(let-values(((s_237)" +"(if(syntax?$1" +" s_236)" +"(syntax-e$1" +" s_236)" +" s_236)))" +"(if(null?" +" s_237)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" spec163_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" id:prefix161_0" +" spec162_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" prefix158_0" +" id:prefix159_0" +" spec160_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10)))))" +"(values" +" #t" +" prefix155_1" +" id:prefix156_1" +" spec157_1))))))" +"(loop_88" +"(list" +" spec157_0)" +"(let-values(((or-part_113)" +" top-req_0))" +"(if or-part_113" +" or-part_113" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-prefix2.1" +"(syntax-e$1" +" id:prefix156_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'all-except)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_9" +" all-except164_0" +" spec165_0" +" id166_0)" +"(let-values(((s_238)" +" req_0))" +"(let-values(((orig-s_11)" +" s_238))" +"(let-values(((all-except164_1" +" spec165_1" +" id166_1)" +"(let-values(((s_239)" +"(if(syntax?$1" +" s_238)" +"(syntax-e$1" +" s_238)" +" s_238)))" +"(if(pair?" +" s_239)" +"(let-values(((all-except167_0)" +"(let-values(((s_240)" +"(car" +" s_239)))" +" s_240))" +"((spec168_0" +" id169_0)" +"(let-values(((s_241)" +"(cdr" +" s_239)))" +"(let-values(((s_242)" +"(if(syntax?$1" +" s_241)" +"(syntax-e$1" +" s_241)" +" s_241)))" +"(if(pair?" +" s_242)" +"(let-values(((spec170_0)" +"(let-values(((s_243)" +"(car" +" s_242)))" +" s_243))" +"((id171_0)" +"(let-values(((s_244)" +"(cdr" +" s_242)))" +"(let-values(((s_245)" +"(if(syntax?$1" +" s_244)" +"(syntax-e$1" +" s_244)" +" s_244)))" +"(let-values(((flat-s_6)" +"(to-syntax-list.1" +" s_245)))" +"(if(not" +" flat-s_6)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11))" +"(let-values()" +"(let-values(((id_35)" +"(let-values(((lst_144)" +" flat-s_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_144)))" +"((letrec-values(((for-loop_175)" +"(lambda(id_36" +" lst_145)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_145)" +"(let-values(((s_246)" +"(unsafe-car" +" lst_145))" +"((rest_74)" +"(unsafe-cdr" +" lst_145)))" +"(let-values(((id_37)" +"(let-values(((id_38)" +" id_36))" +"(let-values(((id_39)" +"(let-values()" +"(let-values(((id172_0)" +"(let-values()" +"(if(let-values(((or-part_186)" +"(if(syntax?$1" +" s_246)" +"(symbol?" +"(syntax-e$1" +" s_246))" +" #f)))" +"(if or-part_186" +" or-part_186" +"(symbol?" +" s_246)))" +" s_246" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_11" +" s_246)))))" +"(cons" +" id172_0" +" id_38)))))" +"(values" +" id_39)))))" +"(if(not" +" #f)" +"(for-loop_175" +" id_37" +" rest_74)" +" id_37)))" +" id_36)))))" +" for-loop_175)" +" null" +" lst_144)))))" +"(reverse$1" +" id_35)))))))))" +"(values" +" spec170_0" +" id171_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11))))))" +"(values" +" all-except167_0" +" spec168_0" +" id169_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11)))))" +"(values" +" #t" +" all-except164_1" +" spec165_1" +" id166_1))))))" +"(loop_88" +"(list" +" spec165_0)" +"(let-values(((or-part_187)" +" top-req_0))" +"(if or-part_187" +" or-part_187" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-all-except3.1" +" '||" +"(ids->sym-set" +" id166_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'prefix-all-except)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_10" +" prefix-all-except173_0" +" id:prefix174_0" +" spec175_0" +" id176_0)" +"(let-values(((s_247)" +" req_0))" +"(let-values(((orig-s_12)" +" s_247))" +"(let-values(((prefix-all-except173_1" +" id:prefix174_1" +" spec175_1" +" id176_1)" +"(let-values(((s_248)" +"(if(syntax?$1" +" s_247)" +"(syntax-e$1" +" s_247)" +" s_247)))" +"(if(pair?" +" s_248)" +"(let-values(((prefix-all-except177_0)" +"(let-values(((s_249)" +"(car" +" s_248)))" +" s_249))" +"((id:prefix178_0" +" spec179_0" +" id180_0)" +"(let-values(((s_250)" +"(cdr" +" s_248)))" +"(let-values(((s_251)" +"(if(syntax?$1" +" s_250)" +"(syntax-e$1" +" s_250)" +" s_250)))" +"(if(pair?" +" s_251)" +"(let-values(((id:prefix181_0)" +"(let-values(((s_252)" +"(car" +" s_251)))" +"(if(let-values(((or-part_188)" +"(if(syntax?$1" +" s_252)" +"(symbol?" +"(syntax-e$1" +" s_252))" +" #f)))" +"(if or-part_188" +" or-part_188" +"(symbol?" +" s_252)))" +" s_252" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_12" +" s_252))))" +"((spec182_0" +" id183_0)" +"(let-values(((s_253)" +"(cdr" +" s_251)))" +"(let-values(((s_254)" +"(if(syntax?$1" +" s_253)" +"(syntax-e$1" +" s_253)" +" s_253)))" +"(if(pair?" +" s_254)" +"(let-values(((spec184_0)" +"(let-values(((s_255)" +"(car" +" s_254)))" +" s_255))" +"((id185_0)" +"(let-values(((s_256)" +"(cdr" +" s_254)))" +"(let-values(((s_257)" +"(if(syntax?$1" +" s_256)" +"(syntax-e$1" +" s_256)" +" s_256)))" +"(let-values(((flat-s_7)" +"(to-syntax-list.1" +" s_257)))" +"(if(not" +" flat-s_7)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))" +"(let-values()" +"(let-values(((id_40)" +"(let-values(((lst_146)" +" flat-s_7))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_146)))" +"((letrec-values(((for-loop_176)" +"(lambda(id_41" +" lst_147)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_147)" +"(let-values(((s_258)" +"(unsafe-car" +" lst_147))" +"((rest_75)" +"(unsafe-cdr" +" lst_147)))" +"(let-values(((id_42)" +"(let-values(((id_43)" +" id_41))" +"(let-values(((id_44)" +"(let-values()" +"(let-values(((id186_0)" +"(let-values()" +"(if(let-values(((or-part_189)" +"(if(syntax?$1" +" s_258)" +"(symbol?" +"(syntax-e$1" +" s_258))" +" #f)))" +"(if or-part_189" +" or-part_189" +"(symbol?" +" s_258)))" +" s_258" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_12" +" s_258)))))" +"(cons" +" id186_0" +" id_43)))))" +"(values" +" id_44)))))" +"(if(not" +" #f)" +"(for-loop_176" +" id_42" +" rest_75)" +" id_42)))" +" id_41)))))" +" for-loop_176)" +" null" +" lst_146)))))" +"(reverse$1" +" id_40)))))))))" +"(values" +" spec184_0" +" id185_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))))))" +"(values" +" id:prefix181_0" +" spec182_0" +" id183_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))))))" +"(values" +" prefix-all-except177_0" +" id:prefix178_0" +" spec179_0" +" id180_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12)))))" +"(values" +" #t" +" prefix-all-except173_1" +" id:prefix174_1" +" spec175_1" +" id176_1))))))" +"(loop_88" +"(list" +" spec175_0)" +"(let-values(((or-part_190)" +" top-req_0))" +"(if or-part_190" +" or-part_190" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-all-except3.1" +"(syntax-e$1" +" id:prefix174_0)" +"(ids->sym-set" +" id176_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'rename)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_11" +" rename187_0" +" spec188_0" +" id:to189_0" +" id:from190_0)" +"(let-values(((s_259)" +" req_0))" +"(let-values(((orig-s_13)" +" s_259))" +"(let-values(((rename187_1" +" spec188_1" +" id:to189_1" +" id:from190_1)" +"(let-values(((s_260)" +"(if(syntax?$1" +" s_259)" +"(syntax-e$1" +" s_259)" +" s_259)))" +"(if(pair?" +" s_260)" +"(let-values(((rename191_0)" +"(let-values(((s_261)" +"(car" +" s_260)))" +" s_261))" +"((spec192_0" +" id:to193_0" +" id:from194_0)" +"(let-values(((s_262)" +"(cdr" +" s_260)))" +"(let-values(((s_263)" +"(if(syntax?$1" +" s_262)" +"(syntax-e$1" +" s_262)" +" s_262)))" +"(if(pair?" +" s_263)" +"(let-values(((spec195_0)" +"(let-values(((s_264)" +"(car" +" s_263)))" +" s_264))" +"((id:to196_0" +" id:from197_0)" +"(let-values(((s_265)" +"(cdr" +" s_263)))" +"(let-values(((s_266)" +"(if(syntax?$1" +" s_265)" +"(syntax-e$1" +" s_265)" +" s_265)))" +"(if(pair?" +" s_266)" +"(let-values(((id:to198_0)" +"(let-values(((s_267)" +"(car" +" s_266)))" +"(if(let-values(((or-part_191)" +"(if(syntax?$1" +" s_267)" +"(symbol?" +"(syntax-e$1" +" s_267))" +" #f)))" +"(if or-part_191" +" or-part_191" +"(symbol?" +" s_267)))" +" s_267" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_13" +" s_267))))" +"((id:from199_0)" +"(let-values(((s_268)" +"(cdr" +" s_266)))" +"(let-values(((s_269)" +"(if(syntax?$1" +" s_268)" +"(syntax-e$1" +" s_268)" +" s_268)))" +"(if(pair?" +" s_269)" +"(let-values(((id:from200_0)" +"(let-values(((s_270)" +"(car" +" s_269)))" +"(if(let-values(((or-part_192)" +"(if(syntax?$1" +" s_270)" +"(symbol?" +"(syntax-e$1" +" s_270))" +" #f)))" +"(if or-part_192" +" or-part_192" +"(symbol?" +" s_270)))" +" s_270" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_13" +" s_270))))" +"(()" +"(let-values(((s_135)" +"(cdr" +" s_269)))" +"(let-values(((s_271)" +"(if(syntax?$1" +" s_135)" +"(syntax-e$1" +" s_135)" +" s_135)))" +"(if(null?" +" s_271)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" id:from200_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" id:to198_0" +" id:from199_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" spec195_0" +" id:to196_0" +" id:from197_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" rename191_0" +" spec192_0" +" id:to193_0" +" id:from194_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13)))))" +"(values" +" #t" +" rename187_1" +" spec188_1" +" id:to189_1" +" id:from190_1))))))" +"(loop_88" +"(list" +" spec188_0)" +"(let-values(((or-part_193)" +" top-req_0))" +"(if or-part_193" +" or-part_193" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-rename4.1" +" id:to189_0" +"(syntax-e$1" +" id:from190_0))" +" #f" +" #f" +" 'path))))" +"(let-values()" +"(let-values(((maybe-mp_0)" +"(syntax->datum$1" +" req_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_194)" +"(1/module-path?" +" maybe-mp_0)))" +"(if or-part_194" +" or-part_194" +"(1/resolved-module-path?" +" maybe-mp_0)))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad require spec\"" +" orig-s_3" +" req_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_195)" +" adjust_0))" +"(if or-part_195" +" or-part_195" +"(not" +"(eq?" +" just-meta_0" +" 'all))))" +"(let-values()" +"(set-requires+provides-all-bindings-simple?!" +" requires+provides_1" +" #f))" +"(void))" +"(values))))" +"(let-values(((mp_0)" +"(if(1/resolved-module-path?" +" maybe-mp_0)" +"(resolved-module-path->module-path" +" maybe-mp_0)" +" maybe-mp_0)))" +"(let-values(((mpi_16)" +"(let-values(((mp218_0)" +" mp_0)" +"((self219_0)" +" self_10)" +"((declared-submodule-names220_0)" +" declared-submodule-names_2))" +"(module-path->mpi5.1" +" declared-submodule-names220_0" +" mp218_0" +" self219_0))))" +"(begin" +"(let-values(((mpi201_0)" +" mpi_16)" +"((req202_0)" +" req_0)" +"((self203_0)" +" self_10)" +"((temp204_0)" +"(let-values(((or-part_196)" +" req_0))" +"(if or-part_196" +" or-part_196" +" top-req_0)))" +"((m-ns205_0)" +" m-ns_8)" +"((phase-shift206_0)" +" phase-shift_9)" +"((run-phase207_0)" +" run-phase_5)" +"((just-meta208_0)" +" just-meta_0)" +"((adjust209_0)" +" adjust_0)" +"((requires+provides210_0)" +" requires+provides_1)" +"((run?211_0)" +" run?_1)" +"((visit?212_0)" +" visit?_1)" +"((copy-variable-phase-level213_0)" +" copy-variable-phase-level_0)" +"((copy-variable-as-constant?214_0)" +" copy-variable-as-constant?_0)" +"((skip-variable-phase-level215_0)" +" skip-variable-phase-level_0)" +"((initial-require?216_0)" +" initial-require?_0)" +"((who217_0)" +" who_13))" +"(perform-require!78.1" +" adjust209_0" +" #t" +" #f" +" copy-variable-as-constant?214_0" +" copy-variable-phase-level213_0" +" initial-require?216_0" +" just-meta208_0" +" phase-shift206_0" +" requires+provides210_0" +" run-phase207_0" +" run?211_0" +" skip-variable-phase-level215_0" +" visit?212_0" +" who217_0" +" mpi201_0" +" req202_0" +" self203_0" +" temp204_0" +" m-ns205_0))" +"(set! initial-require?_0" +" #f)))))))))))))))))))))))))" +"(values" +" result_76)))))" +"(if(if(not" +"((lambda x_55" +"(not result_75))" +" req_0))" +"(not #f)" +" #f)" +"(for-loop_173" +" result_75" +" rest_72)" +" result_75)))" +" result_74)))))" +" for-loop_173)" +" #t" +" lst_140)))))))" +" loop_88)" +" reqs_0" +" #f" +" phase-shift_8" +" 'all" +" #f" +" #t" +" #t" +" 'raw))))))))))))))))))))" +"(define-values" +"(ids->sym-set)" +"(lambda(ids_3)" +"(begin" +"(let-values(((lst_148) ids_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_148)))" +"((letrec-values(((for-loop_177)" +"(lambda(table_136 lst_149)" +"(begin" +" 'for-loop" +"(if(pair? lst_149)" +"(let-values(((id_45)(unsafe-car lst_149))((rest_76)(unsafe-cdr lst_149)))" +"(let-values(((table_137)" +"(let-values(((table_138) table_136))" +"(let-values(((table_139)" +"(let-values()" +"(let-values(((key_54 val_46)" +"(let-values()" +"(values" +"(let-values()(syntax-e$1 id_45))" +" #t))))" +"(hash-set table_138 key_54 val_46)))))" +"(values table_139)))))" +"(if(not #f)(for-loop_177 table_137 rest_76) table_137)))" +" table_136)))))" +" for-loop_177)" +" '#hash()" +" lst_148))))))" +"(define-values" +"(perform-initial-require!42.1)" +"(lambda(bind?33_0 who34_0 mod-path37_0 self38_0 in-stx39_0 m-ns40_0 requires+provides41_0)" +"(begin" +" 'perform-initial-require!42" +"(let-values(((mod-path_7) mod-path37_0))" +"(let-values(((self_11) self38_0))" +"(let-values(((in-stx_0) in-stx39_0))" +"(let-values(((m-ns_9) m-ns40_0))" +"(let-values(((requires+provides_2) requires+provides41_0))" +"(let-values(((bind?_0) bind?33_0))" +"(let-values(((who_14) who34_0))" +"(let-values()" +"(let-values(((temp221_1)" +"(let-values(((mod-path233_0) mod-path_7)((self234_0) self_11))" +"(module-path->mpi5.1 unsafe-undefined mod-path233_0 self234_0)))" +"((temp222_0) #f)" +"((self223_0) self_11)" +"((in-stx224_0) in-stx_0)" +"((m-ns225_0) m-ns_9)" +"((temp226_1) 0)" +"((temp227_0) 0)" +"((requires+provides228_0) requires+provides_2)" +"((temp229_1) #t)" +"((temp230_1) #t)" +"((bind?231_0) bind?_0)" +"((who232_0) who_14))" +"(perform-require!78.1" +" #f" +" bind?231_0" +" temp229_1" +" #f" +" #f" +" temp230_1" +" 'all" +" temp226_1" +" requires+provides228_0" +" temp227_0" +" #f" +" #f" +" #t" +" who232_0" +" temp221_1" +" temp222_0" +" self223_0" +" in-stx224_0" +" m-ns225_0)))))))))))))" +"(define-values" +"(perform-require!78.1)" +"(lambda(adjust48_0" +" bind?57_0" +" can-be-shadowed?52_0" +" copy-variable-as-constant?55_0" +" copy-variable-phase-level54_0" +" initial-require?53_0" +" just-meta47_0" +" phase-shift45_0" +" requires+provides49_0" +" run-phase46_0" +" run?51_0" +" skip-variable-phase-level56_0" +" visit?50_0" +" who58_0" +" mpi73_0" +" orig-s74_0" +" self75_0" +" in-stx76_0" +" m-ns77_0)" +"(begin" +" 'perform-require!78" +"(let-values(((mpi_36) mpi73_0))" +"(let-values(((orig-s_14) orig-s74_0))" +"(let-values()" +"(let-values(((in-stx_1) in-stx76_0))" +"(let-values(((m-ns_10) m-ns77_0))" +"(let-values(((phase-shift_10) phase-shift45_0))" +"(let-values(((run-phase_6) run-phase46_0))" +"(let-values(((just-meta_1) just-meta47_0))" +"(let-values(((adjust_1) adjust48_0))" +"(let-values(((requires+provides_3) requires+provides49_0))" +"(let-values(((visit?_2) visit?50_0))" +"(let-values(((run?_2) run?51_0))" +"(let-values(((can-be-shadowed?_3) can-be-shadowed?52_0))" +"(let-values(((initial-require?_1) initial-require?53_0))" +"(let-values(((copy-variable-phase-level_1) copy-variable-phase-level54_0))" +"(let-values(((copy-variable-as-constant?_1) copy-variable-as-constant?55_0))" +"(let-values(((skip-variable-phase-level_1) skip-variable-phase-level56_0))" +"(let-values(((bind?_1) bind?57_0))" +"(let-values(((who_15) who58_0))" +"(let-values()" +"(let-values()" +"(let-values(((module-name_0)(1/module-path-index-resolve mpi_36 #t)))" +"(let-values(((bind-in-stx_0)" +"(if(adjust-rename? adjust_1)" +"(adjust-rename-to-id adjust_1)" +" in-stx_1)))" +"(let-values(((done-syms_0)(if adjust_1(make-hash) #f)))" +"(let-values(((m_13)(namespace->module m-ns_10 module-name_0)))" +"(let-values((()" +"(begin" +"(if m_13" +"(void)" +"(let-values()" +"(raise-unknown-module-error" +" 'require" +" module-name_0)))" +"(values))))" +"(let-values(((interned-mpi_0)" +"(if requires+provides_3" +"(add-required-module!" +" requires+provides_3" +" mpi_36" +" phase-shift_10" +"(module-cross-phase-persistent? m_13))" +" mpi_36)))" +"(let-values((()" +"(begin" +"(if visit?_2" +"(let-values()" +"(let-values(((m-ns251_0) m-ns_10)" +"((interned-mpi252_0)" +" interned-mpi_0)" +"((phase-shift253_0)" +" phase-shift_10)" +"((run-phase254_0)" +" run-phase_6))" +"(namespace-module-visit!104.1" +" run-phase254_0" +" m-ns251_0" +" interned-mpi252_0" +" phase-shift253_0)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if run?_2" +"(let-values()" +"(let-values(((m-ns255_0) m-ns_10)" +"((interned-mpi256_0)" +" interned-mpi_0)" +"((phase-shift257_0)" +" phase-shift_10)" +"((run-phase258_0)" +" run-phase_6))" +"(namespace-module-instantiate!96.1" +" #t" +" run-phase258_0" +" unsafe-undefined" +" #f" +" m-ns255_0" +" interned-mpi256_0" +" phase-shift257_0)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(not" +"(let-values(((or-part_197)" +" visit?_2))" +"(if or-part_197" +" or-part_197" +" run?_2)))" +"(let-values()" +"(let-values(((m-ns259_0) m-ns_10)" +"((interned-mpi260_0)" +" interned-mpi_0)" +"((phase-shift261_0)" +" phase-shift_10)" +"((run-phase262_0)" +" run-phase_6))" +"(namespace-module-make-available!112.1" +" run-phase262_0" +" m-ns259_0" +" interned-mpi260_0" +" phase-shift261_0)))" +"(void))" +"(values))))" +"(let-values(((can-bulk-bind?_0)" +"(if(let-values(((or-part_198)" +"(not adjust_1)))" +"(if or-part_198" +" or-part_198" +"(let-values(((or-part_199)" +"(adjust-prefix?" +" adjust_1)))" +"(if or-part_199" +" or-part_199" +"(adjust-all-except?" +" adjust_1)))))" +"(not skip-variable-phase-level_1)" +" #f)))" +"(let-values(((bulk-prefix_1)" +"(if(adjust-prefix? adjust_1)" +"(let-values()" +"(adjust-prefix-sym adjust_1))" +"(if(adjust-all-except? adjust_1)" +"(let-values()" +"(adjust-all-except-prefix-sym" +" adjust_1))" +"(let-values() #f)))))" +"(let-values(((bulk-excepts_1)" +"(if(adjust-all-except? adjust_1)" +"(let-values()" +"(adjust-all-except-syms" +" adjust_1))" +"(let-values() '#hasheq()))))" +"(let-values(((update-nominals-box_0)" +"(if can-bulk-bind?_0" +"(box null)" +" #f)))" +"(let-values((()" +"(begin" +"(let-values(((m235_0) m_13)" +"((bind-in-stx236_0)" +" bind-in-stx_0)" +"((phase-shift237_0)" +" phase-shift_10)" +"((m-ns238_0)" +" m-ns_10)" +"((interned-mpi239_0)" +" interned-mpi_0)" +"((module-name240_0)" +" module-name_0)" +"((orig-s241_0)" +" orig-s_14)" +"((temp242_0)" +"(if requires+provides_3" +"(requires+provides-self" +" requires+provides_3)" +" #f))" +"((temp243_0)" +"(if(adjust-only?" +" adjust_1)" +"(let-values()" +"(set->list" +"(adjust-only-syms" +" adjust_1)))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(list" +"(adjust-rename-from-sym" +" adjust_1)))" +"(let-values()" +" #f))))" +"((just-meta244_0)" +" just-meta_1)" +"((bind?245_0)" +" bind?_1)" +"((can-bulk-bind?246_0)" +" can-bulk-bind?_0)" +"((bulk-prefix247_0)" +" bulk-prefix_1)" +"((bulk-excepts248_0)" +" bulk-excepts_1)" +"((temp249_0)" +"(if requires+provides_3" +"(if can-bulk-bind?_0" +"(lambda(provides_6" +" provide-phase-level_4)" +"(begin" +" 'temp249" +"(let-values(((requires+provides263_0)" +" requires+provides_3)" +"((bind-in-stx264_0)" +" bind-in-stx_0)" +"((temp265_0)" +"(module-self" +" m_13))" +"((mpi266_0)" +" mpi_36)" +"((phase-shift267_0)" +" phase-shift_10)" +"((provides268_0)" +" provides_6)" +"((provide-phase-level269_0)" +" provide-phase-level_4)" +"((bulk-prefix270_0)" +" bulk-prefix_1)" +"((bulk-excepts271_0)" +" bulk-excepts_1)" +"((temp272_0)" +"(if(positive?" +"(hash-count" +" bulk-excepts_1))" +" done-syms_0" +" #f))" +"((can-be-shadowed?273_0)" +" can-be-shadowed?_3)" +"((temp274_0)" +"(not" +" initial-require?_1))" +"((orig-s275_0)" +" orig-s_14)" +"((update-nominals-box276_0)" +" update-nominals-box_0)" +"((who277_0)" +" who_15))" +"(add-bulk-required-ids!59.1" +" update-nominals-box276_0" +" can-be-shadowed?273_0" +" temp274_0" +" bulk-excepts271_0" +" orig-s275_0" +" bulk-prefix270_0" +" temp272_0" +" who277_0" +" requires+provides263_0" +" bind-in-stx264_0" +" temp265_0" +" mpi266_0" +" phase-shift267_0" +" provides268_0" +" provide-phase-level269_0))))" +" #f)" +" #f))" +"((temp250_0)" +"(if(let-values(((or-part_200)" +"(not" +" can-bulk-bind?_0)))" +"(if or-part_200" +" or-part_200" +" copy-variable-phase-level_1))" +"(lambda(binding_16" +" as-transformer?_4)" +"(begin" +" 'temp250" +"(let-values(((sym_47)" +"(module-binding-nominal-sym" +" binding_16)))" +"(let-values(((provide-phase_0)" +"(module-binding-nominal-phase" +" binding_16)))" +"(let-values(((adjusted-sym_0)" +"(if(not" +"(symbol-interned?" +" sym_47))" +"(let-values()" +" #f)" +"(if(if skip-variable-phase-level_1" +"(if(not" +" as-transformer?_4)" +"(equal?" +" provide-phase_0" +" skip-variable-phase-level_1)" +" #f)" +" #f)" +"(let-values()" +" #f)" +"(if(not" +" adjust_1)" +"(let-values()" +" sym_47)" +"(if(adjust-only?" +" adjust_1)" +"(let-values()" +"(if(set-member?" +"(adjust-only-syms" +" adjust_1)" +" sym_47)" +"(if(hash-set!" +" done-syms_0" +" sym_47" +" #t)" +" sym_47" +" #f)" +" #f))" +"(if(adjust-prefix?" +" adjust_1)" +"(let-values()" +"(string->symbol" +"(format" +" \"~a~a\"" +"(adjust-prefix-sym" +" adjust_1)" +" sym_47)))" +"(if(adjust-all-except?" +" adjust_1)" +"(let-values()" +"(if(not" +"(if(set-member?" +"(adjust-all-except-syms" +" adjust_1)" +" sym_47)" +"(hash-set!" +" done-syms_0" +" sym_47" +" #t)" +" #f))" +"(string->symbol" +"(format" +" \"~a~a\"" +"(adjust-all-except-prefix-sym" +" adjust_1)" +" sym_47))" +" #f))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(if(eq?" +" sym_47" +"(adjust-rename-from-sym" +" adjust_1))" +"(if(hash-set!" +" done-syms_0" +" sym_47" +" #t)" +"(adjust-rename-to-id" +" adjust_1)" +" #f)" +" #f))" +"(void))))))))))" +"(let-values(((skip-bind?_0)" +"(if(if adjusted-sym_0" +" requires+provides_3" +" #f)" +"(let-values()" +"(let-values(((s_272)" +"(datum->syntax$1" +" bind-in-stx_0" +" adjusted-sym_0)))" +"(let-values(((bind-phase_0)" +"(phase+" +" phase-shift_10" +" provide-phase_0)))" +"(let-values(((skip-bind?_1)" +"(if initial-require?_1" +"(let-values()" +" #f)" +"(let-values()" +"(let-values(((temp278_0)" +" #t)" +"((temp279_0)" +" #t)" +"((requires+provides280_0)" +" requires+provides_3)" +"((s281_0)" +" s_272)" +"((bind-phase282_0)" +" bind-phase_0)" +"((binding283_0)" +" binding_16)" +"((orig-s284_0)" +" orig-s_14)" +"((temp285_0)" +" #t)" +"((who286_0)" +" who_15))" +"(check-not-defined95.1" +" #f" +" temp279_0" +" temp278_0" +" orig-s284_0" +" temp285_0" +" binding283_0" +" who286_0" +" requires+provides280_0" +" s281_0" +" bind-phase282_0))))))" +"(begin" +"(if skip-bind?_1" +"(void)" +"(let-values()" +"(let-values(((requires+provides287_0)" +" requires+provides_3)" +"((s288_0)" +" s_272)" +"((bind-phase289_0)" +" bind-phase_0)" +"((binding290_0)" +" binding_16)" +"((can-be-shadowed?291_0)" +" can-be-shadowed?_3)" +"((as-transformer?292_0)" +" as-transformer?_4))" +"(add-defined-or-required-id!19.1" +" as-transformer?292_0" +" can-be-shadowed?291_0" +" requires+provides287_0" +" s288_0" +" bind-phase289_0" +" binding290_0))))" +" skip-bind?_1)))))" +"(let-values()" +" #f))))" +"(begin" +"(if(if copy-variable-phase-level_1" +"(if(not" +" as-transformer?_4)" +"(equal?" +" provide-phase_0" +" copy-variable-phase-level_1)" +" #f)" +" #f)" +"(let-values()" +"(copy-namespace-value" +" m-ns_10" +" sym_47" +" binding_16" +" copy-variable-phase-level_1" +" phase-shift_10" +" copy-variable-as-constant?_1))" +"(void))" +"(if(not" +" skip-bind?_0)" +" adjusted-sym_0" +" #f))))))))" +" #f)))" +"(bind-all-provides!107.1" +" bind?245_0" +" temp249_0" +" bulk-excepts248_0" +" bulk-prefix247_0" +" can-bulk-bind?246_0" +" temp242_0" +" temp250_0" +" orig-s241_0" +" just-meta244_0" +" temp243_0" +" m235_0" +" bind-in-stx236_0" +" phase-shift237_0" +" m-ns238_0" +" interned-mpi239_0" +" module-name240_0))" +"(values))))" +"(let-values((()" +"(begin" +"(if update-nominals-box_0" +"(let-values()" +"(begin" +"(let-values(((lst_150)" +"(unbox" +" update-nominals-box_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_150)))" +"((letrec-values(((for-loop_178)" +"(lambda(lst_151)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_151)" +"(let-values(((update!_1)" +"(unsafe-car" +" lst_151))" +"((rest_77)" +"(unsafe-cdr" +" lst_151)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(update!_1))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_178" +" rest_77)" +"(values))))" +"(values))))))" +" for-loop_178)" +" lst_150)))" +"(void)))" +"(void))" +"(values))))" +"(let-values(((need-syms_0)" +"(if(adjust-only? adjust_1)" +"(let-values()" +"(adjust-only-syms" +" adjust_1))" +"(if(adjust-all-except?" +" adjust_1)" +"(let-values()" +"(adjust-all-except-syms" +" adjust_1))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(set" +"(adjust-rename-from-sym" +" adjust_1)))" +"(let-values()" +" #f))))))" +"(if(if need-syms_0" +"(not" +"(=" +"(set-count need-syms_0)" +"(hash-count done-syms_0)))" +" #f)" +"(let-values()" +"(begin" +"(let-values(((ht_106)" +" need-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys" +" ht_106)))" +"((letrec-values(((for-loop_179)" +"(lambda(i_133)" +"(begin" +" 'for-loop" +"(if i_133" +"(let-values(((sym_48)" +"(unsafe-immutable-hash-iterate-key" +" ht_106" +" i_133)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(hash-ref" +" done-syms_0" +" sym_48" +" #f)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" who_15" +" \"not in nested spec\"" +" orig-s_14" +" sym_48))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_179" +"(unsafe-immutable-hash-iterate-next" +" ht_106" +" i_133))" +"(values))))" +"(values))))))" +" for-loop_179)" +"(unsafe-immutable-hash-iterate-first" +" ht_106))))" +"(void)))" +"(void))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(bind-all-provides!107.1)" +"(lambda(bind?85_0" +" bulk-callback90_0" +" bulk-excepts88_0" +" bulk-prefix87_0" +" can-bulk?86_0" +" defines-mpi82_0" +" filter89_0" +" in81_0" +" just-meta84_0" +" only83_0" +" m101_0" +" in-stx102_0" +" phase-shift103_0" +" ns104_0" +" mpi105_0" +" module-name106_0)" +"(begin" +" 'bind-all-provides!107" +"(let-values(((m_14) m101_0))" +"(let-values(((in-stx_2) in-stx102_0))" +"(let-values(((phase-shift_11) phase-shift103_0))" +"(let-values(((ns_50) ns104_0))" +"(let-values(((mpi_37) mpi105_0))" +"(let-values(((module-name_1) module-name106_0))" +"(let-values(((orig-s_15) in81_0))" +"(let-values(((defines-mpi_0) defines-mpi82_0))" +"(let-values(((only-syms_0) only83_0))" +"(let-values(((just-meta_2) just-meta84_0))" +"(let-values(((bind?_2) bind?85_0))" +"(let-values(((can-bulk?_0) can-bulk?86_0))" +"(let-values(((bulk-prefix_2) bulk-prefix87_0))" +"(let-values(((bulk-excepts_2) bulk-excepts88_0))" +"(let-values(((filter_0) filter89_0))" +"(let-values(((bulk-callback_0) bulk-callback90_0))" +"(let-values()" +"(let-values(((self_12)(module-self m_14)))" +"(begin" +"(let-values(((ht_107)(module-provides m_14)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_107)))" +"((letrec-values(((for-loop_180)" +"(lambda(i_134)" +"(begin" +" 'for-loop" +"(if i_134" +"(let-values(((provide-phase-level_5 provides_7)" +"(hash-iterate-key+value" +" ht_107" +" i_134)))" +"(let-values((()" +"(let-values()" +"(if(let-values(((or-part_201)" +"(eq?" +" just-meta_2" +" 'all)))" +"(if or-part_201" +" or-part_201" +"(eqv?" +" just-meta_2" +" provide-phase-level_5)))" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_69)" +"(phase+" +" phase-shift_11" +" provide-phase-level_5)))" +"(let-values(((need-except?_0)" +"(if bulk-callback_0" +"(bulk-callback_0" +" provides_7" +" provide-phase-level_5)" +" #f)))" +"(if bind?_2" +"(let-values()" +"(begin" +"(if filter_0" +"(let-values()" +"(begin" +"(let-values(((lst_152)" +"(let-values(((or-part_202)" +" only-syms_0))" +"(if or-part_202" +" or-part_202" +"(hash-keys" +" provides_7)))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_152)))" +"((letrec-values(((for-loop_181)" +"(lambda(lst_153)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_153)" +"(let-values(((sym_49)" +"(unsafe-car" +" lst_153))" +"((rest_78)" +"(unsafe-cdr" +" lst_153)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((binding/p_4)" +"(hash-ref" +" provides_7" +" sym_49" +" #f)))" +"(if binding/p_4" +"(let-values()" +"(let-values(((b_72)" +"(let-values(((binding/p293_0)" +" binding/p_4)" +"((sym294_0)" +" sym_49)" +"((self295_0)" +" self_12)" +"((mpi296_0)" +" mpi_37)" +"((provide-phase-level297_0)" +" provide-phase-level_5)" +"((phase-shift298_0)" +" phase-shift_11))" +"(provide-binding-to-require-binding11.1" +" mpi296_0" +" phase-shift298_0" +" provide-phase-level297_0" +" self295_0" +" binding/p293_0" +" sym294_0))))" +"(let-values(((sym_50)" +"(filter_0" +" b_72" +"(provided-as-transformer?" +" binding/p_4))))" +"(if(if sym_50" +"(not" +" can-bulk?_0)" +" #f)" +"(let-values()" +"(let-values(((temp299_0)" +"(datum->syntax$1" +" in-stx_2" +" sym_50))" +"((b300_0)" +" b_72)" +"((phase301_0)" +" phase_69))" +"(add-binding!17.1" +" #f" +" #f" +" temp299_0" +" b300_0" +" phase301_0)))" +"(void)))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_181" +" rest_78)" +"(values))))" +"(values))))))" +" for-loop_181)" +" lst_152)))" +"(void)))" +"(void))" +"(if can-bulk?_0" +"(let-values()" +"(let-values(((bulk-binding-registry_10)" +"(namespace-bulk-binding-registry" +" ns_50)))" +"(let-values(((in-stx302_0)" +" in-stx_2)" +"((temp303_0)" +"(bulk-binding14.1" +"(let-values(((or-part_203)" +"(if(not" +" bulk-prefix_2)" +"(if(zero?" +"(hash-count" +" bulk-excepts_2))" +" provides_7" +" #f)" +" #f)))" +"(if or-part_203" +" or-part_203" +"(if(not" +"(registered-bulk-provide?" +" bulk-binding-registry_10" +" module-name_1))" +"(bulk-provides-add-prefix-remove-exceptions" +" provides_7" +" bulk-prefix_2" +" bulk-excepts_2)" +" #f)))" +" bulk-prefix_2" +" bulk-excepts_2" +" self_12" +" mpi_37" +" provide-phase-level_5" +" phase-shift_11" +" bulk-binding-registry_10))" +"((phase304_0)" +" phase_69)" +"((orig-s305_0)" +" orig-s_15)" +"((temp306_0)" +"(if need-except?_0" +" defines-mpi_0" +" #f)))" +"(add-bulk-binding!27.1" +" orig-s305_0" +" temp306_0" +" in-stx302_0" +" temp303_0" +" phase304_0))))" +"(void))))" +"(void)))))" +"(values)))))" +"(values)))" +"(values)))))" +"(if(not #f)" +"(for-loop_180" +"(hash-iterate-next ht_107 i_134))" +"(values))))" +"(values))))))" +" for-loop_180)" +"(hash-iterate-first ht_107))))" +"(void)))))))))))))))))))))))" +"(define-values" +"(require-spec-shift-for-syntax)" +"(lambda(req_1)" +"(begin" +"(let-values(((rebuild-req_0)" +"(lambda(req_2 new-req_0)(begin 'rebuild-req(datum->syntax$1 req_2 new-req_0 req_2 req_2)))))" +"(letrec-values(((loop_89)" +"(lambda(shifted?_0)" +"(begin" +" 'loop" +"(lambda(req_3)" +"(let-values(((fm_1)" +"(if(pair?(syntax-e$1 req_3))" +"(if(identifier?(car(syntax-e$1 req_3)))" +"(syntax-e$1(car(syntax-e$1 req_3)))" +" #f)" +" #f)))" +"(let-values(((tmp_25) fm_1))" +"(if(equal? tmp_25 'for-meta)" +"(let-values()" +"(let-values(((ok?_12 for-meta307_0 phase-level308_0 spec309_0)" +"(let-values(((s_273) req_3))" +"(let-values(((orig-s_16) s_273))" +"(let-values(((for-meta307_1 phase-level308_1 spec309_1)" +"(let-values(((s_274)" +"(if(syntax?$1 s_273)" +"(syntax-e$1 s_273)" +" s_273)))" +"(if(pair? s_274)" +"(let-values(((for-meta310_0)" +"(let-values(((s_275)" +"(car s_274)))" +" s_275))" +"((phase-level311_0 spec312_0)" +"(let-values(((s_276)" +"(cdr s_274)))" +"(let-values(((s_277)" +"(if(syntax?$1" +" s_276)" +"(syntax-e$1" +" s_276)" +" s_276)))" +"(if(pair? s_277)" +"(let-values(((phase-level313_0)" +"(let-values(((s_278)" +"(car" +" s_277)))" +" s_278))" +"((spec314_0)" +"(let-values(((s_279)" +"(cdr" +" s_277)))" +"(let-values(((s_280)" +"(if(syntax?$1" +" s_279)" +"(syntax-e$1" +" s_279)" +" s_279)))" +"(let-values(((flat-s_8)" +"(to-syntax-list.1" +" s_280)))" +"(if(not" +" flat-s_8)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16))" +"(let-values()" +" flat-s_8)))))))" +"(values" +" phase-level313_0" +" spec314_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16))))))" +"(values" +" for-meta310_0" +" phase-level311_0" +" spec312_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16)))))" +"(values #t for-meta307_1 phase-level308_1 spec309_1))))))" +"(let-values(((p_36)(syntax-e$1 phase-level308_0)))" +"(begin" +"(if(phase? p_36)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"bad phase\" req_3)))" +"(rebuild-req_0" +" req_3" +"(list* for-meta307_0(phase+ p_36 1)(map2(loop_89 #t) spec309_0)))))))" +"(if(equal? tmp_25 'for-syntax)" +"(let-values()" +"(let-values(((ok?_13 for-syntax315_0 spec316_0)" +"(let-values(((s_281) req_3))" +"(let-values(((orig-s_17) s_281))" +"(let-values(((for-syntax315_1 spec316_1)" +"(let-values(((s_282)" +"(if(syntax?$1 s_281)" +"(syntax-e$1 s_281)" +" s_281)))" +"(if(pair? s_282)" +"(let-values(((for-syntax317_0)" +"(let-values(((s_283)" +"(car s_282)))" +" s_283))" +"((spec318_0)" +"(let-values(((s_284)" +"(cdr s_282)))" +"(let-values(((s_285)" +"(if(syntax?$1" +" s_284)" +"(syntax-e$1" +" s_284)" +" s_284)))" +"(let-values(((flat-s_9)" +"(to-syntax-list.1" +" s_285)))" +"(if(not flat-s_9)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_17))" +"(let-values()" +" flat-s_9)))))))" +"(values for-syntax317_0 spec318_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_17)))))" +"(values #t for-syntax315_1 spec316_1))))))" +"(rebuild-req_0 req_3(list* 'for-meta 2(map2(loop_89 #t) spec316_0)))))" +"(if(equal? tmp_25 'for-template)" +"(let-values()" +"(let-values(((ok?_14 for-template319_0 spec320_0)" +"(let-values(((s_286) req_3))" +"(let-values(((orig-s_18) s_286))" +"(let-values(((for-template319_1 spec320_1)" +"(let-values(((s_287)" +"(if(syntax?$1 s_286)" +"(syntax-e$1 s_286)" +" s_286)))" +"(if(pair? s_287)" +"(let-values(((for-template321_0)" +"(let-values(((s_288)" +"(car s_287)))" +" s_288))" +"((spec322_0)" +"(let-values(((s_289)" +"(cdr s_287)))" +"(let-values(((s_290)" +"(if(syntax?$1" +" s_289)" +"(syntax-e$1" +" s_289)" +" s_289)))" +"(let-values(((flat-s_10)" +"(to-syntax-list.1" +" s_290)))" +"(if(not flat-s_10)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_18))" +"(let-values()" +" flat-s_10)))))))" +"(values for-template321_0 spec322_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_18)))))" +"(values #t for-template319_1 spec320_1))))))" +"(rebuild-req_0 req_3(list* 'for-meta 0(map2(loop_89 #t) spec320_0)))))" +"(if(equal? tmp_25 'for-label)" +"(let-values()" +"(let-values(((ok?_15 for-label323_0 spec324_0)" +"(let-values(((s_291) req_3))" +"(let-values(((orig-s_19) s_291))" +"(let-values(((for-label323_1 spec324_1)" +"(let-values(((s_292)" +"(if(syntax?$1 s_291)" +"(syntax-e$1 s_291)" +" s_291)))" +"(if(pair? s_292)" +"(let-values(((for-label325_0)" +"(let-values(((s_293)" +"(car" +" s_292)))" +" s_293))" +"((spec326_0)" +"(let-values(((s_294)" +"(cdr" +" s_292)))" +"(let-values(((s_295)" +"(if(syntax?$1" +" s_294)" +"(syntax-e$1" +" s_294)" +" s_294)))" +"(let-values(((flat-s_11)" +"(to-syntax-list.1" +" s_295)))" +"(if(not flat-s_11)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_19))" +"(let-values()" +" flat-s_11)))))))" +"(values for-label325_0 spec326_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_19)))))" +"(values #t for-label323_1 spec324_1))))))" +"(rebuild-req_0" +" req_3" +"(list* for-label323_0(map2(loop_89 #t) spec324_0)))))" +"(if(equal? tmp_25 'just-meta)" +"(let-values()" +"(let-values(((ok?_16 just-meta327_0 phase-level328_0 spec329_0)" +"(let-values(((s_296) req_3))" +"(let-values(((orig-s_20) s_296))" +"(let-values(((just-meta327_1" +" phase-level328_1" +" spec329_1)" +"(let-values(((s_297)" +"(if(syntax?$1 s_296)" +"(syntax-e$1 s_296)" +" s_296)))" +"(if(pair? s_297)" +"(let-values(((just-meta330_0)" +"(let-values(((s_298)" +"(car" +" s_297)))" +" s_298))" +"((phase-level331_0" +" spec332_0)" +"(let-values(((s_299)" +"(cdr" +" s_297)))" +"(let-values(((s_300)" +"(if(syntax?$1" +" s_299)" +"(syntax-e$1" +" s_299)" +" s_299)))" +"(if(pair? s_300)" +"(let-values(((phase-level333_0)" +"(let-values(((s_301)" +"(car" +" s_300)))" +" s_301))" +"((spec334_0)" +"(let-values(((s_302)" +"(cdr" +" s_300)))" +"(let-values(((s_303)" +"(if(syntax?$1" +" s_302)" +"(syntax-e$1" +" s_302)" +" s_302)))" +"(let-values(((flat-s_12)" +"(to-syntax-list.1" +" s_303)))" +"(if(not" +" flat-s_12)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20))" +"(let-values()" +" flat-s_12)))))))" +"(values" +" phase-level333_0" +" spec334_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20))))))" +"(values" +" just-meta330_0" +" phase-level331_0" +" spec332_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20)))))" +"(values" +" #t" +" just-meta327_1" +" phase-level328_1" +" spec329_1))))))" +"(rebuild-req_0" +" req_3" +"(list*" +" just-meta327_0" +" phase-level328_0" +"(map2(loop_89 #f) spec329_0)))))" +"(let-values()" +"(if shifted?_0" +" req_3" +"(datum->syntax$1 #f(list 'for-syntax req_3))))))))))))))))" +"((loop_89 #f) req_1))))))" +"(define-values" +"(copy-namespace-value)" +"(lambda(m-ns_11 adjusted-sym_1 binding_17 phase-level_16 phase-shift_12 as-constant?_1)" +"(begin" +"(let-values(((i-ns_0)" +"(let-values(((m-ns335_0) m-ns_11)" +"((temp336_0)(1/module-path-index-resolve(module-binding-module binding_17)))" +"((temp337_0)(phase-(module-binding-phase binding_17) phase-level_16))" +"((temp338_0) #t))" +"(namespace->module-namespace82.1 #f temp338_0 unsafe-undefined m-ns335_0 temp336_0 temp337_0))))" +"(let-values(((val_47)" +"(namespace-get-variable" +" i-ns_0" +"(module-binding-phase binding_17)" +"(module-binding-sym binding_17)" +"(lambda()" +"(error" +" 'namespace-require/copy" +"(format" +"(string-append" +" \"namespace mismatch;\\n\"" +" \" variable not found\\n\"" +" \" module: ~a\\n\"" +" \" variable name: ~s\\n\"" +" \" phase level: ~s\")" +"(module-binding-module binding_17)" +"(module-binding-sym binding_17)" +"(module-binding-phase binding_17)))))))" +"(namespace-set-variable!" +" m-ns_11" +"(phase+ phase-shift_12 phase-level_16)" +" adjusted-sym_1" +" val_47" +" as-constant?_1))))))" +"(define-values" +"(top-level-instance)" +"(1/make-instance" +" 'top-level" +" #f" +" 'constant" +" top-level-bind!-id" +"(lambda(id_20 mpi_38 orig-phase_0 phase-shift_13 ns_51 sym_51 trans?_0 trans-val_0)" +"(let-values(((phase_70)(phase+ orig-phase_0 phase-shift_13)))" +"(let-values(((b_73)" +"(let-values(((mpi4_1) mpi_38)" +"((phase5_1) phase_70)" +"((sym6_1) sym_51)" +"((temp7_0)(root-expand-context-frame-id(namespace-get-root-expand-ctx ns_51))))" +"(make-module-binding22.1" +" #f" +" null" +" temp7_0" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" mpi4_1" +" phase5_1" +" sym6_1))))" +"(begin" +"(let-values(((id1_3) id_20)((b2_4) b_73)((phase3_2) phase_70))" +"(add-binding!17.1 #f #f id1_3 b2_4 phase3_2))" +"(if trans?_0" +"(let-values()(if trans-val_0(let-values()(maybe-install-free=id! trans-val_0 id_20 phase_70))(void)))" +"(let-values()(namespace-unset-transformer! ns_51 phase_70 sym_51)))))))" +" top-level-require!-id" +"(lambda(stx_13 ns_52)" +"(let-values(((reqs_2)(cdr(syntax->list$1 stx_13))))" +"(let-values(((temp8_1) #t)" +"((temp9_1) #f)" +"((reqs10_0) reqs_2)" +"((temp11_1) #f)" +"((ns12_1) ns_52)" +"((temp13_0)(namespace-phase ns_52))" +"((temp14_2)(let-values(((temp17_1) #f))(make-requires+provides8.1 #f temp17_1)))" +"((temp15_2) 'require)" +"((temp16_2) #t))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" unsafe-undefined" +" temp16_2" +" unsafe-undefined" +" temp8_1" +" #f" +" #f" +" temp9_1" +" temp15_2" +" reqs10_0" +" temp11_1" +" ns12_1" +" temp13_0" +" temp14_2))))))" +"(define-values" +"(struct:compiled-in-memory" +" compiled-in-memory1.1" +" compiled-in-memory?" +" compiled-in-memory-linklet-directory" +" compiled-in-memory-original-self" +" compiled-in-memory-requires" +" compiled-in-memory-provides" +" compiled-in-memory-phase-to-link-module-uses" +" compiled-in-memory-compile-time-inspector" +" compiled-in-memory-phase-to-link-extra-inspectorsss" +" compiled-in-memory-mpis" +" compiled-in-memory-syntax-literals" +" compiled-in-memory-pre-compiled-in-memorys" +" compiled-in-memory-post-compiled-in-memorys" +" compiled-in-memory-namespace-scopes" +" compiled-in-memory-purely-functional?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'compiled-in-memory" +" #f" +" 13" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(cim_0 port_11 mode_12)(write(compiled-in-memory-linklet-directory cim_0) port_11))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 12)" +" #f" +" 'compiled-in-memory)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'linklet-directory)" +"(make-struct-field-accessor -ref_0 1 'original-self)" +"(make-struct-field-accessor -ref_0 2 'requires)" +"(make-struct-field-accessor -ref_0 3 'provides)" +"(make-struct-field-accessor -ref_0 4 'phase-to-link-module-uses)" +"(make-struct-field-accessor -ref_0 5 'compile-time-inspector)" +"(make-struct-field-accessor -ref_0 6 'phase-to-link-extra-inspectorsss)" +"(make-struct-field-accessor -ref_0 7 'mpis)" +"(make-struct-field-accessor -ref_0 8 'syntax-literals)" +"(make-struct-field-accessor -ref_0 9 'pre-compiled-in-memorys)" +"(make-struct-field-accessor -ref_0 10 'post-compiled-in-memorys)" +"(make-struct-field-accessor -ref_0 11 'namespace-scopes)" +"(make-struct-field-accessor -ref_0 12 'purely-functional?))))" +"(define-values" +"(struct:namespace-scopes namespace-scopes1.1 namespace-scopes? namespace-scopes-post namespace-scopes-other)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'namespace-scopes #f 2 0 #f null 'prefab #f '(0 1) #f 'namespace-scopes)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'post)" +"(make-struct-field-accessor -ref_0 1 'other))))" +"(define-values" +"(swap-top-level-scopes)" +"(lambda(s_304 original-scopes-s_0 new-ns_0)" +"(begin" +"(let-values(((old-scs-post_0 old-scs-other_0)" +"(if(namespace-scopes? original-scopes-s_0)" +"(values(namespace-scopes-post original-scopes-s_0)(namespace-scopes-other original-scopes-s_0))" +"(decode-namespace-scopes original-scopes-s_0))))" +"(let-values(((new-scs-post_0 new-scs-other_0)(extract-namespace-scopes/values new-ns_0)))" +"(syntax-swap-scopes" +"(syntax-swap-scopes s_304 old-scs-post_0 new-scs-post_0)" +" old-scs-other_0" +" new-scs-other_0))))))" +"(define-values" +"(extract-namespace-scopes/values)" +"(lambda(ns_46)" +"(begin" +"(let-values(((root-ctx_3)(namespace-get-root-expand-ctx ns_46)))" +"(let-values(((post-expansion-sc_0)(post-expansion-scope(root-expand-context-post-expansion root-ctx_3))))" +"(values" +"(seteq post-expansion-sc_0)" +"(set-remove(list->seteq(root-expand-context-module-scopes root-ctx_3)) post-expansion-sc_0)))))))" +"(define-values" +"(extract-namespace-scopes)" +"(lambda(ns_53)" +"(begin" +"(let-values(((scs-post_0 scs-other_0)(extract-namespace-scopes/values ns_53)))" +"(namespace-scopes1.1 scs-post_0 scs-other_0)))))" +"(define-values" +"(encode-namespace-scopes)" +"(lambda(ns_54)" +"(begin" +"(let-values(((post-expansion-scs_0 other-scs_0)(extract-namespace-scopes/values ns_54)))" +"(let-values(((post-expansion-s_0)(add-scopes(datum->syntax$1 #f 'post)(set->list post-expansion-scs_0))))" +"(let-values(((other-s_0)(add-scopes(datum->syntax$1 #f 'other)(set->list other-scs_0))))" +"(datum->syntax$1 #f(vector post-expansion-s_0 other-s_0))))))))" +"(define-values" +"(decode-namespace-scopes)" +"(lambda(stx_14)" +"(begin" +"(let-values(((vec_54)(syntax-e$1 stx_14)))" +"(values(syntax-scope-set(vector-ref vec_54 0) 0)(syntax-scope-set(vector-ref vec_54 1) 0))))))" +"(define-values" +"(namespace-scopes=?)" +"(lambda(nss1_0 nss2_0)" +"(begin" +"(if(set=?(namespace-scopes-post nss1_0)(namespace-scopes-post nss2_0))" +"(set=?(namespace-scopes-other nss1_0)(namespace-scopes-other nss2_0))" +" #f))))" +"(define-values" +"(struct:syntax-literals" +" syntax-literals1.1" +" syntax-literals?" +" syntax-literals-stxes" +" syntax-literals-count" +" set-syntax-literals-stxes!" +" set-syntax-literals-count!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'syntax-literals" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'syntax-literals)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'stxes)" +"(make-struct-field-accessor -ref_0 1 'count)" +"(make-struct-field-mutator -set!_0 0 'stxes)" +"(make-struct-field-mutator -set!_0 1 'count))))" +"(define-values" +"(struct:header" +" header2.1" +" header?" +" header-module-path-indexes" +" header-binding-sym-to-define-sym" +" header-binding-syms-in-order" +" header-require-var-to-import-sym" +" header-import-sym-to-extra-inspectors" +" header-require-vars-in-order" +" header-define-and-import-syms" +" header-syntax-literals" +" set-header-binding-syms-in-order!" +" set-header-require-vars-in-order!)" +"(let-values(((struct:_68 make-_68 ?_68 -ref_68 -set!_68)" +"(let-values()" +"(let-values()" +"(make-struct-type 'header #f 8 0 #f null(current-inspector) #f '(0 1 3 4 6 7) #f 'header)))))" +"(values" +" struct:_68" +" make-_68" +" ?_68" +"(make-struct-field-accessor -ref_68 0 'module-path-indexes)" +"(make-struct-field-accessor -ref_68 1 'binding-sym-to-define-sym)" +"(make-struct-field-accessor -ref_68 2 'binding-syms-in-order)" +"(make-struct-field-accessor -ref_68 3 'require-var-to-import-sym)" +"(make-struct-field-accessor -ref_68 4 'import-sym-to-extra-inspectors)" +"(make-struct-field-accessor -ref_68 5 'require-vars-in-order)" +"(make-struct-field-accessor -ref_68 6 'define-and-import-syms)" +"(make-struct-field-accessor -ref_68 7 'syntax-literals)" +"(make-struct-field-mutator -set!_68 2 'binding-syms-in-order)" +"(make-struct-field-mutator -set!_68 5 'require-vars-in-order))))" +"(define-values" +"(struct:variable-use variable-use3.1 variable-use? variable-use-module-use variable-use-sym)" +"(let-values(((struct:_69 make-_69 ?_69 -ref_69 -set!_69)" +"(let-values()" +"(let-values()(make-struct-type 'variable-use #f 2 0 #f null #f #f '(0 1) #f 'variable-use)))))" +"(values" +" struct:_69" +" make-_69" +" ?_69" +"(make-struct-field-accessor -ref_69 0 'module-use)" +"(make-struct-field-accessor -ref_69 1 'sym))))" +"(define-values(make-syntax-literals)(lambda()(begin(syntax-literals1.1 null 0))))" +"(define-values" +"(make-header)" +"(lambda(mpis_11 syntax-literals_0)" +"(begin" +"(header2.1 mpis_11(make-hasheq) null(make-variable-uses)(make-hasheq) null(make-hasheq) syntax-literals_0))))" +"(define-values(make-variable-uses)(lambda()(begin(make-hash))))" +"(define-values" +"(add-syntax-literal!)" +"(lambda(header-or-literals_0 q_0)" +"(begin" +"(let-values(((sl_0)" +"(if(header? header-or-literals_0)" +"(header-syntax-literals header-or-literals_0)" +" header-or-literals_0)))" +"(let-values(((pos_84)(syntax-literals-count sl_0)))" +"(begin" +"(set-syntax-literals-count! sl_0(add1 pos_84))" +"(set-syntax-literals-stxes! sl_0(cons q_0(syntax-literals-stxes sl_0)))" +" pos_84))))))" +"(define-values" +"(add-syntax-literals!)" +"(lambda(sl_1 vec_55)" +"(begin" +"(let-values(((pos_85)(syntax-literals-count sl_1)))" +"(begin" +"(let-values(((vec_56 len_27)" +"(let-values(((vec_57) vec_55))" +"(begin(check-vector vec_57)(values vec_57(unsafe-vector-length vec_57))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_182)" +"(lambda(pos_86)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_86 len_27)" +"(let-values(((e_11)(unsafe-vector-ref vec_56 pos_86)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(add-syntax-literal! sl_1 e_11))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_182(unsafe-fx+ 1 pos_86))(values))))" +"(values))))))" +" for-loop_182)" +" 0)))" +"(void)" +"(cons pos_85(vector-length vec_55)))))))" +"(define-values(syntax-literals-empty?)(lambda(sl_2)(begin(null?(syntax-literals-stxes sl_2)))))" +"(define-values" +"(generate-lazy-syntax-literals!9.1)" +"(lambda(skip-deserialize?4_0 sl6_0 mpis7_0 self8_0)" +"(begin" +" 'generate-lazy-syntax-literals!9" +"(let-values(((sl_3) sl6_0))" +"(let-values(((mpis_12) mpis7_0))" +"(let-values(((self_13) self8_0))" +"(let-values(((skip-deserialize?_0) skip-deserialize?4_0))" +"(let-values()" +"(list" +"(list 'define-values(list syntax-literals-id)(list* 'make-vector(syntax-literals-count sl_3) '(#f)))" +"(list" +" 'define-values" +"(list get-syntax-literal!-id)" +"(list" +" 'lambda" +" '(pos)" +"(list" +" 'let-values" +"(list(list '(ready-stx)(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))" +"(list" +" 'if" +" 'ready-stx" +" 'ready-stx" +"(list*" +" 'begin" +"(qq-append" +"(if skip-deserialize?_0" +" null" +"(list" +"(list" +" 'if" +"(list* 'unsafe-vector*-ref deserialized-syntax-vector-id '(0))" +" '(void)" +"(list deserialize-syntax-id bulk-binding-registry-id))))" +"(list" +"(list" +" 'let-values" +"(list" +"(list" +" '(stx)" +"(list" +" 'syntax-module-path-index-shift" +"(list" +" 'syntax-shift-phase-level" +"(list* 'unsafe-vector*-ref deserialized-syntax-vector-id '(pos))" +" phase-shift-id)" +"(add-module-path-index! mpis_12 self_13)" +" self-id" +" inspector-id)))" +"(list" +" 'begin" +"(list* 'vector-cas! syntax-literals-id '(pos #f stx))" +"(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))))))))))))))))))" +"(define-values" +"(generate-lazy-syntax-literals-data!)" +"(lambda(sl_4 mpis_13)" +"(begin" +"(if(syntax-literals-empty? sl_4)" +"(let-values()(list(list* 'define-values(list deserialize-syntax-id) '(#f))))" +"(let-values()" +"(list" +"(list" +" 'define-values" +"(list deserialize-syntax-id)" +"(list" +" 'lambda" +"(list bulk-binding-registry-id)" +"(list" +" 'begin" +"(list" +" 'vector-copy!" +" deserialized-syntax-vector-id" +" ''0" +"(list" +" 'let-values" +"(list(list*(list inspector-id) '(#f)))" +"(let-values(((temp25_1)" +"(vector->immutable-vector(list->vector(reverse$1(syntax-literals-stxes sl_4)))))" +"((mpis26_0) mpis_13))" +"(generate-deserialize6.1 #t temp25_1 mpis26_0))))" +"(list* 'set! deserialize-syntax-id '(#f)))))))))))" +"(define-values(generate-lazy-syntax-literal-lookup)(lambda(pos_87)(begin(list get-syntax-literal!-id pos_87))))" +"(define-values" +"(generate-eager-syntax-literals!)" +"(lambda(sl_5 mpis_14 base-phase_0 self_14 ns_4)" +"(begin" +"(if(syntax-literals-empty? sl_5)" +"(let-values() #f)" +"(let-values()" +"(list" +" 'let-values" +"(list" +"(list" +" '(ns+stxss)" +"(let-values(((temp27_2)(cons(encode-namespace-scopes ns_4)(reverse$1(syntax-literals-stxes sl_5))))" +"((mpis28_0) mpis_14))" +"(generate-deserialize6.1 #t temp27_2 mpis28_0))))" +"(list" +" 'let-values" +" '(((ns-scope-s)(car ns+stxss)))" +"(list" +" 'list->vector" +"(list*" +" 'map" +"(list" +" 'lambda" +" '(stx)" +"(list" +" 'swap-top-level-scopes" +"(list" +" 'syntax-module-path-index-shift" +"(list 'syntax-shift-phase-level 'stx(list '- base-phase_0 dest-phase-id))" +"(add-module-path-index! mpis_14 self_14)" +" self-id)" +" 'ns-scope-s" +" ns-id))" +" '((cdr ns+stxss)))))))))))" +"(define-values" +"(generate-eager-syntax-literal-lookup)" +"(lambda(pos_88)(begin(list 'unsafe-vector*-ref syntax-literals-id pos_88))))" +"(define-values" +"(syntax-literals-as-vector)" +"(lambda(sl_6)(begin(list->vector(reverse$1(syntax-literals-stxes sl_6))))))" +"(define-values" +"(select-fresh)" +"(lambda(sym_52 header_0)" +"(begin" +"(if(symbol-conflicts? sym_52 header_0)" +"((letrec-values(((loop_90)" +"(lambda(pos_89)" +"(begin" +" 'loop" +" (let-values (((new-sym_0) (string->symbol (format \"~a/~a\" pos_89 sym_52))))" +"(if(symbol-conflicts? new-sym_0 header_0)(loop_90(add1 pos_89)) new-sym_0))))))" +" loop_90)" +" 1)" +" sym_52))))" +"(define-values" +"(symbol-conflicts?)" +"(lambda(sym_53 header_1)" +"(begin" +"(let-values(((or-part_204)(built-in-symbol? sym_53)))" +"(if or-part_204 or-part_204(hash-ref(header-define-and-import-syms header_1) sym_53 #f))))))" +"(define-values" +"(register-required-variable-use!19.1)" +"(lambda(defined?12_0 header14_0 mpi15_0 phase16_1 sym17_0 extra-inspector18_0)" +"(begin" +" 'register-required-variable-use!19" +"(let-values(((header_2) header14_0))" +"(let-values(((mpi_39) mpi15_0))" +"(let-values(((phase_71) phase16_1))" +"(let-values(((sym_54) sym17_0))" +"(let-values(((extra-inspector_4) extra-inspector18_0))" +"(let-values(((defined?_2) defined?12_0))" +"(let-values()" +"(let-values(((key_55)(variable-use3.1(module-use1.1 mpi_39 phase_71) sym_54)))" +"(let-values(((variable-uses_0)(header-require-var-to-import-sym header_2)))" +"(let-values(((prev-var-sym_0)(hash-ref variable-uses_0 key_55 #f)))" +"(let-values(((var-sym_0)" +"(let-values(((or-part_205) prev-var-sym_0))" +"(if or-part_205" +" or-part_205" +"(let-values(((sym_55)(select-fresh(variable-use-sym key_55) header_2)))" +"(begin" +"(hash-set! variable-uses_0 key_55 sym_55)" +"(set-header-require-vars-in-order!" +" header_2" +"(cons key_55(header-require-vars-in-order header_2)))" +"(hash-set!" +"(header-define-and-import-syms header_2)" +" sym_55" +"(if defined?_2 'defined 'required))" +" sym_55))))))" +"(begin" +"(if(if extra-inspector_4(not prev-var-sym_0) #f)" +"(let-values()" +"(let-values(((extra-inspectors_0)(header-import-sym-to-extra-inspectors header_2)))" +"(hash-update!" +" extra-inspectors_0" +" var-sym_0" +"(lambda(s_305)(set-add s_305 extra-inspector_4))" +" '#hasheq())))" +"(void))" +" var-sym_0)))))))))))))))" +"(define-values" +"(register-as-defined!)" +"(lambda(header_3 def-sym_0)(begin(hash-set!(header-define-and-import-syms header_3) def-sym_0 'defined))))" +"(define-values" +"(registered-as-required?)" +"(lambda(header_4 var-sym_1)" +"(begin(eq? 'required(hash-ref(header-define-and-import-syms header_4) var-sym_1 #f)))))" +"(define-values" +"(generate-links+imports)" +"(lambda(header_5 phase_38 cctx_0 cross-linklet-inlining?_0)" +"(begin" +"(let-values(((mod-use-ht_0 link-mod-uses_0)" +"(let-values(((lst_154)(header-require-vars-in-order header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_154)))" +"((letrec-values(((for-loop_183)" +"(lambda(ht_108 link-mod-uses_1 lst_155)" +"(begin" +" 'for-loop" +"(if(pair? lst_155)" +"(let-values(((vu_0)(unsafe-car lst_155))" +"((rest_79)(unsafe-cdr lst_155)))" +"(let-values(((ht_109 link-mod-uses_2)" +"(let-values(((ht_110) ht_108)" +"((link-mod-uses_3) link-mod-uses_1))" +"(let-values(((ht_111 link-mod-uses_4)" +"(let-values()" +"(let-values(((mu_2)" +"(variable-use-module-use" +" vu_0)))" +"(if(let-values(((or-part_206)" +"(hash-ref" +" ht_110" +" mu_2" +" #f)))" +"(if or-part_206" +" or-part_206" +"(let-values(((or-part_207)" +"(eq?" +"(module-use-module" +" mu_2)" +"(compile-context-self" +" cctx_0))))" +"(if or-part_207" +" or-part_207" +"(top-level-module-path-index?" +"(module-use-module" +" mu_2))))))" +"(values ht_110 link-mod-uses_3)" +"(values" +"(hash-set ht_110 mu_2 #t)" +"(cons mu_2 link-mod-uses_3)))))))" +"(values ht_111 link-mod-uses_4)))))" +"(if(not #f)" +"(for-loop_183 ht_109 link-mod-uses_2 rest_79)" +"(values ht_109 link-mod-uses_2))))" +"(values ht_108 link-mod-uses_1))))))" +" for-loop_183)" +" '#hash()" +" null" +" lst_154)))))" +"(values" +" link-mod-uses_0" +"(reverse$1" +"(let-values(((lst_33) link-mod-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_33)))" +"((letrec-values(((for-loop_184)" +"(lambda(fold-var_141 lst_107)" +"(begin" +" 'for-loop" +"(if(pair? lst_107)" +"(let-values(((mu_3)(unsafe-car lst_107))((rest_80)(unsafe-cdr lst_107)))" +"(let-values(((fold-var_142)" +"(let-values(((fold-var_143) fold-var_141))" +"(let-values(((fold-var_144)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_156)" +"(header-require-vars-in-order" +" header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_156)))" +"((letrec-values(((for-loop_185)" +"(lambda(fold-var_145" +" lst_157)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_157)" +"(let-values(((vu_1)" +"(unsafe-car" +" lst_157))" +"((rest_81)" +"(unsafe-cdr" +" lst_157)))" +"(let-values(((fold-var_146)" +"(let-values(((fold-var_147)" +" fold-var_145))" +"(if(equal?" +" mu_3" +"(variable-use-module-use" +" vu_1))" +"(let-values(((fold-var_40)" +" fold-var_147))" +"(let-values(((fold-var_41)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((var-sym_2)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_1)))" +"(let-values(((ex-sym_0)" +"(variable-use-sym" +" vu_1)))" +"(if(eq?" +" var-sym_2" +" ex-sym_0)" +" var-sym_2" +"(list" +" ex-sym_0" +" var-sym_2)))))" +" fold-var_40))))" +"(values" +" fold-var_41)))" +" fold-var_147))))" +"(if(not #f)" +"(for-loop_185" +" fold-var_146" +" rest_81)" +" fold-var_146)))" +" fold-var_145)))))" +" for-loop_185)" +" null" +" lst_156)))))" +" fold-var_143))))" +"(values fold-var_144)))))" +"(if(not #f)(for-loop_184 fold-var_142 rest_80) fold-var_142)))" +" fold-var_141)))))" +" for-loop_184)" +" null" +" lst_33))))" +"(reverse$1" +"(let-values(((lst_158) link-mod-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_158)))" +"((letrec-values(((for-loop_186)" +"(lambda(fold-var_148 lst_159)" +"(begin" +" 'for-loop" +"(if(pair? lst_159)" +"(let-values(((mu_4)(unsafe-car lst_159))((rest_82)(unsafe-cdr lst_159)))" +"(let-values(((fold-var_149)" +"(let-values(((fold-var_150) fold-var_148))" +"(let-values(((fold-var_151)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((extra-inspectorss_0)" +"(let-values(((lst_160)" +"(header-require-vars-in-order" +" header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_160)))" +"((letrec-values(((for-loop_187)" +"(lambda(table_140" +" lst_112)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_112)" +"(let-values(((vu_2)" +"(unsafe-car" +" lst_112))" +"((rest_56)" +"(unsafe-cdr" +" lst_112)))" +"(let-values(((table_141)" +"(let-values(((table_142)" +" table_140))" +"(if(equal?" +" mu_4" +"(variable-use-module-use" +" vu_2))" +"(let-values(((var-sym_3)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_2)))" +"(begin" +" #t" +"((letrec-values(((for-loop_188)" +"(lambda(table_31)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_32)" +"(let-values(((extra-inspectors_1)" +"(hash-ref" +"(header-import-sym-to-extra-inspectors" +" header_5)" +" var-sym_3" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_189)" +"(lambda(table_143)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_33)" +"(let-values(((table_144)" +" table_143))" +"(if(let-values(((or-part_208)" +" extra-inspectors_1))" +"(if or-part_208" +" or-part_208" +" cross-linklet-inlining?_0))" +"(let-values(((table_145)" +" table_144))" +"(let-values(((table_146)" +"(let-values()" +"(let-values(((key_56" +" val_48)" +"(let-values()" +"(values" +" var-sym_3" +" extra-inspectors_1))))" +"(hash-set" +" table_145" +" key_56" +" val_48)))))" +"(values" +" table_146)))" +" table_144))))" +" table_33))))))" +" for-loop_189)" +" table_31)))))" +" table_32))))))" +" for-loop_188)" +" table_142)))" +" table_142))))" +"(if(not" +" #f)" +"(for-loop_187" +" table_141" +" rest_56)" +" table_141)))" +" table_140)))))" +" for-loop_187)" +" '#hash()" +" lst_160)))))" +"(if(hash-count extra-inspectorss_0)" +" extra-inspectorss_0" +" #f)))" +" fold-var_150))))" +"(values fold-var_151)))))" +"(if(not #f)(for-loop_186 fold-var_149 rest_82) fold-var_149)))" +" fold-var_148)))))" +" for-loop_186)" +" null" +" lst_158))))" +"(reverse$1" +"(let-values(((lst_161)(header-require-vars-in-order header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_161)))" +"((letrec-values(((for-loop_190)" +"(lambda(fold-var_152 lst_162)" +"(begin" +" 'for-loop" +"(if(pair? lst_162)" +"(let-values(((vu_3)(unsafe-car lst_162))((rest_83)(unsafe-cdr lst_162)))" +"(let-values(((fold-var_153)" +"(let-values(((fold-var_154) fold-var_152))" +"(if(let-values(((mod_2)" +"(module-use-module" +"(variable-use-module-use vu_3))))" +"(let-values(((or-part_209)" +"(eq? mod_2(compile-context-self cctx_0))))" +"(if or-part_209" +" or-part_209" +"(top-level-module-path-index? mod_2))))" +"(let-values(((fold-var_155) fold-var_154))" +"(let-values(((fold-var_156)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((var-sym_4)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_3)))" +"(let-values(((ex-sym_1)" +"(variable-use-sym vu_3)))" +"(if(eq? var-sym_4 ex-sym_1)" +" var-sym_4" +"(list var-sym_4 ex-sym_1)))))" +" fold-var_155))))" +"(values fold-var_156)))" +" fold-var_154))))" +"(if(not #f)(for-loop_190 fold-var_153 rest_83) fold-var_153)))" +" fold-var_152)))))" +" for-loop_190)" +" null" +" lst_161)))))))))" +"(define-values" +"(instance-imports)" +"(list ns-id phase-shift-id self-id inspector-id bulk-binding-registry-id set-transformer!-id))" +"(define-values" +"(make-instance-instance13.1)" +"(lambda(bulk-binding-registry5_0 inspector4_0 namespace1_0 phase-shift2_0 self3_0 set-transformer!6_0)" +"(begin" +" 'make-instance-instance13" +"(let-values(((ns_55) namespace1_0))" +"(let-values(((phase-shift_14) phase-shift2_0))" +"(let-values(((self_15) self3_0))" +"(let-values(((inspector_11) inspector4_0))" +"(let-values(((bulk-binding-registry_11) bulk-binding-registry5_0))" +"(let-values(((set-transformer!_0) set-transformer!6_0))" +"(let-values()" +"(1/make-instance" +" 'instance" +" #f" +" 'constant" +" ns-id" +" ns_55" +" phase-shift-id" +" phase-shift_14" +" self-id" +" self_15" +" inspector-id" +" inspector_11" +" bulk-binding-registry-id" +" bulk-binding-registry_11" +" set-transformer!-id" +" set-transformer!_0)))))))))))" +"(define-values" +"(make-module-body-instance-instance18.1)" +"(lambda(set-transformer!16_0)" +"(begin" +" 'make-module-body-instance-instance18" +"(let-values(((set-transformer!_1) set-transformer!16_0))" +"(let-values()(1/make-instance 'body-instance #f 'constant set-transformer!-id set-transformer!_1))))))" +"(define-values" +"(empty-syntax-literals-instance)" +"(1/make-instance 'empty-stx #f 'constant get-syntax-literal!-id(lambda(pos_90) #f) 'get-encoded-root-expand-ctx #f))" +"(define-values" +"(empty-module-body-instance)" +"(let-values(((temp21_0)(lambda(name_39 val_49)(void))))(make-module-body-instance-instance18.1 temp21_0)))" +"(define-values" +"(empty-top-syntax-literal-instance)" +"(1/make-instance 'top-syntax-literal #f 'constant mpi-vector-id #f syntax-literals-id #f))" +"(define-values" +"(empty-syntax-literals-data-instance)" +"(1/make-instance 'empty-stx-data #f 'constant deserialized-syntax-vector-id(vector) deserialize-syntax-id void))" +"(define-values" +"(empty-instance-instance)" +"(let-values(((temp22_2) #f)((temp23_2) #f)((temp24_2) #f)((temp25_2) #f)((temp26_1) #f)((temp27_3) #f))" +"(make-instance-instance13.1 temp26_1 temp25_2 temp22_2 temp23_2 temp24_2 temp27_3)))" +"(define-values" +"(eager-instance-imports)" +"(list* ns-id dest-phase-id self-id bulk-binding-registry-id inspector-id '(swap-top-level-scopes)))" +"(define-values" +"(make-eager-instance-instance11.1)" +"(lambda(bulk-binding-registry4_0 dest-phase2_0 inspector5_0 namespace1_1 self3_1)" +"(begin" +" 'make-eager-instance-instance11" +"(let-values(((ns_56) namespace1_1))" +"(let-values(((dest-phase_0) dest-phase2_0))" +"(let-values(((self_16) self3_1))" +"(let-values(((bulk-binding-registry_12) bulk-binding-registry4_0))" +"(let-values(((inspector_12) inspector5_0))" +"(let-values()" +"(1/make-instance" +" 'instance" +" #f" +" 'constant" +" ns-id" +" ns_56" +" dest-phase-id" +" dest-phase_0" +" self-id" +" self_16" +" bulk-binding-registry-id" +" bulk-binding-registry_12" +" inspector-id" +" inspector_12" +" 'swap-top-level-scopes" +" swap-top-level-scopes))))))))))" +"(define-values" +"(empty-eager-instance-instance)" +"(let-values(((temp14_3) #f)((temp15_3) #f)((temp16_3) #f)((temp17_2) #f)((temp18_4) #f))" +"(make-eager-instance-instance11.1 temp17_2 temp15_3 temp18_4 temp14_3 temp16_3)))" +"(define-values" +"(self-quoting-in-linklet?)" +"(lambda(datum_0)" +"(begin" +"(let-values(((or-part_0)(number? datum_0)))" +"(if or-part_0" +" or-part_0" +"(let-values(((or-part_1)(boolean? datum_0)))" +"(if or-part_1" +" or-part_1" +"(let-values(((or-part_11)(string? datum_0)))(if or-part_11 or-part_11(bytes? datum_0))))))))))" +"(define-values(datum->syntax$3) datum->syntax)" +"(define-values(syntax-property$2) syntax-property)" +"(define-values(syntax-e$2) syntax-e)" +"(define-values(1/syntax?) syntax?)" +"(define-values(correlated?)(lambda(e_25)(begin(1/syntax? e_25))))" +"(define-values" +"(datum->correlated)" +"(let-values(((datum->correlated3_0)" +"(lambda(d2_0 srcloc1_0)" +"(begin" +" 'datum->correlated3" +"(let-values(((d_26) d2_0))" +"(let-values(((srcloc_6) srcloc1_0))(let-values()(datum->syntax$3 #f d_26 srcloc_6))))))))" +"(case-lambda" +"((d_27)(begin(datum->correlated3_0 d_27 #f)))" +"((d_28 srcloc1_1)(datum->correlated3_0 d_28 srcloc1_1)))))" +"(define-values(correlated-e)(lambda(e_26)(begin(if(1/syntax? e_26)(syntax-e$2 e_26) e_26))))" +"(define-values(correlated-cadr)(lambda(e_27)(begin(car(correlated-e(cdr(correlated-e e_27)))))))" +"(define-values" +"(correlated-length)" +"(lambda(e_28)(begin(let-values(((l_54)(correlated-e e_28)))(if(list? l_54)(length l_54) #f)))))" +"(define-values" +"(correlated->list)" +"(lambda(e_29)" +"(begin" +"((letrec-values(((loop_91)" +"(lambda(e_30)" +"(begin" +" 'loop" +"(if(list? e_30)" +"(let-values() e_30)" +"(if(pair? e_30)" +"(let-values()(cons(car e_30)(loop_91(cdr e_30))))" +"(if(null? e_30)" +"(let-values() null)" +"(if(1/syntax? e_30)" +"(let-values()(loop_91(syntax-e$2 e_30)))" +" (let-values () (error 'correlated->list \"not a list\"))))))))))" +" loop_91)" +" e_29))))" +"(define-values" +"(correlated-property)" +"(case-lambda" +"((e_31 k_31)(begin(syntax-property$2 e_31 k_31)))" +"((e_32 k_32 v_163)(syntax-property$2 e_32 k_32 v_163))))" +"(define-values" +"(to-syntax-list.1$1)" +"(lambda(s_109)" +"(begin" +" 'to-syntax-list" +"(if(list? s_109)" +"(let-values() s_109)" +"(if(pair? s_109)" +"(let-values()(let-values(((r_39)(to-syntax-list.1$1(cdr s_109))))(if r_39(cons(car s_109) r_39) #f)))" +"(if(1/syntax? s_109)(let-values()(to-syntax-list.1$1(syntax-e$2 s_109)))(let-values() #f)))))))" +"(define-values" +"(srcloc->vector)" +"(lambda(s_80)" +"(begin" +"(if s_80" +"(vector(srcloc-source s_80)(srcloc-line s_80)(srcloc-column s_80)(srcloc-position s_80)(srcloc-span s_80))" +" #f))))" +"(define-values" +"(correlate*)" +"(lambda(stx_15 s-exp_0)" +"(begin(if(syntax-srcloc stx_15)(datum->correlated s-exp_0(srcloc->vector(syntax-srcloc stx_15))) s-exp_0))))" +"(define-values(correlate~)(lambda(stx_16 s-exp_1)(begin s-exp_1)))" +"(define-values" +"(correlate/app)" +"(lambda(stx_17 s-exp_2)" +"(begin(if(eq?(system-type 'vm) 'chez-scheme)(correlate* stx_17 s-exp_2)(correlate~ stx_17 s-exp_2)))))" +"(define-values(->correlated)(lambda(s_2)(begin(datum->correlated s_2 #f))))" +"(define-values" +"(compile$2)" +"(let-values(((compile5_0)" +"(lambda(p3_0 cctx4_0 name1_0 result-used?2_0)" +"(begin" +" 'compile5" +"(let-values(((p_37) p3_0))" +"(let-values(((cctx_1) cctx4_0))" +"(let-values(((name_40) name1_0))" +"(let-values(((result-used?_0) result-used?2_0))" +"(let-values()" +"(let-values(((compile_0)" +"(lambda(p_38 name_4 result-used?_1)" +"(begin 'compile(compile$2 p_38 cctx_1 name_4 result-used?_1)))))" +"(let-values(((s_170)(parsed-s p_37)))" +"(if(parsed-id? p_37)" +"(let-values()" +"(let-values(((p25_0) p_37)((cctx26_0) cctx_1))" +"(compile-identifier22.1 #f #f p25_0 cctx26_0)))" +"(if(parsed-lambda? p_37)" +"(let-values()" +"(if result-used?_0" +"(let-values()" +"(add-lambda-properties" +"(correlate*" +" s_170" +"(list*" +" 'lambda" +"(compile-lambda" +"(parsed-lambda-keys p_37)" +"(parsed-lambda-body p_37)" +" cctx_1)))" +" name_40" +" s_170))" +"(let-values()(correlate~ s_170 ''unused-lambda))))" +"(if(parsed-case-lambda? p_37)" +"(let-values()" +"(if result-used?_0" +"(let-values()" +"(add-lambda-properties" +"(correlate*" +" s_170" +"(list*" +" 'case-lambda" +"(reverse$1" +"(let-values(((lst_86)(parsed-case-lambda-clauses p_37)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_86)))" +"((letrec-values(((for-loop_108)" +"(lambda(fold-var_69 lst_87)" +"(begin" +" 'for-loop" +"(if(pair? lst_87)" +"(let-values(((clause_0)" +"(unsafe-car lst_87))" +"((rest_41)" +"(unsafe-cdr lst_87)))" +"(let-values(((fold-var_70)" +"(let-values(((fold-var_27)" +" fold-var_69))" +"(let-values(((fold-var_28)" +"(let-values()" +"(cons" +"(let-values()" +"(compile-lambda" +"(car" +" clause_0)" +"(cadr" +" clause_0)" +" cctx_1))" +" fold-var_27))))" +"(values" +" fold-var_28)))))" +"(if(not #f)" +"(for-loop_108 fold-var_70 rest_41)" +" fold-var_70)))" +" fold-var_69)))))" +" for-loop_108)" +" null" +" lst_86))))))" +" name_40" +" s_170))" +"(let-values()(correlate~ s_170 ''unused-case-lambda))))" +"(if(parsed-app? p_37)" +"(let-values()" +"(let-values(((rands_0)(parsed-app-rands p_37)))" +"(correlate/app" +" s_170" +"(cons" +"(compile_0(parsed-app-rator p_37) #f #t)" +"(reverse$1" +"(let-values(((lst_88) rands_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_88)))" +"((letrec-values(((for-loop_191)" +"(lambda(fold-var_157 lst_163)" +"(begin" +" 'for-loop" +"(if(pair? lst_163)" +"(let-values(((r_40)(unsafe-car lst_163))" +"((rest_84)" +"(unsafe-cdr lst_163)))" +"(let-values(((fold-var_33)" +"(let-values(((fold-var_34)" +" fold-var_157))" +"(let-values(((fold-var_158)" +"(let-values()" +"(cons" +"(let-values()" +"(compile_0" +" r_40" +" #f" +" #t))" +" fold-var_34))))" +"(values" +" fold-var_158)))))" +"(if(not #f)" +"(for-loop_191 fold-var_33 rest_84)" +" fold-var_33)))" +" fold-var_157)))))" +" for-loop_191)" +" null" +" lst_88))))))))" +"(if(parsed-if? p_37)" +"(let-values()" +"(let-values(((tst-e_0)(compile_0(parsed-if-tst p_37) #f #f)))" +"(if(eq?(correlated-e tst-e_0) #t)" +"(let-values()" +"(compile_0(parsed-if-thn p_37) name_40 result-used?_0))" +"(if(eq?(correlated-e tst-e_0) #f)" +"(let-values()" +"(compile_0(parsed-if-els p_37) name_40 result-used?_0))" +"(let-values()" +"(correlate~" +" s_170" +"(list" +" 'if" +" tst-e_0" +"(compile_0(parsed-if-thn p_37) name_40 result-used?_0)" +"(compile_0(parsed-if-els p_37) name_40 result-used?_0))))))))" +"(if(parsed-with-continuation-mark? p_37)" +"(let-values()" +"(correlate~" +" s_170" +"(list" +" 'with-continuation-mark" +"(compile_0(parsed-with-continuation-mark-key p_37) #f #t)" +"(compile_0(parsed-with-continuation-mark-val p_37) #f #t)" +"(compile_0" +"(parsed-with-continuation-mark-body p_37)" +" name_40" +" result-used?_0))))" +"(if(parsed-begin0? p_37)" +"(let-values()" +"(correlate~" +" s_170" +"(list*" +" 'begin0" +"(compile_0(car(parsed-begin0-body p_37)) name_40 result-used?_0)" +"(reverse$1" +"(let-values(((lst_23)(cdr(parsed-begin0-body p_37))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_23)))" +"((letrec-values(((for-loop_192)" +"(lambda(fold-var_159 lst_79)" +"(begin" +" 'for-loop" +"(if(pair? lst_79)" +"(let-values(((e_33)" +"(unsafe-car lst_79))" +"((rest_85)" +"(unsafe-cdr lst_79)))" +"(let-values(((fold-var_160)" +"(let-values(((fold-var_94)" +" fold-var_159))" +"(let-values(((fold-var_95)" +"(let-values()" +"(cons" +"(let-values()" +"(compile_0" +" e_33" +" #f" +" #f))" +" fold-var_94))))" +"(values" +" fold-var_95)))))" +"(if(not #f)" +"(for-loop_192" +" fold-var_160" +" rest_85)" +" fold-var_160)))" +" fold-var_159)))))" +" for-loop_192)" +" null" +" lst_23)))))))" +"(if(parsed-begin? p_37)" +"(let-values()" +"(correlate~" +" s_170" +"(compile-begin" +"(parsed-begin-body p_37)" +" cctx_1" +" name_40" +" result-used?_0)))" +"(if(parsed-set!? p_37)" +"(let-values()" +"(correlate~" +" s_170" +"(let-values(((temp27_4)(parsed-set!-id p_37))" +"((cctx28_0) cctx_1)" +"((temp29_1) #t)" +"((temp30_1)" +"(compile_0" +"(parsed-set!-rhs p_37)" +"(parsed-s(parsed-set!-id p_37))" +" #t)))" +"(compile-identifier22.1 temp30_1 temp29_1 temp27_4 cctx28_0))))" +"(if(parsed-let-values? p_37)" +"(let-values()" +"(let-values(((p31_0) p_37)" +"((cctx32_0) cctx_1)" +"((name33_0) name_40)" +"((temp34_1) #f)" +"((result-used?35_0) result-used?_0))" +"(compile-let13.1" +" temp34_1" +" p31_0" +" cctx32_0" +" name33_0" +" result-used?35_0)))" +"(if(parsed-letrec-values? p_37)" +"(let-values()" +"(let-values(((p36_0) p_37)" +"((cctx37_0) cctx_1)" +"((name38_0) name_40)" +"((temp39_0) #t)" +"((result-used?40_0) result-used?_0))" +"(compile-let13.1" +" temp39_0" +" p36_0" +" cctx37_0" +" name38_0" +" result-used?40_0)))" +"(if(parsed-quote? p_37)" +"(let-values()" +"(let-values(((datum_1)(parsed-quote-datum p_37)))" +"(if(self-quoting-in-linklet? datum_1)" +"(let-values()(correlate~ s_170 datum_1))" +"(let-values()" +"(correlate~ s_170(list 'quote datum_1))))))" +"(if(parsed-quote-syntax? p_37)" +"(let-values()" +"(if result-used?_0" +"(compile-quote-syntax" +"(parsed-quote-syntax-datum p_37)" +" cctx_1)" +"(correlate~" +" s_170" +"(list 'quote(syntax->datum$1 s_170)))))" +"(if(parsed-#%variable-reference? p_37)" +"(let-values()" +"(let-values(((id_46)" +"(parsed-#%variable-reference-id p_37)))" +"(correlate~" +" s_170" +"(if id_46" +"(list" +" '#%variable-reference" +"(let-values(((id41_0) id_46)((cctx42_0) cctx_1))" +"(compile-identifier22.1 #f #f id41_0 cctx42_0)))" +" '(#%variable-reference)))))" +"(let-values()" +"(error" +" \"unrecognized parsed form:\"" +" p_37)))))))))))))))))))))))))))" +"(case-lambda" +"((p_39 cctx_2)(begin 'compile(compile5_0 p_39 cctx_2 #f #t)))" +"((p_40 cctx_3 name_41 result-used?2_1)(compile5_0 p_40 cctx_3 name_41 result-used?2_1))" +"((p_41 cctx_4 name1_1)(compile5_0 p_41 cctx_4 name1_1 #t)))))" +"(define-values" +"(compile-lambda)" +"(lambda(formals_0 bodys_0 cctx_5)(begin(list formals_0(compile-sequence bodys_0 cctx_5 #f #t)))))" +"(define-values" +"(compile-sequence)" +"(lambda(bodys_1 cctx_6 name_42 result-used?_2)" +"(begin" +"(if(null?(cdr bodys_1))" +"(compile$2(car bodys_1) cctx_6 name_42 result-used?_2)" +"(compile-begin bodys_1 cctx_6 name_42 result-used?_2)))))" +"(define-values" +"(compile-begin)" +"(lambda(es_0 cctx_7 name_43 result-used?_3)" +"(begin" +"(let-values(((used-pos_0)(sub1(length es_0))))" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_164) es_0)((start_33) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_164)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_33)))" +"((letrec-values(((for-loop_193)" +"(lambda(fold-var_161 lst_165 pos_91)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_165) #t #f)" +"(let-values(((e_4)(unsafe-car lst_165))" +"((rest_86)(unsafe-cdr lst_165))" +"((i_135) pos_91))" +"(let-values(((fold-var_162)" +"(let-values(((fold-var_163) fold-var_161))" +"(let-values(((fold-var_164)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((used?_0)" +"(= i_135 used-pos_0)))" +"(compile$2" +" e_4" +" cctx_7" +"(if used?_0 name_43 #f)" +"(if used?_0 result-used?_3 #f))))" +" fold-var_163))))" +"(values fold-var_164)))))" +"(if(not #f)(for-loop_193 fold-var_162 rest_86(+ pos_91 1)) fold-var_162)))" +" fold-var_161)))))" +" for-loop_193)" +" null" +" lst_164" +" start_33)))))))))" +"(define-values" +"(add-lambda-properties)" +"(lambda(s_306 inferred-name_0 orig-s_21)" +"(begin" +"(letrec-values(((simplify-name_0)" +"(lambda(v_164)" +"(begin" +" 'simplify-name" +"(if(pair? v_164)" +"(let-values()" +"(let-values(((n1_0)(simplify-name_0(car v_164))))" +"(let-values(((n2_0)(simplify-name_0(cdr v_164))))(if(eq? n1_0 n2_0) n1_0 v_164))))" +"(let-values() v_164))))))" +"(let-values(((name_44)" +"(let-values(((or-part_210)" +"(let-values(((v_54)" +"(simplify-name_0(syntax-property$1 orig-s_21 'inferred-name))))" +"(if(let-values(((or-part_211)(symbol? v_54)))" +"(if or-part_211" +" or-part_211" +"(let-values(((or-part_212)(syntax?$1 v_54)))" +"(if or-part_212 or-part_212(void? v_54)))))" +" v_54" +" #f))))" +"(if or-part_210 or-part_210 inferred-name_0))))" +"(let-values(((named-s_0)" +"(if name_44" +"(correlated-property" +"(->correlated s_306)" +" 'inferred-name" +"(if(syntax?$1 name_44)(syntax-e$1 name_44) name_44))" +" s_306)))" +"(let-values(((as-method_0)(syntax-property$1 orig-s_21 'method-arity-error)))" +"(if as-method_0" +"(correlated-property(->correlated named-s_0) 'method-arity-error as-method_0)" +" named-s_0))))))))" +"(define-values" +"(compile-let13.1)" +"(lambda(rec?7_0 p9_0 cctx10_0 name11_0 result-used?12_0)" +"(begin" +" 'compile-let13" +"(let-values(((p_42) p9_0))" +"(let-values(((cctx_8) cctx10_0))" +"(let-values(((name_45) name11_0))" +"(let-values(((rec?_0) rec?7_0))" +"(let-values(((result-used?_4) result-used?12_0))" +"(let-values()" +"(let-values(((body_0)(parsed-let_-values-body p_42)))" +"(correlate~" +"(parsed-s p_42)" +"(list" +"(if rec?_0 'letrec-values 'let-values)" +"(reverse$1" +"(let-values(((lst_166)(parsed-let_-values-clauses p_42))" +"((lst_167)(parsed-let_-values-idss p_42)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_166)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_167)))" +"((letrec-values(((for-loop_194)" +"(lambda(fold-var_165 lst_168 lst_169)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_168)(pair? lst_169) #f)" +"(let-values(((clause_1)(unsafe-car lst_168))" +"((rest_87)(unsafe-cdr lst_168))" +"((ids_4)(unsafe-car lst_169))" +"((rest_88)(unsafe-cdr lst_169)))" +"(let-values(((fold-var_166)" +"(let-values(((fold-var_167) fold-var_165))" +"(let-values(((fold-var_168)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +"(if rec?_0" +"(reverse$1" +"(let-values(((lst_170)" +"(car" +" clause_1))" +"((lst_171)" +" ids_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_170)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_171)))" +"((letrec-values(((for-loop_195)" +"(lambda(fold-var_169" +" lst_172" +" lst_173)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_172)" +"(pair?" +" lst_173)" +" #f)" +"(let-values(((sym_56)" +"(unsafe-car" +" lst_172))" +"((rest_89)" +"(unsafe-cdr" +" lst_172))" +"((id_47)" +"(unsafe-car" +" lst_173))" +"((rest_90)" +"(unsafe-cdr" +" lst_173)))" +"(let-values(((fold-var_2)" +"(let-values(((fold-var_3)" +" fold-var_169))" +"(let-values(((fold-var_97)" +"(let-values()" +"(cons" +"(let-values()" +"(add-undefined-error-name-property" +" sym_56" +" id_47))" +" fold-var_3))))" +"(values" +" fold-var_97)))))" +"(if(not" +" #f)" +"(for-loop_195" +" fold-var_2" +" rest_89" +" rest_90)" +" fold-var_2)))" +" fold-var_169)))))" +" for-loop_195)" +" null" +" lst_170" +" lst_171))))" +"(car clause_1))" +"(compile$2" +"(cadr clause_1)" +" cctx_8" +"(if(= 1(length ids_4))" +"(car ids_4)" +" #f))))" +" fold-var_167))))" +"(values fold-var_168)))))" +"(if(not #f)" +"(for-loop_194 fold-var_166 rest_87 rest_88)" +" fold-var_166)))" +" fold-var_165)))))" +" for-loop_194)" +" null" +" lst_166" +" lst_167))))" +"(compile-sequence body_0 cctx_8 name_45 result-used?_4)))))))))))))" +"(define-values" +"(add-undefined-error-name-property)" +"(lambda(sym_54 orig-id_0)" +"(begin" +"(let-values(((id_48)(correlate~ orig-id_0 sym_54)))" +"(correlated-property" +"(->correlated id_48)" +" 'undefined-error-name" +"(let-values(((or-part_213)(syntax-property$1 orig-id_0 'undefined-error-name)))" +"(if or-part_213 or-part_213(syntax-e$1 orig-id_0))))))))" +"(define-values" +"(compile-identifier22.1)" +"(lambda(set-to17_0 set-to?16_0 p20_0 cctx21_0)" +"(begin" +" 'compile-identifier22" +"(let-values(((p_43) p20_0))" +"(let-values(((cctx_9) cctx21_0))" +"(let-values(((set-to?_0) set-to?16_0))" +"(let-values(((rhs_0) set-to17_0))" +"(let-values()" +"(let-values(((normal-b_0)(parsed-id-binding p_43)))" +"(let-values(((b_74)" +"(let-values(((or-part_214) normal-b_0))" +"(if or-part_214" +" or-part_214" +"(let-values(((temp43_0)(compile-context-self cctx_9))" +"((temp44_0)(compile-context-phase cctx_9))" +"((temp45_0)(syntax-e$1(parsed-s p_43))))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" temp43_0" +" temp44_0" +" temp45_0))))))" +"(let-values(((sym_57)" +"(if(local-binding? b_74)" +"(let-values()(local-binding-key b_74))" +"(if(module-binding? b_74)" +"(let-values()" +"(let-values(((mpi_40)" +"(if(parsed-top-id? p_43)" +"(compile-context-self cctx_9)" +"(module-binding-module b_74))))" +"(if(parsed-primitive-id? p_43)" +"(let-values()" +"(begin" +"(if(zero?(module-binding-phase b_74))" +"(void)" +"(let-values()" +" (error \"internal error: non-zero phase for a primitive\")))" +"(if set-to?_0" +"(let-values()" +"(error" +" \"internal error: cannot assign to a primitive:\"" +"(module-binding-sym b_74)))" +"(void))" +"(module-binding-sym b_74)))" +"(if(eq? mpi_40(compile-context-module-self cctx_9))" +"(let-values()" +"(let-values(((header_6)(compile-context-header cctx_9)))" +"(hash-ref" +"(header-binding-sym-to-define-sym header_6)" +"(module-binding-sym b_74))))" +"(let-values()" +"(let-values(((temp46_0)(compile-context-header cctx_9))" +"((mpi47_0) mpi_40)" +"((temp48_0)(module-binding-phase b_74))" +"((temp49_0)(module-binding-sym b_74))" +"((temp50_0)" +"(let-values(((or-part_215)" +"(module-binding-extra-inspector b_74)))" +"(if or-part_215" +" or-part_215" +"(let-values(((or-part_216)" +"(parsed-id-inspector p_43)))" +"(if or-part_216" +" or-part_216" +"(if(parsed-s p_43)" +"(syntax-inspector(parsed-s p_43))" +" #f)))))))" +"(register-required-variable-use!19.1" +" #f" +" temp46_0" +" mpi47_0" +" temp48_0" +" temp49_0" +" temp50_0)))))))" +"(let-values()" +"(error" +" \"not a reference to a module or local binding:\"" +" b_74" +"(parsed-s p_43)))))))" +"(correlate~(parsed-s p_43)(if set-to?_0(list 'set! sym_57 rhs_0) sym_57)))))))))))))" +"(define-values" +"(compile-quote-syntax)" +"(lambda(q_1 cctx_10)" +"(begin" +"(let-values(((pos_92)(add-syntax-literal!(compile-context-header cctx_10) q_1)))" +"(if(compile-context-lazy-syntax-literals? cctx_10)" +"(let-values()(generate-lazy-syntax-literal-lookup pos_92))" +"(let-values()(generate-eager-syntax-literal-lookup pos_92)))))))" +"(define-values" +"(extra-inspectors-allow?)" +"(lambda(extra-inspectors_2 guard-insp_0)" +"(begin" +"(if(not extra-inspectors_2)" +"(let-values() #f)" +"(if(set? extra-inspectors_2)" +"(let-values()" +"(let-values(((ht_112) extra-inspectors_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_112)))" +"((letrec-values(((for-loop_97)" +"(lambda(result_77 i_136)" +"(begin" +" 'for-loop" +"(if i_136" +"(let-values(((extra-insp_0)(unsafe-immutable-hash-iterate-key ht_112 i_136)))" +"(let-values(((result_78)" +"(let-values()" +"(let-values(((result_79)" +"(let-values()" +"(let-values()" +"(inspector-superior?" +" extra-insp_0" +" guard-insp_0)))))" +"(values result_79)))))" +"(if(if(not((lambda x_56(not result_78)) extra-insp_0))(not #f) #f)" +"(for-loop_97 result_78(unsafe-immutable-hash-iterate-next ht_112 i_136))" +" result_78)))" +" result_77)))))" +" for-loop_97)" +" #t" +"(unsafe-immutable-hash-iterate-first ht_112)))))" +"(if(procedure? extra-inspectors_2)" +"(let-values()(extra-inspectors_2 guard-insp_0))" +"(let-values()" +"(error" +" 'extra-inspectors-allow?" +" \"unknown representation of extra inspectors: ~e\"" +" extra-inspectors_2))))))))" +"(define-values" +"(extra-inspectors-merge)" +"(lambda(extra-inspectors-1_0 extra-inspectors-2_0)" +"(begin" +"(if(let-values(((or-part_217)(not extra-inspectors-1_0)))" +"(if or-part_217 or-part_217(not extra-inspectors-2_0)))" +"(let-values() #f)" +"(if(if(set? extra-inspectors-1_0)(set? extra-inspectors-2_0) #f)" +"(let-values()(set-union extra-inspectors-1_0 extra-inspectors-2_0))" +"(let-values()" +"(lambda(guard-insp_1)" +"(if(extra-inspectors-allow? extra-inspectors-1_0 guard-insp_1)" +"(extra-inspectors-allow? extra-inspectors-2_0 guard-insp_1)" +" #f))))))))" +"(define-values" +"(struct:module-use*" +" module-use*1.1" +" module-use*?" +" module-use*-extra-inspectorss" +" module-use*-self-inspector" +" set-module-use*-extra-inspectorss!" +" set-module-use*-self-inspector!)" +"(let-values(((struct:_70 make-_70 ?_70 -ref_70 -set!_70)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-use*" +" struct:module-use" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'module-use*)))))" +"(values" +" struct:_70" +" make-_70" +" ?_70" +"(make-struct-field-accessor -ref_70 0 'extra-inspectorss)" +"(make-struct-field-accessor -ref_70 1 'self-inspector)" +"(make-struct-field-mutator -set!_70 0 'extra-inspectorss)" +"(make-struct-field-mutator -set!_70 1 'self-inspector))))" +"(define-values" +"(module-uses-add-extra-inspectorsss)" +"(lambda(mus_1 extra-inspectorsss_0)" +"(begin" +"(if extra-inspectorsss_0" +"(let-values()" +"(reverse$1" +"(let-values(((lst_104) mus_1)((lst_90) extra-inspectorsss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_104)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_90)))" +"((letrec-values(((for-loop_110)" +"(lambda(fold-var_11 lst_91 lst_174)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_91)(pair? lst_174) #f)" +"(let-values(((mu_5)(unsafe-car lst_91))" +"((rest_91)(unsafe-cdr lst_91))" +"((extra-inspectorss_1)(unsafe-car lst_174))" +"((rest_37)(unsafe-cdr lst_174)))" +"(let-values(((fold-var_170)" +"(let-values(((fold-var_171) fold-var_11))" +"(let-values(((fold-var_172)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*1.1" +"(module-use-module mu_5)" +"(module-use-phase mu_5)" +" extra-inspectorss_1" +" #f))" +" fold-var_171))))" +"(values fold-var_172)))))" +"(if(not #f)(for-loop_110 fold-var_170 rest_91 rest_37) fold-var_170)))" +" fold-var_11)))))" +" for-loop_110)" +" null" +" lst_104" +" lst_90)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_92) mus_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_92)))" +"((letrec-values(((for-loop_196)" +"(lambda(fold-var_173 lst_17)" +"(begin" +" 'for-loop" +"(if(pair? lst_17)" +"(let-values(((mu_6)(unsafe-car lst_17))((rest_92)(unsafe-cdr lst_17)))" +"(let-values(((fold-var_74)" +"(let-values(((fold-var_64) fold-var_173))" +"(let-values(((fold-var_174)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*1.1" +"(module-use-module mu_6)" +"(module-use-phase mu_6)" +" #f" +" #f))" +" fold-var_64))))" +"(values fold-var_174)))))" +"(if(not #f)(for-loop_196 fold-var_74 rest_92) fold-var_74)))" +" fold-var_173)))))" +" for-loop_196)" +" null" +" lst_92)))))))))" +"(define-values" +"(module-uses-strip-extra-inspectorsss)" +"(lambda(mu*s_0)" +"(begin" +"(reverse$1" +"(let-values(((lst_175) mu*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_175)))" +"((letrec-values(((for-loop_197)" +"(lambda(fold-var_76 lst_176)" +"(begin" +" 'for-loop" +"(if(pair? lst_176)" +"(let-values(((mu*_0)(unsafe-car lst_176))((rest_93)(unsafe-cdr lst_176)))" +"(let-values(((fold-var_17)" +"(let-values(((fold-var_66) fold-var_76))" +"(let-values(((fold-var_67)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use1.1" +"(module-use-module mu*_0)" +"(module-use-phase mu*_0)))" +" fold-var_66))))" +"(values fold-var_67)))))" +"(if(not #f)(for-loop_197 fold-var_17 rest_93) fold-var_17)))" +" fold-var_76)))))" +" for-loop_197)" +" null" +" lst_175)))))))" +"(define-values" +"(module-uses-extract-extra-inspectorsss)" +"(lambda(mu*s_1 linklet_0 check-inlined-reference?_0 skip-n_0)" +"(begin" +"(if(not check-inlined-reference?_0)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_177) mu*s_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_177)))" +"((letrec-values(((for-loop_198)" +"(lambda(fold-var_79 lst_96)" +"(begin" +" 'for-loop" +"(if(pair? lst_96)" +"(let-values(((mu*_1)(unsafe-car lst_96))((rest_94)(unsafe-cdr lst_96)))" +"(let-values(((fold-var_175)" +"(let-values(((fold-var_4) fold-var_79))" +"(let-values(((fold-var_68)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*-extra-inspectorss mu*_1))" +" fold-var_4))))" +"(values fold-var_68)))))" +"(if(not #f)(for-loop_198 fold-var_175 rest_94) fold-var_175)))" +" fold-var_79)))))" +" for-loop_198)" +" null" +" lst_177)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_178) mu*s_1)((lst_179)(list-tail(1/linklet-import-variables linklet_0) skip-n_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_178)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_179)))" +"((letrec-values(((for-loop_28)" +"(lambda(fold-var_6 lst_180 lst_164)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_180)(pair? lst_164) #f)" +"(let-values(((mu*_2)(unsafe-car lst_180))" +"((rest_95)(unsafe-cdr lst_180))" +"((imports_0)(unsafe-car lst_164))" +"((rest_96)(unsafe-cdr lst_164)))" +"(let-values(((fold-var_176)" +"(let-values(((fold-var_177) fold-var_6))" +"(let-values(((fold-var_178)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((extra-inspectorss_2)" +"(module-use*-extra-inspectorss" +" mu*_2)))" +"(let-values(((lst_99) imports_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_99)))" +"((letrec-values(((for-loop_19)" +"(lambda(extra-inspectorss_3" +" lst_181)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_181)" +"(let-values(((import_0)" +"(unsafe-car" +" lst_181))" +"((rest_97)" +"(unsafe-cdr" +" lst_181)))" +"(let-values(((extra-inspectorss_4)" +"(let-values(((extra-inspectorss_5)" +" extra-inspectorss_3))" +"(let-values(((extra-inspectorss_6)" +"(let-values()" +"(if(eq?" +"(hash-ref" +" extra-inspectorss_5" +" import_0" +" '#:not-recorded)" +" '#:not-recorded)" +"(let-values()" +"(hash-set" +" extra-inspectorss_5" +" import_0" +"(set" +"(module-use*-self-inspector" +" mu*_2))))" +"(let-values()" +" extra-inspectorss_5)))))" +"(values" +" extra-inspectorss_6)))))" +"(if(not" +" #f)" +"(for-loop_19" +" extra-inspectorss_4" +" rest_97)" +" extra-inspectorss_4)))" +" extra-inspectorss_3)))))" +" for-loop_19)" +" extra-inspectorss_2" +" lst_99)))))" +" fold-var_177))))" +"(values fold-var_178)))))" +"(if(not #f)(for-loop_28 fold-var_176 rest_95 rest_96) fold-var_176)))" +" fold-var_6)))))" +" for-loop_28)" +" null" +" lst_178" +" lst_179)))))))))" +"(define-values" +"(module-use*-declaration-inspector!)" +"(lambda(mu*_3 insp_9)(begin(set-module-use*-self-inspector! mu*_3 insp_9))))" +"(define-values" +"(module-use+extra-inspectors)" +"(lambda(mpi_41 phase_72 imports_1 inspector_13 extra-inspector_5 extra-inspectorss_7)" +"(begin" +"(let-values(((now-inspector_0)(current-code-inspector)))" +"(let-values(((add-insp?_0)(if inspector_13(inspector-superior? inspector_13 now-inspector_0) #f)))" +"(let-values(((add-extra-insp?_0)" +"(if extra-inspector_5(inspector-superior? extra-inspector_5 now-inspector_0) #f)))" +"(let-values(((new-extra-inspectorss_0)" +"(if(let-values(((or-part_218) add-insp?_0))(if or-part_218 or-part_218 add-extra-insp?_0))" +"(let-values()" +"(let-values(((lst_182) imports_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_182)))" +"((letrec-values(((for-loop_199)" +"(lambda(table_147 lst_183)" +"(begin" +" 'for-loop" +"(if(pair? lst_183)" +"(let-values(((import_1)(unsafe-car lst_183))" +"((rest_98)(unsafe-cdr lst_183)))" +"(let-values(((table_148)" +"(let-values(((table_149) table_147))" +"(let-values(((table_150)" +"(let-values()" +"(let-values(((key_57" +" val_50)" +"(let-values()" +"(values" +" import_1" +"(let-values(((extra-inspectors_3)" +"(if extra-inspectorss_7" +"(hash-ref" +" extra-inspectorss_7" +" import_1" +" #f)" +" #f)))" +"(lambda(guard-insp_2)" +"(let-values(((or-part_219)" +"(if add-insp?_0" +"(inspector-superior?" +" inspector_13" +" guard-insp_2)" +" #f)))" +"(if or-part_219" +" or-part_219" +"(let-values(((or-part_100)" +"(if add-extra-insp?_0" +"(inspector-superior?" +" extra-inspector_5" +" guard-insp_2)" +" #f)))" +"(if or-part_100" +" or-part_100" +"(extra-inspectors-allow?" +" extra-inspectors_3" +" guard-insp_2)))))))))))" +"(hash-set" +" table_149" +" key_57" +" val_50)))))" +"(values table_150)))))" +"(if(not #f)(for-loop_199 table_148 rest_98) table_148)))" +" table_147)))))" +" for-loop_199)" +" '#hash()" +" lst_182))))" +"(let-values()" +"(let-values(((lst_184) imports_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_184)))" +"((letrec-values(((for-loop_200)" +"(lambda(extra-inspectorss_8 lst_167)" +"(begin" +" 'for-loop" +"(if(pair? lst_167)" +"(let-values(((import_2)(unsafe-car lst_167))" +"((rest_99)(unsafe-cdr lst_167)))" +"(let-values(((extra-inspectorss_9)" +"(let-values(((extra-inspectorss_10)" +" extra-inspectorss_8))" +"(let-values(((extra-inspectorss_11)" +"(let-values()" +"(if(hash-ref" +" extra-inspectorss_10" +" import_2" +" #f)" +" extra-inspectorss_10" +"(hash-set" +" extra-inspectorss_10" +" import_2" +" #f)))))" +"(values extra-inspectorss_11)))))" +"(if(not #f)" +"(for-loop_200 extra-inspectorss_9 rest_99)" +" extra-inspectorss_9)))" +" extra-inspectorss_8)))))" +" for-loop_200)" +"(let-values(((or-part_38) extra-inspectorss_7))(if or-part_38 or-part_38(seteq)))" +" lst_184)))))))" +"(module-use*1.1 mpi_41 phase_72 new-extra-inspectorss_0 #f))))))))" +"(define-values" +"(module-use-merge-extra-inspectorss!)" +"(lambda(existing-mu*_0 mu*_4)" +"(begin" +"(let-values(((extra-inspectorss_12)(module-use*-extra-inspectorss mu*_4)))" +"(let-values(((existing-extra-inspectorss_0)(module-use*-extra-inspectorss existing-mu*_0)))" +"(let-values(((new-extra-inspectorss_1)" +"(let-values(((ht_113) extra-inspectorss_12))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_113)))" +"((letrec-values(((for-loop_201)" +"(lambda(new-extra-inspectorss_2 i_137)" +"(begin" +" 'for-loop" +"(if i_137" +"(let-values(((sym_58 extra-inspectors_4)" +"(hash-iterate-key+value ht_113 i_137)))" +"(let-values(((new-extra-inspectorss_3)" +"(let-values(((new-extra-inspectorss_4)" +" new-extra-inspectorss_2))" +"(let-values(((new-extra-inspectorss_5)" +"(let-values()" +"(hash-set" +" new-extra-inspectorss_4" +" sym_58" +"(extra-inspectors-merge" +" extra-inspectors_4" +"(hash-ref" +" new-extra-inspectorss_4" +" sym_58" +"(seteq)))))))" +"(values new-extra-inspectorss_5)))))" +"(if(not #f)" +"(for-loop_201" +" new-extra-inspectorss_3" +"(hash-iterate-next ht_113 i_137))" +" new-extra-inspectorss_3)))" +" new-extra-inspectorss_2)))))" +" for-loop_201)" +" existing-extra-inspectorss_0" +"(hash-iterate-first ht_113))))))" +"(set-module-use*-extra-inspectorss! existing-mu*_0 new-extra-inspectorss_1)))))))" +"(define-values" +"(struct:link-info" +" link-info1.1" +" link-info?" +" link-info-link-module-uses" +" link-info-imports" +" link-info-extra-inspectorsss" +" link-info-def-decls)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type 'link-info #f 4 0 #f null(current-inspector) #f '(0 1 2 3) #f 'link-info)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'link-module-uses)" +"(make-struct-field-accessor -ref_36 1 'imports)" +"(make-struct-field-accessor -ref_36 2 'extra-inspectorsss)" +"(make-struct-field-accessor -ref_36 3 'def-decls))))" +"(define-values" +"(compile-forms31.1)" +"(lambda(body-import-instances3_0" +" body-imports2_0" +" body-suffix-forms4_0" +" compiled-expression-callback8_0" +" cross-linklet-inlining?14_0" +" definition-callback9_0" +" encoded-root-expand-ctx-box6_0" +" force-phases5_0" +" get-module-linklet-info11_0" +" other-form-callback10_0" +" root-ctx-only-if-syntax?7_0" +" serializable?13_0" +" to-source?12_0" +" bodys28_0" +" cctx29_0" +" mpis30_0)" +"(begin" +" 'compile-forms31" +"(let-values(((bodys_2) bodys28_0))" +"(let-values(((cctx_11) cctx29_0))" +"(let-values(((mpis_15) mpis30_0))" +"(let-values(((body-imports_0) body-imports2_0))" +"(let-values(((body-import-instances_0) body-import-instances3_0))" +"(let-values(((body-suffix-forms_0) body-suffix-forms4_0))" +"(let-values(((force-phases_0) force-phases5_0))" +"(let-values(((encoded-root-expand-ctx-box_0) encoded-root-expand-ctx-box6_0))" +"(let-values(((root-ctx-only-if-syntax?_0) root-ctx-only-if-syntax?7_0))" +"(let-values(((compiled-expression-callback_0)" +"(if(eq? compiled-expression-callback8_0 unsafe-undefined)" +" void" +" compiled-expression-callback8_0)))" +"(let-values(((definition-callback_0)" +"(if(eq? definition-callback9_0 unsafe-undefined) void definition-callback9_0)))" +"(let-values(((other-form-callback_0)" +"(if(eq? other-form-callback10_0 unsafe-undefined)" +" void" +" other-form-callback10_0)))" +"(let-values(((get-module-linklet-info_0)" +"(if(eq? get-module-linklet-info11_0 unsafe-undefined)" +"(lambda(mod-name_14 p_44)(begin 'get-module-linklet-info #f))" +" get-module-linklet-info11_0)))" +"(let-values(((to-source?_0) to-source?12_0))" +"(let-values(((serializable?_0) serializable?13_0))" +"(let-values(((cross-linklet-inlining?_1) cross-linklet-inlining?14_0))" +"(let-values()" +"(let-values(((phase_73)(compile-context-phase cctx_11)))" +"(let-values(((self_17)(compile-context-self cctx_11)))" +"(let-values(((syntax-literals_1)(make-syntax-literals)))" +"(let-values(((phase-to-body_0)(make-hasheqv)))" +"(let-values(((add-body!_0)" +"(lambda(phase_74 body_1)" +"(begin" +" 'add-body!" +"(hash-update!" +" phase-to-body_0" +" phase_74" +"(lambda(l_21)(cons body_1 l_21))" +" null)))))" +"(let-values(((phase-to-header_0)(make-hasheqv)))" +"(let-values(((find-or-create-header!_0)" +"(lambda(phase_75)" +"(begin" +" 'find-or-create-header!" +"(let-values(((or-part_220)" +"(hash-ref" +" phase-to-header_0" +" phase_75" +" #f)))" +"(if or-part_220" +" or-part_220" +"(let-values(((header_7)" +"(make-header" +" mpis_15" +" syntax-literals_1)))" +"(begin" +"(hash-set!" +" phase-to-header_0" +" phase_75" +" header_7)" +" header_7))))))))" +"(let-values((()" +"(begin" +"(let-values(((lst_100) force-phases_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_100)))" +"((letrec-values(((for-loop_115)" +"(lambda(lst_26)" +"(begin" +" 'for-loop" +"(if(pair? lst_26)" +"(let-values(((phase_76)" +"(unsafe-car" +" lst_26))" +"((rest_100)" +"(unsafe-cdr" +" lst_26)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(find-or-create-header!_0" +" phase_76)" +"(add-body!_0" +" phase_76" +" '(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_115" +" rest_100)" +"(values))))" +"(values))))))" +" for-loop_115)" +" lst_100)))" +"(values))))" +"(let-values()" +"(let-values(((saw-define-syntaxes?_0) #f))" +"(let-values((()" +"(begin" +"(if(compile-context-module-self cctx_11)" +"(let-values()" +"((letrec-values(((loop!_0)" +"(lambda(bodys_3" +" phase_7" +" header_8)" +"(begin" +" 'loop!" +"(begin" +"(let-values(((lst_185)" +" bodys_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_185)))" +"((letrec-values(((for-loop_202)" +"(lambda(lst_186)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_186)" +"(let-values(((body_2)" +"(unsafe-car" +" lst_186))" +"((rest_101)" +"(unsafe-cdr" +" lst_186)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(parsed-define-values?" +" body_2)" +"(let-values()" +"(begin" +"(let-values(((lst_187)" +"(parsed-define-values-syms" +" body_2)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_187)))" +"((letrec-values(((for-loop_3)" +"(lambda(lst_188)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_188)" +"(let-values(((sym_59)" +"(unsafe-car" +" lst_188))" +"((rest_102)" +"(unsafe-cdr" +" lst_188)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((def-sym_1)" +"(select-fresh" +" sym_59" +" header_8)))" +"(begin" +"(hash-set!" +"(header-binding-sym-to-define-sym" +" header_8)" +" sym_59" +" def-sym_1)" +"(set-header-binding-syms-in-order!" +" header_8" +"(cons" +" sym_59" +"(header-binding-syms-in-order" +" header_8)))" +"(register-as-defined!" +" header_8" +" def-sym_1))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_3" +" rest_102)" +"(values))))" +"(values))))))" +" for-loop_3)" +" lst_187)))" +"(void)))" +"(if(parsed-begin-for-syntax?" +" body_2)" +"(let-values()" +"(loop!_0" +"(parsed-begin-for-syntax-body" +" body_2)" +"(add1" +" phase_7)" +"(find-or-create-header!_0" +"(add1" +" phase_7))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_202" +" rest_101)" +"(values))))" +"(values))))))" +" for-loop_202)" +" lst_185)))" +"(void))))))" +" loop!_0)" +" bodys_2" +" phase_73" +"(find-or-create-header!_0 phase_73)))" +"(void))" +"(values))))" +"(let-values(((as-required?_0)" +"(lambda(header_9)" +"(begin" +" 'as-required?" +"(lambda(sym_60)" +"(registered-as-required?" +" header_9" +" sym_60))))))" +"(let-values(((last-i_0)(sub1(length bodys_2))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop!_1)" +"(lambda(bodys_4" +" phase_77" +" header_10)" +"(begin" +" 'loop!" +"(begin" +"(let-values(((lst_189)" +" bodys_4)" +"((start_34)" +" 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_189)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals" +" start_34)))" +"((letrec-values(((for-loop_203)" +"(lambda(lst_190" +" pos_93)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_190)" +" #t" +" #f)" +"(let-values(((body_0)" +"(unsafe-car" +" lst_190))" +"((rest_103)" +"(unsafe-cdr" +" lst_190))" +"((i_107)" +" pos_93))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(parsed-define-values?" +" body_0)" +"(let-values()" +"(let-values(((ids_5)" +"(parsed-define-values-ids" +" body_0)))" +"(let-values(((binding-syms_0)" +"(parsed-define-values-syms" +" body_0)))" +"(let-values(((def-syms_0)" +"(if(compile-context-module-self" +" cctx_11)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_191)" +" binding-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_191)))" +"((letrec-values(((for-loop_123)" +"(lambda(fold-var_179" +" lst_192)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_192)" +"(let-values(((binding-sym_0)" +"(unsafe-car" +" lst_192))" +"((rest_104)" +"(unsafe-cdr" +" lst_192)))" +"(let-values(((fold-var_168)" +"(let-values(((fold-var_180)" +" fold-var_179))" +"(let-values(((fold-var_181)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +"(header-binding-sym-to-define-sym" +" header_10)" +" binding-sym_0))" +" fold-var_180))))" +"(values" +" fold-var_181)))))" +"(if(not" +" #f)" +"(for-loop_123" +" fold-var_168" +" rest_104)" +" fold-var_168)))" +" fold-var_179)))))" +" for-loop_123)" +" null" +" lst_191)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_193)" +" binding-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_193)))" +"((letrec-values(((for-loop_204)" +"(lambda(fold-var_182" +" lst_173)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_173)" +"(let-values(((binding-sym_1)" +"(unsafe-car" +" lst_173))" +"((rest_89)" +"(unsafe-cdr" +" lst_173)))" +"(let-values(((fold-var_183)" +"(let-values(((fold-var_1)" +" fold-var_182))" +"(let-values(((fold-var_2)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((header35_0)" +" header_10)" +"((temp36_0)" +"(compile-context-self" +" cctx_11))" +"((phase37_0)" +" phase_77)" +"((binding-sym38_0)" +" binding-sym_1)" +"((temp39_1)" +" #f)" +"((temp40_0)" +" #t))" +"(register-required-variable-use!19.1" +" temp40_0" +" header35_0" +" temp36_0" +" phase37_0" +" binding-sym38_0" +" temp39_1)))" +" fold-var_1))))" +"(values" +" fold-var_2)))))" +"(if(not" +" #f)" +"(for-loop_204" +" fold-var_183" +" rest_89)" +" fold-var_183)))" +" fold-var_182)))))" +" for-loop_204)" +" null" +" lst_193))))))))" +"(let-values(((rhs_1)" +"(compile$2" +"(parsed-define-values-rhs" +" body_0)" +"(let-values(((the-struct_48)" +" cctx_11))" +"(if(compile-context?" +" the-struct_48)" +"(let-values(((phase41_0)" +" phase_77)" +"((header42_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_48)" +" phase41_0" +"(compile-context-self" +" the-struct_48)" +"(compile-context-module-self" +" the-struct_48)" +"(compile-context-full-module-name" +" the-struct_48)" +"(compile-context-lazy-syntax-literals?" +" the-struct_48)" +" header42_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_48)))" +"(if(=" +"(length" +" ids_5)" +" 1)" +"(car" +" ids_5)" +" #f))))" +"(begin" +"(definition-callback_0)" +"(compiled-expression-callback_0" +" rhs_1" +"(length" +" def-syms_0)" +" phase_77" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_77" +"(propagate-inline-property" +"(correlate*" +"(parsed-s" +" body_0)" +"(list" +" 'define-values" +" def-syms_0" +" rhs_1))" +"(parsed-s" +" body_0)))" +"(if(let-values(((or-part_169)" +"(compile-context-module-self" +" cctx_11)))" +"(if or-part_169" +" or-part_169" +"(null?" +" ids_5)))" +"(void)" +"(let-values()" +"(begin" +"(add-body!_0" +" phase_77" +"(list*" +" 'if" +" #f" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_194)" +" def-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_194)))" +"((letrec-values(((for-loop_205)" +"(lambda(fold-var_184" +" lst_13)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_13)" +"(let-values(((def-sym_2)" +"(unsafe-car" +" lst_13))" +"((rest_105)" +"(unsafe-cdr" +" lst_13)))" +"(let-values(((fold-var_185)" +"(let-values(((fold-var_186)" +" fold-var_184))" +"(let-values(((fold-var_187)" +"(let-values()" +"(cons" +"(let-values()" +"(list*" +" 'set!" +" def-sym_2" +" '(#f)))" +" fold-var_186))))" +"(values" +" fold-var_187)))))" +"(if(not" +" #f)" +"(for-loop_205" +" fold-var_185" +" rest_105)" +" fold-var_185)))" +" fold-var_184)))))" +" for-loop_205)" +" null" +" lst_194)))))" +" '((void))))" +"(add-body!_0" +" phase_77" +"(compile-top-level-bind" +" ids_5" +" binding-syms_0" +"(let-values(((the-struct_49)" +" cctx_11))" +"(if(compile-context?" +" the-struct_49)" +"(let-values(((phase43_0)" +" phase_77)" +"((header44_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_49)" +" phase43_0" +"(compile-context-self" +" the-struct_49)" +"(compile-context-module-self" +" the-struct_49)" +"(compile-context-full-module-name" +" the-struct_49)" +"(compile-context-lazy-syntax-literals?" +" the-struct_49)" +" header44_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_49)))" +" #f)))))))))))" +"(if(parsed-define-syntaxes?" +" body_0)" +"(let-values()" +"(let-values(((ids_6)" +"(parsed-define-syntaxes-ids" +" body_0)))" +"(let-values(((binding-syms_1)" +"(parsed-define-syntaxes-syms" +" body_0)))" +"(let-values(((next-header_0)" +"(find-or-create-header!_0" +"(add1" +" phase_77))))" +"(let-values(((gen-syms_0)" +"(reverse$1" +"(let-values(((lst_195)" +" binding-syms_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_195)))" +"((letrec-values(((for-loop_206)" +"(lambda(fold-var_188" +" lst_196)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_196)" +"(let-values(((binding-sym_2)" +"(unsafe-car" +" lst_196))" +"((rest_106)" +"(unsafe-cdr" +" lst_196)))" +"(let-values(((fold-var_189)" +"(let-values(((fold-var_190)" +" fold-var_188))" +"(let-values(((fold-var_191)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((gen-sym_0)" +"(select-fresh" +" binding-sym_2" +" next-header_0)))" +"(begin" +"(register-as-defined!" +" next-header_0" +" gen-sym_0)" +" gen-sym_0)))" +" fold-var_190))))" +"(values" +" fold-var_191)))))" +"(if(not" +" #f)" +"(for-loop_206" +" fold-var_189" +" rest_106)" +" fold-var_189)))" +" fold-var_188)))))" +" for-loop_206)" +" null" +" lst_195))))))" +"(let-values(((rhs_2)" +"(compile$2" +"(parsed-define-syntaxes-rhs" +" body_0)" +"(let-values(((the-struct_50)" +" cctx_11))" +"(if(compile-context?" +" the-struct_50)" +"(let-values(((phase45_0)" +"(add1" +" phase_77))" +"((header46_0)" +" next-header_0))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_50)" +" phase45_0" +"(compile-context-self" +" the-struct_50)" +"(compile-context-module-self" +" the-struct_50)" +"(compile-context-full-module-name" +" the-struct_50)" +"(compile-context-lazy-syntax-literals?" +" the-struct_50)" +" header46_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_50))))))" +"(let-values((()" +"(begin" +"(definition-callback_0)" +"(values))))" +"(let-values((()" +"(begin" +"(compiled-expression-callback_0" +" rhs_2" +"(length" +" gen-syms_0)" +"(add1" +" phase_77)" +"(as-required?_0" +" header_10))" +"(values))))" +"(let-values(((transformer-set!s_0)" +"(reverse$1" +"(let-values(((lst_197)" +" binding-syms_1)" +"((lst_198)" +" gen-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_197)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_198)))" +"((letrec-values(((for-loop_207)" +"(lambda(fold-var_192" +" lst_199" +" lst_200)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_199)" +"(pair?" +" lst_200)" +" #f)" +"(let-values(((binding-sym_3)" +"(unsafe-car" +" lst_199))" +"((rest_107)" +"(unsafe-cdr" +" lst_199))" +"((gen-sym_1)" +"(unsafe-car" +" lst_200))" +"((rest_108)" +"(unsafe-cdr" +" lst_200)))" +"(let-values(((fold-var_193)" +"(let-values(((fold-var_194)" +" fold-var_192))" +"(let-values(((fold-var_195)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" set-transformer!-id" +"(list" +" 'quote" +" binding-sym_3)" +" gen-sym_1))" +" fold-var_194))))" +"(values" +" fold-var_195)))))" +"(if(not" +" #f)" +"(for-loop_207" +" fold-var_193" +" rest_107" +" rest_108)" +" fold-var_193)))" +" fold-var_192)))))" +" for-loop_207)" +" null" +" lst_197" +" lst_198))))))" +"(begin" +"(if(compile-context-module-self" +" cctx_11)" +"(let-values()" +"(add-body!_0" +"(add1" +" phase_77)" +"(list" +" 'let-values" +"(list" +"(list" +" gen-syms_0" +" rhs_2))" +"(list*" +" 'begin" +"(qq-append" +" transformer-set!s_0" +" '((void)))))))" +"(let-values()" +"(add-body!_0" +"(add1" +" phase_77)" +"(generate-top-level-define-syntaxes" +" gen-syms_0" +" rhs_2" +" transformer-set!s_0" +"(compile-top-level-bind" +" ids_6" +" binding-syms_1" +"(let-values(((the-struct_51)" +" cctx_11))" +"(if(compile-context?" +" the-struct_51)" +"(let-values(((phase47_0)" +" phase_77)" +"((header48_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_51)" +" phase47_0" +"(compile-context-self" +" the-struct_51)" +"(compile-context-module-self" +" the-struct_51)" +"(compile-context-full-module-name" +" the-struct_51)" +"(compile-context-lazy-syntax-literals?" +" the-struct_51)" +" header48_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_51)))" +" gen-syms_0)))))" +"(set! saw-define-syntaxes?_0" +" #t)))))))))))" +"(if(parsed-begin-for-syntax?" +" body_0)" +"(let-values()" +"(loop!_1" +"(parsed-begin-for-syntax-body" +" body_0)" +"(add1" +" phase_77)" +"(find-or-create-header!_0" +"(add1" +" phase_77))))" +"(if(let-values(((or-part_221)" +"(parsed-#%declare?" +" body_0)))" +"(if or-part_221" +" or-part_221" +"(let-values(((or-part_87)" +"(parsed-module?" +" body_0)))" +"(if or-part_87" +" or-part_87" +"(parsed-require?" +" body_0)))))" +"(let-values()" +"(let-values(((e_34)" +"(other-form-callback_0" +" body_0" +"(let-values(((the-struct_52)" +" cctx_11))" +"(if(compile-context?" +" the-struct_52)" +"(let-values(((phase49_0)" +" phase_77)" +"((header50_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_52)" +" phase49_0" +"(compile-context-self" +" the-struct_52)" +"(compile-context-module-self" +" the-struct_52)" +"(compile-context-full-module-name" +" the-struct_52)" +"(compile-context-lazy-syntax-literals?" +" the-struct_52)" +" header50_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_52))))))" +"(if e_34" +"(let-values()" +"(begin" +"(compiled-expression-callback_0" +" e_34" +" #f" +" phase_77" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_77" +" e_34)))" +"(void))))" +"(let-values()" +"(let-values(((e_35)" +"(compile$2" +" body_0" +"(let-values(((the-struct_53)" +" cctx_11))" +"(if(compile-context?" +" the-struct_53)" +"(let-values(((phase51_0)" +" phase_77)" +"((header52_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_53)" +" phase51_0" +"(compile-context-self" +" the-struct_53)" +"(compile-context-module-self" +" the-struct_53)" +"(compile-context-full-module-name" +" the-struct_53)" +"(compile-context-lazy-syntax-literals?" +" the-struct_53)" +" header52_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_53)))" +" #f" +"(=" +" i_107" +" last-i_0))))" +"(begin" +"(compiled-expression-callback_0" +" e_35" +" #f" +" phase_77" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_77" +" e_35)))))))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_203" +" rest_103" +"(+" +" pos_93" +" 1))" +"(values))))" +"(values))))))" +" for-loop_203)" +" lst_189" +" start_34)))" +"(void))))))" +" loop!_1)" +" bodys_2" +" phase_73" +"(find-or-create-header!_0 phase_73))" +"(values))))" +"(let-values(((encoded-root-expand-pos_0)" +"(if encoded-root-expand-ctx-box_0" +"(if(unbox" +" encoded-root-expand-ctx-box_0)" +"(if(not" +"(if root-ctx-only-if-syntax?_0" +"(if(not" +" saw-define-syntaxes?_0)" +"(syntax-literals-empty?" +" syntax-literals_1)" +" #f)" +" #f))" +"(add-syntax-literal!" +" syntax-literals_1" +"(unbox" +" encoded-root-expand-ctx-box_0))" +" #f)" +" #f)" +" #f)))" +"(let-values(((phases-in-order_2)" +"(let-values(((temp53_1)" +"(hash-keys" +" phase-to-body_0))" +"((<54_0) <))" +"(sort7.1 #f #f temp53_1 <54_0))))" +"(let-values(((min-phase_0)" +"(if(pair? phases-in-order_2)" +"(car phases-in-order_2)" +" phase_73)))" +"(let-values(((max-phase_0)" +"(if(pair? phases-in-order_2)" +"(car" +"(reverse$1" +" phases-in-order_2))" +" phase_73)))" +"(let-values(((phase-to-link-info_0)" +"(let-values(((lst_201)" +" phases-in-order_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_201)))" +"((letrec-values(((for-loop_208)" +"(lambda(table_151" +" lst_202)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_202)" +"(let-values(((phase_78)" +"(unsafe-car" +" lst_202))" +"((rest_109)" +"(unsafe-cdr" +" lst_202)))" +"(let-values(((table_152)" +"(let-values(((table_153)" +" table_151))" +"(let-values(((table_154)" +"(let-values()" +"(let-values(((key_58" +" val_51)" +"(let-values()" +"(let-values(((header_11)" +"(hash-ref" +" phase-to-header_0" +" phase_78" +" #f)))" +"(let-values(((link-module-uses_0" +" imports_2" +" extra-inspectorsss_1" +" def-decls_0)" +"(generate-links+imports" +" header_11" +" phase_78" +" cctx_11" +" cross-linklet-inlining?_1)))" +"(values" +" phase_78" +"(link-info1.1" +" link-module-uses_0" +" imports_2" +" extra-inspectorsss_1" +" def-decls_0)))))))" +"(hash-set" +" table_153" +" key_58" +" val_51)))))" +"(values" +" table_154)))))" +"(if(not" +" #f)" +"(for-loop_208" +" table_152" +" rest_109)" +" table_152)))" +" table_151)))))" +" for-loop_208)" +" '#hash()" +" lst_201)))))" +"(let-values(((body-linklets+module-use*s_0)" +"(let-values(((lst_108)" +" phases-in-order_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_108)))" +"((letrec-values(((for-loop_209)" +"(lambda(table_155" +" lst_109)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_109)" +"(let-values(((phase_79)" +"(unsafe-car" +" lst_109))" +"((rest_110)" +"(unsafe-cdr" +" lst_109)))" +"(let-values(((table_156)" +"(let-values(((table_157)" +" table_155))" +"(let-values(((table_158)" +"(let-values()" +"(let-values(((key_59" +" val_52)" +"(let-values()" +"(let-values(((bodys_5)" +"(hash-ref" +" phase-to-body_0" +" phase_79)))" +"(let-values(((li_0)" +"(hash-ref" +" phase-to-link-info_0" +" phase_79)))" +"(let-values(((binding-sym-to-define-sym_0)" +"(header-binding-sym-to-define-sym" +"(hash-ref" +" phase-to-header_0" +" phase_79))))" +"(let-values(((module-use*s_0)" +"(module-uses-add-extra-inspectorsss" +"(link-info-link-module-uses" +" li_0)" +"(link-info-extra-inspectorsss" +" li_0))))" +"(let-values(((linklet_1" +" new-module-use*s_0)" +"(let-values()" +"((if to-source?_0" +"(lambda(l_55" +" name_46" +" keys_0" +" getter_0)" +"(values" +" l_55" +" keys_0))" +"(lambda(l_56" +" name_47" +" keys_1" +" getter_1)" +"(1/compile-linklet" +" l_56" +" name_47" +" keys_1" +" getter_1" +"(if serializable?_0" +" '(serializable)" +" '()))))" +"(list*" +" 'linklet" +"(qq-append" +" body-imports_0" +"(link-info-imports" +" li_0))" +"(qq-append" +"(link-info-def-decls" +" li_0)" +"(reverse$1" +"(let-values(((lst_203)" +"(header-binding-syms-in-order" +"(hash-ref" +" phase-to-header_0" +" phase_79))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_203)))" +"((letrec-values(((for-loop_210)" +"(lambda(fold-var_196" +" lst_204)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_204)" +"(let-values(((binding-sym_4)" +"(unsafe-car" +" lst_204))" +"((rest_111)" +"(unsafe-cdr" +" lst_204)))" +"(let-values(((fold-var_197)" +"(let-values(((fold-var_198)" +" fold-var_196))" +"(let-values(((fold-var_199)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((def-sym_3)" +"(hash-ref" +" binding-sym-to-define-sym_0" +" binding-sym_4)))" +"(if(eq?" +" def-sym_3" +" binding-sym_4)" +" def-sym_3" +"(list" +" def-sym_3" +" binding-sym_4))))" +" fold-var_198))))" +"(values" +" fold-var_199)))))" +"(if(not" +" #f)" +"(for-loop_210" +" fold-var_197" +" rest_111)" +" fold-var_197)))" +" fold-var_196)))))" +" for-loop_210)" +" null" +" lst_203)))))" +"(qq-append" +"(reverse$1" +" bodys_5)" +" body-suffix-forms_0))" +" 'module" +"(list->vector" +"(append" +" body-import-instances_0" +" module-use*s_0))" +"(make-module-use-to-linklet" +" cross-linklet-inlining?_1" +"(compile-context-namespace" +" cctx_11)" +" get-module-linklet-info_0" +" module-use*s_0)))))" +"(values" +" phase_79" +"(cons" +" linklet_1" +"(list-tail" +"(vector->list" +" new-module-use*s_0)" +"(length" +" body-imports_0))))))))))))" +"(hash-set" +" table_157" +" key_59" +" val_52)))))" +"(values" +" table_158)))))" +"(if(not" +" #f)" +"(for-loop_209" +" table_156" +" rest_110)" +" table_156)))" +" table_155)))))" +" for-loop_209)" +" '#hasheq()" +" lst_108)))))" +"(let-values(((body-linklets_0)" +"(let-values(((ht_114)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_114)))" +"((letrec-values(((for-loop_211)" +"(lambda(table_32" +" i_138)" +"(begin" +" 'for-loop" +"(if i_138" +"(let-values(((phase_80" +" l+mu*s_0)" +"(hash-iterate-key+value" +" ht_114" +" i_138)))" +"(let-values(((table_33)" +"(let-values(((table_144)" +" table_32))" +"(let-values(((table_159)" +"(let-values()" +"(let-values(((key_60" +" val_53)" +"(let-values()" +"(values" +" phase_80" +"(car" +" l+mu*s_0)))))" +"(hash-set" +" table_144" +" key_60" +" val_53)))))" +"(values" +" table_159)))))" +"(if(not" +" #f)" +"(for-loop_211" +" table_33" +"(hash-iterate-next" +" ht_114" +" i_138))" +" table_33)))" +" table_32)))))" +" for-loop_211)" +" '#hasheq()" +"(hash-iterate-first" +" ht_114))))))" +"(let-values(((phase-to-link-module-uses_1)" +"(let-values(((ht_115)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_115)))" +"((letrec-values(((for-loop_212)" +"(lambda(table_160" +" i_139)" +"(begin" +" 'for-loop" +"(if i_139" +"(let-values(((phase_81" +" l+mu*s_1)" +"(hash-iterate-key+value" +" ht_115" +" i_139)))" +"(let-values(((table_125)" +"(let-values(((table_35)" +" table_160))" +"(let-values(((table_36)" +"(let-values()" +"(let-values(((key_47" +" val_40)" +"(let-values()" +"(values" +" phase_81" +"(module-uses-strip-extra-inspectorsss" +"(cdr" +" l+mu*s_1))))))" +"(hash-set" +" table_35" +" key_47" +" val_40)))))" +"(values" +" table_36)))))" +"(if(not" +" #f)" +"(for-loop_212" +" table_125" +"(hash-iterate-next" +" ht_115" +" i_139))" +" table_125)))" +" table_160)))))" +" for-loop_212)" +" '#hasheq()" +"(hash-iterate-first" +" ht_115))))))" +"(let-values(((phase-to-link-module-uses-expr_0)" +"(serialize-phase-to-link-module-uses" +" phase-to-link-module-uses_1" +" mpis_15)))" +"(let-values(((phase-to-link-extra-inspectorsss_0)" +"(let-values(((ht_116)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_116)))" +"((letrec-values(((for-loop_213)" +"(lambda(table_161" +" i_140)" +"(begin" +" 'for-loop" +"(if i_140" +"(let-values(((phase_82" +" l+mu*s_2)" +"(hash-iterate-key+value" +" ht_116" +" i_140)))" +"(let-values(((table_162)" +"(let-values(((extra-inspectorsss_2)" +"(module-uses-extract-extra-inspectorsss" +"(cdr" +" l+mu*s_2)" +"(car" +" l+mu*s_2)" +" cross-linklet-inlining?_1" +"(length" +" body-imports_0))))" +"(begin" +" #t" +"((letrec-values(((for-loop_214)" +"(lambda(table_163)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_164)" +"(let-values(((table_165)" +" table_163))" +"(if extra-inspectorsss_2" +"(let-values(((table_166)" +" table_165))" +"(let-values(((table_39)" +"(let-values()" +"(let-values(((key_61" +" val_54)" +"(let-values()" +"(values" +" phase_82" +" extra-inspectorsss_2))))" +"(hash-set" +" table_166" +" key_61" +" val_54)))))" +"(values" +" table_39)))" +" table_165))))" +" table_164))))))" +" for-loop_214)" +" table_161)))))" +"(if(not" +" #f)" +"(for-loop_213" +" table_162" +"(hash-iterate-next" +" ht_116" +" i_140))" +" table_162)))" +" table_161)))))" +" for-loop_213)" +" '#hash()" +"(hash-iterate-first" +" ht_116))))))" +"(values" +" body-linklets_0" +" min-phase_0" +" max-phase_0" +" phase-to-link-module-uses_1" +" phase-to-link-module-uses-expr_0" +" phase-to-link-extra-inspectorsss_0" +" syntax-literals_1" +" encoded-root-expand-pos_0)))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(compile-top-level-bind)" +"(lambda(ids_7 binding-syms_2 cctx_12 trans-exprs_0)" +"(begin" +"(let-values(((phase_83)(compile-context-phase cctx_12)))" +"(let-values(((self_18)(compile-context-self cctx_12)))" +"(let-values(((header_12)(compile-context-header cctx_12)))" +"(let-values(((mpis_16)(header-module-path-indexes header_12)))" +"(let-values(((top-level-bind-scope_2)" +"(root-expand-context-top-level-bind-scope" +"(namespace-get-root-expand-ctx(compile-context-namespace cctx_12)))))" +"(let-values(((self-expr_0)(add-module-path-index! mpis_16 self_18)))" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_205) ids_7)" +"((lst_206) binding-syms_2)" +"((lst_47)" +"(let-values(((or-part_222) trans-exprs_0))" +"(if or-part_222" +" or-part_222" +"(reverse$1" +"(let-values(((lst_207) ids_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_207)))" +"((letrec-values(((for-loop_215)" +"(lambda(fold-var_200 lst_39)" +"(begin" +" 'for-loop" +"(if(pair? lst_39)" +"(let-values(((id_49)(unsafe-car lst_39))" +"((rest_16)(unsafe-cdr lst_39)))" +"(let-values(((fold-var_201)" +"(let-values(((fold-var_202)" +" fold-var_200))" +"(let-values(((fold-var_203)" +"(let-values()" +"(cons" +"(let-values()" +" ''#f)" +" fold-var_202))))" +"(values fold-var_203)))))" +"(if(not #f)" +"(for-loop_215 fold-var_201 rest_16)" +" fold-var_201)))" +" fold-var_200)))))" +" for-loop_215)" +" null" +" lst_207))))))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_205)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_206)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_47)))" +"((letrec-values(((for-loop_137)" +"(lambda(fold-var_204 lst_1 lst_208 lst_209)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_1)(if(pair? lst_208)(pair? lst_209) #f) #f)" +"(let-values(((id_50)(unsafe-car lst_1))" +"((rest_112)(unsafe-cdr lst_1))" +"((binding-sym_5)(unsafe-car lst_208))" +"((rest_113)(unsafe-cdr lst_208))" +"((trans-expr_0)(unsafe-car lst_209))" +"((rest_114)(unsafe-cdr lst_209)))" +"(let-values(((fold-var_205)" +"(let-values(((fold-var_206) fold-var_204))" +"(let-values(((fold-var_207)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id-stx_0)" +"(compile-quote-syntax" +"(remove-scope" +" id_50" +" top-level-bind-scope_2)" +" cctx_12)))" +"(list" +" top-level-bind!-id" +" id-stx_0" +" self-expr_0" +" phase_83" +" phase-shift-id" +" ns-id" +"(list 'quote binding-sym_5)" +"(if trans-exprs_0 #t #f)" +" trans-expr_0)))" +" fold-var_206))))" +"(values fold-var_207)))))" +"(if(not #f)" +"(for-loop_137 fold-var_205 rest_112 rest_113 rest_114)" +" fold-var_205)))" +" fold-var_204)))))" +" for-loop_137)" +" null" +" lst_205" +" lst_206" +" lst_47))))))))))))))" +"(define-values" +"(generate-top-level-define-syntaxes)" +"(lambda(gen-syms_1 rhs_3 transformer-set!s_1 finish_1)" +"(begin" +"(list" +" 'call-with-values" +"(list 'lambda '() rhs_3)" +"(list" +" 'case-lambda" +"(list gen-syms_1(list* 'begin(qq-append transformer-set!s_1(list* finish_1 '((void))))))" +"(list" +" '()" +"(list" +" 'let-values" +"(list" +"(list" +" gen-syms_1" +"(list*" +" 'values" +"(reverse$1" +"(let-values(((lst_210) gen-syms_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_210)))" +"((letrec-values(((for-loop_140)" +"(lambda(fold-var_208 lst_211)" +"(begin" +" 'for-loop" +"(if(pair? lst_211)" +"(let-values(((s_132)(unsafe-car lst_211))((rest_115)(unsafe-cdr lst_211)))" +"(let-values(((fold-var_209)" +"(let-values(((fold-var_210) fold-var_208))" +"(let-values(((fold-var_211)" +"(let-values()" +"(cons(let-values() ''#f) fold-var_210))))" +"(values fold-var_211)))))" +"(if(not #f)(for-loop_140 fold-var_209 rest_115) fold-var_209)))" +" fold-var_208)))))" +" for-loop_140)" +" null" +" lst_210)))))))" +"(list* 'begin finish_1 '((void)))))" +"(list 'args(list* 'let-values(list(list* gen-syms_1 '((apply values args)))) '((void)))))))))" +"(define-values" +"(propagate-inline-property)" +"(lambda(e_36 orig-s_22)" +"(begin" +"(let-values(((v_165)(syntax-property$1 orig-s_22 'compiler-hint:cross-module-inline)))" +"(if v_165(correlated-property e_36 'compiler-hint:cross-module-inline v_165) e_36)))))" +"(define-values" +"(make-module-use-to-linklet)" +"(lambda(cross-linklet-inlining?_2 ns_57 get-module-linklet-info_1 init-mu*s_0)" +"(begin" +"(let-values(((mu*-intern-table_0)(make-hash)))" +"(let-values(((intern-module-use*_0)" +"(lambda(mu*_5)" +"(begin" +" 'intern-module-use*" +"(let-values(((mod-name_15)(1/module-path-index-resolve(module-use-module mu*_5))))" +"(let-values(((existing-mu*_1)" +"(hash-ref mu*-intern-table_0(cons mod-name_15(module-use-phase mu*_5)) #f)))" +"(if existing-mu*_1" +"(let-values()" +"(begin(module-use-merge-extra-inspectorss! existing-mu*_1 mu*_5) existing-mu*_1))" +"(let-values()" +"(begin" +"(hash-set! mu*-intern-table_0(cons mod-name_15(module-use-phase mu*_5)) mu*_5)" +" mu*_5)))))))))" +"(begin" +"(let-values(((lst_212) init-mu*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_212)))" +"((letrec-values(((for-loop_216)" +"(lambda(lst_213)" +"(begin" +" 'for-loop" +"(if(pair? lst_213)" +"(let-values(((mu*_6)(unsafe-car lst_213))((rest_116)(unsafe-cdr lst_213)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()(intern-module-use*_0 mu*_6))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_216 rest_116)(values))))" +"(values))))))" +" for-loop_216)" +" lst_212)))" +"(void)" +"(lambda(mu*-or-instance_0)" +"(if(1/instance? mu*-or-instance_0)" +"(let-values()(values mu*-or-instance_0 #f))" +"(if(not cross-linklet-inlining?_2)" +"(let-values()(values #f #f))" +"(if mu*-or-instance_0" +"(let-values()" +"(let-values(((mu*_7) mu*-or-instance_0))" +"(let-values(((mod-name_16)(1/module-path-index-resolve(module-use-module mu*_7))))" +"(let-values(((mli_0)" +"(let-values(((or-part_223)" +"(get-module-linklet-info_1 mod-name_16(module-use-phase mu*_7))))" +"(if or-part_223" +" or-part_223" +"(namespace->module-linklet-info" +" ns_57" +" mod-name_16" +"(module-use-phase mu*_7))))))" +"(begin" +"(if mli_0" +"(let-values()" +"(module-use*-declaration-inspector! mu*_7(module-linklet-info-inspector mli_0)))" +"(void))" +"(if mli_0" +"(values" +"(module-linklet-info-linklet-or-instance mli_0)" +"(if(module-linklet-info-module-uses mli_0)" +"(list->vector" +"(append" +" '(#f #f)" +"(let-values(((mus_2)(module-linklet-info-module-uses mli_0))" +"((extra-inspectorsss_3)" +"(module-linklet-info-extra-inspectorsss mli_0)))" +"(reverse$1" +"(let-values(((lst_214) mus_2)" +"((lst_215)" +"(1/linklet-import-variables" +"(module-linklet-info-linklet-or-instance mli_0)))" +"((lst_216)" +"(let-values(((or-part_224) extra-inspectorsss_3))" +"(if or-part_224 or-part_224 mus_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_214)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_215)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_216)))" +"((letrec-values(((for-loop_217)" +"(lambda(fold-var_212 lst_217 lst_218 lst_219)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_217)" +"(if(pair? lst_218)(pair? lst_219) #f)" +" #f)" +"(let-values(((sub-mu_0)(unsafe-car lst_217))" +"((rest_117)(unsafe-cdr lst_217))" +"((imports_3)(unsafe-car lst_218))" +"((rest_118)(unsafe-cdr lst_218))" +"((extra-inspectorss_13)" +"(unsafe-car lst_219))" +"((rest_119)(unsafe-cdr lst_219)))" +"(let-values(((fold-var_213)" +"(let-values(((fold-var_214)" +" fold-var_212))" +"(let-values(((fold-var_215)" +"(let-values()" +"(cons" +"(let-values()" +"(intern-module-use*_0" +"(module-use+extra-inspectors" +"(module-path-index-shift" +"(module-use-module" +" sub-mu_0)" +"(module-linklet-info-self" +" mli_0)" +"(module-use-module" +" mu*_7))" +"(module-use-phase" +" sub-mu_0)" +" imports_3" +"(module-linklet-info-inspector" +" mli_0)" +"(module-linklet-info-extra-inspector" +" mli_0)" +"(if extra-inspectorsss_3" +" extra-inspectorss_13" +" #f))))" +" fold-var_214))))" +"(values fold-var_215)))))" +"(if(not #f)" +"(for-loop_217" +" fold-var_213" +" rest_117" +" rest_118" +" rest_119)" +" fold-var_213)))" +" fold-var_212)))))" +" for-loop_217)" +" null" +" lst_214" +" lst_215" +" lst_216)))))))" +" #f))" +"(values #f #f)))))))" +"(let-values()(values #f #f))))))))))))" +"(define-values" +"(build-shared-data-linklet)" +"(lambda(cims_0 ns_42)" +"(begin" +"(let-values(((mpis_17)(make-module-path-index-table)))" +"(let-values(((mpi-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_1)" +"(let-values(((vec_58 i_141)" +"(let-values(((vec_59 len_28)" +"(let-values(((vec_60)(compiled-in-memory-mpis cim_1)))" +"(begin" +"(check-vector vec_60)" +"(values vec_60(unsafe-vector-length vec_60))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_98)" +"(lambda(vec_61 i_142 pos_94)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_94 len_28)" +"(let-values(((mpi_42)" +"(unsafe-vector-ref vec_59 pos_94)))" +"(let-values(((vec_62 i_143)" +"(let-values(((vec_63) vec_61)" +"((i_61) i_142))" +"(let-values(((vec_64 i_144)" +"(let-values()" +"(let-values(((new-vec_3)" +"(if(eq?" +" i_61" +"(unsafe-vector*-length" +" vec_63))" +"(grow-vector" +" vec_63)" +" vec_63)))" +"(begin" +"(unsafe-vector*-set!" +" new-vec_3" +" i_61" +"(let-values()" +"(add-module-path-index!/pos" +" mpis_17" +" mpi_42)))" +"(values" +" new-vec_3" +"(unsafe-fx+" +" i_61" +" 1)))))))" +"(values vec_64 i_144)))))" +"(if(not #f)" +"(for-loop_98" +" vec_62" +" i_143" +"(unsafe-fx+ 1 pos_94))" +"(values vec_62 i_143))))" +"(values vec_61 i_142))))))" +" for-loop_98)" +"(make-vector 16)" +" 0" +" 0)))))" +"(shrink-vector vec_58 i_141))))))" +"(let-values(((syntax-literals_2)(make-syntax-literals)))" +"(let-values(((syntax-literals-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_2)" +"(add-syntax-literals! syntax-literals_2(compiled-in-memory-syntax-literals cim_2))))))" +"(let-values(((module-uses-tables_0) null))" +"(let-values(((module-uses-tables-count_0) 0))" +"(let-values(((phase-to-link-module-uses-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_3)" +"(let-values(((pos_95) module-uses-tables-count_0))" +"(begin" +"(set! module-uses-tables_0" +"(cons" +"(compiled-in-memory-phase-to-link-module-uses cim_3)" +" module-uses-tables_0))" +"(set! module-uses-tables-count_0(add1 pos_95))" +" pos_95))))))" +"(let-values(((syntax-literals-expr_0)" +"(generate-eager-syntax-literals! syntax-literals_2 mpis_17 0 #f ns_42)))" +"(let-values(((phase-to-link-module-uses-expr_1)" +"(list*" +" 'vector" +"(reverse$1" +"(let-values(((lst_220)(reverse$1 module-uses-tables_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_220)))" +"((letrec-values(((for-loop_109)" +"(lambda(fold-var_71 lst_89)" +"(begin" +" 'for-loop" +"(if(pair? lst_89)" +"(let-values(((phase-to-link-module-uses_2)" +"(unsafe-car lst_89))" +"((rest_120)(unsafe-cdr lst_89)))" +"(let-values(((fold-var_34)" +"(let-values(((fold-var_158)" +" fold-var_71))" +"(let-values(((fold-var_9)" +"(let-values()" +"(cons" +"(let-values()" +"(serialize-phase-to-link-module-uses" +" phase-to-link-module-uses_2" +" mpis_17))" +" fold-var_158))))" +"(values fold-var_9)))))" +"(if(not #f)" +"(for-loop_109 fold-var_34 rest_120)" +" fold-var_34)))" +" fold-var_71)))))" +" for-loop_109)" +" null" +" lst_220)))))))" +"(1/compile-linklet" +"(list" +" 'linklet" +"(list deserialize-imports eager-instance-imports)" +"(list*" +" mpi-vector-id" +" '(mpi-vector-trees" +" phase-to-link-modules-vector" +" phase-to-link-modules-trees" +" syntax-literals" +" syntax-literals-trees))" +"(list 'define-values(list mpi-vector-id)(generate-module-path-index-deserialize mpis_17))" +"(list 'define-values '(mpi-vector-trees)(list 'quote mpi-trees_0))" +"(list 'define-values '(phase-to-link-modules-vector) phase-to-link-module-uses-expr_1)" +"(list" +" 'define-values" +" '(phase-to-link-modules-trees)" +"(list 'quote phase-to-link-module-uses-trees_0))" +"(list 'define-values '(syntax-literals) syntax-literals-expr_0)" +"(list" +" 'define-values" +" '(syntax-literals-trees)" +"(list 'quote syntax-literals-trees_0))))))))))))))))" +"(define-values" +"(map-cim-tree)" +"(lambda(cims_1 proc_8)" +"(begin" +"((letrec-values(((loop_92)" +"(lambda(cims_2)" +"(begin" +" 'loop" +"(reverse$1" +"(let-values(((lst_80) cims_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_80)))" +"((letrec-values(((for-loop_99)" +"(lambda(fold-var_160 lst_81)" +"(begin" +" 'for-loop" +"(if(pair? lst_81)" +"(let-values(((cim_4)(unsafe-car lst_81))" +"((rest_121)(unsafe-cdr lst_81)))" +"(let-values(((fold-var_216)" +"(let-values(((fold-var_170) fold-var_160))" +"(let-values(((fold-var_171)" +"(let-values()" +"(cons" +"(let-values()" +"(vector" +"(proc_8 cim_4)" +"(loop_92" +"(compiled-in-memory-pre-compiled-in-memorys" +" cim_4))" +"(loop_92" +"(compiled-in-memory-post-compiled-in-memorys" +" cim_4))))" +" fold-var_170))))" +"(values fold-var_171)))))" +"(if(not #f)" +"(for-loop_99 fold-var_216 rest_121)" +" fold-var_216)))" +" fold-var_160)))))" +" for-loop_99)" +" null" +" lst_80))))))))" +" loop_92)" +" cims_1))))" +"(define-values" +"(compiled-tops->compiled-top8.1)" +"(lambda(merge-serialization?2_0 namespace3_0 to-source?1_0 all-cims7_0)" +"(begin" +" 'compiled-tops->compiled-top8" +"(let-values(((all-cims_0) all-cims7_0))" +"(let-values(((to-source?_1) to-source?1_0))" +"(let-values(((merge-serialization?_0) merge-serialization?2_0))" +"(let-values(((ns_58) namespace3_0))" +"(let-values()" +"(let-values(((cims_3)(remove-nontail-purely-functional all-cims_0)))" +"(if(= 1(length cims_3))" +"(let-values()(car cims_3))" +"(let-values()" +"(let-values(((sequence-ht_0)" +"(let-values(((lst_221) cims_3)((start_35) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_221)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_35)))" +"((letrec-values(((for-loop_218)" +"(lambda(table_167 lst_222 pos_96)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_222) #t #f)" +"(let-values(((cim_5)(unsafe-car lst_222))" +"((rest_49)(unsafe-cdr lst_222))" +"((i_142) pos_96))" +"(let-values(((table_168)" +"(let-values(((table_169) table_167))" +"(let-values(((table_170)" +"(let-values()" +"(let-values(((key_62" +" val_35)" +"(let-values()" +"(values" +"(string->symbol" +"(number->string" +" i_142))" +"((if to-source?_1" +" values" +" compiled-in-memory-linklet-directory)" +" cim_5)))))" +"(hash-set" +" table_169" +" key_62" +" val_35)))))" +"(values table_170)))))" +"(if(not #f)" +"(for-loop_218 table_168 rest_49(+ pos_96 1))" +" table_168)))" +" table_167)))))" +" for-loop_218)" +" '#hasheq()" +" lst_221" +" start_35)))))" +"(let-values(((ht_76)" +"(if merge-serialization?_0" +"(hash-set" +" sequence-ht_0" +" 'data" +"(1/hash->linklet-directory" +"(hasheq" +" #f" +"(1/hash->linklet-bundle" +"(hasheq 0(build-shared-data-linklet cims_3 ns_58))))))" +" sequence-ht_0)))" +"(if to-source?_1" +"(let-values() ht_76)" +"(let-values()" +"(compiled-in-memory1.1" +"(1/hash->linklet-directory ht_76)" +" #f" +" #f" +" #f" +" '#hasheqv()" +" #f" +" '#hasheqv()" +" '#()" +" '#()" +" cims_3" +" null" +" #f" +" #f))))))))))))))))" +"(define-values" +"(compiled-top->compiled-tops)" +"(lambda(ld_0)" +"(begin" +"(let-values(((ht_117)(1/linklet-directory->hash ld_0)))" +"(reverse$1" +"(let-values(((start_36) 0)((end_25)(hash-count ht_117))((inc_19) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_36 end_25 inc_19)))" +"((letrec-values(((for-loop_196)" +"(lambda(fold-var_173 pos_97)" +"(begin" +" 'for-loop" +"(if(< pos_97 end_25)" +"(let-values(((i_42) pos_97))" +"(let-values(((fold-var_217)" +"(let-values(((top_0)" +"(hash-ref" +" ht_117" +"(string->symbol(number->string i_42))" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_219)" +"(lambda(fold-var_174)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_218)" +"(let-values(((fold-var_75)" +" fold-var_174))" +"(if top_0" +"(let-values(((fold-var_65)" +" fold-var_75))" +"(let-values(((fold-var_76)" +"(let-values()" +"(cons" +"(let-values()" +" top_0)" +" fold-var_65))))" +"(values" +" fold-var_76)))" +" fold-var_75))))" +" fold-var_218))))))" +" for-loop_219)" +" fold-var_173)))))" +"(if(not #f)(for-loop_196 fold-var_217(+ pos_97 inc_19)) fold-var_217)))" +" fold-var_173)))))" +" for-loop_196)" +" null" +" start_36))))))))" +"(define-values" +"(remove-nontail-purely-functional)" +"(lambda(cims_4)" +"(begin" +"((letrec-values(((loop_85)" +"(lambda(cims_5)" +"(begin" +" 'loop" +"(if(null? cims_5)" +"(let-values() null)" +"(if(null?(cdr cims_5))" +"(let-values() cims_5)" +"(if(if(compiled-in-memory?(car cims_5))" +"(compiled-in-memory-purely-functional?(car cims_5))" +" #f)" +"(let-values()(loop_85(cdr cims_5)))" +"(let-values()(cons(car cims_5)(cdr cims_5))))))))))" +" loop_85)" +" cims_4))))" +"(define-values" +"(struct:known-defined/delay known-defined/delay2.1 known-defined/delay? known-defined/delay-thunk)" +"(let-values(((struct:_70 make-_70 ?_70 -ref_70 -set!_70)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-defined/delay #f 1 0 #f null 'prefab #f '(0) #f 'known-defined/delay)))))" +"(values struct:_70 make-_70 ?_70(make-struct-field-accessor -ref_70 0 'thunk))))" +"(define-values" +"(struct:known-property known-property3.1 known-property?)" +"(let-values(((struct:_64 make-_64 ?_64 -ref_64 -set!_64)" +"(let-values()" +"(let-values()(make-struct-type 'known-property #f 0 0 #f null 'prefab #f '() #f 'known-property)))))" +"(values struct:_64 make-_64 ?_64)))" +"(define-values" +"(struct:known-function known-function4.1 known-function? known-function-arity known-function-pure?)" +"(let-values(((struct:_71 make-_71 ?_71 -ref_71 -set!_71)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-function #f 2 0 #f null 'prefab #f '(0 1) #f 'known-function)))))" +"(values" +" struct:_71" +" make-_71" +" ?_71" +"(make-struct-field-accessor -ref_71 0 'arity)" +"(make-struct-field-accessor -ref_71 1 'pure?))))" +"(define-values" +"(struct:known-function-of-satisfying" +" known-function-of-satisfying5.1" +" known-function-of-satisfying?" +" known-function-of-satisfying-arg-predicate-keys)" +"(let-values(((struct:_42 make-_42 ?_42 -ref_42 -set!_42)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'known-function-of-satisfying" +" #f" +" 1" +" 0" +" #f" +" null" +" 'prefab" +" #f" +" '(0)" +" #f" +" 'known-function-of-satisfying)))))" +"(values struct:_42 make-_42 ?_42(make-struct-field-accessor -ref_42 0 'arg-predicate-keys))))" +"(define-values" +"(struct:known-predicate known-predicate6.1 known-predicate? known-predicate-key)" +"(let-values(((struct:_11 make-_11 ?_11 -ref_11 -set!_11)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-predicate #f 1 0 #f null 'prefab #f '(0) #f 'known-predicate)))))" +"(values struct:_11 make-_11 ?_11(make-struct-field-accessor -ref_11 0 'key))))" +"(define-values" +"(struct:known-satisfies known-satisfies7.1 known-satisfies? known-satisfies-predicate-key)" +"(let-values(((struct:_72 make-_72 ?_72 -ref_72 -set!_72)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-satisfies #f 1 0 #f null 'prefab #f '(0) #f 'known-satisfies)))))" +"(values struct:_72 make-_72 ?_72(make-struct-field-accessor -ref_72 0 'predicate-key))))" +"(define-values" +"(struct:known-struct-op known-struct-op8.1 known-struct-op? known-struct-op-type known-struct-op-field-count)" +"(let-values(((struct:_39 make-_39 ?_39 -ref_39 -set!_39)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-struct-op #f 2 0 #f null 'prefab #f '(0 1) #f 'known-struct-op)))))" +"(values" +" struct:_39" +" make-_39" +" ?_39" +"(make-struct-field-accessor -ref_39 0 'type)" +"(make-struct-field-accessor -ref_39 1 'field-count))))" +"(define-values" +"(lookup-defn)" +"(lambda(defns_0 sym_61)" +"(begin" +"(let-values(((d_29)(hash-ref defns_0 sym_61 #f)))" +"(if(known-defined/delay? d_29)" +"(let-values()(begin((known-defined/delay-thunk d_29))(lookup-defn defns_0 sym_61)))" +"(let-values() d_29))))))" +"(define-values" +"(any-side-effects?9.1)" +"(lambda(known-defns2_0 known-locals1_0 ready-variable?3_0 e7_0 expected-results8_0)" +"(begin" +" 'any-side-effects?9" +"(let-values(((e_37) e7_0))" +"(let-values(((expected-results_0) expected-results8_0))" +"(let-values(((locals_0)(if(eq? known-locals1_0 unsafe-undefined) '#hasheq() known-locals1_0)))" +"(let-values(((defns_1)(if(eq? known-defns2_0 unsafe-undefined) '#hasheq() known-defns2_0)))" +"(let-values(((ready-variable?_0)" +"(if(eq? ready-variable?3_0 unsafe-undefined)" +"(lambda(id_51)(begin 'ready-variable? #f))" +" ready-variable?3_0)))" +"(let-values()" +"(let-values(((effects?_0)" +"(lambda(e_38 expected-results_1 locals_1)" +"(begin" +" 'effects?" +"(let-values(((e12_0) e_38)" +"((expected-results13_0) expected-results_1)" +"((locals14_0) locals_1)" +"((defns15_0) defns_1)" +"((ready-variable?16_0) ready-variable?_0))" +"(any-side-effects?9.1" +" defns15_0" +" locals14_0" +" ready-variable?16_0" +" e12_0" +" expected-results13_0))))))" +"(let-values(((actual-results_0)" +"((letrec-values(((loop_82)" +"(lambda(e_39 locals_2)" +"(begin" +" 'loop" +"(let-values(((tmp_26)" +"(if(pair?(correlated-e e_39))" +"(correlated-e(car(correlated-e e_39)))" +" #f)))" +"(let-values(((index_1)" +"(if(symbol? tmp_26)" +"(hash-ref" +" '#hasheq((#%variable-reference . 1)" +"(begin . 5)" +"(begin0 . 6)" +"(case-lambda . 1)" +"(gensym . 11)" +"(if . 12)" +"(lambda . 1)" +"(let-values . 2)" +"(letrec-values . 2)" +"(make-struct-field-accessor . 8)" +"(make-struct-field-mutator . 9)" +"(make-struct-type . 7)" +"(make-struct-type-property . 10)" +"(quote . 1)" +"(values . 3)" +"(void . 4))" +" tmp_26" +"(lambda() 0))" +" 0)))" +"(if(unsafe-fx< index_1 6)" +"(if(unsafe-fx< index_1 2)" +"(if(unsafe-fx< index_1 1)" +"(let-values()" +"(let-values(((v_32)(correlated-e e_39)))" +"(if(let-values(((or-part_73)(string? v_32)))" +"(if or-part_73" +" or-part_73" +"(let-values(((or-part_74)" +"(number? v_32)))" +"(if or-part_74" +" or-part_74" +"(let-values(((or-part_75)" +"(boolean? v_32)))" +"(if or-part_75" +" or-part_75" +"(char? v_32)))))))" +"(let-values() 1)" +"(let-values(((c1_26)" +"(if(pair? v_32)" +"(let-values(((rator_0)" +"(correlated-e" +"(car v_32))))" +"(let-values(((or-part_29)" +"(hash-ref" +" locals_2" +" rator_0" +" #f)))" +"(if or-part_29" +" or-part_29" +"(lookup-defn" +" defns_1" +" rator_0))))" +" #f)))" +"(if c1_26" +"((lambda(d_30)" +"(let-values(((ok?_17 _17_0 e18_0)" +"(let-values(((s_90) e_39))" +"(let-values(((orig-s_23)" +" s_90))" +"(let-values(((_17_1" +" e18_1)" +"(let-values(((s_307)" +"(if(1/syntax?" +" s_90)" +"(syntax-e$2" +" s_90)" +" s_90)))" +"(if(pair?" +" s_307)" +"(let-values(((_19_0)" +"(let-values(((s_91)" +"(car" +" s_307)))" +" s_91))" +"((e20_0)" +"(let-values(((s_168)" +"(cdr" +" s_307)))" +"(let-values(((s_308)" +"(if(1/syntax?" +" s_168)" +"(syntax-e$2" +" s_168)" +" s_168)))" +"(let-values(((flat-s_13)" +"(to-syntax-list.1$1" +" s_308)))" +"(if(not" +" flat-s_13)" +"(let-values()" +"((lambda(false_0" +" str_5" +" e_40)" +"(error" +" str_5))" +" #f" +" \"bad syntax\"" +" orig-s_23))" +"(let-values()" +" flat-s_13)))))))" +"(values" +" _19_0" +" e20_0))" +"((lambda(false_1" +" str_6" +" e_41)" +"(error" +" str_6))" +" #f" +" \"bad syntax\"" +" orig-s_23)))))" +"(values" +" #t" +" _17_1" +" e18_1))))))" +"(let-values(((n-args_0)" +"(length e18_0)))" +"(if(let-values(((or-part_225)" +"(if(let-values(((or-part_226)" +"(if(known-struct-op?" +" d_30)" +"(if(eq?" +" 'constructor" +"(known-struct-op-type" +" d_30))" +"(=" +"(known-struct-op-field-count" +" d_30)" +" n-args_0)" +" #f)" +" #f)))" +"(if or-part_226" +" or-part_226" +"(if(known-function?" +" d_30)" +"(if(known-function-pure?" +" d_30)" +"(arity-includes?" +"(known-function-arity" +" d_30)" +" n-args_0)" +" #f)" +" #f)))" +"(let-values(((lst_223)" +" e18_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_223)))" +"((letrec-values(((for-loop_220)" +"(lambda(result_80" +" lst_224)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_224)" +"(let-values(((e_42)" +"(unsafe-car" +" lst_224))" +"((rest_122)" +"(unsafe-cdr" +" lst_224)))" +"(let-values(((result_81)" +"(let-values()" +"(let-values(((result_82)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_42" +" 1" +" locals_2))))))" +"(values" +" result_82)))))" +"(if(if(not" +"((lambda x_57" +"(not" +" result_81))" +" e_42))" +"(not" +" #f)" +" #f)" +"(for-loop_220" +" result_81" +" rest_122)" +" result_81)))" +" result_80)))))" +" for-loop_220)" +" #t" +" lst_223)))" +" #f)))" +"(if or-part_225" +" or-part_225" +"(if(known-function-of-satisfying?" +" d_30)" +"(if(=" +" n-args_0" +"(length" +"(known-function-of-satisfying-arg-predicate-keys" +" d_30)))" +"(let-values(((lst_97)" +" e18_0)" +"((lst_225)" +"(known-function-of-satisfying-arg-predicate-keys" +" d_30)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_97)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_225)))" +"((letrec-values(((for-loop_101)" +"(lambda(result_83" +" lst_179" +" lst_10)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_179)" +"(pair?" +" lst_10)" +" #f)" +"(let-values(((e_3)" +"(unsafe-car" +" lst_179))" +"((rest_1)" +"(unsafe-cdr" +" lst_179))" +"((key_63)" +"(unsafe-car" +" lst_10))" +"((rest_123)" +"(unsafe-cdr" +" lst_10)))" +"(let-values(((result_84)" +"(let-values()" +"(let-values(((result_85)" +"(let-values()" +"(let-values()" +"(if(not" +"(effects?_0" +" e_3" +" 1" +" locals_2))" +"(satisfies?" +" e_3" +" key_63" +" defns_1" +" locals_2)" +" #f)))))" +"(values" +" result_85)))))" +"(if(if(not" +"((lambda x_58" +"(not" +" result_84))" +" e_3))" +"(if(not" +"((lambda x_9" +"(not" +" result_84))" +" key_63))" +"(not" +" #f)" +" #f)" +" #f)" +"(for-loop_101" +" result_84" +" rest_1" +" rest_123)" +" result_84)))" +" result_83)))))" +" for-loop_101)" +" #t" +" lst_97" +" lst_225)))" +" #f)" +" #f)))" +" 1" +" #f))))" +" c1_26)" +"(let-values()" +"(if(let-values(((or-part_167)" +"(self-quoting-in-linklet?" +" v_32)))" +"(if or-part_167" +" or-part_167" +"(if(symbol? v_32)" +"(let-values(((or-part_65)" +"(hash-ref" +" locals_2" +" v_32" +" #f)))" +"(if or-part_65" +" or-part_65" +"(let-values(((or-part_227)" +"(lookup-defn" +" defns_1" +" v_32)))" +"(if or-part_227" +" or-part_227" +"(let-values(((or-part_66)" +"(built-in-symbol?" +" v_32)))" +"(if or-part_66" +" or-part_66" +"(ready-variable?_0" +" v_32)))))))" +" #f)))" +" 1" +" #f)))))))" +"(let-values() 1))" +"(if(unsafe-fx< index_1 3)" +"(let-values()" +"(let-values(((ok?_18" +" _21_0" +" ids22_0" +" rhs23_0" +" body24_0)" +"(let-values(((s_46) e_39))" +"(let-values(((orig-s_24) s_46))" +"(let-values(((_21_1" +" ids22_1" +" rhs23_1" +" body24_1)" +"(let-values(((s_309)" +"(if(1/syntax?" +" s_46)" +"(syntax-e$2" +" s_46)" +" s_46)))" +"(if(pair? s_309)" +"(let-values(((_25_0)" +"(let-values(((s_28)" +"(car" +" s_309)))" +" s_28))" +"((ids26_0" +" rhs27_0" +" body28_0)" +"(let-values(((s_29)" +"(cdr" +" s_309)))" +"(let-values(((s_30)" +"(if(1/syntax?" +" s_29)" +"(syntax-e$2" +" s_29)" +" s_29)))" +"(if(pair?" +" s_30)" +"(let-values(((ids29_0" +" rhs30_0)" +"(let-values(((s_310)" +"(car" +" s_30)))" +"(let-values(((s_311)" +"(if(1/syntax?" +" s_310)" +"(syntax-e$2" +" s_310)" +" s_310)))" +"(let-values(((flat-s_14)" +"(to-syntax-list.1$1" +" s_311)))" +"(if(not" +" flat-s_14)" +"(let-values()" +"((lambda(false_2" +" str_7" +" e_43)" +"(error" +" str_7))" +" #f" +" \"bad syntax\"" +" orig-s_24))" +"(let-values()" +"(let-values(((ids_8" +" rhs_4)" +"(let-values(((lst_193)" +" flat-s_14))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_193)))" +"((letrec-values(((for-loop_204)" +"(lambda(ids_9" +" rhs_5" +" lst_226)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_226)" +"(let-values(((s_49)" +"(unsafe-car" +" lst_226))" +"((rest_124)" +"(unsafe-cdr" +" lst_226)))" +"(let-values(((ids_10" +" rhs_6)" +"(let-values(((ids_11)" +" ids_9)" +"((rhs_7)" +" rhs_5))" +"(let-values(((ids_12" +" rhs_8)" +"(let-values()" +"(let-values(((ids36_0" +" rhs37_0)" +"(let-values()" +"(let-values(((s_166)" +"(if(1/syntax?" +" s_49)" +"(syntax-e$2" +" s_49)" +" s_49)))" +"(if(pair?" +" s_166)" +"(let-values(((ids32_0)" +"(let-values(((s_54)" +"(car" +" s_166)))" +" s_54))" +"((rhs33_0)" +"(let-values(((s_312)" +"(cdr" +" s_166)))" +"(let-values(((s_93)" +"(if(1/syntax?" +" s_312)" +"(syntax-e$2" +" s_312)" +" s_312)))" +"(if(pair?" +" s_93)" +"(let-values(((rhs34_0)" +"(let-values(((s_94)" +"(car" +" s_93)))" +" s_94))" +"(()" +"(let-values(((s_313)" +"(cdr" +" s_93)))" +"(let-values(((s_314)" +"(if(1/syntax?" +" s_313)" +"(syntax-e$2" +" s_313)" +" s_313)))" +"(if(null?" +" s_314)" +"(values)" +"((lambda(false_3" +" str_8" +" e_44)" +"(error" +" str_8))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" rhs34_0))" +"((lambda(false_4" +" str_9" +" e_45)" +"(error" +" str_9))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" ids32_0" +" rhs33_0))" +"((lambda(false_5" +" str_10" +" e_46)" +"(error" +" str_10))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +"(cons" +" ids36_0" +" ids_11)" +"(cons" +" rhs37_0" +" rhs_7))))))" +"(values" +" ids_12" +" rhs_8)))))" +"(if(not" +" #f)" +"(for-loop_204" +" ids_10" +" rhs_6" +" rest_124)" +"(values" +" ids_10" +" rhs_6))))" +"(values" +" ids_9" +" rhs_5))))))" +" for-loop_204)" +" null" +" null" +" lst_193)))))" +"(values" +"(reverse$1" +" ids_8)" +"(reverse$1" +" rhs_4)))))))))" +"((body31_0)" +"(let-values(((s_96)" +"(cdr" +" s_30)))" +"(let-values(((s_57)" +"(if(1/syntax?" +" s_96)" +"(syntax-e$2" +" s_96)" +" s_96)))" +"(if(pair?" +" s_57)" +"(let-values(((body35_0)" +"(let-values(((s_305)" +"(car" +" s_57)))" +" s_305))" +"(()" +"(let-values(((s_315)" +"(cdr" +" s_57)))" +"(let-values(((s_316)" +"(if(1/syntax?" +" s_315)" +"(syntax-e$2" +" s_315)" +" s_315)))" +"(if(null?" +" s_316)" +"(values)" +"((lambda(false_6" +" str_11" +" e_47)" +"(error" +" str_11))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" body35_0))" +"((lambda(false_7" +" str_12" +" e_48)" +"(error" +" str_12))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" ids29_0" +" rhs30_0" +" body31_0))" +"((lambda(false_8" +" str_13" +" e_49)" +"(error" +" str_13))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" _25_0" +" ids26_0" +" rhs27_0" +" body28_0))" +"((lambda(false_9" +" str_14" +" e_50)" +"(error" +" str_14))" +" #f" +" \"bad syntax\"" +" orig-s_24)))))" +"(values" +" #t" +" _21_1" +" ids22_1" +" rhs23_1" +" body24_1))))))" +"(if(not" +"(let-values(((lst_198) ids22_0)" +"((lst_227) rhs23_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_198)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_227)))" +"((letrec-values(((for-loop_221)" +"(lambda(result_13" +" lst_200" +" lst_228)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_200)" +"(pair?" +" lst_228)" +" #f)" +"(let-values(((ids_13)" +"(unsafe-car" +" lst_200))" +"((rest_125)" +"(unsafe-cdr" +" lst_200))" +"((rhs_9)" +"(unsafe-car" +" lst_228))" +"((rest_126)" +"(unsafe-cdr" +" lst_228)))" +"(let-values(((result_86)" +"(let-values()" +"(let-values(((result_87)" +"(let-values()" +"(let-values()" +"(effects?_0" +" rhs_9" +"(correlated-length" +" ids_13)" +" locals_2)))))" +"(values" +" result_87)))))" +"(if(if(not" +"((lambda x_59" +" result_86)" +" ids_13))" +"(if(not" +"((lambda x_60" +" result_86)" +" rhs_9))" +"(not" +" #f)" +" #f)" +" #f)" +"(for-loop_221" +" result_86" +" rest_125" +" rest_126)" +" result_86)))" +" result_13)))))" +" for-loop_221)" +" #f" +" lst_198" +" lst_227))))" +"(loop_82" +" body24_0" +"(add-binding-info locals_2 ids22_0 rhs23_0))" +" #f)))" +"(if(unsafe-fx< index_1 4)" +"(let-values()" +"(let-values(((ok?_19 _38_0 e39_0)" +"(let-values(((s_317) e_39))" +"(let-values(((orig-s_25) s_317))" +"(let-values(((_38_1 e39_1)" +"(let-values(((s_318)" +"(if(1/syntax?" +" s_317)" +"(syntax-e$2" +" s_317)" +" s_317)))" +"(if(pair?" +" s_318)" +"(let-values(((_40_0)" +"(let-values(((s_209)" +"(car" +" s_318)))" +" s_209))" +"((e41_0)" +"(let-values(((s_38)" +"(cdr" +" s_318)))" +"(let-values(((s_319)" +"(if(1/syntax?" +" s_38)" +"(syntax-e$2" +" s_38)" +" s_38)))" +"(let-values(((flat-s_15)" +"(to-syntax-list.1$1" +" s_319)))" +"(if(not" +" flat-s_15)" +"(let-values()" +"((lambda(false_10" +" str_15" +" e_51)" +"(error" +" str_15))" +" #f" +" \"bad syntax\"" +" orig-s_25))" +"(let-values()" +" flat-s_15)))))))" +"(values" +" _40_0" +" e41_0))" +"((lambda(false_11" +" str_16" +" e_52)" +"(error" +" str_16))" +" #f" +" \"bad syntax\"" +" orig-s_25)))))" +"(values #t _38_1 e39_1))))))" +"(if(let-values(((lst_229) e39_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_229)))" +"((letrec-values(((for-loop_222)" +"(lambda(result_88" +" lst_230)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_230)" +"(let-values(((e_53)" +"(unsafe-car" +" lst_230))" +"((rest_127)" +"(unsafe-cdr" +" lst_230)))" +"(let-values(((result_89)" +"(let-values()" +"(let-values(((result_90)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_53" +" 1" +" locals_2))))))" +"(values" +" result_90)))))" +"(if(if(not" +"((lambda x_61" +"(not" +" result_89))" +" e_53))" +"(not" +" #f)" +" #f)" +"(for-loop_222" +" result_89" +" rest_127)" +" result_89)))" +" result_88)))))" +" for-loop_222)" +" #t" +" lst_229)))" +"(length e39_0)" +" #f)))" +"(if(unsafe-fx< index_1 5)" +"(let-values()" +"(let-values(((ok?_20 _42_0 e43_0)" +"(let-values(((s_320) e_39))" +"(let-values(((orig-s_26)" +" s_320))" +"(let-values(((_42_1 e43_1)" +"(let-values(((s_321)" +"(if(1/syntax?" +" s_320)" +"(syntax-e$2" +" s_320)" +" s_320)))" +"(if(pair?" +" s_321)" +"(let-values(((_44_0)" +"(let-values(((s_322)" +"(car" +" s_321)))" +" s_322))" +"((e45_0)" +"(let-values(((s_323)" +"(cdr" +" s_321)))" +"(let-values(((s_71)" +"(if(1/syntax?" +" s_323)" +"(syntax-e$2" +" s_323)" +" s_323)))" +"(let-values(((flat-s_16)" +"(to-syntax-list.1$1" +" s_71)))" +"(if(not" +" flat-s_16)" +"(let-values()" +"((lambda(false_12" +" str_17" +" e_54)" +"(error" +" str_17))" +" #f" +" \"bad syntax\"" +" orig-s_26))" +"(let-values()" +" flat-s_16)))))))" +"(values" +" _44_0" +" e45_0))" +"((lambda(false_13" +" str_18" +" e_55)" +"(error" +" str_18))" +" #f" +" \"bad syntax\"" +" orig-s_26)))))" +"(values #t _42_1 e43_1))))))" +"(if(let-values(((lst_231) e43_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_231)))" +"((letrec-values(((for-loop_223)" +"(lambda(result_91" +" lst_232)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_232)" +"(let-values(((e_56)" +"(unsafe-car" +" lst_232))" +"((rest_128)" +"(unsafe-cdr" +" lst_232)))" +"(let-values(((result_29)" +"(let-values()" +"(let-values(((result_30)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_56" +" 1" +" locals_2))))))" +"(values" +" result_30)))))" +"(if(if(not" +"((lambda x_27" +"(not" +" result_29))" +" e_56))" +"(not" +" #f)" +" #f)" +"(for-loop_223" +" result_29" +" rest_128)" +" result_29)))" +" result_91)))))" +" for-loop_223)" +" #t" +" lst_231)))" +" 1" +" #f)))" +"(let-values()" +"(let-values(((ok?_21 _46_0 e47_0)" +"(let-values(((s_324) e_39))" +"(let-values(((orig-s_27)" +" s_324))" +"(let-values(((_46_1 e47_1)" +"(let-values(((s_325)" +"(if(1/syntax?" +" s_324)" +"(syntax-e$2" +" s_324)" +" s_324)))" +"(if(pair?" +" s_325)" +"(let-values(((_48_0)" +"(let-values(((s_221)" +"(car" +" s_325)))" +" s_221))" +"((e49_0)" +"(let-values(((s_326)" +"(cdr" +" s_325)))" +"(let-values(((s_327)" +"(if(1/syntax?" +" s_326)" +"(syntax-e$2" +" s_326)" +" s_326)))" +"(let-values(((flat-s_17)" +"(to-syntax-list.1$1" +" s_327)))" +"(if(not" +" flat-s_17)" +"(let-values()" +"((lambda(false_14" +" str_19" +" e_31)" +"(error" +" str_19))" +" #f" +" \"bad syntax\"" +" orig-s_27))" +"(let-values()" +" flat-s_17)))))))" +"(values" +" _48_0" +" e49_0))" +"((lambda(false_15" +" str_20" +" e_57)" +"(error" +" str_20))" +" #f" +" \"bad syntax\"" +" orig-s_27)))))" +"(values #t _46_1 e47_1))))))" +"((letrec-values(((bloop_0)" +"(lambda(es_1)" +"(begin" +" 'bloop" +"(if(null? es_1)" +"(let-values() #f)" +"(if(null?(cdr es_1))" +"(let-values()" +"(loop_82" +"(car es_1)" +" locals_2))" +"(let-values()" +"(if(not" +"(effects?_0" +"(car es_1)" +" #f" +" locals_2))" +"(bloop_0" +"(cdr es_1))" +" #f))))))))" +" bloop_0)" +" e47_0)))))))" +"(if(unsafe-fx< index_1 9)" +"(if(unsafe-fx< index_1 7)" +"(let-values()" +"(let-values(((ok?_22 _50_0 e051_0 e52_0)" +"(let-values(((s_116) e_39))" +"(let-values(((orig-s_0) s_116))" +"(let-values(((_50_1 e051_1 e52_1)" +"(let-values(((s_120)" +"(if(1/syntax?" +" s_116)" +"(syntax-e$2" +" s_116)" +" s_116)))" +"(if(pair? s_120)" +"(let-values(((_53_0)" +"(let-values(((s_227)" +"(car" +" s_120)))" +" s_227))" +"((e054_0" +" e55_0)" +"(let-values(((s_163)" +"(cdr" +" s_120)))" +"(let-values(((s_164)" +"(if(1/syntax?" +" s_163)" +"(syntax-e$2" +" s_163)" +" s_163)))" +"(if(pair?" +" s_164)" +"(let-values(((e056_0)" +"(let-values(((s_328)" +"(car" +" s_164)))" +" s_328))" +"((e57_0)" +"(let-values(((s_329)" +"(cdr" +" s_164)))" +"(let-values(((s_228)" +"(if(1/syntax?" +" s_329)" +"(syntax-e$2" +" s_329)" +" s_329)))" +"(let-values(((flat-s_18)" +"(to-syntax-list.1$1" +" s_228)))" +"(if(not" +" flat-s_18)" +"(let-values()" +"((lambda(false_16" +" str_21" +" e_58)" +"(error" +" str_21))" +" #f" +" \"bad syntax\"" +" orig-s_0))" +"(let-values()" +" flat-s_18)))))))" +"(values" +" e056_0" +" e57_0))" +"((lambda(false_17" +" str_22" +" e_59)" +"(error" +" str_22))" +" #f" +" \"bad syntax\"" +" orig-s_0))))))" +"(values" +" _53_0" +" e054_0" +" e55_0))" +"((lambda(false_18" +" str_23" +" e_60)" +"(error" +" str_23))" +" #f" +" \"bad syntax\"" +" orig-s_0)))))" +"(values" +" #t" +" _50_1" +" e051_1" +" e52_1))))))" +"(if(let-values(((lst_233) e52_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_233)))" +"((letrec-values(((for-loop_224)" +"(lambda(result_92" +" lst_119)" +"(begin" +" 'for-loop" +"(if(pair? lst_119)" +"(let-values(((e_61)" +"(unsafe-car" +" lst_119))" +"((rest_129)" +"(unsafe-cdr" +" lst_119)))" +"(let-values(((result_93)" +"(let-values()" +"(let-values(((result_94)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_61" +" #f" +" locals_2))))))" +"(values" +" result_94)))))" +"(if(if(not" +"((lambda x_62" +"(not" +" result_93))" +" e_61))" +"(not #f)" +" #f)" +"(for-loop_224" +" result_93" +" rest_129)" +" result_93)))" +" result_92)))))" +" for-loop_224)" +" #t" +" lst_233)))" +"(loop_82 e051_0 locals_2)" +" #f)))" +"(if(unsafe-fx< index_1 8)" +"(let-values()" +"(if(ok-make-struct-type?" +" e_39" +" ready-variable?_0" +" defns_1)" +" 5" +" #f))" +"(let-values()" +"(if(ok-make-struct-field-accessor/mutator?" +" e_39" +" locals_2" +" 'general-accessor" +" defns_1)" +" 1" +" #f))))" +"(if(unsafe-fx< index_1 10)" +"(let-values()" +"(if(ok-make-struct-field-accessor/mutator?" +" e_39" +" locals_2" +" 'general-mutator" +" defns_1)" +" 1" +" #f))" +"(if(unsafe-fx< index_1 11)" +"(let-values()" +"(if(ok-make-struct-type-property? e_39 defns_1)" +" 3" +" #f))" +"(if(unsafe-fx< index_1 12)" +"(let-values()" +"(let-values(((ok?_23 gs58_0 quot59_0 datum60_0)" +"(let-values(((s_234) e_39))" +"(if(let-values(((s_235)" +"(if(1/syntax?" +" s_234)" +"(syntax-e$2" +" s_234)" +" s_234)))" +"(if(pair? s_235)" +"(if(let-values(((s_330)" +"(car" +" s_235)))" +" #t)" +"(let-values(((s_133)" +"(cdr" +" s_235)))" +"(let-values(((s_236)" +"(if(1/syntax?" +" s_133)" +"(syntax-e$2" +" s_133)" +" s_133)))" +"(if(pair? s_236)" +"(if(let-values(((s_237)" +"(car" +" s_236)))" +"(let-values(((s_331)" +"(if(1/syntax?" +" s_237)" +"(syntax-e$2" +" s_237)" +" s_237)))" +"(if(pair?" +" s_331)" +"(if(let-values(((s_332)" +"(car" +" s_331)))" +" #t)" +"(let-values(((s_134)" +"(cdr" +" s_331)))" +"(let-values(((s_333)" +"(if(1/syntax?" +" s_134)" +"(syntax-e$2" +" s_134)" +" s_134)))" +"(if(pair?" +" s_333)" +"(if(let-values(((s_334)" +"(car" +" s_333)))" +" #t)" +"(let-values(((s_335)" +"(cdr" +" s_333)))" +"(let-values(((s_336)" +"(if(1/syntax?" +" s_335)" +"(syntax-e$2" +" s_335)" +" s_335)))" +"(null?" +" s_336)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +"(let-values(((s_337)" +"(cdr" +" s_236)))" +"(let-values(((s_338)" +"(if(1/syntax?" +" s_337)" +"(syntax-e$2" +" s_337)" +" s_337)))" +"(null?" +" s_338)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((gs58_1" +" quot59_1" +" datum60_1)" +"(let-values(((s_339)" +"(if(1/syntax?" +" s_234)" +"(syntax-e$2" +" s_234)" +" s_234)))" +"(let-values(((gs61_0)" +"(let-values(((s_340)" +"(car" +" s_339)))" +" s_340))" +"((quot62_0" +" datum63_0)" +"(let-values(((s_341)" +"(cdr" +" s_339)))" +"(let-values(((s_342)" +"(if(1/syntax?" +" s_341)" +"(syntax-e$2" +" s_341)" +" s_341)))" +"(let-values(((quot64_0" +" datum65_0)" +"(let-values(((s_343)" +"(car" +" s_342)))" +"(let-values(((s_344)" +"(if(1/syntax?" +" s_343)" +"(syntax-e$2" +" s_343)" +" s_343)))" +"(let-values(((quot66_0)" +"(let-values(((s_239)" +"(car" +" s_344)))" +" s_239))" +"((datum67_0)" +"(let-values(((s_345)" +"(cdr" +" s_344)))" +"(let-values(((s_346)" +"(if(1/syntax?" +" s_345)" +"(syntax-e$2" +" s_345)" +" s_345)))" +"(let-values(((datum68_0)" +"(let-values(((s_240)" +"(car" +" s_346)))" +" s_240))" +"(()" +"(let-values(((s_241)" +"(cdr" +" s_346)))" +"(let-values(((s_242)" +"(if(1/syntax?" +" s_241)" +"(syntax-e$2" +" s_241)" +" s_241)))" +"(values)))))" +"(values" +" datum68_0))))))" +"(values" +" quot66_0" +" datum67_0)))))" +"(()" +"(let-values(((s_347)" +"(cdr" +" s_342)))" +"(let-values(((s_348)" +"(if(1/syntax?" +" s_347)" +"(syntax-e$2" +" s_347)" +" s_347)))" +"(values)))))" +"(values" +" quot64_0" +" datum65_0))))))" +"(values" +" gs61_0" +" quot62_0" +" datum63_0)))))" +"(values" +" #t" +" gs58_1" +" quot59_1" +" datum60_1)))" +"(values #f #f #f #f)))))" +"(if(let-values(((or-part_228)" +"(if ok?_23" +"(if(eq? 'quote quot59_0)" +"(let-values(((or-part_229)" +"(symbol?" +" datum60_0)))" +"(if or-part_229" +" or-part_229" +"(string?" +" datum60_0)))" +" #f)" +" #f)))" +"(if or-part_228" +" or-part_228" +"(null?(cdr(correlated-e e_39)))))" +" 1" +" #f)))" +"(let-values()" +"(let-values(((ok?_24" +" _69_0" +" id:rator70_0" +" id:arg71_0" +" thn72_0" +" els73_0)" +"(let-values(((s_349) e_39))" +"(if(let-values(((s_350)" +"(if(1/syntax?" +" s_349)" +"(syntax-e$2" +" s_349)" +" s_349)))" +"(if(pair? s_350)" +"(if(let-values(((s_351)" +"(car" +" s_350)))" +" #t)" +"(let-values(((s_352)" +"(cdr" +" s_350)))" +"(let-values(((s_353)" +"(if(1/syntax?" +" s_352)" +"(syntax-e$2" +" s_352)" +" s_352)))" +"(if(pair? s_353)" +"(if(let-values(((s_248)" +"(car" +" s_353)))" +"(let-values(((s_354)" +"(if(1/syntax?" +" s_248)" +"(syntax-e$2" +" s_248)" +" s_248)))" +"(if(pair?" +" s_354)" +"(if(let-values(((s_355)" +"(car" +" s_354)))" +"(let-values(((or-part_230)" +"(if(1/syntax?" +" s_355)" +"(symbol?" +"(syntax-e$2" +" s_355))" +" #f)))" +"(if or-part_230" +" or-part_230" +"(symbol?" +" s_355))))" +"(let-values(((s_356)" +"(cdr" +" s_354)))" +"(let-values(((s_249)" +"(if(1/syntax?" +" s_356)" +"(syntax-e$2" +" s_356)" +" s_356)))" +"(if(pair?" +" s_249)" +"(if(let-values(((s_250)" +"(car" +" s_249)))" +"(let-values(((or-part_231)" +"(if(1/syntax?" +" s_250)" +"(symbol?" +"(syntax-e$2" +" s_250))" +" #f)))" +"(if or-part_231" +" or-part_231" +"(symbol?" +" s_250))))" +"(let-values(((s_357)" +"(cdr" +" s_249)))" +"(let-values(((s_358)" +"(if(1/syntax?" +" s_357)" +"(syntax-e$2" +" s_357)" +" s_357)))" +"(null?" +" s_358)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +"(let-values(((s_359)" +"(cdr" +" s_353)))" +"(let-values(((s_252)" +"(if(1/syntax?" +" s_359)" +"(syntax-e$2" +" s_359)" +" s_359)))" +"(if(pair?" +" s_252)" +"(if(let-values(((s_360)" +"(car" +" s_252)))" +" #t)" +"(let-values(((s_253)" +"(cdr" +" s_252)))" +"(let-values(((s_254)" +"(if(1/syntax?" +" s_253)" +"(syntax-e$2" +" s_253)" +" s_253)))" +"(if(pair?" +" s_254)" +"(if(let-values(((s_361)" +"(car" +" s_254)))" +" #t)" +"(let-values(((s_362)" +"(cdr" +" s_254)))" +"(let-values(((s_255)" +"(if(1/syntax?" +" s_362)" +"(syntax-e$2" +" s_362)" +" s_362)))" +"(null?" +" s_255)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((_69_1" +" id:rator70_1" +" id:arg71_1" +" thn72_1" +" els73_1)" +"(let-values(((s_363)" +"(if(1/syntax?" +" s_349)" +"(syntax-e$2" +" s_349)" +" s_349)))" +"(let-values(((_74_0)" +"(let-values(((s_364)" +"(car" +" s_363)))" +" s_364))" +"((id:rator75_0" +" id:arg76_0" +" thn77_0" +" els78_0)" +"(let-values(((s_365)" +"(cdr" +" s_363)))" +"(let-values(((s_366)" +"(if(1/syntax?" +" s_365)" +"(syntax-e$2" +" s_365)" +" s_365)))" +"(let-values(((id:rator79_0" +" id:arg80_0)" +"(let-values(((s_367)" +"(car" +" s_366)))" +"(let-values(((s_368)" +"(if(1/syntax?" +" s_367)" +"(syntax-e$2" +" s_367)" +" s_367)))" +"(let-values(((id:rator83_0)" +"(let-values(((s_369)" +"(car" +" s_368)))" +" s_369))" +"((id:arg84_0)" +"(let-values(((s_370)" +"(cdr" +" s_368)))" +"(let-values(((s_371)" +"(if(1/syntax?" +" s_370)" +"(syntax-e$2" +" s_370)" +" s_370)))" +"(let-values(((id:arg85_0)" +"(let-values(((s_372)" +"(car" +" s_371)))" +" s_372))" +"(()" +"(let-values(((s_373)" +"(cdr" +" s_371)))" +"(let-values(((s_374)" +"(if(1/syntax?" +" s_373)" +"(syntax-e$2" +" s_373)" +" s_373)))" +"(values)))))" +"(values" +" id:arg85_0))))))" +"(values" +" id:rator83_0" +" id:arg84_0)))))" +"((thn81_0" +" els82_0)" +"(let-values(((s_375)" +"(cdr" +" s_366)))" +"(let-values(((s_376)" +"(if(1/syntax?" +" s_375)" +"(syntax-e$2" +" s_375)" +" s_375)))" +"(let-values(((thn86_0)" +"(let-values(((s_259)" +"(car" +" s_376)))" +" s_259))" +"((els87_0)" +"(let-values(((s_377)" +"(cdr" +" s_376)))" +"(let-values(((s_378)" +"(if(1/syntax?" +" s_377)" +"(syntax-e$2" +" s_377)" +" s_377)))" +"(let-values(((els88_0)" +"(let-values(((s_379)" +"(car" +" s_378)))" +" s_379))" +"(()" +"(let-values(((s_380)" +"(cdr" +" s_378)))" +"(let-values(((s_260)" +"(if(1/syntax?" +" s_380)" +"(syntax-e$2" +" s_380)" +" s_380)))" +"(values)))))" +"(values" +" els88_0))))))" +"(values" +" thn86_0" +" els87_0))))))" +"(values" +" id:rator79_0" +" id:arg80_0" +" thn81_0" +" els82_0))))))" +"(values" +" _74_0" +" id:rator75_0" +" id:arg76_0" +" thn77_0" +" els78_0)))))" +"(values" +" #t" +" _69_1" +" id:rator70_1" +" id:arg71_1" +" thn72_1" +" els73_1)))" +"(values #f #f #f #f #f #f)))))" +"(if ok?_24" +"(let-values()" +"(let-values(((c2_2)" +"(let-values(((or-part_232)" +"(hash-ref" +" locals_2" +" id:rator70_0" +" #f)))" +"(if or-part_232" +" or-part_232" +"(lookup-defn" +" defns_1" +" id:rator70_0)))))" +"(if c2_2" +"((lambda(d_31)" +"(if(known-predicate? d_31)" +"(if(not" +"(effects?_0" +" thn72_0" +" expected-results_0" +"(hash-set" +" locals_2" +" id:arg71_0" +"(known-satisfies7.1" +"(known-predicate-key" +" d_31)))))" +"(loop_82 els73_0 locals_2)" +" #f)" +" #f))" +" c2_2)" +"(let-values() #f))))" +"(let-values()" +"(let-values(((ok?_25" +" _89_0" +" tst90_0" +" thn91_0" +" els92_0)" +"(let-values(((s_381) e_39))" +"(if(let-values(((s_382)" +"(if(1/syntax?" +" s_381)" +"(syntax-e$2" +" s_381)" +" s_381)))" +"(if(pair? s_382)" +"(if(let-values(((s_383)" +"(car" +" s_382)))" +" #t)" +"(let-values(((s_384)" +"(cdr" +" s_382)))" +"(let-values(((s_385)" +"(if(1/syntax?" +" s_384)" +"(syntax-e$2" +" s_384)" +" s_384)))" +"(if(pair?" +" s_385)" +"(if(let-values(((s_386)" +"(car" +" s_385)))" +" #t)" +"(let-values(((s_136)" +"(cdr" +" s_385)))" +"(let-values(((s_387)" +"(if(1/syntax?" +" s_136)" +"(syntax-e$2" +" s_136)" +" s_136)))" +"(if(pair?" +" s_387)" +"(if(let-values(((s_388)" +"(car" +" s_387)))" +" #t)" +"(let-values(((s_389)" +"(cdr" +" s_387)))" +"(let-values(((s_390)" +"(if(1/syntax?" +" s_389)" +"(syntax-e$2" +" s_389)" +" s_389)))" +"(if(pair?" +" s_390)" +"(if(let-values(((s_391)" +"(car" +" s_390)))" +" #t)" +"(let-values(((s_392)" +"(cdr" +" s_390)))" +"(let-values(((s_137)" +"(if(1/syntax?" +" s_392)" +"(syntax-e$2" +" s_392)" +" s_392)))" +"(null?" +" s_137)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((_89_1" +" tst90_1" +" thn91_1" +" els92_1)" +"(let-values(((s_138)" +"(if(1/syntax?" +" s_381)" +"(syntax-e$2" +" s_381)" +" s_381)))" +"(let-values(((_93_0)" +"(let-values(((s_393)" +"(car" +" s_138)))" +" s_393))" +"((tst94_0" +" thn95_0" +" els96_0)" +"(let-values(((s_394)" +"(cdr" +" s_138)))" +"(let-values(((s_395)" +"(if(1/syntax?" +" s_394)" +"(syntax-e$2" +" s_394)" +" s_394)))" +"(let-values(((tst97_0)" +"(let-values(((s_396)" +"(car" +" s_395)))" +" s_396))" +"((thn98_0" +" els99_0)" +"(let-values(((s_397)" +"(cdr" +" s_395)))" +"(let-values(((s_141)" +"(if(1/syntax?" +" s_397)" +"(syntax-e$2" +" s_397)" +" s_397)))" +"(let-values(((thn100_0)" +"(let-values(((s_398)" +"(car" +" s_141)))" +" s_398))" +"((els101_0)" +"(let-values(((s_399)" +"(cdr" +" s_141)))" +"(let-values(((s_142)" +"(if(1/syntax?" +" s_399)" +"(syntax-e$2" +" s_399)" +" s_399)))" +"(let-values(((els102_0)" +"(let-values(((s_400)" +"(car" +" s_142)))" +" s_400))" +"(()" +"(let-values(((s_401)" +"(cdr" +" s_142)))" +"(let-values(((s_402)" +"(if(1/syntax?" +" s_401)" +"(syntax-e$2" +" s_401)" +" s_401)))" +"(values)))))" +"(values" +" els102_0))))))" +"(values" +" thn100_0" +" els101_0))))))" +"(values" +" tst97_0" +" thn98_0" +" els99_0))))))" +"(values" +" _93_0" +" tst94_0" +" thn95_0" +" els96_0)))))" +"(values" +" #t" +" _89_1" +" tst90_1" +" thn91_1" +" els92_1)))" +"(values" +" #f" +" #f" +" #f" +" #f" +" #f)))))" +"(if ok?_25" +"(if(not" +"(effects?_0 tst90_0 1 locals_2))" +"(if(not" +"(effects?_0" +" thn91_0" +" expected-results_0" +" locals_2))" +"(loop_82 els92_0 locals_2)" +" #f)" +" #f)" +" #f)))))))))))))))))" +" loop_82)" +" e_37" +" locals_0)))" +"(not" +"(if actual-results_0" +"(let-values(((or-part_233)(not expected-results_0)))" +"(if or-part_233 or-part_233(= actual-results_0 expected-results_0)))" +" #f)))))))))))))" +"(define-values" +"(satisfies?)" +"(lambda(e_62 key_50 defns_2 locals_3)" +"(begin" +"(let-values(((d_32)" +"(let-values(((or-part_234)(hash-ref locals_3 e_62 #f)))" +"(if or-part_234 or-part_234(lookup-defn defns_2 e_62)))))" +"(if d_32(if(known-satisfies? d_32)(eq? key_50(known-satisfies-predicate-key d_32)) #f) #f)))))" +"(define-values" +"(add-binding-info)" +"(lambda(locals_4 idss_0 rhss_0)" +"(begin" +"(let-values(((lst_234) idss_0)((lst_235) rhss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_234)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_235)))" +"((letrec-values(((for-loop_149)" +"(lambda(locals_5 lst_236 lst_237)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_236)(pair? lst_237) #f)" +"(let-values(((ids_14)(unsafe-car lst_236))" +"((rest_130)(unsafe-cdr lst_236))" +"((rhs_10)(unsafe-car lst_237))" +"((rest_131)(unsafe-cdr lst_237)))" +"(let-values(((locals_6)" +"(let-values(((locals_7) locals_5))" +"(let-values(((locals_8)" +"(let-values()" +"((letrec-values(((loop_93)" +"(lambda(rhs_11)" +"(begin" +" 'loop" +"(let-values(((tmp_27)" +"(if(pair?" +"(correlated-e" +" rhs_11))" +"(correlated-e" +"(car" +"(correlated-e" +" rhs_11)))" +" #f)))" +"(if(equal?" +" tmp_27" +" 'make-struct-type)" +"(let-values()" +"(let-values(((field-count_0)" +"(extract-struct-field-count-lower-bound" +" rhs_11)))" +"(let-values(((lst_238)" +"(correlated->list" +" ids_14))" +"((lst_239)" +" '(struct-type" +" constructor" +" predicate" +" general-accessor" +" general-mutator)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_238)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_239)))" +"((letrec-values(((for-loop_225)" +"(lambda(locals_9" +" lst_240" +" lst_241)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_240)" +"(pair?" +" lst_241)" +" #f)" +"(let-values(((id_52)" +"(unsafe-car" +" lst_240))" +"((rest_132)" +"(unsafe-cdr" +" lst_240))" +"((type_0)" +"(unsafe-car" +" lst_241))" +"((rest_133)" +"(unsafe-cdr" +" lst_241)))" +"(let-values(((locals_10)" +"(let-values(((locals_11)" +" locals_9))" +"(let-values(((locals_12)" +"(let-values()" +"(hash-set" +" locals_11" +"(correlated-e" +" id_52)" +"(known-struct-op8.1" +" type_0" +" field-count_0)))))" +"(values" +" locals_12)))))" +"(if(not" +" #f)" +"(for-loop_225" +" locals_10" +" rest_132" +" rest_133)" +" locals_10)))" +" locals_9)))))" +" for-loop_225)" +" locals_7" +" lst_238" +" lst_239)))))" +"(if(equal?" +" tmp_27" +" 'let-values)" +"(let-values()" +"(if(null?" +"(correlated-e" +"(correlated-cadr" +" rhs_11)))" +"(loop_93" +"(caddr" +"(correlated->list" +" rhs_11)))" +"(loop_93 #f)))" +"(let-values()" +"(let-values(((lst_242)" +"(correlated->list" +" ids_14)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_242)))" +"((letrec-values(((for-loop_226)" +"(lambda(locals_13" +" lst_243)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_243)" +"(let-values(((id_53)" +"(unsafe-car" +" lst_243))" +"((rest_134)" +"(unsafe-cdr" +" lst_243)))" +"(let-values(((locals_14)" +"(let-values(((locals_15)" +" locals_13))" +"(let-values(((locals_16)" +"(let-values()" +"(hash-set" +" locals_15" +"(correlated-e" +" id_53)" +" #t))))" +"(values" +" locals_16)))))" +"(if(not" +" #f)" +"(for-loop_226" +" locals_14" +" rest_134)" +" locals_14)))" +" locals_13)))))" +" for-loop_226)" +" locals_7" +" lst_242)))))))))))" +" loop_93)" +" rhs_10))))" +"(values locals_8)))))" +"(if(not #f)(for-loop_149 locals_6 rest_130 rest_131) locals_6)))" +" locals_5)))))" +" for-loop_149)" +" locals_4" +" lst_234" +" lst_235))))))" +"(define-values" +"(ok-make-struct-type-property?)" +"(lambda(e_63 defns_3)" +"(begin" +"(let-values(((l_57)(correlated->list e_63)))" +"(if(<= 2(length l_57) 5)" +"(let-values(((lst_244)(cdr l_57))" +"((lst_245)" +"(list" +"(lambda(v_166)(quoted? symbol? v_166))" +"(lambda(v_167)(is-lambda? v_167 2 defns_3))" +"(lambda(v_168)(ok-make-struct-type-property-super? v_168 defns_3))" +"(lambda(v_169)" +"(let-values(((v103_0) v_169)((temp104_1) 1)((defns105_0) defns_3))" +"(any-side-effects?9.1 defns105_0 unsafe-undefined unsafe-undefined v103_0 temp104_1))))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_244)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_245)))" +"((letrec-values(((for-loop_227)" +"(lambda(result_95 lst_246 lst_60)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_246)(pair? lst_60) #f)" +"(let-values(((arg_0)(unsafe-car lst_246))" +"((rest_27)(unsafe-cdr lst_246))" +"((pred_1)(unsafe-car lst_60))" +"((rest_135)(unsafe-cdr lst_60)))" +"(let-values(((result_96)" +"(let-values()" +"(let-values(((result_97)" +"(let-values()(let-values()(pred_1 arg_0)))))" +"(values result_97)))))" +"(if(if(not((lambda x_63(not result_96)) arg_0))" +"(if(not((lambda x_64(not result_96)) pred_1))(not #f) #f)" +" #f)" +"(for-loop_227 result_96 rest_27 rest_135)" +" result_96)))" +" result_95)))))" +" for-loop_227)" +" #t" +" lst_244" +" lst_245)))" +" #f)))))" +"(define-values" +"(ok-make-struct-type-property-super?)" +"(lambda(v_170 defns_4)" +"(begin" +"(let-values(((or-part_235)(quoted? null? v_170)))" +"(if or-part_235" +" or-part_235" +"(let-values(((or-part_236)(eq? 'null(correlated-e v_170))))" +"(if or-part_236" +" or-part_236" +"(if(pair?(correlated-e v_170))" +"(if(eq?(correlated-e(car(correlated-e v_170))) 'list)" +"(if(let-values(((lst_247)(cdr(correlated->list v_170))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_247)))" +"((letrec-values(((for-loop_228)" +"(lambda(result_98 lst_64)" +"(begin" +" 'for-loop" +"(if(pair? lst_64)" +"(let-values(((prop+val_0)(unsafe-car lst_64))" +"((rest_29)(unsafe-cdr lst_64)))" +"(let-values(((result_99)" +"(let-values()" +"(let-values(((result_100)" +"(let-values()" +"(let-values()" +"(if(=" +"(correlated-length" +" prop+val_0)" +" 3)" +"(let-values(((prop+val_1)" +"(correlated->list" +" prop+val_0)))" +"(if(eq?" +" 'cons" +"(correlated-e" +"(car prop+val_1)))" +"(if(let-values(((or-part_237)" +"(memq" +"(correlated-e" +"(list-ref" +" prop+val_1" +" 1))" +" '(prop:procedure" +" prop:equal+hash" +" prop:custom-write))))" +"(if or-part_237" +" or-part_237" +"(known-property?" +"(lookup-defn" +" defns_4" +"(correlated-e" +"(list-ref" +" prop+val_1" +" 1))))))" +"(not" +"(let-values(((temp106_1)" +"(list-ref" +" prop+val_1" +" 2))" +"((temp107_0)" +" 1)" +"((defns108_0)" +" defns_4))" +"(any-side-effects?9.1" +" defns108_0" +" unsafe-undefined" +" unsafe-undefined" +" temp106_1" +" temp107_0)))" +" #f)" +" #f))" +" #f)))))" +"(values result_100)))))" +"(if(if(not((lambda x_65(not result_99)) prop+val_0))" +"(not #f)" +" #f)" +"(for-loop_228 result_99 rest_29)" +" result_99)))" +" result_98)))))" +" for-loop_228)" +" #t" +" lst_247)))" +"(=" +"(sub1(correlated-length v_170))" +"(set-count" +"(let-values(((lst_248)(cdr(correlated->list v_170))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_248)))" +"((letrec-values(((for-loop_229)" +"(lambda(table_171 lst_249)" +"(begin" +" 'for-loop" +"(if(pair? lst_249)" +"(let-values(((prop+val_2)(unsafe-car lst_249))" +"((rest_136)(unsafe-cdr lst_249)))" +"(let-values(((table_172)" +"(let-values(((table_173) table_171))" +"(let-values(((table_174)" +"(let-values()" +"(let-values(((key_64 val_55)" +"(let-values()" +"(values" +"(let-values()" +"(correlated-e" +"(list-ref" +"(correlated->list" +" prop+val_2)" +" 1)))" +" #t))))" +"(hash-set" +" table_173" +" key_64" +" val_55)))))" +"(values table_174)))))" +"(if(not #f)(for-loop_229 table_172 rest_136) table_172)))" +" table_171)))))" +" for-loop_229)" +" '#hash()" +" lst_248)))))" +" #f)" +" #f)" +" #f))))))))" +"(define-values" +"(ok-make-struct-type?)" +"(lambda(e_64 ready-variable?_1 defns_5)" +"(begin" +"(let-values(((l_58)(correlated->list e_64)))" +"(let-values(((init-field-count-expr_0)(if(>(length l_58) 3)(list-ref l_58 3) #f)))" +"(let-values(((auto-field-count-expr_0)(if(>(length l_58) 4)(list-ref l_58 4) #f)))" +"(let-values(((num-fields_0)" +"(maybe+" +"(field-count-expr-to-field-count init-field-count-expr_0)" +"(field-count-expr-to-field-count auto-field-count-expr_0))))" +"(let-values(((immutables-expr_0)" +"(let-values(((or-part_238)(if(>(length l_58) 9)(list-ref l_58 9) #f)))" +"(if or-part_238 or-part_238 'null))))" +"(let-values(((super-expr_0)(if(>(length l_58) 2)(list-ref l_58 2) #f)))" +"(if(>=(length l_58) 5)" +"(if(<=(length l_58) 12)" +"(let-values(((lst_250)(cdr l_58))" +"((lst_251)" +"(list" +"(lambda(v_171)(quoted? symbol? v_171))" +"(lambda(v_172)(super-ok? v_172 defns_5))" +"(lambda(v_173)(field-count-expr-to-field-count v_173))" +"(lambda(v_174)(field-count-expr-to-field-count v_174))" +"(lambda(v_175)" +"(not" +"(let-values(((v109_0) v_175)" +"((temp110_0) 1)" +"((ready-variable?111_0) ready-variable?_1)" +"((defns112_0) defns_5))" +"(any-side-effects?9.1" +" defns112_0" +" unsafe-undefined" +" ready-variable?111_0" +" v109_0" +" temp110_0))))" +"(lambda(v_176)" +"(known-good-struct-properties? v_176 immutables-expr_0 super-expr_0 defns_5))" +"(lambda(v_177)(inspector-or-false? v_177))" +"(lambda(v_178)(procedure-spec? v_178 num-fields_0))" +"(lambda(v_179)(immutables-ok? v_179 init-field-count-expr_0)))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_250)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_251)))" +"((letrec-values(((for-loop_230)" +"(lambda(result_101 lst_252 lst_253)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_252)(pair? lst_253) #f)" +"(let-values(((arg_1)(unsafe-car lst_252))" +"((rest_137)(unsafe-cdr lst_252))" +"((pred_2)(unsafe-car lst_253))" +"((rest_138)(unsafe-cdr lst_253)))" +"(let-values(((result_102)" +"(let-values()" +"(let-values(((result_103)" +"(let-values()" +"(let-values()(pred_2 arg_1)))))" +"(values result_103)))))" +"(if(if(not((lambda x_66(not result_102)) arg_1))" +"(if(not((lambda x_67(not result_102)) pred_2))" +"(not #f)" +" #f)" +" #f)" +"(for-loop_230 result_102 rest_137 rest_138)" +" result_102)))" +" result_101)))))" +" for-loop_230)" +" #t" +" lst_250" +" lst_251)))" +" #f)" +" #f))))))))))" +"(define-values" +"(super-ok?)" +"(lambda(e_65 defns_6)" +"(begin" +"(let-values(((or-part_239)(quoted? false? e_65)))" +"(if or-part_239" +" or-part_239" +"(let-values(((o_0)(lookup-defn defns_6(correlated-e e_65))))" +"(if o_0(if(known-struct-op? o_0)(eq? 'struct-type(known-struct-op-type o_0)) #f) #f)))))))" +"(define-values" +"(extract-struct-field-count-lower-bound)" +"(lambda(e_66)" +"(begin" +"(let-values(((l_59)(correlated->list e_66)))" +"(+(field-count-expr-to-field-count(list-ref l_59 3))(field-count-expr-to-field-count(list-ref l_59 4)))))))" +"(define-values" +"(quoted?)" +"(lambda(val?_0 v_180)" +"(begin" +"(let-values(((or-part_240)" +"(if(pair?(correlated-e v_180))" +"(if(eq?(correlated-e(car(correlated-e v_180))) 'quote)" +"(val?_0(correlated-e(correlated-cadr v_180)))" +" #f)" +" #f)))" +"(if or-part_240 or-part_240(val?_0(correlated-e v_180)))))))" +"(define-values" +"(quoted-value)" +"(lambda(v_181)" +"(begin(if(pair?(correlated-e v_181))(correlated-e(correlated-cadr v_181))(correlated-e v_181)))))" +"(define-values(false?)(lambda(v_182)(begin(eq?(correlated-e v_182) #f))))" +"(define-values" +"(field-count-expr-to-field-count)" +"(lambda(v_183)(begin(if(quoted? exact-nonnegative-integer? v_183)(quoted-value v_183) #f))))" +"(define-values" +"(inspector-or-false?)" +"(lambda(v_184)" +"(begin" +"(let-values(((or-part_241)(quoted? false? v_184)))" +"(if or-part_241" +" or-part_241" +"(let-values(((or-part_242)(if(quoted? symbol? v_184)(eq? 'prefab(quoted-value v_184)) #f)))" +"(if or-part_242" +" or-part_242" +"(if(= 1(correlated-length v_184))" +"(eq? 'current-inspector(correlated-e(car(correlated-e v_184))))" +" #f))))))))" +"(define-values" +"(known-good-struct-properties?)" +"(lambda(v_185 immutables-expr_1 super-expr_1 defns_7)" +"(begin" +"(let-values(((or-part_243)(quoted? null? v_185)))" +"(if or-part_243" +" or-part_243" +"(let-values(((or-part_244)(eq? 'null(correlated-e v_185))))" +"(if or-part_244" +" or-part_244" +"(if(pair?(correlated-e v_185))" +"(if(eq?(correlated-e(car(correlated-e v_185))) 'list)" +"(if(let-values(((lst_254)(cdr(correlated->list v_185))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_254)))" +"((letrec-values(((for-loop_231)" +"(lambda(result_104 lst_255)" +"(begin" +" 'for-loop" +"(if(pair? lst_255)" +"(let-values(((prop+val_3)(unsafe-car lst_255))" +"((rest_139)(unsafe-cdr lst_255)))" +"(let-values(((result_105)" +"(let-values()" +"(let-values(((result_106)" +"(let-values()" +"(let-values()" +"(if(=" +"(correlated-length" +" prop+val_3)" +" 3)" +"(let-values(((prop+val_4)" +"(correlated->list" +" prop+val_3)))" +"(if(eq?" +" 'cons" +"(correlated-e" +"(car prop+val_4)))" +"(known-good-struct-property+value?" +"(list-ref prop+val_4 1)" +"(list-ref prop+val_4 2)" +" immutables-expr_1" +" super-expr_1" +" defns_7)" +" #f))" +" #f)))))" +"(values result_106)))))" +"(if(if(not((lambda x_68(not result_105)) prop+val_3))" +"(not #f)" +" #f)" +"(for-loop_231 result_105 rest_139)" +" result_105)))" +" result_104)))))" +" for-loop_231)" +" #t" +" lst_254)))" +"(=" +"(sub1(correlated-length v_185))" +"(set-count" +"(let-values(((lst_256)(cdr(correlated->list v_185))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_256)))" +"((letrec-values(((for-loop_232)" +"(lambda(table_175 lst_136)" +"(begin" +" 'for-loop" +"(if(pair? lst_136)" +"(let-values(((prop+val_5)(unsafe-car lst_136))" +"((rest_140)(unsafe-cdr lst_136)))" +"(let-values(((table_176)" +"(let-values(((table_177) table_175))" +"(let-values(((table_178)" +"(let-values()" +"(let-values(((key_65 val_56)" +"(let-values()" +"(values" +"(let-values()" +"(correlated-e" +"(list-ref" +"(correlated->list" +" prop+val_5)" +" 1)))" +" #t))))" +"(hash-set" +" table_177" +" key_65" +" val_56)))))" +"(values table_178)))))" +"(if(not #f)(for-loop_232 table_176 rest_140) table_176)))" +" table_175)))))" +" for-loop_232)" +" '#hash()" +" lst_256)))))" +" #f)" +" #f)" +" #f))))))))" +"(define-values" +"(known-good-struct-property+value?)" +"(lambda(prop-expr_0 val-expr_0 immutables-expr_2 super-expr_2 defns_8)" +"(begin" +"(let-values(((prop-name_0)(correlated-e prop-expr_0)))" +"(let-values(((tmp_28) prop-name_0))" +"(if(equal? tmp_28 'prop:evt)" +"(let-values()" +"(let-values(((or-part_245)(is-lambda? val-expr_0 1 defns_8)))" +"(if or-part_245 or-part_245(immutable-field? val-expr_0 immutables-expr_2))))" +"(if(equal? tmp_28 'prop:procedure)" +"(let-values()" +"(let-values(((or-part_246)(is-lambda? val-expr_0 1 defns_8)))" +"(if or-part_246 or-part_246(immutable-field? val-expr_0 immutables-expr_2))))" +"(if(equal? tmp_28 'prop:custom-write)" +"(let-values()(is-lambda? val-expr_0 3 defns_8))" +"(if(equal? tmp_28 'prop:equal+hash)" +"(let-values()" +"(let-values(((l_60)(correlated->list val-expr_0)))" +"(if(eq? 'list(car l_60))" +"(if(is-lambda?(list-ref l_60 1) 3 defns_8)" +"(if(is-lambda?(list-ref l_60 2) 2 defns_8)(is-lambda?(list-ref l_60 3) 2 defns_8) #f)" +" #f)" +" #f)))" +"(if(if(equal? tmp_28 'prop:method-arity-error) #t(equal? tmp_28 'prop:incomplete-arity))" +"(let-values()" +"(not" +"(let-values(((val-expr113_0) val-expr_0)((temp114_0) 1)((defns115_0) defns_8))" +"(any-side-effects?9.1 defns115_0 unsafe-undefined unsafe-undefined val-expr113_0 temp114_0))))" +"(if(equal? tmp_28 'prop:impersonator-of)" +"(let-values()(is-lambda? val-expr_0 1 defns_8))" +"(if(equal? tmp_28 'prop:arity-string)" +"(let-values()(is-lambda? val-expr_0 1 defns_8))" +"(if(equal? tmp_28 'prop:checked-procedure)" +"(let-values()(if(quoted? false? super-expr_2)(immutable-field? 1 immutables-expr_2) #f))" +"(let-values()" +"(let-values(((o_1)(lookup-defn defns_8 prop-name_0)))" +"(if o_1" +"(if(known-property? o_1)" +"(not" +"(let-values(((val-expr116_0) val-expr_0)((temp117_0) 1)((defns118_0) defns_8))" +"(any-side-effects?9.1" +" defns118_0" +" unsafe-undefined" +" unsafe-undefined" +" val-expr116_0" +" temp117_0)))" +" #f)" +" #f))))))))))))))))" +"(define-values" +"(is-lambda?)" +"(lambda(expr_9 arity_0 defns_9)" +"(begin" +"(let-values(((lookup_0)(lookup-defn defns_9 expr_9)))" +"(let-values(((or-part_247)" +"(if lookup_0" +"(if(known-function? lookup_0)" +"(let-values(((or-part_248)(not arity_0)))" +"(if or-part_248 or-part_248(arity-includes?(known-function-arity lookup_0) arity_0)))" +" #f)" +" #f)))" +"(if or-part_247" +" or-part_247" +"(let-values(((or-part_249)" +"(if(pair?(correlated-e expr_9))" +"(if(eq? 'case-lambda(car(correlated-e expr_9)))(not arity_0) #f)" +" #f)))" +"(if or-part_249" +" or-part_249" +"(if(pair?(correlated-e expr_9))" +"(if(eq? 'lambda(car(correlated-e expr_9)))" +"(let-values(((or-part_250)(not arity_0)))" +"(if or-part_250" +" or-part_250" +"((letrec-values(((loop_94)" +"(lambda(args_4 arity_1)" +"(begin" +" 'loop" +"(if(correlated? args_4)" +"(let-values()(loop_94(correlated-e args_4) arity_1))" +"(if(null? args_4)" +"(let-values()(zero? arity_1))" +"(if(pair? args_4)" +"(let-values()(loop_94(cdr args_4)(sub1 arity_1)))" +"(let-values()(not(negative? arity_1))))))))))" +" loop_94)" +"(cadr(correlated->list expr_9))" +" arity_0)))" +" #f)" +" #f)))))))))" +"(define-values" +"(arity-includes?)" +"(lambda(a_44 n_26)" +"(begin" +"(let-values(((or-part_251)(equal? a_44 n_26)))" +"(if or-part_251" +" or-part_251" +"(if(list? a_44)" +"(let-values(((lst_257) a_44))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_257)))" +"((letrec-values(((for-loop_233)" +"(lambda(result_107 lst_258)" +"(begin" +" 'for-loop" +"(if(pair? lst_258)" +"(let-values(((a_45)(unsafe-car lst_258))((rest_141)(unsafe-cdr lst_258)))" +"(let-values(((result_108)" +"(let-values()" +"(let-values(((result_109)" +"(let-values()" +"(let-values()(equal? a_45 n_26)))))" +"(values result_109)))))" +"(if(if(not((lambda x_69 result_108) a_45))(not #f) #f)" +"(for-loop_233 result_108 rest_141)" +" result_108)))" +" result_107)))))" +" for-loop_233)" +" #f" +" lst_257)))" +" #f))))))" +"(define-values" +"(immutable-field?)" +"(lambda(val-expr_1 immutables-expr_3)" +"(begin" +"(if(quoted? exact-nonnegative-integer? val-expr_1)" +"(memv(quoted-value val-expr_1)(immutables-expr-to-immutables immutables-expr_3 null))" +" #f))))" +"(define-values" +"(immutables-expr-to-immutables)" +"(lambda(e_67 fail-v_0)" +"(begin" +"(let-values(((tmp_29)(if(pair?(correlated-e e_67))(correlated-e(car(correlated-e e_67))) #f)))" +"(if(equal? tmp_29 'quote)" +"(let-values()" +"(let-values(((v_186)(correlated-cadr e_67)))" +"(let-values(((or-part_252)" +"(if(correlated-length v_186)" +"(let-values(((l_61)(map2 correlated-e(correlated->list v_186))))" +"(if(andmap2 exact-nonnegative-integer? l_61)" +"(if(=(length l_61)(set-count(list->set l_61))) l_61 #f)" +" #f))" +" #f)))" +"(if or-part_252 or-part_252 fail-v_0))))" +"(let-values() fail-v_0))))))" +"(define-values" +"(procedure-spec?)" +"(lambda(e_68 field-count_1)" +"(begin" +"(let-values(((or-part_253)(quoted? false? e_68)))" +"(if or-part_253" +" or-part_253" +"(let-values(((or-part_254)" +"(if(quoted? exact-nonnegative-integer? e_68)" +"(if field-count_1(<(quoted-value e_68) field-count_1) #f)" +" #f)))" +"(if or-part_254 or-part_254(is-lambda? e_68 #f '#hasheq()))))))))" +"(define-values" +"(immutables-ok?)" +"(lambda(e_69 init-field-count-expr_1)" +"(begin" +"(let-values(((l_62)(immutables-expr-to-immutables e_69 #f)))" +"(let-values(((c_24)(field-count-expr-to-field-count init-field-count-expr_1)))" +"(if l_62" +"(let-values(((lst_259) l_62))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_259)))" +"((letrec-values(((for-loop_95)" +"(lambda(result_110 lst_260)" +"(begin" +" 'for-loop" +"(if(pair? lst_260)" +"(let-values(((n_27)(unsafe-car lst_260))((rest_142)(unsafe-cdr lst_260)))" +"(let-values(((result_111)" +"(let-values()" +"(let-values(((result_112)" +"(let-values()(let-values()(< n_27 c_24)))))" +"(values result_112)))))" +"(if(if(not((lambda x_70(not result_111)) n_27))(not #f) #f)" +"(for-loop_95 result_111 rest_142)" +" result_111)))" +" result_110)))))" +" for-loop_95)" +" #t" +" lst_259)))" +" #f))))))" +"(define-values" +"(ok-make-struct-field-accessor/mutator?)" +"(lambda(e_70 locals_17 type_1 defns_10)" +"(begin" +"(let-values(((l_63)(correlated->list e_70)))" +"(let-values(((a_46)" +"(if(let-values(((or-part_255)(=(length l_63) 3)))" +"(if or-part_255 or-part_255(=(length l_63) 4)))" +"(let-values(((or-part_256)(hash-ref locals_17(correlated-e(list-ref l_63 1)) #f)))" +"(if or-part_256 or-part_256(lookup-defn defns_10(correlated-e(list-ref l_63 1)))))" +" #f)))" +"(if(known-struct-op? a_46)" +"(if(eq?(known-struct-op-type a_46) type_1)" +"(if(<(field-count-expr-to-field-count(list-ref l_63 2))(known-struct-op-field-count a_46))" +"(let-values(((or-part_257)(=(length l_63) 3)))" +"(if or-part_257 or-part_257(quoted? symbol?(list-ref l_63 3))))" +" #f)" +" #f)" +" #f))))))" +"(define-values(maybe+)(lambda(x_71 y_10)(begin(if x_71(if y_10(+ x_71 y_10) #f) #f))))" +"(define-values" +"(compile-single)" +"(lambda(p_45 cctx_13)" +"(begin" +"(let-values(((p12_0) p_45)((cctx13_0) cctx_13)((temp14_4) #f)((temp15_4) #t))" +"(compile-top9.1 temp14_4 temp15_4 #f p12_0 cctx13_0)))))" +"(define-values" +"(compile-top9.1)" +"(lambda(serializable?1_0 single-expression?2_0 to-source?3_0 p7_0 cctx8_0)" +"(begin" +" 'compile-top9" +"(let-values(((p_46) p7_0))" +"(let-values(((cctx_14) cctx8_0))" +"(let-values(((serializable?_1) serializable?1_0))" +"(let-values(((single-expression?_0) single-expression?2_0))" +"(let-values(((to-source?_2) to-source?3_0))" +"(let-values()" +"(let-values()" +"(let-values(((phase_84)(compile-context-phase cctx_14)))" +"(let-values(((mpis_18)(make-module-path-index-table)))" +"(let-values(((purely-functional?_0) #t))" +"(let-values(((body-linklets_1" +" min-phase_1" +" max-phase_1" +" phase-to-link-module-uses_3" +" phase-to-link-module-uses-expr_2" +" phase-to-link-extra-inspectorss_0" +" syntax-literals_3" +" no-root-context-pos_0)" +"(let-values(((temp16_4)(list p_46))" +"((cctx17_0) cctx_14)" +"((mpis18_0) mpis_18)" +"((temp19_1)" +"(if single-expression?_0" +"(list* '()(list syntax-literals-id) '(()))" +"(list" +"(list top-level-bind!-id top-level-require!-id)" +"(list mpi-vector-id syntax-literals-id)" +" instance-imports)))" +"((temp20_1)" +"(list" +" top-level-instance" +" empty-top-syntax-literal-instance" +" empty-instance-instance))" +"((to-source?21_0) to-source?_2)" +"((serializable?22_0) serializable?_1)" +"((temp23_3)(lambda()(set! purely-functional?_0 #f)))" +"((temp24_3)" +"(lambda(e_71 expected-results_2 phase_22 required-reference?_0)" +"(if(if purely-functional?_0" +"(let-values(((e27_0) e_71)" +"((expected-results28_0) expected-results_2)" +"((required-reference?29_0)" +" required-reference?_0))" +"(any-side-effects?9.1" +" unsafe-undefined" +" unsafe-undefined" +" required-reference?29_0" +" e27_0" +" expected-results28_0))" +" #f)" +"(let-values()(set! purely-functional?_0 #f))" +"(void))))" +"((temp25_3)" +"(lambda(s_43 cctx_15)" +"(begin" +"(set! purely-functional?_0 #f)" +"(compile-top-level-require s_43 cctx_15))))" +"((temp26_2)(not single-expression?_0)))" +"(compile-forms31.1" +" temp20_1" +" temp19_1" +" null" +" temp24_3" +" temp26_2" +" temp23_3" +" #f" +" null" +" unsafe-undefined" +" temp25_3" +" #f" +" serializable?22_0" +" to-source?21_0" +" temp16_4" +" cctx17_0" +" mpis18_0))))" +"(let-values(((add-metadata_0)" +"(lambda(ht_117)" +"(begin" +" 'add-metadata" +"(let-values(((ht_118)(hash-set ht_117 'original-phase phase_84)))" +"(let-values(((ht_119)(hash-set ht_118 'max-phase max-phase_1)))" +" ht_119))))))" +"(let-values(((bundle_0)" +"((if to-source?_2 values 1/hash->linklet-bundle)" +"(add-metadata_0" +"(if serializable?_1" +"(let-values()" +"(let-values(((syntax-literals-expr_1)" +"(let-values()" +"(generate-eager-syntax-literals!" +" syntax-literals_3" +" mpis_18" +" phase_84" +"(compile-context-self cctx_14)" +"(compile-context-namespace cctx_14)))))" +"(let-values(((link-linklet_0)" +"((if to-source?_2" +" values" +"(lambda(s_35)" +"(let-values()" +"(let-values(((linklet_2 new-keys_0)" +"(1/compile-linklet" +" s_35" +" #f" +"(vector" +" deserialize-instance" +" empty-eager-instance-instance)" +"(lambda(inst_0)" +"(values inst_0 #f)))))" +" linklet_2))))" +"(list" +" 'linklet" +"(list deserialize-imports eager-instance-imports)" +"(list" +" mpi-vector-id" +" deserialized-syntax-vector-id" +" 'phase-to-link-modules" +" syntax-literals-id)" +"(list" +" 'define-values" +"(list mpi-vector-id)" +"(generate-module-path-index-deserialize mpis_18))" +"(list" +" 'define-values" +"(list deserialized-syntax-vector-id)" +"(list* 'make-vector(add1 phase_84) '(#f)))" +"(list" +" 'define-values" +" '(phase-to-link-modules)" +" phase-to-link-module-uses-expr_2)" +"(list" +" 'define-values" +"(list syntax-literals-id)" +" syntax-literals-expr_1)))))" +"(hash-set body-linklets_1 'link link-linklet_0))))" +"(let-values() body-linklets_1))))))" +"(if to-source?_2" +"(let-values()(hasheq #f bundle_0))" +"(let-values()" +"(compiled-in-memory1.1" +"(1/hash->linklet-directory(hasheq #f bundle_0))" +" #f" +" #f" +" #f" +" phase-to-link-module-uses_3" +"(current-code-inspector)" +" phase-to-link-extra-inspectorss_0" +"(mpis-as-vector mpis_18)" +"(syntax-literals-as-vector syntax-literals_3)" +" null" +" null" +"(extract-namespace-scopes(compile-context-namespace cctx_14))" +" purely-functional?_0)))))))))))))))))))" +"(define-values" +"(compile-top-level-require)" +"(lambda(p_47 cctx_16)" +"(begin" +"(let-values(((phase_85)(compile-context-phase cctx_16)))" +"(if(parsed-require? p_47)" +"(let-values()" +"(let-values(((form-stx_0)(compile-quote-syntax(syntax-disarm$1(parsed-s p_47)) cctx_16)))" +"(list top-level-require!-id form-stx_0 ns-id)))" +"(let-values() #f))))))" +"(define-values" +"(select-defined-syms-and-bind!16.1)" +"(lambda(as-transformer?5_0" +" frame-id1_0" +" in4_0" +" requires+provides3_0" +" top-level-bind-scope2_0" +" ids11_0" +" defined-syms12_0" +" self13_0" +" phase14_0" +" all-scopes-stx15_0)" +"(begin" +" 'select-defined-syms-and-bind!16" +"(let-values(((ids_15) ids11_0))" +"(let-values(((defined-syms_8) defined-syms12_0))" +"(let-values(((self_19) self13_0))" +"(let-values(((phase_86) phase14_0))" +"(let-values(((all-scopes-stx_3) all-scopes-stx15_0))" +"(let-values(((frame-id_7) frame-id1_0))" +"(let-values(((top-level-bind-scope_3) top-level-bind-scope2_0))" +"(let-values(((requires+provides_4) requires+provides3_0))" +"(let-values(((orig-s_28) in4_0))" +"(let-values(((as-transformer?_5) as-transformer?5_0))" +"(let-values()" +"(let-values(((defined-syms-at-phase_0)" +"(let-values(((or-part_82)(hash-ref defined-syms_8 phase_86 #f)))" +"(if or-part_82" +" or-part_82" +"(let-values(((ht_120)(make-hasheq)))" +"(begin(hash-set! defined-syms_8 phase_86 ht_120) ht_120))))))" +"(reverse$1" +"(let-values(((lst_261) ids_15))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_261)))" +"((letrec-values(((for-loop_234)" +"(lambda(fold-var_73 lst_90)" +"(begin" +" 'for-loop" +"(if(pair? lst_90)" +"(let-values(((id_54)(unsafe-car lst_90))" +"((rest_143)(unsafe-cdr lst_90)))" +"(let-values(((fold-var_12)" +"(let-values(((fold-var_160) fold-var_73))" +"(let-values(((fold-var_94)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((sym_62)" +"(syntax-e$1" +" id_54)))" +"(let-values(((defined-sym_0)" +"(if(if(not" +"(defined-as-other?" +"(hash-ref" +" defined-syms-at-phase_0" +" sym_62" +" #f)" +" id_54" +" phase_86" +" top-level-bind-scope_3))" +"(if(no-extra-scopes?" +" id_54" +" all-scopes-stx_3" +" top-level-bind-scope_3" +" phase_86)" +"(symbol-interned?" +" sym_62)" +" #f)" +" #f)" +" sym_62" +"((letrec-values(((loop_83)" +"(lambda(pos_98)" +"(begin" +" 'loop" +"(let-values(((s_183)" +"(string->unreadable-symbol" +"(format" +" \"~a.~a\"" +" sym_62" +" pos_98))))" +"(if(defined-as-other?" +"(hash-ref" +" defined-syms-at-phase_0" +" s_183" +" #f)" +" id_54" +" phase_86" +" top-level-bind-scope_3)" +"(loop_83" +"(add1" +" pos_98))" +" s_183))))))" +" loop_83)" +" 1))))" +"(let-values((()" +"(begin" +"(hash-set!" +" defined-syms-at-phase_0" +" defined-sym_0" +" id_54)" +"(values))))" +"(let-values(((b_75)" +"(let-values(((self23_0)" +" self_19)" +"((phase24_0)" +" phase_86)" +"((defined-sym25_0)" +" defined-sym_0)" +"((frame-id26_0)" +" frame-id_7)" +"((sym27_1)" +" sym_62))" +"(make-module-binding22.1" +" #f" +" null" +" frame-id26_0" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" sym27_1" +" unsafe-undefined" +" self23_0" +" phase24_0" +" defined-sym25_0))))" +"(begin" +"(if requires+provides_4" +"(let-values()" +"(let-values(((requires+provides28_0)" +" requires+provides_4)" +"((id29_0)" +" id_54)" +"((phase30_0)" +" phase_86)" +"((b31_0)" +" b_75))" +"(remove-required-id!75.1" +" b31_0" +" requires+provides28_0" +" id29_0" +" phase30_0)))" +"(void))" +"(let-values(((id19_0)" +" id_54)" +"((b20_0)" +" b_75)" +"((phase21_1)" +" phase_86)" +"((orig-s22_0)" +" orig-s_28))" +"(add-binding!17.1" +" orig-s22_0" +" #f" +" id19_0" +" b20_0" +" phase21_1))" +"(if requires+provides_4" +"(let-values()" +"(let-values(((requires+provides32_0)" +" requires+provides_4)" +"((id33_0)" +" id_54)" +"((phase34_0)" +" phase_86)" +"((b35_0)" +" b_75)" +"((as-transformer?36_0)" +" as-transformer?_5))" +"(add-defined-or-required-id!19.1" +" as-transformer?36_0" +" #f" +" requires+provides32_0" +" id33_0" +" phase34_0" +" b35_0)))" +"(void))" +" defined-sym_0))))))" +" fold-var_160))))" +"(values fold-var_94)))))" +"(if(not #f)" +"(for-loop_234 fold-var_12 rest_143)" +" fold-var_12)))" +" fold-var_73)))))" +" for-loop_234)" +" null" +" lst_261)))))))))))))))))))" +"(define-values" +"(no-extra-scopes?)" +"(lambda(id_55 all-scopes-stx_4 top-level-bind-scope_4 phase_72)" +"(begin" +"(let-values(((m-id_0)(datum->syntax$1 all-scopes-stx_4(syntax-e$1 id_55))))" +"(let-values(((or-part_210)(bound-identifier=?$1 id_55 m-id_0 phase_72)))" +"(if or-part_210" +" or-part_210" +"(if top-level-bind-scope_4" +"(bound-identifier=?$1 id_55(add-scope m-id_0 top-level-bind-scope_4) phase_72)" +" #f)))))))" +"(define-values" +"(defined-as-other?)" +"(lambda(prev-id_0 id_56 phase_87 top-level-bind-scope_5)" +"(begin" +"(if prev-id_0" +"(if(not(bound-identifier=?$1 prev-id_0 id_56 phase_87))" +"(let-values(((or-part_258)(not top-level-bind-scope_5)))" +"(if or-part_258" +" or-part_258" +"(not" +"(bound-identifier=?$1" +"(remove-scope prev-id_0 top-level-bind-scope_5)" +"(remove-scope id_56 top-level-bind-scope_5)" +" phase_87))))" +" #f)" +" #f))))" +"(define-values" +"(select-defined-syms-and-bind!/ctx)" +"(lambda(tl-ids_0 ctx_10)" +"(begin" +"(let-values(((tl-ids37_0) tl-ids_0)" +"((temp38_1)(root-expand-context-defined-syms ctx_10))" +"((temp39_2)(root-expand-context-self-mpi ctx_10))" +"((temp40_1)(expand-context-phase ctx_10))" +"((temp41_0)(root-expand-context-all-scopes-stx ctx_10))" +"((temp42_1)(root-expand-context-frame-id ctx_10))" +"((temp43_1)(root-expand-context-top-level-bind-scope ctx_10)))" +"(select-defined-syms-and-bind!16.1" +" #f" +" temp42_1" +" #f" +" #f" +" temp43_1" +" tl-ids37_0" +" temp38_1" +" temp39_2" +" temp40_1" +" temp41_0)))))" +"(define-values" +"(add-defined-sym!)" +"(lambda(defined-syms_9 phase_77 sym_63 id_57)" +"(begin" +"(let-values(((defined-syms-at-phase_1)" +"(let-values(((or-part_219)(hash-ref defined-syms_9 phase_77 #f)))" +"(if or-part_219" +" or-part_219" +"(let-values(((ht_121)(make-hasheq)))" +"(begin(hash-set! defined-syms_9 phase_77 ht_121) ht_121))))))" +"(hash-set! defined-syms-at-phase_1 sym_63 id_57)))))" +"(define-values" +"(make-create-root-expand-context-from-module)" +"(lambda(requires_3 evaled-ld-h_0)" +"(begin" +"(lambda(ns_59 phase-shift_13 original-self_0 self_20)" +"(let-values(((root-ctx_4)" +"(let-values(((temp1_3)(namespace-mpi ns_59)))" +"(make-root-expand-context13.1 #f null unsafe-undefined unsafe-undefined temp1_3))))" +"(let-values(((s_3)(add-scopes empty-syntax(root-expand-context-module-scopes root-ctx_4))))" +"(let-values((()" +"(begin" +"(let-values(((lst_221) requires_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_221)))" +"((letrec-values(((for-loop_235)" +"(lambda(lst_16)" +"(begin" +" 'for-loop" +"(if(pair? lst_16)" +"(let-values(((phase+reqs_0)(unsafe-car lst_16))" +"((rest_4)(unsafe-cdr lst_16)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_34)" +"(car" +" phase+reqs_0)))" +"(begin" +"(let-values(((lst_262)" +"(cdr" +" phase+reqs_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_262)))" +"((letrec-values(((for-loop_236)" +"(lambda(lst_78)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_78)" +"(let-values(((req_4)" +"(unsafe-car" +" lst_78))" +"((rest_36)" +"(unsafe-cdr" +" lst_78)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((mpi_43)" +"(module-path-index-shift" +" req_4" +" original-self_0" +" self_20)))" +"(let-values(((mpi2_1)" +" mpi_43)" +"((s3_0)" +" s_3)" +"((self4_3)" +" self_20)" +"((s5_1)" +" s_3)" +"((ns6_0)" +" ns_59)" +"((temp7_1)" +"(phase+" +" phase_34" +" phase-shift_13))" +"((phase-shift8_0)" +" phase-shift_13)" +"((temp9_2)" +" 'module))" +"(perform-require!78.1" +" #f" +" #t" +" #f" +" #f" +" #f" +" #f" +" 'all" +" temp7_1" +" #f" +" phase-shift8_0" +" #f" +" #f" +" #t" +" temp9_2" +" mpi2_1" +" s3_0" +" self4_3" +" s5_1" +" ns6_0))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_236" +" rest_36)" +"(values))))" +"(values))))))" +" for-loop_236)" +" lst_262)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_235 rest_4)(values))))" +"(values))))))" +" for-loop_235)" +" lst_221)))" +"(values))))" +"(let-values()" +"(let-values(((defined-syms_10)(root-expand-context-defined-syms root-ctx_4)))" +"(begin" +"(let-values(((ht_122) evaled-ld-h_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_122)))" +"((letrec-values(((for-loop_109)" +"(lambda(i_145)" +"(begin" +" 'for-loop" +"(if i_145" +"(let-values(((phase_88 linklet_3)" +"(hash-iterate-key+value ht_122 i_145)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((lst_263)" +"(1/linklet-export-variables" +" linklet_3)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_263)))" +"((letrec-values(((for-loop_237)" +"(lambda(lst_264)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_264)" +"(let-values(((sym_64)" +"(unsafe-car" +" lst_264))" +"((rest_144)" +"(unsafe-cdr" +" lst_264)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_58)" +"(datum->syntax$1" +" s_3" +" sym_64)))" +"(begin" +"(let-values(((id10_0)" +" id_58)" +"((temp11_2)" +"(let-values(((self13_1)" +" self_20)" +"((phase14_1)" +" phase_88)" +"((sym15_0)" +" sym_64))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" self13_1" +" phase14_1" +" sym15_0)))" +"((phase12_0)" +" phase_88))" +"(add-binding!17.1" +" #f" +" #f" +" id10_0" +" temp11_2" +" phase12_0))" +"(add-defined-sym!" +" defined-syms_10" +" phase_88" +" sym_64" +" id_58))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_237" +" rest_144)" +"(values))))" +"(values))))))" +" for-loop_237)" +" lst_263)))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_109(hash-iterate-next ht_122 i_145))" +"(values))))" +"(values))))))" +" for-loop_109)" +"(hash-iterate-first ht_122))))" +"(void)" +" root-ctx_4))))))))))" +"(define-values" +"(shift-to-inside-root-context)" +"(lambda(root-context_0)" +"(begin" +"(let-values(((outside-mpi_0)(root-expand-context-self-mpi root-context_0)))" +"(let-values(((inside-mpi_0)(make-self-module-path-index(module-path-index-resolved outside-mpi_0))))" +"(let-values(((v_187) root-context_0))" +"(let-values(((the-struct_54) v_187))" +"(if(root-expand-context/outer? the-struct_54)" +"(let-values(((inner16_0)" +"(let-values(((the-struct_55)(root-expand-context/outer-inner v_187)))" +"(if(root-expand-context/inner? the-struct_55)" +"(let-values(((self-mpi17_0) inside-mpi_0)" +"((all-scopes-stx18_0)" +"(let-values(((temp19_2)" +"(root-expand-context-all-scopes-stx root-context_0))" +"((outside-mpi20_0) outside-mpi_0)" +"((inside-mpi21_0) inside-mpi_0))" +"(syntax-module-path-index-shift13.1" +" #f" +" temp19_2" +" outside-mpi20_0" +" inside-mpi21_0" +" #f))))" +"(root-expand-context/inner2.1" +" self-mpi17_0" +"(root-expand-context/inner-module-scopes the-struct_55)" +"(root-expand-context/inner-top-level-bind-scope the-struct_55)" +" all-scopes-stx18_0" +"(root-expand-context/inner-defined-syms the-struct_55)" +"(root-expand-context/inner-counter the-struct_55)" +"(root-expand-context/inner-lift-key the-struct_55)))" +" (raise-argument-error 'struct-copy \"root-expand-context/inner?\" the-struct_55)))))" +"(root-expand-context/outer1.1" +" inner16_0" +"(root-expand-context/outer-post-expansion the-struct_54)" +"(root-expand-context/outer-use-site-scopes the-struct_54)" +"(root-expand-context/outer-frame-id the-struct_54)))" +" (raise-argument-error 'struct-copy \"root-expand-context/outer?\" the-struct_54)))))))))" +"(define-values" +"(check-require-access9.1)" +"(lambda(skip-imports1_0" +" linklet3_0" +" import-module-uses4_0" +" import-module-instances5_0" +" insp6_0" +" extra-inspector7_0" +" extra-inspectorsss8_0)" +"(begin" +" 'check-require-access9" +"(let-values(((linklet_4) linklet3_0))" +"(let-values(((skip-num-imports_0) skip-imports1_0))" +"(let-values(((import-module-uses_0) import-module-uses4_0))" +"(let-values(((import-module-instances_0) import-module-instances5_0))" +"(let-values(((insp_10) insp6_0))" +"(let-values(((extra-inspector_6) extra-inspector7_0))" +"(let-values(((extra-inspectorsss_4) extra-inspectorsss8_0))" +"(let-values()" +"(begin" +"(let-values(((lst_41)(list-tail(1/linklet-import-variables linklet_4) skip-num-imports_0))" +"((lst_163) import-module-uses_0)" +"((lst_89) import-module-instances_0)" +"((lst_265)" +"(let-values(((or-part_81) extra-inspectorsss_4))" +"(if or-part_81 or-part_81 import-module-uses_0))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_41)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_163)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_89)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_265)))" +"((letrec-values(((for-loop_237)" +"(lambda(lst_264 lst_261 lst_23 lst_104)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_264)" +"(if(pair? lst_261)(if(pair? lst_23)(pair? lst_104) #f) #f)" +" #f)" +"(let-values(((import-syms_0)(unsafe-car lst_264))" +"((rest_145)(unsafe-cdr lst_264))" +"((mu_7)(unsafe-car lst_261))" +"((rest_85)(unsafe-cdr lst_261))" +"((mi_16)(unsafe-car lst_23))" +"((rest_43)(unsafe-cdr lst_23))" +"((extra-inspectorss_14)(unsafe-car lst_104))" +"((rest_121)(unsafe-cdr lst_104)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((m_15)" +"(module-instance-module" +" mi_16)))" +"(if(module-no-protected?" +" m_15)" +"(void)" +"(let-values()" +"(let-values(((access_2)" +"(let-values(((or-part_8)" +"(module-access" +" m_15)))" +"(if or-part_8" +" or-part_8" +"(module-compute-access!" +" m_15)))))" +"(begin" +"(let-values(((lst_266)" +" import-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_266)))" +"((letrec-values(((for-loop_238)" +"(lambda(lst_25)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_25)" +"(let-values(((import-sym_0)" +"(unsafe-car" +" lst_25))" +"((rest_9)" +"(unsafe-cdr" +" lst_25)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((a_47)" +"(hash-ref" +"(hash-ref" +" access_2" +"(module-use-phase" +" mu_7)" +" '#hasheq())" +" import-sym_0" +" 'unexported)))" +"(if(let-values(((or-part_21)" +"(eq?" +" a_47" +" 'unexported)))" +"(if or-part_21" +" or-part_21" +"(eq?" +" a_47" +" 'protected)))" +"(let-values()" +"(let-values(((guard-insp_3)" +"(namespace-inspector" +"(module-instance-namespace" +" mi_16))))" +"(if(let-values(((or-part_259)" +"(inspector-superior?" +" insp_10" +" guard-insp_3)))" +"(if or-part_259" +" or-part_259" +"(let-values(((or-part_260)" +"(if extra-inspector_6" +"(inspector-superior?" +" extra-inspector_6" +" guard-insp_3)" +" #f)))" +"(if or-part_260" +" or-part_260" +"(if extra-inspectorsss_4" +"(if extra-inspectorss_14" +"(extra-inspectors-allow?" +"(hash-ref" +" extra-inspectorss_14" +" import-sym_0" +" #f)" +" guard-insp_3)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(error" +" 'link" +"(string-append" +" \"access disallowed by code inspector to ~a variable\\n\"" +" \" variable: ~s\\n\"" +" \" from module: ~a\")" +" a_47" +" import-sym_0" +"(1/module-path-index-resolve" +"(namespace-mpi" +"(module-instance-namespace" +" mi_16))))))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_238" +" rest_9)" +"(values))))" +"(values))))))" +" for-loop_238)" +" lst_266)))" +"(void)))))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_237 rest_145 rest_85 rest_43 rest_121)" +"(values))))" +"(values))))))" +" for-loop_237)" +" lst_41" +" lst_163" +" lst_89" +" lst_265)))" +"(void)))))))))))))" +"(define-values" +"(check-single-require-access)" +"(lambda(mi_17 phase_89 sym_65 insp_11)" +"(begin" +"(let-values(((m_16)(module-instance-module mi_17)))" +"(if(module-no-protected? m_16)" +"(let-values() #t)" +"(let-values()" +"(let-values(((access_3)" +"(let-values(((or-part_261)(module-access m_16)))" +"(if or-part_261 or-part_261(module-compute-access! m_16)))))" +"(let-values(((a_48)(hash-ref(hash-ref access_3 phase_89 '#hasheq()) sym_65 'unexported)))" +"(if(let-values(((or-part_34)(eq? a_48 'unexported)))" +"(if or-part_34 or-part_34(eq? a_48 'protected)))" +"(let-values()" +"(let-values(((guard-insp_4)(namespace-inspector(module-instance-namespace mi_17))))" +"(let-values(((or-part_262)(if insp_11(inspector-superior? insp_11 guard-insp_4) #f)))" +"(if or-part_262 or-part_262(inspector-superior?(current-code-inspector) guard-insp_4)))))" +"(let-values() #t))))))))))" +"(define-values(module-cache)(make-weak-hasheq))" +"(define-values" +"(make-module-cache-key)" +"(lambda(hash-code_6)" +" (begin (if hash-code_6 (string->symbol (format \"~s\" (list hash-code_6 (current-load-relative-directory)))) #f))))" +"(define-values" +"(module-cache-set!)" +"(lambda(key_10 proc_9)(begin(hash-set! module-cache key_10(make-ephemeron key_10 proc_9)))))" +"(define-values" +"(module-cache-ref)" +"(lambda(key_66)" +"(begin(let-values(((e_72)(hash-ref module-cache key_66 #f)))(if e_72(ephemeron-value e_72) #f)))))" +"(define-values(current-module-declare-as-predefined)(make-parameter #f))" +"(define-values" +"(eval-module8.1)" +"(lambda(namespace1_2 supermodule-name3_0 with-submodules?2_0 c7_0)" +"(begin" +" 'eval-module8" +"(let-values(((c_25) c7_0))" +"(let-values(((ns_60)(if(eq? namespace1_2 unsafe-undefined)(1/current-namespace) namespace1_2)))" +"(let-values(((with-submodules?_1) with-submodules?2_0))" +"(let-values(((supermodule-name_1) supermodule-name3_0))" +"(let-values()" +"(let-values()" +"(let-values(((dh_0 h_1 data-instance_0 declaration-instance_0)" +"(compiled-module->dh+h+data-instance+declaration-instance c_25)))" +"(let-values(((syntax-literals-data-instance_0)" +"(if(compiled-in-memory? c_25)" +"(make-syntax-literal-data-instance-from-compiled-in-memory c_25)" +"(let-values(((l_64)(hash-ref h_1 'stx-data #f)))" +"(if l_64" +"(let-values()" +"(1/instantiate-linklet" +"(1/eval-linklet l_64)" +"(list deserialize-instance data-instance_0)))" +"(if(eq?(hash-ref h_1 'module->namespace #f) 'empty)" +"(let-values() empty-syntax-literals-instance/empty-namespace)" +"(let-values() empty-syntax-literals-data-instance)))))))" +"(let-values(((decl_0)" +"(lambda(key_67)" +"(begin 'decl(1/instance-variable-value declaration-instance_0 key_67)))))" +"(let-values(((pre-submodule-names_0)(hash-ref h_1 'pre null)))" +"(let-values(((post-submodule-names_0)(hash-ref h_1 'post null)))" +"(let-values(((default-name_1)(hash-ref h_1 'name 'module)))" +"(let-values(((cache-key_0)" +"(make-module-cache-key" +"(if(null? pre-submodule-names_0)" +"(if(null? post-submodule-names_0)(hash-ref h_1 'hash-code #f) #f)" +" #f))))" +"(let-values(((cross-phase-persistent?_1)(hash-ref h_1 'cross-phase-persistent? #f)))" +"(let-values(((min-phase_2)(hash-ref h_1 'min-phase 0)))" +"(let-values(((max-phase_2)(hash-ref h_1 'max-phase 0)))" +"(let-values(((language-info_1)(hash-ref h_1 'language-info #f)))" +"(let-values(((phases-h_0)" +"(let-values(((start_37) min-phase_2)" +"((end_26)(add1 max-phase_2))" +"((inc_20) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_37 end_26 inc_20)))" +"((letrec-values(((for-loop_237)" +"(lambda(table_179 pos_99)" +"(begin" +" 'for-loop" +"(if(< pos_99 end_26)" +"(let-values(((phase-level_17)" +" pos_99))" +"(let-values(((table_180)" +"(let-values(((v_188)" +"(hash-ref" +" h_1" +" phase-level_17" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_110)" +"(lambda(table_181)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_182)" +"(let-values(((table_111)" +" table_181))" +"(if v_188" +"(let-values(((table_183)" +" table_111))" +"(let-values(((table_184)" +"(let-values()" +"(let-values(((key_68" +" val_57)" +"(let-values()" +"(values" +" phase-level_17" +"(1/eval-linklet" +" v_188)))))" +"(hash-set" +" table_183" +" key_68" +" val_57)))))" +"(values" +" table_184)))" +" table_111))))" +" table_182))))))" +" for-loop_110)" +" table_179)))))" +"(if(not #f)" +"(for-loop_237" +" table_180" +"(+ pos_99 inc_20))" +" table_180)))" +" table_179)))))" +" for-loop_237)" +" '#hash()" +" start_37)))))" +"(let-values(((syntax-literals-linklet_0)" +"(let-values(((l_14)(hash-ref h_1 'stx #f)))" +"(if l_14(1/eval-linklet l_14) #f))))" +"(let-values(((extra-inspector_7)" +"(if(compiled-in-memory? c_25)" +"(compiled-in-memory-compile-time-inspector c_25)" +" #f)))" +"(let-values(((phase-to-link-extra-inspectorsss_1)" +"(if(compiled-in-memory? c_25)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss c_25)" +" '#hasheqv())))" +"(let-values(((requires_4)(decl_0 'requires)))" +"(let-values(((provides_8)(decl_0 'provides)))" +"(let-values(((original-self_1)(decl_0 'self-mpi)))" +"(let-values(((phase-to-link-modules_0)" +"(decl_0 'phase-to-link-modules)))" +"(let-values(((create-root-expand-context-from-module_0)" +"(make-create-root-expand-context-from-module" +" requires_4" +" phases-h_0)))" +"(let-values(((declare-submodules_0)" +"(if dh_0" +"(lambda(ns_61 names_0 declare-name_0 pre?_0)" +"(begin" +" 'declare-submodules" +"(if(compiled-in-memory? c_25)" +"(begin" +"(let-values(((lst_19)" +"(if pre?_0" +"(compiled-in-memory-pre-compiled-in-memorys" +" c_25)" +"(compiled-in-memory-post-compiled-in-memorys" +" c_25))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_19)))" +"((letrec-values(((for-loop_15)" +"(lambda(lst_267)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_267)" +"(let-values(((c_26)" +"(unsafe-car" +" lst_267))" +"((rest_146)" +"(unsafe-cdr" +" lst_267)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((c12_0)" +" c_26)" +"((ns13_0)" +" ns_61)" +"((declare-name14_0)" +" declare-name_0))" +"(eval-module8.1" +" ns13_0" +" declare-name14_0" +" #t" +" c12_0)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_15" +" rest_146)" +"(values))))" +"(values))))))" +" for-loop_15)" +" lst_19)))" +"(void))" +"(begin" +"(let-values(((lst_268) names_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_268)))" +"((letrec-values(((for-loop_239)" +"(lambda(lst_176)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_176)" +"(let-values(((name_48)" +"(unsafe-car" +" lst_176))" +"((rest_93)" +"(unsafe-cdr" +" lst_176)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((sm-cd_0)" +"(hash-ref" +" dh_0" +" name_48" +" #f)))" +"(begin" +"(if sm-cd_0" +"(void)" +"(let-values()" +"(error" +" \"missing submodule declaration:\"" +" name_48)))" +"(let-values(((sm-cd15_0)" +" sm-cd_0)" +"((ns16_0)" +" ns_61)" +"((declare-name17_0)" +" declare-name_0))" +"(eval-module8.1" +" ns16_0" +" declare-name17_0" +" #t" +" sm-cd15_0)))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_239" +" rest_93)" +"(values))))" +"(values))))))" +" for-loop_239)" +" lst_268)))" +"(void)))))" +" void)))" +"(let-values(((declare-this-module_0)" +"(lambda(ns_62)" +"(begin" +" 'declare-this-module" +"(let-values(((m_17)" +"(let-values(((temp22_3)" +"(1/current-module-declare-source))" +"((original-self23_0)" +" original-self_1)" +"((requires24_0)" +" requires_4)" +"((provides25_0)" +" provides_8)" +"((language-info26_0)" +" language-info_1)" +"((min-phase27_0)" +" min-phase_2)" +"((max-phase28_0)" +" max-phase_2)" +"((cross-phase-persistent?29_0)" +" cross-phase-persistent?_1)" +"((temp30_2)" +"(current-module-declare-as-predefined))" +"((temp31_1)" +"(append" +" pre-submodule-names_0" +" post-submodule-names_0))" +"((supermodule-name32_0)" +" supermodule-name_1)" +"((temp33_0)" +"(lambda()" +"(get-all-variables" +" phases-h_0)))" +"((temp34_2)" +"(lambda(phase-level_18" +" ns_63" +" insp_12)" +"(module-linklet-info2.1" +"(hash-ref" +" phases-h_0" +" phase-level_18" +" #f)" +"(hash-ref" +" phase-to-link-modules_0" +" phase-level_18" +" #f)" +" original-self_1" +" insp_12" +" extra-inspector_7" +"(hash-ref" +" phase-to-link-extra-inspectorsss_1" +" phase-level_18" +" #f))))" +"((temp35_0)" +"(lambda(bulk-binding-registry_13)" +"(force-syntax-deserialize" +" syntax-literals-data-instance_0" +" bulk-binding-registry_13)))" +"((temp36_1)" +"(lambda(data-box_2" +" ns_64" +" phase-shift_15" +" self_21" +" bulk-binding-registry_14" +" insp_13)" +"(if(unbox" +" data-box_2)" +"(void)" +"(let-values()" +"(init-instance-data!" +" data-box_2" +" cache-key_0" +" ns_64" +" syntax-literals-linklet_0" +" data-instance_0" +" syntax-literals-data-instance_0" +" phase-shift_15" +" original-self_1" +" self_21" +" bulk-binding-registry_14" +" insp_13" +" create-root-expand-context-from-module_0)))))" +"((temp37_0)" +"(lambda(data-box_3" +" ns_65" +" phase-shift_16" +" phase-level_19" +" self_22" +" bulk-binding-registry_15" +" insp_14)" +"(let-values()" +"(let-values(((syntax-literals-instance_0)" +"(instance-data-syntax-literals-instance" +"(unbox" +" data-box_3))))" +"(let-values(((phase-linklet_0)" +"(hash-ref" +" phases-h_0" +" phase-level_19" +" #f)))" +"(if phase-linklet_0" +"(let-values()" +"(let-values(((module-uses_0)" +"(hash-ref" +" phase-to-link-modules_0" +" phase-level_19)))" +"(let-values(((import-module-instances_1" +" import-instances_0)" +"(let-values(((mis_1" +" is_0)" +"(let-values(((lst_187)" +" module-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_187)))" +"((letrec-values(((for-loop_3)" +"(lambda(mis_2" +" is_1" +" lst_183)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_183)" +"(let-values(((mu_8)" +"(unsafe-car" +" lst_183))" +"((rest_98)" +"(unsafe-cdr" +" lst_183)))" +"(let-values(((mis_3" +" is_2)" +"(let-values(((mis_4)" +" mis_2)" +"((is_3)" +" is_1))" +"(let-values(((mis_5" +" is_4)" +"(let-values()" +"(let-values(((mis45_0" +" is46_0)" +"(let-values()" +"(let-values(((ns47_1)" +" ns_65)" +"((mu48_0)" +" mu_8)" +"((original-self49_0)" +" original-self_1)" +"((self50_0)" +" self_22)" +"((temp51_0)" +"(phase+" +"(phase-" +" phase-level_19" +"(module-use-phase" +" mu_8))" +" phase-shift_16)))" +"(namespace-module-use->module+linklet-instances144.1" +" temp51_0" +" original-self49_0" +" self50_0" +" ns47_1" +" mu48_0)))))" +"(values" +"(cons" +" mis45_0" +" mis_4)" +"(cons" +" is46_0" +" is_3))))))" +"(values" +" mis_5" +" is_4)))))" +"(if(not" +" #f)" +"(for-loop_3" +" mis_3" +" is_2" +" rest_98)" +"(values" +" mis_3" +" is_2))))" +"(values" +" mis_2" +" is_1))))))" +" for-loop_3)" +" null" +" null" +" lst_187)))))" +"(values" +"(reverse$1" +" mis_1)" +"(reverse$1" +" is_0)))))" +"(let-values((()" +"(begin" +"(let-values(((phase-linklet38_0)" +" phase-linklet_0)" +"((temp39_3)" +" 2)" +"((module-uses40_0)" +" module-uses_0)" +"((import-module-instances41_0)" +" import-module-instances_1)" +"((insp42_0)" +" insp_14)" +"((extra-inspector43_0)" +" extra-inspector_7)" +"((temp44_1)" +"(hash-ref" +" phase-to-link-extra-inspectorsss_1" +" phase-level_19" +" #f)))" +"(check-require-access9.1" +" temp39_3" +" phase-linklet38_0" +" module-uses40_0" +" import-module-instances41_0" +" insp42_0" +" extra-inspector43_0" +" temp44_1))" +"(values))))" +"(let-values(((module-body-instance-instance_0)" +"(let-values(((temp52_0)" +"(lambda(name_49" +" val_58)" +"(namespace-set-transformer!" +" ns_65" +"(sub1" +" phase-level_19)" +" name_49" +" val_58))))" +"(make-module-body-instance-instance18.1" +" temp52_0))))" +"(let-values(((instantiate-body_0)" +"(lambda()" +"(begin" +" 'instantiate-body" +"(1/instantiate-linklet" +" phase-linklet_0" +"(list*" +" syntax-literals-instance_0" +" module-body-instance-instance_0" +" import-instances_0)" +"(namespace->instance" +" ns_65" +" phase-level_19))))))" +"(if(zero-phase?" +" phase-level_19)" +"(let-values()" +"(if(zero-phase?" +" phase-shift_16)" +"(let-values()" +"(instantiate-body_0))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" ns_65)" +"(let-values()" +"(instantiate-body_0))))))" +"(let-values()" +"(let-values(((ns-1_0)" +"(namespace->namespace-at-phase" +" ns_65" +"(phase+" +" phase-shift_16" +"(sub1" +" phase-level_19)))))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:214:76" +"(let-values(((ns-153_0)" +" ns-1_0))" +"(make-expand-context10.1" +" #f" +" #f" +" #f" +" ns-153_0)))))" +" 1/current-namespace" +" ns_65" +" current-module-code-inspector" +" insp_14)" +"(let-values()" +"(instantiate-body_0))))))))))))" +"(void))))))))" +"(make-module39.1" +" cross-phase-persistent?29_0" +" temp35_0" +" temp33_0" +" temp37_0" +" language-info26_0" +" max-phase28_0" +" min-phase27_0" +" #f" +" temp34_2" +" temp30_2" +" temp36_1" +" #f" +" provides25_0" +" requires24_0" +" original-self23_0" +" temp22_3" +" temp31_1" +" supermodule-name32_0))))" +"(let-values(((declare-name_1)" +"(substitute-module-declare-name" +" default-name_1)))" +"(begin" +"(if with-submodules?_1" +"(let-values()" +"(declare-submodules_0" +" ns_62" +" pre-submodule-names_0" +" declare-name_1" +" #t))" +"(void))" +"(let-values(((ns18_0) ns_62)" +"((m19_0) m_17)" +"((declare-name20_0)" +" declare-name_1)" +"((with-submodules?21_0)" +" with-submodules?_1))" +"(declare-module!58.1" +" with-submodules?21_0" +" ns18_0" +" m19_0" +" declare-name20_0))" +"(if with-submodules?_1" +"(let-values()" +"(declare-submodules_0" +" ns_62" +" post-submodule-names_0" +" declare-name_1" +" #f))" +"(void)))))))))" +"(begin" +"(if cache-key_0" +"(let-values()" +"(module-cache-set!" +" cache-key_0" +" declare-this-module_0))" +"(void))" +"(declare-this-module_0" +" ns_60)))))))))))))))))))))))))))))))))" +"(define-values" +"(struct:instance-data instance-data11.1 instance-data? instance-data-syntax-literals-instance instance-data-cache-key)" +"(let-values(((struct:_73 make-_73 ?_73 -ref_73 -set!_73)" +"(let-values()" +"(let-values()" +"(make-struct-type 'instance-data #f 2 0 #f null(current-inspector) #f '(0 1) #f 'instance-data)))))" +"(values" +" struct:_73" +" make-_73" +" ?_73" +"(make-struct-field-accessor -ref_73 0 'syntax-literals-instance)" +"(make-struct-field-accessor -ref_73 1 'cache-key))))" +"(define-values" +"(init-instance-data!)" +"(lambda(data-box_4" +" cache-key_1" +" ns_66" +" syntax-literals-linklet_1" +" data-instance_1" +" syntax-literals-data-instance_1" +" phase-shift_17" +" original-self_2" +" self_23" +" bulk-binding-registry_16" +" insp_15" +" create-root-expand-context-from-module_1)" +"(begin" +"(let-values((()" +"(begin" +"(if(not(load-on-demand-enabled))" +"(let-values()" +"(force-syntax-deserialize syntax-literals-data-instance_1 bulk-binding-registry_16))" +"(void))" +"(values))))" +"(let-values(((inst_1)" +"(let-values(((ns55_1) ns_66)" +"((phase-shift56_1) phase-shift_17)" +"((self57_0) self_23)" +"((insp58_0) insp_15)" +"((bulk-binding-registry59_0) bulk-binding-registry_16)" +"((temp60_0)" +" (lambda (name_50 val_59) (error \"shouldn't get here for the root-ctx linklet\"))))" +"(make-instance-instance13.1" +" bulk-binding-registry59_0" +" insp58_0" +" ns55_1" +" phase-shift56_1" +" self57_0" +" temp60_0))))" +"(let-values(((syntax-literals-instance_1)" +"(if syntax-literals-linklet_1" +"(1/instantiate-linklet" +" syntax-literals-linklet_1" +"(list deserialize-instance data-instance_1 syntax-literals-data-instance_1 inst_1))" +" empty-syntax-literals-instance)))" +"(let-values((()" +"(begin" +"(set-box! data-box_4(instance-data11.1 syntax-literals-instance_1 cache-key_1))" +"(values))))" +"(let-values(((get-encoded-root-expand-ctx_0)" +"(1/instance-variable-value syntax-literals-instance_1 'get-encoded-root-expand-ctx)))" +"(if(eq? get-encoded-root-expand-ctx_0 'empty)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_66" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:279:39" +"(shift-to-inside-root-context" +"(let-values(((self61_0) self_23))" +"(make-root-expand-context13.1 #f null unsafe-undefined unsafe-undefined self61_0))))))))" +"(if(procedure? get-encoded-root-expand-ctx_0)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_66" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:283:39" +"(shift-to-inside-root-context" +"(root-expand-context-decode-for-module(get-encoded-root-expand-ctx_0) self_23)))))))" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_66" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:290:39" +"(shift-to-inside-root-context" +"(create-root-expand-context-from-module_1" +" ns_66" +" phase-shift_17" +" original-self_2" +" self_23)))))))))))))))))" +"(define-values" +"(force-syntax-deserialize)" +"(lambda(syntax-literals-data-instance_2 bulk-binding-registry_17)" +"(begin" +"(if(let-values(((or-part_263)(eq? syntax-literals-data-instance_2 empty-syntax-literals-data-instance)))" +"(if or-part_263" +" or-part_263" +"(eq? syntax-literals-data-instance_2 empty-syntax-literals-instance/empty-namespace)))" +"(void)" +"(let-values()" +"(let-values(((deserialize-syntax_0)" +"(1/instance-variable-value syntax-literals-data-instance_2 deserialize-syntax-id)))" +"(if deserialize-syntax_0(let-values()(deserialize-syntax_0 bulk-binding-registry_17))(void))))))))" +"(define-values" +"(compiled-module->dh+h)" +"(lambda(c_27)" +"(begin" +"(let-values(((ld/h_0)(if(compiled-in-memory? c_27)(compiled-in-memory-linklet-directory c_27) c_27)))" +"(let-values(((dh_1)" +"(if(1/linklet-directory? ld/h_0)" +"(let-values()(1/linklet-directory->hash ld/h_0))" +"(let-values() #f))))" +"(let-values(((h_2)(1/linklet-bundle->hash(if dh_1(hash-ref dh_1 #f) ld/h_0))))(values dh_1 h_2)))))))" +"(define-values" +"(compiled-module->h)" +"(lambda(c_28)(begin(let-values(((dh_2 h_3)(compiled-module->dh+h c_28))) h_3))))" +"(define-values" +"(compiled-module->dh+h+data-instance+declaration-instance)" +"(lambda(c_29)" +"(begin" +"(let-values(((dh_3 h_4)(compiled-module->dh+h c_29)))" +"(let-values(((data-instance_2)" +"(if(compiled-in-memory? c_29)" +"(make-data-instance-from-compiled-in-memory c_29)" +"(1/instantiate-linklet(1/eval-linklet(hash-ref h_4 'data))(list deserialize-instance)))))" +"(let-values(((declaration-instance_1)" +"(if(if(compiled-in-memory? c_29)(compiled-in-memory-original-self c_29) #f)" +"(make-declaration-instance-from-compiled-in-memory c_29)" +"(1/instantiate-linklet" +"(1/eval-linklet(hash-ref h_4 'decl))" +"(list deserialize-instance data-instance_2)))))" +"(values dh_3 h_4 data-instance_2 declaration-instance_1)))))))" +"(define-values" +"(compiled-module->declaration-instance)" +"(lambda(c_30)" +"(begin" +"(let-values(((dh_4 h_5 data-instance_3 declaration-instance_2)" +"(compiled-module->dh+h+data-instance+declaration-instance c_30)))" +" declaration-instance_2))))" +"(define-values" +"(compiled-module->h+declaration-instance)" +"(lambda(c_31)" +"(begin" +"(let-values(((dh_5 h_6 data-instance_4 declaration-instance_3)" +"(compiled-module->dh+h+data-instance+declaration-instance c_31)))" +"(values h_6 declaration-instance_3)))))" +"(define-values" +"(make-data-instance-from-compiled-in-memory)" +"(lambda(cim_6)(begin(1/make-instance 'data #f 'constant mpi-vector-id(compiled-in-memory-mpis cim_6)))))" +"(define-values" +"(make-declaration-instance-from-compiled-in-memory)" +"(lambda(cim_7)" +"(begin" +"(1/make-instance" +" 'decl" +" #f" +" 'constant" +" 'self-mpi" +"(compiled-in-memory-original-self cim_7)" +" 'requires" +"(compiled-in-memory-requires cim_7)" +" 'provides" +"(compiled-in-memory-provides cim_7)" +" 'phase-to-link-modules" +"(compiled-in-memory-phase-to-link-module-uses cim_7)))))" +"(define-values" +"(make-syntax-literal-data-instance-from-compiled-in-memory)" +"(lambda(cim_8)" +"(begin" +"(1/make-instance" +" 'syntax-literal-data" +" #f" +" #f" +" deserialize-syntax-id" +" void" +" deserialized-syntax-vector-id" +"(compiled-in-memory-syntax-literals cim_8)))))" +"(define-values" +"(empty-syntax-literals-instance/empty-namespace)" +"(1/make-instance" +" 'empty-stx/empty-ns" +" #f" +" 'constant" +" get-syntax-literal!-id" +"(lambda(pos_100) #f)" +" 'get-encoded-root-expand-ctx" +" 'empty))" +"(define-values" +"(get-all-variables)" +"(lambda(phases-h_1)" +"(begin" +"(let-values(((ht_123) phases-h_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_123)))" +"((letrec-values(((for-loop_240)" +"(lambda(table_185 i_146)" +"(begin" +" 'for-loop" +"(if i_146" +"(let-values(((phase_90 linklet_5)(hash-iterate-key+value ht_123 i_146)))" +"(let-values(((table_186)" +"(let-values(((table_187) table_185))" +"(let-values(((table_140)" +"(let-values()" +"(let-values(((key_69 val_60)" +"(let-values()" +"(values" +" phase_90" +"(1/linklet-export-variables" +" linklet_5)))))" +"(hash-set table_187 key_69 val_60)))))" +"(values table_140)))))" +"(if(not #f)" +"(for-loop_240 table_186(hash-iterate-next ht_123 i_146))" +" table_186)))" +" table_185)))))" +" for-loop_240)" +" '#hash()" +"(hash-iterate-first ht_123)))))))" +"(define-values" +"(provides->api-provides)" +"(lambda(provides_9 self_24)" +"(begin" +"(let-values(((extract_0)" +"(lambda(ok?_26)" +"(begin" +" 'extract" +"(let-values(((result-l_0)" +"(reverse$1" +"(let-values(((ht_124) provides_9))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_124)))" +"((letrec-values(((for-loop_103)" +"(lambda(fold-var_59 i_147)" +"(begin" +" 'for-loop" +"(if i_147" +"(let-values(((phase_91 at-phase_11)" +"(hash-iterate-key+value ht_124 i_147)))" +"(let-values(((fold-var_60)" +"(let-values(((l_65)" +"(reverse$1" +"(let-values(((ht_125)" +" at-phase_11))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_125)))" +"((letrec-values(((for-loop_241)" +"(lambda(fold-var_219" +" i_148)" +"(begin" +" 'for-loop" +"(if i_148" +"(let-values(((sym_66" +" b/p_1)" +"(hash-iterate-key+value" +" ht_125" +" i_148)))" +"(let-values(((fold-var_220)" +"(let-values(((fold-var_221)" +" fold-var_219))" +"(if(ok?_26" +" b/p_1)" +"(let-values(((fold-var_222)" +" fold-var_221))" +"(let-values(((fold-var_223)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((b_64)" +"(provided-as-binding" +" b/p_1)))" +"(list" +" sym_66" +"(if(eq?" +" self_24" +"(module-binding-module" +" b_64))" +"(let-values()" +" null)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_87)" +"(cons" +" b_64" +"(module-binding-extra-nominal-bindings" +" b_64))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_87)))" +"((letrec-values(((for-loop_242)" +"(lambda(fold-var_224" +" lst_269)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_269)" +"(let-values(((b_76)" +"(unsafe-car" +" lst_269))" +"((rest_147)" +"(unsafe-cdr" +" lst_269)))" +"(let-values(((fold-var_29)" +"(let-values(((fold-var_30)" +" fold-var_224))" +"(let-values(((fold-var_31)" +"(let-values()" +"(cons" +"(let-values()" +"(if(if(eqv?" +"(module-binding-nominal-phase" +" b_76)" +" phase_91)" +"(eq?" +"(module-binding-nominal-sym" +" b_76)" +" sym_66)" +" #f)" +"(let-values()" +"(module-binding-nominal-module" +" b_76))" +"(let-values()" +"(list" +"(module-binding-nominal-module" +" b_76)" +"(module-binding-phase" +" b_76)" +"(module-binding-nominal-sym" +" b_76)" +"(module-binding-nominal-phase" +" b_76)))))" +" fold-var_30))))" +"(values" +" fold-var_31)))))" +"(if(not" +" #f)" +"(for-loop_242" +" fold-var_29" +" rest_147)" +" fold-var_29)))" +" fold-var_224)))))" +" for-loop_242)" +" null" +" lst_87)))))))))" +" fold-var_222))))" +"(values" +" fold-var_223)))" +" fold-var_221))))" +"(if(not" +" #f)" +"(for-loop_241" +" fold-var_220" +"(hash-iterate-next" +" ht_125" +" i_148))" +" fold-var_220)))" +" fold-var_219)))))" +" for-loop_241)" +" null" +"(hash-iterate-first" +" ht_125)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_109)" +"(lambda(fold-var_71)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_225)" +"(let-values(((fold-var_32)" +" fold-var_71))" +"(if(null?" +" l_65)" +" fold-var_32" +"(let-values(((fold-var_33)" +" fold-var_32))" +"(let-values(((fold-var_34)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_91" +"(let-values(((l4_0)" +" l_65)" +"((symbolapi-nonprovides)" +"(lambda(provides_10 all-vars_0)" +"(begin" +"(let-values(((result-l_1)" +"(reverse$1" +"(let-values(((ht_85) all-vars_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_85)))" +"((letrec-values(((for-loop_119)" +"(lambda(fold-var_171 i_95)" +"(begin" +" 'for-loop" +"(if i_95" +"(let-values(((phase_92 vars_0)(hash-iterate-key+value ht_85 i_95)))" +"(let-values(((fold-var_173)" +"(let-values(((fold-var_226) fold-var_171))" +"(let-values(((l_66)" +"(let-values(((syms_19)" +"(hash-ref" +" provides_10" +" phase_92" +" '#hasheq())))" +"(reverse$1" +"(let-values(((lst_18) vars_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_18)))" +"((letrec-values(((for-loop_219)" +"(lambda(fold-var_174" +" lst_270)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_270)" +"(let-values(((var-sym_5)" +"(unsafe-car" +" lst_270))" +"((rest_148)" +"(unsafe-cdr" +" lst_270)))" +"(let-values(((fold-var_76)" +"(let-values(((fold-var_227)" +" fold-var_174))" +"(if(hash-ref" +" syms_19" +" var-sym_5" +" #f)" +" fold-var_227" +"(let-values(((fold-var_228)" +" fold-var_227))" +"(let-values(((fold-var_229)" +"(let-values()" +"(cons" +"(let-values()" +" var-sym_5)" +" fold-var_228))))" +"(values" +" fold-var_229)))))))" +"(if(not" +" #f)" +"(for-loop_219" +" fold-var_76" +" rest_148)" +" fold-var_76)))" +" fold-var_174)))))" +" for-loop_219)" +" null" +" lst_18)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_112)" +"(lambda(fold-var_66)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_67)" +"(let-values(((fold-var_18)" +" fold-var_66))" +"(if(null?" +" l_66)" +" fold-var_18" +"(let-values(((fold-var_19)" +" fold-var_18))" +"(let-values(((fold-var_20)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_92" +"(let-values(((l10_0)" +" l_66)" +"((symbollinklet-directory-or-bundle)" +"(lambda(c_32)(begin(if(compiled-in-memory? c_32)(compiled-in-memory-linklet-directory c_32) c_32))))" +"(define-values" +"(module-compiled-current-name)" +"(lambda(c_33)" +"(begin" +"(let-values(((ld_1)(compiled->linklet-directory-or-bundle c_33)))" +"(let-values(((b_15)(if(1/linklet-bundle? ld_1) ld_1(hash-ref(1/linklet-directory->hash ld_1) #f))))" +"(hash-ref(1/linklet-bundle->hash b_15) 'name))))))" +"(define-values" +"(module-compiled-immediate-name)" +"(lambda(c_25)" +"(begin(let-values(((n_28)(module-compiled-current-name c_25)))(if(pair? n_28)(car(reverse$1 n_28)) n_28)))))" +"(define-values" +"(change-module-name)" +"(lambda(c_34 name_3 prefix_4)" +"(begin" +"(let-values(((full-name_0)(if(null? prefix_4) name_3(append prefix_4(list name_3)))))" +"(let-values(((next-prefix_0)(if(null? prefix_4)(list name_3) full-name_0)))" +"(let-values(((recur_0)" +"(lambda(sub-c_0 name_51)" +"(begin" +" 'recur" +"(if(equal?(module-compiled-current-name sub-c_0)(append next-prefix_0(list name_51)))" +" sub-c_0" +"(change-module-name sub-c_0 name_51 next-prefix_0))))))" +"(if(compiled-in-memory? c_34)" +"(let-values()" +"(let-values(((change-submodule-name_0)" +"(lambda(sub-c_1)" +"(begin" +" 'change-submodule-name" +"(recur_0 sub-c_1(module-compiled-immediate-name sub-c_1))))))" +"(let-values(((pre-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-pre-compiled-in-memorys c_34))))" +"(let-values(((post-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-post-compiled-in-memorys c_34))))" +"(let-values(((the-struct_6) c_34))" +"(if(compiled-in-memory? the-struct_6)" +"(let-values(((pre-compiled-in-memorys8_0) pre-compiled-in-memorys_0)" +"((post-compiled-in-memorys9_0) post-compiled-in-memorys_0)" +"((linklet-directory10_0)" +"(let-values(((temp11_3)" +"(update-one-name" +"(let-values(((ld_2)" +"(compiled->linklet-directory-or-bundle c_34)))" +"(if(1/linklet-bundle? ld_2)" +" ld_2" +"(hash-ref(1/linklet-directory->hash ld_2) #f)))" +" full-name_0))" +"((temp12_1)(symbol? full-name_0))" +"((temp13_1)" +"(append pre-compiled-in-memorys_0 post-compiled-in-memorys_0)))" +"(rebuild-linklet-directory5.1 temp12_1 temp11_3 temp13_1))))" +"(compiled-in-memory1.1" +" linklet-directory10_0" +"(compiled-in-memory-original-self the-struct_6)" +"(compiled-in-memory-requires the-struct_6)" +"(compiled-in-memory-provides the-struct_6)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_6)" +"(compiled-in-memory-compile-time-inspector the-struct_6)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_6)" +"(compiled-in-memory-mpis the-struct_6)" +"(compiled-in-memory-syntax-literals the-struct_6)" +" pre-compiled-in-memorys8_0" +" post-compiled-in-memorys9_0" +"(compiled-in-memory-namespace-scopes the-struct_6)" +"(compiled-in-memory-purely-functional? the-struct_6)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_6)))))))" +"(if(1/linklet-directory? c_34)" +"(let-values()" +"(1/hash->linklet-directory" +"(let-values(((ht_126)(1/linklet-directory->hash c_34)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_126)))" +"((letrec-values(((for-loop_243)" +"(lambda(table_188 i_92)" +"(begin" +" 'for-loop" +"(if i_92" +"(let-values(((key_70 val_61)(hash-iterate-key+value ht_126 i_92)))" +"(let-values(((table_189)" +"(let-values(((table_190) table_188))" +"(let-values(((table_191)" +"(let-values()" +"(let-values(((key_71 val_62)" +"(let-values()" +"(values" +" key_70" +"(if(not key_70)" +"(update-one-name" +" val_61" +" full-name_0)" +"(recur_0" +" val_61" +" key_70))))))" +"(hash-set" +" table_190" +" key_71" +" val_62)))))" +"(values table_191)))))" +"(if(not #f)" +"(for-loop_243 table_189(hash-iterate-next ht_126 i_92))" +" table_189)))" +" table_188)))))" +" for-loop_243)" +" '#hasheq()" +"(hash-iterate-first ht_126))))))" +"(let-values()(update-one-name c_34 full-name_0))))))))))" +"(define-values" +"(update-one-name)" +"(lambda(lb_0 name_52)(begin(1/hash->linklet-bundle(hash-set(1/linklet-bundle->hash lb_0) 'name name_52)))))" +"(define-values" +"(rebuild-linklet-directory5.1)" +"(lambda(bundle-ok?1_0 main3_0 submods4_0)" +"(begin" +" 'rebuild-linklet-directory5" +"(let-values(((main_0) main3_0))" +"(let-values(((submods_0) submods4_0))" +"(let-values(((bundle-ok?_0) bundle-ok?1_0))" +"(let-values()" +"(if(if(null? submods_0) bundle-ok?_0 #f)" +" main_0" +"(1/hash->linklet-directory" +"(hash-set" +"(let-values(((lst_91) submods_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_91)))" +"((letrec-values(((for-loop_49)" +"(lambda(ht_127 lst_82)" +"(begin" +" 'for-loop" +"(if(pair? lst_82)" +"(let-values(((submod_1)(unsafe-car lst_82))" +"((rest_37)(unsafe-cdr lst_82)))" +"(let-values(((ht_117)" +"(let-values(((ht_118) ht_127))" +"(let-values(((ht_119)" +"(let-values()" +"(let-values(((name_53)" +"(module-compiled-immediate-name" +" submod_1)))" +"(if(hash-ref ht_118 name_53 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-compiled-submodules" +" \"change would result in duplicate submodule name\"" +" \"name\"" +" name_53))" +"(let-values()" +"(hash-set" +" ht_118" +" name_53" +"(compiled->linklet-directory-or-bundle" +" submod_1))))))))" +"(values ht_119)))))" +"(if(not #f)(for-loop_49 ht_117 rest_37) ht_117)))" +" ht_127)))))" +" for-loop_49)" +" '#hasheq()" +" lst_91)))" +" #f" +" main_0))))))))))" +"(define-values" +"(1/compiled-expression?)" +"(lambda(c_32)" +"(begin" +" 'compiled-expression?" +"(let-values(((or-part_0)(compiled-in-memory? c_32)))" +"(if or-part_0" +" or-part_0" +"(let-values(((or-part_1)(1/linklet-directory? c_32)))" +"(if or-part_1 or-part_1(1/linklet-bundle? c_32))))))))" +"(define-values" +"(1/compiled-module-expression?)" +"(lambda(c_35)" +"(begin" +" 'compiled-module-expression?" +"(let-values(((ld_3)(compiled->linklet-directory-or-bundle c_35)))" +"(let-values(((or-part_26)" +"(if(1/linklet-directory? ld_3)" +"(if(let-values(((b_77)(hash-ref(1/linklet-directory->hash ld_3) #f #f)))" +"(if b_77(hash-ref(1/linklet-bundle->hash b_77) 'decl #f) #f))" +" #t" +" #f)" +" #f)))" +"(if or-part_26" +" or-part_26" +"(if(1/linklet-bundle? ld_3)(if(hash-ref(1/linklet-bundle->hash ld_3) 'decl #f) #t #f) #f)))))))" +"(define-values" +"(1/module-compiled-name)" +"(let-values()" +"(let-values()" +"(case-lambda" +"((c_36)" +"(begin" +" 'module-compiled-name" +"(begin" +"(if(1/compiled-module-expression? c_36)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-name \"compiled-module-expression?\" c_36)))" +"(module-compiled-current-name c_36))))" +"((c_37 name_54)" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_37)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-name \"compiled-module-expression?\" c_37)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_217)(symbol? name_54)))" +"(if or-part_217" +" or-part_217" +"(if(pair? name_54)(if(list? name_54)(andmap2 symbol? name_54) #f) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-compiled-name" +" \"(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))\"" +" name_54)))" +"(values))))" +"(let-values(((i-name_0 prefix_5)" +"(if(symbol? name_54)" +"(values name_54 null)" +"(let-values(((r_41)(reverse$1 name_54)))(values(car r_41)(reverse$1(cdr r_41)))))))" +"(change-module-name c_37 i-name_0 prefix_5)))))))))" +"(define-values" +"(1/module-compiled-submodules)" +"(let-values()" +"(let-values()" +"(case-lambda" +"((c_13 non-star?_0)" +"(begin" +" 'module-compiled-submodules" +"(begin" +"(if(1/compiled-module-expression? c_13)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-submodules \"compiled-module-expression?\" c_13)))" +"(if(compiled-in-memory? c_13)" +"(let-values()" +"(if non-star?_0" +"(compiled-in-memory-pre-compiled-in-memorys c_13)" +"(compiled-in-memory-post-compiled-in-memorys c_13)))" +"(let-values()" +"(if(1/linklet-directory? c_13)" +"(let-values()" +"(let-values(((ht_69)(1/linklet-directory->hash c_13)))" +"(let-values(((bh_0)(1/linklet-bundle->hash(hash-ref ht_69 #f))))" +"(let-values(((names_1)(hash-ref bh_0(if non-star?_0 'pre 'post) null)))" +"(reverse$1" +"(let-values(((lst_86) names_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_86)))" +"((letrec-values(((for-loop_108)" +"(lambda(fold-var_69 lst_87)" +"(begin" +" 'for-loop" +"(if(pair? lst_87)" +"(let-values(((name_55)(unsafe-car lst_87))" +"((rest_41)(unsafe-cdr lst_87)))" +"(let-values(((fold-var_70)" +"(let-values(((fold-var_27) fold-var_69))" +"(let-values(((fold-var_28)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref ht_69 name_55))" +" fold-var_27))))" +"(values fold-var_28)))))" +"(if(not #f)" +"(for-loop_108 fold-var_70 rest_41)" +" fold-var_70)))" +" fold-var_69)))))" +" for-loop_108)" +" null" +" lst_86))))))))" +"(let-values() null)))))))" +"((c_38 non-star?_1 submods_1)" +"(begin" +"(if(1/compiled-module-expression? c_38)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-submodules \"compiled-module-expression?\" c_38)))" +"(if(if(list? submods_1)(andmap2 1/compiled-module-expression? submods_1) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-submodules \"(listof compiled-module-expression?)\" submods_1)))" +"(if(if(null? submods_1)" +"(let-values(((or-part_29)(1/linklet-bundle?(compiled->linklet-directory-or-bundle c_38))))" +"(if or-part_29" +" or-part_29" +"(if(compiled-in-memory? c_38)" +"(null?" +"(if non-star?_1" +"(compiled-in-memory-pre-compiled-in-memorys c_38)" +"(compiled-in-memory-post-compiled-in-memorys c_38)))" +" #f)))" +" #f)" +"(let-values() c_38)" +"(if(if(compiled-in-memory? c_38)(andmap2 compiled-in-memory? submods_1) #f)" +"(let-values()" +"(let-values(((pre-compiled-in-memorys_1)" +"(if non-star?_1 submods_1(compiled-in-memory-pre-compiled-in-memorys c_38))))" +"(let-values(((post-compiled-in-memorys_1)" +"(if non-star?_1(compiled-in-memory-post-compiled-in-memorys c_38) submods_1)))" +"(let-values(((n-c_0)(normalize-to-linklet-directory c_38)))" +"(fixup-submodule-names" +"(let-values(((the-struct_47) n-c_0))" +"(if(compiled-in-memory? the-struct_47)" +"(let-values(((pre-compiled-in-memorys3_0) pre-compiled-in-memorys_1)" +"((post-compiled-in-memorys4_0) post-compiled-in-memorys_1)" +"((linklet-directory5_0)" +"(let-values(((temp6_0)" +"(reset-submodule-names" +"(hash-ref" +"(1/linklet-directory->hash" +"(compiled->linklet-directory-or-bundle n-c_0))" +" #f)" +" non-star?_1" +" submods_1))" +"((temp7_2)(symbol?(module-compiled-current-name c_38)))" +"((temp8_2)" +"(append pre-compiled-in-memorys_1 post-compiled-in-memorys_1)))" +"(rebuild-linklet-directory5.1 temp7_2 temp6_0 temp8_2))))" +"(compiled-in-memory1.1" +" linklet-directory5_0" +"(compiled-in-memory-original-self the-struct_47)" +"(compiled-in-memory-requires the-struct_47)" +"(compiled-in-memory-provides the-struct_47)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_47)" +"(compiled-in-memory-compile-time-inspector the-struct_47)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_47)" +"(compiled-in-memory-mpis the-struct_47)" +"(compiled-in-memory-syntax-literals the-struct_47)" +" pre-compiled-in-memorys3_0" +" post-compiled-in-memorys4_0" +"(compiled-in-memory-namespace-scopes the-struct_47)" +"(compiled-in-memory-purely-functional? the-struct_47)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_47))))))))" +"(let-values()" +"(let-values(((n-c_1)(normalize-to-linklet-directory c_38)))" +"(fixup-submodule-names" +"(let-values(((temp9_3)" +"(reset-submodule-names" +"(hash-ref" +"(1/linklet-directory->hash(compiled->linklet-directory-or-bundle n-c_1))" +" #f)" +" non-star?_1" +" submods_1))" +"((temp10_3)" +"(map2" +" compiled->linklet-directory-or-bundle" +"(append" +"(if non-star?_1 submods_1(1/module-compiled-submodules c_38 #t))" +"(if non-star?_1(1/module-compiled-submodules c_38 #f) submods_1)))))" +"(rebuild-linklet-directory5.1 #f temp9_3 temp10_3)))))))))))))" +"(define-values" +"(1/module-compiled-language-info)" +"(lambda(c_39)" +"(begin" +" 'module-compiled-language-info" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_39)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-language-info \"compiled-module-expression?\" c_39)))" +"(values))))" +"(let-values(((h_7)(compiled-module->h c_39)))(hash-ref h_7 'language-info #f))))))))" +"(define-values" +"(1/module-compiled-imports)" +"(lambda(c_40)" +"(begin" +" 'module-compiled-imports" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_40)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-imports \"compiled-module-expression?\" c_40)))" +"(values))))" +"(let-values(((inst_2)(compiled-module->declaration-instance c_40)))" +"(1/instance-variable-value inst_2 'requires))))))))" +"(define-values" +"(1/module-compiled-exports)" +"(lambda(c_41)" +"(begin" +" 'module-compiled-exports" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_41)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-exports \"compiled-module-expression?\" c_41)))" +"(values))))" +"(let-values(((inst_3)(compiled-module->declaration-instance c_41)))" +"(provides->api-provides" +"(1/instance-variable-value inst_3 'provides)" +"(1/instance-variable-value inst_3 'self-mpi)))))))))" +"(define-values" +"(1/module-compiled-indirect-exports)" +"(lambda(c_15)" +"(begin" +" 'module-compiled-indirect-exports" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_15)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-compiled-indirect-exports" +" \"compiled-module-expression?\"" +" c_15)))" +"(values))))" +"(let-values(((h_8 inst_0)(compiled-module->h+declaration-instance c_15)))" +"(let-values(((min-phase_3)(hash-ref h_8 'min-phase 0)))" +"(let-values(((max-phase_3)(hash-ref h_8 'max-phase 0)))" +"(variables->api-nonprovides" +"(1/instance-variable-value inst_0 'provides)" +"(let-values(((start_38) min-phase_3)((end_27)(add1 max-phase_3))((inc_21) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_38 end_27 inc_21)))" +"((letrec-values(((for-loop_197)" +"(lambda(table_64 pos_101)" +"(begin" +" 'for-loop" +"(if(< pos_101 end_27)" +"(let-values(((phase-level_20) pos_101))" +"(let-values(((table_67)" +"(let-values(((table_192) table_64))" +"(let-values(((table_193)" +"(let-values()" +"(let-values(((key_72 val_63)" +"(let-values()" +"(let-values(((linklet_0)" +"(hash-ref" +" h_8" +" phase-level_20" +" #f)))" +"(values" +" phase-level_20" +"(if linklet_0" +"(1/linklet-export-variables" +" linklet_0)" +" null))))))" +"(hash-set" +" table_192" +" key_72" +" val_63)))))" +"(values table_193)))))" +"(if(not #f)(for-loop_197 table_67(+ pos_101 inc_21)) table_67)))" +" table_64)))))" +" for-loop_197)" +" '#hash()" +" start_38)))))))))))))" +"(define-values" +"(1/module-compiled-cross-phase-persistent?)" +"(lambda(c_42)" +"(begin" +" 'module-compiled-cross-phase-persistent?" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_42)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-compiled-cross-phase-persistent?" +" \"compiled-module-expression?\"" +" c_42)))" +"(values))))" +"(let-values(((h_9)(compiled-module->h c_42)))(hash-ref h_9 'cross-phase-persistent? #f))))))))" +"(define-values" +"(normalize-to-linklet-directory)" +"(lambda(c_43)" +"(begin" +"(if(1/linklet-directory?(compiled->linklet-directory-or-bundle c_43))" +"(let-values() c_43)" +"(if(1/linklet-bundle? c_43)" +"(let-values()(1/hash->linklet-directory(hasheq #f c_43)))" +"(let-values()" +"(let-values(((the-struct_8) c_43))" +"(if(compiled-in-memory? the-struct_8)" +"(let-values(((linklet-directory16_0)" +"(normalize-to-linklet-directory(compiled-in-memory-linklet-directory c_43))))" +"(compiled-in-memory1.1" +" linklet-directory16_0" +"(compiled-in-memory-original-self the-struct_8)" +"(compiled-in-memory-requires the-struct_8)" +"(compiled-in-memory-provides the-struct_8)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_8)" +"(compiled-in-memory-compile-time-inspector the-struct_8)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_8)" +"(compiled-in-memory-mpis the-struct_8)" +"(compiled-in-memory-syntax-literals the-struct_8)" +"(compiled-in-memory-pre-compiled-in-memorys the-struct_8)" +"(compiled-in-memory-post-compiled-in-memorys the-struct_8)" +"(compiled-in-memory-namespace-scopes the-struct_8)" +"(compiled-in-memory-purely-functional? the-struct_8)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_8)))))))))" +"(define-values" +"(fixup-submodule-names)" +"(lambda(c_44)(begin(1/module-compiled-name c_44(1/module-compiled-name c_44)))))" +"(define-values" +"(reset-submodule-names)" +"(lambda(b_78 pre?_1 submods_2)" +"(begin" +"(1/hash->linklet-bundle" +"(hash-set" +"(1/linklet-bundle->hash b_78)" +"(if pre?_1 'pre 'post)" +"(map2 module-compiled-immediate-name submods_2))))))" +"(define-values" +"(compile-module13.1)" +"(lambda(force-linklet-directory?1_0" +" modules-being-compiled4_0" +" need-compiled-submodule-rename?5_0" +" serializable?2_0" +" to-source?3_0" +" p11_0" +" cctx12_0)" +"(begin" +" 'compile-module13" +"(let-values(((p_46) p11_0))" +"(let-values(((cctx_14) cctx12_0))" +"(let-values(((force-linklet-directory?_0) force-linklet-directory?1_0))" +"(let-values(((serializable?_2) serializable?2_0))" +"(let-values(((to-source?_2) to-source?3_0))" +"(let-values(((modules-being-compiled_0)" +"(if(eq? modules-being-compiled4_0 unsafe-undefined)" +"(make-hasheq)" +" modules-being-compiled4_0)))" +"(let-values(((need-compiled-submodule-rename?_0) need-compiled-submodule-rename?5_0))" +"(let-values()" +"(let-values(((full-module-name_1)" +"(let-values(((parent-full-name_0)(compile-context-full-module-name cctx_14))" +"((name_55)(syntax-e$1(parsed-module-name-id p_46))))" +"(if parent-full-name_0" +"(append" +"(if(list? parent-full-name_0) parent-full-name_0(list parent-full-name_0))" +"(list name_55))" +" name_55))))" +"(let-values(((compiled-submodules_0)(parsed-module-compiled-submodules p_46)))" +"(let-values(((get-submodules_0)" +"(lambda(star?_0)" +"(begin" +" 'get-submodules" +"(reverse$1" +"(let-values(((ht_126) compiled-submodules_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_126)))" +"((letrec-values(((for-loop_243)" +"(lambda(fold-var_28 i_92)" +"(begin" +" 'for-loop" +"(if i_92" +"(let-values(((name_56 star?+compiled_0)" +"(hash-iterate-key+value" +" ht_126" +" i_92)))" +"(let-values(((fold-var_157)" +"(let-values(((fold-var_71)" +" fold-var_28))" +"(if(eq?" +" star?_0" +"(car star?+compiled_0))" +"(let-values(((fold-var_225)" +" fold-var_71))" +"(let-values(((fold-var_32)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" name_56" +"(if(if need-compiled-submodule-rename?_0" +"(not" +"(parsed-module-compiled-module" +" p_46))" +" #f)" +"(update-submodule-names" +"(cdr" +" star?+compiled_0)" +" name_56" +" full-module-name_1)" +"(cdr" +" star?+compiled_0))))" +" fold-var_225))))" +"(values fold-var_32)))" +" fold-var_71))))" +"(if(not #f)" +"(for-loop_243" +" fold-var_157" +"(hash-iterate-next ht_126 i_92))" +" fold-var_157)))" +" fold-var_28)))))" +" for-loop_243)" +" null" +"(hash-iterate-first ht_126)))))))))" +"(let-values(((pre-submodules_0)(get-submodules_0 #f)))" +"(let-values(((post-submodules_0)(get-submodules_0 #t)))" +"(let-values(((c1_27)(parsed-module-compiled-module p_46)))" +"(if c1_27" +"((lambda(c_45)" +"(let-values(((name_52 prefix_6)" +"(if(symbol? full-module-name_1)" +"(values full-module-name_1 null)" +"(let-values(((r_6)(reverse$1 full-module-name_1)))" +"(values(car r_6)(reverse$1(cdr r_6)))))))" +"(let-values(((m_18)(change-module-name c_45 name_52 prefix_6)))" +"(1/module-compiled-submodules" +"(1/module-compiled-submodules m_18 #t(map2 cdr pre-submodules_0))" +" #f" +"(map2 cdr post-submodules_0)))))" +" c1_27)" +"(let-values()" +"(let-values(((p37_0) p_46)" +"((cctx38_0) cctx_14)" +"((full-module-name39_0) full-module-name_1)" +"((force-linklet-directory?40_0) force-linklet-directory?_0)" +"((serializable?41_0) serializable?_2)" +"((to-source?42_0) to-source?_2)" +"((modules-being-compiled43_0) modules-being-compiled_0)" +"((pre-submodules44_0) pre-submodules_0)" +"((post-submodules45_0) post-submodules_0)" +"((need-compiled-submodule-rename?46_0)" +" need-compiled-submodule-rename?_0))" +"(compile-module-from-parsed34.1" +" force-linklet-directory?40_0" +" full-module-name39_0" +" modules-being-compiled43_0" +" need-compiled-submodule-rename?46_0" +" post-submodules45_0" +" pre-submodules44_0" +" serializable?41_0" +" to-source?42_0" +" p37_0" +" cctx38_0)))))))))))))))))))))" +"(define-values" +"(compile-module-from-parsed34.1)" +"(lambda(force-linklet-directory?17_0" +" full-module-name16_0" +" modules-being-compiled20_0" +" need-compiled-submodule-rename?23_0" +" post-submodules22_0" +" pre-submodules21_0" +" serializable?18_0" +" to-source?19_0" +" p32_1" +" cctx33_0)" +"(begin" +" 'compile-module-from-parsed34" +"(let-values(((p_19) p32_1))" +"(let-values(((cctx_17) cctx33_0))" +"(let-values(((full-module-name_2) full-module-name16_0))" +"(let-values(((force-linklet-directory?_1) force-linklet-directory?17_0))" +"(let-values(((serializable?_3) serializable?18_0))" +"(let-values(((to-source?_3) to-source?19_0))" +"(let-values(((modules-being-compiled_1) modules-being-compiled20_0))" +"(let-values(((pre-submodules_1) pre-submodules21_0))" +"(let-values(((post-submodules_1) post-submodules22_0))" +"(let-values(((need-compiled-submodule-rename?_1) need-compiled-submodule-rename?23_0))" +"(let-values()" +"(let-values()" +"(let-values(((enclosing-self_0)(compile-context-module-self cctx_17)))" +"(let-values(((self_25)(parsed-module-self p_19)))" +"(let-values(((requires_5)(parsed-module-requires p_19)))" +"(let-values(((provides_11)(parsed-module-provides p_19)))" +"(let-values(((encoded-root-expand-ctx-box_1)" +"(box(parsed-module-encoded-root-ctx p_19))))" +"(let-values(((body-context-simple?_0)(parsed-module-root-ctx-simple? p_19)))" +"(let-values(((language-info_2)" +"(filter-language-info" +"(syntax-property$1(parsed-s p_19) 'module-language))))" +"(let-values(((bodys_6)(parsed-module-body p_19)))" +"(let-values(((empty-result-for-module->namespace?_0) #f))" +"(let-values(((mpis_19)(make-module-path-index-table)))" +"(let-values(((body-cctx_0)" +"(let-values(((the-struct_56) cctx_17))" +"(if(compile-context? the-struct_56)" +"(let-values(((phase47_1) 0)" +"((self48_0) self_25)" +"((module-self49_0) self_25)" +"((full-module-name50_0)" +" full-module-name_2)" +"((lazy-syntax-literals?51_0) #t))" +"(compile-context1.1" +"(compile-context-namespace the-struct_56)" +" phase47_1" +" self48_0" +" module-self49_0" +" full-module-name50_0" +" lazy-syntax-literals?51_0" +"(compile-context-header the-struct_56)))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_56)))))" +"(let-values(((cross-phase-persistent?_2) #f))" +"(let-values(((side-effects_0)(make-hasheqv)))" +"(let-values(((check-side-effects!_0)" +"(lambda(e_73" +" expected-results_3" +" phase_93" +" required-reference?_1)" +"(begin" +" 'check-side-effects!" +"(if(hash-ref side-effects_0 phase_93 #f)" +"(void)" +"(let-values()" +"(if(let-values(((e52_2) e_73)" +"((expected-results53_0)" +" expected-results_3)" +"((required-reference?54_0)" +" required-reference?_1))" +"(any-side-effects?9.1" +" unsafe-undefined" +" unsafe-undefined" +" required-reference?54_0" +" e52_2" +" expected-results53_0))" +"(let-values()" +"(hash-set!" +" side-effects_0" +" phase_93" +" #t))" +"(void))))))))" +"(let-values((()" +"(begin" +"(if(if need-compiled-submodule-rename?_1" +" modules-being-compiled_1" +" #f)" +"(let-values()" +"(begin" +"(if(null? post-submodules_1)" +"(void)" +"(let-values()" +"(error" +" \"internal error: have post submodules, but not already compiled\")))" +"(register-compiled-submodules" +" modules-being-compiled_1" +" pre-submodules_1" +" self_25)))" +"(void))" +"(values))))" +"(let-values(((body-linklets_2" +" min-phase_4" +" max-phase_4" +" phase-to-link-module-uses_4" +" phase-to-link-module-uses-expr_3" +" phase-to-link-extra-inspectorsss_2" +" syntax-literals_4" +" root-ctx-pos_0)" +"(let-values(((bodys55_0) bodys_6)" +"((body-cctx56_0) body-cctx_0)" +"((mpis57_0) mpis_19)" +"((temp58_0)" +"(list" +"(list get-syntax-literal!-id)" +"(list set-transformer!-id)))" +"((temp59_2)" +"(list" +" empty-syntax-literals-instance" +" empty-module-body-instance))" +"((temp60_1) '((void)))" +"((temp61_0) '(0))" +"((encoded-root-expand-ctx-box62_0)" +" encoded-root-expand-ctx-box_1)" +"((body-context-simple?63_0)" +" body-context-simple?_0)" +"((check-side-effects!64_0)" +" check-side-effects!_0)" +"((temp65_0)" +"(lambda(body_3 cctx_18)" +"(if(parsed-#%declare? body_3)" +"(let-values()" +"(let-values(((ok?_27" +" _69_2" +" kw70_0)" +"(let-values(((s_403)" +"(parsed-s" +" body_3)))" +"(let-values(((orig-s_29)" +" s_403))" +"(let-values(((_69_3" +" kw70_1)" +"(let-values(((s_34)" +"(if(syntax?$1" +" s_403)" +"(syntax-e$1" +" s_403)" +" s_403)))" +"(if(pair?" +" s_34)" +"(let-values(((_71_0)" +"(let-values(((s_59)" +"(car" +" s_34)))" +" s_59))" +"((kw72_0)" +"(let-values(((s_404)" +"(cdr" +" s_34)))" +"(let-values(((s_405)" +"(if(syntax?$1" +" s_404)" +"(syntax-e$1" +" s_404)" +" s_404)))" +"(let-values(((flat-s_19)" +"(to-syntax-list.1" +" s_405)))" +"(if(not" +" flat-s_19)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_29))" +"(let-values()" +" flat-s_19)))))))" +"(values" +" _71_0" +" kw72_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_29)))))" +"(values" +" #t" +" _69_3" +" kw70_1))))))" +"(begin" +"(let-values(((lst_198)" +" kw70_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_198)))" +"((letrec-values(((for-loop_207)" +"(lambda(lst_271)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_271)" +"(let-values(((kw_0)" +"(unsafe-car" +" lst_271))" +"((rest_149)" +"(unsafe-cdr" +" lst_271)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(if(eq?" +"(syntax-e$1" +" kw_0)" +" '#:cross-phase-persistent)" +"(let-values()" +"(set! cross-phase-persistent?_2" +" #t))" +"(void))" +"(if(eq?" +"(syntax-e$1" +" kw_0)" +" '#:empty-namespace)" +"(let-values()" +"(begin" +"(set! empty-result-for-module->namespace?_0" +" #t)" +"(set-box!" +" encoded-root-expand-ctx-box_1" +" #f)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_207" +" rest_149)" +"(values))))" +"(values))))))" +" for-loop_207)" +" lst_198)))" +"(void)" +" #f)))" +"(let-values() #f))))" +"((temp66_1)" +"(lambda(mod-name_17 phase_94)" +"(let-values(((ht_128)" +"(if modules-being-compiled_1" +"(hash-ref" +" modules-being-compiled_1" +" mod-name_17" +" #f)" +" #f)))" +"(if ht_128" +"(hash-ref" +" ht_128" +" phase_94" +" #f)" +" #f))))" +"((to-source?67_0) to-source?_3)" +"((serializable?68_0)" +" serializable?_3))" +"(compile-forms31.1" +" temp59_2" +" temp58_0" +" temp60_1" +" check-side-effects!64_0" +" #t" +" unsafe-undefined" +" encoded-root-expand-ctx-box62_0" +" temp61_0" +" temp66_1" +" temp65_0" +" body-context-simple?63_0" +" serializable?68_0" +" to-source?67_0" +" bodys55_0" +" body-cctx56_0" +" mpis57_0))))" +"(let-values((()" +"(begin" +"(if modules-being-compiled_1" +"(let-values()" +"(hash-set!" +" modules-being-compiled_1" +"(1/module-path-index-resolve self_25)" +"(let-values(((ht_129)" +" body-linklets_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_129)))" +"((letrec-values(((for-loop_23)" +"(lambda(table_100" +" i_149)" +"(begin" +" 'for-loop" +"(if i_149" +"(let-values(((phase_95" +" linklet_6)" +"(hash-iterate-key+value" +" ht_129" +" i_149)))" +"(let-values(((table_194)" +"(let-values(((table_195)" +" table_100))" +"(let-values(((table_196)" +"(let-values()" +"(let-values(((key_73" +" val_64)" +"(let-values()" +"(values" +" phase_95" +"(module-linklet-info2.1" +" linklet_6" +"(hash-ref" +" phase-to-link-module-uses_4" +" phase_95" +" #f)" +" self_25" +" #f" +" #f" +"(if phase-to-link-extra-inspectorsss_2" +"(hash-ref" +" phase-to-link-extra-inspectorsss_2" +" phase_95" +" #f)" +" #f))))))" +"(hash-set" +" table_195" +" key_73" +" val_64)))))" +"(values" +" table_196)))))" +"(if(not" +" #f)" +"(for-loop_23" +" table_194" +"(hash-iterate-next" +" ht_129" +" i_149))" +" table_194)))" +" table_100)))))" +" for-loop_23)" +" '#hasheq()" +"(hash-iterate-first ht_129))))))" +"(void))" +"(values))))" +"(let-values(((declaration-linklet_0)" +"(if serializable?_3" +"((if to-source?_3" +" values" +"(lambda(s_406)" +"(let-values()" +"(1/compile-linklet" +" s_406" +" 'decl))))" +"(list" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id))" +" '(self-mpi" +" requires" +" provides" +" phase-to-link-modules)" +"(list" +" 'define-values" +" '(self-mpi)" +"(add-module-path-index!" +" mpis_19" +" self_25))" +"(list" +" 'define-values" +" '(requires)" +"(let-values(((requires73_0)" +" requires_5)" +"((mpis74_0) mpis_19)" +"((temp75_0) #f))" +"(generate-deserialize6.1" +" temp75_0" +" requires73_0" +" mpis74_0)))" +"(list" +" 'define-values" +" '(provides)" +"(let-values(((provides76_0)" +" provides_11)" +"((mpis77_0) mpis_19)" +"((temp78_0) #f))" +"(generate-deserialize6.1" +" temp78_0" +" provides76_0" +" mpis77_0)))" +"(list" +" 'define-values" +" '(phase-to-link-modules)" +" phase-to-link-module-uses-expr_3)))" +" #f)))" +"(let-values(((syntax-literals-linklet_2)" +"(if(not" +"(syntax-literals-empty?" +" syntax-literals_4))" +"((if to-source?_3" +" values" +"(lambda(s_407)" +"(let-values()" +"(let-values(((linklet_7" +" new-keys_1)" +"(1/compile-linklet" +" s_407" +" 'syntax-literals" +"(vector" +" deserialize-instance" +" empty-top-syntax-literal-instance" +" empty-syntax-literals-data-instance" +" empty-instance-instance)" +"(lambda(inst_4)" +"(values" +" inst_4" +" #f))" +"(if serializable?_3" +" '(serializable)" +" '()))))" +" linklet_7))))" +"(list*" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id)" +"(list*" +" deserialized-syntax-vector-id" +"(if serializable?_3" +"(list deserialize-syntax-id)" +" '()))" +" instance-imports)" +"(list*" +" get-syntax-literal!-id" +" '(get-encoded-root-expand-ctx))" +"(qq-append" +"(let-values(((syntax-literals79_0)" +" syntax-literals_4)" +"((mpis80_0) mpis_19)" +"((self81_0) self_25)" +"((temp82_1)" +"(not" +" serializable?_3)))" +"(generate-lazy-syntax-literals!9.1" +" temp82_1" +" syntax-literals79_0" +" mpis80_0" +" self81_0))" +"(list" +"(list" +" 'define-values" +" '(get-encoded-root-expand-ctx)" +"(if root-ctx-pos_0" +"(let-values()" +"(list" +" 'lambda" +" '()" +"(generate-lazy-syntax-literal-lookup" +" root-ctx-pos_0)))" +"(if empty-result-for-module->namespace?_0" +"(let-values() ''empty)" +"(let-values() ''#f))))))))" +" #f)))" +"(let-values(((syntax-literals-data-linklet_0)" +"(if serializable?_3" +"(if(not" +"(syntax-literals-empty?" +" syntax-literals_4))" +"((if to-source?_3" +" values" +"(lambda(s_208)" +"(let-values()" +"(1/compile-linklet" +" s_208" +" 'syntax-literals-data))))" +"(list*" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id))" +"(list" +" deserialized-syntax-vector-id" +" deserialize-syntax-id)" +"(list" +" 'define-values" +"(list" +" deserialized-syntax-vector-id)" +"(list*" +" 'make-vector" +"(syntax-literals-count" +" syntax-literals_4)" +" '(#f)))" +"(let-values()" +"(generate-lazy-syntax-literals-data!" +" syntax-literals_4" +" mpis_19))))" +" #f)" +" #f)))" +"(let-values(((data-linklet_0)" +"(if serializable?_3" +"((if to-source?_3" +" values" +"(lambda(s_209)" +"(let-values()" +"(1/compile-linklet" +" s_209" +" 'data))))" +"(list" +" 'linklet" +"(list deserialize-imports)" +"(list mpi-vector-id)" +"(list*" +" 'define-values" +"(list inspector-id)" +" '((current-code-inspector)))" +"(list" +" 'define-values" +"(list mpi-vector-id)" +"(generate-module-path-index-deserialize" +" mpis_19))))" +" #f)))" +"(let-values(((bundle_1)" +"(let-values(((bundle_2)" +"(hash-set" +" body-linklets_2" +" 'name" +" full-module-name_2)))" +"(let-values(((bundle_3)" +"(hash-set" +" bundle_2" +" 'decl" +"(let-values(((or-part_179)" +" declaration-linklet_0))" +"(if or-part_179" +" or-part_179" +" 'in-memory)))))" +"(let-values(((bundle_4)" +"(if data-linklet_0" +"(hash-set" +" bundle_3" +" 'data" +" data-linklet_0)" +" bundle_3)))" +"(let-values(((bundle_5)" +"(if syntax-literals-linklet_2" +"(hash-set" +" bundle_4" +" 'stx" +" syntax-literals-linklet_2)" +" bundle_4)))" +"(let-values(((bundle_6)" +"(if syntax-literals-data-linklet_0" +"(hash-set" +" bundle_5" +" 'stx-data" +" syntax-literals-data-linklet_0)" +" bundle_5)))" +"(let-values(((bundle_7)" +"(if(null?" +" pre-submodules_1)" +" bundle_6" +"(hash-set" +" bundle_6" +" 'pre" +"(map2" +" car" +" pre-submodules_1)))))" +"(let-values(((bundle_8)" +"(if(null?" +" post-submodules_1)" +" bundle_7" +"(hash-set" +" bundle_7" +" 'post" +"(map2" +" car" +" post-submodules_1)))))" +"(let-values(((bundle_9)" +"(if cross-phase-persistent?_2" +"(hash-set" +" bundle_8" +" 'cross-phase-persistent?" +" #t)" +" bundle_8)))" +"(let-values(((bundle_10)" +"(if language-info_2" +"(hash-set" +" bundle_9" +" 'language-info" +" language-info_2)" +" bundle_9)))" +"(let-values(((bundle_11)" +"(if(zero?" +" min-phase_4)" +" bundle_10" +"(hash-set" +" bundle_10" +" 'min-phase" +" min-phase_4))))" +"(let-values(((bundle_12)" +"(if(zero?" +" max-phase_4)" +" bundle_11" +"(hash-set" +" bundle_11" +" 'max-phase" +" max-phase_4))))" +"(let-values(((bundle_13)" +"(if(hash-count" +" side-effects_0)" +"(hash-set" +" bundle_12" +" 'side-effects" +"(let-values(((temp83_0)" +"(hash-keys" +" side-effects_0))" +"((<84_0)" +" <))" +"(sort7.1" +" #f" +" #f" +" temp83_0" +" <84_0)))" +" bundle_12)))" +"(let-values(((bundle_14)" +"(if empty-result-for-module->namespace?_0" +"(hash-set" +" bundle_13" +" 'module->namespace" +" 'empty)" +" bundle_13)))" +"(1/hash->linklet-bundle" +" bundle_14))))))))))))))))" +"(let-values(((ld_4)" +"(if(if(null? pre-submodules_1)" +"(if(null?" +" post-submodules_1)" +"(not" +" force-linklet-directory?_1)" +" #f)" +" #f)" +"(let-values() bundle_1)" +"(let-values()" +"((if to-source?_3" +" values" +" 1/hash->linklet-directory)" +"(let-values(((lst_272)" +"(append" +" pre-submodules_1" +" post-submodules_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_272)))" +"((letrec-values(((for-loop_244)" +"(lambda(ht_130" +" lst_273)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_273)" +"(let-values(((sm_0)" +"(unsafe-car" +" lst_273))" +"((rest_150)" +"(unsafe-cdr" +" lst_273)))" +"(let-values(((ht_131)" +"(let-values(((ht_132)" +" ht_130))" +"(let-values(((ht_123)" +"(let-values()" +"(hash-set" +" ht_132" +"(car" +" sm_0)" +"((if to-source?_3" +" values" +" compiled-in-memory-linklet-directory)" +"(cdr" +" sm_0))))))" +"(values" +" ht_123)))))" +"(if(not" +" #f)" +"(for-loop_244" +" ht_131" +" rest_150)" +" ht_131)))" +" ht_130)))))" +" for-loop_244)" +"(hasheq #f bundle_1)" +" lst_272))))))))" +"(if to-source?_3" +"(let-values() ld_4)" +"(let-values()" +"(compiled-in-memory1.1" +" ld_4" +" self_25" +" requires_5" +" provides_11" +" phase-to-link-module-uses_4" +"(current-code-inspector)" +" phase-to-link-extra-inspectorsss_2" +"(mpis-as-vector mpis_19)" +"(syntax-literals-as-vector" +" syntax-literals_4)" +"(map2 cdr pre-submodules_1)" +"(map2 cdr post-submodules_1)" +" #f" +" #f)))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(update-submodule-names)" +"(lambda(cim_9 name_57 full-module-name_3)" +"(begin" +"(change-module-name" +" cim_9" +" name_57" +"(if(symbol? full-module-name_3)(list full-module-name_3)(reverse$1(cdr(reverse$1 full-module-name_3))))))))" +"(define-values" +"(register-compiled-submodules)" +"(lambda(modules-being-compiled_2 pre-submodules_2 self_26)" +"(begin" +"(begin" +"(let-values(((lst_274) pre-submodules_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_274)))" +"((letrec-values(((for-loop_245)" +"(lambda(lst_275)" +"(begin" +" 'for-loop" +"(if(pair? lst_275)" +"(let-values(((s_408)(unsafe-car lst_275))((rest_151)(unsafe-cdr lst_275)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((name_58)(car s_408)))" +"(let-values(((cim_10)(cdr s_408)))" +"(let-values(((phase-to-link-module-uses_5)" +"(compiled-in-memory-phase-to-link-module-uses" +" cim_10)))" +"(let-values(((ld_5)" +"(compiled-in-memory-linklet-directory" +" cim_10)))" +"(let-values(((sm-self_0)" +"(1/module-path-index-join" +"(list" +" 'submod" +" \".\"" +" name_58)" +" self_26)))" +"(let-values(((phase-to-extra-inspectorsss_0)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss" +" cim_10)))" +"(hash-set!" +" modules-being-compiled_2" +"(1/module-path-index-resolve" +" sm-self_0)" +"(let-values(((ht_133)" +"(1/linklet-bundle->hash" +"(if(1/linklet-directory?" +" ld_5)" +"(hash-ref" +"(1/linklet-directory->hash" +" ld_5)" +" #f)" +" ld_5))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_133)))" +"((letrec-values(((for-loop_246)" +"(lambda(table_197" +" i_150)" +"(begin" +" 'for-loop" +"(if i_150" +"(let-values(((phase_96" +" linklet_8)" +"(hash-iterate-key+value" +" ht_133" +" i_150)))" +"(let-values(((table_198)" +"(let-values(((table_199)" +" table_197))" +"(if(number?" +" phase_96)" +"(let-values(((table_200)" +" table_199))" +"(let-values(((table_201)" +"(let-values()" +"(let-values(((key_74" +" val_65)" +"(let-values()" +"(values" +" phase_96" +"(module-linklet-info2.1" +" linklet_8" +"(hash-ref" +" phase-to-link-module-uses_5" +" phase_96" +" #f)" +"(compiled-in-memory-original-self" +" cim_10)" +" #f" +"(compiled-in-memory-compile-time-inspector" +" cim_10)" +"(if phase-to-extra-inspectorsss_0" +"(hash-ref" +" phase-to-extra-inspectorsss_0" +" phase_96" +" #f)" +" #f))))))" +"(hash-set" +" table_200" +" key_74" +" val_65)))))" +"(values" +" table_201)))" +" table_199))))" +"(if(not" +" #f)" +"(for-loop_246" +" table_198" +"(hash-iterate-next" +" ht_133" +" i_150))" +" table_198)))" +" table_197)))))" +" for-loop_246)" +" '#hasheq()" +"(hash-iterate-first" +" ht_133))))))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_245 rest_151)(values))))" +"(values))))))" +" for-loop_245)" +" lst_274)))" +"(void)))))" +"(define-values" +"(filter-language-info)" +"(lambda(li_1)" +"(begin" +"(if(vector? li_1)" +"(if(= 3(vector-length li_1))" +"(if(1/module-path?(vector-ref li_1 0))(if(symbol?(vector-ref li_1 1)) li_1 #f) #f)" +" #f)" +" #f))))" +"(define-values" +"(1/compiled-expression-recompile)" +"(lambda(c_32)" +"(begin" +" 'compiled-expression-recompile" +"(begin" +"(if(1/compiled-expression? c_32)" +"(void)" +" (let-values () (raise-argument-error 'compiled-expression-recompile \"compiled-expression?\" c_32)))" +"(if(1/linklet-bundle? c_32)" +"(let-values()" +"(1/hash->linklet-bundle" +"(let-values(((ht_134)(1/linklet-bundle->hash c_32)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_134)))" +"((letrec-values(((for-loop_247)" +"(lambda(table_202 i_151)" +"(begin" +" 'for-loop" +"(if i_151" +"(let-values(((k_33 v_73)(hash-iterate-key+value ht_134 i_151)))" +"(let-values(((table_203)" +"(let-values(((table_204) table_202))" +"(let-values(((table_205)" +"(let-values()" +"(let-values(((key_75 val_66)" +"(let-values()" +"(if(1/linklet? v_73)" +"(let-values()" +"(values" +" k_33" +"(1/recompile-linklet" +" v_73)))" +"(let-values()" +"(values k_33 v_73))))))" +"(hash-set table_204 key_75 val_66)))))" +"(values table_205)))))" +"(if(not #f)" +"(for-loop_247 table_203(hash-iterate-next ht_134 i_151))" +" table_203)))" +" table_202)))))" +" for-loop_247)" +" '#hasheq()" +"(hash-iterate-first ht_134))))))" +"(if(1/linklet-directory? c_32)" +"(let-values()" +"(1/hash->linklet-directory" +"(let-values(((ht_84)(1/linklet-directory->hash c_32)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_84)))" +"((letrec-values(((for-loop_218)" +"(lambda(table_167 i_152)" +"(begin" +" 'for-loop" +"(if i_152" +"(let-values(((k_34 v_1)(hash-iterate-key+value ht_84 i_152)))" +"(let-values(((table_206)" +"(let-values(((table_207) table_167))" +"(let-values(((table_168)" +"(let-values()" +"(let-values(((key_76 val_67)" +"(let-values()" +"(if(1/compiled-expression?" +" v_1)" +"(let-values()" +"(values" +" k_34" +"(1/compiled-expression-recompile" +" v_1)))" +"(let-values()" +"(values k_34 v_1))))))" +"(hash-set table_207 key_76 val_67)))))" +"(values table_168)))))" +"(if(not #f)" +"(for-loop_218 table_206(hash-iterate-next ht_84 i_152))" +" table_206)))" +" table_167)))))" +" for-loop_218)" +" '#hasheq()" +"(hash-iterate-first ht_84))))))" +"(let-values() c_32)))))))" +"(define-values" +"(create-compiled-in-memorys-using-shared-data)" +"(lambda(tops_0 data-linklet_1 ns_59)" +"(begin" +"(let-values(((data-instance_5)" +"(1/instantiate-linklet" +" data-linklet_1" +"(list" +" deserialize-instance" +"(let-values(((ns1_1) ns_59)" +"((temp2_3)(namespace-phase ns_59))" +"((temp3_3)(namespace-mpi ns_59))" +"((temp4_1)(namespace-bulk-binding-registry ns_59))" +"((temp5_3)(current-code-inspector)))" +"(make-eager-instance-instance11.1 temp4_1 temp2_3 temp5_3 ns1_1 temp3_3))))))" +"(let-values(((data_0)(lambda(key_77)(begin 'data(1/instance-variable-value data-instance_5 key_77)))))" +"(let-values(((mpi-vector_0)(data_0 mpi-vector-id)))" +"(let-values(((mpi-vector-trees_0)(data_0 'mpi-vector-trees)))" +"(let-values(((phase-to-link-modules-vector_0)(data_0 'phase-to-link-modules-vector)))" +"(let-values(((phase-to-link-modules-trees_0)(data_0 'phase-to-link-modules-trees)))" +"(let-values(((syntax-literals_5)(data_0 'syntax-literals)))" +"(let-values(((syntax-literals-trees_1)(data_0 'syntax-literals-trees)))" +"(let-values(((namespace-scopes_0)(extract-namespace-scopes ns_59)))" +"(letrec-values(((construct-compiled-in-memory_0)" +"(lambda(ld_6" +" mpi-vector-tree_0" +" phase-to-link-modules-tree_0" +" syntax-literals-tree_0)" +"(begin" +" 'construct-compiled-in-memory" +"(let-values(((is-module?_0)" +"(let-values(((or-part_75)(1/linklet-bundle? ld_6)))" +"(if or-part_75" +" or-part_75" +"(let-values(((b_79)" +"(hash-ref" +"(1/linklet-directory->hash ld_6)" +" #f" +" #f)))" +"(if b_79" +"(hash-ref(1/linklet-bundle->hash b_79) 'decl #f)" +" #f))))))" +"(let-values(((mpi-pos-vec_0)(vector-ref mpi-vector-tree_0 0)))" +"(let-values(((syntax-literals-spec_0)" +"(vector-ref syntax-literals-tree_0 0)))" +"(let-values(((pres_0)" +"(if is-module?_0" +"(extract-submodules ld_6 'pre)" +"(compiled-top->compiled-tops ld_6))))" +"(let-values(((posts_0)" +"(if is-module?_0" +"(extract-submodules ld_6 'post)" +" null)))" +"(let-values(((map-construct-compiled-in-memory_0)" +"(lambda(l_67 vec-pos_0)" +"(begin" +" 'map-construct-compiled-in-memory" +"(reverse$1" +"(let-values(((lst_163) l_67)" +"((lst_89)" +"(vector-ref" +" mpi-vector-tree_0" +" vec-pos_0))" +"((lst_265)" +"(vector-ref" +" phase-to-link-modules-tree_0" +" vec-pos_0))" +"((lst_263)" +"(vector-ref" +" syntax-literals-tree_0" +" vec-pos_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_163)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_89)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_265)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_263)))" +"((letrec-values(((for-loop_237)" +"(lambda(fold-var_158" +" lst_261" +" lst_23" +" lst_104" +" lst_90)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_261)" +"(if(pair?" +" lst_23)" +"(if(pair?" +" lst_104)" +"(pair?" +" lst_90)" +" #f)" +" #f)" +" #f)" +"(let-values(((sub-ld_0)" +"(unsafe-car" +" lst_261))" +"((rest_143)" +"(unsafe-cdr" +" lst_261))" +"((mpi-vector-tree_1)" +"(unsafe-car" +" lst_23))" +"((rest_51)" +"(unsafe-cdr" +" lst_23))" +"((phase-to-link-modules-tree_1)" +"(unsafe-car" +" lst_104))" +"((rest_91)" +"(unsafe-cdr" +" lst_104))" +"((syntax-literals-tree_1)" +"(unsafe-car" +" lst_90))" +"((rest_37)" +"(unsafe-cdr" +" lst_90)))" +"(let-values(((fold-var_170)" +"(let-values(((fold-var_171)" +" fold-var_158))" +"(let-values(((fold-var_172)" +"(let-values()" +"(cons" +"(let-values()" +"(construct-compiled-in-memory_0" +" sub-ld_0" +" mpi-vector-tree_1" +" phase-to-link-modules-tree_1" +" syntax-literals-tree_1))" +" fold-var_171))))" +"(values" +" fold-var_172)))))" +"(if(not #f)" +"(for-loop_237" +" fold-var_170" +" rest_143" +" rest_51" +" rest_91" +" rest_37)" +" fold-var_170)))" +" fold-var_158)))))" +" for-loop_237)" +" null" +" lst_163" +" lst_89" +" lst_265" +" lst_263))))))))" +"(compiled-in-memory1.1" +" ld_6" +" #f" +" #f" +" #f" +"(vector-ref" +" phase-to-link-modules-vector_0" +"(vector-ref phase-to-link-modules-tree_0 0))" +" #f" +" '#hasheqv()" +"(let-values(((len_29)(vector-length mpi-pos-vec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_29)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_29)))" +"(let-values(((v_69)(make-vector len_29 0)))" +"(begin" +"(if(zero? len_29)" +"(void)" +"(let-values()" +"(let-values(((vec_65 len_30)" +"(let-values(((vec_66)" +" mpi-pos-vec_0))" +"(begin" +"(check-vector vec_66)" +"(values" +" vec_66" +"(unsafe-vector-length" +" vec_66))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_111)" +"(lambda(i_153 pos_102)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_102" +" len_30)" +"(let-values(((pos_103)" +"(unsafe-vector-ref" +" vec_65" +" pos_102)))" +"(let-values(((i_154)" +"(let-values(((i_63)" +" i_153))" +"(let-values(((i_155)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_69" +" i_63" +"(let-values()" +"(vector-ref" +" mpi-vector_0" +" pos_103)))" +"(unsafe-fx+" +" 1" +" i_63)))))" +"(values" +" i_155)))))" +"(if(if(not" +"((lambda x_19" +"(unsafe-fx=" +" i_154" +" len_29))" +" pos_103))" +"(not #f)" +" #f)" +"(for-loop_111" +" i_154" +"(unsafe-fx+" +" 1" +" pos_102))" +" i_154)))" +" i_153)))))" +" for-loop_111)" +" 0" +" 0)))))" +" v_69))))" +"(let-values(((len_31)(cdr syntax-literals-spec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_31)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_31)))" +"(let-values(((v_36)(make-vector len_31 0)))" +"(begin" +"(if(zero? len_31)" +"(void)" +"(let-values()" +"(let-values(((start_15) 0)" +"((end_28)" +"(cdr syntax-literals-spec_0))" +"((inc_22) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_15 end_28 inc_22)))" +"((letrec-values(((for-loop_248)" +"(lambda(i_156 pos_104)" +"(begin" +" 'for-loop" +"(if(< pos_104 end_28)" +"(let-values(((i_93)" +" pos_104))" +"(let-values(((i_157)" +"(let-values(((i_36)" +" i_156))" +"(let-values(((i_20)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_36" +" i_36" +"(let-values()" +"(if syntax-literals_5" +"(vector-ref" +" syntax-literals_5" +"(+" +"(car" +" syntax-literals-spec_0)" +" i_93))" +" #f)))" +"(unsafe-fx+" +" 1" +" i_36)))))" +"(values" +" i_20)))))" +"(if(if(not" +"((lambda x_72" +"(unsafe-fx=" +" i_157" +" len_31))" +" i_93))" +"(not #f)" +" #f)" +"(for-loop_248" +" i_157" +"(+" +" pos_104" +" inc_22))" +" i_157)))" +" i_156)))))" +" for-loop_248)" +" 0" +" start_15)))))" +" v_36))))" +"(map-construct-compiled-in-memory_0 pres_0 1)" +"(map-construct-compiled-in-memory_0 posts_0 2)" +" namespace-scopes_0" +" #f)))))))))))" +"(map2" +" construct-compiled-in-memory_0" +" tops_0" +" mpi-vector-trees_0" +" phase-to-link-modules-trees_0" +" syntax-literals-trees_1))))))))))))))" +"(define-values" +"(extract-submodules)" +"(lambda(ld_7 names-key_0)" +"(begin" +"(if(1/linklet-bundle? ld_7)" +"(let-values() null)" +"(let-values()" +"(let-values(((h_10)(1/linklet-directory->hash ld_7)))" +"(let-values(((mod_3)(hash-ref h_10 #f #f)))" +" (let-values ((() (begin (if mod_3 (void) (let-values () (error \"missing main module\"))) (values))))" +"(let-values(((mh_0)(1/linklet-bundle->hash mod_3)))" +"(let-values(((names_2)(hash-ref mh_0 names-key_0 null)))" +"(reverse$1" +"(let-values(((lst_178) names_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_178)))" +"((letrec-values(((for-loop_249)" +"(lambda(fold-var_5 lst_276)" +"(begin" +" 'for-loop" +"(if(pair? lst_276)" +"(let-values(((name_59)(unsafe-car lst_276))" +"((rest_152)(unsafe-cdr lst_276)))" +"(let-values(((fold-var_230)" +"(let-values(((fold-var_231) fold-var_5))" +"(let-values(((fold-var_161)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" h_10" +" name_59" +"(lambda()" +"(error" +" \"missing submodule declaration:\"" +" name_59))))" +" fold-var_231))))" +"(values fold-var_161)))))" +"(if(not #f)(for-loop_249 fold-var_230 rest_152) fold-var_230)))" +" fold-var_5)))))" +" for-loop_249)" +" null" +" lst_178))))))))))))))" +"(define-values" +"(eval-single-top)" +"(lambda(c_32 ns_42)" +"(begin(let-values(((c15_0) c_32)((ns16_1) ns_42)((temp17_3) #t))(eval-one-top12.1 temp17_3 c15_0 ns16_1 #t)))))" +"(define-values" +"(compiled-multiple-top?)" +"(lambda(c_34)" +"(begin" +"(let-values(((ld_8)(if(compiled-in-memory? c_34)(compiled-in-memory-linklet-directory c_34) c_34)))" +"(if(1/linklet-directory? ld_8)(not(hash-ref(1/linklet-directory->hash ld_8) #f #f)) #f)))))" +"(define-values" +"(eval-top)" +"(let-values(((eval-top5_0)" +"(lambda(c3_1 ns4_0 eval-compiled1_0 as-tail?2_0)" +"(begin" +" 'eval-top5" +"(let-values(((c_46) c3_1))" +"(let-values(((ns_67) ns4_0))" +"(let-values(((eval-compiled_0)" +"(if(eq? eval-compiled1_0 unsafe-undefined) eval-top eval-compiled1_0)))" +"(let-values(((as-tail?_0) as-tail?2_0))" +"(let-values()" +"(if(compiled-multiple-top? c_46)" +"(eval-multiple-tops c_46 ns_67 eval-compiled_0 as-tail?_0)" +"(let-values(((c18_0) c_46)((ns19_0) ns_67)((as-tail?20_0) as-tail?_0))" +"(eval-one-top12.1 #f c18_0 ns19_0 as-tail?20_0))))))))))))" +"(case-lambda" +"((c_47 ns_68)(begin(eval-top5_0 c_47 ns_68 unsafe-undefined #t)))" +"((c_48 ns_69 eval-compiled_1 as-tail?2_1)(eval-top5_0 c_48 ns_69 eval-compiled_1 as-tail?2_1))" +"((c_49 ns_70 eval-compiled1_1)(eval-top5_0 c_49 ns_70 eval-compiled1_1 #t)))))" +"(define-values" +"(eval-multiple-tops)" +"(lambda(c_50 ns_71 eval-compiled_2 as-tail?_1)" +"(begin" +"(let-values(((eval-compiled-parts_0)" +"(lambda(l_68)" +"(begin" +" 'eval-compiled-parts" +"((letrec-values(((loop_5)" +"(lambda(l_69)" +"(begin" +" 'loop" +"(if(null? l_69)" +"(let-values() void)" +"(if(null?(cdr l_69))" +"(let-values()(eval-compiled_2(car l_69) ns_71 as-tail?_1))" +"(let-values()" +"(begin" +"(eval-compiled_2(car l_69) ns_71 #f)" +"(loop_5(cdr l_69))))))))))" +" loop_5)" +" l_68)))))" +"(if(compiled-in-memory? c_50)" +"(let-values()(eval-compiled-parts_0(compiled-in-memory-pre-compiled-in-memorys c_50)))" +"(let-values(((c1_27)(hash-ref(1/linklet-directory->hash c_50) 'data #f)))" +"(if c1_27" +"((lambda(data-ld_0)" +"(eval-compiled-parts_0" +"(create-compiled-in-memorys-using-shared-data" +"(compiled-top->compiled-tops c_50)" +"(hash-ref(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash data-ld_0) #f)) 0)" +" ns_71)))" +" c1_27)" +"(let-values()(eval-compiled-parts_0(compiled-top->compiled-tops c_50))))))))))" +"(define-values" +"(eval-one-top12.1)" +"(lambda(single-expression?7_0 c10_0 ns11_0 as-tail?9_0)" +"(begin" +" 'eval-one-top12" +"(let-values(((c_51) c10_0))" +"(let-values(((ns_72) ns11_0))" +"(let-values(((as-tail?_2) as-tail?9_0))" +"(let-values(((single-expression?_1) single-expression?7_0))" +"(let-values()" +"(let-values()" +"(let-values(((ld_9)" +"(if(compiled-in-memory? c_51)(compiled-in-memory-linklet-directory c_51) c_51)))" +"(let-values(((h_11)(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash ld_9) #f))))" +"(let-values(((link-instance_0)" +"(if(compiled-in-memory? c_51)" +"(link-instance-from-compiled-in-memory" +" c_51" +"(if(not single-expression?_1) ns_72 #f))" +"(1/instantiate-linklet" +"(hash-ref h_11 'link)" +"(list" +" deserialize-instance" +"(let-values(((ns21_0) ns_72)" +"((temp22_4)(namespace-phase ns_72))" +"((temp23_4)(namespace-mpi ns_72))" +"((temp24_4)(namespace-bulk-binding-registry ns_72))" +"((temp25_4)(current-code-inspector)))" +"(make-eager-instance-instance11.1" +" temp24_4" +" temp22_4" +" temp25_4" +" ns21_0" +" temp23_4)))))))" +"(let-values(((orig-phase_1)(hash-ref h_11 'original-phase)))" +"(let-values(((max-phase_5)(hash-ref h_11 'max-phase)))" +"(let-values(((phase-shift_18)(phase-(namespace-phase ns_72) orig-phase_1)))" +"(let-values(((extra-inspector_8)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-compile-time-inspector c_51)" +" #f)))" +"(let-values(((phase-to-link-extra-inspectorsss_3)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss c_51)" +" '#hasheqv())))" +"(let-values(((phase-to-link-modules_1)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-phase-to-link-module-uses c_51)" +"(1/instance-variable-value link-instance_0 'phase-to-link-modules))))" +"(let-values(((thunk_5)" +"(let-values(((start_38) max-phase_5)" +"((end_27)(sub1 orig-phase_1))" +"((inc_21) -1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_38 end_27 inc_21)))" +"((letrec-values(((for-loop_197)" +"(lambda(prev-thunk_0 pos_101)" +"(begin" +" 'for-loop" +"(if(> pos_101 end_27)" +"(let-values(((phase_97) pos_101))" +"(let-values(((prev-thunk_1)" +"(let-values(((prev-thunk_2)" +" prev-thunk_0))" +"(let-values(((prev-thunk_3)" +"(let-values()" +"(let-values((()" +"(begin" +"(prev-thunk_2" +" #f)" +"(values))))" +"(let-values(((module-uses_1)" +"(hash-ref" +" phase-to-link-modules_1" +" phase_97" +" null)))" +"(let-values(((import-module-instances_2" +" import-instances_1)" +"(let-values(((mis_6" +" is_5)" +"(let-values(((lst_96)" +" module-uses_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_96)))" +"((letrec-values(((for-loop_113)" +"(lambda(mis_7" +" is_6" +" lst_225)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_225)" +"(let-values(((mu_9)" +"(unsafe-car" +" lst_225))" +"((rest_153)" +"(unsafe-cdr" +" lst_225)))" +"(let-values(((mis_8" +" is_7)" +"(let-values(((mis_9)" +" mis_7)" +"((is_8)" +" is_6))" +"(let-values(((mis_10" +" is_9)" +"(let-values()" +"(let-values(((mis26_0" +" is27_0)" +"(let-values()" +"(let-values(((ns28_0)" +" ns_72)" +"((mu29_0)" +" mu_9)" +"((temp30_3)" +"(phase-" +"(phase+" +" phase_97" +" phase-shift_18)" +"(module-use-phase" +" mu_9))))" +"(namespace-module-use->module+linklet-instances144.1" +" temp30_3" +" #f" +" #f" +" ns28_0" +" mu29_0)))))" +"(values" +"(cons" +" mis26_0" +" mis_9)" +"(cons" +" is27_0" +" is_8))))))" +"(values" +" mis_10" +" is_9)))))" +"(if(not" +" #f)" +"(for-loop_113" +" mis_8" +" is_7" +" rest_153)" +"(values" +" mis_8" +" is_7))))" +"(values" +" mis_7" +" is_6))))))" +" for-loop_113)" +" null" +" null" +" lst_96)))))" +"(values" +"(reverse$1" +" mis_6)" +"(reverse$1" +" is_5)))))" +"(let-values(((phase-ns_0)" +"(namespace->namespace-at-phase" +" ns_72" +"(phase+" +" phase_97" +" phase-shift_18))))" +"(let-values(((inst_5)" +"(if single-expression?_1" +" link-instance_0" +"(let-values(((phase-ns31_0)" +" phase-ns_0)" +"((phase-shift32_0)" +" phase-shift_18)" +"((temp33_1)" +"(namespace-mpi" +" ns_72))" +"((temp34_3)" +"(namespace-inspector" +" ns_72))" +"((temp35_1)" +"(namespace-bulk-binding-registry" +" ns_72))" +"((temp36_2)" +"(lambda(name_60" +" val_68)" +"(namespace-set-transformer!" +" ns_72" +"(phase+" +"(sub1" +" phase_97)" +" phase-shift_18)" +" name_60" +" val_68))))" +"(make-instance-instance13.1" +" temp35_1" +" temp34_3" +" phase-ns31_0" +" phase-shift32_0" +" temp33_1" +" temp36_2)))))" +"(let-values(((linklet_9)" +"(hash-ref" +" h_11" +" phase_97" +" #f)))" +"(if linklet_9" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((linklet37_0)" +" linklet_9)" +"((temp38_2)" +" 3)" +"((module-uses39_0)" +" module-uses_1)" +"((import-module-instances40_0)" +" import-module-instances_2)" +"((temp41_1)" +"(current-code-inspector))" +"((extra-inspector42_0)" +" extra-inspector_8)" +"((temp43_2)" +"(hash-ref" +" phase-to-link-extra-inspectorsss_3" +" phase_97" +" #f)))" +"(check-require-access9.1" +" temp38_2" +" linklet37_0" +" module-uses39_0" +" import-module-instances40_0" +" temp41_1" +" extra-inspector42_0" +" temp43_2))" +"(values))))" +"(let-values(((instantiate_0)" +"(lambda(tail?_49)" +"(begin" +" 'instantiate" +"(1/instantiate-linklet" +" linklet_9" +"(list*" +" top-level-instance" +" link-instance_0" +" inst_5" +" import-instances_1)" +"(namespace->instance" +" ns_72" +"(phase-" +"(phase+" +" phase_97" +" phase-shift_18)" +"(namespace-0-phase" +" ns_72)))" +"(not" +" tail?_49))))))" +"(if(zero-phase?" +" phase_97)" +"(let-values()" +" instantiate_0)" +"(if single-expression?_1" +"(let-values()" +"(lambda(tail?_50)" +"(begin" +" 'prev-thunk" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" phase-ns_0)" +"(let-values()" +"(instantiate_0" +" tail?_50))))))" +"(let-values()" +"(let-values(((ns-1_1)" +"(namespace->namespace-at-phase" +" phase-ns_0" +"(sub1" +" phase_97))))" +"(lambda(tail?_51)" +"(begin" +" 'prev-thunk" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +"(let-values(((ns-144_0)" +" ns-1_1))" +"(make-expand-context10.1" +" #f" +" #f" +" #f" +" ns-144_0))" +" 1/current-namespace" +" phase-ns_0)" +"(let-values()" +"(instantiate_0" +" tail?_51))))))))))))" +"(let-values()" +" void)))))))))))" +"(values" +" prev-thunk_3)))))" +"(if(not #f)" +"(for-loop_197" +" prev-thunk_1" +"(+ pos_101 inc_21))" +" prev-thunk_1)))" +" prev-thunk_0)))))" +" for-loop_197)" +" void" +" start_38)))))" +"(thunk_5 as-tail?_2))))))))))))))))))))" +"(define-values" +"(link-instance-from-compiled-in-memory)" +"(lambda(cim_11 to-ns_0)" +"(begin" +"(let-values(((orig-syntax-literals_0)(compiled-in-memory-syntax-literals cim_11)))" +"(let-values(((syntax-literals_6)" +"(if(not to-ns_0)" +"(let-values() orig-syntax-literals_0)" +"(if(namespace-scopes=?" +"(compiled-in-memory-namespace-scopes cim_11)" +"(extract-namespace-scopes to-ns_0))" +"(let-values() orig-syntax-literals_0)" +"(let-values()" +"(let-values(((len_32)(vector-length orig-syntax-literals_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_32)" +"(void)" +"(let-values()" +" (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_32)))" +"(let-values(((v_98)(make-vector len_32 0)))" +"(begin" +"(if(zero? len_32)" +"(void)" +"(let-values()" +"(let-values(((vec_67 len_33)" +"(let-values(((vec_68) orig-syntax-literals_0))" +"(begin" +"(check-vector vec_68)" +"(values vec_68(unsafe-vector-length vec_68))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_6)" +"(lambda(i_158 pos_105)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_105 len_33)" +"(let-values(((s_50)" +"(unsafe-vector-ref vec_67 pos_105)))" +"(let-values(((i_83)" +"(let-values(((i_159) i_158))" +"(let-values(((i_160)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_98" +" i_159" +"(let-values()" +"(swap-top-level-scopes" +" s_50" +"(compiled-in-memory-namespace-scopes" +" cim_11)" +" to-ns_0)))" +"(unsafe-fx+" +" 1" +" i_159)))))" +"(values i_160)))))" +"(if(if(not" +"((lambda x_73(unsafe-fx= i_83 len_32))" +" s_50))" +"(not #f)" +" #f)" +"(for-loop_6 i_83(unsafe-fx+ 1 pos_105))" +" i_83)))" +" i_158)))))" +" for-loop_6)" +" 0" +" 0)))))" +" v_98)))))))))" +"(1/make-instance" +" 'link" +" #f" +" 'constant" +" mpi-vector-id" +"(compiled-in-memory-mpis cim_11)" +" syntax-literals-id" +" syntax-literals_6))))))" +"(define-values(not-available)(gensym 'not-available))" +"(define-values(get-not-available)(lambda()(begin not-available)))" +"(define-values" +"(can-direct-eval?)" +"(lambda(p_45 ns_42 self-mpi_3)" +"(begin" +"(if(parsed-app? p_45)" +"(let-values()" +"(if(can-direct-eval?(parsed-app-rator p_45) ns_42 self-mpi_3)" +"(let-values(((lst_103)(parsed-app-rands p_45)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_103)))" +"((letrec-values(((for-loop_117)" +"(lambda(result_113 lst_84)" +"(begin" +" 'for-loop" +"(if(pair? lst_84)" +"(let-values(((r_42)(unsafe-car lst_84))((rest_50)(unsafe-cdr lst_84)))" +"(let-values(((result_79)" +"(let-values()" +"(let-values(((result_114)" +"(let-values()" +"(let-values()" +"(can-direct-eval? r_42 ns_42 self-mpi_3)))))" +"(values result_114)))))" +"(if(if(not((lambda x_74(not result_79)) r_42))(not #f) #f)" +"(for-loop_117 result_79 rest_50)" +" result_79)))" +" result_113)))))" +" for-loop_117)" +" #t" +" lst_103)))" +" #f))" +"(if(parsed-id? p_45)" +"(let-values()(not(eq?(get-id-value p_45 ns_42 self-mpi_3) not-available)))" +"(if(parsed-quote? p_45)" +"(let-values() #t)" +"(if(parsed-quote-syntax? p_45)(let-values() #t)(let-values() #f))))))))" +"(define-values" +"(direct-eval)" +"(lambda(p_48 ns_67 self-mpi_4)" +"(begin" +"(if(parsed-app? p_48)" +"(let-values()" +"(apply" +"(direct-eval(parsed-app-rator p_48) ns_67 self-mpi_4)" +"(reverse$1" +"(let-values(((lst_77)(parsed-app-rands p_48)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_77)))" +"((letrec-values(((for-loop_98)" +"(lambda(fold-var_232 lst_78)" +"(begin" +" 'for-loop" +"(if(pair? lst_78)" +"(let-values(((r_8)(unsafe-car lst_78))((rest_36)(unsafe-cdr lst_78)))" +"(let-values(((fold-var_223)" +"(let-values(((fold-var_69) fold-var_232))" +"(let-values(((fold-var_26)" +"(let-values()" +"(cons" +"(let-values()" +"(direct-eval r_8 ns_67 self-mpi_4))" +" fold-var_69))))" +"(values fold-var_26)))))" +"(if(not #f)(for-loop_98 fold-var_223 rest_36) fold-var_223)))" +" fold-var_232)))))" +" for-loop_98)" +" null" +" lst_77))))))" +"(if(parsed-id? p_48)" +"(let-values()(get-id-value p_48 ns_67 self-mpi_4))" +"(if(parsed-quote? p_48)" +"(let-values()(parsed-quote-datum p_48))" +"(if(parsed-quote-syntax? p_48)(let-values()(parsed-quote-syntax-datum p_48))(let-values() #f))))))))" +"(define-values" +"(get-id-value)" +"(lambda(p_1 ns_73 self-mpi_5)" +"(begin" +"(let-values(((b_76)(parsed-id-binding p_1)))" +"(if(parsed-primitive-id? p_1)" +"(let-values()(hash-ref(1/primitive-table '#%kernel)(module-binding-sym b_76) get-not-available))" +"(if(let-values(((or-part_74)(parsed-top-id? p_1)))" +"(if or-part_74" +" or-part_74" +"(let-values(((or-part_75)(not b_76)))" +"(if or-part_75 or-part_75(eq? self-mpi_5(module-binding-module b_76))))))" +"(let-values()" +"(namespace-get-variable" +" ns_73" +"(if b_76(module-binding-phase b_76)(namespace-phase ns_73))" +"(if b_76(module-binding-sym b_76)(syntax-e$1(parsed-s p_1)))" +" get-not-available))" +"(let-values()" +"(let-values(((mi_18)" +"(let-values(((ns1_2) ns_73)" +"((temp2_4)(1/module-path-index-resolve(module-binding-module b_76)))" +"((temp3_4)(phase-(namespace-phase ns_73)(module-binding-phase b_76))))" +"(namespace->module-instance70.1 #f #f unsafe-undefined ns1_2 temp2_4 temp3_4))))" +"(if(not mi_18)" +"(let-values() not-available)" +"(if(check-single-require-access" +" mi_18" +"(module-binding-phase b_76)" +"(module-binding-sym b_76)" +"(module-binding-extra-inspector b_76))" +"(let-values()" +"(namespace-get-variable" +"(module-instance-namespace mi_18)" +"(module-binding-phase b_76)" +"(module-binding-sym b_76)" +" get-not-available))" +"(let-values() not-available)))))))))))" +"(define-values(runtime-scope)(new-multi-scope))" +"(define-values(runtime-stx)(add-scope empty-syntax runtime-scope))" +"(define-values(runtime-module-name)(1/make-resolved-module-path '#%runtime))" +"(define-values(runtime-mpi)(1/module-path-index-join ''#%runtime #f))" +"(define-values" +"(add-runtime-primitive!)" +"(lambda(sym_67)" +"(begin" +"(let-values(((temp1_4)(syntax-scope-set runtime-stx 0))" +"((sym2_0) sym_67)" +"((temp3_5)" +"(let-values(((runtime-mpi4_0) runtime-mpi)((temp5_4) 0)((sym6_2) sym_67))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" runtime-mpi4_0" +" temp5_4" +" sym6_2))))" +"(add-binding-in-scopes!20.1 #f temp1_4 sym2_0 temp3_5)))))" +"(void" +"(begin" +"(add-runtime-primitive! 'values)" +"(add-runtime-primitive! 'cons)" +"(add-runtime-primitive! 'list)" +"(add-runtime-primitive! 'make-struct-type)" +"(add-runtime-primitive! 'make-struct-type-property)" +"(add-runtime-primitive! 'gensym)" +"(add-runtime-primitive! 'string->uninterned-symbol)))" +"(define-values" +"(runtime-instances)" +" '(#%kernel #%paramz #%foreign #%unsafe #%flfxnum #%extfl #%network #%place #%futures))" +"(define-values(box-cons!)(lambda(b_16 v_73)(begin(set-box! b_16(cons v_73(unbox b_16))))))" +"(define-values(box-clear!)(lambda(b_17)(begin(begin0(reverse$1(unbox b_17))(set-box! b_17 null)))))" +"(define-values" +"(struct:lift-context lift-context1.1 lift-context? lift-context-convert lift-context-lifts lift-context-module*-ok?)" +"(let-values(((struct:_74 make-_74 ?_74 -ref_74 -set!_74)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'lift-context" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'lift-context)))))" +"(values" +" struct:_74" +" make-_74" +" ?_74" +"(make-struct-field-accessor -ref_74 0 'convert)" +"(make-struct-field-accessor -ref_74 1 'lifts)" +"(make-struct-field-accessor -ref_74 2 'module*-ok?))))" +"(define-values" +"(struct:lifted-bind lifted-bind2.1 lifted-bind? lifted-bind-ids lifted-bind-keys lifted-bind-rhs)" +"(let-values(((struct:_75 make-_75 ?_75 -ref_75 -set!_75)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'lifted-bind" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'lifted-bind)))))" +"(values" +" struct:_75" +" make-_75" +" ?_75" +"(make-struct-field-accessor -ref_75 0 'ids)" +"(make-struct-field-accessor -ref_75 1 'keys)" +"(make-struct-field-accessor -ref_75 2 'rhs))))" +"(define-values" +"(make-lift-context6.1)" +"(lambda(module*-ok?3_0 convert5_0)" +"(begin" +" 'make-lift-context6" +"(let-values(((convert_0) convert5_0))" +"(let-values(((module*-ok?_0) module*-ok?3_0))" +"(let-values()(lift-context1.1 convert_0(box null) module*-ok?_0)))))))" +"(define-values" +"(add-lifted!)" +"(lambda(lifts_1 ids_16 rhs_12 phase_98)" +"(begin" +"(let-values(((lifted-ids_0 lifted_0)((lift-context-convert lifts_1) ids_16 rhs_12 phase_98)))" +"(begin(box-cons!(lift-context-lifts lifts_1) lifted_0) lifted-ids_0)))))" +"(define-values(get-and-clear-lifts!)(lambda(lifts_2)(begin(box-clear!(lift-context-lifts lifts_2)))))" +"(define-values" +"(make-local-lift)" +"(lambda(lift-env_1 counter_3)" +"(begin" +"(lambda(ids_17 rhs_13 phase_99)" +"(let-values(((keys_2)" +"(reverse$1" +"(let-values(((lst_277) ids_17))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_277)))" +"((letrec-values(((for-loop_29)" +"(lambda(fold-var_162 lst_278)" +"(begin" +" 'for-loop" +"(if(pair? lst_278)" +"(let-values(((id_59)(unsafe-car lst_278))" +"((rest_154)(unsafe-cdr lst_278)))" +"(let-values(((fold-var_85)" +"(let-values(((fold-var_86) fold-var_162))" +"(let-values(((fold-var_87)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((key_15)" +"(let-values(((id32_0)" +" id_59)" +"((phase33_0)" +" phase_99)" +"((counter34_0)" +" counter_3))" +"(add-local-binding!37.1" +" #f" +" #f" +" id32_0" +" phase33_0" +" counter34_0))))" +"(begin" +"(set-box!" +" lift-env_1" +"(hash-set" +"(unbox lift-env_1)" +" key_15" +" variable))" +" key_15)))" +" fold-var_86))))" +"(values fold-var_87)))))" +"(if(not #f)(for-loop_29 fold-var_85 rest_154) fold-var_85)))" +" fold-var_162)))))" +" for-loop_29)" +" null" +" lst_277))))))" +"(values ids_17(lifted-bind2.1 ids_17 keys_2 rhs_13)))))))" +"(define-values" +"(make-top-level-lift)" +"(lambda(ctx_11)" +"(begin" +"(lambda(ids_18 rhs_14 phase_7)" +"(let-values(((post-scope_0)" +"(post-expansion-scope" +"(root-expand-context-post-expansion" +"(namespace-get-root-expand-ctx(expand-context-namespace ctx_11))))))" +"(let-values(((tl-ids_1)" +"(reverse$1" +"(let-values(((lst_186) ids_18))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_186)))" +"((letrec-values(((for-loop_250)" +"(lambda(fold-var_233 lst_187)" +"(begin" +" 'for-loop" +"(if(pair? lst_187)" +"(let-values(((id_60)(unsafe-car lst_187))" +"((rest_155)(unsafe-cdr lst_187)))" +"(let-values(((fold-var_234)" +"(let-values(((fold-var_235) fold-var_233))" +"(let-values(((fold-var_236)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_60" +" post-scope_0))" +" fold-var_235))))" +"(values fold-var_236)))))" +"(if(not #f)" +"(for-loop_250 fold-var_234 rest_155)" +" fold-var_234)))" +" fold-var_233)))))" +" for-loop_250)" +" null" +" lst_186))))))" +"(let-values(((syms_20)(select-defined-syms-and-bind!/ctx tl-ids_1 ctx_11)))" +"(values tl-ids_1(lifted-bind2.1 tl-ids_1 syms_20 rhs_14)))))))))" +"(define-values" +"(wrap-lifts-as-let)" +"(lambda(lifts_3 body_4 phase_100)" +"(begin" +"(datum->syntax$1" +" #f" +"(let-values(((lst_279)(reverse$1 lifts_3)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_279)))" +"((letrec-values(((for-loop_56)" +"(lambda(body_5 lst_189)" +"(begin" +" 'for-loop" +"(if(pair? lst_189)" +"(let-values(((lift_0)(unsafe-car lst_189))((rest_156)(unsafe-cdr lst_189)))" +"(let-values(((body_6)" +"(let-values(((body_7) body_5))" +"(let-values(((body_0)" +"(let-values()" +"(begin" +"(if(lifted-bind? lift_0)" +"(void)" +"(let-values()" +" (error \"non-bindings in `lift-context`\")))" +"(list" +"(datum->syntax$1" +"(syntax-shift-phase-level$1 core-stx phase_100)" +" 'let-values)" +"(list" +"(list" +"(lifted-bind-ids lift_0)" +"(lifted-bind-rhs lift_0)))" +" body_7)))))" +"(values body_0)))))" +"(if(not #f)(for-loop_56 body_6 rest_156) body_6)))" +" body_5)))))" +" for-loop_56)" +" body_4" +" lst_279)))))))" +"(define-values" +"(wrap-lifts-as-begin16.1)" +"(lambda(adjust-body10_0 adjust-form9_0 lifts13_0 body14_0 phase15_0)" +"(begin" +" 'wrap-lifts-as-begin16" +"(let-values(((lifts_4) lifts13_0))" +"(let-values(((body_8) body14_0))" +"(let-values(((phase_101) phase15_0))" +"(let-values(((adjust-form_0)(if(eq? adjust-form9_0 unsafe-undefined) values adjust-form9_0)))" +"(let-values(((adjust-body_0)(if(eq? adjust-body10_0 unsafe-undefined) values adjust-body10_0)))" +"(let-values()" +"(datum->syntax$1" +" #f" +"(cons" +"(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_101) 'begin)" +"(append" +"(reverse$1" +"(let-values(((lst_280) lifts_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_280)))" +"((letrec-values(((for-loop_251)" +"(lambda(fold-var_168 lst_170)" +"(begin" +" 'for-loop" +"(if(pair? lst_170)" +"(let-values(((lift_1)(unsafe-car lst_170))" +"((rest_157)(unsafe-cdr lst_170)))" +"(let-values(((fold-var_169)" +"(let-values(((fold-var_182) fold-var_168))" +"(let-values(((fold-var_237)" +"(let-values()" +"(cons" +"(let-values()" +"(adjust-form_0" +"(if(lifted-bind? lift_1)" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list" +"(datum->syntax$1" +"(syntax-shift-phase-level$1" +" core-stx" +" phase_101)" +" 'define-values)" +"(lifted-bind-ids lift_1)" +"(lifted-bind-rhs" +" lift_1))))" +"(let-values() lift_1))))" +" fold-var_182))))" +"(values fold-var_237)))))" +"(if(not #f)(for-loop_251 fold-var_169 rest_157) fold-var_169)))" +" fold-var_168)))))" +" for-loop_251)" +" null" +" lst_280))))" +"(list(adjust-body_0 body_8))))))))))))))" +"(define-values" +"(get-lifts-as-lists)" +"(lambda(lifts_5)" +"(begin" +"(reverse$1" +"(let-values(((lst_50) lifts_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_50)))" +"((letrec-values(((for-loop_73)" +"(lambda(fold-var_35 lst_51)" +"(begin" +" 'for-loop" +"(if(pair? lst_51)" +"(let-values(((lift_2)(unsafe-car lst_51))((rest_22)(unsafe-cdr lst_51)))" +"(let-values(((fold-var_36)" +"(let-values(((fold-var_37) fold-var_35))" +"(let-values(((fold-var_38)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +"(lifted-bind-ids lift_2)" +"(lifted-bind-keys lift_2)" +"(lifted-bind-rhs lift_2)))" +" fold-var_37))))" +"(values fold-var_38)))))" +"(if(not #f)(for-loop_73 fold-var_36 rest_22) fold-var_36)))" +" fold-var_35)))))" +" for-loop_73)" +" null" +" lst_50)))))))" +"(define-values" +"(struct:module-lift-context" +" module-lift-context19.1" +" module-lift-context?" +" module-lift-context-wrt-phase" +" module-lift-context-lifts" +" module-lift-context-module*-ok?)" +"(let-values(((struct:_76 make-_76 ?_76 -ref_76 -set!_76)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-lift-context" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'module-lift-context)))))" +"(values" +" struct:_76" +" make-_76" +" ?_76" +"(make-struct-field-accessor -ref_76 0 'wrt-phase)" +"(make-struct-field-accessor -ref_76 1 'lifts)" +"(make-struct-field-accessor -ref_76 2 'module*-ok?))))" +"(define-values" +"(make-module-lift-context)" +"(lambda(phase_10 module*-ok?_1)(begin(module-lift-context19.1 phase_10(box null) module*-ok?_1))))" +"(define-values" +"(get-and-clear-module-lifts!)" +"(lambda(module-lifts_1)(begin(box-clear!(module-lift-context-lifts module-lifts_1)))))" +"(define-values" +"(add-lifted-module!)" +"(lambda(module-lifts_2 s_409 phase_102)" +"(begin" +"(begin" +"(if(let-values(((or-part_171)" +"(if(module-lift-context? module-lifts_2)" +"(module-lift-context-module*-ok? module-lifts_2)" +" #f)))" +"(if or-part_171" +" or-part_171" +"(if(lift-context? module-lifts_2)(lift-context-module*-ok? module-lifts_2) #f)))" +"(void)" +"(let-values()" +"(let-values(((tmp_30)(core-form-sym s_409 phase_102)))" +"(if(equal? tmp_30 'module)" +"(let-values()(void))" +"(if(equal? tmp_30 'module*)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-lift-module" +" \"cannot lift `module*' to a top-level context\"" +" \"syntax\"" +" s_409))" +"(let-values()" +" (raise-arguments-error 'syntax-local-lift-module \"not a `module' declaration\" \"syntax\" s_409)))))))" +"(if(module-lift-context? module-lifts_2)" +"(let-values()(box-cons!(module-lift-context-lifts module-lifts_2) s_409))" +"(if(lift-context? module-lifts_2)" +"(let-values()(box-cons!(lift-context-lifts module-lifts_2) s_409))" +" (let-values () (error \"internal error: unrecognized lift-context type for module lift\"))))))))" +"(define-values" +"(struct:require-lift-context" +" require-lift-context20.1" +" require-lift-context?" +" require-lift-context-do-require" +" require-lift-context-wrt-phase" +" require-lift-context-requires)" +"(let-values(((struct:_77 make-_77 ?_77 -ref_77 -set!_77)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'require-lift-context" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'require-lift-context)))))" +"(values" +" struct:_77" +" make-_77" +" ?_77" +"(make-struct-field-accessor -ref_77 0 'do-require)" +"(make-struct-field-accessor -ref_77 1 'wrt-phase)" +"(make-struct-field-accessor -ref_77 2 'requires))))" +"(define-values" +"(make-require-lift-context)" +"(lambda(wrt-phase_0 do-require_0)(begin(require-lift-context20.1 do-require_0 wrt-phase_0(box null)))))" +"(define-values" +"(get-and-clear-require-lifts!)" +"(lambda(require-lifts_1)(begin(box-clear!(require-lift-context-requires require-lifts_1)))))" +"(define-values" +"(add-lifted-require!)" +"(lambda(require-lifts_2 s_410 phase_103)" +"(begin" +"(begin" +"((require-lift-context-do-require require-lifts_2) s_410 phase_103)" +"(box-cons!(require-lift-context-requires require-lifts_2) s_410)))))" +"(define-values" +"(struct:to-module-lift-context" +" to-module-lift-context21.1" +" to-module-lift-context?" +" to-module-lift-context-wrt-phase" +" to-module-lift-context-provides" +" to-module-lift-context-end-as-expressions?" +" to-module-lift-context-ends)" +"(let-values(((struct:_78 make-_78 ?_78 -ref_78 -set!_78)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'to-module-lift-context" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'to-module-lift-context)))))" +"(values" +" struct:_78" +" make-_78" +" ?_78" +"(make-struct-field-accessor -ref_78 0 'wrt-phase)" +"(make-struct-field-accessor -ref_78 1 'provides)" +"(make-struct-field-accessor -ref_78 2 'end-as-expressions?)" +"(make-struct-field-accessor -ref_78 3 'ends))))" +"(define-values" +"(make-to-module-lift-context27.1)" +"(lambda(end-as-expressions?23_0 shared-module-ends22_0 phase26_2)" +"(begin" +" 'make-to-module-lift-context27" +"(let-values(((phase_82) phase26_2))" +"(let-values(((ends_0) shared-module-ends22_0))" +"(let-values(((end-as-expressions?_0) end-as-expressions?23_0))" +"(let-values()(to-module-lift-context21.1 phase_82(box null) end-as-expressions?_0 ends_0))))))))" +"(define-values(make-shared-module-ends)(lambda()(begin(box null))))" +"(define-values" +"(get-and-clear-end-lifts!)" +"(lambda(to-module-lifts_1)(begin(box-clear!(to-module-lift-context-ends to-module-lifts_1)))))" +"(define-values" +"(get-and-clear-provide-lifts!)" +"(lambda(to-module-lifts_2)(begin(box-clear!(to-module-lift-context-provides to-module-lifts_2)))))" +"(define-values" +"(add-lifted-to-module-provide!)" +"(lambda(to-module-lifts_3 s_218 phase_96)" +"(begin(box-cons!(to-module-lift-context-provides to-module-lifts_3) s_218))))" +"(define-values" +"(add-lifted-to-module-end!)" +"(lambda(to-module-lifts_4 s_325 phase_3)(begin(box-cons!(to-module-lift-context-ends to-module-lifts_4) s_325))))" +"(define-values" +"(struct:already-expanded already-expanded1.1 already-expanded? already-expanded-s already-expanded-binding-layer)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expanded-syntax" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'already-expanded)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 's)" +"(make-struct-field-accessor -ref_0 1 'binding-layer))))" +"(define-values" +"(1/prop:liberal-define-context has-liberal-define-context-property? liberal-define-context-value)" +"(make-struct-type-property 'liberal-define-context))" +"(define-values" +"(struct:liberal-define-context make-liberal-define-context 1/liberal-define-context?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'liberal-define-context" +" #f" +" 0" +" 0" +" #f" +"(list(cons 1/prop:liberal-define-context #t))" +" #f" +" #f" +" '()" +" #f" +" 'make-liberal-define-context)))))" +"(values struct:_0 make-_0 ?_0)))" +"(define-values" +"(1/prop:expansion-contexts expansion-contexts? expansion-contexts-ref)" +"(make-struct-type-property" +" 'expansion-contexts" +"(lambda(v_28 info_1)" +"(begin" +"(if(if(list? v_28)" +"(let-values(((lst_75) v_28))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_75)))" +"((letrec-values(((for-loop_97)" +"(lambda(result_77 lst_76)" +"(begin" +" 'for-loop" +"(if(pair? lst_76)" +"(let-values(((s_2)(unsafe-car lst_76))((rest_35)(unsafe-cdr lst_76)))" +"(let-values(((result_64)" +"(let-values()" +"(let-values(((result_115)" +"(let-values()" +"(let-values()" +"(memq" +" s_2" +" '(expression" +" top-level" +" module" +" module-begin" +" definition-context))))))" +"(values result_115)))))" +"(if(if(not((lambda x_75(not result_64)) s_2))(not #f) #f)" +"(for-loop_97 result_64 rest_35)" +" result_64)))" +" result_77)))))" +" for-loop_97)" +" #t" +" lst_75)))" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:expansion-contexts" +" \"(listof (or/c 'expression 'top-level 'module 'module-begin 'definition-context))\"" +" v_28)))" +" v_28))))" +"(define-values" +"(not-in-this-expand-context?)" +"(lambda(t_46 ctx_12)" +"(begin" +"(if(expansion-contexts? t_46)" +"(not(memq(context->symbol(expand-context-context ctx_12))(expansion-contexts-ref t_46)))" +" #f))))" +"(define-values(context->symbol)(lambda(context_5)(begin(if(symbol? context_5) context_5 'definition-context))))" +"(define-values" +"(avoid-current-expand-context)" +"(lambda(s_178 t_47 ctx_13)" +"(begin" +"(let-values(((wrap_1)" +"(lambda(sym_68)" +"(begin" +" 'wrap" +"(datum->syntax$1" +" #f" +"(list" +"(syntax-shift-phase-level$1(datum->syntax$1 core-stx sym_68)(expand-context-phase ctx_13))" +" s_178))))))" +"(let-values(((fail_0)" +"(lambda()" +"(begin" +" 'fail" +"(raise-syntax-error$1" +" #f" +"(format" +" \"not allowed in context\\n expansion context: ~a\"" +"(context->symbol(expand-context-context ctx_13)))" +" s_178)))))" +"(let-values(((tmp_31)(context->symbol(expand-context-context ctx_13))))" +"(if(equal? tmp_31 'module-begin)" +"(let-values()(wrap_1 'begin))" +"(if(if(equal? tmp_31 'module) #t(if(equal? tmp_31 'top-level) #t(equal? tmp_31 'definition-context)))" +"(let-values()(if(memq 'expression(expansion-contexts-ref t_47))(wrap_1 '#%expression)(fail_0)))" +"(let-values()(fail_0))))))))))" +"(define-values" +"(struct:reference-record" +" reference-record1.1" +" reference-record?" +" reference-record-already-bound" +" reference-record-reference-before-bound" +" reference-record-all-referenced?" +" set-reference-record-already-bound!" +" set-reference-record-reference-before-bound!" +" set-reference-record-all-referenced?!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'reference-record" +" #f" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '()" +" #f" +" 'reference-record)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'already-bound)" +"(make-struct-field-accessor -ref_0 1 'reference-before-bound)" +"(make-struct-field-accessor -ref_0 2 'all-referenced?)" +"(make-struct-field-mutator -set!_0 0 'already-bound)" +"(make-struct-field-mutator -set!_0 1 'reference-before-bound)" +"(make-struct-field-mutator -set!_0 2 'all-referenced?))))" +"(define-values(make-reference-record)(lambda()(begin(reference-record1.1(seteq)(seteq) #f))))" +"(define-values" +"(reference-record-used!)" +"(lambda(rr_0 key_70)" +"(begin" +"(if(set-member?(reference-record-already-bound rr_0) key_70)" +"(void)" +"(let-values()" +"(set-reference-record-reference-before-bound!" +" rr_0" +"(set-add(reference-record-reference-before-bound rr_0) key_70)))))))" +"(define-values" +"(reference-records-all-used!)" +"(lambda(rrs_0)" +"(begin" +"(begin" +"(let-values(((lst_41) rrs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_41)))" +"((letrec-values(((for-loop_252)" +"(lambda(lst_89)" +"(begin" +" 'for-loop" +"(if(pair? lst_89)" +"(let-values(((rr_1)(unsafe-car lst_89))((rest_120)(unsafe-cdr lst_89)))" +"(let-values(((post-guard-var_0)(lambda()(begin 'post-guard-var #t))))" +"(let-values()" +"(if(reference-record-all-referenced? rr_1)" +"(values)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(set-reference-record-all-referenced?! rr_1 #t))" +"(values)))))" +"(if(post-guard-var_0)(for-loop_252 rest_120)(values))))))))" +"(values))))))" +" for-loop_252)" +" lst_41)))" +"(void)))))" +"(define-values" +"(reference-record-bound!)" +"(lambda(rr_2 keys_3)" +"(begin" +"(begin" +"(set-reference-record-already-bound!" +" rr_2" +"(let-values(((lst_23) keys_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_23)))" +"((letrec-values(((for-loop_192)" +"(lambda(ab_3 lst_79)" +"(begin" +" 'for-loop" +"(if(pair? lst_79)" +"(let-values(((key_78)(unsafe-car lst_79))((rest_85)(unsafe-cdr lst_79)))" +"(let-values(((ab_4)" +"(let-values(((ab_5) ab_3))" +"(let-values(((ab_6)(let-values()(set-add ab_5 key_78))))" +"(values ab_6)))))" +"(if(not #f)(for-loop_192 ab_4 rest_85) ab_4)))" +" ab_3)))))" +" for-loop_192)" +"(reference-record-already-bound rr_2)" +" lst_23))))" +"(set-reference-record-reference-before-bound!" +" rr_2" +"(let-values(((lst_58) keys_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_58)))" +"((letrec-values(((for-loop_85)" +"(lambda(rbb_0 lst_24)" +"(begin" +" 'for-loop" +"(if(pair? lst_24)" +"(let-values(((key_79)(unsafe-car lst_24))((rest_26)(unsafe-cdr lst_24)))" +"(let-values(((rbb_1)" +"(let-values(((rbb_2) rbb_0))" +"(let-values(((rbb_3)(let-values()(set-remove rbb_2 key_79))))" +"(values rbb_3)))))" +"(if(not #f)(for-loop_85 rbb_1 rest_26) rbb_1)))" +" rbb_0)))))" +" for-loop_85)" +"(reference-record-reference-before-bound rr_2)" +" lst_58))))))))" +"(define-values" +"(reference-record-forward-references?)" +"(lambda(rr_3)" +"(begin" +"(let-values(((or-part_21)(reference-record-all-referenced? rr_3)))" +"(if or-part_21 or-part_21(positive?(set-count(reference-record-reference-before-bound rr_3))))))))" +"(define-values" +"(reference-record-clear!)" +"(lambda(rr_4)" +"(begin" +"(begin(set-reference-record-already-bound! rr_4 #f)(set-reference-record-reference-before-bound! rr_4 #f)))))" +"(define-values" +"(call-expand-observe)" +"(lambda(obs_0 key_80 . args_5)" +"(begin" +"(begin" +"(let-values(((c1_28)(hash-ref key->arity key_80 #f)))" +"(if c1_28" +"((lambda(arity_2)" +"(if(let-values(((or-part_130)(eq? arity_2 'any)))" +"(if or-part_130 or-part_130(eqv?(length args_5) arity_2)))" +"(void)" +" (let-values () (error 'call-expand-observe \"wrong arity for ~s: ~e\" key_80 args_5))))" +" c1_28)" +" (let-values () (error 'call-expand-observe \"bad key: ~s\" key_80))))" +"(obs_0 key_80(if(null? args_5)(let-values() #f)(let-values()(apply list* args_5))))))))" +"(define-values" +"(key->arity)" +" '#hash((block->letrec . 1)" +"(block->list . 1)" +"(block-renames . 2)" +"(enter-bind . 0)" +"(enter-block . 1)" +"(enter-check . 1)" +"(enter-list . 1)" +"(enter-local . 1)" +"(enter-macro . 1)" +"(enter-prim . 1)" +"(exit-bind . 0)" +"(exit-check . 1)" +"(exit-list . 1)" +"(exit-local . 1)" +"(exit-local-bind . 0)" +"(exit-macro . 1)" +"(exit-prim . 1)" +"(lambda-renames . 2)" +"(let-renames . any)" +"(letlift-loop . 1)" +"(letrec-syntaxes-renames . any)" +"(lift-expr . 2)" +"(lift-loop . 1)" +"(lift-provide . 1)" +"(lift-require . 3)" +"(lift-statement . 1)" +"(local-bind . 1)" +"(local-post . 1)" +"(local-pre . 1)" +"(local-value . 1)" +"(local-value-result . 1)" +"(macro-post-x . 2)" +"(macro-pre-x . 1)" +"(module-body . 1)" +"(module-lift-end-loop . 1)" +"(module-lift-loop . 1)" +"(next . 0)" +"(next-group . 0)" +"(opaque-expr . 1)" +"(phase-up . 0)" +"(prepare-env . 0)" +"(prim-#%app . 0)" +"(prim-#%datum . 0)" +"(prim-#%expression . 0)" +"(prim-#%stratified . 0)" +"(prim-#%top . 0)" +"(prim-#%variable-reference . 0)" +"(prim-begin . 0)" +"(prim-begin-for-syntax . 0)" +"(prim-begin0 . 0)" +"(prim-case-lambda . 0)" +"(prim-define-syntaxes . 0)" +"(prim-define-values . 0)" +"(prim-if . 0)" +"(prim-lambda . 0)" +"(prim-let-values . 0)" +"(prim-letrec-syntaxes+values . 0)" +"(prim-letrec-values . 0)" +"(prim-module . 0)" +"(prim-module-begin . 0)" +"(prim-provide . 0)" +"(prim-quote . 0)" +"(prim-quote-syntax . 0)" +"(prim-require . 0)" +"(prim-set! . 0)" +"(prim-stop . 0)" +"(prim-submodule . 0)" +"(prim-submodule* . 0)" +"(prim-with-continuation-mark . 0)" +"(rename-list . 1)" +"(rename-one . 1)" +"(resolve . 1)" +"(return . 1)" +"(splice . 1)" +"(start . 0)" +"(start-top . 0)" +"(tag . 1)" +"(track-origin . 2)" +"(variable . 2)" +"(visit . 1)))" +"(define-values" +"(rebuild5.1)" +"(lambda(track?1_0 orig-s3_0 new4_0)" +"(begin" +" 'rebuild5" +"(let-values(((orig-s_30) orig-s3_0))" +"(let-values(((new_2) new4_0))" +"(let-values(((track?_0) track?1_0))" +"(let-values()" +"(syntax-rearm$1" +"(datum->syntax$1(syntax-disarm$1 orig-s_30) new_2 orig-s_30(if track?_0 orig-s_30 #f))" +" orig-s_30))))))))" +"(define-values" +"(struct:expanded+parsed expanded+parsed1.1 expanded+parsed? expanded+parsed-s expanded+parsed-parsed)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expanded+parsed" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'expanded+parsed)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 's)" +"(make-struct-field-accessor -ref_0 1 'parsed))))" +"(define-values" +"(struct:semi-parsed-define-values" +" semi-parsed-define-values2.1" +" semi-parsed-define-values?" +" semi-parsed-define-values-s" +" semi-parsed-define-values-syms" +" semi-parsed-define-values-ids" +" semi-parsed-define-values-rhs)" +"(let-values(((struct:_68 make-_68 ?_68 -ref_68 -set!_68)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'semi-parsed-define-values" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'semi-parsed-define-values)))))" +"(values" +" struct:_68" +" make-_68" +" ?_68" +"(make-struct-field-accessor -ref_68 0 's)" +"(make-struct-field-accessor -ref_68 1 'syms)" +"(make-struct-field-accessor -ref_68 2 'ids)" +"(make-struct-field-accessor -ref_68 3 'rhs))))" +"(define-values" +"(struct:semi-parsed-begin-for-syntax" +" semi-parsed-begin-for-syntax3.1" +" semi-parsed-begin-for-syntax?" +" semi-parsed-begin-for-syntax-s" +" semi-parsed-begin-for-syntax-body)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'semi-parsed-begin-for-syntax" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'semi-parsed-begin-for-syntax)))))" +"(values" +" struct:_10" +" make-_10" +" ?_10" +"(make-struct-field-accessor -ref_10 0 's)" +"(make-struct-field-accessor -ref_10 1 'body))))" +"(define-values(extract-syntax)(lambda(s_191)(begin(if(expanded+parsed? s_191)(expanded+parsed-s s_191) s_191))))" +"(define-values" +"(parsed-only)" +"(lambda(l_70)" +"(begin" +"(reverse$1" +"(let-values(((lst_178) l_70))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_178)))" +"((letrec-values(((for-loop_249)" +"(lambda(fold-var_5 lst_276)" +"(begin" +" 'for-loop" +"(if(pair? lst_276)" +"(let-values(((i_45)(unsafe-car lst_276))((rest_152)(unsafe-cdr lst_276)))" +"(let-values(((fold-var_230)" +"(let-values(((fold-var_231) fold-var_5))" +"(if(let-values(((or-part_264)(parsed? i_45)))" +"(if or-part_264" +" or-part_264" +"(let-values(((or-part_36)(expanded+parsed? i_45)))" +"(if or-part_36" +" or-part_36" +"(semi-parsed-begin-for-syntax? i_45)))))" +"(let-values(((fold-var_176) fold-var_231))" +"(let-values(((fold-var_177)" +"(let-values()" +"(cons" +"(let-values()" +"(if(expanded+parsed? i_45)" +"(let-values()" +"(expanded+parsed-parsed i_45))" +"(if(semi-parsed-begin-for-syntax? i_45)" +"(let-values()" +"(parsed-begin-for-syntax21.1" +"(semi-parsed-begin-for-syntax-s i_45)" +"(parsed-only" +"(semi-parsed-begin-for-syntax-body" +" i_45))))" +"(let-values() i_45))))" +" fold-var_176))))" +"(values fold-var_177)))" +" fold-var_231))))" +"(if(not #f)(for-loop_249 fold-var_230 rest_152) fold-var_230)))" +" fold-var_5)))))" +" for-loop_249)" +" null" +" lst_178)))))))" +"(define-values" +"(syntax-only)" +"(lambda(l_19)" +"(begin" +"(reverse$1" +"(let-values(((lst_281) l_19))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_281)))" +"((letrec-values(((for-loop_253)" +"(lambda(fold-var_163 lst_282)" +"(begin" +" 'for-loop" +"(if(pair? lst_282)" +"(let-values(((i_37)(unsafe-car lst_282))((rest_158)(unsafe-cdr lst_282)))" +"(let-values(((fold-var_86)" +"(let-values(((fold-var_87) fold-var_163))" +"(if(let-values(((or-part_265)(syntax?$1 i_37)))" +"(if or-part_265" +" or-part_265" +"(let-values(((or-part_25)(expanded+parsed? i_37)))" +"(if or-part_25" +" or-part_25" +"(semi-parsed-begin-for-syntax? i_37)))))" +"(let-values(((fold-var_88) fold-var_87))" +"(let-values(((fold-var_238)" +"(let-values()" +"(cons" +"(let-values()" +"(if(expanded+parsed? i_37)" +"(let-values()(expanded+parsed-s i_37))" +"(if(semi-parsed-begin-for-syntax? i_37)" +"(let-values()" +"(let-values(((s_411)" +"(semi-parsed-begin-for-syntax-s" +" i_37)))" +"(let-values(((nested-bodys_0)" +"(semi-parsed-begin-for-syntax-body" +" i_37)))" +"(let-values(((disarmed-s_0)" +"(syntax-disarm$1" +" s_411)))" +"(let-values(((ok?_28" +" begin-for-syntax7_0" +" _8_0)" +"(let-values(((s_412)" +" disarmed-s_0))" +"(let-values(((orig-s_31)" +" s_412))" +"(let-values(((begin-for-syntax7_1" +" _8_1)" +"(let-values(((s_86)" +"(if(syntax?$1" +" s_412)" +"(syntax-e$1" +" s_412)" +" s_412)))" +"(if(pair?" +" s_86)" +"(let-values(((begin-for-syntax9_0)" +"(let-values(((s_28)" +"(car" +" s_86)))" +" s_28))" +"((_10_0)" +"(let-values(((s_29)" +"(cdr" +" s_86)))" +"(let-values(((s_30)" +"(if(syntax?$1" +" s_29)" +"(syntax-e$1" +" s_29)" +" s_29)))" +"(let-values(((flat-s_20)" +"(to-syntax-list.1" +" s_30)))" +"(if(not" +" flat-s_20)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_31))" +"(let-values()" +" flat-s_20)))))))" +"(values" +" begin-for-syntax9_0" +" _10_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_31)))))" +"(values" +" #t" +" begin-for-syntax7_1" +" _8_1))))))" +"(let-values(((s11_0) s_411)" +"((temp12_2)" +"(list*" +" begin-for-syntax7_0" +"(syntax-only" +" nested-bodys_0))))" +"(rebuild5.1" +" #t" +" s11_0" +" temp12_2)))))))" +"(let-values() i_37))))" +" fold-var_88))))" +"(values fold-var_238)))" +" fold-var_87))))" +"(if(not #f)(for-loop_253 fold-var_86 rest_158) fold-var_86)))" +" fold-var_163)))))" +" for-loop_253)" +" null" +" lst_281)))))))" +"(define-values" +"(expand9.1)" +"(lambda(alternate-id1_0 fail-non-transformer3_0 skip-log?2_0 s7_0 ctx8_0)" +"(begin" +" 'expand9" +"(let-values(((s_188) s7_0))" +"(let-values(((ctx_14) ctx8_0))" +"(let-values(((alternate-id_0) alternate-id1_0))" +"(let-values(((skip-log?_0) skip-log?2_0))" +"(let-values(((fail-non-transformer_0) fail-non-transformer3_0))" +"(let-values()" +"(begin" +"(let-values(((obs_1)(expand-context-observer ctx_14)))" +"(if obs_1" +"(let-values()" +"(if(not skip-log?_0)" +"(let-values()" +"(call-expand-observe" +" obs_1" +"(if(expand-context-only-immediate? ctx_14) 'enter-check 'visit)" +" s_188))" +"(void)))" +"(void)))" +"(if(syntax-identifier? s_188)" +"(let-values()(expand-identifier s_188 ctx_14 alternate-id_0))" +"(if(if(pair?(syntax-content s_188))(syntax-identifier?(car(syntax-content s_188))) #f)" +"(let-values()" +"(let-values(((s122_0) s_188)" +"((ctx123_0) ctx_14)" +"((alternate-id124_0) alternate-id_0)" +"((fail-non-transformer125_0) fail-non-transformer_0))" +"(expand-id-application-form17.1" +" fail-non-transformer125_0" +" s122_0" +" ctx123_0" +" alternate-id124_0)))" +"(if(let-values(((or-part_67)(pair?(syntax-content s_188))))" +"(if or-part_67 or-part_67(null?(syntax-content s_188))))" +"(let-values()(expand-implicit '#%app s_188 ctx_14 #f))" +"(if(already-expanded?(syntax-content s_188))" +"(let-values()(expand-already-expanded s_188 ctx_14))" +"(let-values()(expand-implicit '#%datum s_188 ctx_14 #f))))))))))))))))" +"(define-values" +"(expand-identifier)" +"(lambda(s_413 ctx_15 alternate-id_1)" +"(begin" +"(let-values(((id_61)(let-values(((or-part_266) alternate-id_1))(if or-part_266 or-part_266 s_413))))" +"(if(if(not(free-id-set-empty?(expand-context-stops ctx_15)))" +"(free-id-set-member?(expand-context-stops ctx_15)(expand-context-phase ctx_15) id_61)" +" #f)" +"(let-values()" +"(begin" +"(let-values(((obs_2)(expand-context-observer ctx_15)))" +"(if obs_2" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_15))" +"(let-values()" +"(begin" +"(call-expand-observe obs_2 'resolve id_61)" +"(call-expand-observe obs_2 'enter-prim s_413)" +"(call-expand-observe obs_2 'prim-stop)" +"(call-expand-observe obs_2 'exit-prim s_413)" +"(call-expand-observe obs_2 'return s_413)))" +"(void)))" +"(void)))" +" s_413))" +"(let-values()" +"(let-values(((binding_18)" +"(let-values(((id126_0) id_61)" +"((temp127_1)(expand-context-phase ctx_15))" +"((temp128_1) 'ambiguous)" +"((temp129_0) #t))" +"(resolve+shift28.1 temp128_1 #f null temp129_0 #f id126_0 temp127_1))))" +"(begin" +"(let-values(((obs_3)(expand-context-observer ctx_15)))" +"(if obs_3" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_15))" +"(let-values()(call-expand-observe obs_3 'resolve id_61))" +"(void)))" +"(void)))" +"(if(eq? binding_18 'ambiguous)" +"(let-values()(raise-ambiguous-error id_61 ctx_15))" +"(if(not binding_18)" +"(let-values()(expand-implicit '#%top(substitute-alternate-id s_413 alternate-id_1) ctx_15 s_413))" +"(let-values()" +"(let-values(((t_48 primitive?_2 insp-of-t_0 protected?_3)" +"(let-values(((binding138_0) binding_18)" +"((ctx139_0) ctx_15)" +"((id140_0) id_61)" +"((temp141_0)(if alternate-id_1 s_413 #f))" +"((temp142_0)(expand-context-in-local-expand? ctx_15)))" +"(lookup62.1 temp141_0 temp142_0 binding138_0 ctx139_0 id140_0))))" +"(let-values(((t130_0) t_48)" +"((insp-of-t131_0) insp-of-t_0)" +"((s132_0) s_413)" +"((id133_0) id_61)" +"((ctx134_0) ctx_15)" +"((binding135_0) binding_18)" +"((primitive?136_0) primitive?_2)" +"((protected?137_0) protected?_3))" +"(dispatch30.1" +" #f" +" t130_0" +" insp-of-t131_0" +" s132_0" +" id133_0" +" ctx134_0" +" binding135_0" +" primitive?136_0" +" protected?137_0))))))))))))))" +"(define-values" +"(expand-id-application-form17.1)" +"(lambda(fail-non-transformer12_0 s14_0 ctx15_0 alternate-id16_0)" +"(begin" +" 'expand-id-application-form17" +"(let-values(((s_84) s14_0))" +"(let-values(((ctx_16) ctx15_0))" +"(let-values(((alternate-id_2) alternate-id16_0))" +"(let-values(((fail-non-transformer_1) fail-non-transformer12_0))" +"(let-values()" +"(let-values(((id_62)" +"(let-values(((or-part_141) alternate-id_2))" +"(if or-part_141 or-part_141(car(syntax-e/no-taint s_84))))))" +"(if(if(not(free-id-set-empty?(expand-context-stops ctx_16)))" +"(free-id-set-member?(expand-context-stops ctx_16)(expand-context-phase ctx_16) id_62)" +" #f)" +"(let-values()" +"(begin" +"(let-values(((obs_4)(expand-context-observer ctx_16)))" +"(if obs_4" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_16))" +"(let-values()" +"(begin" +"(call-expand-observe obs_4 'resolve id_62)" +"(call-expand-observe obs_4 'enter-prim s_84)" +"(call-expand-observe obs_4 'prim-stop)" +"(call-expand-observe obs_4 'exit-prim s_84)" +"(call-expand-observe obs_4 'return s_84)))" +"(void)))" +"(void)))" +" s_84))" +"(let-values()" +"(let-values(((binding_19)" +"(let-values(((id143_0) id_62)" +"((temp144_0)(expand-context-phase ctx_16))" +"((temp145_0) 'ambiguous)" +"((temp146_0) #t))" +"(resolve+shift28.1 temp145_0 #f null temp146_0 #f id143_0 temp144_0))))" +"(begin" +"(let-values(((obs_5)(expand-context-observer ctx_16)))" +"(if obs_5" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_16))" +"(let-values()(call-expand-observe obs_5 'resolve id_62))" +"(void)))" +"(void)))" +"(if(eq? binding_19 'ambiguous)" +"(let-values()" +"(begin" +"(if fail-non-transformer_1(let-values()(fail-non-transformer_1))(void))" +"(raise-ambiguous-error id_62 ctx_16)))" +"(if(not binding_19)" +"(let-values()" +"(begin" +"(if fail-non-transformer_1(let-values()(fail-non-transformer_1))(void))" +"(expand-implicit '#%app(substitute-alternate-id s_84 alternate-id_2) ctx_16 id_62)))" +"(let-values()" +"(let-values(((t_49 primitive?_3 insp-of-t_1 protected?_4)" +"(let-values(((binding147_0) binding_19)" +"((ctx148_0) ctx_16)" +"((id149_0) id_62)" +"((temp150_0)" +"(if alternate-id_2(car(syntax-e/no-taint s_84)) #f))" +"((temp151_0)(expand-context-in-local-expand? ctx_16)))" +"(lookup62.1 temp150_0 temp151_0 binding147_0 ctx148_0 id149_0))))" +"(if(variable? t_49)" +"(let-values()" +"(begin" +"(if fail-non-transformer_1(let-values()(fail-non-transformer_1))(void))" +"(expand-implicit" +" '#%app" +"(substitute-alternate-id s_84 alternate-id_2)" +" ctx_16" +" id_62)))" +"(let-values()" +"(let-values(((t152_0) t_49)" +"((insp-of-t153_0) insp-of-t_1)" +"((s154_0) s_84)" +"((id155_0) id_62)" +"((ctx156_0) ctx_16)" +"((binding157_0) binding_19)" +"((primitive?158_0) primitive?_3)" +"((protected?159_0) protected?_4)" +"((fail-non-transformer160_0) fail-non-transformer_1))" +"(dispatch30.1" +" fail-non-transformer160_0" +" t152_0" +" insp-of-t153_0" +" s154_0" +" id155_0" +" ctx156_0" +" binding157_0" +" primitive?158_0" +" protected?159_0)))))))))))))))))))))" +"(define-values" +"(expand-implicit)" +"(lambda(sym_69 s_52 ctx_17 trigger-id_1)" +"(begin" +"(if(expand-context-only-immediate? ctx_17)" +"(let-values()" +"(begin" +"(let-values(((obs_6)(expand-context-observer ctx_17)))" +"(if obs_6(let-values()(let-values()(call-expand-observe obs_6 'exit-check s_52)))(void)))" +" s_52))" +"(let-values()" +"(let-values(((disarmed-s_1)(syntax-disarm$1 s_52)))" +"(let-values(((id_63)(datum->syntax$1 disarmed-s_1 sym_69)))" +"(if(if(not(free-id-set-empty?(expand-context-stops ctx_17)))" +"(free-id-set-member?(expand-context-stops ctx_17)(expand-context-phase ctx_17) id_63)" +" #f)" +"(let-values()" +"(begin" +"(let-values(((obs_7)(expand-context-observer ctx_17)))" +"(if obs_7" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_17))" +"(let-values()" +"(begin" +"(call-expand-observe obs_7 'resolve id_63)" +"(call-expand-observe obs_7 'enter-prim s_52)" +"(call-expand-observe obs_7 'prim-stop)" +"(call-expand-observe obs_7 'exit-prim s_52)" +"(call-expand-observe obs_7 'return s_52)))" +"(void)))" +"(void)))" +" s_52))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_8)(expand-context-observer ctx_17)))" +"(if obs_8" +"(let-values()(let-values()(call-expand-observe obs_8 'resolve id_63)))" +"(void)))" +"(values))))" +"(let-values(((b_80)" +"(let-values(((id161_0) id_63)" +"((temp162_1)(expand-context-phase ctx_17))" +"((temp163_2) 'ambiguous)" +"((temp164_0) #t))" +"(resolve+shift28.1 temp163_2 #f null temp164_0 #f id161_0 temp162_1))))" +"(if(eq? b_80 'ambiguous)" +"(let-values()(raise-ambiguous-error id_63 ctx_17))" +"(let-values()" +"(let-values(((t_50 primitive?_4 insp-of-t_2 protected?_5)" +"(if b_80" +"(let-values(((b165_0) b_80)((ctx166_0) ctx_17)((id167_0) id_63))" +"(lookup62.1 #f #f b165_0 ctx166_0 id167_0))" +"(values #f #f #f #f))))" +"(if(transformer? t_50)" +"(let-values()" +"(let-values(((fail-non-transformer_2)" +"(if(1/rename-transformer? t_50)" +"(lambda()" +"(begin" +" 'fail-non-transformer" +"(raise-syntax-implicit-error s_52 sym_69 trigger-id_1 ctx_17)))" +" #f)))" +"(let-values(((t168_0) t_50)" +"((insp-of-t169_0) insp-of-t_2)" +"((temp170_1)(make-explicit ctx_17 sym_69 s_52 disarmed-s_1))" +"((id171_1) id_63)" +"((ctx172_0) ctx_17)" +"((b173_0) b_80)" +"((fail-non-transformer174_0) fail-non-transformer_2))" +"(dispatch-transformer41.1" +" fail-non-transformer174_0" +" t168_0" +" insp-of-t169_0" +" temp170_1" +" id171_1" +" ctx172_0" +" b173_0))))" +"(if(core-form? t_50)" +"(let-values()" +"(if(if(eq? sym_69 '#%top)" +"(if(eq?(core-form-name t_50) '#%top)" +"(expand-context-in-local-expand? ctx_17)" +" #f)" +" #f)" +"(let-values()(dispatch-implicit-#%top-core-form t_50 s_52 ctx_17))" +"(let-values()" +"(dispatch-core-form" +" t_50" +"(make-explicit ctx_17 sym_69 s_52 disarmed-s_1)" +" ctx_17))))" +"(let-values()" +"(let-values(((tl-id_0)" +"(if(eq? sym_69 '#%top)" +"(if(root-expand-context-top-level-bind-scope ctx_17)" +"(add-scope s_52(root-expand-context-top-level-bind-scope ctx_17))" +" #f)" +" #f)))" +"(let-values(((tl-b_0)" +"(if tl-id_0" +"(let-values(((tl-id175_0) tl-id_0)" +"((temp176_0)(expand-context-phase ctx_17)))" +"(resolve40.1 #f #f null #f tl-id175_0 temp176_0))" +" #f)))" +"(if tl-b_0" +"(let-values()" +"(if(if(expand-context-to-parsed? ctx_17)" +"(free-id-set-empty?(expand-context-stops ctx_17))" +" #f)" +"(parsed-id2.1 tl-id_0 tl-b_0 #f)" +" tl-id_0))" +"(let-values()" +"(raise-syntax-implicit-error" +" s_52" +" sym_69" +" trigger-id_1" +" ctx_17))))))))))))))))))))))" +"(define-values" +"(expand-already-expanded)" +"(lambda(s_59 ctx_18)" +"(begin" +"(let-values(((ae_0)(syntax-e$1 s_59)))" +"(let-values(((exp-s_0)(already-expanded-s ae_0)))" +"(begin" +"(if(let-values(((or-part_267)(syntax-any-macro-scopes? s_59)))" +"(if or-part_267" +" or-part_267" +"(let-values(((or-part_215)" +"(not" +"(eq?(expand-context-binding-layer ctx_18)(already-expanded-binding-layer ae_0)))))" +"(if or-part_215" +" or-part_215" +"(if(parsed? exp-s_0)" +"(not" +"(if(expand-context-to-parsed? ctx_18)" +"(free-id-set-empty?(expand-context-stops ctx_18))" +" #f))" +" #f)))))" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(string-append" +" \"expanded syntax not in its original lexical context;\\n\"" +" \" extra bindings or scopes in the current context\")" +"(if(not(parsed? exp-s_0)) exp-s_0 #f)))" +"(void))" +"(if(expand-context-only-immediate? ctx_18)" +"(let-values() s_59)" +"(if(parsed? exp-s_0)" +"(let-values() exp-s_0)" +"(let-values()" +"(let-values(((result-s_1)(syntax-track-origin$1 exp-s_0 s_59)))" +"(begin" +"(let-values(((obs_9)(expand-context-observer ctx_18)))" +"(if obs_9" +"(let-values()(let-values()(call-expand-observe obs_9 'opaque-expr result-s_1)))" +"(void)))" +"(if(if(expand-context-to-parsed? ctx_18)(free-id-set-empty?(expand-context-stops ctx_18)) #f)" +"(let-values(((result-s177_0) result-s_1)((ctx178_0) ctx_18))" +"(expand9.1 #f #f #f result-s177_0 ctx178_0))" +" result-s_1))))))))))))" +"(define-values" +"(make-explicit)" +"(lambda(ctx_19 sym_70 s_414 disarmed-s_2)" +"(begin" +"(let-values(((new-s_0)" +"(syntax-rearm$1(datum->syntax$1 disarmed-s_2(cons sym_70 disarmed-s_2) s_414 s_414) s_414)))" +"(begin" +"(let-values(((obs_10)(expand-context-observer ctx_19)))" +"(if obs_10(let-values()(let-values()(call-expand-observe obs_10 'tag new-s_0)))(void)))" +" new-s_0)))))" +"(define-values" +"(dispatch30.1)" +"(lambda(fail-non-transformer20_0 t22_0 insp-of-t23_0 s24_1 id25_1 ctx26_0 binding27_1 primitive?28_0 protected?29_0)" +"(begin" +" 'dispatch30" +"(let-values(((t_51) t22_0))" +"(let-values(((insp-of-t_3) insp-of-t23_0))" +"(let-values(((s_415) s24_1))" +"(let-values(((id_64) id25_1))" +"(let-values(((ctx_20) ctx26_0))" +"(let-values(((binding_20) binding27_1))" +"(let-values(((primitive?_5) primitive?28_0))" +"(let-values(((protected?_6) protected?29_0))" +"(let-values(((fail-non-transformer_3) fail-non-transformer20_0))" +"(let-values()" +"(if(core-form? t_51)" +"(let-values()(dispatch-core-form t_51 s_415 ctx_20))" +"(if(transformer? t_51)" +"(let-values()" +"(let-values(((t179_0) t_51)" +"((insp-of-t180_0) insp-of-t_3)" +"((s181_0) s_415)" +"((id182_0) id_64)" +"((ctx183_0) ctx_20)" +"((binding184_0) binding_20)" +"((fail-non-transformer185_0) fail-non-transformer_3))" +"(dispatch-transformer41.1" +" fail-non-transformer185_0" +" t179_0" +" insp-of-t180_0" +" s181_0" +" id182_0" +" ctx183_0" +" binding184_0)))" +"(if(variable? t_51)" +"(let-values()" +"(dispatch-variable t_51 s_415 id_64 ctx_20 binding_20 primitive?_5 protected?_6))" +" (let-values () (raise-syntax-error$1 #f \"illegal use of syntax\" s_415))))))))))))))))))" +"(define-values" +"(dispatch-core-form)" +"(lambda(t_52 s_416 ctx_21)" +"(begin" +"(if(expand-context-only-immediate? ctx_21)" +"(let-values()" +"(begin" +"(let-values(((obs_11)(expand-context-observer ctx_21)))" +"(if obs_11(let-values()(let-values()(call-expand-observe obs_11 'exit-check s_416)))(void)))" +" s_416))" +"(if(expand-context-observer ctx_21)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_12)(expand-context-observer ctx_21)))" +"(if obs_12" +"(let-values()(let-values()(call-expand-observe obs_12 'enter-prim s_416)))" +"(void)))" +"(values))))" +"(let-values(((result-s_2)((core-form-expander t_52) s_416 ctx_21)))" +"(begin" +"(let-values(((obs_13)(expand-context-observer ctx_21)))" +"(if obs_13" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_13 'exit-prim(extract-syntax result-s_2))" +"(call-expand-observe obs_13 'return(extract-syntax result-s_2)))))" +"(void)))" +" result-s_2))))" +"(let-values()((core-form-expander t_52) s_416 ctx_21)))))))" +"(define-values" +"(dispatch-implicit-#%top-core-form)" +"(lambda(t_53 s_321 ctx_22)" +"(begin" +"(let-values((()" +"(begin" +"(let-values(((obs_14)(expand-context-observer ctx_22)))" +"(if obs_14" +"(let-values()(let-values()(call-expand-observe obs_14 'enter-prim s_321)))" +"(void)))" +"(values))))" +"(let-values(((result-s_3)((core-form-expander t_53) s_321 ctx_22 #t)))" +"(begin" +"(let-values(((obs_15)(expand-context-observer ctx_22)))" +"(if obs_15" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_15 'exit-prim result-s_3)" +"(call-expand-observe obs_15 'return result-s_3))))" +"(void)))" +" result-s_3))))))" +"(define-values" +"(dispatch-transformer41.1)" +"(lambda(fail-non-transformer33_0 t35_0 insp-of-t36_0 s37_0 id38_0 ctx39_0 binding40_0)" +"(begin" +" 'dispatch-transformer41" +"(let-values(((t_54) t35_0))" +"(let-values(((insp-of-t_4) insp-of-t36_0))" +"(let-values(((s_417) s37_0))" +"(let-values(((id_65) id38_0))" +"(let-values(((ctx_23) ctx39_0))" +"(let-values(((binding_21) binding40_0))" +"(let-values(((fail-non-transformer_4) fail-non-transformer33_0))" +"(let-values()" +"(if(not-in-this-expand-context? t_54 ctx_23)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_16)(expand-context-observer ctx_23)))" +"(if obs_16" +"(let-values()" +"(let-values()(call-expand-observe obs_16 'enter-macro s_417)))" +"(void)))" +"(values))))" +"(let-values(((adj-s_0)" +"(avoid-current-expand-context" +"(substitute-alternate-id s_417 id_65)" +" t_54" +" ctx_23)))" +"(begin" +"(let-values(((obs_17)(expand-context-observer ctx_23)))" +"(if obs_17" +"(let-values()(let-values()(call-expand-observe obs_17 'exit-macro s_417)))" +"(void)))" +"(let-values(((adj-s186_0) adj-s_0)((ctx187_0) ctx_23))" +"(expand9.1 #f #f #f adj-s186_0 ctx187_0))))))" +"(if(if(expand-context-should-not-encounter-macros? ctx_23)" +"(not(1/rename-transformer? t_54))" +" #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"encountered a macro binding in form that should be fully expanded\"" +" s_417))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_18)(expand-context-observer ctx_23)))" +"(if obs_18" +"(let-values()" +"(if(if(expand-context-only-immediate? ctx_23)" +"(not(1/rename-transformer? t_54))" +" #f)" +"(let-values()" +"(begin" +"(call-expand-observe obs_18 'visit s_417)" +"(call-expand-observe obs_18 'resolve id_65)))" +"(void)))" +"(void)))" +"(values))))" +"(let-values(((exp-s_1 re-ctx_0)" +"(if(1/rename-transformer? t_54)" +"(values s_417 ctx_23)" +"(let-values(((t188_0) t_54)" +"((insp-of-t189_0) insp-of-t_4)" +"((s190_0) s_417)" +"((id191_0) id_65)" +"((ctx192_0) ctx_23)" +"((binding193_0) binding_21))" +"(apply-transformer52.1" +" #f" +" t188_0" +" insp-of-t189_0" +" s190_0" +" id191_0" +" ctx192_0" +" binding193_0)))))" +"(begin" +"(let-values(((obs_19)(expand-context-observer ctx_23)))" +"(if obs_19" +"(let-values()" +"(if(if(expand-context-only-immediate? ctx_23)" +"(not(1/rename-transformer? t_54))" +" #f)" +"(let-values()(call-expand-observe obs_19 'return exp-s_1))" +"(void)))" +"(void)))" +"(if(expand-context-just-once? ctx_23)" +"(let-values() exp-s_1)" +"(let-values()" +"(let-values(((exp-s194_0) exp-s_1)" +"((re-ctx195_0) re-ctx_0)" +"((temp196_0)" +"(if(1/rename-transformer? t_54)" +"(syntax-track-origin$1" +"(transfer-srcloc" +"(rename-transformer-target-in-context t_54 ctx_23)" +" id_65)" +" id_65" +" id_65)" +" #f))" +"((temp197_0)" +"(let-values(((or-part_268)" +"(expand-context-only-immediate? ctx_23)))" +"(if or-part_268 or-part_268(1/rename-transformer? t_54))))" +"((temp198_0)" +"(if(1/rename-transformer? t_54) fail-non-transformer_4 #f)))" +"(expand9.1" +" temp196_0" +" temp198_0" +" temp197_0" +" exp-s194_0" +" re-ctx195_0)))))))))))))))))))))" +"(define-values" +"(dispatch-variable)" +"(lambda(t_55 s_114 id_66 ctx_24 binding_22 primitive?_6 protected?_7)" +"(begin" +"(if(expand-context-only-immediate? ctx_24)" +"(let-values()" +"(begin" +"(let-values(((obs_20)(expand-context-observer ctx_24)))" +"(if obs_20(let-values()(let-values()(call-expand-observe obs_20 'exit-check s_114)))(void)))" +" id_66))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_21)(expand-context-observer ctx_24)))" +"(if obs_21" +"(let-values()(let-values()(call-expand-observe obs_21 'variable s_114 id_66)))" +"(void)))" +"(values))))" +"(let-values((()(begin(register-variable-referenced-if-local! binding_22)(values))))" +"(let-values(((result-s_4)" +"(let-values(((id199_0) id_66)" +"((t200_0) t_55)" +"((temp201_0)" +"(free-id-set-empty-or-just-module*?(expand-context-stops ctx_24))))" +"(substitute-variable6.1 temp201_0 id199_0 t200_0))))" +"(if(if(expand-context-to-parsed? ctx_24)(free-id-set-empty?(expand-context-stops ctx_24)) #f)" +"(let-values()" +"(let-values(((prop-s_0)(keep-properties-only~ result-s_4)))" +"(let-values(((insp_16)(syntax-inspector result-s_4)))" +"(if primitive?_6" +"(parsed-primitive-id3.1 prop-s_0 binding_22 insp_16)" +"(parsed-id2.1 prop-s_0 binding_22 insp_16)))))" +"(let-values()" +"(let-values(((protected-result-s_0)" +"(if protected?_7(syntax-property$1 result-s_4 'protected #t) result-s_4)))" +"(begin" +"(let-values(((obs_22)(expand-context-observer ctx_24)))" +"(if obs_22" +"(let-values()(let-values()(call-expand-observe obs_22 'return protected-result-s_0)))" +"(void)))" +" protected-result-s_0))))))))))))" +"(define-values" +"(apply-transformer52.1)" +"(lambda(origin-id44_0 t46_0 insp-of-t47_0 s48_1 id49_1 ctx50_0 binding51_0)" +"(begin" +" 'apply-transformer52" +"(let-values(((t_56) t46_0))" +"(let-values(((insp-of-t_5) insp-of-t47_0))" +"(let-values(((s_122) s48_1))" +"(let-values(((id_33) id49_1))" +"(let-values(((ctx_25) ctx50_0))" +"(let-values(((binding_23) binding51_0))" +"(let-values(((origin-id_0) origin-id44_0))" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_23)(expand-context-observer ctx_25)))" +"(if obs_23" +"(let-values()" +"(let-values()(call-expand-observe obs_23 'enter-macro s_122)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_3)(syntax-disarm$1 s_122)))" +"(let-values(((intro-scope_0)(new-scope 'macro)))" +"(let-values(((intro-s_0)(flip-scope disarmed-s_3 intro-scope_0)))" +"(let-values(((use-s_0 use-scopes_0)" +"(maybe-add-use-site-scope intro-s_0 ctx_25 binding_23)))" +"(let-values(((cleaned-s_0)(syntax-remove-taint-dispatch-properties use-s_0)))" +"(let-values(((def-ctx-scopes_1)(box null)))" +"(let-values(((transformed-s_0)" +"(apply-transformer-in-context" +" t_56" +" cleaned-s_0" +" ctx_25" +" insp-of-t_5" +" intro-scope_0" +" use-scopes_0" +" def-ctx-scopes_1" +" id_33)))" +"(let-values(((result-s_5)(flip-scope transformed-s_0 intro-scope_0)))" +"(let-values(((post-s_0)(maybe-add-post-expansion result-s_5 ctx_25)))" +"(let-values(((tracked-s_0)" +"(syntax-track-origin$1" +" post-s_0" +" cleaned-s_0" +"(let-values(((or-part_269) origin-id_0))" +"(if or-part_269" +" or-part_269" +"(if(syntax-identifier? s_122)" +" s_122" +"(car(syntax-e$1 s_122))))))))" +"(let-values(((rearmed-s_0)" +"(taint-dispatch" +" tracked-s_0" +"(lambda(t-s_0)(syntax-rearm$1 t-s_0 s_122))" +"(expand-context-phase ctx_25))))" +"(begin" +"(let-values(((obs_24)(expand-context-observer ctx_25)))" +"(if obs_24" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_24 'exit-macro rearmed-s_0)))" +"(void)))" +"(values" +" rearmed-s_0" +"(accumulate-def-ctx-scopes" +" ctx_25" +" def-ctx-scopes_1)))))))))))))))))))))))))))" +"(define-values" +"(apply-transformer-in-context)" +"(lambda(t_57 cleaned-s_1 ctx_26 insp-of-t_6 intro-scope_1 use-scopes_1 def-ctx-scopes_2 id_67)" +"(begin" +"(let-values((()" +"(begin" +"(let-values(((obs_25)(expand-context-observer ctx_26)))" +"(if obs_25" +"(let-values()(let-values()(call-expand-observe obs_25 'macro-pre-x cleaned-s_1)))" +"(void)))" +"(values))))" +"(let-values(((confine-def-ctx-scopes?_0)" +"(not" +"(let-values(((or-part_270)(expand-context-only-immediate? ctx_26)))" +"(if or-part_270" +" or-part_270" +"(not(free-id-set-empty-or-just-module*?(expand-context-stops ctx_26))))))))" +"(let-values(((accum-ctx_0)" +"(if(if confine-def-ctx-scopes?_0" +"(if(expand-context-def-ctx-scopes ctx_26)" +"(not(null?(unbox(expand-context-def-ctx-scopes ctx_26))))" +" #f)" +" #f)" +"(accumulate-def-ctx-scopes ctx_26(expand-context-def-ctx-scopes ctx_26))" +" ctx_26)))" +"(let-values(((m-ctx_0)" +"(let-values(((v_189) accum-ctx_0))" +"(let-values(((the-struct_57) v_189))" +"(if(expand-context/outer? the-struct_57)" +"(let-values(((current-introduction-scopes202_0)(list intro-scope_1))" +"((current-use-scopes203_0) use-scopes_1)" +"((def-ctx-scopes204_0)" +"(if confine-def-ctx-scopes?_0" +" def-ctx-scopes_2" +"(expand-context-def-ctx-scopes ctx_26)))" +"((inner205_0)(root-expand-context/outer-inner v_189)))" +"(expand-context/outer1.1" +" inner205_0" +"(root-expand-context/outer-post-expansion the-struct_57)" +"(root-expand-context/outer-use-site-scopes the-struct_57)" +"(root-expand-context/outer-frame-id the-struct_57)" +"(expand-context/outer-context the-struct_57)" +"(expand-context/outer-env the-struct_57)" +"(expand-context/outer-scopes the-struct_57)" +" def-ctx-scopes204_0" +"(expand-context/outer-binding-layer the-struct_57)" +"(expand-context/outer-reference-records the-struct_57)" +"(expand-context/outer-only-immediate? the-struct_57)" +"(expand-context/outer-need-eventually-defined the-struct_57)" +" current-introduction-scopes202_0" +" current-use-scopes203_0" +"(expand-context/outer-name the-struct_57)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_57))))))" +"(let-values(((transformed-s_1)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-context" +" m-ctx_0" +" 1/current-namespace" +"(namespace->namespace-at-phase" +"(expand-context-namespace ctx_26)" +"(add1(expand-context-phase ctx_26)))" +" current-module-code-inspector" +" insp-of-t_6)" +"(let-values()" +"(call-with-continuation-barrier" +"(lambda()((transformer->procedure t_57) cleaned-s_1)))))))" +"(begin" +"(let-values(((obs_26)(expand-context-observer ctx_26)))" +"(if obs_26" +"(let-values()" +"(let-values()(call-expand-observe obs_26 'macro-post-x transformed-s_1 cleaned-s_1)))" +"(void)))" +"(if(syntax?$1 transformed-s_1)" +"(void)" +"(let-values()" +"(raise-arguments-error" +"(syntax-e$1 id_67)" +" \"received value from syntax expander was not syntax\"" +" \"received\"" +" transformed-s_1)))" +" transformed-s_1)))))))))" +"(define-values" +"(maybe-add-use-site-scope)" +"(lambda(s_344 ctx_27 binding_24)" +"(begin" +"(if(if(root-expand-context-use-site-scopes ctx_27)" +"(matching-frame?(root-expand-context-frame-id ctx_27)(binding-frame-id binding_24))" +" #f)" +"(let-values()" +"(let-values(((sc_32)(new-scope 'use-site)))" +"(let-values(((b_81)(root-expand-context-use-site-scopes ctx_27)))" +"(begin(set-box! b_81(cons sc_32(unbox b_81)))(values(add-scope s_344 sc_32)(list sc_32))))))" +"(let-values()(values s_344 null))))))" +"(define-values" +"(matching-frame?)" +"(lambda(current-frame-id_0 bind-frame-id_0)" +"(begin" +"(if current-frame-id_0" +"(let-values(((or-part_271)(eq? current-frame-id_0 bind-frame-id_0)))" +"(if or-part_271 or-part_271(eq? current-frame-id_0 'all)))" +" #f))))" +"(define-values" +"(maybe-add-post-expansion)" +"(lambda(s_241 ctx_28)(begin(apply-post-expansion(root-expand-context-post-expansion ctx_28) s_241))))" +"(define-values" +"(accumulate-def-ctx-scopes)" +"(lambda(ctx_29 def-ctx-scopes_3)" +"(begin" +"(if(null?(unbox def-ctx-scopes_3))" +" ctx_29" +"(let-values(((v_190) ctx_29))" +"(let-values(((the-struct_58) v_190))" +"(if(expand-context/outer? the-struct_58)" +"(let-values(((scopes206_0)(append(unbox def-ctx-scopes_3)(expand-context-scopes ctx_29)))" +"((inner207_0)(root-expand-context/outer-inner v_190)))" +"(expand-context/outer1.1" +" inner207_0" +"(root-expand-context/outer-post-expansion the-struct_58)" +"(root-expand-context/outer-use-site-scopes the-struct_58)" +"(root-expand-context/outer-frame-id the-struct_58)" +"(expand-context/outer-context the-struct_58)" +"(expand-context/outer-env the-struct_58)" +" scopes206_0" +"(expand-context/outer-def-ctx-scopes the-struct_58)" +"(expand-context/outer-binding-layer the-struct_58)" +"(expand-context/outer-reference-records the-struct_58)" +"(expand-context/outer-only-immediate? the-struct_58)" +"(expand-context/outer-need-eventually-defined the-struct_58)" +"(expand-context/outer-current-introduction-scopes the-struct_58)" +"(expand-context/outer-current-use-scopes the-struct_58)" +"(expand-context/outer-name the-struct_58)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_58))))))))" +"(define-values" +"(lookup62.1)" +"(lambda(in55_0 out-of-context-as-variable?56_0 b59_0 ctx60_0 id61_0)" +"(begin" +" 'lookup62" +"(let-values(((b_82) b59_0))" +"(let-values(((ctx_30) ctx60_0))" +"(let-values(((id_37) id61_0))" +"(let-values(((in-s_7) in55_0))" +"(let-values(((out-of-context-as-variable?_1) out-of-context-as-variable?56_0))" +"(let-values()" +"(let-values(((b208_0) b_82)" +"((temp209_1)(expand-context-env ctx_30))" +"((temp210_0)(expand-context-lift-envs ctx_30))" +"((temp211_0)(expand-context-namespace ctx_30))" +"((temp212_0)(expand-context-phase ctx_30))" +"((id213_0) id_37)" +"((in-s214_0) in-s_7)" +"((out-of-context-as-variable?215_0) out-of-context-as-variable?_1))" +"(binding-lookup50.1" +" in-s214_0" +" out-of-context-as-variable?215_0" +" b208_0" +" temp209_1" +" temp210_0" +" temp211_0" +" temp212_0" +" id213_0)))))))))))" +"(define-values" +"(substitute-alternate-id)" +"(lambda(s_355 alternate-id_3)" +"(begin" +"(if(not alternate-id_3)" +"(let-values() s_355)" +"(if(syntax-identifier? s_355)" +"(let-values()(syntax-rearm$1(syntax-track-origin$1 alternate-id_3 s_355) s_355))" +"(let-values()" +"(let-values(((disarmed-s_4)(syntax-disarm$1 s_355)))" +"(syntax-rearm$1" +"(syntax-track-origin$1" +"(datum->syntax$1 disarmed-s_4(cons alternate-id_3(cdr(syntax-e$1 disarmed-s_4))) s_355)" +" s_355)" +" s_355))))))))" +"(define-values" +"(register-variable-referenced-if-local!)" +"(lambda(binding_25)" +"(begin" +"(if(if(local-binding? binding_25)(reference-record?(binding-frame-id binding_25)) #f)" +"(let-values()(reference-record-used!(binding-frame-id binding_25)(local-binding-key binding_25)))" +"(void)))))" +"(define-values" +"(expand/capture-lifts75.1)" +"(lambda(always-wrap?68_0 begin-form?66_0 expand-lifts?65_0 lift-key67_0 s73_0 ctx74_0)" +"(begin" +" 'expand/capture-lifts75" +"(let-values(((s_360) s73_0))" +"(let-values(((ctx_31) ctx74_0))" +"(let-values(((expand-lifts?_0) expand-lifts?65_0))" +"(let-values(((begin-form?_0) begin-form?66_0))" +"(let-values(((lift-key_2)(if(eq? lift-key67_0 unsafe-undefined)(generate-lift-key) lift-key67_0)))" +"(let-values(((always-wrap?_0) always-wrap?68_0))" +"(let-values()" +"(let-values(((context_6)(expand-context-context ctx_31)))" +"(let-values(((phase_104)(expand-context-phase ctx_31)))" +"(let-values(((local?_0)(not begin-form?_0)))" +"((letrec-values(((loop_95)" +"(lambda(s_418 always-wrap?_1 ctx_32)" +"(begin" +" 'loop" +"(let-values(((lift-env_2)(if local?_0(box empty-env) #f)))" +"(let-values(((lift-ctx_0)" +"(let-values(((temp216_0)" +"(if local?_0" +"(make-local-lift" +" lift-env_2" +"(root-expand-context-counter ctx_32))" +"(make-top-level-lift ctx_32)))" +"((temp217_1)" +"(if(not local?_0)" +"(eq? context_6 'module)" +" #f)))" +"(make-lift-context6.1 temp217_1 temp216_0))))" +"(let-values(((capture-ctx_0)" +"(let-values(((v_191) ctx_32))" +"(let-values(((the-struct_59) v_191))" +"(if(expand-context/outer? the-struct_59)" +"(let-values(((inner218_0)" +"(let-values(((the-struct_60)" +"(root-expand-context/outer-inner" +" v_191)))" +"(if(expand-context/inner?" +" the-struct_60)" +"(let-values(((lift-key219_0)" +" lift-key_2)" +"((lifts220_0)" +" lift-ctx_0)" +"((lift-envs221_0)" +"(if local?_0" +"(cons" +" lift-env_2" +"(expand-context-lift-envs" +" ctx_32))" +"(expand-context-lift-envs" +" ctx_32)))" +"((module-lifts222_0)" +"(if(let-values(((or-part_272)" +" local?_0))" +"(if or-part_272" +" or-part_272" +"(not" +"(memq" +" context_6" +" '(top-level" +" module)))))" +"(expand-context-module-lifts" +" ctx_32)" +" lift-ctx_0)))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_60)" +"(root-expand-context/inner-module-scopes" +" the-struct_60)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_60)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_60)" +"(root-expand-context/inner-defined-syms" +" the-struct_60)" +"(root-expand-context/inner-counter" +" the-struct_60)" +" lift-key219_0" +"(expand-context/inner-to-parsed?" +" the-struct_60)" +"(expand-context/inner-phase" +" the-struct_60)" +"(expand-context/inner-namespace" +" the-struct_60)" +"(expand-context/inner-just-once?" +" the-struct_60)" +"(expand-context/inner-module-begin-k" +" the-struct_60)" +"(expand-context/inner-allow-unbound?" +" the-struct_60)" +"(expand-context/inner-in-local-expand?" +" the-struct_60)" +"(expand-context/inner-keep-#%expression?" +" the-struct_60)" +"(expand-context/inner-stops" +" the-struct_60)" +"(expand-context/inner-declared-submodule-names" +" the-struct_60)" +" lifts220_0" +" lift-envs221_0" +" module-lifts222_0" +"(expand-context/inner-require-lifts" +" the-struct_60)" +"(expand-context/inner-to-module-lifts" +" the-struct_60)" +"(expand-context/inner-requires+provides" +" the-struct_60)" +"(expand-context/inner-observer" +" the-struct_60)" +"(expand-context/inner-for-serializable?" +" the-struct_60)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_60)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_60)))))" +"(expand-context/outer1.1" +" inner218_0" +"(root-expand-context/outer-post-expansion" +" the-struct_59)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_59)" +"(root-expand-context/outer-frame-id" +" the-struct_59)" +"(expand-context/outer-context the-struct_59)" +"(expand-context/outer-env the-struct_59)" +"(expand-context/outer-scopes the-struct_59)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_59)" +"(expand-context/outer-binding-layer" +" the-struct_59)" +"(expand-context/outer-reference-records" +" the-struct_59)" +"(expand-context/outer-only-immediate?" +" the-struct_59)" +"(expand-context/outer-need-eventually-defined" +" the-struct_59)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_59)" +"(expand-context/outer-current-use-scopes" +" the-struct_59)" +"(expand-context/outer-name the-struct_59)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_59))))))" +"(let-values(((rebuild-s_0)(keep-properties-only s_418)))" +"(let-values(((exp-s_2)" +"(let-values(((s223_0) s_418)" +"((capture-ctx224_0) capture-ctx_0))" +"(expand9.1 #f #f #f s223_0 capture-ctx224_0))))" +"(let-values(((lifts_6)" +"(get-and-clear-lifts!" +"(expand-context-lifts capture-ctx_0))))" +"(let-values(((with-lifts-s_0)" +"(if(let-values(((or-part_273)" +"(pair? lifts_6)))" +"(if or-part_273" +" or-part_273" +" always-wrap?_1))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_32)" +"(let-values()" +"(begin" +"(if expand-lifts?_0" +"(void)" +"(let-values()" +"(error" +" \"internal error: to-parsed mode without expanding lifts\")))" +"(wrap-lifts-as-parsed-let" +" lifts_6" +" exp-s_2" +" rebuild-s_0" +" ctx_32" +"(lambda(rhs_15 rhs-ctx_0)" +"(loop_95 rhs_15 #f rhs-ctx_0)))))" +"(let-values()" +"(if begin-form?_0" +"(let-values(((lifts225_0) lifts_6)" +"((exp-s226_0) exp-s_2)" +"((phase227_0)" +" phase_104))" +"(wrap-lifts-as-begin16.1" +" unsafe-undefined" +" unsafe-undefined" +" lifts225_0" +" exp-s226_0" +" phase227_0))" +"(wrap-lifts-as-let" +" lifts_6" +" exp-s_2" +" phase_104)))))" +"(let-values() exp-s_2))))" +"(if(let-values(((or-part_274)(not expand-lifts?_0)))" +"(if or-part_274" +" or-part_274" +"(let-values(((or-part_275)(null? lifts_6)))" +"(if or-part_275" +" or-part_275" +"(expand-context-to-parsed? ctx_32)))))" +"(let-values() with-lifts-s_0)" +"(let-values()" +"(begin" +"(let-values(((obs_27)" +"(expand-context-observer ctx_32)))" +"(if obs_27" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_27" +" 'letlift-loop" +" with-lifts-s_0)))" +"(void)))" +"(loop_95 with-lifts-s_0 #f ctx_32)))))))))))))))" +" loop_95)" +" s_360" +" always-wrap?_0" +" ctx_31))))))))))))))" +"(define-values" +"(expand-transformer92.1)" +"(lambda(always-wrap?82_0 begin-form?79_0 context78_0 expand-lifts?80_0 keep-stops?83_0 lift-key81_0 s90_0 ctx91_0)" +"(begin" +" 'expand-transformer92" +"(let-values(((s_419) s90_0))" +"(let-values(((ctx_33) ctx91_0))" +"(let-values(((context_7) context78_0))" +"(let-values(((begin-form?_1) begin-form?79_0))" +"(let-values(((expand-lifts?_1) expand-lifts?80_0))" +"(let-values(((lift-key_3)(if(eq? lift-key81_0 unsafe-undefined)(generate-lift-key) lift-key81_0)))" +"(let-values(((always-wrap?_2) always-wrap?82_0))" +"(let-values(((keep-stops?_0) keep-stops?83_0))" +"(let-values()" +"(let-values()" +"(let-values(((trans-ctx_0)" +"(let-values(((ctx234_0) ctx_33)" +"((context235_0) context_7)" +"((keep-stops?236_0) keep-stops?_0))" +"(context->transformer-context99.1 keep-stops?236_0 ctx234_0 context235_0))))" +"(let-values(((s228_0) s_419)" +"((trans-ctx229_0) trans-ctx_0)" +"((expand-lifts?230_0) expand-lifts?_1)" +"((begin-form?231_0) begin-form?_1)" +"((lift-key232_0) lift-key_3)" +"((always-wrap?233_0) always-wrap?_2))" +"(expand/capture-lifts75.1" +" always-wrap?233_0" +" begin-form?231_0" +" expand-lifts?230_0" +" lift-key232_0" +" s228_0" +" trans-ctx229_0))))))))))))))))" +"(define-values" +"(context->transformer-context99.1)" +"(lambda(keep-stops?95_0 ctx98_0 context97_0)" +"(begin" +" 'context->transformer-context99" +"(let-values(((ctx_34) ctx98_0))" +"(let-values(((context_8) context97_0))" +"(let-values(((keep-stops?_1) keep-stops?95_0))" +"(let-values()" +"(let-values(((phase_105)(add1(expand-context-phase ctx_34))))" +"(let-values(((ns_74)(namespace->namespace-at-phase(expand-context-namespace ctx_34) phase_105)))" +"(begin" +"(namespace-visit-available-modules! ns_74 phase_105)" +"(let-values(((v_192) ctx_34))" +"(let-values(((the-struct_61) v_192))" +"(if(expand-context/outer? the-struct_61)" +"(let-values(((context237_0) context_8)" +"((scopes238_0) null)" +"((env239_0) empty-env)" +"((only-immediate?240_0)" +"(if keep-stops?_1(expand-context-only-immediate? ctx_34) #f))" +"((def-ctx-scopes241_0) #f)" +"((post-expansion242_0) #f)" +"((inner243_0)" +"(let-values(((the-struct_62)(root-expand-context/outer-inner v_192)))" +"(if(expand-context/inner? the-struct_62)" +"(let-values(((phase244_0) phase_105)" +"((namespace245_0) ns_74)" +"((stops246_0)" +"(if keep-stops?_1" +"(expand-context-stops ctx_34)" +" empty-free-id-set)))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_62)" +"(root-expand-context/inner-module-scopes the-struct_62)" +"(root-expand-context/inner-top-level-bind-scope the-struct_62)" +"(root-expand-context/inner-all-scopes-stx the-struct_62)" +"(root-expand-context/inner-defined-syms the-struct_62)" +"(root-expand-context/inner-counter the-struct_62)" +"(root-expand-context/inner-lift-key the-struct_62)" +"(expand-context/inner-to-parsed? the-struct_62)" +" phase244_0" +" namespace245_0" +"(expand-context/inner-just-once? the-struct_62)" +"(expand-context/inner-module-begin-k the-struct_62)" +"(expand-context/inner-allow-unbound? the-struct_62)" +"(expand-context/inner-in-local-expand? the-struct_62)" +"(expand-context/inner-keep-#%expression? the-struct_62)" +" stops246_0" +"(expand-context/inner-declared-submodule-names the-struct_62)" +"(expand-context/inner-lifts the-struct_62)" +"(expand-context/inner-lift-envs the-struct_62)" +"(expand-context/inner-module-lifts the-struct_62)" +"(expand-context/inner-require-lifts the-struct_62)" +"(expand-context/inner-to-module-lifts the-struct_62)" +"(expand-context/inner-requires+provides the-struct_62)" +"(expand-context/inner-observer the-struct_62)" +"(expand-context/inner-for-serializable? the-struct_62)" +"(expand-context/inner-should-not-encounter-macros? the-struct_62)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_62)))))" +"(expand-context/outer1.1" +" inner243_0" +" post-expansion242_0" +"(root-expand-context/outer-use-site-scopes the-struct_61)" +"(root-expand-context/outer-frame-id the-struct_61)" +" context237_0" +" env239_0" +" scopes238_0" +" def-ctx-scopes241_0" +"(expand-context/outer-binding-layer the-struct_61)" +"(expand-context/outer-reference-records the-struct_61)" +" only-immediate?240_0" +"(expand-context/outer-need-eventually-defined the-struct_61)" +"(expand-context/outer-current-introduction-scopes the-struct_61)" +"(expand-context/outer-current-use-scopes the-struct_61)" +"(expand-context/outer-name the-struct_61)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_61))))))))))))))" +"(define-values" +"(expand+eval-for-syntaxes-binding108.1)" +"(lambda(log-next?102_0 who104_0 rhs105_0 ids106_0 ctx107_0)" +"(begin" +" 'expand+eval-for-syntaxes-binding108" +"(let-values(((who_16) who104_0))" +"(let-values(((rhs_16) rhs105_0))" +"(let-values(((ids_19) ids106_0))" +"(let-values(((ctx_35) ctx107_0))" +"(let-values(((log-next?_0) log-next?102_0))" +"(let-values()" +"(let-values(((exp-rhs_0)" +"(let-values(((rhs247_0) rhs_16)((temp248_0)(as-named-context ctx_35 ids_19)))" +"(expand-transformer92.1" +" #f" +" #f" +" 'expression" +" #t" +" #f" +" unsafe-undefined" +" rhs247_0" +" temp248_0))))" +"(let-values(((phase_106)(add1(expand-context-phase ctx_35))))" +"(let-values(((parsed-rhs_0)" +"(if(expand-context-to-parsed? ctx_35)" +" exp-rhs_0" +"(let-values(((exp-rhs249_0) exp-rhs_0)" +"((temp250_1)" +"(let-values(((temp251_0)(as-to-parsed-context ctx_35)))" +"(context->transformer-context99.1 #f temp251_0 'expression))))" +"(expand9.1 #f #f #f exp-rhs249_0 temp250_1)))))" +"(begin" +"(if log-next?_0" +"(let-values()" +"(let-values(((obs_28)(expand-context-observer ctx_35)))" +"(if obs_28(let-values()(let-values()(call-expand-observe obs_28 'next)))(void))))" +"(void))" +"(values" +" exp-rhs_0" +" parsed-rhs_0" +"(eval-for-bindings" +" who_16" +" ids_19" +" parsed-rhs_0" +" phase_106" +"(namespace->namespace-at-phase(expand-context-namespace ctx_35) phase_106)" +" ctx_35)))))))))))))))" +"(define-values" +"(eval-for-syntaxes-binding)" +"(lambda(who_17 rhs_17 ids_20 ctx_36)" +"(begin" +"(let-values(((exp-rhs_1 parsed-rhs_1 vals_3)" +"(let-values(((who252_0) who_17)((rhs253_0) rhs_17)((ids254_0) ids_20)((ctx255_0) ctx_36))" +"(expand+eval-for-syntaxes-binding108.1 #t who252_0 rhs253_0 ids254_0 ctx255_0))))" +" vals_3))))" +"(define-values" +"(eval-for-bindings)" +"(lambda(who_18 ids_21 p_49 phase_107 ns_75 ctx_37)" +"(begin" +"(let-values(((compiled_0)" +"(if(can-direct-eval? p_49 ns_75(root-expand-context-self-mpi ctx_37))" +" #f" +"(compile-single" +" p_49" +"(let-values(((ns256_0) ns_75)((phase257_0) phase_107))" +"(make-compile-context14.1 #f unsafe-undefined #f ns256_0 phase257_0 unsafe-undefined))))))" +"(let-values(((vals_4)" +"(call-with-values" +"(lambda()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-context" +" ctx_37" +" 1/current-namespace" +" ns_75" +" eval-jit-enabled" +" #f)" +"(let-values()" +"(if compiled_0" +"(eval-single-top compiled_0 ns_75)" +"(direct-eval p_49 ns_75(root-expand-context-self-mpi ctx_37))))))" +" list)))" +"(begin" +"(if(=(length vals_4)(length ids_21))" +"(void)" +"(let-values()" +"(apply" +" raise-result-arity-error" +" who_18" +"(length ids_21)" +"(if(null? ids_21)" +" (let-values () \"\")" +"(let-values()" +"(format" +" \"\\n in: definition of ~a~a\"" +"(syntax-e$1(car ids_21))" +" (if (pair? (cdr ids_21)) \" ...\" \"\"))))" +" vals_4)))" +" vals_4))))))" +"(define-values(keep-properties-only)(lambda(s_420)(begin(datum->syntax$1 #f 'props s_420 s_420))))" +"(define-values(keep-properties-only~)(lambda(s_421)(begin #f)))" +"(define-values" +"(keep-as-needed119.1)" +"(lambda(for-track?111_0 keep-for-error?113_0 keep-for-parsed?112_0 ctx117_0 s118_0)" +"(begin" +" 'keep-as-needed119" +"(let-values(((ctx_38) ctx117_0))" +"(let-values(((s_422) s118_0))" +"(let-values()" +"(let-values(((keep-for-parsed?_0) keep-for-parsed?112_0))" +"(let-values(((keep-for-error?_0) keep-for-error?113_0))" +"(let-values()" +"(let-values(((d_33)(syntax-e$1 s_422)))" +"(let-values(((keep-e_0)" +"(if(symbol? d_33)" +"(let-values() d_33)" +"(if(if(pair? d_33)(syntax-identifier?(car d_33)) #f)" +"(let-values()(syntax-e$1(car d_33)))" +"(let-values() #f)))))" +"(if(expand-context-to-parsed? ctx_38)" +"(let-values()" +"(if(let-values(((or-part_276) keep-for-parsed?_0))" +"(if or-part_276 or-part_276 keep-for-error?_0))" +"(datum->syntax$1 #f keep-e_0 s_422 s_422)" +" #f))" +"(let-values()" +"(syntax-rearm$1" +"(datum->syntax$1(syntax-disarm$1 s_422) keep-e_0 s_422 s_422)" +" s_422))))))))))))))" +"(define-values" +"(attach-disappeared-transformer-bindings)" +"(lambda(s_154 trans-idss_0)" +"(begin" +"(if(null? trans-idss_0)" +"(let-values() s_154)" +"(let-values()" +"(syntax-property$1" +" s_154" +" 'disappeared-binding" +"(append" +"(apply append trans-idss_0)" +"(let-values(((or-part_197)(syntax-property$1 s_154 'disappeared-binding)))" +"(if or-part_197 or-part_197 null)))))))))" +"(define-values" +"(increment-binding-layer)" +"(lambda(ids_22 ctx_39 layer-val_0)" +"(begin" +"(if((letrec-values(((loop_96)" +"(lambda(ids_23)" +"(begin" +" 'loop" +"(let-values(((or-part_198)(identifier? ids_23)))" +"(if or-part_198" +" or-part_198" +"(if(pair? ids_23)" +"(let-values(((or-part_199)(loop_96(car ids_23))))" +"(if or-part_199 or-part_199(loop_96(cdr ids_23))))" +" #f)))))))" +" loop_96)" +" ids_22)" +" layer-val_0" +"(expand-context-binding-layer ctx_39)))))" +"(define-values" +"(wrap-lifts-as-parsed-let)" +"(lambda(lifts_7 exp-s_3 rebuild-s_1 ctx_40 parse-rhs_0)" +"(begin" +"(let-values(((idss+keyss+rhss_0)(get-lifts-as-lists lifts_7)))" +"((letrec-values(((lets-loop_0)" +"(lambda(idss+keyss+rhss_1 rhs-ctx_1)" +"(begin" +" 'lets-loop" +"(if(null? idss+keyss+rhss_1)" +"(let-values() exp-s_3)" +"(let-values()" +"(let-values(((ids_24)(caar idss+keyss+rhss_1)))" +"(let-values(((keys_4)(cadar idss+keyss+rhss_1)))" +"(let-values(((rhs_18)(caddar idss+keyss+rhss_1)))" +"(let-values(((exp-rhs_2)(parse-rhs_0 rhs_18 rhs-ctx_1)))" +"(parsed-let-values17.1" +" rebuild-s_1" +"(list ids_24)" +"(list(list keys_4 exp-rhs_2))" +"(list" +"(lets-loop_0" +"(cdr idss+keyss+rhss_1)" +"(let-values(((v_193) rhs-ctx_1))" +"(let-values(((the-struct_63) v_193))" +"(if(expand-context/outer? the-struct_63)" +"(let-values(((env258_0)" +"(let-values(((lst_283) ids_24)((lst_284) keys_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_283)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_284)))" +"((letrec-values(((for-loop_254)" +"(lambda(env_3 lst_285 lst_286)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_285)" +"(pair? lst_286)" +" #f)" +"(let-values(((id_68)" +"(unsafe-car" +" lst_285))" +"((rest_159)" +"(unsafe-cdr" +" lst_285))" +"((key_81)" +"(unsafe-car" +" lst_286))" +"((rest_160)" +"(unsafe-cdr" +" lst_286)))" +"(let-values(((env_4)" +"(let-values(((env_5)" +" env_3))" +"(let-values(((env_6)" +"(let-values()" +"(env-extend" +" env_5" +" key_81" +"(local-variable1.1" +" id_68)))))" +"(values" +" env_6)))))" +"(if(not #f)" +"(for-loop_254" +" env_4" +" rest_159" +" rest_160)" +" env_4)))" +" env_3)))))" +" for-loop_254)" +"(expand-context-env rhs-ctx_1)" +" lst_283" +" lst_284))))" +"((inner259_0)(root-expand-context/outer-inner v_193)))" +"(expand-context/outer1.1" +" inner259_0" +"(root-expand-context/outer-post-expansion the-struct_63)" +"(root-expand-context/outer-use-site-scopes the-struct_63)" +"(root-expand-context/outer-frame-id the-struct_63)" +"(expand-context/outer-context the-struct_63)" +" env258_0" +"(expand-context/outer-scopes the-struct_63)" +"(expand-context/outer-def-ctx-scopes the-struct_63)" +"(expand-context/outer-binding-layer the-struct_63)" +"(expand-context/outer-reference-records the-struct_63)" +"(expand-context/outer-only-immediate? the-struct_63)" +"(expand-context/outer-need-eventually-defined the-struct_63)" +"(expand-context/outer-current-introduction-scopes the-struct_63)" +"(expand-context/outer-current-use-scopes the-struct_63)" +"(expand-context/outer-name the-struct_63)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_63)))))))))))))))))" +" lets-loop_0)" +" idss+keyss+rhss_0" +" ctx_40)))))" +"(define-values" +"(rename-transformer-target-in-context)" +"(lambda(t_58 ctx_41)" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_41)" +"(let-values()(1/rename-transformer-target t_58))))))" +"(define-values" +"(maybe-install-free=id-in-context!)" +"(lambda(val_69 id_69 phase_108 ctx_42)" +"(begin" +"(if(1/rename-transformer? val_69)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_42)" +"(let-values()(maybe-install-free=id! val_69 id_69 phase_108))))" +"(void)))))" +"(define-values" +"(transfer-srcloc)" +"(lambda(new-s_1 old-s_0)" +"(begin" +"(let-values(((srcloc_7)(syntax-srcloc old-s_0)))" +"(if srcloc_7" +"(let-values(((the-struct_64) new-s_1))" +"(if(syntax?$1 the-struct_64)" +"(let-values(((srcloc260_0) srcloc_7))" +"(syntax1.1" +"(syntax-content the-struct_64)" +"(syntax-scopes the-struct_64)" +"(syntax-shifted-multi-scopes the-struct_64)" +"(syntax-scope-propagations+tamper the-struct_64)" +"(syntax-mpi-shifts the-struct_64)" +" srcloc260_0" +"(syntax-props the-struct_64)" +"(syntax-inspector the-struct_64)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_64)))" +" new-s_1)))))" +"(define-values" +"(stop-ids->all-stop-ids)" +"(lambda(stop-ids_0 phase_44)" +"(begin" +"(if(null? stop-ids_0)" +"(let-values() stop-ids_0)" +"(let-values()" +"(let-values(((p-core-stx_0)(syntax-shift-phase-level$1 core-stx phase_44)))" +"(if(if(= 1(length stop-ids_0))" +"(free-identifier=?$1(car stop-ids_0)(datum->syntax$1 p-core-stx_0 'module*) phase_44 phase_44)" +" #f)" +"(let-values() stop-ids_0)" +"(let-values()" +"(append" +" stop-ids_0" +"(reverse$1" +"(let-values(((lst_103) auto-stop-syms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_103)))" +"((letrec-values(((for-loop_117)" +"(lambda(fold-var_91 lst_84)" +"(begin" +" 'for-loop" +"(if(pair? lst_84)" +"(let-values(((sym_71)(unsafe-car lst_84))" +"((rest_50)(unsafe-cdr lst_84)))" +"(let-values(((fold-var_92)" +"(let-values(((fold-var_93) fold-var_91))" +"(let-values(((fold-var_60)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" p-core-stx_0" +" sym_71))" +" fold-var_93))))" +"(values fold-var_60)))))" +"(if(not #f)(for-loop_117 fold-var_92 rest_50) fold-var_92)))" +" fold-var_91)))))" +" for-loop_117)" +" null" +" lst_103)))))))))))))" +"(define-values" +"(auto-stop-syms)" +" '(begin" +" quote" +" set!" +" lambda" +" case-lambda" +" let-values" +" letrec-values" +" if" +" begin0" +" with-continuation-mark" +" letrec-syntaxes+values" +" #%app" +" #%expression" +" #%top" +" #%variable-reference))" +"(define-values" +"(module-expand-stop-ids)" +"(lambda(phase_109)" +"(begin" +"(let-values(((p-core-stx_1)(syntax-shift-phase-level$1 core-stx phase_109)))" +"(reverse$1" +"(let-values(((lst_102) module-stop-syms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_102)))" +"((letrec-values(((for-loop_116)" +"(lambda(fold-var_239 lst_262)" +"(begin" +" 'for-loop" +"(if(pair? lst_262)" +"(let-values(((sym_18)(unsafe-car lst_262))((rest_161)(unsafe-cdr lst_262)))" +"(let-values(((fold-var_221)" +"(let-values(((fold-var_222) fold-var_239))" +"(let-values(((fold-var_223)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1 p-core-stx_1 sym_18))" +" fold-var_222))))" +"(values fold-var_223)))))" +"(if(not #f)(for-loop_116 fold-var_221 rest_161) fold-var_221)))" +" fold-var_239)))))" +" for-loop_116)" +" null" +" lst_102))))))))" +"(define-values" +"(module-stop-syms)" +"(append" +" auto-stop-syms" +" '(define-values define-syntaxes begin-for-syntax #%require #%provide module module* #%declare #%stratified-body)))" +"(define-values" +"(struct:internal-definition-context" +" internal-definition-context1.1" +" 1/internal-definition-context?" +" internal-definition-context-frame-id" +" internal-definition-context-scope" +" internal-definition-context-add-scope?" +" internal-definition-context-env-mixins" +" internal-definition-context-parent-ctx)" +"(let-values(((struct:_41 make-_41 ?_41 -ref_41 -set!_41)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'internal-definition-context" +" #f" +" 5" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2 3 4)" +" #f" +" 'internal-definition-context)))))" +"(values" +" struct:_41" +" make-_41" +" ?_41" +"(make-struct-field-accessor -ref_41 0 'frame-id)" +"(make-struct-field-accessor -ref_41 1 'scope)" +"(make-struct-field-accessor -ref_41 2 'add-scope?)" +"(make-struct-field-accessor -ref_41 3 'env-mixins)" +"(make-struct-field-accessor -ref_41 4 'parent-ctx))))" +"(define-values" +"(struct:env-mixin env-mixin2.1 env-mixin? env-mixin-id env-mixin-sym env-mixin-value env-mixin-cache)" +"(let-values(((struct:_79 make-_79 ?_79 -ref_79 -set!_79)" +"(let-values()" +"(let-values()" +"(make-struct-type 'env-mixin #f 4 0 #f null(current-inspector) #f '(0 1 2 3) #f 'env-mixin)))))" +"(values" +" struct:_79" +" make-_79" +" ?_79" +"(make-struct-field-accessor -ref_79 0 'id)" +"(make-struct-field-accessor -ref_79 1 'sym)" +"(make-struct-field-accessor -ref_79 2 'value)" +"(make-struct-field-accessor -ref_79 3 'cache))))" +"(define-values" +"(1/syntax-local-make-definition-context)" +"(let-values(((syntax-local-make-definition-context5_0)" +"(lambda(parent-ctx3_0 add-scope?4_0)" +"(begin" +" 'syntax-local-make-definition-context5" +"(let-values(((parent-ctx_0) parent-ctx3_0))" +"(let-values(((add-scope?_0) add-scope?4_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_64)(not parent-ctx_0)))" +"(if or-part_64" +" or-part_64" +"(1/internal-definition-context? parent-ctx_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-make-definition-context" +" \"(or/c #f internal-definition-context?)\"" +" parent-ctx_0)))" +"(values))))" +"(let-values(((ctx_43)" +"(let-values(((temp47_0) 'syntax-local-make-definition-context))" +"(get-current-expand-context16.1 #f temp47_0))))" +"(let-values(((frame-id_8)" +"(let-values(((or-part_65)(root-expand-context-frame-id ctx_43)))" +"(if or-part_65" +" or-part_65" +"(let-values(((or-part_227)" +"(if parent-ctx_0" +"(internal-definition-context-frame-id parent-ctx_0)" +" #f)))" +"(if or-part_227 or-part_227(gensym)))))))" +"(let-values(((sc_33)(new-scope 'intdef)))" +"(let-values(((def-ctx-scopes_4)(expand-context-def-ctx-scopes ctx_43)))" +"(begin" +"(if def-ctx-scopes_4" +"(let-values()" +"(set-box! def-ctx-scopes_4(cons sc_33(unbox def-ctx-scopes_4))))" +"(void))" +"(internal-definition-context1.1" +" frame-id_8" +" sc_33" +" add-scope?_0" +"(box null)" +" parent-ctx_0))))))))))))))" +"(case-lambda" +"(()(begin 'syntax-local-make-definition-context(syntax-local-make-definition-context5_0 #f #t)))" +"((parent-ctx_1 add-scope?4_1)(syntax-local-make-definition-context5_0 parent-ctx_1 add-scope?4_1))" +"((parent-ctx3_1)(syntax-local-make-definition-context5_0 parent-ctx3_1 #t)))))" +"(define-values" +"(1/syntax-local-bind-syntaxes)" +"(let-values(((syntax-local-bind-syntaxes11_0)" +"(lambda(ids8_0 s9_0 intdef10_0 extra-intdefs7_0)" +"(begin" +" 'syntax-local-bind-syntaxes11" +"(let-values(((ids_25) ids8_0))" +"(let-values(((s_423) s9_0))" +"(let-values(((intdef_0) intdef10_0))" +"(let-values(((extra-intdefs_0) extra-intdefs7_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(list? ids_25)(andmap2 identifier? ids_25) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-bind-syntaxes" +" \"(listof identifier?)\"" +" ids_25)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_98)(not s_423)))" +"(if or-part_98 or-part_98(syntax?$1 s_423)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-bind-syntaxes" +" \"(or/c syntax? #f)\"" +" s_423)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/internal-definition-context? intdef_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-bind-syntaxes" +" \"internal-definition-context?\"" +" intdef_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(intdefs? extra-intdefs_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-bind-syntaxes" +" intdefs?-string" +" extra-intdefs_0)))" +"(values))))" +"(let-values(((ctx_44)" +"(let-values(((temp48_1) 'local-expand))" +"(get-current-expand-context16.1 #f temp48_1))))" +"(let-values((()" +"(begin" +"(let-values(((obs_29)(expand-context-observer ctx_44)))" +"(if obs_29" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_29 'local-bind ids_25)))" +"(void)))" +"(values))))" +"(let-values(((phase_7)(expand-context-phase ctx_44)))" +"(let-values(((all-intdefs_0)" +"(if(list? extra-intdefs_0)" +"(cons intdef_0 extra-intdefs_0)" +"(list intdef_0 extra-intdefs_0))))" +"(let-values(((intdef-ids_0)" +"(reverse$1" +"(let-values(((lst_188) ids_25))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_188)))" +"((letrec-values(((for-loop_121)" +"(lambda(fold-var_235 lst_287)" +"(begin" +" 'for-loop" +"(if(pair? lst_287)" +"(let-values(((id_70)" +"(unsafe-car" +" lst_287))" +"((rest_162)" +"(unsafe-cdr" +" lst_287)))" +"(let-values(((fold-var_240)" +"(let-values(((fold-var_241)" +" fold-var_235))" +"(let-values(((fold-var_242)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((pre-id_0)" +"(remove-use-site-scopes" +"(flip-introduction-scopes" +" id_70" +" ctx_44)" +" ctx_44)))" +"(let-values(((temp49_1)" +"(let-values(((pre-id51_0)" +" pre-id_0)" +"((intdef52_0)" +" intdef_0)" +"((temp53_2)" +" #t))" +"(add-intdef-scopes24.1" +" unsafe-undefined" +" temp53_2" +" pre-id51_0" +" intdef52_0)))" +"((extra-intdefs50_0)" +" extra-intdefs_0))" +"(add-intdef-scopes24.1" +" unsafe-undefined" +" #f" +" temp49_1" +" extra-intdefs50_0))))" +" fold-var_241))))" +"(values" +" fold-var_242)))))" +"(if(not #f)" +"(for-loop_121" +" fold-var_240" +" rest_162)" +" fold-var_240)))" +" fold-var_235)))))" +" for-loop_121)" +" null" +" lst_188))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_30)" +"(expand-context-observer ctx_44)))" +"(if obs_30" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_30" +" 'rename-list" +" intdef-ids_0)))" +"(void)))" +"(values))))" +"(let-values(((syms_20)" +"(reverse$1" +"(let-values(((lst_167) intdef-ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_167)))" +"((letrec-values(((for-loop_194)" +"(lambda(fold-var_165 lst_168)" +"(begin" +" 'for-loop" +"(if(pair? lst_168)" +"(let-values(((intdef-id_0)" +"(unsafe-car" +" lst_168))" +"((rest_163)" +"(unsafe-cdr" +" lst_168)))" +"(let-values(((fold-var_243)" +"(let-values(((fold-var_179)" +" fold-var_165))" +"(let-values(((fold-var_244)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((intdef-id54_0)" +" intdef-id_0)" +"((phase55_0)" +" phase_7)" +"((temp56_2)" +"(root-expand-context-counter" +" ctx_44))" +"((temp57_0)" +"(internal-definition-context-frame-id" +" intdef_0)))" +"(add-local-binding!37.1" +" temp57_0" +" #f" +" intdef-id54_0" +" phase55_0" +" temp56_2)))" +" fold-var_179))))" +"(values" +" fold-var_244)))))" +"(if(not #f)" +"(for-loop_194" +" fold-var_243" +" rest_163)" +" fold-var_243)))" +" fold-var_165)))))" +" for-loop_194)" +" null" +" lst_167))))))" +"(let-values(((vals_5)" +"(if s_423" +"(let-values()" +"(let-values(((input-s_0)" +"(flip-introduction-scopes" +"(let-values(((s58_0) s_423)" +"((all-intdefs59_0)" +" all-intdefs_0))" +"(add-intdef-scopes24.1" +" unsafe-undefined" +" #f" +" s58_0" +" all-intdefs59_0))" +" ctx_44)))" +"(let-values(((tmp-env_0)" +"(let-values(((lst_288) syms_20)" +"((lst_140)" +" intdef-ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_288)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_140)))" +"((letrec-values(((for-loop_173)" +"(lambda(env_7" +" lst_141" +" lst_289)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_141)" +"(pair?" +" lst_289)" +" #f)" +"(let-values(((sym_72)" +"(unsafe-car" +" lst_141))" +"((rest_164)" +"(unsafe-cdr" +" lst_141))" +"((intdef-id_1)" +"(unsafe-car" +" lst_289))" +"((rest_165)" +"(unsafe-cdr" +" lst_289)))" +"(let-values(((env_8)" +"(let-values(((env_9)" +" env_7))" +"(let-values(((env_10)" +"(let-values()" +"(hash-set" +" env_9" +" sym_72" +"(local-variable1.1" +" intdef-id_1)))))" +"(values" +" env_10)))))" +"(if(not" +" #f)" +"(for-loop_173" +" env_8" +" rest_164" +" rest_165)" +" env_8)))" +" env_7)))))" +" for-loop_173)" +"(expand-context-env ctx_44)" +" lst_288" +" lst_140)))))" +"(let-values((()" +"(begin" +"(let-values(((obs_31)" +"(expand-context-observer" +" ctx_44)))" +"(if obs_31" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_31" +" 'enter-bind)))" +"(void)))" +"(values))))" +"(let-values(((vals_6)" +"(eval-for-syntaxes-binding" +" 'syntax-local-bind-syntaxes" +" input-s_0" +" ids_25" +"(let-values(((temp60_2)" +"(let-values(((v_77)" +" ctx_44))" +"(let-values(((the-struct_65)" +" v_77))" +"(if(expand-context/outer?" +" the-struct_65)" +"(let-values(((env63_0)" +" tmp-env_0)" +"((inner64_0)" +"(root-expand-context/outer-inner" +" v_77)))" +"(expand-context/outer1.1" +" inner64_0" +"(root-expand-context/outer-post-expansion" +" the-struct_65)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_65)" +"(root-expand-context/outer-frame-id" +" the-struct_65)" +"(expand-context/outer-context" +" the-struct_65)" +" env63_0" +"(expand-context/outer-scopes" +" the-struct_65)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_65)" +"(expand-context/outer-binding-layer" +" the-struct_65)" +"(expand-context/outer-reference-records" +" the-struct_65)" +"(expand-context/outer-only-immediate?" +" the-struct_65)" +"(expand-context/outer-need-eventually-defined" +" the-struct_65)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_65)" +"(expand-context/outer-current-use-scopes" +" the-struct_65)" +"(expand-context/outer-name" +" the-struct_65)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_65)))))" +"((temp61_1)" +" 'expression)" +"((all-intdefs62_0)" +" all-intdefs_0))" +"(make-local-expand-context42.1" +" temp61_1" +" all-intdefs62_0" +" #t" +" unsafe-undefined" +" #f" +" #f" +" #f" +" temp60_2)))))" +"(begin" +"(let-values(((obs_32)" +"(expand-context-observer" +" ctx_44)))" +"(if obs_32" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_32" +" 'exit-bind)))" +"(void)))" +" vals_6))))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_106) intdef-ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_106)))" +"((letrec-values(((for-loop_80)" +"(lambda(fold-var_101" +" lst_50)" +"(begin" +" 'for-loop" +"(if(pair? lst_50)" +"(let-values(((intdef-id_2)" +"(unsafe-car" +" lst_50))" +"((rest_53)" +"(unsafe-cdr" +" lst_50)))" +"(let-values(((fold-var_102)" +"(let-values(((fold-var_103)" +" fold-var_101))" +"(let-values(((fold-var_104)" +"(let-values()" +"(cons" +"(let-values()" +"(local-variable1.1" +" intdef-id_2))" +" fold-var_103))))" +"(values" +" fold-var_104)))))" +"(if(not #f)" +"(for-loop_80" +" fold-var_102" +" rest_53)" +" fold-var_102)))" +" fold-var_101)))))" +" for-loop_80)" +" null" +" lst_106))))))))" +"(let-values(((env-mixins_0)" +"(internal-definition-context-env-mixins intdef_0)))" +"(begin" +"(set-box!" +" env-mixins_0" +"(append" +"(reverse$1" +"(let-values(((lst_290) intdef-ids_0)" +"((lst_195) syms_20)" +"((lst_291) vals_5))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_290)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_195)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_291)))" +"((letrec-values(((for-loop_255)" +"(lambda(fold-var_245" +" lst_292" +" lst_293" +" lst_294)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_292)" +"(if(pair? lst_293)" +"(pair? lst_294)" +" #f)" +" #f)" +"(let-values(((intdef-id_3)" +"(unsafe-car" +" lst_292))" +"((rest_166)" +"(unsafe-cdr" +" lst_292))" +"((sym_73)" +"(unsafe-car" +" lst_293))" +"((rest_167)" +"(unsafe-cdr" +" lst_293))" +"((val_70)" +"(unsafe-car" +" lst_294))" +"((rest_168)" +"(unsafe-cdr" +" lst_294)))" +"(let-values(((fold-var_246)" +"(let-values(((fold-var_247)" +" fold-var_245))" +"(let-values(((fold-var_248)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_70" +" intdef-id_3" +" phase_7" +" ctx_44)" +"(env-mixin2.1" +" intdef-id_3" +" sym_73" +" val_70" +"(make-weak-hasheq))))" +" fold-var_247))))" +"(values" +" fold-var_248)))))" +"(if(not #f)" +"(for-loop_255" +" fold-var_246" +" rest_166" +" rest_167" +" rest_168)" +" fold-var_246)))" +" fold-var_245)))))" +" for-loop_255)" +" null" +" lst_290" +" lst_195" +" lst_291))))" +"(unbox env-mixins_0)))" +"(let-values(((obs_33)(expand-context-observer ctx_44)))" +"(if obs_33" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_33 'exit-local-bind)))" +"(void))))))))))))))))))))))))))" +"(case-lambda" +"((ids_26 s_202 intdef_1)" +"(begin 'syntax-local-bind-syntaxes(syntax-local-bind-syntaxes11_0 ids_26 s_202 intdef_1 '())))" +"((ids_13 s_424 intdef_2 extra-intdefs7_1)" +"(syntax-local-bind-syntaxes11_0 ids_13 s_424 intdef_2 extra-intdefs7_1)))))" +"(define-values" +"(1/internal-definition-context-binding-identifiers)" +"(lambda(intdef_3)" +"(begin" +" 'internal-definition-context-binding-identifiers" +"(begin" +"(if(1/internal-definition-context? intdef_3)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'internal-definition-context-binding-identifiers" +" \"internal-definition-context?\"" +" intdef_3)))" +"(reverse$1" +"(let-values(((lst_29)(unbox(internal-definition-context-env-mixins intdef_3))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_29)))" +"((letrec-values(((for-loop_14)" +"(lambda(fold-var_249 lst_295)" +"(begin" +" 'for-loop" +"(if(pair? lst_295)" +"(let-values(((env-mixin_0)(unsafe-car lst_295))" +"((rest_169)(unsafe-cdr lst_295)))" +"(let-values(((fold-var_250)" +"(let-values(((fold-var_251) fold-var_249))" +"(let-values(((fold-var_252)" +"(let-values()" +"(cons" +"(let-values()(env-mixin-id env-mixin_0))" +" fold-var_251))))" +"(values fold-var_252)))))" +"(if(not #f)(for-loop_14 fold-var_250 rest_169) fold-var_250)))" +" fold-var_249)))))" +" for-loop_14)" +" null" +" lst_29))))))))" +"(define-values" +"(1/internal-definition-context-introduce)" +"(let-values(((internal-definition-context-introduce16_0)" +"(lambda(intdef14_0 s15_0 mode13_0)" +"(begin" +" 'internal-definition-context-introduce16" +"(let-values(((intdef_4) intdef14_0))" +"(let-values(((s_37) s15_0))" +"(let-values(((mode_13) mode13_0))" +"(let-values()" +"(begin" +"(if(1/internal-definition-context? intdef_4)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'internal-definition-context-introduce" +" \"internal-definition-context?\"" +" intdef_4)))" +"(if(syntax?$1 s_37)" +"(void)" +"(let-values()" +" (raise-argument-error 'internal-definition-context-introduce \"syntax?\" s_37)))" +"(let-values(((s65_0) s_37)" +"((intdef66_0) intdef_4)" +"((temp67_1) #t)" +"((temp68_1)" +"(let-values(((tmp_32) mode_13))" +"(if(equal? tmp_32 'add)" +"(let-values() add-scope)" +"(if(equal? tmp_32 'remove)" +"(let-values() remove-scope)" +"(if(equal? tmp_32 'flip)" +"(let-values() flip-scope)" +"(let-values()" +"(raise-argument-error" +" 'internal-definition-context-introduce" +" \"(or/c 'add 'remove 'flip)\"" +" mode_13))))))))" +"(add-intdef-scopes24.1 temp68_1 temp67_1 s65_0 intdef66_0)))))))))))" +"(case-lambda" +"((intdef_5 s_207)" +"(begin 'internal-definition-context-introduce(internal-definition-context-introduce16_0 intdef_5 s_207 'flip)))" +"((intdef_6 s_425 mode13_1)(internal-definition-context-introduce16_0 intdef_6 s_425 mode13_1)))))" +"(define-values" +"(1/internal-definition-context-seal)" +"(lambda(intdef_7)" +"(begin" +" 'internal-definition-context-seal" +"(begin" +"(if(1/internal-definition-context? intdef_7)" +"(void)" +"(let-values()" +" (raise-argument-error 'internal-definition-context-seal \"internal-definition-context?\" intdef_7)))" +"(void)))))" +"(define-values" +"(1/identifier-remove-from-definition-context)" +"(lambda(id_71 intdef_8)" +"(begin" +" 'identifier-remove-from-definition-context" +"(begin" +"(if(identifier? id_71)" +"(void)" +" (let-values () (raise-argument-error 'identifier-remove-from-definition-context \"identifier?\" id_71)))" +"(if(let-values(((or-part_179)(1/internal-definition-context? intdef_8)))" +"(if or-part_179 or-part_179(if(list? intdef_8)(andmap2 1/internal-definition-context? intdef_8) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'identifier-remove-from-definition-context" +" \"(or/c internal-definition-context? (listof internal-definition-context?))\"" +" intdef_8)))" +"(let-values(((x_76)" +"(let-values(((a_49) intdef_8))" +"(if(list? a_49)" +"(let-values()(reverse$1 a_49))" +"(if(not a_49)(let-values() null)(let-values()(list a_49)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_209)" +"(lambda(id_72 a_50)" +"(begin" +" 'for-loop" +"(if(pair? a_50)" +"(let-values(((intdef_9)(car a_50)))" +"(let-values(((id_73)" +"(let-values(((id_74) id_72))" +"(let-values(((id_75)" +"(let-values()" +"(1/internal-definition-context-introduce" +" intdef_9" +" id_74" +" 'remove))))" +"(values id_75)))))" +"(if(not #f)(for-loop_209 id_73(cdr a_50)) id_73)))" +" id_72)))))" +" for-loop_209)" +" id_71" +" x_76)))))))" +"(define-values" +"(intdefs?)" +"(lambda(x_77)" +"(begin" +"(let-values(((or-part_277)(1/internal-definition-context? x_77)))" +"(if or-part_277 or-part_277(if(list? x_77)(andmap2 1/internal-definition-context? x_77) #f))))))" +" (define-values (intdefs?-string) \"(or/c internal-definition-context? (listof internal-definition-context?))\")" +"(define-values" +"(intdefs-or-false?)" +"(lambda(x_78)(begin(let-values(((or-part_278)(not x_78)))(if or-part_278 or-part_278(intdefs? x_78))))))" +"(define-values" +"(intdefs-or-false?-string)" +" \"(or/c internal-definition-context? (listof internal-definition-context?) #f)\")" +"(define-values" +"(add-intdef-bindings)" +"(lambda(env_11 intdefs_0)" +"(begin" +"(let-values(((x_79)" +"(let-values(((a_51) intdefs_0))" +"(if(list? a_51)" +"(let-values()(reverse$1 a_51))" +"(if(not a_51)(let-values() null)(let-values()(list a_51)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_256)" +"(lambda(env_12 a_52)" +"(begin" +" 'for-loop" +"(if(pair? a_52)" +"(let-values(((intdef_10)(car a_52)))" +"(let-values(((env_13)" +"(let-values(((env_14) env_12))" +"(let-values(((env_15)" +"(let-values()" +"(let-values(((parent-ctx_2)" +"(internal-definition-context-parent-ctx" +" intdef_10)))" +"(let-values(((parent-env_0)" +"(if parent-ctx_2" +"(add-intdef-bindings" +" env_14" +" parent-ctx_2)" +" env_14)))" +"(let-values(((env-mixins_1)" +"(unbox" +"(internal-definition-context-env-mixins" +" intdef_10))))" +"((letrec-values(((loop_97)" +"(lambda(env_16" +" env-mixins_2)" +"(begin" +" 'loop" +"(if(null? env-mixins_2)" +"(let-values() env_16)" +"(let-values()" +"(let-values(((env-mixin_1)" +"(car" +" env-mixins_2)))" +"(let-values(((or-part_279)" +"(hash-ref" +"(env-mixin-cache" +" env-mixin_1)" +" env_16" +" #f)))" +"(if or-part_279" +" or-part_279" +"(let-values(((new-env_0)" +"(env-extend" +"(loop_97" +" env_16" +"(cdr" +" env-mixins_2))" +"(env-mixin-sym" +" env-mixin_1)" +"(env-mixin-value" +" env-mixin_1))))" +"(begin" +"(hash-set!" +"(env-mixin-cache" +" env-mixin_1)" +" env_16" +" new-env_0)" +" new-env_0)))))))))))" +" loop_97)" +" parent-env_0" +" env-mixins_1)))))))" +"(values env_15)))))" +"(if(not #f)(for-loop_256 env_13(cdr a_52)) env_13)))" +" env_12)))))" +" for-loop_256)" +" env_11" +" x_79))))))" +"(define-values" +"(add-intdef-scopes24.1)" +"(lambda(action19_0 always?18_0 s22_0 intdefs23_0)" +"(begin" +" 'add-intdef-scopes24" +"(let-values(((s_426) s22_0))" +"(let-values(((intdefs_1) intdefs23_0))" +"(let-values(((always?_0) always?18_0))" +"(let-values(((action_0)(if(eq? action19_0 unsafe-undefined) add-scope action19_0)))" +"(let-values()" +"(let-values(((x_80)" +"(let-values(((a_53) intdefs_1))" +"(if(list? a_53)" +"(let-values()(reverse$1 a_53))" +"(if(not a_53)(let-values() null)(let-values()(list a_53)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_257)" +"(lambda(s_71 a_54)" +"(begin" +" 'for-loop" +"(if(pair? a_54)" +"(let-values(((intdef_11)(car a_54)))" +"(let-values(((s_427)" +"(let-values(((s_214) s_71))" +"(if(let-values(((or-part_280) always?_0))" +"(if or-part_280" +" or-part_280" +"(internal-definition-context-add-scope?" +" intdef_11)))" +"(let-values(((s_428) s_214))" +"(let-values(((s_215)" +"(let-values()" +"(action_0" +" s_428" +"(internal-definition-context-scope" +" intdef_11)))))" +"(values s_215)))" +" s_214))))" +"(if(not #f)(for-loop_257 s_427(cdr a_54)) s_427)))" +" s_71)))))" +" for-loop_257)" +" s_426" +" x_80)))))))))))" +"(define-values" +"(make-local-expand-context42.1)" +"(lambda(context27_0" +" intdefs29_0" +" keep-#%expression?33_0" +" phase28_1" +" stop-ids30_0" +" to-parsed-ok?31_0" +" track-to-be-defined?32_0" +" ctx41_0)" +"(begin" +" 'make-local-expand-context42" +"(let-values(((ctx_45) ctx41_0))" +"(let-values(((context_9) context27_0))" +"(let-values(((phase_110)(if(eq? phase28_1 unsafe-undefined)(expand-context-phase ctx_45) phase28_1)))" +"(let-values(((intdefs_2) intdefs29_0))" +"(let-values(((stop-ids_1) stop-ids30_0))" +"(let-values(((to-parsed-ok?_0) to-parsed-ok?31_0))" +"(let-values(((track-to-be-defined?_0) track-to-be-defined?32_0))" +"(let-values(((keep-#%expression?_1) keep-#%expression?33_0))" +"(let-values()" +"(let-values(((same-kind?_0)" +"(let-values(((or-part_281)(eq? context_9(expand-context-context ctx_45))))" +"(if or-part_281" +" or-part_281" +"(if(list? context_9)(list?(expand-context-context ctx_45)) #f)))))" +"(let-values(((all-stop-ids_0)" +"(if stop-ids_1(stop-ids->all-stop-ids stop-ids_1 phase_110) #f)))" +"(let-values(((def-ctx-scopes_5)" +"(if(expand-context-def-ctx-scopes ctx_45)" +"(unbox(expand-context-def-ctx-scopes ctx_45))" +" null)))" +"(let-values(((v_194) ctx_45))" +"(let-values(((the-struct_66) v_194))" +"(if(expand-context/outer? the-struct_66)" +"(let-values(((context69_0) context_9)" +"((env70_0)(add-intdef-bindings(expand-context-env ctx_45) intdefs_2))" +"((use-site-scopes71_0)" +"(if(let-values(((or-part_282)(eq? context_9 'module)))" +"(if or-part_282" +" or-part_282" +"(let-values(((or-part_133)(eq? context_9 'module-begin)))" +"(if or-part_133 or-part_133(list? context_9)))))" +"(let-values(((or-part_283)" +"(root-expand-context-use-site-scopes ctx_45)))" +"(if or-part_283 or-part_283(box null)))" +" #f))" +"((frame-id72_0)" +"(let-values(((x_5)" +"(let-values(((a_55) intdefs_2))" +"(if(list? a_55)" +"(let-values()(reverse$1 a_55))" +"(if(not a_55)" +"(let-values() null)" +"(let-values()(list a_55)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_258)" +"(lambda(frame-id_9 a_56)" +"(begin" +" 'for-loop" +"(if(pair? a_56)" +"(let-values(((intdef_12)(car a_56)))" +"(let-values(((frame-id_10)" +"(let-values(((frame-id_11)" +" frame-id_9))" +"(let-values(((frame-id_12)" +"(let-values()" +"(let-values(((i-frame-id_0)" +"(internal-definition-context-frame-id" +" intdef_12)))" +"(if(if frame-id_11" +"(if i-frame-id_0" +"(not" +"(eq?" +" frame-id_11" +" i-frame-id_0))" +" #f)" +" #f)" +"(let-values()" +" 'all)" +"(let-values()" +"(let-values(((or-part_284)" +" frame-id_11))" +"(if or-part_284" +" or-part_284" +" i-frame-id_0))))))))" +"(values" +" frame-id_12)))))" +"(if(not #f)" +"(for-loop_258" +" frame-id_10" +"(cdr a_56))" +" frame-id_10)))" +" frame-id_9)))))" +" for-loop_258)" +"(root-expand-context-frame-id ctx_45)" +" x_5))))" +"((post-expansion73_0)" +"(let-values(((pe_2)" +"(if same-kind?_0" +"(if(let-values(((or-part_285)(pair? context_9)))" +"(if or-part_285" +" or-part_285" +"(memq" +" context_9" +" '(module module-begin top-level))))" +"(root-expand-context-post-expansion ctx_45)" +" #f)" +" #f)))" +"(if(if intdefs_2(not(null? intdefs_2)) #f)" +"(let-values()" +"(lambda(s_225)" +"(begin" +" 'post-expansion73" +"(let-values(((temp79_0)(apply-post-expansion pe_2 s_225))" +"((intdefs80_0) intdefs_2))" +"(add-intdef-scopes24.1" +" unsafe-undefined" +" #f" +" temp79_0" +" intdefs80_0)))))" +"(let-values() pe_2))))" +"((scopes74_0)(append def-ctx-scopes_5(expand-context-scopes ctx_45)))" +"((only-immediate?75_0)(not stop-ids_1))" +"((current-introduction-scopes76_0) null)" +"((need-eventually-defined77_0)" +"(let-values(((ht_135)" +"(expand-context-need-eventually-defined ctx_45)))" +"(if track-to-be-defined?_0" +"(let-values() ht_135)" +"(if ht_135(let-values()(make-hasheqv))(let-values() #f)))))" +"((inner78_0)" +"(let-values(((the-struct_67)" +"(root-expand-context/outer-inner v_194)))" +"(if(expand-context/inner? the-struct_67)" +"(let-values(((to-parsed?81_0)" +"(if to-parsed-ok?_0" +"(expand-context-to-parsed? ctx_45)" +" #f))" +"((just-once?82_0) #f)" +"((in-local-expand?83_0) #t)" +"((keep-#%expression?84_0) keep-#%expression?_1)" +"((stops85_0)" +"(free-id-set" +" phase_110" +"(let-values(((or-part_286) all-stop-ids_0))" +"(if or-part_286 or-part_286 null)))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_67)" +"(root-expand-context/inner-module-scopes the-struct_67)" +"(root-expand-context/inner-top-level-bind-scope the-struct_67)" +"(root-expand-context/inner-all-scopes-stx the-struct_67)" +"(root-expand-context/inner-defined-syms the-struct_67)" +"(root-expand-context/inner-counter the-struct_67)" +"(root-expand-context/inner-lift-key the-struct_67)" +" to-parsed?81_0" +"(expand-context/inner-phase the-struct_67)" +"(expand-context/inner-namespace the-struct_67)" +" just-once?82_0" +"(expand-context/inner-module-begin-k the-struct_67)" +"(expand-context/inner-allow-unbound? the-struct_67)" +" in-local-expand?83_0" +" keep-#%expression?84_0" +" stops85_0" +"(expand-context/inner-declared-submodule-names the-struct_67)" +"(expand-context/inner-lifts the-struct_67)" +"(expand-context/inner-lift-envs the-struct_67)" +"(expand-context/inner-module-lifts the-struct_67)" +"(expand-context/inner-require-lifts the-struct_67)" +"(expand-context/inner-to-module-lifts the-struct_67)" +"(expand-context/inner-requires+provides the-struct_67)" +"(expand-context/inner-observer the-struct_67)" +"(expand-context/inner-for-serializable? the-struct_67)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_67)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_67)))))" +"(expand-context/outer1.1" +" inner78_0" +" post-expansion73_0" +" use-site-scopes71_0" +" frame-id72_0" +" context69_0" +" env70_0" +" scopes74_0" +"(expand-context/outer-def-ctx-scopes the-struct_66)" +"(expand-context/outer-binding-layer the-struct_66)" +"(expand-context/outer-reference-records the-struct_66)" +" only-immediate?75_0" +" need-eventually-defined77_0" +" current-introduction-scopes76_0" +"(expand-context/outer-current-use-scopes the-struct_66)" +"(expand-context/outer-name the-struct_66)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_66)))))))))))))))))))" +"(define-values" +"(flip-introduction-scopes)" +"(lambda(s_429 ctx_46)(begin(flip-scopes s_429(expand-context-current-introduction-scopes ctx_46)))))" +"(define-values" +"(flip-introduction-and-use-scopes)" +"(lambda(s_229 ctx_47)" +"(begin(flip-scopes(flip-introduction-scopes s_229 ctx_47)(expand-context-current-use-scopes ctx_47)))))" +"(define-values" +"(1/syntax-transforming?)" +"(lambda()" +"(begin" +" 'syntax-transforming?" +"(if(let-values(((temp55_1) #t))(get-current-expand-context16.1 temp55_1 'unexpected)) #t #f))))" +"(define-values" +"(1/syntax-transforming-with-lifts?)" +"(lambda()" +"(begin" +" 'syntax-transforming-with-lifts?" +"(let-values(((ctx_48)(let-values(((temp56_3) #t))(get-current-expand-context16.1 temp56_3 'unexpected))))" +"(if ctx_48(if(expand-context-lifts ctx_48) #t #f) #f)))))" +"(define-values" +"(1/syntax-transforming-module-expression?)" +"(lambda()" +"(begin" +" 'syntax-transforming-module-expression?" +"(let-values(((ctx_49)(let-values(((temp57_1) #t))(get-current-expand-context16.1 temp57_1 'unexpected))))" +"(if ctx_49(if(expand-context-to-module-lifts ctx_49) #t #f) #f)))))" +"(define-values" +"(1/syntax-local-transforming-module-provides?)" +"(lambda()" +"(begin" +" 'syntax-local-transforming-module-provides?" +"(let-values(((ctx_50)(let-values(((temp58_1) #t))(get-current-expand-context16.1 temp58_1 'unexpected))))" +"(if ctx_50(if(expand-context-requires+provides ctx_50) #t #f) #f)))))" +"(define-values" +"(1/syntax-local-context)" +"(lambda()" +"(begin" +" 'syntax-local-context" +"(let-values(((ctx_51)" +"(let-values(((temp59_3) 'syntax-local-context))(get-current-expand-context16.1 #f temp59_3))))" +"(expand-context-context ctx_51)))))" +"(define-values" +"(1/syntax-local-introduce)" +"(lambda(s_430)" +"(begin" +" 'syntax-local-introduce" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_430)" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-introduce \"syntax?\" s_430)))" +"(values))))" +"(let-values(((ctx_9)" +"(let-values(((temp61_2) 'syntax-local-introduce))" +"(get-current-expand-context16.1 #f temp61_2))))" +"(flip-introduction-and-use-scopes s_430 ctx_9))))))))" +"(define-values" +"(1/syntax-local-identifier-as-binding)" +"(lambda(id_76)" +"(begin" +" 'syntax-local-identifier-as-binding" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? id_76)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-local-identifier-as-binding \"identifier?\" id_76)))" +"(values))))" +"(let-values(((ctx_52)" +"(let-values(((temp63_2) 'syntax-local-identifier-as-binding))" +"(get-current-expand-context16.1 #f temp63_2))))" +"(remove-use-site-scopes id_76 ctx_52))))))))" +"(define-values" +"(1/syntax-local-phase-level)" +"(lambda()" +"(begin" +" 'syntax-local-phase-level" +"(let-values(((ctx_53)(let-values(((temp64_2) #t))(get-current-expand-context16.1 temp64_2 'unexpected))))" +"(if ctx_53(expand-context-phase ctx_53) 0)))))" +"(define-values" +"(1/syntax-local-name)" +"(lambda()" +"(begin" +" 'syntax-local-name" +"(let-values()" +"(let-values()" +"(let-values(((ctx_54)" +"(let-values(((who66_0) 'syntax-local-name))(get-current-expand-context16.1 #f who66_0))))" +"(let-values(((id_77)(expand-context-name ctx_54)))" +"(if id_77(datum->syntax$1 #f(syntax-e$1 id_77) id_77) #f))))))))" +"(define-values" +"(1/make-syntax-introducer)" +"(let-values(((make-syntax-introducer2_0)" +"(lambda(as-use-site?1_0)" +"(begin" +" 'make-syntax-introducer2" +"(let-values(((as-use-site?_0) as-use-site?1_0))" +"(let-values()(do-make-syntax-introducer(new-scope(if as-use-site?_0 'use-site 'macro)))))))))" +"(case-lambda" +"(()(begin 'make-syntax-introducer(make-syntax-introducer2_0 #f)))" +"((as-use-site?1_1)(make-syntax-introducer2_0 as-use-site?1_1)))))" +"(define-values" +"(1/make-interned-syntax-introducer)" +"(lambda(sym-key_0)" +"(begin" +" 'make-interned-syntax-introducer" +"(let-values()" +"(let-values()" +"(begin" +"(if(symbol? sym-key_0)" +"(void)" +" (let-values () (raise-argument-error 'make-interned-syntax-introducer \"symbol?\" sym-key_0)))" +"(do-make-syntax-introducer(make-interned-scope sym-key_0))))))))" +"(define-values" +"(do-make-syntax-introducer)" +"(lambda(sc_34)" +"(begin" +"(let-values(((core70_0)" +"(lambda(s69_0 mode68_0)" +"(begin" +" 'core70" +"(let-values(((s_431) s69_0))" +"(let-values(((mode_14) mode68_0))" +"(let-values()" +"(begin" +"(if(syntax?$1 s_431)" +"(void)" +" (let-values () (raise-argument-error 'syntax-introducer \"syntax?\" s_431)))" +"(let-values(((tmp_33) mode_14))" +"(if(equal? tmp_33 'add)" +"(let-values()(add-scope s_431 sc_34))" +"(if(equal? tmp_33 'remove)" +"(let-values()(remove-scope s_431 sc_34))" +"(if(equal? tmp_33 'flip)" +"(let-values()(flip-scope s_431 sc_34))" +"(let-values()" +"(raise-argument-error" +" 'syntax-introducer" +" \"(or/c 'add 'remove 'flip)\"" +" mode_14))))))))))))))" +"(case-lambda((s_190)(core70_0 s_190 'flip))((s_90 mode68_1)(core70_0 s_90 mode68_1)))))))" +"(define-values" +"(1/make-syntax-delta-introducer)" +"(let-values(((make-syntax-delta-introducer7_0)" +"(lambda(ext-s5_0 base-s6_0 phase4_0)" +"(begin" +" 'make-syntax-delta-introducer7" +"(let-values(((ext-s_0) ext-s5_0))" +"(let-values(((base-s_0) base-s6_0))" +"(let-values(((phase_5)" +"(if(eq? phase4_0 unsafe-undefined)(1/syntax-local-phase-level) phase4_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 ext-s_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-syntax-delta-introducer" +" \"syntax?\"" +" ext-s_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if((lambda(x_19)" +"(let-values(((or-part_287)(not x_19)))" +"(if or-part_287 or-part_287(syntax?$1 x_19))))" +" base-s_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-syntax-delta-introducer" +" \"(or/c syntax? #f)\"" +" base-s_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(phase? phase_5)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-syntax-delta-introducer" +" phase?-string" +" phase_5)))" +"(values))))" +"(let-values(((ext-scs_0)(syntax-scope-set ext-s_0 phase_5)))" +"(let-values(((base-scs_0)" +"(syntax-scope-set" +"(let-values(((or-part_22) base-s_0))" +"(if or-part_22 or-part_22 empty-syntax))" +" phase_5)))" +"(let-values(((use-base-scs_0)" +"(if(subset? base-scs_0 ext-scs_0)" +" base-scs_0" +"(let-values(((or-part_288)" +"(if(identifier? base-s_0)" +"(let-values(((base-s73_0) base-s_0)" +"((phase74_1) phase_5)" +"((temp75_1) #t))" +"(resolve40.1" +" #f" +" #f" +" null" +" temp75_1" +" base-s73_0" +" phase74_1))" +" #f)))" +"(if or-part_288 or-part_288(seteq))))))" +"(let-values(((delta-scs_0)" +"(set->list(set-subtract ext-scs_0 use-base-scs_0))))" +"(let-values(((maybe-taint_0)" +"(if(syntax-clean? ext-s_0) values syntax-taint$1)))" +"(let-values(((core78_0)" +"(lambda(s77_1 mode76_0)" +"(begin" +" 'core78" +"(let-values(((s_11) s77_1))" +"(let-values(((mode_15) mode76_0))" +"(let-values()" +"(maybe-taint_0" +"(let-values(((tmp_34) mode_15))" +"(if(equal? tmp_34 'add)" +"(let-values()" +"(add-scopes s_11 delta-scs_0))" +"(if(equal? tmp_34 'remove)" +"(let-values()" +"(remove-scopes s_11 delta-scs_0))" +"(if(equal? tmp_34 'flip)" +"(let-values()" +"(flip-scopes s_11 delta-scs_0))" +"(let-values()" +"(raise-argument-error" +" 'syntax-introducer" +" \"(or/c 'add 'remove 'flip)\"" +" mode_15))))))))))))))" +"(case-lambda" +"((s_92)(core78_0 s_92 'add))" +"((s_12 mode76_1)(core78_0 s_12 mode76_1))))))))))))))))))))))" +"(case-lambda" +"((ext-s_1 base-s_1)" +"(begin 'make-syntax-delta-introducer(make-syntax-delta-introducer7_0 ext-s_1 base-s_1 unsafe-undefined)))" +"((ext-s_2 base-s_2 phase4_1)(make-syntax-delta-introducer7_0 ext-s_2 base-s_2 phase4_1)))))" +"(define-values" +"(1/syntax-local-make-delta-introducer)" +"(lambda(id-stx_1)" +"(begin" +" 'syntax-local-make-delta-introducer" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id-stx_1)" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-make-delta-introducer \"identifier?\" id-stx_1)))" +"(raise" +"(exn:fail:unsupported" +" \"syntax-local-make-delta-introducer: not supported anymore\"" +"(current-continuation-marks)))))))))" +"(define-values" +"(do-syntax-local-value15.1)" +"(lambda(immediate?9_0 who11_0 id12_0 intdefs13_0 failure-thunk14_0)" +"(begin" +" 'do-syntax-local-value15" +"(let-values(((who_19) who11_0))" +"(let-values(((id_78) id12_0))" +"(let-values(((intdefs_3) intdefs13_0))" +"(let-values(((failure-thunk_0) failure-thunk14_0))" +"(let-values(((immediate?_1) immediate?9_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? id_78)" +"(void)" +" (let-values () (raise-argument-error who_19 \"identifier?\" id_78)))" +"(values))))" +"(let-values((()" +"(begin" +"(if((lambda(x_81)" +"(let-values(((or-part_210)(not x_81)))" +"(if or-part_210" +" or-part_210" +"((lambda(p_50)" +"(if(procedure? p_50)(procedure-arity-includes? p_50 0) #f))" +" x_81))))" +" failure-thunk_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_19" +" \"(or/c #f (procedure-arity-includes/c 0))\"" +" failure-thunk_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(intdefs-or-false? intdefs_3)" +"(void)" +"(let-values()" +"(raise-argument-error who_19 intdefs-or-false?-string intdefs_3)))" +"(values))))" +"(let-values(((current-ctx_0)" +"(let-values(((who81_0) who_19))(get-current-expand-context16.1 #f who81_0))))" +"(let-values(((ctx_11)" +"(if intdefs_3" +"(let-values(((v_195) current-ctx_0))" +"(let-values(((the-struct_68) v_195))" +"(if(expand-context/outer? the-struct_68)" +"(let-values(((env82_0)" +"(add-intdef-bindings" +"(expand-context-env current-ctx_0)" +" intdefs_3))" +"((inner83_0)(root-expand-context/outer-inner v_195)))" +"(expand-context/outer1.1" +" inner83_0" +"(root-expand-context/outer-post-expansion the-struct_68)" +"(root-expand-context/outer-use-site-scopes the-struct_68)" +"(root-expand-context/outer-frame-id the-struct_68)" +"(expand-context/outer-context the-struct_68)" +" env82_0" +"(expand-context/outer-scopes the-struct_68)" +"(expand-context/outer-def-ctx-scopes the-struct_68)" +"(expand-context/outer-binding-layer the-struct_68)" +"(expand-context/outer-reference-records the-struct_68)" +"(expand-context/outer-only-immediate? the-struct_68)" +"(expand-context/outer-need-eventually-defined the-struct_68)" +"(expand-context/outer-current-introduction-scopes the-struct_68)" +"(expand-context/outer-current-use-scopes the-struct_68)" +"(expand-context/outer-name the-struct_68)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_68))))" +" current-ctx_0)))" +"(let-values((()" +"(begin" +"(let-values(((obs_34)(expand-context-observer ctx_11)))" +"(if obs_34" +"(let-values()" +"(let-values()(call-expand-observe obs_34 'local-value id_78)))" +"(void)))" +"(values))))" +"(let-values(((phase_72)(expand-context-phase ctx_11)))" +"((letrec-values(((loop_98)" +"(lambda(id_62)" +"(begin" +" 'loop" +"(let-values(((b_83)" +"(if immediate?_1" +"(let-values(((id84_0) id_62)" +"((phase85_0) phase_72)" +"((temp86_0) #t))" +"(resolve+shift28.1" +" #f" +" #f" +" null" +" temp86_0" +" #f" +" id84_0" +" phase85_0))" +"(resolve+shift/extra-inspector" +" id_62" +" phase_72" +"(expand-context-namespace ctx_11)))))" +"(begin" +"(let-values(((obs_35)(expand-context-observer ctx_11)))" +"(if obs_35" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_35 'resolve id_62)))" +"(void)))" +"(if(not b_83)" +"(let-values()" +"(begin" +"(let-values(((obs_36)" +"(expand-context-observer ctx_11)))" +"(if obs_36" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_36" +" 'local-value-result" +" #f)))" +"(void)))" +"(if failure-thunk_0" +"(failure-thunk_0)" +" (error who_19 \"unbound identifier: ~v\" id_62))))" +"(let-values()" +"(let-values(((v_39 primitive?_7 insp_17 protected?_8)" +"(let-values(((b87_0) b_83)" +"((ctx88_0) ctx_11)" +"((id89_0) id_62)" +"((temp90_0) #t))" +"(lookup62.1" +" #f" +" temp90_0" +" b87_0" +" ctx88_0" +" id89_0))))" +"(if(let-values(((or-part_101)(variable? v_39)))" +"(if or-part_101 or-part_101(core-form? v_39)))" +"(let-values()" +"(begin" +"(let-values(((obs_37)" +"(expand-context-observer ctx_11)))" +"(if obs_37" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_37" +" 'local-value-result" +" #f)))" +"(void)))" +"(if failure-thunk_0" +"(failure-thunk_0)" +"(error" +" who_19" +" \"identifier is not bound to syntax: ~v\"" +" id_62))))" +"(let-values()" +"(begin" +"(let-values(((obs_38)" +"(expand-context-observer ctx_11)))" +"(if obs_38" +"(let-values()" +"(if(not" +"(if(1/rename-transformer? v_39)" +"(not immediate?_1)" +" #f))" +"(let-values()" +"(call-expand-observe" +" obs_38" +" 'local-value-result" +" #t))" +"(void)))" +"(void)))" +"(if(1/rename-transformer? v_39)" +"(let-values()" +"(if immediate?_1" +"(values" +" v_39" +"(1/rename-transformer-target v_39))" +"(loop_98" +"(1/rename-transformer-target v_39))))" +"(if immediate?_1" +"(let-values()(values v_39 #f))" +"(let-values() v_39)))))))))))))))" +" loop_98)" +"(flip-introduction-scopes id_78 ctx_11))))))))))))))))))" +"(define-values" +"(1/syntax-local-value)" +"(let-values(((syntax-local-value21_0)" +"(lambda(id20_0 failure-thunk18_0 intdef19_0)" +"(begin" +" 'syntax-local-value21" +"(let-values(((id_79) id20_0))" +"(let-values(((failure-thunk_1) failure-thunk18_0))" +"(let-values(((intdef_13) intdef19_0))" +"(let-values()" +"(let-values(((temp91_1) 'syntax-local-value)" +"((temp92_1) #f)" +"((id93_1) id_79)" +"((intdef94_0) intdef_13)" +"((failure-thunk95_0) failure-thunk_1))" +"(do-syntax-local-value15.1 temp92_1 temp91_1 id93_1 intdef94_0 failure-thunk95_0))))))))))" +"(case-lambda" +"((id_80)(begin 'syntax-local-value(syntax-local-value21_0 id_80 #f #f)))" +"((id_63 failure-thunk_2 intdef19_1)(syntax-local-value21_0 id_63 failure-thunk_2 intdef19_1))" +"((id_81 failure-thunk18_1)(syntax-local-value21_0 id_81 failure-thunk18_1 #f)))))" +"(define-values" +"(1/syntax-local-value/immediate)" +"(let-values(((syntax-local-value/immediate26_0)" +"(lambda(id25_2 failure-thunk23_0 intdef24_0)" +"(begin" +" 'syntax-local-value/immediate26" +"(let-values(((id_82) id25_2))" +"(let-values(((failure-thunk_3) failure-thunk23_0))" +"(let-values(((intdef_14) intdef24_0))" +"(let-values()" +"(let-values(((temp96_1) 'syntax-local-value/immediate)" +"((temp97_1) #t)" +"((id98_0) id_82)" +"((intdef99_0) intdef_14)" +"((failure-thunk100_0) failure-thunk_3))" +"(do-syntax-local-value15.1" +" temp97_1" +" temp96_1" +" id98_0" +" intdef99_0" +" failure-thunk100_0))))))))))" +"(case-lambda" +"((id_83)(begin 'syntax-local-value/immediate(syntax-local-value/immediate26_0 id_83 #f #f)))" +"((id_84 failure-thunk_4 intdef24_1)(syntax-local-value/immediate26_0 id_84 failure-thunk_4 intdef24_1))" +"((id_85 failure-thunk23_1)(syntax-local-value/immediate26_0 id_85 failure-thunk23_1 #f)))))" +"(define-values" +"(do-lift-values-expression)" +"(lambda(who_20 n_29 s_34)" +"(begin" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_34) (void) (let-values () (raise-argument-error who_20 \"syntax?\" s_34)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? n_29)" +"(void)" +" (let-values () (raise-argument-error who_20 \"exact-nonnegative-integer?\" n_29)))" +"(values))))" +"(let-values(((ctx_55)(let-values(((who101_0) who_20))(get-current-expand-context16.1 #f who101_0))))" +"(let-values(((lifts_8)(expand-context-lifts ctx_55)))" +"(let-values((()" +"(begin" +" (if lifts_8 (void) (let-values () (raise-arguments-error who_20 \"no lift target\")))" +"(values))))" +"(let-values(((counter_4)(root-expand-context-counter ctx_55)))" +"(let-values(((ids_27)" +"(reverse$1" +"(let-values(((start_39) 0)((end_29) n_29)((inc_23) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_39 end_29 inc_23)))" +"((letrec-values(((for-loop_221)" +"(lambda(fold-var_253 pos_106)" +"(begin" +" 'for-loop" +"(if(< pos_106 end_29)" +"(let-values()" +"(let-values(((fold-var_254)" +"(let-values(((fold-var_255) fold-var_253))" +"(let-values(((fold-var_256)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(set-box!" +" counter_4" +"(add1" +"(unbox" +" counter_4)))" +"(values))))" +"(let-values(((name_61)" +"(string->unreadable-symbol" +"(format" +" \"lifted/~a\"" +"(unbox" +" counter_4)))))" +"(add-scope" +"(datum->syntax$1" +" #f" +" name_61)" +"(new-scope" +" 'macro)))))" +" fold-var_255))))" +"(values fold-var_256)))))" +"(if(not #f)" +"(for-loop_221 fold-var_254(+ pos_106 inc_23))" +" fold-var_254)))" +" fold-var_253)))))" +" for-loop_221)" +" null" +" start_39))))))" +"(begin" +"(let-values(((obs_39)(expand-context-observer ctx_55)))" +"(if obs_39" +"(let-values()(let-values()(call-expand-observe obs_39 'lift-expr ids_27 s_34)))" +"(void)))" +"(map2" +"(lambda(id_86)(flip-introduction-scopes id_86 ctx_55))" +"(add-lifted!" +" lifts_8" +" ids_27" +"(flip-introduction-scopes s_34 ctx_55)" +"(expand-context-phase ctx_55))))))))))))))" +"(define-values" +"(1/syntax-local-lift-expression)" +"(lambda(s_36)" +"(begin" +" 'syntax-local-lift-expression" +"(let-values()(let-values()(car(do-lift-values-expression 'syntax-local-lift-expression 1 s_36)))))))" +"(define-values" +"(1/syntax-local-lift-values-expression)" +"(lambda(n_30 s_63)" +"(begin" +" 'syntax-local-lift-values-expression" +"(let-values()(let-values()(do-lift-values-expression 'syntax-local-lift-values-expression n_30 s_63))))))" +"(define-values" +"(1/syntax-local-lift-context)" +"(lambda()" +"(begin" +" 'syntax-local-lift-context" +"(let-values()" +"(let-values()" +"(let-values(((ctx_56)" +"(let-values(((who105_0) 'syntax-local-lift-context))" +"(get-current-expand-context16.1 #f who105_0))))" +"(root-expand-context-lift-key ctx_56)))))))" +"(define-values" +"(1/syntax-local-lift-module)" +"(lambda(s_64)" +"(begin" +" 'syntax-local-lift-module" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_64)" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-lift-module \"syntax?\" s_64)))" +"(values))))" +"(let-values(((ctx_57)" +"(let-values(((who107_0) 'syntax-local-lift-module))" +"(get-current-expand-context16.1 #f who107_0))))" +"(let-values(((phase_102)(expand-context-phase ctx_57)))" +"(begin" +"(let-values(((tmp_30)(core-form-sym s_64 phase_102)))" +"(if(if(equal? tmp_30 'module) #t(equal? tmp_30 'module*))" +"(let-values()" +"(let-values(((lifts_9)(expand-context-module-lifts ctx_57)))" +"(begin" +"(if lifts_9" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-lift-module" +" \"not currently transforming within a module declaration or top level\"" +" \"form to lift\"" +" s_64)))" +"(add-lifted-module! lifts_9(flip-introduction-scopes s_64 ctx_57) phase_102))))" +"(let-values()" +" (raise-arguments-error 'syntax-local-lift-module \"not a module form\" \"given form\" s_64))))" +"(let-values(((obs_40)(expand-context-observer ctx_57)))" +"(if obs_40" +"(let-values()(let-values()(call-expand-observe obs_40 'lift-statement s_64)))" +"(void))))))))))))" +"(define-values" +"(do-local-lift-to-module48.1)" +"(lambda(add-lifted!32_0" +" get-lift-ctx31_0" +" get-wrt-phase33_0" +" intro?29_0" +" more-checks30_0" +" no-target-msg28_0" +" post-wrap36_0" +" pre-wrap34_0" +" shift-wrap35_0" +" who46_0" +" s47_0)" +"(begin" +" 'do-local-lift-to-module48" +"(let-values(((who_21) who46_0))" +"(let-values(((s_432) s47_0))" +"(let-values(((no-target-msg_0) no-target-msg28_0))" +"(let-values(((intro?_0) intro?29_0))" +"(let-values(((more-checks_0)(if(eq? more-checks30_0 unsafe-undefined) void more-checks30_0)))" +"(let-values(((get-lift-ctx_0) get-lift-ctx31_0))" +"(let-values(((add-lifted!_0) add-lifted!32_0))" +"(let-values(((get-wrt-phase_0) get-wrt-phase33_0))" +"(let-values(((pre-wrap_0)" +"(if(eq? pre-wrap34_0 unsafe-undefined)" +"(lambda(s_433 phase_111 lift-ctx_1)(begin 'pre-wrap s_433))" +" pre-wrap34_0)))" +"(let-values(((shift-wrap_0)" +"(if(eq? shift-wrap35_0 unsafe-undefined)" +"(lambda(s_210 phase_112 lift-ctx_2)(begin 'shift-wrap s_210))" +" shift-wrap35_0)))" +"(let-values(((post-wrap_0)" +"(if(eq? post-wrap36_0 unsafe-undefined)" +"(lambda(s_211 phase_12 lift-ctx_3)(begin 'post-wrap s_211))" +" post-wrap36_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_432)" +"(void)" +" (let-values () (raise-argument-error who_21 \"syntax?\" s_432)))" +"(values))))" +"(let-values((()(begin(more-checks_0)(values))))" +"(let-values(((ctx_58)" +"(let-values(((who108_0) who_21))" +"(get-current-expand-context16.1 #f who108_0))))" +"(let-values(((lift-ctx_4)(get-lift-ctx_0 ctx_58)))" +"(let-values((()" +"(begin" +"(if lift-ctx_4" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_21" +" no-target-msg_0" +" \"form to lift\"" +" s_432)))" +"(values))))" +"(let-values(((phase_90)(expand-context-phase ctx_58)))" +"(let-values(((wrt-phase_1)(get-wrt-phase_0 lift-ctx_4)))" +"(let-values(((added-s_0)" +"(if intro?_0(flip-introduction-scopes s_432 ctx_58) s_432)))" +"(let-values(((pre-s_0)(pre-wrap_0 added-s_0 phase_90 lift-ctx_4)))" +"(let-values(((shift-s_0)" +"(let-values(((start_40) phase_90)" +"((end_30) wrt-phase_1)" +"((inc_24) -1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_40 end_30 inc_24)))" +"((letrec-values(((for-loop_131)" +"(lambda(s_434 pos_107)" +"(begin" +" 'for-loop" +"(if(> pos_107 end_30)" +"(let-values(((phase_113)" +" pos_107))" +"(let-values(((s_321)" +"(let-values(((s_435)" +" s_434))" +"(let-values(((s_436)" +"(let-values()" +"(shift-wrap_0" +" s_435" +"(sub1" +" phase_113)" +" lift-ctx_4))))" +"(values" +" s_436)))))" +"(if(not #f)" +"(for-loop_131" +" s_321" +"(+ pos_107 inc_24))" +" s_321)))" +" s_434)))))" +" for-loop_131)" +" pre-s_0" +" start_40)))))" +"(let-values(((post-s_1)" +"(post-wrap_0 shift-s_0 wrt-phase_1 lift-ctx_4)))" +"(begin" +"(add-lifted!_0 lift-ctx_4 post-s_1 wrt-phase_1)" +"(values ctx_58 post-s_1))))))))))))))))))))))))))))" +"(define-values" +"(1/syntax-local-lift-require)" +"(lambda(s_218 use-s_1)" +"(begin" +" 'syntax-local-lift-require" +"(let-values()" +"(let-values()" +"(let-values(((sc_35)(new-scope 'lifted-require)))" +"(let-values(((ctx_59 added-s_1)" +"(let-values(((who110_0) 'syntax-local-lift-require)" +"((temp111_0)(datum->syntax$1 #f s_218))" +" ((temp112_0) \"could not find target context\")" +"((temp113_0) #f)" +"((temp114_1)" +"(lambda()" +"(if(syntax?$1 use-s_1)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-local-lift-require \"syntax?\" use-s_1)))))" +"((expand-context-require-lifts115_0) expand-context-require-lifts)" +"((require-lift-context-wrt-phase116_0) require-lift-context-wrt-phase)" +"((add-lifted-require!117_0) add-lifted-require!)" +"((temp118_0)" +"(lambda(s_110 phase_114 require-lift-ctx_0)" +"(require-spec-shift-for-syntax s_110)))" +"((temp119_0)" +"(lambda(s_437 phase_115 require-lift-ctx_1)" +"(wrap-form '#%require(add-scope s_437 sc_35) phase_115))))" +"(do-local-lift-to-module48.1" +" add-lifted-require!117_0" +" expand-context-require-lifts115_0" +" require-lift-context-wrt-phase116_0" +" temp113_0" +" temp114_1" +" temp112_0" +" temp119_0" +" unsafe-undefined" +" temp118_0" +" who110_0" +" temp111_0))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +"(expand-context-namespace ctx_59)" +"(expand-context-phase ctx_59))" +"(values))))" +"(let-values(((result-s_6)(add-scope use-s_1 sc_35)))" +"(begin" +"(let-values(((obs_41)(expand-context-observer ctx_59)))" +"(if obs_41" +"(let-values()" +"(let-values()(call-expand-observe obs_41 'lift-require added-s_1 use-s_1 result-s_6)))" +"(void)))" +" result-s_6))))))))))" +"(define-values" +"(1/syntax-local-lift-provide)" +"(lambda(s_161)" +"(begin" +" 'syntax-local-lift-provide" +"(let-values()" +"(let-values()" +"(let-values(((ctx_60 result-s_7)" +"(let-values(((who121_0) 'syntax-local-lift-provide)" +"((s122_1) s_161)" +" ((temp123_0) \"not expanding in a module run-time body\")" +"((expand-context-to-module-lifts124_0) expand-context-to-module-lifts)" +"((to-module-lift-context-wrt-phase125_0) to-module-lift-context-wrt-phase)" +"((add-lifted-to-module-provide!126_0) add-lifted-to-module-provide!)" +"((temp127_2)" +"(lambda(s_438 phase_116 to-module-lift-ctx_0)(wrap-form 'for-syntax s_438 #f)))" +"((temp128_2)" +"(lambda(s_116 phase_117 to-module-lift-ctx_1)" +"(wrap-form '#%provide s_116 phase_117))))" +"(do-local-lift-to-module48.1" +" add-lifted-to-module-provide!126_0" +" expand-context-to-module-lifts124_0" +" to-module-lift-context-wrt-phase125_0" +" #t" +" unsafe-undefined" +" temp123_0" +" temp128_2" +" unsafe-undefined" +" temp127_2" +" who121_0" +" s122_1))))" +"(let-values(((obs_42)(expand-context-observer ctx_60)))" +"(if obs_42" +"(let-values()(let-values()(call-expand-observe obs_42 'lift-provide result-s_7)))" +"(void)))))))))" +"(define-values" +"(1/syntax-local-lift-module-end-declaration)" +"(lambda(s_225)" +"(begin" +" 'syntax-local-lift-module-end-declaration" +"(let-values()" +"(let-values()" +"(let-values(((ctx_61 also-s_0)" +"(let-values(((who130_0) 'syntax-local-lift-module-end-declaration)" +"((s131_0) s_225)" +"((temp132_1)" +" \"not currently transforming an expression within a module declaration\")" +"((expand-context-to-module-lifts133_0) expand-context-to-module-lifts)" +"((temp134_1)(lambda(lift-ctx_5) 0))" +"((add-lifted-to-module-end!135_0) add-lifted-to-module-end!)" +"((temp136_0)" +"(lambda(orig-s_32 phase_118 to-module-lift-ctx_2)" +"(if(to-module-lift-context-end-as-expressions? to-module-lift-ctx_2)" +"(wrap-form '#%expression orig-s_32 phase_118)" +" orig-s_32)))" +"((temp137_1)" +"(lambda(s_439 phase_119 to-module-lift-ctx_3)" +"(wrap-form 'begin-for-syntax s_439 phase_119))))" +"(do-local-lift-to-module48.1" +" add-lifted-to-module-end!135_0" +" expand-context-to-module-lifts133_0" +" temp134_1" +" #t" +" unsafe-undefined" +" temp132_1" +" unsafe-undefined" +" temp136_0" +" temp137_1" +" who130_0" +" s131_0))))" +"(let-values(((obs_43)(expand-context-observer ctx_61)))" +"(if obs_43" +"(let-values()(let-values()(call-expand-observe obs_43 'lift-statement s_225)))" +"(void)))))))))" +"(define-values" +"(wrap-form)" +"(lambda(sym_74 s_124 phase_120)" +"(begin" +"(datum->syntax$1" +" #f" +"(list(datum->syntax$1(if phase_120(syntax-shift-phase-level$1 core-stx phase_120) #f) sym_74) s_124)))))" +"(define-values" +"(1/syntax-local-module-defined-identifiers)" +"(lambda()" +"(begin" +" 'syntax-local-module-defined-identifiers" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/syntax-local-transforming-module-provides?)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-module-defined-identifiers" +" \"not currently transforming module provides\")))" +"(values))))" +"(let-values(((ctx_62)" +"(let-values(((temp139_0) 'syntax-local-module-defined-identifiers))" +"(get-current-expand-context16.1 #f temp139_0))))" +"(requireds->phase-ht(extract-module-definitions(expand-context-requires+provides ctx_62))))))))))" +"(define-values" +"(1/syntax-local-module-required-identifiers)" +"(lambda(mod-path_8 phase-level_21)" +"(begin" +" 'syntax-local-module-required-identifiers" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_289)(not mod-path_8)))" +"(if or-part_289 or-part_289(1/module-path? mod-path_8)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-required-identifiers" +" \"(or/c module-path? #f)\"" +" mod-path_8)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_290)(eq? phase-level_21 #t)))" +"(if or-part_290 or-part_290(phase? phase-level_21)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-required-identifiers" +" (format \"(or/c ~a #t)\" phase?-string)" +" phase-level_21)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/syntax-local-transforming-module-provides?)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-module-required-identifiers" +" \"not currently transforming module provides\")))" +"(values))))" +"(let-values(((ctx_63)" +"(let-values(((temp141_1) 'syntax-local-module-required-identifiers))" +"(get-current-expand-context16.1 #f temp141_1))))" +"(let-values(((requires+provides_5)(expand-context-requires+provides ctx_63)))" +"(let-values(((mpi_44)(if mod-path_8(module-path->mpi/context mod-path_8 ctx_63) #f)))" +"(let-values(((requireds_0)" +"(extract-all-module-requires" +" requires+provides_5" +" mpi_44" +"(if(eq? phase-level_21 #t) 'all phase-level_21))))" +"(if requireds_0" +"(reverse$1" +"(let-values(((ht_136)(requireds->phase-ht requireds_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_136)))" +"((letrec-values(((for-loop_259)" +"(lambda(fold-var_257 i_161)" +"(begin" +" 'for-loop" +"(if i_161" +"(let-values(((phase_121 ids_28)" +"(hash-iterate-key+value ht_136 i_161)))" +"(let-values(((fold-var_207)" +"(let-values(((fold-var_258) fold-var_257))" +"(let-values(((fold-var_259)" +"(let-values()" +"(cons" +"(let-values()" +"(cons phase_121 ids_28))" +" fold-var_258))))" +"(values fold-var_259)))))" +"(if(not #f)" +"(for-loop_259" +" fold-var_207" +"(hash-iterate-next ht_136 i_161))" +" fold-var_207)))" +" fold-var_257)))))" +" for-loop_259)" +" null" +"(hash-iterate-first ht_136)))))" +" #f)))))))))))))" +"(define-values" +"(requireds->phase-ht)" +"(lambda(requireds_1)" +"(begin" +"(let-values(((lst_296) requireds_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_296)))" +"((letrec-values(((for-loop_139)" +"(lambda(ht_137 lst_297)" +"(begin" +" 'for-loop" +"(if(pair? lst_297)" +"(let-values(((r_43)(unsafe-car lst_297))((rest_170)(unsafe-cdr lst_297)))" +"(let-values(((ht_138)" +"(let-values(((ht_139) ht_137))" +"(let-values(((ht_140)" +"(let-values()" +"(hash-update" +" ht_139" +"(required-phase r_43)" +"(lambda(l_71)(cons(required-id r_43) l_71))" +" null))))" +"(values ht_140)))))" +"(if(not #f)(for-loop_139 ht_138 rest_170) ht_138)))" +" ht_137)))))" +" for-loop_139)" +"(hasheqv)" +" lst_296))))))" +"(define-values" +"(1/syntax-local-module-exports)" +"(lambda(mod-path_9)" +"(begin" +" 'syntax-local-module-exports" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_291)(1/module-path? mod-path_9)))" +"(if or-part_291" +" or-part_291" +"(if(syntax?$1 mod-path_9)(1/module-path?(syntax->datum$1 mod-path_9)) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-exports" +"(string-append" +" \"(or/c module-path?\\n\"" +" \" (and/c syntax?\\n\"" +" \" (lambda (stx)\\n\"" +" \" (module-path? (syntax->datum stx)))))\")" +" mod-path_9)))" +"(values))))" +"(let-values(((ctx_64)" +"(let-values(((temp143_0) 'syntax-local-module-exports))" +"(get-current-expand-context16.1 #f temp143_0))))" +"(let-values(((ns_76)(expand-context-namespace ctx_64)))" +"(let-values(((mod-name_18)" +"(1/module-path-index-resolve" +"(module-path->mpi/context" +"(if(syntax?$1 mod-path_9)(syntax->datum$1 mod-path_9) mod-path_9)" +" ctx_64)" +" #t)))" +"(let-values(((m_19)(namespace->module ns_76 mod-name_18)))" +"(begin" +"(if m_19" +"(void)" +"(let-values()(raise-unknown-module-error 'syntax-local-module-exports mod-name_18)))" +"(reverse$1" +"(let-values(((ht_141)(module-provides m_19)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_141)))" +"((letrec-values(((for-loop_260)" +"(lambda(fold-var_260 i_162)" +"(begin" +" 'for-loop" +"(if i_162" +"(let-values(((phase_122 syms_21)" +"(hash-iterate-key+value ht_141 i_162)))" +"(let-values(((fold-var_261)" +"(let-values(((fold-var_262) fold-var_260))" +"(let-values(((fold-var_263)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_122" +"(reverse$1" +"(let-values(((ht_142)" +" syms_21))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys" +" ht_142)))" +"((letrec-values(((for-loop_261)" +"(lambda(fold-var_264" +" i_12)" +"(begin" +" 'for-loop" +"(if i_12" +"(let-values(((sym_75)" +"(hash-iterate-key" +" ht_142" +" i_12)))" +"(let-values(((fold-var_265)" +"(let-values(((fold-var_266)" +" fold-var_264))" +"(let-values(((fold-var_267)" +"(let-values()" +"(cons" +"(let-values()" +" sym_75)" +" fold-var_266))))" +"(values" +" fold-var_267)))))" +"(if(not" +" #f)" +"(for-loop_261" +" fold-var_265" +"(hash-iterate-next" +" ht_142" +" i_12))" +" fold-var_265)))" +" fold-var_264)))))" +" for-loop_261)" +" null" +"(hash-iterate-first" +" ht_142)))))))" +" fold-var_262))))" +"(values fold-var_263)))))" +"(if(not #f)" +"(for-loop_260 fold-var_261(hash-iterate-next ht_141 i_162))" +" fold-var_261)))" +" fold-var_260)))))" +" for-loop_260)" +" null" +"(hash-iterate-first ht_141))))))))))))))))" +"(define-values" +"(1/syntax-local-submodules)" +"(lambda()" +"(begin" +" 'syntax-local-submodules" +"(let-values()" +"(let-values()" +"(let-values(((ctx_65)" +"(let-values(((who145_0) 'syntax-local-submodules))" +"(get-current-expand-context16.1 #f who145_0))))" +"(let-values(((submods_3)(expand-context-declared-submodule-names ctx_65)))" +"(reverse$1" +"(let-values(((ht_143) submods_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_143)))" +"((letrec-values(((for-loop_262)" +"(lambda(fold-var_268 i_163)" +"(begin" +" 'for-loop" +"(if i_163" +"(let-values(((name_62 kind_8)(hash-iterate-key+value ht_143 i_163)))" +"(let-values(((fold-var_269)" +"(let-values(((fold-var_270) fold-var_268))" +"(if(eq? kind_8 'module)" +"(let-values(((fold-var_271) fold-var_270))" +"(let-values(((fold-var_272)" +"(let-values()" +"(cons" +"(let-values() name_62)" +" fold-var_271))))" +"(values fold-var_272)))" +" fold-var_270))))" +"(if(not #f)" +"(for-loop_262 fold-var_269(hash-iterate-next ht_143 i_163))" +" fold-var_269)))" +" fold-var_268)))))" +" for-loop_262)" +" null" +"(hash-iterate-first ht_143))))))))))))" +"(define-values" +"(1/syntax-local-get-shadower)" +"(let-values(((syntax-local-get-shadower53_0)" +"(lambda(id52_0 only-generated?51_0)" +"(begin" +" 'syntax-local-get-shadower53" +"(let-values(((id_87) id52_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? id_87)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-get-shadower" +" \"identifier?\"" +" id_87)))" +"(values))))" +"(let-values(((ctx_66)" +"(let-values(((who147_0) 'syntax-local-get-shadower))" +"(get-current-expand-context16.1 #f who147_0))))" +"(let-values(((new-id_0)(add-scopes id_87(expand-context-scopes ctx_66))))" +"(if(syntax-clean? id_87) new-id_0(syntax-taint$1 new-id_0))))))))))))))" +"(case-lambda" +"((id_88)(begin 'syntax-local-get-shadower(syntax-local-get-shadower53_0 id_88 #f)))" +"((id_89 only-generated?51_1)(syntax-local-get-shadower53_0 id_89 only-generated?51_1)))))" +"(define-values" +"(syntax-source-accessor)" +"(lambda(who_0 srcloc-accessor_0)" +"(begin" +"(lambda(s_189)" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_189) (void) (let-values () (raise-argument-error who_0 \"syntax?\" s_189)))" +"(values))))" +"(let-values(((srcloc_8)(syntax-srcloc s_189)))(if srcloc_8(srcloc-accessor_0 srcloc_8) #f)))))))" +"(define-values(1/syntax-source)(syntax-source-accessor 'syntax-source srcloc-source))" +"(define-values(1/syntax-line)(syntax-source-accessor 'syntax-line srcloc-line))" +"(define-values(1/syntax-column)(syntax-source-accessor 'syntax-column srcloc-column))" +"(define-values(1/syntax-position)(syntax-source-accessor 'syntax-position srcloc-position))" +"(define-values(1/syntax-span)(syntax-source-accessor 'syntax-span srcloc-span))" +"(define-values" +"(encoded-srcloc?)" +"(lambda(v_71)" +"(begin" +"(let-values(((or-part_26)(if(list? v_71)(if(=(length v_71) 5)(srcloc-vector?(list->vector v_71)) #f) #f)))" +"(if or-part_26 or-part_26(if(vector? v_71)(if(=(vector-length v_71) 5)(srcloc-vector? v_71) #f) #f))))))" +"(define-values" +"(srcloc-vector?)" +"(lambda(v_73)" +"(begin" +"(if(let-values(((or-part_292)(not(vector-ref v_73 1))))" +"(if or-part_292 or-part_292(exact-positive-integer?(vector-ref v_73 1))))" +"(if(let-values(((or-part_27)(not(vector-ref v_73 2))))" +"(if or-part_27 or-part_27(exact-nonnegative-integer?(vector-ref v_73 2))))" +"(if(let-values(((or-part_10)(not(vector-ref v_73 3))))" +"(if or-part_10 or-part_10(exact-positive-integer?(vector-ref v_73 3))))" +"(let-values(((or-part_158)(not(vector-ref v_73 4))))" +"(if or-part_158 or-part_158(exact-nonnegative-integer?(vector-ref v_73 4))))" +" #f)" +" #f)" +" #f))))" +"(define-values" +"(to-srcloc-stx)" +"(lambda(v_138)" +"(begin" +"(if(srcloc? v_138)" +"(let-values()" +"(let-values(((the-struct_35) empty-syntax))" +"(if(syntax?$1 the-struct_35)" +"(let-values(((srcloc1_2) v_138))" +"(syntax1.1" +"(syntax-content the-struct_35)" +"(syntax-scopes the-struct_35)" +"(syntax-shifted-multi-scopes the-struct_35)" +"(syntax-scope-propagations+tamper the-struct_35)" +"(syntax-mpi-shifts the-struct_35)" +" srcloc1_2" +"(syntax-props the-struct_35)" +"(syntax-inspector the-struct_35)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_35))))" +"(if(pair? v_138)" +"(let-values()(to-srcloc-stx(list->vector v_138)))" +"(if(vector? v_138)" +"(let-values()" +"(let-values(((the-struct_36) empty-syntax))" +"(if(syntax?$1 the-struct_36)" +"(let-values(((srcloc2_0)" +"(srcloc" +"(vector-ref v_138 0)" +"(vector-ref v_138 1)" +"(vector-ref v_138 2)" +"(vector-ref v_138 3)" +"(vector-ref v_138 4))))" +"(syntax1.1" +"(syntax-content the-struct_36)" +"(syntax-scopes the-struct_36)" +"(syntax-shifted-multi-scopes the-struct_36)" +"(syntax-scope-propagations+tamper the-struct_36)" +"(syntax-mpi-shifts the-struct_36)" +" srcloc2_0" +"(syntax-props the-struct_36)" +"(syntax-inspector the-struct_36)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_36))))" +"(let-values() v_138)))))))" +"(define-values" +"(1/syntax-e)" +"(lambda(s_0)" +"(begin" +" 'syntax-e" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_0) (void) (let-values () (raise-argument-error 'syntax-e \"syntax?\" s_0)))" +"(syntax-e$1 s_0)))))))" +"(define-values" +"(1/syntax->datum)" +"(lambda(s_189)" +"(begin" +" 'syntax->datum" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_189) (void) (let-values () (raise-argument-error 'syntax->datum \"syntax?\" s_189)))" +"(syntax->datum$1 s_189)))))))" +"(define-values(maybe-syntax->datum)(lambda(s_73)(begin(if(syntax?$1 s_73)(syntax->datum$1 s_73) s_73))))" +"(define-values" +"(1/datum->syntax)" +"(let-values(((datum->syntax6_1)" +"(lambda(stx-c4_1 s5_2 stx-l1_0 stx-p2_0 ignored3_0)" +"(begin" +" 'datum->syntax6" +"(let-values(((stx-c_4) stx-c4_1))" +"(let-values(((s_440) s5_2))" +"(let-values(((stx-l_2) stx-l1_0))" +"(let-values(((stx-p_1) stx-p2_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(let-values(((or-part_6)(not stx-c_4)))" +"(if or-part_6 or-part_6(syntax?$1 stx-c_4)))" +"(void)" +" (let-values () (raise-argument-error 'datum->syntax \"(or #f syntax?)\" stx-c_4)))" +"(if(let-values(((or-part_293)(not stx-l_2)))" +"(if or-part_293" +" or-part_293" +"(let-values(((or-part_28)(syntax?$1 stx-l_2)))" +"(if or-part_28 or-part_28(encoded-srcloc? stx-l_2)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'datum->syntax" +"(string-append" +" \"(or #f syntax?\\n\"" +" \" (list/c any/c\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f))\\n\"" +" \" (vector/c any/c\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)))\")" +" stx-l_2)))" +"(if(let-values(((or-part_294)(not stx-p_1)))" +"(if or-part_294 or-part_294(syntax?$1 stx-p_1)))" +"(void)" +" (let-values () (raise-argument-error 'datum->syntax \"(or #f syntax?)\" stx-p_1)))" +"(datum->syntax$1 stx-c_4 s_440(to-srcloc-stx stx-l_2) stx-p_1))))))))))))))" +"(case-lambda" +"((stx-c_5 s_77)(begin 'datum->syntax(datum->syntax6_1 stx-c_5 s_77 #f #f #f)))" +"((stx-c_6 s_4 stx-l_3 stx-p_2 ignored3_1)(datum->syntax6_1 stx-c_6 s_4 stx-l_3 stx-p_2 ignored3_1))" +"((stx-c_7 s_441 stx-l_4 stx-p2_1)(datum->syntax6_1 stx-c_7 s_441 stx-l_4 stx-p2_1 #f))" +"((stx-c_8 s_181 stx-l1_1)(datum->syntax6_1 stx-c_8 s_181 stx-l1_1 #f #f)))))" +"(define-values" +"(1/syntax->list)" +"(lambda(s_442)" +"(begin" +" 'syntax->list" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_442) (void) (let-values () (raise-argument-error 'syntax->list \"syntax?\" s_442)))" +"(syntax->list$1 s_442)))))))" +"(define-values" +"(1/syntax-original?)" +"(lambda(s_167)" +"(begin" +" 'syntax-original?" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_167) (void) (let-values () (raise-argument-error 'syntax-original? \"syntax?\" s_167)))" +"(if(syntax-property$1 s_167 original-property-sym)(not(syntax-any-macro-scopes? s_167)) #f)))))))" +"(define-values" +"(1/bound-identifier=?)" +"(let-values(((bound-identifier=?11_0)" +"(lambda(a9_0 b10_0 phase8_0)" +"(begin" +" 'bound-identifier=?11" +"(let-values(((a_57) a9_0))" +"(let-values(((b_65) b10_0))" +"(let-values(((phase_123)" +"(if(eq? phase8_0 unsafe-undefined)(1/syntax-local-phase-level) phase8_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? a_57)" +"(void)" +" (let-values () (raise-argument-error 'bound-identifier=? \"identifier?\" a_57)))" +"(if(identifier? b_65)" +"(void)" +" (let-values () (raise-argument-error 'bound-identifier=? \"identifier?\" b_65)))" +"(if(phase? phase_123)" +"(void)" +"(let-values()(raise-argument-error 'bound-identifier=? phase?-string phase_123)))" +"(bound-identifier=?$1 a_57 b_65 phase_123))))))))))))" +"(case-lambda" +"((a_58 b_84)(begin 'bound-identifier=?(bound-identifier=?11_0 a_58 b_84 unsafe-undefined)))" +"((a_59 b_85 phase8_1)(bound-identifier=?11_0 a_59 b_85 phase8_1)))))" +"(define-values" +"(1/free-identifier=?)" +"(let-values(((free-identifier=?17_0)" +"(lambda(a15_0 b16_1 a-phase13_0 b-phase14_0)" +"(begin" +" 'free-identifier=?17" +"(let-values(((a_60) a15_0))" +"(let-values(((b_86) b16_1))" +"(let-values(((a-phase_1)" +"(if(eq? a-phase13_0 unsafe-undefined)(1/syntax-local-phase-level) a-phase13_0)))" +"(let-values(((b-phase_1)(if(eq? b-phase14_0 unsafe-undefined) a-phase_1 b-phase14_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? a_60)" +"(void)" +" (let-values () (raise-argument-error 'free-identifier=? \"identifier?\" a_60)))" +"(if(identifier? b_86)" +"(void)" +" (let-values () (raise-argument-error 'free-identifier=? \"identifier?\" b_86)))" +"(if(phase? a-phase_1)" +"(void)" +"(let-values()(raise-argument-error 'free-identifier=? phase?-string a-phase_1)))" +"(if(phase? b-phase_1)" +"(void)" +"(let-values()(raise-argument-error 'free-identifier=? phase?-string b-phase_1)))" +"(free-identifier=?$1 a_60 b_86 a-phase_1 b-phase_1)))))))))))))" +"(case-lambda" +"((a_61 b_39)(begin 'free-identifier=?(free-identifier=?17_0 a_61 b_39 unsafe-undefined unsafe-undefined)))" +"((a_62 b_87 a-phase_2 b-phase14_1)(free-identifier=?17_0 a_62 b_87 a-phase_2 b-phase14_1))" +"((a_63 b_88 a-phase13_1)(free-identifier=?17_0 a_63 b_88 a-phase13_1 unsafe-undefined)))))" +"(define-values" +"(1/free-transformer-identifier=?)" +"(lambda(a_64 b_89)" +"(begin" +" 'free-transformer-identifier=?" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? a_64)" +"(void)" +" (let-values () (raise-argument-error 'free-transformer-identifier=? \"identifier?\" a_64)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? b_89)" +"(void)" +" (let-values () (raise-argument-error 'free-transformer-identifier=? \"identifier?\" b_89)))" +"(values))))" +"(let-values(((phase_124)(add1(1/syntax-local-phase-level))))" +"(free-identifier=?$1 a_64 b_89 phase_124 phase_124)))))))))" +"(define-values" +"(1/free-template-identifier=?)" +"(lambda(a_65 b_90)" +"(begin" +" 'free-template-identifier=?" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? a_65)" +"(void)" +" (let-values () (raise-argument-error 'free-template-identifier=? \"identifier?\" a_65)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? b_90)" +"(void)" +" (let-values () (raise-argument-error 'free-template-identifier=? \"identifier?\" b_90)))" +"(values))))" +"(let-values(((phase_125)(sub1(1/syntax-local-phase-level))))" +"(free-identifier=?$1 a_65 b_90 phase_125 phase_125)))))))))" +"(define-values" +"(1/free-label-identifier=?)" +"(lambda(a_66 b_91)" +"(begin" +" 'free-label-identifier=?" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? a_66)" +"(void)" +" (let-values () (raise-argument-error 'free-label-identifier=? \"identifier?\" a_66)))" +"(if(identifier? b_91)" +"(void)" +" (let-values () (raise-argument-error 'free-label-identifier=? \"identifier?\" b_91)))" +"(free-identifier=?$1 a_66 b_91 #f #f)))))))" +"(define-values" +"(1/identifier-binding)" +"(let-values(((identifier-binding22_0)" +"(lambda(id21_0 phase19_0 top-level-symbol?20_0)" +"(begin" +" 'identifier-binding22" +"(let-values(((id_90) id21_0))" +"(let-values(((phase_126)" +"(if(eq? phase19_0 unsafe-undefined)(1/syntax-local-phase-level) phase19_0)))" +"(let-values(((top-level-symbol?_1) top-level-symbol?20_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_90)" +"(void)" +" (let-values () (raise-argument-error 'identifier-binding \"identifier?\" id_90)))" +"(if(phase? phase_126)" +"(void)" +"(let-values()(raise-argument-error 'identifier-binding phase?-string phase_126)))" +"(identifier-binding$1 id_90 phase_126 top-level-symbol?_1))))))))))))" +"(case-lambda" +"((id_91)(begin 'identifier-binding(identifier-binding22_0 id_91 unsafe-undefined #f)))" +"((id_15 phase_85 top-level-symbol?20_1)(identifier-binding22_0 id_15 phase_85 top-level-symbol?20_1))" +"((id_92 phase19_1)(identifier-binding22_0 id_92 phase19_1 #f)))))" +"(define-values" +"(1/identifier-transformer-binding)" +"(let-values(((identifier-transformer-binding26_0)" +"(lambda(id25_3 phase24_1)" +"(begin" +" 'identifier-transformer-binding26" +"(let-values(((id_93) id25_3))" +"(let-values(((phase_127)" +"(if(eq? phase24_1 unsafe-undefined)(1/syntax-local-phase-level) phase24_1)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_93)" +"(void)" +"(let-values()" +" (raise-argument-error 'identifier-transformer-binding \"identifier?\" id_93)))" +"(identifier-binding$1 id_93(if phase_127(add1 phase_127) #f))))))))))))" +"(case-lambda" +"((id_94)(begin 'identifier-transformer-binding(identifier-transformer-binding26_0 id_94 unsafe-undefined)))" +"((id_59 phase24_2)(identifier-transformer-binding26_0 id_59 phase24_2)))))" +"(define-values" +"(1/identifier-template-binding)" +"(lambda(id_95)" +"(begin" +" 'identifier-template-binding" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_95)" +"(void)" +" (let-values () (raise-argument-error 'identifier-template-binding \"identifier?\" id_95)))" +"(identifier-binding$1 id_95(sub1(1/syntax-local-phase-level)))))))))" +"(define-values" +"(1/identifier-label-binding)" +"(lambda(id_78)" +"(begin" +" 'identifier-label-binding" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_78)" +"(void)" +" (let-values () (raise-argument-error 'identifier-label-binding \"identifier?\" id_78)))" +"(identifier-binding$1 id_78 #f)))))))" +"(define-values" +"(1/identifier-binding-symbol)" +"(let-values(((identifier-binding-symbol30_0)" +"(lambda(id29_1 phase28_2)" +"(begin" +" 'identifier-binding-symbol30" +"(let-values(((id_96) id29_1))" +"(let-values(((phase_72)" +"(if(eq? phase28_2 unsafe-undefined)(1/syntax-local-phase-level) phase28_2)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_96)" +"(void)" +" (let-values () (raise-argument-error 'identifier-binding-symbol \"identifier?\" id_96)))" +"(if(phase? phase_72)" +"(void)" +"(let-values()" +"(raise-argument-error 'identifier-binding-symbol phase?-string phase_72)))" +"(identifier-binding-symbol$1 id_96 phase_72)))))))))))" +"(case-lambda" +"((id_97)(begin 'identifier-binding-symbol(identifier-binding-symbol30_0 id_97 unsafe-undefined)))" +"((id_98 phase28_3)(identifier-binding-symbol30_0 id_98 phase28_3)))))" +"(define-values" +"(1/identifier-prune-lexical-context)" +"(let-values(((identifier-prune-lexical-context34_0)" +"(lambda(id33_1 syms32_1)" +"(begin" +" 'identifier-prune-lexical-context34" +"(let-values(((id_99) id33_1))" +"(let-values(((syms_22) syms32_1))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(identifier? id_99)" +"(void)" +"(let-values()" +" (raise-argument-error 'identifier-prune-lexical-context \"identifier?\" id_99)))" +"(if(if(list? syms_22)(andmap2 symbol? syms_22) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'identifier-prune-lexical-context" +" \"(listof symbol?)\"" +" syms_22)))" +" id_99))))))))))" +"(case-lambda" +"((id_62)(begin 'identifier-prune-lexical-context(identifier-prune-lexical-context34_0 id_62 null)))" +"((id_100 syms32_2)(identifier-prune-lexical-context34_0 id_100 syms32_2)))))" +"(define-values" +"(1/syntax-debug-info)" +"(let-values(((syntax-debug-info39_0)" +"(lambda(s38_1 phase36_0 all-bindings?37_0)" +"(begin" +" 'syntax-debug-info39" +"(let-values(((s_412) s38_1))" +"(let-values(((phase_77)" +"(if(eq? phase36_0 unsafe-undefined)(1/syntax-local-phase-level) phase36_0)))" +"(let-values(((all-bindings?_1) all-bindings?37_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_412)" +"(void)" +" (let-values () (raise-argument-error 'syntax-debug-info \"syntax?\" s_412)))" +"(if(phase? phase_77)" +"(void)" +"(let-values()(raise-argument-error 'syntax-debug-info phase?-string phase_77)))" +"(syntax-debug-info$1 s_412 phase_77 all-bindings?_1))))))))))))" +"(case-lambda" +"((s_86)(begin 'syntax-debug-info(syntax-debug-info39_0 s_86 unsafe-undefined #f)))" +"((s_443 phase_128 all-bindings?37_1)(syntax-debug-info39_0 s_443 phase_128 all-bindings?37_1))" +"((s_29 phase36_1)(syntax-debug-info39_0 s_29 phase36_1 #f)))))" +"(define-values" +"(1/syntax-shift-phase-level)" +"(lambda(s_444 phase_129)" +"(begin" +" 'syntax-shift-phase-level" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_444)" +"(void)" +" (let-values () (raise-argument-error 'syntax-shift-phase-level \"syntax?\" s_444)))" +"(if(phase? phase_129)" +"(void)" +"(let-values()(raise-argument-error 'syntax-shift-phase-level phase?-string phase_129)))" +"(syntax-shift-phase-level$1 s_444 phase_129)))))))" +"(define-values" +"(1/syntax-track-origin)" +"(lambda(new-stx_8 old-stx_4 id_101)" +"(begin" +" 'syntax-track-origin" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 new-stx_8)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" new-stx_8)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(syntax?$1 old-stx_4)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" old-stx_4)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? id_101)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"identifier?\" id_101)))" +"(values))))" +"(let-values(((s_445)(syntax-track-origin$1 new-stx_8 old-stx_4 id_101)))" +"(let-values(((ctx_67)" +"(let-values(((temp60_3) #t))(get-current-expand-context16.1 temp60_3 'unexpected))))" +"(begin" +"(if ctx_67" +"(let-values()" +"(let-values(((obs_44)(expand-context-observer ctx_67)))" +"(if obs_44" +"(let-values()(let-values()(call-expand-observe obs_44 'track-origin new-stx_8 s_445)))" +"(void))))" +"(void))" +" s_445)))))))))))" +"(define-values" +"(1/namespace-attach-module)" +"(let-values(((namespace-attach-module4_0)" +"(lambda(src-namespace2_0 mod-path3_1 dest-namespace1_0)" +"(begin" +" 'namespace-attach-module4" +"(let-values(((src-namespace_0) src-namespace2_0))" +"(let-values(((mod-path_10) mod-path3_1))" +"(let-values(((dest-namespace_0)" +"(if(eq? dest-namespace1_0 unsafe-undefined)" +"(1/current-namespace)" +" dest-namespace1_0)))" +"(let-values()" +"(let-values(((temp20_2) 'namespace-attach-module)" +"((src-namespace21_0) src-namespace_0)" +"((mod-path22_0) mod-path_10)" +"((dest-namespace23_0) dest-namespace_0)" +"((temp24_5) #t))" +"(do-attach-module17.1" +" temp24_5" +" temp20_2" +" src-namespace21_0" +" mod-path22_0" +" dest-namespace23_0))))))))))" +"(case-lambda" +"((src-namespace_1 mod-path_11)" +"(begin 'namespace-attach-module(namespace-attach-module4_0 src-namespace_1 mod-path_11 unsafe-undefined)))" +"((src-namespace_2 mod-path_12 dest-namespace1_1)" +"(namespace-attach-module4_0 src-namespace_2 mod-path_12 dest-namespace1_1)))))" +"(define-values" +"(1/namespace-attach-module-declaration)" +"(let-values(((namespace-attach-module-declaration9_0)" +"(lambda(src-namespace7_0 mod-path8_2 dest-namespace6_0)" +"(begin" +" 'namespace-attach-module-declaration9" +"(let-values(((src-namespace_3) src-namespace7_0))" +"(let-values(((mod-path_13) mod-path8_2))" +"(let-values(((dest-namespace_1)" +"(if(eq? dest-namespace6_0 unsafe-undefined)" +"(1/current-namespace)" +" dest-namespace6_0)))" +"(let-values()" +"(let-values(((temp25_5) 'namespace-attach-module-declaration)" +"((src-namespace26_0) src-namespace_3)" +"((mod-path27_0) mod-path_13)" +"((dest-namespace28_0) dest-namespace_1)" +"((temp29_2) #f))" +"(do-attach-module17.1" +" temp29_2" +" temp25_5" +" src-namespace26_0" +" mod-path27_0" +" dest-namespace28_0))))))))))" +"(case-lambda" +"((src-namespace_4 mod-path_14)" +"(begin" +" 'namespace-attach-module-declaration" +"(namespace-attach-module-declaration9_0 src-namespace_4 mod-path_14 unsafe-undefined)))" +"((src-namespace_5 mod-path_15 dest-namespace6_1)" +"(namespace-attach-module-declaration9_0 src-namespace_5 mod-path_15 dest-namespace6_1)))))" +"(define-values" +"(do-attach-module17.1)" +"(lambda(attach-instances?11_0 who13_0 src-namespace14_0 mod-path15_0 dest-namespace16_0)" +"(begin" +" 'do-attach-module17" +"(let-values(((who_22) who13_0))" +"(let-values(((src-namespace_6) src-namespace14_0))" +"(let-values(((mod-path_16) mod-path15_0))" +"(let-values(((dest-namespace_2) dest-namespace16_0))" +"(let-values(((attach-instances?_0) attach-instances?11_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/namespace? src-namespace_6)" +"(void)" +" (let-values () (raise-argument-error who_22 \"namespace?\" src-namespace_6)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_53)(1/module-path? mod-path_16)))" +"(if or-part_53 or-part_53(1/resolved-module-path? mod-path_16)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_22" +" \"(or/c module-path? resolved-module-path?)\"" +" mod-path_16)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? dest-namespace_2)" +"(void)" +" (let-values () (raise-argument-error who_22 \"namespace?\" dest-namespace_2)))" +"(values))))" +"(let-values(((phase_130)(namespace-phase src-namespace_6)))" +"(let-values((()" +"(begin" +"(if(eqv? phase_130(namespace-phase dest-namespace_2))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_22" +" \"source and destination namespace phases do not match\"" +" \"source phase\"" +" phase_130" +" \"destination phase\"" +"(namespace-phase dest-namespace_2))))" +"(values))))" +"(let-values(((todo_0)(make-hasheq)))" +"(let-values(((missing_0)(gensym 'missing)))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_99)" +"(lambda(mpi_45" +" phase_131" +" attach-instances?_1" +" attach-phase_0)" +"(begin" +" 'loop" +"(let-values(((mod-name_19)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" src-namespace_6)" +"(let-values()" +"(1/module-path-index-resolve" +" mpi_45)))))" +"(let-values(((attach-this-instance?_0)" +"(if attach-instances?_1" +"(eqv? phase_131 attach-phase_0)" +" #f)))" +"(let-values(((m-ns_12)" +"(hash-ref" +"(hash-ref" +" todo_0" +" mod-name_19" +" '#hasheqv())" +" phase_131" +" missing_0)))" +"(if(let-values(((or-part_164)" +"(eq? missing_0 m-ns_12)))" +"(if or-part_164" +" or-part_164" +"(if attach-this-instance?_0" +"(not m-ns_12)" +" #f)))" +"(let-values()" +"(let-values(((m_20)" +"(namespace->module" +" src-namespace_6" +" mod-name_19)))" +"(begin" +"(if m_20" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_22" +" \"module not declared (in the source namespace)\"" +" \"module name\"" +" mod-name_19)))" +"(if(if(module-cross-phase-persistent?" +" m_20)" +"(if(not" +"(label-phase? phase_131))" +"(not" +"(zero-phase? phase_131))" +" #f)" +" #f)" +"(let-values()" +"(loop_99" +" mpi_45" +" 0" +" attach-instances?_1" +" 0))" +"(let-values()" +"(let-values(((already-m_0)" +"(namespace->module" +" dest-namespace_2" +" mod-name_19)))" +"(let-values((()" +"(begin" +"(if(if already-m_0" +"(not" +"(eq?" +" already-m_0" +" m_20))" +" #f)" +"(let-values()" +"(raise-arguments-error" +" who_22" +" \"a different declaration is already in the destination namespace\"" +" \"module name\"" +" mod-name_19))" +"(void))" +"(values))))" +"(let-values(((m-ns_13" +" already?_0)" +"(if(let-values(((or-part_295)" +" attach-this-instance?_0))" +"(if or-part_295" +" or-part_295" +"(module-cross-phase-persistent?" +" m_20)))" +"(let-values()" +"(let-values(((m-ns_14)" +"(let-values(((src-namespace30_0)" +" src-namespace_6)" +"((mod-name31_0)" +" mod-name_19)" +"((phase32_1)" +" phase_131))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" src-namespace30_0" +" mod-name31_0" +" phase32_1))))" +"(let-values((()" +"(begin" +"(if m-ns_14" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_22" +" \"module not instantiated (in the source namespace)\"" +" \"module name\"" +" mod-name_19)))" +"(values))))" +"(let-values(((already-m-ns_0)" +"(if already-m_0" +"(let-values(((dest-namespace33_0)" +" dest-namespace_2)" +"((mod-name34_0)" +" mod-name_19)" +"((phase35_1)" +" phase_131))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" dest-namespace33_0" +" mod-name34_0" +" phase35_1))" +" #f)))" +"(begin" +"(if(if already-m-ns_0" +"(if(not" +"(eq?" +" m-ns_14" +" already-m-ns_0))" +"(not" +"(namespace-same-instance?" +" m-ns_14" +" already-m-ns_0))" +" #f)" +" #f)" +"(let-values()" +"(raise-arguments-error" +" who_22" +" \"a different instance is already in the destination namespace\"" +" \"module name\"" +" mod-name_19))" +"(void))" +"(values" +" m-ns_14" +"(if already-m-ns_0" +" #t" +" #f)))))))" +"(let-values()" +"(begin" +"(if(if(label-phase?" +" phase_131)" +"(not" +"(let-values(((src-namespace36_0)" +" src-namespace_6)" +"((mod-name37_0)" +" mod-name_19)" +"((phase38_0)" +" phase_131))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" src-namespace36_0" +" mod-name37_0" +" phase38_0)))" +" #f)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" src-namespace_6)" +"(let-values()" +"(let-values(((src-namespace39_0)" +" src-namespace_6)" +"((mpi40_0)" +" mpi_45)" +"((phase41_1)" +" phase_131))" +"(namespace-module-instantiate!96.1" +" #t" +" unsafe-undefined" +" unsafe-undefined" +" #f" +" src-namespace39_0" +" mpi40_0" +" phase41_1)))))" +"(void))" +"(values" +" #f" +"(if already-m_0" +" #t" +" #f)))))))" +"(begin" +"(hash-update!" +" todo_0" +" mod-name_19" +"(lambda(ht_144)" +"(hash-set" +" ht_144" +" phase_131" +" m-ns_13))" +" '#hasheqv())" +"(if already?_0" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_298)" +"(module-requires" +" m_20)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_298)))" +"((letrec-values(((for-loop_263)" +"(lambda(lst_299)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_299)" +"(let-values(((phase+reqs_1)" +"(unsafe-car" +" lst_299))" +"((rest_171)" +"(unsafe-cdr" +" lst_299)))" +"(let-values((()" +"(let-values(((lst_225)" +"(cdr" +" phase+reqs_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_225)))" +"((letrec-values(((for-loop_101)" +"(lambda(lst_178)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_178)" +"(let-values(((req_5)" +"(unsafe-car" +" lst_178))" +"((rest_172)" +"(unsafe-cdr" +" lst_178)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_99" +"(module-path-index-shift" +" req_5" +"(module-self" +" m_20)" +" mpi_45)" +"(phase+" +" phase_131" +"(car" +" phase+reqs_1))" +" attach-instances?_1" +" attach-phase_0))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_101" +" rest_172)" +"(values))))" +"(values))))))" +" for-loop_101)" +" lst_225)))))" +"(if(not" +" #f)" +"(for-loop_263" +" rest_171)" +"(values))))" +"(values))))))" +" for-loop_263)" +" lst_298)))" +"(void)" +"(let-values(((lst_276)" +"(module-submodule-names" +" m_20)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_276)))" +"((letrec-values(((for-loop_102)" +"(lambda(lst_164)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_164)" +"(let-values(((submod-name_0)" +"(unsafe-car" +" lst_164))" +"((rest_95)" +"(unsafe-cdr" +" lst_164)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_99" +"(1/module-path-index-join" +"(list" +" 'submod" +" \".\"" +" submod-name_0)" +" mpi_45)" +" #f" +" #f" +" attach-phase_0))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_102" +" rest_95)" +"(values))))" +"(values))))))" +" for-loop_102)" +" lst_276)))" +"(void)" +"(if(module-supermodule-name" +" m_20)" +"(let-values()" +"(loop_99" +"(1/module-path-index-join" +" '(submod" +" \"..\")" +" mpi_45)" +" #f" +" #f" +" attach-phase_0))" +"(void))))))))))))))" +"(void)))))))))" +" loop_99)" +"(1/module-path-index-join" +"(if(1/resolved-module-path? mod-path_16)" +"(resolved-module-path->module-path mod-path_16)" +" mod-path_16)" +" #f)" +" phase_130" +" attach-instances?_0" +" phase_130)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((ht_145) todo_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_145)))" +"((letrec-values(((for-loop_264)" +"(lambda(i_164)" +"(begin" +" 'for-loop" +"(if i_164" +"(let-values(((mod-name_20 phases_0)" +"(hash-iterate-key+value" +" ht_145" +" i_164)))" +"(let-values((()" +"(let-values(((ht_146)" +" phases_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_146)))" +"((letrec-values(((for-loop_253)" +"(lambda(i_46)" +"(begin" +" 'for-loop" +"(if i_46" +"(let-values(((phase_132" +" m-ns_15)" +"(hash-iterate-key+value" +" ht_146" +" i_46)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((m_21)" +"(namespace->module" +" src-namespace_6" +" mod-name_20)))" +"(begin" +"(module-force-bulk-binding!" +" m_21" +" src-namespace_6)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" dest-namespace_2)" +"(let-values()" +"(let-values(((dest-namespace42_0)" +" dest-namespace_2)" +"((m43_0)" +" m_21)" +"((mod-name44_0)" +" mod-name_20))" +"(declare-module!58.1" +" #t" +" dest-namespace42_0" +" m43_0" +" mod-name44_0))))" +"(if m-ns_15" +"(let-values()" +"(begin" +"(namespace-record-module-instance-attached!" +" src-namespace_6" +" mod-name_20" +" phase_132)" +"(let-values(((or-part_25)" +"(let-values(((dest-namespace45_0)" +" dest-namespace_2)" +"((mod-name46_0)" +" mod-name_20)" +"((phase47_2)" +" phase_132))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" dest-namespace45_0" +" mod-name46_0" +" phase47_2))))" +"(if or-part_25" +" or-part_25" +"(namespace-install-module-namespace!" +" dest-namespace_2" +" mod-name_20" +" phase_132" +" m_21" +" m-ns_15)))))" +"(void)))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_253" +"(hash-iterate-next" +" ht_146" +" i_46))" +"(values))))" +"(values))))))" +" for-loop_253)" +"(hash-iterate-first" +" ht_146))))))" +"(if(not #f)" +"(for-loop_264" +"(hash-iterate-next ht_145 i_164))" +"(values))))" +"(values))))))" +" for-loop_264)" +"(hash-iterate-first ht_145))))" +"(values))))" +"(let-values()" +"(let-values(((mnr_0)(1/current-module-name-resolver)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" dest-namespace_2)" +"(let-values()" +"(begin" +"(let-values(((ht_147) todo_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_147)))" +"((letrec-values(((for-loop_265)" +"(lambda(i_21)" +"(begin" +" 'for-loop" +"(if i_21" +"(let-values(((mod-name_21)" +"(hash-iterate-key ht_147 i_21)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(mnr_0" +" mod-name_21" +" src-namespace_6))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_265" +"(hash-iterate-next ht_147 i_21))" +"(values))))" +"(values))))))" +" for-loop_265)" +"(hash-iterate-first ht_147))))" +"(void))))))))))))))))))))))))" +"(define-values" +"(1/make-empty-namespace)" +"(lambda()" +"(begin" +" 'make-empty-namespace" +"(let-values(((current-ns_0)(1/current-namespace)))" +"(let-values(((phase_44)(namespace-phase current-ns_0)))" +"(let-values(((ns_59)(namespace->namespace-at-phase(make-namespace) phase_44)))" +"(begin" +"(1/namespace-attach-module current-ns_0 ''#%kernel ns_59)" +"(namespace-primitive-module-visit! ns_59 '#%kernel)" +" ns_59)))))))" +"(define-values" +"(1/namespace-syntax-introduce)" +"(let-values(((namespace-syntax-introduce3_0)" +"(lambda(s2_8 ns1_3)" +"(begin" +" 'namespace-syntax-introduce3" +"(let-values(((s_2) s2_8))" +"(let-values(((ns_58)(if(eq? ns1_3 unsafe-undefined)(1/current-namespace) ns1_3)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_2)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-syntax-introduce \"syntax?\" s_2)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_58)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-syntax-introduce" +" \"namespace?\"" +" ns_58)))" +"(values))))" +"(let-values(((root-ctx_5)(namespace-get-root-expand-ctx ns_58)))" +"(let-values(((post-scope_1)" +"(post-expansion-scope" +"(root-expand-context-post-expansion root-ctx_5))))" +"(let-values(((other-namespace-scopes_0)" +"(reverse$1" +"(let-values(((ht_148)" +"(syntax-scope-set" +"(root-expand-context-all-scopes-stx root-ctx_5)" +" 0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_148)))" +"((letrec-values(((for-loop_116)" +"(lambda(fold-var_239 i_165)" +"(begin" +" 'for-loop" +"(if i_165" +"(let-values(((sc_36)" +"(unsafe-immutable-hash-iterate-key" +" ht_148" +" i_165)))" +"(let-values(((fold-var_220)" +"(let-values(((fold-var_221)" +" fold-var_239))" +"(if(equal?" +" sc_36" +" post-scope_1)" +" fold-var_221" +"(let-values(((fold-var_222)" +" fold-var_221))" +"(let-values(((fold-var_223)" +"(let-values()" +"(cons" +"(let-values()" +" sc_36)" +" fold-var_222))))" +"(values" +" fold-var_223)))))))" +"(if(not #f)" +"(for-loop_116" +" fold-var_220" +"(unsafe-immutable-hash-iterate-next" +" ht_148" +" i_165))" +" fold-var_220)))" +" fold-var_239)))))" +" for-loop_116)" +" null" +"(unsafe-immutable-hash-iterate-first ht_148)))))))" +"(let-values(((add-ns-scopes_0)" +"(lambda(s_430)" +"(begin" +" 'add-ns-scopes" +"(let-values(((temp64_3)" +"(add-scopes" +"(push-scope s_430 post-scope_1)" +" other-namespace-scopes_0))" +"((temp65_1)" +"(root-expand-context-all-scopes-stx root-ctx_5))" +"((temp66_2)" +"(let-values(((or-part_74)" +"(namespace-declaration-inspector" +" ns_58)))" +"(if or-part_74" +" or-part_74" +"(current-code-inspector))))" +"((temp67_2) #t))" +"(syntax-transfer-shifts36.1" +" temp67_2" +" temp64_3" +" temp65_1" +" temp66_2))))))" +"(let-values(((maybe-module-id_0)" +"(if(pair?(1/syntax-e s_2))" +"(if(identifier?(car(1/syntax-e s_2)))" +"(add-ns-scopes_0(car(1/syntax-e s_2)))" +" #f)" +" #f)))" +"(if(if maybe-module-id_0" +"(1/free-identifier=?" +" maybe-module-id_0" +"(1/namespace-module-identifier ns_58)" +"(namespace-phase ns_58))" +" #f)" +"(let-values()" +"(1/datum->syntax" +" s_2" +"(cons maybe-module-id_0(cdr(1/syntax-e s_2)))" +" s_2" +" s_2))" +"(let-values()(add-ns-scopes_0 s_2)))))))))))))))))))" +"(case-lambda" +"((s_78)(begin 'namespace-syntax-introduce(namespace-syntax-introduce3_0 s_78 unsafe-undefined)))" +"((s_446 ns1_2)(namespace-syntax-introduce3_0 s_446 ns1_2)))))" +"(define-values" +"(namespace-datum-introduce)" +"(lambda(s_181)(begin(1/namespace-syntax-introduce(1/datum->syntax #f s_181)))))" +"(define-values" +"(1/namespace-module-identifier)" +"(let-values(((namespace-module-identifier6_0)" +"(lambda(where5_0)" +"(begin" +" 'namespace-module-identifier6" +"(let-values(((where_0)(if(eq? where5_0 unsafe-undefined)(1/current-namespace) where5_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(let-values(((or-part_82)(1/namespace? where_0)))" +"(if or-part_82 or-part_82(phase? where_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-module-identifier" +" (string-append \"(or/c namespace? \" phase?-string \")\")" +" where_0)))" +"(1/datum->syntax" +"(1/syntax-shift-phase-level" +" core-stx" +"(if(1/namespace? where_0)(namespace-phase where_0) where_0))" +" 'module))))))))))" +"(case-lambda" +"(()(begin 'namespace-module-identifier(namespace-module-identifier6_0 unsafe-undefined)))" +"((where5_1)(namespace-module-identifier6_0 where5_1)))))" +"(define-values" +"(1/namespace-symbol->identifier)" +"(lambda(sym_64)" +"(begin" +" 'namespace-symbol->identifier" +"(let-values()" +"(let-values()" +"(begin" +"(if(symbol? sym_64)" +"(void)" +" (let-values () (raise-argument-error 'namespace-symbol->identifier \"symbol?\" sym_64)))" +"(1/namespace-syntax-introduce(1/datum->syntax #f sym_64))))))))" +"(define-values" +"(do-namespace-require21.1)" +"(lambda(copy-variable-as-constant?11_1" +" copy-variable-phase-level10_1" +" run?8_0" +" skip-variable-phase-level12_1" +" visit?9_0" +" who18_0" +" req19_0" +" ns20_1)" +"(begin" +" 'do-namespace-require21" +"(let-values(((run?_3) run?8_0))" +"(let-values(((visit?_3) visit?9_0))" +"(let-values(((who_23) who18_0))" +"(let-values(((req_6) req19_0))" +"(let-values(((ns_77) ns20_1))" +"(let-values(((copy-variable-phase-level_2) copy-variable-phase-level10_1))" +"(let-values(((copy-variable-as-constant?_2) copy-variable-as-constant?11_1))" +"(let-values(((skip-variable-phase-level_2) skip-variable-phase-level12_1))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_77)" +"(void)" +" (let-values () (raise-argument-error who_23 \"namespace?\" ns_77)))" +"(values))))" +"(let-values(((ctx-stx_0)" +"(add-scopes" +" empty-syntax" +"(root-expand-context-module-scopes(namespace-get-root-expand-ctx ns_77)))))" +"(if(let-values(((or-part_164)(1/module-path-index? req_6)))" +"(if or-part_164 or-part_164(1/module-path? req_6)))" +"(let-values()" +"(let-values(((temp70_0)" +"(if(1/module-path-index? req_6)" +" req_6" +"(1/module-path-index-join req_6 #f)))" +"((temp71_0) #f)" +"((temp72_0) #f)" +"((ctx-stx73_0) ctx-stx_0)" +"((ns74_0) ns_77)" +"((run?75_0) run?_3)" +"((visit?76_0) visit?_3)" +"((temp77_0)(namespace-phase ns_77))" +"((temp78_1)(namespace-phase ns_77))" +"((copy-variable-phase-level79_0) copy-variable-phase-level_2)" +"((copy-variable-as-constant?80_0) copy-variable-as-constant?_2)" +"((skip-variable-phase-level81_0) skip-variable-phase-level_2)" +"((who82_0) who_23))" +"(perform-require!78.1" +" #f" +" #t" +" #f" +" copy-variable-as-constant?80_0" +" copy-variable-phase-level79_0" +" #f" +" 'all" +" temp77_0" +" #f" +" temp78_1" +" run?75_0" +" skip-variable-phase-level81_0" +" visit?76_0" +" who82_0" +" temp70_0" +" temp71_0" +" temp72_0" +" ctx-stx73_0" +" ns74_0)))" +"(let-values()" +"(let-values(((run?83_0) run?_3)" +"((visit?84_0) visit?_3)" +"((temp85_0)(list(1/datum->syntax ctx-stx_0 req_6)))" +"((temp86_1) #f)" +"((ns87_0) ns_77)" +"((temp88_0)(namespace-phase ns_77))" +"((temp89_1)" +"(let-values(((temp92_2) #f))(make-requires+provides8.1 #f temp92_2)))" +"((skip-variable-phase-level90_0) skip-variable-phase-level_2)" +"((who91_0) who_23))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" unsafe-undefined" +" #f" +" unsafe-undefined" +" run?83_0" +" #f" +" skip-variable-phase-level90_0" +" visit?84_0" +" who91_0" +" temp85_0" +" temp86_1" +" ns87_0" +" temp88_0" +" temp89_1))))))))))))))))))" +"(define-values" +"(1/namespace-require)" +"(let-values(((namespace-require26_0)" +"(lambda(req25_0 ns24_0)" +"(begin" +" 'namespace-require26" +"(let-values(((req_7) req25_0))" +"(let-values(((ns_78)(if(eq? ns24_0 unsafe-undefined)(1/current-namespace) ns24_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values(((who94_0) 'namespace-require)((req95_0) req_7)((ns96_0) ns_78))" +"(do-namespace-require21.1 #f #f #t #f #f who94_0 req95_0 ns96_0)))))))))))" +"(case-lambda" +"((req_8)(begin 'namespace-require(namespace-require26_0 req_8 unsafe-undefined)))" +"((req_9 ns24_1)(namespace-require26_0 req_9 ns24_1)))))" +"(define-values" +"(1/namespace-require/expansion-time)" +"(let-values(((namespace-require/expansion-time30_0)" +"(lambda(req29_0 ns28_1)" +"(begin" +" 'namespace-require/expansion-time30" +"(let-values(((req_10) req29_0))" +"(let-values(((ns_79)(if(eq? ns28_1 unsafe-undefined)(1/current-namespace) ns28_1)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values(((temp98_1) #f)" +"((temp99_0) #t)" +"((who100_0) 'namespace-require/expansion-time)" +"((req101_0) req_10)" +"((ns102_0) ns_79))" +"(do-namespace-require21.1" +" #f" +" #f" +" temp98_1" +" #f" +" temp99_0" +" who100_0" +" req101_0" +" ns102_0)))))))))))" +"(case-lambda" +"((req_11)(begin 'namespace-require/expansion-time(namespace-require/expansion-time30_0 req_11 unsafe-undefined)))" +"((req_12 ns28_2)(namespace-require/expansion-time30_0 req_12 ns28_2)))))" +"(define-values" +"(1/namespace-require/constant)" +"(let-values(((namespace-require/constant34_0)" +"(lambda(req33_0 ns32_0)" +"(begin" +" 'namespace-require/constant34" +"(let-values(((req_13) req33_0))" +"(let-values(((ns_80)(if(eq? ns32_0 unsafe-undefined)(1/current-namespace) ns32_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values(((who104_1) 'namespace-require/constant)" +"((req105_0) req_13)" +"((ns106_0) ns_80)" +"((temp107_1) 0)" +"((temp108_0) #t))" +"(do-namespace-require21.1" +" temp108_0" +" temp107_1" +" #t" +" #f" +" #f" +" who104_1" +" req105_0" +" ns106_0)))))))))))" +"(case-lambda" +"((req_14)(begin 'namespace-require/constant(namespace-require/constant34_0 req_14 unsafe-undefined)))" +"((req_15 ns32_1)(namespace-require/constant34_0 req_15 ns32_1)))))" +"(define-values" +"(1/namespace-require/copy)" +"(let-values(((namespace-require/copy38_0)" +"(lambda(req37_0 ns36_0)" +"(begin" +" 'namespace-require/copy38" +"(let-values(((req_16) req37_0))" +"(let-values(((ns_81)(if(eq? ns36_0 unsafe-undefined)(1/current-namespace) ns36_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values(((who110_1) 'namespace-require/copy)" +"((req111_0) req_16)" +"((ns112_0) ns_81)" +"((temp113_1) 0)" +"((temp114_2) 0))" +"(do-namespace-require21.1" +" #f" +" temp113_1" +" #t" +" temp114_2" +" #f" +" who110_1" +" req111_0" +" ns112_0)))))))))))" +"(case-lambda" +"((req_17)(begin 'namespace-require/copy(namespace-require/copy38_0 req_17 unsafe-undefined)))" +"((req_18 ns36_1)(namespace-require/copy38_0 req_18 ns36_1)))))" +"(define-values" +"(1/namespace-variable-value)" +"(let-values(((namespace-variable-value44_0)" +"(lambda(sym43_0 use-mapping?40_0 failure-thunk41_0 ns42_0)" +"(begin" +" 'namespace-variable-value44" +"(let-values(((sym_76) sym43_0))" +"(let-values(((use-mapping?_0) use-mapping?40_0))" +"(let-values(((failure-thunk_5) failure-thunk41_0))" +"(let-values(((ns_11)(if(eq? ns42_0 unsafe-undefined)(1/current-namespace) ns42_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(symbol? sym_76)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"symbol?\" sym_76)))" +"(if(let-values(((or-part_132)(not failure-thunk_5)))" +"(if or-part_132" +" or-part_132" +"(if(procedure? failure-thunk_5)" +"(procedure-arity-includes? failure-thunk_5 0)" +" #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-variable-value" +" \"(or/c #f (procedure-arity-includes/c 0))\"" +" failure-thunk_5)))" +"(if(1/namespace? ns_11)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-variable-value \"namespace?\" ns_11)))" +"((call/ec" +"(lambda(escape_0)" +"(let-values(((var-ns_0 var-phase-level_0 var-sym_6)" +"(if use-mapping?_0" +"(let-values()" +"(let-values(((id_102)(1/datum->syntax #f sym_76)))" +"(let-values(((b_14)" +"(resolve+shift/extra-inspector" +"(1/namespace-syntax-introduce id_102 ns_11)" +"(namespace-phase ns_11)" +" ns_11)))" +"(let-values((()" +"(begin" +"(if b_14" +"(let-values()" +"(namespace-visit-available-modules!" +" ns_11))" +"(void))" +"(values))))" +"(let-values(((v_196" +" primitive?_8" +" extra-inspector_9" +" protected?_9)" +"(if b_14" +"(let-values(((b116_0) b_14)" +"((empty-env117_0)" +" empty-env)" +"((null118_0) null)" +"((ns119_0) ns_11)" +"((temp120_0)" +"(namespace-phase ns_11))" +"((id121_0) id_102))" +"(binding-lookup50.1" +" #f" +" #f" +" b116_0" +" empty-env117_0" +" null118_0" +" ns119_0" +" temp120_0" +" id121_0))" +"(values variable #f #f #f))))" +"(begin" +"(if(variable? v_196)" +"(void)" +"(let-values()" +"(escape_0" +"(let-values(((or-part_52) failure-thunk_5))" +"(if or-part_52" +" or-part_52" +"(lambda()" +"(raise" +"(make-exn:fail:syntax$1" +"(format" +"(string-append" +" \"namespace-variable-value: bound to syntax\\n\"" +" \" in: ~s\")" +" sym_76)" +"(current-continuation-marks)" +" null))))))))" +"(if(module-binding? b_14)" +"(values" +"(if(top-level-module-path-index?" +"(module-binding-module b_14))" +" ns_11" +"(module-instance-namespace" +"(binding->module-instance" +" b_14" +" ns_11" +"(namespace-phase ns_11)" +" id_102)))" +"(module-binding-phase b_14)" +"(module-binding-sym b_14))" +"(values" +" ns_11" +"(namespace-phase ns_11)" +" sym_76))))))))" +"(let-values()(values ns_11(namespace-phase ns_11) sym_76)))))" +"(let-values(((val_71)" +"(namespace-get-variable" +" var-ns_0" +" var-phase-level_0" +" var-sym_6" +"(lambda()" +"(escape_0" +"(let-values(((or-part_296) failure-thunk_5))" +"(if or-part_296" +" or-part_296" +"(raise" +"(exn:fail:contract:variable" +"(format" +"(string-append" +" \"namespace-variable-value: given name is not defined\\n\"" +" \" name: ~s\")" +" sym_76)" +"(current-continuation-marks)" +" sym_76)))))))))" +"(lambda() val_71))))))))))))))))))" +"(case-lambda" +"((sym_77)(begin 'namespace-variable-value(namespace-variable-value44_0 sym_77 #t #f unsafe-undefined)))" +"((sym_78 use-mapping?_1 failure-thunk_6 ns42_1)" +"(namespace-variable-value44_0 sym_78 use-mapping?_1 failure-thunk_6 ns42_1))" +"((sym_79 use-mapping?_2 failure-thunk41_1)" +"(namespace-variable-value44_0 sym_79 use-mapping?_2 failure-thunk41_1 unsafe-undefined))" +"((sym_80 use-mapping?40_1)(namespace-variable-value44_0 sym_80 use-mapping?40_1 #f unsafe-undefined)))))" +"(define-values" +"(1/namespace-set-variable-value!)" +"(let-values(((namespace-set-variable-value!51_0)" +"(lambda(sym49_0 val50_0 map?46_0 ns47_2 as-constant?48_0)" +"(begin" +" 'namespace-set-variable-value!51" +"(let-values(((sym_81) sym49_0))" +"(let-values(((val_72) val50_0))" +"(let-values(((map?_0) map?46_0))" +"(let-values(((ns_82)(if(eq? ns47_2 unsafe-undefined)(1/current-namespace) ns47_2)))" +"(let-values(((as-constant?_2) as-constant?48_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(symbol? sym_81)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-set-variable-value! \"symbol?\" sym_81)))" +"(if(1/namespace? ns_82)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-set-variable-value! \"namespace?\" ns_82)))" +"(namespace-set-variable!" +" ns_82" +"(namespace-phase ns_82)" +" sym_81" +" val_72" +" as-constant?_2)" +"(if map?_0" +"(let-values()" +"(let-values((()" +"(begin" +"(namespace-unset-transformer!" +" ns_82" +"(namespace-phase ns_82)" +" sym_81)" +"(values))))" +"(let-values(((id_103)(1/datum->syntax #f sym_81)))" +"(let-values(((temp123_1)(1/namespace-syntax-introduce id_103 ns_82))" +"((temp124_0)" +"(let-values(((temp126_0)(namespace-mpi ns_82))" +"((temp127_3)(namespace-phase ns_82))" +"((sym128_0) sym_81))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" temp126_0" +" temp127_3" +" sym128_0)))" +"((temp125_0)(namespace-phase ns_82)))" +"(add-binding!17.1 #f #f temp123_1 temp124_0 temp125_0)))))" +"(void)))))))))))))))" +"(case-lambda" +"((sym_82 val_73)" +"(begin 'namespace-set-variable-value!(namespace-set-variable-value!51_0 sym_82 val_73 #f unsafe-undefined #f)))" +"((sym_83 val_74 map?_1 ns_83 as-constant?48_1)" +"(namespace-set-variable-value!51_0 sym_83 val_74 map?_1 ns_83 as-constant?48_1))" +"((sym_84 val_75 map?_2 ns47_3)(namespace-set-variable-value!51_0 sym_84 val_75 map?_2 ns47_3 #f))" +"((sym_85 val_76 map?46_1)(namespace-set-variable-value!51_0 sym_85 val_76 map?46_1 unsafe-undefined #f)))))" +"(define-values" +"(1/namespace-undefine-variable!)" +"(let-values(((namespace-undefine-variable!55_0)" +"(lambda(sym54_0 ns53_0)" +"(begin" +" 'namespace-undefine-variable!55" +"(let-values(((sym_86) sym54_0))" +"(let-values(((ns_84)(if(eq? ns53_0 unsafe-undefined)(1/current-namespace) ns53_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(symbol? sym_86)" +"(void)" +" (let-values () (raise-argument-error 'namespace-undefine-variable! \"symbol?\" sym_86)))" +"(if(1/namespace? ns_84)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-undefine-variable! \"namespace?\" ns_84)))" +"(namespace-unset-variable! ns_84(namespace-phase ns_84) sym_86)))))))))))" +"(case-lambda" +"((sym_87)(begin 'namespace-undefine-variable!(namespace-undefine-variable!55_0 sym_87 unsafe-undefined)))" +"((sym_7 ns53_1)(namespace-undefine-variable!55_0 sym_7 ns53_1)))))" +"(define-values" +"(1/namespace-mapped-symbols)" +"(let-values(((namespace-mapped-symbols58_0)" +"(lambda(ns57_0)" +"(begin" +" 'namespace-mapped-symbols58" +"(let-values(((ns_85)(if(eq? ns57_0 unsafe-undefined)(1/current-namespace) ns57_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/namespace? ns_85)" +"(void)" +" (let-values () (raise-argument-error 'namespace-mapped-symbols \"namespace?\" ns_85)))" +"(set->list" +"(set-union" +"(syntax-mapped-names" +"(root-expand-context-all-scopes-stx(namespace-get-root-expand-ctx ns_85))" +"(namespace-phase ns_85))" +"(list->set(1/instance-variable-names(namespace->instance ns_85 0))))))))))))))" +"(case-lambda" +"(()(begin 'namespace-mapped-symbols(namespace-mapped-symbols58_0 unsafe-undefined)))" +"((ns57_1)(namespace-mapped-symbols58_0 ns57_1)))))" +"(define-values" +"(1/namespace-base-phase)" +"(let-values(((namespace-base-phase61_0)" +"(lambda(ns60_0)" +"(begin" +" 'namespace-base-phase61" +"(let-values(((ns_86)(if(eq? ns60_0 unsafe-undefined)(1/current-namespace) ns60_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/namespace? ns_86)" +"(void)" +" (let-values () (raise-argument-error 'namespace-base-phase \"namespace?\" ns_86)))" +"(namespace-phase ns_86))))))))))" +"(case-lambda" +"(()(begin 'namespace-base-phase(namespace-base-phase61_0 unsafe-undefined)))" +"((ns60_1)(namespace-base-phase61_0 ns60_1)))))" +"(define-values" +"(1/eval)" +"(let-values(((eval4_0)" +"(lambda(s3_1 ns1_4 compile2_0)" +"(begin" +" 'eval4" +"(let-values(((s_447) s3_1))" +"(let-values(((ns_87)(if(eq? ns1_4 unsafe-undefined)(1/current-namespace) ns1_4)))" +"(let-values(((compile_1)" +"(if(eq? compile2_0 unsafe-undefined)" +"(lambda(s_75 ns_55)(begin 'compile(1/compile s_75 ns_55 #f)))" +" compile2_0)))" +"(let-values()" +"(if(let-values(((or-part_28)(compiled-in-memory? s_447)))" +"(if or-part_28" +" or-part_28" +"(let-values(((or-part_294)(1/linklet-directory? s_447)))" +"(if or-part_294 or-part_294(1/linklet-bundle? s_447)))))" +"(let-values()(eval-compiled s_447 ns_87))" +"(if(if(syntax?$1 s_447)" +"(let-values(((or-part_297)(compiled-in-memory?(1/syntax-e s_447))))" +"(if or-part_297" +" or-part_297" +"(let-values(((or-part_298)(1/linklet-directory?(1/syntax-e s_447))))" +"(if or-part_298 or-part_298(1/linklet-bundle?(1/syntax-e s_447))))))" +" #f)" +"(let-values()(eval-compiled(1/syntax->datum s_447) ns_87))" +"(let-values()" +"(let-values(((s66_0) s_447)" +"((ns67_1) ns_87)" +"((temp68_2)" +"(lambda(s_180 ns_88 tail?_52)" +"(eval-compiled(compile_1 s_180 ns_88) ns_88 tail?_52)))" +"((temp69_0) #f))" +"(per-top-level54.1 #f #f temp69_0 #t #f temp68_2 #f s66_0 ns67_1)))))))))))))" +"(case-lambda" +"((s_446)(begin 'eval(eval4_0 s_446 unsafe-undefined unsafe-undefined)))" +"((s_76 ns_89 compile2_1)(eval4_0 s_76 ns_89 compile2_1))" +"((s_442 ns1_5)(eval4_0 s_442 ns1_5 unsafe-undefined)))))" +"(define-values" +"(eval-compiled)" +"(let-values(((eval-compiled9_0)" +"(lambda(c7_1 ns8_0 as-tail?6_0)" +"(begin" +" 'eval-compiled9" +"(let-values(((c_52) c7_1))" +"(let-values(((ns_90) ns8_0))" +"(let-values(((as-tail?_3) as-tail?6_0))" +"(let-values()" +"(if(1/compiled-module-expression? c_52)" +"(let-values()" +"(let-values(((c70_0) c_52)((ns71_0) ns_90))(eval-module8.1 ns71_0 #f #t c70_0)))" +"(let-values()(eval-top c_52 ns_90 eval-compiled as-tail?_3)))))))))))" +"(case-lambda" +"((c_53 ns_91)(begin(eval-compiled9_0 c_53 ns_91 #t)))" +"((c_54 ns_92 as-tail?6_1)(eval-compiled9_0 c_54 ns_92 as-tail?6_1)))))" +"(define-values" +"(1/compile)" +"(let-values(((compile16_0)" +"(lambda(s15_1 ns11_1 serializable?12_0 expand13_0 to-source?14_0)" +"(begin" +" 'compile16" +"(let-values(((s_184) s15_1))" +"(let-values(((ns_93)(if(eq? ns11_1 unsafe-undefined)(1/current-namespace) ns11_1)))" +"(let-values(((serializable?_4) serializable?12_0))" +"(let-values(((expand_0)(if(eq? expand13_0 unsafe-undefined) expand$1 expand13_0)))" +"(let-values(((to-source?_4) to-source?14_0))" +"(let-values()" +"(let-values(((cs_0)" +"(if(1/compiled-expression? s_184)" +"(let-values()(list s_184))" +"(if(if(syntax?$1 s_184)" +"(1/compiled-expression?(1/syntax-e s_184))" +" #f)" +"(let-values()(list(1/syntax-e s_184)))" +"(let-values()" +"(let-values(((s72_0) s_184)" +"((ns73_0) ns_93)" +"((temp74_0)" +"(lambda(s_448 ns_47 as-tail?_4)" +"(list" +"(compile-single$1" +" s_448" +" ns_47" +" expand_0" +" serializable?_4" +" to-source?_4))))" +"((append75_0) append)" +"((temp76_0) #f))" +"(per-top-level54.1" +" append75_0" +" #f" +" temp76_0" +" #t" +" #f" +" temp74_0" +" #f" +" s72_0" +" ns73_0)))))))" +"(if(if(= 1(length cs_0))(not(compiled-multiple-top?(car cs_0))) #f)" +"(car cs_0)" +"(let-values(((cs77_0) cs_0)" +"((to-source?78_0) to-source?_4)" +"((serializable?79_0) serializable?_4)" +"((ns80_0) ns_93))" +"(compiled-tops->compiled-top8.1" +" serializable?79_0" +" ns80_0" +" to-source?78_0" +" cs77_0))))))))))))))" +"(case-lambda" +"((s_11)(begin 'compile(compile16_0 s_11 unsafe-undefined #t unsafe-undefined #f)))" +"((s_449 ns_94 serializable?_5 expand_1 to-source?14_1)" +"(compile16_0 s_449 ns_94 serializable?_5 expand_1 to-source?14_1))" +"((s_14 ns_95 serializable?_6 expand13_1)(compile16_0 s_14 ns_95 serializable?_6 expand13_1 #f))" +"((s_15 ns_96 serializable?12_1)(compile16_0 s_15 ns_96 serializable?12_1 unsafe-undefined #f))" +"((s_83 ns11_2)(compile16_0 s_83 ns11_2 #t unsafe-undefined #f)))))" +"(define-values" +"(compile-to-linklets)" +"(let-values(((compile-to-linklets20_0)" +"(lambda(s19_0 ns18_1)" +"(begin" +" 'compile-to-linklets20" +"(let-values(((s_20) s19_0))" +"(let-values(((ns_63)(if(eq? ns18_1 unsafe-undefined)(1/current-namespace) ns18_1)))" +"(let-values()(1/compile s_20 ns_63 #t expand$1 #t))))))))" +"(case-lambda" +"((s_450)(begin(compile-to-linklets20_0 s_450 unsafe-undefined)))" +"((s_22 ns18_2)(compile-to-linklets20_0 s_22 ns18_2)))))" +"(define-values" +"(struct:lifted-parsed-begin" +" lifted-parsed-begin22.1" +" lifted-parsed-begin?" +" lifted-parsed-begin-seq" +" lifted-parsed-begin-last)" +"(let-values(((struct:_80 make-_80 ?_80 -ref_80 -set!_80)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'lifted-parsed-begin" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'lifted-parsed-begin)))))" +"(values" +" struct:_80" +" make-_80" +" ?_80" +"(make-struct-field-accessor -ref_80 0 'seq)" +"(make-struct-field-accessor -ref_80 1 'last))))" +"(define-values" +"(compile-single$1)" +"(lambda(s_451 ns_97 expand_2 serializable?_7 to-source?_5)" +"(begin" +" 'compile-single" +"(let-values(((exp-s_4)(expand_2 s_451 ns_97 #f #t serializable?_7)))" +"((letrec-values(((loop_100)" +"(lambda(exp-s_5)" +"(begin" +" 'loop" +"(if(parsed-module? exp-s_5)" +"(let-values()" +"(let-values(((exp-s82_0) exp-s_5)" +"((temp83_1)" +"(let-values(((ns86_0) ns_97))" +"(make-compile-context14.1" +" #f" +" unsafe-undefined" +" #f" +" ns86_0" +" unsafe-undefined" +" unsafe-undefined)))" +"((serializable?84_0) serializable?_7)" +"((to-source?85_0) to-source?_5))" +"(compile-module13.1" +" #f" +" unsafe-undefined" +" #t" +" serializable?84_0" +" to-source?85_0" +" exp-s82_0" +" temp83_1)))" +"(if(lifted-parsed-begin? exp-s_5)" +"(let-values()" +"(let-values(((temp87_0)" +"(reverse$1" +"(let-values(((lst_168)" +"(append" +"(lifted-parsed-begin-seq exp-s_5)" +"(list(lifted-parsed-begin-last exp-s_5)))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_168)))" +"((letrec-values(((for-loop_5)" +"(lambda(fold-var_273 lst_300)" +"(begin" +" 'for-loop" +"(if(pair? lst_300)" +"(let-values(((e_74)" +"(unsafe-car lst_300))" +"((rest_88)" +"(unsafe-cdr lst_300)))" +"(let-values(((fold-var_166)" +"(let-values(((fold-var_167)" +" fold-var_273))" +"(let-values(((fold-var_168)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_100" +" e_74))" +" fold-var_167))))" +"(values" +" fold-var_168)))))" +"(if(not #f)" +"(for-loop_5 fold-var_166 rest_88)" +" fold-var_166)))" +" fold-var_273)))))" +" for-loop_5)" +" null" +" lst_168)))))" +"((to-source?88_0) to-source?_5))" +"(compiled-tops->compiled-top8.1 #f #f to-source?88_0 temp87_0)))" +"(let-values()" +"(let-values(((exp-s89_0) exp-s_5)" +"((temp90_1)" +"(let-values(((ns93_1) ns_97))" +"(make-compile-context14.1" +" #f" +" unsafe-undefined" +" #f" +" ns93_1" +" unsafe-undefined" +" unsafe-undefined)))" +"((serializable?91_0) serializable?_7)" +"((to-source?92_0) to-source?_5))" +"(compile-top9.1 serializable?91_0 #f to-source?92_0 exp-s89_0 temp90_1)))))))))" +" loop_100)" +" exp-s_4)))))" +"(define-values" +"(expand$1)" +"(let-values(((expand28_0)" +"(lambda(s27_1 ns23_0 observable?24_0 to-parsed?25_0 serializable?26_0)" +"(begin" +" 'expand28" +"(let-values(((s_452) s27_1))" +"(let-values(((ns_98)(if(eq? ns23_0 unsafe-undefined)(1/current-namespace) ns23_0)))" +"(let-values(((observable?_0) observable?24_0))" +"(let-values(((to-parsed?_2) to-parsed?25_0))" +"(let-values(((serializable?_8) serializable?26_0))" +"(let-values()" +"(let-values(((observer_2)(if observable?_0(current-expand-observe) #f)))" +"(begin" +"(if observer_2(let-values()(call-expand-observe observer_2 'start-top))(void))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-observe" +" #f)" +"(let-values()" +"(let-values(((s94_1) s_452)" +"((ns95_0) ns_98)" +"((temp96_2)" +"(lambda(s_314 ns_99 as-tail?_5)" +"(expand-single" +" s_314" +" ns_99" +" observer_2" +" to-parsed?_2" +" serializable?_8)))" +"((cons97_0) cons)" +"((re-pair98_0) re-pair)" +"((observer99_0) observer_2))" +"(per-top-level54.1" +" cons97_0" +" #f" +" observer99_0" +" #t" +" #f" +" temp96_2" +" re-pair98_0" +" s94_1" +" ns95_0))))))))))))))))" +"(case-lambda" +"((s_453)(begin 'expand(expand28_0 s_453 unsafe-undefined #f #f #f)))" +"((s_454 ns_9 observable?_1 to-parsed?_3 serializable?26_1)" +"(expand28_0 s_454 ns_9 observable?_1 to-parsed?_3 serializable?26_1))" +"((s_455 ns_100 observable?_2 to-parsed?25_1)(expand28_0 s_455 ns_100 observable?_2 to-parsed?25_1 #f))" +"((s_305 ns_101 observable?24_1)(expand28_0 s_305 ns_101 observable?24_1 #f #f))" +"((s_456 ns23_1)(expand28_0 s_456 ns23_1 #f #f #f)))))" +"(define-values" +"(expand-single)" +"(lambda(s_58 ns_102 observer_3 to-parsed?_4 serializable?_9)" +"(begin" +"(let-values(((rebuild-s_2)(keep-properties-only s_58)))" +"(let-values(((ctx_68)" +"(let-values(((ns100_0) ns_102)" +"((to-parsed?101_0) to-parsed?_4)" +"((serializable?102_0) serializable?_9)" +"((observer103_0) observer_3))" +"(make-expand-context10.1 serializable?102_0 observer103_0 to-parsed?101_0 ns100_0))))" +"(let-values(((require-lifts_3 lifts_10 exp-s_0)(expand-capturing-lifts s_58 ctx_68)))" +"(if(if(null? require-lifts_3)(null? lifts_10) #f)" +"(let-values() exp-s_0)" +"(if to-parsed?_4" +"(let-values()" +"(let-values(((require-lifts104_0) require-lifts_3)" +"((lifts105_0) lifts_10)" +"((exp-s106_0) exp-s_0)" +"((rebuild-s107_0) rebuild-s_2)" +"((temp108_1)" +"(lambda(form_0)" +"(expand-single form_0 ns_102 observer_3 to-parsed?_4 serializable?_9))))" +"(wrap-lifts-as-lifted-parsed-begin63.1" +" temp108_1" +" require-lifts104_0" +" lifts105_0" +" exp-s106_0" +" rebuild-s107_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(log-top-lift-begin-before ctx_68 require-lifts_3 lifts_10 exp-s_0 ns_102)" +"(values))))" +"(let-values(((new-s_2)" +"(let-values(((temp109_0)(append require-lifts_3 lifts_10))" +"((temp110_1)" +"(lambda(form_1)" +"(begin" +"(let-values(((obs_45)(expand-context-observer ctx_68)))" +"(if obs_45" +"(let-values()" +"(let-values()(call-expand-observe obs_45 'next)))" +"(void)))" +"(expand-single" +" form_1" +" ns_102" +" observer_3" +" to-parsed?_4" +" serializable?_9))))" +"((temp111_1)" +"(lambda(form_2)" +"(if to-parsed?_4" +"(let-values() form_2)" +"(let-values()" +"(begin" +"(let-values(((obs_46)(expand-context-observer ctx_68)))" +"(if obs_46" +"(let-values()" +"(let-values()(call-expand-observe obs_46 'next)))" +"(void)))" +"(expand-single" +" form_2" +" ns_102" +" observer_3" +" to-parsed?_4" +" serializable?_9))))))" +"((exp-s112_0) exp-s_0)" +"((temp113_2)(namespace-phase ns_102)))" +"(wrap-lifts-as-begin16.1 temp111_1 temp110_1 temp109_0 exp-s112_0 temp113_2))))" +"(begin(log-top-begin-after ctx_68 new-s_2) new-s_2))))))))))))" +"(define-values" +"(expand-once$1)" +"(let-values(((expand-once32_0)" +"(lambda(s31_0 ns30_0)" +"(begin" +" 'expand-once32" +"(let-values(((s_66) s31_0))" +"(let-values(((ns_103)(if(eq? ns30_0 unsafe-undefined)(1/current-namespace) ns30_0)))" +"(let-values()" +"(let-values(((s114_0) s_66)" +"((ns115_0) ns_103)" +"((temp116_0)" +"(lambda(s_425 ns_104 as-tail?_6)(expand-single-once s_425 ns_104)))" +"((cons117_0) cons)" +"((re-pair118_0) re-pair)" +"((temp119_1) #t)" +"((temp120_1) #f))" +"(per-top-level54.1" +" cons117_0" +" temp119_1" +" temp120_1" +" #t" +" #f" +" temp116_0" +" re-pair118_0" +" s114_0" +" ns115_0)))))))))" +"(case-lambda" +"((s_38)(begin 'expand-once(expand-once32_0 s_38 unsafe-undefined)))" +"((s_319 ns30_1)(expand-once32_0 s_319 ns30_1)))))" +"(define-values" +"(expand-single-once)" +"(lambda(s_457 ns_83)" +"(begin" +"(let-values(((require-lifts_4 lifts_11 exp-s_6)" +"(expand-capturing-lifts" +" s_457" +"(let-values(((v_128)(let-values(((ns121_0) ns_83))(make-expand-context10.1 #f #f #f ns121_0))))" +"(let-values(((the-struct_69) v_128))" +"(if(expand-context/outer? the-struct_69)" +"(let-values(((inner122_0)" +"(let-values(((the-struct_70)(root-expand-context/outer-inner v_128)))" +"(if(expand-context/inner? the-struct_70)" +"(let-values(((just-once?123_0) #t))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_70)" +"(root-expand-context/inner-module-scopes the-struct_70)" +"(root-expand-context/inner-top-level-bind-scope the-struct_70)" +"(root-expand-context/inner-all-scopes-stx the-struct_70)" +"(root-expand-context/inner-defined-syms the-struct_70)" +"(root-expand-context/inner-counter the-struct_70)" +"(root-expand-context/inner-lift-key the-struct_70)" +"(expand-context/inner-to-parsed? the-struct_70)" +"(expand-context/inner-phase the-struct_70)" +"(expand-context/inner-namespace the-struct_70)" +" just-once?123_0" +"(expand-context/inner-module-begin-k the-struct_70)" +"(expand-context/inner-allow-unbound? the-struct_70)" +"(expand-context/inner-in-local-expand? the-struct_70)" +"(expand-context/inner-keep-#%expression? the-struct_70)" +"(expand-context/inner-stops the-struct_70)" +"(expand-context/inner-declared-submodule-names the-struct_70)" +"(expand-context/inner-lifts the-struct_70)" +"(expand-context/inner-lift-envs the-struct_70)" +"(expand-context/inner-module-lifts the-struct_70)" +"(expand-context/inner-require-lifts the-struct_70)" +"(expand-context/inner-to-module-lifts the-struct_70)" +"(expand-context/inner-requires+provides the-struct_70)" +"(expand-context/inner-observer the-struct_70)" +"(expand-context/inner-for-serializable? the-struct_70)" +"(expand-context/inner-should-not-encounter-macros? the-struct_70)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_70)))))" +"(expand-context/outer1.1" +" inner122_0" +"(root-expand-context/outer-post-expansion the-struct_69)" +"(root-expand-context/outer-use-site-scopes the-struct_69)" +"(root-expand-context/outer-frame-id the-struct_69)" +"(expand-context/outer-context the-struct_69)" +"(expand-context/outer-env the-struct_69)" +"(expand-context/outer-scopes the-struct_69)" +"(expand-context/outer-def-ctx-scopes the-struct_69)" +"(expand-context/outer-binding-layer the-struct_69)" +"(expand-context/outer-reference-records the-struct_69)" +"(expand-context/outer-only-immediate? the-struct_69)" +"(expand-context/outer-need-eventually-defined the-struct_69)" +"(expand-context/outer-current-introduction-scopes the-struct_69)" +"(expand-context/outer-current-use-scopes the-struct_69)" +"(expand-context/outer-name the-struct_69)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_69)))))))" +"(if(if(null? require-lifts_4)(null? lifts_11) #f)" +"(let-values() exp-s_6)" +"(let-values()" +"(let-values(((temp124_1)(append require-lifts_4 lifts_11))" +"((exp-s125_0) exp-s_6)" +"((temp126_1)(namespace-phase ns_83)))" +"(wrap-lifts-as-begin16.1 unsafe-undefined unsafe-undefined temp124_1 exp-s125_0 temp126_1))))))))" +"(define-values" +"(expand-to-top-form$1)" +"(let-values(((expand-to-top-form36_0)" +"(lambda(s35_0 ns34_0)" +"(begin" +" 'expand-to-top-form36" +"(let-values(((s_458) s35_0))" +"(let-values(((ns_105)(if(eq? ns34_0 unsafe-undefined)(1/current-namespace) ns34_0)))" +"(let-values()" +"(let-values(((observer_4)(current-expand-observe)))" +"(begin" +"(if observer_4(let-values()(call-expand-observe observer_4 'start-top))(void))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-observe" +" #f)" +"(let-values()" +"(let-values(((s127_0) s_458)" +"((ns128_0) ns_105)" +"((temp129_1) #f)" +"((temp130_0) #f)" +"((observer131_0) observer_4))" +"(per-top-level54.1" +" #f" +" #f" +" observer131_0" +" temp130_0" +" #f" +" temp129_1" +" #f" +" s127_0" +" ns128_0)))))))))))))" +"(case-lambda" +"((s_459)(begin 'expand-to-top-form(expand-to-top-form36_0 s_459 unsafe-undefined)))" +"((s_460 ns34_1)(expand-to-top-form36_0 s_460 ns34_1)))))" +"(define-values" +"(per-top-level54.1)" +"(lambda(combine39_0" +" just-once?41_0" +" observer44_0" +" quick-immediate?42_0" +" serializable?43_0" +" single38_0" +" wrap40_0" +" given-s52_0" +" ns53_2)" +"(begin" +" 'per-top-level54" +"(let-values(((given-s_0) given-s52_0))" +"(let-values(((ns_106) ns53_2))" +"(let-values(((single_0) single38_0))" +"(let-values(((combine_0) combine39_0))" +"(let-values(((wrap_2) wrap40_0))" +"(let-values(((just-once?_1) just-once?41_0))" +"(let-values(((quick-immediate?_0) quick-immediate?42_0))" +"(let-values(((serializable?_10) serializable?43_0))" +"(let-values(((observer_5) observer44_0))" +"(let-values()" +"(let-values(((s_216)(maybe-intro given-s_0 ns_106)))" +"(let-values(((ctx_69)" +"(let-values(((ns132_0) ns_106)((observer133_0) observer_5))" +"(make-expand-context10.1 #f observer133_0 #f ns132_0))))" +"(let-values(((phase_133)(namespace-phase ns_106)))" +"((letrec-values(((loop_101)" +"(lambda(s_461 phase_134 ns_107 as-tail?_7)" +"(begin" +" 'loop" +"(let-values(((tl-ctx_0)" +"(let-values(((v_197) ctx_69))" +"(let-values(((the-struct_71) v_197))" +"(if(expand-context/outer? the-struct_71)" +"(let-values(((inner134_0)" +"(let-values(((the-struct_72)" +"(root-expand-context/outer-inner" +" v_197)))" +"(if(expand-context/inner?" +" the-struct_72)" +"(let-values(((phase135_1)" +" phase_134)" +"((namespace136_0)" +" ns_107)" +"((just-once?137_0)" +" just-once?_1)" +"((for-serializable?138_0)" +" serializable?_10))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_72)" +"(root-expand-context/inner-module-scopes" +" the-struct_72)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_72)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_72)" +"(root-expand-context/inner-defined-syms" +" the-struct_72)" +"(root-expand-context/inner-counter" +" the-struct_72)" +"(root-expand-context/inner-lift-key" +" the-struct_72)" +"(expand-context/inner-to-parsed?" +" the-struct_72)" +" phase135_1" +" namespace136_0" +" just-once?137_0" +"(expand-context/inner-module-begin-k" +" the-struct_72)" +"(expand-context/inner-allow-unbound?" +" the-struct_72)" +"(expand-context/inner-in-local-expand?" +" the-struct_72)" +"(expand-context/inner-keep-#%expression?" +" the-struct_72)" +"(expand-context/inner-stops" +" the-struct_72)" +"(expand-context/inner-declared-submodule-names" +" the-struct_72)" +"(expand-context/inner-lifts" +" the-struct_72)" +"(expand-context/inner-lift-envs" +" the-struct_72)" +"(expand-context/inner-module-lifts" +" the-struct_72)" +"(expand-context/inner-require-lifts" +" the-struct_72)" +"(expand-context/inner-to-module-lifts" +" the-struct_72)" +"(expand-context/inner-requires+provides" +" the-struct_72)" +"(expand-context/inner-observer" +" the-struct_72)" +" for-serializable?138_0" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_72)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_72)))))" +"(expand-context/outer1.1" +" inner134_0" +"(root-expand-context/outer-post-expansion" +" the-struct_71)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_71)" +"(root-expand-context/outer-frame-id" +" the-struct_71)" +"(expand-context/outer-context" +" the-struct_71)" +"(expand-context/outer-env the-struct_71)" +"(expand-context/outer-scopes the-struct_71)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_71)" +"(expand-context/outer-binding-layer" +" the-struct_71)" +"(expand-context/outer-reference-records" +" the-struct_71)" +"(expand-context/outer-only-immediate?" +" the-struct_71)" +"(expand-context/outer-need-eventually-defined" +" the-struct_71)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_71)" +"(expand-context/outer-current-use-scopes" +" the-struct_71)" +"(expand-context/outer-name the-struct_71)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_71))))))" +"(let-values(((wb-s_0)(if just-once?_1 s_461 #f)))" +"(let-values((()" +"(begin" +"(let-values(((obs_47)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_47" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_47" +" 'visit" +" s_461)))" +"(void)))" +"(values))))" +"(let-values(((require-lifts_5 lifts_12 exp-s_7)" +"(expand-capturing-lifts" +" s_461" +"(let-values(((v_198) tl-ctx_0))" +"(let-values(((the-struct_73) v_198))" +"(if(expand-context/outer? the-struct_73)" +"(let-values(((only-immediate?139_0)" +" #t)" +"((inner140_0)" +"(let-values(((the-struct_74)" +"(root-expand-context/outer-inner" +" v_198)))" +"(if(expand-context/inner?" +" the-struct_74)" +"(let-values(((phase141_0)" +" phase_134)" +"((namespace142_0)" +" ns_107))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_74)" +"(root-expand-context/inner-module-scopes" +" the-struct_74)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_74)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_74)" +"(root-expand-context/inner-defined-syms" +" the-struct_74)" +"(root-expand-context/inner-counter" +" the-struct_74)" +"(root-expand-context/inner-lift-key" +" the-struct_74)" +"(expand-context/inner-to-parsed?" +" the-struct_74)" +" phase141_0" +" namespace142_0" +"(expand-context/inner-just-once?" +" the-struct_74)" +"(expand-context/inner-module-begin-k" +" the-struct_74)" +"(expand-context/inner-allow-unbound?" +" the-struct_74)" +"(expand-context/inner-in-local-expand?" +" the-struct_74)" +"(expand-context/inner-keep-#%expression?" +" the-struct_74)" +"(expand-context/inner-stops" +" the-struct_74)" +"(expand-context/inner-declared-submodule-names" +" the-struct_74)" +"(expand-context/inner-lifts" +" the-struct_74)" +"(expand-context/inner-lift-envs" +" the-struct_74)" +"(expand-context/inner-module-lifts" +" the-struct_74)" +"(expand-context/inner-require-lifts" +" the-struct_74)" +"(expand-context/inner-to-module-lifts" +" the-struct_74)" +"(expand-context/inner-requires+provides" +" the-struct_74)" +"(expand-context/inner-observer" +" the-struct_74)" +"(expand-context/inner-for-serializable?" +" the-struct_74)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_74)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_74)))))" +"(expand-context/outer1.1" +" inner140_0" +"(root-expand-context/outer-post-expansion" +" the-struct_73)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_73)" +"(root-expand-context/outer-frame-id" +" the-struct_73)" +"(expand-context/outer-context" +" the-struct_73)" +"(expand-context/outer-env" +" the-struct_73)" +"(expand-context/outer-scopes" +" the-struct_73)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_73)" +"(expand-context/outer-binding-layer" +" the-struct_73)" +"(expand-context/outer-reference-records" +" the-struct_73)" +" only-immediate?139_0" +"(expand-context/outer-need-eventually-defined" +" the-struct_73)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_73)" +"(expand-context/outer-current-use-scopes" +" the-struct_73)" +"(expand-context/outer-name" +" the-struct_73)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_73)))))))" +"(let-values(((disarmed-exp-s_0)" +"(syntax-disarm$1 exp-s_7)))" +"(if(let-values(((or-part_299)" +"(pair? require-lifts_5)))" +"(if or-part_299 or-part_299(pair? lifts_12)))" +"(let-values()" +"(let-values(((new-s_3)" +"(let-values(((temp143_1)" +"(append" +" require-lifts_5" +" lifts_12))" +"((exp-s144_0) exp-s_7)" +"((phase145_0) phase_134))" +"(wrap-lifts-as-begin16.1" +" unsafe-undefined" +" unsafe-undefined" +" temp143_1" +" exp-s144_0" +" phase145_0))))" +"(begin" +"(let-values(((obs_48)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_48" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_48" +" 'lift-loop" +" new-s_3)))" +"(void)))" +"(if just-once?_1" +" new-s_3" +"(loop_101" +" new-s_3" +" phase_134" +" ns_107" +" as-tail?_7)))))" +"(if(not single_0)" +"(let-values()" +"(begin" +"(let-values(((obs_49)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_49" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_49" +" 'return" +" exp-s_7)))" +"(void)))" +" exp-s_7))" +"(if(if just-once?_1(not(eq? exp-s_7 wb-s_0)) #f)" +"(let-values() exp-s_7)" +"(let-values()" +"(let-values(((tmp_35)" +"(core-form-sym" +" disarmed-exp-s_0" +" phase_134)))" +"(if(equal? tmp_35 'begin)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_50)" +"(expand-context-observer" +" ctx_69)))" +"(if obs_50" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_50" +" 'prim-begin)))" +"(void)))" +"(values))))" +"(let-values(((ok?_29 begin146_0 e147_0)" +"(let-values(((s_462)" +" disarmed-exp-s_0))" +"(let-values(((orig-s_33)" +" s_462))" +"(let-values(((begin146_1" +" e147_1)" +"(let-values(((s_162)" +"(if(syntax?$1" +" s_462)" +"(syntax-e$1" +" s_462)" +" s_462)))" +"(if(pair?" +" s_162)" +"(let-values(((begin148_0)" +"(let-values(((s_115)" +"(car" +" s_162)))" +" s_115))" +"((e149_0)" +"(let-values(((s_438)" +"(cdr" +" s_162)))" +"(let-values(((s_224)" +"(if(syntax?$1" +" s_438)" +"(syntax-e$1" +" s_438)" +" s_438)))" +"(let-values(((flat-s_21)" +"(to-syntax-list.1" +" s_224)))" +"(if(not" +" flat-s_21)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_33))" +"(let-values()" +" flat-s_21)))))))" +"(values" +" begin148_0" +" e149_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_33)))))" +"(values" +" #t" +" begin146_1" +" e147_1))))))" +"(letrec-values(((begin-loop_0)" +"(lambda(es_2)" +"(begin" +" 'begin-loop" +"(if(null? es_2)" +"(let-values()" +"(if combine_0" +" null" +"(void)))" +"(if(if(not" +" combine_0)" +"(null?" +"(cdr" +" es_2))" +" #f)" +"(let-values()" +"(loop_101" +"(car es_2)" +" phase_134" +" ns_107" +" as-tail?_7))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_51)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_51" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_51" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((a_67)" +"(if combine_0" +"(loop_101" +"(car" +" es_2)" +" phase_134" +" ns_107" +" #f)" +"(begin" +"(loop_101" +"(car" +" es_2)" +" phase_134" +" ns_107" +" #f)" +"(void)))))" +"(if combine_0" +"(combine_0" +" a_67" +"(begin-loop_0" +"(cdr" +" es_2)))" +"(begin-loop_0" +"(cdr" +" es_2))))))))))))" +"(if wrap_2" +"(let-values()" +"(let-values(((new-s_4)" +"(wrap_2" +" begin146_0" +" exp-s_7" +"(begin-loop_0" +" e147_0))))" +"(begin" +"(let-values(((obs_52)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_52" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_52" +" 'return" +" new-s_4)))" +"(void)))" +" new-s_4)))" +"(let-values()" +"(begin-loop_0 e147_0)))))))" +"(if(equal? tmp_35 'begin-for-syntax)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_43)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_43" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_43" +" 'prim-begin-for-syntax)))" +"(void)))" +"(values))))" +"(let-values(((ok?_30" +" begin-for-syntax150_0" +" e151_0)" +"(let-values(((s_463)" +" disarmed-exp-s_0))" +"(let-values(((orig-s_34)" +" s_463))" +"(let-values(((begin-for-syntax150_1" +" e151_1)" +"(let-values(((s_127)" +"(if(syntax?$1" +" s_463)" +"(syntax-e$1" +" s_463)" +" s_463)))" +"(if(pair?" +" s_127)" +"(let-values(((begin-for-syntax152_0)" +"(let-values(((s_464)" +"(car" +" s_127)))" +" s_464))" +"((e153_0)" +"(let-values(((s_465)" +"(cdr" +" s_127)))" +"(let-values(((s_466)" +"(if(syntax?$1" +" s_465)" +"(syntax-e$1" +" s_465)" +" s_465)))" +"(let-values(((flat-s_22)" +"(to-syntax-list.1" +" s_466)))" +"(if(not" +" flat-s_22)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_34))" +"(let-values()" +" flat-s_22)))))))" +"(values" +" begin-for-syntax152_0" +" e153_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_34)))))" +"(values" +" #t" +" begin-for-syntax150_1" +" e151_1))))))" +"(let-values(((next-phase_0)" +"(add1 phase_134)))" +"(let-values(((next-ns_0)" +"(namespace->namespace-at-phase" +" ns_107" +" next-phase_0)))" +"(let-values((()" +"(begin" +"(let-values(((obs_53)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_53" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_53" +" 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if quick-immediate?_0" +"(let-values()" +"(namespace-visit-available-modules!" +" ns_107))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +" next-ns_0)" +"(values))))" +"(let-values(((l_72)" +"(reverse$1" +"(let-values(((lst_208)" +" e151_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_208)))" +"((letrec-values(((for-loop_266)" +"(lambda(fold-var_274" +" lst_301)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_301)" +"(let-values(((s_467)" +"(unsafe-car" +" lst_301))" +"((rest_113)" +"(unsafe-cdr" +" lst_301)))" +"(let-values(((fold-var_257)" +"(let-values(((fold-var_275)" +" fold-var_274))" +"(let-values(((fold-var_205)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(let-values(((obs_54)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_54" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_54" +" 'next)))" +"(void)))" +"(loop_101" +" s_467" +" next-phase_0" +" next-ns_0" +" #f)))" +" fold-var_275))))" +"(values" +" fold-var_205)))))" +"(if(not" +" #f)" +"(for-loop_266" +" fold-var_257" +" rest_113)" +" fold-var_257)))" +" fold-var_274)))))" +" for-loop_266)" +" null" +" lst_208))))))" +"(if wrap_2" +"(let-values()" +"(let-values(((new-s_5)" +"(wrap_2" +" begin-for-syntax150_0" +" exp-s_7" +" l_72)))" +"(begin" +"(let-values(((obs_55)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_55" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_55" +" 'return" +" new-s_5)))" +"(void)))" +" new-s_5)))" +"(if combine_0" +"(let-values()" +"(apply" +" append" +" l_72))" +"(let-values()" +"(void)))))))))))))" +"(let-values()" +"(single_0" +" exp-s_7" +" ns_107" +" as-tail?_7))))))))))))))))))" +" loop_101)" +" s_216" +" phase_133" +" ns_106" +" #t)))))))))))))))))" +"(define-values" +"(maybe-intro)" +"(lambda(s_340 ns_108)" +"(begin(if(syntax?$1 s_340) s_340(1/namespace-syntax-introduce(1/datum->syntax #f s_340) ns_108)))))" +"(define-values" +"(re-pair)" +"(lambda(form-id_0 s_468 r_44)" +"(begin(syntax-rearm$1(1/datum->syntax(syntax-disarm$1 s_468)(cons form-id_0 r_44) s_468 s_468) s_468))))" +"(define-values" +"(expand-capturing-lifts)" +"(lambda(s_343 ctx_70)" +"(begin" +"(let-values()" +"(let-values(((ns_109)(expand-context-namespace ctx_70)))" +"(let-values((()(begin(namespace-visit-available-modules! ns_109)(values))))" +"(let-values(((lift-ctx_6)" +"(let-values(((temp154_1)(make-top-level-lift ctx_70)))" +"(make-lift-context6.1 #f temp154_1))))" +"(let-values(((require-lift-ctx_2)" +"(make-require-lift-context" +"(namespace-phase ns_109)" +"(make-parse-top-lifted-require ns_109))))" +"(let-values(((exp-s_8)" +"(let-values(((s155_0) s_343)" +"((temp156_0)" +"(let-values(((v_199) ctx_70))" +"(let-values(((the-struct_75) v_199))" +"(if(expand-context/outer? the-struct_75)" +"(let-values(((inner157_0)" +"(let-values(((the-struct_76)" +"(root-expand-context/outer-inner v_199)))" +"(if(expand-context/inner? the-struct_76)" +"(let-values(((lifts158_0) lift-ctx_6)" +"((module-lifts159_0) lift-ctx_6)" +"((require-lifts160_0)" +" require-lift-ctx_2))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_76)" +"(root-expand-context/inner-module-scopes" +" the-struct_76)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_76)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_76)" +"(root-expand-context/inner-defined-syms" +" the-struct_76)" +"(root-expand-context/inner-counter the-struct_76)" +"(root-expand-context/inner-lift-key" +" the-struct_76)" +"(expand-context/inner-to-parsed? the-struct_76)" +"(expand-context/inner-phase the-struct_76)" +"(expand-context/inner-namespace the-struct_76)" +"(expand-context/inner-just-once? the-struct_76)" +"(expand-context/inner-module-begin-k" +" the-struct_76)" +"(expand-context/inner-allow-unbound?" +" the-struct_76)" +"(expand-context/inner-in-local-expand?" +" the-struct_76)" +"(expand-context/inner-keep-#%expression?" +" the-struct_76)" +"(expand-context/inner-stops the-struct_76)" +"(expand-context/inner-declared-submodule-names" +" the-struct_76)" +" lifts158_0" +"(expand-context/inner-lift-envs the-struct_76)" +" module-lifts159_0" +" require-lifts160_0" +"(expand-context/inner-to-module-lifts" +" the-struct_76)" +"(expand-context/inner-requires+provides" +" the-struct_76)" +"(expand-context/inner-observer the-struct_76)" +"(expand-context/inner-for-serializable?" +" the-struct_76)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_76)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_76)))))" +"(expand-context/outer1.1" +" inner157_0" +"(root-expand-context/outer-post-expansion the-struct_75)" +"(root-expand-context/outer-use-site-scopes the-struct_75)" +"(root-expand-context/outer-frame-id the-struct_75)" +"(expand-context/outer-context the-struct_75)" +"(expand-context/outer-env the-struct_75)" +"(expand-context/outer-scopes the-struct_75)" +"(expand-context/outer-def-ctx-scopes the-struct_75)" +"(expand-context/outer-binding-layer the-struct_75)" +"(expand-context/outer-reference-records the-struct_75)" +"(expand-context/outer-only-immediate? the-struct_75)" +"(expand-context/outer-need-eventually-defined the-struct_75)" +"(expand-context/outer-current-introduction-scopes the-struct_75)" +"(expand-context/outer-current-use-scopes the-struct_75)" +"(expand-context/outer-name the-struct_75)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_75))))))" +"(expand9.1 #f #f #f s155_0 temp156_0))))" +"(values" +"(get-and-clear-require-lifts! require-lift-ctx_2)" +"(get-and-clear-lifts! lift-ctx_6)" +" exp-s_8))))))))))" +"(define-values" +"(make-parse-top-lifted-require)" +"(lambda(ns_110)" +"(begin" +"(lambda(s_347 phase_135)" +"(let-values(((ok?_31 #%require161_0 req162_0)" +"(let-values(((s_469)(syntax-disarm$1 s_347)))" +"(let-values(((orig-s_35) s_469))" +"(let-values(((#%require161_1 req162_1)" +"(let-values(((s_470)(if(syntax?$1 s_469)(syntax-e$1 s_469) s_469)))" +"(if(pair? s_470)" +"(let-values(((#%require163_0)(let-values(((s_471)(car s_470))) s_471))" +"((req164_0)" +"(let-values(((s_472)(cdr s_470)))" +"(let-values(((s_473)" +"(if(syntax?$1 s_472)" +"(syntax-e$1 s_472)" +" s_472)))" +"(if(pair? s_473)" +"(let-values(((req165_0)" +"(let-values(((s_474)(car s_473)))" +" s_474))" +"(()" +"(let-values(((s_475)(cdr s_473)))" +"(let-values(((s_476)" +"(if(syntax?$1 s_475)" +"(syntax-e$1 s_475)" +" s_475)))" +"(if(null? s_476)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_35))))))" +"(values req165_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_35))))))" +"(values #%require163_0 req164_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_35)))))" +"(values #t #%require161_1 req162_1))))))" +"(let-values(((temp166_0)(list req162_0))" +"((s167_0) s_347)" +"((ns168_0) ns_110)" +"((phase169_1) phase_135)" +"((phase170_0) phase_135)" +"((temp171_1)(let-values(((temp173_0) #f))(make-requires+provides8.1 #f temp173_0)))" +"((temp172_0) 'require))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" unsafe-undefined" +" #f" +" phase170_0" +" #f" +" #f" +" #f" +" #t" +" temp172_0" +" temp166_0" +" s167_0" +" ns168_0" +" phase169_1" +" temp171_1)))))))" +"(define-values" +"(wrap-lifts-as-lifted-parsed-begin63.1)" +"(lambda(adjust-form57_0 require-lifts59_0 lifts60_0 exp-s61_0 rebuild-s62_0)" +"(begin" +" 'wrap-lifts-as-lifted-parsed-begin63" +"(let-values(((require-lifts_6) require-lifts59_0))" +"(let-values(((lifts_13) lifts60_0))" +"(let-values(((exp-s_9) exp-s61_0))" +"(let-values(((rebuild-s_3) rebuild-s62_0))" +"(let-values(((adjust-form_1) adjust-form57_0))" +"(let-values()" +"(lifted-parsed-begin22.1" +"(append" +"(reverse$1" +"(let-values(((lst_302) require-lifts_6))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_302)))" +"((letrec-values(((for-loop_267)" +"(lambda(fold-var_276 lst_303)" +"(begin" +" 'for-loop" +"(if(pair? lst_303)" +"(let-values(((req_19)(unsafe-car lst_303))" +"((rest_173)(unsafe-cdr lst_303)))" +"(let-values(((fold-var_277)" +"(let-values(((fold-var_278) fold-var_276))" +"(let-values(((fold-var_279)" +"(let-values()" +"(cons" +"(let-values()" +"(parsed-require23.1 req_19))" +" fold-var_278))))" +"(values fold-var_279)))))" +"(if(not #f)(for-loop_267 fold-var_277 rest_173) fold-var_277)))" +" fold-var_276)))))" +" for-loop_267)" +" null" +" lst_302))))" +"(reverse$1" +"(let-values(((lst_304)(get-lifts-as-lists lifts_13)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_304)))" +"((letrec-values(((for-loop_268)" +"(lambda(fold-var_280 lst_305)" +"(begin" +" 'for-loop" +"(if(pair? lst_305)" +"(let-values(((ids+syms+rhs_0)(unsafe-car lst_305))" +"((rest_174)(unsafe-cdr lst_305)))" +"(let-values(((fold-var_281)" +"(let-values(((fold-var_282) fold-var_280))" +"(let-values(((fold-var_283)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((exp-rhs_3)" +"(adjust-form_1" +"(caddr" +" ids+syms+rhs_0))))" +"(let-values(((just-rhs_0)" +"(if(lifted-parsed-begin?" +" exp-rhs_3)" +"(lifted-parsed-begin-last" +" exp-rhs_3)" +" exp-rhs_3)))" +"(let-values(((dv_0)" +"(parsed-define-values19.1" +" rebuild-s_3" +"(car" +" ids+syms+rhs_0)" +"(cadr" +" ids+syms+rhs_0)" +" just-rhs_0)))" +"(if(lifted-parsed-begin?" +" exp-rhs_3)" +"(let-values(((the-struct_77)" +" exp-rhs_3))" +"(if(lifted-parsed-begin?" +" the-struct_77)" +"(let-values(((last174_0)" +" dv_0))" +"(lifted-parsed-begin22.1" +"(lifted-parsed-begin-seq" +" the-struct_77)" +" last174_0))" +"(raise-argument-error" +" 'struct-copy" +" \"lifted-parsed-begin?\"" +" the-struct_77)))" +" dv_0)))))" +" fold-var_282))))" +"(values fold-var_283)))))" +"(if(not #f)(for-loop_268 fold-var_281 rest_174) fold-var_281)))" +" fold-var_280)))))" +" for-loop_268)" +" null" +" lst_304)))))" +" exp-s_9))))))))))" +"(define-values" +"(log-top-lift-begin-before)" +"(lambda(ctx_71 require-lifts_7 lifts_14 exp-s_10 ns_111)" +"(begin" +"(let-values(((obs_56)(expand-context-observer ctx_71)))" +"(if obs_56" +"(let-values()" +"(let-values(((new-s_6)" +"(let-values(((temp175_0)(append require-lifts_7 lifts_14))" +"((exp-s176_0) exp-s_10)" +"((temp177_0)(namespace-phase ns_111)))" +"(wrap-lifts-as-begin16.1" +" unsafe-undefined" +" unsafe-undefined" +" temp175_0" +" exp-s176_0" +" temp177_0))))" +"(begin(call-expand-observe obs_56 'lift-loop new-s_6)(log-top-begin-before ctx_71 new-s_6))))" +"(void))))))" +"(define-values" +"(log-top-begin-before)" +"(lambda(ctx_72 new-s_7)" +"(begin" +"(let-values(((obs_57)(expand-context-observer ctx_72)))" +"(if obs_57" +"(let-values()" +"(let-values(((ok?_32 begin178_0 e179_0)" +"(let-values(((s_477) new-s_7))" +"(let-values(((orig-s_36) s_477))" +"(let-values(((begin178_1 e179_1)" +"(let-values(((s_478)(if(syntax?$1 s_477)(syntax-e$1 s_477) s_477)))" +"(if(pair? s_478)" +"(let-values(((begin180_0)(let-values(((s_479)(car s_478))) s_479))" +"((e181_0)" +"(let-values(((s_480)(cdr s_478)))" +"(let-values(((s_481)" +"(if(syntax?$1 s_480)" +"(syntax-e$1 s_480)" +" s_480)))" +"(let-values(((flat-s_23)(to-syntax-list.1 s_481)))" +"(if(not flat-s_23)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_36))" +"(let-values() flat-s_23)))))))" +"(values begin180_0 e181_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_36)))))" +"(values #t begin178_1 e179_1))))))" +"(begin" +"(call-expand-observe obs_57 'visit new-s_7)" +"(call-expand-observe obs_57 'resolve begin178_0)" +"(call-expand-observe obs_57 'enter-prim new-s_7)" +"(call-expand-observe obs_57 'prim-begin)" +"(call-expand-observe obs_57 'enter-list(1/datum->syntax #f e179_0 new-s_7)))))" +"(void))))))" +"(define-values" +"(log-top-begin-after)" +"(lambda(ctx_73 new-s_8)" +"(begin" +"(let-values(((obs_58)(expand-context-observer ctx_73)))" +"(if obs_58" +"(let-values()" +"(let-values(((ok?_33 begin182_0 e183_0)" +"(let-values(((s_392) new-s_8))" +"(let-values(((orig-s_37) s_392))" +"(let-values(((begin182_1 e183_1)" +"(let-values(((s_482)(if(syntax?$1 s_392)(syntax-e$1 s_392) s_392)))" +"(if(pair? s_482)" +"(let-values(((begin184_0)(let-values(((s_138)(car s_482))) s_138))" +"((e185_0)" +"(let-values(((s_139)(cdr s_482)))" +"(let-values(((s_483)" +"(if(syntax?$1 s_139)" +"(syntax-e$1 s_139)" +" s_139)))" +"(let-values(((flat-s_24)(to-syntax-list.1 s_483)))" +"(if(not flat-s_24)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_37))" +"(let-values() flat-s_24)))))))" +"(values begin184_0 e185_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_37)))))" +"(values #t begin182_1 e183_1))))))" +"(let-values(((obs_59)(expand-context-observer ctx_73)))" +"(if obs_59" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_59 'exit-list(1/datum->syntax #f e183_0 new-s_8))" +"(call-expand-observe obs_59 'exit-prim new-s_8)" +"(call-expand-observe obs_59 'return new-s_8))))" +"(void)))))" +"(void))))))" +" (define-values (replace-me) (lambda (who_0) (begin (lambda args_6 (error who_0 \"this stub must be replaced\")))))" +"(define-values" +"(1/current-eval)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-eval)" +"(lambda(p_51)" +"(begin" +"(if((lambda(p_52)(if(procedure? p_52)(procedure-arity-includes? p_52 1) #f)) p_51)" +"(void)" +" (let-values () (raise-argument-error 'current-eval \"(procedure-arity-includes/c 1)\" p_51)))" +" p_51))))))" +"(define-values" +"(1/current-compile)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-compile)" +"(lambda(p_32)" +"(begin" +"(if((lambda(p_53)(if(procedure? p_53)(procedure-arity-includes? p_53 2) #f)) p_32)" +"(void)" +" (let-values () (raise-argument-error 'current-compile \"(procedure-arity-includes/c 2)\" p_32)))" +" p_32))))))" +"(define-values" +"(1/current-load)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-load)" +"(lambda(p_54)" +"(begin" +"(if((lambda(p_37)(if(procedure? p_37)(procedure-arity-includes? p_37 2) #f)) p_54)" +"(void)" +" (let-values () (raise-argument-error 'current-load \"(procedure-arity-includes/c 2)\" p_54)))" +" p_54))))))" +"(define-values" +"(1/current-load/use-compiled)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-load/use-compiled)" +"(lambda(p_46)" +"(begin" +"(if((lambda(p_48)(if(procedure? p_48)(procedure-arity-includes? p_48 2) #f)) p_46)" +"(void)" +" (let-values () (raise-argument-error 'current-load/use-compiled \"(procedure-arity-includes/c 2)\" p_46)))" +" p_46))))))" +"(define-values" +"(1/current-library-collection-paths)" +"(let-values()" +"(let-values()" +"(make-parameter" +" null" +"(lambda(l_73)" +"(begin" +"(if((lambda(l_74)(if(list? l_74)(andmap2 complete-path-string? l_74) #f)) l_73)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-library-collection-paths" +" \"(listof (and/c path-string? complete-path?))\"" +" l_73)))" +"(map2 to-path l_73)))))))" +"(define-values" +"(1/current-library-collection-links)" +"(let-values()" +"(let-values()" +"(make-parameter" +" null" +"(lambda(l_8)" +"(begin" +"(if((lambda(l_75)" +"(if(list? l_75)" +"(andmap2" +"(lambda(p_55)" +"(let-values(((or-part_297)(not p_55)))" +"(if or-part_297" +" or-part_297" +"(let-values(((or-part_298)(complete-path-string? p_55)))" +"(if or-part_298" +" or-part_298" +"(if(hash? p_55)" +"(let-values(((ht_149) p_55))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_149)))" +"((letrec-values(((for-loop_269)" +"(lambda(result_116 i_166)" +"(begin" +" 'for-loop" +"(if i_166" +"(let-values(((k_35 v_3)" +"(hash-iterate-key+value ht_149 i_166)))" +"(let-values(((result_117)" +"(let-values()" +"(let-values(((result_118)" +"(let-values()" +"(let-values()" +"(if(let-values(((or-part_77)" +"(not" +" k_35)))" +"(if or-part_77" +" or-part_77" +"(if(symbol?" +" k_35)" +"(1/module-path?" +" k_35)" +" #f)))" +"(if(list? v_3)" +"(andmap2" +" complete-path-string?" +" v_3)" +" #f)" +" #f)))))" +"(values result_118)))))" +"(if(if(not((lambda x_82(not result_117)) k_35 v_3))" +"(not #f)" +" #f)" +"(for-loop_269" +" result_117" +"(hash-iterate-next ht_149 i_166))" +" result_117)))" +" result_116)))))" +" for-loop_269)" +" #t" +"(hash-iterate-first ht_149))))" +" #f))))))" +" l_75)" +" #f))" +" l_8)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-library-collection-links" +"(string-append" +" \"(listof (or/c #f\\n\"" +" \" (and/c path-string? complete-path?)\\n\"" +" \" (hash/c (or/c (and/c symbol? module-path?) #f)\\n\"" +" \" (listof (and/c path-string? complete-path?)))))\")" +" l_8)))" +"(map2" +"(lambda(p_4)" +"(if(not p_4)" +"(let-values() #f)" +"(if(path? p_4)" +"(let-values() p_4)" +"(if(string? p_4)" +"(let-values()(string->path p_4))" +"(let-values()" +"(let-values(((ht_150) p_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_150)))" +"((letrec-values(((for-loop_270)" +"(lambda(table_208 i_167)" +"(begin" +" 'for-loop" +"(if i_167" +"(let-values(((k_36 v_200)(hash-iterate-key+value ht_150 i_167)))" +"(let-values(((table_209)" +"(let-values(((table_180) table_208))" +"(let-values(((table_210)" +"(let-values()" +"(let-values(((key_82 val_77)" +"(let-values()" +"(values" +" k_36" +"(to-path v_200)))))" +"(hash-set" +" table_180" +" key_82" +" val_77)))))" +"(values table_210)))))" +"(if(not #f)" +"(for-loop_270 table_209(hash-iterate-next ht_150 i_167))" +" table_209)))" +" table_208)))))" +" for-loop_270)" +" '#hash()" +"(hash-iterate-first ht_150)))))))))" +" l_8)))))))" +"(define-values" +"(1/use-compiled-file-paths)" +"(let-values()" +"(let-values()" +"(make-parameter" +" (list (string->path \"compiled\"))" +"(lambda(l_48)" +"(begin" +"(if((lambda(l_76)(if(list? l_76)(andmap2 relative-path-string?$1 l_76) #f)) l_48)" +"(void)" +"(let-values()" +" (raise-argument-error 'use-compiled-file-paths \"(listof (and/c path-string? relative-path?))\" l_48)))" +"(map2 to-path l_48)))))))" +"(define-values" +"(1/current-compiled-file-roots)" +"(let-values()" +"(let-values()" +"(make-parameter" +" '(same)" +"(lambda(l_77)" +"(begin" +"(if((lambda(l_78)" +"(if(list? l_78)" +"(andmap2" +"(lambda(p_56)" +"(let-values(((or-part_8)(path-string? p_56)))(if or-part_8 or-part_8(eq? p_56 'same))))" +" l_78)" +" #f))" +" l_77)" +"(void)" +"(let-values()" +" (raise-argument-error 'current-compiled-file-roots \"(listof (or/c path-string? 'same))\" l_77)))" +"(map2 to-path l_77)))))))" +"(define-values" +"(1/use-compiled-file-check)" +"(let-values()" +"(let-values()" +"(make-parameter" +" 'modify-seconds" +"(lambda(v_201)" +"(begin" +"(if((lambda(v_69)" +"(let-values(((or-part_32)(eq? v_69 'modify-seconds)))" +"(if or-part_32 or-part_32(eq? v_69 'exists))))" +" v_201)" +"(void)" +" (let-values () (raise-argument-error 'use-compiled-file-check \"(or/c 'modify-seconds 'exists)\" v_201)))" +" v_201))))))" +"(define-values(1/use-collection-link-paths)(make-parameter #t(lambda(v_82)(if v_82 #t #f))))" +"(define-values(1/use-user-specific-search-paths)(make-parameter #t(lambda(v_202)(if v_202 #t #f))))" +"(define-values(complete-path-string?)(lambda(p_57)(begin(if(path-string? p_57)(complete-path? p_57) #f))))" +"(define-values" +"(relative-path-string?$1)" +"(lambda(p_58)(begin 'relative-path-string?(if(path-string? p_58)(relative-path? p_58) #f))))" +"(define-values(to-path)(lambda(p_59)(begin(if(string? p_59)(string->path p_59) p_59))))" +"(define-values" +"(eval$1)" +"(let-values()" +"(let-values()" +"(case-lambda" +"((s_72)(begin 'eval((1/current-eval)(intro s_72))))" +"((s_189 ns_112)" +"(begin" +" (if (1/namespace? ns_112) (void) (let-values () (raise-argument-error 'eval \"namespace?\" ns_112)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_112)" +"(let-values()((1/current-eval)(intro s_189 ns_112))))))))))" +"(define-values" +"(1/eval-syntax)" +"(let-values()" +"(let-values()" +"(case-lambda" +"((s_8)" +"(begin" +" 'eval-syntax" +"(begin" +" (if (syntax?$1 s_8) (void) (let-values () (raise-argument-error 'eval-syntax \"syntax?\" s_8)))" +"((1/current-eval) s_8))))" +"((s_2 ns_58)" +"(begin" +" (if (syntax?$1 s_2) (void) (let-values () (raise-argument-error 'eval-syntax \"syntax?\" s_2)))" +" (if (1/namespace? ns_58) (void) (let-values () (raise-argument-error 'eval-syntax \"namespace?\" ns_58)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_58)" +"(let-values()((1/current-eval) s_2)))))))))" +"(define-values(compile$1)(lambda(s_177)(begin 'compile((1/current-compile)(intro s_177) #f))))" +"(define-values" +"(1/compile-syntax)" +"(lambda(s_484)" +"(begin" +" 'compile-syntax" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_484) (void) (let-values () (raise-argument-error 'compile-syntax \"syntax?\" s_484)))" +"((1/current-compile) s_484 #f)))))))" +"(define-values(1/expand)(lambda(s_9)(begin 'expand(expand$1(intro s_9)(1/current-namespace) #t))))" +"(define-values" +"(1/expand-syntax)" +"(lambda(s_440)" +"(begin" +" 'expand-syntax" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_440) (void) (let-values () (raise-argument-error 'expand-syntax \"syntax?\" s_440)))" +"(expand$1 s_440(1/current-namespace) #t)))))))" +"(define-values(1/expand-once)(lambda(s_447)(begin 'expand-once(expand-once$1(intro s_447)))))" +"(define-values" +"(1/expand-syntax-once)" +"(lambda(s_178)" +"(begin" +" 'expand-syntax-once" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_178) (void) (let-values () (raise-argument-error 'expand-syntax-once \"syntax?\" s_178)))" +"(expand-once$1 s_178)))))))" +"(define-values(1/expand-to-top-form)(lambda(s_75)(begin 'expand-to-top-form(expand-to-top-form$1(intro s_75)))))" +"(define-values" +"(1/expand-syntax-to-top-form)" +"(lambda(s_170)" +"(begin" +" 'expand-syntax-to-top-form" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_170)" +"(void)" +" (let-values () (raise-argument-error 'expand-syntax-to-top-form \"syntax?\" s_170)))" +"(expand-to-top-form$1 s_170)))))))" +"(define-values" +"(intro)" +"(let-values(((intro3_0)" +"(lambda(given-s2_0 ns1_6)" +"(begin" +" 'intro3" +"(let-values(((given-s_1) given-s2_0))" +"(let-values(((ns_113)(if(eq? ns1_6 unsafe-undefined)(1/current-namespace) ns1_6)))" +"(let-values()" +"(let-values(((s_304)(if(syntax?$1 given-s_1) given-s_1(1/datum->syntax #f given-s_1))))" +"(1/namespace-syntax-introduce s_304 ns_113)))))))))" +"(case-lambda" +"((given-s_2)(begin(intro3_0 given-s_2 unsafe-undefined)))" +"((given-s_3 ns1_7)(intro3_0 given-s_3 ns1_7)))))" +"(define-values" +"(do-dynamic-require)" +"(let-values(((do-dynamic-require5_0)" +"(lambda(who2_0 mod-path3_1 sym4_0 fail-k1_0)" +"(begin" +" 'do-dynamic-require5" +"(let-values(((who_24) who2_0))" +"(let-values(((mod-path_5) mod-path3_1))" +"(let-values(((sym_71) sym4_0))" +"(let-values(((fail-k_2)" +"(if(eq? fail-k1_0 unsafe-undefined)" +" default-dynamic-require-fail-thunk" +" fail-k1_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_217)(1/module-path? mod-path_5)))" +"(if or-part_217" +" or-part_217" +"(let-values(((or-part_3)(1/module-path-index? mod-path_5)))" +"(if or-part_3 or-part_3(1/resolved-module-path? mod-path_5)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_24" +" \"(or/c module-path? module-path-index? resolved-module-path?)\"" +" mod-path_5)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_4)(symbol? sym_71)))" +"(if or-part_4" +" or-part_4" +"(let-values(((or-part_5)(not sym_71)))" +"(if or-part_5" +" or-part_5" +"(let-values(((or-part_6)(equal? sym_71 0)))" +"(if or-part_6 or-part_6(void? sym_71)))))))" +"(void)" +"(let-values()" +" (raise-argument-error who_24 \"(or/c symbol? #f 0 void?)\" sym_71)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(if(procedure? fail-k_2)" +"(procedure-arity-includes? fail-k_2 0)" +" #f)" +"(void)" +" (let-values () (raise-argument-error who_24 \"(-> any)\" fail-k_2)))" +"(values))))" +"(let-values(((ns_114)(1/current-namespace)))" +"(let-values(((mpi_46)" +"(if(1/module-path? mod-path_5)" +"(let-values()(1/module-path-index-join mod-path_5 #f))" +"(if(1/module-path-index? mod-path_5)" +"(let-values() mod-path_5)" +"(let-values()" +"(1/module-path-index-join" +"(resolved-module-path->module-path mod-path_5)" +" #f))))))" +"(let-values(((mod-name_22)(1/module-path-index-resolve mpi_46 #t)))" +"(let-values(((phase_109)(namespace-phase ns_114)))" +"(if(not sym_71)" +"(let-values()" +"(let-values(((ns17_0) ns_114)" +"((mpi18_0) mpi_46)" +"((phase19_2) phase_109)" +"((phase20_1) phase_109)" +"((temp21_1) #f))" +"(namespace-module-instantiate!96.1" +" temp21_1" +" phase20_1" +" unsafe-undefined" +" #f" +" ns17_0" +" mpi18_0" +" phase19_2)))" +"(if(equal? sym_71 0)" +"(let-values()" +"(let-values(((ns22_0) ns_114)" +"((mpi23_0) mpi_46)" +"((phase24_3) phase_109)" +"((phase25_0) phase_109))" +"(namespace-module-instantiate!96.1" +" #t" +" phase25_0" +" unsafe-undefined" +" #f" +" ns22_0" +" mpi23_0" +" phase24_3)))" +"(if(void? sym_71)" +"(let-values()" +"(let-values(((ns26_0) ns_114)" +"((mpi27_0) mpi_46)" +"((phase28_4) phase_109)" +"((phase29_0) phase_109))" +"(namespace-module-visit!104.1" +" phase29_0" +" ns26_0" +" mpi27_0" +" phase28_4)))" +"(let-values()" +"(let-values(((m_22)(namespace->module ns_114 mod-name_22)))" +"(let-values((()" +"(begin" +"(if m_22" +"(void)" +"(let-values()" +"(raise-unknown-module-error" +" 'dynamic-require" +" mod-name_22)))" +"(values))))" +"(let-values(((binding/p_5)" +"(hash-ref" +"(hash-ref(module-provides m_22) 0 '#hasheq())" +" sym_71" +" #f)))" +"(if(not binding/p_5)" +"(let-values()" +"(if(eq? fail-k_2 default-dynamic-require-fail-thunk)" +"(raise-arguments-error" +" 'dynamic-require" +" \"name is not provided\"" +" \"name\"" +" sym_71" +" \"module\"" +" mod-name_22)" +"(fail-k_2)))" +"(let-values()" +"(let-values(((binding_5)" +"(provided-as-binding binding/p_5)))" +"(let-values(((ex-sym_2)" +"(module-binding-sym binding_5)))" +"(let-values(((ex-phase_0)" +"(module-binding-phase binding_5)))" +"(let-values((()" +"(begin" +"(let-values(((ns30_2) ns_114)" +"((mpi31_0) mpi_46)" +"((phase32_2) phase_109)" +"((phase33_1) phase_109)" +"((temp34_4) #f))" +"(namespace-module-instantiate!96.1" +" temp34_4" +" phase33_1" +" unsafe-undefined" +" #f" +" ns30_2" +" mpi31_0" +" phase32_2))" +"(values))))" +"(let-values(((ex-mod-name_0)" +"(1/module-path-index-resolve" +"(module-path-index-shift" +"(module-binding-module binding_5)" +"(module-self m_22)" +" mpi_46))))" +"(let-values(((m-ns_16)" +"(let-values(((ns35_0) ns_114)" +"((ex-mod-name36_0)" +" ex-mod-name_0)" +"((temp37_1)" +"(phase-" +" phase_109" +" ex-phase_0))" +"((temp38_3) #t))" +"(namespace->module-namespace82.1" +" #f" +" temp38_3" +" unsafe-undefined" +" ns35_0" +" ex-mod-name36_0" +" temp37_1))))" +"(let-values(((ex-m_0)" +"(namespace->module" +" ns_114" +" ex-mod-name_0)))" +"(let-values(((access_4)" +"(let-values(((or-part_30)" +"(module-access" +" ex-m_0)))" +"(if or-part_30" +" or-part_30" +"(module-compute-access!" +" ex-m_0)))))" +"(let-values((()" +"(begin" +"(if(if(not" +"(eq?" +" 'provided" +"(hash-ref" +"(hash-ref" +" access_4" +" ex-phase_0" +" '#hasheq())" +" ex-sym_2" +" #f)))" +"(if(not" +"(inspector-superior?" +"(current-code-inspector)" +"(namespace-inspector" +" m-ns_16)))" +"(not" +"(if(module-binding-extra-inspector" +" binding_5)" +"(inspector-superior?" +"(module-binding-extra-inspector" +" binding_5)" +"(namespace-inspector" +" m-ns_16))" +" #f))" +" #f)" +" #f)" +"(let-values()" +"(raise-arguments-error" +" 'dynamic-require" +" \"name is protected\"" +" \"name\"" +" sym_71" +" \"module\"" +" mod-name_22))" +"(void))" +"(values))))" +"(let-values(((fail_1)" +"(lambda()" +"(begin" +" 'fail" +"(if(eq?" +" fail-k_2" +" default-dynamic-require-fail-thunk)" +"(raise-arguments-error" +" 'dynamic-require" +" \"name's binding is missing\"" +" \"name\"" +" sym_71" +" \"module\"" +" mod-name_22)" +"(fail-k_2))))))" +"(if(not" +"(provided-as-transformer?" +" binding/p_5))" +"(let-values()" +"(namespace-get-variable" +" m-ns_16" +" ex-phase_0" +" ex-sym_2" +" fail_1))" +"(let-values()" +"(let-values(((missing_1)" +"(gensym 'missing)))" +"(let-values((()" +"(begin" +"(let-values(((ns39_0)" +" ns_114)" +"((mpi40_1)" +" mpi_46)" +"((phase41_2)" +" phase_109)" +"((phase42_0)" +" phase_109))" +"(namespace-module-visit!104.1" +" phase42_0" +" ns39_0" +" mpi40_1" +" phase41_2))" +"(values))))" +"(let-values(((t_59)" +"(namespace-get-transformer" +" m-ns_16" +" ex-phase_0" +" ex-sym_2" +" missing_1)))" +"(if(eq? t_59 missing_1)" +"(let-values()(fail_1))" +"(let-values()" +"(let-values(((tmp-ns_0)" +"(let-values(((ns43_0)" +" ns_114))" +"(new-namespace8.1" +" #t" +" unsafe-undefined" +" ns43_0))))" +"(let-values(((mod-path_17)" +"(resolved-module-path->module-path" +" mod-name_22)))" +"(begin" +"(1/namespace-require" +" mod-path_17" +" tmp-ns_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" tmp-ns_0)" +"(let-values()" +"(1/eval" +" sym_71" +" tmp-ns_0))))))))))))))))))))))))))))))))))))))))))))))))" +"(case-lambda" +"((who_25 mod-path_18 sym_88)(begin(do-dynamic-require5_0 who_25 mod-path_18 sym_88 unsafe-undefined)))" +"((who_26 mod-path_19 sym_89 fail-k1_1)(do-dynamic-require5_0 who_26 mod-path_19 sym_89 fail-k1_1)))))" +" (define-values (default-dynamic-require-fail-thunk) (lambda () (begin (error \"failed\"))))" +"(define-values" +"(1/dynamic-require)" +"(let-values(((dynamic-require10_0)" +"(lambda(mod-path8_3 sym9_0 fail-k7_0)" +"(begin" +" 'dynamic-require10" +"(let-values(((mod-path_20) mod-path8_3))" +"(let-values(((sym_90) sym9_0))" +"(let-values(((fail-k_3)" +"(if(eq? fail-k7_0 unsafe-undefined)" +" default-dynamic-require-fail-thunk" +" fail-k7_0)))" +"(let-values()" +"(let-values()" +"(let-values()(do-dynamic-require 'dynamic-require mod-path_20 sym_90 fail-k_3)))))))))))" +"(case-lambda" +"((mod-path_21 sym_91)(begin 'dynamic-require(dynamic-require10_0 mod-path_21 sym_91 unsafe-undefined)))" +"((mod-path_22 sym_92 fail-k7_1)(dynamic-require10_0 mod-path_22 sym_92 fail-k7_1)))))" +"(define-values" +"(1/dynamic-require-for-syntax)" +"(let-values(((dynamic-require-for-syntax15_0)" +"(lambda(mod-path13_0 sym14_0 fail-k12_0)" +"(begin" +" 'dynamic-require-for-syntax15" +"(let-values(((mod-path_23) mod-path13_0))" +"(let-values(((sym_93) sym14_0))" +"(let-values(((fail-k_4)" +"(if(eq? fail-k12_0 unsafe-undefined)" +" default-dynamic-require-fail-thunk" +" fail-k12_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +"(let-values(((ns_115)(1/current-namespace)))" +"(namespace->namespace-at-phase ns_115(add1(namespace-phase ns_115)))))" +"(let-values()" +"(do-dynamic-require" +" 'dynamic-require-for-syntax" +" mod-path_23" +" sym_93" +" fail-k_4)))))))))))))" +"(case-lambda" +"((mod-path_24 sym_94)" +"(begin 'dynamic-require-for-syntax(dynamic-require-for-syntax15_0 mod-path_24 sym_94 unsafe-undefined)))" +"((mod-path_25 sym_95 fail-k12_1)(dynamic-require-for-syntax15_0 mod-path_25 sym_95 fail-k12_1)))))" +"(define-values" +"(1/load)" +"(lambda(s_0)" +"(begin" +" 'load" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +" (if (path-string? s_0) (void) (let-values () (raise-argument-error 'load \"path-string?\" s_0)))" +"(values))))" +"(let-values(((p_60)(->path s_0)))" +"(call-with-current-load-relative-directory p_60(lambda()((1/current-load) p_60 #f))))))))))" +"(define-values" +"(1/load-extension)" +"(lambda(s_1)" +"(begin" +" 'load-extension" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(path-string? s_1)" +"(void)" +" (let-values () (raise-argument-error 'load-extension \"path-string?\" s_1)))" +"(values))))" +"(let-values(((p_61)(->path s_1)))" +"(call-with-current-load-relative-directory p_61(lambda()((current-load-extension) p_61 #f))))))))))" +"(define-values" +"(call-with-current-load-relative-directory)" +"(lambda(p_32 thunk_6)" +"(begin" +"(let-values(((base_18 name_63 dir?_2)(split-path p_32)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-load-relative-directory" +"(if(eq? base_18 'relative)(current-directory)(path->complete-path base_18)))" +"(let-values()(thunk_6)))))))" +"(define-values" +"(1/load/use-compiled)" +"(lambda(f_27)" +"(begin" +" 'load/use-compiled" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(path-string? f_27)" +"(void)" +" (let-values () (raise-argument-error 'load/use-compiled \"path-string?\" f_27)))" +"(values))))" +"(let-values(((p_48)(->path f_27)))((1/current-load/use-compiled) p_48 #f))))))))" +"(define-values" +"(embedded-load)" +"(lambda(start_41 end_31 str_24 as-predefined?_0)" +"(begin" +"(let-values(((s_170)" +"(if str_24" +" str_24" +"(let-values(((sp_0)(find-system-path 'exec-file)))" +"(let-values(((exe_0)(find-executable-path sp_0 #f)))" +"(let-values(((start_42)" +"(let-values(((or-part_298)(1/string->number start_41)))" +"(if or-part_298 or-part_298 0))))" +"(let-values(((end_32)" +"(let-values(((or-part_90)(1/string->number end_31)))" +"(if or-part_90 or-part_90 0))))" +"(let-values(((exe4_0) exe_0)" +"((temp5_5)" +"(lambda()" +"(begin" +" 'temp5" +"(begin" +"(file-position(current-input-port) start_42)" +"(read-bytes(max 0(- end_32 start_42))))))))" +"(with-input-from-file45.1 'binary exe4_0 temp5_5)))))))))" +"(let-values(((p_62)(open-input-bytes s_170)))" +"((letrec-values(((loop_70)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((e_75)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-compiled" +" #t" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t" +" read-on-demand-source" +" #t)" +"(let-values()(1/read p_62)))))" +"(if(eof-object? e_75)" +"(void)" +"(let-values()" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-module-declare-as-predefined" +" as-predefined?_0)" +"(let-values()((1/current-eval) e_75)))" +"(loop_70)))))))))" +" loop_70)))))))" +"(define-values(->path)(lambda(s_78)(begin(if(string? s_78)(string->path s_78) s_78))))" +"(define-values" +"(find-main-collects)" +"(lambda()" +"(begin(cache-configuration 0(lambda()(exe-relative-path->complete-path(find-system-path 'collects-dir)))))))" +"(define-values" +"(find-main-config)" +"(lambda()" +"(begin(cache-configuration 1(lambda()(exe-relative-path->complete-path(find-system-path 'config-dir)))))))" +"(define-values" +"(exe-relative-path->complete-path)" +"(lambda(collects-path_0)" +"(begin" +"(if(complete-path? collects-path_0)" +"(let-values()(simplify-path collects-path_0))" +"(if(absolute-path? collects-path_0)" +"(let-values()" +"(let-values(((exec_0)" +"(path->complete-path" +"(find-executable-path(find-system-path 'exec-file))" +"(find-system-path 'orig-dir))))" +"(let-values(((base_19 name_64 dir?_3)(split-path exec_0)))" +"(simplify-path(path->complete-path collects-path_0 base_19)))))" +"(let-values()" +"(let-values(((p_61)(find-executable-path(find-system-path 'exec-file) collects-path_0 #t)))" +"(if p_61(simplify-path p_61) #f))))))))" +"(define-values(relative-path-string?)(lambda(s_0)(begin(if(path-string? s_0)(relative-path? s_0) #f))))" +"(define-values" +"(check-collection)" +"(lambda(who_27 s_189 l_4)" +"(begin" +"(begin" +"(if(relative-path-string? s_189)" +"(void)" +" (let-values () (raise-argument-error who_27 \"(and/c path-string? relative-path?)\" s_189)))" +"(if((lambda(l_2)(if(list? l_2)(andmap2 relative-path-string? l_2) #f)) l_4)" +"(void)" +" (let-values () (raise-argument-error who_27 \"(listof (and/c path-string? relative-path?))\" l_4)))))))" +"(define-values" +"(check-fail)" +"(lambda(who_24 fail_2)" +"(begin" +"(if((lambda(p_53)(if(procedure? p_53)(procedure-arity-includes? p_53 1) #f)) fail_2)" +"(void)" +" (let-values () (raise-argument-error who_24 \"(procedure-arity-includes/c 1)\" fail_2))))))" +"(define-values" +"(1/collection-path)" +"(lambda(fail_3 collection_0 collection-path_0)" +"(begin" +" 'collection-path" +"(let-values()" +"(let-values()" +"(begin" +"(check-collection 'collection-path collection_0 collection-path_0)" +"(check-fail 'collection-path fail_3)" +"(find-col-file fail_3 collection_0 collection-path_0 #f #f)))))))" +"(define-values" +"(1/collection-file-path)" +"(lambda(fail_4 check-compiled?_0 file-name_0 collection_1 collection-path_1)" +"(begin" +" 'collection-file-path" +"(let-values()" +"(let-values()" +"(begin" +"(if(relative-path-string? file-name_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'collection-file-path \"(and/c path-string? relative-path?)\" file-name_0)))" +"(check-collection 'collection-file-path collection_1 collection-path_1)" +"(check-fail 'collection-file-path fail_4)" +"(find-col-file fail_4 collection_1 collection-path_1 file-name_0 check-compiled?_0)))))))" +"(define-values" +"(get-config-table)" +"(lambda(d_34)" +"(begin" +" (let-values (((p_63) (if d_34 (build-path d_34 \"config.rktd\") #f)))" +"(let-values(((or-part_294)" +"(if p_63" +"(if(file-exists? p_63)" +"(let-values(((p7_1) p_63)" +"((temp8_1)" +"(lambda()" +"(begin" +" 'temp8" +"(let-values(((v_2)(call-with-default-reading-parameterization 1/read)))" +"(if(hash? v_2) v_2 #f))))))" +"(with-input-from-file45.1 'binary p7_1 temp8_1))" +" #f)" +" #f)))" +"(if or-part_294 or-part_294 '#hash()))))))" +"(define-values" +"(get-installation-name)" +"(lambda(config-table_0)(begin(hash-ref config-table_0 'installation-name(version)))))" +"(define-values" +"(coerce-to-path)" +"(lambda(p_1)" +"(begin" +"(if(string? p_1)" +"(let-values()(collects-relative-path->complete-path(string->path p_1)))" +"(if(bytes? p_1)" +"(let-values()(collects-relative-path->complete-path(bytes->path p_1)))" +"(if(path? p_1)(let-values()(collects-relative-path->complete-path p_1))(let-values() p_1)))))))" +"(define-values" +"(collects-relative-path->complete-path)" +"(lambda(p_64)" +"(begin" +"(if(complete-path? p_64)" +"(let-values() p_64)" +"(let-values()" +"(path->complete-path" +" p_64" +"(let-values(((or-part_72)(find-main-collects)))(if or-part_72 or-part_72(current-directory)))))))))" +"(define-values" +"(add-config-search)" +"(lambda(ht_70 key_83 orig-l_9)" +"(begin" +"(let-values(((l_79)(hash-ref ht_70 key_83 #f)))" +"(if l_79" +"((letrec-values(((loop_102)" +"(lambda(l_64)" +"(begin" +" 'loop" +"(if(null? l_64)" +"(let-values() null)" +"(if(not(car l_64))" +"(let-values()(append orig-l_9(loop_102(cdr l_64))))" +"(let-values()(cons(coerce-to-path(car l_64))(loop_102(cdr l_64))))))))))" +" loop_102)" +" l_79)" +" orig-l_9)))))" +"(define-values" +"(1/find-library-collection-links)" +"(lambda()" +"(begin" +" 'find-library-collection-links" +"(let-values(((ht_81)(get-config-table(find-main-config))))" +"(let-values(((lf_0)" +"(coerce-to-path" +"(let-values(((or-part_80)(hash-ref ht_81 'links-file #f)))" +"(if or-part_80" +" or-part_80" +"(build-path" +"(let-values(((or-part_81)(hash-ref ht_81 'share-dir #f)))" +" (if or-part_81 or-part_81 (build-path 'up \"share\")))" +" \"links.rktd\"))))))" +"(append" +"(list #f)" +"(if(if(1/use-user-specific-search-paths)(1/use-collection-link-paths) #f)" +" (list (build-path (find-system-path 'addon-dir) (get-installation-name ht_81) \"links.rktd\"))" +" null)" +"(if(1/use-collection-link-paths)(add-config-search ht_81 'links-search-files(list lf_0)) null)))))))" +"(define-values(links-cache)(make-weak-hash))" +"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))" +"(define-values" +"(file->stamp)" +"(lambda(path_7 old-stamp_0)" +"(begin" +"(if(if old-stamp_0(if(cdr old-stamp_0)(not(sync/timeout 0(cdr old-stamp_0))) #f) #f)" +"(let-values() old-stamp_0)" +"(let-values()" +"(call-with-continuation-prompt" +"(lambda()" +"(call-with-exception-handler" +"(lambda(exn_1)" +"(abort-current-continuation" +" stamp-prompt-tag" +"(if(exn:fail:filesystem? exn_1)(lambda() #f)(lambda()(raise exn_1)))))" +"(lambda()" +"(let-values(((dir-evt_0)" +"(if(vector-ref(system-type 'fs-change) 2)" +"((letrec-values(((loop_65)" +"(lambda(path_8)" +"(begin" +" 'loop" +"(let-values(((base_20 name_65 dir?_4)(split-path path_8)))" +"(if(path? base_20)" +"(if(directory-exists? base_20)" +"(filesystem-change-evt base_20(lambda() #f))" +"(loop_65 base_20))" +" #f))))))" +" loop_65)" +" path_7)" +" #f)))" +"(if(not(file-exists? path_7))" +"(let-values()(cons #f dir-evt_0))" +"(let-values()" +"(let-values(((evt_0)" +"(if(vector-ref(system-type 'fs-change) 2)" +"(filesystem-change-evt path_7(lambda() #f))" +" #f)))" +"(begin" +"(if dir-evt_0(let-values()(filesystem-change-evt-cancel dir-evt_0))(void))" +"(cons(file->bytes path_7) evt_0)))))))))" +" stamp-prompt-tag))))))" +"(define-values" +"(file->bytes)" +"(lambda(path_9)" +"(begin" +"(let-values(((path9_0) path_9)" +"((temp10_4)" +"(lambda(p_65)" +"(begin" +" 'temp10" +"(let-values(((bstr_1)(read-bytes 8192 p_65)))" +"(if(if(bytes? bstr_1)(>=(bytes-length bstr_1) 8192) #f)" +"(apply" +" bytes-append" +"(cons" +" bstr_1" +"((letrec-values(((loop_103)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((bstr_2)(read-bytes 8192 p_65)))" +"(if(eof-object? bstr_2) null(cons bstr_2(loop_103))))))))" +" loop_103))))" +" bstr_1))))))" +"(call-with-input-file*61.1 'binary path9_0 temp10_4)))))" +"(define-values" +"(no-file-stamp?)" +"(lambda(a_68)(begin(let-values(((or-part_31)(not a_68)))(if or-part_31 or-part_31(not(car a_68)))))))" +"(define-values" +"(get-linked-collections)" +"(lambda(links-path_0)" +"(begin" +"(call/ec" +"(lambda(esc_1)" +"(let-values(((make-handler_0)" +"(lambda(ts_0)" +"(begin" +" 'make-handler" +"(lambda(exn_2)" +"(begin" +"(if(exn:fail? exn_2)" +"(let-values(((l_80)(current-logger)))" +"(if(log-level? l_80 'error)" +"(let-values()" +"(log-message" +" l_80" +" 'error" +"(format" +" \"error reading collection links file ~s: ~a\"" +" links-path_0" +"(exn-message exn_2))" +"(current-continuation-marks)))" +"(void)))" +"(void))" +"(if ts_0" +"(let-values()(hash-set! links-cache links-path_0(cons ts_0 '#hasheq())))" +"(void))" +"(if(exn:fail? exn_2)(esc_1(make-hasheq)) exn_2)))))))" +"(call-with-exception-handler" +"(make-handler_0 #f)" +"(lambda()" +"(let-values(((links-stamp+cache_0)(hash-ref links-cache links-path_0 '(#f . #hasheq()))))" +"(let-values(((a-links-stamp_0)(car links-stamp+cache_0)))" +"(let-values(((ts_1)(file->stamp links-path_0 a-links-stamp_0)))" +"(if(equal? ts_1 a-links-stamp_0)" +"(let-values()(cdr links-stamp+cache_0))" +"(let-values()" +"(call-with-exception-handler" +"(make-handler_0 ts_1)" +"(lambda()" +"(call-with-default-reading-parameterization" +"(lambda()" +"(let-values(((v_203)" +"(if(no-file-stamp? ts_1)" +" null" +"(let-values(((links-path11_0) links-path_0)" +"((temp12_3)" +"(lambda(p_39)" +"(begin" +" 'temp12" +"(begin0" +"(1/read p_39)" +"(if(eof-object?(1/read p_39))" +"(void)" +"(let-values()" +" (error \"expected a single S-expression\"))))))))" +"(call-with-input-file*61.1 'binary links-path11_0 temp12_3)))))" +"(let-values((()" +"(begin" +"(if(if(list? v_203)" +"(andmap2" +"(lambda(p_66)" +"(if(list? p_66)" +"(if(let-values(((or-part_226)(= 2(length p_66))))" +"(if or-part_226 or-part_226(= 3(length p_66))))" +"(if(let-values(((or-part_300)(string?(car p_66))))" +"(if or-part_300" +" or-part_300" +"(let-values(((or-part_301)" +"(eq? 'root(car p_66))))" +"(if or-part_301" +" or-part_301" +"(eq? 'static-root(car p_66))))))" +"(if(path-string?(cadr p_66))" +"(let-values(((or-part_302)(null?(cddr p_66))))" +"(if or-part_302 or-part_302(regexp?(caddr p_66))))" +" #f)" +" #f)" +" #f)" +" #f))" +" v_203)" +" #f)" +"(void)" +" (let-values () (error \"ill-formed content\")))" +"(values))))" +"(let-values(((ht_151)(make-hasheq)))" +"(let-values(((dir_0)" +"(let-values(((base_21 name_66 dir?_5)(split-path links-path_0)))" +" base_21)))" +"(begin" +"(for-each2" +"(lambda(p_67)" +"(if(let-values(((or-part_266)(null?(cddr p_67))))" +"(if or-part_266 or-part_266(regexp-match?(caddr p_67)(version))))" +"(let-values()" +"(let-values(((dir_1)" +"(simplify-path(path->complete-path(cadr p_67) dir_0))))" +"(if(eq?(car p_67) 'static-root)" +"(let-values()" +"(for-each2" +"(lambda(sub_1)" +"(if(directory-exists?(build-path dir_1 sub_1))" +"(let-values()" +"(let-values(((k_37)(string->symbol(path->string sub_1))))" +"(hash-set!" +" ht_151" +" k_37" +"(cons dir_1(hash-ref ht_151 k_37 null)))))" +"(void)))" +"(directory-list dir_1)))" +"(if(eq?(car p_67) 'root)" +"(let-values()" +"(begin" +"(if(hash-ref ht_151 #f #f)" +"(void)" +"(let-values()(hash-set! ht_151 #f null)))" +"(hash-for-each" +" ht_151" +"(lambda(k_38 v_204)" +"(hash-set! ht_151 k_38(cons dir_1 v_204))))))" +"(let-values()" +"(let-values(((s_485)(string->symbol(car p_67))))" +"(hash-set!" +" ht_151" +" s_485" +"(cons(box dir_1)(hash-ref ht_151 s_485 null)))))))))" +"(void)))" +" v_203)" +"(hash-for-each" +" ht_151" +"(lambda(k_39 v_205)(hash-set! ht_151 k_39(reverse$1 v_205))))" +"(hash-set! links-cache links-path_0(cons ts_1 ht_151))" +" ht_151))))))))))))))))))))))" +"(define-values" +"(normalize-collection-reference)" +"(lambda(collection_2 collection-path_2)" +"(begin" +"(if(string? collection_2)" +"(let-values()" +" (let-values (((m_23) (regexp-match-positions '#rx\"/+\" collection_2)))" +"(if m_23" +"(if(=(caar m_23)(sub1(string-length collection_2)))" +"(let-values()(values(substring collection_2 0(caar m_23)) collection-path_2))" +"(let-values()" +"(values" +"(substring collection_2 0(caar m_23))" +"(cons(substring collection_2(cdar m_23)) collection-path_2))))" +"(values collection_2 collection-path_2))))" +"(let-values()" +"(let-values(((base_22 name_67 dir?_6)(split-path collection_2)))" +"(if(eq? base_22 'relative)" +"(values name_67 collection-path_2)" +"(normalize-collection-reference base_22(cons name_67 collection-path_2)))))))))" +"(define-values" +"(find-col-file)" +"(lambda(fail_5 collection-in_0 collection-path-in_0 file-name_1 check-compiled?_1)" +"(begin" +"(let-values(((collection_3 collection-path_3)" +"(normalize-collection-reference collection-in_0 collection-path-in_0)))" +"(let-values(((all-paths_0)" +"(let-values(((sym_96)" +"(string->symbol" +"(if(path? collection_3)(path->string collection_3) collection_3))))" +"((letrec-values(((loop_47)" +"(lambda(l_81)" +"(begin" +" 'loop" +"(if(null? l_81)" +"(let-values() null)" +"(if(not(car l_81))" +"(let-values()" +"(append(1/current-library-collection-paths)(loop_47(cdr l_81))))" +"(if(hash?(car l_81))" +"(let-values()" +"(append" +"(map2 box(hash-ref(car l_81) sym_96 null))" +"(hash-ref(car l_81) #f null)" +"(loop_47(cdr l_81))))" +"(let-values()" +"(let-values(((ht_152)(get-linked-collections(car l_81))))" +"(append" +"(hash-ref ht_152 sym_96 null)" +"(hash-ref ht_152 #f null)" +"(loop_47(cdr l_81))))))))))))" +" loop_47)" +"(1/current-library-collection-links)))))" +"(let-values(((done_1)(lambda(p_12)(begin 'done(if file-name_1(build-path p_12 file-name_1) p_12)))))" +"(let-values(((*build-path-rep_0)" +"(lambda(p_68 c_55)" +"(begin '*build-path-rep(if(path? p_68)(build-path p_68 c_55)(unbox p_68))))))" +"(let-values(((*directory-exists?_0)" +"(lambda(orig_0 p_50)" +"(begin '*directory-exists?(if(path? orig_0)(directory-exists? p_50) #t)))))" +"(let-values(((to-string_0)" +"(lambda(p_69)(begin 'to-string(if(path? p_69)(path->string p_69) p_69)))))" +"((letrec-values(((cloop_0)" +"(lambda(paths_1 found-col_0)" +"(begin" +" 'cloop" +"(if(null? paths_1)" +"(if found-col_0" +"(done_1 found-col_0)" +"(let-values(((rest-coll_0)" +"(if(null? collection-path_3)" +" \"\"" +"(apply" +" string-append" +"((letrec-values(((loop_104)" +"(lambda(cp_0)" +"(begin" +" 'loop" +"(if(null?(cdr cp_0))" +"(list(to-string_0(car cp_0)))" +"(list*" +"(to-string_0(car cp_0))" +" \"/\"" +"(loop_104(cdr cp_0))))))))" +" loop_104)" +" collection-path_3)))))" +"(letrec-values(((filter_1)" +"(lambda(f_40 l_82)" +"(begin" +" 'filter" +"(if(null? l_82)" +" null" +"(if(f_40(car l_82))" +"(cons(car l_82)(filter_1 f_40(cdr l_82)))" +"(filter_1 f_40(cdr l_82))))))))" +"(fail_5" +"(format" +" \"collection not found\\n collection: ~s\\n in collection directories:~a~a\"" +"(if(null? collection-path_3)" +"(to-string_0 collection_3)" +" (string-append (to-string_0 collection_3) \"/\" rest-coll_0))" +"(apply" +" string-append" +"(map2" +" (lambda (p_70) (format \"\\n ~a ~a\" \" \" p_70))" +"(let-values(((len_34)(length all-paths_0))" +"((clen_0)" +"(length(1/current-library-collection-paths))))" +"(if(<(- len_34 clen_0) 5)" +" all-paths_0" +"(append" +"(1/current-library-collection-paths)" +"(list" +"(format" +" \"... [~a additional linked and package directories]\"" +"(- len_34 clen_0))))))))" +"(if(ormap2 box? all-paths_0)" +"(format" +" \"\\n sub-collection: ~s\\n in parent directories:~a\"" +" rest-coll_0" +"(apply" +" string-append" +"(map2" +" (lambda (p_71) (format \"\\n ~a\" (unbox p_71)))" +"(filter_1 box? all-paths_0))))" +" \"\"))))))" +"(let-values(((dir_2)(*build-path-rep_0(car paths_1) collection_3)))" +"(if(*directory-exists?_0(car paths_1) dir_2)" +"(let-values(((cpath_0)(apply build-path dir_2 collection-path_3)))" +"(if(if(null? collection-path_3) #t(directory-exists? cpath_0))" +"(if file-name_1" +"(if(let-values(((or-part_303)" +"(file-exists?/maybe-compiled" +" cpath_0" +" file-name_1" +" check-compiled?_1)))" +"(if or-part_303" +" or-part_303" +"(let-values(((alt-file-name_0)" +"(let-values(((file-name_2)" +"(if(path? file-name_1)" +"(path->string file-name_1)" +" file-name_1)))" +"(let-values(((len_35)" +"(string-length file-name_2)))" +"(if(>= len_35 4)" +"(if(string=?" +" \".rkt\"" +"(substring" +" file-name_2" +"(- len_35 4)))" +"(string-append" +"(substring" +" file-name_2" +" 0" +"(- len_35 4))" +" \".ss\")" +" #f)" +" #f)))))" +"(if alt-file-name_0" +"(file-exists?/maybe-compiled" +" cpath_0" +" alt-file-name_0" +" check-compiled?_1)" +" #f))))" +"(done_1 cpath_0)" +"(cloop_0" +"(cdr paths_1)" +"(let-values(((or-part_100) found-col_0))" +"(if or-part_100 or-part_100 cpath_0))))" +"(done_1 cpath_0))" +"(cloop_0(cdr paths_1) found-col_0)))" +"(cloop_0(cdr paths_1) found-col_0))))))))" +" cloop_0)" +" all-paths_0" +" #f))))))))))" +"(define-values" +"(file-exists?/maybe-compiled)" +"(lambda(dir_3 path_10 check-compiled?_2)" +"(begin" +"(let-values(((or-part_101)(file-exists?(build-path dir_3 path_10))))" +"(if or-part_101" +" or-part_101" +"(if check-compiled?_2" +" (let-values (((try-path_0) (path-add-extension path_10 #\".zo\"))" +"((modes_0)(1/use-compiled-file-paths))" +"((roots_0)(1/current-compiled-file-roots)))" +"(ormap2" +"(lambda(d_35)" +"(ormap2" +"(lambda(mode_16)" +"(file-exists?" +"(let-values(((p_72)(build-path dir_3 mode_16 try-path_0)))" +"(if(eq? d_35 'same)" +"(let-values() p_72)" +"(if(relative-path? d_35)" +"(let-values()(build-path p_72 d_35))" +"(let-values()(reroot-path p_72 d_35)))))))" +" modes_0))" +" roots_0))" +" #f))))))" +"(define-values" +"(1/find-library-collection-paths)" +"(let-values(((find-library-collection-paths3_0)" +"(lambda(extra-collects-dirs1_0 post-collects-dirs2_0)" +"(begin" +" 'find-library-collection-paths3" +"(let-values(((extra-collects-dirs_0) extra-collects-dirs1_0))" +"(let-values(((post-collects-dirs_0) post-collects-dirs2_0))" +"(let-values()" +"(let-values(((user-too?_0)(1/use-user-specific-search-paths))" +"((cons-if_0)" +"(lambda(f_41 r_45)(begin 'cons-if(if f_41(cons f_41 r_45) r_45))))" +"((config-table_1)(get-config-table(find-main-config))))" +"(path-list-string->path-list" +"(if user-too?_0" +"(let-values(((c_56)" +"(environment-variables-ref" +"(current-environment-variables)" +" #\"PLTCOLLECTS\")))" +" (if c_56 (bytes->string/locale c_56 '#\\?) \"\"))" +" \"\")" +"(add-config-search" +" config-table_1" +" 'collects-search-dirs" +"(cons-if_0" +"(if user-too?_0" +"(build-path" +"(find-system-path 'addon-dir)" +"(get-installation-name config-table_1)" +" \"collects\")" +" #f)" +"((letrec-values(((loop_105)" +"(lambda(l_83)" +"(begin" +" 'loop" +"(if(null? l_83)" +" null" +"(let-values(((collects-path_1)(car l_83)))" +"(let-values(((v_206)" +"(exe-relative-path->complete-path" +" collects-path_1)))" +"(if v_206" +"(cons" +"(simplify-path" +"(path->complete-path v_206(current-directory)))" +"(loop_105(cdr l_83)))" +"(loop_105(cdr l_83))))))))))" +" loop_105)" +"(append" +" extra-collects-dirs_0" +"(list(find-system-path 'collects-dir))" +" post-collects-dirs_0)))))))))))))" +"(case-lambda" +"(()(begin 'find-library-collection-paths(find-library-collection-paths3_0 null null)))" +"((extra-collects-dirs_1 post-collects-dirs2_1)" +"(find-library-collection-paths3_0 extra-collects-dirs_1 post-collects-dirs2_1))" +"((extra-collects-dirs1_1)(find-library-collection-paths3_0 extra-collects-dirs1_1 null)))))" +"(define-values(prop:readtable prop:readtable? prop:readtable-ref)(make-struct-type-property 'readtable))" +"(define-values" +"(1/current-readtable)" +"(let-values()" +"(let-values()" +"(make-parameter" +" #f" +"(lambda(v_207)" +"(begin" +"(if((lambda(x_83)" +"(let-values(((or-part_11)(not x_83)))(if or-part_11 or-part_11(prop:readtable? x_83))))" +" v_207)" +"(void)" +" (let-values () (raise-argument-error 'current-readtable \"(or/c prop:readtable? #f)\" v_207)))" +" v_207))))))" +"(define-values" +"(struct:read-config/outer" +" read-config/outer1.1" +" read-config/outer?" +" read-config/outer-inner" +" read-config/outer-wrap" +" read-config/outer-line" +" read-config/outer-col" +" read-config/outer-pos" +" read-config/outer-indentations" +" read-config/outer-keep-comment?)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'read-config/outer)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'inner)" +"(make-struct-field-accessor -ref_36 1 'wrap)" +"(make-struct-field-accessor -ref_36 2 'line)" +"(make-struct-field-accessor -ref_36 3 'col)" +"(make-struct-field-accessor -ref_36 4 'pos)" +"(make-struct-field-accessor -ref_36 5 'indentations)" +"(make-struct-field-accessor -ref_36 6 'keep-comment?))))" +"(define-values" +"(struct:read-config/inner" +" read-config/inner2.1" +" read-config/inner?" +" read-config/inner-readtable" +" read-config/inner-next-readtable" +" read-config/inner-for-syntax?" +" read-config/inner-source" +" read-config/inner-read-compiled" +" read-config/inner-dynamic-require" +" read-config/inner-module-declared?" +" read-config/inner-coerce" +" read-config/inner-coerce-key" +" read-config/inner-parameter-override" +" read-config/inner-parameter-cache" +" read-config/inner-st)" +"(let-values(((struct:_81 make-_81 ?_81 -ref_81 -set!_81)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config/inner" +" #f" +" 12" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11)" +" #f" +" 'read-config/inner)))))" +"(values" +" struct:_81" +" make-_81" +" ?_81" +"(make-struct-field-accessor -ref_81 0 'readtable)" +"(make-struct-field-accessor -ref_81 1 'next-readtable)" +"(make-struct-field-accessor -ref_81 2 'for-syntax?)" +"(make-struct-field-accessor -ref_81 3 'source)" +"(make-struct-field-accessor -ref_81 4 'read-compiled)" +"(make-struct-field-accessor -ref_81 5 'dynamic-require)" +"(make-struct-field-accessor -ref_81 6 'module-declared?)" +"(make-struct-field-accessor -ref_81 7 'coerce)" +"(make-struct-field-accessor -ref_81 8 'coerce-key)" +"(make-struct-field-accessor -ref_81 9 'parameter-override)" +"(make-struct-field-accessor -ref_81 10 'parameter-cache)" +"(make-struct-field-accessor -ref_81 11 'st))))" +"(define-values" +"(read-config/make)" +"(lambda(readtable_0" +" next-readtable_0" +" for-syntax?_0" +" source_1" +" wrap_3" +" read-compiled_0" +" dynamic-require_0" +" module-declared?_0" +" coerce_0" +" coerce-key_0" +" line_1" +" col_0" +" pos_108" +" indentations_0" +" keep-comment?_0" +" parameter-override_0" +" parameter-cache_0" +" st_0)" +"(begin" +"(read-config/outer1.1" +"(read-config/inner2.1" +" readtable_0" +" next-readtable_0" +" for-syntax?_0" +" source_1" +" read-compiled_0" +" dynamic-require_0" +" module-declared?_0" +" coerce_0" +" coerce-key_0" +" parameter-override_0" +" parameter-cache_0" +" st_0)" +" wrap_3" +" line_1" +" col_0" +" pos_108" +" indentations_0" +" keep-comment?_0))))" +"(define-values(read-config-wrap)(lambda(v_27)(begin(read-config/outer-wrap v_27))))" +"(define-values(read-config-line)(lambda(v_208)(begin(read-config/outer-line v_208))))" +"(define-values(read-config-col)(lambda(v_209)(begin(read-config/outer-col v_209))))" +"(define-values(read-config-pos)(lambda(v_210)(begin(read-config/outer-pos v_210))))" +"(define-values(read-config-indentations)(lambda(v_211)(begin(read-config/outer-indentations v_211))))" +"(define-values(read-config-keep-comment?)(lambda(v_98)(begin(read-config/outer-keep-comment? v_98))))" +"(define-values" +"(read-config-readtable)" +"(lambda(v_212)(begin(read-config/inner-readtable(read-config/outer-inner v_212)))))" +"(define-values" +"(read-config-next-readtable)" +"(lambda(v_213)(begin(read-config/inner-next-readtable(read-config/outer-inner v_213)))))" +"(define-values" +"(read-config-for-syntax?)" +"(lambda(v_214)(begin(read-config/inner-for-syntax?(read-config/outer-inner v_214)))))" +"(define-values(read-config-source)(lambda(v_76)(begin(read-config/inner-source(read-config/outer-inner v_76)))))" +"(define-values" +"(read-config-read-compiled)" +"(lambda(v_215)(begin(read-config/inner-read-compiled(read-config/outer-inner v_215)))))" +"(define-values" +"(read-config-dynamic-require)" +"(lambda(v_216)(begin(read-config/inner-dynamic-require(read-config/outer-inner v_216)))))" +"(define-values" +"(read-config-module-declared?)" +"(lambda(v_217)(begin(read-config/inner-module-declared?(read-config/outer-inner v_217)))))" +"(define-values" +"(read-config-coerce)" +"(lambda(v_206)(begin(read-config/inner-coerce(read-config/outer-inner v_206)))))" +"(define-values" +"(read-config-coerce-key)" +"(lambda(v_218)(begin(read-config/inner-coerce-key(read-config/outer-inner v_218)))))" +"(define-values" +"(read-config-parameter-override)" +"(lambda(v_219)(begin(read-config/inner-parameter-override(read-config/outer-inner v_219)))))" +"(define-values" +"(read-config-parameter-cache)" +"(lambda(v_40)(begin(read-config/inner-parameter-cache(read-config/outer-inner v_40)))))" +"(define-values(read-config-st)(lambda(v_220)(begin(read-config/inner-st(read-config/outer-inner v_220)))))" +"(define-values" +"(struct:read-config-state" +" read-config-state3.1" +" read-config-state?" +" read-config-state-accum-str" +" read-config-state-graph" +" set-read-config-state-accum-str!" +" set-read-config-state-graph!)" +"(let-values(((struct:_82 make-_82 ?_82 -ref_82 -set!_82)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config-state" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'read-config-state)))))" +"(values" +" struct:_82" +" make-_82" +" ?_82" +"(make-struct-field-accessor -ref_82 0 'accum-str)" +"(make-struct-field-accessor -ref_82 1 'graph)" +"(make-struct-field-mutator -set!_82 0 'accum-str)" +"(make-struct-field-mutator -set!_82 1 'graph))))" +"(define-values(current-read-config)(make-parameter #f))" +"(define-values" +"(make-read-config26.1)" +"(lambda(coerce12_0" +" coerce-key13_0" +" dynamic-require10_1" +" for-syntax?5_0" +" keep-comment?14_0" +" module-declared?11_0" +" next-readtable7_0" +" read-compiled9_0" +" readtable6_0" +" source4_0" +" wrap8_0)" +"(begin" +" 'make-read-config26" +"(let-values(((source_2) source4_0))" +"(let-values(((for-syntax?_1) for-syntax?5_0))" +"(let-values(((readtable_1)(if(eq? readtable6_0 unsafe-undefined)(1/current-readtable) readtable6_0)))" +"(let-values(((next-readtable_1)" +"(if(eq? next-readtable7_0 unsafe-undefined) readtable_1 next-readtable7_0)))" +"(let-values(((wrap_4) wrap8_0))" +"(let-values(((read-compiled_1) read-compiled9_0))" +"(let-values(((dynamic-require_1) dynamic-require10_1))" +"(let-values(((module-declared?_1) module-declared?11_0))" +"(let-values(((coerce_1) coerce12_0))" +"(let-values(((coerce-key_1) coerce-key13_0))" +"(let-values(((keep-comment?_1) keep-comment?14_0))" +"(let-values()" +"(read-config/make" +" readtable_1" +" next-readtable_1" +" for-syntax?_1" +" source_2" +" wrap_4" +"(let-values(((or-part_52) read-compiled_1))" +" (if or-part_52 or-part_52 (lambda (in_0) (error 'read \"no `read-compiled` provided\"))))" +"(let-values(((or-part_304) dynamic-require_1))" +"(if or-part_304" +" or-part_304" +"(lambda(mod-path_26 sym_97 failure-k_0)" +" (error 'read \"no `dynamic-require` provided\"))))" +"(let-values(((or-part_178) module-declared?_1))" +"(if or-part_178" +" or-part_178" +" (lambda (mod-path_27) (error 'read \"no `module-declare?` provided\"))))" +"(let-values(((or-part_221) coerce_1))" +"(if or-part_221 or-part_221(lambda(for-syntax?_2 v_144 srcloc_9) v_144)))" +"(let-values(((or-part_305) coerce-key_1))" +"(if or-part_305 or-part_305(lambda(for-syntax?_3 v_102) v_102)))" +" #f" +" #f" +" #f" +" null" +" keep-comment?_1" +" '#hasheq()" +"(make-hasheq)" +"(read-config-state3.1 #f #f)))))))))))))))))" +"(define-values" +"(read-config-update42.1)" +"(lambda(for-syntax?29_0 keep-comment?34_0 next-readtable32_0 readtable31_0 reset-graph?33_0 wrap30_0 config41_0)" +"(begin" +" 'read-config-update42" +"(let-values(((config_0) config41_0))" +"(let-values(((for-syntax?_4) for-syntax?29_0))" +"(let-values(((wrap_5) wrap30_0))" +"(let-values(((readtable_2) readtable31_0))" +"(let-values(((next-readtable_2)" +"(if(eq? next-readtable32_0 unsafe-undefined)" +"(read-config-readtable config_0)" +" next-readtable32_0)))" +"(let-values(((local-graph?_0) reset-graph?33_0))" +"(let-values(((keep-comment?_2) keep-comment?34_0))" +"(let-values()" +"(let-values(((v_221) config_0))" +"(let-values(((the-struct_78) v_221))" +"(if(read-config/outer? the-struct_78)" +"(let-values(((wrap55_0) wrap_5)" +"((keep-comment?56_0) keep-comment?_2)" +"((inner57_0)" +"(let-values(((the-struct_79)(read-config/outer-inner v_221)))" +"(if(read-config/inner? the-struct_79)" +"(let-values(((for-syntax?58_0) for-syntax?_4)" +"((readtable59_0) readtable_2)" +"((next-readtable60_0) next-readtable_2)" +"((st61_0)" +"(if local-graph?_0" +"(read-config-state3.1 #f #f)" +"(read-config-st config_0))))" +"(read-config/inner2.1" +" readtable59_0" +" next-readtable60_0" +" for-syntax?58_0" +"(read-config/inner-source the-struct_79)" +"(read-config/inner-read-compiled the-struct_79)" +"(read-config/inner-dynamic-require the-struct_79)" +"(read-config/inner-module-declared? the-struct_79)" +"(read-config/inner-coerce the-struct_79)" +"(read-config/inner-coerce-key the-struct_79)" +"(read-config/inner-parameter-override the-struct_79)" +"(read-config/inner-parameter-cache the-struct_79)" +" st61_0))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_79)))))" +"(read-config/outer1.1" +" inner57_0" +" wrap55_0" +"(read-config/outer-line the-struct_78)" +"(read-config/outer-col the-struct_78)" +"(read-config/outer-pos the-struct_78)" +"(read-config/outer-indentations the-struct_78)" +" keep-comment?56_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_78)))))))))))))))" +"(define-values" +"(port+config->srcloc49.1)" +"(lambda(end-pos45_0 in47_0 config48_0)" +"(begin" +" 'port+config->srcloc49" +"(let-values(((in_1) in47_0))" +"(let-values(((config_1) config48_0))" +"(let-values(((given-end-pos_0) end-pos45_0))" +"(let-values()" +"(let-values(((end-pos_0)" +"(let-values(((or-part_282) given-end-pos_0))" +"(if or-part_282" +" or-part_282" +"(let-values(((end-line_0 end-col_0 end-pos_1)(port-next-location in_1)))" +" end-pos_1)))))" +"(srcloc" +"(let-values(((or-part_306)(read-config-source config_1)))" +"(if or-part_306" +" or-part_306" +" (let-values (((or-part_307) (object-name in_1))) (if or-part_307 or-part_307 \"UNKNOWN\"))))" +"(read-config-line config_1)" +"(read-config-col config_1)" +"(read-config-pos config_1)" +"(if(read-config-pos config_1)" +"(if end-pos_0(max 0(- end-pos_0(read-config-pos config_1))) #f)" +" #f))))))))))" +"(define-values" +"(reading-at)" +"(lambda(config_2 line_2 col_1 pos_109)" +"(begin" +"(let-values(((v_222) config_2))" +"(let-values(((the-struct_80) v_222))" +"(if(read-config/outer? the-struct_80)" +"(let-values(((line62_0) line_2)" +"((col63_0) col_1)" +"((pos64_0) pos_109)" +"((inner65_0)(read-config/outer-inner v_222)))" +"(read-config/outer1.1" +" inner65_0" +"(read-config/outer-wrap the-struct_80)" +" line62_0" +" col63_0" +" pos64_0" +"(read-config/outer-indentations the-struct_80)" +"(read-config/outer-keep-comment? the-struct_80)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_80)))))))" +"(define-values" +"(disable-wrapping)" +"(lambda(config_3)" +"(begin" +"(let-values(((v_223) config_3))" +"(let-values(((the-struct_81) v_223))" +"(if(read-config/outer? the-struct_81)" +"(let-values(((wrap66_0) #f)((inner67_0)(read-config/outer-inner v_223)))" +"(read-config/outer1.1" +" inner67_0" +" wrap66_0" +"(read-config/outer-line the-struct_81)" +"(read-config/outer-col the-struct_81)" +"(read-config/outer-pos the-struct_81)" +"(read-config/outer-indentations the-struct_81)" +"(read-config/outer-keep-comment? the-struct_81)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_81)))))))" +"(define-values" +"(keep-comment)" +"(lambda(config_4)" +"(begin" +"(let-values(((v_224) config_4))" +"(let-values(((the-struct_82) v_224))" +"(if(read-config/outer? the-struct_82)" +"(let-values(((keep-comment?68_0) #t)((inner69_0)(read-config/outer-inner v_224)))" +"(read-config/outer1.1" +" inner69_0" +"(read-config/outer-wrap the-struct_82)" +"(read-config/outer-line the-struct_82)" +"(read-config/outer-col the-struct_82)" +"(read-config/outer-pos the-struct_82)" +"(read-config/outer-indentations the-struct_82)" +" keep-comment?68_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_82)))))))" +"(define-values" +"(discard-comment)" +"(lambda(config_5)" +"(begin" +"(if(not(read-config-keep-comment? config_5))" +"(let-values() config_5)" +"(let-values()" +"(let-values(((v_81) config_5))" +"(let-values(((the-struct_83) v_81))" +"(if(read-config/outer? the-struct_83)" +"(let-values(((keep-comment?70_0) #f)((inner71_0)(read-config/outer-inner v_81)))" +"(read-config/outer1.1" +" inner71_0" +"(read-config/outer-wrap the-struct_83)" +"(read-config/outer-line the-struct_83)" +"(read-config/outer-col the-struct_83)" +"(read-config/outer-pos the-struct_83)" +"(read-config/outer-indentations the-struct_83)" +" keep-comment?70_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_83)))))))))" +"(define-values" +"(next-readtable)" +"(lambda(config_6)" +"(begin" +"(if(eq?(read-config-readtable config_6)(read-config-next-readtable config_6))" +"(let-values() config_6)" +"(let-values()" +"(let-values(((v_225) config_6))" +"(let-values(((the-struct_84) v_225))" +"(if(read-config/outer? the-struct_84)" +"(let-values(((inner72_0)" +"(let-values(((the-struct_85)(read-config/outer-inner v_225)))" +"(if(read-config/inner? the-struct_85)" +"(let-values(((readtable73_0)(read-config-next-readtable config_6)))" +"(read-config/inner2.1" +" readtable73_0" +"(read-config/inner-next-readtable the-struct_85)" +"(read-config/inner-for-syntax? the-struct_85)" +"(read-config/inner-source the-struct_85)" +"(read-config/inner-read-compiled the-struct_85)" +"(read-config/inner-dynamic-require the-struct_85)" +"(read-config/inner-module-declared? the-struct_85)" +"(read-config/inner-coerce the-struct_85)" +"(read-config/inner-coerce-key the-struct_85)" +"(read-config/inner-parameter-override the-struct_85)" +"(read-config/inner-parameter-cache the-struct_85)" +"(read-config/inner-st the-struct_85)))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_85)))))" +"(read-config/outer1.1" +" inner72_0" +"(read-config/outer-wrap the-struct_84)" +"(read-config/outer-line the-struct_84)" +"(read-config/outer-col the-struct_84)" +"(read-config/outer-pos the-struct_84)" +"(read-config/outer-indentations the-struct_84)" +"(read-config/outer-keep-comment? the-struct_84)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_84)))))))))" +"(define-values" +"(coerce)" +"(lambda(val_78 in_2 config_7)" +"(begin" +"(let-values(((for-syntax?_5)(read-config-for-syntax? config_7)))" +"((read-config-coerce config_7)" +" for-syntax?_5" +" val_78" +"(if for-syntax?_5" +"(let-values(((in1_0) in_2)((config2_0) config_7))(port+config->srcloc49.1 #f in1_0 config2_0))" +" #f))))))" +"(define-values(default-reader-guard$1)(lambda(v_226)(begin 'default-reader-guard v_226)))" +"(define-values" +"(1/current-reader-guard)" +"(make-parameter" +" default-reader-guard$1" +"(lambda(v_227)" +"(begin" +"(if(if(procedure? v_227)(procedure-arity-includes? v_227 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'current-reader-guard \"(procedure-arity-includes/c 1)\" v_227)))" +" v_227))))" +"(define-values(1/read-square-bracket-as-paren)(make-parameter #t(lambda(v_1)(if v_1 #t #f))))" +"(define-values(1/read-curly-brace-as-paren)(make-parameter #t(lambda(v_228)(if v_228 #t #f))))" +"(define-values(1/read-square-bracket-with-tag)(make-parameter #f(lambda(v_229)(if v_229 #t #f))))" +"(define-values(1/read-curly-brace-with-tag)(make-parameter #f(lambda(v_66)(if v_66 #t #f))))" +"(define-values(1/read-cdot)(make-parameter #f(lambda(v_31)(if v_31 #t #f))))" +"(define-values(1/read-accept-graph)(make-parameter #t(lambda(v_67)(if v_67 #t #f))))" +"(define-values(1/read-accept-compiled)(make-parameter #f(lambda(v_2)(if v_2 #t #f))))" +"(define-values(1/read-accept-box)(make-parameter #t(lambda(v_230)(if v_230 #t #f))))" +"(define-values(1/read-decimal-as-inexact)(make-parameter #t(lambda(v_231)(if v_231 #t #f))))" +"(define-values(1/read-accept-dot)(make-parameter #t(lambda(v_68)(if v_68 #t #f))))" +"(define-values(1/read-accept-infix-dot)(make-parameter #t(lambda(v_32)(if v_32 #t #f))))" +"(define-values(1/read-accept-quasiquote)(make-parameter #t(lambda(v_3)(if v_3 #t #f))))" +"(define-values(1/read-accept-reader)(make-parameter #f(lambda(v_33)(if v_33 #t #f))))" +"(define-values(1/read-accept-lang)(make-parameter #t(lambda(v_4)(if v_4 #t #f))))" +"(define-values(unknown)(gensym 'unknown))" +"(define-values" +"(check-parameter)" +"(lambda(param_0 config_8)" +"(begin" +"(let-values(((cache_4)(read-config-parameter-cache config_8)))" +"(let-values(((v_70)" +"(hash-ref(read-config-parameter-override config_8) param_0(hash-ref cache_4 param_0 unknown))))" +"(if(eq? v_70 unknown)" +"(let-values()(let-values(((v_71)(param_0)))(begin(hash-set! cache_4 param_0 v_71) v_71)))" +"(let-values() v_70)))))))" +"(define-values" +"(override-parameter)" +"(lambda(param_1 config_9 v_30)" +"(begin" +"(let-values(((v_232) config_9))" +"(let-values(((the-struct_86) v_232))" +"(if(read-config/outer? the-struct_86)" +"(let-values(((inner1_0)" +"(let-values(((the-struct_87)(read-config/outer-inner v_232)))" +"(if(read-config/inner? the-struct_87)" +"(let-values(((parameter-override2_0)" +"(hash-set(read-config-parameter-override config_9) param_1 v_30)))" +"(read-config/inner2.1" +"(read-config/inner-readtable the-struct_87)" +"(read-config/inner-next-readtable the-struct_87)" +"(read-config/inner-for-syntax? the-struct_87)" +"(read-config/inner-source the-struct_87)" +"(read-config/inner-read-compiled the-struct_87)" +"(read-config/inner-dynamic-require the-struct_87)" +"(read-config/inner-module-declared? the-struct_87)" +"(read-config/inner-coerce the-struct_87)" +"(read-config/inner-coerce-key the-struct_87)" +" parameter-override2_0" +"(read-config/inner-parameter-cache the-struct_87)" +"(read-config/inner-st the-struct_87)))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_87)))))" +"(read-config/outer1.1" +" inner1_0" +"(read-config/outer-wrap the-struct_86)" +"(read-config/outer-line the-struct_86)" +"(read-config/outer-col the-struct_86)" +"(read-config/outer-pos the-struct_86)" +"(read-config/outer-indentations the-struct_86)" +"(read-config/outer-keep-comment? the-struct_86)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_86)))))))" +"(define-values" +"(force-parameters!)" +"(lambda(config_10)" +"(begin" +"(let-values(((cache_5)(read-config-parameter-cache config_10)))" +"(if(hash-ref cache_5 'all-forced #f)" +"(void)" +"(let-values()" +"(begin" +"(hash-set! cache_5 'all-forced #t)" +"(check-parameter read-case-sensitive config_10)" +"(check-parameter 1/read-square-bracket-as-paren config_10)" +"(check-parameter 1/read-curly-brace-as-paren config_10)" +"(check-parameter 1/read-square-bracket-with-tag config_10)" +"(check-parameter 1/read-curly-brace-with-tag config_10)" +"(check-parameter 1/read-cdot config_10)" +"(check-parameter 1/read-accept-graph config_10)" +"(check-parameter 1/read-accept-compiled config_10)" +"(check-parameter 1/read-accept-box config_10)" +"(check-parameter read-accept-bar-quote config_10)" +"(check-parameter 1/read-decimal-as-inexact config_10)" +"(check-parameter 1/read-accept-dot config_10)" +"(check-parameter 1/read-accept-infix-dot config_10)" +"(check-parameter 1/read-accept-quasiquote config_10)" +"(check-parameter 1/read-accept-reader config_10)" +"(check-parameter 1/read-accept-lang config_10))))))))" +"(define-values" +"(struct:special-comment 1/make-special-comment 1/special-comment? 1/special-comment-value)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'special-comment" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'make-special-comment)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'value))))" +"(define-values" +"(struct:readtable" +" readtable1.1" +" 1/readtable?" +" readtable-symbol-parser" +" readtable-char-ht" +" readtable-dispatch-ht" +" readtable-delimiter-ht)" +"(let-values(((struct:_23 make-_23 ?_23 -ref_23 -set!_23)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'readtable" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:readtable #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'readtable)))))" +"(values" +" struct:_23" +" make-_23" +" ?_23" +"(make-struct-field-accessor -ref_23 0 'symbol-parser)" +"(make-struct-field-accessor -ref_23 1 'char-ht)" +"(make-struct-field-accessor -ref_23 2 'dispatch-ht)" +"(make-struct-field-accessor -ref_23 3 'delimiter-ht))))" +"(define-values" +"(1/make-readtable)" +"(lambda(rt_0 . args_7)" +"(begin" +" 'make-readtable" +"(begin" +"(if(let-values(((or-part_53)(not rt_0)))(if or-part_53 or-part_53(1/readtable? rt_0)))" +"(void)" +" (let-values () (raise-argument-error 'make-readtable \"(or/c readtable? #f)\" rt_0)))" +"((letrec-values(((loop_99)" +"(lambda(args_8 symbol-parser_0 char-ht_0 dispatch-ht_0 delimiter-ht_0)" +"(begin" +" 'loop" +"(if(null? args_8)" +"(let-values()(readtable1.1 symbol-parser_0 char-ht_0 dispatch-ht_0 delimiter-ht_0))" +"(let-values()" +"(let-values(((key_84)(car args_8)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_165)(not key_84)))" +"(if or-part_165 or-part_165(char? key_84)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c char? #f)\"" +" key_84)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(null? args_8)" +"(let-values()" +"(if key_84" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +"(string-append" +" \"expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro,\"" +" \" or character argument after character argument\")" +" \"character\"" +" key_84))" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +" \"expected 'non-terminating-macro after #f\"))))" +"(void))" +"(values))))" +"(let-values(((mode_17)(cadr args_8)))" +"(let-values((()" +"(begin" +"(if key_84" +"(let-values()" +"(if(let-values(((or-part_259)" +"(eq? mode_17 'terminating-macro)))" +"(if or-part_259" +" or-part_259" +"(let-values(((or-part_260)" +"(eq?" +" mode_17" +" 'non-terminating-macro)))" +"(if or-part_260" +" or-part_260" +"(let-values(((or-part_295)" +"(eq? mode_17 'dispatch-macro)))" +"(if or-part_295" +" or-part_295" +"(char? mode_17)))))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)\"" +" mode_17))))" +"(let-values()" +"(if(eq? mode_17 'non-terminating-macro)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +" \"expected 'non-terminating-macro after #f\")))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(null?(cddr args_8))" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +"(if key_84" +" \"expected readtable or #f argument after character argument\"" +" \"expected procedure argument after symbol argument\")" +" \"given\"" +" mode_17))" +"(void))" +"(values))))" +"(let-values(((target_0)(caddr args_8)))" +"(let-values(((rest-args_0)(cdddr args_8)))" +"(if(not key_84)" +"(let-values()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(loop_99" +" rest-args_0" +" target_0" +" char-ht_0" +" dispatch-ht_0" +" delimiter-ht_0)))" +"(if(eq? mode_17 'dispatch-macro)" +"(let-values()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(loop_99" +" rest-args_0" +" symbol-parser_0" +" char-ht_0" +"(hash-set dispatch-ht_0 key_84 target_0)" +" delimiter-ht_0)))" +"(if(char? mode_17)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_287)" +"(not target_0)))" +"(if or-part_287" +" or-part_287" +"(1/readtable? target_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c readtable? #f)\"" +" target_0)))" +"(values))))" +"(let-values(((actual-target_0)" +"(let-values(((or-part_22)" +"(if target_0" +"(hash-ref" +"(readtable-char-ht target_0)" +" mode_17" +" #f)" +" #f)))" +"(if or-part_22 or-part_22 mode_17))))" +"(let-values(((new-char-ht_0)" +"(if actual-target_0" +"(hash-set" +" char-ht_0" +" key_84" +" actual-target_0)" +"(hash-remove char-ht_0 key_84))))" +"(let-values(((new-delimiter-ht_0)" +"(hash-set" +" delimiter-ht_0" +" key_84" +"(if target_0" +"(hash-ref" +"(readtable-delimiter-ht target_0)" +" mode_17" +" mode_17)" +" mode_17))))" +"(loop_99" +" rest-args_0" +" symbol-parser_0" +" new-char-ht_0" +" dispatch-ht_0" +" new-delimiter-ht_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(values))))" +"(let-values(((new-char-ht_1)" +"(hash-set char-ht_0 key_84 target_0)))" +"(let-values(((new-delimiter-ht_1)" +"(hash-set" +" delimiter-ht_0" +" key_84" +"(if(eq? mode_17 'terminating-macro)" +" 'delimit" +" 'no-delimit))))" +"(loop_99" +" rest-args_0" +" symbol-parser_0" +" new-char-ht_1" +" dispatch-ht_0" +" new-delimiter-ht_1))))))))))))))))))))))" +" loop_99)" +" args_7" +"(if rt_0(readtable-symbol-parser rt_0) #f)" +"(if rt_0(readtable-char-ht rt_0) '#hasheqv())" +"(if rt_0(readtable-dispatch-ht rt_0) '#hasheqv())" +"(if rt_0(readtable-delimiter-ht rt_0) '#hasheqv()))))))" +"(define-values" +"(*readtable-effective-char)" +"(lambda(rt_1 c_57)" +"(begin" +"(let-values(((target_1)(hash-ref(readtable-char-ht rt_1) c_57 #f)))" +"(if(not target_1)(let-values() c_57)(if(char? target_1)(let-values() target_1)(let-values() '#\\x)))))))" +"(define-values" +"(effective-char)" +"(lambda(c_58 config_11)" +"(begin" +"(let-values(((rt_2)(read-config-readtable config_11))((c_59) c_58))" +"(if(let-values(((or-part_308)(not rt_2)))(if or-part_308 or-part_308(not(char? c_59))))" +"(let-values() c_59)" +"(let-values()(*readtable-effective-char rt_2 c_59)))))))" +"(define-values" +"(readtable-handler)" +"(lambda(config_12 c_60)" +"(begin" +"(let-values(((rt_3)(read-config-readtable config_12)))" +"(if rt_3" +"(let-values(((target_2)(hash-ref(readtable-char-ht rt_3) c_60 #f)))" +"(if target_2(if(not(char? target_2)) target_2 #f) #f))" +" #f)))))" +"(define-values" +"(readtable-dispatch-handler)" +"(lambda(config_13 c_61)" +"(begin" +"(let-values((()(begin(force-parameters! config_13)(values))))" +"(let-values(((rt_4)(read-config-readtable config_13)))" +"(if rt_4(hash-ref(readtable-dispatch-ht rt_4) c_61 #f) #f))))))" +"(define-values" +"(readtable-apply)" +"(lambda(handler_0 c_62 in_3 config_14 line_3 col_2 pos_110)" +"(begin" +"(let-values(((for-syntax?_6)(read-config-for-syntax? config_14)))" +"(let-values(((v_233)" +"(if(not for-syntax?_6)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_14)" +"(let-values()" +"(if(procedure-arity-includes? handler_0 2)" +"(handler_0 c_62 in_3)" +"(handler_0 c_62 in_3 #f line_3 col_2 pos_110)))))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_14)" +"(let-values()" +"(handler_0 c_62 in_3(read-config-source config_14) line_3 col_2 pos_110)))))))" +"(if(1/special-comment? v_233) v_233(coerce v_233 in_3 config_14)))))))" +"(define-values" +"(1/readtable-mapping)" +"(lambda(rt_5 c_63)" +"(begin" +" 'readtable-mapping" +"(let-values((()" +"(begin" +"(if(1/readtable? rt_5)" +"(void)" +" (let-values () (raise-argument-error 'readtable-mapping \"readtable?\" rt_5)))" +"(values))))" +"(let-values((()" +"(begin" +" (if (char? c_63) (void) (let-values () (raise-argument-error 'readtable-mapping \"char?\" c_63)))" +"(values))))" +"(let-values(((handler_1)(hash-ref(readtable-char-ht rt_5) c_63 #f)))" +"(values" +"(let-values(((or-part_167)" +"(if handler_1" +"(if(char? handler_1)" +"(let-values() handler_1)" +"(if(eq? 'delimit(hash-ref(readtable-delimiter-ht rt_5) c_63 #f))" +"(let-values() 'terminating-macro)" +"(let-values() 'non-terminating-macro)))" +" #f)))" +"(if or-part_167 or-part_167 c_63))" +"(if(char? handler_1) #f handler_1)" +"(hash-ref(readtable-dispatch-ht rt_5) c_63 #f))))))))" +"(define-values" +"(readtable-equivalent-chars)" +"(lambda(rt_6 c_64)" +"(begin" +"(let-values(((ht_153)(readtable-char-ht rt_6)))" +"(append" +"(if(hash-ref ht_153 c_64 #f) null(list c_64))" +"(reverse$1" +"(let-values(((ht_154) ht_153))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_154)))" +"((letrec-values(((for-loop_271)" +"(lambda(fold-var_85 i_168)" +"(begin" +" 'for-loop" +"(if i_168" +"(let-values(((k_40 v_94)(hash-iterate-key+value ht_154 i_168)))" +"(let-values(((fold-var_284)" +"(let-values(((fold-var_88) fold-var_85))" +"(if(eqv? v_94 c_64)" +"(let-values(((fold-var_238) fold-var_88))" +"(let-values(((fold-var_13)" +"(let-values()" +"(cons(let-values() k_40) fold-var_238))))" +"(values fold-var_13)))" +" fold-var_88))))" +"(if(not #f)" +"(for-loop_271 fold-var_284(hash-iterate-next ht_154 i_168))" +" fold-var_284)))" +" fold-var_85)))))" +" for-loop_271)" +" null" +"(hash-iterate-first ht_154))))))))))" +"(define-values" +"(struct:special special1.1 special? special-value)" +"(let-values(((struct:_83 make-_83 ?_83 -ref_83 -set!_83)" +"(let-values()" +"(let-values()(make-struct-type 'special #f 1 0 #f null(current-inspector) #f '(0) #f 'special)))))" +"(values struct:_83 make-_83 ?_83(make-struct-field-accessor -ref_83 0 'value))))" +"(define-values" +"(wrap)" +"(lambda(s-exp_3 in_2 config_7 rep_0)" +"(begin" +"(let-values(((wrap_6)(read-config-wrap config_7)))" +"(if wrap_6" +"(wrap_6" +" s-exp_3" +"(let-values(((in1_1) in_2)((config2_1) config_7))(port+config->srcloc49.1 #f in1_1 config2_1))" +" rep_0)" +" s-exp_3)))))" +"(define-values(consume-char)(lambda(in_4 c_33)(begin(begin(read-char in_4)(void)))))" +"(define-values" +"(consume-char/special)" +"(lambda(in_5 config_15 c_25)" +"(begin(begin(read-char-or-special in_5 special1.1(read-config-source config_15))(void)))))" +"(define-values" +"(reader-error12.1)" +"(lambda(continuation-marks1_0 due-to2_0 end-pos4_0 who3_0 in9_0 config10_0 str11_0 new-rest_0)" +"(begin" +" 'reader-error12" +"(let-values(((in_6) in9_0))" +"(let-values(((config_16) config10_0))" +"(let-values(((continuation-marks_0)" +"(if(eq? continuation-marks1_0 unsafe-undefined)" +"(current-continuation-marks)" +" continuation-marks1_0)))" +"(let-values(((due-to_0) due-to2_0))" +"(let-values(((who_28)" +"(if(eq? who3_0 unsafe-undefined)" +"(if(read-config-for-syntax? config_16) 'read-syntax 'read)" +" who3_0)))" +"(let-values(((end-pos_2) end-pos4_0))" +"(let-values(((str_25) str11_0))" +"(let-values(((args_9) new-rest_0))" +" (let-values (((msg_0) (format \"~a: ~a\" who_28 (apply format str_25 args_9))))" +"(let-values(((srcloc_10)" +"(if in_6" +"(let-values(((in23_0) in_6)((config24_0) config_16)((end-pos25_0) end-pos_2))" +"(port+config->srcloc49.1 end-pos25_0 in23_0 config24_0))" +" #f)))" +"(raise" +"((if(eof-object? due-to_0)" +"(let-values() exn:fail:read:eof)" +"(if(not(char? due-to_0))" +"(let-values() exn:fail:read:non-char)" +"(let-values() exn:fail:read)))" +"(let-values(((s_41)" +"(if(error-print-source-location)" +"(if srcloc_10(srcloc->string srcloc_10) #f)" +" #f)))" +" (if s_41 (string-append s_41 \": \" msg_0) msg_0))" +" continuation-marks_0" +"(if srcloc_10(list srcloc_10) null))))))))))))))))" +"(define-values" +"(bad-syntax-error20.1)" +"(lambda(due-to15_0 in17_0 config18_0 str19_0)" +"(begin" +" 'bad-syntax-error20" +"(let-values(((in_7) in17_0))" +"(let-values(((config_17) config18_0))" +"(let-values(((str_26) str19_0))" +"(let-values(((due-to_1) due-to15_0))" +"(let-values()" +"(let-values(((in26_0) in_7)" +"((config27_0) config_17)" +"((due-to28_0) due-to_1)" +" ((temp29_3) \"bad syntax `~a`\")" +"((str30_0) str_26))" +"(reader-error12.1" +" unsafe-undefined" +" due-to28_0" +" #f" +" unsafe-undefined" +" in26_0" +" config27_0" +" temp29_3" +"(list str30_0)))))))))))" +"(define-values" +"(catch-and-reraise-as-reader/proc)" +"(lambda(in_8 config_18 thunk_7)" +"(begin" +"(let-values(((with-handlers-predicate31_0) exn:fail?)" +"((with-handlers-handler32_0)" +"(lambda(exn_3)" +"(begin" +" 'with-handlers-handler32" +"(let-values(((in33_0) in_8)" +"((config34_0) config_18)" +" ((temp35_2) \"~a\")" +"((temp36_3)" +"(let-values(((s_486)(exn-message exn_3)))" +" (regexp-replace \"^[a-z-]*: \" s_486 \"\")))" +"((temp37_2)(exn-continuation-marks exn_3)))" +"(reader-error12.1" +" temp37_2" +" '#\\x" +" #f" +" unsafe-undefined" +" in33_0" +" config34_0" +" temp35_2" +"(list temp36_3)))))))" +"(let-values(((bpz_3)(continuation-mark-set-first #f break-enabled-key)))" +"(call-handled-body" +" bpz_3" +"(lambda(e_76)" +"(select-handler/no-breaks e_76 bpz_3(list(cons with-handlers-predicate31_0 with-handlers-handler32_0))))" +"(lambda()(thunk_7))))))))" +"(define-values" +"(port-next-location*)" +"(lambda(in_4 init-c_0)" +"(begin" +"(if(not init-c_0)" +"(let-values()(port-next-location in_4))" +"(let-values()" +"(let-values(((line_4 col_3 pos_111)(port-next-location in_4)))" +"(values line_4(if col_3(max 0(sub1 col_3)) #f)(if pos_111(max 1(sub1 pos_111)) #f))))))))" +"(define-values" +"(read-char/skip-whitespace-and-comments)" +"(lambda(init-c_1 read-one_0 in_5 config_15)" +"(begin" +"(let-values(((rt_7)(read-config-readtable config_15)))" +"(let-values(((source_3)(read-config-source config_15)))" +"((letrec-values(((skip-loop_0)" +"(lambda(init-c_2)" +"(begin" +" 'skip-loop" +"(let-values(((c_36)" +"(let-values(((or-part_158) init-c_2))" +"(if or-part_158" +" or-part_158" +"(let-values(((in_9) in_5)((source_4) source_3))" +"(read-char-or-special in_9 special1.1 source_4))))))" +"(let-values(((ec_0)" +"(let-values(((rt_8) rt_7)((c_65) c_36))" +"(if(let-values(((or-part_5)(not rt_8)))" +"(if or-part_5 or-part_5(not(char? c_65))))" +"(let-values() c_65)" +"(let-values()(*readtable-effective-char rt_8 c_65))))))" +"(if(eof-object? ec_0)" +"(let-values() c_36)" +"(if(not(char? ec_0))" +"(let-values()" +"(let-values(((v_1)(special-value c_36)))" +"(if(if(1/special-comment? v_1)" +"(not(read-config-keep-comment? config_15))" +" #f)" +"(let-values()(skip-loop_0 #f))" +"(let-values() c_36))))" +"(if(char-whitespace? ec_0)" +"(let-values()(skip-loop_0 #f))" +"(if(char=? '#\\; ec_0)" +"(let-values()" +"(begin" +"((letrec-values(((loop_80)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_66)" +"(let-values(((in_10) in_5)" +"((source_5) source_3))" +"(read-char-or-special" +" in_10" +" special1.1" +" source_5))))" +"(if(let-values(((or-part_309)" +"(eof-object? c_66)))" +"(if or-part_309" +" or-part_309" +"(eqv?" +" '#\\newline" +"(effective-char c_66 config_15))))" +"(void)" +"(let-values()(loop_80))))))))" +" loop_80))" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(eqv?" +" '#\\|" +"(let-values(((in_11) in_5)((skip-count_0) 0)((source_6) source_3))" +"(let-values(((c_67)" +"(peek-char-or-special" +" in_11" +" skip-count_0" +" 'special" +" source_6)))" +"(if(eq? c_67 'special)(special1.1 'special) c_67))))" +" #f)" +"(let-values()" +"(begin" +"(skip-pipe-comment! c_36 in_5 config_15)" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(if(eqv?" +" '#\\!" +"(let-values(((in_12) in_5)" +"((skip-count_1) 0)" +"((source_7) source_3))" +"(let-values(((c_68)" +"(peek-char-or-special" +" in_12" +" skip-count_1" +" 'special" +" source_7)))" +"(if(eq? c_68 'special)(special1.1 'special) c_68))))" +"(let-values(((c3_2)" +"(let-values(((in_13) in_5)" +"((skip-count_2) 1)" +"((source_8) source_3))" +"(let-values(((c_69)" +"(peek-char-or-special" +" in_13" +" skip-count_2" +" 'special" +" source_8)))" +"(if(eq? c_69 'special)" +"(special1.1 'special)" +" c_69)))))" +"(let-values(((or-part_310)(eqv? '#\\space c3_2)))" +"(if or-part_310 or-part_310(eqv? '#\\/ c3_2))))" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(skip-unix-line-comment! in_5 config_15)" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(eqv?" +" '#\\;" +"(let-values(((in_14) in_5)" +"((skip-count_3) 0)" +"((source_9) source_3))" +"(let-values(((c_70)" +"(peek-char-or-special" +" in_14" +" skip-count_3" +" 'special" +" source_9)))" +"(if(eq? c_70 'special)(special1.1 'special) c_70))))" +" #f)" +"(let-values()" +"(let-values((()(begin(consume-char in_5 '#\\;)(values))))" +"(let-values(((v_234)(read-one_0 #f in_5 config_15)))" +"(begin" +"(if(eof-object? v_234)" +"(let-values()" +"(let-values(((in1_2) in_5)" +"((config2_2) config_15)" +"((v3_0) v_234)" +"((temp4_2)" +" \"expected a commented-out element for `~a;`, but found end-of-file\")" +"((ec5_0) ec_0))" +"(reader-error12.1" +" unsafe-undefined" +" v3_0" +" #f" +" unsafe-undefined" +" in1_2" +" config2_2" +" temp4_2" +"(list ec5_0))))" +"(void))" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))))" +"(let-values() c_36))))))))))))))" +" skip-loop_0)" +" init-c_1))))))" +"(define-values(result-special-comment)(lambda()(begin(special1.1(1/make-special-comment #f)))))" +"(define-values" +"(skip-pipe-comment!)" +"(lambda(init-c_3 in_15 config_19)" +"(begin" +"(let-values(((source_10)(read-config-source config_19)))" +"(let-values(((line_5 col_4 pos_112)(port-next-location in_15)))" +"(begin" +"(consume-char in_15 '#\\|)" +"((letrec-values(((loop_106)" +"(lambda(prev-c_0 depth_10)" +"(begin" +" 'loop" +"(let-values(((c_71)" +"(let-values(((in_16) in_15)((source_11) source_10))" +"(read-char-or-special in_16 special1.1 source_11))))" +"(if(eof-object? c_71)" +"(let-values()" +"(let-values(((in6_0) in_15)" +"((temp7_3)(reading-at config_19 line_5 col_4 pos_112))" +"((c8_0) c_71)" +" ((temp9_4) \"end of file in `#|` comment\"))" +"(reader-error12.1" +" unsafe-undefined" +" c8_0" +" #f" +" unsafe-undefined" +" in6_0" +" temp7_3" +" temp9_4" +"(list))))" +"(if(not(char? c_71))" +"(let-values()(loop_106 #f depth_10))" +"(if(if(char=? '#\\| c_71)(eqv? prev-c_0 '#\\#) #f)" +"(let-values()(loop_106 #f(add1 depth_10)))" +"(if(if(char=? '#\\# c_71)(eqv? prev-c_0 '#\\|) #f)" +"(let-values()" +"(if(positive? depth_10)" +"(let-values()(loop_106 #f(sub1 depth_10)))" +"(void)))" +"(let-values()(loop_106 c_71 depth_10)))))))))))" +" loop_106)" +" #f" +" 0)))))))" +"(define-values" +"(skip-unix-line-comment!)" +"(lambda(in_17 config_20)" +"(begin" +"((letrec-values(((loop_107)" +"(lambda(backslash?_0)" +"(begin" +" 'loop" +"(let-values(((c_42)" +"(let-values(((in_18) in_17)((source_12)(read-config-source config_20)))" +"(read-char-or-special in_18 special1.1 source_12))))" +"(if(eof-object? c_42)" +"(let-values()(void))" +"(if(not(char? c_42))" +"(let-values()(loop_107 #f))" +"(if(char=? c_42 '#\\newline)" +"(let-values()(if backslash?_0(let-values()(loop_107 #f))(void)))" +"(if(char=? c_42 '#\\\\)" +"(let-values()(loop_107 #t))" +"(let-values()(loop_107 #f)))))))))))" +" loop_107)" +" #f))))" +"(define-values" +"(readtable-char-delimiter?)" +"(lambda(rt_9 c_33 config_7)" +"(begin" +"(let-values(((dc_0)" +"(let-values(((or-part_2)(if rt_9(hash-ref(readtable-delimiter-ht rt_9) c_33 #f) #f)))" +"(if or-part_2 or-part_2 c_33))))" +"(if(eq? dc_0 'no-delimit)" +"(let-values() #f)" +"(if(not(char? dc_0))" +"(let-values() #t)" +"(let-values()" +"(let-values(((or-part_26)(char-whitespace? dc_0)))" +"(if or-part_26" +" or-part_26" +"(let-values(((or-part_311)(char=? dc_0 '#\\()))" +"(if or-part_311" +" or-part_311" +"(let-values(((or-part_292)(char=? dc_0 '#\\))))" +"(if or-part_292" +" or-part_292" +"(let-values(((or-part_27)(char=? dc_0 '#\\[)))" +"(if or-part_27" +" or-part_27" +"(let-values(((or-part_10)(char=? dc_0 '#\\])))" +"(if or-part_10" +" or-part_10" +"(let-values(((or-part_158)(char=? dc_0 '#\\{)))" +"(if or-part_158" +" or-part_158" +"(let-values(((or-part_12)(char=? dc_0 '#\\})))" +"(if or-part_12" +" or-part_12" +"(let-values(((or-part_13)(char=? dc_0 '#\\')))" +"(if or-part_13" +" or-part_13" +"(let-values(((or-part_217)(char=? dc_0 '#\\`)))" +"(if or-part_217" +" or-part_217" +"(let-values(((or-part_3)(char=? dc_0 '#\\,)))" +"(if or-part_3" +" or-part_3" +"(let-values(((or-part_4)(char=? dc_0 '#\\;)))" +"(if or-part_4" +" or-part_4" +" (let-values (((or-part_5) (char=? dc_0 '#\\\")))" +"(if or-part_5" +" or-part_5" +"(if(char=? dc_0 '#\\.)" +"(check-parameter 1/read-cdot config_7)" +" #f))))))))))))))))))))))))))))))))" +"(define-values" +"(char-delimiter?)" +"(lambda(c_14 config_21)(begin(readtable-char-delimiter?(read-config-readtable config_21) c_14 config_21))))" +"(define-values" +"(char-closer?)" +"(lambda(ec_1 config_8)" +"(begin" +"(if(not(eof-object? ec_1))" +"(let-values(((or-part_1)(char=? ec_1 '#\\))))" +"(if or-part_1" +" or-part_1" +"(let-values(((or-part_11)(char=? ec_1 '#\\])))(if or-part_11 or-part_11(char=? ec_1 '#\\})))))" +" #f))))" +" (define-values (closer-name) (lambda (c_25 config_22) (begin (effective-char-names c_25 config_22 \"closer\"))))" +" (define-values (opener-name) (lambda (c_34 config_23) (begin (effective-char-names c_34 config_23 \"opener\"))))" +"(define-values" +"(effective-char-names)" +"(lambda(c_36 config_24 fallback-str_0)" +"(begin" +"(let-values(((rt_10)(read-config-readtable config_24)))" +"(if(not rt_10)" +" (let-values () (format \"`~a`\" c_36))" +"(let-values()" +"(let-values(((cs_1)(readtable-equivalent-chars rt_10 c_36)))" +"(if(null? cs_1)" +"(let-values() fallback-str_0)" +"(if(null?(cdr cs_1))" +" (let-values () (format \"`~a`\" (car cs_1)))" +"(if(null?(cddr cs_1))" +" (let-values () (format \"`~a` or `~a`\" (car cs_1) (cadr cs_1)))" +"(let-values()" +"(apply" +" string-append" +"((letrec-values(((loop_108)" +"(lambda(cs_2)" +"(begin" +" 'loop" +"(if(null?(cdr cs_2))" +" (let-values () (list (format \"or `~a`\" (car cs_2))))" +"(let-values()" +" (cons (format \"`~a`, \" (car cs_2)) (loop_108 (cdr cs_2)))))))))" +" loop_108)" +" cs_1)))))))))))))" +"(define-values" +"(closer->opener)" +"(lambda(c_65)" +"(begin" +"(let-values(((tmp_36) c_65))" +"(if(equal? tmp_36 '#\\))" +"(let-values() '#\\()" +"(if(equal? tmp_36 '#\\])" +"(let-values() '#\\[)" +"(if(equal? tmp_36 '#\\})(let-values() '#\\{)(let-values() c_65))))))))" +" (define-values (dot-name) (lambda (config_25) (begin \"`.`\")))" +"(define-values" +"(all-openers-str)" +"(lambda(config_21)" +"(begin" +"(let-values(((p_63)(opener-name '#\\( config_21)))" +"(let-values(((s_10)" +"(if(check-parameter 1/read-square-bracket-as-paren config_21)(opener-name '#\\[ config_21) #f)))" +"(let-values(((c_72)" +"(if(check-parameter 1/read-curly-brace-as-paren config_21)(opener-name '#\\{ config_21) #f)))" +"(if(if s_10 c_72 #f)" +" (let-values () (format \"~a, ~a, or ~a\" p_63 s_10 c_72))" +"(if(let-values(((or-part_298) s_10))(if or-part_298 or-part_298 c_72))" +"(let-values()" +" (format \"~a or ~a\" p_63 (let-values (((or-part_309) s_10)) (if or-part_309 or-part_309 c_72))))" +"(let-values() p_63)))))))))" +"(define-values" +"(struct:accum-string" +" accum-string1.1" +" accum-string?" +" accum-string-pos" +" accum-string-str" +" set-accum-string-pos!" +" set-accum-string-str!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'accum-string #f 2 0 #f null(current-inspector) #f '() #f 'accum-string)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'pos)" +"(make-struct-field-accessor -ref_0 1 'str)" +"(make-struct-field-mutator -set!_0 0 'pos)" +"(make-struct-field-mutator -set!_0 1 'str))))" +"(define-values" +"(accum-string-init!)" +"(lambda(config_26)" +"(begin" +"(let-values(((st_1)(read-config-st config_26)))" +"(let-values(((a_69)(read-config-state-accum-str st_1)))" +"(if a_69" +"(let-values()(begin(set-read-config-state-accum-str! st_1 #f)(set-accum-string-pos! a_69 0) a_69))" +"(let-values()(accum-string1.1 0(make-string 32)))))))))" +"(define-values" +"(accum-string-add!)" +"(lambda(a_70 c_50)" +"(begin" +"(let-values(((pos_113)(accum-string-pos a_70)))" +"(let-values(((str_27)(accum-string-str a_70)))" +"(let-values(((str2_0)" +"(if(< pos_113(string-length str_27))" +"(let-values() str_27)" +"(let-values()" +"(let-values(((str2_1)(make-string(*(string-length str_27) 2))))" +"(begin(string-copy! str2_1 0 str_27)(set-accum-string-str! a_70 str2_1) str2_1))))))" +"(begin(string-set! str2_0 pos_113 c_50)(set-accum-string-pos! a_70(add1 pos_113)))))))))" +"(define-values(accum-string-count)(lambda(a_71)(begin(accum-string-pos a_71))))" +"(define-values(set-accum-string-count!)(lambda(a_72 pos_12)(begin(set-accum-string-pos! a_72 pos_12))))" +"(define-values" +"(accum-string-convert!)" +"(lambda(a_73 convert_1 start-pos_6)" +"(begin" +"(let-values(((str_28)(accum-string-str a_73)))" +"(let-values(((s_80)(convert_1(substring str_28 start-pos_6(accum-string-pos a_73)))))" +"(let-values(((len_36)(string-length s_80)))" +"(begin" +"(if(<(+ len_36 start-pos_6)(string-length str_28))" +"(void)" +"(let-values()" +"(let-values(((str2_2)(make-string(+ start-pos_6 len_36))))" +"(begin(string-copy! str2_2 0 str_28 0 start-pos_6)(set-accum-string-str! a_73 str2_2)))))" +"(string-copy!(accum-string-str a_73) start-pos_6 s_80)" +"(set-accum-string-pos! a_73(+ start-pos_6 len_36)))))))))" +"(define-values" +"(accum-string-get!6.1)" +"(lambda(start-pos2_0 a4_0 config5_0)" +"(begin" +" 'accum-string-get!6" +"(let-values(((a_58) a4_0))" +"(let-values(((config_27) config5_0))" +"(let-values(((start-pos_7) start-pos2_0))" +"(let-values()" +"(let-values(((s_43)(substring(accum-string-str a_58) start-pos_7(accum-string-pos a_58))))" +"(begin(accum-string-abandon! a_58 config_27) s_43)))))))))" +"(define-values" +"(accum-string-get-bytes!13.1)" +"(lambda(start-pos9_0 a11_0 config12_0)" +"(begin" +" 'accum-string-get-bytes!13" +"(let-values(((a_64) a11_0))" +"(let-values(((config_28) config12_0))" +"(let-values(((start-pos_8) start-pos9_0))" +"(let-values()" +"(let-values(((bstr_3)" +"(string->bytes/latin-1(accum-string-str a_64) #f start-pos_8(accum-string-pos a_64))))" +"(begin(accum-string-abandon! a_64 config_28) bstr_3)))))))))" +"(define-values" +"(accum-string-abandon!)" +"(lambda(a_74 config_29)(begin(set-read-config-state-accum-str!(read-config-st config_29) a_74))))" +"(define-values" +"(struct:indentation" +" indentation1.1" +" indentation?" +" indentation-closer" +" indentation-suspicious-closer" +" indentation-multiline?" +" indentation-start-line" +" indentation-last-line" +" indentation-suspicious-line" +" indentation-max-indent" +" indentation-suspicious-quote" +" set-indentation-suspicious-closer!" +" set-indentation-multiline?!" +" set-indentation-last-line!" +" set-indentation-suspicious-line!" +" set-indentation-max-indent!" +" set-indentation-suspicious-quote!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'indentation #f 8 0 #f null(current-inspector) #f '(0 3) #f 'indentation)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'closer)" +"(make-struct-field-accessor -ref_0 1 'suspicious-closer)" +"(make-struct-field-accessor -ref_0 2 'multiline?)" +"(make-struct-field-accessor -ref_0 3 'start-line)" +"(make-struct-field-accessor -ref_0 4 'last-line)" +"(make-struct-field-accessor -ref_0 5 'suspicious-line)" +"(make-struct-field-accessor -ref_0 6 'max-indent)" +"(make-struct-field-accessor -ref_0 7 'suspicious-quote)" +"(make-struct-field-mutator -set!_0 1 'suspicious-closer)" +"(make-struct-field-mutator -set!_0 2 'multiline?)" +"(make-struct-field-mutator -set!_0 4 'last-line)" +"(make-struct-field-mutator -set!_0 5 'suspicious-line)" +"(make-struct-field-mutator -set!_0 6 'max-indent)" +"(make-struct-field-mutator -set!_0 7 'suspicious-quote))))" +"(define-values" +"(make-indentation)" +"(lambda(closer_0 in_19 config_30)" +"(begin" +"(let-values(((line_6 col_5 pos_114)(port-next-location in_19)))" +"(indentation1.1 closer_0 #f #f line_6 line_6 #f(if col_5(add1 col_5) #f) #f)))))" +"(define-values" +"(track-indentation!)" +"(lambda(config_31 line_7 col_6)" +"(begin" +"(let-values(((indts_0)(read-config-indentations config_31)))" +"(let-values(((indt_0)(if(pair? indts_0)(car indts_0) #f)))" +"(if(if indt_0" +"(if line_7(if(indentation-last-line indt_0)(> line_7(indentation-last-line indt_0)) #f) #f)" +" #f)" +"(let-values()" +"(begin" +"(set-indentation-last-line! indt_0 line_7)" +"(set-indentation-multiline?! indt_0 #t)" +"(if(>= col_6(indentation-max-indent indt_0))" +"(let-values()(set-indentation-max-indent! indt_0 col_6))" +"(let-values()" +"(if(indentation-suspicious-line indt_0)" +"(void)" +"(let-values()" +"(begin" +"(set-indentation-suspicious-closer! indt_0(indentation-closer indt_0))" +"(set-indentation-suspicious-line! indt_0 line_7))))))))" +"(void)))))))" +"(define-values" +"(indentation-possible-cause)" +"(lambda(config_32)" +"(begin" +"(let-values(((indt_1)(car(read-config-indentations config_32))))" +"(if(indentation-suspicious-line indt_1)" +"(let-values()" +"(format" +" \"\\n possible cause: indentation suggests a missing ~a before line ~a\"" +"(closer-name(indentation-suspicious-closer indt_1) config_32)" +"(indentation-suspicious-line indt_1)))" +" (let-values () \"\"))))))" +"(define-values" +"(indentation-unexpected-closer-message)" +"(lambda(ec_2 c_73 config_33)" +"(begin" +"(let-values(((indts_1)(read-config-indentations config_33)))" +"(if(null? indts_1)" +" (let-values () (format \"unexpected `~a`\" c_73))" +"(let-values()" +"(let-values(((indt_2)(car indts_1)))" +"(string-append" +"(if(char=? ec_2(indentation-closer indt_2))" +" (let-values () (format \"unexpected `~a`\" c_73))" +"(let-values()" +"(let-values(((missing_2)" +"(let-values(((or-part_301)" +"(let-values(((lst_7)(cdr indts_1)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_7)))" +"((letrec-values(((for-loop_0)" +"(lambda(result_119 lst_8)" +"(begin" +" 'for-loop" +"(if(pair? lst_8)" +"(let-values(((indt_3)(unsafe-car lst_8))" +"((rest_0)(unsafe-cdr lst_8)))" +"(let-values(((result_82)" +"(let-values()" +"(let-values(((result_120)" +"(let-values()" +"(let-values()" +"(if(char=?" +" ec_2" +"(indentation-closer" +" indt_3))" +" \"missing\"" +" #f)))))" +"(values result_120)))))" +"(if(if(not" +"((lambda x_84 result_82)" +" indt_3))" +"(not #f)" +" #f)" +"(for-loop_0 result_82 rest_0)" +" result_82)))" +" result_119)))))" +" for-loop_0)" +" #f" +" lst_7)))))" +" (if or-part_301 or-part_301 \"expected\"))))" +"(let-values(((opener-str_0)(opener-name(closer->opener(indentation-closer indt_2)) config_33)))" +"(format" +" \"~a ~a to close ~a, found instead `~a`\"" +" missing_2" +"(closer-name(indentation-closer indt_2) config_33)" +"(if(indentation-multiline? indt_2)" +" (let-values () (format \"~a on line ~a\" opener-str_0 (indentation-start-line indt_2)))" +" (let-values () (format \"preceding ~a\" opener-str_0)))" +" c_73)))))" +"(indentation-possible-cause config_33)))))))))" +"(define-values" +"(read-unwrapped-sequence17.1)" +"(lambda(dot-mode2_0" +" elem-config1_0" +" first-read-one5_0" +" shape-tag?3_0" +" whitespace-read-one4_0" +" read-one11_0" +" opener-c12_0" +" opener13_0" +" closer14_0" +" in15_0" +" seq-config16_0)" +"(begin" +" 'read-unwrapped-sequence17" +"(let-values(((read-one_1) read-one11_0))" +"(let-values(((opener-c_0) opener-c12_0))" +"(let-values(((opener_0) opener13_0))" +"(let-values(((closer_1) closer14_0))" +"(let-values(((in_20) in15_0))" +"(let-values(((seq-config_0) seq-config16_0))" +"(let-values(((elem-config_0)" +"(if(eq? elem-config1_0 unsafe-undefined)" +"(next-readtable seq-config_0)" +" elem-config1_0)))" +"(let-values(((dot-mode_0) dot-mode2_0))" +"(let-values(((shape-tag?_0) shape-tag?3_0))" +"(let-values(((whitespace-read-one_0)" +"(if(eq? whitespace-read-one4_0 unsafe-undefined)" +" read-one_1" +" whitespace-read-one4_0)))" +"(let-values(((first-read-one_0)" +"(if(eq? first-read-one5_0 unsafe-undefined) read-one_1 first-read-one5_0)))" +"(let-values()" +"(let-values(((head_0) #f))" +"(let-values(((indentation_0)(make-indentation closer_1 in_20 seq-config_0)))" +"(let-values(((config_34)" +"(let-values(((v_235) elem-config_0))" +"(let-values(((the-struct_88) v_235))" +"(if(read-config/outer? the-struct_88)" +"(let-values(((indentations20_0)" +"(cons" +" indentation_0" +"(read-config-indentations seq-config_0)))" +"((inner21_0)(read-config/outer-inner v_235)))" +"(read-config/outer1.1" +" inner21_0" +"(read-config/outer-wrap the-struct_88)" +"(read-config/outer-line the-struct_88)" +"(read-config/outer-col the-struct_88)" +"(read-config/outer-pos the-struct_88)" +" indentations20_0" +"(read-config/outer-keep-comment? the-struct_88)))" +"(raise-argument-error" +" 'struct-copy" +" \"read-config/outer?\"" +" the-struct_88))))))" +"(let-values(((open-end-line_0 open-end-col_0 open-end-pos_0)" +"(port-next-location in_20)))" +"(let-values(((config/keep-comment_0)(keep-comment config_34)))" +"(let-values(((read-one/not-eof_0)" +"(lambda(init-c_4 read-one_2 config_35)" +"(begin" +" 'read-one/not-eof" +"(let-values(((e_77)(read-one_2 init-c_4 in_20 config_35)))" +"(begin" +"(if(eof-object? e_77)" +"(let-values()" +"(let-values(((in22_0) in_20)" +"((seq-config23_0) seq-config_0)" +"((e24_0) e_77)" +"((open-end-pos25_0) open-end-pos_0)" +"((temp26_3)" +" \"expected a ~a to close `~a`~a\")" +"((temp27_5)" +"(closer-name closer_1 config_35))" +"((opener-c28_0) opener-c_0)" +"((temp29_4)" +"(indentation-possible-cause config_35)))" +"(reader-error12.1" +" unsafe-undefined" +" e24_0" +" open-end-pos25_0" +" unsafe-undefined" +" in22_0" +" seq-config23_0" +" temp26_3" +"(list temp27_5 opener-c28_0 temp29_4))))" +"(void))" +" e_77))))))" +"(let-values(((seq_0)" +"((letrec-values(((loop_109)" +"(lambda(depth_11" +" accum_0" +" init-c_5" +" first?_1" +" first-read-one_1)" +"(begin" +" 'loop" +"(let-values(((c_74)" +"(read-char/skip-whitespace-and-comments" +" init-c_5" +" whitespace-read-one_0" +" in_20" +" seq-config_0)))" +"(let-values(((ec_3)" +"(effective-char" +" c_74" +" seq-config_0)))" +"(if(eqv? ec_3 closer_1)" +"(let-values()" +"(if(null? accum_0)" +" null" +"(reverse$1 accum_0)))" +"(if(if(not first?_1)" +"(if(eqv? ec_3 '#\\.)" +"(if(check-parameter" +" 1/read-accept-dot" +" config_34)" +"(char-delimiter?" +"(let-values(((in_21)" +" in_20)" +"((skip-count_4)" +" 0)" +"((source_13)" +"(read-config-source" +" config_34)))" +"(let-values(((c_75)" +"(peek-char-or-special" +" in_21" +" skip-count_4" +" 'special" +" source_13)))" +"(if(eq?" +" c_75" +" 'special)" +"(special1.1" +" 'special)" +" c_75)))" +" seq-config_0)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((dot-line_0" +" dot-col_0" +" dot-pos_0)" +"(port-next-location*" +" in_20" +" c_74)))" +"(let-values((()" +"(begin" +"(track-indentation!" +" config_34" +" dot-line_0" +" dot-col_0)" +"(values))))" +"(let-values((()" +"(begin" +"(if(if dot-mode_0" +"(not" +" head_0)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((in30_0)" +" in_20)" +"((temp31_2)" +"(reading-at" +" config_34" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((temp32_1)" +" \"illegal use of `.`\"))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in30_0" +" temp31_2" +" temp32_1" +"(list)))))" +"(values))))" +"(let-values(((v_236)" +"(read-one/not-eof_0" +" #f" +" first-read-one_1" +" config_34)))" +"(let-values(((rest-c_0)" +"(read-char/skip-whitespace-and-comments" +" #f" +" whitespace-read-one_0" +" in_20" +" seq-config_0)))" +"(let-values(((rest-ec_0)" +"(effective-char" +" rest-c_0" +" seq-config_0)))" +"(if(eqv?" +" rest-ec_0" +" closer_1)" +"(let-values()" +"(if(null?" +" accum_0)" +" v_236" +"(append" +"(reverse$1" +" accum_0)" +" v_236)))" +"(if(if(eqv?" +" rest-ec_0" +" '#\\.)" +"(if(check-parameter" +" 1/read-accept-dot" +" config_34)" +"(if(check-parameter" +" 1/read-accept-infix-dot" +" config_34)" +"(char-delimiter?" +"(let-values(((in_22)" +" in_20)" +"((skip-count_5)" +" 0)" +"((source_14)" +"(read-config-source" +" config_34)))" +"(let-values(((c_58)" +"(peek-char-or-special" +" in_22" +" skip-count_5" +" 'special" +" source_14)))" +"(if(eq?" +" c_58" +" 'special)" +"(special1.1" +" 'special)" +" c_58)))" +" seq-config_0)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(set! head_0" +"(box" +" v_236))" +"(values))))" +"(let-values(((dot2-line_0" +" dot2-col_0" +" dot2-pos_0)" +"(port-next-location" +" in_20)))" +"(let-values((()" +"(begin" +"(track-indentation!" +" config_34" +" dot2-line_0" +" dot2-col_0)" +"(values))))" +"(let-values(((post-c_0)" +"(read-char/skip-whitespace-and-comments" +" #f" +" whitespace-read-one_0" +" in_20" +" seq-config_0)))" +"(let-values(((post-ec_0)" +"(effective-char" +" post-c_0" +" seq-config_0)))" +"(begin" +"(if(let-values(((or-part_266)" +"(eof-object?" +" post-ec_0)))" +"(if or-part_266" +" or-part_266" +"(eqv?" +" post-ec_0" +" closer_1)))" +"(let-values()" +"(let-values(((in33_1)" +" in_20)" +"((temp34_5)" +"(reading-at" +" config_34" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((post-ec35_0)" +" post-ec_0)" +"((temp36_4)" +" \"illegal use of `.`\"))" +"(reader-error12.1" +" unsafe-undefined" +" post-ec35_0" +" #f" +" unsafe-undefined" +" in33_1" +" temp34_5" +" temp36_4" +"(list))))" +"(void))" +"(loop_109" +" depth_11" +" accum_0" +" post-c_0" +" #f" +" read-one_1))))))))" +"(let-values()" +"(let-values(((in37_0)" +" in_20)" +"((temp38_4)" +"(reading-at" +" config_34" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((rest-c39_0)" +" rest-c_0)" +"((temp40_2)" +" \"illegal use of `.`\"))" +"(reader-error12.1" +" unsafe-undefined" +" rest-c39_0" +" #f" +" unsafe-undefined" +" in37_0" +" temp38_4" +" temp40_2" +"(list)))))))))))))" +"(let-values()" +"(let-values(((v_137)" +"(read-one/not-eof_0" +" c_74" +" first-read-one_1" +" config/keep-comment_0)))" +"(if(1/special-comment? v_137)" +"(let-values()" +"(loop_109" +" depth_11" +" accum_0" +" #f" +" #f" +" read-one_1))" +"(if(> depth_11 1024)" +"(let-values()" +"(loop_109" +" depth_11" +"(cons v_137 accum_0)" +" #f" +" #f" +" read-one_1))" +"(let-values()" +"(cons" +" v_137" +"(loop_109" +"(add1 depth_11)" +" null" +" #f" +" #f" +" read-one_1)))))))))))))))" +" loop_109)" +" 0" +" null" +" #f" +" #t" +" first-read-one_0)))" +"(let-values(((full-seq_0)(if head_0(cons(unbox head_0) seq_0) seq_0)))" +"(if shape-tag?_0" +"(add-shape-tag opener_0 in_20 config_34 full-seq_0)" +" full-seq_0))))))))))))))))))))))))" +"(define-values" +"(add-shape-tag)" +"(lambda(opener_1 in_23 config_36 seq_1)" +"(begin" +"(let-values(((tag_0)" +"(let-values(((tmp_37) opener_1))" +"(if(equal? tmp_37 '#\\[)" +"(let-values()(if(check-parameter 1/read-square-bracket-with-tag config_36) '#%brackets #f))" +"(if(equal? tmp_37 '#\\{)" +"(let-values()(if(check-parameter 1/read-curly-brace-with-tag config_36) '#%braces #f))" +"(let-values() #f))))))" +"(if tag_0(cons(wrap tag_0 in_23 config_36 #f) seq_1) seq_1)))))" +" (define-values (not-an-fX.1$1) (lambda (who_7 v_61) (begin 'not-an-fX (raise-argument-error who_7 \"flonum?\" v_61))))" +"(define-values" +"(read-digits12.1)" +"(lambda(base1_0 init3_0 max-count2_0 zero-digits-result4_0 in10_1 config11_0 accum-str9_0)" +"(begin" +" 'read-digits12" +"(let-values(((in_6) in10_1))" +"(let-values(((config_16) config11_0))" +"(let-values(((accum-str_0) accum-str9_0))" +"(let-values(((base_15) base1_0))" +"(let-values(((max-count_0) max-count2_0))" +"(let-values(((init-v_0) init3_0))" +"(let-values(((zero-digits-result_0) zero-digits-result4_0))" +"(let-values()" +"(let-values(((c_68)" +"(let-values(((in_24) in_6)" +"((skip-count_6) 0)" +"((source_15)(read-config-source config_16)))" +"(let-values(((c_45)" +"(peek-char-or-special in_24 skip-count_6 'special source_15)))" +"(if(eq? c_45 'special)(special1.1 'special) c_45)))))" +"(if(digit?$1 c_68 base_15)" +"(let-values()" +"(begin" +"(consume-char in_6 c_68)" +"(if accum-str_0(let-values()(accum-string-add! accum-str_0 c_68))(void))" +"((letrec-values(((loop_110)" +"(lambda(v_200 max-count_1)" +"(begin" +" 'loop" +"(if(zero? max-count_1)" +"(let-values() v_200)" +"(let-values()" +"(let-values(((c_76)" +"(let-values(((in_25) in_6)" +"((skip-count_7) 0)" +"((source_16)" +"(read-config-source config_16)))" +"(let-values(((c_53)" +"(peek-char-or-special" +" in_25" +" skip-count_7" +" 'special" +" source_16)))" +"(if(eq? c_53 'special)" +"(special1.1 'special)" +" c_53)))))" +"(if(digit?$1 c_76 base_15)" +"(let-values()" +"(begin" +"(consume-char in_6 c_76)" +"(if accum-str_0" +"(let-values()(accum-string-add! accum-str_0 c_76))" +"(void))" +"(loop_110" +"(+(digit->number c_76)(* v_200 base_15))" +"(sub1 max-count_1))))" +"(let-values() v_200)))))))))" +" loop_110)" +"(+(digit->number c_68)(* init-v_0 base_15))" +"(sub1 max-count_0))))" +"(if zero-digits-result_0" +"(let-values() zero-digits-result_0)" +"(let-values() c_68)))))))))))))))" +"(define-values" +"(digit?$1)" +"(lambda(c_42 base_21)" +"(begin" +" 'digit?" +"(if(not(char? c_42))" +"(let-values() #f)" +"(if(= base_21 8)" +"(let-values()(octal-digit? c_42))" +"(if(= base_21 16)(let-values()(hex-digit? c_42))(let-values()(decimal-digit? c_42))))))))" +"(define-values(decimal-digit?)(lambda(c_59)(begin(if(char>=? c_59 '#\\0)(char<=? c_59 '#\\9) #f))))" +"(define-values(octal-digit?)(lambda(c_43)(begin(if(char>=? c_43 '#\\0)(char<=? c_43 '#\\7) #f))))" +"(define-values" +"(hex-digit?)" +"(lambda(c_77)" +"(begin" +"(let-values(((or-part_266)(if(char>=? c_77 '#\\0)(char<=? c_77 '#\\9) #f)))" +"(if or-part_266" +" or-part_266" +"(let-values(((or-part_312)(if(char>=? c_77 '#\\A)(char<=? c_77 '#\\F) #f)))" +"(if or-part_312 or-part_312(if(char>=? c_77 '#\\a)(char<=? c_77 '#\\f) #f))))))))" +"(define-values" +"(digit->number)" +"(lambda(c_78)" +"(begin" +"(if(if(char>=? c_78 '#\\0)(char<=? c_78 '#\\9) #f)" +"(let-values()(-(char->integer c_78)(char->integer '#\\0)))" +"(if(if(char>=? c_78 '#\\A)(char<=? c_78 '#\\F) #f)" +"(let-values()(-(char->integer c_78)(-(char->integer '#\\A) 10)))" +"(let-values()(-(char->integer c_78)(-(char->integer '#\\a) 10))))))))" +"(define-values(string->number$1) string->number)" +"(define-values" +"(1/string->number)" +"(let-values(((string->number5_0)" +"(lambda(s4_0 radix1_0 convert-mode2_0 decimal-mode3_0)" +"(begin" +" 'string->number5" +"(let-values(((s_87) s4_0))" +"(let-values(((radix_0) radix1_0))" +"(let-values(((convert-mode_0) convert-mode2_0))" +"(let-values(((decimal-mode_0)" +"(if(eq? decimal-mode3_0 unsafe-undefined)" +"(if(1/read-decimal-as-inexact) 'decimal-as-inexact 'decimal-as-exact)" +" decimal-mode3_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(string? s_87)" +"(void)" +" (let-values () (raise-argument-error 'string->number \"string?\" s_87)))" +"(if((lambda(p_73)(if(exact-integer? radix_0)(<= 2 radix_0 16) #f)) radix_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'string->number \"(integer-in 2 16)\" radix_0)))" +"(if((lambda(p_6)" +"(let-values(((or-part_53)(eq? p_6 'number-or-false)))" +"(if or-part_53 or-part_53(eq? p_6 'read))))" +" convert-mode_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'string->number" +" \"(or/c 'number-or-false 'read)\"" +" convert-mode_0)))" +"(if((lambda(p_65)" +"(let-values(((or-part_7)(eq? p_65 'decimal-as-inexact)))" +"(if or-part_7 or-part_7(eq? p_65 'decimal-as-exact))))" +" decimal-mode_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'string->number" +" \"(or/c 'decimal-as-inexact decimal-as-exact)\"" +" decimal-mode_0)))" +"(let-values(((s66_1) s_87)" +"((temp67_3) 0)" +"((temp68_3)(string-length s_87))" +"((radix69_0) radix_0)" +"((temp70_1) #f)" +"((decimal-mode71_0) decimal-mode_0)" +"((convert-mode72_0) convert-mode_0))" +"(do-string->number17.1" +" #f" +" temp70_1" +" s66_1" +" temp67_3" +" temp68_3" +" radix69_0" +" decimal-mode71_0" +" convert-mode72_0))))))))))))))" +"(case-lambda" +"((s_308)(begin 'string->number(string->number5_0 s_308 10 'number-or-false unsafe-undefined)))" +"((s_487 radix_1 convert-mode_1 decimal-mode3_1)(string->number5_0 s_487 radix_1 convert-mode_1 decimal-mode3_1))" +"((s_186 radix_2 convert-mode2_1)(string->number5_0 s_186 radix_2 convert-mode2_1 unsafe-undefined))" +"((s_488 radix1_1)(string->number5_0 s_488 radix1_1 'number-or-false unsafe-undefined)))))" +"(define-values" +"(do-string->number17.1)" +"(lambda(in-complex8_0 radix-set?7_0 s11_1 start12_0 end13_0 radix14_0 exactness15_0 convert-mode16_0)" +"(begin" +" 'do-string->number17" +"(let-values(((s_17) s11_1))" +"(let-values(((start_43) start12_0))" +"(let-values(((end_33) end13_0))" +"(let-values(((radix_3) radix14_0))" +"(let-values(((radix-set?_0) radix-set?7_0))" +"(let-values(((exactness_0) exactness15_0))" +"(let-values(((in-complex_0) in-complex8_0))" +"(let-values(((convert-mode_2) convert-mode16_0))" +"(let-values()" +"(if(= start_43 end_33)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no digits\"))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((c_64)(string-ref s_17 start_43)))" +"(if(char=? '#\\# c_64)" +"(let-values()" +"(let-values(((next_4)(add1 start_43)))" +"(if(= next_4 end_33)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no character after `#` indicator in `~.a`\" s_17))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((i_169)(string-ref s_17 next_4)))" +"(let-values(((tmp_38) i_169))" +"(let-values(((index_2)" +"(if(char? tmp_38)" +"(let-values(((codepoint_0)(char->integer tmp_38)))" +"(if(if(unsafe-fx>= codepoint_0 66)" +"(unsafe-fx< codepoint_0 121)" +" #f)" +"(let-values(((tbl_0)" +" '#(2" +" 0" +" 2" +" 1" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 2" +" 1" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2)))" +"(unsafe-vector*-ref" +" tbl_0" +"(unsafe-fx- codepoint_0 66)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_2 1)" +"(let-values()" +"(if(eq?(read-complains convert-mode_2) 'must-read)" +"(let-values()" +"(format" +" \"bad `#` indicator `~a` at `~.a`\"" +" i_169" +"(substring s_17 start_43 end_33)))" +"(let-values() #f)))" +"(if(unsafe-fx< index_2 2)" +"(let-values()" +"(if(let-values(((or-part_265)(exactness-set? exactness_0)))" +"(if or-part_265 or-part_265 in-complex_0))" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +"(let-values()" +"(format" +" \"misplaced exactness specification at `~.a`\"" +"(substring s_17 start_43 end_33)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((s73_1) s_17)" +"((temp74_1)(add1 next_4))" +"((end75_0) end_33)" +"((radix76_0) radix_3)" +"((radix-set?77_0) radix-set?_0)" +"((temp78_2)" +"(if(let-values(((or-part_211)" +"(char=? i_169 '#\\e)))" +"(if or-part_211" +" or-part_211" +"(char=? i_169 '#\\E)))" +" 'exact" +" 'inexact))" +"((temp79_1)" +"(if(eq? convert-mode_2 'read)" +" 'must-read" +" convert-mode_2)))" +"(do-string->number17.1" +" #f" +" radix-set?77_0" +" s73_1" +" temp74_1" +" end75_0" +" radix76_0" +" temp78_2" +" temp79_1)))))" +"(let-values()" +"(if(let-values(((or-part_212) radix-set?_0))" +"(if or-part_212 or-part_212 in-complex_0))" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +"(let-values()" +"(format" +" \"misplaced radix specification at `~.a`\"" +"(substring s_17 start_43 end_33)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((radix_4)" +"(let-values(((tmp_39) i_169))" +"(if(if(equal? tmp_39 '#\\b)" +" #t" +"(equal? tmp_39 '#\\B))" +"(let-values() 2)" +"(if(if(equal? tmp_39 '#\\o)" +" #t" +"(equal? tmp_39 '#\\O))" +"(let-values() 8)" +"(if(if(equal? tmp_39 '#\\d)" +" #t" +"(equal? tmp_39 '#\\D))" +"(let-values() 10)" +"(let-values() 16)))))))" +"(let-values(((s80_0) s_17)" +"((temp81_0)(add1 next_4))" +"((end82_0) end_33)" +"((radix83_0) radix_4)" +"((temp84_1) #t)" +"((exactness85_0) exactness_0)" +"((temp86_2)" +"(if(eq? convert-mode_2 'read)" +" 'must-read" +" convert-mode_2)))" +"(do-string->number17.1" +" #f" +" temp84_1" +" s80_0" +" temp81_0" +" end82_0" +" radix83_0" +" exactness85_0" +" temp86_2)))))))))))))))" +"(let-values(((c1_29)" +"(if(char-sign? c_64)" +"(read-special-number s_17 start_43 end_33 convert-mode_2)" +" #f)))" +"(if c1_29" +"((lambda(v_237)" +"(if(eq? exactness_0 'exact)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no exact representation for `~a`\" v_237))" +"(let-values() #f)))" +"(let-values() v_237)))" +" c1_29)" +"(let-values(((c2_3)" +"(if(char-sign? c_64)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_43) 7)" +"(if(char=? '#\\i(string-ref s_17(sub1 end_33)))" +"(if(char-sign?(string-ref s_17 6))" +"(read-special-number" +" s_17" +" start_43" +"(+ start_43 6)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c2_3" +"((lambda(v_39)" +"(let-values(((s87_0) s_17)" +"((temp88_1)(+ start_43 6))" +"((temp89_2)(sub1 end_33))" +"((radix90_0) radix_3)" +"((exactness91_0) exactness_0)" +"((convert-mode92_0) convert-mode_2)" +"((temp93_1) 'i)" +"((v94_0) v_39)" +"((temp95_0)" +"(lambda(v_238 v2_0)" +"(begin 'temp95(make-rectangular v_238 v2_0)))))" +"(read-for-special-compound62.1" +" temp93_1" +" #f" +" s87_0" +" temp88_1" +" temp89_2" +" radix90_0" +" exactness91_0" +" convert-mode92_0" +" v94_0" +" temp95_0)))" +" c2_3)" +"(let-values(((c3_3)" +"(if(not in-complex_0)" +"(if(>=(- end_33 start_43) 7)" +"(if(char=? '#\\i(string-ref s_17(sub1 end_33)))" +"(if(char-sign?(string-ref s_17(- end_33 7)))" +"(read-special-number" +" s_17" +"(- end_33 7)" +"(sub1 end_33)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c3_3" +"((lambda(v2_1)" +"(if(if(= start_43(- end_33 7))(not(extflonum? v2_1)) #f)" +"(let-values()(make-rectangular 0 v2_1))" +"(let-values()" +"(let-values(((s96_0) s_17)" +"((start97_0) start_43)" +"((temp98_2)(- end_33 7))" +"((radix99_0) radix_3)" +"((exactness100_0) exactness_0)" +"((convert-mode101_0) convert-mode_2)" +"((temp102_0) 'i)" +"((temp103_0) #t)" +"((v2104_0) v2_1)" +"((temp105_1)" +"(lambda(v2_2 v_215)" +"(begin 'temp105(make-rectangular v_215 v2_2)))))" +"(read-for-special-compound62.1" +" temp102_0" +" temp103_0" +" s96_0" +" start97_0" +" temp98_2" +" radix99_0" +" exactness100_0" +" convert-mode101_0" +" v2104_0" +" temp105_1)))))" +" c3_3)" +"(let-values(((c4_0)" +"(if(char-sign? c_64)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_43) 7)" +"(if(char=? '#\\@(string-ref s_17(+ start_43 6)))" +"(read-special-number" +" s_17" +" start_43" +"(+ start_43 6)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c4_0" +"((lambda(v_217)" +"(let-values(((s106_0) s_17)" +"((temp107_2)(+ start_43 7))" +"((end108_0) end_33)" +"((radix109_0) radix_3)" +"((exactness110_0) exactness_0)" +"((convert-mode111_0) convert-mode_2)" +"((temp112_1) '@)" +"((v113_0) v_217)" +"((temp114_3)" +"(lambda(v_142 v2_3)" +"(begin 'temp114(make-polar v_142 v2_3)))))" +"(read-for-special-compound62.1" +" temp112_1" +" #f" +" s106_0" +" temp107_2" +" end108_0" +" radix109_0" +" exactness110_0" +" convert-mode111_0" +" v113_0" +" temp114_3)))" +" c4_0)" +"(let-values(((c5_0)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_43) 7)" +"(if(char=? '#\\@(string-ref s_17(- end_33 7)))" +"(read-special-number" +" s_17" +"(- end_33 6)" +" end_33" +" convert-mode_2)" +" #f)" +" #f)" +" #f)))" +"(if c5_0" +"((lambda(v2_4)" +"(let-values(((s115_0) s_17)" +"((start116_0) start_43)" +"((temp117_1)(- end_33 7))" +"((radix118_0) radix_3)" +"((exactness119_0) exactness_0)" +"((convert-mode120_0) convert-mode_2)" +"((temp121_0) '@)" +"((temp122_0) #t)" +"((v2123_0) v2_4)" +"((temp124_2)" +"(lambda(v2_5 v_83)" +"(begin 'temp124(make-polar v_83 v2_5)))))" +"(read-for-special-compound62.1" +" temp121_0" +" temp122_0" +" s115_0" +" start116_0" +" temp117_1" +" radix118_0" +" exactness119_0" +" convert-mode120_0" +" v2123_0" +" temp124_2)))" +" c5_0)" +"(let-values()" +"(let-values(((s125_0) s_17)" +"((start126_0) start_43)" +"((end127_0) end_33)" +"((radix128_0) radix_3)" +"((radix-set?129_0) radix-set?_0)" +"((exactness130_0) exactness_0)" +"((in-complex131_0) in-complex_0)" +"((convert-mode132_0) convert-mode_2))" +"(do-string->non-special-number30.1" +" in-complex131_0" +" radix-set?129_0" +" s125_0" +" start126_0" +" end127_0" +" radix128_0" +" exactness130_0" +" convert-mode132_0)))))))))))))))))))))))))))))" +"(define-values" +"(do-string->non-special-number30.1)" +"(lambda(in-complex21_0 radix-set?20_0 s24_2 start25_0 end26_0 radix27_0 exactness28_0 convert-mode29_0)" +"(begin" +" 'do-string->non-special-number30" +"(let-values(((s_425) s24_2))" +"(let-values(((start_44) start25_0))" +"(let-values(((end_34) end26_0))" +"(let-values(((radix_5) radix27_0))" +"(let-values(((radix-set?_1) radix-set?20_0))" +"(let-values(((exactness_1) exactness28_0))" +"(let-values(((in-complex_1) in-complex21_0))" +"(let-values(((convert-mode_3) convert-mode29_0))" +"(let-values()" +"((letrec-values(((loop_111)" +"(lambda(i_170" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0)" +"(begin" +" 'loop" +"(if(= i_170 end_34)" +"(let-values()" +"(if(if(not any-digits?_0)(not i-pos_3) #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"no digits in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(if must-i?_0(not i-pos_3) #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(if sign-pos_0" +"(let-values(((or-part_313)" +"(if dot-pos_1(< dot-pos_1 sign-pos_0) #f)))" +"(if or-part_313" +" or-part_313" +"(if slash-pos_0(< slash-pos_0 sign-pos_0) #f)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced sign in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if i-pos_3" +"(let-values()" +"(let-values(((s133_0) s_425)" +"((start134_0) start_44)" +"((sign-pos135_0) sign-pos_0)" +"((sign-pos136_0) sign-pos_0)" +"((temp137_2)(sub1 end_34))" +"((i-pos138_0) i-pos_3)" +"((sign-pos139_0) sign-pos_0)" +"((radix140_0) radix_5)" +"((radix-set?141_0) radix-set?_1)" +"((exactness142_0) exactness_1)" +"((temp143_2) 'i)" +"((convert-mode144_0) convert-mode_3))" +"(string->complex-number47.1" +" temp143_2" +" radix-set?141_0" +" s133_0" +" start134_0" +" sign-pos135_0" +" sign-pos136_0" +" temp137_2" +" i-pos138_0" +" sign-pos139_0" +" radix140_0" +" exactness142_0" +" convert-mode144_0)))" +"(if @-pos_0" +"(let-values()" +"(let-values(((s145_0) s_425)" +"((start146_0) start_44)" +"((@-pos147_0) @-pos_0)" +"((temp148_1)(add1 @-pos_0))" +"((end149_0) end_34)" +"((i-pos150_0) i-pos_3)" +"((sign-pos151_0) sign-pos_0)" +"((radix152_0) radix_5)" +"((radix-set?153_0) radix-set?_1)" +"((exactness154_0) exactness_1)" +"((temp155_1) '@)" +"((convert-mode156_0) convert-mode_3))" +"(string->complex-number47.1" +" temp155_1" +" radix-set?153_0" +" s145_0" +" start146_0" +" @-pos147_0" +" temp148_1" +" end149_0" +" i-pos150_0" +" sign-pos151_0" +" radix152_0" +" exactness154_0" +" convert-mode156_0)))" +"(let-values()" +"(string->real-number" +" s_425" +" start_44" +" end_34" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" any-hashes?_0" +" radix_5" +" exactness_1" +" convert-mode_3))))))))" +"(let-values()" +"(let-values(((c_79)(string-ref s_425 i_170)))" +"(if(digit? c_79 radix_5)" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" #t" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0))" +"(if(char=? c_79 '#\\#)" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" #t" +" #t" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0))" +"(if(char-sign? c_79)" +"(let-values()" +"(if(if sign-pos_0 must-i?_0 #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" i_170" +" dot-pos_1" +" slash-pos_0" +" #f" +"(if(> i_170 start_44)" +"(let-values(((or-part_314)(not @-pos_0)))" +"(if or-part_314" +" or-part_314" +"(> i_170(add1 @-pos_0))))" +" #f)))))" +"(if(char=? c_79 '#\\.)" +"(let-values()" +"(if(let-values(((or-part_315)" +"(if exp-pos_0" +"(let-values(((or-part_316)" +"(not sign-pos_0)))" +"(if or-part_316" +" or-part_316" +"(> exp-pos_0 sign-pos_0)))" +" #f)))" +"(if or-part_315" +" or-part_315" +"(if dot-pos_1" +"(let-values(((or-part_208)(not sign-pos_0)))" +"(if or-part_208" +" or-part_208" +"(> dot-pos_1 sign-pos_0)))" +" #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `.` in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(if slash-pos_0" +"(let-values(((or-part_317)(not sign-pos_0)))" +"(if or-part_317" +" or-part_317" +"(> slash-pos_0 sign-pos_0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"decimal points and fractions annot be mixed `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" i_170" +" #f" +" #f" +" must-i?_0)))))" +"(if(char=? c_79 '#\\/)" +"(let-values()" +"(if(if dot-pos_1" +"(let-values(((or-part_318)(not sign-pos_0)))" +"(if or-part_318" +" or-part_318" +"(> dot-pos_1 sign-pos_0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"decimal points and fractions annot be mixed `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_319)" +"(if exp-pos_0" +"(let-values(((or-part_320)" +"(not sign-pos_0)))" +"(if or-part_320" +" or-part_320" +"(> exp-pos_0 sign-pos_0)))" +" #f)))" +"(if or-part_319" +" or-part_319" +"(if slash-pos_0" +"(let-values(((or-part_280)" +"(not sign-pos_0)))" +"(if or-part_280" +" or-part_280" +"(> slash-pos_0 sign-pos_0)))" +" #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `/` in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" #f" +" i_170" +" #f" +" must-i?_0)))))" +"(if(let-values(((or-part_321)(char=? c_79 '#\\e)))" +"(if or-part_321" +" or-part_321" +"(let-values(((or-part_322)(char=? c_79 '#\\E)))" +"(if or-part_322" +" or-part_322" +"(let-values(((or-part_323)" +"(char=? c_79 '#\\f)))" +"(if or-part_323" +" or-part_323" +"(let-values(((or-part_324)" +"(char=? c_79 '#\\F)))" +"(if or-part_324" +" or-part_324" +"(let-values(((or-part_325)" +"(char=? c_79 '#\\d)))" +"(if or-part_325" +" or-part_325" +"(let-values(((or-part_181)" +"(char=? c_79 '#\\D)))" +"(if or-part_181" +" or-part_181" +"(let-values(((or-part_326)" +"(char=?" +" c_79" +" '#\\s)))" +"(if or-part_326" +" or-part_326" +"(let-values(((or-part_327)" +"(char=?" +" c_79" +" '#\\S)))" +"(if or-part_327" +" or-part_327" +"(let-values(((or-part_209)" +"(char=?" +" c_79" +" '#\\l)))" +"(if or-part_209" +" or-part_209" +"(let-values(((or-part_328)" +"(char=?" +" c_79" +" '#\\L)))" +"(if or-part_328" +" or-part_328" +"(let-values(((or-part_173)" +"(char=?" +" c_79" +" '#\\t)))" +"(if or-part_173" +" or-part_173" +"(char=?" +" c_79" +" '#\\T)))))))))))))))))))))))" +"(let-values()" +"(if exp-pos_0" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `~a` in `~.a`\"" +" c_79" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(if(<(add1 i_170) end_34)" +"(char-sign?(string-ref s_425(add1 i_170)))" +" #f)" +"(let-values()" +"(loop_111" +"(+ i_170 2)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +"(let-values(((or-part_329) exp-pos_0))" +"(if or-part_329 or-part_329 i_170))" +" must-i?_0))" +"(let-values()" +"(loop_111" +"(+ i_170 1)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +"(let-values(((or-part_330) exp-pos_0))" +"(if or-part_330 or-part_330 i_170))" +" must-i?_0)))))" +"(if(char=? c_79 '#\\@)" +"(let-values()" +"(if(eq? in-complex_1 'i)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"cannot mix `@` and `i` in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_160) @-pos_0))" +"(if or-part_160" +" or-part_160" +"(eq? in-complex_1 '@)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many `@`s in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(= i_170 start_44)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"`@` cannot be at start in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if must-i?_0" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" i_170" +" #f" +" #f" +" #f" +" #f" +" must-i?_0)))))))" +"(if(if(let-values(((or-part_331)" +"(char=? c_79 '#\\i)))" +"(if or-part_331" +" or-part_331" +"(char=? c_79 '#\\I)))" +" sign-pos_0" +" #f)" +"(let-values()" +"(if(let-values(((or-part_332) @-pos_0))" +"(if or-part_332" +" or-part_332" +"(eq? in-complex_1 '@)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"cannot mix `@` and `i` in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_333)" +"(<(add1 i_170) end_34)))" +"(if or-part_333" +" or-part_333" +"(eq? in-complex_1 'i)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"`i` must be at the end in `~.a`\"" +"(substring s_425 start_44 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_111" +"(add1 i_170)" +" any-digits?_0" +" any-hashes?_0" +" i_170" +" @-pos_0" +" sign-pos_0" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values()" +"(if(char=? c_79 '#\\nul)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +" (format \"nul character in `~.a`\" s_425))" +"(let-values() #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +" (format \"bad digit `~a`\" c_79))" +"(let-values() #f))))))))))))))))))))" +" loop_111)" +" start_44" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f)))))))))))))" +"(define-values" +"(string->complex-number47.1)" +"(lambda(in-complex34_0" +" radix-set?33_0" +" s37_1" +" start138_0" +" end139_0" +" start240_0" +" end241_0" +" i-pos42_0" +" sign-pos43_0" +" radix44_0" +" exactness45_0" +" convert-mode46_0)" +"(begin" +" 'string->complex-number47" +"(let-values(((s_117) s37_1))" +"(let-values(((start1_0) start138_0))" +"(let-values(((end1_0) end139_0))" +"(let-values(((start2_0) start240_0))" +"(let-values(((end2_0) end241_0))" +"(let-values()" +"(let-values()" +"(let-values(((radix_6) radix44_0))" +"(let-values(((radix-set?_2) radix-set?33_0))" +"(let-values(((exactness_2) exactness45_0))" +"(let-values(((in-complex_2) in-complex34_0))" +"(let-values(((convert-mode_4) convert-mode46_0))" +"(let-values()" +"(let-values(((v1_0)" +"(if(= start1_0 end1_0)" +"(let-values()(if(eq? exactness_2 'inexact) 0.0 0))" +"(let-values()" +"(let-values(((s157_0) s_117)" +"((start1158_0) start1_0)" +"((end1159_0) end1_0)" +"((radix160_0) radix_6)" +"((radix-set?161_0) radix-set?_2)" +"((exactness162_0) exactness_2)" +"((in-complex163_0) in-complex_2)" +"((convert-mode164_0) convert-mode_4))" +"(do-string->number17.1" +" in-complex163_0" +" radix-set?161_0" +" s157_0" +" start1158_0" +" end1159_0" +" radix160_0" +" exactness162_0" +" convert-mode164_0))))))" +"(let-values(((v2_6)" +"(if(if(eq? in-complex_2 'i)(=(- end2_0 start2_0) 1) #f)" +"(let-values()" +"(let-values(((neg?_0)(char=?(string-ref s_117 start2_0) '#\\-)))" +"(if(eq? exactness_2 'inexact)" +"(let-values()(if neg?_0 -1.0 1.0))" +"(let-values()(if neg?_0 -1 1)))))" +"(let-values()" +"(let-values(((s165_0) s_117)" +"((start2166_0) start2_0)" +"((end2167_0) end2_0)" +"((radix168_0) radix_6)" +"((radix-set?169_0) radix-set?_2)" +"((exactness170_0) exactness_2)" +"((in-complex171_0) in-complex_2)" +"((convert-mode172_0) convert-mode_4))" +"(do-string->number17.1" +" in-complex171_0" +" radix-set?169_0" +" s165_0" +" start2166_0" +" end2167_0" +" radix168_0" +" exactness170_0" +" convert-mode172_0))))))" +"(if(let-values(((or-part_334)(not v1_0)))" +"(if or-part_334 or-part_334(not v2_6)))" +"(let-values() #f)" +"(if(if(let-values(((or-part_335)(extflonum? v1_0)))" +"(if or-part_335 or-part_335(extflonum? v2_6)))" +"(not(eq? convert-mode_4 'must-read))" +" #f)" +"(let-values()(fail-extflonum convert-mode_4 v1_0))" +"(if(string? v1_0)" +"(let-values() v1_0)" +"(if(extflonum? v1_0)" +"(let-values()(fail-extflonum convert-mode_4 v1_0))" +"(if(string? v2_6)" +"(let-values() v2_6)" +"(if(extflonum? v2_6)" +"(let-values()(fail-extflonum convert-mode_4 v2_6))" +"(if(eq? in-complex_2 'i)" +"(let-values()(make-rectangular v1_0 v2_6))" +"(let-values()" +"(let-values(((p_74)(make-polar v1_0 v2_6)))" +"(if(eq? exactness_2 'exact)" +"(inexact->exact p_74)" +" p_74))))))))))))))))))))))))))))" +"(define-values" +"(string->real-number)" +"(lambda(s_333 start_45 end_35 dot-pos_2 slash-pos_1 exp-pos_1 any-hashes?_1 radix_7 exactness_3 convert-mode_5)" +"(begin" +"(let-values(((extfl-mark?_0)" +"(lambda()(begin 'extfl-mark?(char=?(char-downcase(string-ref s_333 exp-pos_1)) '#\\t)))))" +"(let-values(((simple?_0)" +"(if(not slash-pos_1)" +"(if(let-values(((or-part_336)(eq? exactness_3 'inexact)))" +"(if or-part_336" +" or-part_336" +"(let-values(((or-part_337)(eq? exactness_3 'decimal-as-inexact)))" +"(if or-part_337 or-part_337(if(not dot-pos_2)(not exp-pos_1) #f)))))" +"(if(let-values(((or-part_338)(not exp-pos_1)))" +"(if or-part_338" +" or-part_338" +"(let-values(((or-part_223)(not(eq? convert-mode_5 'number-or-false))))" +"(if or-part_223 or-part_223(not(extfl-mark?_0))))))" +"(not(if any-hashes?_1(hashes? s_333 start_45 end_35) #f))" +" #f)" +" #f)" +" #f)))" +"(let-values(((has-sign?_0)(if(> end_35 start_45)(char-sign?(string-ref s_333 start_45)) #f)))" +"(if(=(- end_35 start_45)(+(if dot-pos_2 1 0)(if exp-pos_1 1 0)(if has-sign?_0 1 0)))" +"(let-values()" +"(if(= end_35 start_45)" +" (if (eq? convert-mode_5 'must-read) (let-values () (format \"missing digits\")) (let-values () #f))" +"(if(eq? convert-mode_5 'must-read)" +" (let-values () (format \"missing digits in `~.a`\" (substring s_333 start_45 end_35)))" +"(let-values() #f))))" +"(if simple?_0" +"(let-values()" +"(if(if exp-pos_1" +"(=" +"(- exp-pos_1 start_45)" +"(+(if(if dot-pos_2(< dot-pos_2 exp-pos_1) #f) 1 0)(if has-sign?_0 1 0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +" (format \"missing digits before exponent marker in `~.a`\" (substring s_333 start_45 end_35)))" +"(let-values() #f)))" +"(if(if exp-pos_1" +"(let-values(((or-part_339)(= exp-pos_1(sub1 end_35))))" +"(if or-part_339" +" or-part_339" +"(if(= exp-pos_1(- end_35 2))(char-sign?(string-ref s_333(sub1 end_35))) #f)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +" (format \"missing digits after exponent marker in `~.a`\" (substring s_333 start_45 end_35)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_31)" +"(string->number$1" +"(maybe-substring s_333 start_45 end_35)" +" radix_7" +"(if(let-values(((or-part_340)(eq? convert-mode_5 'number-or-false)))" +"(if or-part_340" +" or-part_340" +"(let-values(((or-part_147)(not exp-pos_1)))" +"(if or-part_147 or-part_147(not(extfl-mark?_0))))))" +" 'number-or-false" +" 'read))))" +"(if(let-values(((or-part_148)(not n_31)))(if or-part_148 or-part_148(string? n_31)))" +"(let-values()" +"(error" +" 'string->number" +" \"host `string->number` failed on ~s\"" +"(substring s_333 start_45 end_35)))" +"(if(eq? exactness_3 'inexact)" +"(let-values()" +"(if(extflonum? n_31)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +"(format" +" \"cannot convert extflonum `~.a` to inexact\"" +"(substring s_333 start_45 end_35)))" +"(let-values() #f)))" +"(if(if(eqv? n_31 0)(char=?(string-ref s_333 start_45) '#\\-) #f)" +"(let-values() -0.0)" +"(let-values()(exact->inexact n_31)))))" +"(let-values() n_31))))))))" +"(if exp-pos_1" +"(let-values()" +"(let-values(((m-v_0)" +"(string->real-number" +" s_333" +" start_45" +" exp-pos_1" +" dot-pos_2" +" slash-pos_1" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((e-v_0)" +"(string->exact-integer-number s_333(+ exp-pos_1 1) end_35 radix_7 convert-mode_5)))" +"(let-values(((real->precision-inexact_0)" +"(lambda(r_46)" +"(begin" +" 'real->precision-inexact" +"(let-values(((tmp_40)(string-ref s_333 exp-pos_1)))" +"(if(if(equal? tmp_40 '#\\s)" +" #t" +"(if(equal? tmp_40 '#\\S)" +" #t" +"(if(equal? tmp_40 '#\\f) #t(equal? tmp_40 '#\\F))))" +"(let-values()(real->single-flonum r_46))" +"(if(if(equal? tmp_40 '#\\t) #t(equal? tmp_40 '#\\T))" +"(let-values()" +"(if(extflonum-available?)" +"(real->extfl r_46)" +"(string->number$1" +"(replace-hashes s_333 start_45 end_35)" +" radix_7" +" 'read)))" +"(let-values()(real->double-flonum r_46)))))))))" +"(let-values(((get-extfl?_0)(extfl-mark?_0)))" +"(if(let-values(((or-part_341)(not m-v_0)))(if or-part_341 or-part_341(not e-v_0)))" +"(let-values() #f)" +"(if(string? m-v_0)" +"(let-values() m-v_0)" +"(if(string? e-v_0)" +"(let-values() e-v_0)" +"(if(if(eq? convert-mode_5 'number-or-false) get-extfl?_0 #f)" +"(let-values() #f)" +"(if(if(let-values(((or-part_342)(eq? exactness_3 'inexact)))" +"(if or-part_342 or-part_342(eq? exactness_3 'decimal-as-inexact)))" +"(>(abs e-v_0)(if get-extfl?_0 6000 400))" +" #f)" +"(let-values()" +"(real->precision-inexact_0" +"(if(eqv? m-v_0 0)" +"(let-values()(if(char=?(string-ref s_333 start_45) '#\\-) -0.0 0.0))" +"(if(positive? m-v_0)" +"(let-values()(if(positive? e-v_0) +inf.0 0.0))" +"(let-values()(if(positive? e-v_0) -inf.0 -0.0))))))" +"(if(if(exactness-set? exactness_3) get-extfl?_0 #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +"(format" +" \"cannot convert extflonum `~.a` to ~a\"" +"(substring s_333 start_45 end_35)" +" exactness_3))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_32)(* m-v_0(expt radix_7 e-v_0))))" +"(if(if(not get-extfl?_0)" +"(let-values(((or-part_343)(eq? exactness_3 'exact)))" +"(if or-part_343 or-part_343(eq? exactness_3 'decimal-as-exact)))" +" #f)" +"(let-values() n_32)" +"(if(if(eqv? n_32 0)(char=?(string-ref s_333 start_45) '#\\-) #f)" +"(let-values()(real->precision-inexact_0 -0.0))" +"(let-values()(real->precision-inexact_0 n_32)))))))))))))))))" +"(if slash-pos_1" +"(let-values()" +"(let-values(((n-v_0)" +"(string->real-number" +" s_333" +" start_45" +" slash-pos_1" +" #f" +" #f" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((d-v_0)" +"(string->real-number" +" s_333" +"(add1 slash-pos_1)" +" end_35" +" #f" +" #f" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((get-inexact?_0)" +"(lambda(from-pos_0)" +"(begin" +" 'get-inexact?" +"(let-values(((or-part_344)(eq? exactness_3 'inexact)))" +"(if or-part_344" +" or-part_344" +"(if(not(eq? exactness_3 'exact))" +"(hashes? s_333 from-pos_0 end_35)" +" #f)))))))" +"(if(let-values(((or-part_345)(not n-v_0)))(if or-part_345 or-part_345(not d-v_0)))" +"(let-values() #f)" +"(if(string? n-v_0)" +"(let-values() n-v_0)" +"(if(string? d-v_0)" +"(let-values() d-v_0)" +"(if(eqv? d-v_0 0)" +"(let-values()" +"(if(get-inexact?_0(add1 slash-pos_1))" +"(let-values()(if(negative? n-v_0) -inf.0 +inf.0))" +"(let-values()" +"(if(eq?(read-complains convert-mode_5) 'must-read)" +"(let-values()" +" (format \"division by zero in `~.a`\" (substring s_333 start_45 end_35)))" +"(let-values() #f)))))" +"(let-values()" +"(let-values(((n_33)(/ n-v_0 d-v_0)))" +"(if(get-inexact?_0 start_45)(exact->inexact n_33) n_33)))))))))))" +"(let-values()" +"(string->decimal-number" +" s_333" +" start_45" +" end_35" +" dot-pos_2" +" radix_7" +" exactness_3" +" convert-mode_5))))))))))))" +"(define-values" +"(string->decimal-number)" +"(lambda(s_489 start_46 end_36 dot-pos_3 radix_8 exactness_4 convert-mode_6)" +"(begin" +"(let-values(((get-exact?_0)" +"(let-values(((or-part_187)(eq? exactness_4 'exact)))" +"(if or-part_187 or-part_187(eq? exactness_4 'decimal-as-exact)))))" +"(let-values(((new-str_0)(make-string(- end_36 start_46(if(if dot-pos_3 get-exact?_0 #f) 1 0)))))" +"((letrec-values(((loop_112)" +"(lambda(i_171 j_3 hashes-pos_0)" +"(begin" +" 'loop" +"(if(< i_171 start_46)" +"(let-values()" +"(if(= hashes-pos_0 start_46)" +"(let-values()" +"(if(eq? convert-mode_6 'must-read)" +"(let-values()" +" (format \"misplaced `#` in `~.a`\" (substring s_489 start_46 end_36)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_34)(string->number$1 new-str_0 radix_8)))" +"(if(not n_34)" +"(let-values()(fail-bad-number convert-mode_6 s_489 start_46 end_36))" +"(if(not get-exact?_0)" +"(let-values()" +"(if(if(eqv? n_34 0)(char=?(string-ref s_489 start_46) '#\\-) #f)" +" -0.0" +"(exact->inexact n_34)))" +"(if(if dot-pos_3 get-exact?_0 #f)" +"(let-values()(/ n_34(expt 10(- end_36 dot-pos_3 1))))" +"(let-values() n_34))))))))" +"(let-values()" +"(let-values(((c_80)(string-ref s_489 i_171)))" +"(if(char=? c_80 '#\\.)" +"(let-values()" +"(if get-exact?_0" +"(let-values()" +"(loop_112" +"(sub1 i_171)" +" j_3" +"(if(= hashes-pos_0(add1 i_171)) i_171 hashes-pos_0)))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_80)" +"(loop_112" +"(sub1 i_171)" +"(sub1 j_3)" +"(if(= hashes-pos_0(add1 i_171)) i_171 hashes-pos_0))))))" +"(if(let-values(((or-part_346)(char=? c_80 '#\\-)))" +"(if or-part_346 or-part_346(char=? c_80 '#\\+)))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_80)" +"(loop_112" +"(sub1 i_171)" +"(sub1 j_3)" +"(if(= hashes-pos_0(add1 i_171)) i_171 hashes-pos_0))))" +"(if(char=? c_80 '#\\#)" +"(let-values()" +"(if(= hashes-pos_0(add1 i_171))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 '#\\0)" +"(loop_112(sub1 i_171)(sub1 j_3) i_171)))" +"(let-values()" +"(if(eq? convert-mode_6 'must-read)" +"(let-values()" +"(format" +" \"misplaced `#` in `~.a`\"" +"(substring s_489 start_46 end_36)))" +"(let-values() #f)))))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_80)" +"(loop_112(sub1 i_171)(sub1 j_3) hashes-pos_0)))))))))))))" +" loop_112)" +"(sub1 end_36)" +"(sub1(string-length new-str_0))" +" end_36))))))" +"(define-values" +"(string->exact-integer-number)" +"(lambda(s_490 start_47 end_37 radix_9 convert-mode_7)" +"(begin" +"(if(hashes? s_490 start_47 end_37)" +"(let-values()" +"(if(eq? convert-mode_7 'must-read)" +" (let-values () (format \"misplaced `#` in `~.a`\" (substring s_490 start_47 end_37)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_35)(string->number$1(maybe-substring s_490 start_47 end_37) radix_9)))" +"(if(not n_35)" +"(let-values()" +"(if(eq? convert-mode_7 'must-read)" +" (let-values () (format \"bad exponent `~.a`\" (substring s_490 start_47 end_37)))" +"(let-values() #f)))" +"(let-values() n_35))))))))" +"(define-values" +"(read-special-number)" +"(lambda(s_472 start_48 end_38 convert-mode_8)" +"(begin" +"(if(=(- end_38 start_48) 6)" +"(if(let-values(((or-part_347)(char=?(string-ref s_472 start_48) '#\\+)))" +"(if or-part_347 or-part_347(char=?(string-ref s_472 start_48) '#\\-)))" +"(let-values(((or-part_348)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 1))) '#\\i)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 2))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 3))) '#\\f)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 4))) '#\\.)" +"(let-values(((or-part_349)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\0)" +"(if(char=?(string-ref s_472 start_48) '#\\+) +inf.0 -inf.0)" +" #f)))" +"(if or-part_349" +" or-part_349" +"(let-values(((or-part_350)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\f)" +"(if(char=?(string-ref s_472 start_48) '#\\+) +inf.f -inf.f)" +" #f)))" +"(if or-part_350" +" or-part_350" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\t)" +"(if(not(eq? convert-mode_8 'number-or-false))" +"(if(char=?(string-ref s_472 start_48) '#\\+) '+inf.t '-inf.t)" +" #f)" +" #f)))))" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if or-part_348" +" or-part_348" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 1))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 2))) '#\\a)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 3))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 4))) '#\\.)" +"(let-values(((or-part_351)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\0) +nan.0 #f)))" +"(if or-part_351" +" or-part_351" +"(let-values(((or-part_352)" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\f) +nan.f #f)))" +"(if or-part_352" +" or-part_352" +"(if(char=?(char-downcase(string-ref s_472(+ start_48 5))) '#\\t)" +"(if(not(eq? convert-mode_8 'number-or-false)) '+nan.t #f)" +" #f)))))" +" #f)" +" #f)" +" #f)" +" #f)))" +" #f)" +" #f))))" +"(define-values" +"(fail-extflonum)" +"(lambda(convert-mode_9 v_239)" +"(begin" +"(if(eq? convert-mode_9 'must-read)" +" (let-values () (format \"cannot combine extflonum `~a` into complex number\" v_239))" +"(let-values() #f)))))" +"(define-values" +"(read-for-special-compound62.1)" +"(lambda(in-complex50_0" +" reading-first?51_0" +" s54_0" +" start55_0" +" end56_0" +" radix57_0" +" exactness58_0" +" convert-mode59_0" +" v60_0" +" combine61_0)" +"(begin" +" 'read-for-special-compound62" +"(let-values(((s_491) s54_0))" +"(let-values(((start_49) start55_0))" +"(let-values(((end_39) end56_0))" +"(let-values(((radix_10) radix57_0))" +"(let-values(((exactness_5) exactness58_0))" +"(let-values(((convert-mode_10) convert-mode59_0))" +"(let-values(((in-complex_3) in-complex50_0))" +"(let-values(((reading-first?_0) reading-first?51_0))" +"(let-values(((v_240) v60_0))" +"(let-values(((combine_1) combine61_0))" +"(let-values()" +"(if(eq? exactness_5 'exact)" +"(let-values()" +"(if(eq? convert-mode_10 'must-read)" +" (let-values () (format \"no exact representation for `~a`\" v_240))" +"(let-values() #f)))" +"(if(if(extflonum? v_240)" +"(let-values(((or-part_190)(not reading-first?_0)))" +"(if or-part_190 or-part_190(not(eq? convert-mode_10 'must-read))))" +" #f)" +"(let-values()(fail-extflonum convert-mode_10 v_240))" +"(let-values()" +"(let-values(((v2_7)" +"(let-values(((s173_0) s_491)" +"((start174_0) start_49)" +"((end175_0) end_39)" +"((radix176_0) radix_10)" +"((temp177_1) #t)" +"((exactness178_0) exactness_5)" +"((in-complex179_0) in-complex_3)" +"((convert-mode180_0) convert-mode_10))" +"(do-string->number17.1" +" in-complex179_0" +" temp177_1" +" s173_0" +" start174_0" +" end175_0" +" radix176_0" +" exactness178_0" +" convert-mode180_0))))" +"(if(string? v2_7)" +"(let-values() v2_7)" +"(if(not v2_7)" +"(let-values() v2_7)" +"(if(extflonum? v_240)" +"(let-values()(fail-extflonum convert-mode_10 v_240))" +"(let-values()(combine_1 v_240 v2_7)))))))))))))))))))))))" +"(define-values" +"(hashes?)" +"(lambda(s_263 start_50 end_40)" +"(begin" +"(let-values(((v*_6 start*_5 stop*_6 step*_5)" +"(normalise-inputs" +" 'in-string" +" \"string\"" +"(lambda(x_85)(string? x_85))" +"(lambda(x_86)(unsafe-string-length x_86))" +" s_263" +" start_50" +" end_40" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_272)" +"(lambda(result_121 idx_5)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_5 stop*_6)" +"(let-values(((c_81)(string-ref v*_6 idx_5)))" +"(let-values(((result_122)" +"(let-values()" +"(let-values(((result_123)" +"(let-values()(let-values()(char=? c_81 '#\\#)))))" +"(values result_123)))))" +"(if(if(not((lambda x_87 result_122) c_81))(not #f) #f)" +"(for-loop_272 result_122(unsafe-fx+ idx_5 1))" +" result_122)))" +" result_121)))))" +" for-loop_272)" +" #f" +" start*_5))))))" +"(define-values" +"(replace-hashes)" +"(lambda(s_271 start_51 end_41)" +"(begin" +"(let-values(((new-s_9)(make-string(- end_41 start_51))))" +"(begin" +"(let-values(((v*_7 start*_6 stop*_7 step*_6)" +"(normalise-inputs" +" 'in-string" +" \"string\"" +"(lambda(x_88)(string? x_88))" +"(lambda(x_89)(unsafe-string-length x_89))" +" s_271" +" start_51" +" end_41" +" 1))" +"((start_52) 0))" +"(begin" +" #t" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_52)))" +"((letrec-values(((for-loop_273)" +"(lambda(idx_6 pos_115)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< idx_6 stop*_7) #t #f)" +"(let-values(((c_82)(string-ref v*_7 idx_6))((i_121) pos_115))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(char=? c_82 '#\\#)" +"(string-set! new-s_9 i_121 '#\\0)" +"(string-set! new-s_9 i_121 c_82)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_273(unsafe-fx+ idx_6 1)(+ pos_115 1))(values))))" +"(values))))))" +" for-loop_273)" +" start*_6" +" start_52)))" +"(void)" +" new-s_9)))))" +"(define-values" +"(maybe-substring)" +"(lambda(s_381 start_3 end_3)" +"(begin(if(if(= 0 start_3)(= end_3(string-length s_381)) #f) s_381(substring s_381 start_3 end_3)))))" +"(define-values" +"(exactness-set?)" +"(lambda(exactness_6)" +"(begin" +"(let-values(((or-part_353)(eq? exactness_6 'exact)))(if or-part_353 or-part_353(eq? exactness_6 'inexact))))))" +"(define-values" +"(char-sign?)" +"(lambda(c_83)" +"(begin(let-values(((or-part_354)(char=? c_83 '#\\-)))(if or-part_354 or-part_354(char=? c_83 '#\\+))))))" +"(define-values" +"(digit?)" +"(lambda(c_84 radix_11)" +"(begin" +"(let-values(((v_241)(char->integer c_84)))" +"(let-values(((or-part_355)" +"(if(>= v_241(char->integer '#\\0))(<(- v_241(char->integer '#\\0)) radix_11) #f)))" +"(if or-part_355" +" or-part_355" +"(if(> radix_11 10)" +"(let-values(((or-part_356)" +"(if(>= v_241(char->integer '#\\a))(<(- v_241(-(char->integer '#\\a) 10)) radix_11) #f)))" +"(if or-part_356" +" or-part_356" +"(if(>= v_241(char->integer '#\\A))(<(- v_241(-(char->integer '#\\A) 10)) radix_11) #f)))" +" #f)))))))" +"(define-values" +"(fail-bad-number)" +"(lambda(convert-mode_11 s_137 start_53 end_42)" +"(begin" +"(if(eq? convert-mode_11 'must-read)" +" (let-values () (format \"bad number `~.a`\" (substring s_137 start_53 end_42)))" +"(let-values() #f)))))" +"(define-values" +"(read-complains)" +"(lambda(convert-mode_12)(begin(if(eq? convert-mode_12 'read) 'must-read convert-mode_12))))" +"(define-values" +"(read-symbol-or-number8.1)" +"(lambda(extra-prefix2_0 mode1_0 init-c5_0 in6_1 orig-config7_0)" +"(begin" +" 'read-symbol-or-number8" +"(let-values(((init-c_6) init-c5_0))" +"(let-values(((in_26) in6_1))" +"(let-values(((orig-config_0) orig-config7_0))" +"(let-values(((mode_18) mode1_0))" +"(let-values(((extra-prefix_0) extra-prefix2_0))" +"(let-values()" +"(let-values(((config_37)" +"(if(string? mode_18)(override-parameter 1/read-cdot orig-config_0 #f) orig-config_0)))" +"(let-values(((rt_10)(read-config-readtable config_37)))" +"(let-values(((c1_30)" +"(if rt_10" +"(if(let-values(((or-part_217)(eq? mode_18 'symbol-or-number)))" +"(if or-part_217 or-part_217(eq? mode_18 'symbol/indirect)))" +"(readtable-symbol-parser rt_10)" +" #f)" +" #f)))" +"(if c1_30" +"((lambda(handler_2)" +"(readtable-apply" +" handler_2" +" init-c_6" +" in_26" +" config_37" +"(read-config-line config_37)" +"(read-config-col config_37)" +"(read-config-pos config_37)))" +" c1_30)" +"(let-values()" +"(let-values(((accum-str_1)(accum-string-init! config_37)))" +"(let-values(((quoted-ever?_0) #f))" +"(let-values(((case-sens?_0)(check-parameter read-case-sensitive config_37)))" +"(let-values((()" +"(begin" +"(if extra-prefix_0" +"(let-values()(accum-string-add! accum-str_1 extra-prefix_0))" +"(void))" +"(values))))" +"(let-values(((source_17)(read-config-source config_37)))" +"(let-values(((unexpected-quoted_0)" +"(lambda(c_48 after-c_0)" +"(begin" +" 'unexpected-quoted" +"(let-values(((in11_0) in_26)" +"((config12_1) config_37)" +"((c13_0) c_48)" +" ((temp14_2) \"~a following `~a` in ~a\")" +"((temp15_2)" +"(if(eof-object? c_48)" +" \"end-of-file\"" +" \"non-character\"))" +"((after-c16_0) after-c_0)" +"((temp17_1)" +"(if(eq? mode_18 'keyword)" +" (let-values () \"keyword\")" +"(if(string? mode_18)" +" (let-values () \"number\")" +" (let-values () \"symbol\")))))" +"(reader-error12.1" +" unsafe-undefined" +" c13_0" +" #f" +" unsafe-undefined" +" in11_0" +" config12_1" +" temp14_2" +"(list temp15_2 after-c16_0 temp17_1)))))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_102)" +"(lambda(init-c_7" +" pipe-quote-c_0" +" foldcase-from_0)" +"(begin" +" 'loop" +"(let-values(((c_85)" +"(let-values(((or-part_82)" +" init-c_7))" +"(if or-part_82" +" or-part_82" +"(let-values(((in_27)" +" in_26)" +"((skip-count_8)" +" 0)" +"((source_18)" +" source_17))" +"(let-values(((c_51)" +"(peek-char-or-special" +" in_27" +" skip-count_8" +" 'special" +" source_18)))" +"(if(eq?" +" c_51" +" 'special)" +"(special1.1" +" 'special)" +" c_51)))))))" +"(let-values(((ec_4)" +"(let-values(((rt_11)" +" rt_10)" +"((c_70)" +" c_85))" +"(if(let-values(((or-part_357)" +"(not" +" rt_11)))" +"(if or-part_357" +" or-part_357" +"(not" +"(char? c_70))))" +"(let-values() c_70)" +"(let-values()" +"(*readtable-effective-char" +" rt_11" +" c_70))))))" +"(if(if pipe-quote-c_0" +"(not(char? ec_4))" +" #f)" +"(let-values()" +"(begin" +"(if init-c_7" +"(void)" +"(let-values()" +"(consume-char/special" +" in_26" +" config_37" +" c_85)))" +"(unexpected-quoted_0" +" c_85" +" pipe-quote-c_0)))" +"(if(if(not pipe-quote-c_0)" +"(readtable-char-delimiter?" +" rt_10" +" c_85" +" config_37)" +" #f)" +"(let-values()" +"(if case-sens?_0" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0))))" +"(if(if pipe-quote-c_0" +"(char=? c_85 pipe-quote-c_0)" +" #f)" +"(let-values()" +"(begin" +"(if init-c_7" +"(void)" +"(let-values()" +"(consume-char" +" in_26" +" c_85)))" +"(loop_102" +" #f" +" #f" +"(accum-string-count" +" accum-str_1))))" +"(if(if(char=? ec_4 '#\\|)" +"(check-parameter" +" read-accept-bar-quote" +" config_37)" +" #f)" +"(let-values()" +"(begin" +"(if init-c_7" +"(void)" +"(let-values()" +"(consume-char" +" in_26" +" c_85)))" +"(set! quoted-ever?_0 #t)" +"(if case-sens?_0" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0)))" +"(loop_102" +" #f" +" c_85" +"(accum-string-count" +" accum-str_1))))" +"(if(if(char=? ec_4 '#\\\\)" +"(not pipe-quote-c_0)" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(if init-c_7" +"(void)" +"(let-values()" +"(consume-char" +" in_26" +" c_85)))" +"(values))))" +"(let-values(((next-c_0)" +"(let-values(((in_28)" +" in_26)" +"((source_19)" +" source_17))" +"(read-char-or-special" +" in_28" +" special1.1" +" source_19))))" +"(begin" +"(if(char? next-c_0)" +"(void)" +"(let-values()" +"(unexpected-quoted_0" +" next-c_0" +" c_85)))" +"(if(let-values(((or-part_54)" +" pipe-quote-c_0))" +"(if or-part_54" +" or-part_54" +" case-sens?_0))" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0)))" +"(accum-string-add!" +" accum-str_1" +" next-c_0)" +"(set! quoted-ever?_0" +" #t)" +"(loop_102" +" #f" +" #f" +"(accum-string-count" +" accum-str_1))))))" +"(let-values()" +"(begin" +"(if init-c_7" +"(void)" +"(let-values()" +"(consume-char" +" in_26" +" c_85)))" +"(accum-string-add!" +" accum-str_1" +" c_85)" +"(loop_102" +" #f" +" pipe-quote-c_0" +" foldcase-from_0))))))))))))))" +" loop_102)" +" init-c_6" +" #f" +" 0)" +"(values))))" +"(let-values(((str_29)" +"(let-values(((accum-str18_0) accum-str_1)" +"((config19_0) config_37))" +"(accum-string-get!6.1 0 accum-str18_0 config19_0))))" +"(let-values((()" +"(begin" +"(if(if(= 1(string-length str_29))" +"(if(not quoted-ever?_0)" +"(char=?" +" '#\\." +"(effective-char(string-ref str_29 0) config_37))" +" #f)" +" #f)" +"(let-values()" +"(let-values(((in20_1) in_26)" +"((config21_0) config_37)" +" ((temp22_5) \"illegal use of `.`\"))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in20_1" +" config21_0" +" temp22_5" +"(list))))" +"(void))" +"(values))))" +"(let-values(((num_0)" +"(if(let-values(((or-part_32)" +"(eq? mode_18 'symbol-or-number)))" +"(if or-part_32 or-part_32(string? mode_18)))" +"(if(not quoted-ever?_0)" +"(1/string->number" +"(if(string? mode_18)" +"(string-append mode_18 str_29)" +" str_29)" +" 10" +" 'read" +"(if(check-parameter" +" 1/read-decimal-as-inexact" +" config_37)" +" 'decimal-as-inexact" +" 'decimal-as-exact))" +" #f)" +" #f)))" +"(begin" +"(if(string? num_0)" +"(let-values()" +"(let-values(((in23_1) in_26)" +"((config24_1) config_37)" +" ((temp25_6) \"~a\")" +"((num26_0) num_0))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in23_1" +" config24_1" +" temp25_6" +"(list num26_0))))" +"(void))" +"(if(if(not num_0)(string? mode_18) #f)" +"(let-values()" +"(let-values(((in27_0) in_26)" +"((config28_0) config_37)" +" ((temp29_5) \"bad number: `~a`\")" +"((temp30_4)(string-append mode_18 str_29)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in27_0" +" config28_0" +" temp29_5" +"(list temp30_4))))" +"(void))" +"(wrap" +"(let-values(((or-part_358) num_0))" +"(if or-part_358" +" or-part_358" +"(let-values(((or-part_166)" +"(if(eq? mode_18 'keyword)" +"(string->keyword str_29)" +" #f)))" +"(if or-part_166 or-part_166(string->symbol str_29)))))" +" in_26" +" config_37" +" str_29))))))))))))))))))))))))))" +"(define-values" +"(read-fixnum)" +"(lambda(read-one_3 init-c_0 in_5 config_15)" +"(begin" +"(let-values(((c_25)(read-char/skip-whitespace-and-comments init-c_0 read-one_3 in_5 config_15)))" +"(let-values(((line_8 col_7 pos_116)(port-next-location* in_5 c_25)))" +" (let-values (((v_232) (read-number-literal c_25 in_5 config_15 \"#e\")))" +"(if(fixnum? v_232)" +"(let-values() v_232)" +"(if(eof-object? v_232)" +"(let-values() v_232)" +"(let-values()" +"(let-values(((in1_3) in_5)" +"((temp2_5)(reading-at config_15 line_8 col_7 pos_116))" +" ((temp3_6) \"expected a fixnum, found ~a\")" +"((v4_1) v_232))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in1_3" +" temp2_5" +" temp3_6" +"(list v4_1))))))))))))" +"(define-values" +"(read-flonum)" +"(lambda(read-one_4 init-c_8 in_20 config_38)" +"(begin" +"(let-values(((c_14)(read-char/skip-whitespace-and-comments init-c_8 read-one_4 in_20 config_38)))" +"(let-values(((line_9 col_8 pos_94)(port-next-location* in_20 c_14)))" +" (let-values (((v_31) (read-number-literal c_14 in_20 config_38 \"#i\")))" +"(if(flonum? v_31)" +"(let-values() v_31)" +"(if(eof-object? v_31)" +"(let-values() v_31)" +"(let-values()" +"(let-values(((in5_0) in_20)" +"((temp6_1)(reading-at config_38 line_9 col_8 pos_94))" +" ((temp7_4) \"expected a flonum, found ~a\")" +"((v8_0) v_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in5_0" +" temp6_1" +" temp7_4" +"(list v8_0))))))))))))" +"(define-values" +"(read-number-literal)" +"(lambda(c_49 in_29 config_39 mode_19)" +"(begin" +"(if(not(char? c_49))" +"(let-values() c_49)" +"(let-values()" +"(let-values(((c9_0) c_49)((in10_2) in_29)((config11_1) config_39)((mode12_0) mode_19))" +"(read-symbol-or-number8.1 #f mode12_0 c9_0 in10_2 config11_1)))))))" +"(define-values" +"(read-vector11.1)" +"(lambda(length2_0 mode1_0 read-one5_0 opener-c6_0 opener7_0 closer8_0 in9_1 config10_1)" +"(begin" +" 'read-vector11" +"(let-values(((read-one_5) read-one5_0))" +"(let-values(((opener-c_1) opener-c6_0))" +"(let-values(((opener_2) opener7_0))" +"(let-values(((closer_2) closer8_0))" +"(let-values(((in_30) in9_1))" +"(let-values(((config_10) config10_1))" +"(let-values(((vector-mode_0) mode1_0))" +"(let-values(((expected-len_0) length2_0))" +"(let-values()" +"(let-values(((read-one-element_0)" +"(let-values(((tmp_41) vector-mode_0))" +"(if(equal? tmp_41 'any)" +"(let-values() read-one_5)" +"(if(equal? tmp_41 'fixnum)" +"(let-values()" +"(lambda(init-c_9 in_31 config_40)" +"(begin" +" 'read-one-element" +"(read-fixnum read-one_5 init-c_9 in_31 config_40))))" +"(if(equal? tmp_41 'flonum)" +"(let-values()" +"(lambda(init-c_10 in_11 config_26)" +"(begin" +" 'read-one-element" +"(read-flonum read-one_5 init-c_10 in_11 config_26))))" +"(let-values()(void))))))))" +"(let-values(((seq_2)" +"(let-values(((read-one-element14_0) read-one-element_0)" +"((opener-c15_0) opener-c_1)" +"((opener16_0) opener_2)" +"((closer17_0) closer_2)" +"((in18_0) in_30)" +"((config19_1) config_10)" +"((read-one20_0) read-one_5)" +"((temp21_2) #f))" +"(read-unwrapped-sequence17.1" +" temp21_2" +" unsafe-undefined" +" unsafe-undefined" +" #f" +" read-one20_0" +" read-one-element14_0" +" opener-c15_0" +" opener16_0" +" closer17_0" +" in18_0" +" config19_1))))" +"(let-values(((vec_61)" +"(if(not expected-len_0)" +"(let-values()" +"(let-values(((tmp_42) vector-mode_0))" +"(if(equal? tmp_42 'any)" +"(let-values()(list->vector seq_2))" +"(if(equal? tmp_42 'fixnum)" +"(let-values()" +"(let-values(((len_37)(length seq_2)))" +"(begin" +"(if(exact-nonnegative-integer? len_37)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/fxvector" +" \"exact-nonnegative-integer?\"" +" len_37)))" +"(let-values(((fill_0) 0))" +"(let-values(((v_35)(make-fxvector len_37 fill_0)))" +"(begin" +"(if(zero? len_37)" +"(void)" +"(let-values()" +"(let-values(((lst_264) seq_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_264)))" +"((letrec-values(((for-loop_274)" +"(lambda(i_3 lst_104)" +"(begin" +" 'for-loop" +"(if(pair? lst_104)" +"(let-values(((e_78)" +"(unsafe-car" +" lst_104))" +"((rest_145)" +"(unsafe-cdr" +" lst_104)))" +"(let-values(((i_172)" +"(let-values(((i_94)" +" i_3))" +"(let-values(((i_173)" +"(let-values()" +"(begin" +"(let-values(((elem_0)" +"(let-values()" +" e_78)))" +"(if(fixnum?" +" elem_0)" +"(unsafe-fxvector-set!" +" v_35" +" i_94" +" elem_0)" +"(not-an-fX.1" +" 'for*/vector" +" elem_0)))" +"(unsafe-fx+" +" 1" +" i_94)))))" +"(values" +" i_173)))))" +"(if(if(not" +"((lambda x_90" +"(unsafe-fx=" +" i_172" +" len_37))" +" e_78))" +"(not #f)" +" #f)" +"(for-loop_274" +" i_172" +" rest_145)" +" i_172)))" +" i_3)))))" +" for-loop_274)" +" 0" +" lst_264)))))" +" v_35))))))" +"(if(equal? tmp_42 'flonum)" +"(let-values()" +"(let-values(((len_38)(length seq_2)))" +"(begin" +"(if(exact-nonnegative-integer? len_38)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/flvector" +" \"exact-nonnegative-integer?\"" +" len_38)))" +"(let-values(((fill_1) 0.0))" +"(let-values(((v_187)(make-flvector len_38 fill_1)))" +"(begin" +"(if(zero? len_38)" +"(void)" +"(let-values()" +"(let-values(((lst_24) seq_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_24)))" +"((letrec-values(((for-loop_21)" +"(lambda(i_40 lst_25)" +"(begin" +" 'for-loop" +"(if(pair? lst_25)" +"(let-values(((e_12)" +"(unsafe-car" +" lst_25))" +"((rest_9)" +"(unsafe-cdr" +" lst_25)))" +"(let-values(((i_42)" +"(let-values(((i_43)" +" i_40))" +"(let-values(((i_153)" +"(let-values()" +"(begin" +"(let-values(((elem_1)" +"(let-values()" +" e_12)))" +"(if(flonum?" +" elem_1)" +"(unsafe-flvector-set!" +" v_187" +" i_43" +" elem_1)" +"(not-an-fX.1$1" +" 'for*/vector" +" elem_1)))" +"(unsafe-fx+" +" 1" +" i_43)))))" +"(values" +" i_153)))))" +"(if(if(not" +"((lambda x_91" +"(unsafe-fx=" +" i_42" +" len_38))" +" e_12))" +"(not #f)" +" #f)" +"(for-loop_21" +" i_42" +" rest_9)" +" i_42)))" +" i_40)))))" +" for-loop_21)" +" 0" +" lst_24)))))" +" v_187))))))" +"(let-values()(void)))))))" +"(let-values()" +"(let-values(((len_39)(length seq_2)))" +"(if(= expected-len_0 len_39)" +"(let-values()(list->vector seq_2))" +"(if(< expected-len_0 len_39)" +"(let-values()" +"(let-values(((in22_1) in_30)" +"((config23_0) config_10)" +"((temp24_6)" +" \"~avector length ~a is too small, ~a values provided\")" +"((temp25_7)" +"(let-values(((tmp_43) vector-mode_0))" +"(if(equal? tmp_43 'any)" +" (let-values () \"\")" +"(if(equal? tmp_43 'fixnum)" +" (let-values () \"fx\")" +"(if(equal? tmp_43 'flonum)" +" (let-values () \"fl\")" +"(let-values()(void)))))))" +"((expected-len26_0) expected-len_0)" +"((len27_0) len_39))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in22_1" +" config23_0" +" temp24_6" +"(list temp25_7 expected-len26_0 len27_0))))" +"(let-values()" +"(let-values(((last-or_0)" +"(lambda(v_242)" +"(begin" +" 'last-or" +"(if(null? seq_2)" +"(wrap v_242 in_30 config_10 #f)" +"((letrec-values(((loop_113)" +"(lambda(seq_3)" +"(begin" +" 'loop" +"(if(null?(cdr seq_3))" +"(car seq_3)" +"(loop_113" +"(cdr seq_3)))))))" +" loop_113)" +" seq_2))))))" +"(let-values((()" +"(begin" +"(if(>=(integer-length expected-len_0) 48)" +"(let-values()" +"(raise" +"(exn:fail:out-of-memory" +" \"out of memory\"" +"(current-continuation-marks))))" +"(void))" +"(values))))" +"(let-values(((vec_69)" +"(let-values(((tmp_44) vector-mode_0))" +"(if(equal? tmp_44 'any)" +"(let-values()" +"(make-vector" +" expected-len_0" +"(last-or_0 0)))" +"(if(equal? tmp_44 'fixnum)" +"(let-values()" +"(make-fxvector" +" expected-len_0" +"(last-or_0 0)))" +"(if(equal? tmp_44 'flonum)" +"(let-values()" +"(make-flvector" +" expected-len_0" +"(last-or_0 0.0)))" +"(let-values()(void))))))))" +"(begin" +"(let-values(((tmp_45) vector-mode_0))" +"(if(equal? tmp_45 'any)" +"(let-values()" +"(begin" +"(let-values(((lst_8) seq_2)((start_54) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_8)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_54)))" +"((letrec-values(((for-loop_263)" +"(lambda(lst_299 pos_117)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_299)" +" #t" +" #f)" +"(let-values(((e_79)" +"(unsafe-car" +" lst_299))" +"((rest_175)" +"(unsafe-cdr" +" lst_299))" +"((i_174)" +" pos_117))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set!" +" vec_69" +" i_174" +" e_79))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_263" +" rest_175" +"(+ pos_117 1))" +"(values))))" +"(values))))))" +" for-loop_263)" +" lst_8" +" start_54)))" +"(void)))" +"(if(equal? tmp_45 'fixnum)" +"(let-values()" +"(begin" +"(let-values(((lst_178) seq_2)((start_55) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_178)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_55)))" +"((letrec-values(((for-loop_28)" +"(lambda(lst_276 pos_17)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_276)" +" #t" +" #f)" +"(let-values(((e_80)" +"(unsafe-car" +" lst_276))" +"((rest_123)" +"(unsafe-cdr" +" lst_276))" +"((i_99)" +" pos_17))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(fxvector-set!" +" vec_69" +" i_99" +" e_80))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_28" +" rest_123" +"(+ pos_17 1))" +"(values))))" +"(values))))))" +" for-loop_28)" +" lst_178" +" start_55)))" +"(void)))" +"(if(equal? tmp_45 'flonum)" +"(let-values()" +"(begin" +"(let-values(((lst_306) seq_2)((start_56) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_306)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals start_56)))" +"((letrec-values(((for-loop_275)" +"(lambda(lst_98 pos_118)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_98)" +" #t" +" #f)" +"(let-values(((e_81)" +"(unsafe-car" +" lst_98))" +"((rest_176)" +"(unsafe-cdr" +" lst_98))" +"((i_46)" +" pos_118))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(flvector-set!" +" vec_69" +" i_46" +" e_81))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_275" +" rest_176" +"(+" +" pos_118" +" 1))" +"(values))))" +"(values))))))" +" for-loop_275)" +" lst_306" +" start_56)))" +"(void)))" +"(let-values()(void))))))" +" vec_69))))))))))))" +"(wrap vec_61 in_30 config_10 opener_2))))))))))))))))" +"(define-values" +"(read-fixnum-or-flonum-vector)" +"(lambda(read-one_6 dispatch-c_0 c_86 c2_4 in_32 config_41)" +"(begin" +"(let-values(((vector-mode_1)(if(char=? c2_4 '#\\x) 'fixnum 'flonum)))" +"(let-values((()(begin(consume-char in_32 c2_4)(values))))" +"(let-values((()" +"(begin" +"(if(read-config-for-syntax? config_41)" +"(let-values()" +"(let-values(((in28_0) in_32)" +"((config29_0) config_41)" +" ((temp30_5) \"literal f~avectors not allowed\")" +"((c231_0) c2_4))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in28_0" +" config29_0" +" temp30_5" +"(list c231_0))))" +"(void))" +"(values))))" +"(let-values(((c3_3)" +"(let-values(((in_33) in_32)((source_20)(read-config-source config_41)))" +"(read-char-or-special in_33 special1.1 source_20))))" +"(let-values(((vector-len_0 len-str_0 c4_1)" +"(if(decimal-digit? c3_3)" +"(let-values()(read-simple-number in_32 config_41 c3_3))" +" (let-values () (values #f \"\" c3_3)))))" +"(let-values(((tmp_46) c4_1))" +"(if(equal? tmp_46 '#\\()" +"(let-values()" +"(let-values(((read-one32_0) read-one_6)" +"((temp33_2) '#\\()" +"((temp34_6) '#\\()" +"((temp35_3) '#\\))" +"((in36_0) in_32)" +"((config37_0) config_41)" +"((vector-mode38_0) vector-mode_1)" +"((vector-len39_0) vector-len_0))" +"(read-vector11.1" +" vector-len39_0" +" vector-mode38_0" +" read-one32_0" +" temp33_2" +" temp34_6" +" temp35_3" +" in36_0" +" config37_0)))" +"(if(equal? tmp_46 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_41)" +"(let-values()" +"(let-values(((read-one40_0) read-one_6)" +"((temp41_2) '#\\[)" +"((temp42_2) '#\\[)" +"((temp43_3) '#\\])" +"((in44_0) in_32)" +"((config45_0) config_41)" +"((vector-mode46_0) vector-mode_1)" +"((vector-len47_0) vector-len_0))" +"(read-vector11.1" +" vector-len47_0" +" vector-mode46_0" +" read-one40_0" +" temp41_2" +" temp42_2" +" temp43_3" +" in44_0" +" config45_0)))" +"(let-values()" +"(let-values(((in48_0) in_32)" +"((config49_0) config_41)" +" ((temp50_1) (format \"~a~a\" dispatch-c_0 (format \"~a~a\" c_86 c2_4))))" +"(bad-syntax-error20.1 '#\\x in48_0 config49_0 temp50_1)))))" +"(if(equal? tmp_46 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_41)" +"(let-values()" +"(let-values(((read-one51_0) read-one_6)" +"((temp52_1) '#\\{)" +"((temp53_3) '#\\{)" +"((temp54_0) '#\\})" +"((in55_1) in_32)" +"((config56_0) config_41)" +"((vector-mode57_0) vector-mode_1)" +"((vector-len58_0) vector-len_0))" +"(read-vector11.1" +" vector-len58_0" +" vector-mode57_0" +" read-one51_0" +" temp52_1" +" temp53_3" +" temp54_0" +" in55_1" +" config56_0)))" +"(let-values()" +"(let-values(((in59_0) in_32)" +"((config60_0) config_41)" +" ((temp61_3) (format \"~a~a\" dispatch-c_0 (format \"~a~a\" c_86 c2_4))))" +"(bad-syntax-error20.1 '#\\x in59_0 config60_0 temp61_3)))))" +"(let-values()" +"(let-values(((in62_0) in_32)" +"((config63_0) config_41)" +"((c464_0) c4_1)" +" ((temp65_2) \"expected `(`, `[`, or `{` after `#~a~a~a`\")" +"((c66_0) c_86)" +"((c267_0) c2_4)" +"((len-str68_0) len-str_0))" +"(reader-error12.1" +" unsafe-undefined" +" c464_0" +" #f" +" unsafe-undefined" +" in62_0" +" config63_0" +" temp65_2" +"(list c66_0 c267_0 len-str68_0))))))))))))))))" +"(define-values" +"(read-simple-number)" +"(lambda(in_34 config_42 init-c_11)" +"(begin" +"(let-values(((accum-str_2)(accum-string-init! config_42)))" +"(let-values((()(begin(accum-string-add! accum-str_2 init-c_11)(values))))" +"(let-values(((init-v_1)(digit->number init-c_11)))" +"(let-values(((v_243)" +"(let-values(((in69_0) in_34)" +"((config70_0) config_42)" +"((accum-str71_0) accum-str_2)" +"((temp72_1) 10)" +"((temp73_0) +inf.0)" +"((init-v74_0) init-v_1)" +"((init-v75_0) init-v_1))" +"(read-digits12.1 temp72_1 init-v74_0 temp73_0 init-v75_0 in69_0 config70_0 accum-str71_0))))" +"(values" +" v_243" +"(let-values(((accum-str76_0) accum-str_2)((config77_0) config_42))" +"(accum-string-get!6.1 0 accum-str76_0 config77_0))" +"(let-values(((in_35) in_34)((source_21)(read-config-source config_42)))" +"(read-char-or-special in_35 special1.1 source_21))))))))))" +"(define-values" +"(read-struct)" +"(lambda(read-one_3 dispatch-c_1 in_5 config_15)" +"(begin" +"(let-values(((c_25)" +"(let-values(((in_11) in_5)((source_22)(read-config-source config_15)))" +"(read-char-or-special in_11 special1.1 source_22))))" +"(let-values(((ec_5)(effective-char c_25 config_15)))" +"(let-values(((seq_4)" +"(let-values(((tmp_47) ec_5))" +"(if(equal? tmp_47 '#\\()" +"(let-values()(read-struct-sequence read-one_3 c_25 '#\\( '#\\) in_5 config_15))" +"(if(equal? tmp_47 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_15)" +"(let-values()(read-struct-sequence read-one_3 c_25 '#\\[ '#\\] in_5 config_15))" +"(let-values()" +"(let-values(((in1_4) in_5)" +"((config2_3) config_15)" +" ((temp3_7) (format \"~as~a\" dispatch-c_1 c_25)))" +"(bad-syntax-error20.1 '#\\x in1_4 config2_3 temp3_7)))))" +"(if(equal? tmp_47 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_15)" +"(let-values()(read-struct-sequence read-one_3 c_25 '#\\{ '#\\} in_5 config_15))" +"(let-values()" +"(let-values(((in4_1) in_5)" +"((config5_1) config_15)" +" ((temp6_2) (format \"~as~a\" dispatch-c_1 c_25)))" +"(bad-syntax-error20.1 '#\\x in4_1 config5_1 temp6_2)))))" +"(let-values()" +"(let-values(((in7_0) in_5)" +"((config8_0) config_15)" +" ((temp9_5) \"expected ~a after `~as`\")" +"((temp10_0)(all-openers-str config_15))" +"((dispatch-c11_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in7_0" +" config8_0" +" temp9_5" +"(list temp10_0 dispatch-c11_0))))))))))" +"(let-values((()" +"(begin" +"(if(null? seq_4)" +"(let-values()" +"(let-values(((in12_0) in_5)" +"((config13_0) config_15)" +" ((temp14_1) \"missing structure description in `~as` form\")" +"((dispatch-c15_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in12_0" +" config13_0" +" temp14_1" +"(list dispatch-c15_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(prefab-key?(car seq_4))" +"(void)" +"(let-values()" +"(let-values(((in16_0) in_5)" +"((config17_0) config_15)" +" ((temp18_5) \"invalid structure description in `~as` form\")" +"((dispatch-c19_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in16_0" +" config17_0" +" temp18_5" +"(list dispatch-c19_0)))))" +"(values))))" +"(let-values(((st_2)" +"(let-values(((with-handlers-predicate20_0) exn:fail?)" +"((with-handlers-handler21_0)" +"(lambda(exn_4)(begin 'with-handlers-handler21 #f))))" +"(let-values(((bpz_4)(continuation-mark-set-first #f break-enabled-key)))" +"(call-handled-body" +" bpz_4" +"(lambda(e_82)" +"(select-handler/no-breaks" +" e_82" +" bpz_4" +"(list(cons with-handlers-predicate20_0 with-handlers-handler21_0))))" +"(lambda()(prefab-key->struct-type(car seq_4)(length(cdr seq_4)))))))))" +"(begin" +"(if st_2" +"(void)" +"(let-values()" +"(let-values(((in22_2) in_5)" +"((config23_1) config_15)" +"((temp24_7)" +"(string-append" +" \"mismatch between structure description\"" +" \" and number of provided field values in `~as` form\"))" +"((dispatch-c25_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in22_2" +" config23_1" +" temp24_7" +"(list dispatch-c25_0)))))" +"(if(read-config-for-syntax? config_15)" +"(let-values()" +"(if(all-fields-immutable?(car seq_4))" +"(void)" +"(let-values()" +"(let-values(((in26_1) in_5)" +"((config27_1) config_15)" +" ((temp28_2) \"cannot read mutable `~as` form as syntax\")" +"((dispatch-c29_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in26_1" +" config27_1" +" temp28_2" +"(list dispatch-c29_0))))))" +"(void))" +"(wrap(apply make-prefab-struct seq_4) in_5 config_15 ec_5)))))))))))" +"(define-values" +"(read-struct-sequence)" +"(lambda(read-one_7 opener-c_2 opener_3 closer_3 in_16 config_43)" +"(begin" +"(let-values(((read-one30_0) read-one_7)" +"((opener-c31_0) opener-c_2)" +"((opener32_0) opener_3)" +"((closer33_0) closer_3)" +"((in34_0) in_16)" +"((config35_0) config_43)" +"((temp36_5)" +"(lambda(init-c_12 in_36 config_11)(read-one_7 init-c_12 in_36(disable-wrapping config_11)))))" +"(read-unwrapped-sequence17.1" +" 'all" +" unsafe-undefined" +" temp36_5" +" #f" +" unsafe-undefined" +" read-one30_0" +" opener-c31_0" +" opener32_0" +" closer33_0" +" in34_0" +" config35_0)))))" +"(define-values" +"(read-vector-or-graph)" +"(lambda(read-one_3 dispatch-c_1 init-c_13 in_37 config_44)" +"(begin" +"(let-values(((accum-str_3)(accum-string-init! config_44)))" +"(let-values((()(begin(accum-string-add! accum-str_3 init-c_13)(values))))" +"(let-values(((init-v_2)(digit->number init-c_13)))" +"(let-values(((v_30)" +"(let-values(((in1_5) in_37)" +"((config2_4) config_44)" +"((accum-str3_0) accum-str_3)" +"((temp4_3) 10)" +"((temp5_6) +inf.0)" +"((init-v6_0) init-v_2)" +"((init-v7_0) init-v_2))" +"(read-digits12.1 temp4_3 init-v6_0 temp5_6 init-v7_0 in1_5 config2_4 accum-str3_0))))" +"(let-values(((post-line_0 post-col_0 post-pos_0)(port-next-location in_37)))" +"(let-values(((get-accum_0)" +"(lambda(c_52)" +"(begin" +" 'get-accum" +"(format" +" \"~a~a~a\"" +" dispatch-c_1" +"(let-values(((accum-str8_0) accum-str_3)((config9_0) config_44))" +"(accum-string-get!6.1 0 accum-str8_0 config9_0))" +" c_52)))))" +"(let-values(((c_87)" +"(let-values(((in_38) in_37)((source_16)(read-config-source config_44)))" +"(read-char-or-special in_38 special1.1 source_16))))" +"(let-values(((ec_6)(effective-char c_87 config_44)))" +"(let-values(((tmp_48) ec_6))" +"(if(equal? tmp_48 '#\\()" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_44)" +"(let-values(((read-one10_0) read-one_3)" +"((c11_0) c_87)" +"((temp12_4) '#\\()" +"((temp13_2) '#\\))" +"((in14_0) in_37)" +"((config15_0) config_44)" +"((v16_0) v_30))" +"(read-vector11.1 v16_0 'any read-one10_0 c11_0 temp12_4 temp13_2 in14_0 config15_0))))" +"(if(equal? tmp_48 '#\\[)" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_44)" +"(if(check-parameter 1/read-square-bracket-as-paren config_44)" +"(let-values()" +"(let-values(((read-one17_0) read-one_3)" +"((c18_1) c_87)" +"((temp19_3) '#\\[)" +"((temp20_3) '#\\])" +"((in21_0) in_37)" +"((config22_0) config_44)" +"((v23_0) v_30))" +"(read-vector11.1" +" v23_0" +" 'any" +" read-one17_0" +" c18_1" +" temp19_3" +" temp20_3" +" in21_0" +" config22_0)))" +"(let-values()" +"(let-values(((in24_0) in_37)" +"((config25_0) config_44)" +"((temp26_4)(get-accum_0(get-accum_0 c_87))))" +"(bad-syntax-error20.1 '#\\x in24_0 config25_0 temp26_4))))))" +"(if(equal? tmp_48 '#\\{)" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_44)" +"(if(check-parameter 1/read-curly-brace-as-paren config_44)" +"(let-values()" +"(let-values(((read-one27_0) read-one_3)" +"((c28_0) c_87)" +"((temp29_6) '#\\{)" +"((temp30_6) '#\\})" +"((in31_1) in_37)" +"((config32_0) config_44)" +"((v33_0) v_30))" +"(read-vector11.1" +" v33_0" +" 'any" +" read-one27_0" +" c28_0" +" temp29_6" +" temp30_6" +" in31_1" +" config32_0)))" +"(let-values()" +"(let-values(((in34_1) in_37)" +"((config35_1) config_44)" +"((temp36_6)(get-accum_0(get-accum_0 c_87))))" +"(bad-syntax-error20.1 '#\\x in34_1 config35_1 temp36_6))))))" +"(let-values()" +"(let-values(((tmp_45) c_87))" +"(if(if(equal? tmp_45 '#\\=) #t(equal? tmp_45 '#\\#))" +"(let-values()" +"(begin" +"(if(let-values(((or-part_308)(read-config-for-syntax? config_44)))" +"(if or-part_308" +" or-part_308" +"(not(check-parameter 1/read-accept-graph config_44))))" +"(let-values()" +"(let-values(((in37_1) in_37)" +"((config38_0) config_44)" +" ((temp39_4) \"`#...~a` forms not ~a\")" +"((c40_0) c_87)" +"((temp41_3)" +"(if(read-config-for-syntax? config_44)" +" \"enabled\"" +" \"allowed in `read-syntax` mode\")))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in37_1" +" config38_0" +" temp39_4" +"(list c40_0 temp41_3))))" +"(void))" +"(if(<=(accum-string-count accum-str_3) 8)" +"(void)" +"(let-values()" +"(let-values(((in42_0) in_37)" +"((config43_0) config_44)" +" ((temp44_2) \"graph ID too long in `~a~a~a`\")" +"((dispatch-c45_0) dispatch-c_1)" +"((temp46_1)" +"(let-values(((accum-str48_0) accum-str_3)" +"((config49_1) config_44))" +"(accum-string-get!6.1 0 accum-str48_0 config49_1)))" +"((c47_0) c_87))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in42_0" +" config43_0" +" temp44_2" +"(list dispatch-c45_0 temp46_1 c47_0)))))" +"(let-values(((tmp_49) c_87))" +"(if(equal? tmp_49 '#\\=)" +"(let-values()" +"(let-values(((ph_1)(make-placeholder 'placeholder)))" +"(let-values(((ht_145)(get-graph-hash config_44)))" +"(let-values((()" +"(begin" +"(if(hash-ref ht_145 v_30 #f)" +"(let-values()" +"(let-values(((in50_0) in_37)" +"((config51_0) config_44)" +" ((temp52_2) \"multiple `~a~a~a` tags\")" +"((dispatch-c53_0) dispatch-c_1)" +"((temp54_1)" +"(let-values(((accum-str56_0)" +" accum-str_3)" +"((config57_0)" +" config_44))" +"(accum-string-get!6.1" +" 0" +" accum-str56_0" +" config57_0)))" +"((c55_0) c_87))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in50_0" +" config51_0" +" temp52_2" +"(list dispatch-c53_0 temp54_1 c55_0))))" +"(void))" +"(values))))" +"(let-values((()(begin(hash-set! ht_145 v_30 ph_1)(values))))" +"(let-values(((result-v_0)" +"(read-one_3 #f in_37(next-readtable config_44))))" +"(begin" +"(if(eof-object? result-v_0)" +"(let-values()" +"(let-values(((in58_0) in_37)" +"((config59_0) config_44)" +"((result-v60_0) result-v_0)" +"((temp61_4)" +" \"expected an element for graph after `~a~a~a`, found end-of-file\")" +"((dispatch-c62_0) dispatch-c_1)" +"((temp63_3)" +"(let-values(((accum-str65_0) accum-str_3)" +"((config66_0) config_44))" +"(accum-string-get!6.1" +" 0" +" accum-str65_0" +" config66_0)))" +"((c64_0) c_87))" +"(reader-error12.1" +" unsafe-undefined" +" result-v60_0" +" #f" +" unsafe-undefined" +" in58_0" +" config59_0" +" temp61_4" +"(list dispatch-c62_0 temp63_3 c64_0))))" +"(void))" +"(accum-string-abandon! accum-str_3 config_44)" +"(placeholder-set! ph_1 result-v_0)" +" ph_1)))))))" +"(if(equal? tmp_49 '#\\#)" +"(let-values()" +"(begin0" +"(hash-ref" +"(let-values(((or-part_210)" +"(read-config-state-graph(read-config-st config_44))))" +"(if or-part_210 or-part_210 '#hash()))" +" v_30" +"(lambda()" +"(let-values(((in67_0) in_37)" +"((config68_0) config_44)" +" ((temp69_1) \"no preceding `~a~a=` for `~a~a~a`\")" +"((dispatch-c70_0) dispatch-c_1)" +"((v71_0) v_30)" +"((dispatch-c72_0) dispatch-c_1)" +"((temp73_1)" +"(let-values(((accum-str75_0) accum-str_3)" +"((config76_0) config_44))" +"(accum-string-get!6.1 0 accum-str75_0 config76_0)))" +"((c74_0) c_87))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in67_0" +" config68_0" +" temp69_1" +"(list dispatch-c70_0 v71_0 dispatch-c72_0 temp73_1 c74_0)))))" +"(accum-string-abandon! accum-str_3 config_44)))" +"(let-values()(void)))))))" +"(let-values()" +"(let-values(((in77_0) in_37)" +"((config78_0) config_44)" +"((c79_0) c_87)" +" ((temp80_0) \"bad syntax `~a`\")" +"((temp81_1)(get-accum_0 c_87)))" +"(reader-error12.1" +" unsafe-undefined" +" c79_0" +" #f" +" unsafe-undefined" +" in77_0" +" config78_0" +" temp80_0" +"(list temp81_1))))))))))))))))))))))" +"(define-values" +"(get-graph-hash)" +"(lambda(config_45)" +"(begin" +"(let-values(((st_3)(read-config-st config_45)))" +"(let-values(((or-part_359)(read-config-state-graph st_3)))" +"(if or-part_359" +" or-part_359" +"(let-values(((ht_155)(make-hasheqv)))(begin(set-read-config-state-graph! st_3 ht_155) ht_155))))))))" +"(define-values" +"(coerce-key)" +"(lambda(key_85 config_8)" +"(begin" +"(let-values(((for-syntax?_7)(read-config-for-syntax? config_8)))" +"((read-config-coerce-key config_8) for-syntax?_7 key_85)))))" +"(define-values" +"(read-hash)" +"(lambda(read-one_3 dispatch-c_1 init-c_13 in_37 config_44)" +"(begin" +"(let-values(((accum-str_3)(accum-string-init! config_44)))" +"(let-values((()(begin(accum-string-add! accum-str_3 dispatch-c_1)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_3 init-c_13)(values))))" +"(let-values(((get-next!_0)" +"(lambda(expect-c_0 expect-alt-c_0)" +"(begin" +" 'get-next!" +"(let-values(((c_46)" +"(let-values(((in_39) in_37)((source_23)(read-config-source config_44)))" +"(read-char-or-special in_39 special1.1 source_23))))" +"(begin" +"(if(let-values(((or-part_6)(eqv? c_46 expect-c_0)))" +"(if or-part_6 or-part_6(eqv? c_46 expect-alt-c_0)))" +"(void)" +"(let-values()" +"(let-values(((in1_6) in_37)" +"((config2_5) config_44)" +"((c3_4) c_46)" +" ((temp4_4) \"expected `~a` after `~a`\")" +"((expect-c5_0) expect-c_0)" +"((temp6_3)" +"(let-values(((accum-str7_0) accum-str_3)((config8_1) config_44))" +"(accum-string-get!6.1 0 accum-str7_0 config8_1))))" +"(reader-error12.1" +" unsafe-undefined" +" c3_4" +" #f" +" unsafe-undefined" +" in1_6" +" config2_5" +" temp4_4" +"(list expect-c5_0 temp6_3)))))" +"(accum-string-add! accum-str_3 c_46)))))))" +"(let-values((()(begin(get-next!_0 '#\\a '#\\A)(values))))" +"(let-values((()(begin(get-next!_0 '#\\s '#\\S)(values))))" +"(let-values((()(begin(get-next!_0 '#\\h '#\\H)(values))))" +"(let-values(((content_11 opener_4 mode_20)" +"((letrec-values(((loop_114)" +"(lambda(mode_21)" +"(begin" +" 'loop" +"(let-values(((c_50)" +"(let-values(((in_40) in_37)" +"((source_24)" +"(read-config-source config_44)))" +"(read-char-or-special" +" in_40" +" special1.1" +" source_24))))" +"(let-values(((ec_7)(effective-char c_50 config_44)))" +"(let-values(((tmp_50) ec_7))" +"(if(equal? tmp_50 '#\\()" +"(let-values()" +"(let-values(((open-end-line_1" +" open-end-col_1" +" open-end-pos_1)" +"(port-next-location in_37)))" +"(let-values(((read-one-key+value_0)" +"(make-read-one-key+value" +" read-one_3" +" c_50" +" '#\\)" +" open-end-pos_1)))" +"(values" +"(let-values(((read-one-key+value9_0)" +" read-one-key+value_0)" +"((c10_1) c_50)" +"((temp11_4) '#\\()" +"((temp12_5) '#\\))" +"((in13_0) in_37)" +"((config14_0) config_44)" +"((config15_1) config_44)" +"((temp16_5) #f))" +"(read-unwrapped-sequence17.1" +" temp16_5" +" config15_1" +" unsafe-undefined" +" #f" +" unsafe-undefined" +" read-one-key+value9_0" +" c10_1" +" temp11_4" +" temp12_5" +" in13_0" +" config14_0))" +" ec_7" +" mode_21))))" +"(if(equal? tmp_50 '#\\[)" +"(let-values()" +"(if(check-parameter" +" 1/read-square-bracket-as-paren" +" config_44)" +"(let-values()" +"(let-values(((open-end-line_2" +" open-end-col_2" +" open-end-pos_2)" +"(port-next-location in_37)))" +"(let-values(((read-one-key+value_1)" +"(make-read-one-key+value" +" read-one_3" +" c_50" +" '#\\]" +" open-end-pos_2)))" +"(values" +"(let-values(((read-one-key+value17_0)" +" read-one-key+value_1)" +"((c18_2) c_50)" +"((temp19_4) '#\\[)" +"((temp20_4) '#\\])" +"((in21_1) in_37)" +"((config22_1) config_44)" +"((config23_2) config_44)" +"((temp24_8) #f))" +"(read-unwrapped-sequence17.1" +" temp24_8" +" config23_2" +" unsafe-undefined" +" #f" +" unsafe-undefined" +" read-one-key+value17_0" +" c18_2" +" temp19_4" +" temp20_4" +" in21_1" +" config22_1))" +" ec_7" +" mode_21))))" +"(let-values()" +"(let-values(((in25_0) in_37)" +"((config26_0) config_44)" +" ((temp27_6) \"illegal use of `~a`\")" +"((c28_1) c_50))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in25_0" +" config26_0" +" temp27_6" +"(list c28_1))))))" +"(if(equal? tmp_50 '#\\{)" +"(let-values()" +"(if(check-parameter" +" 1/read-curly-brace-as-paren" +" config_44)" +"(let-values()" +"(let-values(((open-end-line_3" +" open-end-col_3" +" open-end-pos_3)" +"(port-next-location in_37)))" +"(let-values(((read-one-key+value_2)" +"(make-read-one-key+value" +" read-one_3" +" c_50" +" '#\\}" +" open-end-pos_3)))" +"(values" +"(let-values(((read-one-key+value29_0)" +" read-one-key+value_2)" +"((c30_0) c_50)" +"((temp31_3) '#\\{)" +"((temp32_2) '#\\})" +"((in33_2) in_37)" +"((config34_1) config_44)" +"((config35_1) config_44)" +"((temp36_6) #f))" +"(read-unwrapped-sequence17.1" +" temp36_6" +" config35_1" +" unsafe-undefined" +" #f" +" unsafe-undefined" +" read-one-key+value29_0" +" c30_0" +" temp31_3" +" temp32_2" +" in33_2" +" config34_1))" +" ec_7" +" mode_21))))" +"(let-values()" +"(let-values(((in37_2) in_37)" +"((config38_1) config_44)" +"((temp39_5)" +" \"illegal use of `~a`\")" +"((c40_1) c_50))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in37_2" +" config38_1" +" temp39_5" +"(list c40_1))))))" +"(if(if(equal? tmp_50 '#\\e)" +" #t" +"(equal? tmp_50 '#\\E))" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_3 c_50)" +"(get-next!_0 '#\\q '#\\Q)" +"(loop_114 'eq)))" +"(if(if(equal? tmp_50 '#\\v)" +" #t" +"(equal? tmp_50 '#\\V))" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_3 c_50)" +"(if(eq? mode_21 'eq)" +"(loop_114 'eqv)" +"(let-values(((in41_0) in_37)" +"((config42_0) config_44)" +"((temp43_4)" +" \"bad syntax `~a`\")" +"((temp44_3)" +"(let-values(((accum-str45_0)" +" accum-str_3)" +"((config46_0)" +" config_44))" +"(accum-string-get!6.1" +" 0" +" accum-str45_0" +" config46_0))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in41_0" +" config42_0" +" temp43_4" +"(list temp44_3))))))" +"(let-values()" +"(begin" +"(if(char? c_50)" +"(let-values()" +"(accum-string-add! accum-str_3 c_50))" +"(void))" +"(let-values(((in47_1) in_37)" +"((config48_1) config_44)" +"((c49_0) c_50)" +" ((temp50_2) \"bad syntax `~a`\")" +"((temp51_1)" +"(let-values(((accum-str52_0)" +" accum-str_3)" +"((config53_0)" +" config_44))" +"(accum-string-get!6.1" +" 0" +" accum-str52_0" +" config53_0))))" +"(reader-error12.1" +" unsafe-undefined" +" c49_0" +" #f" +" unsafe-undefined" +" in47_1" +" config48_1" +" temp50_2" +"(list temp51_1)))))))))))))))))" +" loop_114)" +" 'equal)))" +"(let-values(((graph?_0)(if(read-config-state-graph(read-config-st config_44)) #t #f)))" +"(wrap" +"(let-values(((tmp_51) mode_20))" +"(if(equal? tmp_51 'equal)" +"(let-values()" +"(if graph?_0(make-hash-placeholder content_11)(make-immutable-hash content_11)))" +"(if(equal? tmp_51 'eq)" +"(let-values()" +"(if graph?_0(make-hasheq-placeholder content_11)(make-immutable-hasheq content_11)))" +"(if(equal? tmp_51 'eqv)" +"(let-values()" +"(if graph?_0" +"(make-hasheqv-placeholder content_11)" +"(make-immutable-hasheqv content_11)))" +"(let-values()(void))))))" +" in_37" +" config_44" +" opener_4)))))))))))))" +"(define-values" +"(make-read-one-key+value)" +"(lambda(read-one_8 overall-opener-c_0 overall-closer-ec_0 prefix-end-pos_0)" +"(begin" +"(lambda(init-c_14 in_41 config_46)" +"(let-values(((c_88)(read-char/skip-whitespace-and-comments init-c_14 read-one_8 in_41 config_46)))" +"(let-values(((open-line_0 open-col_0 open-pos_0)(port-next-location* in_41 c_88)))" +"(let-values(((ec_8)(effective-char c_88 config_46)))" +"(let-values(((elem-config_1)(next-readtable config_46)))" +"(let-values(((closer_4)" +"(let-values(((tmp_52) ec_8))" +"(if(equal? tmp_52 '#\\()" +"(let-values() '#\\))" +"(if(equal? tmp_52 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_46) '#\\] #f))" +"(if(equal? tmp_52 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_46) '#\\} #f))" +"(let-values() #f)))))))" +"(if(not closer_4)" +"(let-values()" +"(if(eof-object? c_88)" +"(let-values()" +"(let-values(((in54_0) in_41)" +"((config55_0) config_46)" +"((c56_0) c_88)" +"((prefix-end-pos57_0) prefix-end-pos_0)" +" ((temp58_2) \"expected ~a to close `~a`\")" +"((temp59_4)(closer-name overall-closer-ec_0 config_46))" +"((overall-opener-c60_0) overall-opener-c_0))" +"(reader-error12.1" +" unsafe-undefined" +" c56_0" +" prefix-end-pos57_0" +" unsafe-undefined" +" in54_0" +" config55_0" +" temp58_2" +"(list temp59_4 overall-opener-c60_0))))" +"(if(char-closer? ec_8 config_46)" +"(let-values()" +"(let-values(((in61_0) in_41)" +"((temp62_2)(reading-at config_46 open-line_0 open-col_0 open-pos_0))" +" ((temp63_4) \"~a\")" +"((temp64_4)(indentation-unexpected-closer-message ec_8 c_88 config_46)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in61_0" +" temp62_2" +" temp63_4" +"(list temp64_4))))" +"(let-values()" +"(let-values(((v_244)(read-one_8 c_88 in_41(keep-comment elem-config_1))))" +"(if(1/special-comment? v_244)" +"(let-values()" +"((make-read-one-key+value" +" read-one_8" +" overall-opener-c_0" +" overall-closer-ec_0" +" prefix-end-pos_0)" +" #f" +" in_41" +" config_46))" +"(let-values()" +"(let-values(((in65_0) in_41)" +"((temp66_3)(reading-at config_46 open-line_0 open-col_0 open-pos_0))" +" ((temp67_4) \"expected ~a to start a hash pair\")" +"((temp68_4)(all-openers-str config_46)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in65_0" +" temp66_3" +" temp67_4" +"(list temp68_4))))))))))" +"(let-values()" +"(let-values(((k_41)(read-one_8 #f in_41(disable-wrapping elem-config_1))))" +"(let-values(((dot-c_0)(read-char/skip-whitespace-and-comments #f read-one_8 in_41 config_46)))" +"(let-values(((dot-line_1 dot-col_1 dot-pos_4)(port-next-location* in_41 dot-c_0)))" +"(let-values(((dot-ec_0)(effective-char dot-c_0 config_46)))" +"(let-values((()" +"(begin" +"(if(if(eqv? dot-ec_0 '#\\.)" +"(char-delimiter?" +"(let-values(((in_42) in_41)" +"((skip-count_9) 0)" +"((source_25)(read-config-source config_46)))" +"(let-values(((c_89)" +"(peek-char-or-special" +" in_42" +" skip-count_9" +" 'special" +" source_25)))" +"(if(eq? c_89 'special)(special1.1 'special) c_89)))" +" config_46)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((in69_1) in_41)" +"((temp70_2)" +"(reading-at config_46 dot-line_1 dot-col_1 dot-pos_4))" +"((dot-c71_0) dot-c_0)" +" ((temp72_2) \"expected ~a and value for hash\")" +"((temp73_2)(dot-name config_46)))" +"(reader-error12.1" +" unsafe-undefined" +" dot-c71_0" +" #f" +" unsafe-undefined" +" in69_1" +" temp70_2" +" temp72_2" +"(list temp73_2)))))" +"(values))))" +"(let-values(((v_245)(read-one_8 #f in_41 elem-config_1)))" +"(let-values(((closer-c_0)" +"(read-char/skip-whitespace-and-comments #f read-one_8 in_41 config_46)))" +"(let-values(((closer-line_0 closer-col_0 closer-pos_0)" +"(port-next-location* in_41 closer-c_0)))" +"(let-values(((closer-ec_0)(effective-char closer-c_0 config_46)))" +"(begin" +"(if(eqv? closer-ec_0 closer_4)" +"(void)" +"(let-values()" +"(let-values(((in74_0) in_41)" +"((temp75_2)" +"(reading-at" +" config_46" +" closer-line_0" +" closer-col_0" +" closer-pos_0))" +"((closer-c76_0) closer-c_0)" +" ((temp77_1) \"expected ~a after value within a hash\")" +"((temp78_3)(closer-name closer_4 config_46)))" +"(reader-error12.1" +" unsafe-undefined" +" closer-c76_0" +" #f" +" unsafe-undefined" +" in74_0" +" temp75_2" +" temp77_1" +"(list temp78_3)))))" +"(cons(coerce-key k_41 elem-config_1) v_245))))))))))))))))))))))" +"(define-values" +"(read-string5.1)" +"(lambda(mode1_1 in3_0 config4_0)" +"(begin" +" 'read-string5" +"(let-values(((in_37) in3_0))" +"(let-values(((config_44) config4_0))" +"(let-values(((mode_11) mode1_1))" +"(let-values()" +"(let-values(((source_26)(read-config-source config_44)))" +"(let-values(((open-end-line_4 open-end-col_4 open-end-pos_4)(port-next-location in_37)))" +"(let-values(((accum-str_4)(accum-string-init! config_44)))" +"(let-values(((bad-end_0)" +"(lambda(c_46)" +"(begin" +" 'bad-end" +"(if(eof-object? c_46)" +"(let-values()" +"(let-values(((in8_0) in_37)" +"((config9_1) config_44)" +"((c10_2) c_46)" +"((open-end-pos11_0) open-end-pos_4)" +" ((temp12_6) \"expected a closing `\\\"`\"))" +"(reader-error12.1" +" unsafe-undefined" +" c10_2" +" open-end-pos11_0" +" unsafe-undefined" +" in8_0" +" config9_1" +" temp12_6" +"(list))))" +"(let-values()" +"(let-values(((in13_1) in_37)" +"((config14_1) config_44)" +"((c15_1) c_46)" +" ((temp16_6) \"found non-character while reading a ~a\")" +"((mode17_0) mode_11))" +"(reader-error12.1" +" unsafe-undefined" +" c15_1" +" #f" +" unsafe-undefined" +" in13_1" +" config14_1" +" temp16_6" +"(list mode17_0)))))))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_115)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_17)" +"(let-values(((in_43) in_37)" +"((source_27) source_26))" +"(read-char-or-special" +" in_43" +" special1.1" +" source_27))))" +"(if(not(char? c_17))" +"(let-values()(bad-end_0 c_17))" +"(if(char=? '#\\\\ c_17)" +"(let-values()" +"(let-values(((escaping-c_0) c_17))" +"(let-values(((escaped-c_0)" +"(let-values(((in_24) in_37)" +"((source_28)" +" source_26))" +"(read-char-or-special" +" in_24" +" special1.1" +" source_28))))" +"(let-values((()" +"(begin" +"(if(not(char? escaped-c_0))" +"(let-values()" +"(bad-end_0 escaped-c_0))" +"(void))" +"(values))))" +"(let-values(((unknown-error_0)" +"(lambda()" +"(begin" +" 'unknown-error" +"(let-values(((in18_1)" +" in_37)" +"((config19_2)" +" config_44)" +"((temp20_5)" +" \"unknown escape sequence `~a~a` in ~a\")" +"((escaping-c21_0)" +" escaping-c_0)" +"((escaped-c22_0)" +" escaped-c_0)" +"((mode23_0)" +" mode_11))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in18_1" +" config19_2" +" temp20_5" +"(list" +" escaping-c21_0" +" escaped-c22_0" +" mode23_0)))))))" +"(begin" +"(let-values(((tmp_53) escaped-c_0))" +"(let-values(((index_3)" +"(if(char? tmp_53)" +"(let-values(((codepoint_1)" +"(char->integer" +" tmp_53)))" +"(if(if(unsafe-fx>=" +" codepoint_1" +" 10)" +"(unsafe-fx<" +" codepoint_1" +" 121)" +" #f)" +"(let-values(((tbl_1)" +" '#(10" +" 0" +" 0" +" 11" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 15" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 2" +" 3" +" 0" +" 0" +" 9" +" 7" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 5" +" 0" +" 0" +" 0" +" 8" +" 0" +" 4" +" 14" +" 6" +" 0" +" 13)))" +"(unsafe-vector*-ref" +" tbl_1" +"(unsafe-fx-" +" codepoint_1" +" 10)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_3 7)" +"(if(unsafe-fx< index_3 3)" +"(if(unsafe-fx< index_3 1)" +"(let-values()" +"(unknown-error_0))" +"(if(unsafe-fx< index_3 2)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" escaped-c_0))" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\u0007))))" +"(if(unsafe-fx< index_3 4)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\backspace))" +"(if(unsafe-fx< index_3 5)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\tab))" +"(if(unsafe-fx< index_3 6)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\newline))" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\vtab))))))" +"(if(unsafe-fx< index_3 11)" +"(if(unsafe-fx< index_3 8)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\page))" +"(if(unsafe-fx< index_3 9)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\return))" +"(if(unsafe-fx< index_3 10)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\u001B))" +"(let-values()(void)))))" +"(if(unsafe-fx< index_3 13)" +"(if(unsafe-fx< index_3 12)" +"(let-values()" +"(let-values(((maybe-newline-c_0)" +"(let-values(((in_28)" +" in_37)" +"((skip-count_10)" +" 0)" +"((source_29)" +" source_26))" +"(let-values(((c_90)" +"(peek-char-or-special" +" in_28" +" skip-count_10" +" 'special" +" source_29)))" +"(if(eq?" +" c_90" +" 'special)" +"(special1.1" +" 'special)" +" c_90)))))" +"(begin" +"(if(eqv?" +" maybe-newline-c_0" +" '#\\newline)" +"(let-values()" +"(consume-char" +" in_37" +" maybe-newline-c_0))" +"(void))" +"(void))))" +"(let-values()" +"(let-values(((pos_98)" +"(accum-string-count" +" accum-str_4)))" +"(let-values((()" +"(begin" +"(accum-string-add!" +" accum-str_4" +" escaped-c_0)" +"(values))))" +"(let-values(((init-v_3)" +"(digit->number" +" escaped-c_0)))" +"(let-values(((v_201)" +"(let-values(((in24_1)" +" in_37)" +"((config25_1)" +" config_44)" +"((accum-str26_0)" +" accum-str_4)" +"((temp27_7)" +" 8)" +"((temp28_3)" +" 2)" +"((init-v29_0)" +" init-v_3)" +"((init-v30_0)" +" init-v_3))" +"(read-digits12.1" +" temp27_7" +" init-v29_0" +" temp28_3" +" init-v30_0" +" in24_1" +" config25_1" +" accum-str26_0))))" +"(begin" +"(if(<= v_201 255)" +"(void)" +"(let-values()" +"(let-values(((in31_2)" +" in_37)" +"((config32_1)" +" config_44)" +"((temp33_3)" +" \"escape sequence `~a~a` is out of range in ~a\")" +"((escaping-c34_0)" +" escaping-c_0)" +"((temp35_4)" +"(let-values(((accum-str37_0)" +" accum-str_4)" +"((config38_2)" +" config_44)" +"((pos39_0)" +" pos_98))" +"(accum-string-get!6.1" +" pos39_0" +" accum-str37_0" +" config38_2)))" +"((mode36_0)" +" mode_11))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in31_2" +" config32_1" +" temp33_3" +"(list" +" escaping-c34_0" +" temp35_4" +" mode36_0)))))" +"(set-accum-string-count!" +" accum-str_4" +" pos_98)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_201)))))))))" +"(if(unsafe-fx< index_3 14)" +"(let-values()" +"(let-values(((pos_13)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_246)" +"(let-values(((in40_1)" +" in_37)" +"((config41_1)" +" config_44)" +"((accum-str42_0)" +" accum-str_4)" +"((temp43_5)" +" 16)" +"((temp44_4)" +" 2))" +"(read-digits12.1" +" temp43_5" +" 0" +" temp44_4" +" #f" +" in40_1" +" config41_1" +" accum-str42_0))))" +"(begin" +"(if(integer? v_246)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_37" +" config_44" +" v_246" +" escaping-c_0" +" escaped-c_0)))" +"(set-accum-string-count!" +" accum-str_4" +" pos_13)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_246))))))" +"(if(unsafe-fx< index_3 15)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(eq?" +" mode_11" +" 'string)" +"(void)" +"(let-values()" +"(unknown-error_0)))" +"(values))))" +"(let-values(((pos_119)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_247)" +"(let-values(((in45_0)" +" in_37)" +"((config46_1)" +" config_44)" +"((accum-str47_0)" +" accum-str_4)" +"((temp48_2)" +" 16)" +"((temp49_2)" +" 4))" +"(read-digits12.1" +" temp48_2" +" 0" +" temp49_2" +" #f" +" in45_0" +" config46_1" +" accum-str47_0))))" +"(begin" +"(if(integer?" +" v_247)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_37" +" config_44" +" v_247" +" escaping-c_0" +" escaped-c_0)))" +"(if(let-values(((or-part_63)" +"(<" +" v_247" +" 55296)))" +"(if or-part_63" +" or-part_63" +"(>" +" v_247" +" 57343)))" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_119)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_247))))" +"(let-values()" +"(let-values(((next!_0)" +"(lambda()" +"(begin" +" 'next!" +"(let-values(((next-c_1)" +"(let-values(((in_44)" +" in_37)" +"((source_30)" +" source_26))" +"(read-char-or-special" +" in_44" +" special1.1" +" source_30))))" +"(begin" +"(if(char?" +" next-c_1)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" next-c_1))" +"(void))" +" next-c_1))))))" +"(let-values(((v2_8)" +"(let-values(((next-c_2)" +"(next!_0)))" +"(if(char=?" +" next-c_2" +" '#\\\\)" +"(let-values()" +"(let-values(((next-c_3)" +"(next!_0)))" +"(if(char=?" +" next-c_3" +" '#\\u)" +"(let-values()" +"(let-values(((v2_9)" +"(let-values(((in50_1)" +" in_37)" +"((config51_1)" +" config_44)" +"((accum-str52_1)" +" accum-str_4)" +"((temp53_4)" +" 16)" +"((temp54_2)" +" 4))" +"(read-digits12.1" +" temp53_4" +" 0" +" temp54_2" +" #f" +" in50_1" +" config51_1" +" accum-str52_1))))" +"(if(integer?" +" v2_9)" +"(let-values()" +"(if(>=" +" v2_9" +" 56320)" +"(if(<=" +" v2_9" +" 57343)" +" v2_9" +" #f)" +" #f))" +"(let-values()" +" v2_9))))" +"(let-values()" +" next-c_3))))" +"(let-values()" +" next-c_2)))))" +"(if(integer?" +" v2_8)" +"(let-values()" +"(let-values(((combined-v_0)" +"(+" +"(arithmetic-shift" +"(-" +" v_247" +" 55296)" +" 10)" +"(-" +" v2_8" +" 56320)" +" 65536)))" +"(if(>" +" combined-v_0" +" 1114111)" +"(let-values()" +"(let-values(((in55_2)" +" in_37)" +"((config56_1)" +" config_44)" +"((temp57_2)" +" \"escape sequence `~au~a` is out of range in string\")" +"((escaping-c58_0)" +" escaping-c_0)" +"((temp59_5)" +"(let-values(((accum-str60_0)" +" accum-str_4)" +"((config61_0)" +" config_44)" +"((pos62_0)" +" pos_119))" +"(accum-string-get!6.1" +" pos62_0" +" accum-str60_0" +" config61_0))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in55_2" +" config56_1" +" temp57_2" +"(list" +" escaping-c58_0" +" temp59_5))))" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_119)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" combined-v_0)))))))" +"(let-values()" +"(let-values(((in63_0)" +" in_37)" +"((config64_0)" +" config_44)" +"((v265_0)" +" v2_8)" +"((temp66_4)" +" \"bad or incomplete surrogate-style encoding at `~au~a`\")" +"((escaping-c67_0)" +" escaping-c_0)" +"((temp68_5)" +"(let-values(((accum-str69_0)" +" accum-str_4)" +"((config70_1)" +" config_44)" +"((pos71_0)" +" pos_119))" +"(accum-string-get!6.1" +" pos71_0" +" accum-str69_0" +" config70_1))))" +"(reader-error12.1" +" unsafe-undefined" +" v265_0" +" #f" +" unsafe-undefined" +" in63_0" +" config64_0" +" temp66_4" +"(list" +" escaping-c67_0" +" temp68_5))))))))))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(eq?" +" mode_11" +" 'string)" +"(void)" +"(let-values()" +"(unknown-error_0)))" +"(values))))" +"(let-values(((pos_20)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_248)" +"(let-values(((in72_0)" +" in_37)" +"((config73_0)" +" config_44)" +"((accum-str74_0)" +" accum-str_4)" +"((temp75_3)" +" 16)" +"((temp76_1)" +" 8))" +"(read-digits12.1" +" temp75_3" +" 0" +" temp76_1" +" #f" +" in72_0" +" config73_0" +" accum-str74_0))))" +"(begin" +"(if(integer?" +" v_248)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_37" +" config_44" +" v_248" +" escaping-c_0" +" escaped-c_0)))" +"(if(if(let-values(((or-part_55)" +"(<" +" v_248" +" 55296)))" +"(if or-part_55" +" or-part_55" +"(>" +" v_248" +" 57343)))" +"(<=" +" v_248" +" 1114111)" +" #f)" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_20)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_248))))" +"(let-values()" +"(let-values(((in77_1)" +" in_37)" +"((config78_1)" +" config_44)" +"((temp79_2)" +" \"escape sequence `~aU~a` is out of range in string\")" +"((escaping-c80_0)" +" escaping-c_0)" +"((temp81_2)" +"(let-values(((accum-str82_0)" +" accum-str_4)" +"((config83_0)" +" config_44)" +"((pos84_0)" +" pos_20))" +"(accum-string-get!6.1" +" pos84_0" +" accum-str82_0" +" config83_0))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in77_1" +" config78_1" +" temp79_2" +"(list" +" escaping-c80_0" +" temp81_2)))))))))))))))))" +"(loop_115)))))))" +" (if (char=? '#\\\" c_17)" +"(let-values() null)" +"(let-values()" +"(begin" +"(if(eq? mode_11 '|byte string|)" +"(let-values()" +"(if(byte?(char->integer c_17))" +"(void)" +"(let-values()" +"(let-values(((in85_0) in_37)" +"((config86_0) config_44)" +"((temp87_1)" +" \"character `~a` is out of range in byte string\")" +"((c88_0) c_17))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in85_0" +" config86_0" +" temp87_1" +"(list c88_0))))))" +"(void))" +"(accum-string-add! accum-str_4 c_17)" +"(loop_115)))))))))))" +" loop_115))" +"(values))))" +"(let-values(((str_30)" +"(if(eq? mode_11 '|byte string|)" +"(let-values(((accum-str89_0) accum-str_4)((config90_0) config_44))" +"(accum-string-get-bytes!13.1 0 accum-str89_0 config90_0))" +"(let-values(((accum-str91_0) accum-str_4)((config92_0) config_44))" +"(accum-string-get!6.1 0 accum-str91_0 config92_0)))))" +"(wrap str_30 in_37 config_44 str_30))))))))))))))" +"(define-values" +"(read-here-string)" +"(lambda(in_45 config_47)" +"(begin" +"(let-values(((source_31)(read-config-source config_47)))" +"(let-values(((open-end-line_5 open-end-col_5 open-end-pos_5)(port-next-location in_45)))" +"(let-values(((accum-str_5)(accum-string-init! config_47)))" +"(let-values(((full-terminator_0)" +"(cons" +" '#\\newline" +"((letrec-values(((loop_67)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_91)" +"(let-values(((in_46) in_45)((source_32) source_31))" +"(read-char-or-special in_46 special1.1 source_32))))" +"(if(eof-object? c_91)" +"(let-values()" +"(let-values(((in93_0) in_45)" +"((config94_0) config_47)" +"((c95_0) c_91)" +"((temp96_3)" +" \"found end-of-file after `#<<` and before a newline\"))" +"(reader-error12.1" +" unsafe-undefined" +" c95_0" +" #f" +" unsafe-undefined" +" in93_0" +" config94_0" +" temp96_3" +"(list))))" +"(if(not(char? c_91))" +"(let-values()" +"(let-values(((in97_0) in_45)" +"((config98_0) config_47)" +"((c99_0) c_91)" +"((temp100_1)" +" \"found non-character while reading `#<<`\"))" +"(reader-error12.1" +" unsafe-undefined" +" c99_0" +" #f" +" unsafe-undefined" +" in97_0" +" config98_0" +" temp100_1" +"(list))))" +"(if(char=? c_91 '#\\newline)" +"(let-values() null)" +"(let-values()(cons c_91(loop_67)))))))))))" +" loop_67)))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_53)" +"(lambda(terminator_0 terminator-accum_0)" +"(begin" +" 'loop" +"(let-values(((c_92)" +"(let-values(((in_47) in_45)((source_33) source_31))" +"(read-char-or-special in_47 special1.1 source_33))))" +"(if(eof-object? c_92)" +"(let-values()" +"(if(null? terminator_0)" +"(void)" +"(let-values()" +"(let-values(((in101_0) in_45)" +"((config102_0) config_47)" +"((c103_0) c_92)" +"((open-end-pos104_0) open-end-pos_5)" +"((temp105_2)" +" \"found end-of-file before terminating `~a`\")" +"((temp106_2)" +"(list->string(cdr full-terminator_0))))" +"(reader-error12.1" +" unsafe-undefined" +" c103_0" +" open-end-pos104_0" +" unsafe-undefined" +" in101_0" +" config102_0" +" temp105_2" +"(list temp106_2))))))" +"(if(not(char? c_92))" +"(let-values()" +"(let-values(((in107_0) in_45)" +"((config108_0) config_47)" +"((c109_0) c_92)" +"((temp110_2)" +" \"found non-character while reading `#<<`\"))" +"(reader-error12.1" +" unsafe-undefined" +" c109_0" +" #f" +" unsafe-undefined" +" in107_0" +" config108_0" +" temp110_2" +"(list))))" +"(if(if(pair? terminator_0)" +"(char=? c_92(car terminator_0))" +" #f)" +"(let-values()" +"(loop_53" +"(cdr terminator_0)" +"(cons(car terminator_0) terminator-accum_0)))" +"(if(if(null? terminator_0)(char=? c_92 '#\\newline) #f)" +"(let-values()(void))" +"(let-values()" +"(begin" +"(if(null? terminator-accum_0)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_307)" +"(reverse$1 terminator-accum_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_307)))" +"((letrec-values(((for-loop_276)" +"(lambda(lst_28)" +"(begin" +" 'for-loop" +"(if(pair? lst_28)" +"(let-values(((c_93)" +"(unsafe-car" +" lst_28))" +"((rest_177)" +"(unsafe-cdr" +" lst_28)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(accum-string-add!" +" accum-str_5" +" c_93))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_276" +" rest_177)" +"(values))))" +"(values))))))" +" for-loop_276)" +" lst_307)))" +"(void))))" +"(if(char=? c_92 '#\\newline)" +"(let-values()" +"(loop_53" +"(cdr full-terminator_0)" +"(list '#\\newline)))" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_5 c_92)" +"(loop_53 full-terminator_0 null)))))))))))))))" +" loop_53)" +"(cdr full-terminator_0)" +" null)" +"(values))))" +"(let-values(((str_31)" +"(let-values(((accum-str111_0) accum-str_5)((config112_0) config_47))" +"(accum-string-get!6.1 0 accum-str111_0 config112_0))))" +"(wrap str_31 in_45 config_47 str_31))))))))))" +"(define-values" +"(no-hex-digits)" +"(lambda(in_48 config_48 c_94 escaping-c_1 escaped-c_1)" +"(begin" +"(let-values(((in113_0) in_48)" +"((config114_0) config_48)" +"((c115_0) c_94)" +" ((temp116_1) \"no hex digit following `~a~a`\")" +"((escaping-c117_0) escaping-c_1)" +"((escaped-c118_0) escaped-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" c115_0" +" #f" +" unsafe-undefined" +" in113_0" +" config114_0" +" temp116_1" +"(list escaping-c117_0 escaped-c118_0))))))" +"(define-values" +"(read-character)" +"(lambda(in_4 config_8)" +"(begin" +"(let-values(((c_95)" +"(let-values(((in_49) in_4)((source_26)(read-config-source config_8)))" +"(read-char-or-special in_49 special1.1 source_26))))" +"(let-values(((char_0)" +"(if(eof-object? c_95)" +"(let-values()" +"(let-values(((in1_7) in_4)" +"((config2_6) config_8)" +"((c3_5) c_95)" +" ((temp4_5) \"expected a character after `#\\\\`\"))" +"(reader-error12.1" +" unsafe-undefined" +" c3_5" +" #f" +" unsafe-undefined" +" in1_7" +" config2_6" +" temp4_5" +"(list))))" +"(if(not(char? c_95))" +"(let-values()" +"(let-values(((in5_1) in_4)" +"((config6_0) config_8)" +"((c7_2) c_95)" +" ((temp8_3) \"found non-character after `#\\\\`\"))" +"(reader-error12.1" +" unsafe-undefined" +" c7_2" +" #f" +" unsafe-undefined" +" in5_1" +" config6_0" +" temp8_3" +"(list))))" +"(if(octal-digit? c_95)" +"(let-values()" +"(let-values(((c2_5)" +"(let-values(((in_50) in_4)" +"((skip-count_11) 0)" +"((source_34)(read-config-source config_8)))" +"(let-values(((c_48)" +"(peek-char-or-special" +" in_50" +" skip-count_11" +" 'special" +" source_34)))" +"(if(eq? c_48 'special)(special1.1 'special) c_48)))))" +"(if(if(char? c2_5)(octal-digit? c2_5) #f)" +"(let-values()" +"(let-values((()(begin(consume-char in_4 c2_5)(values))))" +"(let-values(((c3_6)" +"(let-values(((in_51) in_4)" +"((source_6)(read-config-source config_8)))" +"(read-char-or-special in_51 special1.1 source_6))))" +"(let-values(((v_230)" +"(if(if(char? c3_6)(octal-digit? c3_6) #f)" +"(let-values()" +"(+" +"(arithmetic-shift(digit->number c_95) 6)" +"(arithmetic-shift(digit->number c2_5) 3)" +"(digit->number c3_6)))" +"(let-values() #f))))" +"(begin" +"(if(if v_230(<= v_230 255) #f)" +"(void)" +"(let-values()" +"(let-values(((in9_2) in_4)" +"((config10_2) config_8)" +"((c311_0) c3_6)" +" ((temp12_7) \"bad character constant `#\\\\~a~a~a`\")" +"((c13_1) c_95)" +"((c214_0) c2_5)" +" ((temp15_5) (if (char? c3_6) c3_6 \"\")))" +"(reader-error12.1" +" unsafe-undefined" +" c311_0" +" #f" +" unsafe-undefined" +" in9_2" +" config10_2" +" temp12_7" +"(list c13_1 c214_0 temp15_5)))))" +"(integer->char v_230))))))" +"(let-values() c_95))))" +"(if(let-values(((or-part_80)(char=? c_95 '#\\u)))" +"(if or-part_80 or-part_80(char=? c_95 '#\\U)))" +"(let-values()" +"(let-values(((accum-str_6)(accum-string-init! config_8)))" +"(let-values(((v_35)" +"(let-values(((in16_1) in_4)" +"((config17_1) config_8)" +"((accum-str18_1) accum-str_6)" +"((temp19_5) 16)" +"((temp20_6)(if(char=? c_95 '#\\u) 4 8)))" +"(read-digits12.1" +" temp19_5" +" 0" +" temp20_6" +" #f" +" in16_1" +" config17_1" +" accum-str18_1))))" +"(if(integer? v_35)" +"(let-values()" +"(if(if(let-values(((or-part_96)(< v_35 55296)))" +"(if or-part_96 or-part_96(> v_35 57343)))" +"(<= v_35 1114111)" +" #f)" +"(let-values()" +"(begin(accum-string-abandon! accum-str_6 config_8)(integer->char v_35)))" +"(let-values()" +"(let-values(((in21_2) in_4)" +"((config22_2) config_8)" +" ((temp23_5) \"bad character constant `#\\\\u~a`\")" +"((temp24_9)" +"(let-values(((accum-str25_0) accum-str_6)" +"((config26_1) config_8))" +"(accum-string-get!6.1 0 accum-str25_0 config26_1))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in21_2" +" config22_2" +" temp23_5" +"(list temp24_9))))))" +"(let-values()(begin(accum-string-abandon! accum-str_6 config_8) c_95))))))" +"(if(char-alphabetic? c_95)" +"(let-values()" +"(let-values(((next-c_4)" +"(let-values(((in_52) in_4)" +"((skip-count_12) 0)" +"((source_10)(read-config-source config_8)))" +"(let-values(((c_15)" +"(peek-char-or-special" +" in_52" +" skip-count_12" +" 'special" +" source_10)))" +"(if(eq? c_15 'special)(special1.1 'special) c_15)))))" +"(if(if(char? next-c_4)(char-alphabetic? next-c_4) #f)" +"(let-values()" +"(let-values(((accum-str_7)(accum-string-init! config_8)))" +"(let-values((()(begin(accum-string-add! accum-str_7 c_95)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_7 next-c_4)(values))))" +"(let-values((()(begin(consume-char in_4 next-c_4)(values))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_106)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((next-c_5)" +"(let-values(((in_53)" +" in_4)" +"((skip-count_13)" +" 0)" +"((source_35)" +"(read-config-source" +" config_8)))" +"(let-values(((c_96)" +"(peek-char-or-special" +" in_53" +" skip-count_13" +" 'special" +" source_35)))" +"(if(eq?" +" c_96" +" 'special)" +"(special1.1" +" 'special)" +" c_96)))))" +"(if(if(char? next-c_5)" +"(char-alphabetic?" +" next-c_5)" +" #f)" +"(let-values()" +"(begin" +"(accum-string-add!" +" accum-str_7" +" next-c_5)" +"(consume-char" +" in_4" +" next-c_5)" +"(loop_106)))" +"(void)))))))" +" loop_106))" +"(values))))" +"(let-values(((name_68)" +"(string-foldcase" +"(let-values(((accum-str27_0) accum-str_7)" +"((config28_1) config_8))" +"(accum-string-get!6.1 0 accum-str27_0 config28_1)))))" +"(let-values(((tmp_54) name_68))" +" (if (if (equal? tmp_54 \"nul\") #t (equal? tmp_54 \"null\"))" +"(let-values() '#\\nul)" +" (if (equal? tmp_54 \"backspace\")" +"(let-values() '#\\backspace)" +" (if (equal? tmp_54 \"tab\")" +"(let-values() '#\\tab)" +" (if (if (equal? tmp_54 \"newline\")" +" #t" +" (equal? tmp_54 \"linefeed\"))" +"(let-values() '#\\newline)" +" (if (equal? tmp_54 \"vtab\")" +"(let-values() '#\\vtab)" +" (if (equal? tmp_54 \"page\")" +"(let-values() '#\\page)" +" (if (equal? tmp_54 \"return\")" +"(let-values() '#\\return)" +" (if (equal? tmp_54 \"space\")" +"(let-values() '#\\space)" +" (if (equal? tmp_54 \"rubout\")" +"(let-values() '#\\rubout)" +"(let-values()" +"(let-values(((in29_0) in_4)" +"((config30_0) config_8)" +"((temp31_3)" +" \"bad character constant `#\\\\~a`\")" +"((name32_0) name_68))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in29_0" +" config30_0" +" temp31_3" +"(list name32_0)))))))))))))))))))))" +"(let-values() c_95))))" +"(let-values() c_95))))))))" +"(wrap char_0 in_4 config_8 char_0))))))" +"(define-values" +"(read-quote)" +"(lambda(read-one_3 sym_31 desc_0 c_35 in_49 config_22)" +"(begin" +"(let-values(((wrapped-sym_0)(wrap sym_31 in_49 config_22 c_35)))" +"(let-values(((end-line_1 end-col_1 end-pos_3)(port-next-location in_49)))" +"(let-values(((e_83)(read-one_3 #f in_49 config_22)))" +"(begin" +"(if(eof-object? e_83)" +"(let-values()" +"(let-values(((in1_8) in_49)" +"((config2_7) config_22)" +"((e3_0) e_83)" +"((end-pos4_1) end-pos_3)" +" ((temp5_7) \"expected an element for ~a, found end-of-file\")" +"((desc6_0) desc_0))" +"(reader-error12.1" +" unsafe-undefined" +" e3_0" +" end-pos4_1" +" unsafe-undefined" +" in1_8" +" config2_7" +" temp5_7" +"(list desc6_0))))" +"(void))" +"(wrap(list wrapped-sym_0 e_83) in_49 config_22 #f))))))))" +"(define-values" +"(read-delimited-constant)" +"(lambda(init-c_1 can-match?_0 chars_0 val_79 in_49 config_22)" +"(begin" +"(let-values(((accum-str_8)(accum-string-init! config_22)))" +"(begin" +"(accum-string-add! accum-str_8 init-c_1)" +"((letrec-values(((loop_116)" +"(lambda(chars_1)" +"(begin" +" 'loop" +"(let-values(((c_37)" +"(let-values(((in_54) in_49)" +"((skip-count_14) 0)" +"((source_4)(read-config-source config_22)))" +"(let-values(((c_97)" +"(peek-char-or-special" +" in_54" +" skip-count_14" +" 'special" +" source_4)))" +"(if(eq? c_97 'special)(special1.1 'special) c_97)))))" +"(if(char-delimiter? c_37 config_22)" +"(let-values()" +"(if(null? chars_1)" +"(void)" +"(let-values()" +"(let-values(((in1_9) in_49)" +"((config2_8) config_22)" +"((c3_7) c_37)" +" ((temp4_6) \"bad syntax `#~a`\")" +"((temp5_8)" +"(let-values(((accum-str6_0) accum-str_8)" +"((config7_0) config_22))" +"(accum-string-get!6.1 0 accum-str6_0 config7_0))))" +"(reader-error12.1" +" unsafe-undefined" +" c3_7" +" #f" +" unsafe-undefined" +" in1_9" +" config2_8" +" temp4_6" +"(list temp5_8))))))" +"(if(null? chars_1)" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_8 c_37)" +"(let-values(((in8_1) in_49)" +"((config9_2) config_22)" +" ((temp10_5) \"bad syntax `#~a`\")" +"((temp11_5)" +"(let-values(((accum-str12_0) accum-str_8)" +"((config13_1) config_22))" +"(accum-string-get!6.1 0 accum-str12_0 config13_1))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in8_1" +" config9_2" +" temp10_5" +"(list temp11_5)))))" +"(if(if can-match?_0(char=? c_37(car chars_1)) #f)" +"(let-values()" +"(begin" +"(consume-char in_49 c_37)" +"(accum-string-add! accum-str_8 c_37)" +"(loop_116(cdr chars_1))))" +"(let-values()" +"(begin" +"(consume-char/special in_49 config_22 c_37)" +"(accum-string-add! accum-str_8 c_37)" +"(let-values(((in14_1) in_49)" +"((config15_2) config_22)" +" ((temp16_4) \"bad syntax `#~a`\")" +"((temp17_4)" +"(let-values(((accum-str18_2) accum-str_8)" +"((config19_3) config_22))" +"(accum-string-get!6.1 0 accum-str18_2 config19_3))))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in14_1" +" config15_2" +" temp16_4" +"(list temp17_4)))))))))))))" +" loop_116)" +" chars_0)" +"(wrap" +" val_79" +" in_49" +" config_22" +"(let-values(((accum-str20_0) accum-str_8)((config21_1) config_22))" +"(accum-string-get!6.1 0 accum-str20_0 config21_1))))))))" +"(define-values" +"(read-box)" +"(lambda(read-one_3 dispatch-c_1 in_5 config_15)" +"(begin" +"(let-values((()" +"(begin" +"(if(check-parameter 1/read-accept-box config_15)" +"(void)" +"(let-values()" +"(let-values(((in1_7) in_5)" +"((config2_6) config_15)" +" ((temp3_8) \"`~a&` forms not enabled\")" +"((dispatch-c4_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in1_7" +" config2_6" +" temp3_8" +"(list dispatch-c4_0)))))" +"(values))))" +"(let-values(((open-end-line_6 open-end-col_6 open-end-pos_6)(port-next-location in_5)))" +"(let-values(((e_84)(read-one_3 #f in_5(next-readtable config_15))))" +"(begin" +"(if(eof-object? e_84)" +"(let-values()" +"(let-values(((in5_1) in_5)" +"((config6_0) config_15)" +"((e7_1) e_84)" +"((open-end-pos8_0) open-end-pos_6)" +" ((temp9_6) \"expected an element for `~a&` box, found end-of-file\")" +"((dispatch-c10_0) dispatch-c_1))" +"(reader-error12.1" +" unsafe-undefined" +" e7_1" +" open-end-pos8_0" +" unsafe-undefined" +" in5_1" +" config6_0" +" temp9_6" +"(list dispatch-c10_0))))" +"(void))" +"(wrap(box e_84) in_5 config_15 #f))))))))" +"(define-values" +"(read-regexp)" +"(lambda(mode-c_0 accum-str_9 in_5 config_15)" +"(begin" +"(let-values(((c3_8)" +"(let-values(((in_55) in_5)((source_36)(read-config-source config_15)))" +"(read-char-or-special in_55 special1.1 source_36))))" +"(let-values(((no-wrap-config_0)(disable-wrapping config_15)))" +"(let-values(((rx_0)" +"(let-values(((tmp_55) c3_8))" +" (if (equal? tmp_55 '#\\\")" +"(let-values()" +"(let-values((()(begin(accum-string-abandon! accum-str_9 config_15)(values))))" +"(let-values(((str_32)" +"(let-values(((in1_8) in_5)((no-wrap-config2_0) no-wrap-config_0))" +"(read-string5.1 'string in1_8 no-wrap-config2_0))))" +"(catch-and-reraise-as-reader/proc" +" in_5" +" config_15" +"(lambda()((if(char=? mode-c_0 '#\\r) regexp pregexp) str_32))))))" +"(if(equal? tmp_55 '#\\#)" +"(let-values()" +"(let-values((()(begin(accum-string-add! accum-str_9 c3_8)(values))))" +"(let-values(((c4_2)" +"(let-values(((in_20) in_5)" +"((source_37)(read-config-source config_15)))" +"(read-char-or-special in_20 special1.1 source_37))))" +"(let-values(((tmp_56) c4_2))" +" (if (equal? tmp_56 '#\\\")" +"(let-values()" +"(let-values((()" +"(begin(accum-string-abandon! accum-str_9 config_15)(values))))" +"(let-values(((bstr_4)" +"(let-values(((in3_1) in_5)" +"((no-wrap-config4_0) no-wrap-config_0)" +"((temp5_9) '|byte string|))" +"(read-string5.1 temp5_9 in3_1 no-wrap-config4_0))))" +"(catch-and-reraise-as-reader/proc" +" in_5" +" config_15" +"(lambda()" +"((if(char=? mode-c_0 '#\\r) byte-regexp byte-pregexp) bstr_4))))))" +"(let-values()" +"(let-values(((in6_2) in_5)" +"((config7_1) config_15)" +"((c48_0) c4_2)" +" ((temp9_0) \"expected `\\\"` after `~a`\")" +"((temp10_2)" +"(let-values(((accum-str11_0) accum-str_9)" +"((config12_2) config_15))" +"(accum-string-get!6.1 0 accum-str11_0 config12_2))))" +"(reader-error12.1" +" unsafe-undefined" +" c48_0" +" #f" +" unsafe-undefined" +" in6_2" +" config7_1" +" temp9_0" +"(list temp10_2)))))))))" +"(let-values()" +"(let-values(((in13_2) in_5)" +"((config14_2) config_15)" +"((c315_0) c3_8)" +" ((temp16_7) \"expected `\\\"` or `#` after `~a`\")" +"((temp17_5)" +"(let-values(((accum-str18_3) accum-str_9)((config19_4) config_15))" +"(accum-string-get!6.1 0 accum-str18_3 config19_4))))" +"(reader-error12.1" +" unsafe-undefined" +" c315_0" +" #f" +" unsafe-undefined" +" in13_2" +" config14_2" +" temp16_7" +"(list temp17_5)))))))))" +"(wrap rx_0 in_5 config_15 #f)))))))" +"(define-values" +"(read-extension-reader)" +"(lambda(read-one_9 read-recur_0 dispatch-c_2 in_56 config_24)" +"(begin" +"(let-values(((extend-str_0)" +"(read-extension-prefix(cons dispatch-c_2 '(#\\r #\\e)) '(#\\a #\\d #\\e #\\r) in_56 config_24)))" +"(let-values((()" +"(begin" +"(if(check-parameter 1/read-accept-reader config_24)" +"(void)" +"(let-values()" +"(let-values(((in52_0) in_56)" +"((config53_1) config_24)" +" ((temp54_3) \"`~a` not enabled\")" +"((extend-str55_0) extend-str_0))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in52_0" +" config53_1" +" temp54_3" +"(list extend-str55_0)))))" +"(values))))" +"(let-values(((mod-path-wrapped_0)(read-one_9 #f in_56(next-readtable config_24))))" +"(begin" +"(if(eof-object? mod-path-wrapped_0)" +"(let-values()" +"(let-values(((in56_0) in_56)" +"((config57_1) config_24)" +"((mod-path-wrapped58_0) mod-path-wrapped_0)" +" ((temp59_6) \"expected a datum after `~a`, found end-of-file\")" +"((extend-str60_0) extend-str_0))" +"(reader-error12.1" +" unsafe-undefined" +" mod-path-wrapped58_0" +" #f" +" unsafe-undefined" +" in56_0" +" config57_1" +" temp59_6" +"(list extend-str60_0))))" +"(void))" +"(let-values(((temp47_1)((read-config-coerce config_24) #f mod-path-wrapped_0 #f))" +"((read-recur48_0) read-recur_0)" +"((in49_0) in_56)" +"((config50_0) config_24)" +"((mod-path-wrapped51_0) mod-path-wrapped_0))" +"(read-extension44.1" +" #f" +" mod-path-wrapped51_0" +" #f" +" '|#reader|" +" temp47_1" +" read-recur48_0" +" in49_0" +" config50_0)))))))))" +"(define-values" +"(read-extension-lang7.1)" +"(lambda(get-info?1_0 read-recur3_0 dispatch-c4_1 in5_2 config6_1)" +"(begin" +" 'read-extension-lang7" +"(let-values(((read-recur_1) read-recur3_0))" +"(let-values(((dispatch-c_3) dispatch-c4_1))" +"(let-values(((in_13) in5_2))" +"(let-values(((config_49) config6_1))" +"(let-values(((get-info?_0) get-info?1_0))" +"(let-values()" +"(let-values(((extend-str_1)" +"(read-extension-prefix(cons dispatch-c_3 '(#\\l)) '(#\\a #\\n #\\g) in_13 config_49)))" +"(let-values(((c_69)" +"(let-values(((in_57) in_13)((source_18)(read-config-source config_49)))" +"(read-char-or-special in_57 special1.1 source_18))))" +"(begin" +"(if(char=? c_69 '#\\space)" +"(void)" +"(let-values()" +"(let-values(((in67_1) in_13)" +"((config68_1) config_49)" +" ((temp69_2) \"expected a single space after `~a`\")" +"((extend-str70_0) extend-str_1))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in67_1" +" config68_1" +" temp69_2" +"(list extend-str70_0)))))" +"(let-values(((extend-str61_0) extend-str_1)" +"((read-recur62_0) read-recur_1)" +"((in63_1) in_13)" +"((config64_1) config_49)" +"((temp65_3) '|#lang|)" +"((get-info?66_0) get-info?_0))" +"(read-lang29.1" +" get-info?66_0" +" #f" +" temp65_3" +" extend-str61_0" +" read-recur62_0" +" in63_1" +" config64_1))))))))))))))" +"(define-values" +"(read-extension-#!16.1)" +"(lambda(get-info?10_0 read-recur12_0 dispatch-c13_0 in14_2 config15_3)" +"(begin" +" 'read-extension-#!16" +"(let-values(((read-recur_2) read-recur12_0))" +"(let-values(((dispatch-c_4) dispatch-c13_0))" +"(let-values(((in_58) in14_2))" +"(let-values(((config_50) config15_3))" +"(let-values(((get-info?_1) get-info?10_0))" +"(let-values()" +"(let-values(((c_98)" +"(let-values(((in_59) in_58)((source_38)(read-config-source config_50)))" +"(read-char-or-special in_59 special1.1 source_38))))" +"(begin" +"(if(char-lang-nonsep? c_98)" +"(void)" +"(let-values()" +"(let-values(((in78_0) in_58)" +"((config79_0) config_50)" +"((temp80_1)" +"(if(char? c_98)(string dispatch-c_4 '#\\! c_98)(string dispatch-c_4 '#\\!))))" +"(bad-syntax-error20.1 '#\\x in78_0 config79_0 temp80_1))))" +"(let-values(((temp71_1)(string dispatch-c_4 '#\\!))" +"((read-recur72_0) read-recur_2)" +"((in73_0) in_58)" +"((config74_0) config_50)" +"((c75_0) c_98)" +"((temp76_2) '|#!|)" +"((get-info?77_0) get-info?_1))" +"(read-lang29.1" +" get-info?77_0" +" c75_0" +" temp76_2" +" temp71_1" +" read-recur72_0" +" in73_0" +" config74_0)))))))))))))" +"(define-values" +"(read-lang29.1)" +"(lambda(get-info?20_0 init-c19_0 who21_0 extend-str25_0 read-recur26_0 in27_1 config28_2)" +"(begin" +" 'read-lang29" +"(let-values(((extend-str_2) extend-str25_0))" +"(let-values(((read-recur_3) read-recur26_0))" +"(let-values(((in_60) in27_1))" +"(let-values(((config_51) config28_2))" +"(let-values(((init-c_15) init-c19_0))" +"(let-values(((get-info?_2) get-info?20_0))" +"(let-values(((who_29) who21_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(check-parameter 1/read-accept-reader config_51)" +"(check-parameter 1/read-accept-lang config_51)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((in88_0) in_60)" +"((config89_0) config_51)" +" ((temp90_2) \"`~a` not enabled\")" +"((extend-str91_0) extend-str_2))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in88_0" +" config89_0" +" temp90_2" +"(list extend-str91_0)))))" +"(values))))" +"(let-values(((line_10 col_9 pos_120)(port-next-location in_60)))" +"(let-values(((accum-str_10)(accum-string-init! config_51)))" +"(let-values((()" +"(begin" +"(if init-c_15" +"(let-values()(accum-string-add! accum-str_10 init-c_15))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_117)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_9)" +"(let-values(((in_61) in_60)" +"((skip-count_15) 0)" +"((source_39)" +"(read-config-source" +" config_51)))" +"(let-values(((c_99)" +"(peek-char-or-special" +" in_61" +" skip-count_15" +" 'special" +" source_39)))" +"(if(eq? c_99 'special)" +"(special1.1 'special)" +" c_99)))))" +"(if(eof-object? c_9)" +"(let-values()(void))" +"(if(not(char? c_9))" +"(let-values()" +"(begin" +"(consume-char/special in_60 config_51 c_9)" +"(let-values(((in92_0) in_60)" +"((config93_0) config_51)" +"((c94_0) c_9)" +"((temp95_1)" +" \"found non-character while reading `#~a`\")" +"((extend-str96_0)" +" extend-str_2))" +"(reader-error12.1" +" unsafe-undefined" +" c94_0" +" #f" +" unsafe-undefined" +" in92_0" +" config93_0" +" temp95_1" +"(list extend-str96_0)))))" +"(if(char-whitespace? c_9)" +"(let-values()(void))" +"(if(let-values(((or-part_168)" +"(char-lang-nonsep? c_9)))" +"(if or-part_168" +" or-part_168" +"(char=? '#\\/ c_9)))" +"(let-values()" +"(begin" +"(consume-char in_60 c_9)" +"(accum-string-add! accum-str_10 c_9)" +"(loop_117)))" +"(let-values()" +"(begin" +"(consume-char in_60 c_9)" +"(let-values(((in97_1) in_60)" +"((config98_1) config_51)" +"((temp99_1)" +"(string-append" +" \"expected only alphanumeric, `-`, `+`, `_`, or `/`\"" +" \" characters for `~a`, found `~a`\"))" +"((extend-str100_0)" +" extend-str_2)" +"((c101_0) c_9))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in97_1" +" config98_1" +" temp99_1" +"(list" +" extend-str100_0" +" c101_0))))))))))))))" +" loop_117))" +"(values))))" +"(let-values(((lang-str_0)" +"(let-values(((accum-str102_0) accum-str_10)((config103_0) config_51))" +"(accum-string-get!6.1 0 accum-str102_0 config103_0))))" +"(let-values((()" +"(begin" +" (if (equal? lang-str_0 \"\")" +"(let-values()" +"(let-values(((in104_0) in_60)" +"((config105_0) config_51)" +"((temp106_3)" +" \"expected a non-empty sequence of alphanumeric, `-`, `+`, `_`, or `/` after `~a`\")" +"((extend-str107_0) extend-str_2))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in104_0" +" config105_0" +" temp106_3" +"(list extend-str107_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(char=? '#\\/(string-ref lang-str_0 0))" +"(let-values()" +"(let-values(((in108_0) in_60)" +"((config109_0) config_51)" +"((temp110_3)" +" \"expected a name that does not start `/` after `~a`\")" +"((extend-str111_0) extend-str_2))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in108_0" +" config109_0" +" temp110_3" +"(list extend-str111_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(char=?" +" '#\\/" +"(string-ref lang-str_0(sub1(string-length lang-str_0))))" +"(let-values()" +"(let-values(((in112_0) in_60)" +"((config113_0) config_51)" +"((temp114_4)" +" \"expected a name that does not end `/` after `~a`\")" +"((extend-str115_0) extend-str_2))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in112_0" +" config113_0" +" temp114_4" +"(list extend-str115_0))))" +"(void))" +"(values))))" +"(let-values(((submod-path_0)" +"(list* 'submod(string->symbol lang-str_0) '(reader))))" +"(let-values(((reader-path_0)" +" (string->symbol (string-append lang-str_0 \"/lang/reader\"))))" +"(let-values(((submod-path81_0) submod-path_0)" +"((reader-path82_0) reader-path_0)" +"((read-recur83_0) read-recur_3)" +"((in84_0) in_60)" +"((temp85_1)(reading-at config_51 line_10 col_9 pos_120))" +"((get-info?86_0) get-info?_2)" +"((who87_0) who_29))" +"(read-extension44.1" +" get-info?86_0" +" unsafe-undefined" +" submod-path81_0" +" who87_0" +" reader-path82_0" +" read-recur83_0" +" in84_0" +" temp85_1))))))))))))))))))))))))" +"(define-values" +"(char-lang-nonsep?)" +"(lambda(c_100)" +"(begin" +"(if(<(char->integer c_100) 128)" +"(let-values(((or-part_89)(char-alphabetic? c_100)))" +"(if or-part_89" +" or-part_89" +"(let-values(((or-part_305)(char-numeric? c_100)))" +"(if or-part_305" +" or-part_305" +"(let-values(((or-part_360)(char=? '#\\- c_100)))" +"(if or-part_360" +" or-part_360" +"(let-values(((or-part_361)(char=? '#\\+ c_100)))" +"(if or-part_361 or-part_361(char=? '#\\_ c_100)))))))))" +" #f))))" +"(define-values" +"(read-extension-prefix)" +"(lambda(already_0 wanted_0 in_62 config_52)" +"(begin" +"(let-values(((accum-str_11)(accum-string-init! config_52)))" +"(begin" +"(let-values(((lst_201) already_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_201)))" +"((letrec-values(((for-loop_208)" +"(lambda(lst_308)" +"(begin" +" 'for-loop" +"(if(pair? lst_308)" +"(let-values(((c_101)(unsafe-car lst_308))((rest_178)(unsafe-cdr lst_308)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(accum-string-add! accum-str_11 c_101))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_208 rest_178)(values))))" +"(values))))))" +" for-loop_208)" +" lst_201)))" +"(void)" +"((letrec-values(((loop_12)" +"(lambda(wanted_1)" +"(begin" +" 'loop" +"(if(null? wanted_1)" +"(void)" +"(let-values()" +"(let-values(((c_102)" +"(let-values(((in_63) in_62)" +"((source_40)(read-config-source config_52)))" +"(read-char-or-special in_63 special1.1 source_40))))" +"(begin" +"(if(char? c_102)(let-values()(accum-string-add! accum-str_11 c_102))(void))" +"(if(eqv? c_102(car wanted_1))" +"(void)" +"(let-values()" +"(let-values(((in118_0) in_62)" +"((config119_0) config_52)" +"((temp120_2)" +"(let-values(((accum-str122_0) accum-str_11)" +"((config123_0) config_52))" +"(accum-string-get!6.1 0 accum-str122_0 config123_0)))" +"((c121_0) c_102))" +"(bad-syntax-error20.1 c121_0 in118_0 config119_0 temp120_2))))" +"(loop_12(cdr wanted_1))))))))))" +" loop_12)" +" wanted_0)" +"(let-values(((accum-str116_0) accum-str_11)((config117_0) config_52))" +"(accum-string-get!6.1 0 accum-str116_0 config117_0)))))))" +"(define-values" +"(read-extension44.1)" +"(lambda(get-info?34_0" +" mod-path-wrapped33_0" +" try-first-mod-path32_0" +" who35_0" +" mod-path-datum40_0" +" read-recur41_0" +" in42_1" +" config43_1)" +"(begin" +" 'read-extension44" +"(let-values(((try-first-mod-path_0) try-first-mod-path32_0))" +"(let-values(((mod-path-datum_0) mod-path-datum40_0))" +"(let-values(((read-recur_4) read-recur41_0))" +"(let-values(((in_64) in42_1))" +"(let-values(((config_53) config43_1))" +"(let-values(((mod-path-wrapped_1)" +"(if(eq? mod-path-wrapped33_0 unsafe-undefined)" +"((read-config-coerce config_53)" +" #t" +" mod-path-datum_0" +"(let-values(((in124_0) in_64)((config125_0) config_53))" +"(port+config->srcloc49.1 #f in124_0 config125_0)))" +" mod-path-wrapped33_0)))" +"(let-values(((get-info?_3) get-info?34_0))" +"(let-values(((who_30) who35_0))" +"(let-values()" +"(let-values((()(begin(force-parameters! config_53)(values))))" +"(let-values(((guard_0)(1/current-reader-guard)))" +"(let-values(((mod-path_28)" +"(let-values(((or-part_362)" +"(if try-first-mod-path_0" +"(let-values(((mod-path_29)(guard_0 try-first-mod-path_0)))" +"(if((read-config-module-declared? config_53)" +" try-first-mod-path_0)" +" mod-path_29" +" #f))" +" #f)))" +"(if or-part_362 or-part_362(guard_0 mod-path-datum_0)))))" +"(let-values(((for-syntax?_8)(read-config-for-syntax? config_53)))" +"(let-values(((dynamic-require_2)(read-config-dynamic-require config_53)))" +"(let-values(((no-value_0)(gensym)))" +"(let-values(((extension_0)" +"(if get-info?_3" +"(let-values()" +"(dynamic-require_2 mod-path_28 'get-info(lambda() no-value_0)))" +"(let-values()" +"(dynamic-require_2" +" mod-path_28" +"(if for-syntax?_8 'read-syntax 'read))))))" +"(if(eq? extension_0 no-value_0)" +"(let-values() #f)" +"(let-values()" +"(let-values(((result-v_1)" +"(if(if for-syntax?_8(not get-info?_3) #f)" +"(let-values()" +"(if(procedure-arity-includes? extension_0 6)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +"(read-config-source config_53)" +" in_64" +" mod-path-wrapped_1" +"(read-config-line config_53)" +"(read-config-col config_53)" +"(read-config-pos config_53)))))" +"(if(procedure-arity-includes? extension_0 2)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +"(read-config-source config_53)" +" in_64))))" +"(let-values()" +"(raise-argument-error" +" who_30" +" \"(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))\"" +" extension_0)))))" +"(let-values()" +"(if(procedure-arity-includes? extension_0 5)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +" in_64" +" mod-path-wrapped_1" +"(read-config-line config_53)" +"(read-config-col config_53)" +"(read-config-pos config_53)))))" +"(if get-info?_3" +"(let-values()" +"(raise-argument-error" +" who_30" +" \"(procedure-arity-includes?/c 5)\"" +" extension_0))" +"(if(procedure-arity-includes? extension_0 1)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()(extension_0 in_64))))" +"(let-values()" +"(raise-argument-error" +" who_30" +" \"(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))\"" +" extension_0)))))))))" +"(if get-info?_3" +"(let-values()" +"(begin" +"(if(if(procedure? result-v_1)" +"(procedure-arity-includes? result-v_1 2)" +" #f)" +"(void)" +"(let-values()" +"(raise-result-error" +" 'read-language" +" \"(procedure-arity-includes?/c 2)\"" +" result-v_1)))" +" result-v_1))" +"(if(1/special-comment? result-v_1)" +"(let-values()(read-recur_4 #f in_64 config_53))" +"(let-values()" +"(coerce result-v_1 in_64 config_53))))))))))))))))))))))))))" +"(define-values" +"(read-language/get-info)" +"(lambda(read-one_3 in_2 config_7 fail-k_5)" +"(begin" +"(let-values(((c_25)(read-char/skip-whitespace-and-comments #f read-one_3 in_2 config_7)))" +"(let-values(((line_8 col_7 pos_116)(port-next-location* in_2 c_25)))" +"(let-values(((l-config_0)" +"(override-parameter 1/read-accept-reader(reading-at config_7 line_8 col_7 pos_116) #t)))" +"(if(not(eqv? c_25 '#\\#))" +" (let-values () (if fail-k_5 (fail-k_5) (lang-error in_2 l-config_0 \"\" c_25)))" +"(let-values()" +"(let-values(((c2_6)" +"(let-values(((in_54) in_2)((source_41)(read-config-source l-config_0)))" +"(read-char-or-special in_54 special1.1 source_41))))" +"(if(eqv? c2_6 '#\\l)" +"(let-values()" +"(let-values(((read-one1_0) read-one_3)" +"((c2_7) c_25)" +"((in3_2) in_2)" +"((l-config4_0) l-config_0)" +"((temp5_3) #t))" +"(read-extension-lang7.1 temp5_3 read-one1_0 c2_7 in3_2 l-config4_0)))" +"(if(eqv? c2_6 '#\\!)" +"(let-values()" +"(let-values(((read-one6_0) read-one_3)" +"((c7_3) c_25)" +"((in8_2) in_2)" +"((l-config9_0) l-config_0)" +"((temp10_6) #t))" +"(read-extension-#!16.1 temp10_6 read-one6_0 c7_3 in8_2 l-config9_0)))" +"(let-values()" +"(if fail-k_5(fail-k_5)(lang-error in_2 l-config_0(string c_25) c2_6))))))))))))))" +"(define-values" +"(lang-error)" +"(lambda(in_51 config_54 prefix_7 c_67)" +"(begin" +"(let-values(((add-prefix_0)" +"(lambda(s_78)" +"(begin" +" 'add-prefix" +" (if (string=? prefix_7 \"\") (format \"`~a` followed by ~a\" prefix_7 s_78) s_78)))))" +"(let-values(((in11_1) in_51)" +"((config12_3) config_54)" +"((c13_2) c_67)" +"((temp14_5) 'read-language)" +"((temp15_6)" +"(string-append" +" \"expected (after whitespace and comments) `#lang ` or `#!` followed\"" +" \" immediately by a language name, found ~a\"))" +"((temp16_8)" +"(if(eof-object? c_67)" +" (let-values () (add-prefix_0 \"end-of-file\"))" +"(if(not(char? c_67))" +" (let-values () (add-prefix_0 \"non-character\"))" +" (let-values () (format \"`~a~a`\" prefix_7 c_67))))))" +"(reader-error12.1 unsafe-undefined c13_2 #f temp14_5 in11_1 config12_3 temp15_6(list temp16_8)))))))" +"(define-values" +"(read30.1)" +"(lambda(coerce12_1" +" coerce-key13_1" +" dynamic-require10_2" +" for-syntax?8_0" +" init-c2_0" +" keep-comment?14_1" +" local-graph?6_0" +" module-declared?11_1" +" next-readtable3_0" +" read-compiled9_1" +" readtable4_0" +" recursive?5_0" +" source7_0" +" wrap1_0" +" in29_1)" +"(begin" +" 'read30" +"(let-values(((in_20) in29_1))" +"(let-values(((wrap_7) wrap1_0))" +"(let-values(((init-c_16) init-c2_0))" +"(let-values(((next-readtable_3)" +"(if(eq? next-readtable3_0 unsafe-undefined)(1/current-readtable) next-readtable3_0)))" +"(let-values(((readtable_3)(if(eq? readtable4_0 unsafe-undefined) next-readtable_3 readtable4_0)))" +"(let-values(((recursive?_0) recursive?5_0))" +"(let-values(((local-graph?_1) local-graph?6_0))" +"(let-values(((source_5) source7_0))" +"(let-values(((for-syntax?_9) for-syntax?8_0))" +"(let-values(((read-compiled_2) read-compiled9_1))" +"(let-values(((dynamic-require_3) dynamic-require10_2))" +"(let-values(((module-declared?_2) module-declared?11_1))" +"(let-values(((coerce_2) coerce12_1))" +"(let-values(((coerce-key_2) coerce-key13_1))" +"(let-values(((keep-comment?_3)" +"(if(eq? keep-comment?14_1 unsafe-undefined)" +" recursive?_0" +" keep-comment?14_1)))" +"(let-values()" +"(let-values(((config_55)" +"(let-values(((c1_31)(if recursive?_0(current-read-config) #f)))" +"(if c1_31" +"((lambda(config_56)" +"(let-values(((config52_0) config_56)" +"((for-syntax?53_0) for-syntax?_9)" +"((wrap54_0) wrap_7)" +"((readtable55_0) readtable_3)" +"((next-readtable56_0) next-readtable_3)" +"((local-graph?57_0) local-graph?_1)" +"((keep-comment?58_0) keep-comment?_3))" +"(read-config-update42.1" +" for-syntax?53_0" +" keep-comment?58_0" +" next-readtable56_0" +" readtable55_0" +" local-graph?57_0" +" wrap54_0" +" config52_0)))" +" c1_31)" +"(let-values()" +"(let-values(((readtable59_1) readtable_3)" +"((next-readtable60_1) next-readtable_3)" +"((source61_0) source_5)" +"((for-syntax?62_0) for-syntax?_9)" +"((wrap63_0) wrap_7)" +"((read-compiled64_0) read-compiled_2)" +"((dynamic-require65_0) dynamic-require_3)" +"((module-declared?66_0) module-declared?_2)" +"((coerce67_0) coerce_2)" +"((coerce-key68_0) coerce-key_2)" +"((keep-comment?69_0) keep-comment?_3))" +"(make-read-config26.1" +" coerce67_0" +" coerce-key68_0" +" dynamic-require65_0" +" for-syntax?62_0" +" keep-comment?69_0" +" module-declared?66_0" +" next-readtable60_1" +" read-compiled64_0" +" readtable59_1" +" source61_0" +" wrap63_0)))))))" +"(let-values(((v_34)(read-one init-c_16 in_20 config_55)))" +"(if(if(let-values(((or-part_9)(not recursive?_0)))" +"(if or-part_9 or-part_9 local-graph?_1))" +"(read-config-state-graph(read-config-st config_55))" +" #f)" +"(let-values()" +"(catch-and-reraise-as-reader/proc" +" #f" +" config_55" +"(lambda()(make-reader-graph v_34))))" +"(if(if recursive?_0" +"(if(not local-graph?_1)" +"(if(not for-syntax?_9)" +"(if(not(eof-object? v_34))(not(1/special-comment? v_34)) #f)" +" #f)" +" #f)" +" #f)" +"(let-values()(begin(get-graph-hash config_55) v_34))" +"(let-values() v_34))))))))))))))))))))))))" +"(define-values" +"(read-language49.1)" +"(lambda(coerce38_0" +" coerce-key39_0" +" dynamic-require36_0" +" for-syntax?33_0" +" module-declared?37_0" +" read-compiled35_0" +" wrap34_0" +" in47_2" +" fail-k48_0)" +"(begin" +" 'read-language49" +"(let-values(((in_65) in47_2))" +"(let-values(((fail-k_6) fail-k48_0))" +"(let-values(((for-syntax?_10) for-syntax?33_0))" +"(let-values(((wrap_8) wrap34_0))" +"(let-values(((read-compiled_3) read-compiled35_0))" +"(let-values(((dynamic-require_4) dynamic-require36_0))" +"(let-values(((module-declared?_3) module-declared?37_0))" +"(let-values(((coerce_3) coerce38_0))" +"(let-values(((coerce-key_3) coerce-key39_0))" +"(let-values()" +"(let-values(((config_57)" +"(let-values(((temp70_3) #f)" +"((temp71_2) #f)" +"((for-syntax?72_0) for-syntax?_10)" +"((wrap73_0) wrap_8)" +"((read-compiled74_0) read-compiled_3)" +"((dynamic-require75_0) dynamic-require_4)" +"((module-declared?76_0) module-declared?_3)" +"((coerce77_0) coerce_3)" +"((coerce-key78_0) coerce-key_3))" +"(make-read-config26.1" +" coerce77_0" +" coerce-key78_0" +" dynamic-require75_0" +" for-syntax?72_0" +" #f" +" module-declared?76_0" +" temp71_2" +" read-compiled74_0" +" temp70_3" +" #f" +" wrap73_0))))" +"(let-values(((l-config_1)(override-parameter 1/read-accept-reader config_57 #f)))" +"(read-language/get-info read-undotted in_65 config_57 fail-k_6))))))))))))))))" +"(define-values" +"(read-one)" +"(lambda(init-c_17 in_62 config_52)" +"(begin" +"(if(not(check-parameter 1/read-cdot config_52))" +"(let-values()(read-undotted init-c_17 in_62 config_52))" +"(if(check-parameter 1/read-cdot config_52)" +"(let-values()" +"(let-values(((line_11 col_10 pos_92)(port-next-location in_62)))" +"(let-values(((v_110)(read-undotted init-c_17 in_62 config_52)))" +"(if(1/special-comment? v_110)" +"(let-values() v_110)" +"(let-values()" +"((letrec-values(((loop_118)" +"(lambda(v_112)" +"(begin" +" 'loop" +"(let-values(((c_103)" +"(let-values(((in_66) in_62)" +"((skip-count_16) 0)" +"((source_40)(read-config-source config_52)))" +"(let-values(((c_104)" +"(peek-char-or-special" +" in_66" +" skip-count_16" +" 'special" +" source_40)))" +"(if(eq? c_104 'special)(special1.1 'special) c_104)))))" +"(let-values(((ec_9)(effective-char c_103 config_52)))" +"(if(not(char? ec_9))" +"(let-values() v_112)" +"(if(char-whitespace? ec_9)" +"(let-values()(begin(consume-char in_62 c_103)(loop_118 v_112)))" +"(if(char=? ec_9 '#\\.)" +"(let-values()" +"(let-values(((dot-line_2 dot-col_2 dot-pos_5)" +"(port-next-location in_62)))" +"(let-values((()(begin(consume-char in_62 c_103)(values))))" +"(let-values(((pos-config_0)" +"(reading-at" +" config_52" +" dot-line_2" +" dot-col_2" +" dot-pos_5)))" +"(let-values(((cdot_0)" +"(wrap '#%dot in_62 pos-config_0 '#\\.)))" +"(let-values(((post-v_0)" +"(read-undotted #f in_62 config_52)))" +"(begin" +"(if(eof-object? post-v_0)" +"(let-values()" +"(let-values(((in79_0) in_62)" +"((pos-config80_0) pos-config_0)" +"((eof81_0) eof)" +"((temp82_2)" +" \"expected a datum after cdot, found end-of-file\"))" +"(reader-error12.1" +" unsafe-undefined" +" eof81_0" +" #f" +" unsafe-undefined" +" in79_0" +" pos-config80_0" +" temp82_2" +"(list))))" +"(void))" +"(loop_118" +"(wrap" +"(list cdot_0 v_112 post-v_0)" +" in_62" +"(reading-at config_52 line_11 col_10 pos_92)" +" '#\\.)))))))))" +"(let-values() v_112))))))))))" +" loop_118)" +" v_110))))))" +"(void))))))" +"(define-values" +"(read-undotted)" +"(lambda(init-c_18 in_67 config_58)" +"(begin" +"(let-values(((c_31)(read-char/skip-whitespace-and-comments init-c_18 read-one in_67 config_58)))" +"(let-values(((line_12 col_11 pos_121)(port-next-location* in_67 c_31)))" +"(if(eof-object? c_31)" +"(let-values() eof)" +"(if(not(char? c_31))" +"(let-values()" +"(let-values(((v_249)(special-value c_31)))" +"(if(1/special-comment? v_249)" +"(let-values()(if(read-config-keep-comment? config_58) v_249(read-undotted #f in_67 config_58)))" +"(let-values()(coerce v_249 in_67(reading-at config_58 line_12 col_11 pos_121))))))" +"(let-values(((c2_8)(readtable-handler config_58 c_31)))" +"(if c2_8" +"((lambda(handler_3)" +"(let-values(((v_250)(readtable-apply handler_3 c_31 in_67 config_58 line_12 col_11 pos_121)))" +"(retry-special-comment v_250 in_67 config_58)))" +" c2_8)" +"(let-values()" +"(let-values(((ec_10)(effective-char c_31 config_58)))" +"(let-values((()" +"(begin" +"(if(not(char-closer? ec_10 config_58))" +"(let-values()(track-indentation! config_58 line_12 col_11))" +"(void))" +"(values))))" +"(let-values(((r-config_0)(reading-at(discard-comment config_58) line_12 col_11 pos_121)))" +"(let-values(((tmp_57) ec_10))" +"(let-values(((index_4)" +"(if(char? tmp_57)" +"(let-values(((codepoint_2)(char->integer tmp_57)))" +"(if(if(unsafe-fx>= codepoint_2 34)(unsafe-fx< codepoint_2 126) #f)" +"(if(unsafe-fx< codepoint_2 91)" +"(if(unsafe-fx< codepoint_2 40)" +"(let-values(((tbl_2) '#(11 1 0 0 0 2)))" +"(unsafe-vector*-ref tbl_2(unsafe-fx- codepoint_2 34)))" +"(if(unsafe-fx< codepoint_2 42)" +"(let-values(((tbl_3) '#(5 6)))" +"(unsafe-vector*-ref tbl_3(unsafe-fx- codepoint_2 40)))" +"(if(unsafe-fx< codepoint_2 44)" +" 0" +"(if(unsafe-fx< codepoint_2 45) 4 0))))" +"(let-values(((tbl_4)" +" '#(7" +" 0" +" 8" +" 0" +" 0" +" 3" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 9" +" 12" +" 10)))" +"(unsafe-vector*-ref tbl_4(unsafe-fx- codepoint_2 91))))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_4 6)" +"(if(unsafe-fx< index_4 2)" +"(if(unsafe-fx< index_4 1)" +"(let-values()" +"(let-values(((v_251)" +"(let-values(((c83_0) c_31)" +"((in84_1) in_67)" +"((r-config85_0) r-config_0)" +"((temp86_3)" +"(if(let-values(((or-part_280)(eq? c_31 ec_10)))" +"(if or-part_280" +" or-part_280" +"(if(<(char->integer ec_10) 128)" +"(char-numeric? ec_10)" +" #f)))" +" 'symbol-or-number" +" 'symbol/indirect)))" +"(read-symbol-or-number8.1" +" #f" +" temp86_3" +" c83_0" +" in84_1" +" r-config85_0))))" +"(retry-special-comment v_251 in_67 config_58)))" +"(let-values()(read-dispatch c_31 in_67 r-config_0 config_58)))" +"(if(unsafe-fx< index_4 3)" +" (let-values () (read-quote read-one 'quote \"quoting \\\"'\\\"\" c_31 in_67 r-config_0))" +"(if(unsafe-fx< index_4 4)" +"(let-values()" +"(if(check-parameter 1/read-accept-quasiquote config_58)" +"(let-values()" +"(read-quote" +" read-one" +" 'quasiquote" +" \"quasiquoting \\\"`\\\"\"" +" c_31" +" in_67" +" r-config_0))" +"(let-values()" +"(let-values(((in87_0) in_67)" +"((r-config88_0) r-config_0)" +" ((temp89_3) \"illegal use of `~a`\")" +"((c90_0) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in87_0" +" r-config88_0" +" temp89_3" +"(list c90_0))))))" +"(if(unsafe-fx< index_4 5)" +"(let-values()" +"(if(check-parameter 1/read-accept-quasiquote config_58)" +"(let-values()" +"(let-values(((c2_9)" +"(let-values(((in_68) in_67)" +"((skip-count_17) 0)" +"((source_42)(read-config-source config_58)))" +"(let-values(((c_105)" +"(peek-char-or-special" +" in_68" +" skip-count_17" +" 'special" +" source_42)))" +"(if(eq? c_105 'special)" +"(special1.1 'special)" +" c_105)))))" +"(if(eqv? c2_9 '#\\@)" +"(begin" +"(consume-char in_67 c2_9)" +"(read-quote" +" read-one" +" 'unquote-splicing" +" \"unquoting `,@`\"" +" c_31" +" in_67" +" r-config_0))" +"(read-quote" +" read-one" +" 'unquote" +" \"unquoting `,`\"" +" c_31" +" in_67" +" r-config_0))))" +"(let-values()" +"(let-values(((in91_0) in_67)" +"((r-config92_0) r-config_0)" +" ((temp93_2) \"illegal use of `~a`\")" +"((c94_1) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in91_0" +" r-config92_0" +" temp93_2" +"(list c94_1))))))" +"(let-values()" +"(wrap" +"(let-values(((read-one95_0) read-one)" +"((ec96_0) ec_10)" +"((temp97_2) '#\\()" +"((temp98_3) '#\\))" +"((in99_0) in_67)" +"((r-config100_0) r-config_0)" +"((temp101_0) #t))" +"(read-unwrapped-sequence17.1" +" 'all" +" unsafe-undefined" +" unsafe-undefined" +" temp101_0" +" unsafe-undefined" +" read-one95_0" +" ec96_0" +" temp97_2" +" temp98_3" +" in99_0" +" r-config100_0))" +" in_67" +" r-config_0" +" ec_10))))))" +"(if(unsafe-fx< index_4 9)" +"(if(unsafe-fx< index_4 7)" +"(let-values()" +"(let-values(((in102_0) in_67)" +"((r-config103_0) r-config_0)" +" ((temp104_2) \"~a\")" +"((temp105_3)" +"(indentation-unexpected-closer-message ec_10 c_31 r-config_0)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in102_0" +" r-config103_0" +" temp104_2" +"(list temp105_3))))" +"(if(unsafe-fx< index_4 8)" +"(let-values()" +"(if(let-values(((or-part_363)" +"(check-parameter 1/read-square-bracket-as-paren config_58)))" +"(if or-part_363" +" or-part_363" +"(check-parameter 1/read-square-bracket-with-tag config_58)))" +"(let-values()" +"(wrap" +"(let-values(((read-one106_0) read-one)" +"((ec107_0) ec_10)" +"((temp108_2) '#\\[)" +"((temp109_1) '#\\])" +"((in110_0) in_67)" +"((r-config111_0) r-config_0)" +"((temp112_2) #t))" +"(read-unwrapped-sequence17.1" +" 'all" +" unsafe-undefined" +" unsafe-undefined" +" temp112_2" +" unsafe-undefined" +" read-one106_0" +" ec107_0" +" temp108_2" +" temp109_1" +" in110_0" +" r-config111_0))" +" in_67" +" r-config_0" +" ec_10))" +"(let-values()" +"(let-values(((in113_1) in_67)" +"((r-config114_0) r-config_0)" +" ((temp115_0) \"illegal use of `~a`\")" +"((c116_0) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in113_1" +" r-config114_0" +" temp115_0" +"(list c116_0))))))" +"(let-values()" +"(if(let-values(((or-part_94)" +"(check-parameter 1/read-square-bracket-as-paren config_58)))" +"(if or-part_94" +" or-part_94" +"(check-parameter 1/read-square-bracket-with-tag config_58)))" +"(let-values()" +"(let-values(((in117_0) in_67)" +"((r-config118_0) r-config_0)" +" ((temp119_2) \"~a\")" +"((temp120_3)" +"(indentation-unexpected-closer-message" +" ec_10" +" c_31" +" r-config_0)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in117_0" +" r-config118_0" +" temp119_2" +"(list temp120_3))))" +"(let-values()" +"(let-values(((in121_0) in_67)" +"((r-config122_0) r-config_0)" +" ((temp123_2) \"illegal use of `~a`\")" +"((c124_0) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in121_0" +" r-config122_0" +" temp123_2" +"(list c124_0))))))))" +"(if(unsafe-fx< index_4 10)" +"(let-values()" +"(if(let-values(((or-part_281)" +"(check-parameter 1/read-curly-brace-as-paren config_58)))" +"(if or-part_281" +" or-part_281" +"(check-parameter 1/read-curly-brace-with-tag config_58)))" +"(let-values()" +"(wrap" +"(let-values(((read-one125_0) read-one)" +"((ec126_0) ec_10)" +"((temp127_4) '#\\{)" +"((temp128_3) '#\\})" +"((in129_0) in_67)" +"((r-config130_0) r-config_0)" +"((temp131_1) #t))" +"(read-unwrapped-sequence17.1" +" 'all" +" unsafe-undefined" +" unsafe-undefined" +" temp131_1" +" unsafe-undefined" +" read-one125_0" +" ec126_0" +" temp127_4" +" temp128_3" +" in129_0" +" r-config130_0))" +" in_67" +" r-config_0" +" ec_10))" +"(let-values()" +"(let-values(((in132_0) in_67)" +"((r-config133_0) r-config_0)" +" ((temp134_2) \"illegal use of `~a`\")" +"((c135_0) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in132_0" +" r-config133_0" +" temp134_2" +"(list c135_0))))))" +"(if(unsafe-fx< index_4 11)" +"(let-values()" +"(if(let-values(((or-part_282)" +"(check-parameter 1/read-curly-brace-as-paren config_58)))" +"(if or-part_282" +" or-part_282" +"(check-parameter 1/read-curly-brace-with-tag config_58)))" +"(let-values()" +"(let-values(((in136_0) in_67)" +"((r-config137_0) r-config_0)" +" ((temp138_1) \"~a\")" +"((temp139_1)" +"(indentation-unexpected-closer-message" +" ec_10" +" c_31" +" r-config_0)))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in136_0" +" r-config137_0" +" temp138_1" +"(list temp139_1))))" +"(let-values()" +"(let-values(((in140_0) in_67)" +"((r-config141_0) r-config_0)" +" ((temp142_1) \"illegal use of `~a`\")" +"((c143_0) c_31))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in140_0" +" r-config141_0" +" temp142_1" +"(list c143_0))))))" +"(if(unsafe-fx< index_4 12)" +"(let-values()" +"(let-values(((in144_0) in_67)((r-config145_0) r-config_0))" +"(read-string5.1 'string in144_0 r-config145_0)))" +"(let-values()" +"(let-values(((c146_0) c_31)" +"((in147_0) in_67)" +"((r-config148_0) r-config_0)" +"((temp149_1) 'symbol))" +"(read-symbol-or-number8.1" +" #f" +" temp149_1" +" c146_0" +" in147_0" +" r-config148_0)))))))))))))))))))))))" +"(define-values" +"(read-dispatch)" +"(lambda(dispatch-c_5 in_69 config_59 orig-config_1)" +"(begin" +"(let-values(((c_106)" +"(let-values(((in_70) in_69)((source_43)(read-config-source config_59)))" +"(read-char-or-special in_70 special1.1 source_43))))" +"(if(eof-object? c_106)" +"(let-values()" +"(let-values(((in150_0) in_69)" +"((config151_0) config_59)" +"((c152_0) c_106)" +" ((temp153_1) \"bad syntax `~a`\")" +"((dispatch-c154_0) dispatch-c_5))" +"(reader-error12.1" +" unsafe-undefined" +" c152_0" +" #f" +" unsafe-undefined" +" in150_0" +" config151_0" +" temp153_1" +"(list dispatch-c154_0))))" +"(if(not(char? c_106))" +"(let-values()" +"(let-values(((in155_0) in_69)" +"((config156_0) config_59)" +"((c157_0) c_106)" +" ((temp158_0) \"bad syntax `~a`\")" +"((dispatch-c159_0) dispatch-c_5))" +"(reader-error12.1" +" unsafe-undefined" +" c157_0" +" #f" +" unsafe-undefined" +" in155_0" +" config156_0" +" temp158_0" +"(list dispatch-c159_0))))" +"(let-values(((c3_9)(readtable-dispatch-handler orig-config_1 c_106)))" +"(if c3_9" +"((lambda(handler_4)" +"(let-values(((line_13)(read-config-line config_59)))" +"(let-values(((col_12)(read-config-col config_59)))" +"(let-values(((pos_122)(read-config-pos config_59)))" +"(let-values(((v_252)" +"(readtable-apply handler_4 c_106 in_69 config_59 line_13 col_12 pos_122)))" +"(retry-special-comment v_252 in_69 orig-config_1))))))" +" c3_9)" +"(let-values()" +"(let-values()" +"(let-values(((tmp_58) c_106))" +"(let-values(((index_5)" +"(if(char? tmp_58)" +"(let-values(((codepoint_3)(char->integer tmp_58)))" +"(if(if(unsafe-fx>= codepoint_3 33)(unsafe-fx< codepoint_3 127) #f)" +"(let-values(((tbl_5)" +" '#(34" +" 11" +" 0" +" 0" +" 13" +" 6" +" 7" +" 2" +" 0" +" 0" +" 0" +" 9" +" 0" +" 0" +" 0" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 14" +" 0" +" 12" +" 0" +" 0" +" 0" +" 0" +" 0" +" 22" +" 29" +" 25" +" 18" +" 16" +" 0" +" 30" +" 20" +" 0" +" 0" +" 0" +" 0" +" 0" +" 24" +" 0" +" 0" +" 0" +" 0" +" 15" +" 0" +" 0" +" 0" +" 28" +" 0" +" 0" +" 3" +" 10" +" 0" +" 0" +" 0" +" 8" +" 0" +" 26" +" 29" +" 21" +" 17" +" 16" +" 0" +" 30" +" 19" +" 0" +" 0" +" 33" +" 0" +" 0" +" 23" +" 32" +" 0" +" 31" +" 5" +" 15" +" 0" +" 0" +" 0" +" 27" +" 0" +" 0" +" 4" +" 0" +" 0" +" 35)))" +"(unsafe-vector*-ref tbl_5(unsafe-fx- codepoint_3 33)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_5 17)" +"(if(unsafe-fx< index_5 8)" +"(if(unsafe-fx< index_5 3)" +"(if(unsafe-fx< index_5 1)" +"(let-values()" +"(let-values(((in160_0) in_69)" +"((config161_0) config_59)" +" ((temp162_2) \"bad syntax `~a~a`\")" +"((dispatch-c163_0) dispatch-c_5)" +"((c164_0) c_106))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in160_0" +" config161_0" +" temp162_2" +"(list dispatch-c163_0 c164_0))))" +"(if(unsafe-fx< index_5 2)" +"(let-values()(read-vector-or-graph read-one dispatch-c_5 c_106 in_69 config_59))" +"(let-values()" +"(let-values(((read-one165_0) read-one)" +"((temp166_1) '#\\()" +"((temp167_0) '#\\()" +"((temp168_2) '#\\))" +"((in169_0) in_69)" +"((config170_0) config_59))" +"(read-vector11.1" +" #f" +" 'any" +" read-one165_0" +" temp166_1" +" temp167_0" +" temp168_2" +" in169_0" +" config170_0)))))" +"(if(unsafe-fx< index_5 5)" +"(if(unsafe-fx< index_5 4)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_59)" +"(let-values()" +"(let-values(((read-one171_0) read-one)" +"((temp172_1) '#\\[)" +"((temp173_1) '#\\[)" +"((temp174_0) '#\\])" +"((in175_0) in_69)" +"((config176_0) config_59))" +"(read-vector11.1" +" #f" +" 'any" +" read-one171_0" +" temp172_1" +" temp173_1" +" temp174_0" +" in175_0" +" config176_0)))" +"(let-values()" +"(let-values(((in177_0) in_69)" +"((config178_0) config_59)" +" ((temp179_0) (format \"~a~a\" dispatch-c_5 c_106)))" +"(bad-syntax-error20.1 '#\\x in177_0 config178_0 temp179_0)))))" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_59)" +"(let-values()" +"(let-values(((read-one180_0) read-one)" +"((temp181_0) '#\\{)" +"((temp182_0) '#\\{)" +"((temp183_0) '#\\})" +"((in184_0) in_69)" +"((config185_0) config_59))" +"(read-vector11.1" +" #f" +" 'any" +" read-one180_0" +" temp181_0" +" temp182_0" +" temp183_0" +" in184_0" +" config185_0)))" +"(let-values()" +"(let-values(((in186_0) in_69)" +"((config187_0) config_59)" +" ((temp188_0) (format \"~a~a\" dispatch-c_5 c_106)))" +"(bad-syntax-error20.1 '#\\x in186_0 config187_0 temp188_0))))))" +"(if(unsafe-fx< index_5 6)" +"(let-values()(read-struct read-one dispatch-c_5 in_69 config_59))" +"(if(unsafe-fx< index_5 7)" +"(let-values()(read-box read-one dispatch-c_5 in_69 config_59))" +" (let-values () (read-quote read-one 'syntax \"quoting #'\" c_106 in_69 config_59))))))" +"(if(unsafe-fx< index_5 12)" +"(if(unsafe-fx< index_5 9)" +"(let-values()" +" (read-quote read-one 'quasisyntax \"quasiquoting #`\" c_106 in_69 config_59))" +"(if(unsafe-fx< index_5 10)" +"(let-values()" +"(let-values(((c2_10)" +"(let-values(((in_71) in_69)" +"((skip-count_18) 0)" +"((source_44)(read-config-source config_59)))" +"(let-values(((c_107)" +"(peek-char-or-special" +" in_71" +" skip-count_18" +" 'special" +" source_44)))" +"(if(eq? c_107 'special)(special1.1 'special) c_107)))))" +"(if(eqv? c2_10 '#\\@)" +"(begin" +"(consume-char in_69 c2_10)" +"(read-quote" +" read-one" +" 'unsyntax-splicing" +" \"unquoting #,@\"" +" c_106" +" in_69" +" config_59))" +" (read-quote read-one 'unsyntax \"unquoting #,\" c_106 in_69 config_59))))" +"(if(unsafe-fx< index_5 11)" +"(let-values()(read-character in_69 config_59))" +"(let-values()" +"(let-values(((in189_0) in_69)" +"((config190_0) config_59)" +"((temp191_0) '|byte string|))" +"(read-string5.1 temp191_0 in189_0 config190_0))))))" +"(if(unsafe-fx< index_5 14)" +"(if(unsafe-fx< index_5 13)" +"(let-values()" +"(let-values(((c2_11)" +"(let-values(((in_72) in_69)" +"((skip-count_19) 0)" +"((source_45)(read-config-source config_59)))" +"(let-values(((c_108)" +"(peek-char-or-special" +" in_72" +" skip-count_19" +" 'special" +" source_45)))" +"(if(eq? c_108 'special)(special1.1 'special) c_108)))))" +"(if(eqv? '#\\< c2_11)" +"(let-values()" +"(begin(consume-char in_69 '#\\<)(read-here-string in_69 config_59)))" +"(let-values()" +"(let-values(((in192_0) in_69)" +"((config193_0) config_59)" +"((c2194_0) c2_11)" +" ((temp195_0) \"bad syntax `~a<`\")" +"((dispatch-c196_0) dispatch-c_5))" +"(reader-error12.1" +" unsafe-undefined" +" c2194_0" +" #f" +" unsafe-undefined" +" in192_0" +" config193_0" +" temp195_0" +"(list dispatch-c196_0)))))))" +"(let-values()" +"(let-values(((c197_0) c_106)" +"((in198_0) in_69)" +"((config199_0) config_59)" +"((dispatch-c200_0) dispatch-c_5)" +"((temp201_1) 'symbol))" +"(read-symbol-or-number8.1 dispatch-c200_0 temp201_1 c197_0 in198_0 config199_0))))" +"(if(unsafe-fx< index_5 15)" +"(let-values()" +"(let-values(((temp202_0) #f)" +"((in203_0) in_69)" +"((config204_0) config_59)" +"((temp205_0) 'keyword))" +"(read-symbol-or-number8.1 #f temp205_0 temp202_0 in203_0 config204_0)))" +"(if(unsafe-fx< index_5 16)" +"(let-values()" +"(let-values(((c2_12)" +"(let-values(((in_73) in_69)" +"((skip-count_20) 0)" +"((source_46)(read-config-source config_59)))" +"(let-values(((c_109)" +"(peek-char-or-special" +" in_73" +" skip-count_20" +" 'special" +" source_46)))" +"(if(eq? c_109 'special)(special1.1 'special) c_109)))))" +"(if(char-delimiter? c2_12 config_59)" +"(let-values()(wrap #t in_69 config_59 c_106))" +"(let-values()" +"(read-delimited-constant" +" c_106" +"(char=? c_106 '#\\t)" +" '(#\\r #\\u #\\e)" +" #t" +" in_69" +" config_59)))))" +"(let-values()" +"(let-values(((c2_13)" +"(let-values(((in_74) in_69)" +"((skip-count_21) 0)" +"((source_47)(read-config-source config_59)))" +"(let-values(((c_110)" +"(peek-char-or-special" +" in_74" +" skip-count_21" +" 'special" +" source_47)))" +"(if(eq? c_110 'special)(special1.1 'special) c_110)))))" +"(if(char-delimiter? c2_13 config_59)" +"(let-values()(wrap #f in_69 config_59 c_106))" +"(if(let-values(((or-part_364)(char=? c2_13 '#\\x)))" +"(if or-part_364 or-part_364(char=? c2_13 '#\\l)))" +"(let-values()" +"(read-fixnum-or-flonum-vector" +" read-one" +" dispatch-c_5" +" c_106" +" c2_13" +" in_69" +" config_59))" +"(let-values()" +"(read-delimited-constant" +" c_106" +"(char=? c_106 '#\\f)" +" '(#\\a #\\l #\\s #\\e)" +" #f" +" in_69" +" config_59)))))))))))" +"(if(unsafe-fx< index_5 26)" +"(if(unsafe-fx< index_5 21)" +"(if(unsafe-fx< index_5 18)" +"(let-values()" +"(let-values(((temp206_0) #f)" +"((in207_0) in_69)" +"((config208_0) config_59)" +" ((temp209_2) \"#e\"))" +"(read-symbol-or-number8.1 #f temp209_2 temp206_0 in207_0 config208_0)))" +"(if(unsafe-fx< index_5 19)" +"(let-values()" +"(let-values(((temp210_1) #f)" +"((in211_0) in_69)" +"((config212_0) config_59)" +" ((temp213_1) \"#E\"))" +"(read-symbol-or-number8.1 #f temp213_1 temp210_1 in211_0 config212_0)))" +"(if(unsafe-fx< index_5 20)" +"(let-values()" +"(let-values(((temp214_1) #f)" +"((in215_0) in_69)" +"((config216_0) config_59)" +" ((temp217_2) \"#i\"))" +"(read-symbol-or-number8.1 #f temp217_2 temp214_1 in215_0 config216_0)))" +"(let-values()" +"(let-values(((temp218_0) #f)" +"((in219_0) in_69)" +"((config220_0) config_59)" +" ((temp221_2) \"#I\"))" +"(read-symbol-or-number8.1 #f temp221_2 temp218_0 in219_0 config220_0))))))" +"(if(unsafe-fx< index_5 23)" +"(if(unsafe-fx< index_5 22)" +"(let-values()" +"(let-values(((temp222_1) #f)" +"((in223_0) in_69)" +"((config224_0) config_59)" +" ((temp225_1) \"#d\"))" +"(read-symbol-or-number8.1 #f temp225_1 temp222_1 in223_0 config224_0)))" +"(let-values()" +"(let-values(((temp226_2) #f)" +"((in227_0) in_69)" +"((config228_0) config_59)" +" ((temp229_2) \"#B\"))" +"(read-symbol-or-number8.1 #f temp229_2 temp226_2 in227_0 config228_0))))" +"(if(unsafe-fx< index_5 24)" +"(let-values()" +"(let-values(((temp230_2) #f)" +"((in231_0) in_69)" +"((config232_0) config_59)" +" ((temp233_1) \"#o\"))" +"(read-symbol-or-number8.1 #f temp233_1 temp230_2 in231_0 config232_0)))" +"(if(unsafe-fx< index_5 25)" +"(let-values()" +"(let-values(((temp234_0) #f)" +"((in235_0) in_69)" +"((config236_0) config_59)" +" ((temp237_0) \"#O\"))" +"(read-symbol-or-number8.1 #f temp237_0 temp234_0 in235_0 config236_0)))" +"(let-values()" +"(let-values(((temp238_0) #f)" +"((in239_0) in_69)" +"((config240_0) config_59)" +" ((temp241_0) \"#D\"))" +"(read-symbol-or-number8.1 #f temp241_0 temp238_0 in239_0 config240_0)))))))" +"(if(unsafe-fx< index_5 30)" +"(if(unsafe-fx< index_5 27)" +"(let-values()" +"(let-values(((temp242_1) #f)" +"((in243_0) in_69)" +"((config244_0) config_59)" +" ((temp245_0) \"#b\"))" +"(read-symbol-or-number8.1 #f temp245_0 temp242_1 in243_0 config244_0)))" +"(if(unsafe-fx< index_5 28)" +"(let-values()" +"(let-values(((temp246_0) #f)" +"((in247_0) in_69)" +"((config248_0) config_59)" +" ((temp249_1) \"#x\"))" +"(read-symbol-or-number8.1 #f temp249_1 temp246_0 in247_0 config248_0)))" +"(if(unsafe-fx< index_5 29)" +"(let-values()" +"(let-values(((temp250_2) #f)" +"((in251_0) in_69)" +"((config252_0) config_59)" +" ((temp253_0) \"#X\"))" +"(read-symbol-or-number8.1 #f temp253_0 temp250_2 in251_0 config252_0)))" +"(let-values()" +"(let-values(((c2_14)" +"(let-values(((in_75) in_69)" +"((source_48)(read-config-source config_59)))" +"(read-char-or-special in_75 special1.1 source_48))))" +"(let-values(((tmp_1) c2_14))" +"(if(if(equal? tmp_1 '#\\s) #t(equal? tmp_1 '#\\S))" +"(let-values()" +"(read-one #f in_69(override-parameter read-case-sensitive config_59 #t)))" +"(if(if(equal? tmp_1 '#\\i) #t(equal? tmp_1 '#\\I))" +"(let-values()" +"(read-one" +" #f" +" in_69" +"(override-parameter read-case-sensitive config_59 #f)))" +"(let-values()" +"(let-values(((in254_0) in_69)" +"((config255_0) config_59)" +"((c2256_0) c2_14)" +" ((temp257_0) \"expected `s', `S`, `i`, or `I` after `~a~a`\")" +"((dispatch-c258_0) dispatch-c_5)" +"((c259_0) c_106))" +"(reader-error12.1" +" unsafe-undefined" +" c2256_0" +" #f" +" unsafe-undefined" +" in254_0" +" config255_0" +" temp257_0" +"(list dispatch-c258_0 c259_0))))))))))))" +"(if(unsafe-fx< index_5 32)" +"(if(unsafe-fx< index_5 31)" +"(let-values()(read-hash read-one dispatch-c_5 c_106 in_69 config_59))" +"(let-values()" +"(let-values(((accum-str_12)(accum-string-init! config_59)))" +"(let-values((()(begin(accum-string-add! accum-str_12 dispatch-c_5)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_12 c_106)(values))))" +"(let-values(((c2_15)" +"(let-values(((in_76) in_69)" +"((source_49)(read-config-source config_59)))" +"(read-char-or-special in_76 special1.1 source_49))))" +"(begin" +"(if(char? c2_15)" +"(let-values()(accum-string-add! accum-str_12 c2_15))" +"(void))" +"(let-values(((tmp_59) c2_15))" +"(if(equal? tmp_59 '#\\x)" +"(let-values()(read-regexp c_106 accum-str_12 in_69 config_59))" +"(if(equal? tmp_59 '#\\e)" +"(let-values()" +"(read-extension-reader" +" read-one" +" read-undotted" +" dispatch-c_5" +" in_69" +" config_59))" +"(let-values()" +"(let-values(((in260_0) in_69)" +"((config261_0) config_59)" +"((c2262_0) c2_15)" +"((temp263_0)" +"(let-values(((accum-str264_0) accum-str_12)" +"((config265_0) config_59))" +"(accum-string-get!6.1" +" 0" +" accum-str264_0" +" config265_0))))" +"(bad-syntax-error20.1" +" c2262_0" +" in260_0" +" config261_0" +" temp263_0)))))))))))))" +"(if(unsafe-fx< index_5 33)" +"(let-values()" +"(let-values(((accum-str_13)(accum-string-init! config_59)))" +"(let-values((()(begin(accum-string-add! accum-str_13 dispatch-c_5)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_13 c_106)(values))))" +"(let-values(((c2_16)" +"(let-values(((in_77) in_69)" +"((source_50)(read-config-source config_59)))" +"(read-char-or-special in_77 special1.1 source_50))))" +"(begin" +"(if(char? c2_16)" +"(let-values()(accum-string-add! accum-str_13 c2_16))" +"(void))" +"(let-values(((tmp_60) c2_16))" +"(if(equal? tmp_60 '#\\x)" +"(let-values()(read-regexp c_106 accum-str_13 in_69 config_59))" +"(let-values()" +"(let-values(((in266_0) in_69)" +"((config267_0) config_59)" +"((c2268_0) c2_16)" +"((temp269_0)" +"(let-values(((accum-str270_0) accum-str_13)" +"((config271_0) config_59))" +"(accum-string-get!6.1" +" 0" +" accum-str270_0" +" config271_0))))" +"(bad-syntax-error20.1" +" c2268_0" +" in266_0" +" config267_0" +" temp269_0)))))))))))" +"(if(unsafe-fx< index_5 34)" +"(let-values()" +"(let-values(((read-undotted272_0) read-undotted)" +"((dispatch-c273_0) dispatch-c_5)" +"((in274_0) in_69)" +"((config275_0) config_59))" +"(read-extension-lang7.1" +" #f" +" read-undotted272_0" +" dispatch-c273_0" +" in274_0" +" config275_0)))" +"(if(unsafe-fx< index_5 35)" +"(let-values()" +"(let-values(((read-undotted276_0) read-undotted)" +"((dispatch-c277_0) dispatch-c_5)" +"((in278_0) in_69)" +"((config279_0) config_59))" +"(read-extension-#!16.1" +" #f" +" read-undotted276_0" +" dispatch-c277_0" +" in278_0" +" config279_0)))" +"(let-values()" +"(if(check-parameter 1/read-accept-compiled config_59)" +"(let-values()" +"(wrap((read-config-read-compiled config_59) in_69) in_69 config_59 c_106))" +"(let-values()" +"(let-values(((in280_0) in_69)" +"((config281_0) config_59)" +" ((temp282_0) \"`~a~~` compiled expressions not enabled\")" +"((dispatch-c283_0) dispatch-c_5))" +"(reader-error12.1" +" unsafe-undefined" +" '#\\x" +" #f" +" unsafe-undefined" +" in280_0" +" config281_0" +" temp282_0" +"(list dispatch-c283_0)))))))))))))))))))))))))" +"(define-values" +"(retry-special-comment)" +"(lambda(v_253 in_78 config_60)" +"(begin" +"(if(1/special-comment? v_253)" +"(let-values()(if(read-config-keep-comment? config_60) v_253(read-undotted #f in_78 config_60)))" +"(let-values() v_253)))))" +"(define-values" +"(1/module-declared?)" +"(let-values(((module-declared?3_0)" +"(lambda(mod2_0 load?1_0)" +"(begin" +" 'module-declared?3" +"(let-values(((mod_4) mod2_0))" +"(let-values(((load?_3) load?1_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_4)" +"(void)" +"(let-values()" +"(raise-argument-error 'module-declared? module-reference-str mod_4)))" +"(values))))" +"(let-values(((ns_116)(1/current-namespace)))" +"(let-values(((name_40)" +"(let-values(((mod31_0) mod_4)((load?32_0) load?_3))" +"(reference->resolved-module-path27.1 load?32_0 mod31_0))))" +"(if(namespace->module ns_116 name_40) #t #f)))))))))))))" +"(case-lambda" +"((mod_5)(begin 'module-declared?(module-declared?3_0 mod_5 #f)))" +"((mod_6 load?1_1)(module-declared?3_0 mod_6 load?1_1)))))" +"(define-values" +"(1/module-predefined?)" +"(lambda(mod_7)" +"(begin" +" 'module-predefined?" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_7)" +"(void)" +"(let-values()(raise-argument-error 'module-predefined? module-reference-str mod_7)))" +"(values))))" +"(let-values(((ns_68)(1/current-namespace)))" +"(let-values(((name_69)" +"(let-values(((mod34_0) mod_7)((temp35_5) #f))" +"(reference->resolved-module-path27.1 temp35_5 mod34_0))))" +"(let-values(((m_24)(namespace->module ns_68 name_69)))" +"(if m_24(module-is-predefined? m_24) #f))))))))))" +"(define-values" +"(module->)" +"(let-values(((module->9_0)" +"(lambda(extract6_0 who7_0 mod8_0 load?5_0)" +"(begin" +" 'module->9" +"(let-values(((extract_1) extract6_0))" +"(let-values(((who_31) who7_0))" +"(let-values(((mod_8) mod8_0))" +"(let-values(((load?_4) load?5_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_8)" +"(void)" +"(let-values()" +"(raise-argument-error who_31 module-reference-str mod_8)))" +"(values))))" +"(let-values(((m_25)" +"(namespace->module/complain" +" who_31" +"(1/current-namespace)" +"(let-values(((mod36_0) mod_8)((load?37_0) load?_4))" +"(reference->resolved-module-path27.1 load?37_0 mod36_0)))))" +"(extract_1 m_25))))))))))))" +"(case-lambda" +"((extract_2 who_22 mod_9)(begin(module->9_0 extract_2 who_22 mod_9 #f)))" +"((extract_3 who_32 mod_10 load?5_1)(module->9_0 extract_3 who_32 mod_10 load?5_1)))))" +"(define-values" +"(1/module->language-info)" +"(let-values(((module->language-info13_0)" +"(lambda(mod12_0 load?11_0)" +"(begin" +" 'module->language-info13" +"(let-values(((mod_11) mod12_0))" +"(let-values(((load?_5) load?11_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(module-> module-language-info 'module->language-info mod_11 load?_5))))))))))" +"(case-lambda" +"((mod_12)(begin 'module->language-info(module->language-info13_0 mod_12 #f)))" +"((mod_13 load?11_1)(module->language-info13_0 mod_13 load?11_1)))))" +"(define-values" +"(1/module->imports)" +"(lambda(mod_14)" +"(begin 'module->imports(let-values()(let-values()(module-> module-requires 'module->imports mod_14))))))" +"(define-values" +"(1/module->exports)" +"(lambda(mod_15)" +"(begin" +" 'module->exports" +"(let-values(((provides_12 self_27)" +"(module->" +"(lambda(m_26)(values(module-provides m_26)(module-self m_26)))" +" 'module->exports" +" mod_15)))" +"(provides->api-provides provides_12 self_27)))))" +"(define-values" +"(1/module->indirect-exports)" +"(lambda(mod_16)" +"(begin" +" 'module->indirect-exports" +"(module->" +"(lambda(m_27)(variables->api-nonprovides(module-provides m_27)((module-get-all-variables m_27))))" +" 'module->indirect-exports" +" mod_16))))" +"(define-values" +"(1/module-provide-protected?)" +"(lambda(mod_17 sym_98)" +"(begin" +" 'module-provide-protected?" +"(module->" +"(lambda(m_28)" +"(let-values(((b/p_3)(hash-ref(module-provides m_28) sym_98 #f)))" +"(let-values(((or-part_287)(not b/p_3)))(if or-part_287 or-part_287(provided-as-protected? b/p_3)))))" +" 'module-provide-protected?" +" mod_17))))" +"(define-values" +"(1/module->namespace)" +"(let-values(((module->namespace17_0)" +"(lambda(mod16_0 ns15_0)" +"(begin" +" 'module->namespace17" +"(let-values(((mod_18) mod16_0))" +"(let-values(((ns_48)(if(eq? ns15_0 unsafe-undefined)(1/current-namespace) ns15_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_18)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module->namespace" +" module-reference-str" +" mod_18)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_48)" +"(void)" +"(let-values()" +" (raise-argument-error 'module->namespace \"namespace?\" ns_48)))" +"(values))))" +"(let-values(((name_41)" +"(let-values(((mod44_0) mod_18)((temp45_1) #t))" +"(reference->resolved-module-path27.1 temp45_1 mod44_0))))" +"(let-values(((phase_136)(namespace-phase ns_48)))" +"(let-values(((m-ns_17)" +"(let-values(((ns46_0) ns_48)" +"((name47_1) name_41)" +"((phase48_1) phase_136))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" ns46_0" +" name47_1" +" phase48_1))))" +"(begin" +"(if m-ns_17" +"(void)" +"(let-values()" +"(begin" +"(namespace->module/complain 'module->namespace ns_48 name_41)" +"(raise-arguments-error" +" 'module->namespace" +" \"module not instantiated in the current namespace\"" +" \"name\"" +" name_41))))" +"(if(inspector-superior?" +"(current-code-inspector)" +"(namespace-inspector m-ns_17))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'module->namespace" +" \"current code inspector cannot access namespace of module\"" +" \"module name\"" +" name_41)))" +"(if(namespace-get-root-expand-ctx m-ns_17)" +"(void)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" m-ns_17" +"(let-values(((temp49_3)(namespace-mpi m-ns_17)))" +"(make-root-expand-context13.1" +" #f" +" null" +" unsafe-undefined" +" unsafe-undefined" +" temp49_3)))))" +"(let-values(((ns41_0) ns_48)" +"((temp42_3)(namespace-mpi m-ns_17))" +"((phase43_1) phase_136))" +"(namespace-module-make-available!112.1" +" unsafe-undefined" +" ns41_0" +" temp42_3" +" phase43_1))" +" m-ns_17)))))))))))))))" +"(case-lambda" +"((mod_19)(begin 'module->namespace(module->namespace17_0 mod_19 unsafe-undefined)))" +"((mod_20 ns15_1)(module->namespace17_0 mod_20 ns15_1)))))" +"(define-values" +"(1/namespace-unprotect-module)" +"(let-values(((namespace-unprotect-module22_0)" +"(lambda(insp20_0 mod21_0 ns19_1)" +"(begin" +" 'namespace-unprotect-module22" +"(let-values(((insp_18) insp20_0))" +"(let-values(((mod_21) mod21_0))" +"(let-values(((ns_117)(if(eq? ns19_1 unsafe-undefined)(1/current-namespace) ns19_1)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(inspector? insp_18)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"inspector?\"" +" insp_18)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/module-path? mod_21)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"module-path?\"" +" mod_21)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_117)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"namespace?\"" +" ns_117)))" +"(values))))" +"(let-values(((name_70)" +"(let-values(((mod51_0) mod_21)((temp52_3) #f))" +"(reference->resolved-module-path27.1 temp52_3 mod51_0))))" +"(let-values(((phase_6)(namespace-phase ns_117)))" +"(let-values(((m-ns_18)" +"(let-values(((ns53_3) ns_117)" +"((name54_0) name_70)" +"((phase55_1) phase_6))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" unsafe-undefined" +" ns53_3" +" name54_0" +" phase55_1))))" +"(begin" +"(if m-ns_18" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'namespace-unprotect-module" +" \"module not instantiated\"" +" \"module name\"" +" name_70)))" +"(if(inspector-superior? insp_18(namespace-inspector m-ns_18))" +"(let-values()" +"(set-namespace-inspector!" +" m-ns_18" +"(make-inspector(current-code-inspector))))" +"(void)))))))))))))))))))" +"(case-lambda" +"((insp_19 mod_22)" +"(begin 'namespace-unprotect-module(namespace-unprotect-module22_0 insp_19 mod_22 unsafe-undefined)))" +"((insp_9 mod_23 ns19_2)(namespace-unprotect-module22_0 insp_9 mod_23 ns19_2)))))" +"(define-values" +"(namespace->module/complain)" +"(lambda(who_33 ns_118 name_71)" +"(begin" +"(let-values(((or-part_211)(namespace->module ns_118 name_71)))" +"(if or-part_211" +" or-part_211" +" (raise-arguments-error who_33 \"unknown module in the current namespace\" \"name\" name_71))))))" +"(define-values" +"(module-reference?)" +"(lambda(mod_24)" +"(begin" +"(let-values(((or-part_134)(1/module-path? mod_24)))" +"(if or-part_134" +" or-part_134" +"(let-values(((or-part_258)(1/module-path-index? mod_24)))" +"(if or-part_258 or-part_258(1/resolved-module-path? mod_24))))))))" +" (define-values (module-reference-str) \"(or/c module-path? module-path-index? resolved-module-path?)\")" +"(define-values" +"(reference->resolved-module-path27.1)" +"(lambda(load?24_0 mod26_0)" +"(begin" +" 'reference->resolved-module-path27" +"(let-values(((mod_25) mod26_0))" +"(let-values(((load?_6) load?24_0))" +"(let-values()" +"(if(1/resolved-module-path? mod_25)" +"(let-values() mod_25)" +"(let-values()" +"(let-values(((mpi_47)(if(1/module-path-index? mod_25) mod_25(1/module-path-index-join mod_25 #f))))" +"(1/module-path-index-resolve mpi_47 load?_6))))))))))" +"(define-values" +"(read-syntax$1)" +"(lambda(src_0 in_26)" +"(begin" +" 'read-syntax" +"(if(default-read-handler? in_26)" +"(let-values()" +"(begin" +"(maybe-flush-stdout in_26)" +"(let-values(((in22_3) in_26)((temp23_6) #t)((src24_0) src_0))" +"(read*14.1 temp23_6 #f #f unsafe-undefined #f src24_0 in22_3))))" +"(let-values()(values((port-read-handler in_26) in_26 src_0)))))))" +"(define-values" +"(read-syntax/recursive$1)" +"(lambda(src_1 in_30 start_57 readtable_4 graph?_1)" +"(begin" +" 'read-syntax/recursive" +"(let-values(((in25_1) in_30)" +"((temp26_5) #t)" +"((temp27_8) #t)" +"((src28_0) src_1)" +"((start29_0) start_57)" +"((readtable30_0) readtable_4)" +"((temp31_4)(not graph?_1)))" +"(read*14.1 temp26_5 start29_0 temp31_4 readtable30_0 temp27_8 src28_0 in25_1)))))" +"(define-values" +"(read$1)" +"(lambda(in_11)" +"(begin" +" 'read" +"(if(default-read-handler? in_11)" +"(let-values()" +"(begin" +"(maybe-flush-stdout in_11)" +"(let-values(((in32_0) in_11)((temp33_4) #f))(read*14.1 temp33_4 #f #f unsafe-undefined #f #f in32_0))))" +"(let-values()(values((port-read-handler in_11) in_11)))))))" +"(define-values" +"(read/recursive$1)" +"(lambda(in_43 start_58 readtable_5 graph?_2)" +"(begin" +" 'read/recursive" +"(let-values(((in34_2) in_43)" +"((temp35_6) #f)" +"((temp36_7) #t)" +"((start37_0) start_58)" +"((readtable38_0) readtable_5)" +"((temp39_6)(not graph?_2)))" +"(read*14.1 temp35_6 start37_0 temp39_6 readtable38_0 temp36_7 #f in34_2)))))" +"(define-values" +"(read*14.1)" +"(lambda(for-syntax?1_0 init-c4_0 local-graph?6_1 readtable5_0 recursive?2_0 source3_0 in13_3)" +"(begin" +" 'read*14" +"(let-values(((in_79) in13_3))" +"(let-values(((for-syntax?_11) for-syntax?1_0))" +"(let-values(((recursive?_1) recursive?2_0))" +"(let-values(((source_51) source3_0))" +"(let-values(((init-c_19) init-c4_0))" +"(let-values(((readtable_6)" +"(if(eq? readtable5_0 unsafe-undefined)(1/current-readtable) readtable5_0)))" +"(let-values(((local-graph?_2) local-graph?6_1))" +"(let-values()" +"(let-values()" +"(let-values(((in40_2) in_79)" +"((for-syntax?41_0) for-syntax?_11)" +"((recursive?42_0) recursive?_1)" +"((source43_0) source_51)" +"((temp44_5)(if for-syntax?_11 read-to-syntax #f))" +"((init-c45_0) init-c_19)" +"((readtable46_0) readtable_6)" +"((local-graph?47_0) local-graph?_2)" +"((read-compiled-linklet48_0) 1/read-compiled-linklet)" +"((dynamic-require-reader49_0) dynamic-require-reader)" +"((read-module-declared?50_0) read-module-declared?)" +"((read-coerce51_0) read-coerce)" +"((read-coerce-key52_0) read-coerce-key))" +"(read30.1" +" read-coerce51_0" +" read-coerce-key52_0" +" dynamic-require-reader49_0" +" for-syntax?41_0" +" init-c45_0" +" unsafe-undefined" +" local-graph?47_0" +" read-module-declared?50_0" +" unsafe-undefined" +" read-compiled-linklet48_0" +" readtable46_0" +" recursive?42_0" +" source43_0" +" temp44_5" +" in40_2))))))))))))))" +"(define-values" +"(read-language$1)" +"(lambda(in_80 fail-thunk_0)" +"(begin" +" 'read-language" +"(let-values(((in53_0) in_80)" +"((fail-thunk54_0) fail-thunk_0)" +"((temp55_2) #t)" +"((read-to-syntax56_0) read-to-syntax)" +"((read-compiled-linklet57_0) 1/read-compiled-linklet)" +"((dynamic-require-reader58_0) dynamic-require-reader)" +"((read-module-declared?59_0) read-module-declared?)" +"((read-coerce60_0) read-coerce)" +"((read-coerce-key61_0) read-coerce-key))" +"(read-language49.1" +" read-coerce60_0" +" read-coerce-key61_0" +" dynamic-require-reader58_0" +" temp55_2" +" read-module-declared?59_0" +" read-compiled-linklet57_0" +" read-to-syntax56_0" +" in53_0" +" fail-thunk54_0)))))" +"(define-values" +"(read-to-syntax)" +"(lambda(s-exp_4 srcloc_11 rep_1)" +"(begin" +"(let-values(((the-struct_89) empty-syntax))" +"(if(syntax?$1 the-struct_89)" +"(let-values(((content62_0)(datum-intern-literal s-exp_4))" +"((srcloc63_0) srcloc_11)" +"((props64_0)" +"(let-values(((tmp_61) rep_1))" +"(if(equal? tmp_61 '#\\[)" +"(let-values() original-square-props)" +"(if(equal? tmp_61 '#\\{)" +"(let-values() original-curly-props)" +"(let-values() original-props))))))" +"(syntax1.1" +" content62_0" +"(syntax-scopes the-struct_89)" +"(syntax-shifted-multi-scopes the-struct_89)" +"(syntax-scope-propagations+tamper the-struct_89)" +"(syntax-mpi-shifts the-struct_89)" +" srcloc63_0" +" props64_0" +"(syntax-inspector the-struct_89)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_89))))))" +"(define-values(original-props)(syntax-props(syntax-property$1 empty-syntax original-property-sym #t)))" +"(define-values" +"(original-square-props)" +"(syntax-props(syntax-property$1(syntax-property$1 empty-syntax original-property-sym #t) 'paren-shape '#\\[)))" +"(define-values" +"(original-curly-props)" +"(syntax-props(syntax-property$1(syntax-property$1 empty-syntax original-property-sym #t) 'paren-shape '#\\{)))" +"(define-values(read-module-declared?)(lambda(mod-path_30)(begin(1/module-declared? mod-path_30 #t))))" +"(define-values" +"(read-coerce)" +"(lambda(for-syntax?_12 v_254 srcloc_12)" +"(begin" +"(if(not for-syntax?_12)" +"(let-values()(if(syntax?$1 v_254)(let-values()(syntax->datum$1 v_254))(let-values() v_254)))" +"(if(syntax?$1 v_254)" +"(let-values() v_254)" +"(if(list? v_254)" +"(let-values()" +"(read-to-syntax" +"(reverse$1" +"(let-values(((lst_188) v_254))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_188)))" +"((letrec-values(((for-loop_121)" +"(lambda(fold-var_235 lst_287)" +"(begin" +" 'for-loop" +"(if(pair? lst_287)" +"(let-values(((e_85)(unsafe-car lst_287))" +"((rest_162)(unsafe-cdr lst_287)))" +"(let-values(((fold-var_240)" +"(let-values(((fold-var_241) fold-var_235))" +"(let-values(((fold-var_242)" +"(let-values()" +"(cons" +"(let-values()" +"(read-coerce #t e_85 srcloc_12))" +" fold-var_241))))" +"(values fold-var_242)))))" +"(if(not #f)(for-loop_121 fold-var_240 rest_162) fold-var_240)))" +" fold-var_235)))))" +" for-loop_121)" +" null" +" lst_188))))" +" srcloc_12" +" #f))" +"(if(pair? v_254)" +"(let-values()" +"(read-to-syntax" +"(cons(read-coerce #t(car v_254) srcloc_12)(read-coerce #t(cdr v_254) srcloc_12))" +" srcloc_12" +" #f))" +"(let-values()(read-to-syntax v_254 srcloc_12 #f)))))))))" +"(define-values" +"(read-coerce-key)" +"(lambda(for-syntax?_0 k_42)" +"(begin(if for-syntax?_0(let-values()(datum-intern-literal k_42))(let-values() k_42)))))" +"(define-values(default-read-handler) #f)" +"(define-values" +"(default-read-handler?)" +"(lambda(in_81)" +"(begin" +"(if(not default-read-handler)" +"(let-values()(begin(set! default-read-handler(port-read-handler in_81)) #t))" +"(let-values()(eq? default-read-handler(port-read-handler in_81)))))))" +"(define-values(orig-input-port)(current-input-port))" +"(define-values(orig-output-port)(current-output-port))" +"(define-values(orig-error-port)(current-error-port))" +"(define-values" +"(maybe-flush-stdout)" +"(lambda(in_82)" +"(begin" +"(if(eq? in_82 orig-input-port)" +"(let-values()(begin(flush-output orig-output-port)(flush-output orig-error-port)))" +"(void)))))" +"(define-values" +"(dynamic-require-reader)" +"(let-values(((dynamic-require-reader20_0)" +"(lambda(mod-path18_0 sym19_1 fail-thunk17_0)" +"(begin" +" 'dynamic-require-reader20" +"(let-values(((mod-path_31) mod-path18_0))" +"(let-values(((sym_99) sym19_1))" +"(let-values(((fail-thunk_1)" +"(if(eq? fail-thunk17_0 unsafe-undefined)" +" default-dynamic-require-fail-thunk" +" fail-thunk17_0)))" +"(let-values()" +"(let-values(((root-ns_0)(namespace-root-namespace(1/current-namespace))))" +"(if root-ns_0" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" root-ns_0)" +"(let-values()(1/dynamic-require mod-path_31 sym_99 fail-thunk_1)))" +"(1/dynamic-require mod-path_31 sym_99 fail-thunk_1)))))))))))" +"(case-lambda" +"((mod-path_32 sym_100)(begin(dynamic-require-reader20_0 mod-path_32 sym_100 unsafe-undefined)))" +"((mod-path_0 sym_101 fail-thunk17_1)(dynamic-require-reader20_0 mod-path_0 sym_101 fail-thunk17_1)))))" +"(define-values" +"(1/read-syntax)" +"(let-values(((read-syntax3_0)" +"(lambda(src1_0 in2_0)" +"(begin" +" 'read-syntax3" +"(let-values(((src_2)(if(eq? src1_0 unsafe-undefined)(object-name(current-input-port)) src1_0)))" +"(let-values(((in_49)(if(eq? in2_0 unsafe-undefined)(current-input-port) in2_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(input-port? in_49)" +"(void)" +" (let-values () (raise-argument-error 'read-syntax \"input-port?\" in_49)))" +"(read-syntax$1 src_2 in_49)))))))))))" +"(case-lambda" +"(()(begin 'read-syntax(read-syntax3_0 unsafe-undefined unsafe-undefined)))" +"((src_3 in2_1)(read-syntax3_0 src_3 in2_1))" +"((src1_1)(read-syntax3_0 src1_1 unsafe-undefined)))))" +"(define-values" +"(1/read-syntax/recursive)" +"(let-values(((read-syntax/recursive10_0)" +"(lambda(src5_0 in6_3 start7_0 readtable8_0 graph?9_0)" +"(begin" +" 'read-syntax/recursive10" +"(let-values(((src_4)(if(eq? src5_0 unsafe-undefined)(object-name(current-input-port)) src5_0)))" +"(let-values(((in_83)(if(eq? in6_3 unsafe-undefined)(current-input-port) in6_3)))" +"(let-values(((start_59) start7_0))" +"(let-values(((readtable_7)" +"(if(eq? readtable8_0 unsafe-undefined)(1/current-readtable) readtable8_0)))" +"(let-values(((graph?_3) graph?9_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(input-port? in_83)" +"(void)" +"(let-values()" +" (raise-argument-error 'read-syntax/recursive \"input-port?\" in_83)))" +"(if((lambda(x_92)" +"(let-values(((or-part_298)(not x_92)))" +"(if or-part_298 or-part_298(char? x_92))))" +" start_59)" +"(void)" +"(let-values()" +" (raise-argument-error 'read-syntax/recursive \"(or/c char? #f)\" start_59)))" +"(if((lambda(x_93)" +"(let-values(((or-part_90)(not x_93)))" +"(if or-part_90 or-part_90(1/readtable? x_93))))" +" readtable_7)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'read-syntax/recursive" +" \"(or/c readtable? #f)\"" +" readtable_7)))" +"(read-syntax/recursive$1 src_4 in_83 start_59 readtable_7 graph?_3))))))))))))))" +"(case-lambda" +"(()" +"(begin" +" 'read-syntax/recursive" +"(read-syntax/recursive10_0 unsafe-undefined unsafe-undefined #f unsafe-undefined #t)))" +"((src_5 in_6 start_60 readtable_8 graph?9_1)(read-syntax/recursive10_0 src_5 in_6 start_60 readtable_8 graph?9_1))" +"((src_6 in_40 start_14 readtable8_1)(read-syntax/recursive10_0 src_6 in_40 start_14 readtable8_1 #t))" +"((src_7 in_13 start7_1)(read-syntax/recursive10_0 src_7 in_13 start7_1 unsafe-undefined #t))" +"((src_8 in6_4)(read-syntax/recursive10_0 src_8 in6_4 #f unsafe-undefined #t))" +"((src5_1)(read-syntax/recursive10_0 src5_1 unsafe-undefined #f unsafe-undefined #t)))))" +"(define-values" +"(1/read)" +"(let-values(((read13_0)" +"(lambda(in12_1)" +"(begin" +" 'read13" +"(let-values(((in_84)(if(eq? in12_1 unsafe-undefined)(current-input-port) in12_1)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(input-port? in_84)" +"(void)" +" (let-values () (raise-argument-error 'read \"input-port?\" in_84)))" +"(read$1 in_84))))))))))" +"(case-lambda(()(begin 'read(read13_0 unsafe-undefined)))((in12_2)(read13_0 in12_2)))))" +"(define-values" +"(1/read/recursive)" +"(let-values(((read/recursive19_0)" +"(lambda(in15_1 start16_0 readtable17_0 graph?18_0)" +"(begin" +" 'read/recursive19" +"(let-values(((in_79)(if(eq? in15_1 unsafe-undefined)(current-input-port) in15_1)))" +"(let-values(((start_61) start16_0))" +"(let-values(((readtable_9)" +"(if(eq? readtable17_0 unsafe-undefined)(1/current-readtable) readtable17_0)))" +"(let-values(((graph?_4) graph?18_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(input-port? in_79)" +"(void)" +" (let-values () (raise-argument-error 'read/recursive \"input-port?\" in_79)))" +"(if((lambda(x_94)" +"(let-values(((or-part_31)(not x_94)))" +"(if or-part_31 or-part_31(char? x_94))))" +" start_61)" +"(void)" +" (let-values () (raise-argument-error 'read/recursive \"(or/c char? #f)\" start_61)))" +"(if((lambda(x_95)" +"(let-values(((or-part_159)(not x_95)))" +"(if or-part_159 or-part_159(1/readtable? x_95))))" +" readtable_9)" +"(void)" +"(let-values()" +" (raise-argument-error 'read/recursive \"(or/c readtable? #f)\" readtable_9)))" +"(read/recursive$1 in_79 start_61 readtable_9 graph?_4)))))))))))))" +"(case-lambda" +"(()(begin 'read/recursive(read/recursive19_0 unsafe-undefined #f unsafe-undefined #t)))" +"((in_85 start_62 readtable_10 graph?18_1)(read/recursive19_0 in_85 start_62 readtable_10 graph?18_1))" +"((in_86 start_63 readtable17_1)(read/recursive19_0 in_86 start_63 readtable17_1 #t))" +"((in_87 start16_1)(read/recursive19_0 in_87 start16_1 unsafe-undefined #t))" +"((in15_2)(read/recursive19_0 in15_2 #f unsafe-undefined #t)))))" +"(define-values" +"(1/read-language)" +"(let-values(((read-language23_0)" +"(lambda(in21_3 fail-thunk22_0)" +"(begin" +" 'read-language23" +"(let-values(((in_17)(if(eq? in21_3 unsafe-undefined)(current-input-port) in21_3)))" +"(let-values(((fail-thunk_2)" +"(if(eq? fail-thunk22_0 unsafe-undefined) read-language-fail-thunk fail-thunk22_0)))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(input-port? in_17)" +"(void)" +" (let-values () (raise-argument-error 'read-language \"input-port?\" in_17)))" +"(if((lambda(p_75)(if(procedure? p_75)(procedure-arity-includes? p_75 0) #f))" +" fail-thunk_2)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'read-language" +" \"(procedure-arity-includes/c 0)\"" +" fail-thunk_2)))" +"(read-language$1" +" in_17" +"(if(eq? fail-thunk_2 read-language-fail-thunk) #f fail-thunk_2))))))))))))" +"(case-lambda" +"(()(begin 'read-language(read-language23_0 unsafe-undefined unsafe-undefined)))" +"((in_88 fail-thunk22_1)(read-language23_0 in_88 fail-thunk22_1))" +"((in21_4)(read-language23_0 in21_4 unsafe-undefined)))))" +" (define-values (read-language-fail-thunk) (lambda () (begin (error \"fail\"))))" +"(define-values" +"(declare-primitive-module!)" +"(lambda(name_72 inst_6 in-ns_0 protected_0 cross-phase-persistent?_3)" +"(begin" +"(let-values(((mpi_48)(1/module-path-index-join(list 'quote name_72) #f)))" +"(let-values(((in-ns1_0) in-ns_0)" +"((temp2_6)" +"(let-values(((temp4_0)(1/current-module-declare-source))" +"((cross-phase-persistent?5_0) cross-phase-persistent?_3)" +"((temp6_4)(zero?(hash-count protected_0)))" +"((mpi7_0) mpi_48)" +"((temp8_4)" +"(hasheqv" +" 0" +"(let-values(((lst_77)(1/instance-variable-names inst_6)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_77)))" +"((letrec-values(((for-loop_98)" +"(lambda(table_206 lst_78)" +"(begin" +" 'for-loop" +"(if(pair? lst_78)" +"(let-values(((sym_68)(unsafe-car lst_78))" +"((rest_36)(unsafe-cdr lst_78)))" +"(let-values(((table_170)" +"(let-values(((table_211) table_206))" +"(let-values(((table_212)" +"(let-values()" +"(let-values(((key_33" +" val_80)" +"(let-values()" +"(let-values(((binding_26)" +"(let-values(((mpi10_0)" +" mpi_48)" +"((temp11_6)" +" 0)" +"((sym12_0)" +" sym_68))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" mpi10_0" +" temp11_6" +" sym12_0))))" +"(values" +" sym_68" +"(if(hash-ref" +" protected_0" +" sym_68" +" #f)" +"(provided1.1" +" binding_26" +" #t" +" #f)" +" binding_26))))))" +"(hash-set" +" table_211" +" key_33" +" val_80)))))" +"(values table_212)))))" +"(if(not #f)" +"(for-loop_98 table_170 rest_36)" +" table_170)))" +" table_206)))))" +" for-loop_98)" +" '#hash()" +" lst_77)))))" +"((temp9_7)" +"(lambda(data-box_5" +" ns_46" +" phase-shift_19" +" phase-level_22" +" self_28" +" bulk-binding-registry_18" +" insp_20)" +"(if(= 0 phase-level_22)" +"(let-values()" +"(begin" +"(let-values(((lst_22)(1/instance-variable-names inst_6)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_22)))" +"((letrec-values(((for-loop_20)" +"(lambda(lst_261)" +"(begin" +" 'for-loop" +"(if(pair? lst_261)" +"(let-values(((sym_102)(unsafe-car lst_261))" +"((rest_179)(unsafe-cdr lst_261)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((val_81)" +"(1/instance-variable-value" +" inst_6" +" sym_102)))" +"(namespace-set-variable!" +" ns_46" +" 0" +" sym_102" +" val_81)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_20 rest_179)" +"(values))))" +"(values))))))" +" for-loop_20)" +" lst_22)))" +"(void)))" +"(void)))))" +"(make-module39.1" +" cross-phase-persistent?5_0" +" unsafe-undefined" +" unsafe-undefined" +" temp9_7" +" #f" +" 0" +" 0" +" temp6_4" +" unsafe-undefined" +" #f" +" unsafe-undefined" +" #f" +" temp8_4" +" null" +" mpi7_0" +" temp4_0" +" null" +" #f)))" +"((temp3_9)(substitute-module-declare-name name_72)))" +"(declare-module!58.1 #t in-ns1_0 temp2_6 temp3_9))))))" +"(define-values" +"(1/prop:exn:missing-module 1/exn:missing-module? 1/exn:missing-module-accessor)" +"(make-struct-type-property" +" 'missing-module" +"(lambda(v_29 info_6)" +"(begin" +"(if(if(procedure? v_29)(procedure-arity-includes? v_29 1) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'guard-for-prop:exn:missing-module \"(procedure-arity-includes/c 1)\" v_29)))" +" v_29))))" +"(define-values" +"(1/struct:exn:fail:filesystem:missing-module" +" 1/make-exn:fail:filesystem:missing-module" +" 1/exn:fail:filesystem:missing-module?" +" 1/exn:fail:filesystem:missing-module-path)" +"(let-values(((struct:_84 make-_84 ?_84 -ref_84 -set!_84)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:filesystem:missing-module" +" struct:exn:fail:filesystem" +" 1" +" 0" +" #f" +"(list" +"(cons 1/prop:exn:missing-module(lambda(e_86)(1/exn:fail:filesystem:missing-module-path e_86))))" +" #f" +" #f" +" '(0)" +" #f" +" 'exn:fail:filesystem:missing-module)))))" +"(values struct:_84 make-_84 ?_84(make-struct-field-accessor -ref_84 0 'path))))" +"(define-values" +"(1/struct:exn:fail:syntax:missing-module" +" 1/make-exn:fail:syntax:missing-module" +" 1/exn:fail:syntax:missing-module?" +" 1/exn:fail:syntax:missing-module-path)" +"(let-values(((struct:_68 make-_68 ?_68 -ref_68 -set!_68)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax:missing-module" +" 1/struct:exn:fail:syntax" +" 1" +" 0" +" #f" +"(list" +"(cons 1/prop:exn:missing-module(lambda(e_33)(1/exn:fail:syntax:missing-module-path e_33))))" +" #f" +" #f" +" '(0)" +" #f" +" 'exn:fail:syntax:missing-module)))))" +"(values struct:_68 make-_68 ?_68(make-struct-field-accessor -ref_68 0 'path))))" +"(define-values" +"(1/current-module-path-for-load)" +"(make-parameter" +" #f" +"(lambda(v_234)" +"(begin" +"(if(let-values(((or-part_67)(not v_234)))" +"(if or-part_67" +" or-part_67" +"(let-values(((or-part_68)(1/module-path? v_234)))" +"(if or-part_68 or-part_68(if(syntax?$1 v_234)(1/module-path?(syntax->datum$1 v_234)) #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-module-path-for-load" +"(string-append" +" \"(or/c module-path?\"" +" \" (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))\"" +" \" #f)\")" +" v_234)))" +" v_234))))" +"(define-values" +"(maybe-raise-missing-module)" +"(lambda(name_73 filename_0 pre_0 rel_0 post_0 errstr_0)" +"(begin" +"(let-values(((path_11)(1/current-module-path-for-load)))" +"(if path_11" +"(let-values()" +"(begin" +"(if(syntax?$1 path_11)" +"(let-values()" +"(raise" +"(1/make-exn:fail:syntax:missing-module" +"(format" +"(string-append" +" \"~a: cannot open module file\\n\"" +" \" module path: ~a\\n\"" +" \" path: ~a~a~a~a\\n\"" +" \" system error: ~a\")" +"(if(syntax-srcloc path_11)(srcloc->string(syntax-srcloc path_11)) name_73)" +"(syntax->datum$1 path_11)" +" filename_0" +" pre_0" +" rel_0" +" post_0" +" errstr_0)" +"(current-continuation-marks)" +"(list path_11)" +"(syntax->datum$1 path_11))))" +"(void))" +"(raise" +"(1/make-exn:fail:filesystem:missing-module" +"(format" +"(string-append" +" \"~a: cannot open module file\\n\"" +" \" module path: ~a\\n\"" +" \" path: ~a~a~a~a\\n\"" +" \" system error: ~a\")" +" name_73" +" path_11" +" filename_0" +" pre_0" +" rel_0" +" post_0" +" errstr_0)" +"(current-continuation-marks)" +" path_11))))" +"(void))))))" +"(define-values" +"(1/local-expand)" +"(let-values(((local-expand5_0)" +"(lambda(s2_9 context3_0 stop-ids4_0 intdefs1_0)" +"(begin" +" 'local-expand5" +"(let-values(((s_8) s2_9))" +"(let-values(((context_10) context3_0))" +"(let-values(((stop-ids_2) stop-ids4_0))" +"(let-values(((intdefs_4) intdefs1_0))" +"(let-values()" +"(let-values(((temp53_0) 'local-expand)" +"((s54_1) s_8)" +"((context55_0) context_10)" +"((stop-ids56_0) stop-ids_2)" +"((intdefs57_0) intdefs_4))" +"(do-local-expand50.1" +" #f" +" #f" +" #t" +" unsafe-undefined" +" #f" +" #f" +" #f" +" temp53_0" +" s54_1" +" context55_0" +" stop-ids56_0" +" intdefs57_0)))))))))))" +"(case-lambda" +"((s_447 context_11 stop-ids_3)(begin 'local-expand(local-expand5_0 s_447 context_11 stop-ids_3 '())))" +"((s_75 context_12 stop-ids_4 intdefs1_1)(local-expand5_0 s_75 context_12 stop-ids_4 intdefs1_1)))))" +"(define-values" +"(1/local-expand/capture-lifts)" +"(let-values(((local-expand/capture-lifts12_0)" +"(lambda(s9_1 context10_0 stop-ids11_0 intdefs7_0 lift-key8_0)" +"(begin" +" 'local-expand/capture-lifts12" +"(let-values(((s_492) s9_1))" +"(let-values(((context_13) context10_0))" +"(let-values(((stop-ids_5) stop-ids11_0))" +"(let-values(((intdefs_5) intdefs7_0))" +"(let-values(((lift-key_4)" +"(if(eq? lift-key8_0 unsafe-undefined)(generate-lift-key) lift-key8_0)))" +"(let-values()" +"(let-values(((temp58_3) 'local-expand)" +"((s59_0) s_492)" +"((context60_0) context_13)" +"((stop-ids61_0) stop-ids_5)" +"((intdefs62_0) intdefs_5)" +"((temp63_5) #t)" +"((lift-key64_0) lift-key_4))" +"(do-local-expand50.1" +" #f" +" temp63_5" +" #t" +" lift-key64_0" +" #f" +" #f" +" #f" +" temp58_3" +" s59_0" +" context60_0" +" stop-ids61_0" +" intdefs62_0))))))))))))" +"(case-lambda" +"((s_41 context_14 stop-ids_6)" +"(begin" +" 'local-expand/capture-lifts" +"(local-expand/capture-lifts12_0 s_41 context_14 stop-ids_6 '() unsafe-undefined)))" +"((s_87 context_15 stop-ids_7 intdefs_6 lift-key8_1)" +"(local-expand/capture-lifts12_0 s_87 context_15 stop-ids_7 intdefs_6 lift-key8_1))" +"((s_431 context_16 stop-ids_8 intdefs7_1)" +"(local-expand/capture-lifts12_0 s_431 context_16 stop-ids_8 intdefs7_1 unsafe-undefined)))))" +"(define-values" +"(1/local-transformer-expand)" +"(let-values(((local-transformer-expand18_0)" +"(lambda(s15_1 context16_0 stop-ids17_0 intdefs14_0)" +"(begin" +" 'local-transformer-expand18" +"(let-values(((s_35) s15_1))" +"(let-values(((context_17) context16_0))" +"(let-values(((stop-ids_9) stop-ids17_0))" +"(let-values(((intdefs_7) intdefs14_0))" +"(let-values()" +"(let-values(((temp65_4) 'local-expand)" +"((s66_2) s_35)" +"((context67_0) context_17)" +"((stop-ids68_0) stop-ids_9)" +"((intdefs69_0) intdefs_7)" +"((temp70_4) #t))" +"(do-local-expand50.1" +" temp70_4" +" #f" +" #t" +" unsafe-undefined" +" #f" +" #f" +" #f" +" temp65_4" +" s66_2" +" context67_0" +" stop-ids68_0" +" intdefs69_0)))))))))))" +"(case-lambda" +"((s_187 context_18 stop-ids_10)" +"(begin 'local-transformer-expand(local-transformer-expand18_0 s_187 context_18 stop-ids_10 '())))" +"((s_493 context_19 stop-ids_11 intdefs14_1)" +"(local-transformer-expand18_0 s_493 context_19 stop-ids_11 intdefs14_1)))))" +"(define-values" +"(1/local-transformer-expand/capture-lifts)" +"(let-values(((local-transformer-expand/capture-lifts25_0)" +"(lambda(s22_1 context23_0 stop-ids24_0 intdefs20_0 lift-key21_0)" +"(begin" +" 'local-transformer-expand/capture-lifts25" +"(let-values(((s_92) s22_1))" +"(let-values(((context_20) context23_0))" +"(let-values(((stop-ids_12) stop-ids24_0))" +"(let-values(((intdefs_8) intdefs20_0))" +"(let-values(((lift-key_5)" +"(if(eq? lift-key21_0 unsafe-undefined)(generate-lift-key) lift-key21_0)))" +"(let-values()" +"(let-values(((temp71_3) 'local-expand)" +"((s72_1) s_92)" +"((context73_0) context_20)" +"((stop-ids74_0) stop-ids_12)" +"((intdefs75_0) intdefs_8)" +"((temp76_3) #t)" +"((temp77_2) #t)" +"((lift-key78_0) lift-key_5))" +"(do-local-expand50.1" +" temp76_3" +" temp77_2" +" #t" +" lift-key78_0" +" #f" +" #f" +" #f" +" temp71_3" +" s72_1" +" context73_0" +" stop-ids74_0" +" intdefs75_0))))))))))))" +"(case-lambda" +"((s_19 context_21 stop-ids_13)" +"(begin" +" 'local-transformer-expand/capture-lifts" +"(local-transformer-expand/capture-lifts25_0 s_19 context_21 stop-ids_13 '() unsafe-undefined)))" +"((s_450 context_22 stop-ids_14 intdefs_9 lift-key21_1)" +"(local-transformer-expand/capture-lifts25_0 s_450 context_22 stop-ids_14 intdefs_9 lift-key21_1))" +"((s_494 context_23 stop-ids_15 intdefs20_1)" +"(local-transformer-expand/capture-lifts25_0 s_494 context_23 stop-ids_15 intdefs20_1 unsafe-undefined)))))" +"(define-values" +"(1/syntax-local-expand-expression)" +"(let-values(((syntax-local-expand-expression29_0)" +"(lambda(s28_1 opaque-only?27_0)" +"(begin" +" 'syntax-local-expand-expression29" +"(let-values(((s_495) s28_1))" +"(let-values(((opaque-only?_0) opaque-only?27_0))" +"(let-values()" +"(let-values(((exp-s_11)" +"(let-values(((temp79_1) 'syntax-local-expand-expression)" +"((s80_1) s_495)" +"((temp81_3) 'expression)" +"((null82_0) null)" +"((temp83_2) #f)" +"((opaque-only?84_0) opaque-only?_0)" +"((temp85_2) #t)" +"((temp86_4) #t)" +"((temp87_2) #f))" +"(do-local-expand50.1" +" #f" +" #f" +" temp87_2" +" unsafe-undefined" +" temp85_2" +" opaque-only?84_0" +" temp86_4" +" temp79_1" +" s80_1" +" temp81_3" +" null82_0" +" temp83_2))))" +"(let-values(((ctx_74)(let-values()(get-current-expand-context16.1 #f 'unexpected))))" +"(let-values(((ae_1)" +"(flip-introduction-scopes" +"(datum->syntax$1" +" #f" +"(already-expanded1.1" +"(if(parsed? exp-s_11)" +" exp-s_11" +"(flip-introduction-scopes exp-s_11 ctx_74))" +"(expand-context-binding-layer ctx_74)))" +" ctx_74)))" +"(begin" +"(let-values(((obs_60)(expand-context-observer ctx_74)))" +"(if obs_60" +"(let-values()(let-values()(call-expand-observe obs_60 'opaque-expr ae_1)))" +"(void)))" +"(let-values(((obs_4)(expand-context-observer ctx_74)))" +"(if obs_4" +"(let-values()(let-values()(call-expand-observe obs_4 'exit-local exp-s_11)))" +"(void)))" +"(values(if(not opaque-only?_0) exp-s_11 #f) ae_1))))))))))))" +"(case-lambda" +"((s_46)(begin 'syntax-local-expand-expression(syntax-local-expand-expression29_0 s_46 #f)))" +"((s_486 opaque-only?27_1)(syntax-local-expand-expression29_0 s_486 opaque-only?27_1)))))" +"(define-values" +"(do-local-expand50.1)" +"(lambda(as-transformer?32_0" +" capture-lifts?31_0" +" keep-#%expression?34_0" +" lift-key35_0" +" skip-log-exit?37_0" +" to-parsed-ok?33_0" +" track-to-be-defined?36_0" +" who46_1" +" s-or-s-exp47_0" +" context48_0" +" stop-ids49_0" +" intdefs45_0)" +"(begin" +" 'do-local-expand50" +"(let-values(((who_34) who46_1))" +"(let-values(((s-or-s-exp_0) s-or-s-exp47_0))" +"(let-values(((context_24) context48_0))" +"(let-values(((stop-ids_16) stop-ids49_0))" +"(let-values(((intdefs_10) intdefs45_0))" +"(let-values(((capture-lifts?_0) capture-lifts?31_0))" +"(let-values(((as-transformer?_6) as-transformer?32_0))" +"(let-values(((to-parsed-ok?_1) to-parsed-ok?33_0))" +"(let-values(((keep-#%expression?_2) keep-#%expression?34_0))" +"(let-values(((lift-key_6)" +"(if(eq? lift-key35_0 unsafe-undefined)" +"(if(let-values(((or-part_40) capture-lifts?_0))" +"(if or-part_40 or-part_40 as-transformer?_6))" +"(generate-lift-key)" +" #f)" +" lift-key35_0)))" +"(let-values(((track-to-be-defined?_1) track-to-be-defined?36_0))" +"(let-values(((skip-log-exit?_0) skip-log-exit?37_0))" +"(let-values()" +"(let-values()" +"(let-values(((s_496)(datum->syntax$1 #f s-or-s-exp_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_365)(list? context_24)))" +"(if or-part_365" +" or-part_365" +"(memq" +" context_24" +"(if as-transformer?_6" +" '(expression top-level)" +" '(expression top-level module module-begin)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_34" +"(if as-transformer?_6" +" \"(or/c 'expression 'top-level list?)\"" +" \"(or/c 'expression 'top-level 'module 'module-begin list?)\")" +" context_24)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_45)(not stop-ids_16)))" +"(if or-part_45" +" or-part_45" +"(if(list? stop-ids_16)" +"(andmap2 identifier? stop-ids_16)" +" #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_34" +" \"(or/c (listof identifier?) #f)\"" +" stop-ids_16)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(intdefs-or-false? intdefs_10)" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_34" +" intdefs-or-false?-string" +" intdefs_10)))" +"(values))))" +"(let-values(((ctx_75)" +"(let-values(((who88_0) who_34))" +"(get-current-expand-context16.1 #f who88_0))))" +"(let-values(((phase_93)" +"(if as-transformer?_6" +"(add1(expand-context-phase ctx_75))" +"(expand-context-phase ctx_75))))" +"(let-values(((local-ctx_0)" +"(let-values(((ctx89_0) ctx_75)" +"((context90_0) context_24)" +"((phase91_0) phase_93)" +"((intdefs92_0) intdefs_10)" +"((stop-ids93_0) stop-ids_16)" +"((to-parsed-ok?94_0) to-parsed-ok?_1)" +"((temp95_2)" +"(let-values(((or-part_169)" +" keep-#%expression?_2))" +"(if or-part_169" +" or-part_169" +"(if(expand-context-in-local-expand?" +" ctx_75)" +"(expand-context-keep-#%expression?" +" ctx_75)" +" #f))))" +"((track-to-be-defined?96_0)" +" track-to-be-defined?_1))" +"(make-local-expand-context42.1" +" context90_0" +" intdefs92_0" +" temp95_2" +" phase91_0" +" stop-ids93_0" +" to-parsed-ok?94_0" +" track-to-be-defined?96_0" +" ctx89_0))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +"(expand-context-namespace ctx_75)" +" phase_93)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_7)" +"(expand-context-observer local-ctx_0)))" +"(if obs_7" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_7" +" 'enter-local" +" s_496)))" +"(void)))" +"(values))))" +"(let-values(((input-s_1)" +"(let-values(((temp97_3)" +"(flip-introduction-scopes s_496 ctx_75))" +"((intdefs98_0) intdefs_10))" +"(add-intdef-scopes24.1" +" unsafe-undefined" +" #f" +" temp97_3" +" intdefs98_0))))" +"(let-values((()" +"(begin" +"(if as-transformer?_6" +"(let-values()" +"(let-values(((obs_61)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_61" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_61" +" 'phase-up)))" +"(void))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_62)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_62" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_62" +" 'local-pre" +" input-s_1)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if stop-ids_16" +"(let-values()" +"(let-values(((obs_63)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_63" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_63" +" 'start)))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((output-s_0)" +"(if(if as-transformer?_6 capture-lifts?_0 #f)" +"(let-values()" +"(let-values(((input-s99_0) input-s_1)" +"((local-ctx100_0)" +" local-ctx_0)" +"((context101_0) context_24)" +"((temp102_1) #f)" +"((temp103_1) #t)" +"((lift-key104_0) lift-key_6)" +"((temp105_4) #t)" +"((temp106_4) #t))" +"(expand-transformer92.1" +" temp105_4" +" temp103_1" +" context101_0" +" temp102_1" +" temp106_4" +" lift-key104_0" +" input-s99_0" +" local-ctx100_0)))" +"(if as-transformer?_6" +"(let-values()" +"(let-values(((input-s107_0) input-s_1)" +"((local-ctx108_0)" +" local-ctx_0)" +"((context109_0) context_24)" +"((temp110_4) #f)" +"((temp111_2)" +"(eq?" +" 'top-level" +" context_24))" +"((lift-key112_0)" +" lift-key_6)" +"((temp113_3) #t))" +"(expand-transformer92.1" +" #f" +" temp111_2" +" context109_0" +" temp110_4" +" temp113_3" +" lift-key112_0" +" input-s107_0" +" local-ctx108_0)))" +"(if capture-lifts?_0" +"(let-values()" +"(let-values(((input-s114_0)" +" input-s_1)" +"((local-ctx115_0)" +" local-ctx_0)" +"((temp116_2) #t)" +"((lift-key117_0)" +" lift-key_6)" +"((temp118_1) #t))" +"(expand/capture-lifts75.1" +" temp118_1" +" temp116_2" +" #f" +" lift-key117_0" +" input-s114_0" +" local-ctx115_0)))" +"(let-values()" +"(let-values(((input-s119_0)" +" input-s_1)" +"((local-ctx120_0)" +" local-ctx_0))" +"(expand9.1" +" #f" +" #f" +" #f" +" input-s119_0" +" local-ctx120_0))))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_64)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_64" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_64" +" 'local-post" +" output-s_0)))" +"(void)))" +"(values))))" +"(let-values(((result-s_8)" +"(if(parsed? output-s_0)" +" output-s_0" +"(flip-introduction-scopes" +" output-s_0" +" ctx_75))))" +"(begin" +"(if skip-log-exit?_0" +"(void)" +"(let-values()" +"(let-values(((obs_65)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_65" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_65" +" 'exit-local" +" result-s_8)))" +"(void)))))" +" result-s_8))))))))))))))))))))))))))))))))))" +"(define-values" +"(1/syntax-tainted?)" +"(lambda(s_0)" +"(begin" +" 'syntax-tainted?" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_0) (void) (let-values () (raise-argument-error 'syntax-tainted? \"syntax?\" s_0)))" +"(syntax-tainted?$1 s_0)))))))" +"(define-values" +"(1/syntax-arm)" +"(let-values(((syntax-arm4_0)" +"(lambda(s3_2 maybe-insp1_0 use-mode?2_0)" +"(begin" +" 'syntax-arm4" +"(let-values(((s_2) s3_2))" +"(let-values(((maybe-insp_0) maybe-insp1_0))" +"(let-values(((use-mode?_0) use-mode?2_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_2)" +"(void)" +" (let-values () (raise-argument-error 'syntax-arm \"syntax?\" s_2)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_12)(not maybe-insp_0)))" +"(if or-part_12 or-part_12(inspector? maybe-insp_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-arm" +" \"(or/c inspector? #f)\"" +" maybe-insp_0)))" +"(values))))" +"(let-values(((insp_21)(inspector-for-taint maybe-insp_0)))" +"(if use-mode?_0" +"(let-values()" +"(taint-dispatch" +" s_2" +"(lambda(s_440)(syntax-arm$1 s_440 insp_21))" +"(1/syntax-local-phase-level)))" +"(let-values()(syntax-arm$1 s_2 insp_21))))))))))))))))" +"(case-lambda" +"((s_497)(begin 'syntax-arm(syntax-arm4_0 s_497 #f #f)))" +"((s_447 maybe-insp_1 use-mode?2_1)(syntax-arm4_0 s_447 maybe-insp_1 use-mode?2_1))" +"((s_75 maybe-insp1_1)(syntax-arm4_0 s_75 maybe-insp1_1 #f)))))" +"(define-values" +"(1/syntax-disarm)" +"(lambda(s_498 maybe-insp_2)" +"(begin" +" 'syntax-disarm" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_498)" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"syntax?\" s_498)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_309)(not maybe-insp_2)))" +"(if or-part_309 or-part_309(inspector? maybe-insp_2)))" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"(or/c inspector? #f)\" maybe-insp_2)))" +"(values))))" +"(let-values(((insp_22)(inspector-for-taint maybe-insp_2)))(syntax-disarm$1 s_498 insp_22)))))))))" +"(define-values" +"(1/syntax-rearm)" +"(let-values(((syntax-rearm9_0)" +"(lambda(s7_1 from-s8_0 use-mode?6_0)" +"(begin" +" 'syntax-rearm9" +"(let-values(((s_180) s7_1))" +"(let-values(((from-s_2) from-s8_0))" +"(let-values(((use-mode?_1) use-mode?6_0))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_180)" +"(void)" +" (let-values () (raise-argument-error 'syntax-rearm \"syntax?\" s_180)))" +"(if(syntax?$1 from-s_2)" +"(void)" +" (let-values () (raise-argument-error 'syntax-rearm \"syntax?\" from-s_2)))" +"(if use-mode?_1" +"(let-values()" +"(taint-dispatch" +" s_180" +"(lambda(s_76)(syntax-rearm$1 s_76 from-s_2))" +"(1/syntax-local-phase-level)))" +"(let-values()(syntax-rearm$1 s_180 from-s_2))))))))))))))" +"(case-lambda" +"((s_181 from-s_3)(begin 'syntax-rearm(syntax-rearm9_0 s_181 from-s_3 #f)))" +"((s_442 from-s_4 use-mode?6_1)(syntax-rearm9_0 s_442 from-s_4 use-mode?6_1)))))" +"(define-values" +"(1/syntax-taint)" +"(lambda(s_5)" +"(begin" +" 'syntax-taint" +"(let-values()" +"(let-values()" +"(begin" +" (if (syntax?$1 s_5) (void) (let-values () (raise-argument-error 'syntax-taint \"syntax?\" s_5)))" +"(syntax-taint$1 s_5)))))))" +"(define-values" +"(inspector-for-taint)" +"(lambda(maybe-insp_3)" +"(begin" +"(let-values(((or-part_366) maybe-insp_3))" +"(if or-part_366" +" or-part_366" +"(let-values(((or-part_163)(current-module-code-inspector)))" +"(if or-part_163 or-part_163(current-code-inspector))))))))" +"(define-values" +"(1/variable-reference->empty-namespace)" +"(lambda(vr_0)" +"(begin" +" 'variable-reference->empty-namespace" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/variable-reference? vr_0)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->empty-namespace \"variable-reference?\" vr_0)))" +"(let-values(((temp2_7)(1/variable-reference->namespace vr_0)))" +"(new-namespace8.1 #t unsafe-undefined temp2_7))))))))" +"(define-values" +"(1/variable-reference->namespace)" +"(lambda(vr_1)" +"(begin" +" 'variable-reference->namespace" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_1)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->namespace \"variable-reference?\" vr_1)))" +"(values))))" +"(let-values(((ns_60)(variable-reference->namespace* vr_1)))" +"(let-values(((mpi_49)(namespace-mpi ns_60)))" +"(begin" +"(if(non-self-module-path-index? mpi_49)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" ns_60)" +"(let-values()" +"(let-values(((ns4_1) ns_60)((mpi5_0) mpi_49)((temp6_5)(namespace-0-phase ns_60)))" +"(namespace-module-make-available!112.1 unsafe-undefined ns4_1 mpi5_0 temp6_5)))))" +"(void))" +" ns_60)))))))))" +"(define-values" +"(variable-reference->namespace*)" +"(lambda(vr_2)" +"(begin" +"(let-values(((inst_7)(1/variable-reference->instance vr_2)))" +"(if(symbol? inst_7)" +"(let-values()" +"(1/module->namespace(list 'quote inst_7)(1/instance-data(1/variable-reference->instance vr_2 #t))))" +"(if(not inst_7)" +"(let-values()(1/instance-data(1/variable-reference->instance vr_2 #t)))" +"(let-values()(1/instance-data inst_7))))))))" +"(define-values" +"(1/variable-reference->module-path-index)" +"(lambda(vr_3)" +"(begin" +" 'variable-reference->module-path-index" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_3)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-path-index \"variable-reference?\" vr_3)))" +"(values))))" +"(let-values(((mpi_50)(namespace-mpi(variable-reference->namespace* vr_3))))" +"(if(top-level-module-path-index? mpi_50) #f mpi_50))))))))" +"(define-values" +"(1/variable-reference->resolved-module-path)" +"(lambda(vr_4)" +"(begin" +" 'variable-reference->resolved-module-path" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_4)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'variable-reference->resolved-module-path" +" \"variable-reference?\"" +" vr_4)))" +"(values))))" +"(let-values(((mpi_51)(1/variable-reference->module-path-index vr_4)))" +"(if mpi_51(1/module-path-index-resolve mpi_51) #f))))))))" +"(define-values" +"(1/variable-reference->module-source)" +"(lambda(vr_5)" +"(begin" +" 'variable-reference->module-source" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_5)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-source \"variable-reference?\" vr_5)))" +"(values))))" +"(let-values(((ns_119)(variable-reference->namespace* vr_5)))(namespace-source-name ns_119))))))))" +"(define-values" +"(1/variable-reference->phase)" +"(lambda(vr_6)" +"(begin" +" 'variable-reference->phase" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/variable-reference? vr_6)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->phase \"variable-reference?\" vr_6)))" +"(namespace-phase(variable-reference->namespace* vr_6))))))))" +"(define-values" +"(1/variable-reference->module-base-phase)" +"(lambda(vr_7)" +"(begin" +" 'variable-reference->module-base-phase" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/variable-reference? vr_7)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->module-base-phase \"variable-reference?\" vr_7)))" +"(namespace-0-phase(variable-reference->namespace* vr_7))))))))" +"(define-values" +"(1/variable-reference->module-declaration-inspector)" +"(lambda(vr_8)" +"(begin" +" 'variable-reference->module-declaration-inspector" +"(let-values()" +"(let-values()" +"(begin" +"(if(1/variable-reference? vr_8)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-declaration-inspector \"variable-reference?\" vr_8)))" +"(if(1/variable-reference->instance vr_8)" +"(let-values()" +"(raise-arguments-error" +" 'variable-reference->module-declaration-inspector" +" \"variable reference does not refer to an anonymous module variable\"" +" \"variable reference\"" +" vr_8))" +"(void))" +"(let-values(((or-part_72)(namespace-declaration-inspector(variable-reference->namespace* vr_8))))" +"(if or-part_72" +" or-part_72" +"(raise-arguments-error" +" 'variable-reference->module-declaration-inspector" +" \"given variable reference is not from a module\")))))))))" +"(define-values" +"(primitive-ids)" +"(seteq" +" 'syntax?" +" 'syntax-e" +" 'syntax->datum" +" 'datum->syntax" +" 'bound-identifier=?" +" 'free-identifier=?" +" 'free-transformer-identifier=?" +" 'free-template-identifier=?" +" 'free-label-identifier=?" +" 'identifier-binding" +" 'identifier-transformer-binding" +" 'identifier-template-binding" +" 'identifier-label-binding" +" 'identifier-binding-symbol" +" 'identifier-prune-lexical-context" +" 'syntax-debug-info" +" 'syntax-track-origin" +" 'syntax-shift-phase-level" +" 'syntax-source-module" +" 'identifier-prune-to-source-module" +" 'syntax-source" +" 'syntax-line" +" 'syntax-column" +" 'syntax-position" +" 'syntax-span" +" 'syntax->list" +" 'syntax-property" +" 'syntax-property-remove" +" 'syntax-property-preserved?" +" 'syntax-property-symbol-keys" +" 'syntax-original?" +" 'syntax-tainted?" +" 'syntax-arm" +" 'syntax-disarm" +" 'syntax-rearm" +" 'syntax-taint" +" 'raise-syntax-error" +" 'struct:exn:fail:syntax" +" 'exn:fail:syntax" +" 'make-exn:fail:syntax" +" 'exn:fail:syntax?" +" 'exn:fail:syntax-exprs" +" 'struct:exn:fail:syntax:unbound" +" 'exn:fail:syntax:unbound" +" 'make-exn:fail:syntax:unbound" +" 'exn:fail:syntax:unbound?" +" 'current-module-path-for-load" +" 'prop:exn:missing-module" +" 'exn:missing-module?" +" 'exn:missing-module-accessor" +" 'struct:exn:fail:filesystem:missing-module" +" 'exn:fail:filesystem:missing-module" +" 'make-exn:fail:filesystem:missing-module" +" 'exn:fail:filesystem:missing-module?" +" 'exn:fail:filesystem:missing-module-path" +" 'struct:exn:fail:syntax:missing-module" +" 'exn:fail:syntax:missing-module" +" 'make-exn:fail:syntax:missing-module" +" 'exn:fail:syntax:missing-module?" +" 'exn:fail:syntax:missing-module-path" +" 'syntax-transforming?" +" 'syntax-transforming-with-lifts?" +" 'syntax-transforming-module-expression?" +" 'syntax-local-transforming-module-provides?" +" 'syntax-local-context" +" 'syntax-local-introduce" +" 'syntax-local-identifier-as-binding" +" 'syntax-local-phase-level" +" 'syntax-local-name" +" 'make-syntax-introducer" +" 'make-interned-syntax-introducer" +" 'make-syntax-delta-introducer" +" 'syntax-local-make-delta-introducer" +" 'syntax-local-value" +" 'syntax-local-value/immediate" +" 'syntax-local-lift-expression" +" 'syntax-local-lift-values-expression" +" 'syntax-local-lift-context" +" 'syntax-local-lift-module" +" 'syntax-local-lift-require" +" 'syntax-local-lift-provide" +" 'syntax-local-lift-module-end-declaration" +" 'syntax-local-module-defined-identifiers" +" 'syntax-local-module-required-identifiers" +" 'syntax-local-module-exports" +" 'syntax-local-submodules" +" 'syntax-local-get-shadower" +" 'local-expand" +" 'local-expand/capture-lifts" +" 'local-transformer-expand" +" 'local-transformer-expand/capture-lifts" +" 'syntax-local-expand-expression" +" 'internal-definition-context?" +" 'syntax-local-make-definition-context" +" 'syntax-local-bind-syntaxes" +" 'internal-definition-context-binding-identifiers" +" 'internal-definition-context-introduce" +" 'internal-definition-context-seal" +" 'identifier-remove-from-definition-context" +" 'make-set!-transformer" +" 'prop:set!-transformer" +" 'set!-transformer?" +" 'set!-transformer-procedure" +" 'rename-transformer?" +" 'prop:rename-transformer" +" 'make-rename-transformer" +" 'rename-transformer-target" +" 'prop:liberal-define-context" +" 'liberal-define-context?" +" 'prop:expansion-contexts" +" 'module-path?" +" 'resolved-module-path?" +" 'make-resolved-module-path" +" 'resolved-module-path-name" +" 'module-path-index?" +" 'module-path-index-resolve" +" 'module-path-index-join" +" 'module-path-index-split" +" 'module-path-index-submodule" +" 'current-module-name-resolver" +" 'current-module-declare-name" +" 'current-module-declare-source" +" 'current-namespace" +" 'namespace-module-registry" +" 'namespace?" +" 'variable-reference->empty-namespace" +" 'variable-reference->namespace" +" 'variable-reference->resolved-module-path" +" 'variable-reference->module-path-index" +" 'variable-reference->module-source" +" 'variable-reference->phase" +" 'variable-reference->module-base-phase" +" 'variable-reference->module-declaration-inspector" +" 'read-syntax" +" 'read-syntax/recursive))" +"(void" +"(begin" +"(add-core-primitive! 'syntax? syntax?$1)" +"(add-core-primitive! 'syntax-e 1/syntax-e)" +"(add-core-primitive! 'syntax->datum 1/syntax->datum)" +"(add-core-primitive! 'datum->syntax 1/datum->syntax)" +"(add-core-primitive! 'bound-identifier=? 1/bound-identifier=?)" +"(add-core-primitive! 'free-identifier=? 1/free-identifier=?)" +"(add-core-primitive! 'free-transformer-identifier=? 1/free-transformer-identifier=?)" +"(add-core-primitive! 'free-template-identifier=? 1/free-template-identifier=?)" +"(add-core-primitive! 'free-label-identifier=? 1/free-label-identifier=?)" +"(add-core-primitive! 'identifier-binding 1/identifier-binding)" +"(add-core-primitive! 'identifier-transformer-binding 1/identifier-transformer-binding)" +"(add-core-primitive! 'identifier-template-binding 1/identifier-template-binding)" +"(add-core-primitive! 'identifier-label-binding 1/identifier-label-binding)" +"(add-core-primitive! 'identifier-binding-symbol 1/identifier-binding-symbol)" +"(add-core-primitive! 'identifier-prune-lexical-context 1/identifier-prune-lexical-context)" +"(add-core-primitive! 'syntax-debug-info 1/syntax-debug-info)" +"(add-core-primitive! 'syntax-track-origin 1/syntax-track-origin)" +"(add-core-primitive! 'syntax-shift-phase-level 1/syntax-shift-phase-level)" +"(add-core-primitive! 'syntax-source-module 1/syntax-source-module)" +"(add-core-primitive! 'identifier-prune-to-source-module 1/identifier-prune-to-source-module)" +"(add-core-primitive! 'syntax-source 1/syntax-source)" +"(add-core-primitive! 'syntax-line 1/syntax-line)" +"(add-core-primitive! 'syntax-column 1/syntax-column)" +"(add-core-primitive! 'syntax-position 1/syntax-position)" +"(add-core-primitive! 'syntax-span 1/syntax-span)" +"(add-core-primitive! 'syntax->list 1/syntax->list)" +"(add-core-primitive! 'syntax-property syntax-property$1)" +"(add-core-primitive! 'syntax-property-remove 1/syntax-property-remove)" +"(add-core-primitive! 'syntax-property-preserved? 1/syntax-property-preserved?)" +"(add-core-primitive! 'syntax-property-symbol-keys 1/syntax-property-symbol-keys)" +"(add-core-primitive! 'syntax-original? 1/syntax-original?)" +"(add-core-primitive! 'syntax-tainted? 1/syntax-tainted?)" +"(add-core-primitive! 'syntax-arm 1/syntax-arm)" +"(add-core-primitive! 'syntax-disarm 1/syntax-disarm)" +"(add-core-primitive! 'syntax-rearm 1/syntax-rearm)" +"(add-core-primitive! 'syntax-taint 1/syntax-taint)" +"(add-core-primitive! 'raise-syntax-error raise-syntax-error$1)" +"(add-core-primitive! 'struct:exn:fail:syntax 1/struct:exn:fail:syntax)" +"(add-core-primitive! 'exn:fail:syntax make-exn:fail:syntax$1)" +"(add-core-primitive! 'make-exn:fail:syntax make-exn:fail:syntax$1)" +"(add-core-primitive! 'exn:fail:syntax? 1/exn:fail:syntax?)" +"(add-core-primitive! 'exn:fail:syntax-exprs 1/exn:fail:syntax-exprs)" +"(add-core-primitive! 'struct:exn:fail:syntax:unbound 1/struct:exn:fail:syntax:unbound)" +"(add-core-primitive! 'exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1)" +"(add-core-primitive! 'make-exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1)" +"(add-core-primitive! 'exn:fail:syntax:unbound? 1/exn:fail:syntax:unbound?)" +"(add-core-primitive! 'current-module-path-for-load 1/current-module-path-for-load)" +"(add-core-primitive! 'prop:exn:missing-module 1/prop:exn:missing-module)" +"(add-core-primitive! 'exn:missing-module? 1/exn:missing-module?)" +"(add-core-primitive! 'exn:missing-module-accessor 1/exn:missing-module-accessor)" +"(add-core-primitive! 'struct:exn:fail:filesystem:missing-module 1/struct:exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module 1/make-exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'make-exn:fail:filesystem:missing-module 1/make-exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module? 1/exn:fail:filesystem:missing-module?)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module-path 1/exn:fail:filesystem:missing-module-path)" +"(add-core-primitive! 'struct:exn:fail:syntax:missing-module 1/struct:exn:fail:syntax:missing-module)" +"(add-core-primitive! 'exn:fail:syntax:missing-module 1/make-exn:fail:syntax:missing-module)" +"(add-core-primitive! 'make-exn:fail:syntax:missing-module 1/make-exn:fail:syntax:missing-module)" +"(add-core-primitive! 'exn:fail:syntax:missing-module? 1/exn:fail:syntax:missing-module?)" +"(add-core-primitive! 'exn:fail:syntax:missing-module-path 1/exn:fail:syntax:missing-module-path)" +"(add-core-primitive! 'syntax-transforming? 1/syntax-transforming?)" +"(add-core-primitive! 'syntax-transforming-with-lifts? 1/syntax-transforming-with-lifts?)" +"(add-core-primitive! 'syntax-transforming-module-expression? 1/syntax-transforming-module-expression?)" +"(add-core-primitive! 'syntax-local-transforming-module-provides? 1/syntax-local-transforming-module-provides?)" +"(add-core-primitive! 'syntax-local-context 1/syntax-local-context)" +"(add-core-primitive! 'syntax-local-introduce 1/syntax-local-introduce)" +"(add-core-primitive! 'syntax-local-identifier-as-binding 1/syntax-local-identifier-as-binding)" +"(add-core-primitive! 'syntax-local-phase-level 1/syntax-local-phase-level)" +"(add-core-primitive! 'syntax-local-name 1/syntax-local-name)" +"(add-core-primitive! 'make-syntax-introducer 1/make-syntax-introducer)" +"(add-core-primitive! 'make-interned-syntax-introducer 1/make-interned-syntax-introducer)" +"(add-core-primitive! 'make-syntax-delta-introducer 1/make-syntax-delta-introducer)" +"(add-core-primitive! 'syntax-local-make-delta-introducer 1/syntax-local-make-delta-introducer)" +"(add-core-primitive! 'syntax-local-value 1/syntax-local-value)" +"(add-core-primitive! 'syntax-local-value/immediate 1/syntax-local-value/immediate)" +"(add-core-primitive! 'syntax-local-lift-expression 1/syntax-local-lift-expression)" +"(add-core-primitive! 'syntax-local-lift-values-expression 1/syntax-local-lift-values-expression)" +"(add-core-primitive! 'syntax-local-lift-context 1/syntax-local-lift-context)" +"(add-core-primitive! 'syntax-local-lift-module 1/syntax-local-lift-module)" +"(add-core-primitive! 'syntax-local-lift-require 1/syntax-local-lift-require)" +"(add-core-primitive! 'syntax-local-lift-provide 1/syntax-local-lift-provide)" +"(add-core-primitive! 'syntax-local-lift-module-end-declaration 1/syntax-local-lift-module-end-declaration)" +"(add-core-primitive! 'syntax-local-module-defined-identifiers 1/syntax-local-module-defined-identifiers)" +"(add-core-primitive! 'syntax-local-module-required-identifiers 1/syntax-local-module-required-identifiers)" +"(add-core-primitive! 'syntax-local-module-exports 1/syntax-local-module-exports)" +"(add-core-primitive! 'syntax-local-submodules 1/syntax-local-submodules)" +"(add-core-primitive! 'syntax-local-get-shadower 1/syntax-local-get-shadower)" +"(add-core-primitive! 'local-expand 1/local-expand)" +"(add-core-primitive! 'local-expand/capture-lifts 1/local-expand/capture-lifts)" +"(add-core-primitive! 'local-transformer-expand 1/local-transformer-expand)" +"(add-core-primitive! 'local-transformer-expand/capture-lifts 1/local-transformer-expand/capture-lifts)" +"(add-core-primitive! 'syntax-local-expand-expression 1/syntax-local-expand-expression)" +"(add-core-primitive! 'internal-definition-context? 1/internal-definition-context?)" +"(add-core-primitive! 'syntax-local-make-definition-context 1/syntax-local-make-definition-context)" +"(add-core-primitive! 'syntax-local-bind-syntaxes 1/syntax-local-bind-syntaxes)" +"(add-core-primitive!" +" 'internal-definition-context-binding-identifiers" +" 1/internal-definition-context-binding-identifiers)" +"(add-core-primitive! 'internal-definition-context-introduce 1/internal-definition-context-introduce)" +"(add-core-primitive! 'internal-definition-context-seal 1/internal-definition-context-seal)" +"(add-core-primitive! 'identifier-remove-from-definition-context 1/identifier-remove-from-definition-context)" +"(add-core-primitive! 'make-set!-transformer 1/make-set!-transformer)" +"(add-core-primitive! 'prop:set!-transformer 1/prop:set!-transformer)" +"(add-core-primitive! 'set!-transformer? 1/set!-transformer?)" +"(add-core-primitive! 'set!-transformer-procedure 1/set!-transformer-procedure)" +"(add-core-primitive! 'rename-transformer? 1/rename-transformer?)" +"(add-core-primitive! 'prop:rename-transformer 1/prop:rename-transformer)" +"(add-core-primitive! 'make-rename-transformer 1/make-rename-transformer)" +"(add-core-primitive! 'rename-transformer-target 1/rename-transformer-target)" +"(add-core-primitive! 'prop:liberal-define-context 1/prop:liberal-define-context)" +"(add-core-primitive! 'liberal-define-context? has-liberal-define-context-property?)" +"(add-core-primitive! 'prop:expansion-contexts 1/prop:expansion-contexts)" +"(add-core-primitive! 'module-path? 1/module-path?)" +"(add-core-primitive! 'resolved-module-path? 1/resolved-module-path?)" +"(add-core-primitive! 'make-resolved-module-path 1/make-resolved-module-path)" +"(add-core-primitive! 'resolved-module-path-name 1/resolved-module-path-name)" +"(add-core-primitive! 'module-path-index? 1/module-path-index?)" +"(add-core-primitive! 'module-path-index-resolve 1/module-path-index-resolve)" +"(add-core-primitive! 'module-path-index-join 1/module-path-index-join)" +"(add-core-primitive! 'module-path-index-split 1/module-path-index-split)" +"(add-core-primitive! 'module-path-index-submodule 1/module-path-index-submodule)" +"(add-core-primitive! 'current-module-name-resolver 1/current-module-name-resolver)" +"(add-core-primitive! 'current-module-declare-name 1/current-module-declare-name)" +"(add-core-primitive! 'current-module-declare-source 1/current-module-declare-source)" +"(add-core-primitive! 'current-namespace 1/current-namespace)" +"(add-core-primitive! 'namespace-module-registry namespace-module-registry$1)" +"(add-core-primitive! 'namespace? 1/namespace?)" +"(add-core-primitive! 'variable-reference->empty-namespace 1/variable-reference->empty-namespace)" +"(add-core-primitive! 'variable-reference->namespace 1/variable-reference->namespace)" +"(add-core-primitive! 'variable-reference->resolved-module-path 1/variable-reference->resolved-module-path)" +"(add-core-primitive! 'variable-reference->module-path-index 1/variable-reference->module-path-index)" +"(add-core-primitive! 'variable-reference->module-source 1/variable-reference->module-source)" +"(add-core-primitive! 'variable-reference->phase 1/variable-reference->phase)" +"(add-core-primitive! 'variable-reference->module-base-phase 1/variable-reference->module-base-phase)" +"(add-core-primitive!" +" 'variable-reference->module-declaration-inspector" +" 1/variable-reference->module-declaration-inspector)" +"(add-core-primitive! 'read-syntax 1/read-syntax)" +"(add-core-primitive! 'read-syntax/recursive 1/read-syntax/recursive)))" +"(define-values" +"(declare-kernel-module!8.1)" +"(lambda(eval1_0 main-ids2_0 read-ids3_0 ns7_1)" +"(begin" +" 'declare-kernel-module!8" +"(let-values(((ns_120) ns7_1))" +"(let-values()" +"(let-values(((main-ids_0) main-ids2_0))" +"(let-values(((read-ids_0) read-ids3_0))" +"(let-values()" +"(begin" +"(let-values(((temp53_5) '#%kernel)" +"((temp54_4) '#%runtime)" +"((temp55_3)(set-union primitive-ids(set-union main-ids_0 read-ids_0)))" +"((temp56_4)" +"(hasheq" +" 'variable-reference?" +" 1/variable-reference?" +" 'variable-reference-constant?" +" 1/variable-reference-constant?" +" 'variable-reference-from-unsafe?" +" 1/variable-reference-from-unsafe?))" +"((ns57_2) ns_120))" +"(copy-runtime-module!26.1 unsafe-undefined temp56_4 ns57_2 #t #f temp55_3 temp54_4 temp53_5))" +"(let-values(((temp58_4) '#%kernel)((temp59_7) '(#%core #%runtime #%main #%read))((ns60_2) ns_120))" +"(declare-reexporting-module!50.1 ns60_2 #t temp58_4 temp59_7)))))))))))" +"(define-values" +"(copy-runtime-module!26.1)" +"(lambda(alts14_0 extras15_0 namespace12_0 primitive?16_0 protected?17_0 skip13_0 to11_0 name25_1)" +"(begin" +" 'copy-runtime-module!26" +"(let-values(((name_74) name25_1))" +"(let-values(((to-name_0)(if(eq? to11_0 unsafe-undefined) name_74 to11_0)))" +"(let-values(((ns_121) namespace12_0))" +"(let-values(((skip-syms_0)(if(eq? skip13_0 unsafe-undefined)(seteq) skip13_0)))" +"(let-values(((alts_0)(if(eq? alts14_0 unsafe-undefined) '#hasheq() alts14_0)))" +"(let-values(((extras_0)(if(eq? extras15_0 unsafe-undefined) '#hasheq() extras15_0)))" +"(let-values(((primitive?_9) primitive?16_0))" +"(let-values(((protected?_10) protected?17_0))" +"(let-values()" +"(let-values(((prims_0)(1/primitive-table name_74)))" +"(let-values((()" +"(begin" +"(let-values(((ht_156) prims_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_156)))" +"((letrec-values(((for-loop_17)" +"(lambda(i_175)" +"(begin" +" 'for-loop" +"(if i_175" +"(let-values(((sym_65)" +"(hash-iterate-key ht_156 i_175)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(register-built-in-symbol!" +" sym_65))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_17" +"(hash-iterate-next ht_156 i_175))" +"(values))))" +"(values))))))" +" for-loop_17)" +"(hash-iterate-first ht_156))))" +"(values))))" +"(let-values()" +"(let-values(((ht_157)" +"(let-values(((ht_158) prims_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_158)))" +"((letrec-values(((for-loop_249)" +"(lambda(table_213 i_97)" +"(begin" +" 'for-loop" +"(if i_97" +"(let-values(((sym_93 val_82)" +"(hash-iterate-key+value" +" ht_158" +" i_97)))" +"(let-values(((table_214)" +"(let-values(((table_10)" +" table_213))" +"(if(set-member?" +" skip-syms_0" +" sym_93)" +" table_10" +"(let-values(((table_11)" +" table_10))" +"(let-values(((table_12)" +"(let-values()" +"(let-values(((key_14" +" val_5)" +"(let-values()" +"(values" +" sym_93" +"(let-values(((or-part_167)" +"(hash-ref" +" alts_0" +" sym_93" +" #f)))" +"(if or-part_167" +" or-part_167" +" val_82))))))" +"(hash-set" +" table_11" +" key_14" +" val_5)))))" +"(values table_12)))))))" +"(if(not #f)" +"(for-loop_249" +" table_214" +"(hash-iterate-next ht_158 i_97))" +" table_214)))" +" table_213)))))" +" for-loop_249)" +" '#hasheq()" +"(hash-iterate-first ht_158))))))" +"(let-values(((ht+extras_0)" +"(let-values(((ht_146) extras_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_146)))" +"((letrec-values(((for-loop_253)" +"(lambda(ht_153 i_169)" +"(begin" +" 'for-loop" +"(if i_169" +"(let-values(((k_43 v_48)" +"(hash-iterate-key+value" +" ht_146" +" i_169)))" +"(let-values(((ht_159)" +"(let-values(((ht_160)" +" ht_153))" +"(let-values(((ht_161)" +"(let-values()" +"(hash-set" +" ht_160" +" k_43" +" v_48))))" +"(values ht_161)))))" +"(if(not #f)" +"(for-loop_253" +" ht_159" +"(hash-iterate-next ht_146 i_169))" +" ht_159)))" +" ht_153)))))" +" for-loop_253)" +" ht_157" +"(hash-iterate-first ht_146))))))" +"(let-values(((to-name61_0) to-name_0)" +"((ht+extras62_0) ht+extras_0)" +"((ns63_0) ns_121)" +"((primitive?64_0) primitive?_9)" +"((protected?65_0) protected?_10))" +"(declare-hash-based-module!41.1" +" ns63_0" +" primitive?64_0" +" null" +" protected?65_0" +" #f" +" to-name61_0" +" ht+extras62_0)))))))))))))))))))" +"(define-values" +"(declare-hash-based-module!41.1)" +"(lambda(namespace29_0 primitive?30_0 protected32_0 protected?31_0 register-builtin?33_0 name39_0 ht40_0)" +"(begin" +" 'declare-hash-based-module!41" +"(let-values(((name_75) name39_0))" +"(let-values(((ht_162) ht40_0))" +"(let-values(((ns_122) namespace29_0))" +"(let-values(((primitive?_10) primitive?30_0))" +"(let-values(((protected?_11) protected?31_0))" +"(let-values(((protected-syms_0) protected32_0))" +"(let-values(((register-builtin?_0) register-builtin?33_0))" +"(let-values()" +"(let-values(((mpi_5)(1/module-path-index-join(list 'quote name_75) #f)))" +"(let-values(((ns66_0) ns_122)" +"((temp67_5)" +"(let-values(((temp69_3) #t)" +"((primitive?70_0) primitive?_10)" +"((temp71_4) #t)" +"((temp72_3)(not protected?_11))" +"((mpi73_1) mpi_5)" +"((temp74_2)" +"(hasheqv" +" 0" +"(let-values(((ht_163) ht_162))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_163)))" +"((letrec-values(((for-loop_277)" +"(lambda(table_215 i_176)" +"(begin" +" 'for-loop" +"(if i_176" +"(let-values(((sym_103)" +"(hash-iterate-key" +" ht_163" +" i_176)))" +"(let-values(((table_6)" +"(let-values(((table_7)" +" table_215))" +"(let-values(((table_216)" +"(let-values()" +"(let-values(((key_86" +" val_83)" +"(let-values()" +"(let-values((()" +"(begin" +"(if register-builtin?_0" +"(let-values()" +"(register-built-in-symbol!" +" sym_103))" +"(void))" +"(values))))" +"(let-values(((binding_27)" +"(let-values(((mpi76_0)" +" mpi_5)" +"((temp77_3)" +" 0)" +"((sym78_0)" +" sym_103))" +"(make-module-binding22.1" +" #f" +" null" +" #f" +" #f" +" unsafe-undefined" +" unsafe-undefined" +" 0" +" unsafe-undefined" +" unsafe-undefined" +" mpi76_0" +" temp77_3" +" sym78_0))))" +"(values" +" sym_103" +"(if(let-values(((or-part_56)" +" protected?_11))" +"(if or-part_56" +" or-part_56" +"(member" +" sym_103" +" protected-syms_0)))" +"(provided1.1" +" binding_27" +" #t" +" #f)" +" binding_27)))))))" +"(hash-set" +" table_7" +" key_86" +" val_83)))))" +"(values" +" table_216)))))" +"(if(not #f)" +"(for-loop_277" +" table_6" +"(hash-iterate-next" +" ht_163" +" i_176))" +" table_6)))" +" table_215)))))" +" for-loop_277)" +" '#hash()" +"(hash-iterate-first ht_163))))))" +"((temp75_4)" +"(lambda(data-box_6" +" ns_123" +" phase-shift_20" +" phase-level_23" +" self_29" +" bulk-binding-registry_19" +" insp_23)" +"(if(= 0 phase-level_23)" +"(let-values()" +"(begin" +"(let-values(((ht_164) ht_162))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_164)))" +"((letrec-values(((for-loop_278)" +"(lambda(i_177)" +"(begin" +" 'for-loop" +"(if i_177" +"(let-values(((sym_104 val_84)" +"(hash-iterate-key+value" +" ht_164" +" i_177)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-variable!" +" ns_123" +" 0" +" sym_104" +" val_84))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_278" +"(hash-iterate-next" +" ht_164" +" i_177))" +"(values))))" +"(values))))))" +" for-loop_278)" +"(hash-iterate-first ht_164))))" +"(void)))" +"(void)))))" +"(make-module39.1" +" temp69_3" +" unsafe-undefined" +" unsafe-undefined" +" temp75_4" +" #f" +" 0" +" 0" +" temp72_3" +" unsafe-undefined" +" temp71_4" +" unsafe-undefined" +" primitive?70_0" +" temp74_2" +" null" +" mpi73_1" +" #f" +" null" +" #f)))" +"((temp68_6)(1/module-path-index-resolve mpi_5)))" +"(declare-module!58.1 #t ns66_0 temp67_5 temp68_6))))))))))))))" +"(define-values" +"(declare-reexporting-module!50.1)" +"(lambda(namespace45_0 reexport?44_0 name48_0 require-names49_0)" +"(begin" +" 'declare-reexporting-module!50" +"(let-values(((name_76) name48_0))" +"(let-values(((require-names_0) require-names49_0))" +"(let-values(((reexport?_0) reexport?44_0))" +"(let-values(((ns_124) namespace45_0))" +"(let-values()" +"(let-values(((mpi_52)(1/module-path-index-join(list 'quote name_76) #f)))" +"(let-values(((require-mpis_0)" +"(reverse$1" +"(let-values(((lst_108) require-names_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_108)))" +"((letrec-values(((for-loop_209)" +"(lambda(fold-var_143 lst_109)" +"(begin" +" 'for-loop" +"(if(pair? lst_109)" +"(let-values(((require-name_0)(unsafe-car lst_109))" +"((rest_110)(unsafe-cdr lst_109)))" +"(let-values(((fold-var_145)" +"(let-values(((fold-var_285) fold-var_143))" +"(let-values(((fold-var_39)" +"(let-values()" +"(cons" +"(let-values()" +"(1/module-path-index-join" +"(list" +" 'quote" +" require-name_0)" +" #f))" +" fold-var_285))))" +"(values fold-var_39)))))" +"(if(not #f)" +"(for-loop_209 fold-var_145 rest_110)" +" fold-var_145)))" +" fold-var_143)))))" +" for-loop_209)" +" null" +" lst_108))))))" +"(let-values(((ns79_1) ns_124)" +"((temp80_2)" +"(let-values(((temp82_3) #t)" +"((temp83_3) #t)" +"((mpi84_0) mpi_52)" +"((temp85_3)(list(cons 0 require-mpis_0)))" +"((temp86_5)" +"(if reexport?_0" +"(hasheqv" +" 0" +"(let-values(((lst_159) require-mpis_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_159)))" +"((letrec-values(((for-loop_279)" +"(lambda(table_217 lst_309)" +"(begin" +" 'for-loop" +"(if(pair? lst_309)" +"(let-values(((require-mpi_0)" +"(unsafe-car lst_309))" +"((rest_180)" +"(unsafe-cdr lst_309)))" +"(let-values(((table_218)" +"(let-values(((m_29)" +"(namespace->module" +" ns_124" +"(1/module-path-index-resolve" +" require-mpi_0))))" +"(begin" +" #t" +"((letrec-values(((for-loop_187)" +"(lambda(table_140)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_219)" +"(let-values(((ht_165)" +"(hash-ref" +"(shift-provides-module-path-index" +"(module-provides" +" m_29)" +"(module-self" +" m_29)" +" require-mpi_0)" +" 0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_165)))" +"((letrec-values(((for-loop_280)" +"(lambda(table_141" +" i_178)" +"(begin" +" 'for-loop" +"(if i_178" +"(let-values(((sym_105" +" binding_28)" +"(hash-iterate-key+value" +" ht_165" +" i_178)))" +"(let-values(((table_31)" +"(let-values(((table_32)" +" table_141))" +"(let-values(((table_220)" +"(let-values()" +"(let-values(((key_87" +" val_85)" +"(let-values()" +"(values" +" sym_105" +" binding_28))))" +"(hash-set" +" table_32" +" key_87" +" val_85)))))" +"(values" +" table_220)))))" +"(if(not" +" #f)" +"(for-loop_280" +" table_31" +"(hash-iterate-next" +" ht_165" +" i_178))" +" table_31)))" +" table_141)))))" +" for-loop_280)" +" table_140" +"(hash-iterate-first" +" ht_165))))))" +" table_219))))))" +" for-loop_187)" +" table_217)))))" +"(if(not #f)" +"(for-loop_279 table_218 rest_180)" +" table_218)))" +" table_217)))))" +" for-loop_279)" +" '#hash()" +" lst_159))))" +" '#hasheqv()))" +"((void87_0) void))" +"(make-module39.1" +" temp82_3" +" unsafe-undefined" +" unsafe-undefined" +" void87_0" +" #f" +" 0" +" 0" +" #f" +" unsafe-undefined" +" temp83_3" +" unsafe-undefined" +" #f" +" temp86_5" +" temp85_3" +" mpi84_0" +" #f" +" null" +" #f)))" +"((temp81_4)(1/module-path-index-resolve mpi_52)))" +"(declare-module!58.1 #t ns79_1 temp80_2 temp81_4))))))))))))" +"(define-values" +"(read-primitives)" +"(hasheq" +" 'read" +" 1/read" +" 'read/recursive" +" 1/read/recursive" +" 'read-language" +" 1/read-language" +" 'string->number" +" 1/string->number" +" 'current-reader-guard" +" 1/current-reader-guard" +" 'read-square-bracket-as-paren" +" 1/read-square-bracket-as-paren" +" 'read-curly-brace-as-paren" +" 1/read-curly-brace-as-paren" +" 'read-square-bracket-with-tag" +" 1/read-square-bracket-with-tag" +" 'read-curly-brace-with-tag" +" 1/read-curly-brace-with-tag" +" 'read-cdot" +" 1/read-cdot" +" 'read-accept-graph" +" 1/read-accept-graph" +" 'read-accept-compiled" +" 1/read-accept-compiled" +" 'read-accept-box" +" 1/read-accept-box" +" 'read-decimal-as-inexact" +" 1/read-decimal-as-inexact" +" 'read-accept-dot" +" 1/read-accept-dot" +" 'read-accept-infix-dot" +" 1/read-accept-infix-dot" +" 'read-accept-quasiquote" +" 1/read-accept-quasiquote" +" 'read-accept-reader" +" 1/read-accept-reader" +" 'read-accept-lang" +" 1/read-accept-lang" +" 'current-readtable" +" 1/current-readtable" +" 'readtable?" +" 1/readtable?" +" 'make-readtable" +" 1/make-readtable" +" 'readtable-mapping" +" 1/readtable-mapping" +" 'special-comment?" +" 1/special-comment?" +" 'make-special-comment" +" 1/make-special-comment" +" 'special-comment-value" +" 1/special-comment-value))" +"(define-values" +"(main-primitives)" +"(hasheq" +" 'eval" +" eval$1" +" 'eval-syntax" +" 1/eval-syntax" +" 'compile" +" compile$1" +" 'compile-syntax" +" 1/compile-syntax" +" 'expand" +" 1/expand" +" 'expand-syntax" +" 1/expand-syntax" +" 'expand-once" +" 1/expand-once" +" 'expand-syntax-once" +" 1/expand-syntax-once" +" 'expand-to-top-form" +" 1/expand-to-top-form" +" 'expand-syntax-to-top-form" +" 1/expand-syntax-to-top-form" +" 'dynamic-require" +" 1/dynamic-require" +" 'dynamic-require-for-syntax" +" 1/dynamic-require-for-syntax" +" 'load" +" 1/load" +" 'load-extension" +" 1/load-extension" +" 'load/use-compiled" +" 1/load/use-compiled" +" 'current-eval" +" 1/current-eval" +" 'current-compile" +" 1/current-compile" +" 'current-load" +" 1/current-load" +" 'current-load/use-compiled" +" 1/current-load/use-compiled" +" 'collection-path" +" 1/collection-path" +" 'collection-file-path" +" 1/collection-file-path" +" 'find-library-collection-paths" +" 1/find-library-collection-paths" +" 'find-library-collection-links" +" 1/find-library-collection-links" +" 'current-library-collection-paths" +" 1/current-library-collection-paths" +" 'current-library-collection-links" +" 1/current-library-collection-links" +" 'use-compiled-file-paths" +" 1/use-compiled-file-paths" +" 'current-compiled-file-roots" +" 1/current-compiled-file-roots" +" 'use-compiled-file-check" +" 1/use-compiled-file-check" +" 'use-collection-link-paths" +" 1/use-collection-link-paths" +" 'use-user-specific-search-paths" +" 1/use-user-specific-search-paths" +" 'compiled-expression?" +" 1/compiled-expression?" +" 'compiled-module-expression?" +" 1/compiled-module-expression?" +" 'module-compiled-name" +" 1/module-compiled-name" +" 'module-compiled-submodules" +" 1/module-compiled-submodules" +" 'module-compiled-language-info" +" 1/module-compiled-language-info" +" 'module-compiled-imports" +" 1/module-compiled-imports" +" 'module-compiled-exports" +" 1/module-compiled-exports" +" 'module-compiled-indirect-exports" +" 1/module-compiled-indirect-exports" +" 'compiled-expression-recompile" +" 1/compiled-expression-recompile" +" 'make-empty-namespace" +" 1/make-empty-namespace" +" 'namespace-attach-module" +" 1/namespace-attach-module" +" 'namespace-attach-module-declaration" +" 1/namespace-attach-module-declaration" +" 'namespace-symbol->identifier" +" 1/namespace-symbol->identifier" +" 'namespace-module-identifier" +" 1/namespace-module-identifier" +" 'namespace-syntax-introduce" +" 1/namespace-syntax-introduce" +" 'namespace-require" +" 1/namespace-require" +" 'namespace-require/copy" +" 1/namespace-require/copy" +" 'namespace-require/constant" +" 1/namespace-require/constant" +" 'namespace-require/expansion-time" +" 1/namespace-require/expansion-time" +" 'namespace-variable-value" +" 1/namespace-variable-value" +" 'namespace-set-variable-value!" +" 1/namespace-set-variable-value!" +" 'namespace-undefine-variable!" +" 1/namespace-undefine-variable!" +" 'namespace-mapped-symbols" +" 1/namespace-mapped-symbols" +" 'namespace-base-phase" +" 1/namespace-base-phase" +" 'module-declared?" +" 1/module-declared?" +" 'module-predefined?" +" 1/module-predefined?" +" 'module->language-info" +" 1/module->language-info" +" 'module->imports" +" 1/module->imports" +" 'module->exports" +" 1/module->exports" +" 'module->indirect-exports" +" 1/module->indirect-exports" +" 'module-compiled-cross-phase-persistent?" +" 1/module-compiled-cross-phase-persistent?" +" 'module-provide-protected?" +" 1/module-provide-protected?" +" 'module->namespace" +" 1/module->namespace" +" 'namespace-unprotect-module" +" 1/namespace-unprotect-module))" +"(define-values" +"(utils-primitives)" +"(hasheq" +" 'path-string?" +" path-string?" +" 'normal-case-path" +" normal-case-path" +" 'path-replace-extension" +" path-replace-extension" +" 'path-add-extension" +" path-add-extension" +" 'reroot-path" +" reroot-path" +" 'path-list-string->path-list" +" path-list-string->path-list" +" 'find-executable-path" +" find-executable-path" +" 'call-with-default-reading-parameterization" +" call-with-default-reading-parameterization" +" 'collection-path" +" 1/collection-path" +" 'collection-file-path" +" 1/collection-file-path" +" 'find-library-collection-paths" +" 1/find-library-collection-paths" +" 'find-library-collection-links" +" 1/find-library-collection-links" +" 'load/use-compiled" +" 1/load/use-compiled" +" 'find-main-config" +" find-main-config" +" 'find-main-collects" +" find-main-collects))" +"(define-values(expobs-primitives)(hasheq 'current-expand-observe current-expand-observe))" +"(define-values" +"(struct:TH-place-channel TH-place-channel TH-place-channel? TH-place-channel-ref TH-place-channel-set!)" +"(make-struct-type 'TH-place-channel #f 2 0 #f(list(cons prop:evt(lambda(x_96)(TH-place-channel-ref x_96 0))))))" +"(define-values" +"(TH-place-channel-in TH-place-channel-out)" +"(values(lambda(x_97)(TH-place-channel-ref x_97 0))(lambda(x_83)(TH-place-channel-ref x_83 1))))" +"(define-values" +"(place-struct-primitives)" +"(hasheq" +" 'struct:TH-place-channel" +" struct:TH-place-channel" +" 'TH-place-channel" +" TH-place-channel" +" 'TH-place-channel?" +" TH-place-channel?" +" 'TH-place-channel-in" +" TH-place-channel-in" +" 'TH-place-channel-out" +" TH-place-channel-out))" +"(define-values" +"(linklet-primitives)" +"(hasheq" +" 'primitive-table" +" 1/primitive-table" +" 'primitive->compiled-position" +" 1/primitive->compiled-position" +" 'compiled-position->primitive" +" 1/compiled-position->primitive" +" 'primitive-in-category?" +" 1/primitive-in-category?" +" 'linklet?" +" 1/linklet?" +" 'compile-linklet" +" 1/compile-linklet" +" 'recompile-linklet" +" 1/recompile-linklet" +" 'eval-linklet" +" 1/eval-linklet" +" 'read-compiled-linklet" +" 1/read-compiled-linklet" +" 'instantiate-linklet" +" 1/instantiate-linklet" +" 'linklet-import-variables" +" 1/linklet-import-variables" +" 'linklet-export-variables" +" 1/linklet-export-variables" +" 'instance?" +" 1/instance?" +" 'make-instance" +" 1/make-instance" +" 'instance-name" +" 1/instance-name" +" 'instance-data" +" 1/instance-data" +" 'instance-variable-names" +" 1/instance-variable-names" +" 'instance-variable-value" +" 1/instance-variable-value" +" 'instance-set-variable-value!" +" 1/instance-set-variable-value!" +" 'instance-unset-variable!" +" 1/instance-unset-variable!" +" 'linklet-directory?" +" 1/linklet-directory?" +" 'hash->linklet-directory" +" 1/hash->linklet-directory" +" 'linklet-directory->hash" +" 1/linklet-directory->hash" +" 'linklet-bundle?" +" 1/linklet-bundle?" +" 'hash->linklet-bundle" +" 1/hash->linklet-bundle" +" 'linklet-bundle->hash" +" 1/linklet-bundle->hash" +" 'variable-reference?" +" 1/variable-reference?" +" 'variable-reference->instance" +" 1/variable-reference->instance" +" 'variable-reference-constant?" +" 1/variable-reference-constant?" +" 'variable-reference-from-unsafe?" +" 1/variable-reference-from-unsafe?))" +"(define-values" +"(with-module-reading-parameterization)" +"(lambda(thunk_3)" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t" +" 1/read-accept-compiled" +" #t" +" read-case-sensitive" +" #t" +" 1/read-square-bracket-as-paren" +" #t" +" 1/read-curly-brace-as-paren" +" #t" +" 1/read-square-bracket-with-tag" +" #f" +" 1/read-curly-brace-with-tag" +" #f" +" 1/read-accept-box" +" #t" +" read-accept-bar-quote" +" #t" +" 1/read-accept-graph" +" #t" +" 1/read-decimal-as-inexact" +" #t" +" 1/read-cdot" +" #f" +" 1/read-accept-dot" +" #t" +" 1/read-accept-infix-dot" +" #t" +" 1/read-accept-quasiquote" +" #t" +" 1/current-readtable" +" #f)" +"(let-values()(thunk_3))))))" +"(define-values" +"(check-module-form)" +"(lambda(exp_0 filename_1)" +"(begin" +"(if(let-values(((or-part_311)(eof-object? exp_0)))" +"(if or-part_311 or-part_311(eof-object?(1/syntax-e exp_0))))" +"(let-values()" +"(if filename_1" +"(error" +" 'load-handler" +" (string-append \"expected a `module' declaration, but found end-of-file\\n\" \" file: ~a\")" +" filename_1)" +" #f))" +"(if(1/compiled-module-expression?(1/syntax-e exp_0))" +"(let-values() exp_0)" +"(if(if(syntax?$1 exp_0)" +"(if(pair?(1/syntax-e exp_0))" +"(if(eq? 'module(1/syntax-e(car(1/syntax-e exp_0))))" +"(let-values(((r_42)(cdr(1/syntax-e exp_0))))" +"(let-values(((r_4)(if(syntax?$1 r_42)(1/syntax-e r_42) r_42)))" +"(if(pair? r_4)(identifier?(car r_4)) #f)))" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(1/datum->syntax exp_0(cons(1/namespace-module-identifier)(cdr(1/syntax-e exp_0))) exp_0 exp_0))" +"(let-values()" +"(if filename_1" +"(error" +" 'default-load-handler" +" (string-append \"expected a `module' declaration, but found something else\\n\" \" file: ~a\")" +" filename_1)" +" #f))))))))" +"(define-values" +"(default-load-handler)" +"(lambda(path_12 expected-mod_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(path-string? path_12)" +"(void)" +" (let-values () (raise-argument-error 'default-load-handler \"path-string?\" path_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)(not expected-mod_0)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(symbol? expected-mod_0)))" +"(if or-part_2" +" or-part_2" +"(if(pair? expected-mod_0)" +"(if(list? expected-mod_0)" +"(if(let-values(((or-part_26)(not(car expected-mod_0))))" +"(if or-part_26 or-part_26(symbol?(car expected-mod_0))))" +"(andmap2 symbol?(cdr expected-mod_0))" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'default-load-handler" +" \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\"" +" expected-mod_0)))" +"(values))))" +"(let-values(((maybe-count-lines!_0)" +"(lambda(i_126)" +"(begin" +" 'maybe-count-lines!" +" (if (regexp-match? '#rx\"[.]zo$\" path_12)" +"(void)" +"(let-values()(port-count-lines! i_126)))))))" +"(if expected-mod_0" +"(let-values()" +"((call-with-input-module-file" +" path_12" +"(lambda(i_179)" +"(begin" +"(maybe-count-lines!_0 i_179)" +"(with-module-reading-parameterization+delay-source" +" path_12" +"(lambda()" +"(let-values(((c1_32)(linklet-directory-start i_179)))" +"(if c1_32" +"((lambda(pos_123)" +"(let-values(((b-pos_0)" +"(search-directory i_179 pos_123(encode-symbols expected-mod_0))))" +"(if b-pos_0" +"(let-values()" +"(begin" +"(file-position i_179 b-pos_0)" +"(let-values(((or-part_12)(cached-bundle i_179)))" +"(if or-part_12" +" or-part_12" +"(let-values(((v_0)(1/read i_179)))" +"(if(1/compiled-module-expression? v_0)" +"(lambda()((1/current-eval) v_0))" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a compiled module\\n\"" +" \" in: ~e\\n\"" +" \" found: ~e\")" +"(object-name i_179)" +" v_0)))))))" +"(if(pair? expected-mod_0)" +"(let-values() void)" +"(let-values()" +"(error" +" 'default-load-handler" +" (string-append \"could not find main module\\n\" \" in: ~e\")" +"(object-name i_179)))))))" +" c1_32)" +"(if(if(pair? expected-mod_0)(not(car expected-mod_0)) #f)" +"(let-values() void)" +"(let-values(((c2_17)(cached-bundle i_179)))" +"(if c2_17" +"((lambda(thunk_8) thunk_8) c2_17)" +"(let-values()" +"(let-values(((s_178)(1/read-syntax(object-name i_179) i_179)))" +"(let-values((()" +"(begin" +"(if(eof-object? s_178)" +"(let-values()" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a `module' declaration;\\n\"" +" \" found end-of-file\\n\"" +" \" in: ~e\")" +"(object-name i_179)))" +"(void))" +"(values))))" +"(let-values(((m-s_0)(check-module-form s_178 path_12)))" +"(let-values(((s2_10)(1/read-syntax(object-name i_179) i_179)))" +"(begin" +"(if(eof-object? s2_10)" +"(void)" +"(let-values()" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a `module' declaration;\\n\"" +" \" found an extra form\\n\"" +" \" in: ~e\\n\"" +" \" found: ~.s\")" +"(object-name i_179)" +" s2_10)))" +"(lambda()((1/current-eval) m-s_0))))))))))))))))))))" +"(let-values()" +"(let-values(((add-top-interaction_0)" +"(lambda(s_498)" +"(begin" +" 'add-top-interaction" +"(1/namespace-syntax-introduce" +"(1/datum->syntax #f(cons '#%top-interaction s_498) s_498))))))" +"(let-values(((path1_0) path_12)" +"((temp2_8)" +"(lambda(i_180)" +"(begin" +" 'temp2" +"(begin" +"(maybe-count-lines!_0 i_180)" +"((letrec-values(((loop_35)" +"(lambda(vals_7)" +"(begin" +" 'loop" +"(let-values(((s_304)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/read-accept-compiled" +" #t" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t)" +"(let-values()" +"(if(load-on-demand-enabled)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" read-on-demand-source" +"(path->complete-path path_12))" +"(let-values()" +"(1/read-syntax" +"(object-name i_180)" +" i_180)))" +"(1/read-syntax" +"(object-name i_180)" +" i_180))))))" +"(if(eof-object? s_304)" +"(apply values vals_7)" +"(loop_35" +"(call-with-continuation-prompt" +"(lambda()" +"(call-with-values" +"(lambda()" +"((1/current-eval)(add-top-interaction_0 s_304)))" +" list))" +"(default-continuation-prompt-tag)" +"(lambda args_10" +"(apply" +" abort-current-continuation" +"(default-continuation-prompt-tag)" +" args_10))))))))))" +" loop_35)" +"(list(void))))))))" +"(call-with-input-file*61.1 'binary path1_0 temp2_8)))))))))))" +"(define-values" +"(linklet-bundle-or-directory-start)" +"(lambda(i_144 tag_1)" +"(begin" +"(let-values(((version-length_0)(string-length(version))))" +"(if(equal?(peek-byte i_144)(char->integer '#\\#))" +"(if(equal?(peek-byte i_144 1)(char->integer '#\\~))" +"(if(equal?(peek-byte i_144 2) version-length_0)" +"(if(equal?(peek-bytes version-length_0 3 i_144)(string->bytes/utf-8(version)))" +"(if(equal?(peek-byte i_144(+ 3 version-length_0))(char->integer tag_1))(+ version-length_0 4) #f)" +" #f)" +" #f)" +" #f)" +" #f)))))" +"(define-values" +"(linklet-directory-start)" +"(lambda(i_92)" +"(begin(let-values(((pos_95)(linklet-bundle-or-directory-start i_92 '#\\D)))(if pos_95(+ pos_95 4) #f)))))" +"(define-values" +"(linklet-bundle-hash-code)" +"(lambda(i_181)" +"(begin" +"(let-values(((pos_15)(linklet-bundle-or-directory-start i_181 '#\\B)))" +"(let-values(((hash-code_7)(if pos_15(peek-bytes 20 pos_15 i_181) #f)))" +"(if(bytes? hash-code_7)" +"(if(= 20(bytes-length hash-code_7))" +"(if(let-values(((vec_70 len_37)" +"(let-values(((vec_71) hash-code_7))" +"(begin(check-bytes vec_71)(values vec_71(unsafe-bytes-length vec_71))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_237)" +"(lambda(result_124 pos_99)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_99 len_37)" +"(let-values(((c_52)(unsafe-bytes-ref vec_70 pos_99)))" +"(let-values(((result_125)" +"(let-values()" +"(let-values(((result_126)" +"(let-values()" +"(let-values()(not(eq? c_52 0))))))" +"(values result_126)))))" +"(if(if(not((lambda x_98 result_125) c_52))(not #f) #f)" +"(for-loop_237 result_125(unsafe-fx+ 1 pos_99))" +" result_125)))" +" result_124)))))" +" for-loop_237)" +" #f" +" 0)))" +" hash-code_7" +" #f)" +" #f)" +" #f))))))" +"(define-values" +"(cached-bundle)" +"(lambda(i_94)" +"(begin" +"(let-values(((c3_10)(module-cache-ref(make-module-cache-key(linklet-bundle-hash-code i_94)))))" +"(if c3_10" +"((lambda(declare-module_0)(lambda()(declare-module_0(1/current-namespace)))) c3_10)" +"(let-values() #f))))))" +"(define-values" +"(read-number)" +"(lambda(i_62)" +"(begin" +"(let-values(((read-byte/not-eof_0)" +"(lambda(i_182)" +"(begin" +" 'read-byte/not-eof" +"(let-values(((v_187)(read-byte i_182)))(if(eof-object? v_187) 0 v_187))))))" +"(bitwise-ior" +"(read-byte/not-eof_0 i_62)" +"(arithmetic-shift(read-byte/not-eof_0 i_62) 8)" +"(arithmetic-shift(read-byte/not-eof_0 i_62) 16)" +"(arithmetic-shift(read-byte/not-eof_0 i_62) 24))))))" +"(define-values" +"(search-directory)" +"(lambda(i_183 pos_124 bstr_5)" +"(begin" +"(if(zero? pos_124)" +"(let-values() #f)" +"(let-values()" +"(let-values((()(begin(file-position i_183 pos_124)(values))))" +"(let-values(((name-len_0)(read-number i_183)))" +"(let-values(((v_255)(read-bytes name-len_0 i_183)))" +"(begin" +"(if(if(bytes? v_255)(=(bytes-length v_255) name-len_0) #f)" +"(void)" +"(let-values()" +"(error" +" 'deafult-load-handler" +"(string-append" +" \"failure getting submodule path\\n\"" +" \" in: ~e\\n\"" +" \" at position: ~a\\n\"" +" \" expected bytes: ~a\\n\"" +" \" read bytes: ~e\")" +"(object-name i_183)" +" pos_124" +" name-len_0" +" v_255)))" +"(if(bytes=? bstr_5 v_255)" +"(let-values()(read-number i_183))" +"(if(bytesbytes/utf-8" +"(symbol->string s_185))))" +"(let-values(((len_40)" +"(bytes-length bstr_6)))" +"(if(< len_40 255)" +"(let-values()" +"(bytes-append" +"(bytes len_40)" +" bstr_6))" +"(let-values()" +"(bytes-append" +" 255" +"(integer->integer-bytes" +" len_40" +" 4" +" #f" +" #f)" +" bstr_6))))))" +" fold-var_65))))" +"(values fold-var_76)))))" +"(if(not #f)(for-loop_111 fold-var_75 rest_44) fold-var_75)))" +" fold-var_74)))))" +" for-loop_111)" +" null" +" lst_267))))))))))" +"(define-values" +"(with-module-reading-parameterization+delay-source)" +"(lambda(path_13 thunk_9)" +"(begin" +"(if(load-on-demand-enabled)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" read-on-demand-source" +"(path->complete-path path_13))" +"(let-values()(with-module-reading-parameterization thunk_9)))" +"(with-module-reading-parameterization thunk_9)))))" +"(define-values" +"(call-with-input-module-file)" +"(lambda(path_14 proc_10)" +"(begin" +"(let-values(((i_156) #f))" +"(dynamic-wind" +"(lambda()" +"(set! i_156(let-values(((path3_0) path_14)((temp4_7) #t))(open-input-file6.1 temp4_7 'binary path3_0))))" +"(lambda()(proc_10 i_156))" +"(lambda()(close-input-port i_156)))))))" +"(define-values(dll-suffix)(system-type 'so-suffix))" +"(define-values" +"(default-load/use-compiled)" +"(let-values(((resolve_0)" +"(lambda(s_72)" +"(begin" +" 'resolve" +"(if(complete-path? s_72)" +" s_72" +"(let-values(((d_36)(current-load-relative-directory)))" +"(if d_36(path->complete-path s_72 d_36) s_72)))))))" +"(let-values(((date-of-1_0)" +"(lambda(a_29)" +"(begin" +" 'date-of-1" +"(let-values(((v_72)(file-or-directory-modify-seconds a_29 #f(lambda() #f))))" +"(if v_72(cons a_29 v_72) #f))))))" +"(let-values(((date-of_0)" +"(lambda(a_39 modes_1 roots_1)" +"(begin" +" 'date-of" +"(ormap2" +"(lambda(root-dir_0)" +"(ormap2" +"(lambda(compiled-dir_0)" +"(let-values(((a_75)(a_39 root-dir_0 compiled-dir_0)))(date-of-1_0 a_75)))" +" modes_1))" +" roots_1)))))" +"(let-values(((date>=?_0)" +"(lambda(modes_2 roots_2 a_76 bm_0)" +"(begin" +" 'date>=?" +"(if a_76" +"(let-values(((am_0)(date-of_0 a_76 modes_2 roots_2)))" +"(let-values(((or-part_28)(if(not bm_0) am_0 #f)))" +"(if or-part_28" +" or-part_28" +"(if am_0(if bm_0(if(>=(cdr am_0)(cdr bm_0)) am_0 #f) #f) #f))))" +" #f)))))" +"(let-values(((with-dir*_0)" +"(lambda(base_23 t_60)" +"(begin" +" 'with-dir*" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-load-relative-directory" +"(if(path? base_23) base_23(current-directory)))" +"(let-values()(t_60)))))))" +"(lambda(path_15 expect-module_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(path-string? path_15)" +"(void)" +" (let-values () (raise-argument-error 'load/use-compiled \"path-string?\" path_15)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_73)(not expect-module_0)))" +"(if or-part_73" +" or-part_73" +"(let-values(((or-part_74)(symbol? expect-module_0)))" +"(if or-part_74" +" or-part_74" +"(if(list? expect-module_0)" +"(if(>(length expect-module_0) 1)" +"(if(let-values(((or-part_75)(symbol?(car expect-module_0))))" +"(if or-part_75 or-part_75(not(car expect-module_0))))" +"(andmap2 symbol?(cdr expect-module_0))" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'load/use-compiled" +" \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\"" +" path_15)))" +"(values))))" +"(let-values(((name_55)(if expect-module_0(1/current-module-declare-name) #f)))" +"(let-values(((ns-hts_0)" +"(if name_55" +"(registry-table-ref(namespace-module-registry$1(1/current-namespace)))" +" #f)))" +"(let-values(((use-path/src_0)(if ns-hts_0(hash-ref(cdr ns-hts_0) name_55 #f) #f)))" +"(if use-path/src_0" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-module-declare-source" +"(cadr use-path/src_0))" +"(let-values()" +"(with-dir*_0" +"(caddr use-path/src_0)" +"(lambda()((1/current-load)(car use-path/src_0) expect-module_0)))))" +"(let-values(((orig-path_0)(resolve_0 path_15)))" +"(let-values(((base_24 orig-file_0 dir?_7)(split-path path_15)))" +"(let-values(((file_1 alt-file_0)" +"(if expect-module_0" +"(let-values(((b_92)(path->bytes orig-file_0)))" +"(let-values(((len_41)(bytes-length b_92)))" +"(if(if(>= len_41 4)" +" (bytes=? #\".rkt\" (subbytes b_92 (- len_41 4)))" +" #f)" +"(let-values()" +"(values" +" orig-file_0" +"(bytes->path" +" (bytes-append (subbytes b_92 0 (- len_41 4)) #\".ss\"))))" +"(let-values()(values orig-file_0 #f)))))" +"(values orig-file_0 #f))))" +"(let-values(((path_16)" +"(if(eq? file_1 orig-file_0) orig-path_0(build-path base_24 file_1))))" +"(let-values(((alt-path_0)" +"(if alt-file_0" +"(if(eq? alt-file_0 orig-file_0)" +" orig-path_0" +"(build-path base_24 alt-file_0))" +" #f)))" +"(let-values(((base_25)(if(eq? base_24 'relative) 'same base_24)))" +"(let-values(((modes_3)(1/use-compiled-file-paths)))" +"(let-values(((roots_3)(1/current-compiled-file-roots)))" +"(let-values(((reroot_0)" +"(lambda(p_76 d_37)" +"(begin" +" 'reroot" +"(if(eq? d_37 'same)" +"(let-values() p_76)" +"(if(relative-path? d_37)" +"(let-values()(build-path p_76 d_37))" +"(let-values()(reroot-path p_76 d_37))))))))" +"(let-values(((main-path-d_0)(date-of-1_0 path_16)))" +"(let-values(((alt-path-d_0)" +"(if alt-path_0" +"(if(not main-path-d_0)(date-of-1_0 alt-path_0) #f)" +" #f)))" +"(let-values(((path-d_0)" +"(let-values(((or-part_53) main-path-d_0))" +"(if or-part_53 or-part_53 alt-path-d_0))))" +"(let-values(((get-so_0)" +"(lambda(file_2 rep-sfx?_0)" +"(begin" +" 'get-so" +"(lambda(root-dir_1 compiled-dir_1)" +"(build-path" +"(reroot_0 base_25 root-dir_1)" +" compiled-dir_1" +" \"native\"" +"(system-library-subpath)" +"(if rep-sfx?_0" +"(path-add-extension file_2 dll-suffix)" +" file_2)))))))" +"(let-values(((zo_0)" +"(lambda(root-dir_2 compiled-dir_2)" +"(begin" +" 'zo" +"(build-path" +"(reroot_0 base_25 root-dir_2)" +" compiled-dir_2" +" (path-add-extension file_1 #\".zo\"))))))" +"(let-values(((alt-zo_0)" +"(lambda(root-dir_3 compiled-dir_3)" +"(begin" +" 'alt-zo" +"(build-path" +"(reroot_0 base_25 root-dir_3)" +" compiled-dir_3" +" (path-add-extension alt-file_0 #\".zo\"))))))" +"(let-values(((so_0)(get-so_0 file_1 #t)))" +"(let-values(((alt-so_0)(get-so_0 alt-file_0 #t)))" +"(let-values(((try-main?_0)" +"(let-values(((or-part_367) main-path-d_0))" +"(if or-part_367" +" or-part_367" +"(not alt-path-d_0)))))" +"(let-values(((try-alt?_0)" +"(if alt-file_0" +"(let-values(((or-part_166)" +" alt-path-d_0))" +"(if or-part_166" +" or-part_166" +"(not main-path-d_0)))" +" #f)))" +"(let-values(((with-dir_0)" +"(lambda(t_61)" +"(begin" +" 'with-dir" +"(with-dir*_0 base_25 t_61)))))" +"(let-values(((c1_33)" +"(if try-main?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" so_0" +" path-d_0)" +" #f)))" +"(if c1_33" +"((lambda(so-d_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" #f)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((current-load-extension)" +"(car so-d_0)" +" expect-module_0))))))" +" c1_33)" +"(let-values(((c2_18)" +"(if try-alt?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" alt-so_0" +" alt-path-d_0)" +" #f)))" +"(if c2_18" +"((lambda(so-d_1)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" alt-path_0)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((current-load-extension)" +"(car so-d_1)" +" expect-module_0))))))" +" c2_18)" +"(let-values(((c3_11)" +"(if try-main?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" zo_0" +" path-d_0)" +" #f)))" +"(if c3_11" +"((lambda(zo-d_0)" +"(begin" +"(register-zo-path" +" name_55" +" ns-hts_0" +"(car zo-d_0)" +" #f" +" base_25)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" #f)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +"(car zo-d_0)" +" expect-module_0)))))))" +" c3_11)" +"(let-values(((c4_3)" +"(if try-alt?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" alt-zo_0" +" path-d_0)" +" #f)))" +"(if c4_3" +"((lambda(zo-d_1)" +"(begin" +"(register-zo-path" +" name_55" +" ns-hts_0" +"(car zo-d_1)" +" alt-path_0" +" base_25)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" alt-path_0)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +"(car zo-d_1)" +" expect-module_0)))))))" +" c4_3)" +"(if(let-values(((or-part_368)" +"(not" +"(pair?" +" expect-module_0))))" +"(if or-part_368" +" or-part_368" +"(car expect-module_0)))" +"(let-values()" +"(let-values(((p_77)" +"(if try-main?_0" +" path_16" +" alt-path_0)))" +"(if(if(pair?" +" expect-module_0)" +"(not" +"(file-exists? p_77))" +" #f)" +"(void)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +"(if expect-module_0" +"(if(not try-main?_0)" +" p_77" +" #f)" +" #f))" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +" p_77" +" expect-module_0)))))))))" +"(void))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(register-zo-path)" +"(lambda(name_77 ns-hts_1 path_17 src-path_0 base_26)" +"(begin(if ns-hts_1(let-values()(hash-set!(cdr ns-hts_1) name_77(list path_17 src-path_0 base_26)))(void)))))" +"(define-values(default-reader-guard)(lambda(path_18)(begin path_18)))" +"(define-values(-module-hash-table-table)(make-weak-hasheq))" +"(define-values" +"(registry-table-ref)" +"(lambda(reg_0)" +"(begin(let-values(((e_87)(hash-ref -module-hash-table-table reg_0 #f)))(if e_87(ephemeron-value e_87) #f)))))" +"(define-values" +"(registry-table-set!)" +"(lambda(reg_1 v_205)(begin(hash-set! -module-hash-table-table reg_1(make-ephemeron reg_1 v_205)))))" +"(define-values(CACHE-N) 512)" +"(define-values(-path-cache)(make-vector CACHE-N #f))" +"(define-values" +"(path-cache-get)" +"(lambda(p_47)" +"(begin" +"(let-values(((i_45)(modulo(abs(equal-hash-code p_47)) CACHE-N)))" +"(let-values(((w_1)(vector-ref -path-cache i_45)))" +"(let-values(((l_84)(if w_1(weak-box-value w_1) #f)))" +"(if l_84(let-values(((a_77)(1/assoc p_47 l_84)))(if a_77(cdr a_77) #f)) #f)))))))" +"(define-values" +"(path-cache-set!)" +"(lambda(p_78 v_256)" +"(begin" +"(let-values(((i_164)(modulo(abs(equal-hash-code p_78)) CACHE-N)))" +"(let-values(((w_2)(vector-ref -path-cache i_164)))" +"(let-values(((l_19)(if w_2(weak-box-value w_2) #f)))" +"(vector-set!" +" -path-cache" +" i_164" +"(make-weak-box" +"(cons(cons p_78 v_256)(let-values(((or-part_65) l_19))(if or-part_65 or-part_65 null)))))))))))" +"(define-values(-loading-filename)(gensym))" +"(define-values(-loading-prompt-tag)(make-continuation-prompt-tag 'module-loading))" +"(define-values(-prev-relto) #f)" +"(define-values(-prev-relto-dir) #f)" +"(define-values" +"(split-relative-string)" +"(lambda(s_499 coll-mode?_0)" +"(begin" +"(let-values(((l_85)" +"((letrec-values(((loop_46)" +"(lambda(s_306)" +"(begin" +" 'loop" +"(let-values(((len_42)(string-length s_306)))" +"((letrec-values(((iloop_2)" +"(lambda(i_100)" +"(begin" +" 'iloop" +"(if(= i_100 len_42)" +"(let-values()(list s_306))" +"(if(char=? '#\\/(string-ref s_306 i_100))" +"(let-values()" +"(cons" +"(substring s_306 0 i_100)" +"(loop_46(substring s_306(add1 i_100)))))" +"(let-values()(iloop_2(add1 i_100)))))))))" +" iloop_2)" +" 0))))))" +" loop_46)" +" s_499)))" +"(if coll-mode?_0" +" l_85" +"((letrec-values(((loop_47)" +"(lambda(l_81)" +"(begin" +" 'loop" +"(if(null?(cdr l_81))" +"(values null(car l_81))" +"(let-values(((c_111 f_42)(loop_47(cdr l_81))))" +"(values(cons(car l_81) c_111) f_42)))))))" +" loop_47)" +" l_85))))))" +"(define-values" +"(format-source-location)" +"(lambda(stx_18)" +"(begin" +"(srcloc->string" +"(srcloc" +"(1/syntax-source stx_18)" +"(1/syntax-line stx_18)" +"(1/syntax-column stx_18)" +"(1/syntax-position stx_18)" +"(1/syntax-span stx_18))))))" +"(define-values(orig-paramz) #f)" +"(define-values" +"(standard-module-name-resolver)" +"(let-values()" +"(let-values(((planet-resolver_0) #f))" +"(let-values(((prep-planet-resolver!_0)" +"(lambda()" +"(begin" +" 'prep-planet-resolver!" +"(if planet-resolver_0" +"(void)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +" orig-paramz" +"(set! planet-resolver_0" +" (1/dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver)))))))))" +"(letrec-values(((standard-module-name-resolver_0)" +"(case-lambda" +"((s_173 from-namespace_1)" +"(begin" +" 'standard-module-name-resolver" +"(begin" +"(if(1/resolved-module-path? s_173)" +"(void)" +"(let-values()" +" (raise-argument-error 'standard-module-name-resolver \"resolved-module-path?\" s_173)))" +"(if(let-values(((or-part_134)(not from-namespace_1)))" +"(if or-part_134 or-part_134(1/namespace? from-namespace_1)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f namespace?)\"" +" from-namespace_1)))" +"(if planet-resolver_0(let-values()(planet-resolver_0 s_173))(void))" +"(let-values(((hts_1)" +"(let-values(((or-part_98)" +"(registry-table-ref" +"(namespace-module-registry$1(1/current-namespace)))))" +"(if or-part_98" +" or-part_98" +"(let-values(((hts_2)(cons(make-hasheq)(make-hasheq))))" +"(begin" +"(registry-table-set!" +"(namespace-module-registry$1(1/current-namespace))" +" hts_2)" +" hts_2))))))" +"(begin" +"(hash-set!(car hts_1) s_173 'declared)" +"(if from-namespace_1" +"(let-values()" +"(let-values(((root-name_2)" +"(if(pair?(1/resolved-module-path-name s_173))" +"(1/make-resolved-module-path" +"(car(1/resolved-module-path-name s_173)))" +" s_173))" +"((from-hts_0)" +"(registry-table-ref" +"(namespace-module-registry$1 from-namespace_1))))" +"(if from-hts_0" +"(let-values()" +"(let-values(((use-path/src_1)(hash-ref(cdr from-hts_0) root-name_2 #f)))" +"(if use-path/src_1" +"(let-values()(hash-set!(cdr hts_1) root-name_2 use-path/src_1))" +"(void))))" +"(void))))" +"(void)))))))" +"((s_451 relto_0 stx_19)" +"(begin" +"(log-message" +"(current-logger)" +" 'error" +" \"default module name resolver called with three arguments (deprecated)\"" +" #f)" +"(standard-module-name-resolver_0 s_451 relto_0 stx_19 #t)))" +"((s_500 relto_1 stx_20 load?_7)" +"(let-values((()" +"(begin" +"(if(1/module-path? s_500)" +"(void)" +"(let-values()" +"(if(syntax?$1 stx_20)" +" (raise-syntax-error$1 #f \"bad module path\" stx_20)" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"module-path?\"" +" s_500))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_359)(not relto_1)))" +"(if or-part_359 or-part_359(1/resolved-module-path? relto_1)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f resolved-module-path?)\"" +" relto_1)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_55)(not stx_20)))" +"(if or-part_55 or-part_55(syntax?$1 stx_20)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f syntax?)\"" +" stx_20)))" +"(values))))" +"(let-values(((flatten-sub-path_0)" +"(lambda(base_27 orig-l_10)" +"(begin" +" 'flatten-sub-path" +"((letrec-values(((loop_119)" +"(lambda(a_78 l_35)" +"(begin" +" 'loop" +"(if(null? l_35)" +"(let-values()" +"(if(null? a_78)" +" base_27" +"(cons base_27(reverse$1 a_78))))" +" (if (equal? (car l_35) \"..\")" +"(let-values()" +"(if(null? a_78)" +"(error" +" 'standard-module-name-resolver" +" \"too many \\\"..\\\"s in submodule path: ~.s\"" +"(list*" +" 'submod" +" (if (equal? base_27 \".\")" +" base_27" +"(if(path? base_27)" +" base_27" +"(list" +"(if(symbol? base_27)" +" 'quote" +" 'file)" +" base_27)))" +" orig-l_10))" +"(loop_119(cdr a_78)(cdr l_35))))" +"(let-values()" +"(loop_119" +"(cons(car l_35) a_78)" +"(cdr l_35)))))))))" +" loop_119)" +" null" +" orig-l_10)))))" +"(if(if(pair? s_500)(eq?(car s_500) 'quote) #f)" +"(let-values()(1/make-resolved-module-path(cadr s_500)))" +"(if(if(pair? s_500)" +"(if(eq?(car s_500) 'submod)" +"(if(pair?(cadr s_500))(eq?(caadr s_500) 'quote) #f)" +" #f)" +" #f)" +"(let-values()" +"(1/make-resolved-module-path(flatten-sub-path_0(cadadr s_500)(cddr s_500))))" +"(if(if(pair? s_500)" +"(if(eq?(car s_500) 'submod)" +" (if (let-values (((or-part_101) (equal? (cadr s_500) \".\")))" +" (if or-part_101 or-part_101 (equal? (cadr s_500) \"..\")))" +"(if relto_1" +"(let-values(((p_79)(1/resolved-module-path-name relto_1)))" +"(let-values(((or-part_369)(symbol? p_79)))" +"(if or-part_369" +" or-part_369" +"(if(pair? p_79)(symbol?(car p_79)) #f))))" +" #f)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((rp_0)(1/resolved-module-path-name relto_1)))" +"(1/make-resolved-module-path" +"(flatten-sub-path_0" +"(if(pair? rp_0)(car rp_0) rp_0)" +"(let-values(((r_47)" +" (if (equal? (cadr s_500) \"..\") (cdr s_500) (cddr s_500))))" +"(if(pair? rp_0)(append(cdr rp_0) r_47) r_47))))))" +"(if(if(pair? s_500)(eq?(car s_500) 'planet) #f)" +"(let-values()" +"(begin" +"(prep-planet-resolver!_0)" +"(planet-resolver_0 s_500 relto_1 stx_20 load?_7 #f orig-paramz)))" +"(if(if(pair? s_500)" +"(if(eq?(car s_500) 'submod)" +"(if(pair?(cadr s_500))(eq?(caadr s_500) 'planet) #f)" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(prep-planet-resolver!_0)" +"(planet-resolver_0" +"(cadr s_500)" +" relto_1" +" stx_20" +" load?_7" +"(cddr s_500)" +" orig-paramz)))" +"(let-values()" +"(let-values(((get-dir_0)" +"(lambda()" +"(begin" +" 'get-dir" +"(let-values(((or-part_41)" +"(if relto_1" +"(if(eq? relto_1 -prev-relto)" +" -prev-relto-dir" +"(let-values(((p_80)" +"(1/resolved-module-path-name" +" relto_1)))" +"(let-values(((p_81)" +"(if(pair? p_80)" +"(car p_80)" +" p_80)))" +"(if(path? p_81)" +"(let-values(((base_28" +" n_36" +" d?_0)" +"(split-path" +" p_81)))" +"(begin" +"(set! -prev-relto relto_1)" +"(set! -prev-relto-dir" +" base_28)" +" base_28))" +" #f))))" +" #f)))" +"(if or-part_41" +" or-part_41" +"(let-values(((or-part_370)" +"(current-load-relative-directory)))" +"(if or-part_370" +" or-part_370" +"(current-directory))))))))" +"((get-reg_0)" +"(lambda()" +"(begin" +" 'get-reg" +"(namespace-module-registry$1(1/current-namespace)))))" +"((show-collection-err_0)" +"(lambda(msg_1)" +"(begin" +" 'show-collection-err" +"(let-values(((msg_2)" +"(string-append" +"(let-values(((or-part_365)" +"(if stx_20" +"(if(error-print-source-location)" +"(format-source-location" +" stx_20)" +" #f)" +" #f)))" +"(if or-part_365" +" or-part_365" +" \"standard-module-name-resolver\"))" +" \": \"" +"(regexp-replace" +" '#rx\"\\n\"" +" msg_1" +"(format" +" \"\\n for module path: ~s\\n\"" +" s_500)))))" +"(raise" +"(if stx_20" +"(1/make-exn:fail:syntax:missing-module" +" msg_2" +"(current-continuation-marks)" +"(list stx_20)" +" s_500)" +"(1/make-exn:fail:filesystem:missing-module" +" msg_2" +"(current-continuation-marks)" +" s_500)))))))" +"((ss->rkt_0)" +"(lambda(s_501)" +"(begin" +" 'ss->rkt" +"(let-values(((len_43)(string-length s_501)))" +"(if(if(>= len_43 3)" +"(if(equal?" +" '#\\." +"(string-ref s_501(- len_43 3)))" +"(if(equal?" +" '#\\s" +"(string-ref s_501(- len_43 2)))" +"(equal?" +" '#\\s" +"(string-ref s_501(- len_43 1)))" +" #f)" +" #f)" +" #f)" +"(string-append" +"(substring s_501 0(- len_43 3))" +" \".rkt\")" +" s_501)))))" +"((path-ss->rkt_0)" +"(lambda(p_82)" +"(begin" +" 'path-ss->rkt" +"(let-values(((base_29 name_78 dir?_8)" +"(split-path p_82)))" +" (if (regexp-match '#rx\"[.]ss$\" (path->bytes name_78))" +" (path-replace-extension p_82 #\".rkt\")" +" p_82)))))" +"((s_502)" +"(if(if(pair? s_500)(eq? 'submod(car s_500)) #f)" +"(let-values(((v_257)(cadr s_500)))" +" (if (let-values (((or-part_371) (equal? v_257 \".\")))" +" (if or-part_371 or-part_371 (equal? v_257 \"..\")))" +"(if relto_1" +"(let-values(((p_7)" +"(1/resolved-module-path-name" +" relto_1)))" +"(if(pair? p_7)(car p_7) p_7))" +"(error" +" 'standard-module-name-resolver" +" \"no base path for relative submodule path: ~.s\"" +" s_500))" +" v_257))" +" s_500))" +"((subm-path_0)" +"(if(if(pair? s_500)(eq? 'submod(car s_500)) #f)" +"(let-values(((p_83)" +"(if(if(let-values(((or-part_168)" +"(equal?" +"(cadr s_500)" +" \".\")))" +"(if or-part_168" +" or-part_168" +" (equal? (cadr s_500) \"..\")))" +" relto_1" +" #f)" +"(let-values(((p_84)" +"(1/resolved-module-path-name" +" relto_1))" +"((r_48)" +"(if(equal?" +"(cadr s_500)" +" \"..\")" +"(cdr s_500)" +"(cddr s_500))))" +"(if(pair? p_84)" +"(flatten-sub-path_0" +"(car p_84)" +"(append(cdr p_84) r_48))" +"(flatten-sub-path_0 p_84 r_48)))" +"(flatten-sub-path_0" +" \".\"" +" (if (equal? (cadr s_500) \"..\")" +"(cdr s_500)" +"(cddr s_500))))))" +"(if(pair? p_83)(cdr p_83) #f))" +" #f)))" +"(let-values(((s-parsed_0)" +"(if(symbol? s_502)" +"(let-values()" +"(let-values(((or-part_46)" +"(path-cache-get" +"(cons s_502(get-reg_0)))))" +"(if or-part_46" +" or-part_46" +"(let-values(((cols_0 file_3)" +"(split-relative-string" +"(symbol->string s_502)" +" #f)))" +"(let-values(((f-file_0)" +"(if(null? cols_0)" +" \"main.rkt\"" +"(string-append" +" file_3" +" \".rkt\"))))" +"(find-col-file" +" show-collection-err_0" +"(if(null? cols_0) file_3(car cols_0))" +"(if(null? cols_0) null(cdr cols_0))" +" f-file_0" +" #t))))))" +"(if(string? s_502)" +"(let-values()" +"(let-values(((dir_4)(get-dir_0)))" +"(let-values(((or-part_372)" +"(path-cache-get" +"(cons s_502 dir_4))))" +"(if or-part_372" +" or-part_372" +"(let-values(((cols_1 file_4)" +"(split-relative-string" +" s_502" +" #f)))" +"(if(null? cols_1)" +"(build-path dir_4(ss->rkt_0 file_4))" +"(apply" +" build-path" +" dir_4" +"(append" +"(map2" +"(lambda(s_56)" +" (if (string=? s_56 \".\")" +"(let-values() 'same)" +" (if (string=? s_56 \"..\")" +"(let-values() 'up)" +"(let-values() s_56))))" +" cols_1)" +"(list(ss->rkt_0 file_4))))))))))" +"(if(path? s_502)" +"(let-values()" +"(path-ss->rkt_0" +"(simplify-path" +"(if(complete-path? s_502)" +" s_502" +"(path->complete-path s_502(get-dir_0))))))" +"(if(eq?(car s_502) 'lib)" +"(let-values()" +"(let-values(((or-part_84)" +"(path-cache-get" +"(cons s_502(get-reg_0)))))" +"(if or-part_84" +" or-part_84" +"(let-values(((cols_2 file_5)" +"(split-relative-string" +"(cadr s_502)" +" #f)))" +"(let-values(((old-style?_0)" +"(if(null?(cddr s_502))" +"(if(null? cols_2)" +"(regexp-match?" +" '#rx\"[.]\"" +" file_5)" +" #f)" +" #t)))" +"(let-values(((f-file_1)" +"(if old-style?_0" +"(ss->rkt_0 file_5)" +"(if(null? cols_2)" +" \"main.rkt\"" +"(if(regexp-match?" +" '#rx\"[.]\"" +" file_5)" +"(ss->rkt_0 file_5)" +"(string-append" +" file_5" +" \".rkt\"))))))" +"(let-values(((cols_3)" +"(if old-style?_0" +"(append" +"(if(null?" +"(cddr s_502))" +" '(\"mzlib\")" +"(apply" +" append" +"(map2" +"(lambda(p_3)" +"(split-relative-string" +" p_3" +" #t))" +"(cddr s_502))))" +" cols_2)" +"(if(null? cols_2)" +"(list file_5)" +" cols_2))))" +"(find-col-file" +" show-collection-err_0" +"(car cols_3)" +"(cdr cols_3)" +" f-file_1" +" #t))))))))" +"(if(eq?(car s_502) 'file)" +"(let-values()" +"(path-ss->rkt_0" +"(simplify-path" +"(path->complete-path" +"(expand-user-path(cadr s_502))" +"(get-dir_0)))))" +"(void))))))))" +"(begin" +"(if(let-values(((or-part_373)(path? s-parsed_0)))" +"(if or-part_373 or-part_373(vector? s-parsed_0)))" +"(void)" +"(let-values()" +"(if stx_20" +"(raise-syntax-error$1" +" 'require" +"(format" +" \"bad module path~a\"" +" (if s-parsed_0 (car s-parsed_0) \"\"))" +" stx_20)" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"module-path?\"" +" s_502))))" +"(let-values(((filename_2)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 0)" +"(simplify-path(cleanse-path s-parsed_0) #f))))" +"(let-values(((normal-filename_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 1)" +"(normal-case-path filename_2))))" +"(let-values(((base_30 name_79 dir?_9)" +"(if(vector? s-parsed_0)" +"(values" +" 'ignored" +"(vector-ref s-parsed_0 2)" +" 'ignored)" +"(split-path filename_2))))" +"(let-values(((no-sfx_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 3)" +" (path-replace-extension name_79 #\"\"))))" +"(let-values(((root-modname_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 4)" +"(1/make-resolved-module-path filename_2))))" +"(let-values(((hts_3)" +"(let-values(((or-part_374)" +"(registry-table-ref" +"(get-reg_0))))" +"(if or-part_374" +" or-part_374" +"(let-values(((hts_4)" +"(cons" +"(make-hasheq)" +"(make-hasheq))))" +"(begin" +"(registry-table-set!" +"(get-reg_0)" +" hts_4)" +" hts_4))))))" +"(let-values(((modname_0)" +"(if subm-path_0" +"(1/make-resolved-module-path" +"(cons" +"(1/resolved-module-path-name" +" root-modname_0)" +" subm-path_0))" +" root-modname_0)))" +"(begin" +"(if load?_7" +"(let-values()" +"(let-values(((got_0)" +"(hash-ref" +"(car hts_3)" +" modname_0" +" #f)))" +"(if got_0" +"(void)" +"(let-values()" +"(let-values(((loading_0)" +"(let-values(((tag_2)" +"(if(continuation-prompt-available?" +" -loading-prompt-tag)" +" -loading-prompt-tag" +"(default-continuation-prompt-tag))))" +"(continuation-mark-set-first" +" #f" +" -loading-filename" +" null" +" tag_2)))" +"((nsr_0)(get-reg_0)))" +"(begin" +"(for-each2" +"(lambda(s_60)" +"(if(if(equal?" +"(cdr s_60)" +" normal-filename_0)" +"(eq?(car s_60) nsr_0)" +" #f)" +"(let-values()" +"(error" +" 'standard-module-name-resolver" +" \"cycle in loading\\n at path: ~a\\n paths:~a\"" +" filename_2" +"(apply" +" string-append" +"((letrec-values(((loop_9)" +"(lambda(l_86)" +"(begin" +" 'loop" +"(if(null?" +" l_86)" +" '()" +"(list*" +" \"\\n \"" +"(path->string" +"(cdar" +" l_86))" +"(loop_9" +"(cdr" +" l_86))))))))" +" loop_9)" +"(reverse$1 loading_0)))))" +"(void)))" +" loading_0)" +"((if(continuation-prompt-available?" +" -loading-prompt-tag)" +"(lambda(f_43)(f_43))" +"(lambda(f_44)" +"(call-with-continuation-prompt" +" f_44" +" -loading-prompt-tag)))" +"(lambda()" +"(with-continuation-mark" +" -loading-filename" +"(cons" +"(cons nsr_0 normal-filename_0)" +" loading_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-name" +" root-modname_0" +" 1/current-module-path-for-load" +"((if stx_20" +"(lambda(p_85)" +"(1/datum->syntax" +" #f" +" p_85" +" stx_20))" +" values)" +"(if(symbol? s_502)" +"(let-values() s_502)" +"(if(if(pair? s_502)" +"(eq?(car s_502) 'lib)" +" #f)" +"(let-values() s_502)" +"(let-values()" +"(if(1/resolved-module-path?" +" root-modname_0)" +"(let-values(((src_9)" +"(1/resolved-module-path-name" +" root-modname_0)))" +"(if(symbol? src_9)" +"(list" +" 'quote" +" src_9)" +" src_9))" +" root-modname_0))))))" +"(let-values()" +"((1/current-load/use-compiled)" +" filename_2" +"(let-values(((sym_77)" +"(string->symbol" +"(path->string" +" no-sfx_0))))" +"(if subm-path_0" +"(if(hash-ref" +"(car hts_3)" +" root-modname_0" +" #f)" +"(cons #f subm-path_0)" +"(cons" +" sym_77" +" subm-path_0))" +" sym_77))))))))))))))" +"(void))" +"(if(if(not(vector? s-parsed_0))" +"(if load?_7" +"(let-values(((or-part_375)" +"(string? s_502)))" +"(if or-part_375" +" or-part_375" +"(let-values(((or-part_376)" +"(symbol? s_502)))" +"(if or-part_376" +" or-part_376" +"(if(pair? s_502)" +"(eq?(car s_502) 'lib)" +" #f)))))" +" #f)" +" #f)" +"(let-values()" +"(path-cache-set!" +"(if(string? s_502)" +"(cons s_502(get-dir_0))" +"(cons s_502(get-reg_0)))" +"(vector" +" filename_2" +" normal-filename_0" +" name_79" +" no-sfx_0" +" root-modname_0)))" +"(void))" +" modname_0)))))))))))))))))))))))))" +" standard-module-name-resolver_0)))))" +"(define-values" +"(default-eval-handler)" +"(lambda(s_36)" +"(begin" +"(1/eval" +" s_36" +"(1/current-namespace)" +"(let-values(((c_112)(1/current-compile)))" +"(lambda(e_88 ns_17)" +"(if(eq? ns_17(1/current-namespace))" +"(c_112 e_88 #t)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_17)" +"(let-values()(c_112 e_88 #t))))))))))" +"(define-values" +"(default-compile-handler)" +"(lambda(s_503 immediate-eval?_0)(begin(1/compile s_503(1/current-namespace)(not immediate-eval?_0)))))" +"(define-values" +"(default-read-interaction)" +"(lambda(src_10 in_89)" +"(begin" +"(begin" +"(if(input-port? in_89)" +"(void)" +" (let-values () (raise-argument-error 'default-read-interaction \"input-port?\" in_89)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #f)" +"(let-values()(1/read-syntax src_10 in_89)))))))" +"(define-values" +"(boot)" +"(lambda()" +"(begin" +"(begin" +"(seal)" +"(1/current-module-name-resolver standard-module-name-resolver)" +"(1/current-load/use-compiled default-load/use-compiled)" +"(1/current-reader-guard default-reader-guard)" +"(1/current-eval default-eval-handler)" +"(1/current-compile default-compile-handler)" +"(1/current-load default-load-handler)" +"(current-read-interaction default-read-interaction)))))" +"(define-values" +"(seal)" +"(lambda()(begin(set! orig-paramz(reparameterize(continuation-mark-set-first #f parameterization-key))))))" +"(define-values(get-original-parameterization)(lambda()(begin orig-paramz)))" +"(define-values" +"(boot-primitives)" +"(hash 'boot boot 'seal seal 'get-original-parameterization get-original-parameterization))" +"(define-values" +"(prepare-next-phase-namespace)" +"(lambda(ctx_76)" +"(begin" +"(let-values(((phase_44)(add1(expand-context-phase ctx_76))))" +"(let-values(((ns_59)(namespace->namespace-at-phase(expand-context-namespace ctx_76) phase_44)))" +"(namespace-visit-available-modules! ns_59 phase_44))))))" +"(define-values" +"(expand-body7.1)" +"(lambda(source1_0 stratified?2_0 bodys5_0 ctx6_0)" +"(begin" +" 'expand-body7" +"(let-values(((bodys_7) bodys5_0))" +"(let-values(((ctx_77) ctx6_0))" +"(let-values(((s_492) source1_0))" +"(let-values(((stratified?_0) stratified?2_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_66)(expand-context-observer ctx_77)))" +"(if obs_66" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_66 'enter-block(datum->syntax$1 #f bodys_7))))" +"(void)))" +"(values))))" +"(let-values(((inside-sc_0)(new-scope 'intdef)))" +"(let-values(((init-bodys_0)" +"(reverse$1" +"(let-values(((lst_22) bodys_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_22)))" +"((letrec-values(((for-loop_20)" +"(lambda(fold-var_9 lst_23)" +"(begin" +" 'for-loop" +"(if(pair? lst_23)" +"(let-values(((body_9)(unsafe-car lst_23))" +"((rest_8)(unsafe-cdr lst_23)))" +"(let-values(((fold-var_10)" +"(let-values(((fold-var_11) fold-var_9))" +"(let-values(((fold-var_12)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_9" +" inside-sc_0))" +" fold-var_11))))" +"(values fold-var_12)))))" +"(if(not #f)" +"(for-loop_20 fold-var_10 rest_8)" +" fold-var_10)))" +" fold-var_9)))))" +" for-loop_20)" +" null" +" lst_22))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_67)(expand-context-observer ctx_77)))" +"(if obs_67" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_67" +" 'block-renames" +"(datum->syntax$1 #f init-bodys_0)" +"(datum->syntax$1 #f bodys_7))))" +"(void)))" +"(values))))" +"(let-values(((phase_137)(expand-context-phase ctx_77)))" +"(let-values(((frame-id_7)(make-reference-record)))" +"(let-values(((def-ctx-scopes_6)(box null)))" +"(let-values(((body-ctx_0)" +"(let-values(((v_258) ctx_77))" +"(let-values(((the-struct_90) v_258))" +"(if(expand-context/outer? the-struct_90)" +"(let-values(((context51_0)(list(make-liberal-define-context)))" +"((name52_0) #f)" +"((only-immediate?53_0) #t)" +"((def-ctx-scopes54_0) def-ctx-scopes_6)" +"((post-expansion55_0)" +"(lambda(s_168)" +"(begin" +" 'post-expansion55" +"(add-scope s_168 inside-sc_0))))" +"((scopes56_0)" +"(cons inside-sc_0(expand-context-scopes ctx_77)))" +"((use-site-scopes57_0)(box null))" +"((frame-id58_0) frame-id_7)" +"((reference-records59_0)" +"(cons" +" frame-id_7" +"(expand-context-reference-records ctx_77)))" +"((inner60_0)(root-expand-context/outer-inner v_258)))" +"(expand-context/outer1.1" +" inner60_0" +" post-expansion55_0" +" use-site-scopes57_0" +" frame-id58_0" +" context51_0" +"(expand-context/outer-env the-struct_90)" +" scopes56_0" +" def-ctx-scopes54_0" +"(expand-context/outer-binding-layer the-struct_90)" +" reference-records59_0" +" only-immediate?53_0" +"(expand-context/outer-need-eventually-defined the-struct_90)" +"(expand-context/outer-current-introduction-scopes the-struct_90)" +"(expand-context/outer-current-use-scopes the-struct_90)" +" name52_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_90))))))" +"(let-values(((maybe-increment-binding-layer_0)" +"(lambda(ids_29 body-ctx_1)" +"(begin" +" 'maybe-increment-binding-layer" +"(if(eq?" +"(expand-context-binding-layer body-ctx_1)" +"(expand-context-binding-layer ctx_77))" +"(increment-binding-layer ids_29 body-ctx_1 inside-sc_0)" +"(expand-context-binding-layer body-ctx_1))))))" +"(let-values(((name_80)(expand-context-name ctx_77)))" +"((letrec-values(((loop_120)" +"(lambda(body-ctx_2" +" bodys_8" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)" +"(begin" +" 'loop" +"(if(null? bodys_8)" +"(let-values()" +"(let-values(((body-ctx61_0) body-ctx_2)" +"((frame-id62_0) frame-id_7)" +"((def-ctx-scopes63_0) def-ctx-scopes_6)" +"((temp64_5)(reverse$1 val-idss_0))" +"((temp65_5)(reverse$1 val-keyss_0))" +"((temp66_5)(reverse$1 val-rhss_0))" +"((temp67_6)(reverse$1 track-stxs_0))" +"((temp68_7)(reverse$1 stx-clauses_0))" +"((temp69_4)(reverse$1 done-bodys_0))" +"((s70_0) s_492)" +"((stratified?71_0) stratified?_0)" +"((name72_0) name_80)" +"((temp73_3)(reverse$1 trans-idss_1)))" +"(finish-expanding-body27.1" +" temp73_3" +" name72_0" +" s70_0" +" stratified?71_0" +" body-ctx61_0" +" frame-id62_0" +" def-ctx-scopes63_0" +" temp64_5" +" temp65_5" +" temp66_5" +" temp67_6" +" temp68_7" +" temp69_4)))" +"(let-values()" +"(let-values(((rest-bodys_0)(cdr bodys_8)))" +"(let-values((()" +"(begin" +"(let-values(((obs_68)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_68" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_68" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_0)" +"(let-values(((temp74_3)(car bodys_8))" +"((temp75_5)" +"(if(if name_80" +"(null?" +"(cdr bodys_8))" +" #f)" +"(let-values(((v_259)" +" body-ctx_2))" +"(let-values(((the-struct_91)" +" v_259))" +"(if(expand-context/outer?" +" the-struct_91)" +"(let-values(((name76_0)" +" name_80)" +"((inner77_0)" +"(root-expand-context/outer-inner" +" v_259)))" +"(expand-context/outer1.1" +" inner77_0" +"(root-expand-context/outer-post-expansion" +" the-struct_91)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_91)" +"(root-expand-context/outer-frame-id" +" the-struct_91)" +"(expand-context/outer-context" +" the-struct_91)" +"(expand-context/outer-env" +" the-struct_91)" +"(expand-context/outer-scopes" +" the-struct_91)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_91)" +"(expand-context/outer-binding-layer" +" the-struct_91)" +"(expand-context/outer-reference-records" +" the-struct_91)" +"(expand-context/outer-only-immediate?" +" the-struct_91)" +"(expand-context/outer-need-eventually-defined" +" the-struct_91)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_91)" +"(expand-context/outer-current-use-scopes" +" the-struct_91)" +" name76_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_91))))" +" body-ctx_2)))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp74_3" +" temp75_5))))" +"(let-values(((disarmed-exp-body_0)" +"(syntax-disarm$1 exp-body_0)))" +"(let-values(((tmp_62)" +"(core-form-sym" +" disarmed-exp-body_0" +" phase_137)))" +"(if(equal? tmp_62 'begin)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_69)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_69" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_69" +" 'prim-begin)))" +"(void)))" +"(values))))" +"(let-values(((ok?_34 begin78_0 e79_0)" +"(let-values(((s_504)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_38)" +" s_504))" +"(let-values(((begin78_1" +" e79_1)" +"(let-values(((s_505)" +"(if(syntax?$1" +" s_504)" +"(syntax-e$1" +" s_504)" +" s_504)))" +"(if(pair?" +" s_505)" +"(let-values(((begin80_0)" +"(let-values(((s_176)" +"(car" +" s_505)))" +" s_176))" +"((e81_0)" +"(let-values(((s_451)" +"(cdr" +" s_505)))" +"(let-values(((s_46)" +"(if(syntax?$1" +" s_451)" +"(syntax-e$1" +" s_451)" +" s_451)))" +"(let-values(((flat-s_25)" +"(to-syntax-list.1" +" s_46)))" +"(if(not" +" flat-s_25)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_38))" +"(let-values()" +" flat-s_25)))))))" +"(values" +" begin80_0" +" e81_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_38)))))" +"(values" +" #t" +" begin78_1" +" e79_1))))))" +"(let-values(((track_0)" +"(lambda(e_89)" +"(begin" +" 'track" +"(syntax-track-origin$1" +" e_89" +" exp-body_0)))))" +"(let-values(((splice-bodys_0)" +"(append" +"(map2 track_0 e79_0)" +" rest-bodys_0)))" +"(begin" +"(let-values(((obs_35)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_35" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_35" +" 'splice" +" splice-bodys_0)))" +"(void)))" +"(loop_120" +" body-ctx_2" +" splice-bodys_0" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)))))))" +"(if(equal? tmp_62 'define-values)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_70)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_70" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_70" +" 'prim-define-values)))" +"(void)))" +"(values))))" +"(let-values(((ok?_35" +" define-values82_0" +" id83_0" +" rhs84_0)" +"(let-values(((s_32)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_39)" +" s_32))" +"(let-values(((define-values82_1" +" id83_1" +" rhs84_1)" +"(let-values(((s_51)" +"(if(syntax?$1" +" s_32)" +"(syntax-e$1" +" s_32)" +" s_32)))" +"(if(pair?" +" s_51)" +"(let-values(((define-values85_0)" +"(let-values(((s_452)" +"(car" +" s_51)))" +" s_452))" +"((id86_0" +" rhs87_0)" +"(let-values(((s_506)" +"(cdr" +" s_51)))" +"(let-values(((s_507)" +"(if(syntax?$1" +" s_506)" +"(syntax-e$1" +" s_506)" +" s_506)))" +"(if(pair?" +" s_507)" +"(let-values(((id88_0)" +"(let-values(((s_508)" +"(car" +" s_507)))" +"(let-values(((s_53)" +"(if(syntax?$1" +" s_508)" +"(syntax-e$1" +" s_508)" +" s_508)))" +"(let-values(((flat-s_26)" +"(to-syntax-list.1" +" s_53)))" +"(if(not" +" flat-s_26)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39))" +"(let-values()" +"(let-values(((id_63)" +"(let-values(((lst_194)" +" flat-s_26))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_194)))" +"((letrec-values(((for-loop_205)" +"(lambda(id_81" +" lst_13)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_13)" +"(let-values(((s_314)" +"(unsafe-car" +" lst_13))" +"((rest_105)" +"(unsafe-cdr" +" lst_13)))" +"(let-values(((id_104)" +"(let-values(((id_105)" +" id_81))" +"(let-values(((id_82)" +"(let-values()" +"(let-values(((id91_0)" +"(let-values()" +"(if(let-values(((or-part_213)" +"(if(syntax?$1" +" s_314)" +"(symbol?" +"(syntax-e$1" +" s_314))" +" #f)))" +"(if or-part_213" +" or-part_213" +"(symbol?" +" s_314)))" +" s_314" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_39" +" s_314)))))" +"(cons" +" id91_0" +" id_105)))))" +"(values" +" id_82)))))" +"(if(not" +" #f)" +"(for-loop_205" +" id_104" +" rest_105)" +" id_104)))" +" id_81)))))" +" for-loop_205)" +" null" +" lst_194)))))" +"(reverse$1" +" id_63))))))))" +"((rhs89_0)" +"(let-values(((s_33)" +"(cdr" +" s_507)))" +"(let-values(((s_509)" +"(if(syntax?$1" +" s_33)" +"(syntax-e$1" +" s_33)" +" s_33)))" +"(if(pair?" +" s_509)" +"(let-values(((rhs90_0)" +"(let-values(((s_96)" +"(car" +" s_509)))" +" s_96))" +"(()" +"(let-values(((s_57)" +"(cdr" +" s_509)))" +"(let-values(((s_510)" +"(if(syntax?$1" +" s_57)" +"(syntax-e$1" +" s_57)" +" s_57)))" +"(if(null?" +" s_510)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39))))))" +"(values" +" rhs90_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39))))))" +"(values" +" id88_0" +" rhs89_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39))))))" +"(values" +" define-values85_0" +" id86_0" +" rhs87_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39)))))" +"(values" +" #t" +" define-values82_1" +" id83_1" +" rhs84_1))))))" +"(let-values(((ids_30)" +"(remove-use-site-scopes" +" id83_0" +" body-ctx_2)))" +"(let-values((()" +"(begin" +"(let-values(((obs_71)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_71" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_71" +" 'rename-one" +"(datum->syntax$1" +" #f" +"(list" +" ids_30" +" rhs84_0)))))" +"(void)))" +"(values))))" +"(let-values(((new-dups_0)" +"(let-values(((ids92_0)" +" ids_30)" +"((phase93_0)" +" phase_137)" +"((exp-body94_0)" +" exp-body_0)" +"((dups95_0)" +" dups_0))" +"(check-no-duplicate-ids7.1" +" unsafe-undefined" +" ids92_0" +" phase93_0" +" exp-body94_0" +" dups95_0))))" +"(let-values(((counter_5)" +"(root-expand-context-counter" +" ctx_77)))" +"(let-values(((keys_5)" +"(reverse$1" +"(let-values(((lst_292)" +" ids_30))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_292)))" +"((letrec-values(((for-loop_281)" +"(lambda(fold-var_189" +" lst_310)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_310)" +"(let-values(((id_106)" +"(unsafe-car" +" lst_310))" +"((rest_181)" +"(unsafe-cdr" +" lst_310)))" +"(let-values(((fold-var_286)" +"(let-values(((fold-var_287)" +" fold-var_189))" +"(let-values(((fold-var_288)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id96_0)" +" id_106)" +"((phase97_0)" +" phase_137)" +"((counter98_0)" +" counter_5)" +"((frame-id99_0)" +" frame-id_7)" +"((exp-body100_0)" +" exp-body_0))" +"(add-local-binding!37.1" +" frame-id99_0" +" exp-body100_0" +" id96_0" +" phase97_0" +" counter98_0)))" +" fold-var_287))))" +"(values" +" fold-var_288)))))" +"(if(not" +" #f)" +"(for-loop_281" +" fold-var_286" +" rest_181)" +" fold-var_286)))" +" fold-var_189)))))" +" for-loop_281)" +" null" +" lst_292))))))" +"(let-values(((extended-env_0)" +"(let-values(((lst_228)" +" keys_5)" +"((lst_307)" +" ids_30))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_228)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_307)))" +"((letrec-values(((for-loop_276)" +"(lambda(env_17" +" lst_311" +" lst_312)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_311)" +"(pair?" +" lst_312)" +" #f)" +"(let-values(((key_88)" +"(unsafe-car" +" lst_311))" +"((rest_182)" +"(unsafe-cdr" +" lst_311))" +"((id_107)" +"(unsafe-car" +" lst_312))" +"((rest_183)" +"(unsafe-cdr" +" lst_312)))" +"(let-values(((env_18)" +"(let-values(((env_19)" +" env_17))" +"(let-values(((env_20)" +"(let-values()" +"(env-extend" +" env_19" +" key_88" +"(local-variable1.1" +" id_107)))))" +"(values" +" env_20)))))" +"(if(not" +" #f)" +"(for-loop_276" +" env_18" +" rest_182" +" rest_183)" +" env_18)))" +" env_17)))))" +" for-loop_276)" +"(expand-context-env" +" body-ctx_2)" +" lst_228" +" lst_307)))))" +"(loop_120" +"(let-values(((v_260)" +" body-ctx_2))" +"(let-values(((the-struct_92)" +" v_260))" +"(if(expand-context/outer?" +" the-struct_92)" +"(let-values(((env101_0)" +" extended-env_0)" +"((binding-layer102_0)" +"(maybe-increment-binding-layer_0" +" ids_30" +" body-ctx_2))" +"((inner103_0)" +"(root-expand-context/outer-inner" +" v_260)))" +"(expand-context/outer1.1" +" inner103_0" +"(root-expand-context/outer-post-expansion" +" the-struct_92)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_92)" +"(root-expand-context/outer-frame-id" +" the-struct_92)" +"(expand-context/outer-context" +" the-struct_92)" +" env101_0" +"(expand-context/outer-scopes" +" the-struct_92)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_92)" +" binding-layer102_0" +"(expand-context/outer-reference-records" +" the-struct_92)" +"(expand-context/outer-only-immediate?" +" the-struct_92)" +"(expand-context/outer-need-eventually-defined" +" the-struct_92)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_92)" +"(expand-context/outer-current-use-scopes" +" the-struct_92)" +"(expand-context/outer-name" +" the-struct_92)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_92))))" +" rest-bodys_0" +" null" +"(cons" +" ids_30" +"(append" +"(reverse$1" +"(let-values(((lst_313)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_313)))" +"((letrec-values(((for-loop_282)" +"(lambda(fold-var_289" +" lst_155)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_155)" +"(let-values(((done-body_0)" +"(unsafe-car" +" lst_155))" +"((rest_79)" +"(unsafe-cdr" +" lst_155)))" +"(let-values(((fold-var_290)" +"(let-values(((fold-var_291)" +" fold-var_289))" +"(let-values(((fold-var_292)" +"(let-values()" +"(cons" +"(let-values()" +" null)" +" fold-var_291))))" +"(values" +" fold-var_292)))))" +"(if(not" +" #f)" +"(for-loop_282" +" fold-var_290" +" rest_79)" +" fold-var_290)))" +" fold-var_289)))))" +" for-loop_282)" +" null" +" lst_313))))" +" val-idss_0))" +"(cons" +" keys_5" +"(append" +"(reverse$1" +"(let-values(((lst_314)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_314)))" +"((letrec-values(((for-loop_283)" +"(lambda(fold-var_293" +" lst_32)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_32)" +"(let-values(((done-body_1)" +"(unsafe-car" +" lst_32))" +"((rest_184)" +"(unsafe-cdr" +" lst_32)))" +"(let-values(((fold-var_294)" +"(let-values(((fold-var_295)" +" fold-var_293))" +"(let-values(((fold-var_141)" +"(let-values()" +"(cons" +"(let-values()" +" null)" +" fold-var_295))))" +"(values" +" fold-var_141)))))" +"(if(not" +" #f)" +"(for-loop_283" +" fold-var_294" +" rest_184)" +" fold-var_294)))" +" fold-var_293)))))" +" for-loop_283)" +" null" +" lst_314))))" +" val-keyss_0))" +"(cons" +" rhs84_0" +"(append" +"(reverse$1" +"(let-values(((lst_107)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_107)))" +"((letrec-values(((for-loop_126)" +"(lambda(fold-var_296" +" lst_315)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_315)" +"(let-values(((done-body_2)" +"(unsafe-car" +" lst_315))" +"((rest_185)" +"(unsafe-cdr" +" lst_315)))" +"(let-values(((fold-var_297)" +"(let-values(((fold-var_298)" +" fold-var_296))" +"(let-values(((fold-var_145)" +"(let-values()" +"(cons" +"(let-values()" +"(no-binds" +" done-body_2" +" s_492" +" phase_137))" +" fold-var_298))))" +"(values" +" fold-var_145)))))" +"(if(not" +" #f)" +"(for-loop_126" +" fold-var_297" +" rest_185)" +" fold-var_297)))" +" fold-var_296)))))" +" for-loop_126)" +" null" +" lst_107))))" +" val-rhss_0))" +"(cons" +" exp-body_0" +"(append" +"(reverse$1" +"(let-values(((lst_157)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_157)))" +"((letrec-values(((for-loop_284)" +"(lambda(fold-var_299" +" lst_316)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_316)" +"(let-values(((done-body_3)" +"(unsafe-car" +" lst_316))" +"((rest_186)" +"(unsafe-cdr" +" lst_316)))" +"(let-values(((fold-var_41)" +"(let-values(((fold-var_42)" +" fold-var_299))" +"(let-values(((fold-var_300)" +"(let-values()" +"(cons" +"(let-values()" +" #f)" +" fold-var_42))))" +"(values" +" fold-var_300)))))" +"(if(not" +" #f)" +"(for-loop_284" +" fold-var_41" +" rest_186)" +" fold-var_41)))" +" fold-var_299)))))" +" for-loop_284)" +" null" +" lst_157))))" +" track-stxs_0))" +" trans-idss_1" +" stx-clauses_0" +" new-dups_0))))))))))" +"(if(equal? tmp_62 'define-syntaxes)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_15)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_15" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_15" +" 'prim-define-syntaxes)))" +"(void)))" +"(values))))" +"(let-values(((ok?_36" +" define-syntaxes104_0" +" id105_0" +" rhs106_0)" +"(let-values(((s_71)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_7)" +" s_71))" +"(let-values(((define-syntaxes104_1" +" id105_1" +" rhs106_1)" +"(let-values(((s_511)" +"(if(syntax?$1" +" s_71)" +"(syntax-e$1" +" s_71)" +" s_71)))" +"(if(pair?" +" s_511)" +"(let-values(((define-syntaxes107_0)" +"(let-values(((s_216)" +"(car" +" s_511)))" +" s_216))" +"((id108_0" +" rhs109_0)" +"(let-values(((s_512)" +"(cdr" +" s_511)))" +"(let-values(((s_513)" +"(if(syntax?$1" +" s_512)" +"(syntax-e$1" +" s_512)" +" s_512)))" +"(if(pair?" +" s_513)" +"(let-values(((id110_0)" +"(let-values(((s_514)" +"(car" +" s_513)))" +"(let-values(((s_515)" +"(if(syntax?$1" +" s_514)" +"(syntax-e$1" +" s_514)" +" s_514)))" +"(let-values(((flat-s_27)" +"(to-syntax-list.1" +" s_515)))" +"(if(not" +" flat-s_27)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_7))" +"(let-values()" +"(let-values(((id_108)" +"(let-values(((lst_317)" +" flat-s_27))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_317)))" +"((letrec-values(((for-loop_285)" +"(lambda(id_109" +" lst_318)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_318)" +"(let-values(((s_159)" +"(unsafe-car" +" lst_318))" +"((rest_187)" +"(unsafe-cdr" +" lst_318)))" +"(let-values(((id_65)" +"(let-values(((id_110)" +" id_109))" +"(let-values(((id_111)" +"(let-values()" +"(let-values(((id113_0)" +"(let-values()" +"(if(let-values(((or-part_377)" +"(if(syntax?$1" +" s_159)" +"(symbol?" +"(syntax-e$1" +" s_159))" +" #f)))" +"(if or-part_377" +" or-part_377" +"(symbol?" +" s_159)))" +" s_159" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_7" +" s_159)))))" +"(cons" +" id113_0" +" id_110)))))" +"(values" +" id_111)))))" +"(if(not" +" #f)" +"(for-loop_285" +" id_65" +" rest_187)" +" id_65)))" +" id_109)))))" +" for-loop_285)" +" null" +" lst_317)))))" +"(reverse$1" +" id_108))))))))" +"((rhs111_0)" +"(let-values(((s_103)" +"(cdr" +" s_513)))" +"(let-values(((s_104)" +"(if(syntax?$1" +" s_103)" +"(syntax-e$1" +" s_103)" +" s_103)))" +"(if(pair?" +" s_104)" +"(let-values(((rhs112_0)" +"(let-values(((s_516)" +"(car" +" s_104)))" +" s_516))" +"(()" +"(let-values(((s_217)" +"(cdr" +" s_104)))" +"(let-values(((s_105)" +"(if(syntax?$1" +" s_217)" +"(syntax-e$1" +" s_217)" +" s_217)))" +"(if(null?" +" s_105)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_7))))))" +"(values" +" rhs112_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_7))))))" +"(values" +" id110_0" +" rhs111_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_7))))))" +"(values" +" define-syntaxes107_0" +" id108_0" +" rhs109_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_7)))))" +"(values" +" #t" +" define-syntaxes104_1" +" id105_1" +" rhs106_1))))))" +"(let-values(((ids_31)" +"(remove-use-site-scopes" +" id105_0" +" body-ctx_2)))" +"(let-values((()" +"(begin" +"(let-values(((obs_18)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_18" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_18" +" 'rename-one" +"(datum->syntax$1" +" #f" +"(list" +" ids_31" +" rhs106_0)))))" +"(void)))" +"(values))))" +"(let-values(((new-dups_1)" +"(let-values(((ids114_0)" +" ids_31)" +"((phase115_0)" +" phase_137)" +"((exp-body116_0)" +" exp-body_0)" +"((dups117_0)" +" dups_0))" +"(check-no-duplicate-ids7.1" +" unsafe-undefined" +" ids114_0" +" phase115_0" +" exp-body116_0" +" dups117_0))))" +"(let-values(((counter_6)" +"(root-expand-context-counter" +" ctx_77)))" +"(let-values(((keys_6)" +"(reverse$1" +"(let-values(((lst_319)" +" ids_31))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_319)))" +"((letrec-values(((for-loop_286)" +"(lambda(fold-var_301" +" lst_320)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_320)" +"(let-values(((id_112)" +"(unsafe-car" +" lst_320))" +"((rest_188)" +"(unsafe-cdr" +" lst_320)))" +"(let-values(((fold-var_302)" +"(let-values(((fold-var_303)" +" fold-var_301))" +"(let-values(((fold-var_304)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id118_0)" +" id_112)" +"((phase119_0)" +" phase_137)" +"((counter120_0)" +" counter_6)" +"((frame-id121_0)" +" frame-id_7)" +"((exp-body122_0)" +" exp-body_0))" +"(add-local-binding!37.1" +" frame-id121_0" +" exp-body122_0" +" id118_0" +" phase119_0" +" counter120_0)))" +" fold-var_303))))" +"(values" +" fold-var_304)))))" +"(if(not" +" #f)" +"(for-loop_286" +" fold-var_302" +" rest_188)" +" fold-var_302)))" +" fold-var_301)))))" +" for-loop_286)" +" null" +" lst_319))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_72)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_72" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_72" +" 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" ctx_77)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_73)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_73" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_73" +" 'enter-bind)))" +"(void)))" +"(values))))" +"(let-values(((vals_8)" +"(eval-for-syntaxes-binding" +" 'define-syntaxes" +" rhs106_0" +" ids_31" +" body-ctx_2)))" +"(let-values(((extended-env_1)" +"(let-values(((lst_321)" +" keys_6)" +"((lst_322)" +" vals_8)" +"((lst_323)" +" ids_31))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_321)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_322)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_323)))" +"((letrec-values(((for-loop_287)" +"(lambda(env_21" +" lst_324" +" lst_325" +" lst_326)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_324)" +"(if(pair?" +" lst_325)" +"(pair?" +" lst_326)" +" #f)" +" #f)" +"(let-values(((key_89)" +"(unsafe-car" +" lst_324))" +"((rest_189)" +"(unsafe-cdr" +" lst_324))" +"((val_41)" +"(unsafe-car" +" lst_325))" +"((rest_190)" +"(unsafe-cdr" +" lst_325))" +"((id_113)" +"(unsafe-car" +" lst_326))" +"((rest_191)" +"(unsafe-cdr" +" lst_326)))" +"(let-values(((env_22)" +"(let-values(((env_23)" +" env_21))" +"(let-values(((env_24)" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_41" +" id_113" +" phase_137" +" body-ctx_2)" +"(env-extend" +" env_23" +" key_89" +" val_41)))))" +"(values" +" env_24)))))" +"(if(not" +" #f)" +"(for-loop_287" +" env_22" +" rest_189" +" rest_190" +" rest_191)" +" env_22)))" +" env_21)))))" +" for-loop_287)" +"(expand-context-env" +" body-ctx_2)" +" lst_321" +" lst_322" +" lst_323)))))" +"(begin" +"(let-values(((obs_74)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_74" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_74" +" 'exit-bind)))" +"(void)))" +"(loop_120" +"(let-values(((v_261)" +" body-ctx_2))" +"(let-values(((the-struct_93)" +" v_261))" +"(if(expand-context/outer?" +" the-struct_93)" +"(let-values(((env123_0)" +" extended-env_1)" +"((binding-layer124_0)" +"(maybe-increment-binding-layer_0" +" ids_31" +" body-ctx_2))" +"((inner125_0)" +"(root-expand-context/outer-inner" +" v_261)))" +"(expand-context/outer1.1" +" inner125_0" +"(root-expand-context/outer-post-expansion" +" the-struct_93)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_93)" +"(root-expand-context/outer-frame-id" +" the-struct_93)" +"(expand-context/outer-context" +" the-struct_93)" +" env123_0" +"(expand-context/outer-scopes" +" the-struct_93)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_93)" +" binding-layer124_0" +"(expand-context/outer-reference-records" +" the-struct_93)" +"(expand-context/outer-only-immediate?" +" the-struct_93)" +"(expand-context/outer-need-eventually-defined" +" the-struct_93)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_93)" +"(expand-context/outer-current-use-scopes" +" the-struct_93)" +"(expand-context/outer-name" +" the-struct_93)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_93))))" +" rest-bodys_0" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +"(cons" +" ids_31" +" trans-idss_1)" +"(cons" +"(datum->syntax$1" +" #f" +"(list" +" ids_31" +" rhs106_0)" +" exp-body_0)" +" stx-clauses_0)" +" new-dups_1)))))))))))))))" +"(let-values()" +"(if stratified?_0" +"(let-values()" +"(begin" +"(if(null? done-bodys_0)" +"(void)" +"(let-values()" +"(error" +" \"internal error: accumulated expressions not empty\")))" +"(loop_120" +" body-ctx_2" +" null" +"(if(if(null? val-idss_0)" +"(null? trans-idss_1)" +" #f)" +"(reverse$1" +"(cons" +" exp-body_0" +" rest-bodys_0))" +"(list" +"(datum->syntax$1" +" #f" +"(cons" +"(core-id" +" '#%stratified-body" +" phase_137)" +"(cons" +" exp-body_0" +" rest-bodys_0)))))" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)))" +"(let-values()" +"(loop_120" +" body-ctx_2" +" rest-bodys_0" +"(cons exp-body_0 done-bodys_0)" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0))))))))))))))))))" +" loop_120)" +" body-ctx_0" +" init-bodys_0" +" null" +" null" +" null" +" null" +" null" +" null" +" null" +"(make-check-no-duplicate-table))))))))))))))))))))" +"(define-values" +"(finish-expanding-body27.1)" +"(lambda(disappeared-transformer-bindings13_0" +" name12_0" +" source10_0" +" stratified?11_0" +" body-ctx18_0" +" frame-id19_0" +" def-ctx-scopes20_0" +" val-idss21_0" +" val-keyss22_0" +" val-rhss23_0" +" track-stxs24_0" +" stx-clauses25_0" +" done-bodys26_0)" +"(begin" +" 'finish-expanding-body27" +"(let-values(((body-ctx_3) body-ctx18_0))" +"(let-values(((frame-id_13) frame-id19_0))" +"(let-values(((def-ctx-scopes_7) def-ctx-scopes20_0))" +"(let-values(((val-idss_1) val-idss21_0))" +"(let-values(((val-keyss_1) val-keyss22_0))" +"(let-values(((val-rhss_1) val-rhss23_0))" +"(let-values(((track-stxs_1) track-stxs24_0))" +"(let-values(((stx-clauses_1) stx-clauses25_0))" +"(let-values(((done-bodys_1) done-bodys26_0))" +"(let-values(((s_233) source10_0))" +"(let-values(((stratified?_1) stratified?11_0))" +"(let-values(((name_81) name12_0))" +"(let-values(((disappeared-transformer-bindings_0) disappeared-transformer-bindings13_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(null? done-bodys_1)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"no expression after a sequence of internal definitions\"" +" s_233))" +"(void))" +"(values))))" +"(let-values(((finish-ctx_0)" +"(let-values(((v_262)" +"(accumulate-def-ctx-scopes" +" body-ctx_3" +" def-ctx-scopes_7)))" +"(let-values(((the-struct_94) v_262))" +"(if(expand-context/outer? the-struct_94)" +"(let-values(((context126_0) 'expression)" +"((use-site-scopes127_0)(box null))" +"((scopes128_0)" +"(append" +"(unbox" +"(root-expand-context-use-site-scopes" +" body-ctx_3))" +"(expand-context-scopes body-ctx_3)))" +"((only-immediate?129_0) #f)" +"((def-ctx-scopes130_0) #f)" +"((post-expansion131_0) #f)" +"((inner132_0)" +"(root-expand-context/outer-inner v_262)))" +"(expand-context/outer1.1" +" inner132_0" +" post-expansion131_0" +" use-site-scopes127_0" +"(root-expand-context/outer-frame-id the-struct_94)" +" context126_0" +"(expand-context/outer-env the-struct_94)" +" scopes128_0" +" def-ctx-scopes130_0" +"(expand-context/outer-binding-layer the-struct_94)" +"(expand-context/outer-reference-records the-struct_94)" +" only-immediate?129_0" +"(expand-context/outer-need-eventually-defined the-struct_94)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_94)" +"(expand-context/outer-current-use-scopes the-struct_94)" +"(expand-context/outer-name the-struct_94)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_94))))))" +"(let-values(((finish-bodys_0)" +"(lambda()" +"(begin" +" 'finish-bodys" +"(let-values(((block->list?_0)(null? val-idss_1)))" +"(let-values((()" +"(begin" +"(if block->list?_0" +"(void)" +"(let-values()" +"(let-values(((obs_75)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_75" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_75" +" 'next-group)))" +"(void)))))" +"(values))))" +"(let-values(((last-i_1)(sub1(length done-bodys_1))))" +"(let-values((()" +"(begin" +"(let-values(((obs_76)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_76" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_76" +" 'enter-list" +"(datum->syntax$1" +" #f" +" done-bodys_1))))" +"(void)))" +"(values))))" +"(let-values(((exp-bodys_0)" +"(reverse$1" +"(let-values(((lst_213) done-bodys_1)" +"((start_64) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_213)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals start_64)))" +"((letrec-values(((for-loop_288)" +"(lambda(fold-var_305" +" lst_5" +" pos_125)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_5)" +" #t" +" #f)" +"(let-values(((done-body_4)" +"(unsafe-car" +" lst_5))" +"((rest_192)" +"(unsafe-cdr" +" lst_5))" +"((i_14)" +" pos_125))" +"(let-values(((fold-var_306)" +"(let-values(((fold-var_307)" +" fold-var_305))" +"(let-values(((fold-var_308)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(let-values(((obs_77)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_77" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_77" +" 'next)))" +"(void)))" +"(let-values(((done-body133_0)" +" done-body_4)" +"((temp134_3)" +"(if(if name_81" +"(=" +" i_14" +" last-i_1)" +" #f)" +"(let-values(((v_263)" +" finish-ctx_0))" +"(let-values(((the-struct_95)" +" v_263))" +"(if(expand-context/outer?" +" the-struct_95)" +"(let-values(((name135_0)" +" name_81)" +"((inner136_0)" +"(root-expand-context/outer-inner" +" v_263)))" +"(expand-context/outer1.1" +" inner136_0" +"(root-expand-context/outer-post-expansion" +" the-struct_95)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_95)" +"(root-expand-context/outer-frame-id" +" the-struct_95)" +"(expand-context/outer-context" +" the-struct_95)" +"(expand-context/outer-env" +" the-struct_95)" +"(expand-context/outer-scopes" +" the-struct_95)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_95)" +"(expand-context/outer-binding-layer" +" the-struct_95)" +"(expand-context/outer-reference-records" +" the-struct_95)" +"(expand-context/outer-only-immediate?" +" the-struct_95)" +"(expand-context/outer-need-eventually-defined" +" the-struct_95)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_95)" +"(expand-context/outer-current-use-scopes" +" the-struct_95)" +" name135_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_95))))" +" finish-ctx_0)))" +"(expand9.1" +" #f" +" #f" +" #f" +" done-body133_0" +" temp134_3))))" +" fold-var_307))))" +"(values" +" fold-var_308)))))" +"(if(not" +" #f)" +"(for-loop_288" +" fold-var_306" +" rest_192" +"(+" +" pos_125" +" 1))" +" fold-var_306)))" +" fold-var_305)))))" +" for-loop_288)" +" null" +" lst_213" +" start_64))))))" +"(begin" +"(let-values(((obs_78)" +"(expand-context-observer body-ctx_3)))" +"(if obs_78" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_78" +" 'exit-list" +"(datum->syntax$1 #f exp-bodys_0))))" +"(void)))" +"(reference-record-clear! frame-id_13)" +" exp-bodys_0))))))))))" +"(if(if(null? val-idss_1)(null? disappeared-transformer-bindings_0) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_79)(expand-context-observer finish-ctx_0)))" +"(if obs_79" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_79" +" 'block->list" +"(datum->syntax$1 s_233 done-bodys_1))))" +"(void)))" +"(finish-bodys_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_80)" +"(expand-context-observer finish-ctx_0)))" +"(if obs_80" +"(let-values()" +"(log-letrec-values$1" +" obs_80" +" finish-ctx_0" +" s_233" +" val-idss_1" +" val-rhss_1" +" track-stxs_1" +" stx-clauses_1" +" done-bodys_1))" +"(void)))" +"(values))))" +"(let-values(((exp-s_12)" +"(let-values(((val-idss137_0) val-idss_1)" +"((val-keyss138_0) val-keyss_1)" +"((val-rhss139_0) val-rhss_1)" +"((track-stxs140_0) track-stxs_1)" +"((temp141_2)(not stratified?_1))" +"((frame-id142_0) frame-id_13)" +"((finish-ctx143_0) finish-ctx_0)" +"((s144_0) s_233)" +"((temp145_1)(pair? stx-clauses_1))" +"((finish-bodys146_0) finish-bodys_0)" +"((temp147_0) #f))" +"(expand-and-split-bindings-by-reference48.1" +" finish-ctx143_0" +" frame-id142_0" +" finish-bodys146_0" +" temp145_1" +" s144_0" +" temp141_2" +" temp147_0" +" val-idss137_0" +" val-keyss138_0" +" val-rhss139_0" +" track-stxs140_0))))" +"(begin" +"(let-values(((obs_81)(expand-context-observer body-ctx_3)))" +"(if obs_81" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_81 'exit-prim exp-s_12)" +"(call-expand-observe obs_81 'return exp-s_12))))" +"(void)))" +"(if(expand-context-to-parsed? body-ctx_3)" +"(list exp-s_12)" +"(list" +"(attach-disappeared-transformer-bindings" +" exp-s_12" +" disappeared-transformer-bindings_0))))))))))))))))))))))))))))" +"(define-values" +"(expand-and-split-bindings-by-reference48.1)" +"(lambda(ctx32_0" +" frame-id31_0" +" get-body35_0" +" had-stxes?34_0" +" source33_0" +" split?30_0" +" track?36_0" +" idss44_0" +" keyss45_0" +" rhss46_0" +" track-stxs47_0)" +"(begin" +" 'expand-and-split-bindings-by-reference48" +"(let-values(((idss_1) idss44_0))" +"(let-values(((keyss_0) keyss45_0))" +"(let-values(((rhss_1) rhss46_0))" +"(let-values(((track-stxs_2) track-stxs47_0))" +"(let-values(((split?_0) split?30_0))" +"(let-values(((frame-id_14) frame-id31_0))" +"(let-values(((ctx_78) ctx32_0))" +"(let-values(((s_366) source33_0))" +"(let-values(((had-stxes?_0) had-stxes?34_0))" +"(let-values(((get-body_0) get-body35_0))" +"(let-values(((track?_1) track?36_0))" +"(let-values()" +"(let-values(((phase_138)(expand-context-phase ctx_78)))" +"((letrec-values(((loop_27)" +"(lambda(idss_2" +" keyss_1" +" rhss_2" +" track-stxs_3" +" accum-idss_0" +" accum-keyss_0" +" accum-rhss_0" +" accum-track-stxs_0" +" track?_2" +" get-list?_0" +" can-log?_0)" +"(begin" +" 'loop" +"(if(null? idss_2)" +"(let-values()" +"(if(if(null? accum-idss_0) get-list?_0 #f)" +"(let-values()(get-body_0))" +"(let-values()" +"(let-values(((exp-body_1)(get-body_0)))" +"(let-values(((result-s_9)" +"(if(expand-context-to-parsed? ctx_78)" +"(if(null? accum-idss_0)" +"(parsed-let-values17.1" +"(keep-properties-only s_366)" +" null" +" null" +" exp-body_1)" +"(parsed-letrec-values18.1" +"(keep-properties-only s_366)" +"(reverse$1 accum-idss_0)" +"(reverse$1" +"(map2" +" list" +" accum-keyss_0" +" accum-rhss_0))" +" exp-body_1))" +"(let-values(((track?148_0) track?_2)" +"((s149_0) s_366)" +"((temp150_1)" +"(list*" +"(if(null? accum-idss_0)" +"(core-id" +" 'let-values" +" phase_138)" +"(core-id" +" 'letrec-values" +" phase_138))" +"(build-clauses" +" accum-idss_0" +" accum-rhss_0" +" accum-track-stxs_0)" +" exp-body_1)))" +"(rebuild5.1" +" track?148_0" +" s149_0" +" temp150_1)))))" +"(begin" +"(let-values(((obs_82)" +"(expand-context-observer ctx_78)))" +"(if obs_82" +"(let-values()" +"(if(if can-log?_0" +"(log-tag? had-stxes?_0 ctx_78)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_82" +" 'tag" +" result-s_9))" +"(void)))" +"(void)))" +"(if get-list?_0(list result-s_9) result-s_9)))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_83)" +"(expand-context-observer" +" ctx_78)))" +"(if obs_83" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_83 'next)))" +"(void)))" +"(values))))" +"(let-values(((ids_32)(car idss_2)))" +"(let-values(((expanded-rhs_0)" +"(let-values(((temp151_1)(car rhss_2))" +"((temp152_1)" +"(as-named-context" +" ctx_78" +" ids_32)))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp151_1" +" temp152_1))))" +"(let-values(((track-stx_0)(car track-stxs_3)))" +"(let-values(((local-or-forward-references?_0)" +"(reference-record-forward-references?" +" frame-id_14)))" +"(let-values((()" +"(begin" +"(reference-record-bound!" +" frame-id_14" +"(car keyss_1))" +"(values))))" +"(let-values(((forward-references?_0)" +"(reference-record-forward-references?" +" frame-id_14)))" +"(if(if(not local-or-forward-references?_0)" +" split?_0" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(null? accum-idss_0)" +"(void)" +"(let-values()" +"(error" +" \"internal error: accumulated ids not empty\")))" +"(values))))" +"(let-values(((exp-rest_0)" +"(loop_27" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +" null" +" null" +" null" +" null" +" #f" +" #t" +" #f)))" +"(let-values(((result-s_10)" +"(if(expand-context-to-parsed?" +" ctx_78)" +"(parsed-let-values17.1" +"(keep-properties-only" +" s_366)" +"(list ids_32)" +"(list" +"(list" +"(car keyss_1)" +" expanded-rhs_0))" +" exp-rest_0)" +"(let-values(((track?153_0)" +" track?_2)" +"((s154_1)" +" s_366)" +"((temp155_2)" +"(list*" +"(core-id" +" 'let-values" +" phase_138)" +"(list" +"(build-clause" +" ids_32" +" expanded-rhs_0" +" track-stx_0))" +" exp-rest_0)))" +"(rebuild5.1" +" track?153_0" +" s154_1" +" temp155_2)))))" +"(begin" +"(let-values(((obs_84)" +"(expand-context-observer" +" ctx_78)))" +"(if obs_84" +"(let-values()" +"(if(if can-log?_0" +"(log-tag?" +" had-stxes?_0" +" ctx_78)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_84" +" 'tag" +" result-s_10))" +"(void)))" +"(void)))" +"(if get-list?_0" +"(list result-s_10)" +" result-s_10))))))" +"(if(if(not forward-references?_0)" +"(let-values(((or-part_378) split?_0))" +"(if or-part_378" +" or-part_378" +"(null?(cdr idss_2))))" +" #f)" +"(let-values()" +"(let-values(((exp-rest_1)" +"(loop_27" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +" null" +" null" +" null" +" null" +" #f" +" #t" +" #f)))" +"(let-values(((result-s_11)" +"(if(expand-context-to-parsed?" +" ctx_78)" +"(parsed-letrec-values18.1" +"(keep-properties-only" +" s_366)" +"(reverse$1" +"(cons" +" ids_32" +" accum-idss_0))" +"(reverse$1" +"(cons" +"(list" +"(car keyss_1)" +" expanded-rhs_0)" +"(map2" +" list" +" accum-keyss_0" +" accum-rhss_0)))" +" exp-rest_1)" +"(let-values(((track?156_0)" +" track?_2)" +"((s157_1)" +" s_366)" +"((temp158_1)" +"(list*" +"(core-id" +" 'letrec-values" +" phase_138)" +"(build-clauses" +"(cons" +" ids_32" +" accum-idss_0)" +"(cons" +" expanded-rhs_0" +" accum-rhss_0)" +"(cons" +" track-stx_0" +" accum-track-stxs_0))" +" exp-rest_1)))" +"(rebuild5.1" +" track?156_0" +" s157_1" +" temp158_1)))))" +"(begin" +"(let-values(((obs_85)" +"(expand-context-observer" +" ctx_78)))" +"(if obs_85" +"(let-values()" +"(if(if can-log?_0" +"(log-tag?" +" had-stxes?_0" +" ctx_78)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_85" +" 'tag" +" result-s_11))" +"(void)))" +"(void)))" +"(if get-list?_0" +"(list result-s_11)" +" result-s_11)))))" +"(let-values()" +"(loop_27" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +"(cons ids_32 accum-idss_0)" +"(cons(car keyss_1) accum-keyss_0)" +"(cons expanded-rhs_0 accum-rhss_0)" +"(cons track-stx_0 accum-track-stxs_0)" +" track?_2" +" get-list?_0" +" can-log?_0)))))))))))))))))" +" loop_27)" +" idss_1" +" keyss_0" +" rhss_1" +" track-stxs_2" +" null" +" null" +" null" +" null" +" track?_1" +" #f" +" #t)))))))))))))))))" +"(define-values" +"(build-clauses)" +"(lambda(accum-idss_1 accum-rhss_1 accum-track-stxs_1)" +"(begin(map2 build-clause(reverse$1 accum-idss_1)(reverse$1 accum-rhss_1)(reverse$1 accum-track-stxs_1)))))" +"(define-values" +"(build-clause)" +"(lambda(ids_33 rhs_19 track-stx_1)" +"(begin" +"(let-values(((clause_2)(datum->syntax$1 #f(list ids_33 rhs_19))))" +"(if track-stx_1(syntax-track-origin$1 clause_2 track-stx_1) clause_2)))))" +"(define-values" +"(no-binds)" +"(lambda(expr_10 s_517 phase_139)" +"(begin" +"(let-values(((s-runtime-stx_0)(syntax-shift-phase-level$1 runtime-stx phase_139)))" +"(datum->syntax$1" +"(core-id '#%app phase_139)" +"(list(core-id 'begin phase_139) expr_10(list(datum->syntax$1 s-runtime-stx_0 'values)))" +" s_517)))))" +"(define-values" +"(log-tag?)" +"(lambda(had-stxes?_1 ctx_79)(begin(if had-stxes?_1(not(expand-context-only-immediate? ctx_79)) #f))))" +"(define-values" +"(log-letrec-values$1)" +"(lambda(obs_86 ctx_80 s_396 val-idss_2 val-rhss_2 track-stxs_4 stx-clauses_2 done-bodys_2)" +"(begin" +" 'log-letrec-values" +"(let-values(((phase_140)(expand-context-phase ctx_80)))" +"(let-values(((clauses_0)" +"(reverse$1" +"(let-values(((lst_327) val-idss_2)((lst_328) val-rhss_2)((lst_329) track-stxs_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_327)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_328)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_329)))" +"((letrec-values(((for-loop_289)" +"(lambda(fold-var_309 lst_330 lst_331 lst_332)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_330)(if(pair? lst_331)(pair? lst_332) #f) #f)" +"(let-values(((val-ids_0)(unsafe-car lst_330))" +"((rest_193)(unsafe-cdr lst_330))" +"((val-rhs_0)(unsafe-car lst_331))" +"((rest_194)(unsafe-cdr lst_331))" +"((track-stx_2)(unsafe-car lst_332))" +"((rest_195)(unsafe-cdr lst_332)))" +"(let-values(((fold-var_310)" +"(let-values(((fold-var_311) fold-var_309))" +"(let-values(((fold-var_312)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list val-ids_0 val-rhs_0)" +" track-stx_2))" +" fold-var_311))))" +"(values fold-var_312)))))" +"(if(not #f)" +"(for-loop_289 fold-var_310 rest_193 rest_194 rest_195)" +" fold-var_310)))" +" fold-var_309)))))" +" for-loop_289)" +" null" +" lst_327" +" lst_328" +" lst_329))))))" +"(let-values(((had-stxes?_2)(not(null? stx-clauses_2))))" +"(let-values(((lv-id_0)(core-id(if had-stxes?_2 'letrec-syntaxes+values 'letrec-values) phase_140)))" +"(let-values(((lv-s_0)" +"(datum->syntax$1" +" #f" +"(if had-stxes?_2" +"(list* lv-id_0 stx-clauses_2 clauses_0 done-bodys_2)" +"(list* lv-id_0 clauses_0 done-bodys_2))" +" s_396)))" +"(begin" +"(call-expand-observe obs_86 'block->letrec(list lv-s_0))" +"(call-expand-observe obs_86 'visit lv-s_0)" +"(call-expand-observe obs_86 'resolve lv-id_0)" +"(call-expand-observe obs_86 'enter-prim lv-s_0)" +"(if had-stxes?_2" +"(let-values()" +"(begin" +"(call-expand-observe obs_86 'prim-letrec-syntaxes+values)" +"(call-expand-observe" +" obs_86" +" 'letrec-syntaxes-renames" +" stx-clauses_2" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_396))" +"(call-expand-observe obs_86 'prepare-env)" +"(call-expand-observe obs_86 'next-group)" +"(if(null? val-idss_2)" +"(void)" +"(let-values()" +"(begin" +"(call-expand-observe obs_86 'prim-letrec-values)" +"(call-expand-observe" +" obs_86" +" 'let-renames" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_396)))))))" +"(let-values()" +"(begin" +"(call-expand-observe obs_86 'prim-letrec-values)" +"(call-expand-observe" +" obs_86" +" 'let-renames" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_396))))))))))))))" +"(define-values" +"(lambda-clause-expander)" +"(lambda(s_74 disarmed-s_5 formals_1 bodys_9 ctx_81 log-renames-tag_0)" +"(begin" +"(let-values(((sc_37)(new-scope 'local)))" +"(let-values(((phase_84)(expand-context-phase ctx_81)))" +"(let-values(((ids_34)(parse-and-flatten-formals formals_1 sc_37 disarmed-s_5)))" +"(let-values((()" +"(begin" +"(let-values(((ids33_0) ids_34)" +"((phase34_1) phase_84)" +"((s35_1) s_74)" +" ((temp36_8) \"argument name\"))" +"(check-no-duplicate-ids7.1 temp36_8 ids33_0 phase34_1 s35_1 unsafe-undefined))" +"(values))))" +"(let-values(((counter_7)(root-expand-context-counter ctx_81)))" +"(let-values(((keys_7)" +"(reverse$1" +"(let-values(((lst_88) ids_34))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_88)))" +"((letrec-values(((for-loop_191)" +"(lambda(fold-var_157 lst_163)" +"(begin" +" 'for-loop" +"(if(pair? lst_163)" +"(let-values(((id_114)(unsafe-car lst_163))" +"((rest_84)(unsafe-cdr lst_163)))" +"(let-values(((fold-var_33)" +"(let-values(((fold-var_34) fold-var_157))" +"(let-values(((fold-var_158)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id37_0)" +" id_114)" +"((phase38_1)" +" phase_84)" +"((counter39_0)" +" counter_7)" +"((s40_0)" +" s_74))" +"(add-local-binding!37.1" +" #f" +" s40_0" +" id37_0" +" phase38_1" +" counter39_0)))" +" fold-var_34))))" +"(values fold-var_158)))))" +"(if(not #f)" +"(for-loop_191 fold-var_33 rest_84)" +" fold-var_33)))" +" fold-var_157)))))" +" for-loop_191)" +" null" +" lst_88))))))" +"(let-values(((body-env_0)" +"(let-values(((lst_80) keys_7)((lst_91) ids_34))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_80)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_91)))" +"((letrec-values(((for-loop_49)" +"(lambda(env_25 lst_82 lst_58)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_82)(pair? lst_58) #f)" +"(let-values(((key_90)(unsafe-car lst_82))" +"((rest_196)(unsafe-cdr lst_82))" +"((id_115)(unsafe-car lst_58))" +"((rest_197)(unsafe-cdr lst_58)))" +"(let-values(((env_26)" +"(let-values(((env_27) env_25))" +"(let-values(((env_28)" +"(let-values()" +"(env-extend" +" env_27" +" key_90" +"(local-variable1.1" +" id_115)))))" +"(values env_28)))))" +"(if(not #f)" +"(for-loop_49 env_26 rest_196 rest_197)" +" env_26)))" +" env_25)))))" +" for-loop_49)" +"(expand-context-env ctx_81)" +" lst_80" +" lst_91)))))" +"(let-values(((sc-formals_0)(add-scope formals_1 sc_37)))" +"(let-values(((sc-bodys_0)" +"(reverse$1" +"(let-values(((lst_17) bodys_9))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(fold-var_217 lst_18)" +"(begin" +" 'for-loop" +"(if(pair? lst_18)" +"(let-values(((body_10)(unsafe-car lst_18))" +"((rest_5)(unsafe-cdr lst_18)))" +"(let-values(((fold-var_218)" +"(let-values(((fold-var_75)" +" fold-var_217))" +"(let-values(((fold-var_65)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_10" +" sc_37))" +" fold-var_75))))" +"(values fold-var_65)))))" +"(if(not #f)" +"(for-loop_10 fold-var_218 rest_5)" +" fold-var_218)))" +" fold-var_217)))))" +" for-loop_10)" +" null" +" lst_17))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_87)(expand-context-observer ctx_81)))" +"(if obs_87" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_87" +" log-renames-tag_0" +" sc-formals_0" +"(datum->syntax$1 #f sc-bodys_0))))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_4)" +"(let-values(((v_264) ctx_81))" +"(let-values(((the-struct_96) v_264))" +"(if(expand-context/outer? the-struct_96)" +"(let-values(((env41_0) body-env_0)" +"((scopes42_0)(cons sc_37(expand-context-scopes ctx_81)))" +"((binding-layer43_0)" +"(increment-binding-layer ids_34 ctx_81 sc_37))" +"((frame-id44_0) #f)" +"((inner45_0)(root-expand-context/outer-inner v_264)))" +"(expand-context/outer1.1" +" inner45_0" +"(root-expand-context/outer-post-expansion the-struct_96)" +"(root-expand-context/outer-use-site-scopes the-struct_96)" +" frame-id44_0" +"(expand-context/outer-context the-struct_96)" +" env41_0" +" scopes42_0" +"(expand-context/outer-def-ctx-scopes the-struct_96)" +" binding-layer43_0" +"(expand-context/outer-reference-records the-struct_96)" +"(expand-context/outer-only-immediate? the-struct_96)" +"(expand-context/outer-need-eventually-defined the-struct_96)" +"(expand-context/outer-current-introduction-scopes the-struct_96)" +"(expand-context/outer-current-use-scopes the-struct_96)" +"(expand-context/outer-name the-struct_96)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_96))))))" +"(let-values(((exp-body_2)" +"(let-values(((sc-bodys46_0) sc-bodys_0)" +"((body-ctx47_0) body-ctx_4)" +"((temp48_3)" +"(let-values(((ctx49_0) ctx_81)((s50_0) s_74)((temp51_2) #t))" +"(keep-as-needed119.1 #f temp51_2 #f ctx49_0 s50_0))))" +"(expand-body7.1 temp48_3 #f sc-bodys46_0 body-ctx47_0))))" +"(values" +"(if(expand-context-to-parsed? ctx_81)" +"(unflatten-like-formals keys_7 formals_1)" +" sc-formals_0)" +" exp-body_2))))))))))))))))" +"(void" +"(add-core-form!*" +" 'lambda" +"(lambda(s_13 ctx_82)" +"(let-values((()" +"(begin" +"(let-values(((obs_88)(expand-context-observer ctx_82)))" +"(if obs_88(let-values()(let-values()(call-expand-observe obs_88 'prim-lambda)))(void)))" +"(values))))" +"(let-values(((disarmed-s_6)(syntax-disarm$1 s_13)))" +"(let-values(((ok?_37 lambda52_0 formals53_0 body54_0)" +"(let-values(((s_495) disarmed-s_6))" +"(let-values(((orig-s_40) s_495))" +"(let-values(((lambda52_1 formals53_1 body54_1)" +"(let-values(((s_172)(if(syntax?$1 s_495)(syntax-e$1 s_495) s_495)))" +"(if(pair? s_172)" +"(let-values(((lambda55_0)(let-values(((s_45)(car s_172))) s_45))" +"((formals56_0 body57_0)" +"(let-values(((s_84)(cdr s_172)))" +"(let-values(((s_174)" +"(if(syntax?$1 s_84)" +"(syntax-e$1 s_84)" +" s_84)))" +"(if(pair? s_174)" +"(let-values(((formals58_0)" +"(let-values(((s_175)(car s_174)))" +" s_175))" +"((body59_0)" +"(let-values(((s_176)(cdr s_174)))" +"(let-values(((s_451)" +"(if(syntax?$1 s_176)" +"(syntax-e$1 s_176)" +" s_176)))" +"(let-values(((flat-s_28)" +"(to-syntax-list.1" +" s_451)))" +"(if(not flat-s_28)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))" +"(if(null? flat-s_28)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))" +"(let-values()" +" flat-s_28))))))))" +"(values formals58_0 body59_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_40))))))" +"(values lambda55_0 formals56_0 body57_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_40)))))" +"(values #t lambda52_1 formals53_1 body54_1))))))" +"(let-values(((rebuild-s_4)" +"(let-values(((ctx60_1) ctx_82)((s61_0) s_13)((temp62_3) #t))" +"(keep-as-needed119.1 #f #f temp62_3 ctx60_1 s61_0))))" +"(let-values(((formals_2 body_11)" +"(lambda-clause-expander s_13 disarmed-s_6 formals53_0 body54_0 ctx_82 'lambda-renames)))" +"(if(expand-context-to-parsed? ctx_82)" +"(parsed-lambda5.1 rebuild-s_4 formals_2 body_11)" +"(let-values(((rebuild-s63_0) rebuild-s_4)((temp64_6)(list* lambda52_0 formals_2 body_11)))" +"(rebuild5.1 #t rebuild-s63_0 temp64_6)))))))))))" +"(void" +"(add-core-form!*" +" 'λ" +"(lambda(s_26)" +"(let-values(((ok?_38 lam-id65_0 formals66_0 _67_0)" +"(let-values(((s_518) s_26))" +"(let-values(((orig-s_41) s_518))" +"(let-values(((lam-id65_1 formals66_1 _67_1)" +"(let-values(((s_501)(if(syntax?$1 s_518)(syntax-e$1 s_518) s_518)))" +"(if(pair? s_501)" +"(let-values(((lam-id68_0)(let-values(((s_506)(car s_501))) s_506))" +"((formals69_0 _70_0)" +"(let-values(((s_507)(cdr s_501)))" +"(let-values(((s_52)" +"(if(syntax?$1 s_507)(syntax-e$1 s_507) s_507)))" +"(if(pair? s_52)" +"(let-values(((formals71_0)" +"(let-values(((s_53)(car s_52))) s_53))" +"((_72_0)" +"(let-values(((s_54)(cdr s_52)))" +"(let-values(((s_312)" +"(if(syntax?$1 s_54)" +"(syntax-e$1 s_54)" +" s_54)))" +"(let-values(((flat-s_29)" +"(to-syntax-list.1 s_312)))" +"(if(not flat-s_29)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))" +"(if(null? flat-s_29)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))" +"(let-values() flat-s_29))))))))" +"(values formals71_0 _72_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_41))))))" +"(values lam-id68_0 formals69_0 _70_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_41)))))" +"(values #t lam-id65_1 formals66_1 _67_1))))))" +"(let-values(((ids_35)(parse-and-flatten-formals formals66_0 #f s_26)))" +"(let-values(((ctx_75)(let-values(((temp77_4) #t))(get-current-expand-context16.1 temp77_4 'unexpected))))" +"(let-values(((phase_93)(if ctx_75(expand-context-phase ctx_75) 0)))" +"(begin" +" (let-values (((ids73_0) ids_35) ((phase74_2) phase_93) ((s75_0) s_26) ((temp76_4) \"argument name\"))" +"(check-no-duplicate-ids7.1 temp76_4 ids73_0 phase74_2 s75_0 unsafe-undefined))" +"(datum->syntax$1" +" s_26" +"(cons" +"(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_93) 'lambda lam-id65_0 lam-id65_0)" +"(cdr(syntax-e$1 s_26)))" +" s_26" +" s_26)))))))))" +"(void" +"(add-core-form!*" +" 'case-lambda" +"(lambda(s_454 ctx_83)" +"(let-values((()" +"(begin" +"(let-values(((obs_89)(expand-context-observer ctx_83)))" +"(if obs_89" +"(let-values()(let-values()(call-expand-observe obs_89 'prim-case-lambda)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_7)(syntax-disarm$1 s_454)))" +"(let-values(((ok?_39 case-lambda78_0 formals79_0 body80_0)" +"(let-values(((s_519) disarmed-s_7))" +"(let-values(((orig-s_42) s_519))" +"(let-values(((case-lambda78_1 formals79_1 body80_1)" +"(let-values(((s_415)(if(syntax?$1 s_519)(syntax-e$1 s_519) s_519)))" +"(if(pair? s_415)" +"(let-values(((case-lambda81_0)(let-values(((s_520)(car s_415))) s_520))" +"((formals82_0 body83_0)" +"(let-values(((s_407)(cdr s_415)))" +"(let-values(((s_521)" +"(if(syntax?$1 s_407)" +"(syntax-e$1 s_407)" +" s_407)))" +"(let-values(((flat-s_30)(to-syntax-list.1 s_521)))" +"(if(not flat-s_30)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_42))" +"(let-values()" +"(let-values(((formals_3 body_12)" +"(let-values(((lst_333) flat-s_30))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_333)))" +"((letrec-values(((for-loop_290)" +"(lambda(formals_4" +" body_13" +" lst_334)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_334)" +"(let-values(((s_209)" +"(unsafe-car" +" lst_334))" +"((rest_198)" +"(unsafe-cdr" +" lst_334)))" +"(let-values(((formals_5" +" body_14)" +"(let-values(((formals_6)" +" formals_4)" +"((body_15)" +" body_13))" +"(let-values(((formals_7" +" body_16)" +"(let-values()" +"(let-values(((formals90_0" +" body91_0)" +"(let-values()" +"(let-values(((s_522)" +"(if(syntax?$1" +" s_209)" +"(syntax-e$1" +" s_209)" +" s_209)))" +"(if(pair?" +" s_522)" +"(let-values(((formals84_0)" +"(let-values(((s_523)" +"(car" +" s_522)))" +" s_523))" +"((body85_0)" +"(let-values(((s_524)" +"(cdr" +" s_522)))" +"(let-values(((s_525)" +"(if(syntax?$1" +" s_524)" +"(syntax-e$1" +" s_524)" +" s_524)))" +"(let-values(((flat-s_31)" +"(to-syntax-list.1" +" s_525)))" +"(if(not" +" flat-s_31)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))" +"(if(null?" +" flat-s_31)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))" +"(let-values()" +" flat-s_31))))))))" +"(values" +" formals84_0" +" body85_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))))))" +"(values" +"(cons" +" formals90_0" +" formals_6)" +"(cons" +" body91_0" +" body_15))))))" +"(values" +" formals_7" +" body_16)))))" +"(if(not" +" #f)" +"(for-loop_290" +" formals_5" +" body_14" +" rest_198)" +"(values" +" formals_5" +" body_14))))" +"(values" +" formals_4" +" body_13))))))" +" for-loop_290)" +" null" +" null" +" lst_333)))))" +"(values" +"(reverse$1 formals_3)" +"(reverse$1 body_12))))))))))" +"(values case-lambda81_0 formals82_0 body83_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_42)))))" +"(values #t case-lambda78_1 formals79_1 body80_1))))))" +"(let-values(((ok?_40 case-lambda86_0 clause87_0)" +"(let-values(((s_526) disarmed-s_7))" +"(let-values(((orig-s_43) s_526))" +"(let-values(((case-lambda86_1 clause87_1)" +"(let-values(((s_458)(if(syntax?$1 s_526)(syntax-e$1 s_526) s_526)))" +"(if(pair? s_458)" +"(let-values(((case-lambda88_0)" +"(let-values(((s_211)(car s_458))) s_211))" +"((clause89_0)" +"(let-values(((s_527)(cdr s_458)))" +"(let-values(((s_528)" +"(if(syntax?$1 s_527)" +"(syntax-e$1 s_527)" +" s_527)))" +"(let-values(((flat-s_32)(to-syntax-list.1 s_528)))" +"(if(not flat-s_32)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_43))" +"(let-values() flat-s_32)))))))" +"(values case-lambda88_0 clause89_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_43)))))" +"(values #t case-lambda86_1 clause87_1))))))" +"(let-values(((rebuild-s_5)" +"(let-values(((ctx92_0) ctx_83)((s93_0) s_454)((temp94_0) #t))" +"(keep-as-needed119.1 #f #f temp94_0 ctx92_0 s93_0))))" +"(let-values(((clauses_1)" +"(reverse$1" +"(let-values(((lst_111) formals79_0)((lst_204) body80_0)((lst_112) clause87_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_111)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_204)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_112)))" +"((letrec-values(((for-loop_31)" +"(lambda(fold-var_197 lst_335 lst_336 lst_337)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_335)" +"(if(pair? lst_336)(pair? lst_337) #f)" +" #f)" +"(let-values(((formals_8)(unsafe-car lst_335))" +"((rest_199)(unsafe-cdr lst_335))" +"((body_17)(unsafe-car lst_336))" +"((rest_200)(unsafe-cdr lst_336))" +"((clause_3)(unsafe-car lst_337))" +"((rest_201)(unsafe-cdr lst_337)))" +"(let-values(((fold-var_313)" +"(let-values(((fold-var_314) fold-var_197))" +"(let-values(((fold-var_315)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_90)" +"(expand-context-observer" +" ctx_83)))" +"(if obs_90" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_90" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((rebuild-clause_0)" +"(let-values(((ctx95_0)" +" ctx_83)" +"((clause96_0)" +" clause_3))" +"(keep-as-needed119.1" +" #f" +" #f" +" #f" +" ctx95_0" +" clause96_0))))" +"(let-values(((exp-formals_0" +" exp-body_3)" +"(lambda-clause-expander" +" s_454" +" disarmed-s_7" +" formals_8" +" body_17" +" ctx_83" +" 'lambda-renames)))" +"(if(expand-context-to-parsed?" +" ctx_83)" +"(list" +" exp-formals_0" +" exp-body_3)" +"(let-values(((rebuild-clause97_0)" +" rebuild-clause_0)" +"((temp98_4)" +"(list*" +" exp-formals_0" +" exp-body_3)))" +"(rebuild5.1" +" #t" +" rebuild-clause97_0" +" temp98_4)))))))" +" fold-var_314))))" +"(values fold-var_315)))))" +"(if(not #f)" +"(for-loop_31 fold-var_313 rest_199 rest_200 rest_201)" +" fold-var_313)))" +" fold-var_197)))))" +" for-loop_31)" +" null" +" lst_111" +" lst_204" +" lst_112))))))" +"(if(expand-context-to-parsed? ctx_83)" +"(parsed-case-lambda6.1 rebuild-s_5 clauses_1)" +"(let-values(((rebuild-s99_0) rebuild-s_5)((temp100_2)(list* case-lambda78_0 clauses_1)))" +"(rebuild5.1 #t rebuild-s99_0 temp100_2))))))))))))" +"(define-values" +"(parse-and-flatten-formals)" +"(lambda(all-formals_0 sc_38 s_529)" +"(begin" +"((letrec-values(((loop_121)" +"(lambda(formals_9)" +"(begin" +" 'loop" +"(if(identifier? formals_9)" +"(let-values()(list(add-scope formals_9 sc_38)))" +"(if(syntax?$1 formals_9)" +"(let-values()" +"(let-values(((p_86)(syntax-e$1 formals_9)))" +"(if(pair? p_86)" +"(let-values()(loop_121 p_86))" +"(if(null? p_86)" +"(let-values() null)" +" (let-values () (raise-syntax-error$1 #f \"not an identifier\" s_529 p_86))))))" +"(if(pair? formals_9)" +"(let-values()" +"(begin" +"(if(identifier?(car formals_9))" +"(void)" +"(let-values()" +" (raise-syntax-error$1 #f \"not an identifier\" s_529 (car formals_9))))" +"(cons" +"(if sc_38(add-scope(car formals_9) sc_38)(car formals_9))" +"(loop_121(cdr formals_9)))))" +"(if(null? formals_9)" +"(let-values() null)" +"(let-values()" +" (raise-syntax-error$1 \"bad argument sequence\" s_529 all-formals_0))))))))))" +" loop_121)" +" all-formals_0))))" +"(define-values" +"(unflatten-like-formals)" +"(lambda(keys_8 formals_10)" +"(begin" +"((letrec-values(((loop_122)" +"(lambda(keys_9 formals_11)" +"(begin" +" 'loop" +"(if(null? formals_11)" +"(let-values() null)" +"(if(pair? formals_11)" +"(let-values()(cons(car keys_9)(loop_122(cdr keys_9)(cdr formals_11))))" +"(if(syntax?$1 formals_11)" +"(let-values()(loop_122 keys_9(syntax-e$1 formals_11)))" +"(let-values()(car keys_9)))))))))" +" loop_122)" +" keys_8" +" formals_10))))" +"(define-values" +"(make-let-values-form11.1)" +"(lambda(log-tag1_0 rec?3_0 renames-log-tag5_0 split-by-reference?4_0 syntaxes?2_0)" +"(begin" +" 'make-let-values-form11" +"(let-values(((log-tag_0) log-tag1_0))" +"(let-values(((syntaxes?_0) syntaxes?2_0))" +"(let-values(((rec?_1) rec?3_0))" +"(let-values(((split-by-reference?_0) split-by-reference?4_0))" +"(let-values(((renames-log-tag_0) renames-log-tag5_0))" +"(let-values()" +"(lambda(s_105 ctx_84)" +"(let-values((()" +"(begin" +"(let-values(((obs_53)(expand-context-observer ctx_84)))" +"(if obs_53" +"(let-values()(let-values()(call-expand-observe obs_53 log-tag_0)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_8)(syntax-disarm$1 s_105)))" +"(let-values(((ok?_41" +" letrec-syntaxes+values101_0" +" id:trans102_0" +" trans-rhs103_0" +" id:val104_0" +" val-rhs105_0" +" body106_0)" +"(let-values(((s_128) disarmed-s_8))" +"(if(if syntaxes?_0 #t #f)" +"(let-values(((orig-s_44) s_128))" +"(let-values(((letrec-syntaxes+values101_1" +" id:trans102_1" +" trans-rhs103_1" +" id:val104_1" +" val-rhs105_1" +" body106_1)" +"(let-values(((s_530)" +"(if(syntax?$1 s_128)" +"(syntax-e$1 s_128)" +" s_128)))" +"(if(pair? s_530)" +"(let-values(((letrec-syntaxes+values107_0)" +"(let-values(((s_531)(car s_530))) s_531))" +"((id:trans108_0" +" trans-rhs109_0" +" id:val110_0" +" val-rhs111_0" +" body112_0)" +"(let-values(((s_230)(cdr s_530)))" +"(let-values(((s_231)" +"(if(syntax?$1 s_230)" +"(syntax-e$1 s_230)" +" s_230)))" +"(if(pair? s_231)" +"(let-values(((id:trans113_0" +" trans-rhs114_0)" +"(let-values(((s_234)" +"(car" +" s_231)))" +"(let-values(((s_235)" +"(if(syntax?$1" +" s_234)" +"(syntax-e$1" +" s_234)" +" s_234)))" +"(let-values(((flat-s_33)" +"(to-syntax-list.1" +" s_235)))" +"(if(not" +" flat-s_33)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(let-values()" +"(let-values(((id:trans_0" +" trans-rhs_0)" +"(let-values(((lst_338)" +" flat-s_33))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_338)))" +"((letrec-values(((for-loop_291)" +"(lambda(id:trans_1" +" trans-rhs_1" +" lst_339)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_339)" +"(let-values(((s_334)" +"(unsafe-car" +" lst_339))" +"((rest_202)" +"(unsafe-cdr" +" lst_339)))" +"(let-values(((id:trans_2" +" trans-rhs_2)" +"(let-values(((id:trans_3)" +" id:trans_1)" +"((trans-rhs_3)" +" trans-rhs_1))" +"(let-values(((id:trans_4" +" trans-rhs_4)" +"(let-values()" +"(let-values(((id:trans144_0" +" trans-rhs145_0)" +"(let-values()" +"(let-values(((s_532)" +"(if(syntax?$1" +" s_334)" +"(syntax-e$1" +" s_334)" +" s_334)))" +"(if(pair?" +" s_532)" +"(let-values(((id:trans118_0)" +"(let-values(((s_340)" +"(car" +" s_532)))" +"(let-values(((s_341)" +"(if(syntax?$1" +" s_340)" +"(syntax-e$1" +" s_340)" +" s_340)))" +"(let-values(((flat-s_34)" +"(to-syntax-list.1" +" s_341)))" +"(if(not" +" flat-s_34)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(let-values()" +"(let-values(((id:trans_5)" +"(let-values(((lst_340)" +" flat-s_34))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_340)))" +"((letrec-values(((for-loop_292)" +"(lambda(id:trans_6" +" lst_216)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_216)" +"(let-values(((s_533)" +"(unsafe-car" +" lst_216))" +"((rest_203)" +"(unsafe-cdr" +" lst_216)))" +"(let-values(((id:trans_7)" +"(let-values(((id:trans_8)" +" id:trans_6))" +"(let-values(((id:trans_9)" +"(let-values()" +"(let-values(((id:trans146_0)" +"(let-values()" +"(if(let-values(((or-part_341)" +"(if(syntax?$1" +" s_533)" +"(symbol?" +"(syntax-e$1" +" s_533))" +" #f)))" +"(if or-part_341" +" or-part_341" +"(symbol?" +" s_533)))" +" s_533" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_44" +" s_533)))))" +"(cons" +" id:trans146_0" +" id:trans_8)))))" +"(values" +" id:trans_9)))))" +"(if(not" +" #f)" +"(for-loop_292" +" id:trans_7" +" rest_203)" +" id:trans_7)))" +" id:trans_6)))))" +" for-loop_292)" +" null" +" lst_340)))))" +"(reverse$1" +" id:trans_5))))))))" +"((trans-rhs119_0)" +"(let-values(((s_242)" +"(cdr" +" s_532)))" +"(let-values(((s_534)" +"(if(syntax?$1" +" s_242)" +"(syntax-e$1" +" s_242)" +" s_242)))" +"(if(pair?" +" s_534)" +"(let-values(((trans-rhs120_0)" +"(let-values(((s_243)" +"(car" +" s_534)))" +" s_243))" +"(()" +"(let-values(((s_244)" +"(cdr" +" s_534)))" +"(let-values(((s_245)" +"(if(syntax?$1" +" s_244)" +"(syntax-e$1" +" s_244)" +" s_244)))" +"(if(null?" +" s_245)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" trans-rhs120_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" id:trans118_0" +" trans-rhs119_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +"(cons" +" id:trans144_0" +" id:trans_3)" +"(cons" +" trans-rhs145_0" +" trans-rhs_3))))))" +"(values" +" id:trans_4" +" trans-rhs_4)))))" +"(if(not" +" #f)" +"(for-loop_291" +" id:trans_2" +" trans-rhs_2" +" rest_202)" +"(values" +" id:trans_2" +" trans-rhs_2))))" +"(values" +" id:trans_1" +" trans-rhs_1))))))" +" for-loop_291)" +" null" +" null" +" lst_338)))))" +"(values" +"(reverse$1" +" id:trans_0)" +"(reverse$1" +" trans-rhs_0)))))))))" +"((id:val115_0" +" val-rhs116_0" +" body117_0)" +"(let-values(((s_535)" +"(cdr" +" s_231)))" +"(let-values(((s_347)" +"(if(syntax?$1" +" s_535)" +"(syntax-e$1" +" s_535)" +" s_535)))" +"(if(pair? s_347)" +"(let-values(((id:val121_0" +" val-rhs122_0)" +"(let-values(((s_536)" +"(car" +" s_347)))" +"(let-values(((s_246)" +"(if(syntax?$1" +" s_536)" +"(syntax-e$1" +" s_536)" +" s_536)))" +"(let-values(((flat-s_35)" +"(to-syntax-list.1" +" s_246)))" +"(if(not" +" flat-s_35)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(let-values()" +"(let-values(((id:val_0" +" val-rhs_1)" +"(let-values(((lst_341)" +" flat-s_35))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_341)))" +"((letrec-values(((for-loop_293)" +"(lambda(id:val_1" +" val-rhs_2" +" lst_342)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_342)" +"(let-values(((s_537)" +"(unsafe-car" +" lst_342))" +"((rest_204)" +"(unsafe-cdr" +" lst_342)))" +"(let-values(((id:val_2" +" val-rhs_3)" +"(let-values(((id:val_3)" +" id:val_1)" +"((val-rhs_4)" +" val-rhs_2))" +"(let-values(((id:val_4" +" val-rhs_5)" +"(let-values()" +"(let-values(((id:val147_0" +" val-rhs148_0)" +"(let-values()" +"(let-values(((s_538)" +"(if(syntax?$1" +" s_537)" +"(syntax-e$1" +" s_537)" +" s_537)))" +"(if(pair?" +" s_538)" +"(let-values(((id:val124_0)" +"(let-values(((s_473)" +"(car" +" s_538)))" +"(let-values(((s_539)" +"(if(syntax?$1" +" s_473)" +"(syntax-e$1" +" s_473)" +" s_473)))" +"(let-values(((flat-s_36)" +"(to-syntax-list.1" +" s_539)))" +"(if(not" +" flat-s_36)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(let-values()" +"(let-values(((id:val_5)" +"(let-values(((lst_343)" +" flat-s_36))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_343)))" +"((letrec-values(((for-loop_294)" +"(lambda(id:val_6" +" lst_123)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_123)" +"(let-values(((s_540)" +"(unsafe-car" +" lst_123))" +"((rest_62)" +"(unsafe-cdr" +" lst_123)))" +"(let-values(((id:val_7)" +"(let-values(((id:val_8)" +" id:val_6))" +"(let-values(((id:val_9)" +"(let-values()" +"(let-values(((id:val149_0)" +"(let-values()" +"(if(let-values(((or-part_379)" +"(if(syntax?$1" +" s_540)" +"(symbol?" +"(syntax-e$1" +" s_540))" +" #f)))" +"(if or-part_379" +" or-part_379" +"(symbol?" +" s_540)))" +" s_540" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_44" +" s_540)))))" +"(cons" +" id:val149_0" +" id:val_8)))))" +"(values" +" id:val_9)))))" +"(if(not" +" #f)" +"(for-loop_294" +" id:val_7" +" rest_62)" +" id:val_7)))" +" id:val_6)))))" +" for-loop_294)" +" null" +" lst_343)))))" +"(reverse$1" +" id:val_5))))))))" +"((val-rhs125_0)" +"(let-values(((s_353)" +"(cdr" +" s_538)))" +"(let-values(((s_248)" +"(if(syntax?$1" +" s_353)" +"(syntax-e$1" +" s_353)" +" s_353)))" +"(if(pair?" +" s_248)" +"(let-values(((val-rhs126_0)" +"(let-values(((s_355)" +"(car" +" s_248)))" +" s_355))" +"(()" +"(let-values(((s_541)" +"(cdr" +" s_248)))" +"(let-values(((s_356)" +"(if(syntax?$1" +" s_541)" +"(syntax-e$1" +" s_541)" +" s_541)))" +"(if(null?" +" s_356)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" val-rhs126_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" id:val124_0" +" val-rhs125_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +"(cons" +" id:val147_0" +" id:val_3)" +"(cons" +" val-rhs148_0" +" val-rhs_4))))))" +"(values" +" id:val_4" +" val-rhs_5)))))" +"(if(not" +" #f)" +"(for-loop_293" +" id:val_2" +" val-rhs_3" +" rest_204)" +"(values" +" id:val_2" +" val-rhs_3))))" +"(values" +" id:val_1" +" val-rhs_2))))))" +" for-loop_293)" +" null" +" null" +" lst_341)))))" +"(values" +"(reverse$1" +" id:val_0)" +"(reverse$1" +" val-rhs_1)))))))))" +"((body123_0)" +"(let-values(((s_249)" +"(cdr" +" s_347)))" +"(let-values(((s_250)" +"(if(syntax?$1" +" s_249)" +"(syntax-e$1" +" s_249)" +" s_249)))" +"(let-values(((flat-s_37)" +"(to-syntax-list.1" +" s_250)))" +"(if(not" +" flat-s_37)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(if(null?" +" flat-s_37)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))" +"(let-values()" +" flat-s_37))))))))" +"(values" +" id:val121_0" +" val-rhs122_0" +" body123_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" id:trans113_0" +" trans-rhs114_0" +" id:val115_0" +" val-rhs116_0" +" body117_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_44))))))" +"(values" +" letrec-syntaxes+values107_0" +" id:trans108_0" +" trans-rhs109_0" +" id:val110_0" +" val-rhs111_0" +" body112_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_44)))))" +"(values" +" #t" +" letrec-syntaxes+values101_1" +" id:trans102_1" +" trans-rhs103_1" +" id:val104_1" +" val-rhs105_1" +" body106_1)))" +"(values #f #f #f #f #f #f #f)))))" +"(let-values(((ok?_42 let-values127_0 id:val128_0 val-rhs129_0 body130_0)" +"(let-values(((s_357) disarmed-s_8))" +"(if(if(not syntaxes?_0) #t #f)" +"(let-values(((orig-s_45) s_357))" +"(let-values(((let-values127_1 id:val128_1 val-rhs129_1 body130_1)" +"(let-values(((s_254)" +"(if(syntax?$1 s_357)" +"(syntax-e$1 s_357)" +" s_357)))" +"(if(pair? s_254)" +"(let-values(((let-values131_0)" +"(let-values(((s_257)(car s_254)))" +" s_257))" +"((id:val132_0 val-rhs133_0 body134_0)" +"(let-values(((s_542)(cdr s_254)))" +"(let-values(((s_543)" +"(if(syntax?$1 s_542)" +"(syntax-e$1 s_542)" +" s_542)))" +"(if(pair? s_543)" +"(let-values(((id:val135_0" +" val-rhs136_0)" +"(let-values(((s_544)" +"(car" +" s_543)))" +"(let-values(((s_258)" +"(if(syntax?$1" +" s_544)" +"(syntax-e$1" +" s_544)" +" s_544)))" +"(let-values(((flat-s_38)" +"(to-syntax-list.1" +" s_258)))" +"(if(not" +" flat-s_38)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:val_10" +" val-rhs_6)" +"(let-values(((lst_305)" +" flat-s_38))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_305)))" +"((letrec-values(((for-loop_295)" +"(lambda(id:val_11" +" val-rhs_7" +" lst_344)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_344)" +"(let-values(((s_545)" +"(unsafe-car" +" lst_344))" +"((rest_205)" +"(unsafe-cdr" +" lst_344)))" +"(let-values(((id:val_12" +" val-rhs_8)" +"(let-values(((id:val_13)" +" id:val_11)" +"((val-rhs_9)" +" val-rhs_7))" +"(let-values(((id:val_14" +" val-rhs_10)" +"(let-values()" +"(let-values(((id:val150_0" +" val-rhs151_0)" +"(let-values()" +"(let-values(((s_372)" +"(if(syntax?$1" +" s_545)" +"(syntax-e$1" +" s_545)" +" s_545)))" +"(if(pair?" +" s_372)" +"(let-values(((id:val138_0)" +"(let-values(((s_546)" +"(car" +" s_372)))" +"(let-values(((s_547)" +"(if(syntax?$1" +" s_546)" +"(syntax-e$1" +" s_546)" +" s_546)))" +"(let-values(((flat-s_39)" +"(to-syntax-list.1" +" s_547)))" +"(if(not" +" flat-s_39)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:val_15)" +"(let-values(((lst_345)" +" flat-s_39))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_345)))" +"((letrec-values(((for-loop_296)" +"(lambda(id:val_16" +" lst_346)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_346)" +"(let-values(((s_548)" +"(unsafe-car" +" lst_346))" +"((rest_206)" +"(unsafe-cdr" +" lst_346)))" +"(let-values(((id:val_17)" +"(let-values(((id:val_18)" +" id:val_16))" +"(let-values(((id:val_19)" +"(let-values()" +"(let-values(((id:val152_0)" +"(let-values()" +"(if(let-values(((or-part_380)" +"(if(syntax?$1" +" s_548)" +"(symbol?" +"(syntax-e$1" +" s_548))" +" #f)))" +"(if or-part_380" +" or-part_380" +"(symbol?" +" s_548)))" +" s_548" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_45" +" s_548)))))" +"(cons" +" id:val152_0" +" id:val_18)))))" +"(values" +" id:val_19)))))" +"(if(not" +" #f)" +"(for-loop_296" +" id:val_17" +" rest_206)" +" id:val_17)))" +" id:val_16)))))" +" for-loop_296)" +" null" +" lst_345)))))" +"(reverse$1" +" id:val_15))))))))" +"((val-rhs139_0)" +"(let-values(((s_380)" +"(cdr" +" s_372)))" +"(let-values(((s_260)" +"(if(syntax?$1" +" s_380)" +"(syntax-e$1" +" s_380)" +" s_380)))" +"(if(pair?" +" s_260)" +"(let-values(((val-rhs140_0)" +"(let-values(((s_549)" +"(car" +" s_260)))" +" s_549))" +"(()" +"(let-values(((s_550)" +"(cdr" +" s_260)))" +"(let-values(((s_551)" +"(if(syntax?$1" +" s_550)" +"(syntax-e$1" +" s_550)" +" s_550)))" +"(if(null?" +" s_551)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" val-rhs140_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" id:val138_0" +" val-rhs139_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +"(cons" +" id:val150_0" +" id:val_13)" +"(cons" +" val-rhs151_0" +" val-rhs_9))))))" +"(values" +" id:val_14" +" val-rhs_10)))))" +"(if(not" +" #f)" +"(for-loop_295" +" id:val_12" +" val-rhs_8" +" rest_205)" +"(values" +" id:val_12" +" val-rhs_8))))" +"(values" +" id:val_11" +" val-rhs_7))))))" +" for-loop_295)" +" null" +" null" +" lst_305)))))" +"(values" +"(reverse$1" +" id:val_10)" +"(reverse$1" +" val-rhs_6)))))))))" +"((body137_0)" +"(let-values(((s_261)" +"(cdr" +" s_543)))" +"(let-values(((s_262)" +"(if(syntax?$1" +" s_261)" +"(syntax-e$1" +" s_261)" +" s_261)))" +"(let-values(((flat-s_40)" +"(to-syntax-list.1" +" s_262)))" +"(if(not" +" flat-s_40)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(if(null?" +" flat-s_40)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +" flat-s_40))))))))" +"(values" +" id:val135_0" +" val-rhs136_0" +" body137_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" let-values131_0" +" id:val132_0" +" val-rhs133_0" +" body134_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_45)))))" +"(values #t let-values127_1 id:val128_1 val-rhs129_1 body130_1)))" +"(values #f #f #f #f #f)))))" +"(let-values(((sc_39)(new-scope 'local)))" +"(let-values(((phase_83)(expand-context-phase ctx_84)))" +"(let-values(((frame-id_15)(if syntaxes?_0(make-reference-record) #f)))" +"(let-values(((trans-idss_2)" +"(reverse$1" +"(let-values(((lst_347)(if syntaxes?_0 id:trans102_0 null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_347)))" +"((letrec-values(((for-loop_297)" +"(lambda(fold-var_316 lst_348)" +"(begin" +" 'for-loop" +"(if(pair? lst_348)" +"(let-values(((ids_36)" +"(unsafe-car lst_348))" +"((rest_207)" +"(unsafe-cdr lst_348)))" +"(let-values(((fold-var_113)" +"(let-values(((fold-var_114)" +" fold-var_316))" +"(let-values(((fold-var_115)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_349)" +" ids_36))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_349)))" +"((letrec-values(((for-loop_298)" +"(lambda(fold-var_317" +" lst_350)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_350)" +"(let-values(((id_116)" +"(unsafe-car" +" lst_350))" +"((rest_208)" +"(unsafe-cdr" +" lst_350)))" +"(let-values(((fold-var_318)" +"(let-values(((fold-var_319)" +" fold-var_317))" +"(let-values(((fold-var_320)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_116" +" sc_39))" +" fold-var_319))))" +"(values" +" fold-var_320)))))" +"(if(not" +" #f)" +"(for-loop_298" +" fold-var_318" +" rest_208)" +" fold-var_318)))" +" fold-var_317)))))" +" for-loop_298)" +" null" +" lst_349)))))" +" fold-var_114))))" +"(values" +" fold-var_115)))))" +"(if(not #f)" +"(for-loop_297 fold-var_113 rest_207)" +" fold-var_113)))" +" fold-var_316)))))" +" for-loop_297)" +" null" +" lst_347))))))" +"(let-values(((val-idss_3)" +"(reverse$1" +"(let-values(((lst_351)(if syntaxes?_0 id:val104_0 id:val128_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_351)))" +"((letrec-values(((for-loop_299)" +"(lambda(fold-var_321 lst_352)" +"(begin" +" 'for-loop" +"(if(pair? lst_352)" +"(let-values(((ids_37)" +"(unsafe-car lst_352))" +"((rest_209)" +"(unsafe-cdr lst_352)))" +"(let-values(((fold-var_322)" +"(let-values(((fold-var_323)" +" fold-var_321))" +"(let-values(((fold-var_324)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_353)" +" ids_37))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_353)))" +"((letrec-values(((for-loop_300)" +"(lambda(fold-var_325" +" lst_354)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_354)" +"(let-values(((id_117)" +"(unsafe-car" +" lst_354))" +"((rest_210)" +"(unsafe-cdr" +" lst_354)))" +"(let-values(((fold-var_326)" +"(let-values(((fold-var_327)" +" fold-var_325))" +"(let-values(((fold-var_328)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_117" +" sc_39))" +" fold-var_327))))" +"(values" +" fold-var_328)))))" +"(if(not" +" #f)" +"(for-loop_300" +" fold-var_326" +" rest_210)" +" fold-var_326)))" +" fold-var_325)))))" +" for-loop_300)" +" null" +" lst_353)))))" +" fold-var_323))))" +"(values" +" fold-var_324)))))" +"(if(not #f)" +"(for-loop_299" +" fold-var_322" +" rest_209)" +" fold-var_322)))" +" fold-var_321)))))" +" for-loop_299)" +" null" +" lst_351))))))" +"(let-values(((val-rhss_3)" +"(if rec?_1" +"(reverse$1" +"(let-values(((lst_355)" +"(if syntaxes?_0 val-rhs105_0 val-rhs129_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_355)))" +"((letrec-values(((for-loop_301)" +"(lambda(fold-var_329 lst_356)" +"(begin" +" 'for-loop" +"(if(pair? lst_356)" +"(let-values(((rhs_20)" +"(unsafe-car lst_356))" +"((rest_211)" +"(unsafe-cdr lst_356)))" +"(let-values(((fold-var_330)" +"(let-values(((fold-var_331)" +" fold-var_329))" +"(let-values(((fold-var_332)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" rhs_20" +" sc_39))" +" fold-var_331))))" +"(values" +" fold-var_332)))))" +"(if(not #f)" +"(for-loop_301" +" fold-var_330" +" rest_211)" +" fold-var_330)))" +" fold-var_329)))))" +" for-loop_301)" +" null" +" lst_355))))" +"(if syntaxes?_0 val-rhs105_0 val-rhs129_0))))" +"(let-values(((val-clauses_0)" +"(if syntaxes?_0" +"(let-values()" +"(let-values(((ok?_43 _153_0 _154_0 clause155_0 _156_0)" +"(let-values(((s_142) disarmed-s_8))" +"(let-values(((orig-s_46) s_142))" +"(let-values(((_153_1" +" _154_1" +" clause155_1" +" _156_1)" +"(let-values(((s_552)" +"(if(syntax?$1" +" s_142)" +"(syntax-e$1" +" s_142)" +" s_142)))" +"(if(pair? s_552)" +"(let-values(((_157_0)" +"(let-values(((s_553)" +"(car" +" s_552)))" +" s_553))" +"((_158_0" +" clause159_0" +" _160_0)" +"(let-values(((s_554)" +"(cdr" +" s_552)))" +"(let-values(((s_555)" +"(if(syntax?$1" +" s_554)" +"(syntax-e$1" +" s_554)" +" s_554)))" +"(if(pair?" +" s_555)" +"(let-values(((_161_0)" +"(let-values(((s_556)" +"(car" +" s_555)))" +" s_556))" +"((clause162_0" +" _163_0)" +"(let-values(((s_557)" +"(cdr" +" s_555)))" +"(let-values(((s_558)" +"(if(syntax?$1" +" s_557)" +"(syntax-e$1" +" s_557)" +" s_557)))" +"(if(pair?" +" s_558)" +"(let-values(((clause164_0)" +"(let-values(((s_559)" +"(car" +" s_558)))" +"(let-values(((s_560)" +"(if(syntax?$1" +" s_559)" +"(syntax-e$1" +" s_559)" +" s_559)))" +"(let-values(((flat-s_41)" +"(to-syntax-list.1" +" s_560)))" +"(if(not" +" flat-s_41)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))" +"(let-values()" +" flat-s_41))))))" +"((_165_0)" +"(let-values(((s_561)" +"(cdr" +" s_558)))" +" s_561)))" +"(values" +" clause164_0" +" _165_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +" _161_0" +" clause162_0" +" _163_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +" _157_0" +" _158_0" +" clause159_0" +" _160_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46)))))" +"(values" +" #t" +" _153_1" +" _154_1" +" clause155_1" +" _156_1))))))" +" clause155_0))" +"(let-values()" +"(let-values(((ok?_44 _166_0 clause167_0 _168_0)" +"(let-values(((s_145) disarmed-s_8))" +"(let-values(((orig-s_47) s_145))" +"(let-values(((_166_1 clause167_1 _168_1)" +"(let-values(((s_562)" +"(if(syntax?$1" +" s_145)" +"(syntax-e$1" +" s_145)" +" s_145)))" +"(if(pair? s_562)" +"(let-values(((_169_0)" +"(let-values(((s_563)" +"(car" +" s_562)))" +" s_563))" +"((clause170_0" +" _171_0)" +"(let-values(((s_564)" +"(cdr" +" s_562)))" +"(let-values(((s_565)" +"(if(syntax?$1" +" s_564)" +"(syntax-e$1" +" s_564)" +" s_564)))" +"(if(pair?" +" s_565)" +"(let-values(((clause172_0)" +"(let-values(((s_566)" +"(car" +" s_565)))" +"(let-values(((s_567)" +"(if(syntax?$1" +" s_566)" +"(syntax-e$1" +" s_566)" +" s_566)))" +"(let-values(((flat-s_42)" +"(to-syntax-list.1" +" s_567)))" +"(if(not" +" flat-s_42)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_47))" +"(let-values()" +" flat-s_42))))))" +"((_173_0)" +"(let-values(((s_568)" +"(cdr" +" s_565)))" +" s_568)))" +"(values" +" clause172_0" +" _173_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_47))))))" +"(values" +" _169_0" +" clause170_0" +" _171_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_47)))))" +"(values #t _166_1 clause167_1 _168_1))))))" +" clause167_0)))))" +"(let-values((()" +"(begin" +"(let-values(((temp141_3)(list trans-idss_2 val-idss_3))" +"((phase142_0) phase_83)" +"((s143_0) s_105))" +"(check-no-duplicate-ids7.1" +" unsafe-undefined" +" temp141_3" +" phase142_0" +" s143_0" +" unsafe-undefined))" +"(values))))" +"(let-values(((counter_8)(root-expand-context-counter ctx_84)))" +"(let-values(((trans-keyss_0)" +"(reverse$1" +"(let-values(((lst_357) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_357)))" +"((letrec-values(((for-loop_302)" +"(lambda(fold-var_333 lst_358)" +"(begin" +" 'for-loop" +"(if(pair? lst_358)" +"(let-values(((ids_38)" +"(unsafe-car" +" lst_358))" +"((rest_212)" +"(unsafe-cdr" +" lst_358)))" +"(let-values(((fold-var_334)" +"(let-values(((fold-var_335)" +" fold-var_333))" +"(let-values(((fold-var_336)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_359)" +" ids_38))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_359)))" +"((letrec-values(((for-loop_303)" +"(lambda(fold-var_337" +" lst_360)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_360)" +"(let-values(((id_118)" +"(unsafe-car" +" lst_360))" +"((rest_213)" +"(unsafe-cdr" +" lst_360)))" +"(let-values(((fold-var_338)" +"(let-values(((fold-var_339)" +" fold-var_337))" +"(let-values(((fold-var_340)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id174_0)" +" id_118)" +"((phase175_0)" +" phase_83)" +"((counter176_0)" +" counter_8)" +"((frame-id177_0)" +" frame-id_15)" +"((s178_0)" +" s_105))" +"(add-local-binding!37.1" +" frame-id177_0" +" s178_0" +" id174_0" +" phase175_0" +" counter176_0)))" +" fold-var_339))))" +"(values" +" fold-var_340)))))" +"(if(not" +" #f)" +"(for-loop_303" +" fold-var_338" +" rest_213)" +" fold-var_338)))" +" fold-var_337)))))" +" for-loop_303)" +" null" +" lst_359)))))" +" fold-var_335))))" +"(values" +" fold-var_336)))))" +"(if(not #f)" +"(for-loop_302" +" fold-var_334" +" rest_212)" +" fold-var_334)))" +" fold-var_333)))))" +" for-loop_302)" +" null" +" lst_357))))))" +"(let-values(((val-keyss_2)" +"(reverse$1" +"(let-values(((lst_361) val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_361)))" +"((letrec-values(((for-loop_304)" +"(lambda(fold-var_341 lst_362)" +"(begin" +" 'for-loop" +"(if(pair? lst_362)" +"(let-values(((ids_39)" +"(unsafe-car" +" lst_362))" +"((rest_214)" +"(unsafe-cdr" +" lst_362)))" +"(let-values(((fold-var_342)" +"(let-values(((fold-var_343)" +" fold-var_341))" +"(let-values(((fold-var_118)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_131)" +" ids_39))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_131)))" +"((letrec-values(((for-loop_305)" +"(lambda(fold-var_344" +" lst_363)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_363)" +"(let-values(((id_119)" +"(unsafe-car" +" lst_363))" +"((rest_215)" +"(unsafe-cdr" +" lst_363)))" +"(let-values(((fold-var_345)" +"(let-values(((fold-var_346)" +" fold-var_344))" +"(let-values(((fold-var_347)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id179_0)" +" id_119)" +"((phase180_0)" +" phase_83)" +"((counter181_0)" +" counter_8)" +"((frame-id182_0)" +" frame-id_15)" +"((s183_0)" +" s_105))" +"(add-local-binding!37.1" +" frame-id182_0" +" s183_0" +" id179_0" +" phase180_0" +" counter181_0)))" +" fold-var_346))))" +"(values" +" fold-var_347)))))" +"(if(not" +" #f)" +"(for-loop_305" +" fold-var_345" +" rest_215)" +" fold-var_345)))" +" fold-var_344)))))" +" for-loop_305)" +" null" +" lst_131)))))" +" fold-var_343))))" +"(values" +" fold-var_118)))))" +"(if(not #f)" +"(for-loop_304" +" fold-var_342" +" rest_214)" +" fold-var_342)))" +" fold-var_341)))))" +" for-loop_304)" +" null" +" lst_361))))))" +"(let-values(((bodys_10)" +"(reverse$1" +"(let-values(((lst_364)" +"(if syntaxes?_0 body106_0 body130_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_364)))" +"((letrec-values(((for-loop_306)" +"(lambda(fold-var_348 lst_365)" +"(begin" +" 'for-loop" +"(if(pair? lst_365)" +"(let-values(((body_18)" +"(unsafe-car" +" lst_365))" +"((rest_216)" +"(unsafe-cdr" +" lst_365)))" +"(let-values(((fold-var_123)" +"(let-values(((fold-var_349)" +" fold-var_348))" +"(let-values(((fold-var_48)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_18" +" sc_39))" +" fold-var_349))))" +"(values" +" fold-var_48)))))" +"(if(not #f)" +"(for-loop_306" +" fold-var_123" +" rest_216)" +" fold-var_123)))" +" fold-var_348)))))" +" for-loop_306)" +" null" +" lst_364))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_91)" +"(expand-context-observer ctx_84)))" +"(if obs_91" +"(let-values()" +"(log-let-renames" +" obs_91" +" renames-log-tag_0" +" val-idss_3" +" val-rhss_3" +" bodys_10" +" trans-idss_2" +"(if syntaxes?_0 trans-rhs103_0 #f)" +" sc_39))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if syntaxes?_0" +"(let-values()" +"(begin" +"(let-values(((obs_92)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_92" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_92" +" 'prepare-env)))" +"(void)))" +"(prepare-next-phase-namespace ctx_84)))" +"(void))" +"(values))))" +"(let-values(((trans-valss_0)" +"(reverse$1" +"(let-values(((lst_63)" +"(if syntaxes?_0" +" trans-rhs103_0" +" '()))" +"((lst_366) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_63)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_366)))" +"((letrec-values(((for-loop_307)" +"(lambda(fold-var_350" +" lst_367" +" lst_368)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_367)" +"(pair? lst_368)" +" #f)" +"(let-values(((rhs_21)" +"(unsafe-car" +" lst_367))" +"((rest_217)" +"(unsafe-cdr" +" lst_367))" +"((ids_40)" +"(unsafe-car" +" lst_368))" +"((rest_218)" +"(unsafe-cdr" +" lst_368)))" +"(let-values(((fold-var_351)" +"(let-values(((fold-var_352)" +" fold-var_350))" +"(let-values(((fold-var_353)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_93)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_93" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_93" +" 'next)" +"(call-expand-observe" +" obs_93" +" 'enter-bind))))" +"(void)))" +"(values))))" +"(let-values(((trans-val_1)" +"(eval-for-syntaxes-binding" +" 'letrec-syntaxes+values" +"(add-scope" +" rhs_21" +" sc_39)" +" ids_40" +" ctx_84)))" +"(begin" +"(let-values(((obs_94)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_94" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_94" +" 'exit-bind)))" +"(void)))" +" trans-val_1))))" +" fold-var_352))))" +"(values" +" fold-var_353)))))" +"(if(not #f)" +"(for-loop_307" +" fold-var_351" +" rest_217" +" rest_218)" +" fold-var_351)))" +" fold-var_350)))))" +" for-loop_307)" +" null" +" lst_63" +" lst_366))))))" +"(let-values(((rec-val-env_0)" +"(let-values(((lst_369) val-keyss_2)" +"((lst_135) val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_369)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_135)))" +"((letrec-values(((for-loop_308)" +"(lambda(env_29" +" lst_370" +" lst_371)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_370)" +"(pair? lst_371)" +" #f)" +"(let-values(((keys_10)" +"(unsafe-car" +" lst_370))" +"((rest_219)" +"(unsafe-cdr" +" lst_370))" +"((ids_41)" +"(unsafe-car" +" lst_371))" +"((rest_220)" +"(unsafe-cdr" +" lst_371)))" +"(let-values(((env_30)" +"(let-values(((env_31)" +" env_29))" +"(let-values(((lst_372)" +" keys_10)" +"((lst_373)" +" ids_41))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_372)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_373)))" +"((letrec-values(((for-loop_309)" +"(lambda(env_32" +" lst_374" +" lst_375)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_374)" +"(pair?" +" lst_375)" +" #f)" +"(let-values(((key_91)" +"(unsafe-car" +" lst_374))" +"((rest_221)" +"(unsafe-cdr" +" lst_374))" +"((id_120)" +"(unsafe-car" +" lst_375))" +"((rest_222)" +"(unsafe-cdr" +" lst_375)))" +"(let-values(((env_33)" +"(let-values(((env_34)" +" env_32))" +"(let-values(((env_35)" +"(let-values()" +"(env-extend" +" env_34" +" key_91" +"(local-variable1.1" +" id_120)))))" +"(values" +" env_35)))))" +"(if(not" +" #f)" +"(for-loop_309" +" env_33" +" rest_221" +" rest_222)" +" env_33)))" +" env_32)))))" +" for-loop_309)" +" env_31" +" lst_372" +" lst_373))))))" +"(if(not #f)" +"(for-loop_308" +" env_30" +" rest_219" +" rest_220)" +" env_30)))" +" env_29)))))" +" for-loop_308)" +"(expand-context-env ctx_84)" +" lst_369" +" lst_135)))))" +"(let-values(((rec-env_0)" +"(let-values(((lst_376) trans-keyss_0)" +"((lst_377) trans-valss_0)" +"((lst_378) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_376)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_377)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_378)))" +"((letrec-values(((for-loop_310)" +"(lambda(env_36" +" lst_379" +" lst_380" +" lst_381)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_379)" +"(if(pair?" +" lst_380)" +"(pair?" +" lst_381)" +" #f)" +" #f)" +"(let-values(((keys_11)" +"(unsafe-car" +" lst_379))" +"((rest_223)" +"(unsafe-cdr" +" lst_379))" +"((vals_9)" +"(unsafe-car" +" lst_380))" +"((rest_224)" +"(unsafe-cdr" +" lst_380))" +"((ids_42)" +"(unsafe-car" +" lst_381))" +"((rest_225)" +"(unsafe-cdr" +" lst_381)))" +"(let-values(((env_37)" +"(let-values(((env_38)" +" env_36))" +"(let-values(((env_39)" +"(let-values()" +"(let-values(((lst_382)" +" keys_11)" +"((lst_383)" +" vals_9)" +"((lst_384)" +" ids_42))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_382)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_383)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_384)))" +"((letrec-values(((for-loop_311)" +"(lambda(env_40" +" lst_385" +" lst_386" +" lst_387)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_385)" +"(if(pair?" +" lst_386)" +"(pair?" +" lst_387)" +" #f)" +" #f)" +"(let-values(((key_92)" +"(unsafe-car" +" lst_385))" +"((rest_226)" +"(unsafe-cdr" +" lst_385))" +"((val_86)" +"(unsafe-car" +" lst_386))" +"((rest_227)" +"(unsafe-cdr" +" lst_386))" +"((id_121)" +"(unsafe-car" +" lst_387))" +"((rest_228)" +"(unsafe-cdr" +" lst_387)))" +"(let-values(((env_41)" +"(let-values(((env_42)" +" env_40))" +"(let-values(((env_43)" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_86" +" id_121" +" phase_83" +" ctx_84)" +"(env-extend" +" env_42" +" key_92" +" val_86)))))" +"(values" +" env_43)))))" +"(if(not" +" #f)" +"(for-loop_311" +" env_41" +" rest_226" +" rest_227" +" rest_228)" +" env_41)))" +" env_40)))))" +" for-loop_311)" +" env_38" +" lst_382" +" lst_383" +" lst_384))))))" +"(values" +" env_39)))))" +"(if(not #f)" +"(for-loop_310" +" env_37" +" rest_223" +" rest_224" +" rest_225)" +" env_37)))" +" env_36)))))" +" for-loop_310)" +" rec-val-env_0" +" lst_376" +" lst_377" +" lst_378)))))" +"(let-values(((expr-ctx_0)" +"(as-expression-context ctx_84)))" +"(let-values(((orig-rrs_0)" +"(expand-context-reference-records" +" expr-ctx_0)))" +"(let-values(((rec-ctx_0)" +"(let-values(((v_182) expr-ctx_0))" +"(let-values(((the-struct_97) v_182))" +"(if(expand-context/outer?" +" the-struct_97)" +"(let-values(((env184_0)" +" rec-env_0)" +"((scopes185_0)" +"(cons" +" sc_39" +"(expand-context-scopes" +" ctx_84)))" +"((reference-records186_0)" +"(if split-by-reference?_0" +"(cons" +" frame-id_15" +" orig-rrs_0)" +" orig-rrs_0))" +"((binding-layer187_0)" +"(increment-binding-layer" +"(cons" +" trans-idss_2" +" val-idss_3)" +" ctx_84" +" sc_39))" +"((inner188_0)" +"(root-expand-context/outer-inner" +" v_182)))" +"(expand-context/outer1.1" +" inner188_0" +"(root-expand-context/outer-post-expansion" +" the-struct_97)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_97)" +"(root-expand-context/outer-frame-id" +" the-struct_97)" +"(expand-context/outer-context" +" the-struct_97)" +" env184_0" +" scopes185_0" +"(expand-context/outer-def-ctx-scopes" +" the-struct_97)" +" binding-layer187_0" +" reference-records186_0" +"(expand-context/outer-only-immediate?" +" the-struct_97)" +"(expand-context/outer-need-eventually-defined" +" the-struct_97)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_97)" +"(expand-context/outer-current-use-scopes" +" the-struct_97)" +"(expand-context/outer-name" +" the-struct_97)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_97))))))" +"(let-values(((letrec-values-id_0)" +"(if(not" +"(expand-context-to-parsed?" +" ctx_84))" +"(if syntaxes?_0" +"(core-id 'letrec-values phase_83)" +" let-values127_0)" +" #f)))" +"(let-values(((rebuild-s_6)" +"(let-values(((ctx189_0) ctx_84)" +"((s190_1) s_105)" +"((temp191_1) #t))" +"(keep-as-needed119.1" +" #f" +" temp191_1" +" #f" +" ctx189_0" +" s190_1))))" +"(let-values(((val-name-idss_0)" +"(if(expand-context-to-parsed?" +" ctx_84)" +"(reverse$1" +"(let-values(((lst_254)" +" val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_254)))" +"((letrec-values(((for-loop_231)" +"(lambda(fold-var_354" +" lst_255)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_255)" +"(let-values(((val-ids_1)" +"(unsafe-car" +" lst_255))" +"((rest_139)" +"(unsafe-cdr" +" lst_255)))" +"(let-values(((fold-var_355)" +"(let-values(((fold-var_356)" +" fold-var_354))" +"(let-values(((fold-var_357)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_388)" +" val-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_388)))" +"((letrec-values(((for-loop_312)" +"(lambda(fold-var_358" +" lst_389)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_389)" +"(let-values(((val-id_0)" +"(unsafe-car" +" lst_389))" +"((rest_229)" +"(unsafe-cdr" +" lst_389)))" +"(let-values(((fold-var_359)" +"(let-values(((fold-var_132)" +" fold-var_358))" +"(let-values(((fold-var_360)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(syntax-e$1" +" val-id_0)" +" val-id_0" +" val-id_0))" +" fold-var_132))))" +"(values" +" fold-var_360)))))" +"(if(not" +" #f)" +"(for-loop_312" +" fold-var_359" +" rest_229)" +" fold-var_359)))" +" fold-var_358)))))" +" for-loop_312)" +" null" +" lst_388)))))" +" fold-var_356))))" +"(values" +" fold-var_357)))))" +"(if(not" +" #f)" +"(for-loop_231" +" fold-var_355" +" rest_139)" +" fold-var_355)))" +" fold-var_354)))))" +" for-loop_231)" +" null" +" lst_254))))" +" val-idss_3)))" +"(let-values((()" +"(begin" +"(if syntaxes?_0" +"(let-values()" +"(let-values(((obs_95)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_95" +"(let-values()" +"(log-letrec-values" +" obs_95" +" val-idss_3" +" val-rhss_3" +" bodys_10))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((get-body_1)" +"(lambda()" +"(begin" +" 'get-body" +"(let-values((()" +"(begin" +"(let-values(((obs_96)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_96" +"(let-values()" +"(if(not" +"(if syntaxes?_0" +"(null?" +" val-idss_3)" +" #f))" +"(let-values()" +"(call-expand-observe" +" obs_96" +" 'next-group))" +"(void)))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_5)" +"(let-values(((v_265)" +" rec-ctx_0))" +"(let-values(((the-struct_98)" +" v_265))" +"(if(expand-context/outer?" +" the-struct_98)" +"(let-values(((reference-records195_0)" +" orig-rrs_0)" +"((inner196_0)" +"(root-expand-context/outer-inner" +" v_265)))" +"(expand-context/outer1.1" +" inner196_0" +"(root-expand-context/outer-post-expansion" +" the-struct_98)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_98)" +"(root-expand-context/outer-frame-id" +" the-struct_98)" +"(expand-context/outer-context" +" the-struct_98)" +"(expand-context/outer-env" +" the-struct_98)" +"(expand-context/outer-scopes" +" the-struct_98)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_98)" +"(expand-context/outer-binding-layer" +" the-struct_98)" +" reference-records195_0" +"(expand-context/outer-only-immediate?" +" the-struct_98)" +"(expand-context/outer-need-eventually-defined" +" the-struct_98)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_98)" +"(expand-context/outer-current-use-scopes" +" the-struct_98)" +"(expand-context/outer-name" +" the-struct_98)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_98))))))" +"(let-values(((bodys192_0)" +" bodys_10)" +"((temp193_0)" +"(let-values(((body-ctx197_0)" +" body-ctx_5)" +"((ctx198_0)" +" ctx_84))" +"(as-tail-context22.1" +" ctx198_0" +" body-ctx197_0)))" +"((rebuild-s194_0)" +" rebuild-s_6))" +"(expand-body7.1" +" rebuild-s194_0" +" #f" +" bodys192_0" +" temp193_0))))))))" +"(let-values(((result-s_12)" +"(if(not" +" split-by-reference?_0)" +"(let-values()" +"(let-values(((clauses_2)" +"(reverse$1" +"(let-values(((lst_150)" +" val-name-idss_0)" +"((lst_390)" +" val-keyss_2)" +"((lst_151)" +" val-rhss_3)" +"((lst_391)" +" val-clauses_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_150)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_390)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_151)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_391)))" +"((letrec-values(((for-loop_313)" +"(lambda(fold-var_361" +" lst_392" +" lst_393" +" lst_394" +" lst_395)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_392)" +"(if(pair?" +" lst_393)" +"(if(pair?" +" lst_394)" +"(pair?" +" lst_395)" +" #f)" +" #f)" +" #f)" +"(let-values(((ids_43)" +"(unsafe-car" +" lst_392))" +"((rest_230)" +"(unsafe-cdr" +" lst_392))" +"((keys_12)" +"(unsafe-car" +" lst_393))" +"((rest_231)" +"(unsafe-cdr" +" lst_393))" +"((rhs_22)" +"(unsafe-car" +" lst_394))" +"((rest_232)" +"(unsafe-cdr" +" lst_394))" +"((clause_4)" +"(unsafe-car" +" lst_395))" +"((rest_233)" +"(unsafe-cdr" +" lst_395)))" +"(let-values(((fold-var_51)" +"(let-values(((fold-var_362)" +" fold-var_361))" +"(let-values(((fold-var_363)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_97)" +"(expand-context-observer" +" ctx_84)))" +"(if obs_97" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_97" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-rhs_4)" +"(let-values(((rhs199_0)" +" rhs_22)" +"((temp200_0)" +"(if rec?_1" +"(as-named-context" +" rec-ctx_0" +" ids_43)" +"(as-named-context" +" expr-ctx_0" +" ids_43))))" +"(expand9.1" +" #f" +" #f" +" #f" +" rhs199_0" +" temp200_0))))" +"(if(expand-context-to-parsed?" +" ctx_84)" +"(list" +" keys_12" +" exp-rhs_4)" +"(datum->syntax$1" +" #f" +"(list" +" ids_43" +" exp-rhs_4)" +" clause_4" +" clause_4)))))" +" fold-var_362))))" +"(values" +" fold-var_363)))))" +"(if(not" +" #f)" +"(for-loop_313" +" fold-var_51" +" rest_230" +" rest_231" +" rest_232" +" rest_233)" +" fold-var_51)))" +" fold-var_361)))))" +" for-loop_313)" +" null" +" lst_150" +" lst_390" +" lst_151" +" lst_391))))))" +"(let-values(((exp-body_4)" +"(get-body_1)))" +"(begin" +"(if frame-id_15" +"(let-values()" +"(reference-record-clear!" +" frame-id_15))" +"(void))" +"(if(expand-context-to-parsed?" +" ctx_84)" +"(if rec?_1" +"(parsed-letrec-values18.1" +" rebuild-s_6" +" val-name-idss_0" +" clauses_2" +" exp-body_4)" +"(parsed-let-values17.1" +" rebuild-s_6" +" val-name-idss_0" +" clauses_2" +" exp-body_4))" +"(let-values(((rebuild-s201_0)" +" rebuild-s_6)" +"((temp202_1)" +"(list*" +" letrec-values-id_0" +" clauses_2" +" exp-body_4)))" +"(rebuild5.1" +" #t" +" rebuild-s201_0" +" temp202_1)))))))" +"(let-values()" +"(let-values(((val-idss203_0)" +" val-idss_3)" +"((val-keyss204_0)" +" val-keyss_2)" +"((val-rhss205_0)" +" val-rhss_3)" +"((val-clauses206_0)" +" val-clauses_0)" +"((temp207_0)" +" #t)" +"((frame-id208_0)" +" frame-id_15)" +"((rec-ctx209_0)" +" rec-ctx_0)" +"((rebuild-s210_0)" +" rebuild-s_6)" +"((syntaxes?211_0)" +" syntaxes?_0)" +"((get-body212_0)" +" get-body_1)" +"((temp213_2)" +" #t))" +"(expand-and-split-bindings-by-reference48.1" +" rec-ctx209_0" +" frame-id208_0" +" get-body212_0" +" syntaxes?211_0" +" rebuild-s210_0" +" temp207_0" +" temp213_2" +" val-idss203_0" +" val-keyss204_0" +" val-rhss205_0" +" val-clauses206_0))))))" +"(if(expand-context-to-parsed? ctx_84)" +" result-s_12" +"(attach-disappeared-transformer-bindings" +" result-s_12" +" trans-idss_2))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(log-let-renames)" +"(lambda(obs_98 renames-log-tag_1 val-idss_4 val-rhss_4 bodys_11 trans-idss_3 trans-rhss_0 sc_40)" +"(begin" +"(let-values(((vals+body_0)" +"(cons" +"(reverse$1" +"(let-values(((lst_396) val-idss_4)((lst_397) val-rhss_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_396)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_397)))" +"((letrec-values(((for-loop_314)" +"(lambda(fold-var_364 lst_398 lst_399)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_398)(pair? lst_399) #f)" +"(let-values(((val-ids_2)(unsafe-car lst_398))" +"((rest_234)(unsafe-cdr lst_398))" +"((val-rhs_11)(unsafe-car lst_399))" +"((rest_235)(unsafe-cdr lst_399)))" +"(let-values(((fold-var_365)" +"(let-values(((fold-var_366) fold-var_364))" +"(let-values(((fold-var_367)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list val-ids_2 val-rhs_11)))" +" fold-var_366))))" +"(values fold-var_367)))))" +"(if(not #f)" +"(for-loop_314 fold-var_365 rest_234 rest_235)" +" fold-var_365)))" +" fold-var_364)))))" +" for-loop_314)" +" null" +" lst_396" +" lst_397))))" +"(datum->syntax$1 #f bodys_11))))" +"(call-expand-observe" +" obs_98" +" renames-log-tag_1" +"(if(not trans-rhss_0)" +" vals+body_0" +"(cons" +"(reverse$1" +"(let-values(((lst_400) trans-idss_3)((lst_401) trans-rhss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_400)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_401)))" +"((letrec-values(((for-loop_315)" +"(lambda(fold-var_368 lst_402 lst_403)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_402)(pair? lst_403) #f)" +"(let-values(((trans-ids_0)(unsafe-car lst_402))" +"((rest_236)(unsafe-cdr lst_402))" +"((trans-rhs_5)(unsafe-car lst_403))" +"((rest_237)(unsafe-cdr lst_403)))" +"(let-values(((fold-var_369)" +"(let-values(((fold-var_370) fold-var_368))" +"(let-values(((fold-var_371)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list" +" trans-ids_0" +"(add-scope trans-rhs_5 sc_40))))" +" fold-var_370))))" +"(values fold-var_371)))))" +"(if(not #f)(for-loop_315 fold-var_369 rest_236 rest_237) fold-var_369)))" +" fold-var_368)))))" +" for-loop_315)" +" null" +" lst_400" +" lst_401))))" +" vals+body_0)))))))" +"(define-values" +"(log-letrec-values)" +"(lambda(obs_99 val-idss_5 val-rhss_5 bodys_12)" +"(begin" +"(begin" +"(call-expand-observe obs_99 'next-group)" +"(if(null? val-idss_5)" +"(void)" +"(let-values()" +"(begin" +"(call-expand-observe obs_99 'prim-letrec-values)" +"(log-let-renames obs_99 'let-renames val-idss_5 val-rhss_5 bodys_12 #f #f #f))))))))" +"(void" +"(add-core-form!*" +" 'let-values" +"(let-values(((temp214_2) 'prim-let-values))(make-let-values-form11.1 temp214_2 #f 'let-renames #f #f))))" +"(void" +"(add-core-form!*" +" 'letrec-values" +"(let-values(((temp215_0) #t)((temp216_1) 'prim-letrec-values))" +"(make-let-values-form11.1 temp216_1 temp215_0 'let-renames #f #f))))" +"(void" +"(add-core-form!*" +" 'letrec-syntaxes+values" +"(let-values(((temp217_3) #t)" +"((temp218_1) #t)" +"((temp219_0) #t)" +"((temp220_0) 'prim-letrec-syntaxes+values)" +"((temp221_3) 'letrec-syntaxes-renames))" +"(make-let-values-form11.1 temp220_0 temp218_1 temp221_3 temp219_0 temp217_3))))" +"(void" +"(add-core-form!*" +" '#%stratified-body" +"(lambda(s_569 ctx_85)" +"(let-values((()" +"(begin" +"(let-values(((obs_100)(expand-context-observer ctx_85)))" +"(if obs_100" +"(let-values()(let-values()(call-expand-observe obs_100 'prim-#%stratified)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_9)(syntax-disarm$1 s_569)))" +"(let-values(((ok?_45 #%stratified-body222_0 body223_0)" +"(let-values(((s_570) disarmed-s_9))" +"(let-values(((orig-s_48) s_570))" +"(let-values(((#%stratified-body222_1 body223_1)" +"(let-values(((s_571)(if(syntax?$1 s_570)(syntax-e$1 s_570) s_570)))" +"(if(pair? s_571)" +"(let-values(((#%stratified-body224_0)" +"(let-values(((s_572)(car s_571))) s_572))" +"((body225_0)" +"(let-values(((s_573)(cdr s_571)))" +"(let-values(((s_574)" +"(if(syntax?$1 s_573)" +"(syntax-e$1 s_573)" +" s_573)))" +"(let-values(((flat-s_43)(to-syntax-list.1 s_574)))" +"(if(not flat-s_43)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_48))" +"(if(null? flat-s_43)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_48))" +"(let-values() flat-s_43))))))))" +"(values #%stratified-body224_0 body225_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_48)))))" +"(values #t #%stratified-body222_1 body223_1))))))" +"(let-values(((rebuild-s_7)" +"(let-values(((ctx226_0) ctx_85)((s227_0) s_569)((temp228_0) #t))" +"(keep-as-needed119.1 #f temp228_0 #f ctx226_0 s227_0))))" +"(let-values(((exp-body_5)" +"(let-values(((temp229_3) body223_0)" +"((ctx230_0) ctx_85)" +"((temp231_1) #t)" +"((rebuild-s232_0) rebuild-s_7))" +"(expand-body7.1 rebuild-s232_0 temp231_1 temp229_3 ctx230_0))))" +"(if(expand-context-to-parsed? ctx_85)" +"(parsed-begin12.1 rebuild-s_7 exp-body_5)" +"(let-values(((rebuild-s233_0) rebuild-s_7)" +"((temp234_1)" +"(if(null?(cdr exp-body_5))" +"(car exp-body_5)" +"(list*(core-id 'begin(expand-context-phase ctx_85)) exp-body_5))))" +"(rebuild5.1 #t rebuild-s233_0 temp234_1)))))))))))" +"(void" +"(add-core-form!*" +" '#%datum" +"(lambda(s_575 ctx_86)" +"(let-values((()" +"(begin" +"(let-values(((obs_101)(expand-context-observer ctx_86)))" +"(if obs_101(let-values()(let-values()(call-expand-observe obs_101 'prim-#%datum)))(void)))" +"(values))))" +"(let-values(((disarmed-s_10)(syntax-disarm$1 s_575)))" +"(let-values(((ok?_46 #%datum235_0 datum236_0)" +"(let-values(((s_576) disarmed-s_10))" +"(let-values(((orig-s_49) s_576))" +"(let-values(((#%datum235_1 datum236_1)" +"(let-values(((s_577)(if(syntax?$1 s_576)(syntax-e$1 s_576) s_576)))" +"(if(pair? s_577)" +"(let-values(((#%datum237_0)(let-values(((s_578)(car s_577))) s_578))" +"((datum238_0)(let-values(((s_579)(cdr s_577))) s_579)))" +"(values #%datum237_0 datum238_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_49)))))" +"(values #t #%datum235_1 datum236_1))))))" +"(let-values(((datum_2) datum236_0))" +"(let-values((()" +"(begin" +"(if(if(syntax?$1 datum_2)(keyword?(syntax-e$1 datum_2)) #f)" +"(let-values()" +" (raise-syntax-error$1 '#%datum \"keyword misused as an expression\" #f datum_2))" +"(void))" +"(values))))" +"(let-values(((phase_141)(expand-context-phase ctx_86)))" +"(if(if(expand-context-to-parsed? ctx_86)(free-id-set-empty?(expand-context-stops ctx_86)) #f)" +"(parsed-quote14.1(keep-properties-only~ s_575)(syntax->datum$1 datum_2))" +"(let-values(((s239_0) s_575)((temp240_0)(list(core-id 'quote phase_141) datum_2)))" +"(rebuild5.1 #t s239_0 temp240_0))))))))))))" +"(void" +"(add-core-form!*" +" '#%app" +"(lambda(s_580 ctx_87)" +"(let-values((()" +"(begin" +"(let-values(((obs_102)(expand-context-observer ctx_87)))" +"(if obs_102(let-values()(let-values()(call-expand-observe obs_102 'prim-#%app)))(void)))" +"(values))))" +"(let-values(((disarmed-s_11)(syntax-disarm$1 s_580)))" +"(let-values(((ok?_47 #%app241_0 e242_0)" +"(let-values(((s_581) disarmed-s_11))" +"(let-values(((orig-s_50) s_581))" +"(let-values(((#%app241_1 e242_1)" +"(let-values(((s_582)(if(syntax?$1 s_581)(syntax-e$1 s_581) s_581)))" +"(if(pair? s_582)" +"(let-values(((#%app243_0)(let-values(((s_583)(car s_582))) s_583))" +"((e244_0)" +"(let-values(((s_584)(cdr s_582)))" +"(let-values(((s_585)" +"(if(syntax?$1 s_584)" +"(syntax-e$1 s_584)" +" s_584)))" +"(let-values(((flat-s_44)(to-syntax-list.1 s_585)))" +"(if(not flat-s_44)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_50))" +"(let-values() flat-s_44)))))))" +"(values #%app243_0 e244_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_50)))))" +"(values #t #%app241_1 e242_1))))))" +"(let-values(((es_3) e242_0))" +"(if(null? es_3)" +"(let-values()" +"(let-values(((phase_142)(expand-context-phase ctx_87)))" +"(if(expand-context-to-parsed? ctx_87)" +"(parsed-quote14.1(keep-properties-only~ s_580) null)" +"(let-values(((s245_0) s_580)((temp246_1)(list(core-id 'quote phase_142) null)))" +"(rebuild5.1 #t s245_0 temp246_1)))))" +"(let-values()" +"(let-values(((keep-for-parsed?_1)(eq?(system-type 'vm) 'chez-scheme)))" +"(let-values(((rebuild-s_8)" +"(let-values(((ctx247_0) ctx_87)" +"((s248_0) s_580)" +"((keep-for-parsed?249_0) keep-for-parsed?_1))" +"(keep-as-needed119.1 #f #f keep-for-parsed?249_0 ctx247_0 s248_0))))" +"(let-values(((prefixless_0)(cdr(syntax-e$1 disarmed-s_11))))" +"(let-values(((rebuild-prefixless_0)" +"(if(syntax?$1 prefixless_0)" +"(let-values(((ctx250_0) ctx_87)" +"((prefixless251_0) prefixless_0)" +"((keep-for-parsed?252_0) keep-for-parsed?_1))" +"(keep-as-needed119.1 #f #f keep-for-parsed?252_0 ctx250_0 prefixless251_0))" +" #f)))" +"(let-values(((expr-ctx_1)(as-expression-context ctx_87)))" +"(let-values((()" +"(begin" +"(let-values(((obs_103)(expand-context-observer expr-ctx_1)))" +"(if obs_103" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_103" +" 'enter-list" +"(datum->syntax$1 #f es_3 s_580))" +"(call-expand-observe obs_103 'next))))" +"(void)))" +"(values))))" +"(let-values(((rest-es_0)(cdr es_3)))" +"(let-values(((exp-rator_0)" +"(let-values(((temp253_1)(car es_3))((expr-ctx254_0) expr-ctx_1))" +"(expand9.1 #f #f #f temp253_1 expr-ctx254_0))))" +"(let-values(((exp-es_0)" +"(reverse$1" +"(let-values(((lst_404) rest-es_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_404)))" +"((letrec-values(((for-loop_316)" +"(lambda(fold-var_372 lst_405)" +"(begin" +" 'for-loop" +"(if(pair? lst_405)" +"(let-values(((e_90)(unsafe-car lst_405))" +"((rest_238)" +"(unsafe-cdr lst_405)))" +"(let-values(((fold-var_373)" +"(let-values(((fold-var_374)" +" fold-var_372))" +"(let-values(((fold-var_375)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(let-values(((obs_104)" +"(expand-context-observer" +" expr-ctx_1)))" +"(if obs_104" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_104" +" 'next)))" +"(void)))" +"(let-values(((e255_0)" +" e_90)" +"((expr-ctx256_0)" +" expr-ctx_1))" +"(expand9.1" +" #f" +" #f" +" #f" +" e255_0" +" expr-ctx256_0))))" +" fold-var_374))))" +"(values" +" fold-var_375)))))" +"(if(not #f)" +"(for-loop_316 fold-var_373 rest_238)" +" fold-var_373)))" +" fold-var_372)))))" +" for-loop_316)" +" null" +" lst_404))))))" +"(if(expand-context-to-parsed? ctx_87)" +"(let-values()" +"(parsed-app7.1" +"(let-values(((or-part_381) rebuild-prefixless_0))" +"(if or-part_381 or-part_381 rebuild-s_8))" +" exp-rator_0" +" exp-es_0))" +"(let-values()" +"(let-values(((es_4)" +"(let-values(((exp-es_1)(cons exp-rator_0 exp-es_0)))" +"(if rebuild-prefixless_0" +"(let-values(((rebuild-prefixless259_0) rebuild-prefixless_0)" +"((exp-es260_0) exp-es_1))" +"(rebuild5.1 #t rebuild-prefixless259_0 exp-es260_0))" +" exp-es_1))))" +"(begin" +"(let-values(((obs_105)(expand-context-observer expr-ctx_1)))" +"(if obs_105" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_105" +" 'exit-list" +"(datum->syntax$1 #f es_4 rebuild-s_8))))" +"(void)))" +"(let-values(((rebuild-s257_0) rebuild-s_8)" +"((temp258_0)(cons #%app241_0 es_4)))" +"(rebuild5.1 #t rebuild-s257_0 temp258_0))))))))))))))))))))))))" +"(void" +"(add-core-form!*" +" 'quote" +"(lambda(s_586 ctx_88)" +"(let-values((()" +"(begin" +"(let-values(((obs_106)(expand-context-observer ctx_88)))" +"(if obs_106(let-values()(let-values()(call-expand-observe obs_106 'prim-quote)))(void)))" +"(values))))" +"(let-values(((ok?_48 quote261_0 datum262_0)" +"(let-values(((s_282)(syntax-disarm$1 s_586)))" +"(let-values(((orig-s_51) s_282))" +"(let-values(((quote261_1 datum262_1)" +"(let-values(((s_284)(if(syntax?$1 s_282)(syntax-e$1 s_282) s_282)))" +"(if(pair? s_284)" +"(let-values(((quote263_0)(let-values(((s_587)(car s_284))) s_587))" +"((datum264_0)" +"(let-values(((s_588)(cdr s_284)))" +"(let-values(((s_589)" +"(if(syntax?$1 s_588)" +"(syntax-e$1 s_588)" +" s_588)))" +"(if(pair? s_589)" +"(let-values(((datum265_0)" +"(let-values(((s_590)(car s_589))) s_590))" +"(()" +"(let-values(((s_591)(cdr s_589)))" +"(let-values(((s_592)" +"(if(syntax?$1 s_591)" +"(syntax-e$1 s_591)" +" s_591)))" +"(if(null? s_592)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_51))))))" +"(values datum265_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_51))))))" +"(values quote263_0 datum264_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_51)))))" +"(values #t quote261_1 datum262_1))))))" +"(if(expand-context-to-parsed? ctx_88)" +"(parsed-quote14.1(keep-properties-only~ s_586)(syntax->datum$1 datum262_0))" +" s_586))))))" +"(void" +"(add-core-form!*" +" 'quote-syntax" +"(lambda(s_593 ctx_89)" +"(let-values((()" +"(begin" +"(let-values(((obs_107)(expand-context-observer ctx_89)))" +"(if obs_107" +"(let-values()(let-values()(call-expand-observe obs_107 'prim-quote-syntax)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_12)(syntax-disarm$1 s_593)))" +"(let-values(((ok?_49 quote-syntax266_0 datum267_0)" +"(let-values(((s_291) disarmed-s_12))" +"(if(let-values(((s_594)(if(syntax?$1 s_291)(syntax-e$1 s_291) s_291)))" +"(if(pair? s_594)" +"(if(let-values(((s_595)(car s_594))) #t)" +"(let-values(((s_596)(cdr s_594)))" +"(let-values(((s_292)(if(syntax?$1 s_596)(syntax-e$1 s_596) s_596)))" +"(if(pair? s_292)" +"(if(let-values(((s_597)(car s_292))) #t)" +"(let-values(((s_598)(cdr s_292)))" +"(let-values(((s_293)(if(syntax?$1 s_598)(syntax-e$1 s_598) s_598)))" +"(if(pair? s_293)" +"(if(let-values(((s_294)(car s_293)))" +"(let-values(((s_295)" +"(if(syntax?$1 s_294)(syntax-e$1 s_294) s_294)))" +"(eq? '#:local s_295)))" +"(let-values(((s_599)(cdr s_293)))" +"(let-values(((s_600)" +"(if(syntax?$1 s_599)(syntax-e$1 s_599) s_599)))" +"(null? s_600)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((quote-syntax266_1 datum267_1)" +"(let-values(((s_601)(if(syntax?$1 s_291)(syntax-e$1 s_291) s_291)))" +"(let-values(((quote-syntax268_0)" +"(let-values(((s_602)(car s_601))) s_602))" +"((datum269_0)" +"(let-values(((s_603)(cdr s_601)))" +"(let-values(((s_604)" +"(if(syntax?$1 s_603)" +"(syntax-e$1 s_603)" +" s_603)))" +"(let-values(((datum270_0)" +"(let-values(((s_605)(car s_604))) s_605))" +"(()" +"(let-values(((s_606)(cdr s_604)))" +"(let-values(((s_607)" +"(if(syntax?$1 s_606)" +"(syntax-e$1 s_606)" +" s_606)))" +"(let-values((()" +"(let-values(((s_608)" +"(car" +" s_607)))" +"(let-values(((s_609)" +"(if(syntax?$1" +" s_608)" +"(syntax-e$1" +" s_608)" +" s_608)))" +"(values))))" +"(()" +"(let-values(((s_610)" +"(cdr" +" s_607)))" +"(let-values(((s_611)" +"(if(syntax?$1" +" s_610)" +"(syntax-e$1" +" s_610)" +" s_610)))" +"(values)))))" +"(values))))))" +"(values datum270_0))))))" +"(values quote-syntax268_0 datum269_0)))))" +"(values #t quote-syntax266_1 datum267_1)))" +"(values #f #f #f)))))" +"(let-values(((ok?_50 quote-syntax271_0 datum272_0)" +"(let-values(((s_612) disarmed-s_12))" +"(if(if(not ok?_49) #t #f)" +"(let-values(((orig-s_52) s_612))" +"(let-values(((quote-syntax271_1 datum272_1)" +"(let-values(((s_613)(if(syntax?$1 s_612)(syntax-e$1 s_612) s_612)))" +"(if(pair? s_613)" +"(let-values(((quote-syntax273_0)" +"(let-values(((s_297)(car s_613))) s_297))" +"((datum274_0)" +"(let-values(((s_614)(cdr s_613)))" +"(let-values(((s_615)" +"(if(syntax?$1 s_614)" +"(syntax-e$1 s_614)" +" s_614)))" +"(if(pair? s_615)" +"(let-values(((datum275_0)" +"(let-values(((s_298)(car s_615)))" +" s_298))" +"(()" +"(let-values(((s_299)(cdr s_615)))" +"(let-values(((s_300)" +"(if(syntax?$1 s_299)" +"(syntax-e$1 s_299)" +" s_299)))" +"(if(null? s_300)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_52))))))" +"(values datum275_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_52))))))" +"(values quote-syntax273_0 datum274_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_52)))))" +"(values #t quote-syntax271_1 datum272_1)))" +"(values #f #f #f)))))" +"(if ok?_49" +"(let-values()" +"(let-values((()" +"(begin" +"(reference-records-all-used!(expand-context-reference-records ctx_89))" +"(values))))" +"(let-values(((ok?_51 _276_0 _277_0 kw278_0)" +"(let-values(((s_616) disarmed-s_12))" +"(let-values(((orig-s_53) s_616))" +"(let-values(((_276_1 _277_1 kw278_1)" +"(let-values(((s_617)" +"(if(syntax?$1 s_616)(syntax-e$1 s_616) s_616)))" +"(if(pair? s_617)" +"(let-values(((_279_0)" +"(let-values(((s_618)(car s_617))) s_618))" +"((_280_0 kw281_0)" +"(let-values(((s_619)(cdr s_617)))" +"(let-values(((s_620)" +"(if(syntax?$1 s_619)" +"(syntax-e$1 s_619)" +" s_619)))" +"(if(pair? s_620)" +"(let-values(((_282_0)" +"(let-values(((s_621)" +"(car s_620)))" +" s_621))" +"((kw283_0)" +"(let-values(((s_622)" +"(cdr s_620)))" +"(let-values(((s_623)" +"(if(syntax?$1" +" s_622)" +"(syntax-e$1" +" s_622)" +" s_622)))" +"(if(pair? s_623)" +"(let-values(((kw284_0)" +"(let-values(((s_624)" +"(car" +" s_623)))" +" s_624))" +"(()" +"(let-values(((s_625)" +"(cdr" +" s_623)))" +"(let-values(((s_626)" +"(if(syntax?$1" +" s_625)" +"(syntax-e$1" +" s_625)" +" s_625)))" +"(if(null?" +" s_626)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values kw284_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values _282_0 kw283_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values _279_0 _280_0 kw281_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_53)))))" +"(values #t _276_1 _277_1 kw278_1))))))" +"(if(expand-context-to-parsed? ctx_89)" +"(parsed-quote-syntax15.1(keep-properties-only~ s_593) datum267_0)" +"(let-values(((s285_0) s_593)((temp286_0)(list quote-syntax266_0 datum267_0 kw278_0)))" +"(rebuild5.1 #t s285_0 temp286_0))))))" +"(let-values()" +"(let-values(((use-site-scopes_2)(root-expand-context-use-site-scopes ctx_89)))" +"(let-values(((datum-s_0)" +"(remove-scopes" +"(remove-scopes datum272_0(expand-context-scopes ctx_89))" +"(if use-site-scopes_2(unbox use-site-scopes_2) '()))))" +"(if(if(expand-context-to-parsed? ctx_89)(free-id-set-empty?(expand-context-stops ctx_89)) #f)" +"(parsed-quote-syntax15.1(keep-properties-only~ s_593) datum-s_0)" +"(let-values(((s287_0) s_593)((temp288_0)(list quote-syntax271_0 datum-s_0)))" +"(rebuild5.1 #t s287_0 temp288_0))))))))))))))" +"(void" +"(add-core-form!*" +" 'if" +"(lambda(s_627 ctx_90)" +"(let-values((()" +"(begin" +"(let-values(((obs_108)(expand-context-observer ctx_90)))" +"(if obs_108(let-values()(let-values()(call-expand-observe obs_108 'prim-if)))(void)))" +"(values))))" +"(let-values(((disarmed-s_13)(syntax-disarm$1 s_627)))" +"(let-values(((ok?_52 _289_0 _290_0 _291_0)" +"(let-values(((s_628) disarmed-s_13))" +"(if(let-values(((s_629)(if(syntax?$1 s_628)(syntax-e$1 s_628) s_628)))" +"(if(pair? s_629)" +"(if(let-values(((s_630)(car s_629))) #t)" +"(let-values(((s_631)(cdr s_629)))" +"(let-values(((s_632)(if(syntax?$1 s_631)(syntax-e$1 s_631) s_631)))" +"(if(pair? s_632)" +"(if(let-values(((s_633)(car s_632))) #t)" +"(let-values(((s_634)(cdr s_632)))" +"(let-values(((s_635)(if(syntax?$1 s_634)(syntax-e$1 s_634) s_634)))" +"(if(pair? s_635)" +"(if(let-values(((s_636)(car s_635))) #t)" +"(let-values(((s_637)(cdr s_635)))" +"(let-values(((s_638)" +"(if(syntax?$1 s_637)(syntax-e$1 s_637) s_637)))" +"(null? s_638)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((_289_1 _290_1 _291_1)" +"(let-values(((s_639)(if(syntax?$1 s_628)(syntax-e$1 s_628) s_628)))" +"(let-values(((_292_0)(let-values(((s_640)(car s_639))) s_640))" +"((_293_0 _294_0)" +"(let-values(((s_641)(cdr s_639)))" +"(let-values(((s_642)" +"(if(syntax?$1 s_641)" +"(syntax-e$1 s_641)" +" s_641)))" +"(let-values(((_295_0)" +"(let-values(((s_643)(car s_642))) s_643))" +"((_296_0)" +"(let-values(((s_644)(cdr s_642)))" +"(let-values(((s_645)" +"(if(syntax?$1 s_644)" +"(syntax-e$1 s_644)" +" s_644)))" +"(let-values(((_297_0)" +"(let-values(((s_646)" +"(car" +" s_645)))" +" s_646))" +"(()" +"(let-values(((s_647)" +"(cdr" +" s_645)))" +"(let-values(((s_648)" +"(if(syntax?$1" +" s_647)" +"(syntax-e$1" +" s_647)" +" s_647)))" +"(values)))))" +"(values _297_0))))))" +"(values _295_0 _296_0))))))" +"(values _292_0 _293_0 _294_0)))))" +"(values #t _289_1 _290_1 _291_1)))" +"(values #f #f #f #f)))))" +"(let-values((()" +"(begin" +"(if ok?_52" +" (let-values () (raise-syntax-error$1 #f \"missing an \\\"else\\\" expression\" s_627))" +"(void))" +"(values))))" +"(let-values(((ok?_53 if298_0 tst299_0 thn300_0 els301_0)" +"(let-values(((s_649) disarmed-s_13))" +"(let-values(((orig-s_54) s_649))" +"(let-values(((if298_1 tst299_1 thn300_1 els301_1)" +"(let-values(((s_650)(if(syntax?$1 s_649)(syntax-e$1 s_649) s_649)))" +"(if(pair? s_650)" +"(let-values(((if302_0)(let-values(((s_651)(car s_650))) s_651))" +"((tst303_0 thn304_0 els305_0)" +"(let-values(((s_652)(cdr s_650)))" +"(let-values(((s_653)" +"(if(syntax?$1 s_652)" +"(syntax-e$1 s_652)" +" s_652)))" +"(if(pair? s_653)" +"(let-values(((tst306_0)" +"(let-values(((s_654)(car s_653)))" +" s_654))" +"((thn307_0 els308_0)" +"(let-values(((s_655)(cdr s_653)))" +"(let-values(((s_656)" +"(if(syntax?$1 s_655)" +"(syntax-e$1 s_655)" +" s_655)))" +"(if(pair? s_656)" +"(let-values(((thn309_0)" +"(let-values(((s_657)" +"(car" +" s_656)))" +" s_657))" +"((els310_0)" +"(let-values(((s_658)" +"(cdr" +" s_656)))" +"(let-values(((s_659)" +"(if(syntax?$1" +" s_658)" +"(syntax-e$1" +" s_658)" +" s_658)))" +"(if(pair?" +" s_659)" +"(let-values(((els311_0)" +"(let-values(((s_660)" +"(car" +" s_659)))" +" s_660))" +"(()" +"(let-values(((s_661)" +"(cdr" +" s_659)))" +"(let-values(((s_662)" +"(if(syntax?$1" +" s_661)" +"(syntax-e$1" +" s_661)" +" s_661)))" +"(if(null?" +" s_662)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values" +" els311_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values thn309_0 els310_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values tst306_0 thn307_0 els308_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values if302_0 tst303_0 thn304_0 els305_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_54)))))" +"(values #t if298_1 tst299_1 thn300_1 els301_1))))))" +"(let-values(((expr-ctx_2)(as-expression-context ctx_90)))" +"(let-values(((tail-ctx_0)" +"(let-values(((expr-ctx312_0) expr-ctx_2)((ctx313_0) ctx_90))" +"(as-tail-context22.1 ctx313_0 expr-ctx312_0))))" +"(let-values(((rebuild-s_9)" +"(let-values(((ctx314_0) ctx_90)((s315_0) s_627))" +"(keep-as-needed119.1 #f #f #f ctx314_0 s315_0))))" +"(let-values(((exp-tst_0)" +"(let-values(((temp316_0) tst299_0)((expr-ctx317_0) expr-ctx_2))" +"(expand9.1 #f #f #f temp316_0 expr-ctx317_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_109)(expand-context-observer ctx_90)))" +"(if obs_109" +"(let-values()(let-values()(call-expand-observe obs_109 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-thn_0)" +"(let-values(((temp318_0) thn300_0)((tail-ctx319_0) tail-ctx_0))" +"(expand9.1 #f #f #f temp318_0 tail-ctx319_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_110)(expand-context-observer ctx_90)))" +"(if obs_110" +"(let-values()(let-values()(call-expand-observe obs_110 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-els_0)" +"(let-values(((temp320_0) els301_0)((tail-ctx321_0) tail-ctx_0))" +"(expand9.1 #f #f #f temp320_0 tail-ctx321_0))))" +"(if(expand-context-to-parsed? ctx_90)" +"(parsed-if8.1 rebuild-s_9 exp-tst_0 exp-thn_0 exp-els_0)" +"(let-values(((rebuild-s322_0) rebuild-s_9)" +"((temp323_0)(list if298_0 exp-tst_0 exp-thn_0 exp-els_0)))" +"(rebuild5.1 #t rebuild-s322_0 temp323_0)))))))))))))))))))" +"(void" +"(add-core-form!*" +" 'with-continuation-mark" +"(lambda(s_663 ctx_91)" +"(let-values((()" +"(begin" +"(let-values(((obs_111)(expand-context-observer ctx_91)))" +"(if obs_111" +"(let-values()(let-values()(call-expand-observe obs_111 'prim-with-continuation-mark)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_14)(syntax-disarm$1 s_663)))" +"(let-values(((ok?_54 with-continuation-mark324_0 key325_0 val326_0 body327_0)" +"(let-values(((s_664) disarmed-s_14))" +"(let-values(((orig-s_55) s_664))" +"(let-values(((with-continuation-mark324_1 key325_1 val326_1 body327_1)" +"(let-values(((s_665)(if(syntax?$1 s_664)(syntax-e$1 s_664) s_664)))" +"(if(pair? s_665)" +"(let-values(((with-continuation-mark328_0)" +"(let-values(((s_666)(car s_665))) s_666))" +"((key329_0 val330_0 body331_0)" +"(let-values(((s_667)(cdr s_665)))" +"(let-values(((s_668)" +"(if(syntax?$1 s_667)" +"(syntax-e$1 s_667)" +" s_667)))" +"(if(pair? s_668)" +"(let-values(((key332_0)" +"(let-values(((s_669)(car s_668)))" +" s_669))" +"((val333_0 body334_0)" +"(let-values(((s_670)(cdr s_668)))" +"(let-values(((s_671)" +"(if(syntax?$1 s_670)" +"(syntax-e$1 s_670)" +" s_670)))" +"(if(pair? s_671)" +"(let-values(((val335_0)" +"(let-values(((s_672)" +"(car" +" s_671)))" +" s_672))" +"((body336_0)" +"(let-values(((s_673)" +"(cdr" +" s_671)))" +"(let-values(((s_674)" +"(if(syntax?$1" +" s_673)" +"(syntax-e$1" +" s_673)" +" s_673)))" +"(if(pair? s_674)" +"(let-values(((body337_0)" +"(let-values(((s_675)" +"(car" +" s_674)))" +" s_675))" +"(()" +"(let-values(((s_676)" +"(cdr" +" s_674)))" +"(let-values(((s_677)" +"(if(syntax?$1" +" s_676)" +"(syntax-e$1" +" s_676)" +" s_676)))" +"(if(null?" +" s_677)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_55))))))" +"(values" +" body337_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_55))))))" +"(values val335_0 body336_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_55))))))" +"(values key332_0 val333_0 body334_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_55))))))" +"(values with-continuation-mark328_0 key329_0 val330_0 body331_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_55)))))" +"(values #t with-continuation-mark324_1 key325_1 val326_1 body327_1))))))" +"(let-values(((expr-ctx_3)(as-expression-context ctx_91)))" +"(let-values(((rebuild-s_10)" +"(let-values(((ctx338_0) ctx_91)((s339_0) s_663))" +"(keep-as-needed119.1 #f #f #f ctx338_0 s339_0))))" +"(let-values(((exp-key_0)" +"(let-values(((temp340_0) key325_0)((expr-ctx341_0) expr-ctx_3))" +"(expand9.1 #f #f #f temp340_0 expr-ctx341_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_112)(expand-context-observer ctx_91)))" +"(if obs_112" +"(let-values()(let-values()(call-expand-observe obs_112 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-val_0)" +"(let-values(((temp342_0) val326_0)((expr-ctx343_0) expr-ctx_3))" +"(expand9.1 #f #f #f temp342_0 expr-ctx343_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_113)(expand-context-observer ctx_91)))" +"(if obs_113" +"(let-values()(let-values()(call-expand-observe obs_113 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_6)" +"(let-values(((temp344_0) body327_0)" +"((temp345_0)" +"(let-values(((expr-ctx346_0) expr-ctx_3)((ctx347_0) ctx_91))" +"(as-tail-context22.1 ctx347_0 expr-ctx346_0))))" +"(expand9.1 #f #f #f temp344_0 temp345_0))))" +"(if(expand-context-to-parsed? ctx_91)" +"(parsed-with-continuation-mark10.1 rebuild-s_10 exp-key_0 exp-val_0 exp-body_6)" +"(let-values(((rebuild-s348_0) rebuild-s_10)" +"((temp349_0)(list with-continuation-mark324_0 exp-key_0 exp-val_0 exp-body_6)))" +"(rebuild5.1 #t rebuild-s348_0 temp349_0))))))))))))))))" +"(define-values" +"(make-begin20.1)" +"(lambda(last-is-tail?15_0 list-start-index14_0 log-tag18_0 parsed-begin19_0)" +"(begin" +" 'make-begin20" +"(let-values(((log-tag_1) log-tag18_0))" +"(let-values(((parsed-begin_0) parsed-begin19_0))" +"(let-values(((list-start-index_0) list-start-index14_0))" +"(let-values(((last-is-tail?_0) last-is-tail?15_0))" +"(let-values()" +"(lambda(s_678 ctx_92)" +"(let-values((()" +"(begin" +"(let-values(((obs_114)(expand-context-observer ctx_92)))" +"(if obs_114" +"(let-values()(let-values()(call-expand-observe obs_114 log-tag_1)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_15)(syntax-disarm$1 s_678)))" +"(let-values(((ok?_55 begin350_0 e351_0)" +"(let-values(((s_679) disarmed-s_15))" +"(let-values(((orig-s_56) s_679))" +"(let-values(((begin350_1 e351_1)" +"(let-values(((s_680)" +"(if(syntax?$1 s_679)(syntax-e$1 s_679) s_679)))" +"(if(pair? s_680)" +"(let-values(((begin352_0)" +"(let-values(((s_681)(car s_680))) s_681))" +"((e353_0)" +"(let-values(((s_682)(cdr s_680)))" +"(let-values(((s_683)" +"(if(syntax?$1 s_682)" +"(syntax-e$1 s_682)" +" s_682)))" +"(let-values(((flat-s_45)" +"(to-syntax-list.1 s_683)))" +"(if(not flat-s_45)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_56))" +"(if(null? flat-s_45)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_56))" +"(let-values() flat-s_45))))))))" +"(values begin352_0 e353_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_56)))))" +"(values #t begin350_1 e351_1))))))" +"(let-values(((expr-ctx_4)" +"(if last-is-tail?_0" +"(as-begin-expression-context ctx_92)" +"(as-expression-context ctx_92))))" +"(let-values(((rebuild-s_11)" +"(let-values(((ctx354_0) ctx_92)((s355_0) s_678))" +"(keep-as-needed119.1 #f #f #f ctx354_0 s355_0))))" +"(let-values(((exp-es_2)" +"((letrec-values(((loop_123)" +"(lambda(es_5 index_6)" +"(begin" +" 'loop" +"(begin" +"(if(zero? index_6)" +"(let-values()" +"(let-values(((obs_115)" +"(expand-context-observer ctx_92)))" +"(if obs_115" +"(let-values()" +"(begin" +"(if(zero? list-start-index_0)" +"(void)" +"(let-values()" +"(call-expand-observe obs_115 'next)))" +"(call-expand-observe" +" obs_115" +" 'enter-list" +"(datum->syntax$1 #f es_5 rebuild-s_11))))" +"(void))))" +"(void))" +"(if(null? es_5)" +"(let-values() null)" +"(let-values()" +"(let-values(((rest-es_1)(cdr es_5)))" +"(begin" +"(let-values(((obs_116)" +"(expand-context-observer" +" ctx_92)))" +"(if obs_116" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_116 'next)))" +"(void)))" +"(cons" +"(let-values(((temp356_0)(car es_5))" +"((temp357_0)" +"(if(if last-is-tail?_0" +"(null? rest-es_1)" +" #f)" +"(let-values(((expr-ctx358_0)" +" expr-ctx_4)" +"((ctx359_0)" +" ctx_92))" +"(as-tail-context22.1" +" ctx359_0" +" expr-ctx358_0))" +" expr-ctx_4)))" +"(expand9.1 #f #f #f temp356_0 temp357_0))" +"(loop_123 rest-es_1(sub1 index_6))))))))))))" +" loop_123)" +" e351_0" +" list-start-index_0)))" +"(begin" +"(let-values(((obs_117)(expand-context-observer ctx_92)))" +"(if obs_117" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_117" +" 'exit-list" +"(datum->syntax$1 #f(list-tail exp-es_2 list-start-index_0) rebuild-s_11))))" +"(void)))" +"(if(expand-context-to-parsed? ctx_92)" +"(parsed-begin_0 rebuild-s_11 exp-es_2)" +"(let-values(((rebuild-s360_0) rebuild-s_11)((temp361_0)(cons begin350_0 exp-es_2)))" +"(rebuild5.1 #t rebuild-s360_0 temp361_0)))))))))))))))))))" +"(void" +"(add-core-form!*" +" 'begin" +"(let-values(((nonempty-begin_0)" +"(let-values(((temp362_0) 'prim-begin)" +"((parsed-begin363_0) parsed-begin12.1)" +"((temp364_0) 0)" +"((temp365_0) #t))" +"(make-begin20.1 temp365_0 temp364_0 temp362_0 parsed-begin363_0))))" +"(lambda(s_684 ctx_93)" +"(let-values(((context_25)(expand-context-context ctx_93)))" +"(if(let-values(((or-part_382)(eq? context_25 'top-level)))" +"(if or-part_382 or-part_382(eq? context_25 'module)))" +"(let-values()" +"(let-values(((disarmed-s_16)(syntax-disarm$1 s_684)))" +"(let-values(((ok?_56 begin366_0)" +"(let-values(((s_685) disarmed-s_16))" +"(if(let-values(((s_686)(if(syntax?$1 s_685)(syntax-e$1 s_685) s_685)))" +"(if(pair? s_686)" +"(if(let-values(((s_687)(car s_686))) #t)" +"(let-values(((s_688)(cdr s_686)))" +"(let-values(((s_689)(if(syntax?$1 s_688)(syntax-e$1 s_688) s_688)))" +"(null? s_689)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((begin366_1)" +"(let-values(((s_690)(if(syntax?$1 s_685)(syntax-e$1 s_685) s_685)))" +"(let-values(((begin367_0)" +"(let-values(((s_691)(car s_690))) s_691))" +"(()" +"(let-values(((s_692)(cdr s_690)))" +"(let-values(((s_693)" +"(if(syntax?$1 s_692)" +"(syntax-e$1 s_692)" +" s_692)))" +"(values)))))" +"(values begin367_0)))))" +"(values #t begin366_1)))" +"(values #f #f)))))" +"(if ok?_56 s_684(nonempty-begin_0 s_684 ctx_93)))))" +"(let-values()(nonempty-begin_0 s_684 ctx_93))))))))" +"(void" +"(add-core-form!*" +" 'begin0" +"(let-values(((temp368_0) 'prim-begin0)((parsed-begin0369_0) parsed-begin013.1)((temp370_0) 1)((temp371_0) #f))" +"(make-begin20.1 temp371_0 temp370_0 temp368_0 parsed-begin0369_0))))" +"(define-values" +"(register-eventual-variable!?)" +"(lambda(id_122 ctx_94)" +"(begin" +"(if(if(expand-context-need-eventually-defined ctx_94)(>=(expand-context-phase ctx_94) 1) #f)" +"(let-values()" +"(begin" +"(hash-update!" +"(expand-context-need-eventually-defined ctx_94)" +"(expand-context-phase ctx_94)" +"(lambda(l_87)(cons id_122 l_87))" +" null)" +" #t))" +"(let-values() #f)))))" +"(void" +"(add-core-form!*" +" '#%top" +"(let-values(((core375_0)" +"(lambda(s373_0 ctx374_0 implicit-omitted?372_0)" +"(begin" +" 'core375" +"(let-values(((s_694) s373_0))" +"(let-values(((ctx_95) ctx374_0))" +"(let-values(((implicit-omitted?_0) implicit-omitted?372_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_118)(expand-context-observer ctx_95)))" +"(if obs_118" +"(let-values()" +"(let-values()(call-expand-observe obs_118 'prim-#%top)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_17)(syntax-disarm$1 s_694)))" +"(let-values(((id_123)" +"(if implicit-omitted?_0" +"(let-values() s_694)" +"(let-values()" +"(let-values(((ok?_57 #%top377_0 id378_0)" +"(let-values(((s_695) disarmed-s_17))" +"(let-values(((orig-s_57) s_695))" +"(let-values(((#%top377_1 id378_1)" +"(let-values(((s_696)" +"(if(syntax?$1 s_695)" +"(syntax-e$1 s_695)" +" s_695)))" +"(if(pair? s_696)" +"(let-values(((#%top379_0)" +"(let-values(((s_697)" +"(car" +" s_696)))" +" s_697))" +"((id380_0)" +"(let-values(((s_698)" +"(cdr" +" s_696)))" +"(if(let-values(((or-part_383)" +"(if(syntax?$1" +" s_698)" +"(symbol?" +"(syntax-e$1" +" s_698))" +" #f)))" +"(if or-part_383" +" or-part_383" +"(symbol?" +" s_698)))" +" s_698" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_57" +" s_698)))))" +"(values #%top379_0 id380_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_57)))))" +"(values #t #%top377_1 id378_1))))))" +" id378_0)))))" +"(let-values(((b_93)" +"(let-values(((id381_0) id_123)" +"((temp382_0)(expand-context-phase ctx_95))" +"((temp383_0) 'ambiguous))" +"(resolve+shift28.1" +" temp383_0" +" #f" +" null" +" unsafe-undefined" +" #f" +" id381_0" +" temp382_0))))" +"(if(eq? b_93 'ambiguous)" +"(let-values()(raise-ambiguous-error id_123 ctx_95))" +"(if(if b_93" +"(if(module-binding? b_93)" +"(eq?(module-binding-module b_93)(root-expand-context-self-mpi ctx_95))" +" #f)" +" #f)" +"(let-values()" +"(if(expand-context-to-parsed? ctx_95)" +"(parsed-id2.1 id_123 b_93 #f)" +"(if(top-level-module-path-index?(module-binding-module b_93))" +"(let-values() s_694)" +"(let-values() id_123))))" +"(if(register-eventual-variable!? id_123 ctx_95)" +"(let-values()" +"(if(expand-context-to-parsed? ctx_95)" +"(parsed-id2.1 id_123 b_93 #f)" +" id_123))" +"(let-values()" +"(if(not(expand-context-allow-unbound? ctx_95))" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" id_123" +" #f" +" null" +"(syntax-debug-info-string id_123 ctx_95)))" +"(let-values()" +"(let-values(((tl-id_1)" +"(add-scope" +" id_123" +"(root-expand-context-top-level-bind-scope ctx_95))))" +"(let-values(((tl-b_1)" +"(let-values(((tl-id384_0) tl-id_1)" +"((temp385_0)" +"(expand-context-phase ctx_95)))" +"(resolve40.1 #f #f null #f tl-id384_0 temp385_0))))" +"(if tl-b_1" +"(let-values()" +"(if(expand-context-to-parsed? ctx_95)" +"(parsed-top-id4.1 tl-id_1 tl-b_1 #f)" +"(if implicit-omitted?_0" +"(let-values() id_123)" +"(let-values()" +"(let-values(((ok?_58 #%top386_0 id387_0)" +"(let-values(((s_699) disarmed-s_17))" +"(let-values(((orig-s_58) s_699))" +"(let-values(((#%top386_1 id387_1)" +"(let-values(((s_700)" +"(if(syntax?$1" +" s_699)" +"(syntax-e$1" +" s_699)" +" s_699)))" +"(if(pair? s_700)" +"(let-values(((#%top388_0)" +"(let-values(((s_701)" +"(car" +" s_700)))" +" s_701))" +"((id389_0)" +"(let-values(((s_702)" +"(cdr" +" s_700)))" +"(if(let-values(((or-part_384)" +"(if(syntax?$1" +" s_702)" +"(symbol?" +"(syntax-e$1" +" s_702))" +" #f)))" +"(if or-part_384" +" or-part_384" +"(symbol?" +" s_702)))" +" s_702" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_58" +" s_702)))))" +"(values" +" #%top388_0" +" id389_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_58)))))" +"(values #t #%top386_1 id387_1))))))" +"(let-values(((s390_0) s_694)" +"((temp391_0)(cons #%top386_0 id_123)))" +"(rebuild5.1 #t s390_0 temp391_0)))))))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_95)" +"(parsed-top-id4.1 id_123 b_93 #f)" +" s_694)))))))))))))))))))))))" +"(case-lambda" +"((s_703 ctx_96)(core375_0 s_703 ctx_96 #f))" +"((s_704 ctx_97 implicit-omitted?372_1)(core375_0 s_704 ctx_97 implicit-omitted?372_1))))))" +"(void" +"(add-core-form!*" +" 'set!" +"(lambda(s_705 ctx_98)" +"(let-values((()" +"(begin" +"(let-values(((obs_119)(expand-context-observer ctx_98)))" +"(if obs_119(let-values()(let-values()(call-expand-observe obs_119 'prim-set!)))(void)))" +"(values))))" +"(let-values(((disarmed-s_18)(syntax-disarm$1 s_705)))" +"(let-values(((ok?_59 set!392_0 id393_0 rhs394_0)" +"(let-values(((s_706) disarmed-s_18))" +"(let-values(((orig-s_59) s_706))" +"(let-values(((set!392_1 id393_1 rhs394_1)" +"(let-values(((s_707)(if(syntax?$1 s_706)(syntax-e$1 s_706) s_706)))" +"(if(pair? s_707)" +"(let-values(((set!395_0)(let-values(((s_708)(car s_707))) s_708))" +"((id396_0 rhs397_0)" +"(let-values(((s_709)(cdr s_707)))" +"(let-values(((s_710)" +"(if(syntax?$1 s_709)" +"(syntax-e$1 s_709)" +" s_709)))" +"(if(pair? s_710)" +"(let-values(((id398_0)" +"(let-values(((s_711)(car s_710)))" +"(if(let-values(((or-part_385)" +"(if(syntax?$1 s_711)" +"(symbol?" +"(syntax-e$1" +" s_711))" +" #f)))" +"(if or-part_385" +" or-part_385" +"(symbol? s_711)))" +" s_711" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_59" +" s_711))))" +"((rhs399_0)" +"(let-values(((s_712)(cdr s_710)))" +"(let-values(((s_713)" +"(if(syntax?$1 s_712)" +"(syntax-e$1 s_712)" +" s_712)))" +"(if(pair? s_713)" +"(let-values(((rhs400_0)" +"(let-values(((s_714)" +"(car" +" s_713)))" +" s_714))" +"(()" +"(let-values(((s_715)" +"(cdr" +" s_713)))" +"(let-values(((s_716)" +"(if(syntax?$1" +" s_715)" +"(syntax-e$1" +" s_715)" +" s_715)))" +"(if(null? s_716)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_59))))))" +"(values rhs400_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_59))))))" +"(values id398_0 rhs399_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_59))))))" +"(values set!395_0 id396_0 rhs397_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_59)))))" +"(values #t set!392_1 id393_1 rhs394_1))))))" +"(let-values(((orig-id_1) id393_0))" +"((letrec-values(((rename-loop_0)" +"(lambda(id_124 from-rename?_0)" +"(begin" +" 'rename-loop" +"(let-values(((binding_29)" +"(let-values(((id401_0) id_124)" +"((temp402_0)(expand-context-phase ctx_98))" +"((temp403_0) 'ambiguous)" +"((temp404_0) #t))" +"(resolve+shift28.1" +" temp403_0" +" #f" +" null" +" temp404_0" +" #f" +" id401_0" +" temp402_0))))" +"(let-values((()" +"(begin" +"(if(eq? binding_29 'ambiguous)" +"(let-values()(raise-ambiguous-error id_124 ctx_98))" +"(void))" +"(values))))" +"(let-values(((t_62 primitive?_11 insp_24 protected?_12)" +"(if binding_29" +"(let-values(((binding405_0) binding_29)" +"((ctx406_0) ctx_98)" +"((s407_0) s_705))" +"(lookup62.1 #f #f binding405_0 ctx406_0 s407_0))" +"(values #f #f #f #f))))" +"(begin" +"(let-values(((obs_120)(expand-context-observer ctx_98)))" +"(if obs_120" +"(let-values()" +"(let-values()(call-expand-observe obs_120 'resolve id_124)))" +"(void)))" +"(if(let-values(((or-part_386)(variable? t_62)))" +"(if or-part_386" +" or-part_386" +"(if(not binding_29)" +"(let-values(((or-part_387)" +"(register-eventual-variable!? id_124 ctx_98)))" +"(if or-part_387" +" or-part_387" +"(expand-context-allow-unbound? ctx_98)))" +" #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(module-binding? binding_29)" +"(not" +"(eq?" +"(module-binding-module binding_29)" +"(root-expand-context-self-mpi ctx_98)))" +" #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot mutate module-required identifier\"" +" s_705" +" id_124))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_121)" +"(expand-context-observer ctx_98)))" +"(if obs_121" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_121 'next)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(register-variable-referenced-if-local! binding_29)" +"(values))))" +"(let-values(((rebuild-s_12)" +"(let-values(((ctx408_0) ctx_98)((s409_0) s_705))" +"(keep-as-needed119.1 #f #f #f ctx408_0 s409_0))))" +"(let-values(((exp-rhs_5)" +"(let-values(((temp410_0) rhs394_0)" +"((temp411_0)" +"(as-expression-context ctx_98)))" +"(expand9.1 #f #f #f temp410_0 temp411_0))))" +"(if(expand-context-to-parsed? ctx_98)" +"(parsed-set!9.1" +" rebuild-s_12" +"(parsed-id2.1 id_124 binding_29 #f)" +" exp-rhs_5)" +"(let-values(((rebuild-s412_0) rebuild-s_12)" +"((temp413_0)" +"(list" +" set!392_0" +"(let-values(((id414_0) id_124)" +"((t415_0) t_62)" +"((temp416_0)" +"(free-id-set-empty-or-just-module*?" +"(expand-context-stops" +" ctx_98))))" +"(substitute-variable6.1" +" temp416_0" +" id414_0" +" t415_0))" +" exp-rhs_5)))" +"(rebuild5.1 #t rebuild-s412_0 temp413_0)))))))))" +"(if(not binding_29)" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" s_705" +" id_124" +" null" +"(syntax-debug-info-string id_124 ctx_98)))" +"(if(1/set!-transformer? t_62)" +"(let-values()" +"(if(not-in-this-expand-context? t_62 ctx_98)" +"(let-values()" +"(let-values(((temp417_0)" +"(avoid-current-expand-context" +"(substitute-set!-rename" +" s_705" +" disarmed-s_18" +" set!392_0" +" rhs394_0" +" id_124" +" from-rename?_0" +" ctx_98)" +" t_62" +" ctx_98))" +"((ctx418_0) ctx_98))" +"(expand9.1 #f #f #f temp417_0 ctx418_0)))" +"(let-values()" +"(let-values(((exp-s_13 re-ctx_1)" +"(let-values(((t419_0) t_62)" +"((insp420_0) insp_24)" +"((s421_0) s_705)" +"((orig-id422_0) orig-id_1)" +"((ctx423_0) ctx_98)" +"((binding424_0) binding_29)" +"((orig-id425_0) orig-id_1))" +"(apply-transformer52.1" +" orig-id425_0" +" t419_0" +" insp420_0" +" s421_0" +" orig-id422_0" +" ctx423_0" +" binding424_0))))" +"(if(expand-context-just-once? ctx_98)" +"(let-values() exp-s_13)" +"(let-values()" +"(let-values(((exp-s426_0) exp-s_13)" +"((re-ctx427_0) re-ctx_1))" +"(expand9.1 #f #f #f exp-s426_0 re-ctx427_0))))))))" +"(if(1/rename-transformer? t_62)" +"(let-values()" +"(if(not-in-this-expand-context? t_62 ctx_98)" +"(let-values()" +"(let-values(((temp428_0)" +"(avoid-current-expand-context" +"(substitute-set!-rename" +" s_705" +" disarmed-s_18" +" set!392_0" +" rhs394_0" +" id_124" +" from-rename?_0" +" ctx_98" +" t_62)" +" t_62" +" ctx_98))" +"((ctx429_0) ctx_98))" +"(expand9.1 #f #f #f temp428_0 ctx429_0)))" +"(let-values()" +"(rename-loop_0" +"(syntax-track-origin$1" +"(rename-transformer-target-in-context t_62 ctx_98)" +" id_124" +" id_124)" +" #t))))" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot mutate syntax identifier\"" +" s_705" +" id_124))))))))))))))" +" rename-loop_0)" +" orig-id_1" +" #f))))))))" +"(define-values" +"(substitute-set!-rename)" +"(let-values(((substitute-set!-rename31_0)" +"(lambda(s24_3 disarmed-s25_0 set!-id26_0 id27_0 rhs-s28_0 from-rename?29_0 ctx30_0 t23_0)" +"(begin" +" 'substitute-set!-rename31" +"(let-values(((s_717) s24_3))" +"(let-values(((disarmed-s_19) disarmed-s25_0))" +"(let-values(((set!-id_0) set!-id26_0))" +"(let-values(((id_125) id27_0))" +"(let-values(((rhs-s_0) rhs-s28_0))" +"(let-values(((from-rename?_1) from-rename?29_0))" +"(let-values(((ctx_99) ctx30_0))" +"(let-values(((t_63) t23_0))" +"(let-values()" +"(if(let-values(((or-part_388) t_63))" +"(if or-part_388 or-part_388 from-rename?_1))" +"(let-values()" +"(let-values(((new-id_1)" +"(if t_63" +"(rename-transformer-target-in-context t_63 ctx_99)" +" id_125)))" +"(syntax-rearm$1" +"(datum->syntax$1" +" disarmed-s_19" +"(list set!-id_0 new-id_1 rhs-s_0)" +" disarmed-s_19" +" disarmed-s_19)" +" s_717)))" +"(let-values() s_717)))))))))))))))" +"(case-lambda" +"((s_718 disarmed-s_20 set!-id_1 id_126 rhs-s_1 from-rename?_2 ctx_100)" +"(begin(substitute-set!-rename31_0 s_718 disarmed-s_20 set!-id_1 id_126 rhs-s_1 from-rename?_2 ctx_100 #f)))" +"((s_719 disarmed-s_21 set!-id_2 id_127 rhs-s_2 from-rename?_3 ctx_101 t23_1)" +"(substitute-set!-rename31_0 s_719 disarmed-s_21 set!-id_2 id_127 rhs-s_2 from-rename?_3 ctx_101 t23_1)))))" +"(void" +"(add-core-form!*" +" '#%variable-reference" +"(lambda(s_720 ctx_102)" +"(let-values((()" +"(begin" +"(let-values(((obs_122)(expand-context-observer ctx_102)))" +"(if obs_122" +"(let-values()(let-values()(call-expand-observe obs_122 'prim-#%variable-reference)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_22)(syntax-disarm$1 s_720)))" +"(let-values(((ok?_60 #%variable-reference430_0 id431_0)" +"(let-values(((s_721) disarmed-s_22))" +"(if(let-values(((s_722)(if(syntax?$1 s_721)(syntax-e$1 s_721) s_721)))" +"(if(pair? s_722)" +"(if(let-values(((s_723)(car s_722))) #t)" +"(let-values(((s_724)(cdr s_722)))" +"(let-values(((s_725)(if(syntax?$1 s_724)(syntax-e$1 s_724) s_724)))" +"(if(pair? s_725)" +"(if(let-values(((s_726)(car s_725)))" +"(let-values(((or-part_389)" +"(if(syntax?$1 s_726)(symbol?(syntax-e$1 s_726)) #f)))" +"(if or-part_389 or-part_389(symbol? s_726))))" +"(let-values(((s_727)(cdr s_725)))" +"(let-values(((s_728)(if(syntax?$1 s_727)(syntax-e$1 s_727) s_727)))" +"(null? s_728)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((#%variable-reference430_1 id431_1)" +"(let-values(((s_729)(if(syntax?$1 s_721)(syntax-e$1 s_721) s_721)))" +"(let-values(((#%variable-reference432_0)" +"(let-values(((s_730)(car s_729))) s_730))" +"((id433_0)" +"(let-values(((s_731)(cdr s_729)))" +"(let-values(((s_732)" +"(if(syntax?$1 s_731)" +"(syntax-e$1 s_731)" +" s_731)))" +"(let-values(((id434_0)" +"(let-values(((s_733)(car s_732))) s_733))" +"(()" +"(let-values(((s_734)(cdr s_732)))" +"(let-values(((s_735)" +"(if(syntax?$1 s_734)" +"(syntax-e$1 s_734)" +" s_734)))" +"(values)))))" +"(values id434_0))))))" +"(values #%variable-reference432_0 id433_0)))))" +"(values #t #%variable-reference430_1 id431_1)))" +"(values #f #f #f)))))" +"(let-values(((ok?_61 #%variable-reference435_0 #%top436_0 id437_0)" +"(let-values(((s_736) disarmed-s_22))" +"(if(if(not ok?_60)" +"(let-values(((s_737)(if(syntax?$1 s_736)(syntax-e$1 s_736) s_736)))" +"(if(pair? s_737)" +"(if(let-values(((s_738)(car s_737))) #t)" +"(let-values(((s_739)(cdr s_737)))" +"(let-values(((s_740)(if(syntax?$1 s_739)(syntax-e$1 s_739) s_739)))" +"(if(pair? s_740)" +"(if(let-values(((s_741)(car s_740)))" +"(let-values(((s_742)" +"(if(syntax?$1 s_741)(syntax-e$1 s_741) s_741)))" +"(if(pair? s_742)" +"(if(let-values(((s_743)(car s_742))) #t)" +"(let-values(((s_744)(cdr s_742)))" +"(let-values(((or-part_390)" +"(if(syntax?$1 s_744)" +"(symbol?(syntax-e$1 s_744))" +" #f)))" +"(if or-part_390 or-part_390(symbol? s_744))))" +" #f)" +" #f)))" +"(let-values(((s_745)(cdr s_740)))" +"(let-values(((s_746)(if(syntax?$1 s_745)(syntax-e$1 s_745) s_745)))" +"(null? s_746)))" +" #f)" +" #f)))" +" #f)" +" #f))" +" #f)" +"(let-values()" +"(let-values(((#%variable-reference435_1 #%top436_1 id437_1)" +"(let-values(((s_747)(if(syntax?$1 s_736)(syntax-e$1 s_736) s_736)))" +"(let-values(((#%variable-reference438_0)" +"(let-values(((s_748)(car s_747))) s_748))" +"((#%top439_0 id440_0)" +"(let-values(((s_749)(cdr s_747)))" +"(let-values(((s_750)" +"(if(syntax?$1 s_749)" +"(syntax-e$1 s_749)" +" s_749)))" +"(let-values(((#%top441_0 id442_0)" +"(let-values(((s_751)(car s_750)))" +"(let-values(((s_752)" +"(if(syntax?$1 s_751)" +"(syntax-e$1 s_751)" +" s_751)))" +"(let-values(((#%top443_0)" +"(let-values(((s_753)" +"(car" +" s_752)))" +" s_753))" +"((id444_0)" +"(let-values(((s_754)" +"(cdr" +" s_752)))" +" s_754)))" +"(values #%top443_0 id444_0)))))" +"(()" +"(let-values(((s_755)(cdr s_750)))" +"(let-values(((s_756)" +"(if(syntax?$1 s_755)" +"(syntax-e$1 s_755)" +" s_755)))" +"(values)))))" +"(values #%top441_0 id442_0))))))" +"(values #%variable-reference438_0 #%top439_0 id440_0)))))" +"(values #t #%variable-reference435_1 #%top436_1 id437_1)))" +"(values #f #f #f #f)))))" +"(let-values(((ok?_62 #%variable-reference445_0)" +"(let-values(((s_757) disarmed-s_22))" +"(if(if(not(let-values(((or-part_391) ok?_60))(if or-part_391 or-part_391 ok?_61)))" +" #t" +" #f)" +"(let-values(((orig-s_60) s_757))" +"(let-values(((#%variable-reference445_1)" +"(let-values(((s_758)(if(syntax?$1 s_757)(syntax-e$1 s_757) s_757)))" +"(if(pair? s_758)" +"(let-values(((#%variable-reference446_0)" +"(let-values(((s_759)(car s_758))) s_759))" +"(()" +"(let-values(((s_760)(cdr s_758)))" +"(let-values(((s_761)" +"(if(syntax?$1 s_760)" +"(syntax-e$1 s_760)" +" s_760)))" +"(if(null? s_761)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_60))))))" +"(values #%variable-reference446_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_60)))))" +"(values #t #%variable-reference445_1)))" +"(values #f #f)))))" +"(if(let-values(((or-part_392) ok?_60))(if or-part_392 or-part_392 ok?_61))" +"(let-values()" +"(let-values(((var-id_0)(if ok?_60 id431_0 id437_0)))" +"(let-values(((binding_30)" +"(let-values(((var-id447_0) var-id_0)" +"((temp448_0)(expand-context-phase ctx_102))" +"((temp449_0) 'ambiguous))" +"(resolve+shift28.1 temp449_0 #f null unsafe-undefined #f var-id447_0 temp448_0))))" +"(let-values((()" +"(begin" +"(if(eq? binding_30 'ambiguous)" +"(let-values()(raise-ambiguous-error var-id_0 ctx_102))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_393) binding_30))" +"(if or-part_393 or-part_393(expand-context-allow-unbound? ctx_102)))" +"(void)" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" s_720" +" var-id_0" +" null" +"(syntax-debug-info-string var-id_0 ctx_102))))" +"(values))))" +"(let-values(((t_64 primitive?_12 insp-of-t_7 protected?_13)" +"(if binding_30" +"(let-values(((binding450_0) binding_30)" +"((ctx451_0) ctx_102)" +"((var-id452_0) var-id_0)" +"((s453_0) s_720)" +"((temp454_0)(expand-context-in-local-expand? ctx_102)))" +"(lookup62.1 s453_0 temp454_0 binding450_0 ctx451_0 var-id452_0))" +"(values #f #f #f #f))))" +"(begin" +"(if(if t_64(not(variable? t_64)) #f)" +"(let-values()" +" (raise-syntax-error$1 #f \"identifier does not refer to a variable\" var-id_0 s_720))" +"(void))" +"(if(expand-context-to-parsed? ctx_102)" +"(parsed-#%variable-reference11.1" +"(keep-properties-only~ s_720)" +"(if ok?_61" +"(let-values()(parsed-top-id4.1 var-id_0 binding_30 #f))" +"(let-values()(parsed-id2.1 var-id_0 binding_30 #f))))" +" s_720))))))))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_102)" +"(parsed-#%variable-reference11.1(keep-properties-only~ s_720) #f)" +" s_720)))))))))))" +"(void" +"(add-core-form!*" +" '#%expression" +"(lambda(s_762 ctx_103)" +"(let-values((()" +"(begin" +"(let-values(((obs_123)(expand-context-observer ctx_103)))" +"(if obs_123" +"(let-values()(let-values()(call-expand-observe obs_123 'prim-#%expression)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_23)(syntax-disarm$1 s_762)))" +"(let-values(((ok?_63 #%expression455_0 e456_0)" +"(let-values(((s_763) disarmed-s_23))" +"(let-values(((orig-s_61) s_763))" +"(let-values(((#%expression455_1 e456_1)" +"(let-values(((s_764)(if(syntax?$1 s_763)(syntax-e$1 s_763) s_763)))" +"(if(pair? s_764)" +"(let-values(((#%expression457_0)" +"(let-values(((s_765)(car s_764))) s_765))" +"((e458_0)" +"(let-values(((s_766)(cdr s_764)))" +"(let-values(((s_767)" +"(if(syntax?$1 s_766)" +"(syntax-e$1 s_766)" +" s_766)))" +"(if(pair? s_767)" +"(let-values(((e459_0)" +"(let-values(((s_768)(car s_767)))" +" s_768))" +"(()" +"(let-values(((s_769)(cdr s_767)))" +"(let-values(((s_770)" +"(if(syntax?$1 s_769)" +"(syntax-e$1 s_769)" +" s_769)))" +"(if(null? s_770)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_61))))))" +"(values e459_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_61))))))" +"(values #%expression457_0 e458_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_61)))))" +"(values #t #%expression455_1 e456_1))))))" +"(let-values(((rebuild-s_13)" +"(let-values(((ctx460_0) ctx_103)((s461_0) s_762)((temp462_0) #t))" +"(keep-as-needed119.1 temp462_0 #f #f ctx460_0 s461_0))))" +"(let-values(((exp-e_0)" +"(let-values(((temp463_0) e456_0)" +"((temp464_0)" +"(let-values(((temp465_0)(as-expression-context ctx_103))" +"((ctx466_0) ctx_103))" +"(as-tail-context22.1 ctx466_0 temp465_0))))" +"(expand9.1 #f #f #f temp463_0 temp464_0))))" +"(if(expand-context-to-parsed? ctx_103)" +" exp-e_0" +"(if(let-values(((or-part_394)" +"(if(expand-context-in-local-expand? ctx_103)" +"(expand-context-keep-#%expression? ctx_103)" +" #f)))" +"(if or-part_394 or-part_394(eq? 'top-level(expand-context-context ctx_103))))" +"(let-values()" +"(let-values(((rebuild-s467_0) rebuild-s_13)((temp468_0)(list #%expression455_0 exp-e_0)))" +"(rebuild5.1 #t rebuild-s467_0 temp468_0)))" +"(let-values()" +"(let-values(((result-s_13)(syntax-track-origin$1 exp-e_0 rebuild-s_13)))" +"(begin" +"(let-values(((obs_124)(expand-context-observer ctx_103)))" +"(if obs_124" +"(let-values()(let-values()(call-expand-observe obs_124 'tag result-s_13)))" +"(void)))" +" result-s_13)))))))))))))" +" (void (add-core-form!* 'unquote (lambda (s_771 ctx_104) (raise-syntax-error$1 #f \"not in quasiquote\" s_771))))" +" (void (add-core-form!* 'unquote-splicing (lambda (s_772 ctx_105) (raise-syntax-error$1 #f \"not in quasiquote\" s_772))))" +"(define-values" +"(binding-for-transformer?)" +"(lambda(b_42 id_128 at-phase_12 ns_112)" +"(begin" +"(if(not at-phase_12)" +"(let-values()" +"(let-values(((m_30)" +"(namespace->module ns_112(1/module-path-index-resolve(module-binding-nominal-module b_42)))))" +"(let-values(((b/p_4)" +"(hash-ref" +"(hash-ref(module-provides m_30)(module-binding-nominal-phase b_42) '#hasheq())" +"(module-binding-nominal-sym b_42)" +" #f)))" +"(provided-as-transformer? b/p_4))))" +"(let-values()" +"(let-values(((val_14 primitive?_13 insp_25 protected?_14)" +"(let-values(((b1_8) b_42)" +"((empty-env2_0) empty-env)" +"((null3_0) null)" +"((ns4_2) ns_112)" +"((at-phase5_0) at-phase_12)" +"((id6_0) id_128))" +"(binding-lookup50.1 #f #f b1_8 empty-env2_0 null3_0 ns4_2 at-phase5_0 id6_0))))" +"(not(variable? val_14))))))))" +"(define-values(layers) '(raw phaseless id))" +"(define-values(provide-form-name) 'provide)" +"(define-values" +"(parse-and-expand-provides!)" +"(lambda(specs_0 orig-s_62 rp_1 self_30 phase_45 ctx_106)" +"(begin" +"(let-values(((ns_125)(expand-context-namespace ctx_106)))" +"((letrec-values(((loop_116)" +"(lambda(specs_1 at-phase_13 protected?_15 layer_6)" +"(begin" +" 'loop" +"(let-values(((track-stxess_0 exp-specss_0)" +"(let-values(((track-stxes_0 exp-specs_0)" +"(let-values(((lst_77) specs_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_77)))" +"((letrec-values(((for-loop_98)" +"(lambda(track-stxes_1" +" exp-specs_1" +" lst_406)" +"(begin" +" 'for-loop" +"(if(pair? lst_406)" +"(let-values(((spec_0)" +"(unsafe-car" +" lst_406))" +"((rest_239)" +"(unsafe-cdr" +" lst_406)))" +"(let-values(((track-stxes_2" +" exp-specs_2)" +"(let-values(((track-stxes_3)" +" track-stxes_1)" +"((exp-specs_3)" +" exp-specs_1))" +"(let-values(((track-stxes_4" +" exp-specs_4)" +"(let-values()" +"(let-values(((track-stxes1_0" +" exp-specs2_0)" +"(let-values()" +"(let-values(((disarmed-spec_0)" +"(syntax-disarm$1" +" spec_0)))" +"(let-values(((fm_2)" +"(if(pair?" +"(syntax-e$1" +" disarmed-spec_0))" +"(if(identifier?" +"(car" +"(syntax-e$1" +" disarmed-spec_0)))" +"(syntax-e$1" +"(car" +"(syntax-e$1" +" disarmed-spec_0)))" +" #f)" +" #f)))" +"(let-values(((check-nested_1)" +"(lambda(want-layer_3)" +"(begin" +" 'check-nested" +"(if(member" +" want-layer_3" +"(member" +" layer_6" +" layers))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +"(format" +" \"nested `~a' not allowed\"" +" fm_2)" +" orig-s_62" +" spec_0)))))))" +"(let-values(((tmp_42)" +" fm_2))" +"(let-values(((index_7)" +"(if(symbol?" +" tmp_42)" +"(hash-ref" +" '#hasheq((all-defined" +" ." +" 9)" +"(all-defined-except" +" ." +" 10)" +"(all-from" +" ." +" 7)" +"(all-from-except" +" ." +" 8)" +"(expand" +" ." +" 13)" +"(for-label" +" ." +" 3)" +"(for-meta" +" ." +" 1)" +"(for-syntax" +" ." +" 2)" +"(prefix-all-defined" +" ." +" 11)" +"(prefix-all-defined-except" +" ." +" 12)" +"(protect" +" ." +" 4)" +"(rename ." +" 5)" +"(struct" +" ." +" 6))" +" tmp_42" +"(lambda()" +" 0))" +" 0)))" +"(if(unsafe-fx<" +" index_7" +" 6)" +"(if(unsafe-fx<" +" index_7" +" 2)" +"(if(unsafe-fx<" +" index_7" +" 1)" +"(let-values()" +"(if(identifier?" +" spec_0)" +"(let-values()" +"(begin" +"(parse-identifier!" +" spec_0" +" orig-s_62" +"(syntax-e$1" +" spec_0)" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"bad syntax\"" +" orig-s_62" +" spec_0))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_64" +" for-meta3_0" +" phase-level4_0" +" spec5_0)" +"(let-values(((s_168)" +" disarmed-spec_0))" +"(let-values(((orig-s_63)" +" s_168))" +"(let-values(((for-meta3_1" +" phase-level4_1" +" spec5_1)" +"(let-values(((s_773)" +"(if(syntax?$1" +" s_168)" +"(syntax-e$1" +" s_168)" +" s_168)))" +"(if(pair?" +" s_773)" +"(let-values(((for-meta6_0)" +"(let-values(((s_488)" +"(car" +" s_773)))" +" s_488))" +"((phase-level7_0" +" spec8_0)" +"(let-values(((s_448)" +"(cdr" +" s_773)))" +"(let-values(((s_493)" +"(if(syntax?$1" +" s_448)" +"(syntax-e$1" +" s_448)" +" s_448)))" +"(if(pair?" +" s_493)" +"(let-values(((phase-level9_0)" +"(let-values(((s_774)" +"(car" +" s_493)))" +" s_774))" +"((spec10_0)" +"(let-values(((s_775)" +"(cdr" +" s_493)))" +"(let-values(((s_81)" +"(if(syntax?$1" +" s_775)" +"(syntax-e$1" +" s_775)" +" s_775)))" +"(let-values(((flat-s_46)" +"(to-syntax-list.1" +" s_81)))" +"(if(not" +" flat-s_46)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_63))" +"(let-values()" +" flat-s_46)))))))" +"(values" +" phase-level9_0" +" spec10_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_63))))))" +"(values" +" for-meta6_0" +" phase-level7_0" +" spec8_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_63)))))" +"(values" +" #t" +" for-meta3_1" +" phase-level4_1" +" spec5_1))))))" +"(let-values(((p_87)" +"(syntax-e$1" +" phase-level4_0)))" +"(let-values((()" +"(begin" +"(if(phase?" +" p_87)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"bad `for-meta' phase\"" +" orig-s_62" +" spec_0)))" +"(values))))" +"(let-values(((track-stxes_5" +" exp-specs_5)" +"(loop_116" +" spec5_0" +"(phase+" +" p_87" +" at-phase_13)" +" protected?_15" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_5" +"(let-values(((spec11_0)" +" spec_0)" +"((temp12_8)" +"(list*" +" for-meta3_0" +" phase-level4_0" +" exp-specs_5)))" +"(rebuild5.1" +" #t" +" spec11_0" +" temp12_8))))))))))))" +"(if(unsafe-fx<" +" index_7" +" 3)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_65" +" for-syntax13_0" +" spec14_0)" +"(let-values(((s_450)" +" disarmed-spec_0))" +"(let-values(((orig-s_64)" +" s_450))" +"(let-values(((for-syntax13_1" +" spec14_1)" +"(let-values(((s_24)" +"(if(syntax?$1" +" s_450)" +"(syntax-e$1" +" s_450)" +" s_450)))" +"(if(pair?" +" s_24)" +"(let-values(((for-syntax15_0)" +"(let-values(((s_306)" +"(car" +" s_24)))" +" s_306))" +"((spec16_0)" +"(let-values(((s_157)" +"(cdr" +" s_24)))" +"(let-values(((s_776)" +"(if(syntax?$1" +" s_157)" +"(syntax-e$1" +" s_157)" +" s_157)))" +"(let-values(((flat-s_47)" +"(to-syntax-list.1" +" s_776)))" +"(if(not" +" flat-s_47)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64))" +"(let-values()" +" flat-s_47)))))))" +"(values" +" for-syntax15_0" +" spec16_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64)))))" +"(values" +" #t" +" for-syntax13_1" +" spec14_1))))))" +"(let-values(((track-stxes_6" +" exp-specs_6)" +"(loop_116" +" spec14_0" +"(phase+" +" 1" +" at-phase_13)" +" protected?_15" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_6" +"(let-values(((spec17_0)" +" spec_0)" +"((temp18_6)" +"(list*" +" for-syntax13_0" +" exp-specs_6)))" +"(rebuild5.1" +" #t" +" spec17_0" +" temp18_6)))))))))" +"(if(unsafe-fx<" +" index_7" +" 4)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_66" +" for-label19_0" +" spec20_0)" +"(let-values(((s_500)" +" disarmed-spec_0))" +"(let-values(((orig-s_65)" +" s_500))" +"(let-values(((for-label19_1" +" spec20_1)" +"(let-values(((s_309)" +"(if(syntax?$1" +" s_500)" +"(syntax-e$1" +" s_500)" +" s_500)))" +"(if(pair?" +" s_309)" +"(let-values(((for-label21_0)" +"(let-values(((s_443)" +"(car" +" s_309)))" +" s_443))" +"((spec22_0)" +"(let-values(((s_27)" +"(cdr" +" s_309)))" +"(let-values(((s_28)" +"(if(syntax?$1" +" s_27)" +"(syntax-e$1" +" s_27)" +" s_27)))" +"(let-values(((flat-s_48)" +"(to-syntax-list.1" +" s_28)))" +"(if(not" +" flat-s_48)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65))" +"(let-values()" +" flat-s_48)))))))" +"(values" +" for-label21_0" +" spec22_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65)))))" +"(values" +" #t" +" for-label19_1" +" spec20_1))))))" +"(let-values(((track-stxes_7" +" exp-specs_7)" +"(loop_116" +" spec20_0" +" #f" +" protected?_15" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_7" +"(let-values(((spec23_0)" +" spec_0)" +"((temp24_10)" +"(list*" +" for-label19_0" +" exp-specs_7)))" +"(rebuild5.1" +" #t" +" spec23_0" +" temp24_10)))))))))" +"(if(unsafe-fx<" +" index_7" +" 5)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values((()" +"(begin" +"(if protected?_15" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"nested `protect' not allowed\"" +" orig-s_62" +" spec_0))" +"(void))" +"(values))))" +"(let-values(((ok?_67" +" protect25_0" +" p-spec26_0)" +"(let-values(((s_49)" +" disarmed-spec_0))" +"(let-values(((orig-s_66)" +" s_49))" +"(let-values(((protect25_1" +" p-spec26_1)" +"(let-values(((s_777)" +"(if(syntax?$1" +" s_49)" +"(syntax-e$1" +" s_49)" +" s_49)))" +"(if(pair?" +" s_777)" +"(let-values(((protect27_0)" +"(let-values(((s_506)" +"(car" +" s_777)))" +" s_506))" +"((p-spec28_0)" +"(let-values(((s_507)" +"(cdr" +" s_777)))" +"(let-values(((s_52)" +"(if(syntax?$1" +" s_507)" +"(syntax-e$1" +" s_507)" +" s_507)))" +"(let-values(((flat-s_49)" +"(to-syntax-list.1" +" s_52)))" +"(if(not" +" flat-s_49)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))" +"(let-values()" +" flat-s_49)))))))" +"(values" +" protect27_0" +" p-spec28_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66)))))" +"(values" +" #t" +" protect25_1" +" p-spec26_1))))))" +"(let-values(((track-stxes_8" +" exp-specs_8)" +"(loop_116" +" p-spec26_0" +" at-phase_13" +" #t" +" layer_6)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_8" +"(let-values(((spec29_0)" +" spec_0)" +"((temp30_7)" +"(list*" +" protect25_0" +" exp-specs_8)))" +"(rebuild5.1" +" #t" +" spec29_0" +" temp30_7))))))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_68" +" rename31_0" +" id:from32_0" +" id:to33_0)" +"(let-values(((s_315)" +" disarmed-spec_0))" +"(let-values(((orig-s_67)" +" s_315))" +"(let-values(((rename31_1" +" id:from32_1" +" id:to33_1)" +"(let-values(((s_778)" +"(if(syntax?$1" +" s_315)" +"(syntax-e$1" +" s_315)" +" s_315)))" +"(if(pair?" +" s_778)" +"(let-values(((rename34_0)" +"(let-values(((s_200)" +"(car" +" s_778)))" +" s_200))" +"((id:from35_0" +" id:to36_0)" +"(let-values(((s_59)" +"(cdr" +" s_778)))" +"(let-values(((s_404)" +"(if(syntax?$1" +" s_59)" +"(syntax-e$1" +" s_59)" +" s_59)))" +"(if(pair?" +" s_404)" +"(let-values(((id:from37_0)" +"(let-values(((s_201)" +"(car" +" s_404)))" +"(if(let-values(((or-part_215)" +"(if(syntax?$1" +" s_201)" +"(symbol?" +"(syntax-e$1" +" s_201))" +" #f)))" +"(if or-part_215" +" or-part_215" +"(symbol?" +" s_201)))" +" s_201" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_67" +" s_201))))" +"((id:to38_0)" +"(let-values(((s_60)" +"(cdr" +" s_404)))" +"(let-values(((s_61)" +"(if(syntax?$1" +" s_60)" +"(syntax-e$1" +" s_60)" +" s_60)))" +"(if(pair?" +" s_61)" +"(let-values(((id:to39_0)" +"(let-values(((s_203)" +"(car" +" s_61)))" +"(if(let-values(((or-part_395)" +"(if(syntax?$1" +" s_203)" +"(symbol?" +"(syntax-e$1" +" s_203))" +" #f)))" +"(if or-part_395" +" or-part_395" +"(symbol?" +" s_203)))" +" s_203" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_67" +" s_203))))" +"(()" +"(let-values(((s_424)" +"(cdr" +" s_61)))" +"(let-values(((s_414)" +"(if(syntax?$1" +" s_424)" +"(syntax-e$1" +" s_424)" +" s_424)))" +"(if(null?" +" s_414)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67))))))" +"(values" +" id:to39_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67))))))" +"(values" +" id:from37_0" +" id:to38_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67))))))" +"(values" +" rename34_0" +" id:from35_0" +" id:to36_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67)))))" +"(values" +" #t" +" rename31_1" +" id:from32_1" +" id:to33_1))))))" +"(begin" +"(parse-identifier!" +" id:from32_0" +" orig-s_62" +"(syntax-e$1" +" id:to33_0)" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))))))))" +"(if(unsafe-fx<" +" index_7" +" 9)" +"(if(unsafe-fx<" +" index_7" +" 7)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_69" +" struct40_0" +" id:struct41_0" +" id:field42_0)" +"(let-values(((s_521)" +" disarmed-spec_0))" +"(let-values(((orig-s_68)" +" s_521))" +"(let-values(((struct40_1" +" id:struct41_1" +" id:field42_1)" +"(let-values(((s_207)" +"(if(syntax?$1" +" s_521)" +"(syntax-e$1" +" s_521)" +" s_521)))" +"(if(pair?" +" s_207)" +"(let-values(((struct43_0)" +"(let-values(((s_209)" +"(car" +" s_207)))" +" s_209))" +"((id:struct44_0" +" id:field45_0)" +"(let-values(((s_38)" +"(cdr" +" s_207)))" +"(let-values(((s_319)" +"(if(syntax?$1" +" s_38)" +"(syntax-e$1" +" s_38)" +" s_38)))" +"(if(pair?" +" s_319)" +"(let-values(((id:struct46_0)" +"(let-values(((s_779)" +"(car" +" s_319)))" +"(if(let-values(((or-part_396)" +"(if(syntax?$1" +" s_779)" +"(symbol?" +"(syntax-e$1" +" s_779))" +" #f)))" +"(if or-part_396" +" or-part_396" +"(symbol?" +" s_779)))" +" s_779" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_68" +" s_779))))" +"((id:field47_0)" +"(let-values(((s_780)" +"(cdr" +" s_319)))" +"(let-values(((s_432)" +"(if(syntax?$1" +" s_780)" +"(syntax-e$1" +" s_780)" +" s_780)))" +"(if(pair?" +" s_432)" +"(let-values(((id:field48_0)" +"(let-values(((s_522)" +"(car" +" s_432)))" +"(let-values(((s_781)" +"(if(syntax?$1" +" s_522)" +"(syntax-e$1" +" s_522)" +" s_522)))" +"(let-values(((flat-s_50)" +"(to-syntax-list.1" +" s_781)))" +"(if(not" +" flat-s_50)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68))" +"(let-values()" +"(let-values(((id:field_0)" +"(let-values(((lst_53)" +" flat-s_50))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_53)))" +"((letrec-values(((for-loop_317)" +"(lambda(id:field_1" +" lst_272)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_272)" +"(let-values(((s_782)" +"(unsafe-car" +" lst_272))" +"((rest_240)" +"(unsafe-cdr" +" lst_272)))" +"(let-values(((id:field_2)" +"(let-values(((id:field_3)" +" id:field_1))" +"(let-values(((id:field_4)" +"(let-values()" +"(let-values(((id:field49_0)" +"(let-values()" +"(if(let-values(((or-part_397)" +"(if(syntax?$1" +" s_782)" +"(symbol?" +"(syntax-e$1" +" s_782))" +" #f)))" +"(if or-part_397" +" or-part_397" +"(symbol?" +" s_782)))" +" s_782" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_68" +" s_782)))))" +"(cons" +" id:field49_0" +" id:field_3)))))" +"(values" +" id:field_4)))))" +"(if(not" +" #f)" +"(for-loop_317" +" id:field_2" +" rest_240)" +" id:field_2)))" +" id:field_1)))))" +" for-loop_317)" +" null" +" lst_53)))))" +"(reverse$1" +" id:field_0))))))))" +"(()" +"(let-values(((s_527)" +"(cdr" +" s_432)))" +"(let-values(((s_528)" +"(if(syntax?$1" +" s_527)" +"(syntax-e$1" +" s_527)" +" s_527)))" +"(if(null?" +" s_528)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68))))))" +"(values" +" id:field48_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68))))))" +"(values" +" id:struct46_0" +" id:field47_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68))))))" +"(values" +" struct43_0" +" id:struct44_0" +" id:field45_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68)))))" +"(values" +" #t" +" struct40_1" +" id:struct41_1" +" id:field42_1))))))" +"(begin" +"(parse-struct!" +" id:struct41_0" +" orig-s_62" +" id:field42_0" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))))" +"(if(unsafe-fx<" +" index_7" +" 8)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_70" +" all-from50_0" +" mod-path51_0)" +"(let-values(((s_321)" +" disarmed-spec_0))" +"(let-values(((orig-s_69)" +" s_321))" +"(let-values(((all-from50_1" +" mod-path51_1)" +"(let-values(((s_323)" +"(if(syntax?$1" +" s_321)" +"(syntax-e$1" +" s_321)" +" s_321)))" +"(if(pair?" +" s_323)" +"(let-values(((all-from52_0)" +"(let-values(((s_783)" +"(car" +" s_323)))" +" s_783))" +"((mod-path53_0)" +"(let-values(((s_427)" +"(cdr" +" s_323)))" +"(let-values(((s_214)" +"(if(syntax?$1" +" s_427)" +"(syntax-e$1" +" s_427)" +" s_427)))" +"(if(pair?" +" s_214)" +"(let-values(((mod-path54_0)" +"(let-values(((s_428)" +"(car" +" s_214)))" +" s_428))" +"(()" +"(let-values(((s_215)" +"(cdr" +" s_214)))" +"(let-values(((s_169)" +"(if(syntax?$1" +" s_215)" +"(syntax-e$1" +" s_215)" +" s_215)))" +"(if(null?" +" s_169)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_69))))))" +"(values" +" mod-path54_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_69))))))" +"(values" +" all-from52_0" +" mod-path53_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_69)))))" +"(values" +" #t" +" all-from50_1" +" mod-path51_1))))))" +"(begin" +"(parse-all-from" +" mod-path51_0" +" orig-s_62" +" self_30" +" null" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15" +" ctx_106)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_71" +" all-from-except55_0" +" mod-path56_0" +" id57_1)" +"(let-values(((s_103)" +" disarmed-spec_0))" +"(let-values(((orig-s_70)" +" s_103))" +"(let-values(((all-from-except55_1" +" mod-path56_1" +" id57_2)" +"(let-values(((s_105)" +"(if(syntax?$1" +" s_103)" +"(syntax-e$1" +" s_103)" +" s_103)))" +"(if(pair?" +" s_105)" +"(let-values(((all-from-except58_0)" +"(let-values(((s_218)" +"(car" +" s_105)))" +" s_218))" +"((mod-path59_0" +" id60_1)" +"(let-values(((s_784)" +"(cdr" +" s_105)))" +"(let-values(((s_785)" +"(if(syntax?$1" +" s_784)" +"(syntax-e$1" +" s_784)" +" s_784)))" +"(if(pair?" +" s_785)" +"(let-values(((mod-path61_0)" +"(let-values(((s_220)" +"(car" +" s_785)))" +" s_220))" +"((id62_0)" +"(let-values(((s_221)" +"(cdr" +" s_785)))" +"(let-values(((s_326)" +"(if(syntax?$1" +" s_221)" +"(syntax-e$1" +" s_221)" +" s_221)))" +"(let-values(((flat-s_51)" +"(to-syntax-list.1" +" s_326)))" +"(if(not" +" flat-s_51)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70))" +"(let-values()" +"(let-values(((id_129)" +"(let-values(((lst_407)" +" flat-s_51))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_407)))" +"((letrec-values(((for-loop_318)" +"(lambda(id_130" +" lst_408)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_408)" +"(let-values(((s_786)" +"(unsafe-car" +" lst_408))" +"((rest_241)" +"(unsafe-cdr" +" lst_408)))" +"(let-values(((id_131)" +"(let-values(((id_132)" +" id_130))" +"(let-values(((id_133)" +"(let-values()" +"(let-values(((id63_0)" +"(let-values()" +"(if(let-values(((or-part_398)" +"(if(syntax?$1" +" s_786)" +"(symbol?" +"(syntax-e$1" +" s_786))" +" #f)))" +"(if or-part_398" +" or-part_398" +"(symbol?" +" s_786)))" +" s_786" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_70" +" s_786)))))" +"(cons" +" id63_0" +" id_132)))))" +"(values" +" id_133)))))" +"(if(not" +" #f)" +"(for-loop_318" +" id_131" +" rest_241)" +" id_131)))" +" id_130)))))" +" for-loop_318)" +" null" +" lst_407)))))" +"(reverse$1" +" id_129)))))))))" +"(values" +" mod-path61_0" +" id62_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70))))))" +"(values" +" all-from-except58_0" +" mod-path59_0" +" id60_1))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70)))))" +"(values" +" #t" +" all-from-except55_1" +" mod-path56_1" +" id57_2))))))" +"(begin" +"(parse-all-from" +" mod-path56_0" +" orig-s_62" +" self_30" +" id57_1" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15" +" ctx_106)" +"(values" +" null" +"(list" +" spec_0))))))))" +"(if(unsafe-fx<" +" index_7" +" 11)" +"(if(unsafe-fx<" +" index_7" +" 10)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_22" +" all-defined64_0)" +"(let-values(((s_114)" +" disarmed-spec_0))" +"(let-values(((orig-s_71)" +" s_114))" +"(let-values(((all-defined64_1)" +"(let-values(((s_787)" +"(if(syntax?$1" +" s_114)" +"(syntax-e$1" +" s_114)" +" s_114)))" +"(if(pair?" +" s_787)" +"(let-values(((all-defined65_0)" +"(let-values(((s_438)" +"(car" +" s_787)))" +" s_438))" +"(()" +"(let-values(((s_224)" +"(cdr" +" s_787)))" +"(let-values(((s_788)" +"(if(syntax?$1" +" s_224)" +"(syntax-e$1" +" s_224)" +" s_224)))" +"(if(null?" +" s_788)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_71))))))" +"(values" +" all-defined65_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_71)))))" +"(values" +" #t" +" all-defined64_1))))))" +"(begin" +"(parse-all-from-module" +" self_30" +" spec_0" +" orig-s_62" +" null" +" #f" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_72" +" all-defined-except66_0" +" id67_0)" +"(let-values(((s_228)" +" disarmed-spec_0))" +"(let-values(((orig-s_72)" +" s_228))" +"(let-values(((all-defined-except66_1" +" id67_1)" +"(let-values(((s_789)" +"(if(syntax?$1" +" s_228)" +"(syntax-e$1" +" s_228)" +" s_228)))" +"(if(pair?" +" s_789)" +"(let-values(((all-defined-except68_0)" +"(let-values(((s_790)" +"(car" +" s_789)))" +" s_790))" +"((id69_0)" +"(let-values(((s_791)" +"(cdr" +" s_789)))" +"(let-values(((s_463)" +"(if(syntax?$1" +" s_791)" +"(syntax-e$1" +" s_791)" +" s_791)))" +"(let-values(((flat-s_52)" +"(to-syntax-list.1" +" s_463)))" +"(if(not" +" flat-s_52)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72))" +"(let-values()" +"(let-values(((id_134)" +"(let-values(((lst_39)" +" flat-s_52))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_39)))" +"((letrec-values(((for-loop_136)" +"(lambda(id_135" +" lst_409)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_409)" +"(let-values(((s_464)" +"(unsafe-car" +" lst_409))" +"((rest_242)" +"(unsafe-cdr" +" lst_409)))" +"(let-values(((id_136)" +"(let-values(((id_137)" +" id_135))" +"(let-values(((id_138)" +"(let-values()" +"(let-values(((id70_0)" +"(let-values()" +"(if(let-values(((or-part_289)" +"(if(syntax?$1" +" s_464)" +"(symbol?" +"(syntax-e$1" +" s_464))" +" #f)))" +"(if or-part_289" +" or-part_289" +"(symbol?" +" s_464)))" +" s_464" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_72" +" s_464)))))" +"(cons" +" id70_0" +" id_137)))))" +"(values" +" id_138)))))" +"(if(not" +" #f)" +"(for-loop_136" +" id_136" +" rest_242)" +" id_136)))" +" id_135)))))" +" for-loop_136)" +" null" +" lst_39)))))" +"(reverse$1" +" id_134)))))))))" +"(values" +" all-defined-except68_0" +" id69_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72)))))" +"(values" +" #t" +" all-defined-except66_1" +" id67_1))))))" +"(begin" +"(parse-all-from-module" +" self_30" +" spec_0" +" orig-s_62" +" id67_0" +" #f" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0)))))))" +"(if(unsafe-fx<" +" index_7" +" 12)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_73" +" prefix-all-defined71_0" +" id:prefix72_0)" +"(let-values(((s_232)" +" disarmed-spec_0))" +"(let-values(((orig-s_73)" +" s_232))" +"(let-values(((prefix-all-defined71_1" +" id:prefix72_1)" +"(let-values(((s_132)" +"(if(syntax?$1" +" s_232)" +"(syntax-e$1" +" s_232)" +" s_232)))" +"(if(pair?" +" s_132)" +"(let-values(((prefix-all-defined73_0)" +"(let-values(((s_330)" +"(car" +" s_132)))" +" s_330))" +"((id:prefix74_0)" +"(let-values(((s_133)" +"(cdr" +" s_132)))" +"(let-values(((s_236)" +"(if(syntax?$1" +" s_133)" +"(syntax-e$1" +" s_133)" +" s_133)))" +"(if(pair?" +" s_236)" +"(let-values(((id:prefix75_0)" +"(let-values(((s_331)" +"(car" +" s_236)))" +"(if(let-values(((or-part_291)" +"(if(syntax?$1" +" s_331)" +"(symbol?" +"(syntax-e$1" +" s_331))" +" #f)))" +"(if or-part_291" +" or-part_291" +"(symbol?" +" s_331)))" +" s_331" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_73" +" s_331))))" +"(()" +"(let-values(((s_134)" +"(cdr" +" s_236)))" +"(let-values(((s_333)" +"(if(syntax?$1" +" s_134)" +"(syntax-e$1" +" s_134)" +" s_134)))" +"(if(null?" +" s_333)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73))))))" +"(values" +" id:prefix75_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73))))))" +"(values" +" prefix-all-defined73_0" +" id:prefix74_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73)))))" +"(values" +" #t" +" prefix-all-defined71_1" +" id:prefix72_1))))))" +"(begin" +"(parse-all-from-module" +" self_30" +" spec_0" +" orig-s_62" +" null" +"(syntax-e$1" +" id:prefix72_0)" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))))" +"(if(unsafe-fx<" +" index_7" +" 13)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_74" +" prefix-all-defined-except76_0" +" id:prefix77_0" +" id78_0)" +"(let-values(((s_792)" +" disarmed-spec_0))" +"(let-values(((orig-s_74)" +" s_792))" +"(let-values(((prefix-all-defined-except76_1" +" id:prefix77_1" +" id78_1)" +"(let-values(((s_793)" +"(if(syntax?$1" +" s_792)" +"(syntax-e$1" +" s_792)" +" s_792)))" +"(if(pair?" +" s_793)" +"(let-values(((prefix-all-defined-except79_0)" +"(let-values(((s_534)" +"(car" +" s_793)))" +" s_534))" +"((id:prefix80_0" +" id81_0)" +"(let-values(((s_794)" +"(cdr" +" s_793)))" +"(let-values(((s_243)" +"(if(syntax?$1" +" s_794)" +"(syntax-e$1" +" s_794)" +" s_794)))" +"(if(pair?" +" s_243)" +"(let-values(((id:prefix82_0)" +"(let-values(((s_535)" +"(car" +" s_243)))" +"(if(let-values(((or-part_344)" +"(if(syntax?$1" +" s_535)" +"(symbol?" +"(syntax-e$1" +" s_535))" +" #f)))" +"(if or-part_344" +" or-part_344" +"(symbol?" +" s_535)))" +" s_535" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_74" +" s_535))))" +"((id83_2)" +"(let-values(((s_348)" +"(cdr" +" s_243)))" +"(let-values(((s_795)" +"(if(syntax?$1" +" s_348)" +"(syntax-e$1" +" s_348)" +" s_348)))" +"(let-values(((flat-s_53)" +"(to-syntax-list.1" +" s_795)))" +"(if(not" +" flat-s_53)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_74))" +"(let-values()" +"(let-values(((id_88)" +"(let-values(((lst_410)" +" flat-s_53))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_410)))" +"((letrec-values(((for-loop_319)" +"(lambda(id_37" +" lst_411)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_411)" +"(let-values(((s_796)" +"(unsafe-car" +" lst_411))" +"((rest_243)" +"(unsafe-cdr" +" lst_411)))" +"(let-values(((id_139)" +"(let-values(((id_140)" +" id_37))" +"(let-values(((id_141)" +"(let-values()" +"(let-values(((id84_1)" +"(let-values()" +"(if(let-values(((or-part_399)" +"(if(syntax?$1" +" s_796)" +"(symbol?" +"(syntax-e$1" +" s_796))" +" #f)))" +"(if or-part_399" +" or-part_399" +"(symbol?" +" s_796)))" +" s_796" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_74" +" s_796)))))" +"(cons" +" id84_1" +" id_140)))))" +"(values" +" id_141)))))" +"(if(not" +" #f)" +"(for-loop_319" +" id_139" +" rest_243)" +" id_139)))" +" id_37)))))" +" for-loop_319)" +" null" +" lst_410)))))" +"(reverse$1" +" id_88)))))))))" +"(values" +" id:prefix82_0" +" id83_2))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_74))))))" +"(values" +" prefix-all-defined-except79_0" +" id:prefix80_0" +" id81_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_74)))))" +"(values" +" #t" +" prefix-all-defined-except76_1" +" id:prefix77_1" +" id78_1))))))" +"(begin" +"(parse-all-from-module" +" self_30" +" spec_0" +" orig-s_62" +" id78_0" +"(syntax-e$1" +" id:prefix77_0)" +" at-phase_13" +" ns_125" +" rp_1" +" protected?_15)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values(((ok?_75" +" expand85_0" +" id86_1" +" datum87_0)" +"(let-values(((s_797)" +" disarmed-spec_0))" +"(let-values(((orig-s_75)" +" s_797))" +"(let-values(((expand85_1" +" id86_2" +" datum87_1)" +"(let-values(((s_798)" +"(if(syntax?$1" +" s_797)" +"(syntax-e$1" +" s_797)" +" s_797)))" +"(if(pair?" +" s_798)" +"(let-values(((expand88_0)" +"(let-values(((s_367)" +"(car" +" s_798)))" +" s_367))" +"((id89_1" +" datum90_0)" +"(let-values(((s_368)" +"(cdr" +" s_798)))" +"(let-values(((s_799)" +"(if(syntax?$1" +" s_368)" +"(syntax-e$1" +" s_368)" +" s_368)))" +"(if(pair?" +" s_799)" +"(let-values(((id91_1" +" datum92_0)" +"(let-values(((s_370)" +"(car" +" s_799)))" +"(let-values(((s_371)" +"(if(syntax?$1" +" s_370)" +"(syntax-e$1" +" s_370)" +" s_370)))" +"(if(pair?" +" s_371)" +"(let-values(((id93_2)" +"(let-values(((s_373)" +"(car" +" s_371)))" +"(if(let-values(((or-part_400)" +"(if(syntax?$1" +" s_373)" +"(symbol?" +"(syntax-e$1" +" s_373))" +" #f)))" +"(if or-part_400" +" or-part_400" +"(symbol?" +" s_373)))" +" s_373" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_75" +" s_373))))" +"((datum94_0)" +"(let-values(((s_546)" +"(cdr" +" s_371)))" +" s_546)))" +"(values" +" id93_2" +" datum94_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_75)))))" +"(()" +"(let-values(((s_547)" +"(cdr" +" s_799)))" +"(let-values(((s_800)" +"(if(syntax?$1" +" s_547)" +"(syntax-e$1" +" s_547)" +" s_547)))" +"(if(null?" +" s_800)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_75))))))" +"(values" +" id91_1" +" datum92_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_75))))))" +"(values" +" expand88_0" +" id89_1" +" datum90_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_75)))))" +"(values" +" #t" +" expand85_1" +" id86_2" +" datum87_1))))))" +"(let-values(((ok?_76" +" expand95_0" +" form96_0)" +"(let-values(((s_801)" +" disarmed-spec_0))" +"(let-values(((orig-s_76)" +" s_801))" +"(let-values(((expand95_1" +" form96_1)" +"(let-values(((s_376)" +"(if(syntax?$1" +" s_801)" +"(syntax-e$1" +" s_801)" +" s_801)))" +"(if(pair?" +" s_376)" +"(let-values(((expand97_0)" +"(let-values(((s_259)" +"(car" +" s_376)))" +" s_259))" +"((form98_0)" +"(let-values(((s_377)" +"(cdr" +" s_376)))" +"(let-values(((s_378)" +"(if(syntax?$1" +" s_377)" +"(syntax-e$1" +" s_377)" +" s_377)))" +"(if(pair?" +" s_378)" +"(let-values(((form99_0)" +"(let-values(((s_379)" +"(car" +" s_378)))" +" s_379))" +"(()" +"(let-values(((s_380)" +"(cdr" +" s_378)))" +"(let-values(((s_260)" +"(if(syntax?$1" +" s_380)" +"(syntax-e$1" +" s_380)" +" s_380)))" +"(if(null?" +" s_260)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_76))))))" +"(values" +" form99_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_76))))))" +"(values" +" expand97_0" +" form98_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_76)))))" +"(values" +" #t" +" expand95_1" +" form96_1))))))" +"(let-values(((exp-spec_0)" +"(let-values(((temp104_3)" +" form96_0)" +"((temp105_5)" +"(let-values(((v_266)" +" ctx_106))" +"(let-values(((the-struct_99)" +" v_266))" +"(if(expand-context/outer?" +" the-struct_99)" +"(let-values(((def-ctx-scopes106_0)" +" #f)" +"((inner107_0)" +"(let-values(((the-struct_100)" +"(root-expand-context/outer-inner" +" v_266)))" +"(if(expand-context/inner?" +" the-struct_100)" +"(let-values(((stops108_0)" +"(free-id-set" +" at-phase_13" +"(list" +"(core-id" +" 'begin" +" at-phase_13)))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_100)" +"(root-expand-context/inner-module-scopes" +" the-struct_100)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_100)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_100)" +"(root-expand-context/inner-defined-syms" +" the-struct_100)" +"(root-expand-context/inner-counter" +" the-struct_100)" +"(root-expand-context/inner-lift-key" +" the-struct_100)" +"(expand-context/inner-to-parsed?" +" the-struct_100)" +"(expand-context/inner-phase" +" the-struct_100)" +"(expand-context/inner-namespace" +" the-struct_100)" +"(expand-context/inner-just-once?" +" the-struct_100)" +"(expand-context/inner-module-begin-k" +" the-struct_100)" +"(expand-context/inner-allow-unbound?" +" the-struct_100)" +"(expand-context/inner-in-local-expand?" +" the-struct_100)" +"(expand-context/inner-keep-#%expression?" +" the-struct_100)" +" stops108_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_100)" +"(expand-context/inner-lifts" +" the-struct_100)" +"(expand-context/inner-lift-envs" +" the-struct_100)" +"(expand-context/inner-module-lifts" +" the-struct_100)" +"(expand-context/inner-require-lifts" +" the-struct_100)" +"(expand-context/inner-to-module-lifts" +" the-struct_100)" +"(expand-context/inner-requires+provides" +" the-struct_100)" +"(expand-context/inner-observer" +" the-struct_100)" +"(expand-context/inner-for-serializable?" +" the-struct_100)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_100)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_100)))))" +"(expand-context/outer1.1" +" inner107_0" +"(root-expand-context/outer-post-expansion" +" the-struct_99)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_99)" +"(root-expand-context/outer-frame-id" +" the-struct_99)" +"(expand-context/outer-context" +" the-struct_99)" +"(expand-context/outer-env" +" the-struct_99)" +"(expand-context/outer-scopes" +" the-struct_99)" +" def-ctx-scopes106_0" +"(expand-context/outer-binding-layer" +" the-struct_99)" +"(expand-context/outer-reference-records" +" the-struct_99)" +"(expand-context/outer-only-immediate?" +" the-struct_99)" +"(expand-context/outer-need-eventually-defined" +" the-struct_99)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_99)" +"(expand-context/outer-current-use-scopes" +" the-struct_99)" +"(expand-context/outer-name" +" the-struct_99)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_99))))))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp104_3" +" temp105_5))))" +"(let-values((()" +"(begin" +"(if(if(pair?" +"(syntax-e$1" +" exp-spec_0))" +"(if(identifier?" +"(car" +"(syntax-e$1" +" exp-spec_0)))" +"(eq?" +" 'begin" +"(core-form-sym" +" exp-spec_0" +" at-phase_13))" +" #f)" +" #f)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"expansion was not a `begin' sequence\"" +" orig-s_62" +" spec_0)))" +"(values))))" +"(let-values(((ok?_77" +" begin100_0" +" spec101_0)" +"(let-values(((s_802)" +" exp-spec_0))" +"(let-values(((orig-s_77)" +" s_802))" +"(let-values(((begin100_1" +" spec101_1)" +"(let-values(((s_266)" +"(if(syntax?$1" +" s_802)" +"(syntax-e$1" +" s_802)" +" s_802)))" +"(if(pair?" +" s_266)" +"(let-values(((begin102_0)" +"(let-values(((s_267)" +"(car" +" s_266)))" +" s_267))" +"((spec103_0)" +"(let-values(((s_803)" +"(cdr" +" s_266)))" +"(let-values(((s_268)" +"(if(syntax?$1" +" s_803)" +"(syntax-e$1" +" s_803)" +" s_803)))" +"(let-values(((flat-s_54)" +"(to-syntax-list.1" +" s_268)))" +"(if(not" +" flat-s_54)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_77))" +"(let-values()" +" flat-s_54)))))))" +"(values" +" begin102_0" +" spec103_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_77)))))" +"(values" +" #t" +" begin100_1" +" spec101_1))))))" +"(let-values(((track-stxes_9" +" exp-specs_9)" +"(loop_116" +" spec101_0" +" at-phase_13" +" protected?_15" +" layer_6)))" +"(values" +"(list*" +" spec_0" +" exp-spec_0" +" track-stxes_9)" +" exp-specs_9)))))))))))))))))))))" +"(values" +"(cons" +" track-stxes1_0" +" track-stxes_3)" +"(cons" +" exp-specs2_0" +" exp-specs_3))))))" +"(values" +" track-stxes_4" +" exp-specs_4)))))" +"(if(not #f)" +"(for-loop_98" +" track-stxes_2" +" exp-specs_2" +" rest_239)" +"(values" +" track-stxes_2" +" exp-specs_2))))" +"(values" +" track-stxes_1" +" exp-specs_1))))))" +" for-loop_98)" +" null" +" null" +" lst_77)))))" +"(values(reverse$1 track-stxes_0)(reverse$1 exp-specs_0)))))" +"(values(apply append track-stxess_0)(apply append exp-specss_0)))))))" +" loop_116)" +" specs_0" +" phase_45" +" #f" +" 'raw)))))" +"(define-values" +"(parse-identifier!)" +"(lambda(spec_1 orig-s_78 sym_106 at-phase_14 ns_126 rp_2 protected?_16)" +"(begin" +"(let-values(((b_94)(resolve+shift/extra-inspector spec_1 at-phase_14 ns_126)))" +"(let-values((()" +"(begin" +"(if b_94" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"provided identifier is not defined or required\"" +" orig-s_78" +" spec_1)))" +"(values))))" +"(let-values(((as-transformer?_7)(binding-for-transformer? b_94 spec_1 at-phase_14 ns_126)))" +"(let-values(((immed-b_0)" +"(let-values(((spec118_0) spec_1)((at-phase119_0) at-phase_14)((temp120_4) #t))" +"(resolve+shift28.1 #f #f null temp120_4 #f spec118_0 at-phase119_0))))" +"(let-values(((rp109_0) rp_2)" +"((sym110_0) sym_106)" +"((at-phase111_0) at-phase_14)" +"((b112_0) b_94)" +"((immed-b113_0) immed-b_0)" +"((spec114_0) spec_1)" +"((orig-s115_0) orig-s_78)" +"((protected?116_0) protected?_16)" +"((as-transformer?117_0) as-transformer?_7))" +"(add-provide!117.1" +" protected?116_0" +" as-transformer?117_0" +" rp109_0" +" sym110_0" +" at-phase111_0" +" b112_0" +" immed-b113_0" +" spec114_0" +" orig-s115_0)))))))))" +"(define-values" +"(parse-struct!)" +"(lambda(id:struct_0 orig-s_79 fields_0 at-phase_15 ns_127 rp_3 protected?_17)" +"(begin" +"(let-values(((mk_0)" +"(lambda(fmt_1)" +"(begin" +" 'mk" +"(let-values(((sym_107)(string->symbol(format fmt_1(syntax-e$1 id:struct_0)))))" +"(datum->syntax$1 id:struct_0 sym_107 id:struct_0))))))" +"(let-values(((mk2_0)" +"(lambda(fmt_2 field-id_0)" +"(begin" +" 'mk2" +"(let-values(((sym_108)" +"(string->symbol" +"(format fmt_2(syntax-e$1 id:struct_0)(syntax-e$1 field-id_0)))))" +"(datum->syntax$1 id:struct_0 sym_108 id:struct_0))))))" +"(begin" +" (let-values (((lst_412) (list \"~a\" \"make-~a\" \"struct:~a\" \"~a?\")))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_412)))" +"((letrec-values(((for-loop_320)" +"(lambda(lst_413)" +"(begin" +" 'for-loop" +"(if(pair? lst_413)" +"(let-values(((fmt_3)(unsafe-car lst_413))((rest_244)(unsafe-cdr lst_413)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_142)(mk_0 fmt_3)))" +"(parse-identifier!" +" id_142" +" orig-s_79" +"(syntax-e$1 id_142)" +" at-phase_15" +" ns_127" +" rp_3" +" protected?_17)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_320 rest_244)(values))))" +"(values))))))" +" for-loop_320)" +" lst_412)))" +"(void)" +"(let-values(((lst_414) fields_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_414)))" +"((letrec-values(((for-loop_321)" +"(lambda(lst_415)" +"(begin" +" 'for-loop" +"(if(pair? lst_415)" +"(let-values(((field_0)(unsafe-car lst_415))((rest_245)(unsafe-cdr lst_415)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((get-id_0)" +" (mk2_0 \"~a-~a\" field_0)))" +"(let-values(((set-id_0)" +"(mk2_0" +" \"set-~a-~a!\"" +" field_0)))" +"(begin" +"(parse-identifier!" +" get-id_0" +" orig-s_79" +"(syntax-e$1 get-id_0)" +" at-phase_15" +" ns_127" +" rp_3" +" protected?_17)" +"(parse-identifier!" +" set-id_0" +" orig-s_79" +"(syntax-e$1 set-id_0)" +" at-phase_15" +" ns_127" +" rp_3" +" protected?_17)))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_321 rest_245)(values))))" +"(values))))))" +" for-loop_321)" +" lst_414)))" +"(void)))))))" +"(define-values" +"(parse-all-from)" +"(lambda(mod-path-stx_0 orig-s_80 self_31 except-ids_0 at-phase_16 ns_128 rp_4 protected?_18 ctx_107)" +"(begin" +"(let-values(((mod-path_33)(syntax->datum$1 mod-path-stx_0)))" +"(let-values((()" +"(begin" +"(if(1/module-path? mod-path_33)" +"(void)" +"(let-values()" +" (raise-syntax-error$1 provide-form-name \"not a module path\" orig-s_80 mod-path-stx_0)))" +"(values))))" +"(let-values(((mpi_53)(module-path->mpi/context mod-path_33 ctx_107)))" +"(parse-all-from-module mpi_53 #f orig-s_80 except-ids_0 #f at-phase_16 ns_128 rp_4 protected?_18)))))))" +"(define-values" +"(parse-all-from-module)" +"(lambda(mpi_54 matching-stx_0 orig-s_81 except-ids_1 prefix-sym_0 at-phase_17 ns_129 rp_5 protected?_19)" +"(begin" +"(let-values(((requireds_2)(extract-module-requires rp_5 mpi_54 at-phase_17)))" +"(let-values(((phase-desc_0)" +"(lambda()" +"(begin" +" 'phase-desc" +"(if(zero-phase? at-phase_17)" +" (let-values () \"\")" +"(if(label-phase? at-phase_17)" +" (let-values () \" for-label\")" +" (let-values () (format \" for phase ~a\" at-phase_17))))))))" +"(let-values((()" +"(begin" +"(if requireds_2" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" (format \"cannot provide from a module without a matching require~a\" (phase-desc_0))" +" orig-s_81" +" matching-stx_0)))" +"(values))))" +"(let-values(((add-prefix_1)" +"(lambda(sym_109)" +"(begin" +" 'add-prefix" +" (if prefix-sym_0 (string->symbol (format \"~a~a\" prefix-sym_0 sym_109)) sym_109)))))" +"(let-values(((found_0)(make-hasheq)))" +"(begin" +"(let-values(((lst_416) requireds_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_416)))" +"((letrec-values(((for-loop_322)" +"(lambda(lst_417)" +"(begin" +" 'for-loop" +"(if(pair? lst_417)" +"(let-values(((i_184)(unsafe-car lst_417))" +"((rest_246)(unsafe-cdr lst_417)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_143)" +"(required-id i_184)))" +"(let-values(((phase_143)" +"(required-phase" +" i_184)))" +"(if(let-values(((or-part_401)" +"(if matching-stx_0" +"(not" +"(if(eqv?" +" phase_143" +" at-phase_17)" +"(free-identifier=?$1" +" id_143" +"(datum->syntax$1" +" matching-stx_0" +"(syntax-e$1" +" id_143))" +" phase_143" +" phase_143)" +" #f))" +" #f)))" +"(if or-part_401" +" or-part_401" +"(let-values(((lst_418)" +" except-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_418)))" +"((letrec-values(((for-loop_323)" +"(lambda(result_127" +" lst_419)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_419)" +"(let-values(((except-id_0)" +"(unsafe-car" +" lst_419))" +"((rest_247)" +"(unsafe-cdr" +" lst_419)))" +"(let-values(((result_128)" +"(let-values()" +"(let-values(((result_129)" +"(let-values()" +"(let-values()" +"(if(free-identifier=?$1" +" id_143" +" except-id_0" +" phase_143" +" phase_143)" +"(hash-set!" +" found_0" +" except-id_0" +" #t)" +" #f)))))" +"(values" +" result_129)))))" +"(if(if(not" +"((lambda x_99" +" result_128)" +" except-id_0))" +"(not" +" #f)" +" #f)" +"(for-loop_323" +" result_128" +" rest_247)" +" result_128)))" +" result_127)))))" +" for-loop_323)" +" #f" +" lst_418)))))" +"(void)" +"(let-values()" +"(let-values(((b_95)" +"(resolve+shift/extra-inspector" +" id_143" +" phase_143" +" ns_129)))" +"(let-values(((immed-b_1)" +"(let-values(((id130_0)" +" id_143)" +"((phase131_0)" +" phase_143)" +"((temp132_2)" +" #t))" +"(resolve+shift28.1" +" #f" +" #f" +" null" +" temp132_2" +" #f" +" id130_0" +" phase131_0))))" +"(let-values(((rp121_0)" +" rp_5)" +"((temp122_1)" +"(add-prefix_1" +"(syntax-e$1" +" id_143)))" +"((phase123_0)" +" phase_143)" +"((b124_0)" +" b_95)" +"((immed-b125_0)" +" immed-b_1)" +"((id126_1)" +" id_143)" +"((orig-s127_0)" +" orig-s_81)" +"((protected?128_0)" +" protected?_19)" +"((temp129_2)" +"(required-as-transformer?" +" i_184)))" +"(add-provide!117.1" +" protected?128_0" +" temp129_2" +" rp121_0" +" temp122_1" +" phase123_0" +" b124_0" +" immed-b125_0" +" id126_1" +" orig-s127_0)))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_322 rest_246)(values))))" +"(values))))))" +" for-loop_322)" +" lst_416)))" +"(void)" +"(if(=(hash-count found_0)(length except-ids_1))" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_420) except-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_420)))" +"((letrec-values(((for-loop_324)" +"(lambda(lst_421)" +"(begin" +" 'for-loop" +"(if(pair? lst_421)" +"(let-values(((except-id_1)(unsafe-car lst_421))" +"((rest_248)(unsafe-cdr lst_421)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(let-values(((or-part_402)" +"(hash-ref" +" found_0" +" except-id_1" +" #f)))" +"(if or-part_402" +" or-part_402" +"(let-values(((lst_422)" +" requireds_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_422)))" +"((letrec-values(((for-loop_325)" +"(lambda(result_130" +" lst_423)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_423)" +"(let-values(((i_185)" +"(unsafe-car" +" lst_423))" +"((rest_249)" +"(unsafe-cdr" +" lst_423)))" +"(let-values(((result_131)" +"(let-values()" +"(let-values(((result_132)" +"(let-values()" +"(let-values()" +"(let-values(((id_144)" +"(required-id" +" i_185)))" +"(let-values(((phase_144)" +"(required-phase" +" i_185)))" +"(free-identifier=?$1" +" id_144" +" except-id_1" +" phase_144" +" phase_144)))))))" +"(values" +" result_132)))))" +"(if(if(not" +"((lambda x_100" +" result_131)" +" i_185))" +"(not" +" #f)" +" #f)" +"(for-loop_325" +" result_131" +" rest_249)" +" result_131)))" +" result_130)))))" +" for-loop_325)" +" #f" +" lst_422)))))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +"(format" +"(if matching-stx_0" +" \"excluded identifier was not defined or required in the module~a\"" +" \"excluded identifier was not required from the specified module~a\")" +"(phase-desc_0))" +" orig-s_81" +" except-id_1))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_324 rest_248)(values))))" +"(values))))))" +" for-loop_324)" +" lst_420)))" +"(void)))))))))))))" +"(define-values" +"(check-cross-phase-persistent-form)" +"(lambda(bodys_13 self-mpi_6)" +"(begin" +"(letrec-values(((check-body_0)" +"(lambda(bodys_14)" +"(begin" +" 'check-body" +"(begin" +"(let-values(((lst_424) bodys_14))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_424)))" +"((letrec-values(((for-loop_326)" +"(lambda(lst_85)" +"(begin" +" 'for-loop" +"(if(pair? lst_85)" +"(let-values(((body_19)(unsafe-car lst_85))" +"((rest_40)(unsafe-cdr lst_85)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((p_46)" +"(if(expanded+parsed?" +" body_19)" +"(expanded+parsed-parsed" +" body_19)" +" body_19)))" +"(if(parsed-define-values?" +" p_46)" +"(let-values()" +"(check-expr_0" +"(parsed-define-values-rhs" +" p_46)" +"(length" +"(parsed-define-values-syms" +" p_46))" +" p_46))" +"(if(let-values(((or-part_217)" +"(parsed-#%declare?" +" p_46)))" +"(if or-part_217" +" or-part_217" +"(let-values(((or-part_3)" +"(parsed-module?" +" p_46)))" +"(if or-part_3" +" or-part_3" +"(syntax?$1" +" p_46)))))" +"(let-values()" +"(void))" +"(let-values()" +"(disallow" +" p_46))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_326 rest_40)(values))))" +"(values))))))" +" for-loop_326)" +" lst_424)))" +"(void)))))" +"((check-expr_0)" +"(lambda(e_91 num-results_0 enclosing_15)" +"(begin" +" 'check-expr" +"(if(parsed-lambda? e_91)" +"(let-values()" +"(begin(check-count 1 num-results_0 enclosing_15)(check-no-disallowed-expr_0 e_91)))" +"(if(parsed-case-lambda? e_91)" +"(let-values()" +"(begin(check-count 1 num-results_0 enclosing_15)(check-no-disallowed-expr_0 e_91)))" +"(if(parsed-quote? e_91)" +"(let-values()" +"(begin" +"(check-datum(parsed-quote-datum e_91) e_91)" +"(check-count 1 num-results_0 enclosing_15)))" +"(if(parsed-app? e_91)" +"(let-values()" +"(let-values(((rands_1)(parsed-app-rands e_91)))" +"(begin" +"(let-values(((lst_78) rands_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_78)))" +"((letrec-values(((for-loop_327)" +"(lambda(lst_86)" +"(begin" +" 'for-loop" +"(if(pair? lst_86)" +"(let-values(((rand_0)(unsafe-car lst_86))" +"((rest_250)(unsafe-cdr lst_86)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-expr_0" +" rand_0" +" 1" +" e_91))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_327 rest_250)" +"(values))))" +"(values))))))" +" for-loop_327)" +" lst_78)))" +"(void)" +"(let-values(((tmp_63)(cross-phase-primitive-name(parsed-app-rator e_91))))" +"(if(if(equal? tmp_63 'cons) #t(equal? tmp_63 'list))" +"(let-values()(check-count 1 num-results_0 enclosing_15))" +"(if(equal? tmp_63 'make-struct-type)" +"(let-values()(check-count 5 num-results_0 enclosing_15))" +"(if(equal? tmp_63 'make-struct-type-property)" +"(let-values()(check-count 3 num-results_0 enclosing_15))" +"(if(equal? tmp_63 'gensym)" +"(let-values()" +"(if(let-values(((or-part_91)(= 0(length rands_1))))" +"(if or-part_91" +" or-part_91" +"(if(= 1(length rands_1))" +"(quoted-string?(car rands_1))" +" #f)))" +"(void)" +"(let-values()(disallow e_91))))" +"(if(equal? tmp_63 'string->uninterned-symbol)" +"(let-values()" +"(if(if(= 1(length rands_1))(quoted-string?(car rands_1)) #f)" +"(void)" +"(let-values()(disallow e_91))))" +"(let-values()(disallow e_91)))))))))))" +"(let-values()(check-no-disallowed-expr_0 e_91)))))))))" +"((check-no-disallowed-expr_0)" +"(lambda(e_92)" +"(begin" +" 'check-no-disallowed-expr" +"(if(parsed-lambda? e_92)" +"(let-values()(check-body-no-disallowed-expr_0(parsed-lambda-body e_92)))" +"(if(parsed-case-lambda? e_92)" +"(let-values()" +"(begin" +"(let-values(((lst_269)(parsed-case-lambda-clauses e_92)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_269)))" +"((letrec-values(((for-loop_243)" +"(lambda(lst_425)" +"(begin" +" 'for-loop" +"(if(pair? lst_425)" +"(let-values(((clause_5)(unsafe-car lst_425))" +"((rest_251)(unsafe-cdr lst_425)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-body-no-disallowed-expr_0" +"(cadr clause_5)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_243 rest_251)(values))))" +"(values))))))" +" for-loop_243)" +" lst_269)))" +"(void)))" +"(if(parsed-app? e_92)" +"(let-values()" +"(begin" +"(check-no-disallowed-expr_0(parsed-app-rator e_92))" +"(let-values(((lst_220)(parsed-app-rands e_92)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_220)))" +"((letrec-values(((for-loop_109)" +"(lambda(lst_163)" +"(begin" +" 'for-loop" +"(if(pair? lst_163)" +"(let-values(((e_93)(unsafe-car lst_163))" +"((rest_84)(unsafe-cdr lst_163)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-no-disallowed-expr_0" +" e_93))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_109 rest_84)(values))))" +"(values))))))" +" for-loop_109)" +" lst_220)))" +"(void)))" +"(if(parsed-if? e_92)" +"(let-values()" +"(begin" +"(check-no-disallowed-expr_0(parsed-if-tst e_92))" +"(check-no-disallowed-expr_0(parsed-if-thn e_92))" +"(check-no-disallowed-expr_0(parsed-if-els e_92))))" +"(if(parsed-set!? e_92)" +"(let-values()" +"(let-values(((id_4)(parsed-set!-id e_92)))" +"(let-values(((normal-b_1)(parsed-id-binding id_4)))" +"(begin" +"(if(let-values(((or-part_83)(not normal-b_1)))" +"(if or-part_83" +" or-part_83" +"(let-values(((or-part_310)(parsed-top-id? id_4)))" +"(if or-part_310" +" or-part_310" +"(if(not(symbol? normal-b_1))" +"(eq?(module-binding-module normal-b_1) self-mpi_6)" +" #f)))))" +"(let-values()(disallow e_92))" +"(void))" +"(check-no-disallowed-expr_0(parsed-set!-rhs e_92))))))" +"(if(parsed-with-continuation-mark? e_92)" +"(let-values()" +"(begin" +"(check-no-disallowed-expr_0(parsed-with-continuation-mark-key e_92))" +"(check-no-disallowed-expr_0(parsed-with-continuation-mark-val e_92))" +"(check-no-disallowed-expr_0(parsed-with-continuation-mark-body e_92))))" +"(if(parsed-begin? e_92)" +"(let-values()(check-body-no-disallowed-expr_0(parsed-begin-body e_92)))" +"(if(parsed-begin0? e_92)" +"(let-values()(check-body-no-disallowed-expr_0(parsed-begin0-body e_92)))" +"(if(parsed-let_-values? e_92)" +"(let-values()" +"(begin" +"(let-values(((lst_23)(parsed-let_-values-clauses e_92)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_23)))" +"((letrec-values(((for-loop_192)" +"(lambda(lst_90)" +"(begin" +" 'for-loop" +"(if(pair? lst_90)" +"(let-values(((clause_6)" +"(unsafe-car lst_90))" +"((rest_143)" +"(unsafe-cdr lst_90)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-no-disallowed-expr_0" +"(cadr" +" clause_6)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_192 rest_143)" +"(values))))" +"(values))))))" +" for-loop_192)" +" lst_23)))" +"(void)" +"(check-body-no-disallowed-expr_0(parsed-let_-values-body e_92))))" +"(if(let-values(((or-part_357)(parsed-quote-syntax? e_92)))" +"(if or-part_357 or-part_357(parsed-#%variable-reference? e_92)))" +"(let-values()(disallow e_92))" +"(let-values()(void)))))))))))))))" +"((check-body-no-disallowed-expr_0)" +"(lambda(l_48)" +"(begin" +" 'check-body-no-disallowed-expr" +"(begin" +"(let-values(((lst_81) l_48))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_81)))" +"((letrec-values(((for-loop_328)" +"(lambda(lst_58)" +"(begin" +" 'for-loop" +"(if(pair? lst_58)" +"(let-values(((e_82)(unsafe-car lst_58))" +"((rest_196)(unsafe-cdr lst_58)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-no-disallowed-expr_0" +" e_82))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_328 rest_196)(values))))" +"(values))))))" +" for-loop_328)" +" lst_81)))" +"(void))))))" +"(check-body_0 bodys_13)))))" +"(define-values" +"(check-count)" +"(lambda(is-num_0 expected-num_0 enclosing_16)" +"(begin(if(= is-num_0 expected-num_0)(void)(let-values()(disallow enclosing_16))))))" +"(define-values" +"(check-datum)" +"(lambda(d_38 e_12)" +"(begin" +"(if(let-values(((or-part_159)(number? d_38)))" +"(if or-part_159" +" or-part_159" +"(let-values(((or-part_164)(boolean? d_38)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_21)(symbol? d_38)))" +"(if or-part_21" +" or-part_21" +"(let-values(((or-part_165)(string? d_38)))" +"(if or-part_165" +" or-part_165" +"(let-values(((or-part_259)(bytes? d_38)))(if or-part_259 or-part_259(null? d_38)))))))))))" +"(let-values()(void))" +"(let-values()(disallow e_12))))))" +"(define-values" +"(quoted-string?)" +"(lambda(e_94)(begin(if(parsed-quote? e_94)(string?(parsed-quote-datum e_94)) #f))))" +"(define-values" +"(cross-phase-primitive-name)" +"(lambda(id_145)" +"(begin" +"(if(parsed-id? id_145)" +"(let-values()" +"(let-values(((b_87)(parsed-id-binding id_145)))" +"(if(module-binding? b_87)" +"(if(eq? runtime-module-name(1/module-path-index-resolve(module-binding-module b_87)))" +"(module-binding-sym b_87)" +" #f)" +" #f)))" +"(let-values() #f)))))" +"(define-values" +"(disallow)" +"(lambda(body_20)" +"(begin" +"(raise-syntax-error$1" +" 'module" +" \"not allowed in a cross-phase persistent module\"" +"(if(parsed? body_20)(datum->syntax$1 #f body_20(parsed-s body_20)) body_20)))))" +"(void" +"(add-core-form!*" +" 'module" +"(lambda(s_43 ctx_108)" +"(begin" +"(if(eq?(expand-context-context ctx_108) 'top-level)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((obs_125)(expand-context-observer ctx_108)))" +"(if obs_125(let-values()(let-values()(call-expand-observe obs_125 'prim-module)))(void)))" +" (raise-syntax-error$1 #f \"allowed only at the top level\" s_43))))" +"(let-values()" +"(let-values(((s219_0) s_43)((ctx220_0) ctx_108)((temp221_4) #f))" +"(expand-module16.1 #f #f #f #f unsafe-undefined #f s219_0 ctx220_0 temp221_4)))))))" +"(void" +"(add-core-form!*" +" 'module*" +"(lambda(s_307 ctx_109)" +"(begin" +"(let-values(((obs_126)(expand-context-observer ctx_109)))" +"(if obs_126(let-values()(let-values()(call-expand-observe obs_126 'prim-module)))(void)))" +" (raise-syntax-error$1 #f \"illegal use (not in a module top-level)\" s_307)))))" +"(void" +"(add-core-form!*" +" '#%module-begin" +"(lambda(s_91 ctx_110)" +"(begin" +"(let-values(((obs_127)(expand-context-observer ctx_110)))" +"(if obs_127(let-values()(let-values()(call-expand-observe obs_127 'prim-module-begin)))(void)))" +"(if(eq?(expand-context-context ctx_110) 'module-begin)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not in a module-definition context\" s_91)))" +"(if(expand-context-module-begin-k ctx_110)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not currently transforming a module\" s_91)))" +"((expand-context-module-begin-k ctx_110)" +" s_91" +"(let-values(((v_267) ctx_110))" +"(let-values(((the-struct_101) v_267))" +"(if(expand-context/outer? the-struct_101)" +"(let-values(((inner222_0)" +"(let-values(((the-struct_102)(root-expand-context/outer-inner v_267)))" +"(if(expand-context/inner? the-struct_102)" +"(let-values(((module-begin-k223_0) #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_102)" +"(root-expand-context/inner-module-scopes the-struct_102)" +"(root-expand-context/inner-top-level-bind-scope the-struct_102)" +"(root-expand-context/inner-all-scopes-stx the-struct_102)" +"(root-expand-context/inner-defined-syms the-struct_102)" +"(root-expand-context/inner-counter the-struct_102)" +"(root-expand-context/inner-lift-key the-struct_102)" +"(expand-context/inner-to-parsed? the-struct_102)" +"(expand-context/inner-phase the-struct_102)" +"(expand-context/inner-namespace the-struct_102)" +"(expand-context/inner-just-once? the-struct_102)" +" module-begin-k223_0" +"(expand-context/inner-allow-unbound? the-struct_102)" +"(expand-context/inner-in-local-expand? the-struct_102)" +"(expand-context/inner-keep-#%expression? the-struct_102)" +"(expand-context/inner-stops the-struct_102)" +"(expand-context/inner-declared-submodule-names the-struct_102)" +"(expand-context/inner-lifts the-struct_102)" +"(expand-context/inner-lift-envs the-struct_102)" +"(expand-context/inner-module-lifts the-struct_102)" +"(expand-context/inner-require-lifts the-struct_102)" +"(expand-context/inner-to-module-lifts the-struct_102)" +"(expand-context/inner-requires+provides the-struct_102)" +"(expand-context/inner-observer the-struct_102)" +"(expand-context/inner-for-serializable? the-struct_102)" +"(expand-context/inner-should-not-encounter-macros? the-struct_102)))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_102)))))" +"(expand-context/outer1.1" +" inner222_0" +"(root-expand-context/outer-post-expansion the-struct_101)" +"(root-expand-context/outer-use-site-scopes the-struct_101)" +"(root-expand-context/outer-frame-id the-struct_101)" +"(expand-context/outer-context the-struct_101)" +"(expand-context/outer-env the-struct_101)" +"(expand-context/outer-scopes the-struct_101)" +"(expand-context/outer-def-ctx-scopes the-struct_101)" +"(expand-context/outer-binding-layer the-struct_101)" +"(expand-context/outer-reference-records the-struct_101)" +"(expand-context/outer-only-immediate? the-struct_101)" +"(expand-context/outer-need-eventually-defined the-struct_101)" +"(expand-context/outer-current-introduction-scopes the-struct_101)" +"(expand-context/outer-current-use-scopes the-struct_101)" +"(expand-context/outer-name the-struct_101)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_101)))))))))" +"(void" +"(add-core-form!*" +" '#%declare" +"(lambda(s_804 ctx_111)" +"(begin" +"(let-values(((obs_128)(expand-context-observer ctx_111)))" +"(if obs_128(let-values()(let-values()(call-expand-observe obs_128 'prim-declare)))(void)))" +" (raise-syntax-error$1 #f \"not allowed outside of a module body\" s_804)))))" +"(define-values" +"(expand-module16.1)" +"(lambda(always-produce-compiled?1_0" +" enclosing-is-cross-phase-persistent?3_0" +" enclosing-requires+provides4_0" +" keep-enclosing-scope-at-phase2_0" +" modules-being-compiled6_0" +" mpis-for-enclosing-reset5_0" +" s13_0" +" init-ctx14_0" +" enclosing-self15_0)" +"(begin" +" 'expand-module16" +"(let-values(((s_449) s13_0))" +"(let-values(((init-ctx_0) init-ctx14_0))" +"(let-values(((enclosing-self_1) enclosing-self15_0))" +"(let-values(((always-produce-compiled?_0) always-produce-compiled?1_0))" +"(let-values(((keep-enclosing-scope-at-phase_0) keep-enclosing-scope-at-phase2_0))" +"(let-values(((enclosing-is-cross-phase-persistent?_0) enclosing-is-cross-phase-persistent?3_0))" +"(let-values(((enclosing-r+p_1) enclosing-requires+provides4_0))" +"(let-values(((mpis-for-enclosing-reset_0) mpis-for-enclosing-reset5_0))" +"(let-values(((modules-being-compiled_3)" +"(if(eq? modules-being-compiled6_0 unsafe-undefined)" +"(make-hasheq)" +" modules-being-compiled6_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_129)(expand-context-observer init-ctx_0)))" +"(if obs_129" +"(let-values()(let-values()(call-expand-observe obs_129 'prim-module)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_24)(syntax-disarm$1 s_449)))" +"(let-values(((ok?_78 module224_0 id:module-name225_0 initial-require226_0 body227_0)" +"(let-values(((s_49) disarmed-s_24))" +"(let-values(((orig-s_66) s_49))" +"(let-values(((module224_1" +" id:module-name225_1" +" initial-require226_1" +" body227_1)" +"(let-values(((s_452)" +"(if(syntax?$1 s_49)" +"(syntax-e$1 s_49)" +" s_49)))" +"(if(pair? s_452)" +"(let-values(((module228_0)" +"(let-values(((s_508)(car s_452)))" +" s_508))" +"((id:module-name229_0" +" initial-require230_0" +" body231_0)" +"(let-values(((s_53)(cdr s_452)))" +"(let-values(((s_54)" +"(if(syntax?$1 s_53)" +"(syntax-e$1 s_53)" +" s_53)))" +"(if(pair? s_54)" +"(let-values(((id:module-name232_0)" +"(let-values(((s_94)" +"(car" +" s_54)))" +"(if(let-values(((or-part_403)" +"(if(syntax?$1" +" s_94)" +"(symbol?" +"(syntax-e$1" +" s_94))" +" #f)))" +"(if or-part_403" +" or-part_403" +"(symbol?" +" s_94)))" +" s_94" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_66" +" s_94))))" +"((initial-require233_0" +" body234_0)" +"(let-values(((s_314)" +"(cdr" +" s_54)))" +"(let-values(((s_95)" +"(if(syntax?$1" +" s_314)" +"(syntax-e$1" +" s_314)" +" s_314)))" +"(if(pair? s_95)" +"(let-values(((initial-require235_0)" +"(let-values(((s_454)" +"(car" +" s_95)))" +" s_454))" +"((body236_0)" +"(let-values(((s_805)" +"(cdr" +" s_95)))" +"(let-values(((s_56)" +"(if(syntax?$1" +" s_805)" +"(syntax-e$1" +" s_805)" +" s_805)))" +"(let-values(((flat-s_55)" +"(to-syntax-list.1" +" s_56)))" +"(if(not" +" flat-s_55)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))" +"(let-values()" +" flat-s_55)))))))" +"(values" +" initial-require235_0" +" body236_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))))))" +"(values" +" id:module-name232_0" +" initial-require233_0" +" body234_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))))))" +"(values" +" module228_0" +" id:module-name229_0" +" initial-require230_0" +" body231_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_66)))))" +"(values" +" #t" +" module224_1" +" id:module-name225_1" +" initial-require226_1" +" body227_1))))))" +"(let-values(((rebuild-s_14)" +"(let-values(((init-ctx249_0) init-ctx_0)" +"((s250_0) s_449)" +"((temp251_1) #t)" +"((temp252_0) #t))" +"(keep-as-needed119.1 #f temp252_0 temp251_1 init-ctx249_0 s250_0))))" +"(let-values(((initial-require_0)(syntax->datum$1 initial-require226_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_404) keep-enclosing-scope-at-phase_0))" +"(if or-part_404" +" or-part_404" +"(1/module-path? initial-require_0)))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"not a module path\"" +" s_449" +" initial-require226_0)))" +"(values))))" +"(let-values(((phase_7) 0))" +"(let-values(((module-name-sym_0)(syntax-e$1 id:module-name225_0)))" +"(let-values(((outside-scope_1)(new-scope 'module)))" +"(let-values(((inside-scope_0)(new-multi-scope module-name-sym_0)))" +"(let-values(((self_32)" +"(make-self-module-path-index" +"(if enclosing-self_1" +" module-name-sym_0" +"(string->uninterned-symbol" +"(symbol->string module-name-sym_0)))" +" enclosing-self_1)))" +"(let-values(((enclosing-mod_1)" +"(if enclosing-self_1" +" (1/module-path-index-join '(submod \"..\") self_32)" +" #f)))" +"(let-values((()" +"(begin" +"(if(if enclosing-mod_1 mpis-for-enclosing-reset_0 #f)" +"(let-values()" +"(set-box!" +" mpis-for-enclosing-reset_0" +"(cons" +" enclosing-mod_1" +"(unbox mpis-for-enclosing-reset_0))))" +"(void))" +"(values))))" +"(let-values(((apply-module-scopes_0)" +"(make-apply-module-scopes" +" outside-scope_1" +" inside-scope_0" +" init-ctx_0" +" keep-enclosing-scope-at-phase_0" +" self_32" +" enclosing-self_1" +" enclosing-mod_1)))" +"(let-values(((initial-require-s_0)" +"(apply-module-scopes_0 initial-require226_0)))" +"(let-values(((all-scopes-s_0) initial-require-s_0))" +"(let-values(((root-ctx_6)" +"(let-values(((self253_0) self_32)" +"((temp254_0)" +"(if keep-enclosing-scope-at-phase_0" +"(root-expand-context-module-scopes" +" init-ctx_0)" +" null))" +"((outside-scope255_0)" +" outside-scope_1)" +"((inside-scope256_0)" +" inside-scope_0)" +"((all-scopes-s257_0)" +" all-scopes-s_0))" +"(make-root-expand-context13.1" +" all-scopes-s257_0" +" temp254_0" +" outside-scope255_0" +" inside-scope256_0" +" self253_0))))" +"(let-values(((new-module-scopes_0)" +"(root-expand-context-module-scopes" +" root-ctx_6)))" +"(let-values(((frame-id_16)" +"(root-expand-context-frame-id root-ctx_6)))" +"(let-values(((make-m-ns240_0)" +"(lambda(for-submodule?237_0 ns239_0)" +"(begin" +" 'make-m-ns240" +"(let-values(((ns_130) ns239_0))" +"(let-values(((for-submodule?_1)" +"(if(eq?" +" for-submodule?237_0" +" unsafe-undefined)" +"(if enclosing-self_1" +" #t" +" #f)" +" for-submodule?237_0)))" +"(let-values()" +"(let-values(((ns258_0) ns_130)" +"((self259_0)" +" self_32)" +"((root-ctx260_0)" +" root-ctx_6)" +"((for-submodule?261_0)" +" for-submodule?_1))" +"(make-module-namespace50.1" +" for-submodule?261_0" +" self259_0" +" root-ctx260_0" +" ns258_0)))))))))" +"(let-values()" +"(let-values()" +"(let-values(((m-ns_19)" +"(let-values(((temp262_0)" +"(expand-context-namespace" +" init-ctx_0)))" +"(make-m-ns240_0" +" unsafe-undefined" +" temp262_0))))" +"(let-values(((ctx_112)" +"(let-values(((v_268)" +"(copy-root-expand-context" +" init-ctx_0" +" root-ctx_6)))" +"(let-values(((the-struct_103)" +" v_268))" +"(if(expand-context/outer?" +" the-struct_103)" +"(let-values(((post-expansion263_0)" +"(lambda(s_64)" +"(begin" +" 'post-expansion263" +"(add-scope" +" s_64" +" inside-scope_0))))" +"((inner264_0)" +"(let-values(((the-struct_0)" +"(root-expand-context/outer-inner" +" v_268)))" +"(if(expand-context/inner?" +" the-struct_0)" +"(let-values(((allow-unbound?265_0)" +" #f)" +"((namespace266_0)" +" m-ns_19)" +"((phase267_0)" +" phase_7)" +"((just-once?268_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_0)" +"(root-expand-context/inner-module-scopes" +" the-struct_0)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_0)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_0)" +"(root-expand-context/inner-defined-syms" +" the-struct_0)" +"(root-expand-context/inner-counter" +" the-struct_0)" +"(root-expand-context/inner-lift-key" +" the-struct_0)" +"(expand-context/inner-to-parsed?" +" the-struct_0)" +" phase267_0" +" namespace266_0" +" just-once?268_0" +"(expand-context/inner-module-begin-k" +" the-struct_0)" +" allow-unbound?265_0" +"(expand-context/inner-in-local-expand?" +" the-struct_0)" +"(expand-context/inner-keep-#%expression?" +" the-struct_0)" +"(expand-context/inner-stops" +" the-struct_0)" +"(expand-context/inner-declared-submodule-names" +" the-struct_0)" +"(expand-context/inner-lifts" +" the-struct_0)" +"(expand-context/inner-lift-envs" +" the-struct_0)" +"(expand-context/inner-module-lifts" +" the-struct_0)" +"(expand-context/inner-require-lifts" +" the-struct_0)" +"(expand-context/inner-to-module-lifts" +" the-struct_0)" +"(expand-context/inner-requires+provides" +" the-struct_0)" +"(expand-context/inner-observer" +" the-struct_0)" +"(expand-context/inner-for-serializable?" +" the-struct_0)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_0)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_0)))))" +"(expand-context/outer1.1" +" inner264_0" +" post-expansion263_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_103)" +"(root-expand-context/outer-frame-id" +" the-struct_103)" +"(expand-context/outer-context" +" the-struct_103)" +"(expand-context/outer-env" +" the-struct_103)" +"(expand-context/outer-scopes" +" the-struct_103)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_103)" +"(expand-context/outer-binding-layer" +" the-struct_103)" +"(expand-context/outer-reference-records" +" the-struct_103)" +"(expand-context/outer-only-immediate?" +" the-struct_103)" +"(expand-context/outer-need-eventually-defined" +" the-struct_103)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_103)" +"(expand-context/outer-current-use-scopes" +" the-struct_103)" +"(expand-context/outer-name" +" the-struct_103)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_103))))))" +"(let-values(((bodys_15)" +"(let-values(((scoped-s_0)" +"(apply-module-scopes_0" +" disarmed-s_24)))" +"(let-values(((ok?_79" +" _269_0" +" _270_0" +" _271_0" +" body272_0)" +"(let-values(((s_523)" +" scoped-s_0))" +"(let-values(((orig-s_82)" +" s_523))" +"(let-values(((_269_1" +" _270_1" +" _271_1" +" body272_1)" +"(let-values(((s_806)" +"(if(syntax?$1" +" s_523)" +"(syntax-e$1" +" s_523)" +" s_523)))" +"(if(pair?" +" s_806)" +"(let-values(((_273_0)" +"(let-values(((s_211)" +"(car" +" s_806)))" +" s_211))" +"((_274_0" +" _275_0" +" body276_0)" +"(let-values(((s_527)" +"(cdr" +" s_806)))" +"(let-values(((s_528)" +"(if(syntax?$1" +" s_527)" +"(syntax-e$1" +" s_527)" +" s_527)))" +"(if(pair?" +" s_528)" +"(let-values(((_277_2)" +"(let-values(((s_459)" +"(car" +" s_528)))" +" s_459))" +"((_278_0" +" body279_0)" +"(let-values(((s_460)" +"(cdr" +" s_528)))" +"(let-values(((s_807)" +"(if(syntax?$1" +" s_460)" +"(syntax-e$1" +" s_460)" +" s_460)))" +"(if(pair?" +" s_807)" +"(let-values(((_280_1)" +"(let-values(((s_808)" +"(car" +" s_807)))" +" s_808))" +"((body281_0)" +"(let-values(((s_416)" +"(cdr" +" s_807)))" +"(let-values(((s_39)" +"(if(syntax?$1" +" s_416)" +"(syntax-e$1" +" s_416)" +" s_416)))" +"(let-values(((flat-s_56)" +"(to-syntax-list.1" +" s_39)))" +"(if(not" +" flat-s_56)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82))" +"(let-values()" +" flat-s_56)))))))" +"(values" +" _280_1" +" body281_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82))))))" +"(values" +" _277_2" +" _278_0" +" body279_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82))))))" +"(values" +" _273_0" +" _274_0" +" _275_0" +" body276_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82)))))" +"(values" +" #t" +" _269_1" +" _270_1" +" _271_1" +" body272_1))))))" +" body272_0))))" +"(let-values(((requires+provides_6)" +"(let-values(((self282_0)" +" self_32))" +"(make-requires+provides8.1" +" #f" +" self282_0))))" +"(let-values(((defined-syms_11)" +"(root-expand-context-defined-syms" +" root-ctx_6)))" +"(let-values(((compiled-submodules_1)" +"(make-hasheq)))" +"(let-values(((compiled-module-box_0)" +"(box #f)))" +"(let-values(((mpis-to-reset_0)" +"(box null)))" +"(let-values(((initial-require!245_0)" +"(lambda(bind?243_0)" +"(begin" +" 'initial-require!245" +"(let-values(((bind?_3)" +" bind?243_0))" +"(let-values()" +"(if(not" +" keep-enclosing-scope-at-phase_0)" +"(let-values()" +"(let-values(((initial-require283_0)" +" initial-require_0)" +"((self284_0)" +" self_32)" +"((all-scopes-s285_0)" +" all-scopes-s_0)" +"((m-ns286_0)" +" m-ns_19)" +"((requires+provides287_1)" +" requires+provides_6)" +"((bind?288_0)" +" bind?_3)" +"((temp289_0)" +" 'module))" +"(perform-initial-require!42.1" +" bind?288_0" +" temp289_0" +" initial-require283_0" +" self284_0" +" all-scopes-s285_0" +" m-ns286_0" +" requires+provides287_1)))" +"(let-values()" +"(begin" +"(add-required-module!" +" requires+provides_6" +" enclosing-mod_1" +" keep-enclosing-scope-at-phase_0" +" enclosing-is-cross-phase-persistent?_0)" +"(let-values(((requires+provides290_0)" +" requires+provides_6)" +"((enclosing-r+p291_0)" +" enclosing-r+p_1)" +"((enclosing-mod292_0)" +" enclosing-mod_1)" +"((keep-enclosing-scope-at-phase293_0)" +" keep-enclosing-scope-at-phase_0))" +"(add-enclosing-module-defined-and-required!67.1" +" enclosing-r+p291_0" +" requires+provides290_0" +" enclosing-mod292_0" +" keep-enclosing-scope-at-phase293_0))" +"(let-values(((m-ns294_0)" +" m-ns_19)" +"((enclosing-mod295_0)" +" enclosing-mod_1)" +"((keep-enclosing-scope-at-phase296_0)" +" keep-enclosing-scope-at-phase_0))" +"(namespace-module-visit!104.1" +" unsafe-undefined" +" m-ns294_0" +" enclosing-mod295_0" +" keep-enclosing-scope-at-phase296_0)))))))))))" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_130)" +"(expand-context-observer" +" init-ctx_0)))" +"(if obs_130" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_130" +" 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((temp248_1)" +" #t))" +"(initial-require!245_0" +" temp248_1))" +"(values))))" +"(let-values(((again?_0)" +" #f))" +"(letrec-values(((module-begin-k_1)" +"(lambda(mb-s_0" +" mb-init-ctx_0)" +"(begin" +" 'module-begin-k" +"(let-values((()" +"(begin" +"(if again?_0" +"(let-values()" +"(begin" +"(requires+provides-reset!" +" requires+provides_6)" +"(let-values(((temp301_0)" +" #f))" +"(initial-require!245_0" +" temp301_0))" +"(hash-clear!" +" compiled-submodules_1)" +"(set-box!" +" compiled-module-box_0" +" #f)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(set! again?_0" +" #t)" +"(values))))" +"(let-values(((ctx_113)" +"(let-values(((v_269)" +" mb-init-ctx_0))" +"(let-values(((the-struct_104)" +" v_269))" +"(if(expand-context/outer?" +" the-struct_104)" +"(let-values(((post-expansion302_0)" +"(lambda(s_809)" +"(begin" +" 'post-expansion302" +"(add-scope" +" s_809" +" inside-scope_0))))" +"((inner303_0)" +"(let-values(((the-struct_105)" +"(root-expand-context/outer-inner" +" v_269)))" +"(if(expand-context/inner?" +" the-struct_105)" +"(let-values(((module-begin-k304_0)" +"(lambda(s_810" +" ctx_60)" +"(begin" +" 'module-begin-k304" +"(let-values(((new-requires+provides_0)" +"(let-values(((self313_0)" +" self_32)" +"((requires+provides314_0)" +" requires+provides_6))" +"(make-requires+provides8.1" +" requires+provides314_0" +" self313_0))))" +"(let-values(((requires+provides305_0)" +" requires+provides_6)" +"((compiled-submodules306_0)" +" compiled-submodules_1)" +"((compiled-module-box307_0)" +" compiled-module-box_0)" +"((defined-syms308_0)" +" defined-syms_11)" +"((requires+provides309_0)" +" new-requires+provides_0)" +"((compiled-submodules310_0)" +"(make-hasheq))" +"((compiled-module-box311_0)" +"(box" +" #f))" +"((defined-syms312_0)" +"(make-hasheq)))" +"(dynamic-wind" +"(lambda()" +"(begin" +"(set! requires+provides_6" +" requires+provides309_0)" +"(set! compiled-submodules_1" +" compiled-submodules310_0)" +"(set! compiled-module-box_0" +" compiled-module-box311_0)" +"(set! defined-syms_11" +" defined-syms312_0)))" +"(lambda()" +"(module-begin-k_1" +" s_810" +" ctx_60))" +"(lambda()" +"(begin" +"(set! requires+provides_6" +" requires+provides305_0)" +"(set! compiled-submodules_1" +" compiled-submodules306_0)" +"(set! compiled-module-box_0" +" compiled-module-box307_0)" +"(set! defined-syms_11" +" defined-syms308_0))))))))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_105)" +"(root-expand-context/inner-module-scopes" +" the-struct_105)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_105)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_105)" +"(root-expand-context/inner-defined-syms" +" the-struct_105)" +"(root-expand-context/inner-counter" +" the-struct_105)" +"(root-expand-context/inner-lift-key" +" the-struct_105)" +"(expand-context/inner-to-parsed?" +" the-struct_105)" +"(expand-context/inner-phase" +" the-struct_105)" +"(expand-context/inner-namespace" +" the-struct_105)" +"(expand-context/inner-just-once?" +" the-struct_105)" +" module-begin-k304_0" +"(expand-context/inner-allow-unbound?" +" the-struct_105)" +"(expand-context/inner-in-local-expand?" +" the-struct_105)" +"(expand-context/inner-keep-#%expression?" +" the-struct_105)" +"(expand-context/inner-stops" +" the-struct_105)" +"(expand-context/inner-declared-submodule-names" +" the-struct_105)" +"(expand-context/inner-lifts" +" the-struct_105)" +"(expand-context/inner-lift-envs" +" the-struct_105)" +"(expand-context/inner-module-lifts" +" the-struct_105)" +"(expand-context/inner-require-lifts" +" the-struct_105)" +"(expand-context/inner-to-module-lifts" +" the-struct_105)" +"(expand-context/inner-requires+provides" +" the-struct_105)" +"(expand-context/inner-observer" +" the-struct_105)" +"(expand-context/inner-for-serializable?" +" the-struct_105)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_105)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_105)))))" +"(expand-context/outer1.1" +" inner303_0" +" post-expansion302_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_104)" +"(root-expand-context/outer-frame-id" +" the-struct_104)" +"(expand-context/outer-context" +" the-struct_104)" +"(expand-context/outer-env" +" the-struct_104)" +"(expand-context/outer-scopes" +" the-struct_104)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_104)" +"(expand-context/outer-binding-layer" +" the-struct_104)" +"(expand-context/outer-reference-records" +" the-struct_104)" +"(expand-context/outer-only-immediate?" +" the-struct_104)" +"(expand-context/outer-need-eventually-defined" +" the-struct_104)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_104)" +"(expand-context/outer-current-use-scopes" +" the-struct_104)" +"(expand-context/outer-name" +" the-struct_104)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_104))))))" +"(let-values(((added-s_2)" +"(add-scope" +" mb-s_0" +" inside-scope_0)))" +"(let-values((()" +"(begin" +"(let-values(((obs_131)" +"(expand-context-observer" +" ctx_113)))" +"(if obs_131" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_131" +" 'rename-one" +" added-s_2)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-mb-s_0)" +"(syntax-disarm$1" +" added-s_2)))" +"(let-values(((ok?_80" +" #%module-begin297_0" +" body298_0)" +"(let-values(((s_116)" +" disarmed-mb-s_0))" +"(let-values(((orig-s_0)" +" s_116))" +"(let-values(((#%module-begin297_1" +" body298_1)" +"(let-values(((s_225)" +"(if(syntax?$1" +" s_116)" +"(syntax-e$1" +" s_116)" +" s_116)))" +"(if(pair?" +" s_225)" +"(let-values(((#%module-begin299_0)" +"(let-values(((s_121)" +"(car" +" s_225)))" +" s_121))" +"((body300_0)" +"(let-values(((s_226)" +"(cdr" +" s_225)))" +"(let-values(((s_227)" +"(if(syntax?$1" +" s_226)" +"(syntax-e$1" +" s_226)" +" s_226)))" +"(let-values(((flat-s_5)" +"(to-syntax-list.1" +" s_227)))" +"(if(not" +" flat-s_5)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_0))" +"(let-values()" +" flat-s_5)))))))" +"(values" +" #%module-begin299_0" +" body300_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_0)))))" +"(values" +" #t" +" #%module-begin297_1" +" body298_1))))))" +"(let-values(((bodys_16)" +" body298_0))" +"(let-values(((rebuild-mb-s_0)" +"(let-values(((ctx315_0)" +" ctx_113)" +"((mb-s316_0)" +" mb-s_0))" +"(keep-as-needed119.1" +" #f" +" #f" +" #f" +" ctx315_0" +" mb-s316_0))))" +"(let-values(((need-eventually-defined_1)" +"(make-hasheqv)))" +"(let-values(((module-ends_0)" +"(make-shared-module-ends)))" +"(let-values(((declared-keywords_0)" +"(make-hasheq)))" +"(let-values(((declared-submodule-names_3)" +"(make-hasheq)))" +"(let-values(((expression-expanded-bodys_0)" +"((letrec-values(((pass-1-and-2-loop_0)" +"(lambda(bodys_17" +" phase_83)" +"(begin" +" 'pass-1-and-2-loop" +"(let-values(((def-ctx-scopes_8)" +"(box" +" null)))" +"(let-values(((to-parsed?_5)" +"(expand-context-to-parsed?" +" ctx_113)))" +"(let-values(((partial-body-ctx_0)" +"(let-values(((v_270)" +" ctx_113))" +"(let-values(((the-struct_106)" +" v_270))" +"(if(expand-context/outer?" +" the-struct_106)" +"(let-values(((context325_0)" +" 'module)" +"((def-ctx-scopes326_0)" +" def-ctx-scopes_8)" +"((need-eventually-defined327_0)" +" need-eventually-defined_1)" +"((inner328_0)" +"(let-values(((the-struct_107)" +"(root-expand-context/outer-inner" +" v_270)))" +"(if(expand-context/inner?" +" the-struct_107)" +"(let-values(((phase329_0)" +" phase_83)" +"((namespace330_0)" +"(namespace->namespace-at-phase" +" m-ns_19" +" phase_83))" +"((stops331_0)" +"(free-id-set" +" phase_83" +"(module-expand-stop-ids" +" phase_83)))" +"((declared-submodule-names332_0)" +" declared-submodule-names_3)" +"((lift-key333_0)" +"(generate-lift-key))" +"((lifts334_0)" +"(let-values(((temp338_1)" +"(make-wrap-as-definition" +" self_32" +" frame-id_16" +" inside-scope_0" +" all-scopes-s_0" +" defined-syms_11" +" requires+provides_6)))" +"(make-lift-context6.1" +" #f" +" temp338_1)))" +"((module-lifts335_0)" +"(make-module-lift-context" +" phase_83" +" #t))" +"((require-lifts336_0)" +"(make-require-lift-context" +" phase_83" +"(let-values(((m-ns339_0)" +" m-ns_19)" +"((self340_0)" +" self_32)" +"((requires+provides341_0)" +" requires+provides_6)" +"((declared-submodule-names342_0)" +" declared-submodule-names_3))" +"(make-parse-lifted-require216.1" +" declared-submodule-names342_0" +" m-ns339_0" +" self340_0" +" requires+provides341_0))))" +"((to-module-lifts337_0)" +"(let-values(((phase343_0)" +" phase_83)" +"((module-ends344_0)" +" module-ends_0)" +"((temp345_1)" +" #f))" +"(make-to-module-lift-context27.1" +" temp345_1" +" module-ends344_0" +" phase343_0))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_107)" +"(root-expand-context/inner-module-scopes" +" the-struct_107)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_107)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_107)" +"(root-expand-context/inner-defined-syms" +" the-struct_107)" +"(root-expand-context/inner-counter" +" the-struct_107)" +" lift-key333_0" +"(expand-context/inner-to-parsed?" +" the-struct_107)" +" phase329_0" +" namespace330_0" +"(expand-context/inner-just-once?" +" the-struct_107)" +"(expand-context/inner-module-begin-k" +" the-struct_107)" +"(expand-context/inner-allow-unbound?" +" the-struct_107)" +"(expand-context/inner-in-local-expand?" +" the-struct_107)" +"(expand-context/inner-keep-#%expression?" +" the-struct_107)" +" stops331_0" +" declared-submodule-names332_0" +" lifts334_0" +"(expand-context/inner-lift-envs" +" the-struct_107)" +" module-lifts335_0" +" require-lifts336_0" +" to-module-lifts337_0" +"(expand-context/inner-requires+provides" +" the-struct_107)" +"(expand-context/inner-observer" +" the-struct_107)" +"(expand-context/inner-for-serializable?" +" the-struct_107)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_107)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_107)))))" +"(expand-context/outer1.1" +" inner328_0" +"(root-expand-context/outer-post-expansion" +" the-struct_106)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_106)" +"(root-expand-context/outer-frame-id" +" the-struct_106)" +" context325_0" +"(expand-context/outer-env" +" the-struct_106)" +"(expand-context/outer-scopes" +" the-struct_106)" +" def-ctx-scopes326_0" +"(expand-context/outer-binding-layer" +" the-struct_106)" +"(expand-context/outer-reference-records" +" the-struct_106)" +"(expand-context/outer-only-immediate?" +" the-struct_106)" +" need-eventually-defined327_0" +"(expand-context/outer-current-introduction-scopes" +" the-struct_106)" +"(expand-context/outer-current-use-scopes" +" the-struct_106)" +"(expand-context/outer-name" +" the-struct_106)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_106))))))" +"(let-values(((partially-expanded-bodys_0)" +"(let-values(((bodys346_0)" +" bodys_17)" +"((phase347_0)" +" phase_83)" +"((partial-body-ctx348_0)" +" partial-body-ctx_0)" +"((m-ns349_0)" +" m-ns_19)" +"((self350_0)" +" self_32)" +"((frame-id351_0)" +" frame-id_16)" +"((requires+provides352_0)" +" requires+provides_6)" +"((need-eventually-defined353_0)" +" need-eventually-defined_1)" +"((all-scopes-s354_0)" +" all-scopes-s_0)" +"((defined-syms355_0)" +" defined-syms_11)" +"((declared-keywords356_0)" +" declared-keywords_0)" +"((declared-submodule-names357_0)" +" declared-submodule-names_3)" +"((compiled-submodules358_0)" +" compiled-submodules_1)" +"((modules-being-compiled359_0)" +" modules-being-compiled_3)" +"((mpis-to-reset360_0)" +" mpis-to-reset_0)" +"((pass-1-and-2-loop361_0)" +" pass-1-and-2-loop_0))" +"(partially-expand-bodys79.1" +" all-scopes-s354_0" +" compiled-submodules358_0" +" partial-body-ctx348_0" +" declared-keywords356_0" +" declared-submodule-names357_0" +" defined-syms355_0" +" frame-id351_0" +" pass-1-and-2-loop361_0" +" modules-being-compiled359_0" +" mpis-to-reset360_0" +" m-ns349_0" +" need-eventually-defined353_0" +" phase347_0" +" requires+provides352_0" +" self350_0" +" bodys346_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_132)" +"(expand-context-observer" +" partial-body-ctx_0)))" +"(if obs_132" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_132" +" 'next-group)))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_6)" +"(let-values(((v_271)" +"(accumulate-def-ctx-scopes" +" partial-body-ctx_0" +" def-ctx-scopes_8)))" +"(let-values(((the-struct_108)" +" v_271))" +"(if(expand-context/outer?" +" the-struct_108)" +"(let-values(((def-ctx-scopes362_0)" +" #f)" +"((post-expansion363_0)" +" #f)" +"((inner364_0)" +"(let-values(((the-struct_109)" +"(root-expand-context/outer-inner" +" v_271)))" +"(if(expand-context/inner?" +" the-struct_109)" +"(let-values(((stops365_0)" +" empty-free-id-set)" +"((to-module-lifts366_0)" +"(let-values(((phase367_0)" +" phase_83)" +"((module-ends368_0)" +" module-ends_0)" +"((temp369_0)" +" #t))" +"(make-to-module-lift-context27.1" +" temp369_0" +" module-ends368_0" +" phase367_0))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_109)" +"(root-expand-context/inner-module-scopes" +" the-struct_109)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_109)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_109)" +"(root-expand-context/inner-defined-syms" +" the-struct_109)" +"(root-expand-context/inner-counter" +" the-struct_109)" +"(root-expand-context/inner-lift-key" +" the-struct_109)" +"(expand-context/inner-to-parsed?" +" the-struct_109)" +"(expand-context/inner-phase" +" the-struct_109)" +"(expand-context/inner-namespace" +" the-struct_109)" +"(expand-context/inner-just-once?" +" the-struct_109)" +"(expand-context/inner-module-begin-k" +" the-struct_109)" +"(expand-context/inner-allow-unbound?" +" the-struct_109)" +"(expand-context/inner-in-local-expand?" +" the-struct_109)" +"(expand-context/inner-keep-#%expression?" +" the-struct_109)" +" stops365_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_109)" +"(expand-context/inner-lifts" +" the-struct_109)" +"(expand-context/inner-lift-envs" +" the-struct_109)" +"(expand-context/inner-module-lifts" +" the-struct_109)" +"(expand-context/inner-require-lifts" +" the-struct_109)" +" to-module-lifts366_0" +"(expand-context/inner-requires+provides" +" the-struct_109)" +"(expand-context/inner-observer" +" the-struct_109)" +"(expand-context/inner-for-serializable?" +" the-struct_109)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_109)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_109)))))" +"(expand-context/outer1.1" +" inner364_0" +" post-expansion363_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_108)" +"(root-expand-context/outer-frame-id" +" the-struct_108)" +"(expand-context/outer-context" +" the-struct_108)" +"(expand-context/outer-env" +" the-struct_108)" +"(expand-context/outer-scopes" +" the-struct_108)" +" def-ctx-scopes362_0" +"(expand-context/outer-binding-layer" +" the-struct_108)" +"(expand-context/outer-reference-records" +" the-struct_108)" +"(expand-context/outer-only-immediate?" +" the-struct_108)" +"(expand-context/outer-need-eventually-defined" +" the-struct_108)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_108)" +"(expand-context/outer-current-use-scopes" +" the-struct_108)" +"(expand-context/outer-name" +" the-struct_108)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_108))))))" +"(let-values(((partially-expanded-bodys317_0)" +" partially-expanded-bodys_0)" +"((phase318_0)" +" phase_83)" +"((body-ctx319_0)" +" body-ctx_6)" +"((self320_0)" +" self_32)" +"((declared-submodule-names321_0)" +" declared-submodule-names_3)" +"((compiled-submodules322_0)" +" compiled-submodules_1)" +"((modules-being-compiled323_0)" +" modules-being-compiled_3)" +"((mpis-to-reset324_0)" +" mpis-to-reset_0))" +"(finish-expanding-body-expressons97.1" +" compiled-submodules322_0" +" body-ctx319_0" +" declared-submodule-names321_0" +" modules-being-compiled323_0" +" mpis-to-reset324_0" +" phase318_0" +" self320_0" +" partially-expanded-bodys317_0))))))))))))" +" pass-1-and-2-loop_0)" +" bodys_16" +" phase_7)))" +"(let-values((()" +"(begin" +"(check-defined-by-now" +" need-eventually-defined_1" +" self_32" +" ctx_113" +" requires+provides_6)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_133)" +"(expand-context-observer" +" ctx_113)))" +"(if obs_133" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_133" +" 'next-group)))" +"(void)))" +"(values))))" +"(let-values(((fully-expanded-bodys-except-post-submodules_0)" +"(let-values(((expression-expanded-bodys370_0)" +" expression-expanded-bodys_0)" +"((requires+provides371_0)" +" requires+provides_6)" +"((declared-submodule-names372_0)" +" declared-submodule-names_3)" +"((m-ns373_0)" +" m-ns_19)" +"((phase374_0)" +" phase_7)" +"((self375_0)" +" self_32)" +"((ctx376_0)" +" ctx_113))" +"(resolve-provides113.1" +" ctx376_0" +" declared-submodule-names372_0" +" m-ns373_0" +" phase374_0" +" requires+provides371_0" +" self375_0" +" expression-expanded-bodys370_0))))" +"(let-values(((is-cross-phase-persistent?_1)" +"(hash-ref" +" declared-keywords_0" +" '#:cross-phase-persistent" +" #f)))" +"(let-values((()" +"(begin" +"(if is-cross-phase-persistent?_1" +"(let-values()" +"(begin" +"(if(requires+provides-can-cross-phase-persistent?" +" requires+provides_6)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot be cross-phase persistent due to required modules\"" +" rebuild-s_14" +"(hash-ref" +" declared-keywords_0" +" '#:cross-phase-persistent))))" +"(check-cross-phase-persistent-form" +" fully-expanded-bodys-except-post-submodules_0" +" self_32)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_134)" +"(expand-context-observer" +" ctx_113)))" +"(if obs_134" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_134" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((submod-m-ns_0)" +"(let-values(((m-ns377_0)" +" m-ns_19)" +"((temp378_0)" +" #t))" +"(make-m-ns240_0" +" temp378_0" +" m-ns377_0))))" +"(let-values(((submod-ctx_0)" +"(let-values(((v_272)" +" ctx_113))" +"(let-values(((the-struct_76)" +" v_272))" +"(if(expand-context/outer?" +" the-struct_76)" +"(let-values(((frame-id379_0)" +" #f)" +"((post-expansion380_0)" +" #f)" +"((inner381_0)" +"(let-values(((the-struct_110)" +"(root-expand-context/outer-inner" +" v_272)))" +"(if(expand-context/inner?" +" the-struct_110)" +"(let-values(((namespace382_0)" +" submod-m-ns_0))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_110)" +"(root-expand-context/inner-module-scopes" +" the-struct_110)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_110)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_110)" +"(root-expand-context/inner-defined-syms" +" the-struct_110)" +"(root-expand-context/inner-counter" +" the-struct_110)" +"(root-expand-context/inner-lift-key" +" the-struct_110)" +"(expand-context/inner-to-parsed?" +" the-struct_110)" +"(expand-context/inner-phase" +" the-struct_110)" +" namespace382_0" +"(expand-context/inner-just-once?" +" the-struct_110)" +"(expand-context/inner-module-begin-k" +" the-struct_110)" +"(expand-context/inner-allow-unbound?" +" the-struct_110)" +"(expand-context/inner-in-local-expand?" +" the-struct_110)" +"(expand-context/inner-keep-#%expression?" +" the-struct_110)" +"(expand-context/inner-stops" +" the-struct_110)" +"(expand-context/inner-declared-submodule-names" +" the-struct_110)" +"(expand-context/inner-lifts" +" the-struct_110)" +"(expand-context/inner-lift-envs" +" the-struct_110)" +"(expand-context/inner-module-lifts" +" the-struct_110)" +"(expand-context/inner-require-lifts" +" the-struct_110)" +"(expand-context/inner-to-module-lifts" +" the-struct_110)" +"(expand-context/inner-requires+provides" +" the-struct_110)" +"(expand-context/inner-observer" +" the-struct_110)" +"(expand-context/inner-for-serializable?" +" the-struct_110)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_110)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_110)))))" +"(expand-context/outer1.1" +" inner381_0" +" post-expansion380_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_76)" +" frame-id379_0" +"(expand-context/outer-context" +" the-struct_76)" +"(expand-context/outer-env" +" the-struct_76)" +"(expand-context/outer-scopes" +" the-struct_76)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_76)" +"(expand-context/outer-binding-layer" +" the-struct_76)" +"(expand-context/outer-reference-records" +" the-struct_76)" +"(expand-context/outer-only-immediate?" +" the-struct_76)" +"(expand-context/outer-need-eventually-defined" +" the-struct_76)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_76)" +"(expand-context/outer-current-use-scopes" +" the-struct_76)" +"(expand-context/outer-name" +" the-struct_76)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_76))))))" +"(let-values(((declare-enclosing-module_0)" +"(delay" +"(lambda()" +"(begin" +" 'declare-enclosing-module" +"(let-values(((fully-expanded-bodys-except-post-submodules383_0)" +" fully-expanded-bodys-except-post-submodules_0)" +"((temp384_0)" +" id:module-name225_0)" +"((rebuild-s385_0)" +" rebuild-s_14)" +"((requires+provides386_0)" +" requires+provides_6)" +"((submod-m-ns387_0)" +" submod-m-ns_0)" +"((self388_0)" +" self_32)" +"((enclosing-self389_0)" +" enclosing-self_1)" +"((root-ctx390_0)" +" root-ctx_6)" +"((submod-ctx391_0)" +" submod-ctx_0)" +"((modules-being-compiled392_0)" +" modules-being-compiled_3)" +"((compiled-module-box393_0)" +" compiled-module-box_0))" +"(declare-module-for-expansion137.1" +" submod-ctx391_0" +" enclosing-self389_0" +" compiled-module-box393_0" +" temp384_0" +" modules-being-compiled392_0" +" submod-m-ns387_0" +" rebuild-s385_0" +" requires+provides386_0" +" root-ctx390_0" +" self388_0" +" fully-expanded-bodys-except-post-submodules383_0)))))))" +"(let-values(((fully-expanded-bodys_0)" +"(if(stop-at-module*?" +" submod-ctx_0)" +"(let-values()" +" fully-expanded-bodys-except-post-submodules_0)" +"(let-values()" +"(let-values(((fully-expanded-bodys-except-post-submodules394_0)" +" fully-expanded-bodys-except-post-submodules_0)" +"((declare-enclosing-module395_0)" +" declare-enclosing-module_0)" +"((phase396_0)" +" phase_7)" +"((self397_0)" +" self_32)" +"((requires+provides398_0)" +" requires+provides_6)" +"((is-cross-phase-persistent?399_0)" +" is-cross-phase-persistent?_1)" +"((all-scopes-s400_0)" +" all-scopes-s_0)" +"((mpis-to-reset401_0)" +" mpis-to-reset_0)" +"((declared-submodule-names402_0)" +" declared-submodule-names_3)" +"((compiled-submodules403_0)" +" compiled-submodules_1)" +"((modules-being-compiled404_0)" +" modules-being-compiled_3)" +"((submod-ctx405_0)" +" submod-ctx_0))" +"(expand-post-submodules163.1" +" all-scopes-s400_0" +" compiled-submodules403_0" +" submod-ctx405_0" +" declare-enclosing-module395_0" +" declared-submodule-names402_0" +" is-cross-phase-persistent?399_0" +" modules-being-compiled404_0" +" mpis-to-reset401_0" +" phase396_0" +" requires+provides398_0" +" self397_0" +" fully-expanded-bodys-except-post-submodules394_0))))))" +"(if(expand-context-to-parsed?" +" submod-ctx_0)" +"(let-values()" +"(parsed-#%module-begin24.1" +" rebuild-mb-s_0" +"(parsed-only" +" fully-expanded-bodys_0)))" +"(let-values()" +"(let-values(((mb-result-s_0)" +"(let-values(((rebuild-mb-s406_0)" +" rebuild-mb-s_0)" +"((temp407_0)" +"(list*" +" #%module-begin297_0" +"(syntax-only" +" fully-expanded-bodys_0))))" +"(rebuild5.1" +" #t" +" rebuild-mb-s406_0" +" temp407_0))))" +"(if(not" +"(expand-context-in-local-expand?" +" submod-ctx_0))" +"(let-values()" +"(expanded+parsed1.1" +" mb-result-s_0" +"(parsed-#%module-begin24.1" +" rebuild-mb-s_0" +"(parsed-only" +" fully-expanded-bodys_0))))" +"(let-values()" +" mb-result-s_0)))))))))))))))))))))))))))))))))" +"(let-values(((mb-ctx_0)" +"(let-values(((v_273)" +" ctx_112))" +"(let-values(((the-struct_111)" +" v_273))" +"(if(expand-context/outer?" +" the-struct_111)" +"(let-values(((context408_0)" +" 'module-begin)" +"((inner409_0)" +"(let-values(((the-struct_112)" +"(root-expand-context/outer-inner" +" v_273)))" +"(if(expand-context/inner?" +" the-struct_112)" +"(let-values(((module-begin-k410_0)" +" module-begin-k_1)" +"((in-local-expand?411_0)" +" #f)" +"((lifts412_0)" +" #f)" +"((module-lifts413_0)" +" #f)" +"((to-module-lifts414_0)" +" #f)" +"((require-lifts415_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_112)" +"(root-expand-context/inner-module-scopes" +" the-struct_112)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_112)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_112)" +"(root-expand-context/inner-defined-syms" +" the-struct_112)" +"(root-expand-context/inner-counter" +" the-struct_112)" +"(root-expand-context/inner-lift-key" +" the-struct_112)" +"(expand-context/inner-to-parsed?" +" the-struct_112)" +"(expand-context/inner-phase" +" the-struct_112)" +"(expand-context/inner-namespace" +" the-struct_112)" +"(expand-context/inner-just-once?" +" the-struct_112)" +" module-begin-k410_0" +"(expand-context/inner-allow-unbound?" +" the-struct_112)" +" in-local-expand?411_0" +"(expand-context/inner-keep-#%expression?" +" the-struct_112)" +"(expand-context/inner-stops" +" the-struct_112)" +"(expand-context/inner-declared-submodule-names" +" the-struct_112)" +" lifts412_0" +"(expand-context/inner-lift-envs" +" the-struct_112)" +" module-lifts413_0" +" require-lifts415_0" +" to-module-lifts414_0" +"(expand-context/inner-requires+provides" +" the-struct_112)" +"(expand-context/inner-observer" +" the-struct_112)" +"(expand-context/inner-for-serializable?" +" the-struct_112)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_112)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_112)))))" +"(expand-context/outer1.1" +" inner409_0" +"(root-expand-context/outer-post-expansion" +" the-struct_111)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_111)" +"(root-expand-context/outer-frame-id" +" the-struct_111)" +" context408_0" +"(expand-context/outer-env" +" the-struct_111)" +"(expand-context/outer-scopes" +" the-struct_111)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_111)" +"(expand-context/outer-binding-layer" +" the-struct_111)" +"(expand-context/outer-reference-records" +" the-struct_111)" +"(expand-context/outer-only-immediate?" +" the-struct_111)" +"(expand-context/outer-need-eventually-defined" +" the-struct_111)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_111)" +"(expand-context/outer-current-use-scopes" +" the-struct_111)" +"(expand-context/outer-name" +" the-struct_111)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_111))))))" +"(let-values(((mb-scopes-s_0)" +"(if keep-enclosing-scope-at-phase_0" +"(apply-module-scopes_0" +" disarmed-s_24)" +" all-scopes-s_0)))" +"(let-values(((mb-def-ctx-scopes_0)" +"(box" +" null)))" +"(let-values(((mb_0)" +"(let-values(((bodys416_0)" +" bodys_15)" +"((module-name-sym417_0)" +" module-name-sym_0)" +"((mb-scopes-s418_0)" +" mb-scopes-s_0)" +"((m-ns419_0)" +" m-ns_19)" +"((mb-ctx420_0)" +" mb-ctx_0)" +"((mb-def-ctx-scopes421_0)" +" mb-def-ctx-scopes_0)" +"((phase422_0)" +" phase_7)" +"((s423_0)" +" s_449))" +"(ensure-module-begin34.1" +" mb-ctx420_0" +" mb-def-ctx-scopes421_0" +" m-ns419_0" +" module-name-sym417_0" +" phase422_0" +" s423_0" +" mb-scopes-s418_0" +" bodys416_0))))" +"(let-values(((expanded-mb_0)" +"(let-values()" +"(let-values(((mb424_0)" +" mb_0)" +"((temp425_0)" +"(let-values(((v_274)" +"(accumulate-def-ctx-scopes" +" mb-ctx_0" +" mb-def-ctx-scopes_0)))" +"(let-values(((the-struct_113)" +" v_274))" +"(if(expand-context/outer?" +" the-struct_113)" +"(let-values(((def-ctx-scopes426_0)" +" #f)" +"((inner427_0)" +"(root-expand-context/outer-inner" +" v_274)))" +"(expand-context/outer1.1" +" inner427_0" +"(root-expand-context/outer-post-expansion" +" the-struct_113)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_113)" +"(root-expand-context/outer-frame-id" +" the-struct_113)" +"(expand-context/outer-context" +" the-struct_113)" +"(expand-context/outer-env" +" the-struct_113)" +"(expand-context/outer-scopes" +" the-struct_113)" +" def-ctx-scopes426_0" +"(expand-context/outer-binding-layer" +" the-struct_113)" +"(expand-context/outer-reference-records" +" the-struct_113)" +"(expand-context/outer-only-immediate?" +" the-struct_113)" +"(expand-context/outer-need-eventually-defined" +" the-struct_113)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_113)" +"(expand-context/outer-current-use-scopes" +" the-struct_113)" +"(expand-context/outer-name" +" the-struct_113)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_113))))))" +"(expand9.1" +" #f" +" #f" +" #f" +" mb424_0" +" temp425_0)))))" +"(let-values(((requires_6" +" provides_13)" +"(extract-requires-and-provides" +" requires+provides_6" +" self_32" +" self_32)))" +"(let-values(((result-form_0)" +"(if(let-values(((or-part_188)" +"(expand-context-to-parsed?" +" init-ctx_0)))" +"(if or-part_188" +" or-part_188" +" always-produce-compiled?_0))" +"(parsed-module25.1" +" rebuild-s_14" +" #f" +" id:module-name225_0" +" self_32" +" requires_6" +" provides_13" +"(requires+provides-all-bindings-simple?" +" requires+provides_6)" +"(root-expand-context-encode-for-module" +" root-ctx_6" +" self_32" +" self_32)" +"(parsed-#%module-begin-body" +"(if(expanded+parsed?" +" expanded-mb_0)" +"(expanded+parsed-parsed" +" expanded-mb_0)" +" expanded-mb_0))" +"(unbox" +" compiled-module-box_0)" +" compiled-submodules_1)" +" #f)))" +"(let-values(((result-s_14)" +"(if(not" +"(expand-context-to-parsed?" +" init-ctx_0))" +"(let-values()" +"(let-values(((generic-self_0)" +"(make-generic-self-module-path-index" +" self_32)))" +"(begin" +"(imitate-generic-module-path-index!" +" self_32)" +"(let-values(((lst_426)" +"(unbox" +" mpis-to-reset_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_426)))" +"((letrec-values(((for-loop_329)" +"(lambda(lst_427)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_427)" +"(let-values(((mpi_55)" +"(unsafe-car" +" lst_427))" +"((rest_252)" +"(unsafe-cdr" +" lst_427)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(imitate-generic-module-path-index!" +" mpi_55))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_329" +" rest_252)" +"(values))))" +"(values))))))" +" for-loop_329)" +" lst_426)))" +"(void)" +"(let-values(((result-s_15)" +"(let-values(((rebuild-s428_0)" +" rebuild-s_14)" +"((temp429_0)" +"(list" +" module224_0" +" id:module-name225_0" +" initial-require-s_0" +"(expanded+parsed-s" +" expanded-mb_0))))" +"(rebuild5.1" +" #t" +" rebuild-s428_0" +" temp429_0))))" +"(let-values(((result-s_16)" +"(let-values(((result-s430_0)" +" result-s_15)" +"((self431_0)" +" self_32)" +"((generic-self432_0)" +" generic-self_0))" +"(syntax-module-path-index-shift13.1" +" #f" +" result-s430_0" +" self431_0" +" generic-self432_0" +" #f))))" +"(let-values(((result-s_17)" +"(attach-root-expand-context-properties" +" result-s_16" +" root-ctx_6" +" self_32" +" generic-self_0)))" +"(let-values(((result-s_18)" +"(if(requires+provides-all-bindings-simple?" +" requires+provides_6)" +"(syntax-property$1" +" result-s_17" +" 'module-body-context-simple?" +" #t)" +" result-s_17)))" +"(begin" +"(let-values(((obs_135)" +"(expand-context-observer" +" init-ctx_0)))" +"(if obs_135" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_135" +" 'rename-one" +" result-s_18)))" +"(void)))" +" result-s_18))))))))" +"(void))))" +"(if(expand-context-to-parsed?" +" init-ctx_0)" +"(let-values()" +" result-form_0)" +"(if always-produce-compiled?_0" +"(let-values()" +"(expanded+parsed1.1" +" result-s_14" +" result-form_0))" +"(let-values()" +" result-s_14)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(ensure-module-begin34.1)" +"(lambda(ctx22_0 def-ctx-scopes23_0 m-ns21_0 module-name-sym19_0 phase24_4 s25_0 scopes-s20_0 bodys33_0)" +"(begin" +" 'ensure-module-begin34" +"(let-values(((bodys_18) bodys33_0))" +"(let-values(((module-name-sym_1) module-name-sym19_0))" +"(let-values(((scopes-s_0) scopes-s20_0))" +"(let-values()" +"(let-values(((ctx_73) ctx22_0))" +"(let-values(((def-ctx-scopes_9) def-ctx-scopes23_0))" +"(let-values(((phase_145) phase24_4))" +"(let-values(((s_811) s25_0))" +"(let-values()" +"(let-values(((make-mb-ctx_0)" +"(lambda()" +"(begin" +" 'make-mb-ctx" +"(let-values(((v_275) ctx_73))" +"(let-values(((the-struct_114) v_275))" +"(if(expand-context/outer? the-struct_114)" +"(let-values(((context433_0) 'module-begin)" +"((only-immediate?434_0) #t)" +"((def-ctx-scopes435_0) def-ctx-scopes_9)" +"((inner436_0)(root-expand-context/outer-inner v_275)))" +"(expand-context/outer1.1" +" inner436_0" +"(root-expand-context/outer-post-expansion the-struct_114)" +"(root-expand-context/outer-use-site-scopes the-struct_114)" +"(root-expand-context/outer-frame-id the-struct_114)" +" context433_0" +"(expand-context/outer-env the-struct_114)" +"(expand-context/outer-scopes the-struct_114)" +" def-ctx-scopes435_0" +"(expand-context/outer-binding-layer the-struct_114)" +"(expand-context/outer-reference-records the-struct_114)" +" only-immediate?434_0" +"(expand-context/outer-need-eventually-defined the-struct_114)" +"(expand-context/outer-current-introduction-scopes the-struct_114)" +"(expand-context/outer-current-use-scopes the-struct_114)" +"(expand-context/outer-name the-struct_114)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_114))))))))" +"(let-values(((mb_1)" +"(if(= 1(length bodys_18))" +"(let-values()" +"(begin" +"(let-values(((obs_136)(expand-context-observer ctx_73)))" +"(if obs_136" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_136 'rename-one(car bodys_18))))" +"(void)))" +"(if(eq?" +" '#%module-begin" +"(core-form-sym(syntax-disarm$1(car bodys_18)) phase_145))" +"(let-values()(car bodys_18))" +"(let-values()" +"(let-values(((partly-expanded-body_0)" +"(let-values()" +"(let-values(((temp437_0)" +"(add-enclosing-name-property" +"(car bodys_18)" +" module-name-sym_1))" +"((temp438_0)(make-mb-ctx_0)))" +"(expand9.1 #f #f #f temp437_0 temp438_0)))))" +"(if(eq?" +" '#%module-begin" +"(core-form-sym" +"(syntax-disarm$1 partly-expanded-body_0)" +" phase_145))" +"(let-values() partly-expanded-body_0)" +"(let-values()" +"(let-values(((temp439_0)(list partly-expanded-body_0))" +"((s440_0) s_811)" +"((scopes-s441_0) scopes-s_0)" +"((phase442_0) phase_145)" +"((module-name-sym443_0) module-name-sym_1)" +"((temp444_0)(make-mb-ctx_0))" +"((temp445_0) #f))" +"(add-module-begin45.1" +" temp445_0" +" temp439_0" +" s440_0" +" scopes-s441_0" +" phase442_0" +" module-name-sym443_0" +" temp444_0)))))))))" +"(let-values()" +"(let-values(((bodys446_0) bodys_18)" +"((s447_0) s_811)" +"((scopes-s448_0) scopes-s_0)" +"((phase449_0) phase_145)" +"((module-name-sym450_0) module-name-sym_1)" +"((temp451_0)(make-mb-ctx_0)))" +"(add-module-begin45.1" +" #t" +" bodys446_0" +" s447_0" +" scopes-s448_0" +" phase449_0" +" module-name-sym450_0" +" temp451_0))))))" +"(add-enclosing-name-property mb_1 module-name-sym_1)))))))))))))))" +"(define-values" +"(add-module-begin45.1)" +"(lambda(log-rename-one?37_0 bodys39_0 s40_1 scopes-s41_0 phase42_1 module-name-sym43_0 mb-ctx44_0)" +"(begin" +" 'add-module-begin45" +"(let-values(((bodys_19) bodys39_0))" +"(let-values(((s_812) s40_1))" +"(let-values(((scopes-s_1) scopes-s41_0))" +"(let-values(((phase_105) phase42_1))" +"(let-values(((module-name-sym_2) module-name-sym43_0))" +"(let-values(((mb-ctx_1) mb-ctx44_0))" +"(let-values(((log-rename-one?_0) log-rename-one?37_0))" +"(let-values()" +"(let-values(((disarmed-scopes-s_0)(syntax-disarm$1 scopes-s_1)))" +"(let-values(((mb-id_0)(datum->syntax$1 disarmed-scopes-s_0 '#%module-begin)))" +"(let-values((()" +"(begin" +"(if(let-values(((mb-id452_0) mb-id_0)((phase453_0) phase_105))" +"(resolve40.1 #f #f null #f mb-id452_0 phase453_0))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"no #%module-begin binding in the module's language\"" +" s_812)))" +"(values))))" +"(let-values(((mb_2)" +"(datum->syntax$1 disarmed-scopes-s_0(list* mb-id_0 bodys_19) s_812 s_812)))" +"(let-values((()" +"(begin" +"(let-values(((obs_137)(expand-context-observer mb-ctx_1)))" +"(if obs_137" +"(let-values()" +"(let-values()(call-expand-observe obs_137 'tag mb_2)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if log-rename-one?_0" +"(let-values()" +"(let-values(((obs_138)(expand-context-observer mb-ctx_1)))" +"(if obs_138" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_138 'rename-one mb_2)))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((partly-expanded-mb_0)" +"(let-values()" +"(let-values(((temp454_1)" +"(add-enclosing-name-property mb_2 module-name-sym_2))" +"((mb-ctx455_0) mb-ctx_1))" +"(expand9.1 #f #f #f temp454_1 mb-ctx455_0)))))" +"(begin" +"(if(eq?" +" '#%module-begin" +"(core-form-sym(syntax-disarm$1 partly-expanded-mb_0) phase_105))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"expansion of #%module-begin is not a #%plain-module-begin form\"" +" s_812" +" partly-expanded-mb_0)))" +" partly-expanded-mb_0)))))))))))))))))))" +"(define-values" +"(add-enclosing-name-property)" +"(lambda(stx_21 module-name-sym_3)(begin(syntax-property$1 stx_21 'enclosing-module-name module-name-sym_3))))" +"(define-values" +"(make-apply-module-scopes)" +"(lambda(inside-scope_1" +" outside-scope_2" +" init-ctx_1" +" keep-enclosing-scope-at-phase_1" +" self_33" +" enclosing-self_2" +" enclosing-mod_2)" +"(begin" +"(lambda(s_813)" +"(let-values()" +"(let-values(((s-without-enclosing_0)" +"(if keep-enclosing-scope-at-phase_1" +" s_813" +"(remove-use-site-scopes" +"(remove-scopes s_813(root-expand-context-module-scopes init-ctx_1))" +" init-ctx_1))))" +"(let-values(((s-with-edges_0)" +"(add-scope(add-scope s-without-enclosing_0 outside-scope_2) inside-scope_1)))" +"(let-values(((s-with-suitable-enclosing_0)" +"(if keep-enclosing-scope-at-phase_1" +"(let-values()" +"(let-values(((s-with-edges460_0) s-with-edges_0)" +"((enclosing-self461_0) enclosing-self_2)" +"((enclosing-mod462_0) enclosing-mod_2))" +"(syntax-module-path-index-shift13.1" +" #f" +" s-with-edges460_0" +" enclosing-self461_0" +" enclosing-mod462_0" +" #f)))" +"(let-values() s-with-edges_0))))" +"(let-values(((s-with-suitable-enclosing456_0) s-with-suitable-enclosing_0)" +"((temp457_0)(make-generic-self-module-path-index self_33))" +"((self458_0) self_33)" +"((temp459_0)(current-code-inspector)))" +"(syntax-module-path-index-shift13.1" +" #f" +" s-with-suitable-enclosing456_0" +" temp457_0" +" self458_0" +" temp459_0))))))))))" +"(define-values" +"(partially-expand-bodys79.1)" +"(lambda(all-scopes-stx55_0" +" compiled-submodules59_0" +" ctx49_1" +" declared-keywords57_0" +" declared-submodule-names58_0" +" defined-syms56_0" +" frame-id52_0" +" loop62_0" +" modules-being-compiled60_0" +" mpis-to-reset61_0" +" namespace50_0" +" need-eventually-defined54_0" +" phase48_2" +" requires-and-provides53_0" +" self51_0" +" bodys78_0)" +"(begin" +" 'partially-expand-bodys79" +"(let-values(((bodys_20) bodys78_0))" +"(let-values(((phase_146) phase48_2))" +"(let-values(((partial-body-ctx_1) ctx49_1))" +"(let-values(((m-ns_20) namespace50_0))" +"(let-values(((self_34) self51_0))" +"(let-values(((frame-id_17) frame-id52_0))" +"(let-values(((requires+provides_7) requires-and-provides53_0))" +"(let-values(((need-eventually-defined_2) need-eventually-defined54_0))" +"(let-values(((all-scopes-stx_5) all-scopes-stx55_0))" +"(let-values(((defined-syms_12) defined-syms56_0))" +"(let-values(((declared-keywords_1) declared-keywords57_0))" +"(let-values(((declared-submodule-names_4) declared-submodule-names58_0))" +"(let-values(((compiled-submodules_2) compiled-submodules59_0))" +"(let-values(((modules-being-compiled_4) modules-being-compiled60_0))" +"(let-values(((mpis-to-reset_1) mpis-to-reset61_0))" +"(let-values(((pass-1-and-2-loop_1) loop62_0))" +"(let-values()" +"(begin" +"(namespace-visit-available-modules! m-ns_20 phase_146)" +"((letrec-values(((loop_124)" +"(lambda(tail?_53 bodys_21)" +"(begin" +" 'loop" +"(if(null? bodys_21)" +"(let-values()" +"(if(if tail?_53(not(zero? phase_146)) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_139)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_139" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_139" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(if tail?_53" +"(let-values()" +"(let-values(((bodys_22)" +"(append" +"(get-and-clear-end-lifts!" +"(expand-context-to-module-lifts" +" partial-body-ctx_1))" +"(get-and-clear-provide-lifts!" +"(expand-context-to-module-lifts" +" partial-body-ctx_1)))))" +"(begin" +"(let-values(((obs_140)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_140" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_140" +" 'module-lift-end-loop" +" bodys_22)))" +"(void)))" +"(if(null? bodys_22)" +"(let-values() null)" +"(let-values()" +"(loop_124" +" #t" +"(add-post-expansion-scope" +" bodys_22" +" partial-body-ctx_1)))))))" +"(let-values() null))))" +"(let-values()" +"(let-values(((rest-bodys_1)(cdr bodys_21)))" +"(let-values((()" +"(begin" +"(let-values(((obs_141)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_141" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_141" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_7)" +"(let-values()" +"(let-values(((temp463_1)" +"(car bodys_21))" +"((partial-body-ctx464_0)" +" partial-body-ctx_1))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp463_1" +" partial-body-ctx464_0)))))" +"(let-values(((disarmed-exp-body_1)" +"(syntax-disarm$1 exp-body_7)))" +"(let-values(((lifted-defns_0)" +"(get-and-clear-lifts!" +"(expand-context-lifts" +" partial-body-ctx_1))))" +"(begin" +"(if(pair? lifted-defns_0)" +"(let-values()" +"(log-lifted-defns" +" partial-body-ctx_1" +" lifted-defns_0" +" exp-body_7" +" rest-bodys_1))" +"(void))" +"(let-values(((obs_142)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_142" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_142" +" 'rename-one" +" exp-body_7)))" +"(void)))" +"(let-values(((finish_2)" +"(lambda()" +"(begin" +" 'finish" +"(let-values(((tmp_64)" +"(core-form-sym" +" disarmed-exp-body_1" +" phase_146)))" +"(if(equal?" +" tmp_64" +" 'begin)" +"(let-values()" +"(let-values(((ok?_81" +" begin465_0" +" e466_0)" +"(let-values(((s_814)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_83)" +" s_814))" +"(let-values(((begin465_1" +" e466_1)" +"(let-values(((s_815)" +"(if(syntax?$1" +" s_814)" +"(syntax-e$1" +" s_814)" +" s_814)))" +"(if(pair?" +" s_815)" +"(let-values(((begin467_0)" +"(let-values(((s_816)" +"(car" +" s_815)))" +" s_816))" +"((e468_0)" +"(let-values(((s_817)" +"(cdr" +" s_815)))" +"(let-values(((s_818)" +"(if(syntax?$1" +" s_817)" +"(syntax-e$1" +" s_817)" +" s_817)))" +"(let-values(((flat-s_57)" +"(to-syntax-list.1" +" s_818)))" +"(if(not" +" flat-s_57)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_83))" +"(let-values()" +" flat-s_57)))))))" +"(values" +" begin467_0" +" e468_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_83)))))" +"(values" +" #t" +" begin465_1" +" e466_1))))))" +"(let-values(((track_1)" +"(lambda(e_95)" +"(begin" +" 'track" +"(syntax-track-origin$1" +" e_95" +" exp-body_7)))))" +"(let-values(((spliced-bodys_0)" +"(append" +"(map2" +" track_1" +" e466_0)" +" rest-bodys_1)))" +"(begin" +"(let-values(((obs_143)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_143" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_143" +" 'splice" +" spliced-bodys_0)))" +"(void)))" +"(loop_124" +" tail?_53" +" spliced-bodys_0))))))" +"(if(equal?" +" tmp_64" +" 'begin-for-syntax)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_144)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_144" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_144" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_144" +" 'prim-begin-for-syntax)" +"(call-expand-observe" +" obs_144" +" 'prepare-env))))" +"(void)))" +"(values))))" +"(let-values(((ct-m-ns_0)" +"(namespace->namespace-at-phase" +" m-ns_20" +"(add1" +" phase_146))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" partial-body-ctx_1)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_145)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_145" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_145" +" 'phase-up)))" +"(void)))" +"(values))))" +"(let-values(((ok?_82" +" begin-for-syntax469_0" +" e470_0)" +"(let-values(((s_819)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_84)" +" s_819))" +"(let-values(((begin-for-syntax469_1" +" e470_1)" +"(let-values(((s_820)" +"(if(syntax?$1" +" s_819)" +"(syntax-e$1" +" s_819)" +" s_819)))" +"(if(pair?" +" s_820)" +"(let-values(((begin-for-syntax471_0)" +"(let-values(((s_821)" +"(car" +" s_820)))" +" s_821))" +"((e472_0)" +"(let-values(((s_822)" +"(cdr" +" s_820)))" +"(let-values(((s_823)" +"(if(syntax?$1" +" s_822)" +"(syntax-e$1" +" s_822)" +" s_822)))" +"(let-values(((flat-s_58)" +"(to-syntax-list.1" +" s_823)))" +"(if(not" +" flat-s_58)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84))" +"(let-values()" +" flat-s_58)))))))" +"(values" +" begin-for-syntax471_0" +" e472_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84)))))" +"(values" +" #t" +" begin-for-syntax469_1" +" e470_1))))))" +"(let-values(((nested-bodys_1)" +"(pass-1-and-2-loop_1" +" e470_0" +"(add1" +" phase_146))))" +"(begin" +"(let-values(((obs_146)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_146" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_146" +" 'next-group)))" +"(void)))" +"(namespace-run-available-modules!" +" m-ns_20" +"(add1" +" phase_146))" +"(eval-nested-bodys" +" nested-bodys_1" +"(add1" +" phase_146)" +" ct-m-ns_0" +" self_34" +" partial-body-ctx_1)" +"(namespace-visit-available-modules!" +" m-ns_20" +" phase_146)" +"(let-values(((obs_147)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_147" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_147" +" 'exit-prim" +"(let-values(((s-nested-bodys_0)" +"(reverse$1" +"(let-values(((lst_428)" +" nested-bodys_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_428)))" +"((letrec-values(((for-loop_154)" +"(lambda(fold-var_376" +" lst_429)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_429)" +"(let-values(((nested-body_0)" +"(unsafe-car" +" lst_429))" +"((rest_253)" +"(unsafe-cdr" +" lst_429)))" +"(let-values(((fold-var_377)" +"(let-values(((fold-var_378)" +" fold-var_376))" +"(let-values(((fold-var_355)" +"(let-values()" +"(cons" +"(let-values()" +"(extract-syntax" +" nested-body_0))" +" fold-var_378))))" +"(values" +" fold-var_355)))))" +"(if(not" +" #f)" +"(for-loop_154" +" fold-var_377" +" rest_253)" +" fold-var_377)))" +" fold-var_376)))))" +" for-loop_154)" +" null" +" lst_428))))))" +"(datum->syntax$1" +" #f" +"(cons" +" begin-for-syntax469_0" +" s-nested-bodys_0)" +" exp-body_7)))))" +"(void)))" +"(cons" +"(semi-parsed-begin-for-syntax3.1" +" exp-body_7" +" nested-bodys_1)" +"(loop_124" +" tail?_53" +" rest-bodys_1))))))))))" +"(if(equal?" +" tmp_64" +" 'define-values)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_148)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_148" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_148" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_148" +" 'prim-define-values))))" +"(void)))" +"(values))))" +"(let-values(((ok?_83" +" define-values473_0" +" id474_0" +" rhs475_0)" +"(let-values(((s_824)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_85)" +" s_824))" +"(let-values(((define-values473_1" +" id474_1" +" rhs475_1)" +"(let-values(((s_825)" +"(if(syntax?$1" +" s_824)" +"(syntax-e$1" +" s_824)" +" s_824)))" +"(if(pair?" +" s_825)" +"(let-values(((define-values476_0)" +"(let-values(((s_826)" +"(car" +" s_825)))" +" s_826))" +"((id477_0" +" rhs478_0)" +"(let-values(((s_827)" +"(cdr" +" s_825)))" +"(let-values(((s_828)" +"(if(syntax?$1" +" s_827)" +"(syntax-e$1" +" s_827)" +" s_827)))" +"(if(pair?" +" s_828)" +"(let-values(((id479_0)" +"(let-values(((s_829)" +"(car" +" s_828)))" +"(let-values(((s_830)" +"(if(syntax?$1" +" s_829)" +"(syntax-e$1" +" s_829)" +" s_829)))" +"(let-values(((flat-s_59)" +"(to-syntax-list.1" +" s_830)))" +"(if(not" +" flat-s_59)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))" +"(let-values()" +"(let-values(((id_146)" +"(let-values(((lst_430)" +" flat-s_59))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_430)))" +"((letrec-values(((for-loop_330)" +"(lambda(id_147" +" lst_431)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_431)" +"(let-values(((s_831)" +"(unsafe-car" +" lst_431))" +"((rest_254)" +"(unsafe-cdr" +" lst_431)))" +"(let-values(((id_148)" +"(let-values(((id_149)" +" id_147))" +"(let-values(((id_150)" +"(let-values()" +"(let-values(((id492_0)" +"(let-values()" +"(if(let-values(((or-part_405)" +"(if(syntax?$1" +" s_831)" +"(symbol?" +"(syntax-e$1" +" s_831))" +" #f)))" +"(if or-part_405" +" or-part_405" +"(symbol?" +" s_831)))" +" s_831" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_85" +" s_831)))))" +"(cons" +" id492_0" +" id_149)))))" +"(values" +" id_150)))))" +"(if(not" +" #f)" +"(for-loop_330" +" id_148" +" rest_254)" +" id_148)))" +" id_147)))))" +" for-loop_330)" +" null" +" lst_430)))))" +"(reverse$1" +" id_146))))))))" +"((rhs480_0)" +"(let-values(((s_832)" +"(cdr" +" s_828)))" +"(let-values(((s_833)" +"(if(syntax?$1" +" s_832)" +"(syntax-e$1" +" s_832)" +" s_832)))" +"(if(pair?" +" s_833)" +"(let-values(((rhs481_0)" +"(let-values(((s_834)" +"(car" +" s_833)))" +" s_834))" +"(()" +"(let-values(((s_835)" +"(cdr" +" s_833)))" +"(let-values(((s_836)" +"(if(syntax?$1" +" s_835)" +"(syntax-e$1" +" s_835)" +" s_835)))" +"(if(null?" +" s_836)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" rhs481_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" id479_0" +" rhs480_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" define-values476_0" +" id477_0" +" rhs478_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85)))))" +"(values" +" #t" +" define-values473_1" +" id474_1" +" rhs475_1))))))" +"(let-values(((ids_44)" +"(remove-use-site-scopes" +" id474_0" +" partial-body-ctx_1)))" +"(let-values((()" +"(begin" +"(let-values(((ids482_0)" +" ids_44)" +"((phase483_0)" +" phase_146)" +"((exp-body484_0)" +" exp-body_7))" +"(check-no-duplicate-ids7.1" +" unsafe-undefined" +" ids482_0" +" phase483_0" +" exp-body484_0" +" unsafe-undefined))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((ids485_0)" +" ids_44)" +"((phase486_0)" +" phase_146)" +"((requires+provides487_0)" +" requires+provides_7)" +"((exp-body488_0)" +" exp-body_7))" +"(check-ids-unbound171.1" +" exp-body488_0" +" ids485_0" +" phase486_0" +" requires+provides487_0))" +"(values))))" +"(let-values(((syms_23)" +"(let-values(((ids493_0)" +" ids_44)" +"((defined-syms494_0)" +" defined-syms_12)" +"((self495_0)" +" self_34)" +"((phase496_0)" +" phase_146)" +"((all-scopes-stx497_0)" +" all-scopes-stx_5)" +"((frame-id498_0)" +" frame-id_17)" +"((requires+provides499_0)" +" requires+provides_7)" +"((exp-body500_0)" +" exp-body_7))" +"(select-defined-syms-and-bind!16.1" +" #f" +" frame-id498_0" +" exp-body500_0" +" requires+provides499_0" +" #f" +" ids493_0" +" defined-syms494_0" +" self495_0" +" phase496_0" +" all-scopes-stx497_0))))" +"(begin" +"(let-values(((lst_432)" +" syms_23))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_432)))" +"((letrec-values(((for-loop_331)" +"(lambda(lst_260)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_260)" +"(let-values(((sym_23)" +"(unsafe-car" +" lst_260))" +"((rest_142)" +"(unsafe-cdr" +" lst_260)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-unset-transformer!" +" m-ns_20" +" phase_146" +" sym_23))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_331" +" rest_142)" +"(values))))" +"(values))))))" +" for-loop_331)" +" lst_432)))" +"(void)" +"(let-values(((requires+provides489_0)" +" requires+provides_7)" +"((syms490_0)" +" syms_23)" +"((phase491_0)" +" phase_146))" +"(add-defined-syms!103.1" +" #f" +" requires+provides489_0" +" syms490_0" +" phase491_0))" +"(let-values(((obs_149)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_149" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_149" +" 'exit-prim" +"(datum->syntax$1" +" #f" +"(list" +" define-values473_0" +" ids_44" +" rhs475_0)" +" exp-body_7))))" +"(void)))" +"(cons" +"(semi-parsed-define-values2.1" +" exp-body_7" +" syms_23" +" ids_44" +" rhs475_0)" +"(loop_124" +" tail?_53" +" rest-bodys_1))))))))))" +"(if(equal?" +" tmp_64" +" 'define-syntaxes)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_150)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_150" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_150" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_150" +" 'prim-define-syntaxes)" +"(call-expand-observe" +" obs_150" +" 'prepare-env))))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" partial-body-ctx_1)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_151)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_151" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_151" +" 'phase-up)))" +"(void)))" +"(values))))" +"(let-values(((ok?_84" +" define-syntaxes501_0" +" id502_0" +" rhs503_0)" +"(let-values(((s_837)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_86)" +" s_837))" +"(let-values(((define-syntaxes501_1" +" id502_1" +" rhs503_1)" +"(let-values(((s_838)" +"(if(syntax?$1" +" s_837)" +"(syntax-e$1" +" s_837)" +" s_837)))" +"(if(pair?" +" s_838)" +"(let-values(((define-syntaxes504_0)" +"(let-values(((s_839)" +"(car" +" s_838)))" +" s_839))" +"((id505_0" +" rhs506_0)" +"(let-values(((s_840)" +"(cdr" +" s_838)))" +"(let-values(((s_841)" +"(if(syntax?$1" +" s_840)" +"(syntax-e$1" +" s_840)" +" s_840)))" +"(if(pair?" +" s_841)" +"(let-values(((id507_0)" +"(let-values(((s_842)" +"(car" +" s_841)))" +"(let-values(((s_843)" +"(if(syntax?$1" +" s_842)" +"(syntax-e$1" +" s_842)" +" s_842)))" +"(let-values(((flat-s_60)" +"(to-syntax-list.1" +" s_843)))" +"(if(not" +" flat-s_60)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86))" +"(let-values()" +"(let-values(((id_151)" +"(let-values(((lst_433)" +" flat-s_60))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_433)))" +"((letrec-values(((for-loop_332)" +"(lambda(id_152" +" lst_434)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_434)" +"(let-values(((s_844)" +"(unsafe-car" +" lst_434))" +"((rest_255)" +"(unsafe-cdr" +" lst_434)))" +"(let-values(((id_153)" +"(let-values(((id_154)" +" id_152))" +"(let-values(((id_155)" +"(let-values()" +"(let-values(((id521_0)" +"(let-values()" +"(if(let-values(((or-part_406)" +"(if(syntax?$1" +" s_844)" +"(symbol?" +"(syntax-e$1" +" s_844))" +" #f)))" +"(if or-part_406" +" or-part_406" +"(symbol?" +" s_844)))" +" s_844" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_86" +" s_844)))))" +"(cons" +" id521_0" +" id_154)))))" +"(values" +" id_155)))))" +"(if(not" +" #f)" +"(for-loop_332" +" id_153" +" rest_255)" +" id_153)))" +" id_152)))))" +" for-loop_332)" +" null" +" lst_433)))))" +"(reverse$1" +" id_151))))))))" +"((rhs508_0)" +"(let-values(((s_845)" +"(cdr" +" s_841)))" +"(let-values(((s_846)" +"(if(syntax?$1" +" s_845)" +"(syntax-e$1" +" s_845)" +" s_845)))" +"(if(pair?" +" s_846)" +"(let-values(((rhs509_0)" +"(let-values(((s_847)" +"(car" +" s_846)))" +" s_847))" +"(()" +"(let-values(((s_848)" +"(cdr" +" s_846)))" +"(let-values(((s_849)" +"(if(syntax?$1" +" s_848)" +"(syntax-e$1" +" s_848)" +" s_848)))" +"(if(null?" +" s_849)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86))))))" +"(values" +" rhs509_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86))))))" +"(values" +" id507_0" +" rhs508_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86))))))" +"(values" +" define-syntaxes504_0" +" id505_0" +" rhs506_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86)))))" +"(values" +" #t" +" define-syntaxes501_1" +" id502_1" +" rhs503_1))))))" +"(let-values(((ids_45)" +"(remove-use-site-scopes" +" id502_0" +" partial-body-ctx_1)))" +"(let-values((()" +"(begin" +"(let-values(((ids510_0)" +" ids_45)" +"((phase511_0)" +" phase_146)" +"((exp-body512_0)" +" exp-body_7))" +"(check-no-duplicate-ids7.1" +" unsafe-undefined" +" ids510_0" +" phase511_0" +" exp-body512_0" +" unsafe-undefined))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((ids513_0)" +" ids_45)" +"((phase514_0)" +" phase_146)" +"((requires+provides515_0)" +" requires+provides_7)" +"((exp-body516_0)" +" exp-body_7))" +"(check-ids-unbound171.1" +" exp-body516_0" +" ids513_0" +" phase514_0" +" requires+provides515_0))" +"(values))))" +"(let-values(((syms_24)" +"(let-values(((ids522_0)" +" ids_45)" +"((defined-syms523_0)" +" defined-syms_12)" +"((self524_0)" +" self_34)" +"((phase525_0)" +" phase_146)" +"((all-scopes-stx526_0)" +" all-scopes-stx_5)" +"((frame-id527_0)" +" frame-id_17)" +"((requires+provides528_0)" +" requires+provides_7)" +"((exp-body529_0)" +" exp-body_7)" +"((temp530_0)" +" #t))" +"(select-defined-syms-and-bind!16.1" +" temp530_0" +" frame-id527_0" +" exp-body529_0" +" requires+provides528_0" +" #f" +" ids522_0" +" defined-syms523_0" +" self524_0" +" phase525_0" +" all-scopes-stx526_0))))" +"(let-values((()" +"(begin" +"(let-values(((requires+provides517_0)" +" requires+provides_7)" +"((syms518_0)" +" syms_24)" +"((phase519_0)" +" phase_146)" +"((temp520_0)" +" #t))" +"(add-defined-syms!103.1" +" temp520_0" +" requires+provides517_0" +" syms518_0" +" phase519_0))" +"(values))))" +"(let-values(((exp-rhs_6" +" parsed-rhs_2" +" vals_10)" +"(let-values(((temp531_0)" +" 'define-syntaxes)" +"((temp532_0)" +" rhs503_0)" +"((ids533_0)" +" ids_45)" +"((temp534_0)" +"(let-values(((v_276)" +" partial-body-ctx_1))" +"(let-values(((the-struct_115)" +" v_276))" +"(if(expand-context/outer?" +" the-struct_115)" +"(let-values(((need-eventually-defined536_0)" +" need-eventually-defined_2)" +"((inner537_0)" +"(let-values(((the-struct_116)" +"(root-expand-context/outer-inner" +" v_276)))" +"(if(expand-context/inner?" +" the-struct_116)" +"(let-values(((lifts538_0)" +" #f)" +"((module-lifts539_0)" +" #f)" +"((to-module-lifts540_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_116)" +"(root-expand-context/inner-module-scopes" +" the-struct_116)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_116)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_116)" +"(root-expand-context/inner-defined-syms" +" the-struct_116)" +"(root-expand-context/inner-counter" +" the-struct_116)" +"(root-expand-context/inner-lift-key" +" the-struct_116)" +"(expand-context/inner-to-parsed?" +" the-struct_116)" +"(expand-context/inner-phase" +" the-struct_116)" +"(expand-context/inner-namespace" +" the-struct_116)" +"(expand-context/inner-just-once?" +" the-struct_116)" +"(expand-context/inner-module-begin-k" +" the-struct_116)" +"(expand-context/inner-allow-unbound?" +" the-struct_116)" +"(expand-context/inner-in-local-expand?" +" the-struct_116)" +"(expand-context/inner-keep-#%expression?" +" the-struct_116)" +"(expand-context/inner-stops" +" the-struct_116)" +"(expand-context/inner-declared-submodule-names" +" the-struct_116)" +" lifts538_0" +"(expand-context/inner-lift-envs" +" the-struct_116)" +" module-lifts539_0" +"(expand-context/inner-require-lifts" +" the-struct_116)" +" to-module-lifts540_0" +"(expand-context/inner-requires+provides" +" the-struct_116)" +"(expand-context/inner-observer" +" the-struct_116)" +"(expand-context/inner-for-serializable?" +" the-struct_116)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_116)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_116)))))" +"(expand-context/outer1.1" +" inner537_0" +"(root-expand-context/outer-post-expansion" +" the-struct_115)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_115)" +"(root-expand-context/outer-frame-id" +" the-struct_115)" +"(expand-context/outer-context" +" the-struct_115)" +"(expand-context/outer-env" +" the-struct_115)" +"(expand-context/outer-scopes" +" the-struct_115)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_115)" +"(expand-context/outer-binding-layer" +" the-struct_115)" +"(expand-context/outer-reference-records" +" the-struct_115)" +"(expand-context/outer-only-immediate?" +" the-struct_115)" +" need-eventually-defined536_0" +"(expand-context/outer-current-introduction-scopes" +" the-struct_115)" +"(expand-context/outer-current-use-scopes" +" the-struct_115)" +"(expand-context/outer-name" +" the-struct_115)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_115)))))" +"((temp535_0)" +" #f))" +"(expand+eval-for-syntaxes-binding108.1" +" temp535_0" +" temp531_0" +" temp532_0" +" ids533_0" +" temp534_0))))" +"(let-values((()" +"(begin" +"(let-values(((lst_435)" +" syms_24)" +"((lst_436)" +" vals_10)" +"((lst_437)" +" ids_45))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_435)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_436)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_437)))" +"((letrec-values(((for-loop_333)" +"(lambda(lst_438" +" lst_439" +" lst_440)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_438)" +"(if(pair?" +" lst_439)" +"(pair?" +" lst_440)" +" #f)" +" #f)" +"(let-values(((sym_110)" +"(unsafe-car" +" lst_438))" +"((rest_256)" +"(unsafe-cdr" +" lst_438))" +"((val_87)" +"(unsafe-car" +" lst_439))" +"((rest_257)" +"(unsafe-cdr" +" lst_439))" +"((id_156)" +"(unsafe-car" +" lst_440))" +"((rest_258)" +"(unsafe-cdr" +" lst_440)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_87" +" id_156" +" phase_146" +" partial-body-ctx_1)" +"(namespace-set-transformer!" +" m-ns_20" +" phase_146" +" sym_110" +" val_87)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_333" +" rest_256" +" rest_257" +" rest_258)" +"(values))))" +"(values))))))" +" for-loop_333)" +" lst_435" +" lst_436" +" lst_437)))" +"(values))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_152)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_152" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_152" +" 'exit-prim" +"(datum->syntax$1" +" #f" +"(list" +" define-syntaxes501_0" +" ids_45" +" exp-rhs_6)))))" +"(void)))" +"(values))))" +"(let-values(((parsed-body_0)" +"(parsed-define-syntaxes20.1" +"(keep-properties-only" +" exp-body_7)" +" ids_45" +" syms_24" +" parsed-rhs_2)))" +"(cons" +"(if(expand-context-to-parsed?" +" partial-body-ctx_1)" +" parsed-body_0" +"(expanded+parsed1.1" +"(let-values(((exp-body541_0)" +" exp-body_7)" +"((temp542_0)" +"(list" +" define-syntaxes501_0" +" ids_45" +" exp-rhs_6)))" +"(rebuild5.1" +" #t" +" exp-body541_0" +" temp542_0))" +" parsed-body_0))" +"(loop_124" +" tail?_53" +" rest-bodys_1)))))))))))))))))" +"(if(equal?" +" tmp_64" +" '#%require)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_153)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_153" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_153" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_153" +" 'prim-require))))" +"(void)))" +"(values))))" +"(let-values(((ready-body_0)" +"(remove-use-site-scopes" +" disarmed-exp-body_1" +" partial-body-ctx_1)))" +"(let-values(((ok?_85" +" #%require543_0" +" req544_0)" +"(let-values(((s_850)" +" ready-body_0))" +"(let-values(((orig-s_87)" +" s_850))" +"(let-values(((#%require543_1" +" req544_1)" +"(let-values(((s_851)" +"(if(syntax?$1" +" s_850)" +"(syntax-e$1" +" s_850)" +" s_850)))" +"(if(pair?" +" s_851)" +"(let-values(((#%require545_0)" +"(let-values(((s_852)" +"(car" +" s_851)))" +" s_852))" +"((req546_0)" +"(let-values(((s_853)" +"(cdr" +" s_851)))" +"(let-values(((s_854)" +"(if(syntax?$1" +" s_853)" +"(syntax-e$1" +" s_853)" +" s_853)))" +"(let-values(((flat-s_61)" +"(to-syntax-list.1" +" s_854)))" +"(if(not" +" flat-s_61)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_87))" +"(let-values()" +" flat-s_61)))))))" +"(values" +" #%require545_0" +" req546_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_87)))))" +"(values" +" #t" +" #%require543_1" +" req544_1))))))" +"(begin" +"(let-values(((temp547_0)" +" req544_0)" +"((exp-body548_0)" +" exp-body_7)" +"((self549_0)" +" self_34)" +"((m-ns550_0)" +" m-ns_20)" +"((phase551_0)" +" phase_146)" +"((phase552_0)" +" phase_146)" +"((requires+provides553_0)" +" requires+provides_7)" +"((declared-submodule-names554_0)" +" declared-submodule-names_4)" +"((temp555_0)" +" 'module))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" declared-submodule-names554_0" +" #f" +" phase552_0" +" #f" +" self549_0" +" #f" +" #t" +" temp555_0" +" temp547_0" +" exp-body548_0" +" m-ns550_0" +" phase551_0" +" requires+provides553_0))" +"(let-values(((obs_154)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_154" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_154" +" 'exit-prim" +" ready-body_0)))" +"(void)))" +"(cons" +" exp-body_7" +"(loop_124" +" tail?_53" +" rest-bodys_1)))))))" +"(if(equal?" +" tmp_64" +" '#%provide)" +"(let-values()" +"(cons" +" exp-body_7" +"(loop_124" +" tail?_53" +" rest-bodys_1)))" +"(if(equal?" +" tmp_64" +" 'module)" +"(let-values()" +"(let-values(((ready-body_1)" +"(remove-use-site-scopes" +" exp-body_7" +" partial-body-ctx_1)))" +"(let-values(((submod_2)" +"(let-values(((ready-body556_0)" +" ready-body_1)" +"((self557_0)" +" self_34)" +"((partial-body-ctx558_0)" +" partial-body-ctx_1)" +"((temp559_0)" +" #f)" +"((declared-submodule-names560_0)" +" declared-submodule-names_4)" +"((mpis-to-reset561_0)" +" mpis-to-reset_1)" +"((compiled-submodules562_0)" +" compiled-submodules_2)" +"((modules-being-compiled563_0)" +" modules-being-compiled_4))" +"(expand-submodule193.1" +" compiled-submodules562_0" +" declared-submodule-names560_0" +" #f" +" #f" +" temp559_0" +" #f" +" modules-being-compiled563_0" +" mpis-to-reset561_0" +" ready-body556_0" +" self557_0" +" partial-body-ctx558_0))))" +"(cons" +" submod_2" +"(loop_124" +" tail?_53" +" rest-bodys_1)))))" +"(if(equal?" +" tmp_64" +" 'module*)" +"(let-values()" +"(begin" +"(let-values(((obs_155)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_155" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_155" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_155" +" 'prim-submodule*)" +"(call-expand-observe" +" obs_155" +" 'exit-prim" +" exp-body_7))))" +"(void)))" +"(cons" +" exp-body_7" +"(loop_124" +" tail?_53" +" rest-bodys_1))))" +"(if(equal?" +" tmp_64" +" '#%declare)" +"(let-values()" +"(let-values(((ok?_86" +" #%declare564_0" +" kw565_0)" +"(let-values(((s_855)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_88)" +" s_855))" +"(let-values(((#%declare564_1" +" kw565_1)" +"(let-values(((s_856)" +"(if(syntax?$1" +" s_855)" +"(syntax-e$1" +" s_855)" +" s_855)))" +"(if(pair?" +" s_856)" +"(let-values(((#%declare566_0)" +"(let-values(((s_274)" +"(car" +" s_856)))" +" s_274))" +"((kw567_0)" +"(let-values(((s_857)" +"(cdr" +" s_856)))" +"(let-values(((s_858)" +"(if(syntax?$1" +" s_857)" +"(syntax-e$1" +" s_857)" +" s_857)))" +"(let-values(((flat-s_62)" +"(to-syntax-list.1" +" s_858)))" +"(if(not" +" flat-s_62)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88))" +"(let-values()" +" flat-s_62)))))))" +"(values" +" #%declare566_0" +" kw567_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88)))))" +"(values" +" #t" +" #%declare564_1" +" kw565_1))))))" +"(let-values((()" +"(begin" +"(let-values(((lst_441)" +" kw565_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_441)))" +"((letrec-values(((for-loop_334)" +"(lambda(lst_442)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_442)" +"(let-values(((kw_1)" +"(unsafe-car" +" lst_442))" +"((rest_259)" +"(unsafe-cdr" +" lst_442)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(if(keyword?" +"(syntax-e$1" +" kw_1))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"expected a keyword\"" +" exp-body_7" +" kw_1)))" +"(if(memq" +"(syntax-e$1" +" kw_1)" +" '(#:cross-phase-persistent" +" #:empty-namespace))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"not an allowed declaration keyword\"" +" exp-body_7" +" kw_1)))" +"(if(hash-ref" +" declared-keywords_1" +"(syntax-e$1" +" kw_1)" +" #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"keyword declared multiple times\"" +" exp-body_7" +" kw_1))" +"(void))" +"(hash-set!" +" declared-keywords_1" +"(syntax-e$1" +" kw_1)" +" kw_1)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_334" +" rest_259)" +"(values))))" +"(values))))))" +" for-loop_334)" +" lst_441)))" +"(values))))" +"(let-values()" +"(let-values(((parsed-body_1)" +"(parsed-#%declare22.1" +" exp-body_7)))" +"(cons" +"(if(expand-context-to-parsed?" +" partial-body-ctx_1)" +" parsed-body_1" +"(expanded+parsed1.1" +" exp-body_7" +" parsed-body_1))" +"(loop_124" +" tail?_53" +" rest-bodys_1)))))))" +"(let-values()" +"(cons" +" exp-body_7" +"(loop_124" +" tail?_53" +" rest-bodys_1)))))))))))))))))" +"(let-values(((l_88)" +"(append" +"(get-and-clear-require-lifts!" +"(expand-context-require-lifts" +" partial-body-ctx_1))" +" lifted-defns_0" +"(loop_124" +" #f" +"(add-post-expansion-scope" +"(get-and-clear-module-lifts!" +"(expand-context-module-lifts" +" partial-body-ctx_1))" +" partial-body-ctx_1)))))" +"(if(null? l_88)" +"(finish_2)" +"(append" +" l_88" +"(finish_2)))))))))))))))))" +" loop_124)" +" #t" +" bodys_20))))))))))))))))))))))" +"(define-values" +"(make-wrap-as-definition)" +"(lambda(self_35 frame-id_18 inside-scope_2 all-scopes-stx_6 defined-syms_13 requires+provides_8)" +"(begin" +"(lambda(ids_46 rhs_23 phase_147)" +"(let-values(((scoped-ids_0)" +"(reverse$1" +"(let-values(((lst_443) ids_46))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_443)))" +"((letrec-values(((for-loop_335)" +"(lambda(fold-var_379 lst_444)" +"(begin" +" 'for-loop" +"(if(pair? lst_444)" +"(let-values(((id_157)(unsafe-car lst_444))" +"((rest_260)(unsafe-cdr lst_444)))" +"(let-values(((fold-var_380)" +"(let-values(((fold-var_381) fold-var_379))" +"(let-values(((fold-var_382)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_157" +" inside-scope_2))" +" fold-var_381))))" +"(values fold-var_382)))))" +"(if(not #f)(for-loop_335 fold-var_380 rest_260) fold-var_380)))" +" fold-var_379)))))" +" for-loop_335)" +" null" +" lst_443))))))" +"(let-values(((syms_25)" +"(let-values(((scoped-ids568_0) scoped-ids_0)" +"((defined-syms569_0) defined-syms_13)" +"((self570_0) self_35)" +"((phase571_0) phase_147)" +"((all-scopes-stx572_0) all-scopes-stx_6)" +"((frame-id573_0) frame-id_18)" +"((requires+provides574_0) requires+provides_8))" +"(select-defined-syms-and-bind!16.1" +" #f" +" frame-id573_0" +" #f" +" requires+provides574_0" +" #f" +" scoped-ids568_0" +" defined-syms569_0" +" self570_0" +" phase571_0" +" all-scopes-stx572_0))))" +"(let-values(((s_292)" +"(add-scope" +"(datum->syntax$1" +" #f" +"(list" +"(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_147) 'define-values)" +" scoped-ids_0" +" rhs_23))" +" inside-scope_2)))" +"(values scoped-ids_0(semi-parsed-define-values2.1 s_292 syms_25 scoped-ids_0 rhs_23)))))))))" +"(define-values" +"(add-post-expansion-scope)" +"(lambda(bodys_23 ctx_114)" +"(begin" +"(let-values(((pe_3)(root-expand-context-post-expansion ctx_114)))" +"(if pe_3" +"(reverse$1" +"(let-values(((lst_445) bodys_23))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_445)))" +"((letrec-values(((for-loop_336)" +"(lambda(fold-var_383 lst_446)" +"(begin" +" 'for-loop" +"(if(pair? lst_446)" +"(let-values(((body_21)(unsafe-car lst_446))((rest_261)(unsafe-cdr lst_446)))" +"(let-values(((fold-var_384)" +"(let-values(((fold-var_385) fold-var_383))" +"(let-values(((fold-var_386)" +"(let-values()" +"(cons" +"(let-values()" +"(apply-post-expansion pe_3 body_21))" +" fold-var_385))))" +"(values fold-var_386)))))" +"(if(not #f)(for-loop_336 fold-var_384 rest_261) fold-var_384)))" +" fold-var_383)))))" +" for-loop_336)" +" null" +" lst_445))))" +" bodys_23)))))" +"(define-values" +"(finish-expanding-body-expressons97.1)" +"(lambda(compiled-submodules86_0" +" ctx83_0" +" declared-submodule-names85_0" +" modules-being-compiled87_0" +" mpis-to-reset88_0" +" phase82_0" +" self84_0" +" partially-expanded-bodys96_0)" +"(begin" +" 'finish-expanding-body-expressons97" +"(let-values(((partially-expanded-bodys_1) partially-expanded-bodys96_0))" +"(let-values(((phase_148) phase82_0))" +"(let-values(((body-ctx_7) ctx83_0))" +"(let-values(((self_36) self84_0))" +"(let-values(((declared-submodule-names_5) declared-submodule-names85_0))" +"(let-values(((compiled-submodules_3) compiled-submodules86_0))" +"(let-values(((modules-being-compiled_5) modules-being-compiled87_0))" +"(let-values(((mpis-to-reset_2) mpis-to-reset88_0))" +"(let-values()" +"((letrec-values(((loop_125)" +"(lambda(tail?_54 bodys_24)" +"(begin" +" 'loop" +"(if(null? bodys_24)" +"(let-values()" +"(if(if tail?_54(not(zero? phase_148)) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_156)(expand-context-observer body-ctx_7)))" +"(if obs_156" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_156" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(if tail?_54" +"(let-values()" +"(let-values(((bodys_25)" +"(append" +"(get-and-clear-end-lifts!" +"(expand-context-to-module-lifts body-ctx_7))" +"(get-and-clear-provide-lifts!" +"(expand-context-to-module-lifts body-ctx_7)))))" +"(if(null? bodys_25)" +"(let-values()" +"(begin" +"(let-values(((obs_157)" +"(expand-context-observer body-ctx_7)))" +"(if obs_157" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_157" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(let-values()" +"(loop_125" +" #t" +"(add-post-expansion-scope bodys_25 body-ctx_7))))))" +"(let-values() null))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_158)" +"(expand-context-observer body-ctx_7)))" +"(if obs_158" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_158 'next)))" +"(void)))" +"(values))))" +"(let-values(((body_22)(car bodys_24)))" +"(let-values(((rest-bodys_2)(cdr bodys_24)))" +"(let-values(((exp-body_8)" +"(if(let-values(((or-part_407)" +"(parsed? body_22)))" +"(if or-part_407" +" or-part_407" +"(let-values(((or-part_408)" +"(expanded+parsed? body_22)))" +"(if or-part_408" +" or-part_408" +"(semi-parsed-begin-for-syntax?" +" body_22)))))" +"(let-values() body_22)" +"(if(semi-parsed-define-values? body_22)" +"(let-values()" +"(let-values(((ids_47)" +"(semi-parsed-define-values-ids" +" body_22)))" +"(let-values(((rhs-ctx_2)" +"(as-named-context" +"(as-expression-context" +" body-ctx_7)" +" ids_47)))" +"(let-values(((syms_26)" +"(semi-parsed-define-values-syms" +" body_22)))" +"(let-values(((s_859)" +"(semi-parsed-define-values-s" +" body_22)))" +"(let-values(((ok?_87" +" define-values575_0" +" _576_0" +" _577_0)" +"(let-values(((s_860)" +"(syntax-disarm$1" +" s_859)))" +"(if(if(not" +"(expand-context-to-parsed?" +" rhs-ctx_2))" +" #t" +" #f)" +"(let-values(((orig-s_89)" +" s_860))" +"(let-values(((define-values575_1" +" _576_1" +" _577_1)" +"(let-values(((s_861)" +"(if(syntax?$1" +" s_860)" +"(syntax-e$1" +" s_860)" +" s_860)))" +"(if(pair?" +" s_861)" +"(let-values(((define-values578_0)" +"(let-values(((s_862)" +"(car" +" s_861)))" +" s_862))" +"((_579_0" +" _580_0)" +"(let-values(((s_863)" +"(cdr" +" s_861)))" +"(let-values(((s_864)" +"(if(syntax?$1" +" s_863)" +"(syntax-e$1" +" s_863)" +" s_863)))" +"(if(pair?" +" s_864)" +"(let-values(((_581_0)" +"(let-values(((s_865)" +"(car" +" s_864)))" +" s_865))" +"((_582_0)" +"(let-values(((s_866)" +"(cdr" +" s_864)))" +"(let-values(((s_867)" +"(if(syntax?$1" +" s_866)" +"(syntax-e$1" +" s_866)" +" s_866)))" +"(if(pair?" +" s_867)" +"(let-values(((_583_0)" +"(let-values(((s_868)" +"(car" +" s_867)))" +" s_868))" +"(()" +"(let-values(((s_869)" +"(cdr" +" s_867)))" +"(let-values(((s_870)" +"(if(syntax?$1" +" s_869)" +"(syntax-e$1" +" s_869)" +" s_869)))" +"(if(null?" +" s_870)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89))))))" +"(values" +" _583_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89))))))" +"(values" +" _581_0" +" _582_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89))))))" +"(values" +" define-values578_0" +" _579_0" +" _580_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89)))))" +"(values" +" #t" +" define-values575_1" +" _576_1" +" _577_1)))" +"(values" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values(((rebuild-s_15)" +"(let-values(((rhs-ctx584_0)" +" rhs-ctx_2)" +"((s585_0)" +" s_859)" +"((temp586_0)" +" #t))" +"(keep-as-needed119.1" +" #f" +" #f" +" temp586_0" +" rhs-ctx584_0" +" s585_0))))" +"(let-values((()" +"(begin" +"(log-defn-enter" +" body-ctx_7" +" body_22)" +"(values))))" +"(let-values(((exp-rhs_7)" +"(let-values()" +"(let-values(((temp587_0)" +"(semi-parsed-define-values-rhs" +" body_22))" +"((rhs-ctx588_0)" +" rhs-ctx_2))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp587_0" +" rhs-ctx588_0)))))" +"(let-values((()" +"(begin" +"(log-defn-exit" +" body-ctx_7" +" body_22" +" exp-rhs_7)" +"(values))))" +"(let-values(((comp-form_0)" +"(parsed-define-values19.1" +" rebuild-s_15" +" ids_47" +" syms_26" +"(if(expand-context-to-parsed?" +" rhs-ctx_2)" +" exp-rhs_7" +"(let-values(((exp-rhs589_0)" +" exp-rhs_7)" +"((temp590_0)" +"(as-to-parsed-context" +" rhs-ctx_2)))" +"(expand9.1" +" #f" +" #f" +" #f" +" exp-rhs589_0" +" temp590_0))))))" +"(if(expand-context-to-parsed?" +" rhs-ctx_2)" +" comp-form_0" +"(expanded+parsed1.1" +"(let-values(((rebuild-s591_0)" +" rebuild-s_15)" +"((temp592_0)" +"(list" +" define-values575_0" +" ids_47" +" exp-rhs_7)))" +"(rebuild5.1" +" #t" +" rebuild-s591_0" +" temp592_0))" +" comp-form_0)))))))))))))" +"(let-values()" +"(let-values(((disarmed-body_0)" +"(syntax-disarm$1 body_22)))" +"(let-values(((tmp_65)" +"(core-form-sym" +" disarmed-body_0" +" phase_148)))" +"(if(if(equal? tmp_65 '#%require)" +" #t" +"(if(equal? tmp_65 '#%provide)" +" #t" +"(equal? tmp_65 'module*)))" +"(let-values() body_22)" +"(let-values()" +"(let-values()" +"(let-values(((exp-body_9)" +"(let-values(((body593_0)" +" body_22)" +"((temp594_0)" +"(as-expression-context" +" body-ctx_7)))" +"(expand9.1" +" #f" +" #f" +" #f" +" body593_0" +" temp594_0))))" +"(if(expand-context-to-parsed?" +" body-ctx_7)" +" exp-body_9" +"(expanded+parsed1.1" +" exp-body_9" +"(let-values(((exp-body595_0)" +" exp-body_9)" +"((temp596_0)" +"(as-to-parsed-context" +" body-ctx_7)))" +"(expand9.1" +" #f" +" #f" +" #f" +" exp-body595_0" +" temp596_0)))))))))))))))" +"(let-values(((lifted-defns_1)" +"(get-and-clear-lifts!" +"(expand-context-lifts body-ctx_7))))" +"(let-values(((lifted-requires_0)" +"(get-and-clear-require-lifts!" +"(expand-context-require-lifts body-ctx_7))))" +"(let-values(((lifted-modules_0)" +"(get-and-clear-module-lifts!" +"(expand-context-module-lifts body-ctx_7))))" +"(let-values(((no-lifts?_0)" +"(if(null? lifted-defns_1)" +"(if(null? lifted-modules_0)" +"(null? lifted-requires_0)" +" #f)" +" #f)))" +"(let-values((()" +"(begin" +"(if no-lifts?_0" +"(void)" +"(let-values()" +"(let-values(((obs_159)" +"(expand-context-observer" +" body-ctx_7)))" +"(if obs_159" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_159" +" 'module-lift-loop" +"(append" +" lifted-requires_0" +"(lifted-defns-extract-syntax" +" lifted-defns_1)" +"(add-post-expansion-scope" +" lifted-modules_0" +" body-ctx_7)))))" +"(void)))))" +"(values))))" +"(let-values(((exp-lifted-modules_0)" +"(let-values(((lifted-modules597_0)" +" lifted-modules_0)" +"((phase598_0) phase_148)" +"((self599_0) self_36)" +"((body-ctx600_0)" +" body-ctx_7)" +"((mpis-to-reset601_0)" +" mpis-to-reset_2)" +"((declared-submodule-names602_0)" +" declared-submodule-names_5)" +"((compiled-submodules603_0)" +" compiled-submodules_3)" +"((modules-being-compiled604_0)" +" modules-being-compiled_5))" +"(expand-non-module*-submodules208.1" +" compiled-submodules603_0" +" declared-submodule-names602_0" +" modules-being-compiled604_0" +" mpis-to-reset601_0" +" lifted-modules597_0" +" phase598_0" +" self599_0" +" body-ctx600_0))))" +"(let-values(((exp-lifted-defns_0)" +"(loop_125 #f lifted-defns_1)))" +"(begin" +"(if no-lifts?_0" +"(void)" +"(let-values()" +"(let-values(((obs_160)" +"(expand-context-observer" +" body-ctx_7)))" +"(if obs_160" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_160" +" 'next)))" +"(void)))))" +"(append" +" lifted-requires_0" +" exp-lifted-defns_0" +" exp-lifted-modules_0" +"(cons" +" exp-body_8" +"(loop_125" +" tail?_54" +" rest-bodys_2)))))))))))))))))))))" +" loop_125)" +" #t" +" partially-expanded-bodys_1)))))))))))))" +"(define-values" +"(check-defined-by-now)" +"(lambda(need-eventually-defined_3 self_37 ctx_115 requires+provides_9)" +"(begin" +"(begin" +"(let-values(((ht_166) need-eventually-defined_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_166)))" +"((letrec-values(((for-loop_337)" +"(lambda(i_186)" +"(begin" +" 'for-loop" +"(if i_186" +"(let-values(((phase_149 l_89)(hash-iterate-key+value ht_166 i_186)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((lst_447) l_89))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_447)))" +"((letrec-values(((for-loop_338)" +"(lambda(lst_448)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_448)" +"(let-values(((id_158)" +"(unsafe-car" +" lst_448))" +"((rest_262)" +"(unsafe-cdr" +" lst_448)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((b_96)" +"(let-values(((id605_0)" +" id_158)" +"((phase606_0)" +" phase_149))" +"(resolve+shift28.1" +" #f" +" #f" +" null" +" unsafe-undefined" +" #f" +" id605_0" +" phase606_0))))" +"(let-values(((bound-here?_0)" +"(if b_96" +"(if(module-binding?" +" b_96)" +"(if(eq?" +"(module-binding-sym" +" b_96)" +"(syntax-e$1" +" id_158))" +"(eq?" +"(module-binding-module" +" b_96)" +" self_37)" +" #f)" +" #f)" +" #f)))" +"(let-values(((bound-kind_0)" +"(if bound-here?_0" +"(defined-sym-kind" +" requires+provides_9" +"(module-binding-sym" +" b_96)" +" phase_149)" +" #f)))" +"(if(eq?" +" bound-kind_0" +" 'variable)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(string-append" +"(if(not" +" b_96)" +"(let-values()" +" \"reference to an unbound identifier\")" +"(if(eq?" +" bound-kind_0" +" 'transformer)" +"(let-values()" +" \"identifier treated as a variable, but later defined as syntax\")" +"(let-values()" +" \"identifier treated as a variable, but later bound differently\")))" +"(format" +" \"\\n at phase: ~a\"" +"(let-values(((tmp_66)" +" phase_149))" +"(if(equal?" +" tmp_66" +" 1)" +"(let-values()" +" \"1; the transformer environment\")" +"(let-values()" +" phase_149)))))" +" id_158" +" #f" +" null" +"(syntax-debug-info-string" +" id_158" +" ctx_115))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_338" +" rest_262)" +"(values))))" +"(values))))))" +" for-loop_338)" +" lst_447)))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_337(hash-iterate-next ht_166 i_186))(values))))" +"(values))))))" +" for-loop_337)" +"(hash-iterate-first ht_166))))" +"(void)))))" +"(define-values" +"(resolve-provides113.1)" +"(lambda(ctx105_0" +" declared-submodule-names101_0" +" namespace102_0" +" phase103_0" +" requires-and-provides100_0" +" self104_0" +" expression-expanded-bodys112_0)" +"(begin" +" 'resolve-provides113" +"(let-values(((expression-expanded-bodys_1) expression-expanded-bodys112_0))" +"(let-values(((requires+provides_10) requires-and-provides100_0))" +"(let-values(((declared-submodule-names_6) declared-submodule-names101_0))" +"(let-values(((m-ns_21) namespace102_0))" +"(let-values(((phase_150) phase103_0))" +"(let-values(((self_38) self104_0))" +"(let-values(((ctx_116) ctx105_0))" +"(let-values()" +"(let-values()" +"((letrec-values(((loop_126)" +"(lambda(bodys_26 phase_151)" +"(begin" +" 'loop" +"(if(null? bodys_26)" +"(let-values() null)" +"(if(let-values(((or-part_409)(parsed?(car bodys_26))))" +"(if or-part_409 or-part_409(expanded+parsed?(car bodys_26))))" +"(let-values()" +"(cons(car bodys_26)(loop_126(cdr bodys_26) phase_151)))" +"(if(semi-parsed-begin-for-syntax?(car bodys_26))" +"(let-values()" +"(let-values(((nested-bodys_2)" +"(loop_126" +"(semi-parsed-begin-for-syntax-body(car bodys_26))" +"(add1 phase_151))))" +"(cons" +"(let-values(((the-struct_117)(car bodys_26)))" +"(if(semi-parsed-begin-for-syntax? the-struct_117)" +"(let-values(((body607_0) nested-bodys_2))" +"(semi-parsed-begin-for-syntax3.1" +"(semi-parsed-begin-for-syntax-s the-struct_117)" +" body607_0))" +"(raise-argument-error" +" 'struct-copy" +" \"semi-parsed-begin-for-syntax?\"" +" the-struct_117)))" +"(loop_126(cdr bodys_26) phase_151))))" +"(let-values()" +"(let-values(((disarmed-body_1)(syntax-disarm$1(car bodys_26))))" +"(let-values(((tmp_67)" +"(core-form-sym disarmed-body_1 phase_151)))" +"(if(equal? tmp_67 '#%provide)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_161)" +"(expand-context-observer" +" ctx_116)))" +"(if obs_161" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_161" +" 'enter-prim" +"(car bodys_26))" +"(call-expand-observe" +" obs_161" +" 'prim-provide))))" +"(void)))" +"(values))))" +"(let-values(((ok?_88 #%provide608_0 spec609_0)" +"(let-values(((s_871) disarmed-body_1))" +"(let-values(((orig-s_90) s_871))" +"(let-values(((#%provide608_1" +" spec609_1)" +"(let-values(((s_664)" +"(if(syntax?$1" +" s_871)" +"(syntax-e$1" +" s_871)" +" s_871)))" +"(if(pair? s_664)" +"(let-values(((#%provide610_0)" +"(let-values(((s_872)" +"(car" +" s_664)))" +" s_872))" +"((spec611_0)" +"(let-values(((s_873)" +"(cdr" +" s_664)))" +"(let-values(((s_874)" +"(if(syntax?$1" +" s_873)" +"(syntax-e$1" +" s_873)" +" s_873)))" +"(let-values(((flat-s_63)" +"(to-syntax-list.1" +" s_874)))" +"(if(not" +" flat-s_63)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_90))" +"(let-values()" +" flat-s_63)))))))" +"(values" +" #%provide610_0" +" spec611_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_90)))))" +"(values" +" #t" +" #%provide608_1" +" spec609_1))))))" +"(let-values(((track-stxes_10 specs_2)" +"(parse-and-expand-provides!" +" spec609_0" +"(car bodys_26)" +" requires+provides_10" +" self_38" +" phase_151" +"(let-values(((v_277) ctx_116))" +"(let-values(((the-struct_118)" +" v_277))" +"(if(expand-context/outer?" +" the-struct_118)" +"(let-values(((context612_0)" +" 'top-level)" +"((inner613_0)" +"(let-values(((the-struct_119)" +"(root-expand-context/outer-inner" +" v_277)))" +"(if(expand-context/inner?" +" the-struct_119)" +"(let-values(((phase614_0)" +" phase_151)" +"((namespace615_0)" +"(namespace->namespace-at-phase" +" m-ns_21" +" phase_151))" +"((requires+provides616_0)" +" requires+provides_10)" +"((declared-submodule-names617_0)" +" declared-submodule-names_6))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_119)" +"(root-expand-context/inner-module-scopes" +" the-struct_119)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_119)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_119)" +"(root-expand-context/inner-defined-syms" +" the-struct_119)" +"(root-expand-context/inner-counter" +" the-struct_119)" +"(root-expand-context/inner-lift-key" +" the-struct_119)" +"(expand-context/inner-to-parsed?" +" the-struct_119)" +" phase614_0" +" namespace615_0" +"(expand-context/inner-just-once?" +" the-struct_119)" +"(expand-context/inner-module-begin-k" +" the-struct_119)" +"(expand-context/inner-allow-unbound?" +" the-struct_119)" +"(expand-context/inner-in-local-expand?" +" the-struct_119)" +"(expand-context/inner-keep-#%expression?" +" the-struct_119)" +"(expand-context/inner-stops" +" the-struct_119)" +" declared-submodule-names617_0" +"(expand-context/inner-lifts" +" the-struct_119)" +"(expand-context/inner-lift-envs" +" the-struct_119)" +"(expand-context/inner-module-lifts" +" the-struct_119)" +"(expand-context/inner-require-lifts" +" the-struct_119)" +"(expand-context/inner-to-module-lifts" +" the-struct_119)" +" requires+provides616_0" +"(expand-context/inner-observer" +" the-struct_119)" +"(expand-context/inner-for-serializable?" +" the-struct_119)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_119)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_119)))))" +"(expand-context/outer1.1" +" inner613_0" +"(root-expand-context/outer-post-expansion" +" the-struct_118)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_118)" +"(root-expand-context/outer-frame-id" +" the-struct_118)" +" context612_0" +"(expand-context/outer-env" +" the-struct_118)" +"(expand-context/outer-scopes" +" the-struct_118)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_118)" +"(expand-context/outer-binding-layer" +" the-struct_118)" +"(expand-context/outer-reference-records" +" the-struct_118)" +"(expand-context/outer-only-immediate?" +" the-struct_118)" +"(expand-context/outer-need-eventually-defined" +" the-struct_118)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_118)" +"(expand-context/outer-current-use-scopes" +" the-struct_118)" +"(expand-context/outer-name" +" the-struct_118)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_118)))))))" +"(if(expand-context-to-parsed? ctx_116)" +"(let-values()" +"(loop_126(cdr bodys_26) phase_151))" +"(let-values()" +"(let-values(((new-s_10)" +"(syntax-track-origin*" +" track-stxes_10" +"(let-values(((temp618_0)" +"(car bodys_26))" +"((temp619_0)" +"(list*" +" #%provide608_0" +" specs_2)))" +"(rebuild5.1" +" #t" +" temp618_0" +" temp619_0)))))" +"(begin" +"(let-values(((obs_162)" +"(expand-context-observer" +" ctx_116)))" +"(if obs_162" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_162" +" 'exit-prim" +" new-s_10)))" +"(void)))" +"(cons" +" new-s_10" +"(loop_126" +"(cdr bodys_26)" +" phase_151))))))))))" +"(let-values()" +"(cons" +"(car bodys_26)" +"(loop_126(cdr bodys_26) phase_151))))))))))))))" +" loop_126)" +" expression-expanded-bodys_1" +" phase_150)))))))))))))" +"(define-values" +"(declare-module-for-expansion137.1)" +"(lambda(ctx123_1" +" enclosing121_0" +" fill125_0" +" module-name-id116_0" +" modules-being-compiled124_0" +" namespace119_0" +" rebuild-s117_0" +" requires-and-provides118_0" +" root-ctx122_0" +" self120_0" +" fully-expanded-bodys-except-post-submodules136_0)" +"(begin" +" 'declare-module-for-expansion137" +"(let-values(((fully-expanded-bodys-except-post-submodules_1) fully-expanded-bodys-except-post-submodules136_0))" +"(let-values(((module-name-id_0) module-name-id116_0))" +"(let-values(((rebuild-s_16) rebuild-s117_0))" +"(let-values(((requires+provides_11) requires-and-provides118_0))" +"(let-values(((m-ns_22) namespace119_0))" +"(let-values(((self_39) self120_0))" +"(let-values(((enclosing-self_3) enclosing121_0))" +"(let-values(((root-ctx_7) root-ctx122_0))" +"(let-values(((ctx_117) ctx123_1))" +"(let-values(((modules-being-compiled_6) modules-being-compiled124_0))" +"(let-values(((compiled-module-box_1) fill125_0))" +"(let-values()" +"(let-values(((requires_7 provides_14)" +"(extract-requires-and-provides requires+provides_11 self_39 self_39)))" +"(let-values(((parsed-mod_0)" +"(parsed-module25.1" +" rebuild-s_16" +" #f" +" module-name-id_0" +" self_39" +" requires_7" +" provides_14" +"(requires+provides-all-bindings-simple? requires+provides_11)" +"(root-expand-context-encode-for-module root-ctx_7 self_39 self_39)" +"(parsed-only fully-expanded-bodys-except-post-submodules_1)" +" #f" +"(hasheq))))" +"(let-values(((module-name_2)" +"(1/module-path-index-resolve" +"(let-values(((or-part_410) enclosing-self_3))" +"(if or-part_410 or-part_410 self_39)))))" +"(let-values(((compiled-module_0)" +"(let-values(((parsed-mod620_0) parsed-mod_0)" +"((temp621_0)" +"(let-values(((m-ns625_0) m-ns_22)" +"((enclosing-self626_0) enclosing-self_3)" +"((temp627_0)" +"(if enclosing-self_3" +"(1/resolved-module-path-name" +" module-name_2)" +" #f)))" +"(make-compile-context14.1" +" temp627_0" +" unsafe-undefined" +" enclosing-self626_0" +" m-ns625_0" +" unsafe-undefined" +" unsafe-undefined)))" +"((temp622_0)(expand-context-for-serializable? ctx_117))" +"((modules-being-compiled623_0) modules-being-compiled_6)" +"((temp624_0) #f))" +"(compile-module13.1" +" #f" +" modules-being-compiled623_0" +" temp624_0" +" temp622_0" +" #f" +" parsed-mod620_0" +" temp621_0))))" +"(let-values((()" +"(begin" +"(set-box! compiled-module-box_1 compiled-module_0)" +"(values))))" +"(let-values(((root-module-name_0)" +"(resolved-module-path-root-name module-name_2)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" m-ns_22" +" 1/current-module-declare-name" +"(1/make-resolved-module-path root-module-name_0))" +"(let-values()" +"(let-values(((compiled-module628_0) compiled-module_0)((temp629_0) #f))" +"(eval-module8.1" +" unsafe-undefined" +" #f" +" temp629_0" +" compiled-module628_0)))))))))))))))))))))))))" +"(define-values" +"(attach-root-expand-context-properties)" +"(lambda(s_875 root-ctx_8 orig-self_1 new-self_2)" +"(begin" +"(let-values(((s_876)" +"(syntax-property$1 s_875 'module-body-context(root-expand-context-all-scopes-stx root-ctx_8))))" +"(let-values(((s_685)" +"(syntax-property$1" +" s_876" +" 'module-body-inside-context" +"(apply-post-expansion(root-expand-context-post-expansion root-ctx_8) empty-syntax))))" +" s_685)))))" +"(define-values" +"(expand-post-submodules163.1)" +"(lambda(all-scopes-s145_0" +" compiled-submodules148_0" +" ctx150_0" +" declare-enclosing140_0" +" declared-submodule-names147_0" +" enclosing-is-cross-phase-persistent?144_0" +" modules-being-compiled149_0" +" mpis-to-reset146_0" +" phase141_1" +" requires-and-provides143_0" +" self142_0" +" fully-expanded-bodys-except-post-submodules162_0)" +"(begin" +" 'expand-post-submodules163" +"(let-values(((fully-expanded-bodys-except-post-submodules_2) fully-expanded-bodys-except-post-submodules162_0))" +"(let-values(((declare-enclosing-module_1) declare-enclosing140_0))" +"(let-values(((phase_152) phase141_1))" +"(let-values(((self_40) self142_0))" +"(let-values(((requires+provides_12) requires-and-provides143_0))" +"(let-values(((enclosing-is-cross-phase-persistent?_1) enclosing-is-cross-phase-persistent?144_0))" +"(let-values()" +"(let-values(((mpis-to-reset_3) mpis-to-reset146_0))" +"(let-values(((declared-submodule-names_7) declared-submodule-names147_0))" +"(let-values(((compiled-submodules_4) compiled-submodules148_0))" +"(let-values(((modules-being-compiled_7) modules-being-compiled149_0))" +"(let-values(((submod-ctx_1) ctx150_0))" +"(let-values()" +"((letrec-values(((loop_127)" +"(lambda(bodys_27 phase_153)" +"(begin" +" 'loop" +"(if(null? bodys_27)" +"(let-values() null)" +"(let-values()" +"(let-values(((body_23)(car bodys_27)))" +"(let-values(((rest-bodys_3)(cdr bodys_27)))" +"(if(semi-parsed-begin-for-syntax? body_23)" +"(let-values()" +"(let-values(((body-s_0)" +"(semi-parsed-begin-for-syntax-s" +" body_23)))" +"(let-values(((ok?_89 begin-for-syntax630_0 _631_0)" +"(let-values(((s_697)" +"(syntax-disarm$1" +" body-s_0)))" +"(let-values(((orig-s_91) s_697))" +"(let-values(((begin-for-syntax630_1" +" _631_1)" +"(let-values(((s_877)" +"(if(syntax?$1" +" s_697)" +"(syntax-e$1" +" s_697)" +" s_697)))" +"(if(pair? s_877)" +"(let-values(((begin-for-syntax632_0)" +"(let-values(((s_878)" +"(car" +" s_877)))" +" s_878))" +"((_633_0)" +"(let-values(((s_879)" +"(cdr" +" s_877)))" +"(let-values(((s_880)" +"(if(syntax?$1" +" s_879)" +"(syntax-e$1" +" s_879)" +" s_879)))" +"(let-values(((flat-s_64)" +"(to-syntax-list.1" +" s_880)))" +"(if(not" +" flat-s_64)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_91))" +"(let-values()" +" flat-s_64)))))))" +"(values" +" begin-for-syntax632_0" +" _633_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_91)))))" +"(values" +" #t" +" begin-for-syntax630_1" +" _631_1))))))" +"(let-values(((rebuild-body-s_0)" +"(let-values(((submod-ctx634_0)" +" submod-ctx_1)" +"((body-s635_0)" +" body-s_0))" +"(keep-as-needed119.1" +" #f" +" #f" +" #f" +" submod-ctx634_0" +" body-s635_0))))" +"(let-values(((nested-bodys_3)" +"(loop_127" +"(semi-parsed-begin-for-syntax-body" +" body_23)" +"(add1 phase_153))))" +"(let-values(((parsed-bfs_0)" +"(parsed-begin-for-syntax21.1" +" rebuild-body-s_0" +"(parsed-only nested-bodys_3))))" +"(cons" +"(if(expand-context-to-parsed?" +" submod-ctx_1)" +" parsed-bfs_0" +"(expanded+parsed1.1" +"(let-values(((rebuild-body-s636_0)" +" rebuild-body-s_0)" +"((temp637_0)" +"(list*" +" begin-for-syntax630_0" +"(syntax-only" +" nested-bodys_3))))" +"(rebuild5.1" +" #t" +" rebuild-body-s636_0" +" temp637_0))" +" parsed-bfs_0))" +"(loop_127 rest-bodys_3 phase_153))))))))" +"(if(let-values(((or-part_411)(parsed? body_23)))" +"(if or-part_411" +" or-part_411" +"(expanded+parsed? body_23)))" +"(let-values()" +"(cons body_23(loop_127 rest-bodys_3 phase_153)))" +"(let-values()" +"(let-values(((disarmed-body_2)" +"(syntax-disarm$1 body_23)))" +"(let-values(((tmp_68)" +"(core-form-sym" +" disarmed-body_2" +" phase_153)))" +"(if(equal? tmp_68 'module*)" +"(let-values()" +"(let-values((()" +"(begin" +"(force" +" declare-enclosing-module_1)" +"(values))))" +"(let-values(((ready-body_2)" +"(remove-use-site-scopes" +" body_23" +" submod-ctx_1)))" +"(let-values(((ok?_90" +" module*638_0" +" name639_0" +" _640_0)" +"(let-values(((s_881)" +" disarmed-body_2))" +"(if(let-values(((s_704)" +"(if(syntax?$1" +" s_881)" +"(syntax-e$1" +" s_881)" +" s_881)))" +"(if(pair? s_704)" +"(if(let-values(((s_882)" +"(car" +" s_704)))" +" #t)" +"(let-values(((s_883)" +"(cdr" +" s_704)))" +"(let-values(((s_705)" +"(if(syntax?$1" +" s_883)" +"(syntax-e$1" +" s_883)" +" s_883)))" +"(if(pair?" +" s_705)" +"(if(let-values(((s_884)" +"(car" +" s_705)))" +" #t)" +"(let-values(((s_885)" +"(cdr" +" s_705)))" +"(let-values(((s_886)" +"(if(syntax?$1" +" s_885)" +"(syntax-e$1" +" s_885)" +" s_885)))" +"(if(pair?" +" s_886)" +"(if(let-values(((s_887)" +"(car" +" s_886)))" +"(let-values(((s_888)" +"(if(syntax?$1" +" s_887)" +"(syntax-e$1" +" s_887)" +" s_887)))" +"(eq?" +" #f" +" s_888)))" +"(let-values(((s_889)" +"(cdr" +" s_886)))" +" #t)" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((module*638_1" +" name639_1" +" _640_1)" +"(let-values(((s_890)" +"(if(syntax?$1" +" s_881)" +"(syntax-e$1" +" s_881)" +" s_881)))" +"(let-values(((module*641_0)" +"(let-values(((s_891)" +"(car" +" s_890)))" +" s_891))" +"((name642_0" +" _643_0)" +"(let-values(((s_892)" +"(cdr" +" s_890)))" +"(let-values(((s_893)" +"(if(syntax?$1" +" s_892)" +"(syntax-e$1" +" s_892)" +" s_892)))" +"(let-values(((name644_0)" +"(let-values(((s_894)" +"(car" +" s_893)))" +" s_894))" +"((_645_0)" +"(let-values(((s_895)" +"(cdr" +" s_893)))" +"(let-values(((s_896)" +"(if(syntax?$1" +" s_895)" +"(syntax-e$1" +" s_895)" +" s_895)))" +"(let-values((()" +"(let-values(((s_897)" +"(car" +" s_896)))" +"(let-values(((s_706)" +"(if(syntax?$1" +" s_897)" +"(syntax-e$1" +" s_897)" +" s_897)))" +"(values))))" +"((_646_0)" +"(let-values(((s_898)" +"(cdr" +" s_896)))" +" s_898)))" +"(values" +" _646_0))))))" +"(values" +" name644_0" +" _645_0))))))" +"(values" +" module*641_0" +" name642_0" +" _643_0)))))" +"(values" +" #t" +" module*638_1" +" name639_1" +" _640_1)))" +"(values" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values(((submod_3)" +"(if ok?_90" +"(let-values()" +"(let-values(((neg-phase_0)" +"(phase-" +" 0" +" phase_153)))" +"(let-values(((shifted-s_0)" +"(syntax-shift-phase-level$1" +" ready-body_2" +" neg-phase_0)))" +"(let-values(((submod_4)" +"(let-values(((shifted-s647_0)" +" shifted-s_0)" +"((self648_0)" +" self_40)" +"((submod-ctx649_0)" +" submod-ctx_1)" +"((temp650_0)" +" #t)" +"((neg-phase651_0)" +" neg-phase_0)" +"((requires+provides652_0)" +" requires+provides_12)" +"((enclosing-is-cross-phase-persistent?653_0)" +" enclosing-is-cross-phase-persistent?_1)" +"((mpis-to-reset654_0)" +" mpis-to-reset_3)" +"((declared-submodule-names655_0)" +" declared-submodule-names_7)" +"((compiled-submodules656_0)" +" compiled-submodules_4)" +"((modules-being-compiled657_0)" +" modules-being-compiled_7))" +"(expand-submodule193.1" +" compiled-submodules656_0" +" declared-submodule-names655_0" +" enclosing-is-cross-phase-persistent?653_0" +" requires+provides652_0" +" temp650_0" +" neg-phase651_0" +" modules-being-compiled657_0" +" mpis-to-reset654_0" +" shifted-s647_0" +" self648_0" +" submod-ctx649_0))))" +"(if(parsed?" +" submod_4)" +"(let-values()" +" submod_4)" +"(if(expanded+parsed?" +" submod_4)" +"(let-values()" +"(let-values(((the-struct_120)" +" submod_4))" +"(if(expanded+parsed?" +" the-struct_120)" +"(let-values(((s658_0)" +"(syntax-shift-phase-level$1" +"(expanded+parsed-s" +" submod_4)" +" phase_153)))" +"(expanded+parsed1.1" +" s658_0" +"(expanded+parsed-parsed" +" the-struct_120)))" +"(raise-argument-error" +" 'struct-copy" +" \"expanded+parsed?\"" +" the-struct_120))))" +"(let-values()" +"(syntax-shift-phase-level$1" +" submod_4" +" phase_153))))))))" +"(let-values()" +"(let-values(((ready-body659_0)" +" ready-body_2)" +"((self660_0)" +" self_40)" +"((submod-ctx661_0)" +" submod-ctx_1)" +"((temp662_0)" +" #t)" +"((mpis-to-reset663_0)" +" mpis-to-reset_3)" +"((declared-submodule-names664_0)" +" declared-submodule-names_7)" +"((compiled-submodules665_0)" +" compiled-submodules_4)" +"((modules-being-compiled666_0)" +" modules-being-compiled_7))" +"(expand-submodule193.1" +" compiled-submodules665_0" +" declared-submodule-names664_0" +" #f" +" #f" +" temp662_0" +" #f" +" modules-being-compiled666_0" +" mpis-to-reset663_0" +" ready-body659_0" +" self660_0" +" submod-ctx661_0))))))" +"(cons" +" submod_3" +"(loop_127" +" rest-bodys_3" +" phase_153)))))))" +"(let-values()" +"(cons" +" body_23" +"(loop_127" +" rest-bodys_3" +" phase_153)))))))))))))))))" +" loop_127)" +" fully-expanded-bodys-except-post-submodules_2" +" phase_152)))))))))))))))))" +"(define-values" +"(stop-at-module*?)" +"(lambda(ctx_118)" +"(begin" +"(free-id-set-member?" +"(expand-context-stops ctx_118)" +"(expand-context-phase ctx_118)" +"(syntax-shift-phase-level$1(datum->syntax$1 core-stx 'module*)(expand-context-phase ctx_118))))))" +"(define-values" +"(check-ids-unbound171.1)" +"(lambda(in166_0 ids168_0 phase169_2 requires+provides170_0)" +"(begin" +" 'check-ids-unbound171" +"(let-values(((ids_48) ids168_0))" +"(let-values(((phase_154) phase169_2))" +"(let-values(((requires+provides_13) requires+provides170_0))" +"(let-values(((s_899) in166_0))" +"(let-values()" +"(begin" +"(let-values(((lst_449) ids_48))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_449)))" +"((letrec-values(((for-loop_339)" +"(lambda(lst_450)" +"(begin" +" 'for-loop" +"(if(pair? lst_450)" +"(let-values(((id_159)(unsafe-car lst_450))" +"((rest_263)(unsafe-cdr lst_450)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((requires+provides667_0)" +" requires+provides_13)" +"((id668_0) id_159)" +"((phase669_0)" +" phase_154)" +"((s670_0) s_899)" +"((temp671_0) 'module))" +"(check-not-defined95.1" +" #f" +" #f" +" #f" +" s670_0" +" #f" +" #f" +" temp671_0" +" requires+provides667_0" +" id668_0" +" phase669_0)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_339 rest_263)(values))))" +"(values))))))" +" for-loop_339)" +" lst_449)))" +"(void))))))))))" +"(define-values" +"(eval-nested-bodys)" +"(lambda(bodys_28 phase_155 m-ns_23 self_41 ctx_119)" +"(begin" +"(begin" +"(let-values(((lst_451) bodys_28))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_451)))" +"((letrec-values(((for-loop_340)" +"(lambda(lst_452)" +"(begin" +" 'for-loop" +"(if(pair? lst_452)" +"(let-values(((body_24)(unsafe-car lst_452))((rest_264)(unsafe-cdr lst_452)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((p_88)" +"(if(expanded+parsed? body_24)" +"(expanded+parsed-parsed" +" body_24)" +" body_24)))" +"(if(parsed-define-values? p_88)" +"(let-values()" +"(let-values(((ids_49)" +"(parsed-define-values-ids" +" p_88)))" +"(let-values(((vals_11)" +"(eval-for-bindings" +" 'define-values" +" ids_49" +"(parsed-define-values-rhs" +" p_88)" +" phase_155" +" m-ns_23" +" ctx_119)))" +"(begin" +"(let-values(((lst_453) ids_49)" +"((lst_454)" +"(parsed-define-values-syms" +" p_88))" +"((lst_455) vals_11))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_453)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_454)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_455)))" +"((letrec-values(((for-loop_341)" +"(lambda(lst_456" +" lst_457" +" lst_458)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_456)" +"(if(pair?" +" lst_457)" +"(pair?" +" lst_458)" +" #f)" +" #f)" +"(let-values(((id_160)" +"(unsafe-car" +" lst_456))" +"((rest_265)" +"(unsafe-cdr" +" lst_456))" +"((sym_111)" +"(unsafe-car" +" lst_457))" +"((rest_266)" +"(unsafe-cdr" +" lst_457))" +"((val_88)" +"(unsafe-car" +" lst_458))" +"((rest_267)" +"(unsafe-cdr" +" lst_458)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-variable!" +" m-ns_23" +" phase_155" +" sym_111" +" val_88))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_341" +" rest_265" +" rest_266" +" rest_267)" +"(values))))" +"(values))))))" +" for-loop_341)" +" lst_453" +" lst_454" +" lst_455)))" +"(void)))))" +"(if(let-values(((or-part_412)" +"(parsed-define-syntaxes?" +" p_88)))" +"(if or-part_412" +" or-part_412" +"(semi-parsed-begin-for-syntax?" +" p_88)))" +"(let-values()(void))" +"(if(let-values(((or-part_413)" +"(parsed-#%declare?" +" p_88)))" +"(if or-part_413" +" or-part_413" +"(syntax?$1 p_88)))" +"(let-values()(void))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +" ctx_119" +" 1/current-namespace" +" m-ns_23)" +"(let-values()" +"(eval-single-top" +"(compile-single" +" p_88" +"(let-values(((m-ns672_0)" +" m-ns_23)" +"((phase673_0)" +" phase_155))" +"(make-compile-context14.1" +" #f" +" unsafe-undefined" +" #f" +" m-ns672_0" +" phase673_0" +" unsafe-undefined)))" +" m-ns_23)))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_340 rest_264)(values))))" +"(values))))))" +" for-loop_340)" +" lst_451)))" +"(void)))))" +"(define-values" +"(expand-submodule193.1)" +"(lambda(compiled-submodules180_0" +" declared-submodule-names179_0" +" enclosing-is-cross-phase-persistent?177_0" +" enclosing-requires+provides176_0" +" is-star?174_0" +" keep-enclosing-scope-at-phase175_0" +" modules-being-compiled181_0" +" mpis-to-reset178_0" +" s190_2" +" self191_0" +" ctx192_1)" +"(begin" +" 'expand-submodule193" +"(let-values(((s_900) s190_2))" +"(let-values(((self_42) self191_0))" +"(let-values(((ctx_120) ctx192_1))" +"(let-values(((is-star?_0) is-star?174_0))" +"(let-values(((keep-enclosing-scope-at-phase_2) keep-enclosing-scope-at-phase175_0))" +"(let-values(((enclosing-r+p_2) enclosing-requires+provides176_0))" +"(let-values(((enclosing-is-cross-phase-persistent?_2) enclosing-is-cross-phase-persistent?177_0))" +"(let-values(((mpis-to-reset_4) mpis-to-reset178_0))" +"(let-values(((declared-submodule-names_8) declared-submodule-names179_0))" +"(let-values(((compiled-submodules_5) compiled-submodules180_0))" +"(let-values(((modules-being-compiled_8) modules-being-compiled181_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if is-star?_0" +"(void)" +"(let-values()" +"(let-values(((obs_163)(expand-context-observer ctx_120)))" +"(if obs_163" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_163 'enter-prim s_900)" +"(call-expand-observe" +" obs_163" +"(if is-star?_0 'prim-submodule* 'prim-submodule)))))" +"(void)))))" +"(values))))" +"(let-values(((ok?_91 module674_0 name675_0 _676_0)" +"(let-values(((s_754) s_900))" +"(let-values(((orig-s_92) s_754))" +"(let-values(((module674_1 name675_1 _676_1)" +"(let-values(((s_901)" +"(if(syntax?$1 s_754)" +"(syntax-e$1 s_754)" +" s_754)))" +"(if(pair? s_901)" +"(let-values(((module677_0)" +"(let-values(((s_759)(car s_901)))" +" s_759))" +"((name678_0 _679_0)" +"(let-values(((s_760)(cdr s_901)))" +"(let-values(((s_761)" +"(if(syntax?$1 s_760)" +"(syntax-e$1 s_760)" +" s_760)))" +"(if(pair? s_761)" +"(let-values(((name680_0)" +"(let-values(((s_902)" +"(car" +" s_761)))" +" s_902))" +"((_681_0)" +"(let-values(((s_903)" +"(cdr" +" s_761)))" +" s_903)))" +"(values name680_0 _681_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_92))))))" +"(values module677_0 name678_0 _679_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_92)))))" +"(values #t module674_1 name675_1 _676_1))))))" +"(let-values(((name_82)(syntax-e$1 name675_0)))" +"(let-values((()" +"(begin" +"(if(hash-ref declared-submodule-names_8 name_82 #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"submodule already declared with the same name\"" +" s_900" +" name_82))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(hash-set!" +" declared-submodule-names_8" +" name_82" +"(syntax-e$1 module674_0))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_164)(expand-context-observer ctx_120)))" +"(if obs_164" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_164 'enter-prim s_900)))" +"(void)))" +"(values))))" +"(let-values(((submod_5)" +"(let-values(((s682_0) s_900)" +"((temp683_0)" +"(let-values(((v_278) ctx_120))" +"(let-values(((the-struct_121) v_278))" +"(if(expand-context/outer? the-struct_121)" +"(let-values(((context691_0) 'module)" +"((post-expansion692_0) #f)" +"((inner693_0)" +"(let-values(((the-struct_122)" +"(root-expand-context/outer-inner" +" v_278)))" +"(if(expand-context/inner?" +" the-struct_122)" +"(let-values(((stops694_0)" +" empty-free-id-set))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi" +" the-struct_122)" +"(root-expand-context/inner-module-scopes" +" the-struct_122)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_122)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_122)" +"(root-expand-context/inner-defined-syms" +" the-struct_122)" +"(root-expand-context/inner-counter" +" the-struct_122)" +"(root-expand-context/inner-lift-key" +" the-struct_122)" +"(expand-context/inner-to-parsed?" +" the-struct_122)" +"(expand-context/inner-phase" +" the-struct_122)" +"(expand-context/inner-namespace" +" the-struct_122)" +"(expand-context/inner-just-once?" +" the-struct_122)" +"(expand-context/inner-module-begin-k" +" the-struct_122)" +"(expand-context/inner-allow-unbound?" +" the-struct_122)" +"(expand-context/inner-in-local-expand?" +" the-struct_122)" +"(expand-context/inner-keep-#%expression?" +" the-struct_122)" +" stops694_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_122)" +"(expand-context/inner-lifts" +" the-struct_122)" +"(expand-context/inner-lift-envs" +" the-struct_122)" +"(expand-context/inner-module-lifts" +" the-struct_122)" +"(expand-context/inner-require-lifts" +" the-struct_122)" +"(expand-context/inner-to-module-lifts" +" the-struct_122)" +"(expand-context/inner-requires+provides" +" the-struct_122)" +"(expand-context/inner-observer" +" the-struct_122)" +"(expand-context/inner-for-serializable?" +" the-struct_122)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_122)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_122)))))" +"(expand-context/outer1.1" +" inner693_0" +" post-expansion692_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_121)" +"(root-expand-context/outer-frame-id" +" the-struct_121)" +" context691_0" +"(expand-context/outer-env the-struct_121)" +"(expand-context/outer-scopes" +" the-struct_121)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_121)" +"(expand-context/outer-binding-layer" +" the-struct_121)" +"(expand-context/outer-reference-records" +" the-struct_121)" +"(expand-context/outer-only-immediate?" +" the-struct_121)" +"(expand-context/outer-need-eventually-defined" +" the-struct_121)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_121)" +"(expand-context/outer-current-use-scopes" +" the-struct_121)" +"(expand-context/outer-name" +" the-struct_121)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_121)))))" +"((self684_0) self_42)" +"((temp685_0) #t)" +"((keep-enclosing-scope-at-phase686_0)" +" keep-enclosing-scope-at-phase_2)" +"((enclosing-r+p687_0) enclosing-r+p_2)" +"((enclosing-is-cross-phase-persistent?688_0)" +" enclosing-is-cross-phase-persistent?_2)" +"((mpis-to-reset689_0) mpis-to-reset_4)" +"((modules-being-compiled690_0)" +" modules-being-compiled_8))" +"(expand-module16.1" +" temp685_0" +" enclosing-is-cross-phase-persistent?688_0" +" enclosing-r+p687_0" +" keep-enclosing-scope-at-phase686_0" +" modules-being-compiled690_0" +" mpis-to-reset689_0" +" s682_0" +" temp683_0" +" self684_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_165)(expand-context-observer ctx_120)))" +"(if obs_165" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_165" +" 'exit-prim" +"(extract-syntax submod_5))))" +"(void)))" +"(values))))" +"(let-values(((ns_131)(expand-context-namespace ctx_120)))" +"(let-values(((module-name_3)(1/module-path-index-resolve self_42)))" +"(let-values(((root-module-name_1)" +"(resolved-module-path-root-name module-name_3)))" +"(let-values(((compiled-submodule_0)" +"(let-values(((temp695_0)" +"(if(expanded+parsed? submod_5)" +"(expanded+parsed-parsed submod_5)" +" submod_5))" +"((temp696_0)" +"(let-values(((ns701_0) ns_131)" +"((self702_0) self_42)" +"((temp703_0)" +"(1/resolved-module-path-name" +" module-name_3)))" +"(make-compile-context14.1" +" temp703_0" +" unsafe-undefined" +" self702_0" +" ns701_0" +" unsafe-undefined" +" unsafe-undefined)))" +"((temp697_0) #t)" +"((temp698_0)" +"(expand-context-for-serializable?" +" ctx_120))" +"((modules-being-compiled699_0)" +" modules-being-compiled_8)" +"((temp700_0) #f))" +"(compile-module13.1" +" temp697_0" +" modules-being-compiled699_0" +" temp700_0" +" temp698_0" +" #f" +" temp695_0" +" temp696_0))))" +"(begin" +"(hash-set!" +" compiled-submodules_5" +" name_82" +"(cons is-star?_0 compiled-submodule_0))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" ns_131" +" 1/current-module-declare-name" +"(1/make-resolved-module-path root-module-name_1))" +"(let-values()" +"(let-values(((compiled-submodule704_0) compiled-submodule_0)" +"((temp705_0) #f))" +"(eval-module8.1" +" unsafe-undefined" +" #f" +" temp705_0" +" compiled-submodule704_0))))" +"(if is-star?_0" +"(void)" +"(let-values()" +"(let-values(((obs_166)(expand-context-observer ctx_120)))" +"(if obs_166" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_166" +" 'exit-prim" +"(extract-syntax submod_5))))" +"(void)))))" +"(if(not is-star?_0)" +"(let-values() submod_5)" +"(if(expanded+parsed? submod_5)" +"(let-values()" +"(let-values(((the-struct_123) submod_5))" +"(if(expanded+parsed? the-struct_123)" +"(let-values(((parsed706_0)" +"(let-values(((the-struct_124)" +"(expanded+parsed-parsed" +" submod_5)))" +"(if(parsed-module? the-struct_124)" +"(let-values(((star?707_0) #t))" +"(parsed-module25.1" +"(parsed-s the-struct_124)" +" star?707_0" +"(parsed-module-name-id" +" the-struct_124)" +"(parsed-module-self" +" the-struct_124)" +"(parsed-module-requires" +" the-struct_124)" +"(parsed-module-provides" +" the-struct_124)" +"(parsed-module-root-ctx-simple?" +" the-struct_124)" +"(parsed-module-encoded-root-ctx" +" the-struct_124)" +"(parsed-module-body" +" the-struct_124)" +"(parsed-module-compiled-module" +" the-struct_124)" +"(parsed-module-compiled-submodules" +" the-struct_124)))" +"(raise-argument-error" +" 'struct-copy" +" \"parsed-module?\"" +" the-struct_124)))))" +"(expanded+parsed1.1" +"(expanded+parsed-s the-struct_123)" +" parsed706_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expanded+parsed?\"" +" the-struct_123))))" +"(let-values()" +"(let-values(((the-struct_125) submod_5))" +"(if(parsed-module? the-struct_125)" +"(let-values(((star?708_0) #t))" +"(parsed-module25.1" +"(parsed-s the-struct_125)" +" star?708_0" +"(parsed-module-name-id the-struct_125)" +"(parsed-module-self the-struct_125)" +"(parsed-module-requires the-struct_125)" +"(parsed-module-provides the-struct_125)" +"(parsed-module-root-ctx-simple? the-struct_125)" +"(parsed-module-encoded-root-ctx the-struct_125)" +"(parsed-module-body the-struct_125)" +"(parsed-module-compiled-module the-struct_125)" +"(parsed-module-compiled-submodules" +" the-struct_125)))" +"(raise-argument-error" +" 'struct-copy" +" \"parsed-module?\"" +" the-struct_125))))))))))))))))))))))))))))))))))" +"(define-values" +"(expand-non-module*-submodules208.1)" +"(lambda(compiled-submodules198_0" +" declared-submodule-names197_0" +" modules-being-compiled199_0" +" mpis-to-reset196_0" +" bodys204_0" +" phase205_0" +" self206_0" +" ctx207_0)" +"(begin" +" 'expand-non-module*-submodules208" +"(let-values(((bodys_29) bodys204_0))" +"(let-values(((phase_156) phase205_0))" +"(let-values(((self_43) self206_0))" +"(let-values(((ctx_121) ctx207_0))" +"(let-values(((mpis-to-reset_5) mpis-to-reset196_0))" +"(let-values(((declared-submodule-names_9) declared-submodule-names197_0))" +"(let-values(((compiled-submodules_6) compiled-submodules198_0))" +"(let-values(((modules-being-compiled_9) modules-being-compiled199_0))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_459) bodys_29))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_459)))" +"((letrec-values(((for-loop_342)" +"(lambda(fold-var_387 lst_460)" +"(begin" +" 'for-loop" +"(if(pair? lst_460)" +"(let-values(((body_25)(unsafe-car lst_460))" +"((rest_268)(unsafe-cdr lst_460)))" +"(let-values(((fold-var_388)" +"(let-values(((fold-var_389) fold-var_387))" +"(let-values(((fold-var_390)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((tmp_69)" +"(core-form-sym" +"(syntax-disarm$1" +" body_25)" +" phase_156)))" +"(if(equal? tmp_69 'module)" +"(let-values()" +"(let-values(((body709_0)" +" body_25)" +"((self710_0)" +" self_43)" +"((ctx711_0)" +" ctx_121)" +"((temp712_0)" +" #f)" +"((mpis-to-reset713_0)" +" mpis-to-reset_5)" +"((declared-submodule-names714_0)" +" declared-submodule-names_9)" +"((compiled-submodules715_0)" +" compiled-submodules_6)" +"((modules-being-compiled716_0)" +" modules-being-compiled_9))" +"(expand-submodule193.1" +" compiled-submodules715_0" +" declared-submodule-names714_0" +" #f" +" #f" +" temp712_0" +" #f" +" modules-being-compiled716_0" +" mpis-to-reset713_0" +" body709_0" +" self710_0" +" ctx711_0)))" +"(let-values() body_25))))" +" fold-var_389))))" +"(values fold-var_390)))))" +"(if(not #f)" +"(for-loop_342 fold-var_388 rest_268)" +" fold-var_388)))" +" fold-var_387)))))" +" for-loop_342)" +" null" +" lst_459))))))))))))))))" +"(define-values" +"(make-parse-lifted-require216.1)" +"(lambda(declared-submodule-names211_0 m-ns213_0 self214_0 requires+provides215_0)" +"(begin" +" 'make-parse-lifted-require216" +"(let-values(((m-ns_24) m-ns213_0))" +"(let-values(((self_44) self214_0))" +"(let-values(((requires+provides_14) requires+provides215_0))" +"(let-values(((declared-submodule-names_10) declared-submodule-names211_0))" +"(let-values()" +"(lambda(s_904 phase_157)" +"(let-values(((ok?_92 #%require717_0 req718_0)" +"(let-values(((s_905)(syntax-disarm$1 s_904)))" +"(let-values(((orig-s_93) s_905))" +"(let-values(((#%require717_1 req718_1)" +"(let-values(((s_906)" +"(if(syntax?$1 s_905)(syntax-e$1 s_905) s_905)))" +"(if(pair? s_906)" +"(let-values(((#%require719_0)" +"(let-values(((s_907)(car s_906))) s_907))" +"((req720_0)" +"(let-values(((s_908)(cdr s_906)))" +"(let-values(((s_909)" +"(if(syntax?$1 s_908)" +"(syntax-e$1 s_908)" +" s_908)))" +"(if(pair? s_909)" +"(let-values(((req721_0)" +"(let-values(((s_910)" +"(car s_909)))" +" s_910))" +"(()" +"(let-values(((s_911)" +"(cdr s_909)))" +"(let-values(((s_912)" +"(if(syntax?$1" +" s_911)" +"(syntax-e$1" +" s_911)" +" s_911)))" +"(if(null? s_912)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_93))))))" +"(values req721_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_93))))))" +"(values #%require719_0 req720_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_93)))))" +"(values #t #%require717_1 req718_1))))))" +"(let-values(((temp722_0)(list req718_0))" +"((s723_0) s_904)" +"((self724_0) self_44)" +"((m-ns725_0) m-ns_24)" +"((phase726_0) phase_157)" +"((phase727_0) phase_157)" +"((requires+provides728_0) requires+provides_14)" +"((declared-submodule-names729_0) declared-submodule-names_10)" +"((temp730_0) 'require))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" declared-submodule-names729_0" +" #f" +" phase727_0" +" #f" +" self724_0" +" #f" +" #t" +" temp730_0" +" temp722_0" +" s723_0" +" m-ns725_0" +" phase726_0" +" requires+provides728_0))))))))))))" +"(define-values" +"(defn-extract-syntax)" +"(lambda(defn_0)" +"(begin" +"(datum->syntax$1" +" #f" +"(list 'define-values(semi-parsed-define-values-ids defn_0)(semi-parsed-define-values-rhs defn_0))" +"(semi-parsed-define-values-s defn_0)))))" +"(define-values" +"(lifted-defns-extract-syntax)" +"(lambda(lifted-defns_2)" +"(begin" +"(reverse$1" +"(let-values(((lst_461) lifted-defns_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_461)))" +"((letrec-values(((for-loop_343)" +"(lambda(fold-var_391 lst_462)" +"(begin" +" 'for-loop" +"(if(pair? lst_462)" +"(let-values(((lifted-defn_0)(unsafe-car lst_462))" +"((rest_269)(unsafe-cdr lst_462)))" +"(let-values(((fold-var_392)" +"(let-values(((fold-var_393) fold-var_391))" +"(let-values(((fold-var_394)" +"(let-values()" +"(cons" +"(let-values()" +"(defn-extract-syntax lifted-defn_0))" +" fold-var_393))))" +"(values fold-var_394)))))" +"(if(not #f)(for-loop_343 fold-var_392 rest_269) fold-var_392)))" +" fold-var_391)))))" +" for-loop_343)" +" null" +" lst_461)))))))" +"(define-values" +"(log-lifted-defns)" +"(lambda(partial-body-ctx_2 lifted-defns_3 exp-body_10 rest-bodys_4)" +"(begin" +"(let-values(((obs_167)(expand-context-observer partial-body-ctx_2)))" +"(if obs_167" +"(let-values()" +"(let-values(((s-lifted-defns_0)(lifted-defns-extract-syntax lifted-defns_3)))" +"(let-values((()" +"(begin" +"(call-expand-observe obs_167 'rename-list(cons exp-body_10 rest-bodys_4))" +"(values))))" +"(let-values((()(begin(call-expand-observe obs_167 'module-lift-loop s-lifted-defns_0)(values))))" +"(let-values((()" +"(begin" +"(let-values(((lst_463) s-lifted-defns_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_463)))" +"((letrec-values(((for-loop_344)" +"(lambda(lst_464)" +"(begin" +" 'for-loop" +"(if(pair? lst_464)" +"(let-values(((s-lifted-defn_0)(unsafe-car lst_464))" +"((rest_270)(unsafe-cdr lst_464)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((ok?_93" +" define-values735_0" +" _736_0)" +"(let-values(((s_913)" +" s-lifted-defn_0))" +"(let-values(((orig-s_94)" +" s_913))" +"(let-values(((define-values735_1" +" _736_1)" +"(let-values(((s_914)" +"(if(syntax?$1" +" s_913)" +"(syntax-e$1" +" s_913)" +" s_913)))" +"(if(pair?" +" s_914)" +"(let-values(((define-values737_0)" +"(let-values(((s_915)" +"(car" +" s_914)))" +" s_915))" +"((_738_0)" +"(let-values(((s_916)" +"(cdr" +" s_914)))" +"(let-values(((s_917)" +"(if(syntax?$1" +" s_916)" +"(syntax-e$1" +" s_916)" +" s_916)))" +"(let-values(((flat-s_65)" +"(to-syntax-list.1" +" s_917)))" +"(if(not" +" flat-s_65)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_94))" +"(let-values()" +" flat-s_65)))))))" +"(values" +" define-values737_0" +" _738_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_94)))))" +"(values" +" #t" +" define-values735_1" +" _736_1))))))" +"(begin" +"(call-expand-observe" +" obs_167" +" 'next)" +"(call-expand-observe" +" obs_167" +" 'visit" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'resolve" +" define-values735_0)" +"(call-expand-observe" +" obs_167" +" 'enter-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'prim-stop)" +"(call-expand-observe" +" obs_167" +" 'exit-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'return" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'rename-one" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'enter-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_167" +" 'prim-define-values)" +"(call-expand-observe" +" obs_167" +" 'exit-prim" +" s-lifted-defn_0))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_344 rest_270)(values))))" +"(values))))))" +" for-loop_344)" +" lst_463)))" +"(values))))" +"(let-values()" +"(let-values(((ok?_94 form-id731_0 _732_0)" +"(let-values(((s_918) exp-body_10))" +"(let-values(((orig-s_95) s_918))" +"(let-values(((form-id731_1 _732_1)" +"(let-values(((s_919)" +"(if(syntax?$1 s_918)(syntax-e$1 s_918) s_918)))" +"(if(pair? s_919)" +"(let-values(((form-id733_0)" +"(let-values(((s_920)(car s_919))) s_920))" +"((_734_0)" +"(let-values(((s_921)(cdr s_919))) s_921)))" +"(values form-id733_0 _734_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_95)))))" +"(values #t form-id731_1 _732_1))))))" +"(begin" +"(call-expand-observe obs_167 'next)" +"(call-expand-observe obs_167 'visit exp-body_10)" +"(call-expand-observe obs_167 'resolve form-id731_0)" +"(call-expand-observe obs_167 'enter-prim exp-body_10)" +"(call-expand-observe obs_167 'prim-stop)" +"(call-expand-observe obs_167 'exit-prim exp-body_10)" +"(call-expand-observe obs_167 'return exp-body_10)))))))))" +"(void))))))" +"(define-values" +"(log-defn-enter)" +"(lambda(ctx_122 defn_1)" +"(begin" +"(let-values(((obs_168)(expand-context-observer ctx_122)))" +"(if obs_168" +"(let-values()" +"(let-values(((s-defn_0)(defn-extract-syntax defn_1)))" +"(let-values(((ok?_95 define-values739_0 _740_0)" +"(let-values(((s_922) s-defn_0))" +"(let-values(((orig-s_96) s_922))" +"(let-values(((define-values739_1 _740_1)" +"(let-values(((s_923)(if(syntax?$1 s_922)(syntax-e$1 s_922) s_922)))" +"(if(pair? s_923)" +"(let-values(((define-values741_0)" +"(let-values(((s_924)(car s_923))) s_924))" +"((_742_0)" +"(let-values(((s_925)(cdr s_923)))" +"(let-values(((s_926)" +"(if(syntax?$1 s_925)" +"(syntax-e$1 s_925)" +" s_925)))" +"(let-values(((flat-s_66)(to-syntax-list.1 s_926)))" +"(if(not flat-s_66)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_96))" +"(let-values() flat-s_66)))))))" +"(values define-values741_0 _742_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_96)))))" +"(values #t define-values739_1 _740_1))))))" +"(begin" +"(call-expand-observe obs_168 'visit s-defn_0)" +"(call-expand-observe obs_168 'resolve define-values739_0)" +"(call-expand-observe obs_168 'enter-prim s-defn_0)" +"(call-expand-observe obs_168 'prim-define-values)))))" +"(void))))))" +"(define-values" +"(log-defn-exit)" +"(lambda(ctx_123 defn_2 exp-rhs_8)" +"(begin" +"(let-values(((obs_169)(expand-context-observer ctx_123)))" +"(if obs_169" +"(let-values()" +"(let-values(((s-defn_1)" +"(datum->syntax$1" +" #f" +"(list 'define-values(semi-parsed-define-values-ids defn_2) exp-rhs_8)" +"(semi-parsed-define-values-s defn_2))))" +"(begin(call-expand-observe obs_169 'exit-prim s-defn_1)(call-expand-observe obs_169 'return s-defn_1))))" +"(void))))))" +"(define-values" +"(as-expand-time-top-level-bindings)" +"(lambda(ids_50 s_72 ctx_124)" +"(begin" +"(let-values(((top-level-bind-scope_6)(root-expand-context-top-level-bind-scope ctx_124)))" +"(let-values(((tl-ids_2)" +"(reverse$1" +"(let-values(((lst_84) ids_50))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_84)))" +"((letrec-values(((for-loop_107)" +"(lambda(fold-var_395 lst_85)" +"(begin" +" 'for-loop" +"(if(pair? lst_85)" +"(let-values(((id_51)(unsafe-car lst_85))" +"((rest_40)(unsafe-cdr lst_85)))" +"(let-values(((fold-var_61)" +"(let-values(((fold-var_62) fold-var_395))" +"(let-values(((fold-var_396)" +"(let-values()" +"(cons" +"(let-values()" +"(remove-use-site-scopes" +" id_51" +" ctx_124))" +" fold-var_62))))" +"(values fold-var_396)))))" +"(if(not #f)(for-loop_107 fold-var_61 rest_40) fold-var_61)))" +" fold-var_395)))))" +" for-loop_107)" +" null" +" lst_84))))))" +"(let-values((()" +"(begin" +"(let-values(((tl-ids1_0) tl-ids_2)((temp2_9)(expand-context-phase ctx_124))((s3_3) s_72))" +"(check-no-duplicate-ids7.1 unsafe-undefined tl-ids1_0 temp2_9 s3_3 unsafe-undefined))" +"(values))))" +"(let-values(((tmp-bind-ids_0)" +"(reverse$1" +"(let-values(((lst_465) tl-ids_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_465)))" +"((letrec-values(((for-loop_83)" +"(lambda(fold-var_221 lst_86)" +"(begin" +" 'for-loop" +"(if(pair? lst_86)" +"(let-values(((id_161)(unsafe-car lst_86))" +"((rest_250)(unsafe-cdr lst_86)))" +"(let-values(((fold-var_26)" +"(let-values(((fold-var_397) fold-var_221))" +"(let-values(((fold-var_224)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_161" +" top-level-bind-scope_6))" +" fold-var_397))))" +"(values fold-var_224)))))" +"(if(not #f)" +"(for-loop_83 fold-var_26 rest_250)" +" fold-var_26)))" +" fold-var_221)))))" +" for-loop_83)" +" null" +" lst_465))))))" +"(values tl-ids_2(select-defined-syms-and-bind!/ctx tmp-bind-ids_0 ctx_124)))))))))" +"(void" +"(add-core-form!*" +" 'define-values" +"(lambda(s_0 ctx_7)" +"(let-values((()" +"(begin" +"(let-values(((obs_170)(expand-context-observer ctx_7)))" +"(if obs_170" +"(let-values()(let-values()(call-expand-observe obs_170 'prim-define-values)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_7) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not allowed in an expression position\" s_0)))" +"(values))))" +"(let-values(((disarmed-s_25)(syntax-disarm$1 s_0)))" +"(let-values(((ok?_26 define-values1_0 id2_1 rhs3_0)" +"(let-values(((s_492) s_0))" +"(let-values(((orig-s_97) s_492))" +"(let-values(((define-values1_1 id2_2 rhs3_1)" +"(let-values(((s_76)(if(syntax?$1 s_492)(syntax-e$1 s_492) s_492)))" +"(if(pair? s_76)" +"(let-values(((define-values4_0)" +"(let-values(((s_188)(car s_76))) s_188))" +"((id5_0 rhs6_0)" +"(let-values(((s_167)(cdr s_76)))" +"(let-values(((s_5)" +"(if(syntax?$1 s_167)" +"(syntax-e$1 s_167)" +" s_167)))" +"(if(pair? s_5)" +"(let-values(((id7_0)" +"(let-values(((s_80)(car s_5)))" +"(let-values(((s_6)" +"(if(syntax?$1 s_80)" +"(syntax-e$1 s_80)" +" s_80)))" +"(let-values(((flat-s_67)" +"(to-syntax-list.1" +" s_6)))" +"(if(not flat-s_67)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))" +"(let-values()" +"(let-values(((id_54)" +"(let-values(((lst_80)" +" flat-s_67))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_80)))" +"((letrec-values(((for-loop_99)" +"(lambda(id_162" +" lst_81)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_81)" +"(let-values(((s_89)" +"(unsafe-car" +" lst_81))" +"((rest_121)" +"(unsafe-cdr" +" lst_81)))" +"(let-values(((id_163)" +"(let-values(((id_164)" +" id_162))" +"(let-values(((id_115)" +"(let-values()" +"(let-values(((id10_1)" +"(let-values()" +"(if(let-values(((or-part_30)" +"(if(syntax?$1" +" s_89)" +"(symbol?" +"(syntax-e$1" +" s_89))" +" #f)))" +"(if or-part_30" +" or-part_30" +"(symbol?" +" s_89)))" +" s_89" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_97" +" s_89)))))" +"(cons" +" id10_1" +" id_164)))))" +"(values" +" id_115)))))" +"(if(not" +" #f)" +"(for-loop_99" +" id_163" +" rest_121)" +" id_163)))" +" id_162)))))" +" for-loop_99)" +" null" +" lst_80)))))" +"(reverse$1 id_54))))))))" +"((rhs8_0)" +"(let-values(((s_307)(cdr s_5)))" +"(let-values(((s_35)" +"(if(syntax?$1 s_307)" +"(syntax-e$1 s_307)" +" s_307)))" +"(if(pair? s_35)" +"(let-values(((rhs9_0)" +"(let-values(((s_91)" +"(car" +" s_35)))" +" s_91))" +"(()" +"(let-values(((s_168)" +"(cdr" +" s_35)))" +"(let-values(((s_308)" +"(if(syntax?$1" +" s_168)" +"(syntax-e$1" +" s_168)" +" s_168)))" +"(if(null?" +" s_308)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))))))" +"(values rhs9_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))))))" +"(values id7_0 rhs8_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_97))))))" +"(values define-values4_0 id5_0 rhs6_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_97)))))" +"(values #t define-values1_1 id2_2 rhs3_1))))))" +"(let-values(((ids_51 syms_27)(as-expand-time-top-level-bindings id2_1 s_0 ctx_7)))" +"(let-values(((exp-rhs_9)" +"(let-values(((temp11_7) rhs3_0)" +"((temp12_9)(as-named-context(as-expression-context ctx_7) ids_51)))" +"(expand9.1 #f #f #f temp11_7 temp12_9))))" +"(if(expand-context-to-parsed? ctx_7)" +"(parsed-define-values19.1 s_0 ids_51 syms_27 exp-rhs_9)" +"(let-values(((s13_1) s_0)((temp14_6)(list define-values1_0 ids_51 exp-rhs_9)))" +"(rebuild5.1 #t s13_1 temp14_6))))))))))))" +"(void" +"(add-core-form!*" +" 'define-syntaxes" +"(lambda(s_186 ctx_125)" +"(let-values((()" +"(begin" +"(let-values(((obs_171)(expand-context-observer ctx_125)))" +"(if obs_171" +"(let-values()(let-values()(call-expand-observe obs_171 'prim-define-syntaxes)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_172)(expand-context-observer ctx_125)))" +"(if obs_172(let-values()(let-values()(call-expand-observe obs_172 'prepare-env)))(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_125) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not in a definition context\" s_186)))" +"(values))))" +"(let-values(((disarmed-s_26)(syntax-disarm$1 s_186)))" +"(let-values(((ok?_96 define-syntaxes15_0 id16_1 rhs17_0)" +"(let-values(((s_18) disarmed-s_26))" +"(let-values(((orig-s_98) s_18))" +"(let-values(((define-syntaxes15_1 id16_2 rhs17_1)" +"(let-values(((s_22)(if(syntax?$1 s_18)(syntax-e$1 s_18) s_18)))" +"(if(pair? s_22)" +"(let-values(((define-syntaxes18_0)" +"(let-values(((s_494)(car s_22))) s_494))" +"((id19_1 rhs20_0)" +"(let-values(((s_25)(cdr s_22)))" +"(let-values(((s_306)" +"(if(syntax?$1 s_25)" +"(syntax-e$1 s_25)" +" s_25)))" +"(if(pair? s_306)" +"(let-values(((id21_1)" +"(let-values(((s_927)(car s_306)))" +"(let-values(((s_928)" +"(if(syntax?$1 s_927)" +"(syntax-e$1 s_927)" +" s_927)))" +"(let-values(((flat-s_68)" +"(to-syntax-list.1" +" s_928)))" +"(if(not flat-s_68)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_98))" +"(let-values()" +"(let-values(((id_165)" +"(let-values(((lst_466)" +" flat-s_68))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_466)))" +"((letrec-values(((for-loop_2)" +"(lambda(id_166" +" lst_467)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_467)" +"(let-values(((s_929)" +"(unsafe-car" +" lst_467))" +"((rest_271)" +"(unsafe-cdr" +" lst_467)))" +"(let-values(((id_167)" +"(let-values(((id_168)" +" id_166))" +"(let-values(((id_169)" +"(let-values()" +"(let-values(((id24_0)" +"(let-values()" +"(if(let-values(((or-part_218)" +"(if(syntax?$1" +" s_929)" +"(symbol?" +"(syntax-e$1" +" s_929))" +" #f)))" +"(if or-part_218" +" or-part_218" +"(symbol?" +" s_929)))" +" s_929" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_98" +" s_929)))))" +"(cons" +" id24_0" +" id_168)))))" +"(values" +" id_169)))))" +"(if(not" +" #f)" +"(for-loop_2" +" id_167" +" rest_271)" +" id_167)))" +" id_166)))))" +" for-loop_2)" +" null" +" lst_466)))))" +"(reverse$1 id_165))))))))" +"((rhs22_0)" +"(let-values(((s_930)(cdr s_306)))" +"(let-values(((s_175)" +"(if(syntax?$1 s_930)" +"(syntax-e$1 s_930)" +" s_930)))" +"(if(pair? s_175)" +"(let-values(((rhs23_2)" +"(let-values(((s_451)" +"(car" +" s_175)))" +" s_451))" +"(()" +"(let-values(((s_46)" +"(cdr" +" s_175)))" +"(let-values(((s_486)" +"(if(syntax?$1" +" s_46)" +"(syntax-e$1" +" s_46)" +" s_46)))" +"(if(null?" +" s_486)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_98))))))" +"(values rhs23_2))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_98))))))" +"(values id21_1 rhs22_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_98))))))" +"(values define-syntaxes18_0 id19_1 rhs20_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_98)))))" +"(values #t define-syntaxes15_1 id16_2 rhs17_1))))))" +"(let-values(((ids_52 syms_28)(as-expand-time-top-level-bindings id16_1 s_186 ctx_125)))" +"(let-values(((exp-rhs_10)" +"(let-values(((temp25_8) rhs17_0)((temp26_6)(as-named-context ctx_125 ids_52)))" +"(expand-transformer92.1 #f #f 'expression #t #f unsafe-undefined temp25_8 temp26_6))))" +"(if(expand-context-to-parsed? ctx_125)" +"(parsed-define-syntaxes20.1 s_186 ids_52 syms_28 exp-rhs_10)" +"(let-values(((s27_2) s_186)((temp28_4)(list define-syntaxes15_0 ids_52 exp-rhs_10)))" +"(rebuild5.1 #t s27_2 temp28_4)))))))))))))" +"(void" +"(add-core-form!*" +" 'begin-for-syntax" +"(lambda(s_309 ctx_126)" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_126) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not in a definition context\" s_309)))" +"(values))))" +"(let-values(((ok?_38 begin-for-syntax29_0 form30_0)" +"(let-values(((s_496) s_309))" +"(let-values(((orig-s_99) s_496))" +"(let-values(((begin-for-syntax29_1 form30_1)" +"(let-values(((s_48)(if(syntax?$1 s_496)(syntax-e$1 s_496) s_496)))" +"(if(pair? s_48)" +"(let-values(((begin-for-syntax31_0)(let-values(((s_51)(car s_48))) s_51))" +"((form32_0)" +"(let-values(((s_501)(cdr s_48)))" +"(let-values(((s_777)" +"(if(syntax?$1 s_501)" +"(syntax-e$1 s_501)" +" s_501)))" +"(let-values(((flat-s_69)(to-syntax-list.1 s_777)))" +"(if(not flat-s_69)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_99))" +"(let-values() flat-s_69)))))))" +"(values begin-for-syntax31_0 form32_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_99)))))" +"(values #t begin-for-syntax29_1 form30_1))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_173)(expand-context-observer ctx_126)))" +"(if obs_173" +"(let-values()(let-values()(call-expand-observe obs_173 'prim-begin-for-syntax)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_174)(expand-context-observer ctx_126)))" +"(if obs_174" +"(let-values()(let-values()(call-expand-observe obs_174 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values(((trans-ctx_1)" +"(let-values(((ctx33_0) ctx_126)((temp34_7) 'top-level)((temp35_7) #t))" +"(context->transformer-context99.1 temp35_7 ctx33_0 temp34_7))))" +"(let-values(((lift-ctx_7)" +"(let-values(((temp36_9)(make-top-level-lift trans-ctx_1)))" +"(make-lift-context6.1 #f temp36_9))))" +"(let-values(((capture-ctx_1)" +"(let-values(((v_96) trans-ctx_1))" +"(let-values(((the-struct_126) v_96))" +"(if(expand-context/outer? the-struct_126)" +"(let-values(((inner37_0)" +"(let-values(((the-struct_127)" +"(root-expand-context/outer-inner v_96)))" +"(if(expand-context/inner? the-struct_127)" +"(let-values(((lift-key38_1)(generate-lift-key))" +"((lifts39_0) lift-ctx_7))" +"(expand-context/inner2.1" +"(root-expand-context/inner-self-mpi the-struct_127)" +"(root-expand-context/inner-module-scopes the-struct_127)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_127)" +"(root-expand-context/inner-all-scopes-stx the-struct_127)" +"(root-expand-context/inner-defined-syms the-struct_127)" +"(root-expand-context/inner-counter the-struct_127)" +" lift-key38_1" +"(expand-context/inner-to-parsed? the-struct_127)" +"(expand-context/inner-phase the-struct_127)" +"(expand-context/inner-namespace the-struct_127)" +"(expand-context/inner-just-once? the-struct_127)" +"(expand-context/inner-module-begin-k the-struct_127)" +"(expand-context/inner-allow-unbound? the-struct_127)" +"(expand-context/inner-in-local-expand? the-struct_127)" +"(expand-context/inner-keep-#%expression? the-struct_127)" +"(expand-context/inner-stops the-struct_127)" +"(expand-context/inner-declared-submodule-names the-struct_127)" +" lifts39_0" +"(expand-context/inner-lift-envs the-struct_127)" +"(expand-context/inner-module-lifts the-struct_127)" +"(expand-context/inner-require-lifts the-struct_127)" +"(expand-context/inner-to-module-lifts the-struct_127)" +"(expand-context/inner-requires+provides the-struct_127)" +"(expand-context/inner-observer the-struct_127)" +"(expand-context/inner-for-serializable? the-struct_127)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_127)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_127)))))" +"(expand-context/outer1.1" +" inner37_0" +"(root-expand-context/outer-post-expansion the-struct_126)" +"(root-expand-context/outer-use-site-scopes the-struct_126)" +"(root-expand-context/outer-frame-id the-struct_126)" +"(expand-context/outer-context the-struct_126)" +"(expand-context/outer-env the-struct_126)" +"(expand-context/outer-scopes the-struct_126)" +"(expand-context/outer-def-ctx-scopes the-struct_126)" +"(expand-context/outer-binding-layer the-struct_126)" +"(expand-context/outer-reference-records the-struct_126)" +"(expand-context/outer-only-immediate? the-struct_126)" +"(expand-context/outer-need-eventually-defined the-struct_126)" +"(expand-context/outer-current-introduction-scopes the-struct_126)" +"(expand-context/outer-current-use-scopes the-struct_126)" +"(expand-context/outer-name the-struct_126)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_126))))))" +"(let-values(((all-exp-forms_0)" +"((letrec-values(((loop_67)" +"(lambda(forms_0)" +"(begin" +" 'loop" +"(let-values((()" +"(begin" +"(let-values(((obs_175)" +"(expand-context-observer ctx_126)))" +"(if obs_175" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_175" +" 'enter-list" +"(datum->syntax$1 #f form30_0 s_309))))" +"(void)))" +"(values))))" +"(let-values(((exp-forms_0)" +"((letrec-values(((loop_128)" +"(lambda(forms_1 accum_1)" +"(begin" +" 'loop" +"(if(null? forms_1)" +"(let-values()" +"(let-values(((forms_2)" +"(reverse$1" +" accum_1)))" +"(begin" +"(let-values(((obs_176)" +"(expand-context-observer" +" ctx_126)))" +"(if obs_176" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_176" +" 'exit-list" +"(datum->syntax$1" +" #f" +" forms_2" +" s_309))))" +"(void)))" +" forms_2)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_177)" +"(expand-context-observer" +" ctx_126)))" +"(if obs_177" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_177" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-form_0)" +"(let-values(((temp40_3)" +"(car" +" forms_1))" +"((capture-ctx41_0)" +" capture-ctx_1))" +"(expand9.1" +" #f" +" #f" +" #f" +" temp40_3" +" capture-ctx41_0))))" +"(loop_128" +"(cdr forms_1)" +"(cons" +" exp-form_0" +" accum_1))))))))))" +" loop_128)" +" forms_0" +" null)))" +"(let-values(((lifts_15)(get-and-clear-lifts! lift-ctx_7)))" +"(if(null? lifts_15)" +"(let-values() exp-forms_0)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_178)" +"(expand-context-observer" +" ctx_126)))" +"(if obs_178" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_178" +" 'module-lift-loop" +" lifts_15)))" +"(void)))" +"(values))))" +"(let-values(((beg_0)" +"(let-values(((lifts42_0) lifts_15)" +"((temp43_6) #f)" +"((temp44_6)" +"(expand-context-phase" +" trans-ctx_1)))" +"(wrap-lifts-as-begin16.1" +" unsafe-undefined" +" unsafe-undefined" +" lifts42_0" +" temp43_6" +" temp44_6))))" +"(let-values(((exprs_1)" +"(reverse$1" +"(cdr" +"(reverse$1" +"(cdr(syntax-e$1 beg_0)))))))" +"(append" +"(loop_67 exprs_1)" +" exp-forms_0)))))))))))))" +" loop_67)" +" form30_0)))" +"(if(expand-context-to-parsed? ctx_126)" +"(parsed-begin-for-syntax21.1 s_309 all-exp-forms_0)" +"(let-values(((s45_0) s_309)((temp46_2)(cons begin-for-syntax29_0 all-exp-forms_0)))" +"(rebuild5.1 #t s45_0 temp46_2))))))))))))))" +"(void" +"(add-core-form!*" +" '#%require" +"(lambda(s_931 ctx_127)" +"(let-values((()" +"(begin" +"(let-values(((obs_179)(expand-context-observer ctx_127)))" +"(if obs_179(let-values()(let-values()(call-expand-observe obs_179 'prim-require)))(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_127) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"allowed only in a module or the top level\" s_931)))" +"(values))))" +"(let-values(((disarmed-s_27)(syntax-disarm$1 s_931)))" +"(let-values(((ok?_97 #%require47_0 req48_0)" +"(let-values(((s_63) disarmed-s_27))" +"(let-values(((orig-s_100) s_63))" +"(let-values(((#%require47_1 req48_1)" +"(let-values(((s_406)(if(syntax?$1 s_63)(syntax-e$1 s_63) s_63)))" +"(if(pair? s_406)" +"(let-values(((#%require49_0)(let-values(((s_409)(car s_406))) s_409))" +"((req50_0)" +"(let-values(((s_415)(cdr s_406)))" +"(let-values(((s_65)" +"(if(syntax?$1 s_415)" +"(syntax-e$1 s_415)" +" s_415)))" +"(let-values(((flat-s_70)(to-syntax-list.1 s_65)))" +"(if(not flat-s_70)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_100))" +"(let-values() flat-s_70)))))))" +"(values #%require49_0 req50_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_100)))))" +"(values #t #%require47_1 req48_1))))))" +"(let-values(((sc_41)(new-scope 'macro)))" +"(begin" +"(let-values(((temp51_3)" +"(reverse$1" +"(let-values(((lst_32) req48_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_32)))" +"((letrec-values(((for-loop_25)" +"(lambda(fold-var_398 lst_33)" +"(begin" +" 'for-loop" +"(if(pair? lst_33)" +"(let-values(((req_20)(unsafe-car lst_33))" +"((rest_13)(unsafe-cdr lst_33)))" +"(let-values(((fold-var_399)" +"(let-values(((fold-var_400) fold-var_398))" +"(let-values(((fold-var_296)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" req_20" +" sc_41))" +" fold-var_400))))" +"(values fold-var_296)))))" +"(if(not #f)" +"(for-loop_25 fold-var_399 rest_13)" +" fold-var_399)))" +" fold-var_398)))))" +" for-loop_25)" +" null" +" lst_32)))))" +"((s52_0) s_931)" +"((temp53_6) #f)" +"((temp54_5)(expand-context-namespace ctx_127))" +"((temp55_4)(expand-context-phase ctx_127))" +"((temp56_5)(let-values(((temp59_8) #f))(make-requires+provides8.1 #f temp59_8)))" +"((temp57_3) 'require)" +"((temp58_5) #t))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" unsafe-undefined" +" temp58_5" +" unsafe-undefined" +" #f" +" #f" +" #f" +" temp53_6" +" temp57_3" +" temp51_3" +" s52_0" +" temp54_5" +" temp55_4" +" temp56_5))" +"(if(expand-context-to-parsed? ctx_127)(parsed-require23.1 s_931) s_931))))))))))" +"(void" +"(add-core-form!*" +" '#%provide" +"(lambda(s_780 ctx_128)" +"(begin" +"(let-values(((obs_180)(expand-context-observer ctx_128)))" +"(if obs_180(let-values()(let-values()(call-expand-observe obs_180 'prim-provide)))(void)))" +" (raise-syntax-error$1 #f \"not allowed outside of a module body\" s_780)))))" +"(define-values(ns)(make-namespace))" +"(void" +"(begin" +"(declare-core-module! ns)" +"(let-values(((temp1_4) '#%read)((read-primitives2_0) read-primitives)((ns3_0) ns))" +"(declare-hash-based-module!41.1 ns3_0 #f null #f #f temp1_4 read-primitives2_0))" +"(let-values(((temp4_8) '#%main)((main-primitives5_0) main-primitives)((ns6_1) ns))" +"(declare-hash-based-module!41.1 ns6_1 #f null #f #f temp4_8 main-primitives5_0))" +"(let-values(((temp7_5) '#%utils)((utils-primitives8_0) utils-primitives)((ns9_1) ns))" +"(declare-hash-based-module!41.1 ns9_1 #f null #f #f temp7_5 utils-primitives8_0))" +"(let-values(((temp10_7) '#%place-struct)" +"((place-struct-primitives11_0) place-struct-primitives)" +"((ns12_2) ns)" +"((temp13_3) '(dynamic-place)))" +"(declare-hash-based-module!41.1 ns12_2 #f temp13_3 #f #f temp10_7 place-struct-primitives11_0))" +"(let-values(((temp14_7) '#%boot)((boot-primitives15_0) boot-primitives)((ns16_2) ns))" +"(declare-hash-based-module!41.1 ns16_2 #f null #f #f temp14_7 boot-primitives15_0))" +"(let-values(((linklet-primitives_0)" +"(hash-remove(hash-remove linklet-primitives 'variable-reference?) 'variable-reference-constant?)))" +"(let-values(((temp17_6) '#%linklet)" +"((linklet-primitives18_0) linklet-primitives_0)" +"((ns19_3) ns)" +"((temp20_7) #t)" +"((temp21_3) #t))" +"(declare-hash-based-module!41.1 ns19_3 temp20_7 null #f temp21_3 temp17_6 linklet-primitives18_0)))" +"(let-values(((temp22_6) '#%expobs)((expobs-primitives23_0) expobs-primitives)((ns24_2) ns)((temp25_9) #t))" +"(declare-hash-based-module!41.1 ns24_2 #f null temp25_9 #f temp22_6 expobs-primitives23_0))" +"(let-values(((ns26_1) ns)" +"((eval27_0) 1/eval)" +"((temp28_5)" +"(let-values(((ht_167) main-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_167)))" +"((letrec-values(((for-loop_20)" +"(lambda(table_221 i_3)" +"(begin" +" 'for-loop" +"(if i_3" +"(let-values(((name_83)(hash-iterate-key ht_167 i_3)))" +"(let-values(((table_210)" +"(let-values(((table_222) table_221))" +"(let-values(((table_181)" +"(let-values()" +"(let-values(((key_93 val_89)" +"(let-values()" +"(values" +"(let-values() name_83)" +" #t))))" +"(hash-set table_222 key_93 val_89)))))" +"(values table_181)))))" +"(if(not #f)" +"(for-loop_20 table_210(hash-iterate-next ht_167 i_3))" +" table_210)))" +" table_221)))))" +" for-loop_20)" +" '#hash()" +"(hash-iterate-first ht_167)))))" +"((temp29_7)" +"(let-values(((ht_127) read-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_127)))" +"((letrec-values(((for-loop_328)" +"(lambda(table_223 i_182)" +"(begin" +" 'for-loop" +"(if i_182" +"(let-values(((name_84)(hash-iterate-key ht_127 i_182)))" +"(let-values(((table_119)" +"(let-values(((table_112) table_223))" +"(let-values(((table_113)" +"(let-values()" +"(let-values(((key_94 val_90)" +"(let-values()" +"(values" +"(let-values() name_84)" +" #t))))" +"(hash-set table_112 key_94 val_90)))))" +"(values table_113)))))" +"(if(not #f)" +"(for-loop_328 table_119(hash-iterate-next ht_127 i_182))" +" table_119)))" +" table_223)))))" +" for-loop_328)" +" '#hash()" +"(hash-iterate-first ht_127))))))" +"(declare-kernel-module!8.1 eval27_0 temp28_5 temp29_7 ns26_1))" +"(begin" +"(let-values(((lst_17) runtime-instances))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(lst_20)" +"(begin" +" 'for-loop" +"(if(pair? lst_20)" +"(let-values(((name_85)(unsafe-car lst_20))((rest_6)(unsafe-cdr lst_20)))" +"(let-values((()" +"(let-values()" +"(if(eq? name_85 '#%kernel)" +"(values)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((name30_0) name_85)" +"((ns31_0) ns)" +"((temp32_3)" +"(let-values(((or-part_166)" +"(eq?" +" name_85" +" '#%foreign)))" +"(if or-part_166" +" or-part_166" +"(let-values(((or-part_287)" +"(eq?" +" name_85" +" '#%futures)))" +"(if or-part_287" +" or-part_287" +"(eq?" +" name_85" +" '#%unsafe)))))))" +"(copy-runtime-module!26.1" +" unsafe-undefined" +" unsafe-undefined" +" ns31_0" +" #t" +" temp32_3" +" unsafe-undefined" +" unsafe-undefined" +" name30_0)))" +"(values)))))" +"(values)))))))" +"(if(not #f)(for-loop_10 rest_6)(values))))" +"(values))))))" +" for-loop_10)" +" lst_17)))" +"(void))" +"(let-values(((temp33_5) '#%builtin)" +"((temp34_8)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))" +"((ns35_1) ns)" +"((temp36_5) #f))" +"(declare-reexporting-module!50.1 ns35_1 temp36_5 temp33_5 temp34_8))" +"(1/current-namespace ns)" +"(1/dynamic-require ''#%kernel 0)))" +"(define-values(datum->kernel-syntax)(lambda(s_774)(begin(1/datum->syntax core-stx s_774)))))" +; diff -Nru racket-6.12+ppa1/src/racket/src/startup.rktl racket-7.0+ppa1/src/racket/src/startup.rktl --- racket-6.12+ppa1/src/racket/src/startup.rktl 2016-10-07 19:56:36.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/startup.rktl 1970-01-01 00:00:00.000000000 +0000 @@ -1,1688 +0,0 @@ -;; This file is converted to [c]startup.inc and evaluated by -;; Racket's scheme_basic_env(). - -;; It implements, in a non-bootstrapping way, some functions -;; needed to start up Racket --- especially to install the -;; default module-name resolver. - -;; Racket runs ((dynamic-require ''#%boot boot)) on startup. Then, -;; after configuring all startup parameters, Racket may run -;; ((dynamic-require ''#%boot seal)), and it may seal multiple -;; times. So, replace the content of this file to get a different set -;; of initial module definitions and parameter values. - -;; When using makefiles, `make startup' in [the build directory for] -;; "plt/src/racket" creates "plt/src/racket/src/cstartup.inc", and -;; `make cstartup' creates plt/src/racket/src/cstartup.inc. Both -;; require a working Racket executable. - -;; The recommend build strategy for cstartup.inc is -;; * Set USE_COMPILED_STARTUP in schminc.h to 0 -;; * Modify startup.rkt to taste -;; * Run make startup in /racket -;; * Run make in /racket -;; * Set USE_COMPILED_STARTUP in schminc.h to 1 -;; * Run make in /racket - -;; Do not use block comments (with #| and |#) in this file. The -;; script to build startup.inc can't handle them. - -;; ------------------------------------------------------ -;; Minimal syntax (no error checks!) needed for the rest - -(module #%min-stx '#%kernel - (#%require '#%paramz - (for-syntax '#%kernel)) - - (#%provide unless when - and or - cond - let let* letrec - let*-values - parameterize - define) - - (begin-for-syntax - (define-values (here-stx) (quote-syntax here))) - - (define-syntaxes (unless) - (lambda (stx) - (let-values ([(s) (syntax->list stx)]) - (datum->syntax here-stx - (list 'if (cadr s) - (void) - (cons 'begin (cddr s))))))) - - (define-syntaxes (when) - (lambda (stx) - (let-values ([(s) (syntax->list stx)]) - (datum->syntax here-stx - (list 'if (cadr s) - (cons 'begin (cddr s)) - (void)))))) - - (define-syntaxes (and) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax #t) - (if (null? (cdr s)) - (car s) - (datum->syntax here-stx - (list 'if (car s) (cons 'and (cdr s)) #f))))))) - - (define-syntaxes (or) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax #f) - (if (null? (cdr s)) - (car s) - (datum->syntax here-stx - (list 'let-values (list (list (list 'x) - (car s))) - (list 'if 'x 'x (cons 'or (cdr s)))))))))) - - (define-syntaxes (let) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (if (symbol? (syntax-e (car s))) - (let-values ([(clauses) - (map (lambda (c) - (syntax->list c)) - (syntax->list (cadr s)))]) - (list 'letrec-values (list (list (list (car s)) - (list* 'lambda - (map car clauses) - (cddr s)))) - (cons (car s) (map cadr clauses)))) - (list* 'let-values (map (lambda (c) - (let-values ([(c) (syntax->list c)]) - (cons (list (car c)) - (cdr c)))) - (syntax->list (car s))) - (cdr s))))))) - - (define-syntaxes (letrec) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (list* 'letrec-values (map (lambda (c) - (let-values ([(c) (syntax->list c)]) - (cons (list (car c)) - (cdr c)))) - (syntax->list (car s))) - (cdr s)))))) - - (define-syntaxes (let*) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(fst) (syntax->list (car s))]) - (datum->syntax - here-stx - (if (null? fst) - (list* 'let-values () (cdr s)) - (list 'let (list (car fst)) - (list* 'let* (cdr fst) (cdr s))))))))) - - (define-syntaxes (let*-values) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(fst) (syntax->list (car s))]) - (datum->syntax - here-stx - (if (null? fst) - (list* 'let-values () (cdr s)) - (list 'let-values (list (car fst)) - (list* 'let*-values (cdr fst) (cdr s))))))))) - - (define-syntaxes (parameterize) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(bindings) (apply append - (map syntax->list (syntax->list (car s))))]) - (syntax-arm - (datum->syntax - here-stx - (list 'with-continuation-mark - 'parameterization-key - (list* 'extend-parameterization - '(continuation-mark-set-first #f parameterization-key) - bindings) - (list* 'let-values () - (cdr s))))))))) - - (define-syntaxes (cond) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax (void)) - (datum->syntax - here-stx - (let-values ([(a) (syntax->list (car s))]) - (if (eq? '=> (syntax-e (cadr a))) - (list 'let-values (list (list '(v) (car a))) - (list* 'cond - (list 'v (list (caddr a) 'v)) - (cdr s))) - (list 'if (if (eq? (syntax-e (car a)) 'else) - #t - (car a)) - (list* 'let-values '() (cdr a)) - (cons 'cond (cdr s)))))))))) - - (define-syntaxes (define) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (if (symbol? (syntax-e (car s))) - (list 'define-values (list (car s)) (cadr s)) - (let-values ([(a) (syntax-e (car s))]) - (list 'define-values (list (car a)) - (list* 'lambda (cdr a) - (cdr s)))))))))) - -;; ---------------------------------------- -;; Utilities that are eventually exported to the rest of the world -;; (along with much of '#%kernel) - -(module #%utils '#%kernel - (#%require '#%min-stx '#%paramz) - - (#%provide path-string? - normal-case-path - path-replace-extension - path-add-extension - reroot-path - find-col-file - collection-path - collection-file-path - find-library-collection-paths - find-library-collection-links - path-list-string->path-list - find-executable-path - load/use-compiled - embedded-load - call-with-default-reading-parameterization - find-main-collects - find-main-config) - - (define-values (path-string?) - (lambda (s) - (or (path? s) - (and (string? s) - (or (relative-path? s) - (absolute-path? s)))))) - - (define-values (bsbs) (string #\u5C #\u5C)) - - (define-values (normal-case-path) - (lambda (s) - (unless (or (path-for-some-system? s) - (path-string? s)) - (raise-argument-error 'normal-path-case "(or/c path-for-some-system? path-string?)" s)) - (cond - [(if (path-for-some-system? s) - (eq? (path-convention-type s) 'windows) - (eq? (system-type) 'windows)) - (let ([str (if (string? s) s (bytes->string/locale (path->bytes s)))]) - (if (regexp-match? #rx"^[\u5C][\u5C][?][\u5C]" str) - (if (string? s) - (string->path s) - s) - (let ([s (string-locale-downcase str)]) - (bytes->path - (string->bytes/locale - (regexp-replace* #rx"/" - (if (regexp-match? #rx"[/\u5C][. ]+[/\u5C]*$" s) - ;; Just "." or ".." in last path element - don't remove - s - (regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1")) - bsbs)) - 'windows))))] - [(string? s) (string->path s)] - [else s]))) - - (define-values (reroot-path) - (lambda (p root) - (unless (or (path-string? p) (path-for-some-system? p)) - (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 0 p root)) - (unless (or (path-string? root) (path-for-some-system? root)) - (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 1 p root)) - (define conv (if (path-for-some-system? p) - (path-convention-type p) - (system-path-convention-type))) - (unless (or (complete-path? p) - (eq? (system-path-convention-type) conv)) - (raise-arguments-error 'reroot-path - "path is not complete and not the platform's convention" - "path" p - "platform convention type" (system-path-convention-type))) - (unless (eq? (if (path-for-some-system? root) - (path-convention-type root) - (system-path-convention-type)) - conv) - (raise-arguments-error 'reroot-path - "given paths use different conventions" - "path" p - "root path" root)) - (define c-p (normal-case-path (cleanse-path (if (complete-path? p) - p - (path->complete-path p))))) - (define bstr (path->bytes c-p)) - (cond - [(eq? conv 'unix) - (if (bytes=? bstr #"/") - (if (path-for-some-system? root) - root - (string->path root)) - (build-path root (bytes->path (subbytes (path->bytes c-p) 1) conv)))] - [(eq? conv 'windows) - (build-path - root - (bytes->path - (cond - ((regexp-match? #rx"^\\\\\\\\[?]\\\\[a-z]:" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4 5) #"\\" (subbytes bstr 6))) - ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4))) - ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4))) - ((regexp-match? #rx"^\\\\\\\\" bstr) - (bytes-append #"UNC\\" (subbytes bstr 2))) - ((regexp-match? #rx"^[a-z]:" bstr) - (bytes-append (subbytes bstr 0 1) (subbytes bstr 2)))) - conv))]))) - - ;; ------------------------------ executable path ------------------------------ - - (define-values (find-executable-path) - (case-lambda - [(program libpath reverse?) - (unless (path-string? program) - (raise-argument-error 'find-executable-path "path-string?" program)) - (unless (or (not libpath) (and (path-string? libpath) - (relative-path? libpath))) - (raise-argument-error 'find-executable-path "(or/c #f (and/c path-string? relative-path?))" libpath)) - (letrec ([found-exec - (lambda (exec-name) - (if libpath - (let-values ([(base name isdir?) (split-path exec-name)]) - (let ([next - (lambda () - (let ([resolved (resolve-path exec-name)]) - (cond - [(equal? resolved exec-name) #f] - [(relative-path? resolved) - (found-exec (build-path base resolved))] - [else (found-exec resolved)])))]) - (or (and reverse? (next)) - (if (path? base) - (let ([lib (build-path base libpath)]) - (and (or (directory-exists? lib) - (file-exists? lib)) - lib)) - #f) - (and (not reverse?) (next))))) - exec-name))]) - (if (and (relative-path? program) - (let-values ([(base name dir?) (split-path program)]) - (eq? base 'relative))) - (let ([paths-str (environment-variables-ref (current-environment-variables) - #"PATH")] - [win-add (lambda (s) (if (eq? (system-type) 'windows) - (cons (bytes->path #".") s) - s))]) - (let loop ([paths (win-add - (if paths-str - (path-list-string->path-list (bytes->string/locale paths-str #\?) - null) - null))]) - (if (null? paths) - #f - (let* ([base (path->complete-path (car paths))] - [name (build-path base program)]) - (if (file-exists? name) - (found-exec name) - (loop (cdr paths))))))) - (let ([p (path->complete-path program)]) - (and (file-exists? p) (found-exec p)))))] - [(program libpath) (find-executable-path program libpath #f)] - [(program) (find-executable-path program #f #f)])) - - (define-values (path-list-string->path-list) - (let ((r (byte-regexp (string->bytes/utf-8 - (let ((sep (if (eq? (system-type) 'windows) - ";" - ":"))) - (format "([^~a]*)~a(.*)" sep sep))))) - (cons-path (lambda (default s l) - (let ([s (if (eq? (system-type) 'windows) - (regexp-replace* #rx#"\"" s #"") - s)]) - (if (bytes=? s #"") - (append default l) - (cons (bytes->path s) - l)))))) - (lambda (s default) - (unless (or (bytes? s) - (string? s)) - (raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s)) - (unless (and (list? default) - (andmap path? default)) - (raise-argument-error 'path-list-string->path-list "(listof path?)" default)) - (let loop ([s (if (string? s) - (string->bytes/utf-8 s) - s)]) - (let ([m (regexp-match r s)]) - (if m - (cons-path default (cadr m) (loop (caddr m))) - (cons-path default s null))))))) - - ;; ------------------------------ Reading ------------------------------ - - (define (call-with-default-reading-parameterization thunk) - (if (and (procedure? thunk) - (procedure-arity-includes? thunk 0)) - (parameterize ([read-case-sensitive #t] - [read-square-bracket-as-paren #t] - [read-curly-brace-as-paren #t] - [read-square-bracket-with-tag #f] - [read-curly-brace-with-tag #f] - [read-accept-box #t] - [read-accept-compiled #f] - [read-accept-bar-quote #t] - [read-accept-graph #t] - [read-decimal-as-inexact #t] - [read-cdot #f] - [read-accept-dot #t] - [read-accept-infix-dot #t] - [read-accept-quasiquote #t] - [read-accept-reader #f] - [read-accept-lang #t] - [current-readtable #f]) - (thunk)) - (raise-argument-error 'call-with-default-reading-parameterization - "(procedure-arity-includes/c 0)" - thunk))) - - ;; ------------------------------ Collections ------------------------------ - - (define-values (-check-relpath) - (lambda (who s) - (unless (path-string? s) - (raise-argument-error who "path-string?" s)) - (unless (relative-path? s) - (raise-arguments-error who - "invalid relative path" - "path" s)))) - - (define-values (-check-collection) - (lambda (who collection collection-path) - (-check-relpath who collection) - (for-each (lambda (p) (-check-relpath who p)) collection-path))) - - (define-values (-check-fail) - (lambda (who fail) - (unless (and (procedure? fail) - (procedure-arity-includes? fail 1)) - (raise-argument-error who "(any/c . -> . any)" fail)))) - - (define-values (collection-path) - (lambda (fail collection collection-path) - (-check-collection 'collection-path collection collection-path) - (-check-fail 'collection-path fail) - (find-col-file fail - collection collection-path - #f - #f))) - - (define-values (collection-file-path) - (lambda (fail check-compiled? file-name collection collection-path) - (-check-relpath 'collection-file-path file-name) - (-check-collection 'collection-file-path collection collection-path) - (-check-fail 'collection-file-path fail) - (find-col-file fail - collection collection-path - file-name - check-compiled?))) - - (define-values (find-main-collects) - (lambda () - ;; Recorded once and for all (per place), which helps avoid - ;; sandbox problems: - (cache-configuration - 0 - (lambda () - (exe-relative-path->complete-path (find-system-path 'collects-dir)))))) - - (define-values (find-main-config) - (lambda () - ;; Also recorded once and for all (per place): - (cache-configuration - 1 - (lambda () - (exe-relative-path->complete-path (find-system-path 'config-dir)))))) - - (define-values (get-config-table) - (lambda (d) - (let ([p (and d (build-path d "config.rktd"))]) - (or (and p - (file-exists? p) - (with-input-from-file p - (lambda () - (let ([v (call-with-default-reading-parameterization read)]) - (and (hash? v) - v))))) - #hash())))) - - (define-values (get-installation-name) - (lambda (config-table) - (hash-ref config-table - 'installation-name - (version)))) - - (define-values (coerce-to-path) - (lambda (p) - (cond - [(string? p) (collects-relative-path->complete-path (string->path p))] - [(bytes? p) (collects-relative-path->complete-path (bytes->path p))] - [(path? p) (collects-relative-path->complete-path p)] - [else p]))) - - (define-values (collects-relative-path->complete-path) - (lambda (p) - (cond - [(complete-path? p) p] - [else - (path->complete-path p (or (find-main-collects) - ;; If we get here, then something is configured wrong, - ;; and making up paths relative to the current directory - ;; is not great --- but we have to come up with some - ;; path at this point. - (current-directory)))]))) - - (define-values (exe-relative-path->complete-path) - (lambda (collects-path) - (cond - [(complete-path? collects-path) (simplify-path collects-path)] - [(absolute-path? collects-path) - ;; This happens only under Windows; add a drive - ;; specification to make the path complete - (let ([exec (path->complete-path - (find-executable-path (find-system-path 'exec-file)) - (find-system-path 'orig-dir))]) - (let-values ([(base name dir?) (split-path exec)]) - (simplify-path (path->complete-path collects-path base))))] - [else - (let ([p (find-executable-path (find-system-path 'exec-file) collects-path #t)]) - (and p (simplify-path p)))]))) - - (define-values (add-config-search) - (lambda (ht key orig-l) - (let ([l (hash-ref ht key #f)]) - (if l - (let loop ([l l]) - (cond - [(null? l) null] - [(not (car l)) (append orig-l (loop (cdr l)))] - [else (cons (coerce-to-path (car l)) (loop (cdr l)))])) - orig-l)))) - - (define-values (find-library-collection-links) - (lambda () - (let* ([ht (get-config-table (find-main-config))] - [lf (coerce-to-path - (or (hash-ref ht 'links-file #f) - (build-path (or (hash-ref ht 'share-dir #f) - (build-path 'up "share")) - "links.rktd")))]) - (append - ;; `#f' means `current-library-collection-paths': - (list #f) - ;; user-specific - (if (and (use-user-specific-search-paths) - (use-collection-link-paths)) - (list (build-path (find-system-path 'addon-dir) - (get-installation-name ht) - "links.rktd")) - null) - ;; installation-wide: - (if (use-collection-link-paths) - (add-config-search - ht - 'links-search-files - (list lf)) - null))))) - - ;; map from link-file names to cached information: - (define-values (links-cache) (make-weak-hash)) - - ;; used for low-level except abort below: - (define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp)) - - (define-values (file->stamp) - (lambda (path old-stamp) - ;; Using just the file's modification date almost works as a stamp, - ;; but 1-second granularity isn't fine enough. A stamp is therefore - ;; the file content paired with a filesystem-change event (where - ;; supported), and the event lets us recycle the old stamp almost - ;; always. - (cond - [(and old-stamp - (cdr old-stamp) - (not (sync/timeout 0 (cdr old-stamp)))) - old-stamp] - [else - (call-with-continuation-prompt - (lambda () - (with-continuation-mark - exception-handler-key - (lambda (exn) - (abort-current-continuation - stamp-prompt-tag - (if (exn:fail:filesystem? exn) - (lambda () #f) - (lambda () (raise exn))))) - (let ([dir-evt - (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? - (let loop ([path path]) - (let-values ([(base name dir?) (split-path path)]) - (and (path? base) - (if (directory-exists? base) - (filesystem-change-evt base (lambda () #f)) - (loop base))))))]) - (if (not (file-exists? path)) - (cons #f dir-evt) - (let ([evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? - (filesystem-change-evt path (lambda () #f)))]) - (when dir-evt (filesystem-change-evt-cancel dir-evt)) - (cons - (let ([p (open-input-file path)]) - (dynamic-wind - void - (lambda () - (let ([bstr (read-bytes 8192 p)]) - (if (and (bytes? bstr) - ((bytes-length bstr) . >= . 8192)) - (apply - bytes-append - (cons - bstr - (let loop () - (let ([bstr (read-bytes 8192 p)]) - (if (eof-object? bstr) - null - (cons bstr (loop))))))) - bstr))) - (lambda () (close-input-port p)))) - evt)))))) - stamp-prompt-tag)]))) - - (define-values (no-file-stamp?) - (lambda (a) - (or (not a) - (not (car a))))) - - (define-values (get-linked-collections) - (lambda (links-path) - ;; Use/save information in `links-cache', relying on filesystem-change events - ;; or a copy of the file to detect when the cache is stale. - (call-with-escape-continuation - (lambda (esc) - (define-values (make-handler) - (lambda (ts) - (lambda (exn) - (if (exn:fail? exn) - (let ([l (current-logger)]) - (when (log-level? l 'error) - (log-message l 'error - (format - "error reading collection links file ~s: ~a" - links-path - (exn-message exn)) - (current-continuation-marks)))) - (void)) - (when ts - (hash-set! links-cache links-path (cons ts #hasheq()))) - (if (exn:fail? exn) - (esc (make-hasheq)) - ;; re-raise the exception (which is probably a break) - exn)))) - (with-continuation-mark - exception-handler-key - (make-handler #f) - (let* ([links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))] - [a-links-stamp (car links-stamp+cache)] - [ts (file->stamp links-path a-links-stamp)]) - (if (not (equal? ts a-links-stamp)) - (with-continuation-mark - exception-handler-key - (make-handler ts) - (call-with-default-reading-parameterization - (lambda () - (let ([v (if (no-file-stamp? ts) - null - (let ([p (open-input-file links-path 'binary)]) - (dynamic-wind - void - (lambda () - (begin0 - (read p) - (unless (eof-object? (read p)) - (error "expected a single S-expression")))) - (lambda () (close-input-port p)))))]) - (unless (and (list? v) - (andmap (lambda (p) - (and (list? p) - (or (= 2 (length p)) - (= 3 (length p))) - (or (string? (car p)) - (eq? 'root (car p)) - (eq? 'static-root (car p))) - (path-string? (cadr p)) - (or (null? (cddr p)) - (regexp? (caddr p))))) - v)) - (error "ill-formed content")) - (let ([ht (make-hasheq)] - [dir (let-values ([(base name dir?) (split-path links-path)]) - base)]) - (for-each - (lambda (p) - (when (or (null? (cddr p)) - (regexp-match? (caddr p) (version))) - (let ([dir (simplify-path - (path->complete-path (cadr p) dir))]) - (cond - [(eq? (car p) 'static-root) - ;; multi-collection, constant content: - (for-each - (lambda (sub) - (when (directory-exists? (build-path dir sub)) - (let ([k (string->symbol (path->string sub))]) - (hash-set! ht k (cons dir (hash-ref ht k null)))))) - (directory-list dir))] - [(eq? (car p) 'root) - ;; multi-collection, dynamic content: - ;; Add directory to the #f mapping, and also - ;; add to every existing table element (to keep - ;; the choices in order) - (unless (hash-ref ht #f #f) - (hash-set! ht #f null)) - (hash-for-each - ht - (lambda (k v) - (hash-set! ht k (cons dir v))))] - [else - ;; single collection: - (let ([s (string->symbol (car p))]) - (hash-set! ht s (cons (box dir) - (hash-ref ht s null))))])))) - v) - ;; reverse all lists: - (hash-for-each - ht - (lambda (k v) (hash-set! ht k (reverse v)))) - ;; save table & file content: - (hash-set! links-cache links-path (cons ts ht)) - ht))))) - (cdr links-stamp+cache)))))))) - - (define-values (normalize-collection-reference) - (lambda (collection collection-path) - ;; make sure that `collection' is a top-level collection name, - (cond - [(string? collection) - (let ([m (regexp-match-positions #rx"/+" collection)]) - (if m - (cond - [(= (caar m) (sub1 (string-length collection))) - (values (substring collection 0 (caar m)) collection-path)] - [else - (values (substring collection 0 (caar m)) - (cons (substring collection (cdar m)) - collection-path))]) - (values collection collection-path)))] - [else - (let-values ([(base name dir?) (split-path collection)]) - (if (eq? base 'relative) - (values name collection-path) - (normalize-collection-reference base (cons name collection-path))))]))) - - (define-values (find-col-file) - (lambda (fail collection collection-path file-name check-compiled?) - (let-values ([(collection collection-path) - (normalize-collection-reference collection collection-path)]) - (let ([all-paths (let ([sym (string->symbol - (if (path? collection) - (path->string collection) - collection))]) - (let loop ([l (current-library-collection-links)]) - (cond - [(null? l) null] - [(not (car l)) - ;; #f is the point where we try the old parameter: - (append - (current-library-collection-paths) - (loop (cdr l)))] - [(hash? (car l)) - ;; A hash table maps a collection-name symbol - ;; to a list of paths. We need to wrap each path - ;; in a box, because that's how the code below - ;; knows that it's a single collection's directory. - ;; A hash table can also map #f to a list of paths - ;; for directories that hold collections. - (append - (map box (hash-ref (car l) sym null)) - (hash-ref (car l) #f null) - (loop (cdr l)))] - [else - (let ([ht (get-linked-collections (car l))]) - (append - ;; Table values are lists of paths and (box path)s, - ;; where a (box path) is a collection directory - ;; (instead of a directory containing collections). - (hash-ref ht sym null) - (hash-ref ht #f null) - (loop (cdr l))))])))]) - (define-values (done) - (lambda (p) - (if file-name (build-path p file-name) p))) - (define-values (*build-path-rep) - (lambda (p c) - (if (path? p) - (build-path p c) - ;; box => from links table for c - (unbox p)))) - (define-values (*directory-exists?) - (lambda (orig p) - (if (path? orig) - (directory-exists? p) - ;; orig is box => from links table - #t))) - (define-values (to-string) (lambda (p) (if (path? p) (path->string p) p))) - (let cloop ([paths all-paths] [found-col #f]) - (if (null? paths) - (if found-col - (done found-col) - (let ([rest-coll - (if (null? collection-path) - "" - (apply - string-append - (let loop ([cp collection-path]) - (if (null? (cdr cp)) - (list (to-string (car cp))) - (list* (to-string (car cp)) "/" (loop (cdr cp)))))))]) - (define-values (filter) - (lambda (f l) - (if (null? l) - null - (if (f (car l)) - (cons (car l) (filter f (cdr l))) - (filter f (cdr l)))))) - (fail - (format "collection not found\n collection: ~s\n in collection directories:~a~a" - (if (null? collection-path) - (to-string collection) - (string-append (to-string collection) "/" rest-coll)) - (apply - string-append - (map (lambda (p) - (format "\n ~a ~a" " " p)) - (let ([len (length all-paths)] - [clen (length (current-library-collection-paths))]) - (if ((- len clen) . < . 5) - all-paths - (append (current-library-collection-paths) - (list (format "... [~a additional linked and package directories]" - (- len clen)))))))) - (if (ormap box? all-paths) - (format "\n sub-collection: ~s\n in parent directories:~a" - rest-coll - (apply - string-append - (map (lambda (p) - (format "\n ~a" (unbox p))) - (filter box? all-paths)))) - ""))))) - (let ([dir (*build-path-rep (car paths) collection)]) - (if (*directory-exists? (car paths) dir) - (let ([cpath (apply build-path dir collection-path)]) - (if (if (null? collection-path) - #t - (directory-exists? cpath)) - (if file-name - (if (or (file-exists?/maybe-compiled cpath file-name - check-compiled?) - (let ([alt-file-name - (let* ([file-name (if (path? file-name) - (path->string file-name) - file-name)] - [len (string-length file-name)]) - (and (len . >= . 4) - (string=? ".rkt" (substring file-name (- len 4))) - (string-append (substring file-name 0 (- len 4)) ".ss")))]) - (and alt-file-name - (file-exists?/maybe-compiled cpath alt-file-name - check-compiled?)))) - (done cpath) - ;; Look further for specific file, but remember - ;; first found directory - (cloop (cdr paths) (or found-col cpath))) - ;; Just looking for dir; found it: - (done cpath)) - ;; sub-collection not here; try next instance - ;; of the top-level collection - (cloop (cdr paths) found-col))) - (cloop (cdr paths) found-col))))))))) - - (define-values (file-exists?/maybe-compiled) - (lambda (dir path check-compiled?) - (or (file-exists? (build-path dir path)) - (and check-compiled? - (let ([try-path (path-add-extension path #".zo")] - [modes (use-compiled-file-paths)] - [roots (current-compiled-file-roots)]) - (ormap (lambda (d) - (ormap (lambda (mode) - (file-exists? - (let ([p (build-path dir mode try-path)]) - (cond - [(eq? d 'same) p] - [(relative-path? d) (build-path p d)] - [else (reroot-path p d)])))) - modes)) - roots)))))) - - (define-values (check-extension-call) - (lambda (s sfx who) - (unless (or (path-for-some-system? s) - (path-string? s)) - (raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx)) - (unless (or (string? sfx) (bytes? sfx)) - (raise-argument-error who "(or/c string? bytes?)" 1 s sfx)) - (let-values ([(base name dir?) (split-path s)]) - (when (not base) - (raise-mismatch-error who "cannot add an extension to a root path: " s)) - (values base name)))) - - (define-values (path-adjust-extension) - (lambda (name sep rest-bytes s sfx) - (let-values ([(base name) (check-extension-call s sfx name)]) - (define bs (path-element->bytes name)) - (define finish - (lambda (i sep i2) - (bytes->path-element - (bytes-append - (subbytes bs 0 i) - sep - (rest-bytes bs i2) - (if (string? sfx) - (string->bytes/locale sfx (char->integer #\?)) - sfx)) - (if (path-for-some-system? s) - (path-convention-type s) - (system-path-convention-type))))) - (let ([new-name (letrec-values ([(loop) - (lambda (i) - (if (zero? i) - (finish (bytes-length bs) #"" (bytes-length bs)) - (let-values ([(i) (sub1 i)]) - (if (and (not (zero? i)) - (eq? (char->integer #\.) (bytes-ref bs i))) - (finish i sep (add1 i)) - (loop i)))))]) - (loop (bytes-length bs)))]) - (if (path-for-some-system? base) - (build-path base new-name) - new-name))))) - - (define-values (path-replace-extension) - (lambda (s sfx) - (path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx))) - - (define-values (path-add-extension) - (lambda (s sfx) - (path-adjust-extension 'path-add-extension #"_" subbytes s sfx))) - - (define-values (load/use-compiled) - (lambda (f) ((current-load/use-compiled) f #f))) - - (define-values (find-library-collection-paths) - (case-lambda - [() (find-library-collection-paths null null)] - [(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)] - [(extra-collects-dirs post-collects-dirs) - (let ([user-too? (use-user-specific-search-paths)] - [cons-if (lambda (f r) (if f (cons f r) r))] - [config-table (get-config-table (find-main-config))]) - (path-list-string->path-list - (if user-too? - (let ([c (environment-variables-ref (current-environment-variables) - #"PLTCOLLECTS")]) - (if c - (bytes->string/locale c #\?) - "")) - "") - (add-config-search - config-table - 'collects-search-dirs - (cons-if - (and user-too? - (build-path (find-system-path 'addon-dir) - (get-installation-name config-table) - "collects")) - (let loop ([l (append - extra-collects-dirs - (list (find-system-path 'collects-dir)) - post-collects-dirs)]) - (if (null? l) - null - (let* ([collects-path (car l)] - [v (exe-relative-path->complete-path collects-path)]) - (if v - (cons (simplify-path (path->complete-path v (current-directory))) - (loop (cdr l))) - (loop (cdr l))))))))))])) - - ;; used for the -k command-line argument: - (define (embedded-load start end str) - (let* ([s (if str - str - (let* ([sp (find-system-path 'exec-file)] - [exe (find-executable-path sp #f)] - [start (or (string->number start) 0)] - [end (or (string->number end) 0)]) - (with-input-from-file exe - (lambda () - (file-position (current-input-port) start) - (read-bytes (max 0 (- end start)))))))] - [p (open-input-bytes s)]) - (let loop () - (let ([e (parameterize ([read-accept-compiled #t] - [read-accept-reader #t] - [read-accept-lang #t] - [read-on-demand-source #t]) - (read p))]) - (unless (eof-object? e) - (eval e) - (loop))))))) - -;; ---------------------------------------- -;; When places are implemented by plain old threads, -;; place channels need to be shared across namespaces, -;; so `#%place-struct' is included in builtins - -(module #%place-struct '#%kernel - - (define-values (struct:TH-place-channel TH-place-channel TH-place-channel? - TH-place-channel-ref TH-place-channel-set!) - (make-struct-type 'TH-place-channel #f 2 0 #f (list (cons prop:evt (lambda (x) (TH-place-channel-ref x 0)))))) - - (define-values (TH-place-channel-in TH-place-channel-out) - (values - (lambda (x) (TH-place-channel-ref x 0)) - (lambda (x) (TH-place-channel-ref x 1)))) - - (#%provide - struct:TH-place-channel - TH-place-channel - TH-place-channel? - TH-place-channel-in - TH-place-channel-out)) - -;; ---------------------------------------- -;; Handlers to install on startup - -(module #%boot '#%kernel - (#%require '#%min-stx '#%utils '#%paramz) - - (#%provide boot seal orig-paramz) - - (define-values (dll-suffix) - (system-type 'so-suffix)) - - (define-values (default-load/use-compiled) - (let* ([resolve (lambda (s) - (if (complete-path? s) - s - (let ([d (current-load-relative-directory)]) - (if d (path->complete-path s d) s))))] - [use-seconds? (eq? (use-compiled-file-check) 'modify-seconds)] - [date-of-1 (lambda (a) - (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))]) - (and v (cons a (if use-seconds? v 0)))))] - [date-of (lambda (a modes roots) - (ormap (lambda (root-dir) - (ormap - (lambda (compiled-dir) - (let ([a (a root-dir compiled-dir)]) - (date-of-1 a))) - modes)) - roots))] - [date>=? - (lambda (modes roots a bm) - (and a - (let ([am (date-of a modes roots)]) - (or (and (not bm) am) - (and am bm (>= (cdr am) (cdr bm)) am)))))] - [with-dir* (lambda (base t) - (parameterize ([current-load-relative-directory - (if (path? base) - base - (current-directory))]) - (t)))]) - (lambda (path expect-module) - (unless (path-string? path) - (raise-argument-error 'load/use-compiled "path-string?" path)) - (unless (or (not expect-module) - (symbol? expect-module) - (and (list? expect-module) - ((length expect-module) . > . 1) - (or (symbol? (car expect-module)) - (not (car expect-module))) - (andmap symbol? (cdr expect-module)))) - (raise-argument-error 'load/use-compiled "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" path)) - (define name (and expect-module (current-module-declare-name))) - (define ns-hts (and name - (hash-ref -module-hash-table-table - (namespace-module-registry (current-namespace)) - #f))) - (define use-path/src (and ns-hts (hash-ref (cdr ns-hts) name #f))) - (if use-path/src - ;; Use previous decision of .zo vs. source: - (parameterize ([current-module-declare-source (cadr use-path/src)]) - (with-dir* (caddr use-path/src) - (lambda () ((current-load) (car use-path/src) expect-module)))) - ;; Check .zo vs. src dates, etc.: - (let*-values ([(orig-path) (resolve path)] - [(base orig-file dir?) (split-path path)] - [(file alt-file) (if expect-module - (let* ([b (path->bytes orig-file)] - [len (bytes-length b)]) - (cond - [(and (len . >= . 4) - (bytes=? #".rkt" (subbytes b (- len 4)))) - ;; .rkt => try .rkt then .ss - (values orig-file - (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] - [else - ;; No search path - (values orig-file #f)])) - (values orig-file #f))] - [(path) (if (eq? file orig-file) - orig-path - (build-path base file))] - [(alt-path) (and alt-file - (if (eq? alt-file orig-file) - orig-path - (build-path base alt-file)))] - [(base) (if (eq? base 'relative) 'same base)] - [(modes) (use-compiled-file-paths)] - [(roots) (current-compiled-file-roots)] - [(reroot) (lambda (p d) - (cond - [(eq? d 'same) p] - [(relative-path? d) (build-path p d)] - [else (reroot-path p d)]))]) - (let* ([main-path-d (date-of-1 path)] - [alt-path-d (and alt-path - (not main-path-d) - (date-of-1 alt-path))] - [path-d (or main-path-d alt-path-d)] - [get-so (lambda (file rep-sfx?) - (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - "native" - (system-library-subpath) - (if rep-sfx? - (path-add-extension - file - dll-suffix) - file))))] - [zo (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - (path-add-extension file #".zo")))] - [alt-zo (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - (path-add-extension alt-file #".zo")))] - [so (get-so file #t)] - [alt-so (get-so alt-file #t)] - [try-main? (or main-path-d (not alt-path-d))] - [try-alt? (and alt-file (or alt-path-d (not main-path-d)))] - [with-dir (lambda (t) (with-dir* base t))]) - (cond - [(and try-main? - (date>=? modes roots so path-d)) - => (lambda (so-d) - (parameterize ([current-module-declare-source #f]) - (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] - [(and try-alt? - (date>=? modes roots alt-so alt-path-d)) - => (lambda (so-d) - (parameterize ([current-module-declare-source alt-path]) - (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] - [(and try-main? - (date>=? modes roots zo path-d)) - => (lambda (zo-d) - (register-zo-path name ns-hts (car zo-d) #f base) - (parameterize ([current-module-declare-source #f]) - (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] - [(and try-alt? - (date>=? modes roots alt-zo path-d)) - => (lambda (zo-d) - (register-zo-path name ns-hts (car zo-d) alt-path base) - (parameterize ([current-module-declare-source alt-path]) - (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] - [(or (not (pair? expect-module)) - (car expect-module)) - (let ([p (if try-main? path alt-path)]) - ;; "quiet" failure when asking for a submodule: - (unless (and (pair? expect-module) - (not (file-exists? p))) - (parameterize ([current-module-declare-source (and expect-module - (not try-main?) - p)]) - (with-dir (lambda () ((current-load) p expect-module))))))]))))))) - - (define (register-zo-path name ns-hts path src-path base) - (when ns-hts - (hash-set! (cdr ns-hts) name (list path src-path base)))) - - (define-values (default-reader-guard) - (lambda (path) path)) - - (define-values (-module-hash-table-table) (make-weak-hasheq)) ; weak map from namespace to pair of module-name hts - - ;; weak map from `lib' path + corrent-library-paths to symbols: - ;; We'd like to use a weak `equal?'-based hash table here, - ;; but that's not kill-safe. Instead, we use a non-thread-safe - ;; custom hash table; a race could lose cache entries, but - ;; that's ok. - (define CACHE-N 512) - (define-values (-path-cache) (make-vector CACHE-N #f)) - (define (path-cache-get p) - (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] - [w (vector-ref -path-cache i)] - [l (and w (weak-box-value w))]) - (and l - (let ([a (assoc p l)]) - (and a (cdr a)))))) - (define (path-cache-set! p v) - (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] - [w (vector-ref -path-cache i)] - [l (and w (weak-box-value w))]) - (vector-set! -path-cache i (make-weak-box (cons (cons p v) (or l null)))))) - - (define-values (-loading-filename) (gensym)) - (define-values (-loading-prompt-tag) (make-continuation-prompt-tag 'module-loading)) - (define-values (-prev-relto) #f) - (define-values (-prev-relto-dir) #f) - - (define (split-relative-string s coll-mode?) - (let ([l (let loop ([s s]) - (let ([len (string-length s)]) - (let iloop ([i 0]) - (cond - [(= i len) (list s)] - [(char=? #\/ (string-ref s i)) - (cons (substring s 0 i) - (loop (substring s (add1 i))))] - [else (iloop (add1 i))]))))]) - (if coll-mode? - l - (let loop ([l l]) - (if (null? (cdr l)) - (values null (car l)) - (let-values ([(c f) (loop (cdr l))]) - (values (cons (car l) c) f))))))) - - (define (format-source-location stx) - (srcloc->string (srcloc (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx)))) - - (define-values (orig-paramz) #f) - - (define-values (standard-module-name-resolver) - (let-values () - (define-values (planet-resolver) #f) - (define-values (prep-planet-resolver!) - (lambda () - (unless planet-resolver - (with-continuation-mark - parameterization-key - orig-paramz - (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))) - (define-values (standard-module-name-resolver) - (case-lambda - [(s from-namespace) - (unless (resolved-module-path? s) - (raise-argument-error 'standard-module-name-resolver - "resolved-module-path?" - s)) - (unless (or (not from-namespace) (namespace? from-namespace)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f namespace?)" - from-namespace)) - (when planet-resolver - ;; Let planet resolver register, too: - (planet-resolver s)) - ;; Register s as loaded: - (let ([hts (or (hash-ref -module-hash-table-table - (namespace-module-registry (current-namespace)) - #f) - (let ([hts (cons (make-hasheq) (make-hasheq))]) - (hash-set! -module-hash-table-table - (namespace-module-registry (current-namespace)) - hts) - hts))]) - (hash-set! (car hts) s 'declared) - ;; If attach from another namespace, copy over source-file path, if any: - (when from-namespace - (let ([root-name (if (pair? (resolved-module-path-name s)) - (make-resolved-module-path (car (resolved-module-path-name s))) - s)] - [from-hts (hash-ref -module-hash-table-table - (namespace-module-registry from-namespace) - #f)]) - (when from-hts - (let ([use-path/src (hash-ref (cdr from-hts) root-name #f)]) - (when use-path/src - (hash-set! (cdr hts) root-name use-path/src)))))))] - [(s relto stx) ; for backward-compatibility - (log-message (current-logger) 'error - "default module name resolver called with three arguments (deprecated)" - #f) - (standard-module-name-resolver s relto stx #t)] - [(s relto stx load?) - ;; If stx is not #f, raise syntax error for ill-formed paths - (unless (module-path? s) - (if (syntax? stx) - (raise-syntax-error #f - "bad module path" - stx) - (raise-argument-error 'standard-module-name-resolver - "module-path?" - s))) - (unless (or (not relto) (resolved-module-path? relto)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f resolved-module-path?)" - relto)) - (unless (or (not stx) (syntax? stx)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f syntax?)" - stx)) - (define (flatten-sub-path base orig-l) - (let loop ([a null] [l orig-l]) - (cond - [(null? l) (if (null? a) - base - (cons base (reverse a)))] - [(equal? (car l) "..") - (if (null? a) - (error - 'standard-module-name-resolver - "too many \"..\"s in submodule path: ~.s" - (list* 'submod - (if (equal? base ".") - base - (if (path? base) - base - (list (if (symbol? base) 'quote 'file) base))) - orig-l)) - (loop (cdr a) (cdr l)))] - [else (loop (cons (car l) a) (cdr l))]))) - (cond - [(and (pair? s) (eq? (car s) 'quote)) - (make-resolved-module-path (cadr s))] - [(and (pair? s) (eq? (car s) 'submod) - (pair? (cadr s)) (eq? (caadr s) 'quote)) - (make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))] - [(and (pair? s) (eq? (car s) 'submod) - (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (and relto - (let ([p (resolved-module-path-name relto)]) - (or (symbol? p) - (and (pair? p) (symbol? (car p))))))) - (define rp (resolved-module-path-name relto)) - (make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp) - (let ([r (if (equal? (cadr s) "..") - (cdr s) - (cddr s))]) - (if (pair? rp) - (append (cdr rp) r) - r))))] - [(and (pair? s) (eq? (car s) 'planet)) - (prep-planet-resolver!) - (planet-resolver s relto stx load? #f orig-paramz)] - [(and (pair? s) - (eq? (car s) 'submod) - (pair? (cadr s)) - (eq? (caadr s) 'planet)) - (prep-planet-resolver!) - (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] - [else - (let ([get-dir (lambda () - (or (and relto - (if (eq? relto -prev-relto) - -prev-relto-dir - (let ([p (resolved-module-path-name relto)]) - (let ([p (if (pair? p) (car p) p)]) - (and (path? p) - (let-values ([(base n d?) (split-path p)]) - (set! -prev-relto relto) - (set! -prev-relto-dir base) - base)))))) - (current-load-relative-directory) - (current-directory)))] - [get-reg (lambda () - (namespace-module-registry (current-namespace)))] - [show-collection-err (lambda (msg) - (let ([msg (string-append - (or (and stx - (error-print-source-location) - (format-source-location stx)) - "standard-module-name-resolver") - ": " - (regexp-replace #rx"\n" - msg - (format "\n for module path: ~s\n" - s)))]) - (raise - (if stx - (exn:fail:syntax:missing-module - msg - (current-continuation-marks) - (list stx) - s) - (exn:fail:filesystem:missing-module - msg - (current-continuation-marks) - s)))))] - [ss->rkt (lambda (s) - (let ([len (string-length s)]) - (if (and (len . >= . 3) - ;; ".ss" - (equal? #\. (string-ref s (- len 3))) - (equal? #\s (string-ref s (- len 2))) - (equal? #\s (string-ref s (- len 1)))) - (string-append (substring s 0 (- len 3)) ".rkt") - s)))] - [path-ss->rkt (lambda (p) - (let-values ([(base name dir?) (split-path p)]) - (if (regexp-match #rx"[.]ss$" (path->bytes name)) - (path-replace-extension p #".rkt") - p)))] - [s (if (and (pair? s) (eq? 'submod (car s))) - (let ([v (cadr s)]) - (if (or (equal? v ".") - (equal? v "..")) - (if relto - ;; must have a path inside, or we wouldn't get here - (let ([p (resolved-module-path-name relto)]) - (if (pair? p) - (car p) - p)) - (error 'standard-module-name-resolver - "no base path for relative submodule path: ~.s" - s)) - v)) - s)] - [subm-path (if (and (pair? s) (eq? 'submod (car s))) - (let ([p (if (and (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - relto) - (let ([p (resolved-module-path-name relto)] - [r (if (equal? (cadr s) "..") - (cdr s) - (cddr s))]) - (if (pair? p) - (flatten-sub-path (car p) (append (cdr p) r)) - (flatten-sub-path p r))) - (flatten-sub-path "." - (if (equal? (cadr s) "..") - (cdr s) - (cddr s))))]) - ;; flattening may erase the submodule path: - (if (pair? p) - (cdr p) - #f)) - #f)]) - (let ([s-parsed - ;; Non-string result represents an error - (cond - [(symbol? s) - (or (path-cache-get (cons s (get-reg))) - (let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) - (let* ([f-file (if (null? cols) - "main.rkt" - (string-append file ".rkt"))]) - (find-col-file show-collection-err - (if (null? cols) file (car cols)) - (if (null? cols) null (cdr cols)) - f-file - #t))))] - [(string? s) - (let* ([dir (get-dir)]) - (or (path-cache-get (cons s dir)) - (let-values ([(cols file) (split-relative-string s #f)]) - (if (null? cols) - (build-path dir (ss->rkt file)) - (apply build-path - dir - (append - (map (lambda (s) - (cond - [(string=? s ".") 'same] - [(string=? s "..") 'up] - [else s])) - cols) - (list (ss->rkt file))))))))] - [(path? s) - ;; Use filesystem-sensitive `simplify-path' here: - (path-ss->rkt (simplify-path (if (complete-path? s) - s - (path->complete-path s (get-dir)))))] - [(eq? (car s) 'lib) - (or (path-cache-get (cons s (get-reg))) - (let*-values ([(cols file) (split-relative-string (cadr s) #f)] - [(old-style?) (if (null? (cddr s)) - (and (null? cols) - (regexp-match? #rx"[.]" file)) - #t)]) - (let* ([f-file (if old-style? - (ss->rkt file) - (if (null? cols) - "main.rkt" - (if (regexp-match? #rx"[.]" file) - (ss->rkt file) - (string-append file ".rkt"))))]) - (let-values ([(cols) - (if old-style? - (append (if (null? (cddr s)) - '("mzlib") - (apply append - (map (lambda (p) - (split-relative-string p #t)) - (cddr s)))) - cols) - (if (null? cols) - (list file) - cols))]) - (find-col-file show-collection-err - (car cols) - (cdr cols) - f-file - #t)))))] - [(eq? (car s) 'file) - ;; Use filesystem-sensitive `simplify-path' here: - (path-ss->rkt - (simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])]) - (unless (or (path? s-parsed) - (vector? s-parsed)) - (if stx - (raise-syntax-error - 'require - (format "bad module path~a" (if s-parsed - (car s-parsed) - "")) - stx) - (raise-argument-error - 'standard-module-name-resolver - "module-path?" - s))) - ;; At this point, s-parsed is a complete path (or a cached vector) - (let* ([filename (if (vector? s-parsed) - (vector-ref s-parsed 0) - (simplify-path (cleanse-path s-parsed) #f))] - [normal-filename (if (vector? s-parsed) - (vector-ref s-parsed 1) - (normal-case-path filename))]) - (let-values ([(base name dir?) (if (vector? s-parsed) - (values 'ignored (vector-ref s-parsed 2) 'ignored) - (split-path filename))]) - (let* ([no-sfx (if (vector? s-parsed) - (vector-ref s-parsed 3) - (path-replace-extension name #""))]) - (let* ([root-modname (if (vector? s-parsed) - (vector-ref s-parsed 4) - (make-resolved-module-path filename))] - [hts (or (hash-ref -module-hash-table-table - (get-reg) - #f) - (let ([hts (cons (make-hasheq) (make-hasheq))]) - (hash-set! -module-hash-table-table - (get-reg) - hts) - hts))] - [modname (if subm-path - (make-resolved-module-path - (cons (resolved-module-path-name root-modname) - subm-path)) - root-modname)]) - ;; Loaded already? - (when load? - (let ([got (hash-ref (car hts) modname #f)]) - (unless got - ;; Currently loading? - (let ([loading - (let ([tag (if (continuation-prompt-available? -loading-prompt-tag) - -loading-prompt-tag - (default-continuation-prompt-tag))]) - (continuation-mark-set-first - #f - -loading-filename - null - tag))] - [nsr (get-reg)]) - (for-each - (lambda (s) - (when (and (equal? (cdr s) normal-filename) - (eq? (car s) nsr)) - (error - 'standard-module-name-resolver - "cycle in loading\n at path: ~a\n paths:~a" - filename - (apply string-append - (let loop ([l (reverse loading)]) - (if (null? l) - '() - (list* "\n " (path->string (cdar l)) (loop (cdr l))))))))) - loading) - ((if (continuation-prompt-available? -loading-prompt-tag) - (lambda (f) (f)) - (lambda (f) (call-with-continuation-prompt f -loading-prompt-tag))) - (lambda () - (with-continuation-mark -loading-filename (cons (cons nsr normal-filename) - loading) - (parameterize ([current-module-declare-name root-modname] - [current-module-path-for-load - ;; If `s' is an absolute module path, then - ;; keep it as-is, the better to let a tool - ;; recommend how to get an unavailable module; - ;; also, propagate the source location. - ((if stx - (lambda (p) (datum->syntax #f p stx)) - values) - (cond - [(symbol? s) s] - [(and (pair? s) (eq? (car s) 'lib)) s] - [else (if (resolved-module-path? root-modname) - (let ([src (resolved-module-path-name root-modname)]) - (if (symbol? src) - (list 'quote src) - src)) - root-modname)]))]) - ((current-load/use-compiled) - filename - (let ([sym (string->symbol (path->string no-sfx))]) - (if subm-path - (if (hash-ref (car hts) root-modname #f) - ;; Root is already loaded, so only use .zo - (cons #f subm-path) - ;; Root isn't loaded, so it's ok to load form source: - (cons sym subm-path)) - sym))))))))))) - ;; If a `lib' path, cache pathname manipulations - (when (and (not (vector? s-parsed)) - load? - (or (string? s) - (symbol? s) - (and (pair? s) - (eq? (car s) 'lib)))) - (path-cache-set! (if (string? s) - (cons s (get-dir)) - (cons s (get-reg))) - (vector filename - normal-filename - name - no-sfx - root-modname))) - ;; Result is the module name: - modname))))))])])) - standard-module-name-resolver)) - - (define-values (boot) - (lambda () - (seal) - (current-module-name-resolver standard-module-name-resolver) - (current-load/use-compiled default-load/use-compiled) - (current-reader-guard default-reader-guard))) - - (define-values (seal) - (lambda () - (set! orig-paramz - (reparameterize - (continuation-mark-set-first #f parameterization-key)))))) - -;; ---------------------------------------- -;; A module that collects all the built-in modules, -;; so that it's easier to keep them attached in new -;; namespaces. - -(module #%builtin '#%kernel - (#%require '#%expobs - (only '#%foreign) ; so it's attached, but doesn't depend on any exports - (only '#%unsafe) ; ditto - (only '#%flfxnum) ; ditto - '#%boot - '#%place-struct - '#%paramz - '#%network - '#%utils - (only '#%place) - (only '#%futures) - (only '#%linklet))) diff -Nru racket-6.12+ppa1/src/racket/src/startup-select.rkt racket-7.0+ppa1/src/racket/src/startup-select.rkt --- racket-6.12+ppa1/src/racket/src/startup-select.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/startup-select.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +(module startup-select '#%kernel + (if (eval-jit-enabled) + (display "bytecode") + (display "c")) + (newline)) + diff -Nru racket-6.12+ppa1/src/racket/src/string.c racket-7.0+ppa1/src/racket/src/string.c --- racket-6.12+ppa1/src/racket/src/string.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/string.c 2018-07-27 22:12:02.000000000 +0000 @@ -68,7 +68,7 @@ Scheme_Custodian_Reference *mref; } Scheme_Converter; -/* locals */ +Scheme_Object *scheme_system_type_proc; static Scheme_Object *make_string (int argc, Scheme_Object *argv[]); static Scheme_Object *string (int argc, Scheme_Object *argv[]); @@ -197,9 +197,9 @@ ROSYM static Scheme_Object *link_symbol, *machine_symbol, *vm_symbol, *gc_symbol; ROSYM static Scheme_Object *so_suffix_symbol, *so_mode_symbol, *word_symbol; ROSYM static Scheme_Object *os_symbol, *fs_change_symbol, *cross_symbol; -ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol; +ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol; ROSYM static Scheme_Object *force_symbol, *infer_symbol; -ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path; +ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path; READ_ONLY static Scheme_Object *zero_length_char_string; READ_ONLY static Scheme_Object *zero_length_byte_string; @@ -230,7 +230,7 @@ static const mzchar xes_char_string[2] = { 0x78787878, 0 }; void -scheme_init_string (Scheme_Env *env) +scheme_init_string (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -261,9 +261,11 @@ REGISTER_SO(racket_symbol); REGISTER_SO(cgc_symbol); REGISTER_SO(_3m_symbol); + REGISTER_SO(cs_symbol); racket_symbol = scheme_intern_symbol("racket"); cgc_symbol = scheme_intern_symbol("cgc"); _3m_symbol = scheme_intern_symbol("3m"); + cs_symbol = scheme_intern_symbol("cs"); REGISTER_SO(force_symbol); REGISTER_SO(infer_symbol); @@ -285,19 +287,19 @@ error_symbol = scheme_intern_symbol("error"); REGISTER_SO(platform_3m_path); -#ifdef UNIX_FILE_SYSTEM -# define MZ3M_SUBDIR "/3m" -#else # ifdef DOS_FILE_SYSTEM # define MZ3M_SUBDIR "\\3m" +# define MZCS_SUBDIR "\\cs" # else -# define MZ3M_SUBDIR ":3m" -# endif +# define MZ3M_SUBDIR "/3m" +# define MZCS_SUBDIR "/cs" #endif REGISTER_SO(platform_3m_path); REGISTER_SO(platform_cgc_path); + REGISTER_SO(platform_cs_path); platform_cgc_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX); platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZ3M_SUBDIR); + platform_cs_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZCS_SUBDIR); REGISTER_SO(embedding_banner); REGISTER_SO(vers_str); @@ -311,16 +313,17 @@ REGISTER_SO(scheme_string_p_proc); p = scheme_make_folding_prim(string_p, "string?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("string?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("string?", p, env); scheme_string_p_proc = p; - scheme_add_global_constant("make-string", + scheme_addto_prim_instance("make-string", scheme_make_immed_prim(make_string, "make-string", 1, 2), env); - scheme_add_global_constant("string", + scheme_addto_prim_instance("string", scheme_make_immed_prim(string, "string", 0, -1), @@ -328,258 +331,262 @@ p = scheme_make_folding_prim(string_length, "string-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - |SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("string-length", p, + |SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-length", p, env); p = scheme_make_immed_prim(scheme_checked_string_ref, "string-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("string-ref", p, env); - + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-ref", p, env); p = scheme_make_immed_prim(scheme_checked_string_set, "string-set!", 3, 3); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("string-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-set!", p, env); p = scheme_make_immed_prim(string_eq, "string=?", 2, -1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("string=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("string=?", p, env); - scheme_add_global_constant("string-locale=?", + scheme_addto_prim_instance("string-locale=?", scheme_make_immed_prim(string_locale_eq, "string-locale=?", 2, -1), env); - scheme_add_global_constant("string-ci=?", + scheme_addto_prim_instance("string-ci=?", scheme_make_immed_prim(string_ci_eq, "string-ci=?", 2, -1), env); - scheme_add_global_constant("string-locale-ci=?", + scheme_addto_prim_instance("string-locale-ci=?", scheme_make_immed_prim(string_locale_ci_eq, "string-locale-ci=?", 2, -1), env); - scheme_add_global_constant("string?", + scheme_addto_prim_instance("string>?", scheme_make_immed_prim(string_gt, "string>?", 2, -1), env); - scheme_add_global_constant("string-locale>?", + scheme_addto_prim_instance("string-locale>?", scheme_make_immed_prim(string_locale_gt, "string-locale>?", 2, -1), env); - scheme_add_global_constant("string<=?", + scheme_addto_prim_instance("string<=?", scheme_make_immed_prim(string_lt_eq, "string<=?", 2, -1), env); - scheme_add_global_constant("string>=?", + scheme_addto_prim_instance("string>=?", scheme_make_immed_prim(string_gt_eq, "string>=?", 2, -1), env); - scheme_add_global_constant("string-ci?", + scheme_addto_prim_instance("string-ci>?", scheme_make_immed_prim(string_ci_gt, "string-ci>?", 2, -1), env); - scheme_add_global_constant("string-locale-ci>?", + scheme_addto_prim_instance("string-locale-ci>?", scheme_make_immed_prim(string_locale_ci_gt, "string-locale-ci>?", 2, -1), env); - scheme_add_global_constant("string-ci<=?", + scheme_addto_prim_instance("string-ci<=?", scheme_make_immed_prim(string_ci_lt_eq, "string-ci<=?", 2, -1), env); - scheme_add_global_constant("string-ci>=?", + scheme_addto_prim_instance("string-ci>=?", scheme_make_immed_prim(string_ci_gt_eq, "string-ci>=?", 2, -1), env); - scheme_add_global_constant("substring", + scheme_addto_prim_instance("substring", scheme_make_immed_prim(substring, "substring", 2, 3), env); - scheme_add_global_constant("string-append", - scheme_make_immed_prim(string_append, - "string-append", - 0, -1), - env); - scheme_add_global_constant("string->list", + + p = scheme_make_immed_prim(string_append, "string-append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-append", p, env); + + scheme_addto_prim_instance("string->list", scheme_make_immed_prim(string_to_list, "string->list", 1, 1), env); - scheme_add_global_constant("list->string", + scheme_addto_prim_instance("list->string", scheme_make_immed_prim(list_to_string, "list->string", 1, 1), env); - scheme_add_global_constant("string-copy", + scheme_addto_prim_instance("string-copy", scheme_make_immed_prim(string_copy, "string-copy", 1, 1), env); - scheme_add_global_constant("string-copy!", + scheme_addto_prim_instance("string-copy!", scheme_make_immed_prim(string_copy_bang, "string-copy!", 3, 5), env); - scheme_add_global_constant("string-fill!", + scheme_addto_prim_instance("string-fill!", scheme_make_immed_prim(string_fill, "string-fill!", 2, 2), env); - scheme_add_global_constant("string->immutable-string", - scheme_make_immed_prim(string_to_immutable, - "string->immutable-string", - 1, 1), - env); - scheme_add_global_constant("string-normalize-nfc", + + p = scheme_make_immed_prim(string_to_immutable, "string->immutable-string", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->immutable-string", p, env); + + scheme_addto_prim_instance("string-normalize-nfc", scheme_make_immed_prim(string_normalize_c, "string-normalize-nfc", 1, 1), env); - scheme_add_global_constant("string-normalize-nfkc", + scheme_addto_prim_instance("string-normalize-nfkc", scheme_make_immed_prim(string_normalize_kc, "string-normalize-nfkc", 1, 1), env); - scheme_add_global_constant("string-normalize-nfd", + scheme_addto_prim_instance("string-normalize-nfd", scheme_make_immed_prim(string_normalize_d, "string-normalize-nfd", 1, 1), env); - scheme_add_global_constant("string-normalize-nfkd", + scheme_addto_prim_instance("string-normalize-nfkd", scheme_make_immed_prim(string_normalize_kd, "string-normalize-nfkd", 1, 1), env); - scheme_add_global_constant("string-upcase", + scheme_addto_prim_instance("string-upcase", scheme_make_immed_prim(string_upcase, "string-upcase", 1, 1), env); - scheme_add_global_constant("string-downcase", + scheme_addto_prim_instance("string-downcase", scheme_make_immed_prim(string_downcase, "string-downcase", 1, 1), env); - scheme_add_global_constant("string-titlecase", + scheme_addto_prim_instance("string-titlecase", scheme_make_immed_prim(string_titlecase, "string-titlecase", 1, 1), env); - scheme_add_global_constant("string-foldcase", + scheme_addto_prim_instance("string-foldcase", scheme_make_immed_prim(string_foldcase, "string-foldcase", 1, 1), env); - scheme_add_global_constant("string-locale-upcase", + scheme_addto_prim_instance("string-locale-upcase", scheme_make_immed_prim(string_locale_upcase, "string-locale-upcase", 1, 1), env); - scheme_add_global_constant("string-locale-downcase", + scheme_addto_prim_instance("string-locale-downcase", scheme_make_immed_prim(string_locale_downcase, "string-locale-downcase", 1, 1), env); - scheme_add_global_constant("current-locale", + scheme_addto_prim_instance("current-locale", scheme_register_parameter(current_locale, "current-locale", MZCONFIG_LOCALE), env); - scheme_add_global_constant("locale-string-encoding", + scheme_addto_prim_instance("locale-string-encoding", scheme_make_immed_prim(locale_string_encoding, "locale-string-encoding", 0, 0), env); - scheme_add_global_constant("system-language+country", + scheme_addto_prim_instance("system-language+country", scheme_make_immed_prim(system_language_country, "system-language+country", 0, 0), env); - scheme_add_global_constant("bytes-converter?", + scheme_addto_prim_instance("bytes-converter?", scheme_make_immed_prim(byte_converter_p, "bytes-converter?", 1, 1), env); - scheme_add_global_constant("bytes-convert", + scheme_addto_prim_instance("bytes-convert", scheme_make_prim_w_arity2(byte_string_convert, "bytes-convert", 1, 7, 3, 3), env); - scheme_add_global_constant("bytes-convert-end", + scheme_addto_prim_instance("bytes-convert-end", scheme_make_prim_w_arity2(byte_string_convert_end, "bytes-convert-end", 0, 3, 2, 2), env); - scheme_add_global_constant("bytes-open-converter", + scheme_addto_prim_instance("bytes-open-converter", scheme_make_immed_prim(byte_string_open_converter, "bytes-open-converter", 2, 2), env); - scheme_add_global_constant("bytes-close-converter", + scheme_addto_prim_instance("bytes-close-converter", scheme_make_immed_prim(byte_string_close_converter, "bytes-close-converter", 1, 1), env); - scheme_add_global_constant("format", + scheme_addto_prim_instance("format", scheme_make_noncm_prim(format, "format", 1, -1), env); - scheme_add_global_constant("printf", + scheme_addto_prim_instance("printf", scheme_make_noncm_prim(sch_printf, "printf", 1, -1), env); - scheme_add_global_constant("eprintf", + scheme_addto_prim_instance("eprintf", scheme_make_noncm_prim(sch_eprintf, "eprintf", 1, -1), env); - scheme_add_global_constant("fprintf", + scheme_addto_prim_instance("fprintf", scheme_make_noncm_prim(sch_fprintf, "fprintf", 2, -1), env); - scheme_add_global_constant("byte?", + scheme_addto_prim_instance("byte?", scheme_make_folding_prim(byte_p, "byte?", 1, 1, 1), @@ -588,142 +595,146 @@ REGISTER_SO(scheme_byte_string_p_proc); p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("bytes?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("bytes?", p, env); scheme_byte_string_p_proc = p; - scheme_add_global_constant("make-bytes", + scheme_addto_prim_instance("make-bytes", scheme_make_immed_prim(make_byte_string, "make-bytes", 1, 2), env); - scheme_add_global_constant("bytes", + scheme_addto_prim_instance("bytes", scheme_make_immed_prim(byte_string, "bytes", 0, -1), env); - GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env); - GLOBAL_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env); + ADD_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env); p = scheme_make_folding_prim(byte_string_length, "bytes-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - |SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("bytes-length", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-length", p, env); p = scheme_make_immed_prim(scheme_checked_byte_string_ref, "bytes-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("bytes-ref", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-ref", p, env); p = scheme_make_immed_prim(scheme_checked_byte_string_set, "bytes-set!", 3, 3); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bytes-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-set!", p, env); p = scheme_make_immed_prim(byte_string_eq, "bytes=?", 2, -1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("bytes=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("bytes=?", p, env); - scheme_add_global_constant("bytes?", + scheme_addto_prim_instance("bytes>?", scheme_make_immed_prim(byte_string_gt, "bytes>?", 2, -1), env); - scheme_add_global_constant("subbytes", + scheme_addto_prim_instance("subbytes", scheme_make_immed_prim(byte_substring, "subbytes", 2, 3), env); - scheme_add_global_constant("bytes-append", - scheme_make_immed_prim(byte_string_append, - "bytes-append", - 0, -1), - env); - scheme_add_global_constant("bytes->list", + + p = scheme_make_immed_prim(byte_string_append, "bytes-append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-append", p, env); + + scheme_addto_prim_instance("bytes->list", scheme_make_immed_prim(byte_string_to_list, "bytes->list", 1, 1), env); - scheme_add_global_constant("list->bytes", + scheme_addto_prim_instance("list->bytes", scheme_make_immed_prim(list_to_byte_string, "list->bytes", 1, 1), env); - scheme_add_global_constant("bytes-copy", + scheme_addto_prim_instance("bytes-copy", scheme_make_immed_prim(byte_string_copy, "bytes-copy", 1, 1), env); - scheme_add_global_constant("bytes-copy!", + scheme_addto_prim_instance("bytes-copy!", scheme_make_immed_prim(byte_string_copy_bang, "bytes-copy!", 3, 5), env); - scheme_add_global_constant("bytes-fill!", + scheme_addto_prim_instance("bytes-fill!", scheme_make_immed_prim(byte_string_fill, "bytes-fill!", 2, 2), env); - scheme_add_global_constant("bytes->immutable-bytes", - scheme_make_immed_prim(byte_string_to_immutable, - "bytes->immutable-bytes", - 1, 1), - env); + + p = scheme_make_immed_prim(byte_string_to_immutable, "bytes->immutable-bytes", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes->immutable-bytes", p, env); p = scheme_make_immed_prim(byte_string_utf8_index, "bytes-utf-8-index", 2, 4); /* Incorrect, since the result can be #f: SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */ - scheme_add_global_constant("bytes-utf-8-index", p, env); + scheme_addto_prim_instance("bytes-utf-8-index", p, env); p = scheme_make_immed_prim(byte_string_utf8_length, "bytes-utf-8-length", 1, 4); /* Incorrect, since the result can be #f: SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */ - scheme_add_global_constant("bytes-utf-8-length", p, env); + scheme_addto_prim_instance("bytes-utf-8-length", p, env); - scheme_add_global_constant("bytes-utf-8-ref", + scheme_addto_prim_instance("bytes-utf-8-ref", scheme_make_immed_prim(byte_string_utf8_ref, "bytes-utf-8-ref", 2, 4), env); - scheme_add_global_constant("bytes->string/utf-8", + scheme_addto_prim_instance("bytes->string/utf-8", scheme_make_immed_prim(byte_string_to_char_string, "bytes->string/utf-8", 1, 4), env); - scheme_add_global_constant("bytes->string/locale", + scheme_addto_prim_instance("bytes->string/locale", scheme_make_immed_prim(byte_string_to_char_string_locale, "bytes->string/locale", 1, 4), env); - scheme_add_global_constant("bytes->string/latin-1", + scheme_addto_prim_instance("bytes->string/latin-1", scheme_make_immed_prim(byte_string_to_char_string_latin1, "bytes->string/latin-1", 1, 4), env); - scheme_add_global_constant("string->bytes/utf-8", + scheme_addto_prim_instance("string->bytes/utf-8", scheme_make_immed_prim(char_string_to_byte_string, "string->bytes/utf-8", 1, 4), env); - scheme_add_global_constant("string->bytes/locale", + scheme_addto_prim_instance("string->bytes/locale", scheme_make_immed_prim(char_string_to_byte_string_locale, "string->bytes/locale", 1, 4), env); - scheme_add_global_constant("string->bytes/latin-1", + scheme_addto_prim_instance("string->bytes/latin-1", scheme_make_immed_prim(char_string_to_byte_string_latin1, "string->bytes/latin-1", 1, 4), env); - scheme_add_global_constant("string-utf-8-length", + scheme_addto_prim_instance("string-utf-8-length", scheme_make_immed_prim(char_string_utf8_length, "string-utf-8-length", 1, 3), @@ -733,12 +744,12 @@ /* In principle, `version' could be foldable, but it invites more problems than it solves... */ - scheme_add_global_constant("version", + scheme_addto_prim_instance("version", scheme_make_immed_prim(version, "version", 0, 0), env); - scheme_add_global_constant("banner", + scheme_addto_prim_instance("banner", scheme_make_immed_prim(banner, "banner", 0, 0), @@ -746,43 +757,43 @@ /* Environment variables */ - scheme_add_global_constant("environment-variables?", + scheme_addto_prim_instance("environment-variables?", scheme_make_folding_prim(env_p, "environment-variables?", 1, 1, 1), env); - scheme_add_global_constant("current-environment-variables", + scheme_addto_prim_instance("current-environment-variables", scheme_register_parameter(current_environment_variables, "current-environment-variables", MZCONFIG_CURRENT_ENV_VARS), env); - scheme_add_global_constant("environment-variables-ref", + scheme_addto_prim_instance("environment-variables-ref", scheme_make_immed_prim(sch_getenv, "environment-variables-ref", 2, 2), env); - scheme_add_global_constant("environment-variables-set!", + scheme_addto_prim_instance("environment-variables-set!", scheme_make_prim_w_arity(sch_putenv, "environment-variables-set!", 3, 4), env); - scheme_add_global_constant("environment-variables-names", + scheme_addto_prim_instance("environment-variables-names", scheme_make_immed_prim(sch_getenv_names, "environment-variables-names", 1, 1), env); - scheme_add_global_constant("environment-variables-copy", + scheme_addto_prim_instance("environment-variables-copy", scheme_make_immed_prim(env_copy, "environment-variables-copy", 1, 1), env); - scheme_add_global_constant("make-environment-variables", + scheme_addto_prim_instance("make-environment-variables", scheme_make_immed_prim(env_make, "make-environment-variables", 0, -1), @@ -790,25 +801,26 @@ /* Don't make these folding, since they're platform-specific: */ - scheme_add_global_constant("system-type", - scheme_make_immed_prim(system_type, - "system-type", - 0, 1), - env); - scheme_add_global_constant("system-library-subpath", + REGISTER_SO(scheme_system_type_proc); + scheme_system_type_proc = scheme_make_immed_prim(system_type, + "system-type", + 0, 1); + scheme_addto_prim_instance("system-type", scheme_system_type_proc, env); + + scheme_addto_prim_instance("system-library-subpath", scheme_make_immed_prim(system_library_subpath, "system-library-subpath", 0, 1), env); - scheme_add_global_constant("current-command-line-arguments", + scheme_addto_prim_instance("current-command-line-arguments", scheme_register_parameter(cmdline_args, "current-command-line-arguments", MZCONFIG_CMDLINE_ARGS), env); - scheme_add_global_constant("pathvector", 1, 2); - scheme_add_global_constant("struct->vector", scheme_struct_to_vector_proc, env); + scheme_addto_prim_instance("struct->vector", scheme_struct_to_vector_proc, env); - scheme_add_global_constant("prefab-struct-key", - scheme_make_immed_prim(prefab_struct_key, - "prefab-struct-key", - 1, 1), - env); - scheme_add_global_constant("make-prefab-struct", + p = scheme_make_immed_prim(prefab_struct_key, + "prefab-struct-key", + 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("prefab-struct-key", p, env); + + scheme_addto_prim_instance("make-prefab-struct", scheme_make_prim_w_arity(make_prefab_struct, "make-prefab-struct", 1, -1), env); - scheme_add_global_constant("prefab-key->struct-type", + scheme_addto_prim_instance("prefab-key->struct-type", scheme_make_prim_w_arity(prefab_key_struct_type, "prefab-key->struct-type", 2, 2), env); - scheme_add_global_constant("prefab-key?", + scheme_addto_prim_instance("prefab-key?", scheme_make_folding_prim(is_prefab_key, "prefab-key?", 1, 1, 1), env); /*** Predicates ****/ - scheme_add_global_constant("struct-mutator-procedure?", + scheme_addto_prim_instance("struct-mutator-procedure?", scheme_make_immed_prim(struct_setter_p, "struct-mutator-procedure?", 1, 1), env); - scheme_add_global_constant("struct-accessor-procedure?", + scheme_addto_prim_instance("struct-accessor-procedure?", scheme_make_immed_prim(struct_getter_p, "struct-accessor-procedure?", 1, 1), env); - scheme_add_global_constant("struct-predicate-procedure?", + scheme_addto_prim_instance("struct-predicate-procedure?", scheme_make_immed_prim(struct_pred_p, "struct-predicate-procedure?", 1, 1), env); - scheme_add_global_constant("struct-constructor-procedure?", + scheme_addto_prim_instance("struct-constructor-procedure?", scheme_make_immed_prim(struct_constr_p, "struct-constructor-procedure?", 1, 1), env); - scheme_add_global_constant("struct-type-property-accessor-procedure?", + scheme_addto_prim_instance("struct-type-property-accessor-procedure?", scheme_make_immed_prim(struct_prop_getter_p, "struct-type-property-accessor-procedure?", 1, 1), env); - scheme_add_global_constant("impersonator-property-accessor-procedure?", + scheme_addto_prim_instance("impersonator-property-accessor-procedure?", scheme_make_immed_prim(chaperone_prop_getter_p, "impersonator-property-accessor-procedure?", 1, 1), @@ -755,18 +676,18 @@ scheme_make_inspector_proc = scheme_make_immed_prim(make_inspector, "make-inspector", 0, 1); - scheme_add_global_constant("make-inspector", scheme_make_inspector_proc, env); - scheme_add_global_constant("make-sibling-inspector", + scheme_addto_prim_instance("make-inspector", scheme_make_inspector_proc, env); + scheme_addto_prim_instance("make-sibling-inspector", scheme_make_immed_prim(make_sibling_inspector, "make-sibling-inspector", 0, 1), env); - scheme_add_global_constant("inspector?", + scheme_addto_prim_instance("inspector?", scheme_make_folding_prim(inspector_p, "inspector?", 1, 1, 1), env); - scheme_add_global_constant("inspector-superior?", + scheme_addto_prim_instance("inspector-superior?", scheme_make_folding_prim(inspector_superior_p, "inspector-superior?", 2, 2, 1), @@ -776,32 +697,15 @@ scheme_current_inspector_proc = scheme_register_parameter(current_inspector, "current-inspector", MZCONFIG_INSPECTOR); - scheme_add_global_constant("current-inspector", + scheme_addto_prim_instance("current-inspector", scheme_current_inspector_proc, env); - scheme_add_global_constant("current-code-inspector", + scheme_addto_prim_instance("current-code-inspector", scheme_register_parameter(current_code_inspector, "current-code-inspector", MZCONFIG_CODE_INSPECTOR), env); - - scheme_add_global_constant("make-special-comment", - scheme_make_immed_prim(make_special_comment, - "make-special-comment", - 1, 1), - env); - scheme_add_global_constant("special-comment-value", - scheme_make_immed_prim(special_comment_value, - "special-comment-value", - 1, 1), - env); - scheme_add_global_constant("special-comment?", - scheme_make_folding_prim(special_comment_p, - "special-comment?", - 1, 1, 1), - env); - REGISTER_SO(ellipses_symbol); ellipses_symbol = scheme_intern_symbol("..."); @@ -817,69 +721,46 @@ scheme_source_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:srclocs"), guard); } - scheme_add_global_constant("prop:exn:srclocs", scheme_source_property, env); - scheme_add_global_constant("exn:srclocs?", + scheme_addto_prim_instance("prop:exn:srclocs", scheme_source_property, env); + scheme_addto_prim_instance("exn:srclocs?", scheme_make_folding_prim(exn_source_p, "exn:srclocs?", 1, 1, 1), env); - scheme_add_global_constant("exn:srclocs-accessor", + scheme_addto_prim_instance("exn:srclocs-accessor", scheme_make_folding_prim(exn_source_get, "exn:srclocs-accessor", 1, 1, 1), env); - REGISTER_SO(scheme_module_path_property); - { - guard = scheme_make_prim_w_arity(check_exn_module_path_property_value_ok, - "guard-for-prop:exn:srclocs", - 2, 2); - scheme_module_path_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:missing-module"), - guard); - } - scheme_add_global_constant("prop:exn:missing-module", scheme_module_path_property, env); - scheme_add_global_constant("exn:missing-module?", - scheme_make_folding_prim(exn_module_path_p, - "exn:missing-module?", - 1, 1, 1), - env); - scheme_add_global_constant("exn:missing-module-accessor", - scheme_make_folding_prim(exn_module_path_get, - "exn:missing-module-accessor", - 1, 1, 1), - env); + p = scheme_make_prim_w_arity(scheme_extract_checked_procedure, + "checked-procedure-check-and-extract", + 5, 5); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); + scheme_addto_prim_instance("checked-procedure-check-and-extract", p, env); - { - Scheme_Object *p; - p = scheme_make_prim_w_arity(scheme_extract_checked_procedure, - "checked-procedure-check-and-extract", - 5, 5); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("checked-procedure-check-and-extract", p, env); - } - - scheme_add_global_constant("chaperone-struct", + scheme_addto_prim_instance("chaperone-struct", scheme_make_prim_w_arity(chaperone_struct, "chaperone-struct", 1, -1), env); - scheme_add_global_constant("impersonate-struct", + scheme_addto_prim_instance("impersonate-struct", scheme_make_prim_w_arity(impersonate_struct, "impersonate-struct", 1, -1), env); - scheme_add_global_constant("chaperone-struct-type", + scheme_addto_prim_instance("chaperone-struct-type", scheme_make_prim_w_arity(chaperone_struct_type, "chaperone-struct-type", 4, -1), env); - scheme_add_global_constant("make-impersonator-property", + scheme_addto_prim_instance("make-impersonator-property", scheme_make_prim_w_arity2(make_chaperone_property, "make-impersonator-property", 1, 1, 3, 3), env); - scheme_add_global_constant("impersonator-property?", + scheme_addto_prim_instance("impersonator-property?", scheme_make_folding_prim(chaperone_property_p, "impersonator-property?", 1, 1, 1), @@ -888,7 +769,7 @@ { REGISTER_SO(scheme_app_mark_impersonator_property); scheme_app_mark_impersonator_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark")); - scheme_add_global_constant("impersonator-prop:application-mark", + scheme_addto_prim_instance("impersonator-prop:application-mark", scheme_app_mark_impersonator_property, env); } @@ -937,6 +818,13 @@ NULL, NULL, 1); } +#if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) +Scheme_Object *scheme_add_builtin_struct_types(Scheme_Object *accum) { + accum = scheme_make_pair(location_struct, accum); + return accum; +} +#endif + /*========================================================================*/ /* inspectors */ /*========================================================================*/ @@ -1849,10 +1737,6 @@ /* This is here so it can use check_indirect_property_value_ok */ static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } -static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o) - || scheme_check_proc_arity(NULL, 2, -1, 0, &o))); } - - static Scheme_Object *check_object_name_property_value_ok(int argc, Scheme_Object *argv[]) /* This is the guard for prop:object-name */ @@ -2021,189 +1905,6 @@ } /*========================================================================*/ -/* rename and set! transformer properties */ -/*========================================================================*/ - -int scheme_is_rename_transformer(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) - return 1; - if (SCHEME_CHAPERONE_STRUCTP(o) - && scheme_struct_type_property_ref(rename_transformer_property, o)) - return 1; - return 0; -} - -int scheme_is_binding_rename_transformer(Scheme_Object *o) -{ - if (scheme_is_rename_transformer(o)) { - o = scheme_rename_transformer_id(o, NULL); - o = scheme_stx_property(o, not_free_id_symbol, NULL); - if (o && SCHEME_TRUEP(o)) - return 0; - return 1; - } - return 0; -} - -static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); } - -static int is_stx_id_or_proc_1(Scheme_Object *o) { return (is_stx_id(o) || is_proc_1(o)); } - -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *comp_env) -{ - Scheme_Object *a[1]; - - if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) - return SCHEME_PTR1_VAL(o); - if (SCHEME_CHAPERONE_STRUCTP(o)) { - Scheme_Object *v; - v = scheme_struct_type_property_ref(rename_transformer_property, o); - if (SCHEME_PROCP(v)) { - a[0] = o; - /* apply a continuation barrier here to prevent a capture in - * the property access */ - if (comp_env && (scheme_current_thread->current_local_env != comp_env)) { - /* Getting identifier during an expansion context */ - Scheme_Dynamic_State dyn_state; - Scheme_Env *genv = comp_env->genv; - scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, - genv, (genv->module - ? (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx) - : NULL)); - v = scheme_apply_with_dynamic_state(v, 1, a, &dyn_state); - } else { - v = scheme_apply(v, 1, a); - } - if (!is_stx_id(v)) { - scheme_contract_error("prop:rename-transformer", - "contract violation for given value", - "expected", 0, "identifier?", - "given", 1, v, - NULL); - } - } else if (SCHEME_INTP(v)) { - v = scheme_struct_ref(o, SCHEME_INT_VAL(v)); - if (!is_stx_id(v)) { - v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0); - } - } - return v; - } - return NULL; -} - -static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]) -{ - return check_indirect_property_value_ok("guard-for-prop:rename-transformer", - is_stx_id_or_proc_1, 0, - "(or/c exact-nonnegative-integer? identifier? (-> any/c identifier?))", - argc, argv); -} - -int scheme_is_set_transformer(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) - return 1; - if (SCHEME_CHAPERONE_STRUCTP(o) - && scheme_struct_type_property_ref(set_transformer_property, o)) - return 1; - return 0; -} - -Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv) -{ - scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax"); - return NULL; -} - -static Scheme_Object *chain_transformer(void *data, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *a[2], *v = (Scheme_Object *)data; - a[0] = SCHEME_CAR(v); - a[1] = argv[0]; - return _scheme_tail_apply(SCHEME_CDR(v), 2, a); -} - -Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) - return SCHEME_PTR_VAL(o); - if (SCHEME_CHAPERONE_STRUCTP(o)) { - Scheme_Object *v; - v = scheme_struct_type_property_ref(set_transformer_property, o); - if (SCHEME_INTP(v)) { - v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; - if (!is_proc_1(v)) { - v = scheme_make_prim_w_arity(signal_bad_syntax, - "bad-syntax-set!-transformer", - 1, 1); - } - } else if (!scheme_check_proc_arity(NULL, 1, -1, 0, &v)) { - /* Must be a procedure of 2 arguments. Reduce to a procedure of 1. */ - o = scheme_make_pair(o, v); - v = scheme_make_closed_prim_w_arity(chain_transformer, (void *)o, - "set!-transformer", 1, 1); - } - return v; - } - return NULL; -} - -static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]) -{ - return check_indirect_property_value_ok("guard-for-prop:set!-transformer", - is_proc_1_or_2, 0, - "(or/c (any/c . -> . any) (any/c any/c . -> . any) exact-nonnegative-integer?)", - argc, argv); -} - -/*========================================================================*/ -/* expansion-contexts property */ -/*========================================================================*/ - -static Scheme_Object *check_expansion_contexts_property_value_ok(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - v = argv[0]; - - while (SCHEME_PAIRP(v)) { - if (!scheme_is_expansion_context_symbol(SCHEME_CAR(v))) - break; - v = SCHEME_CDR(v); - } - - if (SCHEME_NULLP(v)) - return argv[0]; - - wrong_property_contract("guard-for-prop:expression-contexts", - "(lisrof (or/c 'expression 'top-level 'module 'module-begin 'definition-context)", - v); - - return NULL; -} - -int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx) -{ - Scheme_Object *v; - - if (SCHEME_CHAPERONE_STRUCTP(o)) { - v = scheme_chaperone_struct_type_property_ref(expansion_contexts_property, o); - if (v) { - while (!SCHEME_NULLP(v)) { - if (SAME_OBJ(SCHEME_CAR(v), ctx)) - return 1; - v = SCHEME_CDR(v); - } - return 0; - } - } - - return 1; -} - -/*========================================================================*/ /* checked-proc property */ /*========================================================================*/ @@ -2276,22 +1977,6 @@ } /*========================================================================*/ -/* liberal-define */ -/*========================================================================*/ - -static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self) -{ - Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(self)[0], *val; - - val = scheme_struct_type_property_ref(prop, argv[0]); - - if (!val || SCHEME_FALSEP(val)) - return scheme_false; - else - return scheme_true; -} - -/*========================================================================*/ /* struct ops */ /*========================================================================*/ @@ -3732,53 +3417,88 @@ return 1; } -int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) +intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) { - intptr_t _v, v; + intptr_t _v, v, want_v; int i; Scheme_Struct_Type *st; - if (!scheme_decode_struct_shape(expected, &_v)) - return 0; - v = _v; + if (expected) { + if (!scheme_decode_struct_shape(expected, &_v)) + return 0; + v = _v; + } else + v = 0; if (SCHEME_STRUCT_TYPEP(e)) { st = (Scheme_Struct_Type *)e; if (st->num_slots != st->num_islots) - return (v == STRUCT_PROC_SHAPE_OTHER); - return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_STRUCT - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (!SCHEME_PRIMP(e)) - return 0; - - i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); - if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) - || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_CONSTR)); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == (STRUCT_PROC_SHAPE_PRED - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_SETTER - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { - int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((pos << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_GETTER - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) - || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) - || (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) - return (v == STRUCT_PROC_SHAPE_OTHER); + want_v = STRUCT_PROC_SHAPE_OTHER; + else + want_v = ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_STRUCT + | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC))) + ? STRUCT_PROC_SHAPE_AUTHENTIC + : 0) + | ((st->nonfail_constructor + && (!expected || (v & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) + ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR + : 0)); + } else if (!SCHEME_PRIMP(e)) { + want_v = -1; + } else { + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) + || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_CONSTR + | ((st->nonfail_constructor + && (!expected || (v & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) + ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR + : 0)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = (STRUCT_PROC_SHAPE_PRED + | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC))) + ? STRUCT_PROC_SHAPE_AUTHENTIC + : 0)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { + int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); + int parent_slots; + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + parent_slots = ((st->name_pos > 0) + ? st->parent_types[st->name_pos - 1]->num_slots + : 0); + if ((pos - parent_slots) < (31 - STRUCT_PROC_SHAPE_SHIFT)) + pos++; + else + pos = 0; /* => unknown, since simple struct info can't track it */ + want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_SETTER + | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC))) + ? STRUCT_PROC_SHAPE_AUTHENTIC + : 0)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { + int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_GETTER + | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC))) + ? STRUCT_PROC_SHAPE_AUTHENTIC + : 0)); + } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) { + want_v = STRUCT_PROC_SHAPE_OTHER; + } else + want_v = -1; + } - return 0; + if (expected) + return (v == want_v); + else + return want_v; } int scheme_decode_struct_prop_shape(Scheme_Object *expected, intptr_t *_v) @@ -3790,7 +3510,7 @@ return 0; if ((SCHEME_SYM_VAL(expected)[0] != 'p') - || (SCHEME_SYM_LEN(expected) < 4)) + || (SCHEME_SYM_LEN(expected) < 4)) return 0; for (i = 4, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) { @@ -3802,30 +3522,43 @@ return 1; } -int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected) +intptr_t scheme_get_or_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected) { - intptr_t _v, v; + intptr_t _v, v, want_v; int i; - if (!scheme_decode_struct_prop_shape(expected, &_v)) - return 0; - v = _v; + if (expected) { + if (!scheme_decode_struct_prop_shape(expected, &_v)) + return 0; + v = _v; + } else + v = 0; if (SAME_TYPE(SCHEME_TYPE(e), scheme_struct_property_type)) { if (((Scheme_Struct_Property *)e)->guard) - return (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP); - return ((v == STRUCT_PROP_PROC_SHAPE_PROP) - || (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP)); - } else if (!SCHEME_PRIMP(e)) - return 0; - - i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); - if (i == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) - return (v == STRUCT_PROP_PROC_SHAPE_PRED); - else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) - return (v == STRUCT_PROP_PROC_SHAPE_GETTER); + want_v = STRUCT_PROP_PROC_SHAPE_GUARDED_PROP; + else { + want_v = STRUCT_PROP_PROC_SHAPE_PROP; + if (expected) + return ((v == STRUCT_PROP_PROC_SHAPE_PROP) + || (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP)); + } + } else if (!SCHEME_PRIMP(e)) { + want_v = -1; + } else { + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if (i == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) + want_v = STRUCT_PROP_PROC_SHAPE_PRED; + else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + want_v = STRUCT_PROP_PROC_SHAPE_GETTER; + else + want_v = -1; + } - return 0; + if (expected) + return v == want_v; + else + return want_v; } static Scheme_Object *make_struct_field_xxor(const char *who, int getter, @@ -5012,6 +4745,7 @@ struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); struct_type->name_pos = depth; struct_type->authentic = 0; + struct_type->nonfail_constructor = 1; struct_type->inspector = scheme_false; struct_type->uninit_val = uninit_val; struct_type->props = NULL; @@ -5078,6 +4812,7 @@ } struct_type->name = base; + struct_type->nonfail_constructor = (parent_type ? parent_type->nonfail_constructor : 1); struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0); struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); @@ -5341,6 +5076,7 @@ } struct_type->guard = guard; + struct_type->nonfail_constructor = 0; } else if (chaperone_undefined) { struct_type->guard = scheme_undefined; } @@ -5348,6 +5084,7 @@ if (parent && SCHEME_NP_CHAPERONEP(parent)) { guard = add_struct_type_chaperone_guards(parent, struct_type->guard); struct_type->guard = guard; + struct_type->nonfail_constructor = 0; } if (checked_proc) @@ -6033,6 +5770,20 @@ return scheme_make_struct_instance(location_struct, 5, a); } +Scheme_Object *scheme_unsafe_make_location(void) +{ + Scheme_Structure *inst; + + inst = (Scheme_Structure *)scheme_malloc_tagged(STRUCT_BYTES(5)); + + inst->so.type = scheme_structure_type; + inst->stype = (Scheme_Struct_Type *)location_struct; + + /* caller must initialize content */ + + return (Scheme_Object *)inst; +} + int scheme_is_location(Scheme_Object *o) { if (SCHEME_CHAPERONEP(o)) @@ -6141,46 +5892,6 @@ return scheme_values(12, args); } -/*========================================================================*/ -/* special-comment struct */ -/*========================================================================*/ - -Scheme_Object *scheme_special_comment_value(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_special_comment_type)) - return ((Scheme_Small_Object *)o)->u.ptr_val; - else - return NULL; -} - -Scheme_Object *make_special_comment(int argc, Scheme_Object **argv) -{ - Scheme_Object *o; - - o = scheme_alloc_small_object(); - o->type = scheme_special_comment_type; - SCHEME_PTR_VAL(o) = argv[0]; - - return o; -} - -Scheme_Object *special_comment_value(int argc, Scheme_Object **argv) -{ - Scheme_Object *v; - - v = scheme_special_comment_value(argv[0]); - if (!v) - scheme_wrong_contract("special-comment-value", "special-comment?", 0, argc, argv); - return v; -} - -Scheme_Object *special_comment_p(int argc, Scheme_Object **argv) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_special_comment_type) - ? scheme_true - : scheme_false); -} - /**********************************************************************/ static Scheme_Object *exn_source_p(int argc, Scheme_Object **argv) @@ -6208,34 +5919,6 @@ return argv[0]; } - -/**********************************************************************/ - -static Scheme_Object *exn_module_path_p(int argc, Scheme_Object **argv) -{ - return (scheme_struct_type_property_ref(scheme_module_path_property, argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *exn_module_path_get(int argc, Scheme_Object **argv) -{ - Scheme_Object *v; - - v = scheme_struct_type_property_ref(scheme_module_path_property, argv[0]); - if (!v) - scheme_wrong_contract("exn:missing-module-accessor", "exn:missing-module?", 0, argc, argv); - - return v; -} - -static Scheme_Object *check_exn_module_path_property_value_ok(int argc, Scheme_Object *argv[]) - /* This is the guard for prop:exn:srclocs */ -{ - scheme_check_proc_arity("guard-for-prop:exn:missing-module", 1, 0, argc, argv); - - return argv[0]; -} /**********************************************************************/ diff -Nru racket-6.12+ppa1/src/racket/src/stypes.h racket-7.0+ppa1/src/racket/src/stypes.h --- racket-6.12+ppa1/src/racket/src/stypes.h 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/stypes.h 2018-07-27 22:12:02.000000000 +0000 @@ -3,317 +3,298 @@ /* Compiled bytecode elements: */ scheme_toplevel_type, /* 0 */ - scheme_local_type, /* 1 */ - scheme_local_unbox_type, /* 2 */ - scheme_application_type, /* 3 */ - scheme_application2_type, /* 4 */ - scheme_application3_type, /* 5 */ - scheme_sequence_type, /* 6 */ - scheme_branch_type, /* 7 */ - scheme_lambda_type, /* 8 */ - scheme_let_value_type, /* 9 */ - scheme_let_void_type, /* 10 */ - scheme_letrec_type, /* 11 */ - scheme_let_one_type, /* 12 */ - scheme_with_cont_mark_type, /* 13 */ - scheme_quote_syntax_type, /* 14 */ + scheme_static_toplevel_type, /* 1 */ + scheme_local_type, /* 2 */ + scheme_local_unbox_type, /* 3 */ + scheme_application_type, /* 4 */ + scheme_application2_type, /* 5 */ + scheme_application3_type, /* 6 */ + scheme_sequence_type, /* 7 */ + scheme_branch_type, /* 8 */ + scheme_lambda_type, /* 9 */ + scheme_let_value_type, /* 10 */ + scheme_let_void_type, /* 11 */ + scheme_letrec_type, /* 12 */ + scheme_let_one_type, /* 13 */ + scheme_with_cont_mark_type, /* 14 */ scheme_define_values_type, /* 15 */ - scheme_define_syntaxes_type, /* 16 */ - scheme_begin_for_syntax_type, /* 17 */ - scheme_set_bang_type, /* 18 */ - scheme_boxenv_type, /* 19 */ - scheme_begin0_sequence_type, /* 20 */ - scheme_splice_sequence_type, /* 21 */ - scheme_require_form_type, /* 22 */ - scheme_varref_form_type, /* 23 */ - scheme_apply_values_type, /* 24 */ - scheme_with_immed_mark_type, /* 25 */ - scheme_case_lambda_sequence_type, /* 26 */ - scheme_module_type, /* 27 */ - scheme_inline_variant_type, /* 28 */ + scheme_set_bang_type, /* 16 */ + scheme_boxenv_type, /* 17 */ + scheme_begin0_sequence_type, /* 18 */ + scheme_varref_form_type, /* 19 */ + scheme_apply_values_type, /* 20 */ + scheme_with_immed_mark_type, /* 21 */ + scheme_case_lambda_sequence_type, /* 22 */ + scheme_inline_variant_type, /* 23 */ - _scheme_values_types_, /* 29 */ + _scheme_values_types_, /* 24 */ /* All following types are values at run time */ + scheme_linklet_type, /* 25 */ + /* Replacements for some of the above as the compiler's intermediate representation for optimization: */ - scheme_ir_local_type, /* 30 */ - scheme_ir_lambda_type, /* 31 */ - scheme_ir_let_value_type, /* 32 */ - scheme_ir_let_header_type, /* 33 */ - scheme_ir_toplevel_type, /* 34 */ - scheme_ir_quote_syntax_type, /* 35 */ + scheme_ir_local_type, /* 26 */ + scheme_ir_lambda_type, /* 27 */ + scheme_ir_let_value_type, /* 28 */ + scheme_ir_let_header_type, /* 29 */ + scheme_ir_toplevel_type, /* 30 */ scheme_quote_compilation_type, /* used while writing, only */ /* Generated in the compiler front-end, but registered in the prefix table instead of used directly as an "expression": */ - scheme_variable_type, /* 37 */ - scheme_module_variable_type, /* link replaces with scheme_variable_type */ + scheme_variable_type, /* 32 */ - _scheme_ir_values_types_, /* 39 */ + _scheme_ir_values_types_, /* 33 */ /* All of the following are literal values from the perspective of the compiler */ + scheme_linklet_bundle_type, /* 34 */ + scheme_linklet_directory_type, /* 35 */ + scheme_instance_type, /* 36 */ + /* procedure types */ - scheme_prim_type, /* 40 */ - scheme_closed_prim_type, /* 41 */ - scheme_closure_type, /* 42 */ - scheme_case_closure_type, /* 43 */ - scheme_cont_type, /* 44 */ - scheme_escaping_cont_type, /* 45 */ - scheme_proc_struct_type, /* 46 */ - scheme_native_closure_type, /* 47 */ - scheme_proc_chaperone_type, /* 48 */ + scheme_prim_type, /* 37 */ + scheme_closed_prim_type, /* 38 */ + scheme_closure_type, /* 39 */ + scheme_case_closure_type, /* 40 */ + scheme_cont_type, /* 41 */ + scheme_escaping_cont_type, /* 42 */ + scheme_proc_struct_type, /* 43 */ + scheme_native_closure_type, /* 44 */ + scheme_proc_chaperone_type, /* 45 */ - scheme_chaperone_type, /* 49 */ + scheme_chaperone_type, /* 46 */ /* structure type (plus one above for procs) */ - scheme_structure_type, /* 50 */ + scheme_structure_type, /* 47 */ /* number types (must be together) */ - scheme_integer_type, /* 51 */ - scheme_bignum_type, /* 52 */ - scheme_rational_type, /* 53 */ - scheme_float_type, /* 54 */ - scheme_double_type, /* 55 */ - scheme_complex_type, /* 56 */ + scheme_integer_type, /* 48 */ + scheme_bignum_type, /* 49 */ + scheme_rational_type, /* 50 */ + scheme_float_type, /* 51 */ + scheme_double_type, /* 52 */ + scheme_complex_type, /* 53 */ /* other eqv?-able values (must be with numbers) */ - scheme_char_type, /* 57 */ + scheme_char_type, /* 54 */ /* other values */ - scheme_long_double_type, /* 58 */ - scheme_char_string_type, /* 59 */ - scheme_byte_string_type, /* 60 */ - scheme_unix_path_type, /* 61 */ - scheme_windows_path_type, /* 62 */ - scheme_symbol_type, /* 63 */ - scheme_keyword_type, /* 64 */ - scheme_null_type, /* 65 */ - scheme_pair_type, /* 66 */ - scheme_mutable_pair_type, /* 67 */ - scheme_vector_type, /* 68 */ - scheme_inspector_type, /* 69 */ - scheme_input_port_type, /* 70 */ - scheme_output_port_type, /* 71 */ - scheme_eof_type, /* 72 */ - scheme_true_type, /* 73 */ - scheme_false_type, /* 74 */ - scheme_void_type, /* 75 */ - scheme_primitive_syntax_type, /* 76 */ - scheme_macro_type, /* 77 */ - scheme_box_type, /* 78 */ - scheme_thread_type, /* 79 */ - scheme_scope_type, /* 80 */ - scheme_stx_offset_type, /* 81 */ - scheme_cont_mark_set_type, /* 82 */ - scheme_sema_type, /* 83 */ - scheme_hash_table_type, /* 84 */ - scheme_hash_tree_type, /* 85 */ - scheme_eq_hash_tree_type, /* 86 */ - scheme_eqv_hash_tree_type, /* 87 */ - scheme_hash_tree_subtree_type, /* 88 */ - scheme_hash_tree_collision_type, /* 89 */ - scheme_hash_tree_indirection_type, /* 90 */ - scheme_cpointer_type, /* 91 */ - scheme_prefix_type, /* 92 */ - scheme_weak_box_type, /* 93 */ - scheme_ephemeron_type, /* 94 */ - scheme_struct_type_type, /* 95 */ - scheme_module_index_type, /* 96 */ - scheme_set_macro_type, /* 97 */ - scheme_listener_type, /* 98 */ - scheme_namespace_type, /* 99 */ - scheme_config_type, /* 100 */ - scheme_stx_type, /* 101 */ - scheme_will_executor_type, /* 102 */ - scheme_custodian_type, /* 103 */ - scheme_random_state_type, /* 104 */ - scheme_regexp_type, /* 105 */ - scheme_bucket_type, /* 106 */ - scheme_bucket_table_type, /* 107 */ - scheme_subprocess_type, /* 108 */ - scheme_compilation_top_type, /* 109 */ - scheme_wrap_chunk_type, /* 110 */ - scheme_eval_waiting_type, /* 111 */ - scheme_tail_call_waiting_type, /* 112 */ - scheme_undefined_type, /* 113 */ - scheme_struct_property_type, /* 114 */ - scheme_chaperone_property_type, /* 115 */ - scheme_multiple_values_type, /* 116 */ - scheme_placeholder_type, /* 117 */ - scheme_table_placeholder_type, /* 118 */ - scheme_scope_table_type, /* 119 */ - scheme_propagate_table_type, /* 120 */ - scheme_svector_type, /* 121 */ - scheme_resolve_prefix_type, /* 122 */ - scheme_security_guard_type, /* 123 */ - scheme_indent_type, /* 124 */ - scheme_udp_type, /* 125 */ - scheme_udp_evt_type, /* 126 */ - scheme_tcp_accept_evt_type, /* 127 */ - scheme_id_macro_type, /* 128 */ - scheme_evt_set_type, /* 129 */ - scheme_wrap_evt_type, /* 130 */ - scheme_handle_evt_type, /* 131 */ - scheme_replace_evt_type, /* 132 */ - scheme_active_replace_evt_type, /* 133 */ - scheme_nack_guard_evt_type, /* 134 */ - scheme_semaphore_repost_type, /* 135 */ - scheme_channel_type, /* 136 */ - scheme_channel_put_type, /* 137 */ - scheme_thread_resume_type, /* 138 */ - scheme_thread_suspend_type, /* 139 */ - scheme_thread_dead_type, /* 140 */ - scheme_poll_evt_type, /* 141 */ - scheme_nack_evt_type, /* 142 */ - scheme_module_registry_type, /* 143 */ - scheme_thread_set_type, /* 144 */ - scheme_string_converter_type, /* 145 */ - scheme_alarm_type, /* 146 */ - scheme_thread_recv_evt_type, /* 147 */ - scheme_thread_cell_type, /* 148 */ - scheme_channel_syncer_type, /* 149 */ - scheme_special_comment_type, /* 150 */ - scheme_write_evt_type, /* 151 */ - scheme_always_evt_type, /* 152 */ - scheme_never_evt_type, /* 153 */ - scheme_progress_evt_type, /* 154 */ - scheme_place_dead_type, /* 155 */ - scheme_already_comp_type, /* 156 */ - scheme_readtable_type, /* 157 */ - scheme_intdef_context_type, /* 158 */ - scheme_lexical_rib_type, /* 159 */ - scheme_thread_cell_values_type, /* 160 */ - scheme_global_ref_type, /* 161 */ - scheme_cont_mark_chain_type, /* 162 */ - scheme_raw_pair_type, /* 163 */ - scheme_prompt_type, /* 164 */ - scheme_prompt_tag_type, /* 165 */ - scheme_continuation_mark_key_type, /* 166 */ - scheme_expanded_syntax_type, /* 167 */ - scheme_delay_syntax_type, /* 168 */ - scheme_cust_box_type, /* 169 */ - scheme_resolved_module_path_type, /* 170 */ - scheme_module_phase_exports_type, /* 171 */ - scheme_logger_type, /* 172 */ - scheme_log_reader_type, /* 173 */ - scheme_marshal_share_type, /* 174 */ - scheme_rib_delimiter_type, /* 175 */ - scheme_noninline_proc_type, /* 176 */ - scheme_prune_context_type, /* 177 */ - scheme_future_type, /* 178 */ - scheme_flvector_type, /* 179 */ - scheme_extflvector_type, /* 180 */ - scheme_fxvector_type, /* 181 */ - scheme_place_type, /* 182 */ - scheme_place_object_type, /* 183 */ - scheme_place_async_channel_type, /* 184 */ - scheme_place_bi_channel_type, /* 185 */ - scheme_once_used_type, /* 186 */ - scheme_serialized_symbol_type, /* 187 */ - scheme_serialized_keyword_type, /* 188 */ - scheme_serialized_structure_type, /* 189 */ - scheme_fsemaphore_type, /* 190 */ - scheme_serialized_tcp_fd_type, /* 191 */ - scheme_serialized_file_fd_type, /* 192 */ - scheme_port_closed_evt_type, /* 193 */ - scheme_proc_shape_type, /* 194 */ - scheme_struct_proc_shape_type, /* 195 */ - scheme_struct_prop_proc_shape_type, /* 196 */ - scheme_phantom_bytes_type, /* 197 */ - scheme_environment_variables_type, /* 198 */ - scheme_filesystem_change_evt_type, /* 199 */ - scheme_ctype_type, /* 200 */ - scheme_plumber_type, /* 201 */ - scheme_plumber_handle_type, /* 202 */ - scheme_deferred_expr_type, /* 203 */ - scheme_will_be_lambda_type, /* 204 */ - scheme_syntax_property_preserve_type, /* 205 */ - scheme_unquoted_printing_string_type, /* 206 */ - + scheme_long_double_type, /* 55 */ + scheme_char_string_type, /* 56 */ + scheme_byte_string_type, /* 57 */ + scheme_unix_path_type, /* 58 */ + scheme_windows_path_type, /* 59 */ + scheme_symbol_type, /* 60 */ + scheme_keyword_type, /* 61 */ + scheme_null_type, /* 62 */ + scheme_pair_type, /* 63 */ + scheme_mutable_pair_type, /* 64 */ + scheme_vector_type, /* 65 */ + scheme_inspector_type, /* 66 */ + scheme_input_port_type, /* 67 */ + scheme_output_port_type, /* 68 */ + scheme_eof_type, /* 69 */ + scheme_true_type, /* 70 */ + scheme_false_type, /* 71 */ + scheme_void_type, /* 72 */ + scheme_primitive_syntax_type, /* 73 */ + scheme_macro_type, /* 74 */ + scheme_box_type, /* 75 */ + scheme_thread_type, /* 76 */ + scheme_cont_mark_set_type, /* 77 */ + scheme_sema_type, /* 78 */ + + /* hash table types (must be together for hash? + * implementation */ + scheme_hash_table_type, /* 79 */ + scheme_hash_tree_type, /* 80 */ + scheme_eq_hash_tree_type, /* 81 */ + scheme_eqv_hash_tree_type, /* 82 */ + scheme_hash_tree_subtree_type, /* 83 */ + scheme_hash_tree_collision_type, /* 84 */ + scheme_hash_tree_indirection_type, /* 85 */ + scheme_bucket_type, /* 86 */ + scheme_bucket_table_type, /* 87 */ + + scheme_cpointer_type, /* 88 */ + scheme_prefix_type, /* 89 */ + scheme_weak_box_type, /* 90 */ + scheme_ephemeron_type, /* 91 */ + scheme_struct_type_type, /* 92 */ + scheme_set_macro_type, /* 93 */ + scheme_listener_type, /* 94 */ + scheme_env_type, /* 95 */ + scheme_startup_env_type, /* 96 */ + scheme_config_type, /* 97 */ + scheme_stx_type, /* 98 */ + scheme_will_executor_type, /* 99 */ + scheme_custodian_type, /* 100 */ + scheme_random_state_type, /* 101 */ + scheme_regexp_type, /* 102 */ + scheme_subprocess_type, /* 103 */ + scheme_eval_waiting_type, /* 104 */ + scheme_tail_call_waiting_type, /* 105 */ + scheme_undefined_type, /* 106 */ + scheme_struct_property_type, /* 107 */ + scheme_chaperone_property_type, /* 108 */ + scheme_multiple_values_type, /* 109 */ + scheme_placeholder_type, /* 110 */ + scheme_table_placeholder_type, /* 111 */ + scheme_svector_type, /* 112 */ + scheme_resolve_prefix_type, /* 113 */ + scheme_security_guard_type, /* 114 */ + scheme_indent_type, /* 115 */ + scheme_udp_type, /* 116 */ + scheme_udp_evt_type, /* 117 */ + scheme_tcp_accept_evt_type, /* 118 */ + scheme_id_macro_type, /* 119 */ + scheme_evt_set_type, /* 120 */ + scheme_wrap_evt_type, /* 121 */ + scheme_handle_evt_type, /* 122 */ + scheme_replace_evt_type, /* 123 */ + scheme_active_replace_evt_type, /* 124 */ + scheme_nack_guard_evt_type, /* 125 */ + scheme_semaphore_repost_type, /* 126 */ + scheme_channel_type, /* 127 */ + scheme_channel_put_type, /* 128 */ + scheme_thread_resume_type, /* 129 */ + scheme_thread_suspend_type, /* 130 */ + scheme_thread_dead_type, /* 131 */ + scheme_poll_evt_type, /* 132 */ + scheme_nack_evt_type, /* 133 */ + scheme_thread_set_type, /* 134 */ + scheme_string_converter_type, /* 135 */ + scheme_alarm_type, /* 136 */ + scheme_thread_recv_evt_type, /* 137 */ + scheme_thread_cell_type, /* 138 */ + scheme_channel_syncer_type, /* 139 */ + scheme_write_evt_type, /* 140 */ + scheme_always_evt_type, /* 141 */ + scheme_never_evt_type, /* 142 */ + scheme_progress_evt_type, /* 143 */ + scheme_place_dead_type, /* 144 */ + scheme_already_comp_type, /* 145 */ + scheme_readtable_type, /* 146 */ + scheme_thread_cell_values_type, /* 147 */ + scheme_global_ref_type, /* 148 */ + scheme_cont_mark_chain_type, /* 149 */ + scheme_raw_pair_type, /* 150 */ + scheme_prompt_type, /* 151 */ + scheme_prompt_tag_type, /* 152 */ + scheme_continuation_mark_key_type, /* 153 */ + scheme_delay_syntax_type, /* 154 */ + scheme_cust_box_type, /* 155 */ + scheme_logger_type, /* 156 */ + scheme_log_reader_type, /* 157 */ + scheme_noninline_proc_type, /* 158 */ + scheme_future_type, /* 159 */ + scheme_flvector_type, /* 160 */ + scheme_extflvector_type, /* 161 */ + scheme_fxvector_type, /* 162 */ + scheme_place_type, /* 163 */ + scheme_place_object_type, /* 164 */ + scheme_place_async_channel_type, /* 165 */ + scheme_place_bi_channel_type, /* 166 */ + scheme_once_used_type, /* 167 */ + scheme_serialized_symbol_type, /* 168 */ + scheme_serialized_keyword_type, /* 169 */ + scheme_serialized_structure_type, /* 170 */ + scheme_fsemaphore_type, /* 171 */ + scheme_serialized_tcp_fd_type, /* 172 */ + scheme_serialized_file_fd_type, /* 173 */ + scheme_port_closed_evt_type, /* 174 */ + scheme_proc_shape_type, /* 175 */ + scheme_struct_prop_proc_shape_type, /* 176 */ + scheme_struct_proc_shape_type, /* 177 */ + scheme_phantom_bytes_type, /* 178 */ + scheme_environment_variables_type, /* 179 */ + scheme_filesystem_change_evt_type, /* 180 */ + scheme_ctype_type, /* 181 */ + scheme_plumber_type, /* 182 */ + scheme_plumber_handle_type, /* 183 */ + scheme_deferred_expr_type, /* 184 */ + scheme_unquoted_printing_string_type, /* 185 */ + scheme_will_be_lambda_type, /* 186 */ + #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 207 */ + _scheme_last_normal_type_, /* 187 */ /* The remaining tags exist for GC tracing (in non-conservative mode), but they are not needed for run-time tag tests */ - scheme_rt_weak_array, /* 208 */ + scheme_rt_weak_array, /* 188 */ - scheme_rt_comp_env, /* 209 */ - scheme_rt_constant_binding, /* 210 */ - scheme_rt_resolve_info, /* 211 */ - scheme_rt_unresolve_info, /* 212 */ - scheme_rt_optimize_info, /* 213 */ - scheme_rt_cont_mark, /* 214 */ - scheme_rt_saved_stack, /* 215 */ - scheme_rt_reply_item, /* 216 */ - scheme_rt_ir_lambda_info, /* 217 */ - scheme_rt_overflow, /* 218 */ - scheme_rt_overflow_jmp, /* 219 */ - scheme_rt_meta_cont, /* 220 */ - scheme_rt_dyn_wind_cell, /* 221 */ - scheme_rt_dyn_wind_info, /* 222 */ - scheme_rt_dyn_wind, /* 223 */ - scheme_rt_dup_check, /* 224 */ - scheme_rt_thread_memory, /* 225 */ - scheme_rt_input_file, /* 226 */ - scheme_rt_input_fd, /* 227 */ - scheme_rt_oskit_console_input, /* 228 */ - scheme_rt_tested_input_file, /* 229 */ - scheme_rt_tested_output_file, /* 230 */ - scheme_rt_indexed_string, /* 231 */ - scheme_rt_output_file, /* 232 */ - scheme_rt_load_handler_data, /* 233 */ - scheme_rt_pipe, /* 234 */ - scheme_rt_beos_process, /* 235 */ - scheme_rt_system_child, /* 236 */ - scheme_rt_tcp, /* 237 */ - scheme_rt_write_data, /* 238 */ - scheme_rt_tcp_select_info, /* 239 */ - scheme_rt_param_data, /* 240 */ - scheme_rt_will, /* 241 */ - scheme_rt_linker_name, /* 242 */ - scheme_rt_param_map, /* 243 */ - scheme_rt_finalization, /* 244 */ - scheme_rt_finalizations, /* 245 */ - scheme_rt_cpp_object, /* 246 */ - scheme_rt_cpp_array_object, /* 247 */ - scheme_rt_stack_object, /* 248 */ - scheme_rt_preallocated_object, /* 249 */ - scheme_thread_hop_type, /* 250 */ - scheme_rt_srcloc, /* 251 */ - scheme_rt_evt, /* 252 */ - scheme_rt_syncing, /* 253 */ - scheme_rt_comp_prefix, /* 254 */ - scheme_rt_user_input, /* 255 */ - scheme_rt_user_output, /* 256 */ - scheme_rt_compact_port, /* 257 */ - scheme_rt_read_special_dw, /* 258 */ - scheme_rt_regwork, /* 259 */ - scheme_rt_rx_lazy_string, /* 260 */ - scheme_rt_buf_holder, /* 261 */ - scheme_rt_parameterization, /* 262 */ - scheme_rt_print_params, /* 263 */ - scheme_rt_read_params, /* 264 */ - scheme_rt_native_code, /* 265 */ - scheme_rt_native_code_plus_case, /* 266 */ - scheme_rt_jitter_data, /* 267 */ - scheme_rt_module_exports, /* 268 */ - scheme_rt_delay_load_info, /* 269 */ - scheme_rt_marshal_info, /* 270 */ - scheme_rt_unmarshal_info, /* 271 */ - scheme_rt_runstack, /* 272 */ - scheme_rt_sfs_info, /* 273 */ - scheme_rt_validate_clearing, /* 274 */ - scheme_rt_lightweight_cont, /* 275 */ - scheme_rt_export_info, /* 276 */ - scheme_rt_cont_jmp, /* 277 */ - scheme_rt_letrec_check_frame, /* 278 */ + scheme_rt_comp_env, /* 189 */ + scheme_rt_constant_binding, /* 190 */ + scheme_rt_resolve_info, /* 191 */ + scheme_rt_unresolve_info, /* 192 */ + scheme_rt_optimize_info, /* 193 */ + scheme_rt_cont_mark, /* 194 */ + scheme_rt_saved_stack, /* 195 */ + scheme_rt_reply_item, /* 196 */ + scheme_rt_ir_lambda_info, /* 197 */ + scheme_rt_overflow, /* 198 */ + scheme_rt_overflow_jmp, /* 199 */ + scheme_rt_meta_cont, /* 200 */ + scheme_rt_dyn_wind_cell, /* 201 */ + scheme_rt_dyn_wind_info, /* 202 */ + scheme_rt_dyn_wind, /* 203 */ + scheme_rt_dup_check, /* 204 */ + scheme_rt_thread_memory, /* 205 */ + scheme_rt_input_file, /* 206 */ + scheme_rt_input_fd, /* 207 */ + scheme_rt_oskit_console_input, /* 208 */ + scheme_rt_tested_input_file, /* 209 */ + scheme_rt_tested_output_file, /* 210 */ + scheme_rt_indexed_string, /* 211 */ + scheme_rt_output_file, /* 212 */ + scheme_rt_pipe, /* 213 */ + scheme_rt_system_child, /* 214 */ + scheme_rt_tcp, /* 215 */ + scheme_rt_write_data, /* 216 */ + scheme_rt_tcp_select_info, /* 217 */ + scheme_rt_param_data, /* 218 */ + scheme_rt_will, /* 219 */ + scheme_rt_finalization, /* 220 */ + scheme_rt_finalizations, /* 221 */ + scheme_rt_cpp_object, /* 222 */ + scheme_rt_cpp_array_object, /* 223 */ + scheme_rt_stack_object, /* 224 */ + scheme_thread_hop_type, /* 225 */ + scheme_rt_srcloc, /* 226 */ + scheme_rt_evt, /* 227 */ + scheme_rt_syncing, /* 228 */ + scheme_rt_comp_prefix, /* 229 */ + scheme_rt_user_input, /* 230 */ + scheme_rt_user_output, /* 231 */ + scheme_rt_compact_port, /* 232 */ + scheme_rt_read_special_dw, /* 233 */ + scheme_rt_regwork, /* 234 */ + scheme_rt_rx_lazy_string, /* 235 */ + scheme_rt_buf_holder, /* 236 */ + scheme_rt_parameterization, /* 237 */ + scheme_rt_print_params, /* 238 */ + scheme_rt_read_params, /* 239 */ + scheme_rt_native_code, /* 240 */ + scheme_rt_native_code_plus_case, /* 241 */ + scheme_rt_jitter_data, /* 242 */ + scheme_rt_module_exports, /* 243 */ + scheme_rt_delay_load_info, /* 244 */ + scheme_rt_marshal_info, /* 245 */ + scheme_rt_unmarshal_info, /* 246 */ + scheme_rt_runstack, /* 247 */ + scheme_rt_sfs_info, /* 248 */ + scheme_rt_validate_clearing, /* 249 */ + scheme_rt_lightweight_cont, /* 250 */ + scheme_rt_export_info, /* 251 */ + scheme_rt_cont_jmp, /* 252 */ + scheme_rt_letrec_check_frame, /* 253 */ #endif _scheme_last_type_ diff -Nru racket-6.12+ppa1/src/racket/src/symbol.c racket-7.0+ppa1/src/racket/src/symbol.c --- racket-6.12+ppa1/src/racket/src/symbol.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/symbol.c 2018-07-27 22:12:02.000000000 +0000 @@ -72,7 +72,6 @@ static Scheme_Object *symbol_lt (int argc, Scheme_Object *argv[]); static Scheme_Object *symbol_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *symbol_unreadable_p_prim (int argc, Scheme_Object *argv[]); -static Scheme_Object *symbol_interned_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_symbol_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_unreadable_symbol_prim (int argc, Scheme_Object *argv[]); @@ -324,45 +323,63 @@ #endif void -scheme_init_symbol_type (Scheme_Env *env) +scheme_init_symbol_type (Scheme_Startup_Env *env) { } void -scheme_init_symbol (Scheme_Env *env) +scheme_init_symbol (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_symbol_p_proc); p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_symbol_p_proc = p; - scheme_add_global_constant("symbol?", p, env); + scheme_addto_prim_instance("symbol?", p, env); p = scheme_make_folding_prim(symbol_unreadable_p_prim, "symbol-unreadable?", 1, 1, 1); - scheme_add_global_constant("symbol-unreadable?", p, env); + scheme_addto_prim_instance("symbol-unreadable?", p, env); + + p = scheme_make_folding_prim(scheme_checked_symbol_interned_p, "symbol-interned?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("symbol-interned?", p, env); + + ADD_FOLDING_PRIM("symbolsymbol", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->symbol", p, env); - p = scheme_make_folding_prim(symbol_interned_p_prim, "symbol-interned?", 1, 1, 1); - scheme_add_global_constant("symbol-interned?", p, env); + ADD_IMMED_PRIM("string->uninterned-symbol", string_to_uninterned_symbol_prim, 1, 1, env); + ADD_IMMED_PRIM("string->unreadable-symbol", string_to_unreadable_symbol_prim, 1, 1, env); - GLOBAL_FOLDING_PRIM("symbolsymbol", string_to_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("string->uninterned-symbol", string_to_uninterned_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("string->unreadable-symbol", string_to_unreadable_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("symbol->string", symbol_to_string_prim, 1, 1, env); + p = scheme_make_folding_prim(symbol_to_string_prim, "symbol->string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("symbol->string", p, env); REGISTER_SO(scheme_keyword_p_proc); p = scheme_make_folding_prim(keyword_p_prim, "keyword?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_keyword_p_proc = p; - scheme_add_global_constant("keyword?", p, env); + scheme_addto_prim_instance("keyword?", p, env); - GLOBAL_FOLDING_PRIM("keywordkeyword", string_to_keyword_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("keyword->string", keyword_to_string_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("gensym", gensym, 0, 1, env); + ADD_FOLDING_PRIM("keywordkeyword", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->keyword", p, env); + + p = scheme_make_folding_prim(keyword_to_string_prim, "keyword->string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("keyword->string", p, env); + + ADD_IMMED_PRIM("gensym", gensym, 0, 1, env); } uintptr_t scheme_get_max_symbol_length() { @@ -680,7 +697,7 @@ if (cs && digit_start && !(flags & SCHEME_SNF_FOR_TS) - && (SCHEME_TRUEP(scheme_read_number(cs, clen, 0, 0, 1, 10, 0, NULL, &dz, 1, NULL, 0, 0, 0, 0, NULL)) + && (SCHEME_TRUEP(scheme_read_number(cs, clen, 0, 0, 1, 10, 0, NULL, &dz, 1)) || dz)) { /* Need quoting: */ if (pipe_quote) @@ -762,8 +779,8 @@ return SCHEME_SYMBOLP(argv[0]) ? scheme_true : scheme_false; } -static Scheme_Object * -symbol_interned_p_prim (int argc, Scheme_Object *argv[]) +Scheme_Object * +scheme_checked_symbol_interned_p (int argc, Scheme_Object *argv[]) { if (SCHEME_SYMBOLP(argv[0])) return (SCHEME_SYM_WEIRDP(argv[0]) ? scheme_false : scheme_true); @@ -951,7 +968,6 @@ { char buffer[100], *str; Scheme_Object *r; - Scheme_Thread *p; if (argc) r = argv[0]; @@ -961,18 +977,6 @@ if (r && !SCHEME_SYMBOLP(r) && !SCHEME_CHAR_STRINGP(r)) scheme_wrong_contract("gensym", "(or/c symbol? string?)", 0, argc, argv); - if (!r) { - /* Generate a name using an enclosing module name during compilation, if available */ - p = scheme_current_thread; - if (p->current_local_env && p->current_local_env->genv->module) { - r = SCHEME_PTR_VAL(p->current_local_env->genv->module->modname); - if (SCHEME_PAIRP(r)) - r = SCHEME_CAR(r); - if (!SCHEME_SYMBOLP(r)) - r = NULL; - } - } - if (r) { char buf[64]; if (SCHEME_CHAR_STRINGP(r)) { diff -Nru racket-6.12+ppa1/src/racket/src/syntax.c racket-7.0+ppa1/src/racket/src/syntax.c --- racket-6.12+ppa1/src/racket/src/syntax.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/syntax.c 2018-07-27 22:12:02.000000000 +0000 @@ -21,36 +21,12 @@ #include "schpriv.h" #include "schmach.h" -#include "schexpobs.h" ROSYM static Scheme_Object *source_symbol; /* uninterned! */ -ROSYM static Scheme_Object *share_symbol; /* uninterned! */ -ROSYM static Scheme_Object *origin_symbol; -ROSYM static Scheme_Object *lexical_symbol; -ROSYM static Scheme_Object *protected_symbol; -ROSYM static Scheme_Object *nominal_id_symbol; - -ROSYM static Scheme_Object *module_symbol; -ROSYM static Scheme_Object *top_symbol; -ROSYM static Scheme_Object *macro_symbol; -ROSYM static Scheme_Object *local_symbol; -ROSYM static Scheme_Object *intdef_symbol; -ROSYM static Scheme_Object *use_site_symbol; - -ROSYM static Scheme_Object *name_symbol; -ROSYM static Scheme_Object *context_symbol; -ROSYM static Scheme_Object *bindings_symbol; -ROSYM static Scheme_Object *matchp_symbol; -ROSYM static Scheme_Object *cycle_symbol; -ROSYM static Scheme_Object *free_symbol; -ROSYM static Scheme_Object *fallbacks_symbol; READ_ONLY Scheme_Object *scheme_syntax_p_proc; READ_ONLY static Scheme_Hash_Tree *empty_hash_tree; -READ_ONLY static Scheme_Scope_Table *empty_scope_table; -READ_ONLY static Scheme_Scope_Table *empty_propagate_table; -READ_ONLY static Scheme_Scope_Set *empty_scope_set; ROSYM Scheme_Object *scheme_paren_shape_symbol; @@ -62,192 +38,31 @@ READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; -typedef struct Scheme_Scope { - Scheme_Inclhash_Object iso; /* 0x1 => Scheme_Scope_With_Owner */ - mzlonglong id; /* low SCHEME_STX_SCOPE_KIND_SHIFT bits indicate kind */ - Scheme_Object *bindings; /* NULL, vector for one binding, hash table for multiple bindings, - or (rcons hash-table (rcons (cons scope-set pes-info) ... NULL)); - each hash table maps symbols to (cons scope-set binding) - or (mlist (cons scope-set binding) ...) */ -} Scheme_Scope; - -/* For a scope that is for a particular phase within a set of phase-specific scopes: */ -typedef struct Scheme_Scope_With_Owner { - Scheme_Scope m; - Scheme_Object *owner_multi_scope; - Scheme_Object *phase; -} Scheme_Scope_With_Owner; - -#define SCHEME_SCOPE_FLAGS(m) MZ_OPT_HASH_KEY(&(m)->iso) -#define SCHEME_SCOPE_HAS_OWNER(m) (SCHEME_SCOPE_FLAGS(m) & 0x1) - -#define SCHEME_SCOPE_KIND(m) (((Scheme_Scope *)(m))->id & SCHEME_STX_SCOPE_KIND_MASK) - -READ_ONLY static Scheme_Object *root_scope; - -/* For lazy propagation of scope changes: */ -typedef struct Scheme_Propagate_Table { - Scheme_Scope_Table st; /* Maps scopes to actions, instead of just holding a set of scopes; - action compositions can be collased to an action: - SCHEME_STX_ADD + SCHEME_STX_FLIP = SCHEME_STX_REMOVE, etc. */ - Scheme_Scope_Table *prev; /* points to old scope table as a shortcut; - the old table plus these actions equals - the owning object's current table */ - Scheme_Object *phase_shift; /* or (box ); latter converts only to #f */ -} Scheme_Propagate_Table; - -THREAD_LOCAL_DECL(static mzlonglong scope_counter); -THREAD_LOCAL_DECL(static Scheme_Object *last_phase_shift); -THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *taint_intern_table); -THREAD_LOCAL_DECL(static struct Binding_Cache_Entry *binding_cache_table); -THREAD_LOCAL_DECL(static intptr_t binding_cache_pos); -THREAD_LOCAL_DECL(static intptr_t binding_cache_len); -THREAD_LOCAL_DECL(static Scheme_Scope_Set *recent_scope_sets[2][NUM_RECENT_SCOPE_SETS]); -THREAD_LOCAL_DECL(static int recent_scope_sets_pos[2]); - static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv); static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); static Scheme_Object *syntax_line(int argc, Scheme_Object **argv); static Scheme_Object *syntax_col(int argc, Scheme_Object **argv); static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv); static Scheme_Object *syntax_span(int argc, Scheme_Object **argv); static Scheme_Object *syntax_src(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_property_preserved_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv); - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_arm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_disarm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_rearm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv); -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, int *mutate); +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o); +static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, + Scheme_Stx *stx_src, + Scheme_Hash_Table *ht); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -XFORM_NONGCING static int is_armed(Scheme_Object *v); -static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int *mutate); - -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, - Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at); - -static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, Scheme_Object *prefix, Scheme_Object *excepts); -XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info); -XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info); -static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info); -static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes); -static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes); - -XFORM_NONGCING static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b); -static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p); -static Scheme_Object *add_to_scope_list(Scheme_Object *l, Scheme_Object *p); - -static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt); -static Scheme_Object *scope_unmarshal_content(Scheme_Object *c, struct Scheme_Unmarshal_Tables *utx); - -static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes); -static void sort_vector_symbols(Scheme_Object *vec); - -static void sort_scope_array(Scheme_Object **a, intptr_t count); -static void sort_symbol_array(Scheme_Object **a, intptr_t count); -static void sort_number_array(Scheme_Object **a, intptr_t count); - -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_scopes, - Scheme_Marshal_Tables *mt); -static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, - Scheme_Hash_Table *ht, - int tainted); - -XFORM_NONGCING static void extract_module_binding_parts(Scheme_Object *l, - Scheme_Object *phase, - Scheme_Object **_insp_desc, - Scheme_Object **_modidx, - Scheme_Object **_exportname, - Scheme_Object **_nominal_modidx, - Scheme_Object **_mod_phase, - Scheme_Object **_nominal_name, - Scheme_Object **_src_phase, - Scheme_Object **_nominal_src_phase); - -static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings); - -static void init_binding_cache(void); -XFORM_NONGCING static void clear_binding_cache(void); -XFORM_NONGCING static void clear_binding_cache_for(Scheme_Object *sym); -XFORM_NONGCING static void clear_binding_cache_stx(Scheme_Stx *stx); - -static Scheme_Object *make_preserved_property_value(Scheme_Object *v); - #define CONS scheme_make_pair -#define ICONS scheme_make_pair - -/* "substx" means that we need to propagate marks to nested syntax objects */ -#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) -#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) - -#define SCHEME_INSPECTORP(obj) SAME_TYPE(scheme_inspector_type, SCHEME_TYPE(obj)) -#define SCHEME_INSPECTOR_DESCP(obj) (SCHEME_INSPECTORP(obj) || SCHEME_SYMBOLP(obj)) -#define SCHEME_MODIDXP(l) SAME_TYPE(SCHEME_TYPE(l), scheme_module_index_type) -#define SCHEME_PHASEP(a) (SCHEME_INTP(a) || SCHEME_BIGNUMP(a) || SCHEME_FALSEP(a)) - -#define SCHEME_PHASE_SHIFTP(a) (SCHEME_PHASEP(a) || (SCHEME_BOXP(a) && SCHEME_PHASEP(SCHEME_BOX_VAL(a)))) -/* #f as a phase shift is an alias for (box 0) */ - -#define SCHEME_MULTI_SCOPEP(o) SCHEME_HASHTP(o) -#define SCHEME_SCOPEP(x) (SAME_TYPE(SCHEME_TYPE(x), scheme_scope_type)) - -#define SCHEME_TL_MULTI_SCOPEP(o) (MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)o)->iso)) & 0x2) - -/* A hash tabel for a multi scope has meta information mapped from void: */ -#define MULTI_SCOPE_METAP(v) SCHEME_VOIDP(v) -#define MULTI_SCOPE_META_HASHEDP(v) SCHEME_MPAIRP(v) - -/* Represent fallback as vectors, either of size 2 (for normal scope - sets) or size 4 (for sets of propagation instructions, because adding - a fallback layer is an action): */ -#define SCHEME_FALLBACKP(o) SCHEME_VECTORP(o) -#define SCHEME_FALLBACK_QUADP(o) (SCHEME_VEC_SIZE(o) == 4) -#define SCHEME_FALLBACK_FIRST(o) (SCHEME_VEC_ELS(o)[0]) -#define SCHEME_FALLBACK_REST(o) (SCHEME_VEC_ELS(o)[1]) -#define SCHEME_FALLBACK_SCOPE(o) (SCHEME_VEC_ELS(o)[2]) -#define SCHEME_FALLBACK_PHASE(o) (SCHEME_VEC_ELS(o)[3]) - -/* Bindings of the form "everything from module" */ -#define PES_UNMARSHAL_DESCP(v) (SCHEME_VEC_SIZE(v) == 4) -#define PES_BINDINGP(v) (SCHEME_VEC_SIZE(v) == 5) XFORM_NONGCING static int prefab_p(Scheme_Object *o) { @@ -262,44 +77,17 @@ #define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso) #define MUTATE_STX_OBJ 1 -#define MUTATE_STX_SCOPE_TABLE 2 -#define MUTATE_STX_PROP_TABLE 4 - -#if 0 -int stx_alloc_obj, stx_skip_alloc_obj; -int stx_alloc_scope_table, stx_skip_alloc_scope_table; -int stx_alloc_prop_table, stx_skip_alloc_prop_table; -# define COUNT_MUTATE_ALLOCS(x) x -#else -# define COUNT_MUTATE_ALLOCS(x) /* empty */ -#endif - -/* A `taints' field is one of - - NULL => clean - - #t => tainted, and taint propagated to children, if any) - - (void) => tainted, and taint needs to be propagated to children - - => clean, but inspector needs to be proagated to children - - (list ...+) [interned] => armed; first inspector is to propagate */ #define STX_ASSERT(x) MZ_ASSERT(x) -static Scheme_Object *make_vector3(Scheme_Object *a, Scheme_Object *b, Scheme_Object *c) -{ - Scheme_Object *vec; - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = a; - SCHEME_VEC_ELS(vec)[1] = b; - SCHEME_VEC_ELS(vec)[2] = c; - - return vec; -} +#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) +#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) /*========================================================================*/ /* initialization */ /*========================================================================*/ -void scheme_init_stx(Scheme_Env *env) +void scheme_init_stx(Scheme_Startup_Env *env) { Scheme_Object *o; @@ -308,115 +96,32 @@ #endif REGISTER_SO(empty_hash_tree); - REGISTER_SO(empty_scope_table); - REGISTER_SO(empty_propagate_table); - REGISTER_SO(empty_scope_set); - empty_hash_tree = scheme_make_hash_tree(SCHEME_hashtr_eq); - empty_scope_set = (Scheme_Scope_Set *)scheme_make_hash_tree(SCHEME_hashtr_eq); - empty_scope_table = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - empty_scope_table->so.type = scheme_scope_table_type; - empty_scope_table->simple_scopes = empty_scope_set; - empty_scope_table->multi_scopes = scheme_null; - empty_propagate_table = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); - memcpy(empty_propagate_table, empty_scope_table, sizeof(Scheme_Scope_Table)); - empty_propagate_table->simple_scopes = (Scheme_Scope_Set *)empty_hash_tree; - empty_propagate_table->so.type = scheme_propagate_table_type; - ((Scheme_Propagate_Table *)empty_propagate_table)->phase_shift = scheme_make_integer(0); - ((Scheme_Propagate_Table *)empty_propagate_table)->prev = NULL; + empty_hash_tree = scheme_make_hash_tree(0); REGISTER_SO(scheme_syntax_p_proc); o = scheme_make_folding_prim(syntax_p, "syntax?", 1, 1, 1); scheme_syntax_p_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("syntax?", o, env); + scheme_addto_prim_instance("syntax?", o, env); - GLOBAL_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("datum->syntax", datum_to_syntax, 2, 5, env); + ADD_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); + ADD_IMMED_PRIM("datum->syntax", datum_to_syntax, 2, 5, env); - GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax-e", scheme_checked_syntax_e, 1, 1, 1, env); + o = scheme_make_folding_prim(scheme_checked_syntax_e, "syntax-e", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("syntax-e", o, env); - GLOBAL_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax->list" , syntax_to_list, 1, 1, 1, env); - - GLOBAL_IMMED_PRIM("syntax-original?" , syntax_original_p , 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-property" , syntax_property , 2, 4, env); - GLOBAL_IMMED_PRIM("syntax-property-preserved?" , syntax_property_preserved_p, 2, 2, env); - GLOBAL_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); - - GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env); - - GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-shift-phase-level" , syntax_shift_phase , 2, 2, env); - - GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-identifier=?" , free_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , free_trans_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-template-identifier=?" , free_templ_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-label-identifier=?" , free_label_eq , 2, 2, env); - - GLOBAL_IMMED_PRIM("identifier-binding" , free_binding , 1, 3, env); - GLOBAL_IMMED_PRIM("identifier-transformer-binding" , free_trans_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-template-binding" , free_templ_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-label-binding" , free_label_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); - - GLOBAL_IMMED_PRIM("identifier-binding-symbol" , free_binding_symbol , 1, 2, env); - - GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); - - GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-arm" , syntax_arm , 1, 3, env); - GLOBAL_IMMED_PRIM("syntax-disarm" , syntax_disarm , 2, 2, env); - GLOBAL_IMMED_PRIM("syntax-rearm" , syntax_rearm , 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-taint" , syntax_taint , 1, 1, env); + ADD_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-debug-info" , syntax_debug_info , 1, 3, env); + ADD_IMMED_PRIM("syntax-property" , syntax_property , 2, 3, env); + ADD_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); REGISTER_SO(source_symbol); - REGISTER_SO(share_symbol); - REGISTER_SO(origin_symbol); - REGISTER_SO(lexical_symbol); - REGISTER_SO(protected_symbol); - REGISTER_SO(nominal_id_symbol); source_symbol = scheme_make_symbol("source"); /* not interned! */ - share_symbol = scheme_make_symbol("share"); /* not interned! */ - origin_symbol = scheme_intern_symbol("origin"); - lexical_symbol = scheme_intern_symbol("lexical"); - protected_symbol = scheme_intern_symbol("protected"); - nominal_id_symbol = scheme_intern_symbol("nominal-id"); - - REGISTER_SO(module_symbol); - REGISTER_SO(top_symbol); - REGISTER_SO(macro_symbol); - REGISTER_SO(local_symbol); - REGISTER_SO(intdef_symbol); - REGISTER_SO(use_site_symbol); - module_symbol = scheme_intern_symbol("module"); - top_symbol = scheme_intern_symbol("top"); - macro_symbol = scheme_intern_symbol("macro"); - local_symbol = scheme_intern_symbol("local"); - intdef_symbol = scheme_intern_symbol("intdef"); - use_site_symbol = scheme_intern_symbol("use-site"); - - REGISTER_SO(name_symbol); - REGISTER_SO(context_symbol); - REGISTER_SO(bindings_symbol); - REGISTER_SO(matchp_symbol); - REGISTER_SO(cycle_symbol); - REGISTER_SO(free_symbol); - REGISTER_SO(fallbacks_symbol); - name_symbol = scheme_intern_symbol("name"); - context_symbol = scheme_intern_symbol("context"); - bindings_symbol = scheme_intern_symbol("bindings"); - matchp_symbol = scheme_intern_symbol("match?"); - cycle_symbol = scheme_intern_symbol("cycle"); - free_symbol = scheme_intern_symbol("free-identifier=?"); - fallbacks_symbol = scheme_intern_symbol("fallbacks"); REGISTER_SO(empty_srcloc); empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); @@ -428,17 +133,14 @@ empty_srcloc->col = -1; empty_srcloc->pos = -1; - REGISTER_SO(root_scope); - root_scope = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - REGISTER_SO(scheme_paren_shape_symbol); scheme_paren_shape_symbol = scheme_intern_symbol("paren-shape"); REGISTER_SO(scheme_paren_shape_preserve_square); - scheme_paren_shape_preserve_square = make_preserved_property_value(scheme_make_ascii_character('[')); + scheme_paren_shape_preserve_square = scheme_make_ascii_character('['); REGISTER_SO(scheme_paren_shape_preserve_curly); - scheme_paren_shape_preserve_curly = make_preserved_property_value(scheme_make_ascii_character('{')); + scheme_paren_shape_preserve_curly = scheme_make_ascii_character('{'); REGISTER_SO(scheme_source_stx_props); REGISTER_SO(square_stx_props); @@ -449,10 +151,6 @@ } void scheme_init_stx_places(int initial_main_os_thread) { - REGISTER_SO(taint_intern_table); - taint_intern_table = scheme_make_weak_equal_table(); - - init_binding_cache(); } /*========================================================================*/ @@ -466,13 +164,9 @@ Scheme_Stx *stx; stx = MALLOC_ONE_TAGGED(Scheme_Stx); - stx->iso.so.type = scheme_stx_type; - STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; + stx->so.type = scheme_stx_type; stx->val = val; stx->srcloc = srcloc; - stx->scopes = empty_scope_table; - stx->u.to_propagate = NULL; - stx->shifts = scheme_null; stx->props = props; return (Scheme_Object *)stx; @@ -482,41 +176,18 @@ /* the `mutate` argument tracks whether we can mutate `to` */ { Scheme_Stx *stx = (Scheme_Stx *)to; - Scheme_Object *taints, *shifts; - Scheme_Scope_Table *scopes; - Scheme_Scope_Table *to_propagate; - int armed; STX_ASSERT(SCHEME_STXP(to)); - if (mutate && (*mutate & MUTATE_STX_OBJ)) { - COUNT_MUTATE_ALLOCS(stx_skip_alloc_obj++); + if (mutate && (*mutate & MUTATE_STX_OBJ)) return to; - } - - taints = stx->taints; - scopes = stx->scopes; - shifts = stx->shifts; - to_propagate = stx->u.to_propagate; - armed = (STX_KEY(stx) & STX_ARMED_FLAG); - stx = (Scheme_Stx *)scheme_make_stx(stx->val, + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->scopes = scopes; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - stx->u.to_propagate = to_propagate; - if (armed) - STX_KEY(stx) |= STX_ARMED_FLAG; - } - stx->taints = taints; - stx->shifts = shifts; - - if (mutate) { - COUNT_MUTATE_ALLOCS(stx_alloc_obj++); + if (mutate) *mutate |= MUTATE_STX_OBJ; - } return (Scheme_Object *)stx; } @@ -541,8260 +212,798 @@ return scheme_make_stx(val, srcloc, props); } -static Scheme_Object *make_preserved_property_value(Scheme_Object *v) -{ - Scheme_Object *p; - - p = scheme_alloc_small_object(); - p->type = scheme_syntax_property_preserve_type; - SCHEME_PTR_VAL(p) = v; - - return p; -} - -static Scheme_Object *merge_property_value(Scheme_Object *e1, Scheme_Object *e2) -{ - int preserve = 0; - - if (SAME_TYPE(SCHEME_TYPE(e1), scheme_syntax_property_preserve_type)) { - preserve = 1; - e1 = SCHEME_PTR_VAL(e1); - } - if (SAME_TYPE(SCHEME_TYPE(e2), scheme_syntax_property_preserve_type)) { - preserve = 1; - e2 = SCHEME_PTR_VAL(e2); - } - - e1 = ICONS(e1, e2); - - if (preserve) - e1 = make_preserved_property_value(e1); - - return e1; -} +/*========================================================================*/ +/* stx and lists */ +/*========================================================================*/ -Scheme_Object *scheme_stx_track(Scheme_Object *naya, - Scheme_Object *old, - Scheme_Object *origin) - /* Maintain properties for an expanded expression */ +int scheme_stx_list_length(Scheme_Object *list) { - Scheme_Stx *nstx = (Scheme_Stx *)naya; - Scheme_Stx *ostx = (Scheme_Stx *)old; - Scheme_Hash_Tree *ne, *oe; - Scheme_Object *e1, *key, *val; - mzlonglong i; + int len; - STX_ASSERT(!origin || SCHEME_STX_SYMBOLP(origin)); + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); - if (nstx->props) - ne = nstx->props; - else - ne = empty_hash_tree; - - if (ostx->props) { - if (SAME_OBJ(ostx->props, STX_SRCTAG)) { - /* Drop 'source; will add 'origin. */ - oe = empty_hash_tree; + len = 0; + while (!SCHEME_NULLP(list)) { + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + if (SCHEME_PAIRP(list)) { + len++; + list = SCHEME_CDR(list); } else { - oe = ostx->props; - - /* Drop 'source and 'share; will add 'origin */ - oe = scheme_hash_tree_set(oe, source_symbol, NULL); - oe = scheme_hash_tree_set(oe, share_symbol, NULL); + if (!SCHEME_NULLP(list)) + len++; + break; } - } else { - /* Will add 'origin */ - oe = empty_hash_tree; } - e1 = scheme_hash_tree_get(oe, origin_symbol); - if (e1 && origin) - oe = scheme_hash_tree_set(oe, origin_symbol, merge_property_value(origin, e1)); - else if (origin) - oe = scheme_hash_tree_set(oe, origin_symbol, ICONS(origin, scheme_null)); - - /* Merge ne and oe */ + return len; +} - if (SAME_OBJ(ne, empty_hash_tree)) - ne = oe; - else if (ne->count < oe->count) { - i = scheme_hash_tree_next(ne, -1); - while (i != -1) { - scheme_hash_tree_index(ne, i, &key, &val); - e1 = scheme_hash_tree_get(oe, key); - if (e1) - oe = scheme_hash_tree_set(oe, key, merge_property_value(val, e1)); - else - oe = scheme_hash_tree_set(oe, key, val); - i = scheme_hash_tree_next(ne, i); - } - ne = oe; - } else { - i = scheme_hash_tree_next(oe, -1); - while (i != -1) { - scheme_hash_tree_index(oe, i, &key, &val); - e1 = scheme_hash_tree_get(ne, key); - if (e1) - ne = scheme_hash_tree_set(ne, key, merge_property_value(e1, val)); - else - ne = scheme_hash_tree_set(ne, key, val); - i = scheme_hash_tree_next(oe, i); - } - } +int scheme_stx_proper_list_length(Scheme_Object *list) +{ + int len; + Scheme_Object *turtle; - /* Clone nstx, keeping wraps, changing props to ne */ - nstx = (Scheme_Stx *)clone_stx((Scheme_Object *)nstx, NULL); - nstx->props = ne; + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); - return (Scheme_Object *)nstx; -} + len = 0; + turtle = list; + while (SCHEME_PAIRP(list)) { + len++; -void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context) -{ - clear_binding_cache_stx((Scheme_Stx *)q_stx); + list = SCHEME_CDR(list); + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + + if (!SCHEME_PAIRP(list)) + break; + len++; + list = SCHEME_CDR(list); + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); - ((Scheme_Stx *)q_stx)->val = val; + if (SAME_OBJ(turtle, list)) + break; + + turtle = SCHEME_CDR(turtle); + if (SCHEME_STXP(turtle)) + turtle = SCHEME_STX_VAL(turtle); - if (context) { - ((Scheme_Stx *)q_stx)->scopes = ((Scheme_Stx *)context)->scopes; - ((Scheme_Stx *)q_stx)->shifts = ((Scheme_Stx *)context)->shifts; - } else { - ((Scheme_Stx *)q_stx)->scopes = NULL; - ((Scheme_Stx *)q_stx)->shifts = NULL; } + + if (SCHEME_NULLP(list)) + return len; - ((Scheme_Stx *)q_stx)->u.to_propagate = NULL; - ((Scheme_Stx *)q_stx)->taints = NULL; + return -1; } -/******************** scopes ********************/ - -Scheme_Object *scheme_stx_root_scope() -{ - /* The root scope is an all-phases scope used by all top-level namespaces - (and not by module namespaces): */ - return root_scope; -} +/*========================================================================*/ +/* syntax->datum */ +/*========================================================================*/ -Scheme_Object *scheme_new_scope(int kind) +#ifdef DO_STACK_CHECK +static Scheme_Object *syntax_to_datum_k(void) { - mzlonglong id; - Scheme_Object *m; - - if (kind == SCHEME_STX_MODULE_MULTI_SCOPE) { - m = scheme_malloc_small_tagged(sizeof(Scheme_Scope_With_Owner)); - SCHEME_SCOPE_FLAGS((Scheme_Scope *)m) |= 0x1; - } else - m = scheme_malloc_small_tagged(sizeof(Scheme_Scope)); + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - ((Scheme_Scope *)m)->iso.so.type = scheme_scope_type; - id = ((++scope_counter) << SCHEME_STX_SCOPE_KIND_SHIFT) | kind; - ((Scheme_Scope *)m)->id = id; + p->ku.k.p1 = NULL; - return m; + return syntax_to_datum_inner(o); } +#endif -static Scheme_Object *new_multi_scope(Scheme_Object *debug_name) -/* a multi-scope is a set of phase-specific scopes that are - always added, removed, or flipped as a group */ +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o) +/* Recurs through `o` to find syntax objects and strip them away, or + returns `o` if no syntax objects are inside. */ { - Scheme_Hash_Table *multi_scope; - - /* Maps a phase to a scope, where each scope is created on demand: */ - multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); + Scheme_Object *v, *result; - if (SCHEME_FALSEP(debug_name)) - MZ_OPT_HASH_KEY(&(multi_scope->iso)) |= 0x2; +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)o; + return scheme_handle_stack_overflow(syntax_to_datum_k); + } + } +#endif + SCHEME_USE_FUEL(1); - if (SAME_TYPE(SCHEME_TYPE(debug_name), scheme_resolved_module_path_type)) - debug_name = scheme_resolved_module_path_value(debug_name); - if (SCHEME_FALSEP(debug_name)) - debug_name = scheme_gensym(top_symbol); + if (SCHEME_STXP(o)) + o = SCHEME_STX_VAL(o); + v = o; - scheme_hash_set(multi_scope, scheme_void, debug_name); + if (SCHEME_PAIRP(v)) { + Scheme_Object *first = NULL, *last = NULL, *p; + Scheme_Object *a; + int same = 0; + + while (SCHEME_PAIRP(v)) { + a = syntax_to_datum_inner(SCHEME_CAR(v)); - return (Scheme_Object *)multi_scope; -} + if (!first && SAME_OBJ(a, SCHEME_CAR(v))) { + same++; + v = SCHEME_CDR(v); + } else { + if (!first && (same > 0)) { + v = o; + while (same--) { + p = CONS(SCHEME_CAR(v), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + } + + p = CONS(a, scheme_null); + + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + } + if (!SCHEME_NULLP(v)) { + a = syntax_to_datum_inner(v); + if (!first && SAME_OBJ(v, a)) + return o; + else { + v = o; + while (same--) { + p = CONS(SCHEME_CAR(v), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + + SCHEME_CDR(last) = a; + } + } else if (!first) + return o; -static void repair_scope_owner(Scheme_Object *m) -{ - Scheme_Object *multi_scope; - - /* The owner scope might be missing due to broken bytecode. For - non-broken bytecode, there shouldn't be a way to reach a - scope withough going through its owner. Work around the - broken scope object by creating a new owner. */ - - multi_scope = new_multi_scope(scheme_false); - scheme_hash_set((Scheme_Hash_Table *)multi_scope, scheme_make_integer(0), m); - ((Scheme_Scope_With_Owner *)m)->owner_multi_scope = multi_scope; -} + result = first; + } else if (SCHEME_BOXP(v)) { + v = syntax_to_datum_inner(SCHEME_BOX_VAL(v)); + if (v == SCHEME_BOX_VAL(o)) + return o; + result = scheme_box(v); + SCHEME_SET_IMMUTABLE(result); + } else if (SCHEME_VECTORP(v)) { + int size = SCHEME_VEC_SIZE(v), i, j; + Scheme_Object *r, *a; -Scheme_Object *scheme_scope_printed_form(Scheme_Object *m) -{ - int kind = ((Scheme_Scope *)m)->id & SCHEME_STX_SCOPE_KIND_MASK; - Scheme_Object *num, *kind_sym, *vec, *name; + for (i = 0; i < size; i++) { + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i]); + if (!SAME_OBJ(a, SCHEME_VEC_ELS(v)[i])) + break; + } - num = scheme_make_integer_value_from_long_long(((Scheme_Scope *)m)->id >> SCHEME_STX_SCOPE_KIND_SHIFT); - - switch (kind) { - case SCHEME_STX_MODULE_SCOPE: - case SCHEME_STX_MODULE_MULTI_SCOPE: - if (SAME_OBJ(m, root_scope)) - kind_sym = top_symbol; - else - kind_sym = module_symbol; - break; - case SCHEME_STX_MACRO_SCOPE: - kind_sym = macro_symbol; - break; - case SCHEME_STX_LOCAL_BIND_SCOPE: - kind_sym = local_symbol; - break; - case SCHEME_STX_INTDEF_SCOPE: - kind_sym = intdef_symbol; - break; - case SCHEME_STX_USE_SITE_SCOPE: - kind_sym = use_site_symbol; - break; - default: - kind_sym = scheme_false; - break; - } + if (i >= size) + return o; + + r = scheme_make_vector(size, NULL); - if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { - Scheme_Object *multi_scope = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; - if (multi_scope) { - name = scheme_eq_hash_get((Scheme_Hash_Table *)multi_scope, scheme_void); - if (!name) name = scheme_false; - if (MULTI_SCOPE_META_HASHEDP(name)) name = SCHEME_CAR(name); - - if (SCHEME_TL_MULTI_SCOPEP(multi_scope)) - kind_sym = top_symbol; - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[2] = name; - SCHEME_VEC_ELS(vec)[3] = ((Scheme_Scope_With_Owner *)m)->phase; - } else { - /* owner is either missing (bad bytecode) or hasn't been loaded on demand */ - vec = scheme_make_vector(2, NULL); + for (j = 0; j < i; j++) { + SCHEME_VEC_ELS(r)[j] = SCHEME_VEC_ELS(v)[j]; + } + SCHEME_VEC_ELS(r)[i] = a; + for (i++; i < size; i++) { + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i]); + SCHEME_VEC_ELS(r)[i] = a; } - } else { - vec = scheme_make_vector(2, NULL); - } - SCHEME_VEC_ELS(vec)[0] = num; - SCHEME_VEC_ELS(vec)[1] = kind_sym; + result = r; + SCHEME_SET_IMMUTABLE(result); + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val, *val2; + mzlonglong i, j; - return vec; -} + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val2 = syntax_to_datum_inner(val); + if (!SAME_OBJ(val, val2)) + break; + i = scheme_hash_tree_next(ht, i); + } + if (i == -1) + return o; + + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); -#define SCHEME_SCOPE_SETP(m) SCHEME_HASHTRP((Scheme_Object *)(m)) + j = scheme_hash_tree_next(ht, -1); + while (j != i) { + scheme_hash_tree_index(ht, j, &key, &val); + val = syntax_to_datum_inner(val); + ht2 = scheme_hash_tree_set(ht2, key, val); + j = scheme_hash_tree_next(ht, j); + } + + scheme_hash_tree_index(ht, i, &key, &val); + ht2 = scheme_hash_tree_set(ht2, key, val2); + + i = scheme_hash_tree_next(ht, i); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = syntax_to_datum_inner(val); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + result = (Scheme_Object *)ht2; + } else if (prefab_p(v)) { + Scheme_Structure *s = (Scheme_Structure *)v; + Scheme_Object *a; + int size = s->stype->num_slots, i; -XFORM_NONGCING static intptr_t scope_set_count(Scheme_Scope_Set *s) -{ - return ((Scheme_Hash_Tree *)s)->count; -} + for (i = 0; i < size; i++) { + a = syntax_to_datum_inner(s->slots[i]); + if (!SAME_OBJ(a, s->slots[i])) + break; + } + if (i >= size) + return o; -XFORM_NONGCING static Scheme_Object *scope_set_get(Scheme_Scope_Set *s, Scheme_Object *key) -{ - return scheme_eq_hash_tree_get((Scheme_Hash_Tree *)s, key); -} + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + s->slots[i] = a; + for (i++; i < size; i++) { + a = syntax_to_datum_inner(s->slots[i]); + s->slots[i] = a; + } -static Scheme_Scope_Set *scope_set_set(Scheme_Scope_Set *s, Scheme_Object *key, Scheme_Object *val) -{ - return (Scheme_Scope_Set *)scheme_hash_tree_set((Scheme_Hash_Tree *)s, key, val); -} + result = (Scheme_Object *)s; + } else + result = v; -XFORM_NONGCING static mzlonglong scope_set_next(Scheme_Scope_Set *s, mzlonglong pos) -{ - return scheme_hash_tree_next((Scheme_Hash_Tree *)s, pos); + return result; } -XFORM_NONGCING static int scope_set_index(Scheme_Scope_Set *s, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx) { - return scheme_hash_tree_index((Scheme_Hash_Tree *)s, pos, _key, _val); + return syntax_to_datum_inner(stx); } -XFORM_NONGCING static int scope_subset(Scheme_Scope_Set *sa, Scheme_Scope_Set *sb) -{ - return scheme_eq_hash_tree_subset_of((Scheme_Hash_Tree *)sa, - (Scheme_Hash_Tree *)sb); -} +/*========================================================================*/ +/* datum->syntax */ +/*========================================================================*/ -static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) -{ - return (scope_set_count(a) == scope_set_count(b)) && scope_subset(a, b); -} +#define return_NULL return NULL -XFORM_NONGCING static int scope_props_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) +#ifdef DO_STACK_CHECK +static Scheme_Object *datum_to_syntax_k(void) { - return ((scope_set_count(a) == scope_set_count(b)) - && scheme_eq_hash_tree_subset_match_of((Scheme_Hash_Tree *)a, - (Scheme_Hash_Tree *)b)); -} + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2; + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; -static Scheme_Object *make_fallback_pair(Scheme_Object *a, Scheme_Object *b) -{ - a = scheme_make_vector(2, a); - SCHEME_VEC_ELS(a)[1] = b; - return a; + return datum_to_syntax_inner(o, stx_src, ht); } +#endif -static Scheme_Object *make_fallback_quad(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *c, Scheme_Object *d) +static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, + Scheme_Stx *stx_src, + Scheme_Hash_Table *ht) { - a = scheme_make_vector(4, a); - SCHEME_VEC_ELS(a)[1] = b; - SCHEME_VEC_ELS(a)[2] = c; - SCHEME_VEC_ELS(a)[3] = d; - return a; -} + Scheme_Object *result, *hashed; -Scheme_Object *extract_simple_scope(Scheme_Object *multi_scope, Scheme_Object *phase) -{ - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)multi_scope; - Scheme_Object *m; - - if (SCHEME_TRUEP(phase) && !SCHEME_INTP(phase)) { - /* make sure phases are interned (in case of a bignum phase, which should be very rare): */ - phase = scheme_intern_literal_number(phase); - } - - m = scheme_eq_hash_get(ht, phase); - if (!m) { - m = scheme_new_scope(SCHEME_STX_MODULE_MULTI_SCOPE); - ((Scheme_Scope_With_Owner *)m)->owner_multi_scope = (Scheme_Object *)ht; - ((Scheme_Scope_With_Owner *)m)->phase = phase; - scheme_hash_set(ht, phase, m); - - if (SCHEME_MPAIRP(scheme_hash_get(ht, scheme_void))) { - /* pair indicates loading from bytecode; - zero out id, so that ordering is based on the owner plus the phase; - this approach helps ensure determinstic ordering independent of - the time at which simple scopes are generated */ - ((Scheme_Scope *)m)->id &= SCHEME_STX_SCOPE_KIND_MASK; - } - } - - return m; -} + if (SCHEME_STXP(o)) + return o; -static Scheme_Object *extract_simple_scope_from_shifted(Scheme_Object *multi_scope_and_phase, Scheme_Object *phase) -{ - Scheme_Object *ph; - - ph = SCHEME_CDR(multi_scope_and_phase); - if (SCHEME_FALSEP(phase)) { - if (!SCHEME_BOXP(ph)) { - /* number phase shift, so look for #f */ - ph = scheme_false; - } else { - /* phase shift of some to #f, so look for */ - ph = SCHEME_BOX_VAL(ph); +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)o; + p->ku.k.p2 = (void *)stx_src; + p->ku.k.p3 = (void *)ht; + return scheme_handle_stack_overflow(datum_to_syntax_k); } - } else if (SCHEME_BOXP(ph)) { - /* we want a number phase, but this is shifted to #f */ - return NULL; - } else - ph = scheme_bin_minus(phase, ph); - - return extract_simple_scope(SCHEME_CAR(multi_scope_and_phase), ph); -} - -static Scheme_Scope_Set *extract_scope_set_from_scope_list(Scheme_Scope_Set *scopes, - Scheme_Object *multi_scopes, - Scheme_Object *phase) -{ - Scheme_Object *m; - - /* Combine scopes that exist at all phases with a specific scope for - each set of phase-specific scopes */ - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_FIRST(multi_scopes); - - for (; !SCHEME_NULLP(multi_scopes); multi_scopes= SCHEME_CDR(multi_scopes)) { - m = extract_simple_scope_from_shifted(SCHEME_CAR(multi_scopes), phase); - if (m) - scopes = scope_set_set(scopes, m, scheme_true); } +#endif - return scopes; -} - -static Scheme_Scope_Set *extract_scope_set(Scheme_Stx *stx, Scheme_Object *phase) -{ - Scheme_Scope_Table *st = stx->scopes; - return extract_scope_set_from_scope_list(st->simple_scopes, st->multi_scopes, phase); -} - -static Scheme_Scope_Set *adjust_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) -/* operate on a single scope within a set */ -{ - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); + SCHEME_USE_FUEL(1); - if (scope_set_get(scopes, m)) { - if ((mode == SCHEME_STX_FLIP) || (mode == SCHEME_STX_REMOVE)) - return scope_set_set(scopes, m, NULL); - else - return scopes; - } else { - if (mode == SCHEME_STX_REMOVE) - return scopes; - else - return scope_set_set(scopes, m, scheme_true); - } -} + if (ht) { + if (HAS_CHAPERONE_SUBSTX(o)) { + if (scheme_hash_get(ht, o)) { + /* Graphs disallowed */ + return_NULL; + } -Scheme_Object *adjust_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) -/* operate on a set of phase-specific scopes within a set */ -{ - Scheme_Object *l; + scheme_hash_set(ht, o, scheme_true); + hashed = o; + } else + hashed = NULL; + } else + hashed = NULL; - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m, SCHEME_CAR(SCHEME_CAR(l))) - && SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(l)))) { - if ((mode == SCHEME_STX_ADD) || (mode == SCHEME_STX_PUSH)) - return multi_scopes; - break; + if (SCHEME_PAIRP(o)) { + Scheme_Object *first = NULL, *last = NULL, *p; + + /* Check whether it's all conses with + syntax inside */ + p = o; + while (SCHEME_PAIRP(p)) { + if (!SCHEME_STXP(SCHEME_CAR(p))) + break; + p = SCHEME_CDR(p); } - } - - if (mode == SCHEME_STX_PUSH) { - if (!SCHEME_NULLP(multi_scopes)) - return make_fallback_pair(scheme_make_pair(scheme_make_pair(m, phase), - (SCHEME_FALLBACKP(multi_scopes) - ? SCHEME_FALLBACK_FIRST(multi_scopes) - : multi_scopes)), - multi_scopes); - } + if (SCHEME_NULLP(p) || SCHEME_STXP(p)) { + result = o; + } else { + /* Build up a new list while converting elems */ + while (SCHEME_PAIRP(o)) { + Scheme_Object *a; + + if (ht && last) { + if (scheme_hash_get(ht, o)) { + /* cdr is shared. Stop here and let someone else complain. */ + break; + } + } - if ((mode == SCHEME_STX_REMOVE) && SCHEME_NULLP(l)) - return multi_scopes; - else if ((mode == SCHEME_STX_REMOVE) - || ((mode == SCHEME_STX_FLIP && !SCHEME_NULLP(l)))) { - return remove_at_scope_list(multi_scopes, l); - } else - return add_to_scope_list(scheme_make_pair(m, phase), multi_scopes); -} + a = datum_to_syntax_inner(SCHEME_CAR(o), stx_src, ht); + if (!a) return_NULL; + + p = scheme_make_pair(a, scheme_null); + + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + o = SCHEME_CDR(o); + } + if (!first) return_NULL; + if (!SCHEME_NULLP(o)) { + o = datum_to_syntax_inner(o, stx_src, ht); + if (!o) return_NULL; + SCHEME_CDR(last) = o; + } -static Scheme_Scope_Set *combine_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) -/* operate on a single scope within a set of propagation instructions */ -{ - Scheme_Object *old_mode; + result = first; + } + } else if (SCHEME_CHAPERONE_BOXP(o)) { + if (SCHEME_NP_CHAPERONEP(o)) + o = scheme_unbox(o); + else + o = SCHEME_PTR_VAL(o); - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); + o = datum_to_syntax_inner(o, stx_src, ht); + if (!o) return_NULL; + result = scheme_box(o); + SCHEME_SET_BOX_IMMUTABLE(result); + } else if (SCHEME_CHAPERONE_VECTORP(o)) { + int size, i; + Scheme_Object *a, *oo; - old_mode = scope_set_get(scopes, m); + oo = o; + if (SCHEME_NP_CHAPERONEP(o)) + o = SCHEME_CHAPERONE_VAL(o); + size = SCHEME_VEC_SIZE(o); - if (old_mode) { - if (SCHEME_INT_VAL(old_mode) == mode) { - if (mode == SCHEME_STX_FLIP) - return scope_set_set(scopes, m, NULL); + result = scheme_make_vector(size, NULL); + + for (i = 0; i < size; i++) { + if (SAME_OBJ(o, oo)) + a = SCHEME_VEC_ELS(o)[i]; else - return scopes; - } else if (mode == SCHEME_STX_FLIP) { - mode = SCHEME_INT_VAL(old_mode); - mode = ((mode == SCHEME_STX_REMOVE) ? SCHEME_STX_ADD : SCHEME_STX_REMOVE); - return scope_set_set(scopes, m, scheme_make_integer(mode)); - } else - return scope_set_set(scopes, m, scheme_make_integer(mode)); - } else - return scope_set_set(scopes, m, scheme_make_integer(mode)); -} - -Scheme_Object *combine_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) -/* operate on a set of phase-specific scopes within a set of propagation instructions */ -{ - Scheme_Object *l; - - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) { - if ((mode == SCHEME_STX_PUSH) - && SAME_OBJ(SCHEME_FALLBACK_SCOPE(l), m) - && SAME_OBJ(SCHEME_FALLBACK_PHASE(l), phase)) - return multi_scopes; - l = SCHEME_FALLBACK_FIRST(l); - } - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m, SCHEME_VEC_ELS(SCHEME_CAR(l))[0]) - && SAME_OBJ(phase, SCHEME_VEC_ELS(SCHEME_CAR(l))[1])) { - int prev_mode = SCHEME_INT_VAL(SCHEME_VEC_ELS(SCHEME_CAR(l))[2]); - if (mode == SCHEME_STX_PUSH) { - if (prev_mode == SCHEME_STX_ADD) - return multi_scopes; - break; - } else if (mode == SCHEME_STX_FLIP) { - if (prev_mode == SCHEME_STX_FLIP) - return remove_at_scope_list(multi_scopes, l); - else { - if (prev_mode == SCHEME_STX_ADD) - mode = SCHEME_STX_REMOVE; - else - mode = SCHEME_STX_ADD; - multi_scopes = remove_at_scope_list(multi_scopes, l); - break; - } - } else if (mode != prev_mode) { - multi_scopes = remove_at_scope_list(multi_scopes, l); - break; - } else - return multi_scopes; + a = scheme_chaperone_vector_ref(oo, i); + a = datum_to_syntax_inner(a, stx_src, ht); + if (!a) return_NULL; + SCHEME_VEC_ELS(result)[i] = a; } - } - - if (mode == SCHEME_STX_PUSH) - return make_fallback_quad(scheme_null, multi_scopes, m, phase); - else - return add_to_scope_list(make_vector3(m, phase, scheme_make_integer(mode)), - multi_scopes); -} - -static Scheme_Object *reconstruct_fallback(Scheme_Object *fb, Scheme_Object *r) -/* update actions for first (maybe only) in fallback chain */ -{ - if (fb) { - if (SCHEME_FALLBACK_QUADP(fb)) - return make_fallback_quad(r, - SCHEME_FALLBACK_REST(fb), - SCHEME_FALLBACK_SCOPE(fb), - SCHEME_FALLBACK_PHASE(fb)); - else - return make_fallback_pair(r, SCHEME_FALLBACK_REST(fb)); - } else - return r; -} -static Scheme_Object *clone_fallback_chain(Scheme_Object *fb) -{ - Scheme_Object *first = NULL, *last = NULL, *p; + SCHEME_SET_VECTOR_IMMUTABLE(result); + } else if (SCHEME_CHAPERONE_HASHTRP(o)) { + Scheme_Hash_Tree *ht1, *ht2; + Scheme_Object *key, *val; + mzlonglong i; - while (SCHEME_FALLBACKP(fb)) { - p = reconstruct_fallback(fb, SCHEME_FALLBACK_FIRST(fb)); - if (last) - SCHEME_FALLBACK_REST(last) = p; + if (SCHEME_NP_CHAPERONEP(o)) + ht1 = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(o); else - first = p; - last = p; - fb = SCHEME_FALLBACK_REST(fb); - } - - return first; -} - -static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p) -/* remove element at `p` within `l` */ -{ - Scheme_Object *fb; - Scheme_Object *r = SCHEME_CDR(p); - - if (SCHEME_FALLBACKP(l)) { - fb = l; - l = SCHEME_FALLBACK_FIRST(fb); - } else - fb = NULL; - - while (!SAME_OBJ(l, p)) { - r = scheme_make_pair(SCHEME_CAR(l), r); - l = SCHEME_CDR(l); - } - - return reconstruct_fallback(fb, r); -} - -static Scheme_Object *add_to_scope_list(Scheme_Object *p, Scheme_Object *l) -{ - if (SCHEME_FALLBACKP(l)) - return reconstruct_fallback(l, scheme_make_pair(p, SCHEME_FALLBACK_FIRST(l))); - else - return scheme_make_pair(p, l); -} - -static Scheme_Scope_Table *clone_scope_table(Scheme_Scope_Table *st, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -/* If prev is non-NULL, then `st` is a propagate table */ -{ - Scheme_Scope_Table *st2; - - if (!prev) { - if (*mutate & MUTATE_STX_SCOPE_TABLE) { - st2 = st; - COUNT_MUTATE_ALLOCS(stx_skip_alloc_scope_table++); - } else { - st2 = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - memcpy(st2, st, sizeof(Scheme_Scope_Table)); - *mutate |= MUTATE_STX_SCOPE_TABLE; - COUNT_MUTATE_ALLOCS(stx_alloc_scope_table++); - } - } else { - if (*mutate & MUTATE_STX_PROP_TABLE) { - st2 = st; - COUNT_MUTATE_ALLOCS(stx_skip_alloc_prop_table++); - } else { - st2 = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); - memcpy(st2, st, sizeof(Scheme_Propagate_Table)); - if (SAME_OBJ(st, empty_propagate_table)) - ((Scheme_Propagate_Table *)st2)->prev = prev; - *mutate |= MUTATE_STX_PROP_TABLE; - COUNT_MUTATE_ALLOCS(stx_alloc_prop_table++); + ht1 = (Scheme_Hash_Tree *)o; + + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht1)); + + i = scheme_hash_tree_next(ht1, -1); + while (i != -1) { + scheme_hash_tree_index(ht1, i, &key, &val); + if (!SAME_OBJ((Scheme_Object *)ht1, o)) + val = scheme_chaperone_hash_traversal_get(o, key, &key); + val = datum_to_syntax_inner(val, stx_src, ht); + if (!val) return NULL; + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht1, i); } - } - - return st2; -} - -typedef Scheme_Scope_Set *(*do_scope_t)(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode); -typedef Scheme_Object *(do_scope_list_t)(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode); - -static Scheme_Scope_Table *do_scope_at_phase(Scheme_Scope_Table *st, Scheme_Object *m, Scheme_Object *phase, int mode, - do_scope_t do_scope, do_scope_list_t do_scope_list, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -/* operate on a scope or set of phase specific scopes, - either on a scope set or a set of propagation instructions */ -{ - Scheme_Object *l; - Scheme_Scope_Set *scopes; - - if (SCHEME_SCOPEP(m) && SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { - if (!SCHEME_FALSEP(phase)) - phase = scheme_bin_minus(phase, ((Scheme_Scope_With_Owner *)m)->phase); - if (!((Scheme_Scope_With_Owner *)m)->owner_multi_scope) - repair_scope_owner(m); - m = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; - } + + result = (Scheme_Object *)ht2; + } else if (prefab_p(o) || (SCHEME_CHAPERONEP(o) && prefab_p(SCHEME_CHAPERONE_VAL(o)))) { + Scheme_Structure *s; + Scheme_Object *a; + int size, i; - if (SCHEME_MULTI_SCOPEP(m)) { - l = do_scope_list(st->multi_scopes, m, phase, mode); - if (SAME_OBJ(l, st->multi_scopes)) - return st; - st = clone_scope_table(st, prev, mutate); - st->multi_scopes = l; - return st; - } else { - scopes = do_scope(st->simple_scopes, m, mode); - if (SAME_OBJ(scopes, st->simple_scopes)) - return st; - st = clone_scope_table(st, prev, mutate); - st->simple_scopes = scopes; - return st; - } -} + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance((Scheme_Structure *)o); + size = s->stype->num_slots; -static Scheme_Object *stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Scope_Table *scopes; - Scheme_Scope_Table *to_propagate; - Scheme_Object *taints, *shifts; - - STX_ASSERT(SCHEME_STXP(o)); - - if (mode & SCHEME_STX_PROPONLY) { - scopes = stx->scopes; - mode -= SCHEME_STX_PROPONLY; - } else { - scopes = do_scope_at_phase(stx->scopes, m, phase, mode, adjust_scope, adjust_scope_list, NULL, mutate); - if ((stx->scopes == scopes) - && !(STX_KEY(stx) & STX_SUBSTX_FLAG)) { - return (Scheme_Object *)stx; + for (i = 0; i < size; i++) { + a = datum_to_syntax_inner(s->slots[i], stx_src, ht); + if (!a) return NULL; + s->slots[i] = a; } - } - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - to_propagate = (stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table); - to_propagate = do_scope_at_phase(to_propagate, m, phase, mode, combine_scope, combine_scope_list, stx->scopes, mutate); - if ((stx->u.to_propagate == to_propagate) - && (stx->scopes == scopes)) - return (Scheme_Object *)stx; + result = (Scheme_Object *)s; } else - to_propagate = NULL; /* => clear cache */ - - if (*mutate & MUTATE_STX_OBJ) { - stx->scopes = scopes; - stx->u.to_propagate = to_propagate; - } else { - int armed = (STX_KEY(stx) & STX_ARMED_FLAG); - taints = stx->taints; - shifts = stx->shifts; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->scopes = scopes; - stx->u.to_propagate = to_propagate; - stx->taints = taints; - stx->shifts = shifts; - if (armed) - STX_KEY(stx) |= STX_ARMED_FLAG; - *mutate |= MUTATE_STX_OBJ; - } - - return (Scheme_Object *)stx; -} + result = scheme_read_intern(o); -Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode) -{ - int mutate = 0; - return stx_adjust_scope(o, m, phase, mode, &mutate); + if (SCHEME_FALSEP((Scheme_Object *)stx_src)) + result = scheme_make_stx(result, empty_srcloc, NULL); + else + result = scheme_make_stx(result, stx_src->srcloc, NULL); + + if (hashed) + scheme_hash_set(ht, hashed, NULL); + + return result; } -Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) +static int quick_check_graph(Scheme_Object *o, int fuel) { - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_ADD); -} + if (!fuel) return 0; -Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) -{ - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_REMOVE); -} + if (SCHEME_PAIRP(o)) + return quick_check_graph(SCHEME_CDR(o), + quick_check_graph(SCHEME_CAR(o), fuel - 1)); -Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) -{ - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_FLIP); + if (HAS_CHAPERONE_SUBSTX(o)) + return 0; + else + return fuel; } -static Scheme_Object *stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode, - GC_CAN_IGNORE int *mutate) +Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, + Scheme_Object *stx_src, + int flags) { - Scheme_Object *key, *val; - intptr_t i; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(SCHEME_SCOPE_SETP(scopes)); - - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); + Scheme_Object *v; - o = stx_adjust_scope(o, key, phase, mode, mutate); - - i = scope_set_next(scopes, i); - } + if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src)) + return o; - return o; -} + if (SCHEME_STXP(o)) + return o; -Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode) -{ - int mutate = 0; - return stx_adjust_scopes(o, scopes, phase, mode, &mutate); -} - -/* For each environment frame, we need to keep track of various sets of scopes: - - bind scopes (normally 0 or 1) are created for the binding context - - use-site scopes are created for macro expansions that need them - - intdef scopes are for immediately nested internal-definition contexts; - they're treated the same as bind scopes - - frame-scopes = main-scopes - . | (vector bind-scopes use-site-scopes intdef-scopes) - bind-scopes = some-scopes - use-site-scopes = some-scopes - intdef-scopes = some-scopes - some-scopes = #f | scope | scope-set */ - -static Scheme_Object *stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, int which, Scheme_Object *phase, int mode) -{ - if (SCHEME_VECTORP(scope)) { - scope = SCHEME_VEC_ELS(scope)[which]; - } else if (which != 0) - return o; - - if (SCHEME_FALSEP(scope)) - return o; - else if (SCHEME_SCOPEP(scope)) - return scheme_stx_adjust_scope(o, scope, phase, mode); - else { - STX_ASSERT(SCHEME_SCOPE_SETP(scope)); - return scheme_stx_adjust_scopes(o, (Scheme_Scope_Set *)scope, phase, mode); - } -} - -Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - o = scheme_stx_adjust_frame_use_site_scopes(o, scope, phase, mode); - o = scheme_stx_adjust_frame_bind_scopes(o, scope, phase, mode); - return stx_adjust_frame_scopes(o, scope, 2, phase, mode); -} - -Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - return stx_adjust_frame_scopes(o, scope, 0, phase, mode); -} - -Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - return stx_adjust_frame_scopes(o, scope, 1, phase, mode); -} - -Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope) -{ - return scope; -} - -static Scheme_Object *add_frame_scope(Scheme_Object *frame_scopes, Scheme_Object *scope, int pos) -{ - Scheme_Object *scopes; - - if (!frame_scopes) { - if (pos == 0) - return scope; - else - frame_scopes = scheme_false; - } - - if (SCHEME_VECTORP(frame_scopes)) - scopes = SCHEME_VEC_ELS(frame_scopes)[pos]; - else if (pos == 0) - scopes = frame_scopes; - else - scopes = scheme_false; - - if (SCHEME_FALSEP(scopes)) - scopes = scope; - else { - STX_ASSERT(!SCHEME_MULTI_SCOPEP(scopes)); - if (SCHEME_SCOPEP(scopes)) - scopes = (Scheme_Object *)scope_set_set(empty_scope_set, scopes, scheme_true); - scopes = (Scheme_Object *)scope_set_set((Scheme_Scope_Set *)scopes, scope, scheme_true); - } - - if (SCHEME_VECTORP(frame_scopes)) - frame_scopes = make_vector3(SCHEME_VEC_ELS(frame_scopes)[0], - SCHEME_VEC_ELS(frame_scopes)[1], - SCHEME_VEC_ELS(frame_scopes)[2]); - else - frame_scopes = make_vector3(frame_scopes, scheme_false, scheme_false); - - SCHEME_VEC_ELS(frame_scopes)[pos] = scopes; - - return frame_scopes; -} - -Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope) -{ - return add_frame_scope(frame_scopes, use_site_scope, 1); -} - -Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *scope) -{ - return add_frame_scope(frame_scopes, scope, 2); -} - -static Scheme_Object *add_intdef_scopes_of(Scheme_Object *scopes, Scheme_Object *keep_intdef_scopes) -{ - if (SCHEME_VECTORP(keep_intdef_scopes) - && SCHEME_TRUEP(SCHEME_VEC_ELS(keep_intdef_scopes)[2])) { - if (scopes && SCHEME_VECTORP(scopes)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(scopes)[2])) - scheme_signal_error("internal error: cannot currently merge intdef scopes"); - return make_vector3(SCHEME_VEC_ELS(scopes)[0], - SCHEME_VEC_ELS(scopes)[1], - SCHEME_VEC_ELS(keep_intdef_scopes)[2]); - } else - return make_vector3(scopes ? scopes : scheme_false, - scheme_false, - SCHEME_VEC_ELS(keep_intdef_scopes)[2]); - } - - return scopes; -} - -int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase) -{ - return (scope_set_count(extract_scope_set((Scheme_Stx *)stx, phase)) == 0); -} - -/******************** shifts ********************/ - -/* Shifts includes both phase shifts (in the sense of - `syntax-shift-phase-level`) and shifting a module reference based - on one modix (at compile time, say) to a different one (at run - time, say). A modidx kind of shift can also include an inspector - substution (e.g., a load-time inspectr to take the place of the - compile-time one) and an export registry for restoring lazily load - bulk-import bindings (for when all exports of a module are - imported, and we go find the imported module on demand). */ - -XFORM_NONGCING static int same_phase(Scheme_Object *a, Scheme_Object *b) -{ - return ((SAME_OBJ(a, b) || scheme_eqv(a, b)) - ? 1 - : 0); -} - -static Scheme_Object *add_shifts(Scheme_Object *old_shift, Scheme_Object *shift) -/* The new `shift` is allowed to be #f, but `old_shift` and the result are - normalized to `(box 0)` */ -{ - if (SCHEME_BOXP(shift) && SCHEME_FALSEP(SCHEME_BOX_VAL(shift))) { - /* (box #f) is an impossible shift, so discard */ - return NULL; - } - - if ((SCHEME_FALSEP(shift) || SCHEME_BOXP(shift)) - && SCHEME_BOXP(old_shift)) { - /* shifting some numbered phase when already shifted to #f; discard */ - return NULL; - } - - if (SCHEME_BOXP(old_shift)) { - /* numbered shift on already shifted to #f => no change */ - return old_shift; - } - - if (SCHEME_FALSEP(shift)) { - /* shift of before shifting 0 to #f => shift - to #f */ - return scheme_box(scheme_bin_minus(scheme_make_integer(0), old_shift)); - } else if (SCHEME_BOXP(shift)) { - /* shift of before shifting to #f => shift - to #f */ - if (SAME_OBJ(old_shift, scheme_make_integer(0))) - return shift; - else - return scheme_box(scheme_bin_minus(SCHEME_BOX_VAL(shift), old_shift)); - } else - return scheme_bin_plus(old_shift, shift); -} - -static Scheme_Object *shift_multi_scope(Scheme_Object *p, Scheme_Object *shift) -/* shift all phase-specific scopes in a set */ -{ - shift = add_shifts(SCHEME_CDR(p), shift); - - if (!shift) - return NULL; - - if (SAME_OBJ(shift, SCHEME_CDR(p))) - return p; - - return scheme_make_pair(SCHEME_CAR(p), shift); -} - -static Scheme_Object *shift_prop_multi_scope(Scheme_Object *p, Scheme_Object *shift) - /* shift all phase-specific scopes in a set of propagation instructions */ -{ - Scheme_Object *p2; - - shift = add_shifts(SCHEME_VEC_ELS(p)[1], shift); - if (!shift) - return NULL; - - if (SAME_OBJ(shift, SCHEME_VEC_ELS(p)[1])) - return p; - - p2 = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(p2)[0] = SCHEME_VEC_ELS(p)[0]; - SCHEME_VEC_ELS(p2)[1] = shift; - SCHEME_VEC_ELS(p2)[2] = SCHEME_VEC_ELS(p)[2]; - - return p2; -} - -typedef Scheme_Object *(shift_multi_scope_t)(Scheme_Object *p, Scheme_Object *shift); - -static Scheme_Scope_Table *shift_scope_table(Scheme_Scope_Table *st, Scheme_Object *shift, - shift_multi_scope_t shift_mm, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Scope_Table *st2; - Scheme_Object *l, *key, *val, *fbs; - - if (SAME_OBJ(st, empty_scope_table)) { - STX_ASSERT(!prev); - return st; - } - - if ((SCHEME_NULLP(st->multi_scopes) - || (SCHEME_FALLBACKP(st->multi_scopes) - && SCHEME_NULLP(SCHEME_FALLBACK_FIRST(st->multi_scopes)))) - && !prev) - return st; - - st2 = clone_scope_table(st, prev, mutate); - - l = st->multi_scopes; - if (SCHEME_FALLBACKP(l)) { - l = clone_fallback_chain(l); - st2->multi_scopes = l; - fbs = l; - } else - fbs = scheme_false; - /* loop to cover all fallbacks; fbs is #f for - no fallback handling, otherwise it's always - a fallback record and the updated list goes - in first or rest */ - while (1) { - int was_fb; - if (SCHEME_FALLBACKP(l)) { - l = SCHEME_FALLBACK_FIRST(l); - was_fb = 1; - } else - was_fb = 0; - - /* Loop through one list of multi scopes: */ - val = scheme_null; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - key = shift_mm(SCHEME_CAR(l), shift); - if (key) - val = scheme_make_pair(key, val); - } - - if (SCHEME_FALLBACKP(fbs)) { - if (was_fb) { - SCHEME_FALLBACK_FIRST(fbs) = val; - l = SCHEME_FALLBACK_REST(fbs); - if (SCHEME_FALLBACKP(l)) - fbs = l; - } else { - SCHEME_FALLBACK_REST(fbs) = val; - break; - } - } else { - st2->multi_scopes = val; - break; - } - } - - if (prev) { - /* record accumulated shift for propagation */ - shift = add_shifts(((Scheme_Propagate_Table *)st)->phase_shift, shift); - if (!shift) - shift = scheme_box(scheme_false); /* i.e., the impossible shift */ - ((Scheme_Propagate_Table *)st2)->phase_shift = shift; - } - - return st2; -} - -static Scheme_Object *shift_scopes(Scheme_Object *o, Scheme_Object *shift, int prop_only, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Scope_Table *st, *p_st; - - if (prop_only) - st = stx->scopes; - else - st = shift_scope_table(stx->scopes, shift, shift_multi_scope, NULL, mutate); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - p_st = shift_scope_table((stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table), - shift, shift_prop_multi_scope, stx->scopes, - mutate); - else - p_st = NULL; - - if (SAME_OBJ(stx->scopes, st) - && (!(STX_KEY(stx) & STX_SUBSTX_FLAG) - || SAME_OBJ(stx->u.to_propagate, p_st))) - return (Scheme_Object *)stx; - - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - - stx->scopes = st; - if (p_st) - stx->u.to_propagate = p_st; - - return (Scheme_Object *)stx; -} - -static Scheme_Object *do_stx_add_shift(Scheme_Object *o, Scheme_Object *shift, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *vec, *shifts; - - if (!shift) return (Scheme_Object *)stx; - - if (SCHEME_PHASE_SHIFTP(shift)) { - if (SAME_OBJ(shift, scheme_make_integer(0))) - return (Scheme_Object *)stx; - return shift_scopes((Scheme_Object *)stx, shift, 0, mutate); - } - - if (SCHEME_VECTORP(shift) - && (SCHEME_VEC_SIZE(shift) == 6) - && (SCHEME_VEC_ELS(shift)[5] != scheme_make_integer(0))) { - /* Handle phase shift by itself, first: */ - stx = (Scheme_Stx *)do_stx_add_shift((Scheme_Object *)stx, SCHEME_VEC_ELS(shift)[5], mutate); - /* strip away phase shift: */ - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(shift)[0]; - SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(shift)[1]; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(shift)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(shift)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(shift)[4]; - SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(0); - shift = vec; - } - - /* Drop useless shift (identidy modidx shift and no inspector or exports): */ - if (SAME_OBJ(SCHEME_VEC_ELS(shift)[0], SCHEME_VEC_ELS(shift)[1]) - && ((SCHEME_VEC_SIZE(shift) <= 3) - || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[3])) - && ((SCHEME_VEC_SIZE(shift) <= 4) - || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[4]))) - return (Scheme_Object *)stx; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - /* Keep track of shifts that need to be propagated */ - vec = scheme_make_vector(3, NULL); - if (SCHEME_VECTORP(stx->shifts)) { - shifts = scheme_make_pair(shift, SCHEME_VEC_ELS(stx->shifts)[1]); - SCHEME_VEC_ELS(vec)[1] = shifts; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(stx->shifts)[2]; - shifts = SCHEME_VEC_ELS(stx->shifts)[0]; - } else { - shifts = scheme_make_pair(shift, scheme_null); - SCHEME_VEC_ELS(vec)[1] = shifts; - SCHEME_VEC_ELS(vec)[2] = stx->shifts; - shifts = stx->shifts; - } - shifts = scheme_make_pair(shift, shifts); - SCHEME_VEC_ELS(vec)[0] = shifts; - shifts = vec; - } else { - /* No need to propagate, so it's a simple addition. */ - shifts = scheme_make_pair(shift, stx->shifts); - } - - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - stx->shifts = shifts; - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && !stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift) -{ - int mutate = 0; - return do_stx_add_shift(o, shift, &mutate); -} - -Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *l) -{ - int mutate = 0; - - for (l = scheme_reverse(l); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - o = do_stx_add_shift(o, SCHEME_CAR(l), &mutate); - } - - return o; -} - -Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) -{ - Scheme_Object *exr; - - if (!phase_delta) - phase_delta = scheme_make_integer(0); - - if (!new_midx) { - old_midx = scheme_false; - new_midx = scheme_false; - } - if (!src_insp_desc) - src_insp_desc = scheme_false; - if (!insp) - insp = scheme_false; - if (!export_registry) - exr = scheme_false; - else - exr = (Scheme_Object *)export_registry; - - if (new_midx || export_registry || insp) { - Scheme_Object *vec; - - vec = last_phase_shift; - - if (vec - && (SCHEME_VEC_ELS(vec)[0] == old_midx) - && (SCHEME_VEC_ELS(vec)[1] == new_midx) - && (SCHEME_VEC_ELS(vec)[2] == src_insp_desc) - && (SCHEME_VEC_ELS(vec)[3] == insp) - && (SCHEME_VEC_ELS(vec)[4] == exr) - && (SCHEME_VEC_ELS(vec)[5] == phase_delta)) { - /* use the old one */ - } else { - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = old_midx; - SCHEME_VEC_ELS(vec)[1] = new_midx; - SCHEME_VEC_ELS(vec)[2] = src_insp_desc; - SCHEME_VEC_ELS(vec)[3] = insp; - SCHEME_VEC_ELS(vec)[4] = exr; - SCHEME_VEC_ELS(vec)[5] = phase_delta; - - last_phase_shift = vec; - } - - return last_phase_shift; - } else - return NULL; -} - -static int non_source_shift(Scheme_Object *vec) -{ - return SCHEME_BOXP(SCHEME_VEC_ELS(vec)[0]); -} - -void scheme_clear_shift_cache(void) -{ - int i; - - for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { - recent_scope_sets[0][i] = NULL; - recent_scope_sets[1][i] = NULL; - } - - last_phase_shift = NULL; - nominal_ipair_cache = NULL; - clear_binding_cache(); -} - -Scheme_Object *scheme_stx_shift(Scheme_Object *stx, - Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) -/* Shifts the modidx on a syntax object in a module as well as the phase of scopes. */ -{ - Scheme_Object *s; - - s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp); - if (s) - stx = scheme_stx_add_shift(stx, s); - - return stx; -} - -static Scheme_Object *shifts_to_non_source(Scheme_Object *shifts) { - Scheme_Object *l, *p, *last, *first, *vec, *vec2; - int i; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (!non_source_shift(SCHEME_CAR(l))) - break; - } - - if (SCHEME_NULLP(l)) - return shifts; - - last = NULL; - first = NULL; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - vec = SCHEME_CAR(l); - if (!non_source_shift(vec)) { - i = SCHEME_VEC_SIZE(vec); - vec2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i]; - } - vec = vec2; - vec2 = scheme_box(SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = vec2; - } - - p = scheme_make_pair(vec, scheme_null); - if (!first) - first = p; - else - SCHEME_CDR(last) = p; - last = p; - } - - return first; -} - -static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object *modidx, - Scheme_Object **_insp, Scheme_Hash_Table **_export_registry) -{ -#define QUICK_SHIFT_LEN 5 - Scheme_Object *vec, *dest, *src, *insp_desc; - Scheme_Object *quick_a[QUICK_SHIFT_LEN], **a; - intptr_t i, len; - - /* Strip away propagation layer, if any: */ - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - - if (_insp && *_insp) - insp_desc = *_insp; - else - insp_desc = scheme_false; - - /* The `shifts` list is in the reverse order that we want... */ - - len = scheme_list_length(shifts); - if (len <= QUICK_SHIFT_LEN) - a = quick_a; - else - a = MALLOC_N(Scheme_Object *, len); - - i = len; - while (!SCHEME_NULLP(shifts)) { - a[--i] = SCHEME_CAR(shifts); - shifts = SCHEME_CDR(shifts); - } - - if (_export_registry) - *_export_registry = NULL; - - for (i = 0; i < len; i++) { - vec = a[i]; - - src = SCHEME_VEC_ELS(vec)[0]; - dest = SCHEME_VEC_ELS(vec)[1]; - - if (SCHEME_BOXP(src)) - src = SCHEME_BOX_VAL(src); - - modidx = scheme_modidx_shift(modidx, src, dest); - - if (SCHEME_VEC_SIZE(vec) > 2) { - if (SCHEME_SYMBOLP(insp_desc) - && SAME_OBJ(insp_desc, SCHEME_VEC_ELS(vec)[2])) { - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[3])) - insp_desc = SCHEME_VEC_ELS(vec)[3]; - if (_export_registry - && (SCHEME_VEC_SIZE(vec) > 4) - && !SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[4])) - *_export_registry = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[4]; - } - } - } - - if (_insp && (!*_insp || !SCHEME_INSPECTORP(*_insp))) - *_insp = insp_desc; - - return modidx; -} - -static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-shift-phase-level", "syntax?", 0, argc, argv); - if (SCHEME_TRUEP(argv[1]) && !scheme_exact_p(argv[1])) - scheme_wrong_contract("syntax-shift-phase-level", "(or/c exact-integer? #f)", 0, argc, argv); - - if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1])) - return argv[0]; - - return scheme_stx_add_shift(argv[0], argv[1]); -} - -/******************** lazy propagation ********************/ - -#define DO_COUNT_PROPAGATES 0 -#if DO_COUNT_PROPAGATES -# define COUNT_PROPAGATES(x) x -int stx_shorts, stx_meds, stx_longs, stx_couldas; -#else -# define COUNT_PROPAGATES(x) /* empty */ -#endif - -XFORM_NONGCING static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) -/* We don't realy intern, but approximate interning by checking - against a small set of recently allocated scope sets. That's good - enough to find sharing for a deeply nested sequence of `let`s from - a many-argument `or`, for example, where the interleaving of - original an macro-introduced syntax prevents the usual - child-is-same-as-parent sharing detecting from working well - enough. */ -{ - int i; - Scheme_Scope_Set *s; - - if (!t->simple_scopes || !scope_set_count(t->simple_scopes)) - return; - - for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { - s = recent_scope_sets[prop_table][i]; - if (s) { - if (s == t->simple_scopes) - return; - if ((!prop_table && scopes_equal(s, t->simple_scopes)) - || (prop_table && scope_props_equal(s, t->simple_scopes))) { - t->simple_scopes = s; - return; - } - } - } - - recent_scope_sets[prop_table][recent_scope_sets_pos[prop_table]] = t->simple_scopes; - - recent_scope_sets_pos[prop_table] = ((recent_scope_sets_pos[prop_table] + 1) & (NUM_RECENT_SCOPE_SETS - 1)); -} - -static Scheme_Object *propagate_scope_set(Scheme_Scope_Set *props, Scheme_Object *o, - Scheme_Object *phase, int flag, - GC_CAN_IGNORE int *mutate) -{ - intptr_t i; - Scheme_Object *key, *val; - - i = scope_set_next(props, -1); - if (i != -1) { - do { - scope_set_index(props, i, &key, &val); - - STX_ASSERT(!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)); - - o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate); - - i = scope_set_next(props, i); - } while (i != -1); - - intern_scope_set(((Scheme_Stx *)o)->scopes, 0); - if (STX_KEY(((Scheme_Stx *)o)) & STX_SUBSTX_FLAG - && ((Scheme_Stx *)o)->u.to_propagate) - intern_scope_set(((Scheme_Stx *)o)->u.to_propagate, 1); - } - - return o; -} - -XFORM_NONGCING static int equiv_scope_tables(Scheme_Scope_Table *a, Scheme_Scope_Table *b) -/* try to cheaply detect equivalent tables to enable shortcuts */ -{ - if (a == b) - return 1; - - if (((a->simple_scopes == b->simple_scopes) - || (!scope_set_count(a->simple_scopes) - && !scope_set_count(b->simple_scopes))) - && SAME_OBJ(a->multi_scopes, b->multi_scopes)) - return 1; - - return 0; -} - -static Scheme_Object *propagate_scopes(Scheme_Object *o, Scheme_Scope_Table *to_propagate, - Scheme_Scope_Table *parent_scopes, int flag, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *key, *val, *fb; - - if (!to_propagate || (to_propagate == empty_propagate_table)) - return o; - - /* Check whether the child scopes currently match the - parent's scopes before the propagated changes: */ - if (!(flag & SCHEME_STX_PROPONLY) - && equiv_scope_tables(((Scheme_Propagate_Table *)to_propagate)->prev, stx->scopes)) { - /* Yes, so we can take a shortcut: child scopes still match parent. - Does the child need to propagate, and if so, does it just - get the parent's propagation? */ - if (!(STX_KEY(stx) & STX_SUBSTX_FLAG) - || !stx->u.to_propagate - || SAME_OBJ(stx->u.to_propagate, empty_propagate_table)) { - /* Yes, child matches the parent in all relevant dimensions */ - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - stx->scopes = parent_scopes; - *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - stx->u.to_propagate = to_propagate; - *mutate -= (*mutate & MUTATE_STX_PROP_TABLE); - } - COUNT_PROPAGATES(stx_shorts++); - return (Scheme_Object *)stx; - } else { - /* Child scopes match parent, so we don't need to reconstruct - the scope set, but we need to build a new propagation set - to augment the propagate set already here */ - flag |= SCHEME_STX_PROPONLY; - COUNT_PROPAGATES(stx_meds++); - } - } else { - COUNT_PROPAGATES(stx_longs++); - } - - val = ((Scheme_Propagate_Table *)to_propagate)->phase_shift; - if (!SAME_OBJ(val, scheme_make_integer(0))) { - o = shift_scopes(o, val, flag & SCHEME_STX_PROPONLY, mutate); - } - - o = propagate_scope_set(to_propagate->simple_scopes, o, scheme_true, flag, mutate); - - /* fallbacks here mean that we need to propagate fallback creations, - as well as propagating actions at each fallback layer: */ - - fb = to_propagate->multi_scopes; - if (SCHEME_FALLBACKP(fb)) { - /* reverse the fallback list so we can replay them in the right order: */ - key = scheme_null; - while (SCHEME_FALLBACKP(fb)) { - key = make_fallback_quad(SCHEME_FALLBACK_FIRST(fb), - key, - SCHEME_FALLBACK_SCOPE(fb), - SCHEME_FALLBACK_PHASE(fb)); - fb = SCHEME_FALLBACK_REST(fb); - } - fb = make_fallback_pair(fb, key); - } - - while (fb) { - if (SCHEME_FALLBACKP(fb)) { - if (SCHEME_FALLBACK_QUADP(fb)) { - o = stx_adjust_scope(o, SCHEME_FALLBACK_SCOPE(fb), SCHEME_FALLBACK_PHASE(fb), - SCHEME_STX_PUSH | flag, mutate); - } - key = SCHEME_FALLBACK_FIRST(fb); - } else - key = fb; - - for (; !SCHEME_NULLP(key); key = SCHEME_CDR(key)) { - val = SCHEME_CAR(key); - STX_ASSERT(SCHEME_MULTI_SCOPEP(SCHEME_VEC_ELS(val)[0])); - o = stx_adjust_scope(o, SCHEME_VEC_ELS(val)[0], SCHEME_VEC_ELS(val)[1], - SCHEME_INT_VAL(SCHEME_VEC_ELS(val)[2]) | flag, mutate); - } - - if (SCHEME_FALLBACKP(fb)) - fb = SCHEME_FALLBACK_REST(fb); - else - fb = NULL; - } - - if (flag & SCHEME_STX_PROPONLY) { - o = clone_stx(o, mutate); - ((Scheme_Stx *)o)->scopes = parent_scopes; - *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); - } - -#if DO_COUNT_PROPAGATES - if (!(flag & SCHEME_STX_PROPONLY)) { - if (scheme_equal((Scheme_Object *)parent_scopes->simple_scopes, - (Scheme_Object *)((Scheme_Stx *)o)->scopes->simple_scopes) - && scheme_equal(parent_scopes->multi_scopes, - ((Scheme_Stx *)o)->scopes->multi_scopes)) - stx_couldas++; - } -#endif - - return o; -} - -static Scheme_Object *propagate_shifts(Scheme_Object *result, Scheme_Object *shifts, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)result; - Scheme_Object *l; - - if (SAME_OBJ(stx->shifts, SCHEME_VEC_ELS(shifts)[2])) { - result = clone_stx(result, mutate); - stx = (Scheme_Stx *)result; - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG)) { - stx->shifts = shifts; - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - } else - stx->shifts = SCHEME_VEC_ELS(shifts)[0]; - return result; - } - - for (l = scheme_reverse(SCHEME_VEC_ELS(shifts)[1]); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - result = do_stx_add_shift(result, SCHEME_CAR(l), mutate); - } - - return result; -} - -static Scheme_Object *propagate(Scheme_Object *result, - Scheme_Scope_Table *to_propagate, - Scheme_Scope_Table *parent_scopes, - Scheme_Object *shifts, - int add_taint, Scheme_Object *false_insp) -{ - int mutate = 0; - - result = propagate_scopes(result, to_propagate, parent_scopes, 0, &mutate); - - if (shifts) - result = propagate_shifts(result, shifts, &mutate); - - if (add_taint) - result = add_taint_to_stx(result, &mutate); - else if (false_insp) - result = set_false_insp(result, false_insp, &mutate); - - return result; -} - -int propagate_count; - -static Scheme_Object *raw_stx_content(Scheme_Object *o) - /* Propagates wraps and taints while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - /* The fast-path tests are duplicated in jit.c. */ - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.to_propagate) { - Scheme_Object *v = stx->val, *result; - Scheme_Scope_Table *to_propagate; - Scheme_Object *false_insp, *shifts; - int add_taint; - - to_propagate = stx->u.to_propagate; - false_insp = stx->taints; - if (false_insp && SCHEME_VOIDP(false_insp)) { - add_taint = 1; - } else { - add_taint = 0; - if (false_insp) { - if (SCHEME_PAIRP(false_insp)) - false_insp = SCHEME_CAR(false_insp); - if (!SCHEME_INSPECTORP(false_insp)) - false_insp = NULL; - } - } - - shifts = stx->shifts; - if (!SCHEME_VECTORP(stx->shifts)) - shifts = NULL; - - if (SCHEME_PAIRP(v)) { - Scheme_Object *last = NULL, *first = NULL; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *p; - result = SCHEME_CAR(v); - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - p = scheme_make_pair(result, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - result = v; - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - if (last) - SCHEME_CDR(last) = result; - else - first = result; - } - v = first; - } else if (SCHEME_BOXP(v)) { - result = SCHEME_BOX_VAL(v); - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - v = scheme_box(result); - SCHEME_SET_BOX_IMMUTABLE(v); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2; - int size = SCHEME_VEC_SIZE(v), i; - - v2 = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - result = SCHEME_VEC_ELS(v)[i]; - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - SCHEME_VEC_ELS(v2)[i] = result; - } - - SCHEME_SET_VECTOR_IMMUTABLE(v2); - - v = v2; - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = propagate(val, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - v = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *r; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - - size = s->stype->num_slots; - for (i = 0; i < size; i++) { - r = s->slots[i]; - r = propagate(r, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - s->slots[i] = r; - } - - v = (Scheme_Object *)s; - } - - stx->u.to_propagate = NULL; - stx->val = v; - if (add_taint) { - /* if we're setting taints, we must be propagating - taints to touch; change "taints" to "propagated" or "none": */ - stx->taints = scheme_true; - } else if (false_insp) { - /* If we're propagating an inspector with no dye packs, - we're now done propagating. */ - if (!SCHEME_PAIRP(stx->taints)) - stx->taints = NULL; - } - if (shifts) - stx->shifts = SCHEME_VEC_ELS(shifts)[0]; - } - - return stx->val; -} - -Scheme_Object *scheme_stx_content(Scheme_Object *o) -/* Propagates wraps while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - if (!(STX_KEY(stx) & STX_ARMED_FLAG) || !is_armed((Scheme_Object *)stx)) - return raw_stx_content(o); - - /* force propagation: */ - raw_stx_content(o); - - /* taint */ - o = add_taint_to_stx(o, NULL); - - /* return tainted content */ - return raw_stx_content(o); -} - -/******************** taints ********************/ - -static Scheme_Object *taint_intern(Scheme_Object *v) -{ - Scheme_Bucket *b; - - scheme_start_atomic(); - b = scheme_bucket_from_table(taint_intern_table, (const char *)v); - scheme_end_atomic_no_swap(); - if (!b->val) - b->val = scheme_true; - v = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - - return v; -} - -static int is_tainted(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 0; - if (SCHEME_VOIDP(v) || SAME_OBJ(v, scheme_true)) return 1; - return 0; -} - -static int is_clean(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 1; - if (SCHEME_INSPECTORP(v)) return 1; - return 0; -} - -static int is_armed(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 0; - if (SCHEME_PAIRP(v)) return 1; - return 0; -} - -int scheme_stx_is_tainted(Scheme_Object *v) -{ - return is_tainted(v); -} - -int scheme_stx_is_clean(Scheme_Object *v) -{ - return is_clean(v); -} - -static int has_taint_arming(Scheme_Object *l, Scheme_Object *t, Scheme_Object *false_insp) -{ - Scheme_Object *a; - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SCHEME_FALSEP(a)) a = false_insp; - if (SAME_OBJ(a, t)) - return 1; - } - return 0; -} - -static Scheme_Object *add_taint_to_stx(Scheme_Object *o, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx; - - if (is_tainted(o)) - return o; - - o = clone_stx(o, mutate); - stx = (Scheme_Stx *)o; - stx->taints = scheme_void; /* taint to propagate */ - - /* Set to_propagate to indicate taint to propagate: */ - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - if (STX_KEY(stx) & STX_ARMED_FLAG) - STX_KEY(stx) -= STX_ARMED_FLAG; - } - - return o; -} - -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx; - - if (is_tainted(o)) - return o; - else if (is_armed(o)) { - if (SCHEME_TRUEP(SCHEME_CAR(((Scheme_Stx *)o)->taints))) - return o; - } else { - if (((Scheme_Stx *)o)->taints) - /* `taints' must be an inspector already */ - return o; - } - - o = clone_stx(o, mutate); - stx = (Scheme_Stx *)o; - if (stx->taints) - false_insp = taint_intern(scheme_make_pair(false_insp, SCHEME_CDR(stx->taints))); - - stx->taints = false_insp; - - /* Set lazy_prefix to indicate inspector to propagate: */ - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - } - - return o; -} - -static Scheme_Object *do_add_taint_armings_to_stx(Scheme_Object *o, Scheme_Object *taint_armings, int many, int need_clone) -/* If `many', `taint_armings' should be taint-interned. */ -{ - Scheme_Object *l, *taints, *new_taints, *false_insp, *alt_false_insp, *a; - Scheme_Stx *stx; - - taints = ((Scheme_Stx *)o)->taints; - if (taints) { - if (SAME_OBJ(taints, scheme_true) || SCHEME_VOIDP(taints)) - /* tainted */ - return o; - else if (SCHEME_INSPECTORP(taints)) { - false_insp = taints; - taints = NULL; - } else { - false_insp = SCHEME_CAR(taints); - taints = SCHEME_CDR(taints); - } - } else - false_insp = scheme_true; /* block future attempts to propagate a false_insp */ - - if (!taints) { - if (many) - new_taints = taint_armings; - else { - new_taints = taint_intern(scheme_make_pair(taint_armings, scheme_null)); - new_taints = taint_intern(scheme_make_pair(false_insp, new_taints)); - } - } else { - new_taints = taints; - - if (many) { - alt_false_insp = SCHEME_CAR(taint_armings); - taint_armings = SCHEME_CDR(taint_armings); - } else - alt_false_insp = scheme_false; - - for (l = taint_armings; !SCHEME_NULLP(l); ) { - a = many ? SCHEME_CAR(l) : l; - if (SCHEME_FALSEP(a)) a = alt_false_insp; - if (!has_taint_arming(new_taints, a, false_insp)) { - new_taints = taint_intern(scheme_make_pair(a, new_taints)); - } - if (many) - l = SCHEME_CDR(l); - else - l = scheme_null; - } - - if (SAME_OBJ(taints, new_taints)) - return o; - - new_taints = taint_intern(scheme_make_pair(false_insp, new_taints)); - } - - if (need_clone) - o = clone_stx(o, NULL); - stx = (Scheme_Stx *)o; - stx->taints = new_taints; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - STX_KEY(stx) |= STX_ARMED_FLAG; - - return o; -} - -static Scheme_Object *add_taint_arming_to_stx(Scheme_Object *o, Scheme_Object *taint, int need_clone) -{ - return do_add_taint_armings_to_stx(o, taint, 0, need_clone); -} - -static Scheme_Object *add_taint_armings_to_stx(Scheme_Object *o, Scheme_Object *taints, int need_clone) -{ - return do_add_taint_armings_to_stx(o, taints, 1, need_clone); -} - -Scheme_Object *scheme_stx_taint(Scheme_Object *o) -{ - return add_taint_to_stx(o, NULL); -} - -Scheme_Object *scheme_stx_taint_arm(Scheme_Object *o, Scheme_Object *insp) -{ - if (is_tainted(o)) - return o; - else - return add_taint_arming_to_stx(o, insp, 1); -} - -Scheme_Object *scheme_stx_taint_rearm(Scheme_Object *o, Scheme_Object *copy_from) -{ - if (is_tainted(o) || is_clean(copy_from)) - return o; - else if (is_tainted(copy_from)) - return add_taint_to_stx(o, NULL); - else - return add_taint_armings_to_stx(o, ((Scheme_Stx *)copy_from)->taints, 1); -} - - static int is_same_or_subinspector(Scheme_Object *sub, Scheme_Object *sup, Scheme_Object *false_insp) -{ - if (SCHEME_FALSEP(sub)) sub = false_insp; - if (SAME_OBJ(sub, sup)) return 1; - return scheme_is_subinspector(sub, sup); -} - -Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp) -{ - Scheme_Object *l, *l2, *a, *taint_armings, *false_insp; - - if (is_tainted(o) || is_clean(o)) - return o; - - taint_armings = ((Scheme_Stx *)o)->taints; - false_insp = SCHEME_CAR(taint_armings); - taint_armings = SCHEME_CDR(taint_armings); - - if (insp) { - for (l = taint_armings; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (is_same_or_subinspector(a, insp, false_insp)) { - break; - } - } - if (SCHEME_NULLP(l)) - return o; - - l2 = scheme_null; - for (l = taint_armings; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (!is_same_or_subinspector(a, insp, false_insp)) { - l2 = taint_intern(scheme_make_pair(a, l2)); - } - } - } else - l2 = scheme_null; - - o = clone_stx(o, NULL); - - if (SCHEME_NULLP(l2)) { - if (SCHEME_INSPECTORP(false_insp)) - ((Scheme_Stx *)o)->taints = false_insp; - else - ((Scheme_Stx *)o)->taints = NULL; - if (STX_KEY(((Scheme_Stx *)o)) & STX_ARMED_FLAG) - STX_KEY(((Scheme_Stx *)o)) -= STX_ARMED_FLAG; - } else { - l2 = taint_intern(scheme_make_pair(false_insp, l2)); - ((Scheme_Stx *)o)->taints = l2; - } - - return o; -} - -/******************** bindings ********************/ - -XFORM_NONGCING static Scheme_Scope *extract_max_scope(Scheme_Scope_Set *scopes) -{ - intptr_t i; - Scheme_Object *key, *val; - Scheme_Scope *scope; - mzlonglong scope_id_val, id_val; - - i = scope_set_next(scopes, -1); - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - scope_id_val = scope->id; - - i = scope_set_next(scopes, i); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - id_val = ((Scheme_Scope *)key)->id; - if (id_val > scope_id_val) { - scope = (Scheme_Scope *)key; - scope_id_val = id_val; - } - - i = scope_set_next(scopes, i); - } - - return scope; -} - -#define SCHEME_BINDING_SCOPES(p) ((Scheme_Scope_Set *)SCHEME_CAR(p)) -#define SCHEME_BINDING_VAL(p) SCHEME_CDR(p) - -#define SCHEME_VEC_BINDING_KEY(p) (SCHEME_VEC_ELS(p)[0]) -#define SCHEME_VEC_BINDING_SCOPES(p) ((Scheme_Scope_Set *)(SCHEME_VEC_ELS(p)[1])) -#define SCHEME_VEC_BINDING_VAL(p) (SCHEME_VEC_ELS(p)[2]) - -#define CONV_RETURN_UNLESS(p) if (!p) return - -static void check_for_conversion(Scheme_Object *sym, - Scheme_Scope *scope, - Scheme_Module_Phase_Exports *pt, - Scheme_Hash_Table *collapse_table, - Scheme_Hash_Tree *ht, - Scheme_Scope_Set *scopes, - Scheme_Object *phase, - Scheme_Object *bind) -/* Due to `require` macros, importing a whole module can turn into - individual imports from the module. Detect when everything that a - module exports (at a given phase) is imported as a set of bindings, - and collapse them to a bulk-import "pes". */ -{ - Scheme_Hash_Table *mht; - Scheme_Object *v, *v2, *cnt; - int i; - - mht = (Scheme_Hash_Table *)scheme_eq_hash_get(collapse_table, (Scheme_Object *)scope); - if (!mht) { - mht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(collapse_table, (Scheme_Object *)scope, (Scheme_Object *)mht); - } - - cnt = scheme_eq_hash_get(mht, (Scheme_Object *)pt); - if (!cnt) - cnt = scheme_make_integer(1); - else - cnt = scheme_bin_plus(cnt, scheme_make_integer(1)); - scheme_hash_set(mht, (Scheme_Object *)pt, cnt); - - if (bind && (SCHEME_INT_VAL(cnt) == pt->num_provides)) { - Scheme_Object *modidx, *modidx2, *insp_desc, *insp_desc2, *src_phase; - Scheme_Object *exportname, *nominal_modidx, *nominal_modidx2, *mod_phase, *nominal_name; - Scheme_Object *nominal_src_phase; - Scheme_Object *pes; - - nominal_modidx = NULL; - - extract_module_binding_parts(SCHEME_BINDING_VAL(bind), phase, - &insp_desc, - &modidx, - &exportname, - &nominal_modidx, - &mod_phase, - NULL, - NULL, - NULL); - - if (!nominal_modidx) - nominal_modidx = modidx; - - /* since we've mapped N identifiers from a source of N identifiers, - maybe we mapped all of them. */ - for (i = pt->num_provides; i--; ) { - v2 = scheme_eq_hash_tree_get(ht, pt->provides[i]); - CONV_RETURN_UNLESS(v2); - - /* For now, allow only a single binding: */ - CONV_RETURN_UNLESS(SCHEME_PAIRP(v2) - || (SCHEME_MPAIRP(v2) && SCHEME_NULLP(SCHEME_CDR(v2)))); - if (SCHEME_MPAIRP(v2)) - v2 = SCHEME_CAR(v2); - - CONV_RETURN_UNLESS(scopes_equal(scopes, SCHEME_BINDING_SCOPES(v2))); - - /* Pull apart module bindings to make sure they're consistent: */ - exportname = pt->provides[i]; - nominal_modidx2 = NULL; - mod_phase = pt->phase_index; - nominal_name = exportname; - src_phase = scheme_make_integer(0); - nominal_src_phase = NULL; - mod_phase = pt->phase_index; - - extract_module_binding_parts(SCHEME_BINDING_VAL(v2), phase, - &insp_desc2, - &modidx, - &exportname, - &nominal_modidx2, - &mod_phase, - &nominal_name, - &src_phase, - &nominal_src_phase); - - if (!nominal_modidx2) - nominal_modidx2 = modidx; - if (!nominal_src_phase) - nominal_src_phase = mod_phase; - - CONV_RETURN_UNLESS(SAME_OBJ(insp_desc2, insp_desc)); - modidx2 = (pt->provide_srcs ? pt->provide_srcs[i] : scheme_false); - if (SCHEME_FALSEP(modidx2)) - modidx2 = nominal_modidx; - else if (pt->src_modidx) - modidx2 = scheme_modidx_shift(modidx2, pt->src_modidx, nominal_modidx); - CONV_RETURN_UNLESS(scheme_equal(modidx, modidx2)); - CONV_RETURN_UNLESS(SAME_OBJ(exportname, pt->provide_src_names[i])); - CONV_RETURN_UNLESS(scheme_equal(nominal_modidx2, nominal_modidx)); - CONV_RETURN_UNLESS(scheme_eqv(mod_phase, (pt->provide_src_phases - ? scheme_make_integer(pt->provide_src_phases[i]) - : pt->phase_index))); - CONV_RETURN_UNLESS(SAME_OBJ(nominal_name, pt->provides[i])); - CONV_RETURN_UNLESS(scheme_eqv(src_phase, phase)); - CONV_RETURN_UNLESS(scheme_eqv(nominal_src_phase, pt->phase_index)); - } - - /* found a match; convert to a pes: */ - pes = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(pes)[0] = nominal_modidx; - SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; - SCHEME_VEC_ELS(pes)[2] = phase; - SCHEME_VEC_ELS(pes)[3] = pt->phase_index; - SCHEME_VEC_ELS(pes)[4] = insp_desc; - - bind = scheme_make_pair((Scheme_Object *)scopes, pes); - - /* install pes: */ - v = scope->bindings; - if (!SCHEME_RPAIRP(v)) { - STX_ASSERT(SCHEME_HASHTRP(v)); - v = scheme_make_raw_pair(v, NULL); - scope->bindings = v; - } - v = scheme_make_raw_pair(bind, SCHEME_CDR(v)); - SCHEME_CDR(scope->bindings) = v; - - /* remove per-symbol bindings: */ - for (i = pt->num_provides; i--; ) { - ht = scheme_hash_tree_set(ht, pt->provides[i], NULL); - } - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - } -} - -static Scheme_Object *replace_matching_scopes(Scheme_Object *l, Scheme_Scope_Set *scopes) -/* Takes a list of scope--value pairs for a binding table and removes - any match to `scopes` */ -{ - Scheme_Object *p; - int c = 0; - - if (SCHEME_PAIRP(l)) { - /* only one item to check */ - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(l))) - return NULL; - else - return l; - } - - for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { - break; - } - c++; - } - - if (SCHEME_NULLP(p)) - return l; - - p = SCHEME_CDR(p); - while (c--) { - p = scheme_make_mutable_pair(SCHEME_CAR(l), p); - l = SCHEME_CDR(l); - } - - /* down to one item? */ - if (SCHEME_NULLP(SCHEME_CDR(p))) - return SCHEME_CAR(p); - - /* no items? */ - if (SCHEME_NULLP(p)) - return NULL; - - return p; -} - -static void clear_matching_bindings(Scheme_Object *pes, - Scheme_Scope_Set *scopes, - Scheme_Object *l) -/* a new bulk import needs to override any individual imports; this - should only matter for top-level interactions, since modules only - allow shadowing of the initial bulk import */ -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - Scheme_Module_Phase_Exports *pt; - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)SCHEME_CAR(l), *new_ht; - Scheme_Object *key, *val, *new_val; - intptr_t i; - - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - scheme_populate_pt_ht(pt); - } - - new_ht = ht; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if ((ht->count < pt->ht->count) - || SCHEME_TRUEP(prefix) - || excepts) { - /* faster to scan per-symbol binding table */ - i = -1; - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(key, pes))) { - new_val = replace_matching_scopes(val, scopes); - if (!SAME_OBJ(val, new_val)) - new_ht = scheme_hash_tree_set(new_ht, key, new_val); - } - } - } else { - /* faster to scan export table */ - for (i = pt->ht->size; i--; ) { - if (pt->ht->vals[i]) { - key = pt->ht->keys[i]; - val = scheme_eq_hash_tree_get(new_ht, key); - if (val) { - new_val = replace_matching_scopes(val, scopes); - if (!SAME_OBJ(val, new_val)) - new_ht = scheme_hash_tree_set(new_ht, key, new_val); - } - } - } - } - - if (!SAME_OBJ(new_ht, ht)) - SCHEME_CAR(l) = (Scheme_Object *)new_ht; -} - -XFORM_NONGCING static void save_old_value(Scheme_Object *mp, Scheme_Object *old_val) -{ - if (SCHEME_MPAIRP(old_val)) - SCHEME_CAR(mp) = SCHEME_CAR(old_val); - else - SCHEME_CAR(mp) = old_val; -} - -static void add_binding(Scheme_Object *sym, Scheme_Object *phase, Scheme_Scope_Set *scopes, - Scheme_Object *val, - Scheme_Module_Phase_Exports *from_pt, /* to detect collapse conversion */ - Scheme_Hash_Table *collapse_table) /* to triggere collapse detection */ -/* `val` can be a symbol (local binding), a modidx/pair/#f - (module/global binding), a shared-binding vector (i.e., a pes), or - a syntax object (for a `free-identifier=?` equivalence) to be - mutable-paired with the existing binding; the `sym` argument should - be NULL when `val` is a shared-binding vector */ - -{ - Scheme_Hash_Tree *ht; - Scheme_Scope *scope; - Scheme_Object *l, *p, *bind; - - if (scope_set_count(scopes)) { - /* We add the binding to the maximum-valued scope, because it's - likely to be in the least number of binding sets so far. */ - scope = extract_max_scope(scopes); - if (SAME_OBJ((Scheme_Object*)scope, root_scope)) - scheme_signal_error("internal error: cannot bind with only a root scope"); - } else { - scheme_signal_error("internal error: cannot bind identifier with an empty context"); - return; - } - STX_ASSERT(SCHEME_STXP(val) - || SCHEME_FALSEP(val) - || SCHEME_MODIDXP(val) - || SCHEME_PAIRP(val) - || SCHEME_VECTORP(val) - || SCHEME_SYMBOLP(val)); - - if (SCHEME_STXP(val)) - val = scheme_make_mutable_pair(scheme_false, scheme_make_pair(val, phase)); - - l = scope->bindings; - if (!l) { - if (sym) { - /* simple case: a single binding */ - STX_ASSERT(SCHEME_SYMBOLP(sym)); - bind = make_vector3(sym, (Scheme_Object *)scopes, val); - scope->bindings = bind; - clear_binding_cache_for(sym); - if (from_pt) { - /* don't convert, but record addition for potential conversion */ - check_for_conversion(sym, scope, from_pt, collapse_table, NULL, scopes, phase, NULL); - } - return; - } - ht = empty_hash_tree; - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } else if (SCHEME_VECTORP(l)) { - /* convert simple case to more general case */ - ht = scheme_hash_tree_set(empty_hash_tree, - SCHEME_VEC_BINDING_KEY(l), - scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(l), - SCHEME_VEC_BINDING_VAL(l))); - if (sym) { - /* more complex case: table of bindings */ - scope->bindings = (Scheme_Object *)ht; - } else { - /* need most complex form */ - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } - } else if (SCHEME_RPAIRP(l)) { - /* already in complex form */ - ht = (Scheme_Hash_Tree *)SCHEME_CAR(l); - } else { - STX_ASSERT(SCHEME_HASHTRP(l)); - ht = (Scheme_Hash_Tree *)l; - if (!sym) { - /* need most complex form */ - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } - } - - bind = scheme_make_pair((Scheme_Object *)scopes, val); - - if (sym) { - STX_ASSERT(SCHEME_SYMBOLP(sym)); - clear_binding_cache_for(sym); - l = scheme_eq_hash_tree_get(ht, sym); - if (!l) { - ht = scheme_hash_tree_set(ht, sym, bind); - if (SCHEME_RPAIRP(scope->bindings)) - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - else - scope->bindings = (Scheme_Object *)ht; - } else { - if (!SCHEME_MPAIRP(l)) - l = scheme_make_mutable_pair(l, scheme_null); - for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { - if (SCHEME_MPAIRP(val)) - save_old_value(val, SCHEME_BINDING_VAL(SCHEME_CAR(p))); - SCHEME_CAR(p) = bind; - break; - } - } - if (SCHEME_NULLP(p)) { - l = scheme_make_mutable_pair(bind, l); - ht = scheme_hash_tree_set(ht, sym, l); - } else if (SCHEME_NULLP(SCHEME_CDR(l))) { - ht = scheme_hash_tree_set(ht, sym, SCHEME_CAR(l)); - from_pt = NULL; /* single binding; no benefit from pes conversion */ - } - - if (SCHEME_RPAIRP(scope->bindings)) - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - else - scope->bindings = (Scheme_Object *)ht; - } - if (from_pt) - check_for_conversion(sym, scope, from_pt, collapse_table, ht, scopes, phase, bind); - } else { - /* Order matters: the new bindings should hide any existing bindings for the same name. */ - clear_binding_cache(); - p = scheme_make_raw_pair(bind, SCHEME_CDR(l)); - SCHEME_CDR(l) = p; - - /* Remove any matching mappings form the hash table, since it gets checked first. */ - clear_matching_bindings(val, scopes, l); - } -} - -void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - STX_ASSERT(SCHEME_SYMBOLP(binding_sym)); - - add_binding(stx->val, phase, extract_scope_set(stx, phase), binding_sym, NULL, NULL); -} - -static void do_add_module_binding(Scheme_Scope_Set *scopes, Scheme_Object *localname, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *exname, Scheme_Object *defn_phase, - Scheme_Object *insp_desc, - Scheme_Object *nominal_mod, Scheme_Object *nominal_ex, - Scheme_Object *src_phase, - Scheme_Object *nom_phase, - Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table) -{ - Scheme_Object *elem; - int mod_phase; - - if (SCHEME_FALSEP(modidx)) { - if (SAME_OBJ(localname, exname)) - add_binding(localname, phase, scopes, scheme_false, NULL, NULL); - else - add_binding(localname, phase, scopes, scheme_make_pair(scheme_false, exname), NULL, NULL); - return; - } - - STX_ASSERT(SCHEME_MODIDXP(modidx)); - - /* - This encoding is meant to be progressively less compact for - progressively less-common cases: - - binding ::= mod_binding - . | (cons inspector-desc mod_binding) - mod_binding ::= modidx ; mod-phase = 0 - . | (cons modidx exportname) - . | (cons modidx nominal_modidx) - . | (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) - . | (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) - nominal_modix_plus_phase ::= nominal_modix ; import-phase-level is 0, nom-phase = mod-phase - . | (cons nominal_modix import_phase_plus_nominal_phase) - import_phase_plus_nominal_phase ::= import-phase-level ; nom-phase = mod-phase - . | (cons import-phase-level nom-phase) - inspector-desc = inspector - . | symbol - */ - - mod_phase = SCHEME_INT_VAL(defn_phase); - - if (!src_phase) - src_phase = phase; - if (!nom_phase) - nom_phase = scheme_make_integer(mod_phase); - - if (SAME_OBJ(modidx, nominal_mod) - && SAME_OBJ(exname, nominal_ex) - && !mod_phase - && same_phase(src_phase, scheme_make_integer(0)) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (SAME_OBJ(localname, exname)) - elem = modidx; - else - elem = CONS(modidx, exname); - } else if (SAME_OBJ(exname, nominal_ex) - && SAME_OBJ(localname, exname) - && !mod_phase - && same_phase(src_phase, scheme_make_integer(0)) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - /* It's common that a sequence of similar mappings shows up, - e.g., '(#%kernel . mzscheme) */ - if (nominal_ipair_cache - && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modidx) - && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) - elem = nominal_ipair_cache; - else { - elem = ICONS(modidx, nominal_mod); - nominal_ipair_cache = elem; - } - } else { - if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (same_phase(src_phase, scheme_make_integer(0))) - elem = nominal_mod; - else - elem = CONS(nominal_mod, src_phase); - } else { - elem = CONS(nominal_mod, CONS(src_phase, nom_phase)); - } - elem = CONS(exname, CONS(elem, nominal_ex)); - if (mod_phase) - elem = CONS(scheme_make_integer(mod_phase), elem); - elem = CONS(modidx, elem); - } - - if (!SCHEME_FALSEP(insp_desc)) - elem = CONS(insp_desc, elem); - - add_binding(localname, phase, scopes, elem, from_pt, collapse_table); -} - -void extract_module_binding_parts(Scheme_Object *l, - Scheme_Object *phase, - Scheme_Object **_insp_desc, /* required */ - Scheme_Object **_modidx, /* required */ - Scheme_Object **_exportname, /* required, maybe unset */ - Scheme_Object **_nominal_modidx, /* maybe unset */ - Scheme_Object **_mod_phase, /* required, maybe unset */ - Scheme_Object **_nominal_name, /* maybe unset */ - Scheme_Object **_src_phase, /* maybe unset */ - Scheme_Object **_nominal_src_phase) /* maybe unset */ -/* unpack an encodings created by do_add_module_binding() */ -{ - if (SCHEME_PAIRP(l) - && SCHEME_INSPECTOR_DESCP(SCHEME_CAR(l))) { - *_insp_desc = SCHEME_CAR(l); - l = SCHEME_CDR(l); - } else - *_insp_desc = scheme_false; - - if (SCHEME_MODIDXP(l)) - *_modidx = l; - else { - *_modidx = SCHEME_CAR(l); - l = SCHEME_CDR(l); - - if (SCHEME_SYMBOLP(l)) { - /* l is exportname */ - *_exportname = l; - } else if (SCHEME_MODIDXP(l)) { - /* l is nominal_modidx */ - if (_nominal_modidx) *_nominal_modidx = l; - } else { - if (SCHEME_INTP(SCHEME_CAR(l)) || SCHEME_BIGNUMP(SCHEME_CAR(l))) { - /* mod-phase before rest */ - *_mod_phase = SCHEME_CAR(l); - l = SCHEME_CDR(l); - } - - /* l is (list* exportname nominal_modidx_plus_phase nominal_exportname) */ - *_exportname = SCHEME_CAR(l); - l = SCHEME_CDR(l); - if (_nominal_name) - *_nominal_name = SCHEME_CDR(l); - l = SCHEME_CAR(l); - /* l is nominal_modidx_plus_phase */ - if (SCHEME_PAIRP(l)) { - if (_nominal_modidx) *_nominal_modidx = SCHEME_CAR(l); - l = SCHEME_CDR(l); - if (SCHEME_PAIRP(l)) { - if (_src_phase) *_src_phase = SCHEME_CAR(l); - if (_nominal_src_phase) *_nominal_src_phase = SCHEME_CDR(l); - } else { - if (_src_phase) *_src_phase = l; - if (_nominal_src_phase) *_nominal_src_phase = *_mod_phase; - } - } else { - if (_nominal_modidx) *_nominal_modidx = l; - } - } - } -} - -void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *inspector, - Scheme_Object *sym, Scheme_Object *defn_phase) -{ - STX_ASSERT(SCHEME_SYMBOLP(((Scheme_Stx *)o)->val)); - - do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, - modidx, sym, defn_phase, - inspector, - modidx, sym, - NULL, NULL, - NULL, NULL); -} - -void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, - Scheme_Object *inspector, - Scheme_Object *nominal_mod, Scheme_Object *nominal_name, - Scheme_Object *nominal_import_phase, - Scheme_Object *nominal_export_phase, - Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table) -{ - STX_ASSERT(SCHEME_STXP(o)); - do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, - modidx, defn_name, defn_phase, - inspector, - nominal_mod, nominal_name, - nominal_import_phase, nominal_export_phase, - from_pt, collapse_table); -} - -/******************** debug-info ********************/ - -static Scheme_Object *scopes_to_printed_list(Scheme_Scope_Set *scopes) -{ - Scheme_Object *l, *val, *key; - - l = scopes_to_sorted_list(scopes); - val = scheme_null; - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - key = SCHEME_CAR(l); - val = scheme_make_pair(scheme_scope_printed_form(key), val); - } - - return val; -} - -Scheme_Object *add_bindings_info(Scheme_Object *bindings, Scheme_Object *key, Scheme_Object *l, - Scheme_Stx *stx, int all_bindings, Scheme_Object *seen) -{ - Scheme_Hash_Tree *bind_desc; - Scheme_Object *val; - - if (SCHEME_PAIRP(l)) { - l = scheme_make_mutable_pair(l, scheme_null); - } - - while (!SCHEME_NULLP(l)) { - if (all_bindings || SAME_OBJ(key, stx->val)) { - bind_desc = empty_hash_tree; - bind_desc = scheme_hash_tree_set(bind_desc, name_symbol, key); - - val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(val)) { - bind_desc = scheme_hash_tree_set(bind_desc, free_symbol, - stx_debug_info((Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)), - SCHEME_CDR(SCHEME_CDR(val)), - scheme_make_pair((Scheme_Object *)stx, seen), - all_bindings)); - val = SCHEME_CAR(val); - } - - if (SCHEME_SYMBOLP(val)) - bind_desc = scheme_hash_tree_set(bind_desc, local_symbol, val); - else { - if (SCHEME_PAIRP(val)) { - if (SCHEME_INSPECTOR_DESCP(SCHEME_CAR(val))) - val = SCHEME_CDR(val); - val = SCHEME_CAR(val); - } - if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); - bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); - } - - bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, - scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); - - bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); - } - - l = SCHEME_CDR(l); - } - - return bindings; -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *stx_debug_info_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Stx *stx = (Scheme_Stx *)p->ku.k.p1; - Scheme_Object *phase = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *seen = (Scheme_Object *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return stx_debug_info(stx, phase, seen, p->ku.k.i1); -} -#endif - -static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings) -{ - Scheme_Hash_Tree *desc, *bind_desc; - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *l, *pes, *descs = scheme_null, *bindings; - intptr_t i, j; - Scheme_Scope *scope; - Scheme_Scope_Set *scopes; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *multi_scopes; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)stx; - p->ku.k.p2 = (void *)phase; - p->ku.k.p3 = (void *)seen; - p->ku.k.i1 = all_bindings; - - return scheme_handle_stack_overflow(stx_debug_info_k); - } - } -#endif - - { - int up = 0; - for (l = seen; !SCHEME_NULLP(l); l = SCHEME_CDR(l), up++) { - if (SAME_OBJ((Scheme_Object *)stx, SCHEME_CAR(l))) { - return scheme_make_pair(cycle_symbol, - scheme_make_pair(scheme_make_integer(up), - scheme_null)); - } - } - } - - multi_scopes = stx->scopes->multi_scopes; - - /* Loop for top-level fallbacks: */ - while (1) { - scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); - - desc = empty_hash_tree; - - if (SCHEME_SYMBOLP(stx->val)) - desc = scheme_hash_tree_set(desc, name_symbol, stx->val); - desc = scheme_hash_tree_set(desc, context_symbol, scopes_to_printed_list(scopes)); - - /* Describe other bindings */ - bindings = scheme_null; - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - if (SCHEME_VECTORP(scope->bindings)) { - l = scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(scope->bindings), - SCHEME_VEC_BINDING_VAL(scope->bindings)); - bindings = add_bindings_info(bindings, SCHEME_VEC_BINDING_KEY(scope->bindings), l, - stx, all_bindings, seen); - l = NULL; - } else { - l = scope->bindings; - if (SCHEME_RPAIRP(l)) - ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); - else { - STX_ASSERT(SCHEME_HASHTRP(l)); - ht = (Scheme_Hash_Tree *)l; - } - - j = -1; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, &val); - bindings = add_bindings_info(bindings, key, val, stx, all_bindings, seen); - } - - l = scope->bindings; - if (SCHEME_RPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - } - - while (l) { - STX_ASSERT(SCHEME_RPAIRP(l)); - - bind_desc = empty_hash_tree; - - bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, - scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); - - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - val = SCHEME_VEC_ELS(pes)[0]; - if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); - bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); - - if (PES_UNMARSHAL_DESCP(pes)) { - /* unmarshal hasn't happened */ - } else { - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) - scheme_populate_pt_ht(pt); - - if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) - bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_true); - else - bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_false); - } - - bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); - - l = SCHEME_CDR(l); - } - } - - i = scope_set_next(scopes, i); - } - - if (!SCHEME_NULLP(bindings)) - desc = scheme_hash_tree_set(desc, bindings_symbol, scheme_reverse(bindings)); - - descs = scheme_make_pair((Scheme_Object *)desc, descs); - - if (SCHEME_FALLBACKP(multi_scopes)) { - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - } else - break; - } - - if (SCHEME_NULLP(SCHEME_CDR(descs))) - return SCHEME_CAR(descs); - else { - descs = scheme_reverse(descs); - return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)SCHEME_CAR(descs), - fallbacks_symbol, - SCHEME_CDR(descs)); - } -} - -void scheme_stx_debug_print(Scheme_Object *_stx, Scheme_Object *phase, int level) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *info; - - STX_ASSERT(SCHEME_STXP(_stx)); - - info = stx_debug_info(stx, phase, scheme_null, level > 1); - if (!level) { - info = scheme_hash_tree_get((Scheme_Hash_Tree *)info, context_symbol); - if (!info) info = scheme_false; - } - - printf("%s at phase %s:\n", - scheme_write_to_string(stx->val, NULL), - scheme_write_to_string(phase, NULL)); - printf(" %s\n", - scheme_write_to_string(info, NULL)); -} - -static void fprint_string(Scheme_Object *o, const char *s) -{ - (void)scheme_put_byte_string("describe", o, s, 0, strlen(s), 1); -} - -static void fprint_label_string(Scheme_Object *o, int rename_level, Scheme_Object *rename_sym, const char *s) -{ - fprint_string(o, "\n "); - if (rename_level) { - while (rename_level--) { - fprint_string(o, "="); - } - fprint_string(o, "> "); - scheme_write(rename_sym, o); - fprint_string(o, " "); - } - fprint_string(o, s); -} - -static void write_context(Scheme_Object *l, Scheme_Object *o) -{ - intptr_t col = 2, len; - char *s; - - while (!SCHEME_NULLP(l)) { - s = scheme_write_to_string(SCHEME_CAR(l), &len); - if ((col > 2) && (col + len + 1 > 80)) { - col = 2; - fprint_string(o, "\n "); - } - fprint_string(o, " "); - scheme_put_byte_string("describe", o, s, 0, len, 1); - col += len; - - l = SCHEME_CDR(l); - } -} - -static int context_matches(Scheme_Object *l1, Scheme_Object *l2) -/* Check whether the sorted list l2 is a subset of the sorted list l1 */ -{ - while (!SCHEME_NULLP(l2)) { - if (SCHEME_NULLP(l1)) - return 0; - - if (scheme_equal(SCHEME_CAR(l1), SCHEME_CAR(l2))) { - l1 = SCHEME_CDR(l1); - l2 = SCHEME_CDR(l2); - } else - l1 = SCHEME_CDR(l1); - } - - return 1; -} - -static Scheme_Object *describe_bindings(Scheme_Object *o, Scheme_Object *di, - int rename_level, Scheme_Object *rename_sym, - int always) -{ - Scheme_Object *l, *report, *val, *free_id; - Scheme_Hash_Tree *dit, *bt; - int fallback; - - fallback = 0; - while (!SCHEME_NULLP(di)) { - if (SCHEME_PAIRP(di)) - dit = (Scheme_Hash_Tree *)SCHEME_CAR(di); - else - dit = (Scheme_Hash_Tree *)di; - - l = scheme_hash_tree_get(dit, bindings_symbol); - if (l) { - report = scheme_null; - while (!SCHEME_NULLP(l)) { - bt = (Scheme_Hash_Tree *)SCHEME_CAR(l); - - val = scheme_hash_tree_get(bt, matchp_symbol); - - if ((val && SCHEME_TRUEP(val)) - || scheme_hash_tree_get(bt, name_symbol)) - report = scheme_make_pair((Scheme_Object *)bt, report); - - l = SCHEME_CDR(l); - } - - if (!SCHEME_NULLP(report) || always) { - if (!o) - o = scheme_make_byte_string_output_port(); - - fprint_label_string(o, rename_level, rename_sym, "context"); - if (fallback) { - fprint_string(o, " at layer "); - scheme_display(scheme_make_integer(fallback), o); - } - fprint_string(o, "...:\n "); - write_context(scheme_hash_tree_get(dit, context_symbol), o); - - while (!SCHEME_NULLP(report)) { - bt = (Scheme_Hash_Tree *)SCHEME_CAR(report); - - if (context_matches(scheme_hash_tree_get(dit, context_symbol), - scheme_hash_tree_get(bt, context_symbol))) - fprint_label_string(o, rename_level, rename_sym, "matching binding"); - else - fprint_label_string(o, rename_level, rename_sym, "other binding"); - if (fallback) { - fprint_string(o, " at layer "); - scheme_display(scheme_make_integer(fallback), o); - } - fprint_string(o, "...:\n "); - val = scheme_hash_tree_get(bt, module_symbol); - if (!val) { - fprint_string(o, "local "); - val = scheme_hash_tree_get(bt, local_symbol); - } - scheme_write(val, o); - fprint_string(o, "\n "); - write_context(scheme_hash_tree_get(bt, context_symbol), o); - - free_id = scheme_hash_tree_get(bt, free_symbol); - if (free_id) { - fprint_string(o, "\n free-identifier=? to "); - if (SCHEME_PAIRP(free_id) - && SAME_OBJ(SCHEME_CAR(free_id), cycle_symbol)) { - int up = SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CDR(free_id))); - if (!up) - fprint_string(o, "[cycle to self]"); - else { - fprint_string(o, "[cycle, up "); - scheme_write(scheme_make_integer(up), o); - fprint_string(o, " levels]"); - } - } else { - if (SCHEME_HASHTRP(free_id)) - val = scheme_hash_tree_get((Scheme_Hash_Tree *)free_id, name_symbol); - else - val = NULL; - if (val) { - scheme_write(val, o); - o = describe_bindings(o, free_id, rename_level + 1, val, always); - } else { - fprint_string(o, "[unknown]"); - } - } - } - - report = SCHEME_CDR(report); - } - } - } - - if (SCHEME_PAIRP(di)) - di = SCHEME_CDR(di); - else { - di = scheme_hash_tree_get(dit, fallbacks_symbol); - if (!di) - di = scheme_null; - } - fallback++; - } - - return o; -} - -char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always) -{ - Scheme_Object *di, *o = NULL; - intptr_t len; - char *r; - - if (!stx) - return ""; - - di = stx_debug_info((Scheme_Stx *)stx, phase, scheme_null, 0); - - o = describe_bindings(o, di, 0, NULL, always); - - if (o) { - r = scheme_get_sized_byte_string_output(o, &len); - /* make sure error buffer is allocated large enough: */ - scheme_ensure_max_symbol_length(len); - return r; - } - else - return ""; -} - -static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Object *shifts, Scheme_Hash_Table *mapped) -{ - int retry; - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *l, *pes; - intptr_t i, j; - Scheme_Scope *scope; - Scheme_Scope_Set *binding_scopes; - Scheme_Module_Phase_Exports *pt; - - do { - retry = 0; - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - if (SCHEME_VECTORP(scope->bindings)) { - if (scope_subset(SCHEME_VEC_BINDING_SCOPES(scope->bindings), scopes)) - scheme_hash_set(mapped, SCHEME_VEC_BINDING_KEY(scope->bindings), scheme_true); - } else { - /* Check table of symbols */ - if (SCHEME_RPAIRP(scope->bindings)) - ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); - else { - STX_ASSERT(SCHEME_HASHTRP(scope->bindings)); - ht = (Scheme_Hash_Tree *)scope->bindings; - } - j = -1; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, &val); - l = val; - if (l) { - if (SCHEME_PAIRP(l)) { - if (scope_subset(SCHEME_BINDING_SCOPES(l), scopes)) - scheme_hash_set(mapped, key, scheme_true); - } else { - while (!SCHEME_NULLP(l)) { - STX_ASSERT(SCHEME_MPAIRP(l)); - if (scope_subset(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), scopes)) { - scheme_hash_set(mapped, key, scheme_true); - break; - } - l = SCHEME_CDR(l); - } - } - } - } - } - - /* Check list of shared-binding tables */ - if (SCHEME_RPAIRP(scope->bindings)) - l = SCHEME_CDR(scope->bindings); - else - l = NULL; - while (l) { - STX_ASSERT(SCHEME_RPAIRP(l)); - binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - if (scope_subset(binding_scopes, scopes)) { - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (PES_UNMARSHAL_DESCP(pes)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { - unmarshal_module_context_additions(NULL, shifts, pes, binding_scopes, l); - retry = 1; - } - } else { - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) - scheme_populate_pt_ht(pt); - for (j = pt->ht->size; j--; ) { - if (pt->ht->vals[j]) { - val = unmarshal_key_adjust(pt->ht->keys[j], pes); - if (val) - scheme_hash_set(mapped, val, scheme_true); - } - } - } - } - l = SCHEME_CDR(l); - } - } - i = scope_set_next(scopes, i); - } - } while (retry); -} - -/******************** lookup ********************/ - -static Scheme_Object *do_stx_lookup(Scheme_Stx *stx, Scheme_Scope_Set *scopes, - Scheme_Scope_Set *check_subset, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - GC_CAN_IGNORE Scheme_Object **_sole_result) -/* the core lookup operation: walk through an identifier's marks, - and walk through the bindings attached to each of those marks */ -{ - int j, invalid, matches = 0; - intptr_t i; - Scheme_Object *key, *val, *result_best_so_far, *l, *pes; - Scheme_Scope *scope; - Scheme_Scope_Set *binding_scopes, *best_so_far; - Scheme_Module_Phase_Exports *pt; - - do { - invalid = 0; /* to indicate retry if we unmarshal */ - best_so_far = NULL; - result_best_so_far = NULL; - - i = scope_set_next(scopes, -1); - while ((i != -1) && !invalid) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - for (j = 0; j < 2; j++) { - l = scope->bindings; - if (!j) { - if (SCHEME_VECTORP(l)) { - if (!SAME_OBJ(SCHEME_VEC_BINDING_KEY(l), stx->val)) - l = NULL; - /* l is NULL or a vector-form binding */ - } else if (SCHEME_HASHTRP(l)) { - l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)l, stx->val); - /* l is a pair or mlist */ - } else { - STX_ASSERT(SCHEME_RPAIRP(l)); - l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)SCHEME_CAR(l), - stx->val); - /* l is a pair or mlist */ - } - } else { - if (SCHEME_RPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - /* l is an rlist */ - } - - /* l can have many different forms; see above */ - - while (l && !SCHEME_NULLP(l) && !invalid) { - if (SCHEME_VECTORP(l)) - binding_scopes = SCHEME_VEC_BINDING_SCOPES(l); - else if (SCHEME_PAIRP(l)) - binding_scopes = SCHEME_BINDING_SCOPES(l); - else { - STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); - binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - } - - if (j) { - STX_ASSERT(SCHEME_RPAIRP(l)); - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (PES_UNMARSHAL_DESCP(pes)) { - /* Not a pes; an unmarshal */ - if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { - /* Need unmarshal --- but only if the scope set is relevant */ - if (scope_subset(binding_scopes, scopes)) { - /* unmarshal and note that we must restart */ - unmarshal_module_context_additions(stx, NULL, pes, binding_scopes, l); - invalid = 1; - /* Shouldn't encounter this on a second pass: */ - STX_ASSERT(!check_subset); - } - } - binding_scopes = NULL; - } else { - /* Check for id in pes */ - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - scheme_populate_pt_ht(pt); - } - - if (!scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) - binding_scopes = NULL; - } - } - - if (binding_scopes && scope_subset(binding_scopes, scopes)) { - if (check_subset && !scope_subset(binding_scopes, check_subset)) { - if (_ambiguous) *_ambiguous = 1; - return NULL; /* ambiguous */ - } - matches++; - if (!best_so_far - || ((scope_set_count(binding_scopes) > scope_set_count(best_so_far)) - && (!check_subset - || (scope_set_count(binding_scopes) == scope_set_count(check_subset))))) { - best_so_far = binding_scopes; - if (SCHEME_VECTORP(l)) - result_best_so_far = SCHEME_VEC_BINDING_VAL(l); - else if (SCHEME_PAIRP(l)) - result_best_so_far = SCHEME_BINDING_VAL(l); - else { - STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); - result_best_so_far = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - } - STX_ASSERT(SCHEME_FALSEP(result_best_so_far) - || SCHEME_MODIDXP(result_best_so_far) - || SCHEME_PAIRP(result_best_so_far) - || SCHEME_VECTORP(result_best_so_far) - || SCHEME_SYMBOLP(result_best_so_far) - || SCHEME_MPAIRP(result_best_so_far)); - if (_exact_match) *_exact_match = (scope_set_count(binding_scopes) == scope_set_count(scopes)); - } - } - - if (SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - } - } - } - - i = scope_set_next(scopes, i); - } - } while (invalid); - - if (!best_so_far) - return NULL; - - if (check_subset) - return result_best_so_far; - else { - if (matches == 1) - *_sole_result = result_best_so_far; - else - *_sole_result = NULL; - return (Scheme_Object *)best_so_far; - } -} - -static Scheme_Object *do_stx_lookup_nonambigious(Scheme_Stx *stx, Scheme_Object *phase, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - Scheme_Scope_Set **_binding_scopes) -{ - Scheme_Scope_Set *scopes, *best_set; - Scheme_Object *multi_scopes, *result; - - multi_scopes = stx->scopes->multi_scopes; - - /* Loop for top-level fallbacks: */ - while (1) { - scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); - - best_set = (Scheme_Scope_Set *)do_stx_lookup(stx, scopes, - NULL, - _exact_match, _ambiguous, - &result); - if (best_set) { - if (_binding_scopes) *_binding_scopes = best_set; - - if (!result) { - /* Find again, this time checking to ensure no ambiguity: */ - result = do_stx_lookup(stx, scopes, - best_set, - _exact_match, _ambiguous, - NULL); - } - - if (!result && SCHEME_FALLBACKP(multi_scopes)) { - if (_ambiguous) *_ambiguous = 0; - if (_exact_match) *_exact_match = 0; - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - } else - return result; - } else if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - return NULL; - } -} - -static Scheme_Object *apply_accumulated_shifts(Scheme_Object *result, Scheme_Object *prev_shifts, - GC_CAN_IGNORE Scheme_Object **_insp, - GC_CAN_IGNORE Scheme_Object **nominal_modidx, - Scheme_Stx *stx, Scheme_Object *orig_name, Scheme_Object *phase) -/* Adjust result to take the `free-id=?` chain into account: adjust a - `#f` result to add in the original name, or adjust a module name - for modidx shifts */ -{ - Scheme_Object *o; - - if (SCHEME_VECTORP(result)) { - if (!SCHEME_NULLP(prev_shifts) - || (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[0]) - && !SAME_OBJ(stx->val, orig_name))) { - /* Clone result vector */ - o = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(o)[0] = SCHEME_VEC_ELS(result)[0]; - SCHEME_VEC_ELS(o)[1] = SCHEME_VEC_ELS(result)[1]; - SCHEME_VEC_ELS(o)[2] = SCHEME_VEC_ELS(result)[2]; - result = o; - - if (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[1])) - SCHEME_VEC_ELS(result)[1] = stx->val; - - for (; !SCHEME_NULLP(prev_shifts); prev_shifts = SCHEME_CDR(prev_shifts)) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL); - SCHEME_VEC_ELS(result)[0] = o; - if (nominal_modidx) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL); - *nominal_modidx = o; - } - } - } - } else if (SCHEME_FALSEP(result) && !SAME_OBJ(stx->val, orig_name)) { - result = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(result)[0] = scheme_false; - SCHEME_VEC_ELS(result)[1] = stx->val; - SCHEME_VEC_ELS(result)[2] = phase; - } - - if (_insp && *_insp && SCHEME_SYMBOLP(*_insp)) - *_insp = scheme_false; /* wasn't shifted, for some reason */ - - return result; -} - -#define BINDING_CACHE_SIZE 32 - -typedef struct Binding_Cache_Entry { - Scheme_Stx *id; - Scheme_Object *phase; - Scheme_Object *result; - Scheme_Scope_Set *binding_scopes; - Scheme_Object *insp_desc; - Scheme_Object *free_eq; -} Binding_Cache_Entry; - -static void init_binding_cache(void) -{ - REGISTER_SO(binding_cache_table); - binding_cache_table = MALLOC_N_ATOMIC(Binding_Cache_Entry, BINDING_CACHE_SIZE); -} - -static void clear_binding_cache(void) -{ - binding_cache_len = 0; -} - -static void clear_binding_cache_for(Scheme_Object *sym) -{ - clear_binding_cache(); -} - -static void clear_binding_cache_stx(Scheme_Stx *stx) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - for (i = binding_cache_len; i--; ) { - if (SAME_OBJ(binding_cache[i].id, stx)) - binding_cache[i].id = NULL; - } -} - -XFORM_NONGCING static int find_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - for (i = binding_cache_len; i--; ) { - if (SAME_OBJ(binding_cache[i].id, id) - && SAME_OBJ(binding_cache[i].phase, phase)){ - return i; - } - } - - return -1; -} - -XFORM_NONGCING static void save_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase, - Scheme_Object *result, - Scheme_Scope_Set *binding_scopes, Scheme_Object *insp_desc, - Scheme_Object *free_eq) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - if (binding_cache_len < BINDING_CACHE_SIZE) { - i = binding_cache_len++; - } else if (binding_cache_pos < binding_cache_len) { - i = binding_cache_pos; - binding_cache_pos++; - } else { - i = 0; - binding_cache_pos = 1; - } - - binding_cache[i].id = id; - binding_cache[i].phase = phase; - binding_cache[i].result = result; - binding_cache[i].binding_scopes = binding_scopes; - binding_cache[i].insp_desc = insp_desc; - binding_cache[i].free_eq = free_eq; -} - -Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, - int stop_at_free_eq, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - GC_CAN_IGNORE Scheme_Scope_Set **_binding_scopes, - GC_CAN_IGNORE Scheme_Object **_insp, /* access-granting inspector */ - GC_CAN_IGNORE Scheme_Object **nominal_modidx, /* how it was imported */ - GC_CAN_IGNORE Scheme_Object **nominal_name, /* imported as name */ - GC_CAN_IGNORE Scheme_Object **src_phase, /* phase level of import from nominal modidx */ - GC_CAN_IGNORE Scheme_Object **nominal_src_phase) /* phase level of export from nominal modidx */ -/* Result is either a representation of a local binding (probably a symbol), - a vector of the form (vector ), or - #f */ -{ - Scheme_Stx *stx; - Scheme_Object *result, *insp_desc; - Scheme_Scope_Set *binding_scopes; - Scheme_Object *free_eq, *prev_shifts = scheme_null, *orig_name; - Scheme_Hash_Table *free_id_seen = NULL; - int cache_pos; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(nominal_name || (!src_phase && !nominal_src_phase)); - - orig_name = SCHEME_STX_VAL(o); - - while (1) { /* loop for `free-identifier=?` chains */ - stx = (Scheme_Stx *)o; - - if (_ambiguous) *_ambiguous = 0; - - if (nominal_name) - cache_pos = -1; - else - cache_pos = find_in_binding_cache(stx, phase); - - if (cache_pos >= 0) { - /* must extract from cache before a GC: */ - GC_CAN_IGNORE Binding_Cache_Entry *binding_cache = binding_cache_table; - - result = binding_cache[cache_pos].result; - binding_scopes = binding_cache[cache_pos].binding_scopes; - if (_insp) *_insp = binding_cache[cache_pos].insp_desc; - free_eq = binding_cache[cache_pos].free_eq; - - if (_binding_scopes) - *_binding_scopes = binding_scopes; - if (_exact_match) { - if (binding_scopes - && (scope_set_count(binding_scopes) == scope_set_count(extract_scope_set(stx, phase)))) - *_exact_match = 1; - else - *_exact_match = 0; - } - - if (free_eq) { - if (!stop_at_free_eq) { - o = SCHEME_CAR(free_eq); - phase = SCHEME_CDR(free_eq); - /* recur to handle `free-identifier=?` chain */ - if (!free_id_seen) - free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); - if (scheme_eq_hash_get(free_id_seen, o)) - return scheme_false; /* found a cycle */ - scheme_hash_set(free_id_seen, o, scheme_true); - prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); - continue; - } else - return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, - stx, orig_name, phase); - } else - return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, - stx, orig_name, phase); - } - - binding_scopes = NULL; - if (_exact_match) *_exact_match = 0; - - result = do_stx_lookup_nonambigious(stx, phase, - _exact_match, _ambiguous, - &binding_scopes); - - if (_binding_scopes) *_binding_scopes = binding_scopes; - - if (!result) { - save_in_binding_cache(stx, phase, scheme_false, - NULL, NULL, NULL); - return apply_accumulated_shifts(scheme_false, scheme_null, NULL, NULL, - stx, orig_name, phase); - } - - /* - `result` can be: - - a symbol for a lexical binding, - - a pair, modidx, or #f for a module import - - a vector for a pes (shared export table from a module) - - a mutable pair of the above plus an identifier for a `free-identifier=?` link - */ - if (SCHEME_MPAIRP(result)) { - free_eq = SCHEME_CDR(result); - result = SCHEME_CAR(result); - } else - free_eq = NULL; - - if (!SCHEME_SYMBOLP(result)) { - /* Generate a result vector: (vector ) */ - Scheme_Object *l = result; - - result = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(result)[1] = stx->val; - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(0); - - if (nominal_modidx) *nominal_modidx = NULL; - if (nominal_name) *nominal_name = NULL; - if (src_phase) *src_phase = NULL; - if (nominal_src_phase) *nominal_src_phase = NULL; - - if (SCHEME_FALSEP(l)) { - /* top-level bound */ - SCHEME_VEC_ELS(result)[0] = scheme_false; - /* phase of defn must be binding phase: */ - SCHEME_VEC_ELS(result)[2] = phase; - insp_desc = scheme_false; - } else if (SCHEME_MODIDXP(l)) { - SCHEME_VEC_ELS(result)[0] = l; - insp_desc = scheme_false; - } else if (SCHEME_PAIRP(l)) { - /* A list for a module import */ - Scheme_Object *modidx; - Scheme_Object *exportname = SCHEME_VEC_ELS(result)[1]; - Scheme_Object *mod_phase = SCHEME_VEC_ELS(result)[2]; - - extract_module_binding_parts(l, - SCHEME_VEC_ELS(result)[2], - &insp_desc, - &modidx, /* required */ - &exportname, /* required */ - nominal_modidx, - &mod_phase, /* required */ - nominal_name, - src_phase, - nominal_src_phase); - - SCHEME_VEC_ELS(result)[0] = modidx; - SCHEME_VEC_ELS(result)[1] = exportname; - SCHEME_VEC_ELS(result)[2] = mod_phase; - } else { - /* A vector for a pes */ - Scheme_Module_Phase_Exports *pt; - Scheme_Object *pos, *mod; - - STX_ASSERT(SCHEME_VECTORP(l)); - - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(l)[1]; - insp_desc = SCHEME_VEC_ELS(l)[4]; - - pos = scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, l)); - - if (pt->provide_srcs) { - mod = pt->provide_srcs[SCHEME_INT_VAL(pos)]; - if (SCHEME_FALSEP(mod)) - mod = SCHEME_VEC_ELS(l)[0]; - else - mod = scheme_modidx_shift(mod, - pt->src_modidx, - SCHEME_VEC_ELS(l)[0]); - } else - mod = SCHEME_VEC_ELS(l)[0]; - - SCHEME_VEC_ELS(result)[0] = mod; - - if (nominal_modidx) - *nominal_modidx = SCHEME_VEC_ELS(l)[0]; - - SCHEME_VEC_ELS(result)[1] = pt->provide_src_names[SCHEME_INT_VAL(pos)]; - - if (nominal_name) - *nominal_name = pt->provides[SCHEME_INT_VAL(pos)]; - - if (pt->provide_src_phases) - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(pt->provide_src_phases[SCHEME_INT_VAL(pos)]); - - if (src_phase) *src_phase = SCHEME_VEC_ELS(l)[2]; - if (nominal_src_phase) *nominal_src_phase = pt->phase_index; - } - - if (nominal_name && !*nominal_name) - *nominal_name = stx->val; - if (nominal_modidx && !*nominal_modidx) - *nominal_modidx = SCHEME_VEC_ELS(result)[0]; - if (src_phase && !*src_phase) - *src_phase = scheme_make_integer(0); - if (nominal_src_phase && !*nominal_src_phase) - *nominal_src_phase = SCHEME_VEC_ELS(result)[2]; - - l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL); - SCHEME_VEC_ELS(result)[0] = l; - - if (nominal_modidx) { - l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL); - *nominal_modidx = l; - } - } else - insp_desc = scheme_false; - - save_in_binding_cache(stx, phase, result, - binding_scopes, insp_desc, - free_eq); - - if (_insp) *_insp = insp_desc; - - if (!free_eq || stop_at_free_eq) - return apply_accumulated_shifts(result, prev_shifts, _insp, nominal_modidx, - stx, orig_name, phase); - - /* Recur for `free-identifier=?` mapping */ - phase = SCHEME_CDR(free_eq); - o = SCHEME_CAR(free_eq); - prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); - - if (!free_id_seen) - free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); - if (scheme_eq_hash_get(free_id_seen, o)) - return scheme_false; /* found a cycle */ - } -} - -Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase) -{ - return scheme_stx_lookup_w_nominal(o, phase, 0, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL); -} - -Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match) -{ - return scheme_stx_lookup_w_nominal(o, phase, 1, _exact_match, NULL, NULL, NULL, NULL, NULL, NULL, NULL); -} - -Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase) -{ - int exact; - Scheme_Object *b; - - b = scheme_stx_lookup_w_nominal(o, phase, 1, &exact, NULL, NULL, NULL, NULL, NULL, NULL, NULL); - - if (!exact) - return scheme_false; - else - return b; -} - -void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - Scheme_Hash_Table *ht; - int i; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - for (i = pt->num_provides; i--; ) { - scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i)); - } - pt->ht = ht; - } -} - -void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(SCHEME_STXP(from_o)); - - /* Passing an identifier as the "value" adds to the existing binding, - instead of replacing it: */ - add_binding(stx->val, phase, extract_scope_set(stx, phase), from_o, NULL, NULL); -} - -/******************** module contexts ********************/ - -/* A module context is a convenience record to track the scopes, - inspector, etc. that are related to expanding a `module` form */ - -Scheme_Object *scheme_make_module_context(Scheme_Object *insp, - Scheme_Object *shift_or_shifts, - Scheme_Object *debug_name) -{ - Scheme_Object *vec, *bx; - Scheme_Object *body_scopes; - Scheme_Object *intro_multi_scope; - - /* The `intro_multi_scope` is the home for all bindings in a given context. - It is added to any form that emerges into a module context via - macro expansion. - In the case of top-level forms, this context is sometimes stripped away - and replaced with a new top-level context. */ - intro_multi_scope = new_multi_scope(debug_name); - body_scopes = scheme_make_pair(intro_multi_scope, scheme_null); - - /* An additional scope identifies the original module home of an - identifier (i.e., not added to things that are macro-introduced - into the module context). The root scope serves to unify all - top-level contexts. */ - if (SCHEME_FALSEP(debug_name)) - body_scopes = scheme_make_pair(root_scope, body_scopes); - else - body_scopes = scheme_make_pair(scheme_new_scope(SCHEME_STX_MODULE_SCOPE), body_scopes); - - if (!shift_or_shifts) - shift_or_shifts = scheme_null; - else if (!SCHEME_PAIRP(shift_or_shifts) && !SCHEME_NULLP(shift_or_shifts)) - shift_or_shifts = scheme_make_pair(shift_or_shifts, scheme_null); - - /* A module context consists of - - A list of scopes, multi-scopes, and (cons multi-scope phase) that - corresponds to the module body - - A phase used for extracting scopes (not a shift for the intro scope) - - An inspector - - A list of module-index shifts - - A multi-scope for binding/introduction (included in body scopes) - - A list of scopes that correspond to macro uses; - this scopes must be stripped away from a definition - */ - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = body_scopes; - SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(0); - SCHEME_VEC_ELS(vec)[2] = insp; - SCHEME_VEC_ELS(vec)[3] = shift_or_shifts; - SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; - bx = scheme_box((Scheme_Object *)empty_scope_set); - SCHEME_VEC_ELS(vec)[5] = bx; - - return vec; -} - -Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc) -{ - Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; - Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; - Scheme_Scope_Set *scopes = empty_scope_set; - - while (!SCHEME_NULLP(body_scopes)) { - scope = SCHEME_CAR(body_scopes); - if (!SCHEME_SCOPEP(scope)) { - if (SCHEME_PAIRP(scope)) - scope = extract_simple_scope_from_shifted(scope, phase); - else - scope = extract_simple_scope(scope, phase); - } - if (scope) - scopes = scope_set_set(scopes, scope, scheme_true); - body_scopes = SCHEME_CDR(body_scopes); - } - - return scopes; -} - -Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes) -{ - Scheme_Object *scopes; - - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - - if (keep_intdef_scopes) - scopes = add_intdef_scopes_of(scopes, keep_intdef_scopes); - - return scopes; -} - -void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope) -{ - Scheme_Scope_Set *use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - - STX_ASSERT(SCHEME_SCOPEP(use_site_scope)); - - use_site_scopes = scope_set_set(use_site_scopes, use_site_scope, scheme_true); - - SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]) = (Scheme_Object *)use_site_scopes; -} - -Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc) -{ - Scheme_Scope_Set *use_site_scopes; - - use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - if (SAME_OBJ(use_site_scopes, empty_scope_set)) - return NULL; - else - return make_vector3(scheme_false, (Scheme_Object *)use_site_scopes, scheme_false); -} - -Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc) -{ - return SCHEME_VEC_ELS(mc)[2]; -} - -void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped) -{ - add_scopes_mapped_names(scheme_module_context_scopes(mc), - SCHEME_VEC_ELS(mc)[3], /* list of shifts */ - mapped); -} - -Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase) -{ - Scheme_Object *vec; - - /* Clones the module context, but with a different convenience phase */ - - if (SAME_OBJ(SCHEME_VEC_ELS(mc)[1], phase)) - return mc; - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(mc)[0]; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(mc)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(mc)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(mc)[4]; - SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(mc)[5]; - - return vec; -} - -static Scheme_Object *adjust_module_context_except(Scheme_Object *stx, Scheme_Object *mc, Scheme_Object *skip, - int mode) -{ - Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; - Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; - - while (!SCHEME_NULLP(body_scopes)) { - scope = SCHEME_CAR(body_scopes); - if (skip && SAME_OBJ(scope, skip)) - scope = NULL; - else if (!SCHEME_SCOPEP(scope)) { - if (SCHEME_PAIRP(scope)) - scope = extract_simple_scope_from_shifted(scope, phase); - else - scope = extract_simple_scope(scope, phase); - } - if (scope) - stx = scheme_stx_adjust_scope(stx, scope, phase, mode); - body_scopes = SCHEME_CDR(body_scopes); - } - - if (mode == SCHEME_STX_ADD) - stx = scheme_stx_add_shifts(stx, SCHEME_VEC_ELS(mc)[3]); - - return stx; -} - -Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_ADD); -} - -Scheme_Object *scheme_stx_remove_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_REMOVE); -} - -Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; - - stx = scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); - stx = adjust_module_context_except(stx, mc, intro_multi_scope, SCHEME_STX_ADD); - - return stx; -} - -Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; - - return scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); -} - -Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return scheme_stx_add_module_context(stx, mc); -} - -Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *multi_scope; - - STX_ASSERT(SCHEME_VECTORP(mc)); - - multi_scope = SCHEME_VEC_ELS(mc)[4]; - - return scheme_stx_add_scope(stx, multi_scope, scheme_make_integer(0)); -} - -Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_REMOVE); -} - -Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode) -{ - Scheme_Scope_Set *scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - - return scheme_stx_adjust_scopes(stx, scopes, SCHEME_VEC_ELS(mc)[1], mode); -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, - Scheme_Object *add_scopes, Scheme_Object *phase); - -static Scheme_Object *replace_scopes_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *stx = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *remove_scopes = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *add_scopes = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *phase = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return replace_scopes(stx, remove_scopes, add_scopes, phase); -} -#endif - -static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, - Scheme_Object *add_scopes, Scheme_Object *phase) -{ - Scheme_Object *sym, *sym2, *content; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)stx; - p->ku.k.p2 = (void *)remove_scopes; - p->ku.k.p3 = (void *)add_scopes; - p->ku.k.p4 = (void *)phase; - - return scheme_handle_stack_overflow(replace_scopes_k); - } - } -#endif - - if (SCHEME_STXP(stx)) { - int mutate = 0; - - scheme_stx_content(stx); - if (HAS_SUBSTX(SCHEME_STX_VAL(stx))) { - content = replace_scopes(SCHEME_STX_VAL(stx), remove_scopes, add_scopes, phase); - sym = scheme_datum_to_syntax(scheme_false, scheme_false, stx, 0, 0); - } else { - sym = stx; - content = SCHEME_STX_VAL(stx); - } - - if (SCHEME_SCOPEP(remove_scopes) || SCHEME_MULTI_SCOPEP(remove_scopes)) - sym2 = stx_adjust_scope(sym, remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); - else - sym2 = stx_adjust_scopes(sym, (Scheme_Scope_Set *)remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); - - if (!SAME_OBJ(sym, sym2) || !SAME_OBJ(content, SCHEME_STX_VAL(stx))) { - if (SCHEME_SCOPEP(add_scopes) || SCHEME_MULTI_SCOPEP(add_scopes)) - sym2 = stx_adjust_scope(sym2, add_scopes, phase, SCHEME_STX_ADD, &mutate); - else - sym2 = stx_adjust_scopes(sym2, (Scheme_Scope_Set *)add_scopes, phase, SCHEME_STX_ADD, &mutate); - return scheme_datum_to_syntax(content, stx, sym2, 0, 2); - } else - return stx; - } else if (SCHEME_NULLP(stx)) { - return stx; - } else if (SCHEME_PAIRP(stx)) { - sym = replace_scopes(SCHEME_CAR(stx), remove_scopes, add_scopes, phase); - sym2 = replace_scopes(SCHEME_CDR(stx), remove_scopes, add_scopes, phase); - if (SAME_OBJ(sym, SCHEME_CAR(stx)) && SAME_OBJ(sym2, SCHEME_CDR(stx))) - return stx; - else - return scheme_make_pair(sym, sym2); - } else { - scheme_signal_error("internal error: unsupported form for replace_scopes()"); - return NULL; - } -} - -Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc) -{ - /* remove the introduction scope, which should be everywhere, and - map the other scopes to the root scope */ - Scheme_Object *scopes; - stx = scheme_stx_remove_scope(stx, SCHEME_VEC_ELS(mc)[4], SCHEME_VEC_ELS(mc)[1]); - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - return replace_scopes(stx, scopes, root_scope, SCHEME_VEC_ELS(mc)[1]); -} - -Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - /* map the root scope to the body scope, and add the introduction - scope everywhere */ - Scheme_Object *scopes; - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - stx = replace_scopes(stx, root_scope, scopes, SCHEME_VEC_ELS(mc)[1]); - return scheme_stx_introduce_to_module_context(stx, mc); -} - -void scheme_extend_module_context(Scheme_Object *mc, /* (vector ...) */ - Scheme_Object *ctx, /* binding context (as stx) or NULL */ - Scheme_Object *modidx, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - intptr_t mod_phase, /* phase of source defn */ - Scheme_Object *src_phase, /* nominal import phase */ - Scheme_Object *nom_phase) /* nominal export phase */ -{ - Scheme_Scope_Set *scopes; - - if (ctx) - scopes = extract_scope_set((Scheme_Stx *)ctx, SCHEME_VEC_ELS(mc)[1]); - else - scopes = scheme_module_context_scopes(mc); - - do_add_module_binding(scopes, localname, SCHEME_VEC_ELS(mc)[1], - modidx, exname, scheme_make_integer(mod_phase), - SCHEME_VEC_ELS(mc)[2], - nominal_mod, nominal_ex, - src_phase, nom_phase, - NULL, NULL); -} - -void scheme_extend_module_context_with_shared(Scheme_Object *mc, /* (vector ) or (cons ) */ - Scheme_Object *modidx, - Scheme_Module_Phase_Exports *pt, - Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ - Scheme_Hash_Tree *excepts, /* NULL => empty */ - Scheme_Object *src_phase, /* nominal import phase */ - Scheme_Object *context, - Scheme_Object *replace_at) -/* create a bulk import */ -{ - Scheme_Object *phase, *pes, *insp_desc, *unmarshal_info; - Scheme_Scope_Set *scopes; - - if (SCHEME_VECTORP(mc)) { - phase = SCHEME_VEC_ELS(mc)[1]; - insp_desc = SCHEME_VEC_ELS(mc)[2]; - } else { - phase = SCHEME_CAR(mc); - insp_desc = SCHEME_CDR(mc); - } - - if (context) - scopes = extract_scope_set((Scheme_Stx *)context, phase); - else - scopes = scheme_module_context_scopes(mc); - - unmarshal_info = make_unmarshal_info(pt->phase_index, prefix, (Scheme_Object *)excepts); - - pes = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(pes)[0] = modidx; - SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; - SCHEME_VEC_ELS(pes)[2] = src_phase; - SCHEME_VEC_ELS(pes)[3] = unmarshal_info; - SCHEME_VEC_ELS(pes)[4] = (insp_desc ? insp_desc : scheme_false); - - if (replace_at) { - SCHEME_BINDING_VAL(SCHEME_CAR(replace_at)) = pes; - } else { - add_binding(NULL, phase, scopes, pes, NULL, NULL); - } -} - -static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, - Scheme_Object *prefix, - Scheme_Object *excepts) -{ - Scheme_Object *unmarshal_info; - - /* unmarshal_info = phase - . | (cons phase adjusts) - adjusts = prefix - . | (cons excepts-ht prefix) - . | excepts-list - excepts-ht = (hasheq symbol #t ... ...) - */ - unmarshal_info = prefix; - if (excepts) { - if (SCHEME_FALSEP(unmarshal_info)) - unmarshal_info = excepts; - else - unmarshal_info = scheme_make_pair(excepts, prefix); - } - if (SCHEME_FALSEP(unmarshal_info)) - unmarshal_info = phase; - else - unmarshal_info = scheme_make_pair(phase, unmarshal_info); - - return unmarshal_info; -} - -XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) - return SCHEME_CAR(unmarshal_info); - else - return unmarshal_info; -} - -XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) { - unmarshal_info = SCHEME_CDR(unmarshal_info); - if (SCHEME_PAIRP(unmarshal_info)) - unmarshal_info = SCHEME_CDR(unmarshal_info); - - if (SCHEME_SYMBOLP(unmarshal_info)) - return unmarshal_info; - else - return scheme_false; - } else - return scheme_false; -} - -static Scheme_Hash_Tree *unmarshal_vector_to_excepts(Scheme_Object *unmarshal_info, - Scheme_Object *ht_target, - int ht_to_cdr) -{ - Scheme_Hash_Tree *ht = empty_hash_tree; - intptr_t i; - - for (i = SCHEME_VEC_SIZE(unmarshal_info); i--; ) { - if (SCHEME_SYMBOLP(SCHEME_VEC_ELS(unmarshal_info)[i])) - ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(unmarshal_info)[i], scheme_true); - } - - if (ht_to_cdr) - SCHEME_CDR(ht_target) = (Scheme_Object *)ht; - else - SCHEME_CAR(ht_target) = (Scheme_Object *)ht; - - return ht; -} - -static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) { - Scheme_Object *ht_target = unmarshal_info; - int ht_to_cdr = 1; - - unmarshal_info = SCHEME_CDR(unmarshal_info); - if (SCHEME_PAIRP(unmarshal_info)) { - ht_target = unmarshal_info; - ht_to_cdr = 0; - unmarshal_info = SCHEME_CAR(unmarshal_info); - } - - if (SCHEME_HASHTRP(unmarshal_info)) - return (Scheme_Hash_Tree *)unmarshal_info; - else if (SCHEME_VECTORP(unmarshal_info)) { - /* Hash table was converted to a vector in a marshaled unmarshal request */ - return unmarshal_vector_to_excepts(unmarshal_info, ht_target, ht_to_cdr); - } else - return NULL; - } else - return NULL; -} - -static Scheme_Object *unmarshal_excepts_to_vector(Scheme_Object *unmarshal_info) -{ - Scheme_Hash_Tree *ht; - - ht = extract_unmarshal_excepts(unmarshal_info); - if (ht) { - intptr_t i = -1, j = 0; - Scheme_Object *vec, *key, *val; - - vec = scheme_make_vector(ht->count, NULL); - - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - SCHEME_VEC_ELS(vec)[j++] = key; - } - - sort_vector_symbols(vec); - - return make_unmarshal_info(extract_unmarshal_phase(unmarshal_info), - extract_unmarshal_prefix(unmarshal_info), - vec); - } - - return unmarshal_info; -} - -static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes) -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - - if (!SCHEME_SYMBOLP(sym)) - return scheme_false; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if (SCHEME_TRUEP(prefix) && !SCHEME_SYM_WEIRDP(sym)) { - int plen = SCHEME_SYM_LEN(prefix); - if (SCHEME_SYM_LEN(sym) >= plen) { - if (!scheme_strncmp(SCHEME_SYM_VAL(sym), SCHEME_SYM_VAL(prefix), plen)) { - char buf[64], *b; - int slen = SCHEME_SYM_LEN(sym) - plen; - if (slen < 64) - b = buf; - else - b = scheme_malloc_atomic(slen+1); - memcpy(b, SCHEME_SYM_VAL(sym) + plen, slen+1); - sym = scheme_intern_exact_symbol(b, slen); - } else - return scheme_false; /* so lookup will fail */ - } else - return scheme_false; - } - - if (excepts) { - if (scheme_eq_hash_tree_get(excepts, sym)) - return scheme_false; /* so lookup will fail */ - } - - return sym; -} - -static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes) -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if (excepts && scheme_eq_hash_tree_get(excepts, sym)) - return NULL; - - if (SCHEME_TRUEP(prefix)) { - int plen = SCHEME_SYM_LEN(prefix); - int slen = SCHEME_SYM_LEN(sym) + plen; - char buf[64], *b; - - if (slen < 64) - b = buf; - else - b = scheme_malloc_atomic(slen+1); - memcpy(b, SCHEME_SYM_VAL(prefix), plen); - memcpy(b+plen, SCHEME_SYM_VAL(sym), SCHEME_SYM_LEN(sym)+1); - sym = scheme_intern_exact_symbol(b, slen); - } - - return sym; -} - -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, - Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at) -{ - Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase; - Scheme_Object *insp, *req_insp; - Scheme_Hash_Table *export_registry; - - req_modidx = SCHEME_VEC_ELS(vec)[0]; - insp = SCHEME_VEC_ELS(vec)[3]; - req_insp = insp; - - if (stx) - modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); - else - modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry); - - src_phase = SCHEME_VEC_ELS(vec)[1]; - unmarshal_info = SCHEME_VEC_ELS(vec)[2]; - pt_phase = extract_unmarshal_phase(unmarshal_info); - - SCHEME_VEC_ELS(vec)[0] = scheme_false; - SCHEME_VEC_ELS(vec)[1] = scheme_false; - SCHEME_VEC_ELS(vec)[2] = scheme_false; - - if (SCHEME_FALSEP(src_phase) || SCHEME_FALSEP(pt_phase)) - bind_phase = scheme_false; - else - bind_phase = scheme_bin_plus(src_phase, pt_phase); - - context = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - context = scheme_stx_adjust_scopes(context, scopes, bind_phase, SCHEME_STX_ADD); - - scheme_do_module_context_unmarshal(modidx, req_modidx, context, - bind_phase, pt_phase, src_phase, - extract_unmarshal_prefix(unmarshal_info), - extract_unmarshal_excepts(unmarshal_info), - export_registry, insp, req_insp, - replace_at); -} - -Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src) -{ - Scheme_Object *plain, *o, *for_intro, *vec; - - plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - - if (orig_src) - o = scheme_datum_to_syntax(scheme_true, scheme_false, orig_src, 0, 0); - else - o = scheme_stx_add_module_context(plain, mc); - - /* Keep track of intro scope separately: */ - for_intro = scheme_stx_introduce_to_module_context(plain, mc); - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = o; - SCHEME_VEC_ELS(vec)[1] = for_intro; - return scheme_datum_to_syntax(vec, scheme_false, scheme_false, 0, 0); -} - -Scheme_Object *scheme_stx_to_module_context(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *vec, *shifts, *a, *body_scopes, *phase = scheme_make_integer(0); - Scheme_Object *intro_multi_scope = NULL; - - if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) { - (void)scheme_stx_content((Scheme_Object *)stx); /* propagate */ - intro_multi_scope = SCHEME_VEC_ELS(stx->val)[1]; - stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; - } - - shifts = stx->shifts; - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - shifts = shifts_to_non_source(shifts); - - phase = scheme_make_integer(0); - - body_scopes = scheme_null; - a = stx->scopes->multi_scopes; - if (SCHEME_FALLBACKP(a)) - a = SCHEME_FALLBACK_FIRST(a); - for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) { - if (SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(a)))) - body_scopes = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(a)), body_scopes); - else - body_scopes = scheme_make_pair(SCHEME_CAR(a), body_scopes); - } - { - Scheme_Object *key, *val; - intptr_t i; - i = -1; - while ((i = scope_set_next(stx->scopes->simple_scopes, i)) != -1) { - scope_set_index(stx->scopes->simple_scopes, i, &key, &val); - body_scopes = scheme_make_pair(key, body_scopes); - } - } - - if (intro_multi_scope) { - stx = (Scheme_Stx *)intro_multi_scope; - if (!SCHEME_FALLBACKP(stx->scopes->multi_scopes) - && SCHEME_PAIRP(stx->scopes->multi_scopes)) { - intro_multi_scope = SCHEME_CAR(SCHEME_CAR(stx->scopes->multi_scopes)); - } - } - if (!intro_multi_scope) { - /* This won't happen for a well-formed representation */ - intro_multi_scope = new_multi_scope(scheme_false); - } - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = body_scopes; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = scheme_false; /* not sure this is right */ - SCHEME_VEC_ELS(vec)[3] = shifts; - SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; - a = scheme_box((Scheme_Object *)empty_scope_set); - SCHEME_VEC_ELS(vec)[5] = a; - - return vec; -} - -int scheme_stx_equal_module_context(Scheme_Object *other_stx, Scheme_Object *mc_or_stx) -{ - Scheme_Stx *stx; - Scheme_Object *phase; - - if (SCHEME_STXP(mc_or_stx)) { - stx = (Scheme_Stx *)mc_or_stx; - if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) - stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; - } else { - Scheme_Object *plain; - plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - mc_or_stx = scheme_stx_add_module_context(plain, mc_or_stx); - stx = (Scheme_Stx *)mc_or_stx; - } - - phase = scheme_make_integer(0); - - return scopes_equal(extract_scope_set((Scheme_Stx *)other_stx, phase), - extract_scope_set(stx, phase)); -} - -/******************** lazy syntax-object unmarshaling ********************/ - -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) -{ - Scheme_Object *stx; - int c; - - stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), - (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); - rp->stxes[i] = stx; - c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); - --c; - SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); - if (!c) { - SCHEME_CDR(rp->delay_info_rpair) = NULL; - rp->delay_info_rpair = NULL; - } -} - -Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i) -{ - Scheme_Object *shift, *v; - Resolve_Prefix *rp; - int mutate = 0; - - shift = o[0]; - - if (!shift) return scheme_false; /* happens only with corrupted .zo! */ - - rp = (Resolve_Prefix *)o[1]; - - v = rp->stxes[i]; - - if (SCHEME_INTP(v)) { - scheme_load_delayed_syntax(rp, i); - v = rp->stxes[i]; - } - - v = do_stx_add_shift(v, shift, &mutate); - - shift = SCHEME_VEC_ELS(shift)[3]; - if (!SCHEME_FALSEP(shift)) { - /* need to propagate the inspector for dye packs, too */ - (void)set_false_insp((Scheme_Object *)v, shift, &mutate); - } - - return v; -} - -Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx) -{ - if (SCHEME_RPAIRP(stx)) - return scheme_load_delayed_code(SCHEME_INT_VAL(SCHEME_CAR(stx)), - (struct Scheme_Load_Delay *)SCHEME_CDR(stx)); - else - return stx; -} - -/*========================================================================*/ -/* stx comparison */ -/*========================================================================*/ - -int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase) -{ - Scheme_Stx *bind = (Scheme_Stx *)bind_id; - Scheme_Stx *ref = (Scheme_Stx *)ref_id; - - if (!SAME_OBJ(ref->val, bind->val)) - return 0; - - return scope_subset(extract_scope_set(bind, phase), - extract_scope_set(ref, phase)); -} - -int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase) -{ - Scheme_Object *a_bind, *b_bind; - - STX_ASSERT(SCHEME_STXP(a)); - STX_ASSERT(SCHEME_STXP(b)); - - a_bind = scheme_stx_lookup(a, a_phase); - b_bind = scheme_stx_lookup(b, b_phase); - - if (SCHEME_SYMBOLP(a_bind) || SCHEME_SYMBOLP(b_bind)) { - return SAME_OBJ(a_bind, b_bind); - } - - if (SCHEME_FALSEP(a_bind) || SCHEME_FALSEP(b_bind)) { - /* A `#f` binding can be equal to a vector that starts `#f` */ - if (SCHEME_FALSEP(a_bind)) - a = SCHEME_STX_VAL(a); - else if (SCHEME_VECTORP(a_bind) - && SCHEME_FALSEP(SCHEME_VEC_ELS(a_bind)[0]) - && SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], a_phase)) { - a = SCHEME_VEC_ELS(a_bind)[1]; - a_bind = scheme_false; - } - - if (SCHEME_FALSEP(b_bind)) - b = SCHEME_STX_VAL(b); - else if (SCHEME_VECTORP(b_bind) - && SCHEME_FALSEP(SCHEME_VEC_ELS(b_bind)[0]) - && SAME_OBJ(SCHEME_VEC_ELS(b_bind)[2], b_phase)) { - b = SCHEME_VEC_ELS(b_bind)[1]; - b_bind = scheme_false; - } - - if (SCHEME_FALSEP(a_bind) && SCHEME_FALSEP(b_bind)) - return SAME_OBJ(a, b); - else - return 0; - } - - /* Comparison of names & definition phases is fast, so try that next: */ - if (!SAME_OBJ(SCHEME_VEC_ELS(a_bind)[1], SCHEME_VEC_ELS(b_bind)[1]) - || !SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], SCHEME_VEC_ELS(b_bind)[2])) { - return 0; - } - - /* Need to compare modidxs: */ - - a_bind = scheme_module_resolve(SCHEME_VEC_ELS(a_bind)[0], 0); - b_bind = scheme_module_resolve(SCHEME_VEC_ELS(b_bind)[0], 0); - - return SAME_OBJ(a_bind, b_bind); -} - -int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) -{ - return scheme_stx_free_eq3(a, b, phase, phase); -} - -int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) -{ - return scheme_stx_free_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase)); -} - -int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase) -{ - return scheme_stx_free_eq3(a, b, scheme_make_integer(0), scheme_make_integer(b_phase)); -} - -Scheme_Object *scheme_stx_get_free_eq_sym(Scheme_Object *a, Scheme_Object *phase) -{ - if (SCHEME_STXP(a)) { - a = scheme_stx_lookup(a, phase); - if (SCHEME_VECTORP(a)) - return SCHEME_VEC_ELS(a)[1]; - else - return a; - } else - return a; -} - -int scheme_stx_env_bound_eq2(Scheme_Object *_a, Scheme_Object *_b, - Scheme_Object *a_phase, Scheme_Object *b_phase) -{ - Scheme_Stx *a = (Scheme_Stx *)_a; - Scheme_Stx *b = (Scheme_Stx *)_b; - - STX_ASSERT(SCHEME_STXP(_a)); - STX_ASSERT(SCHEME_STXP(_b)); - - if (!SAME_OBJ(a->val, b->val)) - return 0; - - return scopes_equal(extract_scope_set(a, a_phase), extract_scope_set(b, b_phase)); -} - -int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) -{ - return scheme_stx_env_bound_eq2(a, b, phase, phase); -} - -Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source) -{ - /* Look for the oldest "self" modidx that has a resolution: */ - Scheme_Object *l = ((Scheme_Stx *)stx)->shifts, *a, *src; - Scheme_Hash_Table *export_registry; - - if (SCHEME_VECTORP(l)) - l = SCHEME_VEC_ELS(l)[0]; - - l = scheme_reverse(l); - - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_VECTORP(a) && !non_source_shift(a)) { - src = SCHEME_VEC_ELS(a)[1]; - - if (SCHEME_MODIDXP(src)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)src)->path)) { - src = apply_modidx_shifts(((Scheme_Stx *)stx)->shifts, src, - NULL, &export_registry); - if (!SCHEME_FALSEP(((Scheme_Modidx *)src)->path) - || !SCHEME_FALSEP(((Scheme_Modidx *)src)->resolved)) { - if (resolve) { - src = scheme_module_resolve(src, 0); - if (export_registry && source) { - a = scheme_hash_get(export_registry, src); - if (a) - src = ((Scheme_Module_Exports *)a)->modsrc; - } - src = SCHEME_PTR_VAL(src); - } - return src; - } - } - } - } - - l = SCHEME_CDR(l); - } - - return scheme_false; -} - -/*========================================================================*/ -/* stx and lists */ -/*========================================================================*/ - -int scheme_stx_list_length(Scheme_Object *list) -{ - int len; - - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - len = 0; - while (!SCHEME_NULLP(list)) { - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - if (SCHEME_PAIRP(list)) { - len++; - list = SCHEME_CDR(list); - } else { - if (!SCHEME_NULLP(list)) - len++; - break; - } - } - - return len; -} - -int scheme_stx_proper_list_length(Scheme_Object *list) -{ - int len; - Scheme_Object *turtle; - - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - len = 0; - turtle = list; - while (SCHEME_PAIRP(list)) { - len++; - - list = SCHEME_CDR(list); - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - if (!SCHEME_PAIRP(list)) - break; - len++; - list = SCHEME_CDR(list); - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - if (SAME_OBJ(turtle, list)) - break; - - turtle = SCHEME_CDR(turtle); - if (SCHEME_STXP(turtle)) - turtle = SCHEME_STX_VAL(turtle); - - } - - if (SCHEME_NULLP(list)) - return len; - - return -1; -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *flatten_syntax_list_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; - int *r = (int *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_flatten_syntax_list(l, r); -} -#endif - -Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) -{ - Scheme_Object *l = lst, *lflat, *first, *last; - - /* Check whether the list ends in a null: */ - while (SCHEME_PAIRP(l)) { - l = SCHEME_CDR(l); - } - - if (SCHEME_NULLP(l)) { - /* Yes. We're done: */ - if (islist) - *islist = 1; - return lst; - } - - if (islist) - *islist = 0; - - lflat = NULL; - - /* Is it a syntax object, possibly with a list? */ - if (SCHEME_STXP(l)) { - l = scheme_stx_content(l); - if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) { - int lislist; - - lflat = NULL; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - int *r; - - r = (int *)scheme_malloc_atomic(sizeof(int)); - - p->ku.k.p1 = (void *)l; - p->ku.k.p2 = (void *)r; - - lflat = scheme_handle_stack_overflow(flatten_syntax_list_k); - - lislist = *r; - } - } -#endif - - if (!lflat) - lflat = scheme_flatten_syntax_list(l, &lislist); - - if (!lislist) { - /* Not a list. Can't flatten this one. */ - return lst; - } - } else { - /* Not a syntax list. No chance of flattening. */ - return lst; - } - } else { - /* No. No chance of flattening, then. */ - return lst; - } - - /* Need to flatten, end with lflat */ - - if (islist) - *islist = 1; - - first = last = NULL; - for (l = lst; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *p; - p = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - if (last) - SCHEME_CDR(last) = lflat; - else - first = lflat; - - return first; -} - -/*========================================================================*/ -/* wraps->datum */ -/*========================================================================*/ - -static void sort_added_scopes(Scheme_Object *scopes, int added) -{ - Scheme_Object **a, *l; - int i; - - if (!added) - return; - - a = MALLOC_N(Scheme_Object *, added); - for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) { - a[i] = SCHEME_CAR(l); - } - - sort_scope_array(a, added); - - for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) { - SCHEME_CAR(l) = a[i]; - } -} - -static void add_reachable_scopes(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) -{ - intptr_t i, added = 0; - Scheme_Object *key, *val; - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (!scheme_eq_hash_get(mt->reachable_scopes, key)) { - scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL); - scheme_hash_set(mt->reachable_scopes, key, scheme_true); - val = scheme_make_pair(key, mt->reachable_scope_stack); - mt->reachable_scope_stack = val; - added++; - } - } - - sort_added_scopes(mt->reachable_scope_stack, added); -} - -static void add_conditional_as_reachable(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) -{ - int added = 0; - intptr_t i; - Scheme_Object *key, *val; - - STX_ASSERT(SCHEME_SCOPE_SETP(scopes)); - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key) - && scheme_eq_hash_get(mt->conditionally_reachable_scopes, key) - && !scheme_eq_hash_get(mt->reachable_scopes, key)) { - scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL); - scheme_hash_set(mt->reachable_scopes, key, scheme_true); - val = scheme_make_pair(key, mt->reachable_scope_stack); - mt->reachable_scope_stack = val; - added++; - } - } - - sort_added_scopes(mt->reachable_scope_stack, added); -} - -static void add_reachable_multi_scope(Scheme_Object *ms, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)ms; - Scheme_Scope_Set *binding_scopes = empty_scope_set; - Scheme_Object *scope; - int j; - - for (j = ht->size; j--; ) { - scope = ht->vals[j]; - if (scope) { - if (!MULTI_SCOPE_METAP(ht->keys[j])) { - if (!scheme_eq_hash_get(mt->reachable_scopes, scope) - && !scheme_eq_hash_get(mt->conditionally_reachable_scopes, scope)) { - /* This scope is reachable via its multi-scope, but it only - matters if it's reachable through a binding (otherwise it - can be re-generated later). We don't want to keep a scope - that can be re-generated, because pruning it makes - compilation more deterministic relative to other - compilations that involve a shared module. If the scope - itself has any bindings, then we count it as reachable - through a binding (which is an approxmation, because other scopes - in the binding may be unreachable, but it seems good enough for - determinism). */ - scheme_hash_set(mt->conditionally_reachable_scopes, scope, scheme_true); - if (((Scheme_Scope *)scope)->bindings) - binding_scopes = scope_set_set(binding_scopes, scope, scheme_true); - } - } - } - } - - if (!SAME_OBJ(binding_scopes, empty_scope_set)) - add_conditional_as_reachable(binding_scopes, mt); -} - -static void add_reachable_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *l; - - while (1) { - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - add_reachable_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), mt); - } - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - break; - } -} - -static Scheme_Object *any_unreachable_scope(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt, - int check_conditionals) -{ - intptr_t i; - int saw_conditional = 0; - Scheme_Object *key, *val; - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (!scheme_eq_hash_get(mt->reachable_scopes, key)) { - if (check_conditionals && scheme_eq_hash_get(mt->conditionally_reachable_scopes, key)) - saw_conditional = 1; - else - return key; - } - } - - if (saw_conditional) { - /* since this binding is reachable, move any conditional to reachable */ - add_conditional_as_reachable(scopes, mt); - } - - return NULL; -} - -static void possiblly_reachable_free_id(Scheme_Object *val, /* mpair or stx */ - Scheme_Scope_Set *scopes, - Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *free_id = (Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)); - Scheme_Object *unreachable_scope, *l; - Scheme_Hash_Table *ht; - - if (SCHEME_MPAIRP(val)) - free_id = (Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)); - else - free_id = (Scheme_Stx *)val; - - STX_ASSERT(SCHEME_STXP((Scheme_Object *)free_id)); - - unreachable_scope = any_unreachable_scope(scopes, mt, 1); - - if (!unreachable_scope) { - /* causes the free-id mapping's scopes to be reachable: */ - (void)wraps_to_datum(free_id, mt); - } else { - /* the mapping will become reachable only if `unreachable_scope` becomes reachable */ - if (!mt->pending_reachable_ids) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - mt->pending_reachable_ids = ht; - } - l = scheme_eq_hash_get(mt->pending_reachable_ids, unreachable_scope); - if (!l) l = scheme_null; - scheme_hash_set(mt->pending_reachable_ids, unreachable_scope, - scheme_make_pair(scheme_make_pair((Scheme_Object *)free_id, - (Scheme_Object *)scopes), - l)); - } -} - -static int all_symbols(Scheme_Object **a, int c) -{ - while (c--) { - if (!SCHEME_SYMBOLP(a[c])) - return 0; - } - return 1; -} - -static int all_reals(Scheme_Object **a, int c) -{ - while (c--) { - if (!SCHEME_REALP(a[c])) - return 0; - } - return 1; -} - -Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *tree) -{ - intptr_t j, i, count; - Scheme_Object **a, *key; - - if (SCHEME_HASHTRP(tree)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)tree; - - count = ht->count; - if (!count) - return NULL; - - a = MALLOC_N(Scheme_Object *, count); - - j = -1; - i = 0; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, NULL); - a[i++] = key; - } - - STX_ASSERT(i == count); - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)tree; - - count = t->count; - - if (!count) - return NULL; - - a = MALLOC_N(Scheme_Object *, count); - j = 0; - - for (i = t->size; i--; ) { - if (t->vals[i]) { - a[j++] = t->keys[i]; - } - } - - STX_ASSERT(j == count); - } - - if (SCHEME_SYMBOLP(a[0]) && all_symbols(a, count)) - sort_symbol_array(a, count); - else if (SCHEME_SCOPEP(a[0])) - sort_scope_array(a, count); - else if (all_reals(a, count)) - sort_number_array(a, count); - else - return NULL; - - return a; -} - -void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt) -{ - Scheme_Scope *scope; - Scheme_Object *l, *val, *key, **sorted_keys, *pesl; - Scheme_Hash_Tree *ht; - intptr_t j, count; - - /* For each scope, recur on `free-identifier=?` mappings */ - while (!SCHEME_NULLP(mt->reachable_scope_stack)) { - scope = (Scheme_Scope *)SCHEME_CAR(mt->reachable_scope_stack); - mt->reachable_scope_stack = SCHEME_CDR(mt->reachable_scope_stack); - - if (scope->bindings) { - val = scope->bindings; - if (SCHEME_VECTORP(val)) { - add_conditional_as_reachable(SCHEME_VEC_BINDING_SCOPES(val), mt); - l = SCHEME_VEC_BINDING_VAL(val); - if (SCHEME_MPAIRP(l)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(l, SCHEME_VEC_BINDING_SCOPES(val), mt); - } - } else { - if (SCHEME_RPAIRP(val)) { - ht = (Scheme_Hash_Tree *)SCHEME_CAR(val); - pesl = SCHEME_CDR(val); - } else { - STX_ASSERT(SCHEME_HASHTRP(val)); - ht = (Scheme_Hash_Tree *)val; - pesl = NULL; - } - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - count = ht->count; - for (j = 0; j < count; j++) { - key = sorted_keys[j]; - val = scheme_hash_tree_get(ht, key); - l = val; - if (SCHEME_PAIRP(l)) { - add_conditional_as_reachable(SCHEME_BINDING_SCOPES(l), mt); - val = SCHEME_BINDING_VAL(l); - if (SCHEME_MPAIRP(val)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(l), mt); - } - } else { - STX_ASSERT(SCHEME_MPAIRP(l)); - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - add_conditional_as_reachable(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt); - val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(val)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt); - } - } - } - } - while (pesl) { - STX_ASSERT(SCHEME_RPAIRP(pesl)); - val = SCHEME_CAR(pesl); - STX_ASSERT(SCHEME_PAIRP(val)); - add_conditional_as_reachable((Scheme_Scope_Set *)SCHEME_CAR(val), mt); - pesl = SCHEME_CDR(pesl); - } - } - } - - /* Check for any free-id mappings whose reachbility depended on `scope`: */ - if (mt->pending_reachable_ids) { - l = scheme_eq_hash_get(mt->pending_reachable_ids, (Scheme_Object *)scope); - if (l) { - scheme_hash_set(mt->pending_reachable_ids, (Scheme_Object *)scope, NULL); - while (!SCHEME_NULLP(l)) { - val = SCHEME_CAR(l); - possiblly_reachable_free_id(SCHEME_CAR(val), (Scheme_Scope_Set *)SCHEME_CDR(val), mt); - l = SCHEME_CDR(l); - } - } - } - } - - /* Adjust mapping so that each scope maps to its relative position: */ - { - int i; - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)mt->reachable_scopes); - for (j = mt->reachable_scopes->count, i = 0; j--; i++) { - STX_ASSERT(SCHEME_SCOPEP(sorted_keys[j])); - scheme_hash_set(mt->reachable_scopes, sorted_keys[j], scheme_make_integer(i)); - } - } -} - -static Scheme_Object *intern_one(Scheme_Object *v, Scheme_Hash_Table *ht) -{ - Scheme_Object *result; - - result = scheme_hash_get(ht, v); - if (!result) { - result = scheme_make_marshal_shared(v); - scheme_hash_set(ht, v, result); - } - - return result; -} - -static Scheme_Object *intern_tails(Scheme_Object *l, Scheme_Hash_Table *ht) -{ - Scheme_Object *r, *result; - - r = scheme_null; - do { - if (SCHEME_NULLP(l)) - result = scheme_null; - else - result = scheme_hash_get(ht, l); - if (!result) { - r = scheme_make_pair(SCHEME_CAR(l), r); - l = SCHEME_CDR(l); - } - } while (!result); - - while (!SCHEME_NULLP(r)) { - result = scheme_make_pair(SCHEME_CAR(r), result); - l = scheme_make_pair(SCHEME_CAR(r), l); - result = scheme_make_marshal_shared(result); - scheme_hash_set(ht, l, result); - r = SCHEME_CDR(r); - } - - return result; -} - -static Scheme_Object *intern_fallback_tails(Scheme_Object *l, Scheme_Hash_Table *ht) -{ - Scheme_Object *r, *result; - - r = scheme_null; - do { - if (!SCHEME_FALLBACKP(l)) - result = l; - else - result = scheme_hash_get(ht, l); - if (!result) { - r = scheme_make_pair(SCHEME_FALLBACK_FIRST(l), r); - l = SCHEME_FALLBACK_REST(l); - } - } while (!result); - - while (!SCHEME_NULLP(r)) { - result = make_fallback_pair(SCHEME_CAR(r), result); - l = make_fallback_pair(SCHEME_CAR(r), l); - result = scheme_make_marshal_shared(result); - scheme_hash_set(ht, l, result); - r = SCHEME_CDR(r); - } - - return result; -} - -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -#include "../gc2/my_qsort.c" -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - -static int compare_scopes_from_multi(Scheme_Scope *a, Scheme_Scope *b) -{ - Scheme_Scope_With_Owner *ao, *bo; - - ao = (Scheme_Scope_With_Owner *)a; - bo = (Scheme_Scope_With_Owner *)b; - - if (SAME_OBJ(ao->owner_multi_scope, bo->owner_multi_scope)) { - if (SCHEME_FALSEP(ao->phase)) - return 1; - else if (SCHEME_FALSEP(bo->phase)) - return 1; - else if (scheme_bin_lt(ao->phase, bo->phase)) - return 1; - else - return -1; - } else { - Scheme_Object *na, *nb; - na = scheme_hash_get((Scheme_Hash_Table *)ao->owner_multi_scope, scheme_void); - nb = scheme_hash_get((Scheme_Hash_Table *)bo->owner_multi_scope, scheme_void); - STX_ASSERT(MULTI_SCOPE_META_HASHEDP(na)); - STX_ASSERT(MULTI_SCOPE_META_HASHEDP(nb)); - na = SCHEME_CDR(na); - nb = SCHEME_CDR(nb); - STX_ASSERT(SCHEME_REALP(na)); - STX_ASSERT(SCHEME_REALP(nb)); - if (scheme_bin_lt(na, nb)) - return 1; - else if (scheme_bin_lt(nb, na)) - return -1; - else - return 0; - } -} - -static int compare_scopes(const void *_a, const void *_b) -{ - Scheme_Scope *a = *(Scheme_Scope **)_a; - Scheme_Scope *b = *(Scheme_Scope **)_b; - - STX_ASSERT(SCHEME_SCOPEP(a)); - STX_ASSERT(SCHEME_SCOPEP(b)); - - /* Scopes for multi-scopes that were generated late are - ordered before everything else: */ - if (!(a->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) { - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(a)); - if (b->id >> SCHEME_STX_SCOPE_KIND_SHIFT) - return 1; - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b)); - - return compare_scopes_from_multi(a, b); - } else if (!(b->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) { - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b)); - return -1; - } - - if (a->id > b->id) - return -1; - else if (a->id < b->id) - return 1; - else - return 0; -} - -static void sort_scope_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_scopes); -} - -static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes) -{ - Scheme_Object **a, *r, *key, *val; - intptr_t i, j = 0; - - i = scope_set_count(scopes); - a = MALLOC_N(Scheme_Object *, i); - - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - a[j++] = key; - i = scope_set_next(scopes, i); - } - - sort_scope_array(a, j); - - r = scheme_null; - for (i = j; i--; ) { - r = scheme_make_pair(a[i], r); - } - - return r; -} - -static int compare_syms(const void *_a, const void *_b) -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - intptr_t l = SCHEME_SYM_LEN(a), i; - - STX_ASSERT(SCHEME_SYMBOLP(a)); - STX_ASSERT(SCHEME_SYMBOLP(b)); - - if (SCHEME_SYM_LEN(b) < l) - l = SCHEME_SYM_LEN(b); - - for (i = 0; i < l; i++) { - if (SCHEME_SYM_VAL(a)[i] != SCHEME_SYM_VAL(b)[i]) - return (SCHEME_SYM_VAL(a)[i] - SCHEME_SYM_VAL(b)[i]); - } - - return SCHEME_SYM_LEN(a) - SCHEME_SYM_LEN(b); -} - -static void sort_vector_symbols(Scheme_Object *vec) -{ - my_qsort(SCHEME_VEC_ELS(vec), SCHEME_VEC_SIZE(vec), sizeof(Scheme_Object *), compare_syms); -} - -static void sort_symbol_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_syms); -} - -static int compare_nums(const void *_a, const void *_b) -/* also allow #fs */ -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - - if (SCHEME_FALSEP(a)) - return -1; - else if (SCHEME_FALSEP(b)) - return 1; - - STX_ASSERT(SCHEME_REALP(a)); - STX_ASSERT(SCHEME_REALP(b)); - - if (scheme_bin_lt(a, b)) - return -1; - else if (scheme_bin_lt(b, a)) - return 1; - else - return 0; -} - -static void sort_number_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_nums); -} - -static int compare_vars_at_resolve(const void *_a, const void *_b) -{ - Scheme_IR_Local *a = *(Scheme_IR_Local **)_a; - Scheme_IR_Local *b = *(Scheme_IR_Local **)_b; - return a->resolve.lex_depth - b->resolve.lex_depth; -} - -void scheme_sort_resolve_ir_local_array(Scheme_IR_Local **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_IR_Local *), compare_vars_at_resolve); -} - -static Scheme_Object *drop_export_registries(Scheme_Object *shifts) -{ - Scheme_Object *l, *a, *vec, *p, *first = scheme_null, *last = NULL; - int same_insp; - - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - same_insp = ((SCHEME_VEC_SIZE(a) <= 2) - || SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(a)[3]) - || SCHEME_FALSEP(SCHEME_VEC_ELS(a)[3])); - if (!SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(a)[1]) - || !same_insp) { - if (same_insp) - vec = scheme_make_vector(2, NULL); - else - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(a)[0]; - SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(a)[1]; - if (!same_insp) { - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(a)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(a)[3]; - } - - p = scheme_make_pair(vec, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - return first; -} - -static void init_identity_map(Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *id_map; - id_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->identity_map = id_map; -} - -static int compare_phased_scopes(const void *_a, const void *_b) -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - - if (SCHEME_FALSEP(a)) - return -1; - else if (SCHEME_FALSEP(b)) - return 1; - else { - STX_ASSERT(SCHEME_REALP(a)); - STX_ASSERT(SCHEME_REALP(b)); - if (scheme_bin_lt(a, b)) - return -1; - else - return 1; - } -} - -static Scheme_Object *multi_scope_to_vector(Scheme_Object *multi_scope, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *vec; - Scheme_Hash_Table *scopes = (Scheme_Hash_Table *)multi_scope; - intptr_t i, j, count; - - if (!mt->identity_map) - init_identity_map(mt); - - vec = scheme_hash_get(mt->identity_map, multi_scope); - if (vec) - return vec; - - /* only keep reachable scopes: */ - count = 0; - for (i = scopes->size; i--; ) { - if (scopes->vals[i]) { - if (!MULTI_SCOPE_METAP(scopes->keys[i])) { - if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) - count++; - } - } - } - - vec = scheme_make_vector((2 * count) + 1, scheme_void); - j = 0; - for (i = scopes->size; i--; ) { - if (scopes->vals[i]) { - if (!MULTI_SCOPE_METAP(scopes->keys[i])) { - if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) { - SCHEME_VEC_ELS(vec)[j++] = scopes->keys[i]; /* a phase */ - SCHEME_VEC_ELS(vec)[j++] = scopes->vals[i]; /* a scope */ - } - } else { - /* debug name */ - SCHEME_VEC_ELS(vec)[2 * count] = (MULTI_SCOPE_META_HASHEDP(scopes->vals[i]) - ? SCHEME_CAR(scopes->vals[i]) - : scopes->vals[i]); - } - } - } - - my_qsort(SCHEME_VEC_ELS(vec), count, 2 * sizeof(Scheme_Object *), compare_phased_scopes); - - vec = scheme_make_marshal_shared(vec); - - scheme_hash_set(mt->identity_map, multi_scope, vec); - - return vec; -} - -static Scheme_Object *marshal_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt, Scheme_Hash_Table *ht) -{ - Scheme_Object *l, *p, *first, *last; - Scheme_Object *fb_first = scheme_null, *fb_last = NULL; - - while (1) { - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - first = scheme_null; - last = NULL; - - while (!SCHEME_NULLP(l)) { - p = scheme_make_pair(scheme_make_pair(multi_scope_to_vector(SCHEME_CAR(SCHEME_CAR(l)), mt), - SCHEME_CDR(SCHEME_CAR(l))), - scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - l = SCHEME_CDR(l); - } - - first = intern_tails(first, ht); - - if (SCHEME_FALLBACKP(multi_scopes)) - first = make_fallback_pair(first, scheme_false); - - if (fb_last) - SCHEME_FALLBACK_REST(fb_last) = first; - else - fb_first = first; - fb_last = first; - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - break; - } - - if (SCHEME_FALLBACKP(fb_first)) - fb_first = intern_fallback_tails(fb_first, ht); - - return fb_first; -} - -static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *ht; - Scheme_Object *shifts, *simples, *multi, *v, *vec; - - if (mt->pass < 0) { - /* This is the pass to discover reachable scopes. */ - add_reachable_scopes(stx->scopes->simple_scopes, mt); - add_reachable_multi_scopes(stx->scopes->multi_scopes, mt); - return scheme_void; - } - - ht = mt->intern_map; - - shifts = intern_tails(drop_export_registries(stx->shifts), ht); - simples = intern_tails(scopes_to_sorted_list(stx->scopes->simple_scopes), ht); - multi = marshal_multi_scopes(stx->scopes->multi_scopes, mt, ht); - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = shifts; - SCHEME_VEC_ELS(vec)[1] = simples; - SCHEME_VEC_ELS(vec)[2] = multi; - - v = scheme_hash_get(ht, vec); - if (!v) { - v = scheme_make_marshal_shared(vec); - scheme_hash_set(ht, vec, v); - } - - return v; -} - -static Scheme_Object *marshal_free_id_info(Scheme_Object *id_plus_phase, Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *stx = (Scheme_Stx *)SCHEME_CAR(id_plus_phase); - - return scheme_make_pair(scheme_make_pair(stx->val, wraps_to_datum(stx, mt)), - SCHEME_CDR(id_plus_phase)); -} - -static Scheme_Object *marshal_bindings(Scheme_Object *l, Scheme_Marshal_Tables *mt) -/* l is a pair for one binding, or an mlist of bindings */ -{ - Scheme_Object *r, *scopes, *v; - - r = scheme_null; - - while (!SCHEME_NULLP(l)) { - if (SCHEME_PAIRP(l)) - scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(l); - else { - STX_ASSERT(SCHEME_MPAIRP(l)); - scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - } - - if (!any_unreachable_scope((Scheme_Scope_Set *)scopes, mt, 0)) { - if (SCHEME_PAIRP(l)) - v = SCHEME_BINDING_VAL(l); - else - v = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(v)) { - /* has a `free-id=?` equivalence; the marshaled form of a scope's content - cannot contain a syntax object, so we keep just the syntax object's symbol - and scopes */ - v = scheme_make_pair(SCHEME_CAR(v), marshal_free_id_info(SCHEME_CDR(v), mt)); - v = scheme_box(v); /* a box indicates `free-id=?` info */ - } - v = intern_one(v, mt->intern_map); - scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)scopes), - mt->intern_map); - r = scheme_make_pair(intern_one(scheme_make_pair(scopes, v), mt->intern_map), r); - } - - if (SCHEME_MPAIRP(l)) - l = SCHEME_CDR(l); - else - l = scheme_null; - } - - if (!SCHEME_NULLP(r)) - r = intern_one(r, mt->intern_map); - - return r; -} - -Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Tree *ht; - Scheme_Object *v, *l, *r, *l2, *tab, *scopes, *val, **sorted_keys; - intptr_t i, j; - - if (!mt->identity_map) - init_identity_map(mt); - - v = scheme_hash_get(mt->identity_map, m); - if (v) - return v; - - v = ((Scheme_Scope *)m)->bindings; - if (v) { - int count; - - if (SCHEME_VECTORP(v)) { - ht = NULL; - l2 = NULL; - count = 1; - } else { - if (SCHEME_RPAIRP(v)) { - ht = (Scheme_Hash_Tree *)SCHEME_CAR(v); - l2 = SCHEME_CDR(v); - } else { - STX_ASSERT(SCHEME_HASHTRP(v)); - ht = (Scheme_Hash_Tree *)v; - l2 = NULL; - } - count = ht->count; - } - - /* convert to a vector, pruning unreachable and adjusting - encoding of `free-identifier=?` equivalences */ - tab = scheme_make_vector(2 * count, NULL); - j = 0; - if (!ht) { - STX_ASSERT(SCHEME_VECTORP(v)); - r = marshal_bindings(scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(v), - SCHEME_VEC_BINDING_VAL(v)), - mt); - if (SCHEME_NULLP(r)) { - /* no reachable bindings */ - } else { - SCHEME_VEC_ELS(tab)[j++] = SCHEME_VEC_BINDING_KEY(v); - SCHEME_VEC_ELS(tab)[j++] = r; - } - } else { - intptr_t count = ht->count; - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - for (i = 0; i < count; i++) { - val = scheme_hash_tree_get(ht, sorted_keys[i]); - r = marshal_bindings(val, mt); - - if (SCHEME_NULLP(r)) { - /* no reachable bindings */ - } else { - STX_ASSERT(j < (2 * count)); - SCHEME_VEC_ELS(tab)[j++] = sorted_keys[i]; - SCHEME_VEC_ELS(tab)[j++] = r; - } - } - } - - if (j < SCHEME_VEC_SIZE(tab)) { - /* shrink vector: */ - r = scheme_make_vector(j, NULL); - memcpy(SCHEME_VEC_ELS(r), SCHEME_VEC_ELS(tab), j * sizeof(Scheme_Object *)); - } else - r = tab; - - /* convert scopes+pes to scope + unmarshal request */ - for (l = l2; l; l = SCHEME_CDR(l)) { - STX_ASSERT(SCHEME_RPAIRP(l)); - v = SCHEME_CDR(SCHEME_CAR(l)); - if (any_unreachable_scope((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l)), mt, 0)) { - /* drop unreachable bindings */ - v = NULL; - } else if (PES_BINDINGP(v)) { - l2 = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(l2)[0] = SCHEME_VEC_ELS(v)[0]; - SCHEME_VEC_ELS(l2)[1] = SCHEME_VEC_ELS(v)[2]; - SCHEME_VEC_ELS(l2)[3] = SCHEME_VEC_ELS(v)[4]; - v = unmarshal_excepts_to_vector(SCHEME_VEC_ELS(v)[3]); - SCHEME_VEC_ELS(l2)[2] = v; - v = l2; - } else if (PES_UNMARSHAL_DESCP(v)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[0])) { - /* never unmarshaled, so keep it */ - } else { - /* this shouldn't happen, because it should have been - replaced on unmarshal, but discard it if we get here */ - v = NULL; - } - } else { - STX_ASSERT(0); - } - if (v) { - scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l))), - mt->intern_map); - r = scheme_make_pair(scheme_make_pair(scopes, v), r); - } - } - - v = scheme_make_pair(scheme_make_integer(SCHEME_SCOPE_KIND(m)), r); - } else - v = scheme_make_integer(SCHEME_SCOPE_KIND(m)); - - scheme_hash_set(mt->identity_map, m, v); - - return v; -} - -/*========================================================================*/ -/* syntax->datum */ -/*========================================================================*/ - -/* This code can convert a syntax object plus its wraps to something - writeable. In that case, the result is a : - - = | ... - - = (MK (cons (cons ... )) ) - | (MK (cons ... null) ) - | (MK (cons #t ) ) - ; where has no boxes or vectors, and - ; , , and are shared in all elements - = (MK (box ) ) - = (MK (vector ...) ) - = (MK ) - ; where is not a pair, vector, or box - - where - - (MK #f 0) = (cons ) - (MK 0) = (vector ) - (MK #f ) = (vector ) - (MK ) = (vector ) - -*/ - -#define COMMON_EXTRACT_DATUM 0 -#define COMMON_EXTRACT_WRAPS 1 -#define COMMON_EXTRACT_SRCLOC 2 -#define COMMON_EXTRACT_TAINT 3 - -static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_part, int pair_ok) -{ - /* We only share wraps for things constucted with pairs and - atomic (w.r.t. syntax) values. */ - Scheme_Object *v, *wraps, *srcloc, *taint; - - if (SCHEME_PAIRP(a)) { - v = SCHEME_CAR(a); - wraps = SCHEME_CDR(a); - srcloc = scheme_false; - taint = scheme_make_integer(0); - } else if (SCHEME_VECTORP(a)) { - v = SCHEME_VEC_ELS(a)[0]; - wraps = SCHEME_VEC_ELS(a)[1]; - srcloc = SCHEME_VEC_ELS(a)[2]; - if (SCHEME_INTP(srcloc)) { /* an integer is a taint or arm value */ - taint = srcloc; - srcloc = scheme_false; - } else if (SCHEME_VEC_SIZE(a) > 3) - taint = SCHEME_VEC_ELS(a)[3]; - else - taint = scheme_make_integer(0); - } else - return NULL; - - if (SCHEME_PAIRP(v)) { - if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) { - /* A pair with shared wraps for its elements */ - if (get_part == COMMON_EXTRACT_WRAPS) - return wraps; - else if (get_part == COMMON_EXTRACT_SRCLOC) - return srcloc; - else if (get_part == COMMON_EXTRACT_TAINT) - return taint; - else - return SCHEME_CDR(v); - } - } else if (!SCHEME_NULLP(v) && !SCHEME_BOXP(v) && !SCHEME_VECTORP(v) && !SCHEME_HASHTRP(v) && !prefab_p(v)) { - /* It's atomic. */ - if (get_part == COMMON_EXTRACT_WRAPS) - return wraps; - else if (get_part == COMMON_EXTRACT_SRCLOC) - return srcloc; - else if (get_part == COMMON_EXTRACT_TAINT) - return taint; - else - return v; - } - - return NULL; -} - -static void lift_common_wraps(Scheme_Object *l, int cnt, int tail) -{ - Scheme_Object *a; - - while (cnt--) { - a = SCHEME_CAR(l); - a = extract_for_common_wrap(a, COMMON_EXTRACT_DATUM, 1); - SCHEME_CAR(l) = a; - if (cnt) - l = SCHEME_CDR(l); - } - if (tail) { - a = SCHEME_CDR(l); - a = extract_for_common_wrap(a, COMMON_EXTRACT_DATUM, 0); - SCHEME_CDR(l) = a; - } -} - -static Scheme_Object *srcloc_path_to_string(Scheme_Object *p) -{ - Scheme_Object *base, *name, *dir_name; - int isdir; - - name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); - if (SCHEME_PATHP(name) && SCHEME_PATHP(base)) { - dir_name = scheme_split_path(SCHEME_PATH_VAL(base), SCHEME_PATH_LEN(base), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); - if (SCHEME_FALSEP(base)) { - /* Path is file at root, so just keep the whole path */ - return scheme_path_to_char_string(p); - } - if (SCHEME_PATHP(dir_name)) - name = scheme_append_strings(scheme_path_to_char_string(dir_name), - scheme_append_strings(scheme_make_utf8_string("/"), - scheme_path_to_char_string(name))); - else - name = scheme_path_to_char_string(name); - return scheme_append_strings(scheme_make_utf8_string(".../"), name); - } else if (SCHEME_PATHP(name)) - return scheme_path_to_char_string(name); - else - return scheme_false; -} - -static Scheme_Object *convert_prop_val_k(void); - -static Scheme_Object *convert_prop_val(Scheme_Object *val, Scheme_Marshal_Tables *mt, - Scheme_Unmarshal_Tables *ut, - Scheme_Hash_Tree *seen) -/* Encode or decode a property value to encode/decode syntax objects - contained in the value. In encode mode, an exception is raised if any - disallowed value is found. In decoding mode, the result is NULL - if decoding fails. */ -{ -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)val; - p->ku.k.p2 = (void *)mt; - p->ku.k.p3 = (void *)ut; - p->ku.k.p4 = (void *)seen; - - return scheme_handle_stack_overflow(convert_prop_val_k); - } - } -#endif - - if (scheme_hash_tree_get(seen, val)) { - if (mt) - scheme_raise_exn(MZEXN_FAIL, - "write: disallowed cycle within preserved syntax property\n value: %V", - val); - return NULL; - } - - if (SCHEME_PAIRP(val)) { - Scheme_Object *a, *d; - seen = scheme_hash_tree_set(seen, val, scheme_true); - a = convert_prop_val(SCHEME_CAR(val), mt, ut, seen); - d = convert_prop_val(SCHEME_CDR(val), mt, ut, seen); - if (a && d) - return CONS(a, d); - else - return NULL; - } else if (mt ? SCHEME_BOXP(val) : SCHEME_IMMUTABLE_BOXP(val)) { - Scheme_Object *c; - seen = scheme_hash_tree_set(seen, val, scheme_true); - c = convert_prop_val(SCHEME_BOX_VAL(val), mt, ut, seen); - if (c) { - c = scheme_box(c); - SCHEME_SET_IMMUTABLE(c); - return c; - } else - return NULL; - } else if (mt ? SCHEME_VECTORP(val) : SCHEME_IMMUTABLE_VECTORP(val)) { - intptr_t len = SCHEME_VEC_SIZE(val); - if (ut && (len == 2) && SCHEME_TRUEP(SCHEME_VEC_ELS(val)[0])) { - /* A vector that starts #t encodes a syntax object */ - return datum_to_syntax_inner(SCHEME_VEC_ELS(val)[1], - ut, - (Scheme_Stx *)scheme_false, - (Scheme_Stx *)scheme_false, - NULL, - 0); - } else if (len) { - int start, offset; - Scheme_Object *vec, *v; - intptr_t i; - if (mt) { - /* Encode a vector in a vectot that starts #f */ - vec = scheme_make_vector(len+1, scheme_false); - offset = 1; - start = 0; - } else { - /* Decode from a vector that starts #f */ - if (len < 1) return NULL; - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(val)[0])) return NULL; - vec = scheme_make_vector(len-1, scheme_false); - offset = -1; - start = 1; - } - seen = scheme_hash_tree_set(seen, val, scheme_true); - for (i = start; i < len; i++) { - v = convert_prop_val(SCHEME_VEC_ELS(val)[i], mt, ut, seen); - if (!v) - return NULL; - SCHEME_VEC_ELS(vec)[i+offset] = v; - } - SCHEME_SET_IMMUTABLE(vec); - return vec; - } else - return val; - } else if (prefab_p(val)) { - Scheme_Structure *s = (Scheme_Structure *)val; - Scheme_Object *a; - int size = s->stype->num_slots, i; - - seen = scheme_hash_tree_set(seen, val, scheme_true); - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - for (i = 0; i < size; i++) { - a = convert_prop_val(s->slots[i], mt, ut, seen); - if (!a) - return NULL; - s->slots[i] = a; - } - - return (Scheme_Object *)s; - } else if (SCHEME_HASHTRP(val)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)val, *ht2; - Scheme_Object *key, *tval; - mzlonglong i; - - seen = scheme_hash_tree_set(seen, val, scheme_true); - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &tval); - tval = convert_prop_val(tval, mt, ut, seen); - if (!tval) - return NULL; - ht2 = scheme_hash_tree_set(ht2, key, tval); - i = scheme_hash_tree_next(ht, i); - } - - return (Scheme_Object *)ht2; - } else if (SCHEME_STXP(val)) { - /* Encode a syntax object in a vectot that starts #t */ - Scheme_Object *v; - if (!mt) - return NULL; - v = syntax_to_datum_inner(val, 1, mt); - v = scheme_make_vector(2, v); - SCHEME_VEC_ELS(v)[0] = scheme_true; - return v; - } else if (SCHEME_BOOLP(val) - || SCHEME_NULLP(val) - || SCHEME_SYMBOLP(val) - || SCHEME_CHARP(val) - || SCHEME_NUMBERP(val) - || SCHEME_BYTE_STRINGP(val) - || SCHEME_CHAR_STRINGP(val) - || SAME_TYPE(SCHEME_TYPE(val), scheme_regexp_type)) { - return val; - } else { - if (mt) - scheme_raise_exn(MZEXN_FAIL, - "write: disallowed value within preserved syntax property\n value: %V", - val); - return NULL; - } -} - -static Scheme_Object *convert_prop_val_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *val = (Scheme_Object *)p->ku.k.p1; - Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p2; - Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p3; - Scheme_Hash_Tree *seen = (Scheme_Hash_Tree *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return convert_prop_val(val, mt, ut, seen); -} - -static Scheme_Object *convert_srcloc(Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree *props, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *vec, *paren, *src, *dir, *preserved_properties; - - if (props) { - paren = scheme_hash_tree_get(props, scheme_paren_shape_symbol); - if (paren && !(SAME_TYPE(SCHEME_TYPE(paren), scheme_syntax_property_preserve_type) - && SCHEME_CHARP(SCHEME_PTR_VAL(paren)))) - paren = NULL; - } else - paren = NULL; - - preserved_properties = scheme_null; - if (props) { - Scheme_Object *key, *val, **a = NULL; - intptr_t i, count = 0; - - i = scheme_hash_tree_next(props, -1); - while (i != -1) { - scheme_hash_tree_index(props, i, &key, &val); - if (SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)) { - if (!paren || !SAME_OBJ(key, scheme_paren_shape_symbol)) { - if (!a) - a = MALLOC_N(Scheme_Object *, props->count); - a[count++] = key; - } - } - i = scheme_hash_tree_next(props, i); - } - - if (count) { - /* Sort to make list deterministic */ - sort_symbol_array(a, count); - for (i = count; i--; ) { - val = scheme_hash_tree_get(props, a[i]); - val = convert_prop_val(SCHEME_PTR_VAL(val), mt, NULL, empty_hash_tree); - preserved_properties = CONS(CONS(a[i], val), preserved_properties); - } - } - } - - if ((!srcloc || (SCHEME_FALSEP(srcloc->src) - && (srcloc->line < 0) - && (srcloc->col < 0) - && (srcloc->pos < 0))) - && !paren - && SCHEME_NULLP(preserved_properties)) - return scheme_false; - - if (!srcloc) - srcloc = empty_srcloc; - - src = srcloc->src; - if (SCHEME_PATHP(src)) { - /* To make paths portable and to avoid full paths, check whether the - path can be made relative (in which case it is turned into a list - of byte strings). If not, convert to a string using only the - last couple of path elements. */ - dir = scheme_get_param(scheme_current_config(), - MZCONFIG_WRITE_DIRECTORY); - if (SCHEME_TRUEP(dir)) - src = scheme_extract_relative_to(src, dir, mt->path_cache); - if (SCHEME_PATHP(src)) { - src = scheme_hash_get(mt->path_cache, scheme_box(srcloc->src)); - if (!src) { - src = srcloc_path_to_string(srcloc->src); - scheme_hash_set(mt->path_cache, scheme_box(srcloc->src), src); - } - } else { - /* use the path directly and let the printer make it relative */ - src = srcloc->src; - } - } - - vec = scheme_make_vector(((paren || !SCHEME_NULLP(preserved_properties)) - ? (SCHEME_NULLP(preserved_properties) - ? 6 - : 7) - : 5), - NULL); - SCHEME_VEC_ELS(vec)[0] = src; - SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(srcloc->line); - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(srcloc->col); - SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(srcloc->pos); - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(srcloc->span); - if (paren || !SCHEME_NULLP(preserved_properties)) - SCHEME_VEC_ELS(vec)[5] = (paren ? SCHEME_PTR_VAL(paren) : scheme_false); - if (!SCHEME_NULLP(preserved_properties)) - SCHEME_VEC_ELS(vec)[6] = preserved_properties; - - return intern_one(vec, mt->intern_map); -} - -static void unconvert_srcloc(Scheme_Object *srcloc_vec, Scheme_Stx *dest, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Stx_Srcloc *srcloc; - - if (!SCHEME_VECTORP(srcloc_vec) - || ((SCHEME_VEC_SIZE(srcloc_vec) != 5) - && (SCHEME_VEC_SIZE(srcloc_vec) != 6) - && (SCHEME_VEC_SIZE(srcloc_vec) != 7))) - return; - - srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); -#ifdef MZTAG_REQUIRED - srcloc->type = scheme_rt_srcloc; -#endif - srcloc->src = SCHEME_VEC_ELS(srcloc_vec)[0]; - srcloc->line = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[1]); - srcloc->col = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[2]); - srcloc->pos = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[3]); - srcloc->span = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[4]); - - dest->srcloc = srcloc; - - if ((SCHEME_VEC_SIZE(srcloc_vec) > 5) - && SCHEME_CHARP((SCHEME_VEC_ELS(srcloc_vec)[5]))) { - if (SCHEME_CHAR_VAL(SCHEME_VEC_ELS(srcloc_vec)[5]) == '[') - dest->props = square_stx_props; - else if (SCHEME_CHAR_VAL(SCHEME_VEC_ELS(srcloc_vec)[5]) == '{') - dest->props = curly_stx_props; - } - - if (SCHEME_VEC_SIZE(srcloc_vec) > 6) { - /* Restore preserved properties */ - Scheme_Object *l = SCHEME_VEC_ELS(srcloc_vec)[6], *p, *v; - Scheme_Hash_Tree *props; - while (SCHEME_PAIRP(l)) { - p = SCHEME_CAR(l); - if (SCHEME_PAIRP(p) - && SCHEME_SYMBOLP(SCHEME_CAR(p)) - && !SCHEME_SYM_WEIRDP(SCHEME_CAR(p))) { - v = convert_prop_val(SCHEME_CDR(p), NULL, ut, empty_hash_tree); - if (v) { - props = scheme_hash_tree_set((dest->props ? dest->props : empty_hash_tree), - SCHEME_CAR(p), - make_preserved_property_value(v)); - dest->props = props; - } - } - l = SCHEME_CDR(l); - } - } -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *syntax_to_datum_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p3 = NULL; - - return syntax_to_datum_inner(o, p->ku.k.i1, mt); -} -#endif - -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_scopes, /* non-zero => marshal; negative => implicitly tainted */ - Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *v, *result, *converted_wraps = NULL; - int add_taint = 0; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.i1 = with_scopes; - p->ku.k.p3 = (void *)mt; - return scheme_handle_stack_overflow(syntax_to_datum_k); - } - } -#endif - SCHEME_USE_FUEL(1); - - if (with_scopes) { - /* Propagate wraps: */ - scheme_stx_content((Scheme_Object *)stx); - if (with_scopes > 0) { - if (is_tainted((Scheme_Object *)stx)) { - add_taint = 1; - with_scopes = -with_scopes; - } else if (is_armed((Scheme_Object *)stx)) { - add_taint = 2; - } - } - } - - v = stx->val; - - if (SCHEME_PAIRP(v)) { - Scheme_Object *first = NULL, *last = NULL, *p; - Scheme_Object *common_wraps = NULL, *common_srcloc = NULL, *common_taint = NULL; - Scheme_Object *a, *sa, *ta; - int cnt = 0; - - while (SCHEME_PAIRP(v)) { - cnt++; - - a = syntax_to_datum_inner(SCHEME_CAR(v), with_scopes, mt); - - p = CONS(a, scheme_null); - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - - if (with_scopes) { - sa = extract_for_common_wrap(a, COMMON_EXTRACT_SRCLOC, 1); - ta = extract_for_common_wrap(a, COMMON_EXTRACT_TAINT, 1); - a = extract_for_common_wrap(a, COMMON_EXTRACT_WRAPS, 1); - if (!common_wraps) { - if (a) { - common_wraps = a; - common_srcloc = sa; - common_taint = ta; - } else - common_wraps = scheme_false; - } else if (!a - || !SAME_OBJ(common_wraps, a) - || !SAME_OBJ(common_srcloc, sa) - || !SAME_OBJ(common_taint, ta)) - common_wraps = scheme_false; - } - } - if (!SCHEME_NULLP(v)) { - v = syntax_to_datum_inner(v, with_scopes, mt); - SCHEME_CDR(last) = v; - - if (with_scopes) { - sa = extract_for_common_wrap(v, COMMON_EXTRACT_SRCLOC, 0); - ta = extract_for_common_wrap(v, COMMON_EXTRACT_TAINT, 0); - v = extract_for_common_wrap(v, COMMON_EXTRACT_WRAPS, 0); - if (v - && SAME_OBJ(common_wraps, v) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, ta)) { - converted_wraps = wraps_to_datum(stx, mt); - sa = convert_srcloc(stx->srcloc, stx->props, mt); - if (SAME_OBJ(common_wraps, converted_wraps) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, scheme_make_integer(add_taint))) - lift_common_wraps(first, cnt, 1); - else - common_wraps = scheme_false; - } else - common_wraps = scheme_false; - } - - if (with_scopes && SCHEME_FALSEP(common_wraps)) { - /* v is likely a pair, and v's car might be a pair, - which means that the datum->syntax part - won't be able to detect that v is a "non-pair" - terminal. Therefore, we communicate the - length before the terminal to datum->syntax: */ - first = scheme_make_pair(scheme_make_integer(cnt), first); - } - } else if (with_scopes && SCHEME_TRUEP(common_wraps)) { - converted_wraps = wraps_to_datum(stx, mt); - sa = convert_srcloc(stx->srcloc, stx->props, mt); - if (SAME_OBJ(common_wraps, converted_wraps) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, scheme_make_integer(add_taint))) - lift_common_wraps(first, cnt, 0); - else - common_wraps = scheme_false; - } - - if (with_scopes && SCHEME_TRUEP(common_wraps)) { - first = scheme_make_pair(scheme_true, first); - } - - result = first; - } else if (SCHEME_BOXP(v)) { - v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_scopes, mt); - result = scheme_box(v); - SCHEME_SET_IMMUTABLE(result); - } else if (SCHEME_VECTORP(v)) { - int size = SCHEME_VEC_SIZE(v), i; - Scheme_Object *r, *a; - - r = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_scopes, mt); - SCHEME_VEC_ELS(r)[i] = a; - } - - result = r; - SCHEME_SET_IMMUTABLE(result); - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = syntax_to_datum_inner(val, with_scopes, mt); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - result = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *a; - int size = s->stype->num_slots, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(s->slots[i], with_scopes, mt); - s->slots[i] = a; - } - - result = (Scheme_Object *)s; - } else - result = v; - - if (with_scopes) { - if (!converted_wraps) - converted_wraps = wraps_to_datum(stx, mt); - v = convert_srcloc(stx->srcloc, stx->props, mt); - if (SCHEME_TRUEP(v)) { - result = scheme_make_vector((add_taint ? 4 : 3), result); - SCHEME_VEC_ELS(result)[1] = converted_wraps; - SCHEME_VEC_ELS(result)[2] = v; - if (add_taint) - SCHEME_VEC_ELS(result)[3] = scheme_make_integer(add_taint); /* 1 => tainted, 2 => armed */ - } else if (add_taint) { - result = scheme_make_vector(3, result); - SCHEME_VEC_ELS(result)[1] = converted_wraps; - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(add_taint); /* 1 => tainted, 2 => armed */ - } else - result = CONS(result, converted_wraps); - } - - return result; -} - -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, - Scheme_Marshal_Tables *mt) -{ - Scheme_Object *v; - - if (mt && (mt->pass >= 0)) - scheme_marshal_push_refs(mt); - - v = syntax_to_datum_inner(stx, with_scopes, mt); - - if (mt && (mt->pass >= 0)) { - /* A symbol+wrap combination is likely to be used multiple - times. This is a relatively minor optimization in .zo size, - since v is already fairly compact, but it also avoids - allocating extra syntax objects at load time. For consistency, - we try to reuse all combinations. */ - Scheme_Hash_Table *top_map; - Scheme_Object *key; - - top_map = mt->top_map; - if (!top_map) { - top_map = scheme_make_hash_table_equal(); - mt->top_map = top_map; - } - - key = scheme_hash_get(top_map, v); - if (key) { - scheme_marshal_pop_refs(mt, 0); - v = scheme_marshal_lookup(mt, key); - scheme_marshal_using_key(mt, key); - } else { - scheme_hash_set(top_map, stx, v); - v = scheme_marshal_wrap_set(mt, stx, v); - scheme_marshal_pop_refs(mt, 1); - } - } - - return v; -} - -/*========================================================================*/ -/* datum->syntax */ -/*========================================================================*/ - -#define return_NULL return NULL - -Scheme_Object *scheme_hash_get_either(Scheme_Hash_Table *ht, Scheme_Hash_Table *ht2, - Scheme_Object *key) -{ - Scheme_Object *val; - val = scheme_hash_get(ht, key); - if (val) - return val; - else if (ht2) - return scheme_hash_get(ht2, key); - else - return NULL; -} - -static void ensure_current_rns(Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *rht; - if (!ut->current_rns) { - rht = scheme_make_hash_table(SCHEME_hash_ptr); - ut->current_rns = rht; - } -} - -static void ensure_current_multi_scope_pairs(Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *rht; - if (!ut->current_multi_scope_pairs) { - rht = scheme_make_hash_table(SCHEME_hash_ptr); - ut->current_multi_scope_pairs = rht; - } -} - -Scheme_Scope_Set *list_to_scope_set(Scheme_Object *l, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Scope_Set *scopes = NULL; - Scheme_Object *r = scheme_null, *scope; - - if (scheme_proper_list_length(l) < 0) return_NULL; - - while (!SCHEME_NULLP(l)) { - if (!SCHEME_PAIRP(l)) return_NULL; - scopes = (Scheme_Scope_Set *)scheme_hash_get_either(ut->rns, ut->current_rns, l); - if (scopes) - break; - r = scheme_make_pair(l, r); - l = SCHEME_CDR(l); - } - - if (!scopes) scopes = empty_scope_set; - - while (!SCHEME_NULLP(r)) { - l = SCHEME_CAR(r); - - scope = scope_unmarshal_content(SCHEME_CAR(l), ut); - if (!scope) return_NULL; - - scopes = scope_set_set(scopes, scope, scheme_true); - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, l, (Scheme_Object *)scopes); - - r = SCHEME_CDR(r); - } - - return scopes; -} - -static Scheme_Hash_Table *vector_to_multi_scope(Scheme_Object *mht, Scheme_Unmarshal_Tables *ut) -{ - /* Convert multi-scope vector to hash table */ - intptr_t i, len; - Scheme_Hash_Table *multi_scope; - Scheme_Object *scope; - - if (!SCHEME_VECTORP(mht)) return_NULL; - - multi_scope = (Scheme_Hash_Table *)scheme_hash_get_either(ut->rns, ut->current_rns, mht); - if (multi_scope) return multi_scope; - - multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); - - len = SCHEME_VEC_SIZE(mht); - if (!(len & 1)) return_NULL; - - STX_ASSERT(ut->bytecode_hash); - - multi_scope = (Scheme_Hash_Table *)new_multi_scope(SCHEME_VEC_ELS(mht)[len-1]); - scheme_hash_set(multi_scope, - scheme_void, - /* record bytecode hash for making fresh scopes for other phases: */ - scheme_make_mutable_pair(scheme_hash_get(multi_scope, scheme_void), - scheme_make_integer_value_from_long_long(ut->bytecode_hash - >> SCHEME_STX_SCOPE_KIND_SHIFT))); - len -= 1; - - /* A multi-scope can refer back to itself via free-id=? info: */ - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, mht, (Scheme_Object *)multi_scope); - - for (i = 0; i < len; i += 2) { - if (!SCHEME_PHASEP(SCHEME_VEC_ELS(mht)[i])) - return_NULL; - scope = SCHEME_VEC_ELS(mht)[i+1]; - scope = scope_unmarshal_content(scope, ut); - if (!scope) return_NULL; - if (!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)scope)) - return_NULL; - if (((Scheme_Scope_With_Owner *)scope)->owner_multi_scope) - return_NULL; - scheme_hash_set(multi_scope, SCHEME_VEC_ELS(mht)[i], scope); - ((Scheme_Scope_With_Owner *)scope)->owner_multi_scope = (Scheme_Object *)multi_scope; - ((Scheme_Scope_With_Owner *)scope)->phase = SCHEME_VEC_ELS(mht)[i]; - } - - return multi_scope; -} - -Scheme_Object *unmarshal_multi_scopes(Scheme_Object *multi_scopes, - Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *multi_scope; - Scheme_Object *l, *mm_l, *first = NULL, *last = NULL; - Scheme_Object *l_first, *l_last, *p; - - mm_l = multi_scopes; - - while (1) { - l = mm_l; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - if (scheme_proper_list_length(l) < 0) return_NULL; - - l_first = scheme_null; - l_last = NULL; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - int stop; - - if (!SCHEME_PAIRP(l)) return_NULL; - if (!SCHEME_PAIRP(SCHEME_CAR(l))) return_NULL; - - p = scheme_hash_get_either(ut->multi_scope_pairs, ut->current_multi_scope_pairs, l); - if (!p) { - p = scheme_hash_get_either(ut->multi_scope_pairs, ut->current_multi_scope_pairs, SCHEME_CAR(l)); - if (p) { - p = scheme_make_pair(p, scheme_null); - } else { - if (SCHEME_VECTORP(SCHEME_CAR(SCHEME_CAR(l)))) { - multi_scope = vector_to_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), ut); - if (!multi_scope) return_NULL; - if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(SCHEME_CAR(l)))) return_NULL; - p = scheme_make_pair((Scheme_Object *)multi_scope, - SCHEME_CDR(SCHEME_CAR(l))); - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, SCHEME_CAR(l), p); - } else - return_NULL; - } - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, SCHEME_CAR(l), p); - p = scheme_make_pair(p, scheme_null); - stop = 0; - } else - stop = 1; - - if (l_last) - SCHEME_CDR(l_last) = p; - else - l_first = p; - l_last = p; - - if (stop) - break; - else { - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, l, p); - } - } - - if (SCHEME_FALLBACKP(mm_l)) { - p = make_fallback_pair(l_first, scheme_null); - if (last) - SCHEME_FALLBACK_REST(last) = p; - else - first = p; - last = p; - mm_l = SCHEME_FALLBACK_REST(mm_l); - } else { - if (last) - SCHEME_FALLBACK_REST(last) = l_first; - else - first = l_first; - break; - } - } - - return first; -} - -static Scheme_Object *datum_to_wraps(Scheme_Object *w, - Scheme_Unmarshal_Tables *ut) -{ - Scheme_Scope_Table *st; - Scheme_Scope_Set *scopes; - Scheme_Object *l; - - l = scheme_hash_get_either(ut->rns, ut->current_rns, w); - if (l) { - if (!SCHEME_PAIRP(l) - || !SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_scope_table_type)) - return NULL; - return l; - } - - if (!SCHEME_VECTORP(w) - || ((SCHEME_VEC_SIZE(w) != 3) - && (SCHEME_VEC_SIZE(w) != 4))) - return_NULL; - - st = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - st->so.type = scheme_scope_table_type; - - scopes = list_to_scope_set(SCHEME_VEC_ELS(w)[1], ut); - if (!scopes) return NULL; - st->simple_scopes = scopes; - - l = unmarshal_multi_scopes(SCHEME_VEC_ELS(w)[2], ut); - if (!l) return NULL; - st->multi_scopes = l; - - l = scheme_make_pair((Scheme_Object *)st, SCHEME_VEC_ELS(w)[0]); - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, w, l); - - return l; -} - -static Scheme_Object *validate_binding(Scheme_Object *p) -{ - if (SCHEME_SYMBOLP(p)) { - /* Ok: local binding */ - } else { - if (SCHEME_PAIRP(p) && SCHEME_SYMBOLP(SCHEME_CAR(p))) { - /* Inpsector descriptor ok */ - p = SCHEME_CDR(p); - } - - if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(p)) { - Scheme_Object *midx; - - midx = SCHEME_CAR(p); - if (SCHEME_TRUEP(midx) - && !SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) - return_NULL; - - if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { - /* Ok */ - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { - /* Ok */ - } else { - Scheme_Object *ap, *bp; - - ap = SCHEME_CDR(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - - /* mod-phase, maybe */ - if (SCHEME_INTP(SCHEME_CAR(ap))) { - bp = SCHEME_CDR(ap); - } else - bp = ap; - - /* exportname */ - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - - /* nominal_modidx_plus_phase */ - bp = SCHEME_CDR(bp); - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(ap)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) - return_NULL; - ap = SCHEME_CDR(ap); - /* import_phase_plus_nominal_phase */ - if (SCHEME_PAIRP(ap)) { - if (!SCHEME_PHASE_SHIFTP(SCHEME_CAR(ap))) return_NULL; - if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(ap))) return_NULL; - } else if (!SCHEME_PHASE_SHIFTP(ap)) - return_NULL; - } else - return_NULL; - - /* nominal_exportname */ - ap = SCHEME_CDR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - } - } - } - - return scheme_true; -} - -static Scheme_Object *unmarshal_free_id_info(Scheme_Object *p, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *o, *phase; - - if (!SCHEME_PAIRP(p)) return_NULL; - phase = SCHEME_CDR(p); - p = SCHEME_CAR(p); - if (!SCHEME_PAIRP(p)) return_NULL; - o = scheme_make_stx(SCHEME_CAR(p), NULL, NULL); - p = datum_to_wraps(SCHEME_CDR(p), ut); - if (!p) return_NULL; - - ((Scheme_Stx *)o)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(p); - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)o)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)o)->shifts = SCHEME_CDR(p); - - return scheme_make_pair(o, phase); -} - -Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *l = NULL, *l2, *r, *b, *m, *c, *free_id; - Scheme_Hash_Tree *ht; - Scheme_Scope_Set *scopes; - intptr_t i, len, relative_id; - - if (SAME_OBJ(box, root_scope)) - return root_scope; - - r = scheme_hash_get_either(ut->rns, ut->current_rns, box); - if (r) - return r; - - if (!SCHEME_BOXP(box)) return_NULL; - c = SCHEME_BOX_VAL(box); - - if (!SCHEME_PAIRP(c)) return_NULL; - - relative_id = SCHEME_INT_VAL(SCHEME_CAR(c)); - c = SCHEME_CDR(c); - - if (SCHEME_INTP(c)) { - m = scheme_new_scope(SCHEME_INT_VAL(c)); - c = NULL; - } else if (SCHEME_PAIRP(c)) { - m = scheme_new_scope(SCHEME_INT_VAL(SCHEME_CAR(c))); - c = SCHEME_CDR(c); - } else - m = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, box, m); - /* Since we've created the scope before unmarshaling its content, - cycles among scopes are ok. */ - - /* Reset the scope's id to a hash from the bytecode plus a relative - offset. The only use of a scope's id is for debugging and - ordering, and using the bytecode's hash as part of the number is - intended to make ordering deterministic even across modules, - independent of the order that modules are loaded or delay-loaded. - Hashes are not gauarnteed to be distinct or far enough apart, but - they're likely to be. */ - STX_ASSERT(ut->bytecode_hash); - ((Scheme_Scope *)m)->id = ((SCHEME_STX_SCOPE_KIND_MASK & ((Scheme_Scope*)m)->id) - | ((umzlonglong)((relative_id << SCHEME_STX_SCOPE_KIND_SHIFT) - + ut->bytecode_hash) - & (~(umzlonglong)SCHEME_STX_SCOPE_KIND_MASK))); - - if (!c) return m; - - while (SCHEME_PAIRP(c)) { - if (!SCHEME_PAIRP(SCHEME_CAR(c))) return_NULL; - scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(c)), ut); - l = scheme_make_raw_pair(scheme_make_pair((Scheme_Object *)scopes, - SCHEME_CDR(SCHEME_CAR(c))), - l); - c = SCHEME_CDR(c); - } - - if (!SCHEME_VECTORP(c)) return_NULL; - - len = SCHEME_VEC_SIZE(c); - if (len & 1) return_NULL; - - /* If the vector length is 2, and if the only key has a single - binding, then we could generate the compact vector form of - bindings. For now, we just build the hash table. */ - - ht = empty_hash_tree; - for (i = 0; i < len; i += 2) { - l2 = SCHEME_VEC_ELS(c)[i+1]; - r = scheme_null; - while (SCHEME_PAIRP(l2)) { - if (!SCHEME_PAIRP(SCHEME_CAR(l2))) return_NULL; - scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(l2)), ut); - if (!scopes) return_NULL; - - b = SCHEME_CDR(SCHEME_CAR(l2)); - if (SCHEME_BOXP(b)) { - /* has `free-id=?` info */ - b = SCHEME_BOX_VAL(b); - if (!SCHEME_PAIRP(b)) return_NULL; - free_id = unmarshal_free_id_info(SCHEME_CDR(b), ut); - if (!free_id) return_NULL; - b = SCHEME_CAR(b); - } else - free_id = NULL; - if (!validate_binding(b)) return_NULL; - - if (free_id) - b = scheme_make_mutable_pair(b, free_id); - - b = scheme_make_pair((Scheme_Object *)scopes, b); - - if (SCHEME_NULLP(r) && SCHEME_NULLP(SCHEME_CDR(l2))) { - /* leave r as a single binding */ - r = b; - } else - r = scheme_make_mutable_pair(b, r); - - l2 = SCHEME_CDR(l2); - } - - ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(c)[i], r); - } - - if (!l) - l = (Scheme_Object *)ht; - else - l = scheme_make_raw_pair((Scheme_Object *)ht, l); - - ((Scheme_Scope *)m)->bindings = l; - - return m; -} - - -#ifdef DO_STACK_CHECK -static Scheme_Object *datum_to_syntax_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2; - Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3; - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4; - Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - - return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht, (int)p->ku.k.i1); -} -#endif - -static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, /* or rename table, or vectored wrap+srcloc+taint */ - Scheme_Hash_Table *ht, - int tainted) -{ - Scheme_Object *result, *wraps, *hashed, *srcloc_vec; - int do_not_unpack_wraps = 0, taintval = 0; - - if (SCHEME_STXP(o)) - return o; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.p2 = (void *)stx_src; - p->ku.k.p3 = (void *)stx_wraps; - p->ku.k.p4 = (void *)ht; - p->ku.k.p5 = (void *)ut; - p->ku.k.i1 = tainted; - return scheme_handle_stack_overflow(datum_to_syntax_k); - } - } -#endif - - SCHEME_USE_FUEL(1); - - if (ht) { - if (HAS_CHAPERONE_SUBSTX(o)) { - if (scheme_hash_get(ht, o)) { - /* Graphs disallowed */ - return_NULL; - } - - scheme_hash_set(ht, o, scheme_true); - hashed = o; - } else - hashed = NULL; - } else - hashed = NULL; - - srcloc_vec = scheme_false; - - if (ut && !SCHEME_VECTORP(stx_wraps)) { - if (SCHEME_VECTORP(o)) { - if (SCHEME_VEC_SIZE(o) == 4) { - srcloc_vec = SCHEME_VEC_ELS(o)[2]; - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[3]); - } else if (SCHEME_VEC_SIZE(o) == 3) { - if (SCHEME_INTP(SCHEME_VEC_ELS(o)[2])) - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[2]); - else { - srcloc_vec = SCHEME_VEC_ELS(o)[2]; - taintval = 0; - } - } else - return_NULL; - wraps = SCHEME_VEC_ELS(o)[1]; - o = SCHEME_VEC_ELS(o)[0]; - } else { - if (!SCHEME_PAIRP(o)) - return_NULL; - wraps = SCHEME_CDR(o); - o = SCHEME_CAR(o); - } - } else if (SCHEME_VECTORP(stx_wraps)) { - /* Shared wraps, to be used directly everywhere: */ - wraps = SCHEME_VEC_ELS(stx_wraps)[0]; - srcloc_vec = SCHEME_VEC_ELS(stx_wraps)[1]; - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(stx_wraps)[2]); - do_not_unpack_wraps = 1; - } else - wraps = NULL; - - if (taintval == 1) - tainted = 1; - - if (SCHEME_PAIRP(o)) { - Scheme_Object *first = NULL, *last = NULL, *p; - - /* Check whether it's all conses with - syntax inside */ - p = o; - while (SCHEME_PAIRP(p)) { - if (!SCHEME_STXP(SCHEME_CAR(p))) - break; - p = SCHEME_CDR(p); - } - if (SCHEME_NULLP(p) || SCHEME_STXP(p)) { - result = o; - } else { - int cnt = -1; - Scheme_Stx *sub_stx_wraps = stx_wraps; - - if (wraps && !SCHEME_VECTORP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) { - /* Resolve wraps now, and then share it with - all nested objects (as indicated by a box - for stx_wraps). */ - wraps = datum_to_wraps(wraps, ut); - if (!wraps) return_NULL; - do_not_unpack_wraps = 1; - sub_stx_wraps = (Scheme_Stx *)scheme_make_vector(3, wraps); - SCHEME_VEC_ELS((Scheme_Object *)sub_stx_wraps)[1] = srcloc_vec; - SCHEME_VEC_ELS((Scheme_Object *)sub_stx_wraps)[2] = scheme_make_integer(taintval); - o = SCHEME_CDR(o); - } else if (wraps && !SCHEME_VECTORP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) { - /* First element is the number of items - before a non-null terminal: */ - cnt = SCHEME_INT_VAL(SCHEME_CAR(o)); - o = SCHEME_CDR(o); - } - - /* Build up a new list while converting elems */ - while (SCHEME_PAIRP(o) && cnt) { - Scheme_Object *a; - - if (ht && last) { - if (scheme_hash_get(ht, o)) { - /* cdr is shared. Stop here and let someone else complain. */ - break; - } - } - - a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht, tainted); - if (!a) return_NULL; - - p = scheme_make_pair(a, scheme_null); - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - o = SCHEME_CDR(o); - - --cnt; - } - if (!first) return_NULL; - if (!SCHEME_NULLP(o)) { - o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht, tainted); - if (!o) return_NULL; - SCHEME_CDR(last) = o; - } - - result = first; - } - } else if (SCHEME_CHAPERONE_BOXP(o)) { - if (SCHEME_NP_CHAPERONEP(o)) - o = scheme_unbox(o); - else - o = SCHEME_PTR_VAL(o); - - o = datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht, tainted); - if (!o) return_NULL; - result = scheme_box(o); - SCHEME_SET_BOX_IMMUTABLE(result); - } else if (SCHEME_CHAPERONE_VECTORP(o)) { - int size, i; - Scheme_Object *a, *oo; - - oo = o; - if (SCHEME_NP_CHAPERONEP(o)) - o = SCHEME_CHAPERONE_VAL(o); - size = SCHEME_VEC_SIZE(o); - - result = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - if (SAME_OBJ(o, oo)) - a = SCHEME_VEC_ELS(o)[i]; - else - a = scheme_chaperone_vector_ref(oo, i); - a = datum_to_syntax_inner(a, ut, stx_src, stx_wraps, ht, tainted); - if (!a) return_NULL; - SCHEME_VEC_ELS(result)[i] = a; - } - - SCHEME_SET_VECTOR_IMMUTABLE(result); - } else if (SCHEME_CHAPERONE_HASHTRP(o)) { - Scheme_Hash_Tree *ht1, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - if (SCHEME_NP_CHAPERONEP(o)) - ht1 = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(o); - else - ht1 = (Scheme_Hash_Tree *)o; - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht1)); - - i = scheme_hash_tree_next(ht1, -1); - while (i != -1) { - scheme_hash_tree_index(ht1, i, &key, &val); - if (!SAME_OBJ((Scheme_Object *)ht1, o)) - val = scheme_chaperone_hash_traversal_get(o, key, &key); - val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht, tainted); - if (!val) return NULL; - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht1, i); - } - - result = (Scheme_Object *)ht2; - } else if (prefab_p(o) || (SCHEME_CHAPERONEP(o) && prefab_p(SCHEME_CHAPERONE_VAL(o)))) { - Scheme_Structure *s; - Scheme_Object *a; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance((Scheme_Structure *)o); - size = s->stype->num_slots; - - for (i = 0; i < size; i++) { - a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht, tainted); - if (!a) return NULL; - s->slots[i] = a; - } - - result = (Scheme_Object *)s; - } else { - if (!wraps) - o = scheme_read_intern(o); - result = o; - } - - if (SCHEME_FALSEP((Scheme_Object *)stx_src)) - result = scheme_make_stx(result, empty_srcloc, NULL); - else - result = scheme_make_stx(result, stx_src->srcloc, NULL); - - if (tainted) { - int mutate = MUTATE_STX_OBJ; - (void)add_taint_to_stx(result, &mutate); - } else if (taintval == 2) { - /* Arm with #f as the inspector; #f is replaced by a - specific inspector when the encloding code is instanted */ - Scheme_Object *l; - l = taint_intern(scheme_make_pair(scheme_false, scheme_null)); - l = taint_intern(scheme_make_pair(scheme_false, l)); - ((Scheme_Stx *)result)->taints = l; - } - - if (SCHEME_TRUEP(srcloc_vec)) - unconvert_srcloc(srcloc_vec, (Scheme_Stx *)result, ut); - - if (wraps) { - if (!do_not_unpack_wraps) { - wraps = datum_to_wraps(wraps, ut); - if (!wraps) - return_NULL; - } - - if (!SCHEME_PAIRP(wraps)) return_NULL; - ((Scheme_Stx *)result)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(wraps); - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)result)->shifts = SCHEME_CDR(wraps); - } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) { - /* wraps already nulled */ - } else { - /* Note: no propagation will be needed for SUBSTX */ - ((Scheme_Stx *)result)->scopes = stx_wraps->scopes; - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)result)->shifts = stx_wraps->shifts; - if (SCHEME_VECTORP(((Scheme_Stx *)result)->shifts)) - ((Scheme_Stx *)result)->shifts = SCHEME_VEC_ELS(((Scheme_Stx *)result)->shifts)[0]; - } - - if (hashed) { - scheme_hash_set(ht, hashed, NULL); - } - - return result; -} - -static int quick_check_graph(Scheme_Object *o, int fuel) -{ - if (!fuel) return 0; - - if (SCHEME_PAIRP(o)) - return quick_check_graph(SCHEME_CDR(o), - quick_check_graph(SCHEME_CAR(o), fuel - 1)); - - if (HAS_CHAPERONE_SUBSTX(o)) - return 0; - else - return fuel; -} - -static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) - /* If stx_wraps is a hash table, then `o' includes scopes. - If copy_props > 0, properties are copied from src. - If copy_props != 1 or 0, then taint armings are copied from src, too, - but src must not be tainted. */ -{ - Scheme_Hash_Table *ht; - Scheme_Object *v, *code = NULL; - - if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src)) - return o; - - if (SCHEME_STXP(o)) - return o; - - if (can_graph && !quick_check_graph(o, 10)) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = NULL; - - if (ut) { - /* If o is just a number, look it up in the table. */ - if (SCHEME_INTP(o)) { - int decoded; - v = scheme_unmarshal_wrap_get(ut, o, &decoded); - if (!decoded) { - code = o; - o = v; - } else - return v; - } - } - - v = datum_to_syntax_inner(o, - ut, - (Scheme_Stx *)stx_src, - (Scheme_Stx *)stx_wraps, - ht, - 0); - - if (!v) { - if (ut) - return_NULL; /* happens with bad wraps from a bad .zo */ - /* otherwise, only happens with cycles: */ - scheme_contract_error("datum->syntax", - "cannot create syntax from cyclic datum", - "datum", 1, o, - NULL); - return NULL; - } - - if (code) { - scheme_unmarshal_wrap_set(ut, code, v); - } - - if (copy_props > 0) - ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props; - - if (copy_props && (copy_props != 1)) { - if (!is_clean(stx_src)) { - if (is_tainted(stx_src)) - scheme_signal_error("internal error: cannot copy taint armings from tainted source"); - v = add_taint_armings_to_stx(v, ((Scheme_Stx *)stx_src)->taints, 0); - } - } - - return v; -} - -Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) -{ - return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props); -} - -Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, - struct Scheme_Unmarshal_Tables *ut, - int can_graph) -{ - return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0); -} - -/*========================================================================*/ -/* Racket functions and helpers */ -/*========================================================================*/ - -static Scheme_Object *syntax_p(int argc, Scheme_Object **argv) -{ - return SCHEME_STXP(argv[0]) ? scheme_true : scheme_false; -} - -static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax->datum", "syntax?", 0, argc, argv); - - return scheme_syntax_to_datum(argv[0], 0, NULL); -} - -static int nonneg_exact_or_false_p(Scheme_Object *o) -{ - return SCHEME_FALSEP(o) || scheme_nonneg_exact_p(o); -} - -static int pos_exact_or_false_p(Scheme_Object *o) -{ - return (SCHEME_FALSEP(o) - || (SCHEME_INTP(o) && (SCHEME_INT_VAL(o) > 0)) - || (SCHEME_BIGNUMP(o) && SCHEME_BIGPOS(o))); -} - -static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) -{ - Scheme_Object *src = scheme_false; - Scheme_Hash_Tree *properties = NULL; - - if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0])) - scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 0, argc, argv); - if (argc > 2) { - int ll; - - src = argv[2]; - - ll = scheme_proper_list_length(src); - - if (SCHEME_CHAPERONEP(src)) { - src = SCHEME_CHAPERONE_VAL(src); - if (SCHEME_VECTORP(src) && (SCHEME_VEC_SIZE(src) == 5)) { - Scheme_Object *a; - int i; - src = scheme_make_vector(5, NULL); - for (i = 0; i < 5; i++) { - a = scheme_chaperone_vector_ref(argv[2], i); - SCHEME_VEC_ELS(src)[i] = a; - } - } - } - - if (!SCHEME_FALSEP(src) - && !SCHEME_STXP(src) - && !(SCHEME_VECTORP(src) - && (SCHEME_VEC_SIZE(src) == 5) - && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[1]) - && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[2]) - && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[3]) - && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[4])) - && !((ll == 5) - && pos_exact_or_false_p(SCHEME_CADR(src)) - && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(src))) - && pos_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src)))) - && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src))))))) - scheme_wrong_type("datum->syntax", "syntax, source location vector or list, or #f", 2, argc, argv); - - if (SCHEME_VECTORP(src)) - ll = 5; - - if (argc > 3) { - if (!SCHEME_FALSEP(argv[3])) { - if (!SCHEME_STXP(argv[3])) - scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 3, argc, argv); - properties = ((Scheme_Stx *)argv[3])->props; - } - - if (argc > 4) { - /* Not used; allowed for backward-compatibility */ - if (!SCHEME_FALSEP(argv[4])) { - if (!SCHEME_STXP(argv[4])) - scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 4, argc, argv); - } - } - } - - if (ll == 5) { - /* line--column--pos--span format */ - Scheme_Object *line, *col, *pos, *span; - if (SCHEME_VECTORP(src)) { - line = SCHEME_VEC_ELS(src)[1]; - col = SCHEME_VEC_ELS(src)[2]; - pos = SCHEME_VEC_ELS(src)[3]; - span = SCHEME_VEC_ELS(src)[4]; - src = SCHEME_VEC_ELS(src)[0]; - } else { - line = SCHEME_CADR(src); - col = SCHEME_CADR(SCHEME_CDR(src)); - pos = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src))); - span = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src)))); - src = SCHEME_CAR(src); - } - - if (SCHEME_FALSEP(line) != SCHEME_FALSEP(col)) - scheme_contract_error("datum->syntax", - "line and column positions must both be numbers or #f", - "in location", 1, argv[2], - NULL); - - /* Too-large positions go to unknown */ - if (SCHEME_BIGNUMP(line) || SCHEME_BIGNUMP(col)) { - line = scheme_make_integer(-1); - col = scheme_make_integer(-1); - } - if (SCHEME_BIGNUMP(pos)) - pos = scheme_make_integer(-1); - if (span && SCHEME_BIGNUMP(span)) - span = scheme_make_integer(-1); - - src = scheme_make_stx_w_offset(scheme_false, - SCHEME_FALSEP(line) ? -1 : SCHEME_INT_VAL(line), - SCHEME_FALSEP(col) ? -1 : (SCHEME_INT_VAL(col)+1), - SCHEME_FALSEP(pos) ? -1 : SCHEME_INT_VAL(pos), - SCHEME_FALSEP(span) ? -1 : SCHEME_INT_VAL(span), - src, - NULL); - } - } - - if (SCHEME_STXP(argv[1])) - return argv[1]; - - src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0); - - if (properties) { - ((Scheme_Stx *)src)->props = properties; - } - - if (!SCHEME_FALSEP(argv[0]) && !is_clean(argv[0])) { - int mutate = MUTATE_STX_OBJ; - add_taint_to_stx(src, &mutate); - } - - return src; -} - -Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-e", "syntax?", 0, argc, argv); - - return scheme_stx_content(argv[0]); -} - -static Scheme_Object *syntax_line(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-line", "syntax?", 0, argc, argv); - - if (stx->srcloc->line < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->line); -} - -static Scheme_Object *syntax_col(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-column", "syntax?", 0, argc, argv); - - if (stx->srcloc->col < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->col-1); -} - -static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-position", "syntax?", 0, argc, argv); - - if (stx->srcloc->pos < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->pos); -} - -static Scheme_Object *syntax_span(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-span", "syntax?", 0, argc, argv); - - if (stx->srcloc->span < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->span); -} - -static Scheme_Object *syntax_src(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-source", "syntax?", 0, argc, argv); - - return stx->srcloc->src; -} - -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv) -{ - Scheme_Object *l; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax->list", "syntax?", 0, argc, argv); - - l = scheme_stx_content(argv[0]); - if (SCHEME_NULLP(l)) - return scheme_null; - else if (SCHEME_PAIRP(l)) { - int islist; - l = scheme_flatten_syntax_list(l, &islist); - if (islist) - return l; - else - return scheme_false; - } else - return scheme_false; -} - -static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-tainted?", "syntax?", 0, argc, argv); - - return (scheme_stx_is_tainted(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-original?", "syntax?", 0, argc, argv); - - if (scheme_syntax_is_original(argv[0])) - return scheme_true; - else - return scheme_false; -} - -int scheme_syntax_is_original(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *key, *val; - intptr_t i; - - if (stx->props) { - if (!scheme_hash_tree_get(stx->props, source_symbol)) - return 0; - } else - return 0; - - /* Look for any non-original scope: */ - i = scope_set_next(stx->scopes->simple_scopes, -1); - while (i != -1) { - scope_set_index(stx->scopes->simple_scopes, i, &key, &val); - - if (SCHEME_SCOPE_KIND(key) == SCHEME_STX_MACRO_SCOPE) - return 0; - - i = scope_set_next(stx->scopes->simple_scopes, i); - } - - return 1; -} - -Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Hash_Tree *props = stx->props; - - if (!props) - return (Scheme_Object *)stx; - - props = scheme_hash_tree_set(props, source_symbol, NULL); - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); - stx->props = props; - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val, - int preserve) -/* `val` can be scheme_syntax_property_preserve_type already to - make it preserved, but preserve must be 0 in that case */ -{ - Scheme_Stx *stx; - Scheme_Hash_Tree *props; - - stx = (Scheme_Stx *)_stx; - - props = stx->props; - if (!props) - props = empty_hash_tree; - - if (val) { - if (preserve) { - MZ_ASSERT(!SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)); - val = make_preserved_property_value(val); - } - props = scheme_hash_tree_set(props, key, val); - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); - stx->props = props; - return (Scheme_Object *)stx; - } else { - val = scheme_hash_tree_get(props, key); - if (!val) - return scheme_false; - else if (SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)) - return SCHEME_PTR_VAL(val); - else - return val; - } -} - -Scheme_Object *scheme_stx_property(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val) -{ - return scheme_stx_property2(_stx, key, val, 0); -} - - -static Scheme_Object *syntax_property(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-property", "syntax?", 0, argc, argv); - - if ((argc > 3) && SCHEME_TRUEP(argv[3])) { - if (!SCHEME_SYMBOLP(argv[1]) || SCHEME_SYM_WEIRDP(argv[1])) - scheme_contract_error("syntax-property", - "expected an interned symbol key for a preserved property", - "given", 1, argv[1], - NULL); - } - - return scheme_stx_property2(argv[0], - argv[1], - (argc > 2) ? argv[2] : NULL, - ((argc > 3) - ? SCHEME_TRUEP(argv[3]) - : SAME_OBJ(argv[1], scheme_paren_shape_symbol))); -} - -static Scheme_Object *syntax_property_preserved_p(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx; - Scheme_Object *v; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-property-preserved?", "syntax?", 0, argc, argv); - if (!SCHEME_SYMBOLP(argv[1]) || SCHEME_SYM_WEIRDP(argv[1])) - scheme_wrong_contract("syntax-property-preserved?", "(and/c symbol? symbol-interned?)", 1, argc, argv); - - stx = (Scheme_Stx *)argv[0]; - if (!stx->props) - return scheme_false; - - v = scheme_hash_tree_get(stx->props, argv[1]); - if (!v || !SAME_TYPE(SCHEME_TYPE(v), scheme_syntax_property_preserve_type)) - return scheme_false; - return scheme_true; -} - -static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-property-symbol-keys", "syntax?", 0, argc, argv); - - stx = (Scheme_Stx *)argv[0]; - - if (stx->props) { - mzlonglong i; - Scheme_Object *key, *l = scheme_null; - - i = scheme_hash_tree_next(stx->props, -1); - while (i != -1) { - scheme_hash_tree_index(stx->props, i, &key, NULL); - if (SCHEME_SYMBOLP(key) && !SCHEME_SYM_WEIRDP(key)) - l = scheme_make_pair(key, l); - i = scheme_hash_tree_next(stx->props, i); - } - - return l; - } - - return scheme_null; -} - -#define SCHEME_STX_IDP(o) (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))) - -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) -{ - Scheme_Object *result, *observer; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-track-origin", "syntax?", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-track-origin", "syntax?", 1, argc, argv); - if (!SCHEME_STX_IDP(argv[2])) - scheme_wrong_contract("syntax-track-origin", "identifier?", 2, argc, argv); - - result = scheme_stx_track(argv[0], argv[1], argv[2]); - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(observer, argv[0], result); - return result; -} - -Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) -{ - if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) { - to = clone_stx(to, NULL); - ((Scheme_Stx *)to)->srcloc = ((Scheme_Stx *)from)->srcloc; - } - - return to; -} - -static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) -{ - Scheme_Object *r, *delta, *taint_p, *phase; - int mode = SCHEME_STX_ADD; - - r = argv[0]; - if (argc > 1) - mode = scheme_get_introducer_mode("syntax-delta-introducer", 1, argc, argv); - - if (!SCHEME_STXP(r)) - scheme_wrong_contract("syntax-delta-introducer", "syntax?", 0, argc, argv); - - delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; - taint_p = SCHEME_PRIM_CLOSURE_ELS(p)[1]; - phase = SCHEME_PRIM_CLOSURE_ELS(p)[2]; - - r = scheme_stx_adjust_scopes(r, (Scheme_Scope_Set *)delta, phase, mode); - - if (SCHEME_TRUEP(taint_p)) - r = scheme_stx_taint(r); - - return r; -} - -static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, - Scheme_Object *delta, int use_shift) -{ - Scheme_Object *phase; - - if (argc > pos) { - phase = argv[pos]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_contract(who, "(or/c exact-integer? #f)", pos, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - intptr_t ph; - ph = (p->current_local_env - ? p->current_local_env->genv->phase - : (use_shift - ? p->current_phase_shift - : 0)); - phase = scheme_make_integer(ph); - - if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(delta, phase); - } - - return phase; -} - -static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; - int all_bindings; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-debug-info", "syntax?", 0, argc, argv); - - phase = extract_phase("syntax-debug-info", 1, argc, argv, - scheme_make_integer(0), 0); - - all_bindings = ((argc > 2) && SCHEME_TRUEP(argv[2])); - - return stx_debug_info((Scheme_Stx *)argv[0], phase, scheme_null, all_bindings); -} - -Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) -{ - Scheme_Object *a[3], *key, *val, *src; - Scheme_Object *phase; - Scheme_Scope_Set *delta, *m2; - intptr_t i; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("make-syntax-delta-introducer", "identifier?", 0, argc, argv); - if (!SCHEME_STXP(argv[1]) && !SCHEME_FALSEP(argv[1])) - scheme_wrong_contract("make-syntax-delta-introducer", "(or/c syntax? #f)", 1, argc, argv); - - phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); - - delta = extract_scope_set((Scheme_Stx *)argv[0], phase); - - src = argv[1]; - if (!SCHEME_FALSEP(src)) { - m2 = extract_scope_set((Scheme_Stx *)src, phase); - if (!scope_subset(m2, delta)) - m2 = NULL; - } else - m2 = NULL; - - if (!m2 && !SCHEME_FALSEP(src)) { - src = scheme_stx_lookup_w_nominal(argv[1], phase, 1, - NULL, NULL, &m2, - NULL, NULL, NULL, NULL, NULL); - } - - if (m2) { - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (scope_set_get(delta, key)) - delta = scope_set_set(delta, key, NULL); - - i = scope_set_next(m2, i); - } - } - - a[0] = (Scheme_Object *)delta; - if (scheme_stx_is_clean(argv[0])) - a[1] = scheme_false; - else - a[1] = scheme_true; - a[2] = phase; - - return scheme_make_prim_closure_w_arity(delta_introducer, 3, a, "delta-introducer", 1, 2); -} - -Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) -{ - Scheme_Scope_Set *current, *m2; - Scheme_Object *key, *val; - intptr_t i; - int mutate = 0; - - current = extract_scope_set((Scheme_Stx *)o, phase); - m2 = extract_scope_set((Scheme_Stx *)b, phase); - - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (!scope_set_get(current, key)) { - o = stx_adjust_scope(o, key, phase, SCHEME_STX_ADD, &mutate); - } - - i = scope_set_next(m2, i); - } - - return o; -} - -Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) -{ - Scheme_Scope_Set *current, *m2; - Scheme_Object *key, *val; - intptr_t i; - int mutate = 0; - - current = extract_scope_set((Scheme_Stx *)o, phase); - m2 = extract_scope_set((Scheme_Stx *)b, phase); - - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (scope_set_get(current, key)) { - o = stx_adjust_scope(o, key, phase, SCHEME_STX_REMOVE, &mutate); - } - - i = scope_set_next(m2, i); - } - - return o; -} - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; + if (flags & DTS_RECUR) { + Scheme_Hash_Table *ht; - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_contract("bound-identifier=?", "identifier?", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_contract("bound-identifier=?", "identifier?", 1, argc, argv); - - phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); - - return (scheme_stx_env_bound_eq2(argv[0], argv[1], phase, phase) - ? scheme_true - : scheme_false); -} + if ((flags & DTS_CAN_GRAPH) && !quick_check_graph(o, 10)) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = NULL; -static Scheme_Object *do_free_eq(const char *who, int delta, int argc, Scheme_Object **argv) -{ - Scheme_Object *phase, *phase2; - int v; + v = datum_to_syntax_inner(o, (Scheme_Stx *)stx_src, ht); - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_contract(who, "identifier?", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_contract(who, "identifier?", 1, argc, argv); - - phase = extract_phase(who, 2, argc, argv, - ((delta == MZ_LABEL_PHASE) - ? scheme_false - : scheme_make_integer(delta)), - 0); - if (argc > 3) - phase2 = extract_phase(who, 3, argc, argv, phase, 0); + if (!v) { + /* only happens with cycles: */ + scheme_contract_error("datum->syntax", + "cannot create syntax from cyclic datum", + "datum", 1, o, + NULL); + return NULL; + } + } else if (SCHEME_FALSEP(stx_src)) + v = scheme_make_stx(o, empty_srcloc, NULL); else - phase2 = phase; + v = scheme_make_stx(o, ((Scheme_Stx *)stx_src)->srcloc, NULL); - v = scheme_stx_free_eq3(argv[0], argv[1], phase, phase2); + if (flags & DTS_COPY_PROPS) + ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props; - return (v - ? scheme_true - : scheme_false); + return v; } -static Scheme_Object *free_eq(int argc, Scheme_Object **argv) +/*========================================================================*/ +/* Racket functions and helpers */ +/*========================================================================*/ + +static Scheme_Object *syntax_p(int argc, Scheme_Object **argv) { - return do_free_eq("free-identifier=?", 0, argc, argv); + return SCHEME_STXP(argv[0]) ? scheme_true : scheme_false; } -static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv) { - return do_free_eq("free-transformer-identifier=?", 1, argc, argv); + if (!SCHEME_STXP(argv[0])) + scheme_wrong_contract("syntax->datum", "syntax?", 0, argc, argv); + + return scheme_syntax_to_datum(argv[0]); } -static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv) +static int nonneg_exact_or_false_p(Scheme_Object *o) { - return do_free_eq("free-template-identifier=?", -1, argc, argv); + return SCHEME_FALSEP(o) || scheme_nonneg_exact_p(o); } -static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv) +static int pos_exact_or_false_p(Scheme_Object *o) { - return do_free_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); + return (SCHEME_FALSEP(o) + || (SCHEME_INTP(o) && (SCHEME_INT_VAL(o) > 0)) + || (SCHEME_BIGNUMP(o) && SCHEME_BIGPOS(o))); } -static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv, - Scheme_Object *dphase, int get_symbol) +static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) { - Scheme_Object *a, *m, *nom_mod, *nom_a, *phase; - Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase; - int top_level_as_symbol = 0; - - a = argv[0]; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract(name, "identifier?", 0, argc, argv); - - phase = extract_phase(name, 1, argc, argv, dphase, 1); - - if (argc > 1) { - phase = argv[1]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_contract(name, "(or/c exact-integer? #f)", 1, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - if (SCHEME_FALSEP(dphase) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(dphase, phase); - } + Scheme_Object *src = scheme_false; + Scheme_Hash_Tree *properties = NULL; + + /* The first argument is accepted only for backward compatibility: */ + if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0])) + scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 0, argc, argv); + + if (argc > 2) { + int ll; - if (argc > 2) - top_level_as_symbol = SCHEME_TRUEP(argv[2]); + src = argv[2]; - m = scheme_stx_lookup_w_nominal(a, phase, 0, - NULL, NULL, NULL, NULL, - &nom_mod, &nom_a, - &src_phase_index, - &nominal_src_phase); - - if (get_symbol) { - if (SCHEME_VECTORP(m)) - return SCHEME_VEC_ELS(m)[1]; - else - return SCHEME_STX_VAL(a); - } + ll = scheme_proper_list_length(src); - if (SCHEME_FALSEP(m)) - return scheme_false; - else if (SCHEME_SYMBOLP(m)) - return lexical_symbol; - else { - a = SCHEME_VEC_ELS(m)[1]; - mod_phase = SCHEME_VEC_ELS(m)[2]; - m = SCHEME_VEC_ELS(m)[0]; - - if (SCHEME_FALSEP(m)) { - if (top_level_as_symbol) - return CONS(a, scheme_null); - else - return scheme_false; + if (SCHEME_CHAPERONEP(src)) { + src = SCHEME_CHAPERONE_VAL(src); + if (SCHEME_VECTORP(src) && (SCHEME_VEC_SIZE(src) == 5)) { + Scheme_Object *a; + int i; + src = scheme_make_vector(5, NULL); + for (i = 0; i < 5; i++) { + a = scheme_chaperone_vector_ref(argv[2], i); + SCHEME_VEC_ELS(src)[i] = a; + } + } } - return CONS(m, CONS(a, CONS(nom_mod, - CONS(nom_a, - CONS(mod_phase, - CONS(src_phase_index, - CONS(nominal_src_phase, - scheme_null))))))); - } -} + if (!SCHEME_FALSEP(src) + && !SCHEME_STXP(src) + && !(SCHEME_VECTORP(src) + && (SCHEME_VEC_SIZE(src) == 5) + && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[1]) + && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[2]) + && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[3]) + && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[4])) + && !((ll == 5) + && pos_exact_or_false_p(SCHEME_CADR(src)) + && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(src))) + && pos_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src)))) + && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src))))))) + scheme_wrong_type("datum->syntax", "syntax, source location vector or list, or #f", 2, argc, argv); -static Scheme_Object *free_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0); -} + if (SCHEME_VECTORP(src)) + ll = 5; -static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0); -} + if (argc > 3) { + if (!SCHEME_FALSEP(argv[3])) { + if (!SCHEME_STXP(argv[3])) + scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 3, argc, argv); + properties = ((Scheme_Stx *)argv[3])->props; + } + + if (argc > 4) { + /* Not used; allowed for backward-compatibility */ + if (!SCHEME_FALSEP(argv[4])) { + if (!SCHEME_STXP(argv[4])) + scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 4, argc, argv); + } + } + } -static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0); -} + if (ll == 5) { + /* line--column--pos--span format */ + Scheme_Object *line, *col, *pos, *span; + if (SCHEME_VECTORP(src)) { + line = SCHEME_VEC_ELS(src)[1]; + col = SCHEME_VEC_ELS(src)[2]; + pos = SCHEME_VEC_ELS(src)[3]; + span = SCHEME_VEC_ELS(src)[4]; + src = SCHEME_VEC_ELS(src)[0]; + } else { + line = SCHEME_CADR(src); + col = SCHEME_CADR(SCHEME_CDR(src)); + pos = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src))); + span = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src)))); + src = SCHEME_CAR(src); + } + + if (SCHEME_FALSEP(line) != SCHEME_FALSEP(col)) + scheme_contract_error("datum->syntax", + "line and column positions must both be numbers or #f", + "in location", 1, argv[2], + NULL); -static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-label-binding", argc, argv, scheme_false, 0); -} + /* Too-large positions go to unknown */ + if (SCHEME_BIGNUMP(line) || SCHEME_BIGNUMP(col)) { + line = scheme_make_integer(-1); + col = scheme_make_integer(-1); + } + if (SCHEME_BIGNUMP(pos)) + pos = scheme_make_integer(-1); + if (span && SCHEME_BIGNUMP(span)) + span = scheme_make_integer(-1); -static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1); -} + src = scheme_make_stx_w_offset(scheme_false, + SCHEME_FALSEP(line) ? -1 : SCHEME_INT_VAL(line), + SCHEME_FALSEP(col) ? -1 : (SCHEME_INT_VAL(col)+1), + SCHEME_FALSEP(pos) ? -1 : SCHEME_INT_VAL(pos), + SCHEME_FALSEP(span) ? -1 : SCHEME_INT_VAL(span), + src, + NULL); + } + } -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) -{ - Scheme_Object *a = argv[0], *l; + if (SCHEME_STXP(argv[1])) + return argv[1]; - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract("identifier-prune-lexical-context", "identifier?", 0, argc, argv); + src = scheme_datum_to_syntax(argv[1], src, DTS_CAN_GRAPH); - if (argc > 1) { - l = argv[1]; - while (SCHEME_PAIRP(l)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("identifier-prune-lexical-context", "(listof symbol?)", 1, argc, argv); - l = argv[1]; - } else { - l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); + if (properties) { + ((Scheme_Stx *)src)->props = properties; } - /* FIXME: implement pruning */ + return src; +} - return a; +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv) +{ + if (!SCHEME_STXP(argv[0])) + scheme_wrong_contract("syntax-e", "syntax?", 0, argc, argv); + + return SCHEME_STX_VAL(argv[0]); } -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_line(int argc, Scheme_Object **argv) { Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - Scheme_Object *shifts; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0])) - scheme_wrong_contract("identifier-prune-to-source-module", "identifier?", 0, argc, argv); - shifts = stx->shifts; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->shifts = shifts; - - return (Scheme_Object *)stx; + if (!SCHEME_STXP(argv[0])) + scheme_wrong_contract("syntax-line", "syntax?", 0, argc, argv); + + if (stx->srcloc->line < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->line); } -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_col(int argc, Scheme_Object **argv) { - int source = 0; + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-source-module", "syntax?", 0, argc, argv); + scheme_wrong_contract("syntax-column", "syntax?", 0, argc, argv); + + if (stx->srcloc->col <= 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->col-1); +} - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - source = 1; +static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - return scheme_stx_source_module(argv[0], source, source); + if (!SCHEME_STXP(argv[0])) + scheme_wrong_contract("syntax-position", "syntax?", 0, argc, argv); + + if (stx->srcloc->pos < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->pos); } -/**********************************************************************/ - -static Scheme_Object *syntax_arm(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_span(int argc, Scheme_Object **argv) { - Scheme_Object *insp; - int use_mode; + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-arm", "syntax?", 0, argc, argv); - if ((argc > 1) && !SCHEME_FALSEP(argv[1])) { - if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_inspector_type)) - scheme_wrong_contract("syntax-arm", "(or/c inspector? #f)", 1, argc, argv); - insp = argv[1]; - } else - insp = scheme_false; - - use_mode = ((argc > 2) && SCHEME_TRUEP(argv[2])); + scheme_wrong_contract("syntax-span", "syntax?", 0, argc, argv); - return scheme_syntax_taint_arm(argv[0], insp, use_mode); + if (stx->srcloc->span < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->span); } -static Scheme_Object *syntax_disarm(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_src(int argc, Scheme_Object **argv) { - Scheme_Object *insp; + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-disarm", "syntax?", 0, argc, argv); - if (argc > 1) { - if (SCHEME_TRUEP(argv[1]) && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_inspector_type)) - scheme_wrong_contract("syntax-disarm", "(or/c inspector? #f)", 1, argc, argv); - insp = argv[1]; - } else - insp = scheme_false; + scheme_wrong_contract("syntax-source", "syntax?", 0, argc, argv); - return scheme_syntax_taint_disarm(argv[0], insp); + return stx->srcloc->src; } -static Scheme_Object *syntax_rearm(int argc, Scheme_Object **argv) +Scheme_Object *scheme_stx_property(Scheme_Object *_stx, + Scheme_Object *key, + Scheme_Object *val) { - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-rearm", "syntax?", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-rearm", "syntax?", 1, argc, argv); + Scheme_Stx *stx; + Scheme_Hash_Tree *props; - if ((argc > 2) && SCHEME_TRUEP(argv[2])) - return scheme_syntax_taint_rearm(argv[0], argv[1]); - else - return scheme_stx_taint_rearm(argv[0], argv[1]); + if (!SCHEME_STXP(_stx)) + return scheme_false; + + stx = (Scheme_Stx *)_stx; + + props = stx->props; + if (!props) + props = empty_hash_tree; + + if (val) { + props = scheme_hash_tree_set(props, key, val); + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); + stx->props = props; + return (Scheme_Object *)stx; + } else { + val = scheme_hash_tree_get(props, key); + if (!val) + return scheme_false; + return val; + } } -static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv) +static Scheme_Object *syntax_property(int argc, Scheme_Object **argv) { if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-taint", "syntax?", 0, argc, argv); + scheme_wrong_contract("syntax-property", "syntax?", 0, argc, argv); - return add_taint_to_stx(argv[0], NULL); - + if (argc > 2) + return scheme_stx_property(argv[0], argv[1], argv[2]); + else + return scheme_stx_property(argv[0], argv[1], NULL); } -/**********************************************************************/ -/* Debugging */ -/**********************************************************************/ - -Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) +static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) { - Scheme_Object *vec, *v; + Scheme_Stx *stx; - if (SCHEME_PAIRP(stx)) { - return scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(stx), ht), - scheme_explode_syntax(SCHEME_CDR(stx), ht)); - } - if (SCHEME_NULLP(stx)) - return scheme_null; + if (!SCHEME_STXP(argv[0])) + scheme_wrong_contract("syntax-property-symbol-keys", "syntax?", 0, argc, argv); - vec = scheme_hash_get(ht, stx); - if (vec) - return vec; + stx = (Scheme_Stx *)argv[0]; - vec = scheme_make_vector(3, NULL); - scheme_hash_set(ht, stx, vec); + if (stx->props) { + mzlonglong i; + Scheme_Object *key, *l = scheme_null; + + i = scheme_hash_tree_next(stx->props, -1); + while (i != -1) { + scheme_hash_tree_index(stx->props, i, &key, NULL); + if (SCHEME_SYMBOLP(key) && !SCHEME_SYM_WEIRDP(key)) + l = scheme_make_pair(key, l); + i = scheme_hash_tree_next(stx->props, i); + } - v = ((Scheme_Stx *)stx)->val; - if (SCHEME_PAIRP(v)) { - v = scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(v), ht), - scheme_explode_syntax(SCHEME_CDR(v), ht)); + return l; } - SCHEME_VEC_ELS(vec)[0] = v; - - v = ((Scheme_Stx *)stx)->taints; - SCHEME_VEC_ELS(vec)[1] = (v ? v : scheme_null); - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)((Scheme_Stx *)stx)->scopes; - - return vec; + + return scheme_null; } /**********************************************************************/ @@ -8808,9 +1017,6 @@ static void register_traversers(void) { GC_REG_TRAV(scheme_rt_srcloc, mark_srcloc); - GC_REG_TRAV(scheme_scope_type, mark_scope); - GC_REG_TRAV(scheme_scope_table_type, mark_scope_table); - GC_REG_TRAV(scheme_propagate_table_type, mark_propagate_table); } END_XFORM_SKIP; diff -Nru racket-6.12+ppa1/src/racket/src/thread.c racket-7.0+ppa1/src/racket/src/thread.c --- racket-6.12+ppa1/src/racket/src/thread.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/thread.c 2018-07-27 22:12:02.000000000 +0000 @@ -89,6 +89,8 @@ # define scheme_jit_malloced 0 #endif +SHARED_OK int scheme_init_load_on_demand = 1; + /*========================================================================*/ /* local variables and prototypes */ /*========================================================================*/ @@ -131,9 +133,6 @@ THREAD_LOCAL_DECL(static int num_minor_garbage_collections); #endif -SHARED_OK static int init_load_on_demand = 1; -SHARED_OK static int compiled_file_check = SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS; - #ifdef RUNSTACK_IS_GLOBAL THREAD_LOCAL_DECL(Scheme_Object **scheme_current_runstack_start); THREAD_LOCAL_DECL(Scheme_Object **scheme_current_runstack); @@ -201,8 +200,6 @@ ROSYM static Scheme_Object *major_symbol, *minor_symbol, *incremental_symbol; ROSYM static Scheme_Object *cumulative_symbol; -ROSYM static Scheme_Object *initial_compiled_file_check_symbol; - THREAD_LOCAL_DECL(static int do_atomic = 0); THREAD_LOCAL_DECL(static int missed_context_switch = 0); THREAD_LOCAL_DECL(static int have_activity = 0); @@ -342,6 +339,12 @@ static Scheme_Object *unsafe_get_place_table(int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_os_thread_enabled_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_call_in_os_thread(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_make_os_semaphore(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_os_semaphore_wait(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_os_semaphore_post(int argc, Scheme_Object *argv[]); + static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[]); static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[]); static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[]); @@ -350,9 +353,6 @@ static Scheme_Object *plumber_flush_p(int argc, Scheme_Object *argv[]); static Scheme_Object *current_plumber(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_namespace(int argc, Scheme_Object *args[]); -static Scheme_Object *namespace_p(int argc, Scheme_Object *args[]); - static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]); static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]); static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]); @@ -482,7 +482,7 @@ /* initialization */ /*========================================================================*/ -void scheme_init_thread(Scheme_Env *env) +void scheme_init_thread(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -514,26 +514,24 @@ REGISTER_SO(cumulative_symbol); cumulative_symbol = scheme_intern_symbol("cumulative"); - GLOBAL_PRIM_W_ARITY("dump-memory-stats" , scheme_dump_gc_stats, 0, -1, env); - GLOBAL_PRIM_W_ARITY("vector-set-performance-stats!", current_stats , 1, 2, env); + ADD_PRIM_W_ARITY("dump-memory-stats" , scheme_dump_gc_stats, 0, -1, env); + ADD_PRIM_W_ARITY("vector-set-performance-stats!", current_stats , 1, 2, env); - GLOBAL_PRIM_W_ARITY("make-empty-namespace", scheme_make_namespace, 0, 0, env); - - GLOBAL_PRIM_W_ARITY("thread" , sch_thread , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread/suspend-to-kill", sch_thread_nokill , 1, 1, env); - GLOBAL_PRIM_W_ARITY("sleep" , sch_sleep , 0, 1, env); - GLOBAL_FOLDING_PRIM("thread?" , thread_p , 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-running?" , thread_running_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-dead?" , thread_dead_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-wait" , thread_wait , 1, 1, env); - GLOBAL_PRIM_W_ARITY("current-thread" , sch_current , 0, 0, env); - GLOBAL_PRIM_W_ARITY("kill-thread" , kill_thread , 1, 1, env); - GLOBAL_PRIM_W_ARITY("break-thread" , break_thread , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-suspend" , thread_suspend , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-resume" , thread_resume , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-resume-evt" , make_thread_resume , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-suspend-evt" , make_thread_suspend, 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-dead-evt" , make_thread_dead , 1, 1, env); + ADD_PRIM_W_ARITY("thread" , sch_thread , 1, 1, env); + ADD_PRIM_W_ARITY("thread/suspend-to-kill", sch_thread_nokill , 1, 1, env); + ADD_PRIM_W_ARITY("sleep" , sch_sleep , 0, 1, env); + ADD_FOLDING_PRIM("thread?" , thread_p , 1, 1, 1, env); + ADD_PRIM_W_ARITY("thread-running?" , thread_running_p , 1, 1, env); + ADD_PRIM_W_ARITY("thread-dead?" , thread_dead_p , 1, 1, env); + ADD_PRIM_W_ARITY("thread-wait" , thread_wait , 1, 1, env); + ADD_PRIM_W_ARITY("current-thread" , sch_current , 0, 0, env); + ADD_PRIM_W_ARITY("kill-thread" , kill_thread , 1, 1, env); + ADD_PRIM_W_ARITY("break-thread" , break_thread , 1, 2, env); + ADD_PRIM_W_ARITY("thread-suspend" , thread_suspend , 1, 1, env); + ADD_PRIM_W_ARITY("thread-resume" , thread_resume , 1, 2, env); + ADD_PRIM_W_ARITY("thread-resume-evt" , make_thread_resume , 1, 1, env); + ADD_PRIM_W_ARITY("thread-suspend-evt" , make_thread_suspend, 1, 1, env); + ADD_PRIM_W_ARITY("thread-dead-evt" , make_thread_dead , 1, 1, env); register_thread_sync(); scheme_add_evt(scheme_thread_suspend_type, (Scheme_Ready_Fun)resume_suspend_ready, NULL, NULL, 1); @@ -542,128 +540,131 @@ scheme_add_evt(scheme_cust_box_type, cust_box_ready, NULL, NULL, 0); - GLOBAL_PARAMETER("current-custodian" , current_custodian , MZCONFIG_CUSTODIAN, env); - GLOBAL_PRIM_W_ARITY("make-custodian" , make_custodian , 0, 1, env); - GLOBAL_FOLDING_PRIM("custodian?" , custodian_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("custodian-shutdown-all", custodian_close_all , 1, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-shut-down?" , custodian_shut_down_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-managed-list", custodian_to_list , 2, 2, env); - GLOBAL_PRIM_W_ARITY("make-custodian-box" , make_custodian_box , 2, 2, env); - GLOBAL_PRIM_W_ARITY("custodian-box-value" , custodian_box_value , 1, 1, env); - GLOBAL_FOLDING_PRIM("custodian-box?" , custodian_box_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("call-in-nested-thread" , call_as_nested_thread, 1, 2, env); - - GLOBAL_PARAMETER("current-plumber" , current_plumber , MZCONFIG_PLUMBER, env); - GLOBAL_PRIM_W_ARITY("make-plumber" , make_plumber , 0, 0, env); - GLOBAL_FOLDING_PRIM("plumber?" , plumber_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("plumber-flush-all" , plumber_flush_all , 1, 1, env); - GLOBAL_PRIM_W_ARITY("plumber-add-flush!" , plumber_add_flush , 2, 3, env); - GLOBAL_PRIM_W_ARITY("plumber-flush-handle-remove!" , plumber_remove_flush, 1, 1, env); - GLOBAL_PRIM_W_ARITY("plumber-flush-handle?" , plumber_flush_p , 1, 1, env); - - GLOBAL_PARAMETER("current-namespace" , current_namespace, MZCONFIG_ENV, env); - GLOBAL_PRIM_W_ARITY("namespace?" , namespace_p , 1, 1, env); - - GLOBAL_PRIM_W_ARITY("security-guard?" , security_guard_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-security-guard", make_security_guard, 3, 4, env); - GLOBAL_PARAMETER("current-security-guard", current_security_guard, MZCONFIG_SECURITY_GUARD, env); - - GLOBAL_PRIM_W_ARITY("thread-group?" , thread_set_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-thread-group", make_thread_set, 0, 1, env); - GLOBAL_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env); - - GLOBAL_PRIM_W_ARITY("parameter?" , parameter_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 2, env); - GLOBAL_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env); - GLOBAL_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env); - GLOBAL_PRIM_W_ARITY("parameterization?" , parameterization_p , 1, 1, env); - - GLOBAL_PRIM_W_ARITY("thread-cell?" , thread_cell_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-thread-cell" , make_thread_cell , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-cell-ref" , thread_cell_get , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-cell-set!" , thread_cell_set , 2, 2, env); - GLOBAL_PRIM_W_ARITY("current-preserved-thread-cell-values", thread_cell_values, 0, 1, env); - GLOBAL_FOLDING_PRIM("thread-cell-values?" , is_thread_cell_values, 1, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("make-will-executor", make_will_executor, 0, 0, env); - GLOBAL_PRIM_W_ARITY("will-executor?" , will_executor_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("will-register" , register_will , 3, 3, env); - GLOBAL_PRIM_W_ARITY("will-try-execute" , will_executor_try , 1, 1, env); - GLOBAL_PRIM_W_ARITY("will-execute" , will_executor_go , 1, 1, env); + ADD_PARAMETER("current-custodian" , current_custodian , MZCONFIG_CUSTODIAN, env); + ADD_PRIM_W_ARITY("make-custodian" , make_custodian , 0, 1, env); + ADD_FOLDING_PRIM("custodian?" , custodian_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("custodian-shutdown-all", custodian_close_all , 1, 1, env); + ADD_PRIM_W_ARITY("custodian-shut-down?" , custodian_shut_down_p, 1, 1, env); + ADD_PRIM_W_ARITY("custodian-managed-list", custodian_to_list , 2, 2, env); + ADD_PRIM_W_ARITY("make-custodian-box" , make_custodian_box , 2, 2, env); + ADD_PRIM_W_ARITY("custodian-box-value" , custodian_box_value , 1, 1, env); + ADD_FOLDING_PRIM("custodian-box?" , custodian_box_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("call-in-nested-thread" , call_as_nested_thread, 1, 2, env); + + ADD_PARAMETER("current-plumber" , current_plumber , MZCONFIG_PLUMBER, env); + ADD_PRIM_W_ARITY("make-plumber" , make_plumber , 0, 0, env); + ADD_FOLDING_PRIM("plumber?" , plumber_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("plumber-flush-all" , plumber_flush_all , 1, 1, env); + ADD_PRIM_W_ARITY("plumber-add-flush!" , plumber_add_flush , 2, 3, env); + ADD_PRIM_W_ARITY("plumber-flush-handle-remove!" , plumber_remove_flush, 1, 1, env); + ADD_PRIM_W_ARITY("plumber-flush-handle?" , plumber_flush_p , 1, 1, env); + + ADD_PRIM_W_ARITY("security-guard?" , security_guard_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-security-guard", make_security_guard, 3, 4, env); + ADD_PARAMETER("current-security-guard", current_security_guard, MZCONFIG_SECURITY_GUARD, env); + + ADD_PRIM_W_ARITY("thread-group?" , thread_set_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-thread-group", make_thread_set, 0, 1, env); + ADD_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env); + + ADD_PRIM_W_ARITY("parameter?" , parameter_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 2, env); + ADD_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env); + ADD_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env); + ADD_PRIM_W_ARITY("parameterization?" , parameterization_p , 1, 1, env); + + ADD_PRIM_W_ARITY("thread-cell?" , thread_cell_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-thread-cell" , make_thread_cell , 1, 2, env); + ADD_PRIM_W_ARITY("thread-cell-ref" , thread_cell_get , 1, 1, env); + ADD_PRIM_W_ARITY("thread-cell-set!" , thread_cell_set , 2, 2, env); + ADD_PRIM_W_ARITY("current-preserved-thread-cell-values", thread_cell_values, 0, 1, env); + ADD_FOLDING_PRIM("thread-cell-values?" , is_thread_cell_values, 1, 1, 1, env); + + ADD_PRIM_W_ARITY("make-will-executor", make_will_executor, 0, 0, env); + ADD_PRIM_W_ARITY("will-executor?" , will_executor_p , 1, 1, env); + ADD_PRIM_W_ARITY("will-register" , register_will , 3, 3, env); + ADD_PRIM_W_ARITY("will-try-execute" , will_executor_try , 1, 2, env); + ADD_PRIM_W_ARITY("will-execute" , will_executor_go , 1, 1, env); scheme_add_evt_through_sema(scheme_will_executor_type, will_executor_sema, NULL); - GLOBAL_PRIM_W_ARITY("collect-garbage" , collect_garbage , 0, 1, env); - GLOBAL_PRIM_W_ARITY("current-memory-use" , current_memory_use , 0, 1, env); + ADD_PRIM_W_ARITY("collect-garbage" , collect_garbage , 0, 1, env); + ADD_PRIM_W_ARITY("current-memory-use" , current_memory_use , 0, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-require-memory" , custodian_require_mem, 3, 3, env); - GLOBAL_PRIM_W_ARITY("custodian-limit-memory" , custodian_limit_mem , 2, 3, env); - GLOBAL_PRIM_W_ARITY("custodian-memory-accounting-available?", custodian_can_mem , 0, 0, env); - - - GLOBAL_FOLDING_PRIM("evt?" , evt_p , 1, 1 , 1, env); - GLOBAL_PRIM_W_ARITY2("sync" , sch_sync , 0, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/timeout" , sch_sync_timeout , 1, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/enable-break" , sch_sync_enable_break , 0, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/timeout/enable-break", sch_sync_timeout_enable_break, 1, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY("choice-evt" , evts_to_evt , 0, -1, env); - - GLOBAL_PARAMETER("current-thread-initial-stack-size", current_thread_initial_stack_size, MZCONFIG_THREAD_INIT_STACK_SIZE, env); - - GLOBAL_PRIM_W_ARITY("phantom-bytes?", phantom_bytes_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-phantom-bytes", make_phantom_bytes, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set-phantom-bytes!", set_phantom_bytes, 2, 2, env); + ADD_PRIM_W_ARITY("custodian-require-memory" , custodian_require_mem, 3, 3, env); + ADD_PRIM_W_ARITY("custodian-limit-memory" , custodian_limit_mem , 2, 3, env); + ADD_PRIM_W_ARITY("custodian-memory-accounting-available?", custodian_can_mem , 0, 0, env); + + + ADD_FOLDING_PRIM("evt?" , evt_p , 1, 1 , 1, env); + ADD_PRIM_W_ARITY2("sync" , sch_sync , 0, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/timeout" , sch_sync_timeout , 1, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/enable-break" , sch_sync_enable_break , 0, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/timeout/enable-break", sch_sync_timeout_enable_break, 1, -1, 0, -1, env); + ADD_PRIM_W_ARITY("choice-evt" , evts_to_evt , 0, -1, env); + + ADD_PARAMETER("current-thread-initial-stack-size", current_thread_initial_stack_size, MZCONFIG_THREAD_INIT_STACK_SIZE, env); + + ADD_PRIM_W_ARITY("phantom-bytes?", phantom_bytes_p, 1, 1, env); + ADD_PRIM_W_ARITY("make-phantom-bytes", make_phantom_bytes, 1, 1, env); + ADD_PRIM_W_ARITY("set-phantom-bytes!", set_phantom_bytes, 2, 2, env); } void -scheme_init_unsafe_thread (Scheme_Env *env) +scheme_init_unsafe_thread (Scheme_Startup_Env *env) { - scheme_add_global_constant("unsafe-start-atomic", + scheme_addto_prim_instance("unsafe-start-atomic", scheme_make_prim_w_arity(unsafe_start_atomic, "unsafe-start-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-end-atomic", + scheme_addto_prim_instance("unsafe-end-atomic", scheme_make_prim_w_arity(unsafe_end_atomic, "unsafe-end-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-start-breakable-atomic", + scheme_addto_prim_instance("unsafe-start-breakable-atomic", scheme_make_prim_w_arity(unsafe_start_breakable_atomic, "unsafe-start-breakable-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-end-breakable-atomic", + scheme_addto_prim_instance("unsafe-end-breakable-atomic", scheme_make_prim_w_arity(unsafe_end_breakable_atomic, "unsafe-end-breakable-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-in-atomic?", + scheme_addto_prim_instance("unsafe-in-atomic?", scheme_make_prim_w_arity(unsafe_in_atomic_p, "unsafe-in-atomic?", 0, 0), env); - GLOBAL_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env); - GLOBAL_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env); - - GLOBAL_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-get-place-table", unsafe_get_place_table, 0, 0, env); - - GLOBAL_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("unsafe-make-security-guard-at-root", unsafe_make_security_guard_at_root, 0, 3, env); - - scheme_add_global_constant("unsafe-poller", scheme_unsafe_poller_proc, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-fd-wakeup", unsafe_poll_ctx_fd_wakeup, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-eventmask-wakeup", unsafe_poll_ctx_eventmask_wakeup, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-milliseconds-wakeup", unsafe_poll_ctx_time_wakeup, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-signal-received", unsafe_signal_received, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-set-sleep-in-thread!", unsafe_set_sleep_in_thread, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env); + ADD_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env); + + ADD_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-get-place-table", unsafe_get_place_table, 0, 0, env); + + ADD_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env); + + ADD_PRIM_W_ARITY("unsafe-make-security-guard-at-root", unsafe_make_security_guard_at_root, 0, 3, env); + + scheme_addto_prim_instance("unsafe-poller", scheme_unsafe_poller_proc, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-fd-wakeup", unsafe_poll_ctx_fd_wakeup, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-eventmask-wakeup", unsafe_poll_ctx_eventmask_wakeup, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-milliseconds-wakeup", unsafe_poll_ctx_time_wakeup, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-signal-received", unsafe_signal_received, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-set-sleep-in-thread!", unsafe_set_sleep_in_thread, 2, 2, env); + + ADD_PRIM_W_ARITY("unsafe-os-thread-enabled?", unsafe_os_thread_enabled_p, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-call-in-os-thread", unsafe_call_in_os_thread, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-make-os-semaphore", unsafe_make_os_semaphore, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-os-semaphore-wait", unsafe_os_semaphore_wait, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-os-semaphore-post", unsafe_os_semaphore_post, 1, 1, env); } void scheme_init_thread_places(void) { @@ -686,11 +687,6 @@ instances. */ } -void scheme_set_compiled_file_check(int c) -{ - compiled_file_check = c; -} - Scheme_Object *scheme_get_current_inspector() XFORM_SKIP_PROC { @@ -718,39 +714,25 @@ scheme_break_enabled_key = scheme_make_symbol("break-on?"); } -void scheme_init_param_symbol() +void scheme_init_paramz(Scheme_Startup_Env *env) { - REGISTER_SO(initial_compiled_file_check_symbol); - if (compiled_file_check == SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS) - initial_compiled_file_check_symbol = scheme_intern_symbol("modify-seconds"); - else - initial_compiled_file_check_symbol = scheme_intern_symbol("exists"); -} - -void scheme_init_paramz(Scheme_Env *env) -{ - Scheme_Object *v; - Scheme_Env *newenv; - - v = scheme_intern_symbol("#%paramz"); - newenv = scheme_primitive_module(v, env); + scheme_switch_prim_instance(env, "#%paramz"); - scheme_add_global_constant("exception-handler-key", scheme_exn_handler_key , newenv); - scheme_add_global_constant("parameterization-key" , scheme_parameterization_key, newenv); - scheme_add_global_constant("break-enabled-key" , scheme_break_enabled_key , newenv); + scheme_addto_prim_instance("exception-handler-key", scheme_exn_handler_key , env); + scheme_addto_prim_instance("parameterization-key" , scheme_parameterization_key, env); + scheme_addto_prim_instance("break-enabled-key" , scheme_break_enabled_key , env); - GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv); - GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv); + ADD_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, env); + ADD_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, env); + ADD_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, env); - GLOBAL_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, newenv); + ADD_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, env); - GLOBAL_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, newenv); - GLOBAL_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, newenv); - GLOBAL_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, newenv); + ADD_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, env); + ADD_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, env); + ADD_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, env); - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); + scheme_restore_prim_instance(env); } static Scheme_Object *collect_garbage(int argc, Scheme_Object *argv[]) @@ -2496,8 +2478,6 @@ process->block_needs_wakeup = NULL; process->sleep_end = 0; - process->current_local_env = NULL; - process->external_break = 0; process->ran_some = 1; @@ -2827,6 +2807,40 @@ } /*========================================================================*/ +/* OS threads - not supported */ +/*========================================================================*/ + +static Scheme_Object *unsafe_os_thread_enabled_p(int argc, Scheme_Object *argv[]) +{ + return scheme_false; +} + +static Scheme_Object *unsafe_call_in_os_thread(int argc, Scheme_Object *argv[]) +{ + scheme_check_proc_arity("unsafe-call-in-os-thread", 0, 0, argc, argv); + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "unsafe-call-in-os-thread: " NOT_SUPPORTED_STR); + ESCAPED_BEFORE_HERE; +} + +static Scheme_Object *unsafe_make_os_semaphore(int argc, Scheme_Object *argv[]) +{ + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "unsafe-make-os-semaphore: " NOT_SUPPORTED_STR); + ESCAPED_BEFORE_HERE; +} + +static Scheme_Object *unsafe_os_semaphore_wait(int argc, Scheme_Object *argv[]) +{ + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "unsafe-os-semaphore-wait: " NOT_SUPPORTED_STR); + ESCAPED_BEFORE_HERE; +} + +static Scheme_Object *unsafe_os_semaphore_post(int argc, Scheme_Object *argv[]) +{ + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "unsafe-os-semaphore-post: " NOT_SUPPORTED_STR); + ESCAPED_BEFORE_HERE; +} + +/*========================================================================*/ /* thread creation and swapping */ /*========================================================================*/ @@ -4334,7 +4348,7 @@ space on escapes. Aside from a thread kill, this is the only place where we have to worry about freeing bignum space, because kill and escape are the only possible actions within a bignum - calculaion. It is possible to have nested bignum calculations, + calculation. It is possible to have nested bignum calculations, though (if the break handler performs bignum arithmetic), so that's why we save and restore an old snapshot. */ mz_jmp_buf *savebuf, newbuf; @@ -7488,6 +7502,9 @@ Scheme_Object *scheme_get_param(Scheme_Config *c, int pos) { + if (pos == MZCONFIG_ENV) + return (Scheme_Object *)scheme_get_current_namespace_as_env(); + return scheme_get_thread_param(c, scheme_current_thread->cell_values, pos); } @@ -7498,6 +7515,11 @@ void scheme_set_param(Scheme_Config *c, int pos, Scheme_Object *o) { + if (pos == MZCONFIG_ENV) { + scheme_set_current_namespace_as_env((Scheme_Env *)o); + return; + } + scheme_thread_cell_set(find_param_cell(c, scheme_make_integer(pos), 1), scheme_current_thread->cell_values, o); } @@ -7830,19 +7852,10 @@ p->init_config = config; - init_param(cells, paramz, MZCONFIG_READTABLE, scheme_make_default_readtable()); - - init_param(cells, paramz, MZCONFIG_CAN_READ_GRAPH, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_COMPILED, scheme_false); - init_param(cells, paramz, MZCONFIG_CAN_READ_BOX, scheme_true); + init_param(cells, paramz, MZCONFIG_CASE_SENS, (scheme_case_sensitive ? scheme_true : scheme_false)); init_param(cells, paramz, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_DOT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_QUASI, scheme_true); - init_param(cells, paramz, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_READER, scheme_false); - init_param(cells, paramz, MZCONFIG_CAN_READ_LANG, scheme_true); - init_param(cells, paramz, MZCONFIG_LOAD_DELAY_ENABLED, init_load_on_demand ? scheme_true : scheme_false); + + init_param(cells, paramz, MZCONFIG_LOAD_DELAY_ENABLED, scheme_init_load_on_demand ? scheme_true : scheme_false); init_param(cells, paramz, MZCONFIG_DELAY_LOAD_INFO, scheme_false); init_param(cells, paramz, MZCONFIG_PRINT_GRAPH, scheme_false); @@ -7867,16 +7880,6 @@ init_param(cells, paramz, MZCONFIG_LOCALE, s); } - init_param(cells, paramz, MZCONFIG_CASE_SENS, (scheme_case_sensitive ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, (scheme_square_brackets_are_parens - ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_PARENS, (scheme_curly_braces_are_parens - ? scheme_true : scheme_false)); - - init_param(cells, paramz, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); - init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); - init_param(cells, paramz, MZCONFIG_READ_CDOT, scheme_false); - init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(256)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, scheme_make_integer(16)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_SRCLOC, scheme_true); @@ -7897,11 +7900,6 @@ ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_COLLECTION_PATHS, scheme_null); - init_param(cells, paramz, MZCONFIG_COLLECTION_LINKS, scheme_null); - - init_param(cells, paramz, MZCONFIG_USE_COMPILED_FILE_CHECK, initial_compiled_file_check_symbol); - { Scheme_Security_Guard *sg; @@ -7953,23 +7951,6 @@ rs = scheme_make_random_state(scheme_get_milliseconds()); init_param(cells, paramz, MZCONFIG_SCHEDULER_RANDOM_STATE, rs); } - - { - Scheme_Object *eh; - eh = scheme_make_prim_w_arity2(scheme_default_eval_handler, - "default-eval-handler", - 1, 1, - 0, -1); - init_param(cells, paramz, MZCONFIG_EVAL_HANDLER, eh); - } - - { - Scheme_Object *eh; - eh = scheme_make_prim_w_arity(scheme_default_compile_handler, - "default-compile-handler", - 2, 2); - init_param(cells, paramz, MZCONFIG_COMPILE_HANDLER, eh); - } { Scheme_Object *ph; @@ -8047,7 +8028,7 @@ void scheme_set_startup_load_on_demand(int on) { - init_load_on_demand = on; + scheme_init_load_on_demand = on; } Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which) @@ -8262,7 +8243,7 @@ } /*========================================================================*/ -/* namespaces */ +/* environment */ /*========================================================================*/ Scheme_Env *scheme_get_env(Scheme_Config *c) @@ -8277,37 +8258,6 @@ return (Scheme_Env *)o; } -Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv, *env; - intptr_t phase; - - genv = scheme_get_env(NULL); - env = scheme_make_empty_env(); - - for (phase = genv->phase; phase--; ) { - scheme_prepare_exp_env(env); - env = env->exp_env; - } - - return (Scheme_Object *)env; -} - -static Scheme_Object *namespace_p(int argc, Scheme_Object **argv) -{ - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_namespace_type)) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *current_namespace(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-namespace", - scheme_make_integer(MZCONFIG_ENV), - argc, argv, - -1, namespace_p, "namespace?", 0); -} - /*========================================================================*/ /* security guards */ /*========================================================================*/ @@ -8681,6 +8631,8 @@ if (scheme_wait_sema(w->sema, 1)) return do_next_will(w); + else if (argc > 1) + return argv[1]; else return scheme_false; } @@ -9126,8 +9078,6 @@ scheme_zero_unneeded_rands(scheme_current_thread); - scheme_clear_modidx_cache(); - scheme_clear_shift_cache(); scheme_clear_prompt_cache(); scheme_clear_rx_buffers(); scheme_clear_bignum_cache(); @@ -9364,7 +9314,7 @@ Scheme_Logger *logger; if (max_gc_pre_used_bytes > 0) { logger = scheme_get_gc_logger(); - if (logger && scheme_log_level_p(logger, SCHEME_LOG_DEBUG)) { + if (logger && scheme_log_level_p(logger, SCHEME_LOG_INFO)) { char buf[256], nums[128], *num, *numt, *num2; intptr_t buflen, allocated_bytes; #ifdef MZ_PRECISE_GC @@ -9387,7 +9337,7 @@ num_minor_garbage_collections, num2); buflen = strlen(buf); - scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, scheme_false); + scheme_log_message(logger, SCHEME_LOG_INFO, buf, buflen, scheme_false); /* Setting to a negative value ensures that we log the peak only once: */ max_gc_pre_used_bytes = -1; } diff -Nru racket-6.12+ppa1/src/racket/src/type.c racket-7.0+ppa1/src/racket/src/type.c --- racket-6.12+ppa1/src/racket/src/type.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/type.c 2018-07-27 22:12:02.000000000 +0000 @@ -28,8 +28,6 @@ /* types should all be registered before invoking places */ -SHARED_OK Scheme_Type_Reader *scheme_type_readers; -SHARED_OK Scheme_Type_Writer *scheme_type_writers; SHARED_OK Scheme_Equal_Proc *scheme_type_equals; SHARED_OK Scheme_Primary_Hash_Proc *scheme_type_hash1s; SHARED_OK Scheme_Secondary_Hash_Proc *scheme_type_hash2s; @@ -56,8 +54,6 @@ #endif REGISTER_SO(type_names); - REGISTER_SO(scheme_type_readers); - REGISTER_SO(scheme_type_writers); REGISTER_SO(scheme_type_equals); REGISTER_SO(scheme_type_hash1s); REGISTER_SO(scheme_type_hash2s); @@ -67,19 +63,12 @@ type_names = RAW_MALLOC_N(char *, allocmax); memset(type_names, 0, allocmax * sizeof(char *)); - scheme_type_readers = RAW_MALLOC_N(Scheme_Type_Reader, allocmax); - n = allocmax * sizeof(Scheme_Type_Reader); - memset(scheme_type_readers, 0, n); #ifdef MEMORY_COUNTING_ON scheme_type_table_count += n; scheme_misc_count += (allocmax * sizeof(char *)); #endif - scheme_type_writers = RAW_MALLOC_N(Scheme_Type_Writer, allocmax); - n = allocmax * sizeof(Scheme_Type_Writer); - memset(scheme_type_writers, 0, n); - #ifdef MEMORY_COUNTING_ON scheme_type_table_count += n; #endif @@ -112,7 +101,7 @@ set_name(scheme_local_unbox_type, ""); set_name(scheme_variable_type, ""); set_name(scheme_toplevel_type, ""); - set_name(scheme_module_variable_type, ""); + set_name(scheme_static_toplevel_type, ""); set_name(scheme_application_type, ""); set_name(scheme_application2_type, ""); set_name(scheme_application3_type, ""); @@ -121,18 +110,12 @@ set_name(scheme_branch_type, ""); set_name(scheme_sequence_type, ""); set_name(scheme_with_cont_mark_type, ""); - set_name(scheme_quote_syntax_type, ""); set_name(scheme_define_values_type, ""); - set_name(scheme_define_syntaxes_type, ""); - set_name(scheme_begin_for_syntax_type, ""); set_name(scheme_begin0_sequence_type, ""); - set_name(scheme_splice_sequence_type, ""); - set_name(scheme_module_type, ""); set_name(scheme_inline_variant_type, ""); set_name(scheme_set_bang_type, ""); set_name(scheme_boxenv_type, ""); - set_name(scheme_require_form_type, ""); set_name(scheme_varref_form_type, ""); set_name(scheme_apply_values_type, ""); set_name(scheme_with_immed_mark_type, ""); @@ -144,11 +127,15 @@ set_name(scheme_ir_let_value_type, ""); set_name(scheme_ir_let_header_type, ""); set_name(scheme_ir_toplevel_type, ""); - set_name(scheme_ir_quote_syntax_type, ""); set_name(scheme_letrec_type, ""); set_name(scheme_let_one_type, ""); set_name(scheme_quote_compilation_type, ""); + set_name(scheme_linklet_type, ""); + set_name(scheme_instance_type, ""); + set_name(scheme_linklet_directory_type, ""); + set_name(scheme_linklet_bundle_type, ""); + set_name(scheme_eval_waiting_type, ""); set_name(scheme_void_type, ""); set_name(scheme_prim_type, ""); @@ -206,7 +193,6 @@ set_name(scheme_hash_tree_subtree_type, ""); set_name(scheme_hash_tree_collision_type, ""); set_name(scheme_bucket_table_type, ""); - set_name(scheme_module_registry_type, ""); set_name(scheme_case_closure_type, ""); set_name(scheme_placeholder_type, ""); set_name(scheme_table_placeholder_type, ""); @@ -218,21 +204,15 @@ set_name(scheme_listener_type, ""); set_name(scheme_tcp_accept_evt_type, ""); set_name(scheme_filesystem_change_evt_type, ""); - set_name(scheme_namespace_type, ""); + set_name(scheme_env_type, ""); set_name(scheme_config_type, ""); set_name(scheme_will_executor_type, ""); set_name(scheme_random_state_type, ""); set_name(scheme_regexp_type, ""); - set_name(scheme_scope_table_type, ""); - set_name(scheme_propagate_table_type, ""); - set_name(scheme_scope_type, ""); set_name(scheme_bucket_type, ""); set_name(scheme_prefix_type, ""); - set_name(scheme_resolve_prefix_type, ""); set_name(scheme_readtable_type, ""); - set_name(scheme_compilation_top_type, ""); - set_name(scheme_svector_type, ""); set_name(scheme_custodian_type, ""); @@ -244,20 +224,12 @@ set_name(scheme_inspector_type, ""); - set_name(scheme_stx_type, ""); - set_name(scheme_stx_offset_type, ""); - set_name(scheme_expanded_syntax_type, ""); - set_name(scheme_set_macro_type, ""); - set_name(scheme_id_macro_type, ""); - - set_name(scheme_module_index_type, ""); + set_name(scheme_stx_type, ""); set_name(scheme_subprocess_type, ""); set_name(scheme_cpointer_type, ""); - set_name(scheme_wrap_chunk_type, ""); - set_name(scheme_security_guard_type, ""); set_name(scheme_indent_type, ""); @@ -296,17 +268,10 @@ set_name(scheme_channel_syncer_type, ""); - set_name(scheme_special_comment_type, ""); - set_name(scheme_global_ref_type, ""); set_name(scheme_delay_syntax_type, ""); - set_name(scheme_intdef_context_type, ""); - set_name(scheme_lexical_rib_type, ""); - - set_name(scheme_already_comp_type, ""); - set_name(scheme_logger_type, ""); set_name(scheme_log_reader_type, ""); @@ -321,19 +286,20 @@ set_name(scheme_place_bi_channel_type, ""); set_name(scheme_place_dead_type, ""); - set_name(scheme_resolved_module_path_type, ""); - set_name(scheme_phantom_bytes_type, ""); set_name(scheme_environment_variables_type, ""); + set_name(scheme_prompt_type, ""); + set_name(scheme_startup_env_type, ""); + set_name(scheme_ctype_type, ""); + set_name(scheme_unquoted_printing_string_type, ""); -#ifdef MZ_GC_BACKTRACE +#ifdef MZ_PRECISE_GC set_name(scheme_rt_runstack, ""); set_name(scheme_rt_meta_cont, ""); set_name(scheme_rt_weak_array, ""); - set_name(scheme_syntax_property_preserve_type, ""); set_name(scheme_rt_resolve_info, ""); set_name(scheme_rt_unresolve_info, ""); set_name(scheme_rt_optimize_info, ""); @@ -347,8 +313,29 @@ set_name(scheme_rt_native_code_plus_case, ""); set_name(scheme_rt_sfs_info, ""); set_name(scheme_rt_letrec_check_frame, ""); - set_name(scheme_rt_module_exports, ""); - set_name(scheme_rt_export_info, ""); + set_name(scheme_rt_saved_stack, ""); + set_name(scheme_rt_overflow_jmp, ""); + set_name(scheme_rt_dyn_wind, ""); + set_name(scheme_rt_dyn_wind_info, ""); + set_name(scheme_rt_dyn_wind_cell, ""); + set_name(scheme_rt_input_fd, ""); + set_name(scheme_rt_pipe, ""); + set_name(scheme_rt_param_data, ""); + set_name(scheme_rt_will, ""); + set_name(scheme_rt_finalization, ""); + set_name(scheme_rt_finalizations, ""); + set_name(scheme_thread_hop_type, ""); + set_name(scheme_rt_evt, ""); + set_name(scheme_rt_syncing, ""); + set_name(scheme_rt_user_input, ""); + set_name(scheme_rt_user_output, ""); + set_name(scheme_rt_compact_port, ""); + set_name(scheme_rt_rx_lazy_string, ""); + set_name(scheme_rt_parameterization, ""); + set_name(scheme_rt_delay_load_info, ""); + set_name(scheme_rt_validate_clearing, ""); + set_name(scheme_rt_print_params, ""); + set_name(scheme_rt_comp_env, ""); #endif } @@ -376,18 +363,6 @@ free(type_names); type_names = (char **)naya; - naya = malloc(n = allocmax * sizeof(Scheme_Type_Reader)); - memset(naya, 0, n); - memcpy(naya, scheme_type_readers, maxtype * sizeof(Scheme_Type_Reader)); - free(scheme_type_readers); - scheme_type_readers = (Scheme_Type_Reader *)naya; - - naya = malloc(n = allocmax * sizeof(Scheme_Type_Writer)); - memset(naya, 0, n); - memcpy(naya, scheme_type_writers, maxtype * sizeof(Scheme_Type_Writer)); - free(scheme_type_writers); - scheme_type_writers = (Scheme_Type_Writer *)naya; - naya = malloc(n = allocmax * sizeof(Scheme_Equal_Proc)); memset(naya, 0, n); memcpy(naya, scheme_type_equals, maxtype * sizeof(Scheme_Equal_Proc)); @@ -407,8 +382,6 @@ scheme_type_hash2s = (Scheme_Secondary_Hash_Proc *)naya; #ifdef MEMORY_COUNTING_ON - scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader) - + sizeof(Scheme_Type_Writer)); scheme_misc_count += (20 * sizeof(char *)); #endif } @@ -446,23 +419,6 @@ return s ? s : "???"; } -void scheme_install_type_reader(Scheme_Type t, Scheme_Type_Reader f) -{ - if (t < 0 || t >= maxtype) - return; - - scheme_type_readers[t] = f; -} - -void scheme_install_type_writer(Scheme_Type t, Scheme_Type_Writer f) -{ - if (t < 0 || t >= maxtype) - return; - - scheme_type_writers[t] = f; -} - - void scheme_set_type_equality(Scheme_Type t, Scheme_Equal_Proc f, Scheme_Primary_Hash_Proc hash1, @@ -574,6 +530,7 @@ void scheme_register_traversers(void) { GC_REG_TRAV(scheme_toplevel_type, toplevel_obj); + GC_REG_TRAV(scheme_static_toplevel_type, static_toplevel_obj); GC_REG_TRAV(scheme_variable_type, variable_obj); GC_REG_TRAV(scheme_local_type, local_obj); GC_REG_TRAV(scheme_local_unbox_type, local_obj); @@ -588,41 +545,35 @@ GC_REG_TRAV(scheme_letrec_type, letrec); GC_REG_TRAV(scheme_let_one_type, let_one); GC_REG_TRAV(scheme_with_cont_mark_type, with_cont_mark); - GC_REG_TRAV(scheme_quote_syntax_type, quotesyntax_obj); - GC_REG_TRAV(scheme_module_variable_type, module_var); GC_REG_TRAV(scheme_define_values_type, vector_obj); - GC_REG_TRAV(scheme_define_syntaxes_type, vector_obj); - GC_REG_TRAV(scheme_begin_for_syntax_type, vector_obj); GC_REG_TRAV(scheme_varref_form_type, twoptr_obj); GC_REG_TRAV(scheme_apply_values_type, twoptr_obj); GC_REG_TRAV(scheme_with_immed_mark_type, with_cont_mark); GC_REG_TRAV(scheme_boxenv_type, twoptr_obj); GC_REG_TRAV(scheme_case_lambda_sequence_type, case_closure); GC_REG_TRAV(scheme_begin0_sequence_type, seq_rec); - GC_REG_TRAV(scheme_splice_sequence_type, seq_rec); GC_REG_TRAV(scheme_set_bang_type, set_bang); - GC_REG_TRAV(scheme_module_type, module_val); - GC_REG_TRAV(scheme_rt_export_info, exp_info_val); - GC_REG_TRAV(scheme_require_form_type, twoptr_obj); GC_REG_TRAV(scheme_inline_variant_type, vector_obj); GC_REG_TRAV(_scheme_values_types_, bad_trav); GC_REG_TRAV(scheme_ir_lambda_type, unclosed_proc); GC_REG_TRAV(scheme_ir_local_type, ir_local); + GC_REG_TRAV(scheme_ir_toplevel_type, ir_toplevel); GC_REG_TRAV(scheme_ir_let_value_type, ir_let_value); GC_REG_TRAV(scheme_ir_let_header_type, let_header); - GC_REG_TRAV(scheme_ir_toplevel_type, toplevel_obj); - GC_REG_TRAV(scheme_ir_quote_syntax_type, local_obj); GC_REG_TRAV(scheme_quote_compilation_type, small_object); + GC_REG_TRAV(scheme_linklet_type, linklet_val); + GC_REG_TRAV(scheme_instance_type, instance_val); + GC_REG_TRAV(scheme_linklet_directory_type, small_object); + GC_REG_TRAV(scheme_linklet_bundle_type, small_object); + GC_REG_TRAV(_scheme_ir_values_types_, bad_trav); GC_REG_TRAV(scheme_prefix_type, prefix_val); - GC_REG_TRAV(scheme_resolve_prefix_type, resolve_prefix_val); - GC_REG_TRAV(scheme_rt_comp_prefix, comp_prefix_val); GC_REG_TRAV(scheme_prim_type, prim_proc); GC_REG_TRAV(scheme_closed_prim_type, closed_prim_proc); @@ -675,8 +626,6 @@ GC_REG_TRAV(scheme_true_type, small_atomic_obj); GC_REG_TRAV(scheme_false_type, small_atomic_obj); GC_REG_TRAV(scheme_void_type, small_atomic_obj); - GC_REG_TRAV(scheme_primitive_syntax_type, syntax_compiler); - GC_REG_TRAV(scheme_macro_type, small_object); GC_REG_TRAV(scheme_box_type, small_object); GC_REG_TRAV(scheme_thread_type, thread_val); GC_REG_TRAV(scheme_prompt_type, prompt_val); @@ -692,13 +641,10 @@ GC_REG_TRAV(scheme_thread_dead_type, small_object); GC_REG_TRAV(scheme_hash_table_type, hash_table_val); GC_REG_TRAV(scheme_bucket_table_type, bucket_table_val); - GC_REG_TRAV(scheme_module_registry_type, module_reg_val); - GC_REG_TRAV(scheme_namespace_type, namespace_val); + GC_REG_TRAV(scheme_env_type, env_val); + GC_REG_TRAV(scheme_startup_env_type, startup_env_val); GC_REG_TRAV(scheme_random_state_type, random_state_val); - GC_REG_TRAV(scheme_compilation_top_type, compilation_top_val); - GC_REG_TRAV(scheme_intdef_context_type, twoptr_obj); - GC_REG_TRAV(scheme_eval_waiting_type, bad_trav); GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav); GC_REG_TRAV(scheme_undefined_type, small_atomic_obj); @@ -707,15 +653,7 @@ GC_REG_TRAV(scheme_svector_type, svector_val); - GC_REG_TRAV(scheme_set_macro_type, small_object); - GC_REG_TRAV(scheme_id_macro_type, twoptr_obj); - GC_REG_TRAV(scheme_stx_type, stx_val); - GC_REG_TRAV(scheme_stx_offset_type, stx_off_val); - GC_REG_TRAV(scheme_expanded_syntax_type, twoptr_obj); - GC_REG_TRAV(scheme_rt_module_exports, module_exports_val); - GC_REG_TRAV(scheme_module_phase_exports_type, module_phase_exports_val); - GC_REG_TRAV(scheme_module_index_type, modidx_val); GC_REG_TRAV(scheme_security_guard_type, guard_val); @@ -732,12 +670,8 @@ GC_REG_TRAV(scheme_tcp_accept_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_special_comment_type, small_object); - GC_REG_TRAV(scheme_progress_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_already_comp_type, iptr_obj); - GC_REG_TRAV(scheme_will_be_lambda_type, iptr_obj); GC_REG_TRAV(scheme_thread_cell_values_type, small_object); @@ -745,25 +679,19 @@ GC_REG_TRAV(scheme_global_ref_type, twoptr_obj); GC_REG_TRAV(scheme_delay_syntax_type, small_object); - GC_REG_TRAV(scheme_marshal_share_type, small_object); - - GC_REG_TRAV(scheme_resolved_module_path_type, small_object); GC_REG_TRAV(scheme_logger_type, mark_logger); GC_REG_TRAV(scheme_log_reader_type, mark_log_reader); GC_REG_TRAV(scheme_rt_runstack, runstack_val); - GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); - GC_REG_TRAV(scheme_prune_context_type, small_object); GC_REG_TRAV(scheme_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_struct_proc_shape_type, struct_proc_shape); GC_REG_TRAV(scheme_struct_prop_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_environment_variables_type, small_object); - GC_REG_TRAV(scheme_syntax_property_preserve_type, small_object); GC_REG_TRAV(scheme_plumber_handle_type, twoptr_obj); diff -Nru racket-6.12+ppa1/src/racket/src/unwind/libunwind.c racket-7.0+ppa1/src/racket/src/unwind/libunwind.c --- racket-6.12+ppa1/src/racket/src/unwind/libunwind.c 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/unwind/libunwind.c 2018-07-27 22:12:02.000000000 +0000 @@ -2558,12 +2558,14 @@ unw_word_t *n; n = (unw_word_t *)malloc(sizeof(unw_word_t) * size); - memcpy(n, cb_data->starts, sizeof(unw_word_t) * cb_data->size); + if (cb_data->size != 0) + memcpy(n, cb_data->starts, sizeof(unw_word_t) * cb_data->size); if (cb_data->starts) free(cb_data->starts); cb_data->starts = n; n = (unw_word_t *)malloc(sizeof(unw_word_t) * size); - memcpy(n, cb_data->ends, sizeof(unw_word_t) * cb_data->size); + if (cb_data->size != 0) + memcpy(n, cb_data->ends, sizeof(unw_word_t) * cb_data->size); if (cb_data->ends) free(cb_data->ends); cb_data->ends = n; @@ -3142,7 +3144,7 @@ return addr; } -int dwarf_to_unw_regnum(reg) +int dwarf_to_unw_regnum(int reg) { #ifdef UNW_ARM return (((reg) < 16) ? (reg) : 0); diff -Nru racket-6.12+ppa1/src/racket/src/validate.c racket-7.0+ppa1/src/racket/src/validate.c --- racket-6.12+ppa1/src/racket/src/validate.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/validate.c 2018-07-27 22:12:02.000000000 +0000 @@ -37,7 +37,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, @@ -47,7 +47,7 @@ static int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map); + int num_toplevels, int num_lifts, void *tl_use_map); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -143,117 +143,76 @@ scheme_make_integer(shape)); } -static int phaseless_expr(Scheme_Object *expr) -{ - /* A precise check is a little tricky, since compiler optimizations - might change the original program beyond easily recognition of - the syntactic pattern that defines "phaseless". For now, let - anything through; the result can be weird if state somehow leakes - through a "phaseless" module, but I don't think it can be unsafe - from the run-time system's perspective. */ - return 1; -} - -void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, - int depth, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object **toplevels, - int code_vec) -/* code_vec == 2 => check that phasesless is ok */ +void scheme_validate_linklet(Mz_CPort *port, Scheme_Linklet *linklet) { char *stack; - int delta; + int depth, delta, num_toplevels, i, j, pos; + int cnt, tl_timestamp = 1; struct Validate_Clearing *vc; Validate_TLS tls; mzshort *tl_state; Scheme_Hash_Table **_st_ht = NULL; - Scheme_Object *form; + Scheme_Object *form, *shape; - depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + depth = linklet->max_let_depth + 1; /* +1 is for prefix */ stack = scheme_malloc_atomic(depth); memset(stack, VALID_NOT, depth); - if (num_toplevels || num_stxes || num_lifts) { - stack[depth - 1] = VALID_TOPLEVELS; - } - delta = depth - ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + stack[depth - 1] = VALID_TOPLEVELS; + delta = depth - 1; - tls = MALLOC_N(mzshort*, num_lifts); + tls = MALLOC_N(mzshort*, linklet->num_lifts); _st_ht = MALLOC_N(Scheme_Hash_Table*, 1); - - if (code_vec) { - int i; - tl_state = MALLOC_N_ATOMIC(mzshort, num_toplevels); - memset(tl_state, 0, sizeof(mzshort) * num_toplevels); - for (i = 0; i < num_toplevels; i++) { - if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) { - int mv_flags = SCHEME_MODVAR_FLAGS(toplevels[i]); - if (mv_flags & SCHEME_MODVAR_CONST) { + + num_toplevels = SCHEME_LINKLET_PREFIX_PREFIX + linklet->num_total_imports + SCHEME_VEC_SIZE(linklet->defns); + + tl_state = MALLOC_N_ATOMIC(mzshort, num_toplevels); + memset(tl_state, 0, sizeof(mzshort) * num_toplevels); + + if (linklet->need_instance_access) + tl_state[0] = 1; + + pos = SCHEME_LINKLET_PREFIX_PREFIX; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++, pos++) { + shape = (linklet->import_shapes ? SCHEME_VEC_ELS(linklet->import_shapes)[pos-SCHEME_LINKLET_PREFIX_PREFIX] : scheme_false); + if (SCHEME_TRUEP(shape)) { + if (SAME_OBJ(shape, scheme_void)) + tl_state[pos] = SCHEME_TOPLEVEL_FIXED; + else { intptr_t k; - tl_state[i] = SCHEME_TOPLEVEL_CONST; - if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) - add_struct_mapping(_st_ht, i, k, 0); - else if (scheme_decode_struct_prop_shape(((Module_Variable *)toplevels[i])->shape, &k)) - add_struct_mapping(_st_ht, i, k, 1); - } else if (mv_flags & SCHEME_MODVAR_FIXED) - tl_state[i] = SCHEME_TOPLEVEL_FIXED; - else - tl_state[i] = SCHEME_TOPLEVEL_READY; - } - if (0) { - if (i < num_toplevels) { - if (SCHEME_SYMBOLP(toplevels[i])) - printf("%d is %s\n", i, SCHEME_SYM_VAL(toplevels[i])); - if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) - printf("%d is imported %s (%d)\n", i, - SCHEME_SYM_VAL(((Module_Variable *)toplevels[i])->sym), - SCHEME_MODVAR_FLAGS(toplevels[i]) & 0x3); + tl_state[pos] = SCHEME_TOPLEVEL_CONST; + if (scheme_decode_struct_shape(shape, &k)) + add_struct_mapping(_st_ht, pos, k, 0); + else if (scheme_decode_struct_prop_shape(shape, &k)) + add_struct_mapping(_st_ht, pos, k, 1); } - } + } else + tl_state[pos] = SCHEME_TOPLEVEL_READY; } - } else { - tl_state = NULL; } vc = make_clearing_stack(); - if (code_vec) { - int i, cnt, tl_timestamp = 1; - cnt = SCHEME_VEC_SIZE(code); - for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(code)[i]; - if (code_vec == 2) { - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - if (!phaseless_expr(SCHEME_VEC_ELS(form)[0])) - scheme_ill_formed_code(port); - } else - scheme_ill_formed_code(port); - } - reset_clearing(vc); - if (!validate_expr(port, form, - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - NULL, 0, 0, - vc, 1, 0, NULL, -1, _st_ht)) { - tl_timestamp++; - if (0) { - printf("increment to %d for %d %p\n", tl_timestamp, - SCHEME_TYPE(SCHEME_VEC_ELS(code)[i]), - SCHEME_VEC_ELS(code)[i]); - } + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + form = SCHEME_VEC_ELS(linklet->bodies)[i]; + reset_clearing(vc); + if (!validate_expr(port, form, + stack, tls, + depth, delta, delta, + num_toplevels, linklet->num_lifts, NULL, + tl_state, tl_timestamp, + NULL, 0, 0, + vc, 1, 0, NULL, -1, _st_ht)) { + tl_timestamp++; + if (0) { + printf("increment to %d for %d %p\n", tl_timestamp, + SCHEME_TYPE(SCHEME_VEC_ELS(linklet->bodies)[i]), + SCHEME_VEC_ELS(linklet->bodies)[i]); } } - } else { - validate_expr(port, code, - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, 0, - NULL, 0, 0, - vc, 1, 0, NULL, -1, NULL); } } @@ -279,7 +238,7 @@ static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int skip_refs_check) { @@ -288,7 +247,7 @@ return validate_expr(port, expr, stack, tls, depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, skip_refs_check ? 1 : 0, 0, make_clearing_stack(), 0, 0, NULL, 1, NULL); @@ -297,7 +256,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -319,7 +278,7 @@ for (i = 1; i < size; i++) { validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, NULL, tl_timestamp, 1); } @@ -327,12 +286,12 @@ if (only_var) { int pos; pos = SCHEME_TOPLEVEL_POS(only_var); - if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (pos >= (num_toplevels - num_lifts)) { /* It's a lift. Check whether it needs to take reference arguments and/or install reference info. */ Scheme_Object *app_rator; Scheme_Lambda *data = NULL; - int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + int tp = pos - (num_toplevels - num_lifts); mzshort *a, *new_a = NULL; /* Make sure that no one has tried to register information. */ @@ -398,7 +357,7 @@ int is; is = validate_rator_wants_box(val, i, a[i + 1] == 2, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map); + tls, num_toplevels, num_lifts, tl_use_map); if ((is && (a[i + 1] == 1)) || (!is && (a[i + 1] == 2))) scheme_ill_formed_code(port); @@ -412,8 +371,8 @@ if (scheme_is_simple_make_struct_type(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, NULL, &stinfo, NULL, - NULL, NULL, (_st_ht ? *_st_ht : NULL), - NULL, 0, NULL, NULL, NULL, 5)) { + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, NULL, 5)) { /* This set of bindings is constant across invocations, but if `uses_super', we need to increment tl_timestamp for subtype-defining `struct' sequences. */ @@ -425,8 +384,8 @@ has_guard = 0; if (scheme_is_simple_make_struct_type_property(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, &has_guard, - NULL, NULL, (_st_ht ? *_st_ht : NULL), - NULL, 0, NULL, NULL, 5)) { + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, 5)) { is_struct_prop = 1; } else { is_struct_prop = 0; @@ -434,7 +393,7 @@ result = validate_expr(port, val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp + ((is_struct && stinfo.uses_super) ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, size-1, _st_ht); @@ -485,7 +444,7 @@ int ts = (tl_timestamp + (result ? 0 : 1)); if (tl_state) { int p = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]); - if (p < num_toplevels) { + if (p < (num_toplevels - num_lifts)) { int s = -tl_state[p]; int expected_flags = s & SCHEME_TOPLEVEL_FLAGS_MASK; int this_flags = flags; @@ -503,8 +462,9 @@ `(define x x)' with `x' claimed as constant. The `tl_timestamp++' before checking a closure body allows things like `(define x (lambda () x))'. */ - && ((s >> 2) <= ts))) + && ((s >> 2) <= ts))) { scheme_ill_formed_code(port); + } tl_state[p] = (ts << 2) | this_flags; } } @@ -516,7 +476,7 @@ static int set_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -528,11 +488,11 @@ int r1, r2; r1 = validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); r2 = validate_toplevel(sb->var, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, 0); @@ -542,28 +502,42 @@ static void ref_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, struct Validate_Clearing *vc, int tailpos, Scheme_Hash_Tree *procs) { - validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) - validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + tl_timestamp = tl_timestamp + 1; /* allows (define x (#%variable-reference x)) */ + + if (!SCHEME_FALSEP(SCHEME_PTR1_VAL(data))) + validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, 0); + + if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) { + /* must reference */ + int p; + data = SCHEME_PTR2_VAL(data); + if (!SAME_TYPE(scheme_toplevel_type, SCHEME_TYPE(data))) + scheme_ill_formed_code(port); + p = SCHEME_TOPLEVEL_POS(data); + if (p != 0) + scheme_ill_formed_code(port); + + validate_toplevel(data, port, stack, tls, depth, delta, + num_toplevels, num_lifts, tl_use_map, + tl_state, tl_timestamp, + 0); + } } static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -579,12 +553,12 @@ r1 = validate_expr(port, f, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); r2 = validate_expr(port, e, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, -1, _st_ht); @@ -594,7 +568,7 @@ static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -609,19 +583,19 @@ validate_expr(port, f1, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); validate_expr(port, f2, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -642,7 +616,7 @@ && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type)) scheme_ill_formed_code(port); validate_expr(port, e, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } @@ -662,7 +636,7 @@ static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -674,7 +648,7 @@ validate_boxenv(SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)), port, stack, depth, delta, letlimit); return validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results, _st_ht); } @@ -682,7 +656,7 @@ static int begin0_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -701,7 +675,7 @@ for (i = 0; i < seq->count; i++) { r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, i > 0, vc, 0, 0, procs, (i > 0) ? -1 : expected_results, _st_ht); @@ -711,92 +685,6 @@ return result; } -static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int for_stx) -{ - Resolve_Prefix *rp; - Scheme_Object *name, *val, *base_stack_depth, *dummy; - int sdepth; - - if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_begin_for_syntax_type : scheme_define_syntaxes_type)) - || (SCHEME_VEC_SIZE(data) < 4)) - scheme_ill_formed_code(port); - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1]; - base_stack_depth = SCHEME_VEC_ELS(data)[2]; - sdepth = SCHEME_INT_VAL(base_stack_depth); - - if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type) - || (sdepth < 0)) - scheme_ill_formed_code(port); - - dummy = SCHEME_VEC_ELS(data)[3]; - - if (!for_stx) { - int i, size; - size = SCHEME_VEC_SIZE(data); - for (i = 4; i < size; i++) { - name = SCHEME_VEC_ELS(data)[i]; - if (!SCHEME_SYMBOLP(name)) { - scheme_ill_formed_code(port); - } - } - } - - validate_toplevel(dummy, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - - if (!for_stx) { - scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, - NULL, NULL, 0); - } else { - val = SCHEME_VEC_ELS(data)[0]; - while (SCHEME_PAIRP(val)) { - scheme_validate_code(port, SCHEME_CAR(val), sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, - NULL, NULL, 0); - val = SCHEME_CDR(val); - } - if (!SCHEME_NULLP(val)) - scheme_ill_formed_code(port); - } -} - -static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, 0); -} - -static void begin_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp,1); -} - /*========================================================================*/ /* expressions */ /*========================================================================*/ @@ -825,7 +713,7 @@ r = validate_expr(port, expr, stack, tls, args[0], args[1], args[2], - args[3], args[4], args[5], tl_use_map, + args[3], args[5], tl_use_map, tl_state, args[10], app_rator, args[6], args[7], vc, args[8], args[9], procs, args[11], @@ -840,7 +728,7 @@ int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map) + int num_toplevels, int num_lifts, void *tl_use_map) { Scheme_Lambda *data = NULL; Scheme_Type ty; @@ -857,7 +745,7 @@ int p; p = SCHEME_TOPLEVEL_POS(app_rator); while (1) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (p >= (num_toplevels - num_lifts)) { /* It's a lift. Check that the lift is defined, and that it doesn't want reference arguments. */ mzshort *a; /* 0x1 => no ref args, @@ -866,7 +754,7 @@ ptr with 0 => another top-level */ int tp; - tp = (p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0))); + tp = (p - (num_toplevels - num_lifts)); if (tp >= num_lifts) return 0; @@ -942,7 +830,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, char *closure_stack, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int self_pos_in_closure, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht) @@ -1018,7 +906,7 @@ } validate_expr(port, data->body, new_stack, tls, sz, sz, base, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 1, 0, procs, -1, _st_ht); } @@ -1033,7 +921,7 @@ static void validate_lambda(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int self_pos, Scheme_Hash_Tree *procs, @@ -1138,7 +1026,7 @@ SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack; SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls; SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(num_toplevels); - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes); + SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(0); /* not used anymore */ SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts); SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure); SCHEME_VEC_ELS(vec)[7] = new_procs ? (Scheme_Object *)new_procs : scheme_false; @@ -1149,7 +1037,7 @@ SCHEME_CAR(data->body) = vec; } else scheme_validate_closure(port, expr, closure_stack, tls, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, self_pos_in_closure, new_procs, _st_ht); } @@ -1171,73 +1059,6 @@ } } -static void module_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Module *m; - int i, j, cnt, let_depth; - Resolve_Prefix *rp; - Scheme_Object *e; - - m = (Scheme_Module *)data; - - if (!SCHEME_MODNAMEP(m->modname)) - scheme_ill_formed_code(port); - - if (m->phaseless && m->prefix->num_stxes) - scheme_ill_formed_code(port); - - if (m->max_let_depth < 0) - scheme_ill_formed_code(port); - - validate_toplevel(m->dummy, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - - scheme_validate_code(port, m->bodies[0], m->max_let_depth, - m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, - NULL, m->prefix->toplevels, - (m->phaseless ? 2 : 1)); - - /* validate exp-time code */ - for (j = m->num_phases; j-- > 1; ) { - cnt = SCHEME_VEC_SIZE(m->bodies[j]); - for (i = 0; i < cnt; i++) { - if (m->phaseless) scheme_ill_formed_code(port); - - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - e = SCHEME_VEC_ELS(e)[1]; - - scheme_validate_code(port, e, let_depth, - rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, NULL, - 0); - } - } -} - -static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ -} - static void no_typed(int need_local_type, Mz_CPort *port) { if (need_local_type) scheme_ill_formed_code(port); @@ -1271,7 +1092,8 @@ v = scheme_hash_get(*_st_ht, scheme_make_integer(pos)); if (v) { int k = SCHEME_INT_VAL(v); - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_CONSTR) { + if (((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_CONSTR) + && (k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR)) { if (num_args == (k >> STRUCT_PROC_SHAPE_SHIFT)) return 1; } else if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) { @@ -1295,7 +1117,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, @@ -1330,7 +1152,7 @@ args[1] = letlimit; args[2] = delta; args[3] = num_toplevels; - args[4] = num_stxes; + args[4] = 0; /* not used anymore */ args[5] = num_lifts; args[6] = proc_with_refs_ok; args[7] = result_ignored; @@ -1360,7 +1182,7 @@ if (did_one) { if (app_rator) { if (validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, + tls, num_toplevels, num_lifts, tl_use_map)) scheme_ill_formed_code(port); app_rator = NULL; @@ -1383,31 +1205,29 @@ if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) || (stack[d] != VALID_TOPLEVELS) - || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0))) - || ((p >= num_toplevels) && (p < num_toplevels + num_stxes + (num_stxes ? 1 : 0)))) + || (p >= num_toplevels)) scheme_ill_formed_code(port); if (tl_use_map) { - int p2 = ((p < num_toplevels) - ? p - : (p - num_stxes)); - if (num_stxes && (p >= num_toplevels) && (p < (num_toplevels + num_stxes + 1))) - scheme_ill_formed_code(port); if ((uintptr_t)tl_use_map & 0x1) { - if (p2 > 31) + if (p > 31) scheme_ill_formed_code(port); - if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p2 + 1)))) + if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p + 1)))) scheme_ill_formed_code(port); } else { - if (p2 >= (*(int *)tl_use_map * 32)) + if (p >= (*(int *)tl_use_map * 32)) scheme_ill_formed_code(port); - if (!(((int *)tl_use_map)[1 + (p2 / 32)] & ((unsigned int)1 << (p2 & 31)))) + if (!(((int *)tl_use_map)[1 + (p / 32)] & ((unsigned int)1 << (p & 31)))) scheme_ill_formed_code(port); } } if ((flags > SCHEME_TOPLEVEL_UNKNOWN) && tl_state && (p < num_toplevels)) { - if (tl_state[p] <= 0) { + if (p < SCHEME_LINKLET_PREFIX_PREFIX) { + /* instance-access toplevel available? */ + if (!tl_state[p]) + scheme_ill_formed_code(port); + } else if (tl_state[p] <= 0) { /* record expectation */ int s = -tl_state[p]; int new_flags; @@ -1429,12 +1249,12 @@ if ((proc_with_refs_ok != 1) && !argument_to_arity_error(app_rator, proc_with_refs_ok)) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (p >= (num_toplevels - num_lifts)) { /* It's a lift. Check that the lift is defined, and that it doesn't want reference arguments. */ int tp; mzshort *a; - tp = p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + tp = p - (num_toplevels - num_lifts); a = tls[tp]; if (a) { if (a == (mzshort *)0x1) { @@ -1490,7 +1310,7 @@ } else if ((proc_with_refs_ok >= 2) && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) && validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1, - tls, num_toplevels, num_stxes, num_lifts, + tls, num_toplevels, num_lifts, tl_use_map)) { /* It's ok - the function wants us to pass it a box, and we did. */ @@ -1572,7 +1392,7 @@ for (i = 0; i < n; i++) { r = validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(result, r); @@ -1600,12 +1420,12 @@ stack[delta] = VALID_NOT; r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 2, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1641,17 +1461,17 @@ stack[delta+1] = VALID_NOT; r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 2, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 3, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1674,7 +1494,6 @@ } break; case scheme_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)expr; int cnt; @@ -1687,7 +1506,7 @@ for (i = 0; i < cnt - 1; i++) { r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 1, vc, 0, 0, procs, -1, _st_ht); result = validate_join_seq(result, r); @@ -1704,7 +1523,7 @@ b = (Scheme_Branch_Rec *)expr; r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1716,7 +1535,7 @@ vc_pos = vc->stackpos; vc_ncpos = vc->ncstackpos; r = validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, need_local_type, procs, expected_results, _st_ht); @@ -1759,12 +1578,12 @@ int r; r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(result, r); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(result, r); @@ -1773,44 +1592,11 @@ goto top; } break; - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)expr; - int c = qs->depth; - int i = qs->position; - int p = qs->midpoint; - int d = c + delta; - - no_typed(need_local_type, port); - - if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) - || (stack[d] != VALID_TOPLEVELS) - || (p != num_toplevels) - || (i >= num_stxes)) - scheme_ill_formed_code(port); - - if (tl_use_map) { - if ((uintptr_t)tl_use_map & 0x1) { - if (p > 31) - scheme_ill_formed_code(port); - if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p + 1)))) - scheme_ill_formed_code(port); - } else { - if (p >= (*(int *)tl_use_map * 32)) - scheme_ill_formed_code(port); - if (!(((int *)tl_use_map)[1 + (p / 32)] & ((unsigned int)1 << (p & 31)))) - scheme_ill_formed_code(port); - } - } - - result = validate_join_const(result, expected_results); - } - break; case scheme_lambda_type: { no_typed(need_local_type, port); validate_lambda(port, expr, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app_rator, proc_with_refs_ok, -1, procs, _st_ht); @@ -1823,7 +1609,7 @@ int q, p, c, i, r; r = validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, lv->count, _st_ht); result = validate_join_seq(r, result); @@ -1920,7 +1706,7 @@ for (i = 0; i < c; i++) { validate_lambda(port, l->procs[i], stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, i, procs, _st_ht); } @@ -1940,7 +1726,7 @@ stack[delta] = VALID_UNINIT; r = validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, SCHEME_LET_ONE_TYPE(lo), procs, 1, _st_ht); @@ -1968,30 +1754,16 @@ no_typed(need_local_type, port); result = validate_join_seq(result, define_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht)); break; - case scheme_define_syntaxes_type: - no_typed(need_local_type, port); - define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; - case scheme_begin_for_syntax_type: - no_typed(need_local_type, port); - begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; case scheme_set_bang_type: no_typed(need_local_type, port); result = validate_join_seq(result, set_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht)); break; @@ -1999,7 +1771,7 @@ no_typed(need_local_type, port); result = validate_join_seq(result, bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht, expected_results)); break; @@ -2007,21 +1779,14 @@ no_typed(need_local_type, port); result = validate_join_seq(result, begin0_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht, expected_results)); break; - case scheme_require_form_type: - no_typed(need_local_type, port); - top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; case scheme_varref_form_type: no_typed(need_local_type, port); ref_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs); result = validate_join_const(result, expected_results); @@ -2029,7 +1794,7 @@ case scheme_apply_values_type: no_typed(need_local_type, port); apply_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join(0, result); @@ -2042,14 +1807,14 @@ no_typed(need_local_type, port); r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(r, result); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); @@ -2067,23 +1832,15 @@ case scheme_case_lambda_sequence_type: no_typed(need_local_type, port); case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join_const(result, expected_results); break; - case scheme_module_type: - no_typed(need_local_type, port); - module_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - result = validate_join(0, result); - break; case scheme_inline_variant_type: no_typed(need_local_type, port); inline_variant_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join_const(result, expected_results); @@ -2119,7 +1876,7 @@ seq = (Scheme_Case_Lambda *)expr; for (i = 0; i < seq->count; i++) { validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } @@ -2139,7 +1896,7 @@ if (app_rator) if (validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map)) + tls, num_toplevels, num_lifts, tl_use_map)) scheme_ill_formed_code(port); if (vc_merge) { diff -Nru racket-6.12+ppa1/src/racket/src/vector.c racket-7.0+ppa1/src/racket/src/vector.c --- racket-6.12+ppa1/src/racket/src/vector.c 2018-01-12 21:54:34.000000000 +0000 +++ racket-7.0+ppa1/src/racket/src/vector.c 2018-07-27 22:12:02.000000000 +0000 @@ -31,20 +31,35 @@ READ_ONLY Scheme_Object *scheme_vector_p_proc; READ_ONLY Scheme_Object *scheme_make_vector_proc; READ_ONLY Scheme_Object *scheme_vector_immutable_proc; +READ_ONLY Scheme_Object *scheme_vector_length_proc; +READ_ONLY Scheme_Object *scheme_vector_star_length_proc; READ_ONLY Scheme_Object *scheme_vector_ref_proc; +READ_ONLY Scheme_Object *scheme_vector_star_ref_proc; READ_ONLY Scheme_Object *scheme_vector_set_proc; +READ_ONLY Scheme_Object *scheme_vector_star_set_proc; +READ_ONLY Scheme_Object *scheme_vector_cas_proc; READ_ONLY Scheme_Object *scheme_list_to_vector_proc; READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_string_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_string_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_bytes_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_bytes_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc; READ_ONLY Scheme_Object *scheme_unsafe_struct_star_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_struct_set_proc; +READ_ONLY Scheme_Object *scheme_unsafe_struct_star_set_proc; /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *vector (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_length (int argc, Scheme_Object *argv[]); +static Scheme_Object *vector_star_length (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_list (int argc, Scheme_Object *argv[]); static Scheme_Object *list_to_vector (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_fill (int argc, Scheme_Object *argv[]); @@ -78,22 +93,24 @@ static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[]); void -scheme_init_vector (Scheme_Env *env) +scheme_init_vector (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_vector_p_proc); p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("vector?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("vector?", p, env); scheme_vector_p_proc = p; REGISTER_SO(scheme_make_vector_proc); p = scheme_make_immed_prim(scheme_checked_make_vector, "make-vector", 1, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-vector", p, env); + | SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("make-vector", p, env); scheme_make_vector_proc = p; REGISTER_SO(scheme_vector_proc); @@ -103,7 +120,7 @@ | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("vector", p, env); + scheme_addto_prim_instance("vector", p, env); REGISTER_SO(scheme_vector_immutable_proc); p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1); @@ -112,89 +129,120 @@ | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("vector-immutable", p, env); + scheme_addto_prim_instance("vector-immutable", p, env); + + REGISTER_SO(scheme_vector_length_proc); p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("vector-length", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-length", p, env); + scheme_vector_length_proc = p; + + REGISTER_SO(scheme_vector_star_length_proc); + p = scheme_make_folding_prim(vector_star_length, "vector*-length", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-length", p, env); + scheme_vector_star_length_proc = p; REGISTER_SO(scheme_vector_ref_proc); p = scheme_make_noncm_prim(scheme_checked_vector_ref, "vector-ref", 2, 2); scheme_vector_ref_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("vector-ref", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-ref", p, env); + + REGISTER_SO(scheme_vector_star_ref_proc); + p = scheme_make_noncm_prim(scheme_checked_vector_star_ref, + "vector*-ref", + 2, 2); + scheme_vector_star_ref_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-ref", p, env); REGISTER_SO(scheme_vector_set_proc); p = scheme_make_noncm_prim(scheme_checked_vector_set, "vector-set!", 3, 3); scheme_vector_set_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("vector-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-set!", p, env); + + REGISTER_SO(scheme_vector_star_set_proc); + p = scheme_make_noncm_prim(scheme_checked_vector_star_set, + "vector*-set!", + 3, 3); + scheme_vector_star_set_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-set!", p, env); + REGISTER_SO(scheme_vector_cas_proc); p = scheme_make_noncm_prim(scheme_checked_vector_cas, "vector-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("vector-cas!", p, env); + scheme_addto_prim_instance("vector-cas!", p, env); + scheme_vector_cas_proc = p; - scheme_add_global_constant("vector->list", - scheme_make_immed_prim(vector_to_list, - "vector->list", - 1, 1), - env); + p = scheme_make_immed_prim(vector_to_list, "vector->list", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->list", p, env); REGISTER_SO(scheme_list_to_vector_proc); - p = scheme_make_immed_prim(list_to_vector, - "list->vector", - 1, 1); + p = scheme_make_immed_prim(list_to_vector, "list->vector", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); scheme_list_to_vector_proc = p; - scheme_add_global_constant("list->vector", p, env); + scheme_addto_prim_instance("list->vector", p, env); - scheme_add_global_constant("vector-fill!", + scheme_addto_prim_instance("vector-fill!", scheme_make_immed_prim(vector_fill, "vector-fill!", 2, 2), env); - scheme_add_global_constant("vector-copy!", + scheme_addto_prim_instance("vector-copy!", scheme_make_immed_prim(vector_copy_bang, "vector-copy!", 3, 5), env); - scheme_add_global_constant("vector->immutable-vector", - scheme_make_immed_prim(vector_to_immutable, - "vector->immutable-vector", - 1, 1), - env); - scheme_add_global_constant("vector->values", - scheme_make_prim_w_arity2(vector_to_values, - "vector->values", - 1, 3, - 0, -1), - env); - scheme_add_global_constant("chaperone-vector", + p = scheme_make_immed_prim(vector_to_immutable, "vector->immutable-vector", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->immutable-vector", p, env); + + p = scheme_make_prim_w_arity2(vector_to_values, "vector->values", + 1, 3, + 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->values", p, env); + + scheme_addto_prim_instance("chaperone-vector", scheme_make_prim_w_arity(chaperone_vector, "chaperone-vector", 3, -1), env); - scheme_add_global_constant("chaperone-vector*", + scheme_addto_prim_instance("chaperone-vector*", scheme_make_prim_w_arity(chaperone_vector_star, "chaperone-vector*", 3, -1), env); - scheme_add_global_constant("impersonate-vector", + scheme_addto_prim_instance("impersonate-vector", scheme_make_prim_w_arity(impersonate_vector, "impersonate-vector", 3, -1), env); - scheme_add_global_constant("impersonate-vector*", + scheme_addto_prim_instance("impersonate-vector*", scheme_make_prim_w_arity(impersonate_vector_star, "impersonate-vector*", 3, -1), @@ -202,7 +250,7 @@ } void -scheme_init_unsafe_vector (Scheme_Env *env) +scheme_init_unsafe_vector (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -211,38 +259,44 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-vector-length", p, env); + scheme_addto_prim_instance("unsafe-vector-length", p, env); scheme_unsafe_vector_length_proc = p; + REGISTER_SO(scheme_unsafe_vector_star_length_proc); p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-vector*-length", p, env); + scheme_addto_prim_instance("unsafe-vector*-length", p, env); + scheme_unsafe_vector_star_length_proc = p; p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-vector-ref", p, env); + scheme_addto_prim_instance("unsafe-vector-ref", p, env); + REGISTER_SO(scheme_unsafe_vector_star_ref_proc); p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-vector*-ref", p, env); + scheme_addto_prim_instance("unsafe-vector*-ref", p, env); + scheme_unsafe_vector_star_ref_proc = p; p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector-set!", p, env); + scheme_addto_prim_instance("unsafe-vector-set!", p, env); + REGISTER_SO(scheme_unsafe_vector_star_set_proc); p = scheme_make_immed_prim(unsafe_vector_star_set, "unsafe-vector*-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector*-set!", p, env); + scheme_addto_prim_instance("unsafe-vector*-set!", p, env); + scheme_unsafe_vector_star_set_proc = p; p = scheme_make_immed_prim(unsafe_vector_star_cas, "unsafe-vector*-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector*-cas!", p, env); + scheme_addto_prim_instance("unsafe-vector*-cas!", p, env); REGISTER_SO(scheme_unsafe_struct_ref_proc); p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2); @@ -250,7 +304,7 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-struct-ref", p, env); + scheme_addto_prim_instance("unsafe-struct-ref", p, env); REGISTER_SO(scheme_unsafe_struct_ref_proc); p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2); @@ -258,64 +312,76 @@ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-struct*-ref", p, env); + scheme_addto_prim_instance("unsafe-struct*-ref", p, env); + REGISTER_SO(scheme_unsafe_struct_set_proc); p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3); + scheme_unsafe_struct_set_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct-set!", p, env); + scheme_addto_prim_instance("unsafe-struct-set!", p, env); + REGISTER_SO(scheme_unsafe_struct_star_set_proc); p = scheme_make_immed_prim(unsafe_struct_star_set, "unsafe-struct*-set!", 3, 3); + scheme_unsafe_struct_star_set_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct*-set!", p, env); + scheme_addto_prim_instance("unsafe-struct*-set!", p, env); p = scheme_make_immed_prim(unsafe_struct_star_cas, "unsafe-struct*-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct*-cas!", p, env); + scheme_addto_prim_instance("unsafe-struct*-cas!", p, env); REGISTER_SO(scheme_unsafe_string_length_proc); p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-string-length", p, env); + scheme_addto_prim_instance("unsafe-string-length", p, env); scheme_unsafe_string_length_proc = p; + REGISTER_SO(scheme_unsafe_string_ref_proc); p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-string-ref", p, env); + scheme_addto_prim_instance("unsafe-string-ref", p, env); + scheme_unsafe_string_ref_proc = p; + REGISTER_SO(scheme_unsafe_string_set_proc); p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-string-set!", p, env); + scheme_addto_prim_instance("unsafe-string-set!", p, env); + scheme_unsafe_string_set_proc = p; REGISTER_SO(scheme_unsafe_byte_string_length_proc); p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-bytes-length", p, env); + scheme_addto_prim_instance("unsafe-bytes-length", p, env); scheme_unsafe_byte_string_length_proc = p; + REGISTER_SO(scheme_unsafe_bytes_ref_proc); p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-bytes-ref", p, env); + scheme_addto_prim_instance("unsafe-bytes-ref", p, env); + scheme_unsafe_bytes_ref_proc = p; + REGISTER_SO(scheme_unsafe_bytes_set_proc); p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-bytes-set!", p, env); + scheme_addto_prim_instance("unsafe-bytes-set!", p, env); + scheme_unsafe_bytes_set_proc = p; - scheme_add_global_constant("unsafe-impersonate-vector", + scheme_addto_prim_instance("unsafe-impersonate-vector", scheme_make_prim_w_arity(unsafe_impersonate_vector, "unsafe-impersonate-vector", 2, -1), env); - scheme_add_global_constant("unsafe-chaperone-vector", + scheme_addto_prim_instance("unsafe-chaperone-vector", scheme_make_prim_w_arity(unsafe_chaperone_vector, "unsafe-chaperone-vector", 2, -1), @@ -439,6 +505,24 @@ return vector_length(1, a); } +static Scheme_Object * +vector_star_length (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *vec = argv[0]; + + if (!SCHEME_VECTORP(vec)) + scheme_wrong_contract("vector*-length", "(and/c vector? (not/c impersonator?))", 0, argc, argv); + + return scheme_make_integer(SCHEME_VEC_SIZE(vec)); +} + +Scheme_Object *scheme_vector_star_length(Scheme_Object *v) +{ + Scheme_Object *a[1]; + a[0] = v; + return vector_star_length(1, a); +} + void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *which, Scheme_Object *vec, intptr_t bottom, intptr_t len) { @@ -623,6 +707,26 @@ } Scheme_Object * +scheme_checked_vector_star_ref (int argc, Scheme_Object *argv[]) +{ + intptr_t i, len; + Scheme_Object *vec; + + vec = argv[0]; + if (!SCHEME_VECTORP(vec)) + scheme_wrong_contract("vector*-ref", "(and/c vector? (not impersonator?))", 0, argc, argv); + + len = SCHEME_VEC_SIZE(vec); + + i = scheme_extract_index("vector*-ref", 1, argc, argv, len, 0); + + if (i >= len) + return bad_index("vector*-ref", "", argv[1], argv[0], 0); + + return (SCHEME_VEC_ELS(vec))[i]; +} + +Scheme_Object * scheme_checked_vector_set(int argc, Scheme_Object *argv[]) { Scheme_Object *vec = argv[0]; @@ -650,6 +754,27 @@ } Scheme_Object * +scheme_checked_vector_star_set(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *vec = argv[0]; + intptr_t i, len; + + if (!SCHEME_MUTABLE_VECTORP(vec)) + scheme_wrong_contract("vector*-set!", "(and/c vector? (not/c immutable?) (not/c impersonator?))", 0, argc, argv); + + len = SCHEME_VEC_SIZE(vec); + + i = scheme_extract_index("vector*-set!", 1, argc, argv, len, 0); + + if (i >= len) + return bad_index("vector*-set!", "", argv[1], argv[0], 0); + + SCHEME_VEC_ELS(vec)[i] = argv[2]; + + return scheme_void; +} + +Scheme_Object * scheme_checked_vector_cas(int argc, Scheme_Object *argv[]) { Scheme_Object *vec = argv[0]; @@ -825,8 +950,19 @@ if (slow) { int i, o; - for (i = istart, o = ostart; i < ifinish; i++, o++) { - scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i)); + if ((s2 == s1) + && (((istart <= ostart) && (ifinish > ostart)) + || ((ostart <= istart) && (ofinish > istart))) + && (istart < ostart)) { + /* ranges overlap and shifting up: copy from end */ + for (i = ifinish, o = ofinish; i-- > istart; ) { + o--; + scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i)); + } + } else { + for (i = istart, o = ostart; i < ifinish; i++, o++) { + scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i)); + } } } else { memmove(SCHEME_VEC_ELS(s1) + ostart, diff -Nru racket-6.12+ppa1/src/racket/win_tls.inc racket-7.0+ppa1/src/racket/win_tls.inc --- racket-6.12+ppa1/src/racket/win_tls.inc 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/racket/win_tls.inc 2018-07-27 22:12:02.000000000 +0000 @@ -35,5 +35,18 @@ } #else -static void register_win_tls() {} + +/* For emebdded-DLL mode, make sure there's a thread-local space to + be taken ovver by the Racket DLL */ +# ifdef USE_THREAD_LOCAL + +static __declspec(thread) Thread_Local_Variables tls_space; +static void register_win_tls() { + scheme_register_tls_space(&tls_space, 0); +} + +# else +static void register_win_tls() { } +# endif + #endif diff -Nru racket-6.12+ppa1/src/README racket-7.0+ppa1/src/README --- racket-6.12+ppa1/src/README 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/README 2018-07-27 22:12:02.000000000 +0000 @@ -11,7 +11,8 @@ Per-platform instructions are below. Please report bugs via one of the following: - - DrRacket's "submit bug report" menu (preferred) + - https://github.com/racket/racket/issues (preferred) + - DrRacket's "submit bug report" menu - http://bugs.racket-lang.org/ - the mailing list (users@racket-lang.org) (last resort) @@ -19,6 +20,17 @@ racket@racket-lang.org ======================================================================== + Traditional Racket versus Racket-on-Chez +======================================================================== + +To build the experimental variant of Racket that runs on Chez Scheme +see "cs/c/README.txt". + +The rest of the instructions below are about building the traditional +Racket implementation, but a general "Implementation Organization" +note at the end applies to both variants. + +======================================================================== Compiling for Windows ======================================================================== @@ -26,15 +38,15 @@ "racket\src\worksp\README". To compile with MinGW tools, follow the Unix instructions below; do not -use `--enable-shared', because DLLs will be generated automatically. +use `--enable-shared`, because DLLs will be generated automatically. The result is a Windows-style build. If you are using a variant of MinGW without "libdelayimp.a", get the implementation of "delayimp.c" from MinGW-w64 and compile it to "libdelayimp.a". To compile with Cygwin tools, follow the Unix instructions below. The result is a Unix-style build, not a Windows-style build (e.g., -Racket's `system-type' procedure returns 'unix, not 'windows, and -`racket/gui' uses Gtk instead of Win32). +Racket's `system-type` procedure returns 'unix, not 'windows, and +`racket/gui` uses Gtk instead of Win32). ======================================================================== Compiling for Mac OS @@ -49,37 +61,37 @@ but note the following: * The Racket build creates a framework, "Racket.framework", which is - installed into "racket/lib". This framework is used by the `racket' + installed into "racket/lib". This framework is used by the `racket` executable that goes into "racket/bin". * The GRacket build creates a GUI-executable variant of the Racket executable. The GRacket build process also downloads (from github) pre-built libraries for Cairo, Pango, etc. - * The `--enable-shared' flag for `configure' must not be used, because + * The `--enable-shared` flag for `configure` must not be used, because builds create and use frameworks by default. Furthermore, - `--disable-shared' is not supported. (Unless you use - `--enable-xonx'...) + `--disable-shared` is not supported. (Unless you use + `--enable-xonx`...) - * To build an X11- and Gtk-based GRacket, run `configure' with the - `--enable-xonx' flag. Frameworks are not used for such builds, so - `--enable-shared' is allowed. The `--enable-xonx' flag also affects - the Racket build, so that `system-type' reports 'unix. Pre-built + * To build an X11- and Gtk-based GRacket, run `configure` with the + `--enable-xonx` flag. Frameworks are not used for such builds, so + `--enable-shared` is allowed. The `--enable-xonx` flag also affects + the Racket build, so that `system-type` reports 'unix. Pre-built libraries are not downloaded in this mode; you must have Cairo, Pango, and GTk installed. - * To use `--prefix' without `--enable-xonx', you must also supply - `--enable-macprefix'. BEWARE! The directory structure for a + * To use `--prefix` without `--enable-xonx`, you must also supply + `--enable-macprefix`. BEWARE! The directory structure for a non-xonx build does not fit a typical Unix directory structure. For example, frameworks are written directly to a "lib" subdirectory, and executables like "GRacket.app" are written directly to the prefix - directory. (Requiring `--enable-macprefix' with `--prefix' for a + directory. (Requiring `--enable-macprefix` with `--prefix` for a non-xonx build helps prevent accidental installation of a Mac-style directory structure on top of an existing Unix-style directory structure.) * Under Mac OS 10.6 and later, to build Racket in 32-bit mode, - use `--disable-mac64'. + use `--disable-mac64`. ======================================================================== Compiling for supported Unix variants (including Linux) or Cygwin/MinGW @@ -87,7 +99,7 @@ Quick instructions: - From this directory (where the `configure' file is), run the following + From this directory (where the `configure` file is), run the following commands: mkdir build @@ -96,12 +108,12 @@ make make install - This will create an in-place installation of Racket and store the - results of C compilation in a separate "build" subdirectory, which - is useful if you need to update your sources, delete the build, and - start from scratch. + Those commands will create an in-place installation of Racket and + store the results of C compilation in a separate "build" + subdirectory, which is useful if you need to update your sources, + delete the build, and start from scratch. - You can also run the typical `./configure && make && make install' if + You can also run the typical `./configure && make && make install` if you don't anticipate updating/rebuilding, but it will be harder to restart from scratch should you need to. @@ -111,31 +123,31 @@ remove it (unless you are using an "in-place" build from a repository as described below). - To run `racket/draw' and `racket/gui' programs, you will need - Cairo, Pango, and GTk install. These libraries are not + To run `racket/draw` and `racket/gui` programs, you will need + Cairo, Pango, and GTk installed. These libraries are not distributed with Racket, and they are not needed for compilation, - except for building documentation that uses `racket/draw'. More + except for building documentation that uses `racket/draw`. More info about required libs is available at http://docs.racket-lang.org/draw/libs.html and http://docs.racket-lang.org/gui/libs.html. - The content of the "foreign" subdirectory may require GNU `make' + The content of the "foreign" subdirectory may require GNU `make` if no installed "libffi" is detected. If the build fails with - another variant of `make', please try using GNU `make'. + another variant of `make`, please try using GNU `make`. 1. Select (or create) a build directory. It's better to run the build in a directory other than the one - containing `configure', especially if you're getting sources via + containing `configure`, especially if you're getting sources via git. A common way to start a git-based build is: cd [here] mkdir build cd build - where "[here]" is the directory containing this `README' file and - the `configure' script. The git repository is configured to support - this convention by ignoring `build' in this directory. + where "[here]" is the directory containing this `README` file and + the `configure` script. The git repository is configured to support + this convention by ignoring `build` in this directory. A separate build directory is better in case the Makefile organization changes, or in case the Makefiles lack some @@ -143,40 +155,40 @@ you can just delete and re-create "build" without mangling your source tree. - 2. From your build directory, run the script `configure' (which is in + 2. From your build directory, run the script `configure` (which is in the same directory as this README), with optional command-line - arguments `--prefix=TARGETDIR' or `--enable-shared' (or both). + arguments `--prefix=TARGETDIR` or `--enable-shared` (or both). For example, if you want to install into "/usr/local/racket" using dynamic libraries, then run: [here]configure --prefix=/usr/local/racket --enable-shared - Again, "[here]" is the directory path containing the `configure' + Again, "[here]" is the directory path containing the `configure` script. If you follow the convention of running from a "build" subdirectory, "[here]" is just "../". If you build from the current directory, "[here]" is possibly unnecessary, or possibly just "./", depending on your shell and PATH setting. - If the `--prefix' flag is omitted, the binaries are built for an + If the `--prefix` flag is omitted, the binaries are built for an in-place installation (i.e., the parent of the directory containing - this README will be used directly). Unless `--enable-shared' is + this README will be used directly). Unless `--enable-shared` is used, the "racket" directory can be moved later; most system - administrators would recommend that you use `--enable-shared', but + administrators would recommend that you use `--enable-shared`, but the Racket developers distribute binaries built without - `--enable-shared'. + `--enable-shared`. - The `configure' script generates the makefiles for building Racket - and/or GRacket. The current directory at the time `configure' is + The `configure` script generates the makefiles for building Racket + and/or GRacket. The current directory at the time `configure` is run will be used as working space for building the executables - (independent of `--prefix'). This build directory does not have to + (independent of `--prefix`). This build directory does not have to be in the source tree, even for an in-place build. It's ok to run - `configure' from its own directory (as in the first example above), + `configure` from its own directory (as in the first example above), but it's better to pick a separate build directory that is otherwise empty (as in the second example). - The `configure' script accepts many other flags that adjust the - build process. Run `configure --help' for more information. In + The `configure` script accepts many other flags that adjust the + build process. Run `configure --help` for more information. In addition, a specific compiler can be selected through environment variables. For example, to select the SGI compilers for Irix instead of gcc, run configure as @@ -188,89 +200,91 @@ which includes C compilation, and the Racket build normally uses the C pre-processor directly for some parts of the build. - If you re-run `configure' after running `make', then products of the - `make' may be incorrect due to changes in the compiler command line. - To be safe, run `make clean' each time after running `configure'. - To be even safer, run `configure' in a fresh build directory every + If you re-run `configure` after running `make`, then products of the + `make` may be incorrect due to changes in the compiler command line. + To be safe, run `make clean' each time after running `configure`. + To be even safer, run `configure` in a fresh build directory every time. When building for multiple platforms or configurations out of the - same source directory, beware of cached `configure' information in + same source directory, beware of cached `configure` information in "config.cache". Avoid this problem entirely by using a separate build directory (but the same source) for each platform or configuration. - 3. Run `make'. [As noted in step 0, this must be GNU `make'.] + 3. Run `make`. [As noted in step 0, this might need to be GNU `make`.] - With Cygwin, you may need to use `make --unix'. + With Cygwin, you may need to use `make --unix`. Binaries and libraries are placed in subdirectories of the build - directory. For example, the `racket3m' binary appears in the + directory. For example, the `racket3m` binary appears in the "racket" directory. - 4. Run `make install'. + 4. Run `make install`. This step copies binaries and libraries into place within the target installation. For example, the "racket" binary is copied into the "bin" directory for an in-place build, or into the executable - directory for a --prefix build. + directory for a `--prefix` build. - For a `--prefix' build, this step also creates a "config.rkt" module - in a "config" collection, so that various Racket tools and libraries + For a `--prefix` build, this step also creates a "config.rktd" module + in an "etc" directory, so that various Racket tools and libraries can find the installation directories. At this stage, in case you are packaging an installation instead of installing directly, you can redirect the installation by setting the "DESTDIR" environment variable to an absolute path for the packaging area. For example, - `make DESTDIR=/tmp/racket-build install' places the installation + `make DESTDIR=/tmp/racket-build install` places the installation into "/tmp/racket-build" instead of the location originally - specified with `--prefix'. The resulting installation will not + specified with `--prefix`. The resulting installation will not work, however, until it is moved to the location originally - specified with `--prefix'. + specified with `--prefix`. - Finally, the `make install' step compiles ".zo" bytecode files for - installed Racket source, generates launcher programs like - DrRacket, and builds documentation. Use `make plain-install' to - install without compiling ".zo" files, creating launchers, or - building documentation. + Finally, the `make install` step compiles ".zo" bytecode files for + installed Racket source, generates launcher programs like DrRacket + (if it's already installed as a package), and builds documentation + (again, if installed). Use `make plain-install` to install without + compiling ".zo" files, creating launchers, or building + documentation. If the installation fails because the target directory cannot be created, or because the target directory is not the one you want, - then you can try repeating step 4 after running `configure' again - with a new `--prefix' value. That is, sometimes it is not necessary + then you can try repeating step 4 after running `configure` again + with a new `--prefix` value. That is, sometimes it is not necessary to repeat step 3 (so try it and find out). On other platforms and configurations, it is necessary to start with a clean build - directory when changing the `--prefix' value, because the path gets + directory when changing the `--prefix` value, because the path gets wired into shared objects. If you build frequently from the git-based sources, beware that you may accumulate user- and version-specific information in your "add-ons" directory, which you can most easily find by evaluating (find-system-path 'addon-dir) - in Racket. In addition, if you configure with `--enabled-shared', + in Racket. In addition, if you configure with `--enabled-shared`, you may accumulate many unused versions of the dynamic libraries in your installation target. -After an "in-place" install without git, the "racket/src" directory is -no longer needed, and it can be safely deleted. Build information is -recorded in a "buildinfo" file in the installation. +After an "in-place" install from a source distribution, the +"racket/src" directory is no longer needed, and it can be safely +deleted. Build information is recorded in a "buildinfo" file in the +installation. -For a build without `--prefix' (or with `--enable-origtree') and without -`--enable-shared', you can safely move the install tree, because all +For a build without `--prefix` (or with `--enable-origtree`) and without +`--enable-shared`, you can safely move the install tree, because all file references within the installation are relative. ======================================================================== Cross-compiling ======================================================================== -Cross-compilation requires at least two flags to `configure': +Cross-compilation requires at least two flags to `configure`: - * `--host=OS', where OS is something like `i386-gnu-linux' to + * `--host=OS`, where OS is something like `i386-gnu-linux` to indicate the target platform. - The `configure' script uses OS to find suitable compilation tools, - such as `OS-gcc' and `OS-strip'. + The `configure` script uses OS to find suitable compilation tools, + such as `OS-gcc` and `OS-strip`. - * `--enable-racket=RACKET', where RACKET is a path to a Racket + * `--enable-racket=RACKET`, where RACKET is a path to a Racket executable that runs on the build platform; the executable must be the same version of Racket as being built for the target platform. @@ -282,11 +296,16 @@ will run `configure` again (with no arguments) in a "local" subdirectory to create a build for the current platform. -Some less commonly needed `configure' flags: +Some less commonly needed `configure` flags: - * `--enable-stackup', if the target platform's stack grows up. + * `--enable-stackup`, if the target platform`s stack grows up. - * `--enable-bigendian', if target platform is big-endian. + * `--enable-bigendian`, if target platform is big-endian. + + * `--enable-cify` or `--disable-cify` if the JIT availablity on the + target platform is different than the build platform; use + `--enable-cify` if the JIT is not abailable on the target + platform. ======================================================================== Cross-compiling for Android @@ -304,7 +323,7 @@ [ndk]/toolchains/arm-linux-androideabi-[comp]/prebuilt/[platform]/bin -is in your PATH (so that a suitable `gcc', `ar', etc., are found) for +is in your PATH (so that a suitable `gcc`, `ar`, etc., are found) for the [comp] of your choice and the [platform] used to compile. ======================================================================== @@ -335,22 +354,22 @@ CGC versus 3m ======================================================================== -Racket and GRacket have two variants: CGC and 3m. The CGC variant is -older, and it cooperates more easily with extensions written in C. The -3m variant is the default: it is more robust and usually provides better -overall performance. +Traditional Racket and GRacket have two variants: CGC and 3m. The CGC +variant is older, and it cooperates more easily with extensions +written in C. The 3m variant is the default: it is more robust and +usually provides better overall performance. The default build mode creates 3m binaries only (except for a CGC binary that is used to build the 3m binary). To create CGC binaries -in addition, run `make cgc' in addition to `make', or run `make both'. -To install both variants, use `make install-both' instead of just -`make install'. Alternately, use just `make cgc' and `make -install-cgc' to build and install just the CGC variants. +in addition, run `make cgc` in addition to `make`, or run `make both`. +To install both variants, use `make install-both` instead of just +`make install`. Alternately, use just `make cgc` and `make +install-cgc` to build and install just the CGC variants. CGC variants are installed with a "cgc" suffix. To swap the default -build and install mode, supply `--enable-cgcdefault' to `configure'. In -that case, CGC variants are built by default, `make 3m' creates 3m -binaries, and `make install-both' installs CGC variants without a suffix +build and install mode, supply `--enable-cgcdefault` to `configure`. In +that case, CGC variants are built by default, `make 3m` creates 3m +binaries, and `make install-both` installs CGC variants without a suffix and 3m variants with a "3m" suffix. ======================================================================== @@ -370,7 +389,7 @@ overall list must be less than 1024 bytes long. As an alternative to editing an executable directly, the -`create-embedding-executable' procedure from `compiler/embed' can be +`create-embedding-executable` procedure from `compiler/embed` can be used to change the embedded path. For example, the following program clones the Racket executable to "/tmp/mz" and changes the embedded path in the clone to "/tmp/collects": @@ -378,7 +397,7 @@ (require compiler/embed) (create-embedding-executable "/tmp/mz" #:collects-path "/tmp/collects") -Similarly, `raco exe' mode accepts a `--collects' flag to set the +Similarly, `raco exe` mode accepts a `--collects` flag to set the collection path in the generated executable. Under Windows, executables also embed a path to DLLs. For more @@ -425,7 +444,7 @@ when the x87 floating-point processor needs to be configured for double-precision mode, when JIT can use SSE2 instructions, and when extflonums can be supported because both the JIT and C code use SSE2 -for double-precision floating-point while `long double' is available +for double-precision floating-point while `long double` is available for extflonums. In particular, "scheme.h" looks for __SSE2_MATH__ to indicate that gcc @@ -435,12 +454,12 @@ The Windows build using MSVC enables extflonum support through a MinGW-compiled "longdouble.dll", since MSVC does not support `long -double' as extended-precision floating point. +double` as extended-precision floating point. Configuration Options --------------------- -Although `configure' flags control most options, some configurations +Although `configure` flags control most options, some configurations options can be modified by setting flags in "racket/sconfig.h". Some CPP flags control default settings in "racket/sconfig.h": @@ -451,12 +470,101 @@ Racket thread scheduling. * C_COMPILER_USES_SSE - declares that the C compiler is using SSE2 - instructions to implement `double' floating-point operations. + instructions to implement `double` floating-point operations. Modifying Racket ---------------- If you modify Racket and change any primitive syntax or the collection -of built-in identifiers, be sure to turn off USE_COMPILED_STARTUP in -"schminc.h"; otherwise, Racket won't start. See "schminc.h" for -details. +of built-in identifiers, be sure to update the version number in +"racket/src/schvers.h", so that various tools know to rebuild +bytecode. If you add or remove primitives, you'll also need to adjust +the counter in "racket/src/schminc.h" . + +======================================================================== + Implementation Organization +======================================================================== + +Everything in this "src" directory contributes to the implementation +of the `racket` executable (and variants), while "../collects" +contains the additional Racket libraries that are included in a +minimal Racket distribution. + +Directories in "src": + + "racket" --- starting point for the traditional Racket implementation + + This implementation can build from "scratch" with a C + compiler, but first by building a CGC variant of Racket to + transform the C sourses to build a (normal) 3m variant. + + "cs" --- starting point for the Racket-on-Chez implementation + + Building the implementation requires both an existing Racket + (possibly created from the "racket" sources) and an existing + Chez Scheme build. + + "rktio" --- portability layer for low-level I/O, used by "racket" and + "cs" + + If you change "rktio.h", then be sure to regenerate + "rktio.rktl" and "rktio.inc" using an existing Racket + implementation that has the "parser-tools" package installed. + + "start" --- main-executable wrapper, used by "racket" and "cs" + + "foreign" --- the FFI implementation for "racket", including "libffi" + (as needed for some platforms) + + "expander" --- the macro expander implementation, used by "racket" + and "cs"; doubles as the "expander" package + + This expander is both included in Racket builds and used to + expand itself for including in "racket" or "cs". It's also + used to expand other libraries included in "cs". + + If you change the expander, run `make` in its directory to + generate the "startup.inc" file that holds the expander's + implementation for inclusion in the traditional Racket + variant. The "cs" build (which needs an existing Racket to + build, anyway) picks up changes automatically. + + "thread" --- the thread scheduler implementation, used by "cs" + + "io" --- the I/O implementation, used by "cs" + + "regexp" --- the regexp matcher implementation, used by "cs" + + "schemify" --- a Racket-to-Scheme compiler, used by "cs" and "cify" + + Similar to "expander", this layer is applied to itself and + other libraries for inclusion in "cs". + + "cify" --- a Racket-to-C compiler, used by "racket" + + This compiler is used only when embedding the expander as C + code, instead of Racket bytecode, which is the default for + platforms where the Racket JIT is not supported. + + "common" --- Racket libraries used by "thread", "io", etc. + + "gracket" --- implementation of the GRacket layer for the traditional + Racket implementation + + "mzcom" --- implementation of the MzCOM layer (for Windows)for the + traditional Racket implementation + + "mysink" --- `ffi/unsafe/com` helper DLL implementation (for Windows) + + "mac" --- scripts for Mac OS ".app"s, used by "gracket" and "cs" + + "worksp" --- Windows projects and build scripts for "racket" and "cs" + + "native-libs" --- build scripts for some native-library packages + + "lt" --- libtool/configure support + + "utils" --- miscellaneous + + "setup-go.rkt" --- helper script used by parts of the build that need + to run substantial Racket programs diff -Nru racket-6.12+ppa1/src/regexp/analyze/anchor.rkt racket-7.0+ppa1/src/regexp/analyze/anchor.rkt --- racket-6.12+ppa1/src/regexp/analyze/anchor.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/analyze/anchor.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,29 @@ +#lang racket/base +(require "../parse/ast.rkt") + +(provide anchored?) + +;; Determine whether a regexp definitely can only match at the start +;; of input. (A converative `#f` is ok.) + +(define (anchored? rx) + (cond + [(eq? rx rx:start) #t] + [(rx:sequence? rx) + (let loop ([rxs (rx:sequence-rxs rx)]) + (cond + [(null? rxs) #f] + [(rx:lookahead? (car rxs)) (loop (cdr rxs))] + [(rx:lookbehind? (car rxs)) (loop (cdr rxs))] + [else (anchored? (car rxs))]))] + [(rx:alts? rx) + (and (anchored? (rx:alts-rx1 rx)) + (anchored? (rx:alts-rx2 rx)))] + [(rx:conditional? rx) + (and (anchored? (rx:conditional-rx1 rx)) + (anchored? (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (anchored? (rx:group-rx rx))] + [(rx:cut? rx) + (anchored? (rx:cut-rx rx))] + [else #f])) diff -Nru racket-6.12+ppa1/src/regexp/analyze/convert.rkt racket-7.0+ppa1/src/regexp/analyze/convert.rkt --- racket-6.12+ppa1/src/regexp/analyze/convert.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/analyze/convert.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,179 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +;; Convert a string regexp to a byte-string regexp + +(provide convert) + +(define (convert rx) + (cond + [(eq? rx rx:any) + (rx:unicode-categories null #f)] + [(exact-integer? rx) + (cond + [(< rx 128) rx] + [else (string->bytes/utf-8 (string (integer->char rx)))])] + [(rx:range? rx) + (define range (rx:range-range rx)) + (if (range-within? range 0 127) + rx + (range->alts range))] + [(bytes? rx) (convert (bytes->string/latin-1 rx))] + [(string? rx) (string->bytes/utf-8 rx)] + [(rx:alts? rx) + (rx-alts (convert (rx:alts-rx1 rx)) + (convert (rx:alts-rx2 rx)) + 255)] + [(rx:sequence? rx) + (struct-copy rx:sequence rx + [rxs (for/list ([rx (in-list (rx:sequence-rxs rx))]) + (convert rx))])] + [(rx:group? rx) + (struct-copy rx:group rx + [rx (convert (rx:group-rx rx))])] + [(rx:repeat? rx) + (struct-copy rx:repeat rx + [rx (convert (rx:repeat-rx rx))])] + [(rx:maybe? rx) + (struct-copy rx:maybe rx + [rx (convert (rx:maybe-rx rx))])] + [(rx:conditional? rx) + (struct-copy rx:conditional rx + [tst (convert (rx:conditional-tst rx))] + [rx1 (convert (rx:conditional-rx1 rx))] + [rx2 (convert (rx:conditional-rx2 rx))])] + [(rx:lookahead? rx) + (struct-copy rx:lookahead rx + [rx (convert (rx:lookahead-rx rx))])] + [(rx:lookbehind? rx) + (struct-copy rx:lookbehind rx + [rx (convert (rx:lookbehind-rx rx))])] + [(rx:cut? rx) + (struct-copy rx:cut rx + [rx (convert (rx:cut-rx rx))])] + [else rx])) + +(define (range->alts args) + (define l (range->list args)) + (let loop ([l l]) + (cond + [(null? l) rx:never] + [else + (let ([start (caar l)] + [end (cdar l)]) + ;; If this range spans different-sized encodings, split it up + (define seg-end + (cond + [(start . <= . 127) 127] + [(start . <= . #x7FF) #x7FF] + [(start . <= . #xFFFF) #xFFFF] + [(start . <= . #x1FFFFF) #x1FFFFF])) + (cond + [(end . > . seg-end) + (loop (cons (cons start seg-end) + (cons (cons (add1 seg-end) end) + (cdr l))))] + [(end . <= . 127) + (rx-alts (rx-range (range-add-span empty-range start end) 255) + (loop (cdr l)) + 255)] + [else + (rx-alts (bytes-range (string->bytes/utf-8 (string (integer->char start))) + (string->bytes/utf-8 (string (integer->char end)))) + (loop (cdr l)) + 255)]))]))) + +(define (bytes-range start-str end-str) + ;; The `start-str` argument and `end-str` arguments must be the same + ;; length. + (cond + [(equal? start-str end-str) + start-str] + [(= 1 (bytes-length start-str)) + (rx-range (range-add-span empty-range (bytes-ref start-str 0) (bytes-ref end-str 0)) + 255)] + [else + ;; We a range that's has structly more than one value. + ;; + ;; At this point, the situation is much like creating a regexp to + ;; match decimal digits. If we wanted to match the range 28 to 75 + ;; (inclusive), we'd need three parts: + ;; + ;; 2[8-9]|[3-6][0-9]|7[0-5] + ;; + ;; It gets more complex with three digits, say + ;; 128 to 715: + ;; + ;; 12[8-9]|1[3-6][0-9]|[2-6][0-9][0-9]|7[0-0][0-9]|71[0-5] + ;; + ;; but you get the idea. Note that rx:any takes the place of + ;; [0-9]. + (define common (let loop ([i 0]) + (cond + [(= (bytes-ref start-str i) (bytes-ref end-str i)) + (loop (add1 i))] + [else i]))) + + ;; Assert: common must be less than the full string length. + ;; Let `common-str` be the common prefix. + (define common-str (if (zero? common) + #"" + (subbytes start-str 0 common))) + (define n (bytes-ref start-str common)) + (define m (bytes-ref end-str common)) + + ;; Now we have something like nxxxx to mxxxx where n < m. + ;; Find p such that p >= n and p0000 >= nxxxx, and + ;; find q such that q0000 <= mxxxx. + + ;; If the xxxxs in nxxxx are 0, then p is n, + ;; otherwise it's n + 1. + (define p (if (zero-tail? start-str (add1 common)) + n + (add1 n))) + + ;; If the xxxxs in mxxxx are 0, then q is m, + ;; otherwise it's m - 1. + (define q (if (zero-tail? end-str (add1 common)) + m + (sub1 m))) + + (define tail-len (sub1 (- (bytes-length start-str) common))) + + ;; Fill out [nxxxx, nFFFF] + (define n-to-p + (rx-sequence (list n + (bytes-range (subbytes start-str (add1 common)) + (vector-ref FFFF-tails tail-len))))) + + ;; Fill out [m0000, mxxxx] + (define m-and-up + (rx-sequence (list m + (bytes-range (vector-ref 0000-tails tail-len) + (subbytes end-str (add1 common)))))) + + ;; Fill out [p0000,qFFFF] + (define p-through-q + (if (= (add1 p) q) + rx:never + (rx-sequence (cons + (rx-range (range-add-span empty-range p q) 255) + (for/list ([i (in-range tail-len)]) rx:any))))) + + ;; Combine the common prefix with the three filled-out ranges: + (rx-sequence (list (if (= 1 (bytes-length common-str)) + (bytes-ref common-str 0) + common-str) + (rx-alts n-to-p + (rx-alts p-through-q + m-and-up + 255) + 255)))])) + +(define FFFF-tails '#(#"" #"\xFF" #"\xFF\xFF" #"\xFF\xFF\xFF" #"\xFF\xFF\xFF\xFF")) +(define 0000-tails '#(#"" #"\x00" #"\x00\x00" #"\x00\x00\x00" #"\x00\x00\x00\x00")) + +(define (zero-tail? bstr i) + (for/and ([c (in-bytes bstr i)]) + (= c 0))) diff -Nru racket-6.12+ppa1/src/regexp/analyze/must-string.rkt racket-7.0+ppa1/src/regexp/analyze/must-string.rkt --- racket-6.12+ppa1/src/regexp/analyze/must-string.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/analyze/must-string.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,120 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +(provide get-must-string) + +;; If there's something expensive in the regexp, look for a string or +;; sequence of ranges that must be in the input, which is useful as a +;; pre-check for matching. A sequence of ranges is useful for +;; detecting a case-insensitive string match. + +(define (get-must-string rx) + (and (something-expensive? rx) + (choose (must-string rx) + (must-range rx)))) + +;; A short byte string is more likely effective +;; than a long range sequence: +(define (choose bstr seq) + (cond + [(not seq) bstr] + [(not bstr) (compile-range-sequence seq)] + [((bytes-length bstr) . >= . (quotient (length seq) 2)) bstr] + [else (compile-range-sequence seq)])) + +(define (something-expensive? rx) + (cond + [(or (rx:alts? rx) (rx:repeat? rx)) #t] + [(rx:maybe? rx) + (something-expensive? (rx:maybe-rx rx))] + [(rx:sequence? rx) + (for/or ([rx (in-list (rx:sequence-rxs rx))]) + (something-expensive? rx))] + [(rx:conditional? rx) + (or (something-expensive? (rx:conditional-rx1 rx)) + (something-expensive? (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (something-expensive? (rx:group-rx rx))] + [(rx:cut? rx) + (something-expensive? (rx:cut-rx rx))] + [(rx:lookahead? rx) + (something-expensive? (rx:lookahead-rx rx))] + [(rx:lookbehind? rx) + (something-expensive? (rx:lookbehind-rx rx))] + [else #f])) + +(define (must-string rx) + (cond + [(bytes? rx) rx] + [(integer? rx) (bytes rx)] + [(rx:sequence? rx) + (for/fold ([bstr #f]) ([rx (in-list (rx:sequence-rxs rx))]) + (define bstr1 (must-string rx)) + (cond + [(not bstr) bstr1] + [(not bstr1) bstr] + [((bytes-length bstr) . > . (bytes-length bstr1)) + ;; Prefer longer byte string: + bstr] + [else bstr1]))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (must-string (rx:repeat-rx rx)))] + [(rx:group? rx) + (must-string (rx:group-rx rx))] + [(rx:cut? rx) + (must-string (rx:cut-rx rx))] + [(rx:lookahead? rx) + (and (rx:lookahead-match? rx) + (must-string (rx:lookahead-rx rx)))] + [(rx:lookbehind? rx) + (and (rx:lookbehind-match? rx) + (must-string (rx:lookbehind-rx rx)))] + [else #f])) + +(define (must-range rx) + (cond + [(bytes? rx) (bytes->list rx)] + [(integer? rx) (list rx)] + [(rx:range? rx) (list (rx:range-range rx))] + [(rx:sequence? rx) + ;; combine consecutive strings and ranges + (let loop ([seq null] [l (rx:sequence-rxs rx)]) + (cond + [(null? l) (and (pair? seq) (reverse seq))] + [(bytes? (car l)) + (loop (append (reverse (bytes->list (car l))) seq) + (cdr l))] + [(rx:range? (car l)) + (loop (cons (rx:range-range (car l)) + seq) + (cdr l))] + [(null? seq) (loop null (cdr l))] + [else + (define rest-seq (loop null (cdr l))) + (cond + [(and rest-seq + ((length rest-seq) . > . (length seq))) + rest-seq] + [else (reverse seq)])]))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (must-range (rx:repeat-rx rx)))] + [(rx:group? rx) + (must-range (rx:group-rx rx))] + [(rx:cut? rx) + (must-range (rx:cut-rx rx))] + [(rx:lookahead? rx) + (and (rx:lookahead-match? rx) + (must-range (rx:lookahead-rx rx)))] + [(rx:lookbehind? rx) + (and (rx:lookbehind-match? rx) + (must-range (rx:lookbehind-rx rx)))] + [else #f])) + +(define (compile-range-sequence seq) + (for/list ([r (in-list seq)]) + (if (exact-integer? r) + (compile-range (range-add empty-range r)) + (compile-range r)))) diff -Nru racket-6.12+ppa1/src/regexp/analyze/start-range.rkt racket-7.0+ppa1/src/regexp/analyze/start-range.rkt --- racket-6.12+ppa1/src/regexp/analyze/start-range.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/analyze/start-range.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,59 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +(provide get-start-range) + +;; Returns a compiled range for bytes that must appear at the start, +;; or #f if no such set is known +(define (get-start-range rx) + (define r (start-range rx)) + (and r (compile-range r))) + +(define (start-range rx) + (cond + [(integer? rx) (range-add empty-range rx)] + [(bytes? rx) (range-add empty-range (bytes-ref rx 0))] + [(rx:sequence? rx) + (let loop ([l (rx:sequence-rxs rx)]) + (cond + [(null? l) #f] + [else + (define rx (car l)) + (cond + [(zero-sized? rx) + ;; Zero-sized element, so look at rest + (loop (cdr l))] + [else + (start-range rx)])]))] + [(rx:alts? rx) + (union (start-range (rx:alts-rx1 rx)) + (start-range (rx:alts-rx2 rx)))] + [(rx:conditional? rx) + (union (start-range (rx:conditional-rx1 rx)) + (start-range (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (start-range (rx:group-rx rx))] + [(rx:cut? rx) + (start-range (rx:cut-rx rx))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (start-range (rx:repeat-rx rx)))] + [(rx:range? rx) (rx:range-range rx)] + [else #f])) + +(define (zero-sized? rx) + (or (eq? rx rx:empty) + (eq? rx rx:start) + (eq? rx rx:line-start) + (eq? rx rx:word-boundary) + (eq? rx rx:not-word-boundary) + (rx:lookahead? rx) + (rx:lookbehind? rx) + (and (rx:group? rx) + (zero-sized? (rx:group-rx rx))) + (and (rx:cut? rx) + (zero-sized? (rx:cut-rx rx))))) + +(define (union a b) + (and a b (range-union a b))) diff -Nru racket-6.12+ppa1/src/regexp/analyze/validate.rkt racket-7.0+ppa1/src/regexp/analyze/validate.rkt --- racket-6.12+ppa1/src/regexp/analyze/validate.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/analyze/validate.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,118 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt" + "../common/error.rkt") + +(provide validate) + +;; Returns max-lookbehind or reports an error +(define (validate rx num-groups) + (define group-sizes #hasheqv()) + (define depends-sizes #hasheqv()) + (define must-sizes #hasheqv()) + (define (might-be-empty-error) + (regexp-error "`*`, `+`, or `{...}` operand could be empty")) + (define-values (min-len max-len max-lookbehind) + (let validate ([rx rx]) + (cond + [(eq? rx rx:never) + (values 1 1 0)] + [(or (eq? rx rx:any) + (exact-integer? rx) + (rx:range? rx)) + (values 1 1 0)] + [(bytes? rx) + (define len (bytes-length rx)) + (values len len 0)] + [(or (eq? rx rx:empty) + (eq? rx rx:end) + (eq? rx rx:line-end)) + (values 0 0 0)] + [(or (eq? rx rx:start) + (eq? rx rx:line-start)) + (values 0 0 1)] + [(or (eq? rx rx:word-boundary) + (eq? rx rx:not-word-boundary)) + (values 0 0 1)] + [(rx:alts? rx) + (define-values (min1 max1 lb1) (validate (rx:alts-rx1 rx))) + (define-values (min2 max2 lb2) (validate (rx:alts-rx2 rx))) + (values (min min1 min2) (max max1 max2) (max lb1 lb2))] + [(rx:sequence? rx) + (for/fold ([min-len 0] [max-len 0] [max-lb 0]) ([rx (in-list (rx:sequence-rxs rx))]) + (define-values (min1 max1 lb1) (validate rx)) + (values (+ min-len min1) (+ max-len max1) (max max-lb lb1)))] + [(rx:group? rx) + (define-values (min1 max1 lb1) (validate (rx:group-rx rx))) + (set! group-sizes (hash-set group-sizes (rx:group-number rx) min1)) + (values min1 max1 lb1)] + [(rx:repeat? rx) + (define old-depends-sizes depends-sizes) + (set! depends-sizes #hasheqv()) + (define-values (min1 max1 lb1) (validate (rx:repeat-rx rx))) + (when (zero? min1) + (might-be-empty-error)) + (set! must-sizes (merge-depends-sizes must-sizes depends-sizes)) + (set! depends-sizes (merge-depends-sizes old-depends-sizes depends-sizes)) + (values (* min1 (rx:repeat-min rx)) + (* max1 (rx:repeat-max rx)) + lb1)] + [(rx:maybe? rx) + (define-values (min1 max1 lb1) (validate (rx:maybe-rx rx))) + (values 0 max1 lb1)] + [(rx:conditional? rx) + (define-values (min0 max0 lb0) (validate (rx:conditional-tst rx))) + (define-values (min1 max1 lb1) (validate (rx:conditional-rx1 rx))) + (define-values (min2 max2 lb2) (validate (rx:conditional-rx2 rx))) + (values (min min1 min2) (max max1 max2) (max lb0 lb1 lb2))] + [(rx:lookahead? rx) + (define-values (min1 max1 lb1) (validate (rx:lookahead-rx rx))) + (values 0 0 lb1)] + [(rx:lookbehind? rx) + (define-values (min1 max1 lb1) (validate (rx:lookbehind-rx rx))) + (when (= +inf.0 max1) + (regexp-error "lookbehind pattern does not match a bounded length")) + (set-rx:lookbehind-lb-min! rx min1) + (set-rx:lookbehind-lb-max! rx max1) + (values 0 0 (max max1 lb1))] + [(rx:cut? rx) + (validate (rx:cut-rx rx))] + [(rx:reference? rx) + (define n (rx:reference-n rx)) + (unless (n . <= . num-groups) + (regexp-error "backreference number is larger than the highest-numbered cluster")) + (define min-size (hash-ref group-sizes n #f)) + (cond + [min-size + ;; known minimum: + (values min-size +inf.0 0)] + [else + ;; assume at least one, but check: + (set! depends-sizes (hash-set depends-sizes (sub1 n) #t)) + (values 1 +inf.0 0)])] + [(rx:unicode-categories? rx) + (values 1 4 0)] + [else (error 'validate "internal error: ~s" rx)]))) + (for ([n (in-hash-keys must-sizes)]) + (unless (positive? (hash-ref group-sizes n 0)) + (might-be-empty-error))) + max-lookbehind) + +(define (merge-depends-sizes ht1 ht2) + (cond + [(zero? (hash-count ht1)) ht2] + [((hash-count ht2) . < . (hash-count ht1)) + (merge-depends-sizes ht2 ht1)] + [else + (for/fold ([ht2 ht2]) ([k (in-hash-keys ht1)]) + (hash-set ht2 k #t))])) + +(define (range-utf-8-encoding-lengths range) + (for/fold ([min1 4] [max1 0]) ([seg (in-list '((0 127 1) + (128 #x7FF 2) + (#x800 #xFFFF 3) + (#x10000 #x10FFFF 4)))]) + (if (range-overlaps? range (car seg) (cadr seg)) + (values (min min1 (caddr seg)) + (max max1 (caddr seg))) + (values min1 max1)))) diff -Nru racket-6.12+ppa1/src/regexp/common/error.rkt racket-7.0+ppa1/src/regexp/common/error.rkt --- racket-6.12+ppa1/src/regexp/common/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/common/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,9 @@ +#lang racket/base + +(provide regexp-error + regexp-error-tag) + +(define regexp-error-tag (make-continuation-prompt-tag 'regexp-error)) + +(define (regexp-error fmt . args) + (abort-current-continuation regexp-error-tag (apply format fmt args))) diff -Nru racket-6.12+ppa1/src/regexp/common/range.rkt racket-7.0+ppa1/src/regexp/common/range.rkt --- racket-6.12+ppa1/src/regexp/common/range.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/common/range.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,123 @@ +#lang racket/base + +;; Represent a range as a list of `(cons start end)` +;; pairs, where `start` and `end` are inclusive. + +(provide empty-range + range-invert + range-add + range-union + range-add-span + range-in? + range-singleton + range-includes? + range-overlaps? + range-within? + range->list + + compile-range + rng-in?) + +(define empty-range null) + +(define (range-invert r limit-c) + (let loop ([r r] [start 0]) + (cond + [(null? r) + (cond + [(start . > . limit-c) null] + [else (list (cons start limit-c))])] + [(= start (caar r)) + (loop (cdr r) (add1 (cdar r)))] + [else + (cons (cons start (sub1 (caar r))) + (loop (cdr r) (add1 (cdar r))))]))) + +(define (range-in? r v) + (for/or ([p (in-list r)]) + (and (v . >= . (car p)) + (v . <= . (cdr p))))) + +(define (range-add r v) + (cond + [(not v) r] + [(range-in? r v) r] + [else (range-union r (list (cons v v)))])) + +(define (range-union r1 r2) + (cond + [(null? r1) r2] + [(null? r2) r1] + [((caar r1) . <= . (caar r2)) + (cond + [((add1 (cdar r1)) . >= . (caar r2)) + ;; First elements overlap or are contiguous + (cond + [((cdar r1) . <= . (cdar r2)) + ;; First of second extends further + (range-union (cons (cons (caar r1) (cdar r2)) + (cdr r2)) + (cdr r1))] + [else + ;; First of first subsumes first of second + (range-union r1 (cdr r2))])] + [else + ;; First of first is wholly before first of second + (cons (car r1) + (range-union (cdr r1) r2))])] + [else + ;; First of second starts earlier, so change places + (range-union r2 r1)])) + +(define (range-add-span range from-c to-c) + (range-union range (list (cons from-c to-c)))) + +(define (range-singleton range) + (and (pair? range) + (null? (cdr range)) + (= (caar range) (cdar range)) + (caar range))) + +(define (range-includes? range low hi) + (cond + [(null? range) null] + [(low . > . (cdar range)) (range-includes? (cdr range) low hi)] + [else + (and (low . >= . (caar range)) + (hi . <= . (cdar range)))])) + +(define (range-within? range low hi) + (cond + [(null? range) #t] + [((caar range) . < . low) #f] + [((cdar range) . > . hi) #f] + [else (range-within? (cdr range) low hi)])) + +(define (range-overlaps? range low hi) + (cond + [(null? range) null] + [(low . > . (cdar range)) (range-overlaps? (cdr range) low hi)] + [else + (or (and (low . >= . (caar range)) + (low . <= . (cdar range))) + (and (hi . >= . (caar range)) + (hi . <= . (cdar range))))])) + +(define (range->list range) + range) + +;; ---------------------------------------- + +(define rngs (make-weak-hash)) + +(define (compile-range range) + (or (hash-ref rngs range #f) + (let ([rng (make-bytes 256 0)]) + (for* ([p (in-list range)] + [i (in-range (car p) (add1 (cdr p)))]) + (bytes-set! rng i 1)) + (hash-set! rngs range rng) + rng))) + +(define (rng-in? rng v) + (eq? 1 (bytes-ref rng v))) diff -Nru racket-6.12+ppa1/src/regexp/demo.rkt racket-7.0+ppa1/src/regexp/demo.rkt --- racket-6.12+ppa1/src/regexp/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,178 @@ +#lang racket/base +(require (prefix-in rx: "main.rkt")) + +(define-syntax-rule (test expr v) + (let ([b expr]) + (unless (equal? b v) + (error 'test "failed: ~s => ~s" 'expr b)))) + +(test (rx:regexp-match "" (open-input-string "123") 4) + #f) +(test (rx:regexp-match-peek "" (open-input-string "123") 4) + #f) + +(for* ([succeed? '(#f #t)] + [char '(#\x #\u3BB)]) + (for ([N '(1 100 1000 1023 1024 10000)]) + (for ([M (list 0 (quotient N 2))]) + (define o (open-output-bytes)) + (log-error "N = ~a, M = ~a" N M) + (void (rx:regexp-match-positions "y" + (string-append + (make-string N char) + (if succeed? "y" "")) + M + (+ N (if succeed? 1 0)) + o)) + (test (string-length (get-output-string o)) (- N M))))) + +;; Test bounded byte consumption on failure: +(let ([is (open-input-string "barfoo")]) + (test (list (rx:regexp-match "^foo" is 0 3) (read-char is)) '(#f #\f))) +(let ([is (open-input-string "barfoo")]) + (test (list (rx:regexp-match "foo" is 0 3) (read-char is)) '(#f #\f))) + +;; ---------------------------------------- + +(define (check rx in N [M (max 1 (quotient N 10))]) + (define c-start (current-inexact-milliseconds)) + (define orig-rx + (if (bytes? rx) + (for/fold ([r #f]) ([i (in-range M)]) + (byte-pregexp rx)) + (for/fold ([r #f]) ([i (in-range M)]) + (pregexp rx)))) + (define c-after-orig (current-inexact-milliseconds)) + (define new-rx + (if (bytes? rx) + (for/fold ([r #f]) ([i (in-range M)]) + (rx:byte-pregexp rx)) + (for/fold ([r #f]) ([i (in-range M)]) + (rx:pregexp rx)))) + (define c-after-new (current-inexact-milliseconds)) + + (define orig-v (regexp-match orig-rx in)) + (define new-v (rx:regexp-match new-rx in)) + (unless (equal? orig-v new-v) + (error 'check + "failed\n pattern: ~s\n input: ~s\n expected: ~s\n got: ~s" + rx in orig-v new-v)) + + (define start (current-inexact-milliseconds)) + (for/fold ([r #f]) ([i (in-range N)]) + (regexp-match? orig-rx in)) + (define after-orig (current-inexact-milliseconds)) + (for/fold ([r #f]) ([i (in-range N)]) + (rx:regexp-match? new-rx in)) + (define after-new (current-inexact-milliseconds)) + + (define orig-c-msec (- c-after-orig c-start)) + (define new-c-msec (- c-after-new c-after-orig)) + (define orig-msec (- after-orig start)) + (define new-msec (- after-new after-orig)) + + (unless (= N 1) + (parameterize ([error-print-width 64]) + (printf "regex: ~.s\non: ~.s\n" rx in)) + + (define (~n n) + (car (regexp-match #px"^[0-9]*[.]?[0-9]{0,2}" (format "~a" n)))) + + (printf " compile: ~a (~a vs. ~a) / ~a iterations\n" + (~n (/ new-c-msec orig-c-msec)) + (~n orig-c-msec) + (~n new-c-msec) + M) + (printf " interp: ~a (~a vs. ~a) / ~a iterations\n" + (~n (/ new-msec orig-msec)) + (~n orig-msec) + (~n new-msec) + N))) + +;; ---------------------------------------- + +(check #"(?m:^aa$a.)" + #"abaac\nac\naa\nacacaaacd" + 1) + +(check #"\\sa." + #"cat apple" + 1) + +(check "(?>a*)a" + "aaa" + 1) + +(check "(?:a|b)y(\\1)" + "ayb" + 1) + +(check "!.!" + #"!\x80!" + 1) + +(check #"\\P{Ll}" + #"aB" + 1) + +(check #".*" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:a*c)*d" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:a*?c)*d" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:[ab]*c)*d" + #"abaacacaaacacaaacd" + 100000) + +(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*") + +(define url-s + (string-append + "^" + "(?:" ; / scheme-colon-opt + "([^:/?#]*)" ; | #1 = scheme-opt + ":)?" ; \ + "(?://" ; / slash-slash-authority-opt + "(?:" ; | / user-at-opt + "([^/?#@]*)" ; | | #2 = user-opt + "@)?" ; | \ + "(?:" ; + "(?:\\[" ; | / #3 = ipv6-host-opt + "(" ipv6-hex ")" ; | | hex-addresses + "\\])|" ; | \ + "([^/?#:]*)" ; | #4 = host-opt + ")?" ; + "(?::" ; | / colon-port-opt + "([0-9]*)" ; | | #5 = port-opt + ")?" ; | \ + ")?" ; \ + "([^?#]*)" ; #6 = path + "(?:\\?" ; / question-query-opt + "([^#]*)" ; | #7 = query-opt + ")?" ; \ + "(?:#" ; / hash-fragment-opt + "(.*)" ; | #8 = fragment-opt + ")?" ; \ + "$")) + +(define rlo "https://racket-lang.org:80x/people.html?check=ok#end") + +(check (string->bytes/utf-8 url-s) + (string->bytes/utf-8 rlo) + 100000) + +(check url-s + rlo + 10000) + +;; all of the work is looking for a must-string +(check #"a*b" + (make-bytes 1024 (char->integer #\a)) + 100000) diff -Nru racket-6.12+ppa1/src/regexp/main.rkt racket-7.0+ppa1/src/regexp/main.rkt --- racket-6.12+ppa1/src/regexp/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,171 @@ +#lang racket/base +(require "../common/check.rkt" + "match/regexp.rkt" + "match/main.rkt" + "replace/main.rkt") + +(provide regexp + byte-regexp + pregexp + byte-pregexp + + regexp-match + regexp-match/end + regexp-match-positions + regexp-match-positions/end + regexp-match? + regexp-match-peek + regexp-match-peek-positions + regexp-match-peek-positions/end + regexp-match-peek-immediate + regexp-match-peek-positions-immediate + regexp-match-peek-positions-immediate/end + regexp-replace + regexp-replace* + + regexp? + byte-regexp? + pregexp? + byte-pregexp? + + regexp-max-lookbehind) + +(define/who (regexp p [handler #f]) + (check who string? p) + (make-regexp who p #f #f handler)) + +(define/who (byte-regexp p [handler #f]) + (check who bytes? p) + (make-regexp who p #f #t handler)) + +(define/who (pregexp p [handler #f]) + (check who string? p) + (make-regexp 'pregexp p #t #f handler)) + +(define/who (byte-pregexp p [handler #f]) + (check who bytes? p) + (make-regexp 'byte-pregexp p #t #t handler)) + +(define/who (regexp-max-lookbehind rx) + (check who + #:test (or (regexp? rx) (byte-regexp? rx)) + #:contract "(or regexp? byte-regexp?)" + rx) + (rx:regexp-max-lookbehind rx)) + +;; ---------------------------------------- + +;; For especially simple and common cases, reduce the overhead created +;; by the general case by checking for simple cases and using a faster, +;; specific driver. + +(define no-prefix #"") + +(define (fast-bytes? rx in start-pos end-pos out prefix) + (and (byte-regexp? rx) + (bytes? in) + (exact-nonnegative-integer? start-pos) + (let ([len (bytes-length in)]) + (and (start-pos . <= . len) + (or (not end-pos) + (and (exact-nonnegative-integer? end-pos) + (end-pos . <= . len) + (end-pos . >= . start-pos))))) + (not out) + (eq? prefix no-prefix))) + +(define (fast-string? rx in start-pos end-pos out prefix) + (and (regexp? rx) + (string? in) + (exact-nonnegative-integer? start-pos) + (let ([len (string-length in)]) + (and (len . < . FAST-STRING-LEN) + (start-pos . <= . len) + (or (not end-pos) + (and (exact-nonnegative-integer? end-pos) + (end-pos . <= . len) + (end-pos . >= . start-pos))))) + (not out) + (eq? prefix no-prefix))) + +(define/who (regexp-match? rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match?/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match?/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode '?)])) + +(define/who (regexp-match-positions rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match-positions/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match-positions/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'positions)])) + +(define/who (regexp-match rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'strings)])) + +(define/who (regexp-match-positions/end rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match/end rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'strings + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match-peek rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'strings)) + +(define/who (regexp-match-peek-immediate rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'strings)) + +(define/who (regexp-match-peek-positions rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'positions)) + +(define/who (regexp-match-peek-positions/end rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match-peek-positions-immediate rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'positions)) + +(define/who (regexp-match-peek-positions-immediate/end rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) diff -Nru racket-6.12+ppa1/src/regexp/Makefile racket-7.0+ppa1/src/regexp/Makefile --- racket-6.12+ppa1/src/regexp/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,38 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++pure ../../collects/racket/private/collect.rkt + +regexp-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) regexp-src-generate + +GENERATE_ARGS = -t main.rkt \ + --check-depends $(BUILDDIR)compiled/regexp-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/regexp-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/regexp.rktl $(BUILDDIR)compiled/regexp.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/regexp.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +regexp-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +# Writes the extracted, compiled, decompiled expander to compiled/regexp.rkt +decompile: + $(RACO) make ../expander/bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) ../expander/bootstrap-run.rkt -t main.rkt -c compiled/cache-src $(IGNORE) -s -x -D -o compiled/regexp.rkt + +.PHONY: regexp-src regexp-src-generate demo decompile diff -Nru racket-6.12+ppa1/src/regexp/match/compile.rkt racket-7.0+ppa1/src/regexp/match/compile.rkt --- racket-6.12+ppa1/src/regexp/match/compile.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/compile.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,183 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt" + "match.rkt") + +;; Compile to a Spencer-style interpretation of a regular expression, +;; where sequences are implemented by record chaining. Backtracking +;; is implemented by a stack of of success continuations as needed. + +;; Spenser's implementation in C dispatches on records, but we compile +;; to closures, instead. A function like `byte-matcher` allocates a +;; closure to implement byte matching. Matcher-creation functions +;; usually take a closure to use as the next step, so the closure tree +;; is built bottom-up. + +(provide compile) + +(define (compile rx) + (let compile ([rx rx] [next-m done-m]) + (define-syntax-rule (mode-cond + #:tail tail + #:general general) + (cond + [(eq? next-m done-m) tail] + [else general])) + (cond + [(exact-integer? rx) + (mode-cond + #:tail (byte-tail-matcher rx) + #:general (byte-matcher rx next-m))] + [(bytes? rx) + (define len (bytes-length rx)) + (mode-cond + #:tail (bytes-tail-matcher rx len) + #:general (bytes-matcher rx len next-m))] + [(eq? rx rx:empty) + next-m] + [(eq? rx rx:never) + (never-matcher)] + [(eq? rx rx:any) + (mode-cond + #:tail (any-tail-matcher) + #:general (any-matcher next-m))] + [(rx:range? rx) + (define rng (compile-range (rx:range-range rx))) + (mode-cond + #:tail (range-tail-matcher rng) + #:general (range-matcher rng next-m))] + [(eq? rx rx:start) + (start-matcher next-m)] + [(eq? rx rx:end) + (end-matcher next-m)] + [(eq? rx rx:line-start) + (line-start-matcher next-m)] + [(eq? rx rx:line-end) + (line-end-matcher next-m)] + [(eq? rx rx:word-boundary) + (word-boundary-matcher next-m)] + [(eq? rx rx:not-word-boundary) + (not-word-boundary-matcher next-m)] + [(rx:sequence? rx) + (define rxs (rx:sequence-rxs rx)) + (let loop ([rxs rxs]) + (cond + [(null? rxs) next-m] + [else + (define rest-node (loop (cdr rxs))) + (compile (car rxs) rest-node)]))] + [(rx:alts? rx) + (alts-matcher (compile (rx:alts-rx1 rx) next-m) + (compile (rx:alts-rx2 rx) next-m))] + [(rx:maybe? rx) + (if (rx:maybe-non-greedy? rx) + (alts-matcher next-m + (compile (rx:maybe-rx rx) next-m)) + (alts-matcher (compile (rx:maybe-rx rx) next-m) + next-m))] + [(rx:repeat? rx) + (define actual-r-rx (rx:repeat-rx rx)) + ;; As a special case, handle in non-lazy `repeat` a group around + ;; a simple pattern: + (define r-rx (if (and (rx:group? actual-r-rx) + (not (rx:repeat-non-greedy? rx)) + (not (needs-backtrack? (rx:group-rx actual-r-rx)))) + (rx:group-rx actual-r-rx) + actual-r-rx)) + (define simple? (not (needs-backtrack? r-rx))) + (define group-n (and simple? + (rx:group? actual-r-rx) + (rx:group-number actual-r-rx))) + (define min (rx:repeat-min rx)) + (define max (let ([n (rx:repeat-max rx)]) + (if (= n +inf.0) #f n))) + (define r-m* (compile*/maybe r-rx min max)) + (cond + [(and r-m* + (not (rx:repeat-non-greedy? rx))) + (repeat-simple-many-matcher r-m* min max group-n next-m)] + [else + (define r-m (compile r-rx (if simple? done-m continue-m))) + (cond + [(rx:repeat-non-greedy? rx) + (if simple? + (lazy-repeat-simple-matcher r-m min max next-m) + (lazy-repeat-matcher r-m min max next-m))] + [else + (if simple? + (repeat-simple-matcher r-m min max group-n next-m) + (repeat-matcher r-m min max next-m))])])] + [(rx:group? rx) + (define n (rx:group-number rx)) + (define m (compile (rx:group-rx rx) (group-set-matcher n next-m))) + (group-push-matcher n m)] + [(rx:reference? rx) + (define n (rx:reference-n rx)) + (cond + [(zero? n) + (never-matcher)] + [(rx:reference-case-sensitive? rx) + (reference-matcher (sub1 n) next-m)] + [else + (reference-matcher/case-insensitive (sub1 n) next-m)])] + [(rx:cut? rx) + (cut-matcher (compile (rx:cut-rx rx) done-m) + (rx:cut-n-start rx) + (rx:cut-num-n rx) + next-m)] + [(rx:conditional? rx) + (define tst (rx:conditional-tst rx)) + (define m1 (compile (rx:conditional-rx1 rx) next-m)) + (define m2 (compile (rx:conditional-rx2 rx) next-m)) + (cond + [(rx:reference? tst) + (define n (sub1 (rx:reference-n tst))) + (conditional/reference-matcher n m1 m2)] + [else + (conditional/look-matcher (compile tst done-m) m1 m2 + (rx:conditional-n-start rx) + (rx:conditional-num-n rx))])] + [(rx:lookahead? rx) + (lookahead-matcher (rx:lookahead-match? rx) + (compile (rx:lookahead-rx rx) done-m) + (rx:lookahead-n-start rx) + (rx:lookahead-num-n rx) + next-m)] + [(rx:lookbehind? rx) + (lookbehind-matcher (rx:lookbehind-match? rx) + (rx:lookbehind-lb-min rx) + (rx:lookbehind-lb-max rx) + (compile (rx:lookbehind-rx rx) limit-m) + (rx:lookbehind-n-start rx) + (rx:lookbehind-num-n rx) + next-m)] + [(rx:unicode-categories? rx) + (unicode-categories-matcher (rx:unicode-categories-symlist rx) + (rx:unicode-categories-match? rx) + next-m)] + [else (error 'compile/bt "internal error: unrecognized ~s" rx)]))) + +;; Compile a matcher repeater, if possible; the result is +;; the repeating matcher and the (consistent) length of each match +(define (compile*/maybe rx min max) + (cond + [(exact-integer? rx) + (byte-matcher* rx max)] + [(bytes? rx) + (bytes-matcher* rx max)] + [(eq? rx rx:any) + (any-matcher* max)] + [(rx:range? rx) + (range-matcher* (compile-range (rx:range-range rx)) max)] + [else + #f])) + +;; Determine the length of the prefix of `l` that needs backtracking: +(define (count-backtrack-prefix l) + (let loop ([l l] [total 0] [non-bt 0]) + (cond + [(null? l) (- total non-bt)] + [(needs-backtrack? (car l)) + (loop (cdr l) (add1 total) 0)] + [else + (loop (cdr l) (add1 total) (add1 non-bt))]))) diff -Nru racket-6.12+ppa1/src/regexp/match/extract.rkt racket-7.0+ppa1/src/regexp/match/extract.rkt --- racket-6.12+ppa1/src/regexp/match/extract.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/extract.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,65 @@ +#lang racket/base + +;; Helpers to extract position, bytes, and string results from a match +;; result. + +(provide byte-positions->byte-positions + byte-positions->bytess + + byte-positions->string-positions + byte-positions->strings + + add-end-bytes) + +(define (byte-positions->byte-positions ms-pos me-pos state + #:delta [delta 0]) + (cond + [(not state) + (list (cons (+ ms-pos delta) (+ me-pos delta)))] + [(zero? delta) + (cons (cons ms-pos me-pos) (vector->list state))] + [else + (cons (cons (+ ms-pos delta) (+ me-pos delta)) + (for/list ([p (in-vector state)]) + (and p + (cons (+ (car p) delta) + (+ (cdr p) delta)))))])) + +(define (byte-positions->bytess in ms-pos me-pos state + #:delta [delta 0]) + (cons (subbytes in (+ ms-pos delta) (+ me-pos delta)) + (if state + (for/list ([p (in-vector state)]) + (and p + (subbytes in (+ (car p) delta) (+ (cdr p) delta)))) + null))) + +(define (byte-positions->string-positions bstr-in ms-pos me-pos state + #:start-offset start-offset + #:start-pos [start-pos 0]) + (define (string-offset pos) + (+ start-offset (bytes-utf-8-length bstr-in #\? start-pos pos))) + (cons (cons (string-offset ms-pos) (string-offset me-pos)) + (if state + (for/list ([p (in-vector state)]) + (and p + (cons (string-offset (car p)) + (string-offset (cdr p))))) + null))) + +(define (byte-positions->strings bstr-in ms-pos me-pos state + #:delta [delta 0]) + (cons (bytes->string/utf-8 bstr-in #\? (+ ms-pos delta) (+ me-pos delta)) + (if state + (for/list ([p (in-vector state)]) + (and p + (bytes->string/utf-8 bstr-in #\? (+ (car p) delta) (+ delta (cdr p))))) + null))) + +;; For functions like `regexp-match/end`: +(define (add-end-bytes results end-bytes-count bstr me-pos) + (if end-bytes-count + (values results + (and results + (subbytes bstr (max 0 (- me-pos end-bytes-count)) me-pos))) + results)) diff -Nru racket-6.12+ppa1/src/regexp/match/interp.rkt racket-7.0+ppa1/src/regexp/match/interp.rkt --- racket-6.12+ppa1/src/regexp/match/interp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/interp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base + +(provide interp) + +;; Compilation produces a matcher function; see "match.rkt" +(define (interp m ; the compiled matcher function + s ; input bytes or lazy-bytes + pos ; starting seach position, can be > `start`, must be < `limit` + start ; input start in the sense of `^`; don't read before this + limit/end ; don't read past `limit`; `end` corresponds to `$` and can be < `limit` + state) ; vector where group position-pair matches are installed + ;; The search `pos` can be greater than `start` due to prefix bytes + ;; passed to `regexp-match`. + ;; The search `limit` and `end` start out the same, but `limit` + ;; can be less than `end` for a lookbehind match. + (m s pos start limit/end limit/end state null)) + diff -Nru racket-6.12+ppa1/src/regexp/match/lazy-bytes.rkt racket-7.0+ppa1/src/regexp/match/lazy-bytes.rkt --- racket-6.12+ppa1/src/regexp/match/lazy-bytes.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/lazy-bytes.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,124 @@ +#lang racket/base + +;; A compiled matcher accepts a byte string or a `lazy-bytes` object, +;; where the later is used to pull bytes on demand from a port or a +;; long character string. + +(provide make-lazy-bytes + lazy-bytes-before-end? + lazy-bytes-ref + lazy-bytes-bstr + lazy-bytes-failed? + lazy-bytes-discarded-count + lazy-bytes-advance!) + +(struct lazy-bytes ([bstr #:mutable] ; buffered bytes + [end #:mutable] ; number of available bytes --- plus discarded bytes + in ; input port + skip-amt ; offset into the port; 0 if `(not peek?)` + prefix-len ; length of prefix (not from port) + peek? ; peeking mode + immediate-only? ; non-blocking mode; implies `peek?` + progress-evt ; stop peeking if ready + out ; output hold discarded bytes; implies `(not peek?)` + max-lookbehind ; bytes before current counter to preserve, if `out` + [failed? #:mutable] ; set to #t if `progress-evt` fires or read blocks + [discarded-count #:mutable])) ; bytes discarded, if not `peek?` + +(define (make-lazy-bytes in skip-amt prefix + peek? immediate-only? progress-evt + out max-lookbehind) + (define len (bytes-length prefix)) + (lazy-bytes prefix len in skip-amt len + peek? immediate-only? progress-evt + out max-lookbehind + #f 0)) + +(define (lazy-bytes-before-end? s pos end) + (and (or (not (exact-integer? end)) + (pos . < . end)) + (cond + [(pos . < . (lazy-bytes-end s)) + #t] + [else + (and (get-more-bytes! s) + (lazy-bytes-before-end? s pos end))]))) + +(define (lazy-bytes-ref s pos) + ;; Assume a preceding `lazy-bytes-before-end?` call, so + ;; we have the byte + (bytes-ref (lazy-bytes-bstr s) (- pos (lazy-bytes-discarded-count s)))) + +(define (lazy-bytes-advance! s given-pos force?) + ;; If we advance far enough and not peeking, + ;; then flush unneeded bytes... + ;; The promise is that we won't ask for bytes before + ;; `pos` minus the `max-lookbehind` + (define pos (min given-pos (lazy-bytes-end s))) + (when force? + (lazy-bytes-before-end? s pos 'eof)) + (when (and (lazy-bytes? s) + (not (lazy-bytes-peek? s))) + (define discarded-count (lazy-bytes-discarded-count s)) + (define unneeded (- pos + discarded-count + (lazy-bytes-max-lookbehind s))) + (when (or force? (unneeded . > . 4096)) + (define amt (if force? + (- pos (lazy-bytes-discarded-count s)) + 4096)) + (define bstr (lazy-bytes-bstr s)) + (define out (lazy-bytes-out s)) + (when out + ;; Discard bytes to `out` + (define prefix-len (lazy-bytes-prefix-len s)) + (write-bytes bstr + out + ;; Skip over bytes that are part of the prefix: + (cond + [(discarded-count . > . prefix-len) 0] + [else (min amt (- prefix-len discarded-count))]) + ;; To amount to discard: + amt)) + (bytes-copy! bstr 0 bstr amt (- (lazy-bytes-end s) discarded-count)) + (set-lazy-bytes-discarded-count! s (+ amt discarded-count))))) + +;; ---------------------------------------- + +;; Result reports whether new bytes were read +(define (get-more-bytes! s) + (cond + [(lazy-bytes? s) + (define discarded-count (lazy-bytes-discarded-count s)) + (define len (- (lazy-bytes-end s) discarded-count)) + (define bstr (lazy-bytes-bstr s)) + (cond + [(lazy-bytes-failed? s) #f] + [(len . < . (bytes-length bstr)) + ;; Room in current byte string + (define n ((if (lazy-bytes-immediate-only? s) + peek-bytes-avail!* + peek-bytes-avail!) + bstr + (+ (- len (lazy-bytes-prefix-len s)) + (lazy-bytes-skip-amt s) + discarded-count) + (lazy-bytes-progress-evt s) + (lazy-bytes-in s) + len)) + (cond + [(eof-object? n) #f] + [(zero? n) + ;; would block or progress evt became ready + (set-lazy-bytes-failed?! s #t) + #f] + [else + (set-lazy-bytes-end! s (+ n len discarded-count)) + #t])] + [else + ;; We're going to need a bigger byte string + (define bstr2 (make-bytes (max 32 (* 2 (bytes-length bstr))))) + (bytes-copy! bstr2 0 bstr 0 len) + (set-lazy-bytes-bstr! s bstr2) + (get-more-bytes! s)])] + [else #f])) diff -Nru racket-6.12+ppa1/src/regexp/match/main.rkt racket-7.0+ppa1/src/regexp/match/main.rkt --- racket-6.12+ppa1/src/regexp/match/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,381 @@ +#lang racket/base +(require "regexp.rkt" + "lazy-bytes.rkt" + "port.rkt" + "compile.rkt" + "extract.rkt" + "search.rkt") + +;; Drives a regexp matcher on a byte string, character string, or port + +(provide drive-regexp-match + + fast-drive-regexp-match?/bytes + fast-drive-regexp-match?/string + fast-drive-regexp-match-positions/bytes + fast-drive-regexp-match-positions/string + fast-drive-regexp-match/bytes + fast-drive-regexp-match/string + + FAST-STRING-LEN) + +;; ---------------------------------------- +;; Start with some (repetative) functions for the most common cases to +;; keep the overhead low for reaching these cases. + +(define FAST-STRING-LEN 64) + +(define (fast-drive-regexp-match?/bytes rx in start-pos end-pos) + (define state (and (rx:regexp-references? rx) + (make-vector (rx:regexp-num-groups rx) #f))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos #t)) + +(define (fast-drive-regexp-match?/string rx in-str start-offset end-offset) + (define state (and (rx:regexp-references? rx) + (make-vector (rx:regexp-num-groups rx) #f))) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (and ms-pos #t)) + +(define (fast-drive-regexp-match-positions/bytes rx in start-pos end-pos) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos + (if state + (cons (cons ms-pos me-pos) (vector->list state)) + (list (cons ms-pos me-pos))))) + +(define (fast-drive-regexp-match-positions/string rx in-str start-offset end-offset) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (define (string-offset pos) + (+ start-offset (bytes-utf-8-length in #\? 0 pos))) + (and ms-pos + (cons (cons (string-offset ms-pos) (string-offset me-pos)) + (if state + (for/list ([p (in-vector state)]) + (and p + (cons (string-offset (car p)) + (string-offset (cdr p))))) + null)))) + +(define (fast-drive-regexp-match/bytes rx in start-pos end-pos) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos + (cons (subbytes in ms-pos me-pos) + (if state + (for/list ([p (in-vector state)]) + (and p + (subbytes in (car p) (cdr p)))) + null)))) + +(define (fast-drive-regexp-match/string rx in-str start-offset end-offset) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (and ms-pos + (cons (bytes->string/utf-8 in #\? ms-pos me-pos) + (if state + (for/list ([p (in-vector state)]) + (and p + (bytes->string/utf-8 in #\? (car p) (cdr p)))) + null)))) + +;; ---------------------------------------- +;; The general case + +;; An "offset" refers to a position in a byte string (in bytes) string +;; (in characters), or port (in bytes). A "pos" always refers to a +;; position in bytes --- so, a "pos" is normalized to UTF-8 bytes in +;; the case of a string. + +(define (drive-regexp-match who orig-rx orig-in orig-start-offset orig-end-offset out prefix + #:search-offset [search-offset orig-start-offset] + #:mode mode + #:in-port-ok? [in-port-ok? #t] + #:in-path-ok? [in-path-ok? #t] + #:peek? [peek? #f] #:immediate-only? [immediate-only? #f] + #:progress-evt [progress-evt #f] + #:end-bytes? [end-bytes? #f] + #:end-bytes-count [end-bytes-count #f]) + + (define rx (cond + [(rx:regexp? orig-rx) orig-rx] + [(string? orig-rx) (make-regexp who orig-rx #f #f #f)] + [(bytes? orig-rx) (make-regexp who orig-rx #f #t #f)] + [else (raise-argument-error who "(or/c regexp? byte-regexp? string? bytes?)" orig-rx)])) + (define in (if (and in-path-ok? (path? orig-in)) + (if (rx:regexp-bytes? rx) + (path->bytes orig-in) + (path->string orig-in)) + orig-in)) + (unless (or (and (bytes? in) (not peek?)) + (and (string? in) (not peek?)) + (and in-port-ok? (input-port? in))) + (raise-argument-error who + (cond + [peek? "input-port?"] + [in-port-ok? "(or/c bytes? string? input-port? path?)"] + [in-path-ok? "(or/c bytes? string? path?)"] + [else "(or/c bytes? string?)"]) + orig-in)) + + (define start-offset (cond + [orig-start-offset + (unless (exact-nonnegative-integer? orig-start-offset) + (raise-argument-error who "exact-nonnegative-integer?" orig-start-offset)) + (check-range who "starting index" in orig-start-offset 0) + orig-start-offset] + [else 0])) + (define end-offset (cond + [orig-end-offset + (unless (exact-nonnegative-integer? orig-end-offset) + (raise-argument-error who "(or/c #f exact-nonnegative-integer?)" orig-end-offset)) + (check-range who "ending index" in orig-end-offset start-offset) + orig-end-offset] + [(bytes? in) (bytes-length in)] + [(string? in) (string-length in)] + [else 'eof])) + + (unless (or (not out) (output-port? out)) + (raise-argument-error who "(or/c #f output-port?)" out)) + + (unless (bytes? prefix) + (raise-argument-error who "bytes?" prefix)) + + (when end-bytes? + (unless (exact-nonnegative-integer? end-bytes-count) + (raise-argument-error who "exact-nonnegative-integer?" end-bytes-count))) + + (define state (and (or (not (eq? mode '?)) + (rx:regexp-references? rx)) + (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f))))) + + ;; Separate cases for bytes, strings, and port. + ;; There's an annoying level of duplication here, but + ;; there are lots of little differences in each case. + (cond + + ;; Bytes input, no provided prefix: ---------------------------------------- + [(and (bytes? in) + (not out) + (equal? #"" prefix)) + (define start-pos start-offset) + (define search-pos search-offset) + (define end-pos end-offset) + + ;; Search for a match: + (define-values (ms-pos me-pos) (search-match rx in search-pos start-pos end-pos state)) + + ;; Maybe write skipped bytes: + (when out + (write-bytes in out 0 (or ms-pos end-pos))) + + ;; Return match results: + (case (and ms-pos mode) + [(#f) (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + (define positions (byte-positions->byte-positions ms-pos me-pos state)) + (add-end-bytes positions end-bytes-count in me-pos)] + [(strings) + (define bytess (byte-positions->bytess in ms-pos me-pos state)) + (add-end-bytes bytess end-bytes-count in me-pos)])] + + ;; Sufficiently small string input, no provided prefix: -------------------- + [(and (string? in) + (not out) + (equal? #"" prefix) + ((- end-offset start-offset) . < . FAST-STRING-LEN)) + ;; `bstr-in` includes only the characters fom `start-offset` to + ;; `end-offset`, so the starting offset (in characters) + ;; corresponds to a 0 position (in bytes): + (define bstr-in (string->bytes/utf-8 in 0 start-offset end-offset)) + (define search-pos (if (= start-offset search-offset) + 0 + (string-utf-8-length in start-offset search-offset))) + (define end-pos (bytes-length bstr-in)) + + ;; Search for a match: + (define-values (ms-pos me-pos) (search-match rx bstr-in search-pos 0 end-pos state)) + + ;; Maybe write skipped bytes: + (when out + (write-string in out 0 start-offset) + (write-bytes bstr-in out 0 (or ms-pos end-pos))) + + ;; Return match results: + (case (and ms-pos mode) + [(#f) (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + ;; If pattern is bytes-based, then results will be bytes-based: + (define positions + (cond + [(rx:regexp-bytes? rx) + (define delta (string-utf-8-length in 0 start-offset)) + (byte-positions->byte-positions ms-pos me-pos state #:delta delta)] + [else + (byte-positions->string-positions bstr-in ms-pos me-pos state + #:start-offset start-offset)])) + (add-end-bytes positions end-bytes-count bstr-in me-pos)] + [(strings) + ;; If pattern is bytes-based, then results will be bytes instead of strings: + (define bytes/strings + (cond + [(rx:regexp-bytes? rx) + (byte-positions->bytess bstr-in ms-pos me-pos state)] + [else + (byte-positions->strings bstr-in ms-pos me-pos state)])) + (add-end-bytes bytes/strings end-bytes-count bstr-in me-pos)])] + + ;; Port input, long string input, and/or provided prefix: -------------------- + [else + (define prefix-len (bytes-length prefix)) + ;; The lazy-bytes record will include the prefix, + ;; and it won't include bytes/characters before + ;; `start-offset`: + (define start-pos prefix-len) + (define search-pos (if (= start-offset search-offset) + start-pos + (+ start-pos + (cond + [(string? in) (string-utf-8-length in start-offset search-offset)] + [else (- search-offset start-offset)])))) + (define port-in + (cond + [(bytes? in) (open-input-bytes/no-copy in start-offset end-offset)] + [(string? in) (open-input-string/lazy in start-offset end-offset)] + [else in])) + (define any-bytes-left? + (cond + [(and (input-port? in) + (positive? start-offset)) + (cond + [peek? + ;; Make sure we can skip over `start-offset` bytes: + (not (eof-object? (peek-byte port-in (sub1 start-offset))))] + [else + ;; discard skipped bytes: + (copy-port-bytes port-in #f start-offset)])] + [else #t])) + ;; Create a lazy string from the port: + (define lb-in (make-lazy-bytes port-in (if peek? start-offset 0) prefix + peek? immediate-only? progress-evt + out (rx:regexp-max-lookbehind rx))) + (define end-pos (if (eq? 'eof end-offset) + 'eof + (+ start-pos + (cond + [(string? in) (string-utf-8-length in start-offset end-offset)] + [else (- end-offset start-offset)])))) + + ;; Search for a match: + (define-values (ms-pos me-pos) + (if any-bytes-left? + (search-match rx lb-in search-pos 0 end-pos state) + ;; Couldn't skip past `start-offset` bytes for an input port: + (values #f #f))) + + ;; To write and consume skipped bytes, but we'll do this only + ;; after we've extracted match information from the lazy byte + ;; string: + (define (write/consume-skipped) + (when (not peek?) + (cond + [ms-pos + (when (or out (input-port? in)) + ;; Flush bytes before match: + (lazy-bytes-advance! lb-in ms-pos #t) + ;; Consume bytes that correspond to match: + (copy-port-bytes port-in #f me-pos))] + [(eq? end-pos 'eof) + ;; copy all remaining bytes from input to output + (copy-port-bytes port-in out #f)] + [else + (when (or out (input-port? in)) + (lazy-bytes-advance! lb-in end-pos #t))]))) + + (begin0 + + ;; Return match results: + (case (and ms-pos + (not (lazy-bytes-failed? lb-in)) + mode) + [(#f) + (when (and (not peek?) + any-bytes-left? + (input-port? in)) + ;; Consume non-matching bytes + (copy-port-bytes port-in out (if (eq? 'eof end-offset) #f end-offset))) + (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + ;; Result positions correspond to the port after `start-offset`, + ;; but with the prefix bytes (= `start-pos`) + (define bstr (lazy-bytes-bstr lb-in)) + (define positions + (cond + [(or (not (string? in)) + (rx:regexp-bytes? rx)) + (define delta (- start-offset start-pos)) + (byte-positions->byte-positions ms-pos me-pos state #:delta delta)] + [else + (byte-positions->string-positions bstr ms-pos me-pos state + #:start-pos start-pos + #:start-offset start-offset)])) + (add-end-bytes positions end-bytes-count bstr me-pos)] + [(strings) + ;; The byte string may be shifted by discarded bytes, if not + ;; in `peek?` mode + (define bstr (lazy-bytes-bstr lb-in)) + (define delta (lazy-bytes-discarded-count lb-in)) + (define bytes/strings + (cond + [(or (not (string? in)) + (rx:regexp-bytes? rx)) + (byte-positions->bytess bstr ms-pos me-pos state #:delta delta)] + [else + (byte-positions->strings bstr ms-pos me-pos state #:delta delta)])) + (add-end-bytes bytes/strings end-bytes-count bstr me-pos)]) + + ;; Now, write and consume port content: + (write/consume-skipped))])) + +;; ------------------------------------------------------- +;; Range-checking arguments to `regexp-match` and company: + +(define (check-range who what in pos start-pos) + (define len (cond + [(bytes? in) (bytes-length in)] + [(string? in) (string-length in)] + [else +inf.0])) + (unless (pos . >= . start-pos) + (raise-arguments-error who + (format "~a is smaller than starting index" what) + what pos + "starting index" start-pos)) + (unless (pos . <= . len) + (raise-arguments-error who + (format "~a is out of range" what) + what pos))) + diff -Nru racket-6.12+ppa1/src/regexp/match/match.rkt racket-7.0+ppa1/src/regexp/match/match.rkt --- racket-6.12+ppa1/src/regexp/match/match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,585 @@ +#lang racket/base +(require "../common/range.rkt" + "lazy-bytes.rkt" + "utf-8.rkt") + +;; An AST is converted to a pile of matcher closures by "compile.rkt". + +;; See "interp.rkt" for the matcher protocol. + +(provide done-m + continue-m + limit-m + + byte-tail-matcher + byte-matcher + byte-matcher* + + bytes-tail-matcher + bytes-matcher + bytes-matcher* + + never-matcher + + any-tail-matcher + any-matcher + any-matcher* + + range-tail-matcher + range-matcher + range-matcher* + + start-matcher + end-matcher + line-start-matcher + line-end-matcher + word-boundary-matcher + not-word-boundary-matcher + + alts-matcher + + repeat-matcher + repeat-simple-many-matcher + repeat-simple-matcher + lazy-repeat-matcher + lazy-repeat-simple-matcher + + group-push-matcher + group-set-matcher + + reference-matcher + reference-matcher/case-insensitive + + cut-matcher + conditional/reference-matcher + conditional/look-matcher + lookahead-matcher + lookbehind-matcher + + unicode-categories-matcher) + +;; ---------------------------------------- + +(define done-m (lambda (s pos start limit end state stack) + pos)) +(define continue-m (lambda (s pos start limit end state stack) + ((car stack) pos))) +(define limit-m (lambda (s pos start limit end state stack) + (= pos limit))) + + +;; ---------------------------------------- + +(define-syntax-rule (define-general+tail (general-matcher tail-matcher arg ... next-m) + (lambda (s pos start limit end) + tst + next-pos)) + (begin + ;; General mode when `next-m` is not just `done-m`: + (define (general-matcher arg ... next-m) + (lambda (s pos start limit end state stack) + (and tst + (next-m s next-pos start limit end state stack)))) + ;; Tail mode when `next-m` is `done-m`: + (define (tail-matcher arg ...) + (lambda (s pos start limit end state stack) + (and tst + next-pos))))) + +;; An iterator performs a single match as many times as possible, up +;; to a specified max number of times, and it returns the position +;; and the number of items; this mode is used only when each match +;; has a fixed size +(define-syntax-rule (define-iterate (op-matcher* arg ...) + outer-defn ... + (lambda (s pos2 start limit end state) + inner-defn ... + #:size size + #:s-test s-tst + #:ls-test ls-tst)) + (define (op-matcher* arg ... max) + outer-defn ... + (lambda (s pos start limit end state) + inner-defn ... + (if (bytes? s) + (let ([limit (if max + (min limit (+ pos (* size max))) + limit)]) + (let loop ([pos2 pos] [n 0]) + (define pos3 (+ pos2 size)) + (cond + [(or (pos3 . > . limit) + (not s-tst)) + (values pos2 n size)] + [else (loop pos3 (add1 n))]))) + (let ([limit (and max (+ pos (* size max)))]) + (let loop ([pos2 pos] [n 0]) + (cond + [(or (and limit ((+ pos2 size) . > . limit)) + (not (lazy-bytes-before-end? s (+ pos2 (sub1 size)) limit)) + (not ls-tst)) + (values pos2 n size)] + [else + (loop (+ pos2 size) (add1 n))]))))))) + +;; When a simple repeat argument is wrapped as a group, `add-repeated-group` +;; is used in the repeating loop to set the group to the last span produced +;; by an iterator +(define-syntax-rule (add-repeated-group group-n-expr state-expr pos-expr n-expr back-amt + group-revert ; bound to an unwind thunk + body ...) ; duplicated in two `cond` branches + (let ([group-n group-n-expr] + [state state-expr] + [n n-expr] + [pos pos-expr]) + (cond + [(and group-n state) + (define old-span (vector-ref state group-n)) + (vector-set! state group-n (if (zero? n) + #f + (cons (- pos back-amt) pos))) + (define (group-revert) (vector-set! state group-n old-span)) + body ...] + [else + (define (group-revert) (void)) + body ...]))) + +;; ---------------------------------------- +;; Single-byte matching + +(define-general+tail (byte-matcher byte-tail-matcher b next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and (pos . < . limit) + (= b (bytes-ref s pos))) + (and (lazy-bytes-before-end? s pos limit) + (= b (lazy-bytes-ref s pos)))) + (add1 pos))) + +(define-iterate (byte-matcher* b) + (lambda (s pos start limit end state) + #:size 1 + #:s-test (= b (bytes-ref s pos)) + #:ls-test (= b (lazy-bytes-ref s pos)))) + +;; ---------------------------------------- +;; Byte-string matching + +(define-general+tail (bytes-matcher bytes-tail-matcher bstr len next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and ((+ pos len) . <= . limit) + (for/and ([c1 (in-bytes bstr 0 len)] + [c2 (in-bytes s pos (+ pos len))]) + (= c1 c2))) + (and (lazy-bytes-before-end? s (sub1 (+ pos len)) limit) + (for/and ([c1 (in-bytes bstr 0 len)] + [i (in-naturals pos)]) + (define c2 (lazy-bytes-ref s i)) + (= c1 c2)))) + (+ pos len))) + +(define-iterate (bytes-matcher* bstr) + (define len (bytes-length bstr)) + (lambda (s pos start limit end state) + #:size len + #:s-test (for/and ([c1 (in-bytes bstr 0 len)] + [c2 (in-bytes s pos (+ pos len))]) + (= c1 c2)) + #:ls-test (for/and ([c1 (in-bytes bstr 0 len)] + [i (in-naturals pos)]) + (define c2 (lazy-bytes-ref s i)) + (= c1 c2)))) + +;; ---------------------------------------- +;; An always-fail pattern + +(define (never-matcher) + (lambda (s pos start limit end state stack) + #f)) + +;; ---------------------------------------- +;; Match any byte + +(define-general+tail (any-matcher any-tail-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (pos . < . limit) + (lazy-bytes-before-end? s pos limit)) + (add1 pos))) + +(define (any-matcher* max-repeat) + (lambda (s pos start limit end state) + (cond + [(bytes? s) + (define n (if max-repeat + (min max-repeat (- limit pos)) + (- limit pos))) + (values (+ pos n) n 1)] + [else + ;; Search for end position + (let grow-loop ([size 1]) + (define n (if max-repeat (min size max-repeat) size)) + (define pos2 (+ pos n)) + (cond + [(and (lazy-bytes-before-end? s (sub1 pos2) limit) + (or (not max-repeat) (n . < . max-repeat))) + (grow-loop (* size 2))] + [else + (let search-loop ([min pos] [too-high (add1 pos2)]) + (define mid (quotient (+ min too-high) 2)) + (cond + [(= mid min) + (values mid (- mid pos) 1)] + [(lazy-bytes-before-end? s (sub1 mid) limit) + (search-loop mid too-high)] + [else + (search-loop min mid)]))]))]))) + +;; ---------------------------------------- +;; Match any byte in a set + +(define-general+tail (range-matcher range-tail-matcher rng next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and (pos . < . limit) + (rng-in? rng (bytes-ref s pos))) + (and (lazy-bytes-before-end? s pos limit) + (rng-in? rng (lazy-bytes-ref s pos)))) + (add1 pos))) + +(define-iterate (range-matcher* rng) + (lambda (s pos start limit end state) + #:size 1 + #:s-test (rng-in? rng (bytes-ref s pos)) + #:ls-test (rng-in? rng (lazy-bytes-ref s pos)))) + +;; ---------------------------------------- +;; Matches that don't consume any characters, +;; such as end-of-string or word-boundary + +(define-syntax-rule (define-zero-width (op-matcher arg ... next-m) + (lambda (s pos start limit end) + tst)) + (define (op-matcher arg ... next-m) + (lambda (s pos start limit end state stack) + (and tst + (next-m s pos start limit end state stack))))) + +(define-zero-width (start-matcher next-m) + (lambda (s pos start limit end) + (= pos start))) + +(define-zero-width (end-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (= pos end) + (not (lazy-bytes-before-end? s pos end))))) + +(define-zero-width (line-start-matcher next-m) + (lambda (s pos start limit end) + (or (= pos start) + (= (char->integer #\newline) + (if (bytes? s) + (bytes-ref s (sub1 pos)) + (lazy-bytes-ref s (sub1 pos))))))) + +(define-zero-width (line-end-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (or (= pos end) + (= (char->integer #\newline) (bytes-ref s pos))) + (or (not (lazy-bytes-before-end? s pos end)) + (= (char->integer #\newline) + (lazy-bytes-ref s pos)))))) + +(define-zero-width (word-boundary-matcher next-m) + (lambda (s pos start limit end) + (word-boundary? s pos start limit end))) + +(define-zero-width (not-word-boundary-matcher next-m) + (lambda (s pos start limit end) + (not (word-boundary? s pos start limit end)))) + +(define (word-boundary? s pos start limit end) + (not (eq? (or (= pos start) + (not (word-byte? (if (bytes? s) + (bytes-ref s (sub1 pos)) + (lazy-bytes-ref s (sub1 pos)))))) + (or (if (bytes? s) + (= pos end) + (not (lazy-bytes-before-end? s pos end))) + (not (word-byte? (if (bytes? s) + (bytes-ref s pos) + (lazy-bytes-ref s pos)))))))) + +(define (word-byte? c) + (or (and (c . >= . (char->integer #\0)) (c . <= . (char->integer #\9))) + (and (c . >= . (char->integer #\a)) (c . <= . (char->integer #\z))) + (and (c . >= . (char->integer #\A)) (c . <= . (char->integer #\Z))) + (= c (char->integer #\_)))) + +;; ---------------------------------------- +;; Alternatives + +(define (alts-matcher m1 m2) + (lambda (s pos start limit end state stack) + (or (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)))) + +;; ---------------------------------------- +;; Repeats, greedy (normal) and non-greedy, +;; in various optimized forms + +(define (repeat-matcher r-m min max next-m) + ;; The tail of `r-m` is set to `continue-m` instead + ;; of `done-m`, so we can supply a success continuation + ;; by pushing it onto the stack + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0]) + (cond + [(n . < . min) + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n))) + stack)) + (r-m s pos start limit end state new-stack)] + [(and max (= n max)) (next-m s pos start limit end state stack)] + [else + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n))) + stack)) + (or (r-m s pos start limit end state new-stack) + (next-m s pos start limit end state stack))])))) + +(define r-stack (list (lambda (pos) pos))) + +(define (repeat-simple-matcher r-m min max group-n next-m) + ;; The `r-m` matcher doesn't need backtracking, so + ;; we don't need to push a success continuation onto + ;; the stack + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [back-amt 0]) + (define pos2 + (and (or (not max) (n . < . max)) + (r-m s pos start limit end state r-stack))) + (if pos2 + (rloop pos2 (add1 n) (- pos2 pos)) + (let bloop ([pos pos] [n n]) + (cond + [(n . < . min) #f] + [else + (add-repeated-group + group-n state pos n back-amt group-revert + (or (next-m s pos start limit end state stack) + (begin + (group-revert) + (bloop (- pos back-amt) (sub1 n)))))])))))) + +(define (repeat-simple-many-matcher r-m* min max group-n next-m) + ;; Instead of `r-m`, we have a `r-m*` that finds as many matches as + ;; possible (up to max) in one go + (lambda (s pos start limit end state stack) + (define-values (pos2 n back-amt) (r-m* s pos start limit end state)) + (let bloop ([pos pos2] [n n]) + (cond + [(n . < . min) #f] + [else + (add-repeated-group + group-n state pos n back-amt group-revert + (or (next-m s pos start limit end state stack) + (begin + (group-revert) + (bloop (- pos back-amt) (sub1 n)))))])))) + +(define (lazy-repeat-matcher r-m min max next-m) + ;; Like `repeat-matcher`: the tail of `r-m` is set to `continue-m` + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [min min]) + (cond + [(n . < . min) + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n) min)) + stack)) + (r-m s pos start limit end state new-stack)] + [(and max (= n max)) + (next-m s pos start limit end state stack)] + [else + (or (next-m s pos start limit end state stack) + (rloop pos n (add1 min)))])))) + +(define (lazy-repeat-simple-matcher r-m min max next-m) + ;; Like `repeat-simple-matcher`: no backtracking in `r-m` + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [min min]) + (cond + [(n . < . min) + (define pos2 (r-m s pos start limit end state stack)) + (and pos2 + (rloop pos2 (add1 n) min))] + [(and max (= n max)) + (next-m s pos start limit end state stack)] + [else + (or (next-m s pos start limit end state stack) + (rloop pos n (add1 min)))])))) + +;; ---------------------------------------- +;; Recording and referencing group matches + +(define (group-push-matcher n next-m) + (lambda (s pos start limit end state stack) + (define new-stack (cons (cons pos (and state (vector-ref state n))) + stack)) + (next-m s pos start limit end state new-stack))) + +(define (group-set-matcher n next-m) + (lambda (s pos start limit end state stack) + (define old-pos+span (car stack)) + (define old-span (cdr old-pos+span)) + (when state + (vector-set! state n (cons (car old-pos+span) pos))) + (or (next-m s pos start limit end state (cdr stack)) + (begin + (when state (vector-set! state n old-span)) + #f)))) + +(define-syntax-rule (define-reference-matcher reference-matcher chyte=?) + (define (reference-matcher n next-m) + (lambda (s pos start limit end state stack) + (define p (vector-ref state n)) + (cond + [(not p) #f] + [else + (define len (- (cdr p) (car p))) + (define matches? + (if (bytes? s) + (and ((+ pos len) . <= . limit) + (for/and ([c1 (in-bytes s (car p) (cdr p))] + [c2 (in-bytes s pos (+ pos len))]) + (chyte=? c1 c2))) + (and (lazy-bytes-before-end? s (sub1 (+ pos len)) limit) + (for/and ([j (in-range (car p) (cdr p))] + [i (in-naturals pos)]) + (define c1 (lazy-bytes-ref s j)) + (define c2 (lazy-bytes-ref s i)) + (chyte=? c1 c2))))) + (and matches? + (next-m s (+ pos len) start limit end state stack))])))) + +(define-reference-matcher reference-matcher =) + +(define-reference-matcher reference-matcher/case-insensitive + (lambda (c1 c2) (= (chyte-to-lower c1) (chyte-to-lower c2)))) + +(define (chyte-to-lower c) + (if (and (c . >= . (char->integer #\A)) (c . <= . (char->integer #\Z))) + (+ c (- (char->integer #\a) (char->integer #\A))) + c)) + +;; ---------------------------------------- +;; Lookahead, lookbehind, conditionals, and cut + +(define (lookahead-matcher match? sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s pos start limit end state null)) + (cond + [match? + (and pos2 + (or (next-m s pos start limit end state stack) + (restore-groups state old-state n-start num-n)))] + [pos2 + (restore-groups state old-state n-start num-n)] + [else + (next-m s pos start limit end state stack)]))) + +(define (lookbehind-matcher match? lb-min lb-max sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define lb-min-pos (max start (- pos lb-max))) + (let loop ([lb-pos (- pos lb-min)]) + (cond + [(lb-pos . < . lb-min-pos) + (if match? + #f + (next-m s pos start limit end state stack))] + [else + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s lb-pos start pos end state null)) + (cond + [match? + (if pos2 + (or (next-m s pos start limit end state stack) + (restore-groups state old-state n-start num-n)) + (loop (sub1 lb-pos)))] + [pos2 + (restore-groups state old-state n-start num-n)] + [else + (next-m s pos start limit end state stack)])])))) + +(define (conditional/reference-matcher n m1 m2) + (lambda (s pos start limit end state stack) + (if (vector-ref state n) + (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)))) + +(define (conditional/look-matcher tst-m m1 m2 n-start num-n) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (or (if (tst-m s pos start limit end state null) + (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)) + (restore-groups state old-state n-start num-n)))) + +(define (cut-matcher sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s pos start limit end state null)) + (and pos2 + (or (next-m s pos2 start limit end state stack) + (restore-groups state old-state n-start num-n))))) + + +(define (save-groups state n-start num-n) + (cond + [(zero? num-n) #f] + [(not state) #f] + [else + (define vec (make-vector num-n)) + (vector-copy! vec 0 state n-start (+ n-start num-n)) + vec])) + +(define (restore-groups state old-state n-start num-n) + (when old-state + (vector-copy! state n-start old-state)) + #f) + +;; ---------------------------------------- +;; Unicode characters in UTF-8 encoding + +(define (unicode-categories-matcher cats match? next-m) + (lambda (s pos start limit end state stack) + (let loop ([pos pos] [accum null]) + (define b + (if (bytes? s) + (and (pos . < . limit) + (bytes-ref s pos)) + (and (lazy-bytes-before-end? s pos limit) + (lazy-bytes-ref s pos)))) + (cond + [(not b) #f] + [else + (define c (bytes->char/utf-8 b accum)) + (cond + [(char? c) + (if (eq? match? + (let ([c-cat (char-general-category c)]) + (if (list? cats) + (for/or ([cat (in-list cats)]) + (eq? cat c-cat)) + (eq? cats c-cat)))) + (next-m s (add1 pos) start limit end state stack) + #f)] + [(eq? c 'fail) + #f] + [else + ;; c must be 'continue + (loop (add1 pos) (cons b accum))])])))) diff -Nru racket-6.12+ppa1/src/regexp/match/port.rkt racket-7.0+ppa1/src/regexp/match/port.rkt --- racket-6.12+ppa1/src/regexp/match/port.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/port.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,99 @@ +#lang racket/base + +(provide copy-port-bytes + open-input-bytes/no-copy + open-input-string/lazy) + +;; Copy up to `n` bytes from `in` to `out`, where +;; #f for `n` means copy to end-of-file +(define (copy-port-bytes in out n) + (define bstr (make-bytes (min 4096 (or n 4096)))) + (define (copy got expect) + (cond + [(eof-object? got) #f] + [else + (when out + (write-bytes bstr out 0 got)) + (or (and (not n) + (positive? got)) + (and n + (= got expect)))])) + (let loop ([n n]) + (if (and n (n . < . 4096)) + (copy (read-bytes! bstr in 0 n) n) + (and (copy (read-bytes! bstr in) 4096) + (loop (and n (- n 4096))))))) + +;; Similar to `open-input-bytes`, but never copies the +;; argument, and more efficienyl handles a start and +;; end range +(define (open-input-bytes/no-copy bstr pos end) + (define (fill! dest-bstr skip) + (define pos+skip (+ pos skip)) + (cond + [(pos+skip . >= . end) eof] + [else + (define len (min (bytes-length dest-bstr) + (- end pos+skip))) + (bytes-copy! dest-bstr 0 bstr pos+skip (+ pos+skip len)) + len])) + (make-input-port + 'bytes + (lambda (dest-bstr) + (define len (fill! dest-bstr 0)) + (unless (eof-object? len) + (set! pos (+ len pos))) + len) + (lambda (dest-bstr skip evt) + (fill! dest-bstr skip)) + void)) + +;; Similar to `open-input-string`, but lazily decodes +;; a range of the string +(define (open-input-string/lazy str pos end) + (define bstr (make-bytes 64)) + (define bstr-pos 0) + (define bstr-end 0) + (define (fill! dest-bstr skip) + (define bstr-pos+skip (+ bstr-pos skip)) + (when (bstr-pos+skip . >= . bstr-end) + ;; Try to decode more + (decode-more! (add1 bstr-pos+skip))) + (cond + [(bstr-pos+skip . >= . bstr-end) eof] + [else + (define len (min (bytes-length dest-bstr) + (- bstr-end bstr-pos+skip))) + (bytes-copy! dest-bstr 0 bstr bstr-pos+skip (+ bstr-pos+skip len)) + len])) + (define (decode-more! target-pos) + (cond + [(= pos end) (void)] + [else + (define len (min 64 (- end pos))) + ;; We could use the decoder interface here to + ;; avoid byte-string allocations, but we expect + ;; that savings to be in the noise: + (define new-bstr + (string->bytes/utf-8 str 0 pos (+ pos len))) + (set! pos (+ len pos)) + (define new-len (bytes-length new-bstr)) + (when ((- (bytes-length bstr) bstr-end) . < . new-len) + (define bstr2 (make-bytes (max (* (bytes-length bstr) 2) + (+ bstr-end new-len)))) + (bytes-copy! bstr2 0 bstr 0 bstr-end) + (set! bstr bstr2)) + (bytes-copy! bstr bstr-end new-bstr) + (set! bstr-end (+ bstr-end new-len)) + (when (bstr-end . < . target-pos) + (decode-more! target-pos))])) + (make-input-port + 'string + (lambda (dest-bstr) + (define len (fill! dest-bstr 0)) + (unless (eof-object? len) + (set! bstr-pos (+ bstr-pos len))) + len) + (lambda (dest-bstr skip evt) + (fill! dest-bstr skip)) + void)) diff -Nru racket-6.12+ppa1/src/regexp/match/regexp.rkt racket-7.0+ppa1/src/regexp/match/regexp.rkt --- racket-6.12+ppa1/src/regexp/match/regexp.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/regexp.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,80 @@ +#lang racket/base +(require "../common/error.rkt" + "../parse/main.rkt" + "../analyze/validate.rkt" + "../analyze/convert.rkt" + "../analyze/anchor.rkt" + "../analyze/must-string.rkt" + "../analyze/start-range.rkt" + "compile.rkt") + +(provide (struct-out rx:regexp) + make-regexp + regexp? + byte-regexp? + pregexp? + byte-pregexp?) + +(struct rx:regexp (bytes? ; a bytes matcher (as opposed to string matcher)? + px? ; a pregexp (as opposed to pregexp)? + source ; original source string/bytes, but made immutable + matcher ; compiled matcher function; see "compile.rkt" + num-groups ; number of `(...)` groups for reporting submatches + references? ; any backreferences in the pattern? + max-lookbehind ; max lookbehnd + anchored? ; starts with `^`? + must-string ; shortcut: a byte string that must appear in a match + start-range) ; shortcut: a range that must match the initial byte + #:reflection-name 'regexp + #:property prop:custom-write (lambda (rx port mode) + (write-bytes (if (rx:regexp-px? rx) + #"#px" + #"#rx") + port) + (write (rx:regexp-source rx) port)) + #:property prop:object-name (struct-field-index source) + #:property prop:equal+hash (list + (lambda (a b eql?) + (equal? (rx:regexp-source a) (rx:regexp-source b))) + (lambda (a hc) + (hc (rx:regexp-source a))) + (lambda (a hc) + (hc (rx:regexp-source a))))) + +(define (make-regexp who orig-p px? as-bytes? handler) + (call-with-continuation-prompt + (lambda () + (define p (if (bytes? orig-p) + (bytes->immutable-bytes orig-p) + (string->immutable-string orig-p))) + (define-values (raw-rx num-groups references?) (parse p #:px? px?)) + (define rx (if as-bytes? raw-rx (convert raw-rx))) + (define max-lookbehind (validate rx num-groups)) + (define matcher (compile rx)) + (rx:regexp as-bytes? px? p + matcher num-groups references? max-lookbehind + (anchored? rx) (get-must-string rx) + (get-start-range rx))) + regexp-error-tag + (lambda (str) + (if handler + (handler str) + (raise-arguments-error who str "pattern" orig-p))))) + +(define (regexp? v) + (and (rx:regexp? v) + (not (rx:regexp-bytes? v)))) + +(define (byte-regexp? v) + (and (rx:regexp? v) + (rx:regexp-bytes? v))) + +(define (pregexp? v) + (and (rx:regexp? v) + (not (rx:regexp-bytes? v)) + (rx:regexp-px? v))) + +(define (byte-pregexp? v) + (and (rx:regexp? v) + (rx:regexp-bytes? v) + (rx:regexp-px? v))) diff -Nru racket-6.12+ppa1/src/regexp/match/search.rkt racket-7.0+ppa1/src/regexp/match/search.rkt --- racket-6.12+ppa1/src/regexp/match/search.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/search.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,91 @@ +#lang racket/base +(require "../common/range.rkt" + "regexp.rkt" + "lazy-bytes.rkt" + "interp.rkt" + "../analyze/must-string.rkt") + +(provide search-match) + +;; ------------------------------------------------------------ +;; The driver iterates through the input (unless the pattern is +;; anchored) to find a match + +(define (search-match rx in pos start-pos end-pos state) + (define must-string (rx:regexp-must-string rx)) + (cond + [(not (check-must-string must-string in pos end-pos)) + (values #f #f)] + [else + (define matcher (rx:regexp-matcher rx)) + (define anchored? (rx:regexp-anchored? rx)) + (define start-range (rx:regexp-start-range rx)) + (let loop ([pos pos]) + (cond + [(and anchored? (not (= pos start-pos))) + (values #f #f)] + [(and start-range + (if (bytes? in) + (= pos end-pos) + (not (lazy-bytes-before-end? in pos end-pos)))) + (values #f #f)] + [(and start-range + (not (check-start-range start-range in pos end-pos))) + (loop (add1 pos))] + [else + (define pos2 (interp matcher in pos start-pos end-pos state)) + (cond + [pos2 (values pos pos2)] + [start-range (loop (add1 pos))] + [(if (bytes? in) + (pos . < . end-pos) + (lazy-bytes-before-end? in pos end-pos)) + (define pos2 (add1 pos)) + (unless (bytes? in) + (lazy-bytes-advance! in pos2 #f)) + (loop pos2)] + [else (values #f #f)])]))])) + +;; ------------------------------------------------------------------ +;; Checking for a must string (before iterating though the input) can +;; speed up a match failure by avoiding backtracking: + +(define (check-must-string must-string in pos end-pos) + (cond + [(not must-string) #t] + [(not (bytes? in)) #t] + [(bytes? must-string) + (cond + [(= 1 (bytes-length must-string)) + ;; Check for a single byte + (define mc (bytes-ref must-string 0)) + (for/or ([c (in-bytes in pos end-pos)]) + (= c mc))] + [else + ;; Check for a byte string + (define mc1 (bytes-ref must-string 0)) + (for/or ([i (in-range pos (- end-pos (sub1 (bytes-length must-string))))]) + (and (= mc1 (bytes-ref in i)) + (for/and ([c (in-bytes in (add1 i))] + [mc (in-bytes must-string 1)]) + (= c mc))))])] + [else + ;; Check against a sequence of ranges + (for/or ([i (in-range pos (- end-pos (sub1 (length must-string))))]) + (let loop ([i i] [l must-string]) + (cond + [(null? l) #t] + [else + (define e (car l)) + (and (rng-in? e (bytes-ref in i)) + (loop (add1 i) (cdr l)))])))])) + +;; ------------------------------------------------------------------ +;; Checking for a startup byte can speed up a match failure by +;; avoiding the general pattern checker: + +(define (check-start-range start-range in pos end-pos) + (rng-in? start-range + (if (bytes? in) + (bytes-ref in pos) + (lazy-bytes-ref in pos)))) diff -Nru racket-6.12+ppa1/src/regexp/match/utf-8.rkt racket-7.0+ppa1/src/regexp/match/utf-8.rkt --- racket-6.12+ppa1/src/regexp/match/utf-8.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/match/utf-8.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,71 @@ +#lang racket/base +(provide bytes->char/utf-8) + +;; Given a byte and a list of accumulated bytes, +;; return a char, 'fail, or 'continue +(define (bytes->char/utf-8 last-b accum) + (cond + [(last-b . < . 128) + (cond + [(null? accum) (integer->char last-b)] + [else 'fail])] + [(continue-byte? last-b) + ;; A byte that continues + (cond + [(null? accum) 'fail] + [(two-byte-prefix? (car accum)) + (integer->char* + #x80 + (+ (arithmetic-shift (bitwise-and #b11111 (car accum)) 6) + (continue-value last-b)))] + [(three-byte-prefix? (car accum)) + 'continue] + [(four-byte-prefix? (car accum)) + 'continue] + [(and (pair? (cdr accum)) + (three-byte-prefix? (cadr accum))) + (integer->char* + #x800 + (+ (arithmetic-shift (bitwise-and #b1111 (cadr accum)) 12) + (arithmetic-shift (continue-value (car accum)) 6) + (continue-value last-b)))] + [(and (pair? (cdr accum)) + (four-byte-prefix? (cadr accum))) + 'continue] + [(and (pair? (cdr accum)) + (pair? (cddr accum)) + (four-byte-prefix? (caddr accum))) + (integer->char* + #x10000 + (+ (arithmetic-shift (bitwise-and #b1111 (caddr accum)) 18) + (arithmetic-shift (continue-value (cadr accum)) 12) + (arithmetic-shift (continue-value (car accum)) 6) + (continue-value last-b)))] + [else 'fail])] + [(and (or (two-byte-prefix? last-b) + (three-byte-prefix? last-b) + (four-byte-prefix? last-b)) + (null? accum)) + 'continue] + [else 'fail])) + +;; Guard against invalid encodings: +(define (integer->char* lower-bound n) + (if (or (n . < . lower-bound) + (n . > . #x10FFFF) + (and (n . >= . #xD800) + (n . <= . #xDFFF))) + 'fail + (integer->char n))) + +(define (continue-byte? b) + (= (bitwise-and b #b11000000) #b10000000)) +(define (continue-value b) + (bitwise-and b #b00111111)) + +(define (two-byte-prefix? b) + (= (bitwise-and b #b11100000) #b11000000)) +(define (three-byte-prefix? b) + (= (bitwise-and b #b11110000) #b11100000)) +(define (four-byte-prefix? b) + (= (bitwise-and b #b11111000) #b11110000)) diff -Nru racket-6.12+ppa1/src/regexp/parse/ast.rkt racket-7.0+ppa1/src/regexp/parse/ast.rkt --- racket-6.12+ppa1/src/regexp/parse/ast.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/ast.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,156 @@ +#lang racket/base +(require "../common/range.rkt") + +(provide (all-defined-out)) + +(define rx:never 'never) +(define rx:empty 'empty) +(define rx:any 'any) +(define rx:start 'start) +(define rx:end 'end) +(define rx:line-start 'line-start) +(define rx:line-end 'line-end) +(define rx:word-boundary 'word-boundary) +(define rx:not-word-boundary 'not-word-boundary) + +;; exact integer : match single byte or char +;; byte string : match content sequence +;; string : match content sequence + +(struct rx:alts (rx1 rx2) #:transparent) +(struct rx:sequence (rxs needs-backtrack?) #:transparent) +(struct rx:group (rx number) #:transparent) +(struct rx:repeat (rx min max non-greedy?) #:transparent) +(struct rx:maybe (rx non-greedy?) #:transparent) ; special case in size validation +(struct rx:conditional (tst rx1 rx2 n-start num-n needs-backtrack?) #:transparent) +(struct rx:lookahead (rx match? n-start num-n) #:transparent) +(struct rx:lookbehind (rx match? [lb-min #:mutable] [lb-max #:mutable] ; min & max set by `validate` + n-start num-n) + #:transparent) +(struct rx:cut (rx n-start num-n needs-backtrack?) #:transparent) +(struct rx:reference (n case-sensitive?) #:transparent) +(struct rx:range (range) #:transparent) +(struct rx:unicode-categories (symlist match?) #:transparent) + +;; We need to backtrack for `rx` if it has alternatives; +;; we also count as backtracking anything complex enough +;; to match different numbers of elements in an immediate +;; repetition +(define (needs-backtrack? rx) + (cond + [(rx:alts? rx) #t] + [(rx:sequence? rx) (rx:sequence-needs-backtrack? rx)] + [(rx:group? rx) #t] ; to unwind success mappings + [(rx:repeat? rx) #t] + [(rx:maybe? rx) #t] + [(rx:conditional? rx) (rx:conditional-needs-backtrack? rx)] + [(rx:cut? rx) (rx:cut-needs-backtrack? rx)] ; doesn't actually backtrack, but count varies + [(rx:unicode-categories? rx) #t] + [else #f])) + +(define (rx-range range limit-c) + (cond + [(range-singleton range) => (lambda (c) c)] + [(range-includes? range 0 limit-c) rx:any] + [else (rx:range range)])) + +(define (rx-sequence l) + (cond + [(null? l) rx:empty] + [(null? (cdr l)) (car l)] + [else + (define merged-l (merge-adjacent l)) + (cond + [(null? (cdr merged-l)) (car merged-l)] + [else (rx:sequence merged-l (ormap needs-backtrack? merged-l))])])) + +(define (merge-adjacent l) + ;; `mode` tracks whether `accum` has byte or char strings, + ;; where a #f `mode` means that `accum` is empty + (let loop ([mode #f] [accum null] [l l]) + (cond + [(and (pair? l) + (rx:sequence? (car l))) + ;; Flatten nested sequences + (loop mode accum (append (rx:sequence-rxs (car l)) (cdr l)))] + [(and (pair? l) + (or (eq? rx:empty (car l)) + (equal? "" (car l)) + (equal? #"" (car l)))) + ;; Drop empty element + (loop mode accum (cdr l))] + [(or (null? l) + (not (case mode + [(byte) (or (byte? (car l)) + (bytes? (car l)))] + [(char) (or (integer? (car l)) + (string? (car l)))] + [else #t]))) + ;; Compatible subsequence ended + (cond + [(null? accum) + ;; Must be of `l`, with nothing in accumulator + null] + [(null? (cdr accum)) + ;; Subsequence is just one element after all + (cons (car accum) (loop #f null l))] + [else + ;; Combine elements in `accum` + (cons (case mode + [(byte) (apply bytes-append + (for/list ([a (in-list (reverse accum))]) + (cond + [(byte? a) (bytes a)] + [else a])))] + [(char) (apply string-append + (for/list ([a (in-list (reverse accum))]) + (cond + [(integer? a) (string (integer->char a))] + [else a])))] + [else (error "internal error")]) + (loop #f null l))])] + [mode + ;; Continue in same mode + (loop mode (cons (car l) accum) (cdr l))] + [(or (byte? (car l)) + (bytes? (car l))) + ;; Start byte mode + (loop 'byte (list (car l)) (cdr l))] + [(or (integer? (car l)) + (string? (car l))) + ;; Start character mode + (loop 'char (list (car l)) (cdr l))] + [else + ;; No combination possible + (cons (car l) (loop #f null (cdr l)))]))) + +(define (rx-alts rx1 rx2 limit-c) + (cond + [(eq? rx:never rx1) rx2] + [(eq? rx:never rx2) rx1] + [(and (rx:range? rx1) (rx:range? rx2)) + (rx-range (range-union (rx:range-range rx1) + (rx:range-range rx2)) + limit-c)] + [(and (rx:range? rx1) (rx:alts? rx2) (rx:range? (rx:alts-rx1 rx2))) + (rx-alts (rx-alts rx1 (rx:alts-rx1 rx2) limit-c) + (rx:alts-rx2 rx2) + limit-c)] + [(and (rx:range? rx1) (integer? rx2)) + (rx-range (range-add (rx:range-range rx1) rx2) limit-c)] + [(and (rx:range? rx2) (integer? rx1)) + (rx-alts rx2 rx1 limit-c)] + [(and (integer? rx1) (integer? rx2)) + (rx-range (range-add (range-add empty-range rx1) rx2) limit-c)] + [else + (rx:alts rx1 rx2)])) + +(define (rx-group rx n) + (rx:group rx n)) + +(define (rx-cut rx n-start num-n) + (rx:cut rx n-start num-n (needs-backtrack? rx))) + +(define (rx-conditional tst pces1 pces2 n-start num-n) + (rx:conditional tst pces1 pces2 n-start num-n (or (needs-backtrack? pces1) + (needs-backtrack? pces2)))) diff -Nru racket-6.12+ppa1/src/regexp/parse/case.rkt racket-7.0+ppa1/src/regexp/parse/case.rkt --- racket-6.12+ppa1/src/regexp/parse/case.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/case.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,27 @@ +#lang racket/base +(require "../common/range.rkt" + "config.rkt") + +;; Add case-insensitive mappins as specified by `config` +(provide range-add* + range-add-span*) + +(define (range-add* range c config) + (cond + [(not c) range] + [else + (define range2 (range-add range c)) + (cond + [(parse-config-case-sensitive? config) range2] + [else + (define range3 (range-add range2 (char->integer (char-upcase (integer->char c))))) + (define range4 (range-add range3 (char->integer (char-foldcase (integer->char c))))) + (range-add range4 (char->integer (char-downcase (integer->char c))))])])) + +(define (range-add-span* range from-c to-c config) + (cond + [(parse-config-case-sensitive? config) + (range-add-span range from-c to-c)] + [else + (for/fold ([range range]) ([c (in-range from-c (add1 to-c))]) + (range-add* range c config))])) diff -Nru racket-6.12+ppa1/src/regexp/parse/chyte-case.rkt racket-7.0+ppa1/src/regexp/parse/chyte-case.rkt --- racket-6.12+ppa1/src/regexp/parse/chyte-case.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/chyte-case.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,17 @@ +#lang racket/base +(require "chyte.rkt") + +;; Dispatch on chytes with character patterns + +(provide chyte-case + chyte-case/eos) + +(define-syntax-rule (chyte-case c clause ...) + (case (integer->char c) + clause ...)) + +(define-syntax-rule (chyte-case/eos s-expr pos-expr clause ...) + (let ([pos pos-expr] + [s s-expr]) + (case (if (= pos (chytes-length s)) 'eos (chytes-ref/char s pos)) + clause ...))) diff -Nru racket-6.12+ppa1/src/regexp/parse/chyte.rkt racket-7.0+ppa1/src/regexp/parse/chyte.rkt --- racket-6.12+ppa1/src/regexp/parse/chyte.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/chyte.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,37 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; A "chytes" is a string or byte string, and a "chyte" +;; is represented as an integer. + +(provide chyte + chytes-length + chytes-ref + chytes-ref/char + chytes-limit) + +(define-syntax (chyte stx) + (syntax-case stx () + [(_ ch) + (char? (syntax-e #'ch)) + #`(quote #,(char->integer (syntax-e #'ch)))])) + +(define (chytes-length s) + (if (bytes? s) + (bytes-length s) + (string-length s))) + +(define (chytes-ref s i) + (if (bytes? s) + (bytes-ref s i) + (char->integer (string-ref s i)))) + +(define (chytes-ref/char s i) + (if (bytes? s) + (integer->char (bytes-ref s i)) + (string-ref s i))) + +(define (chytes-limit s) + (if (bytes? s) + 255 + #x10FFFF)) diff -Nru racket-6.12+ppa1/src/regexp/parse/class.rkt racket-7.0+ppa1/src/regexp/parse/class.rkt --- racket-6.12+ppa1/src/regexp/parse/class.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/class.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,122 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "../common/range.rkt") + +(provide parse-class + parse-posix-char-class) + +;; returns (values success? range pos) +(define (parse-class s pos config) + ;; We know there's at least one character + (define (success v) (values #t v (add1 pos))) + (chyte-case + (chytes-ref s pos) + [(#\d) (success (range:d))] + [(#\D) (success (range-invert (range:d) (chytes-limit s)))] + [(#\w) (success (range:w))] + [(#\W) (success (range-invert (range:w) (chytes-limit s)))] + [(#\s) (success (range:s))] + [(#\S) (success (range-invert (range:s) (chytes-limit s)))] + [else (values #f #f #f)])) + +(define (range:d) + (range-add-span empty-range (chyte #\0) (chyte #\9))) + +(define (range:w) + (range-add + (range-add-span + (range-add-span + (range:d) + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z)) + (chyte #\_))) + +(define (range:s) + (let* ([r (range-add empty-range (chyte #\space))] + [r (range-add r (chyte #\tab))] + [r (range-add r (chyte #\newline))] + [r (range-add r (chyte #\page))] + [r (range-add r (chyte #\return))]) + r)) + +;; ---------------------------------------- + +;; Returns (values success? range position) +(define (parse-posix-char-class s pos) + (chyte-case/eos + s pos + [(#\:) + (define class + (let loop ([accum null] [pos (add1 pos)]) + (cond + [(= pos (chytes-length s)) #f] + [else + (define c (chytes-ref s pos)) + (cond + [(and (c . >= . (chyte #\a)) (c . <= . (chyte #\z))) + (loop (cons c accum) (add1 pos))] + [(and (= c (chyte #\:)) + ((add1 pos) . < . (chytes-length s)) + (= (chytes-ref s (add1 pos)) (chyte #\]))) + (list->bytes (reverse accum))] + [else #f])]))) + (define range + (case class + [(#"alpha") (range-add-span + (range-add-span + empty-range + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z))] + [(#"upper") (range-add-span + empty-range + (chyte #\A) (chyte #\Z))] + [(#"lower") (range-add-span + empty-range + (chyte #\a) (chyte #\z))] + [(#"digit") (range-add-span + empty-range + (chyte #\0) (chyte #\9))] + [(#"xdigit") (range-add-span + (range-add-span + (range-add-span + empty-range + (chyte #\0) (chyte #\9)) + (chyte #\a) (chyte #\f)) + (chyte #\A) (chyte #\F))] + [(#"alnum") (range-add-span + (range-add-span + (range-add-span + empty-range + (chyte #\0) (chyte #\9)) + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z))] + [(#"word") (range-add + (range-add-span + (range-add-span + empty-range + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z)) + (chyte #\_))] + [(#"blank") (range-add + (range-add empty-range (chyte #\space)) + (chyte #\tab))] + [(#"space") (range:s)] + [(#"graph" #"print") + (define range + (for/fold ([range empty-range]) ([i (in-range 0 128)]) + (if (char-graphic? (integer->char i)) + (range-add range i) + range))) + (if (equal? class #"print") + (range-add + (range-add range (chyte #\space)) + (chyte #\tab)) + range)] + [(#"cntrl") (range-add-span empty-range 0 31)] + [(#"ascii") (range-add-span empty-range 0 127)] + [else #f])) + (if range + (values #t range (+ pos 3 (bytes-length class))) + (values #f #f #f))] + [else (values #f #f #f)])) diff -Nru racket-6.12+ppa1/src/regexp/parse/config.rkt racket-7.0+ppa1/src/regexp/parse/config.rkt --- racket-6.12+ppa1/src/regexp/parse/config.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/config.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,43 @@ +#lang racket/base + +(provide (struct-out parse-config) + make-parse-config + config-case-sensitive + config-multi-line + config-group-number + config-group-number+1) + +(struct parse-config (who + px? + case-sensitive? + multi-line? + group-number-box + references?-box + error-handler?)) + +(define (make-parse-config #:who [who 'regexp] + #:px? [px? #f] + #:error-handler? [error-handler? #f]) + (parse-config who + px? + #t ; case-sensitive? + #f ; multi-line? + (box 0) ; group-number-box + (box #f) ; references?-box + error-handler?)) + +(define (config-case-sensitive config cs?) + (struct-copy parse-config config + [case-sensitive? cs?])) + +(define (config-multi-line config mm?) + (struct-copy parse-config config + [multi-line? mm?])) + +(define (config-group-number config) + (unbox (parse-config-group-number-box config))) + +(define (config-group-number+1 config) + (define b (parse-config-group-number-box config)) + (set-box! b (add1 (unbox b))) + config) diff -Nru racket-6.12+ppa1/src/regexp/parse/error.rkt racket-7.0+ppa1/src/regexp/parse/error.rkt --- racket-6.12+ppa1/src/regexp/parse/error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base +(require "../common/error.rkt") + +(provide parse-error) + +(define (parse-error s pos config fmt . args) + (apply regexp-error fmt args)) diff -Nru racket-6.12+ppa1/src/regexp/parse/main.rkt racket-7.0+ppa1/src/regexp/parse/main.rkt --- racket-6.12+ppa1/src/regexp/parse/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,391 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "ast.rkt" + "config.rkt" + "error.rkt" + "../common/range.rkt" + "class.rkt" + "unicode.rkt" + "range.rkt" + "case.rkt") + +(provide parse) + +(define (parse p #:px? [px? #f]) + (define config (make-parse-config #:px? px?)) + (define-values (rx pos) (parse-regexp p 0 config)) + (values rx + (config-group-number config) + (unbox (parse-config-references?-box config)))) + +;; Returns (values rx position) +(define (parse-regexp s pos config #:parse-regexp [parse-regexp (lambda (s pos config) + (parse-regexp s pos config))]) + (define-values (rxs pos2) (parse-pces s pos config)) + (chyte-case/eos + s pos2 + [(#\|) + (define-values (rx pos3) (parse-regexp s (add1 pos2) config)) + (values (rx-alts (rx-sequence rxs) rx (chytes-limit s)) pos3)] + [else + (values (rx-sequence rxs) pos2)])) + +(define (parse-regexp/maybe-empty s pos config) + (chyte-case/eos + s pos + [(#\)) + (values rx:empty pos)] + [else + (parse-regexp s pos config #:parse-regexp parse-regexp/maybe-empty)])) + +;; Returns (values list-of-rx position) +(define (parse-pces s pos config) + (cond + [(= pos (chytes-length s)) + (values null pos)] + [else + (define-values (rx pos2) (parse-pce s pos config)) + (chyte-case/eos + s pos2 + [(eos) + (values (list rx) pos2)] + [(#\| #\)) + (values (list rx) pos2)] + [else + (define-values (rxs pos3) (parse-pces s pos2 config)) + (values (cons rx rxs) pos3)])])) + +;; Returns (values rx position) +(define (parse-pce s pos config) + (define-values (rx pos2) (parse-atom s pos config)) + (chyte-case/eos + s pos2 + [(#\*) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:repeat rx 0 +inf.0 non-greedy?) pos3)] + [(#\+) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:repeat rx 1 +inf.0 non-greedy?) pos3)] + [(#\?) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:maybe rx non-greedy?) pos3)] + [(#\{) + (cond + [(parse-config-px? config) + (define-values (n1 pos3) (parse-integer 0 s (add1 pos2) config)) + (chyte-case/eos + s pos3 + [(#\,) + (define-values (n2 pos4) (parse-integer 0 s (add1 pos3) config)) + (chyte-case/eos + s pos4 + [(#\}) + (define n2* (if (= pos4 (add1 pos3)) +inf.0 n2)) + (define-values (non-greedy? pos5) (parse-non-greedy s (add1 pos4) config)) + (values (rx:repeat rx n1 n2* non-greedy?) pos5)] + [else + (parse-error s pos3 config "expected digit or `}` to end repetition specification started with `{`")])] + [(#\}) + (define-values (non-greedy? pos4) (parse-non-greedy s (add1 pos3) config)) + (values (rx:repeat rx n1 n1 non-greedy?) pos4)] + [else + (parse-error s pos3 config "expected digit, `,`, or `}' for repetition specification started with `{`")])] + [else + (values rx pos2)])] + [else + (values rx pos2)])) + +(define (parse-non-greedy s pos config) + (chyte-case/eos + s pos + [(#\?) + (values #t (check-not-nested s (add1 pos) config))] + [else + (values #f (check-not-nested s pos config))])) + +(define (check-not-nested s pos config) + (chyte-case/eos + s pos + [(#\? #\* #\+) + (parse-error s pos config + "nested `~a` in patten" + (integer->char (chytes-ref s pos)))] + [(#\{) + (when (parse-config-px? config) + (parse-error s pos config + "nested `{` in pattern"))]) + pos) + +;; Returns (values rx position) +(define (parse-atom s pos config) + ;; Assumes at least one character + (chyte-case + (chytes-ref s pos) + [(#\|) + (values rx:empty pos)] + [(#\() + (parse-parenthesized-atom s (add1 pos) config)] + [(#\[) + (define-values (range pos2) (parse-range/not s (add1 pos) config)) + (values (rx-range range (chytes-limit s)) pos2)] + [(#\.) + (define rx (if (parse-config-multi-line? config) + (rx-range (range-invert (range-add empty-range (chyte #\newline)) + (chytes-limit s)) + (chytes-limit s)) + rx:any)) + (values rx (add1 pos))] + [(#\^) + (values (if (parse-config-multi-line? config) rx:line-start rx:start) + (add1 pos))] + [(#\$) + (values (if (parse-config-multi-line? config) rx:line-end rx:end) + (add1 pos))] + [else + ;; Literal or (for px mode) `\` character class + (parse-literal s pos config)])) + +;; Returns (values rx position) +(define (parse-parenthesized-atom s pos config) + (chyte-case/eos + s pos + [(eos) + (missing-closing-error s pos config)] + [(#\?) + (define pos2 (add1 pos)) + (chyte-case/eos + s pos2 + [(eos) + (bad-?-sequence-error s pos2 config)] + [(#\>) + (define pre-num-groups (config-group-number config)) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (define post-num-groups (config-group-number config)) + (values (rx-cut rx pre-num-groups (- post-num-groups pre-num-groups)) + (check-close-paren s pos3 config))] + [(#\() + (parse-conditional s (add1 pos2) config)] + [(#\i #\s #\m #\- #\:) + (define-values (config2 pos3) (parse-mode s pos2 config)) + (chyte-case/eos + s pos3 + [(#\:) + (define-values (rx pos4) (parse-regexp/maybe-empty s (add1 pos3) config2)) + (values rx (check-close-paren s pos4 config2))] + [else + (parse-error s pos3 config2 (string-append + "expected `:` or another mode after `(?` and a mode sequence;\n" + " a mode is `i`, `-i`, `m`, `-m`, `s`, or `-s`"))])] + [else + (parse-look s pos2 config)])] + [else + (define group-number (config-group-number config)) + (define-values (rx pos2) (parse-regexp/maybe-empty s pos (config-group-number+1 config))) + (values (rx-group rx group-number) + (check-close-paren s pos2 config))])) + +;; Returns (values rx position) +(define (parse-look s pos2 config) + ;; known that one character is available + (define pre-num-groups (config-group-number config)) + (define (span-num-groups) (- (config-group-number config) pre-num-groups)) + (chyte-case + (chytes-ref s pos2) + [(#\=) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (values (rx:lookahead rx #t pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\!) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (values (rx:lookahead rx #f pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\<) + (define pos2+ (add1 pos2)) + (chyte-case/eos + s pos2+ + [(eos) + (bad-?-sequence-error s pos2+ config)] + [(#\=) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2+) config)) + (values (rx:lookbehind rx #t 0 0 pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\!) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2+) config)) + (values (rx:lookbehind rx #f 0 0 pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [else + (bad-?-sequence-error s pos2+ config)])] + [else + (bad-?-sequence-error s pos2 config)])) + +;; Returns (values rx position) +(define (parse-conditional s pos config) + (define tst-pre-num-groups (config-group-number config)) + (define-values (tst pos2) (parse-test s pos config)) + (define tst-span-num-groups (- (config-group-number config) tst-pre-num-groups)) + (define-values (pces pos3) (parse-pces s pos2 config)) + (chyte-case/eos + s pos3 + [(eos) + (missing-closing-error s pos3 config)] + [(#\|) + (define-values (pces2 pos4) (parse-pces s (add1 pos3) config)) + (chyte-case/eos + s pos4 + [(eos) + (missing-closing-error s pos4 config)] + [(#\)) + (values (rx-conditional tst (rx-sequence pces) (rx-sequence pces2) + tst-pre-num-groups tst-span-num-groups) + (add1 pos4))] + [else + (parse-error s pos4 config "expected `)` to close `(?(...)...` after second branch")])] + [(#\)) + (values (rx-conditional tst (rx-sequence pces) rx:empty + tst-pre-num-groups tst-span-num-groups) + (add1 pos3))])) + +;; Returns (values rx position) +(define (parse-test s pos config) + (chyte-case/eos + s pos + [(eos) + (missing-closing-error s pos config)] + [(#\?) + (parse-look s (add1 pos) config)] + [else + (define c (chytes-ref s pos)) + (cond + [(and (>= c (chyte #\0)) (<= c (chyte #\9))) + (set-box! (parse-config-references?-box config) #t) + (define-values (n pos3) (parse-integer 0 s pos config)) + (unless (and (pos3 . < . (chytes-length s)) + (= (chytes-ref s pos3) (chyte #\)))) + (parse-error s pos3 config "expected `)` after `(?(` followed by digits")) + (values (rx:reference n #f) (add1 pos3))] + [else + (parse-error s pos config "expected `(?=`, `(?!`, `(?<`, or digit after `(?(`")])])) + +;; Returns (values n position) +(define (parse-integer n s pos config) + (cond + [(= pos (chytes-length s)) + (values n pos)] + [else + (define c (chytes-ref s pos)) + (cond + [(and (>= c (chyte #\0)) (<= c (chyte #\9))) + (define n2 (+ (* n 10) (- c (chyte #\0)))) + (parse-integer n2 s (add1 pos) config)] + [else + (values n pos)])])) + +;; Returns (values rx position) +(define (parse-literal s pos config) + ;; Assumes at least one character; + ;; we don't get here for `(`, `[`, `.`, `^`, `$`, or `|` + (define c (chytes-ref s pos)) + (chyte-case + c + [(#\* #\+ #\?) + (parse-error s pos config "`~a` follows nothing in pattern" (integer->char c))] + [(#\{) + (cond + [(parse-config-px? config) + (parse-error s pos config "`{` follows nothing in pattern")] + [else (values c (add1 pos))])] + [(#\\) + ;; escaped character + (parse-backslash-literal s (add1 pos) config)] + [(#\)) + (parse-error s pos config "unmatched `)` in pattern")] + [(#\] #\}) + (cond + [(parse-config-px? config) + (parse-error s pos config "unmatched `~a` in pattern" (integer->char c))] + [else (values c (add1 pos))])] + [else + (cond + [(parse-config-case-sensitive? config) + (values c (add1 pos))] + [else + ;; case-insensitive char match + (values (rx-range (range-add* empty-range c config) (chytes-limit s)) + (add1 pos))])])) + +(define (parse-backslash-literal s pos2 config) + (cond + [(= pos2 (chytes-length s)) + ;; An "expected character after `\`" error would make more sense, + ;; but the old expander produced a match against the nul character + (values (chyte #\u0) pos2)] + [else + (define c2 (chytes-ref s pos2)) + (cond + [(and (parse-config-px? config) + (and (>= c2 (chyte #\0)) (<= c2 (chyte #\9)))) + (set-box! (parse-config-references?-box config) #t) + (define-values (n pos3) (parse-integer 0 s pos2 config)) + (values (rx:reference n (parse-config-case-sensitive? config)) pos3)] + [(and (parse-config-px? config) + (or (and (>= c2 (chyte #\a)) (<= c2 (chyte #\z))) + (and (>= c2 (chyte #\A)) (<= c2 (chyte #\Z))))) + (chyte-case + c2 + [(#\p #\P) + (parse-unicode-categories c2 s (add1 pos2) config)] + [(#\b) + (values rx:word-boundary (add1 pos2))] + [(#\B) + (values rx:not-word-boundary (add1 pos2))] + [else + (define-values (success? range pos3) (parse-class s pos2 config)) + (if success? + (values (rx-range range (chytes-limit s)) pos3) + (parse-error s pos2 config "illegal alphabetic escape"))])] + [else + (values c2 (add1 pos2))])])) + +;; Returns (values config position) +(define (parse-mode s pos config) + (chyte-case/eos + s pos + [(eos) + (values config pos)] + [(#\i) + (parse-mode s (add1 pos) (config-case-sensitive config #f))] + [(#\s) + (parse-mode s (add1 pos) (config-multi-line config #f))] + [(#\m) + (parse-mode s (add1 pos) (config-multi-line config #t))] + [(#\-) + (define pos2 (add1 pos)) + (chyte-case/eos + s pos2 + [(eos) + (values config pos)] + [(#\i) + (parse-mode s (add1 pos2) (config-case-sensitive config #t))] + [(#\s) + (parse-mode s (add1 pos2) (config-multi-line config #t))] + [(#\m) + (parse-mode s (add1 pos2) (config-multi-line config #f))] + [else + (values config pos)])] + [else + (values config pos)])) + + +(define (check-close-paren s pos config) + (unless (and (pos . < . (chytes-length s)) + (= (chyte #\)) (chytes-ref s pos))) + (parse-error s pos config "expected a closing `)`")) + (add1 pos)) + +(define (missing-closing-error s pos config) + (parse-error s pos config "missing closing parenthesis in pattern")) + +(define (bad-?-sequence-error s pos config) + (parse-error s pos config + "expected `:`, `=`, `!`, `<=`, `= . (chyte #\a)) (c . <= . (chyte #\z))) + (and (c . >= . (chyte #\A)) (c . <= . (chyte #\Z)))) + (cond + [must-span-from + (parse-error s pos config "misplaced hyphen within square brackets in pattern")] + [else + (define-values (success? range1 pos3) (parse-class s pos2 config)) + (unless success? + (parse-error s pos3 config "illegal alphabetic escape")) + (define range2 (range-union range1 (range-add* range span-from config))) + (parse-range-rest range2 s (add1 pos2) config)])] + [else + (parse-range-rest/span c range s (add1 pos2) config + #:span-from span-from + #:must-span-from must-span-from)])])] + [else + (parse-range-rest/span (chyte #\\) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])] + [(#\[) + (define-values (success? range1 pos2) + (cond + [(and (parse-config-px? config) + (not must-span-from)) + (parse-posix-char-class s (add1 pos))] + [else + (values #f #f #f)])) + (cond + [success? + (define range2 (range-union range1 (range-add* range span-from config))) + (parse-range-rest range2 s pos2 config)] + [else + (parse-range-rest/span (chyte #\[) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])] + [else + (parse-range-rest/span (chytes-ref s pos) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])) + +(define (parse-range-rest/span c range s pos config + #:span-from span-from + #:must-span-from must-span-from) + (cond + [must-span-from + (cond + [(must-span-from . > . c) + (parse-error s pos config "invalid range within square brackets in pattern")] + [else + (parse-range-rest (range-add-span* range must-span-from c config) s pos config)])] + [else + (parse-range-rest (range-add* range span-from config) s pos config + #:span-from c)])) + +(define (missing-square-closing-error s pos config) + (parse-error s pos config "missing closing square bracket in pattern")) + +(define (misplaced-hyphen-error s pos config) + (parse-error s pos config "misplaced hyphen within square brackets in pattern")) diff -Nru racket-6.12+ppa1/src/regexp/parse/unicode.rkt racket-7.0+ppa1/src/regexp/parse/unicode.rkt --- racket-6.12+ppa1/src/regexp/parse/unicode.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/parse/unicode.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,75 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "ast.rkt" + "config.rkt" + "error.rkt") + +(provide parse-unicode-categories) + +(define (parse-unicode-categories p-c s pos config) + (chyte-case/eos + s pos + [(#\{) + (define-values (l pos2) + (let loop ([accum null] [pos (add1 pos)]) + (chyte-case/eos + s pos + [(eos) + (parse-error s pos config + "missing `}` to close `\\~a{`" + (integer->char p-c))] + [(#\}) (values (reverse accum) (add1 pos))] + [else + (loop (cons (chytes-ref s pos) accum) (add1 pos))]))) + (define categories + (case (list->bytes l) + [(#"Ll") 'll] + [(#"Lu") 'lu] + [(#"Lt") 'lt] + [(#"Lm") 'lm] + [(#"L&") '(ll lu lt lm)] + [(#"Lo") 'lo] + [(#"L") '(ll lu lt lm lo)] + [(#"Nd") 'nd] + [(#"Nl") 'nl] + [(#"No") 'no] + [(#"N") '(nd nl no)] + [(#"Ps") 'ps] + [(#"Pe") 'pe] + [(#"Pi") 'pi] + [(#"Pf") 'pf] + [(#"Pc") 'pc] + [(#"Pd") 'pd] + [(#"Po") 'po] + [(#"P") '(ps pe pi pf pc pd po)] + [(#"Mn") 'mn] + [(#"Mc") 'mc] + [(#"Me") 'me] + [(#"M") '(mn mc me)] + [(#"Sc") 'sc] + [(#"Sk") 'sk] + [(#"Sm") 'sm] + [(#"So") 'so] + [(#"S") '(sc sk sm so)] + [(#"Zl") 'zl] + [(#"Zp") 'zp] + [(#"Zs") 'zs] + [(#"Z") '(zl zp zs)] + [(#"Cc") 'cc] + [(#"Cf") 'cf] + [(#"Cs") 'cs] + [(#"Cn") 'cn] + [(#"Co") 'co] + [(#"C") '(cc cf cs cn so)] + [(#".") #t] + [else (parse-error s pos2 config + "unrecognized property name in `\\~a{}`: `~a`" + (integer->char p-c) + (list->string (map integer->char l)))])) + (values (rx:unicode-categories categories (= p-c (char->integer #\p))) + pos2)] + [else + (parse-error s pos config + "expected `{` after `\\~a`" + (integer->char p-c))])) diff -Nru racket-6.12+ppa1/src/regexp/README.txt racket-7.0+ppa1/src/regexp/README.txt --- racket-6.12+ppa1/src/regexp/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,3 @@ +This regexp implementation can be run in a host Racket with `make +demo`, but it's meant to be compiled for use in Racket on Chez Scheme; +see "../cs/README.txt". diff -Nru racket-6.12+ppa1/src/regexp/replace/chyte.rkt racket-7.0+ppa1/src/regexp/replace/chyte.rkt --- racket-6.12+ppa1/src/regexp/replace/chyte.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/replace/chyte.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +#lang racket/base + +(provide chytes-ref + subchytes + chytes-append + chytes? + chytes-length) + +(define (chytes-ref s pos) + (if (bytes? s) + (bytes-ref s pos) + (char->integer (string-ref s pos)))) + +(define (subchytes s a [b #f]) + (if (bytes? s) + (subbytes s a (or b (bytes-length s))) + (substring s a (or b (string-length s))))) + +(define chytes-append + (case-lambda + [(a) a] + [(a b) (if (bytes? a) + (bytes-append a b) + (string-append a b))] + [(a b c) (if (bytes? a) + (bytes-append a b c) + (string-append a b c))] + [(a . l) (if (bytes? a) + (apply bytes-append a l) + (apply string-append a l))])) + +(define (chytes? ex v) + (if (bytes? ex) + (bytes? v) + (string? v))) + +(define (chytes-length s) + (if (bytes? s) + (bytes-length s) + (string-length s))) + + diff -Nru racket-6.12+ppa1/src/regexp/replace/main.rkt racket-7.0+ppa1/src/regexp/replace/main.rkt --- racket-6.12+ppa1/src/regexp/replace/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/regexp/replace/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,140 @@ +#lang racket/base +(require "../match/regexp.rkt" + "../match/main.rkt" + "chyte.rkt") + +(provide regexp-replace + regexp-replace*) + +(define (regexp-replace rx orig-in insert [prefix #""]) + (do-regexp-replace 'regexp-replace rx orig-in insert prefix #f)) + +(define (regexp-replace* rx orig-in insert [prefix #""]) + (do-regexp-replace 'regexp-replace* rx orig-in insert prefix #t)) + +(define (do-regexp-replace who rx-in orig-in insert prefix all?) + (define string-mode? + (and (or (string? rx-in) (regexp? rx-in)) + (string? orig-in))) + (define in (if (and (not string-mode?) + (string? orig-in)) + (string->bytes/utf-8 orig-in) + orig-in)) + + (when (or string-mode? + (and (or (bytes? rx-in) (byte-regexp? rx-in)) + (or (string? orig-in) (bytes? orig-in)))) + (unless (or (string? insert) + (bytes? insert) + (procedure? insert)) + (raise-argument-error who "(or/c string? bytes? procedure?)" insert))) + + (when string-mode? + (when (bytes? insert) + (raise-arguments-error who + "cannot replace a string with a byte string" + "byte string" insert))) + + (define rx (cond + [(string? rx-in) (make-regexp who rx-in #f #f #f)] + [(bytes? rx-in) (make-regexp who rx-in #f #t #f)] + [else rx-in])) + + (define ins (if (and (not string-mode?) + (string? insert)) + (string->bytes/utf-8 insert) + insert)) + + (let loop ([search-pos 0]) + (define poss + (drive-regexp-match who rx in 0 #:search-offset search-pos #f #f prefix + #:in-port-ok? #f + #:in-path-ok? #f + #:mode 'positions)) + + (define (recur) + (define pos (cdar poss)) + (cond + [(= pos search-pos) + (if (= search-pos (chytes-length in)) + (subchytes in 0 0) + (chytes-append (subchytes in search-pos (add1 search-pos)) + (loop (add1 search-pos))))] + [else (loop (cdar poss))])) + + (cond + [(not poss) (cond + [(zero? search-pos) in] + [else (subchytes in search-pos)])] + [else + (chytes-append (subchytes in search-pos (caar poss)) + (replacements who in poss ins) + (if all? + (recur) + (subchytes in (cdar poss))))]))) + +;; ---------------------------------------- + +(define (replacements who in poss insert) + (cond + [(procedure? insert) + (define a (apply insert + (for/list ([pos (in-list poss)]) + (subchytes in (car pos) (cdr pos))))) + (unless (chytes? in a) + (raise-result-error who (if (bytes? in) "bytes?" "string?") a)) + a] + + [else + (define count (length poss)) + + (define (get-chytes n) + (cond + [(n . < . count) + (define pos (list-ref poss n)) + (subchytes in (car pos) (cdr pos))] + [else (subchytes in 0 0)])) + + (define (cons-chytes since pos l) + (if (= since pos) + l + (cons (subchytes insert since pos) l))) + + (define len (chytes-length insert)) + (apply (if (bytes? insert) + bytes-append + string-append) + (let loop ([pos 0] [since 0]) + (cond + [(= pos len) + (cons-chytes since pos null)] + [(= (char->integer #\&) (chytes-ref insert pos)) + (cons-chytes since pos + (cons (get-chytes 0) + (loop (add1 pos) (add1 pos))))] + [(= (char->integer #\\) (chytes-ref insert pos)) + (cons-chytes + since pos + (let ([c (and ((add1 pos) . < . len) + (chytes-ref insert (add1 pos)))]) + (cond + [(or (eq? c (char->integer #\&)) + (eq? c (char->integer #\\))) + (loop (+ pos 2) (add1 pos))] + [(eq? c (char->integer #\$)) + (loop (+ pos 2) (+ pos 2))] + [else + (let d-loop ([pos (add1 pos)] [accum 0]) + (cond + [(= pos len) + (list (get-chytes accum))] + [else + (define c (chytes-ref insert pos)) + (if (and (>= c (char->integer #\0)) + (<= c (char->integer #\9))) + (d-loop (add1 pos) (+ (* accum 10) + (- c (char->integer #\0)))) + (cons (get-chytes accum) + (loop pos pos)))]))])))] + [else + (loop (add1 pos) since)])))])) diff -Nru racket-6.12+ppa1/src/rktio/configure racket-7.0+ppa1/src/rktio/configure --- racket-6.12+ppa1/src/rktio/configure 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/configure 2018-07-27 22:12:02.000000000 +0000 @@ -2274,6 +2274,8 @@ fi skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no # For standalone builds: rktio_version=1.0 @@ -4265,6 +4267,9 @@ ############## final output ################ +CPPFLAGS="$CPPFLAGS $PREFLAGS" + + diff -Nru racket-6.12+ppa1/src/rktio/configure.ac racket-7.0+ppa1/src/rktio/configure.ac --- racket-6.12+ppa1/src/rktio/configure.ac 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/configure.ac 2018-07-27 22:12:02.000000000 +0000 @@ -20,6 +20,8 @@ fi skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no # For standalone builds: rktio_version=1.0 @@ -388,7 +390,10 @@ ############## final output ################ +CPPFLAGS="$CPPFLAGS $PREFLAGS" + AC_SUBST(CC) +AC_SUBST(CPPFLAGS) AC_SUBST(CFLAGS) AC_SUBST(LDFLAGS) AC_SUBST(LIBS) diff -Nru racket-6.12+ppa1/src/rktio/Makefile.in racket-7.0+ppa1/src/rktio/Makefile.in --- racket-6.12+ppa1/src/rktio/Makefile.in 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/Makefile.in 2018-07-27 22:12:02.000000000 +0000 @@ -136,6 +136,24 @@ # ---------------------------------------- +# To rebuild the S-expression form of "rktio.h" + +rktio-rktl rktio-inc rktio-def: + $(MAKE) $(srcdir)/rktio.rktl + $(MAKE) $(srcdir)/rktio.inc + $(MAKE) $(srcdir)/rktio.def + +$(srcdir)/rktio.rktl: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -o $(srcdir)/rktio.rktl $(srcdir)/rktio.h + +$(srcdir)/rktio.inc: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -c -o $(srcdir)/rktio.inc $(srcdir)/rktio.h + +$(srcdir)/rktio.def: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -d -o $(srcdir)/rktio.def $(srcdir)/rktio.h + +# ---------------------------------------- + @HIDE_NOT_STANDALONE@librktio: $(MAKE) librktio.@LIBSFX@ @@ -148,7 +166,3 @@ $(MAKE) librktio.@LIBSFX@ mkdir -p "$(DESTDIR)$(libdir)/" $(ICP_LIB) librktio.@LIBSFX@ "$(DESTDIR)$(libdir)/librktio.@LIBSFX@" - -# Builds an S-expression form of "rktio.h" -rktio.rktl: $(srcdir)/rktio.h $(srcdir)/parse.rkt - $(RACKET) $(srcdir)/parse.rkt -o rktio.rktl $(srcdir)/rktio.h diff -Nru racket-6.12+ppa1/src/rktio/parse.rkt racket-7.0+ppa1/src/rktio/parse.rkt --- racket-6.12+ppa1/src/rktio/parse.rkt 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/parse.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -28,12 +28,18 @@ ;; | (*ref ) ; transparent argument, can be represented by a byte string (define output-file #f) +(define c-mode? #f) +(define .def-mode? #f) (define input-file (command-line #:once-each [("-o") file "Write output to " (set! output-file file)] + [("-c") "Generate foreign-symbol registration" + (set! c-mode? #t)] + [("-d") "Generate .def file" + (set! .def-mode? #t)] #:args (file) file)) @@ -46,7 +52,7 @@ OPEN CLOSE COPEN CCLOSE SEMI COMMA STAR LSHIFT EQUAL __RKTIO_H__ EXTERN EXTERN/NOERR EXTERN/STEP EXTERN/ERR DEFINE TYPEDEF ENUM STRUCT VOID UNSIGNED SHORT INT - CONST NULLABLE)) + CONST NULLABLE BLOCKING)) (define lex (lexer-src-pos @@ -75,6 +81,7 @@ ["RKTIO_EXTERN_STEP" 'EXTERN/STEP] ["RKTIO_EXTERN_ERR" 'EXTERN/ERR] ["RKTIO_NULLABLE" 'NULLABLE] + ["RKTIO_BLOCKING" 'BLOCKING] [(:seq (:or #\_ (:/ #\A #\Z #\a #\z)) (:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9)))) (token-ID (string->symbol lexeme))] @@ -109,6 +116,7 @@ [(DEFINE EXTERN/STEP EXTERN) #f] [(DEFINE EXTERN/ERR OPEN ID CLOSE EXTERN) #f] [(DEFINE NULLABLE) #f] + [(DEFINE BLOCKING) #f] [(STRUCT ID SEMI) #f] [(TYPEDEF SEMI) (if (eq? $2 $3) @@ -118,15 +126,17 @@ (if (eq? $2 $5) `(define-struct-type ,$2 ,$4) (error 'parse "typedef struct names don't match at ~s" $5))] - [( OPEN SEMI) - (let ([r-type (shift-stars $3 $2)] - [id (unstar $3)]) - `(,@(adjust-errno $1 r-type id) ,r-type ,id ,$5))] + [( OPEN SEMI) + (let ([r-type (shift-stars $4 $3)] + [id (unstar $4)]) + `(,@(adjust-errno $1 r-type id) ,$2 ,r-type ,id ,$6))] [(ENUM COPEN SEMI) `(begin . ,(enum-definitions $3))]) ( [(EXTERN) 'define-function/errno] [(EXTERN/STEP) 'define-function/errno+step] [(EXTERN/NOERR) 'define-function] [(EXTERN/ERR OPEN ID CLOSE) `(define-function/errno ,$3)]) + ( [(BLOCKING) '(blocking)] + [() '()]) ( [(VOID CLOSE) null] [() $1]) ( [( CLOSE) `((,(shift-stars $2 $1) ,(unstar $2)))] @@ -264,11 +274,11 @@ (define (update-types e) (match e - [`(,def ,ret ,name ,args) - `(,def ,(update-type ret) ,name + [`(,def ,flags ,ret ,name ,args) + `(,def ,flags ,(update-type ret) ,name ,(map (lambda (a) (update-bind a #:as-argument? #t)) args))] - [`(,def ,err-val ,ret ,name ,args) - `(,def ,err-val ,(update-type ret) ,name + [`(,def ,err-val ,flags ,ret ,name ,args) + `(,def ,err-val ,flags ,(update-type ret) ,name ,(map (lambda (a) (update-bind a #:as-argument? #t)) args))] [else e])) @@ -286,16 +296,41 @@ (filter (lambda (e) (not (or (constant-defn? e) (type-defn? e)))) unsorted-content)))) +(define (function-definition? e) + (and (pair? e) + (or (eq? 'define-function (car e)) + (eq? 'define-function/errno (car e)) + (eq? 'define-function/errno+step (car e))))) + (define (show-content) - (printf "(begin\n") - (for ([e (in-list content)] - #:when e) - (pretty-write e)) - (printf ")\n")) + (cond + [c-mode? + (for ([e (in-list content)] + #:when (function-definition? e)) + (define n (list-ref e (- (length e) 2))) + (printf "Sforeign_symbol(~s, (void *)~a);\n" (symbol->string n) n))] + [.def-mode? + (for ([e (in-list content)] + #:when (function-definition? e)) + (define n (list-ref e (- (length e) 2))) + (printf "~a\n" n))] + [else + (printf "(begin\n") + (for ([e (in-list content)] + #:when e) + (pretty-write e)) + (printf ")\n")])) (if output-file (with-output-to-file output-file #:exists 'truncate - (lambda () (show-content))) + (lambda () + (cond + [c-mode? + (printf "/* Extracted from rktio.h by rktio/parse.rkt */\n")] + [.def-mode? + (printf "EXPORTS\n")] + [else + (printf ";; Extracted from rktio.h by rktio/parse.rkt\n")]) + (show-content))) (show-content)) - diff -Nru racket-6.12+ppa1/src/rktio/rktio_convert.c racket-7.0+ppa1/src/rktio/rktio_convert.c --- racket-6.12+ppa1/src/rktio/rktio_convert.c 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_convert.c 2018-07-27 22:12:02.000000000 +0000 @@ -70,16 +70,24 @@ static void init_iconv() { - HMODULE m; + HMODULE m = NULL; wchar_t *p; - - p = rktio_get_dll_path(L"iconv.dll"); - if (p) { - m = LoadLibraryW(p); - free(p); - } else - m = NULL; - + int hook_handle = 0; + + /* Try embedded "libiconv-2.dll", first: */ + m = rktio_load_library("libiconv-2.dll"); + if (m) + hook_handle = 1; + + if (!m) { + p = rktio_get_dll_path(L"iconv.dll"); + if (p) { + m = LoadLibraryW(p); + free(p); + } else + m = NULL; + } + if (!m) { p = rktio_get_dll_path(L"libiconv.dll"); if (p) { @@ -106,10 +114,17 @@ m = LoadLibraryW(L"libiconv-2.dll"); if (m) { - iconv = (iconv_proc_t)GetProcAddress(m, "libiconv"); - iconv_open = (iconv_open_proc_t)GetProcAddress(m, "libiconv_open"); - iconv_close = (iconv_close_proc_t)GetProcAddress(m, "libiconv_close"); - locale_charset = (locale_charset_proc_t)GetProcAddress(m, "locale_charset"); + if (hook_handle) { + iconv = (iconv_proc_t)rktio_get_proc_address(m, "libiconv"); + iconv_open = (iconv_open_proc_t)rktio_get_proc_address(m, "libiconv_open"); + iconv_close = (iconv_close_proc_t)rktio_get_proc_address(m, "libiconv_close"); + locale_charset = (locale_charset_proc_t)rktio_get_proc_address(m, "locale_charset"); + } else { + iconv = (iconv_proc_t)GetProcAddress(m, "libiconv"); + iconv_open = (iconv_open_proc_t)GetProcAddress(m, "libiconv_open"); + iconv_close = (iconv_close_proc_t)GetProcAddress(m, "libiconv_close"); + locale_charset = (locale_charset_proc_t)GetProcAddress(m, "locale_charset"); + } /* Make sure we have all of them or none: */ if (!iconv || !iconv_open || !iconv_close) { iconv = NULL; @@ -119,7 +134,10 @@ } if (iconv) { - iconv_errno = (errno_proc_t)GetProcAddress(m, "_errno"); + if (hook_handle) + iconv_errno = (errno_proc_t)rktio_get_proc_address(m, "_errno"); + else + iconv_errno = (errno_proc_t)GetProcAddress(m, "_errno"); if (!iconv_errno) { /* The iconv.dll distributed with Racket links to msvcrt.dll. It's a slighly dangerous assumption that whatever iconv we @@ -261,7 +279,7 @@ int len, j; char *enc; i++; - len = scheme_char_strlen(current_locale_name) - i; + len = strlen(current_locale_name) - i; enc = malloc(2 + len + 1); /* Check whether the encoding is numeric, in which case @@ -349,7 +367,7 @@ llen = GetLocaleInfoW(l, LOCALE_SENGLANGUAGE, NULL, 0); lang = malloc(llen * sizeof(wchar_t)); - GetLocaleInfo(l, LOCALE_SENGLANGUAGE, lang, llen); + GetLocaleInfoW(l, LOCALE_SENGLANGUAGE, lang, llen); if (llen) llen -= 1; /* drop nul terminator */ diff -Nru racket-6.12+ppa1/src/rktio/rktio.def racket-7.0+ppa1/src/rktio/rktio.def --- racket-6.12+ppa1/src/rktio/rktio.def 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio.def 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,192 @@ +EXPORTS +rktio_init +rktio_destroy +rktio_free +rktio_set_dll_path +rktio_get_dll_path +rktio_system_fd +rktio_fd_system_fd +rktio_fd_is_regular_file +rktio_fd_is_directory +rktio_fd_is_socket +rktio_fd_is_udp +rktio_fd_is_terminal +rktio_fd_is_text_converted +rktio_fd_modes +rktio_open +rktio_close +rktio_close_noerr +rktio_dup +rktio_forget +rktio_std_fd +rktio_read +rktio_write +rktio_read_converted +rktio_read_in +rktio_write_in +rktio_buffered_byte_count +rktio_poll_read_ready +rktio_poll_write_ready +rktio_poll_write_flushed +rktio_file_lock_try +rktio_file_unlock +rktio_set_file_position +rktio_get_file_position +rktio_set_file_size +rktio_make_pipe +rktio_start_addrinfo_lookup +rktio_get_ipv4_family +rktio_poll_addrinfo_lookup_ready +rktio_addrinfo_lookup_get +rktio_addrinfo_lookup_stop +rktio_addrinfo_free +rktio_listen +rktio_listen_stop +rktio_poll_accept_ready +rktio_accept +rktio_start_connect +rktio_connect_finish +rktio_connect_stop +rktio_poll_connect_ready +rktio_connect_trying +rktio_socket_shutdown +rktio_udp_open +rktio_udp_disconnect +rktio_udp_bind +rktio_udp_connect +rktio_udp_sendto +rktio_udp_sendto_in +rktio_udp_recvfrom +rktio_udp_recvfrom_in +rktio_udp_get_multicast_loopback +rktio_udp_set_multicast_loopback +rktio_udp_get_multicast_ttl +rktio_udp_set_multicast_ttl +rktio_udp_multicast_interface +rktio_udp_set_multicast_interface +rktio_udp_change_multicast_group +rktio_socket_address +rktio_socket_peer_address +rktio_listener_address +rktio_is_ok_envvar_name +rktio_are_envvar_names_case_insensitive +rktio_getenv +rktio_setenv +rktio_envvars +rktio_empty_envvars +rktio_envvars_copy +rktio_envvars_free +rktio_envvars_get +rktio_envvars_set +rktio_envvars_count +rktio_envvars_name_ref +rktio_envvars_value_ref +rktio_process +rktio_process_allowed_flags +rktio_process_pid +rktio_process_kill +rktio_process_interrupt +rktio_process_forget +rktio_poll_process_done +rktio_process_status +rktio_reap_processes +rktio_fs_change_properties +rktio_fs_change +rktio_fs_change_forget +rktio_poll_fs_change_ready +rktio_make_poll_set +rktio_poll_set_forget +rktio_poll_add +rktio_poll_add_accept +rktio_poll_add_connect +rktio_poll_add_addrinfo_lookup +rktio_poll_add_process +rktio_poll_add_fs_change +rktio_poll_set_add_nosleep +rktio_poll_set_add_handle +rktio_poll_set_add_eventmask +rkio_reset_sleep_backoff +rktio_ltps_open +rktio_ltps_close +rktio_ltps_add +rktio_ltps_handle_set_data +rktio_ltps_handle_get_data +rktio_ltps_remove_all +rktio_ltps_poll +rktio_ltps_get_signaled_handle +rktio_ltps_handle_set_auto +rktio_sleep +rktio_start_sleep +rktio_end_sleep +rktio_file_exists +rktio_directory_exists +rktio_link_exists +rktio_is_regular_file +rktio_delete_file +rktio_rename_file +rktio_get_current_directory +rktio_set_current_directory +rktio_make_directory +rktio_delete_directory +rktio_readlink +rktio_make_link +rktio_file_size +rktio_get_file_modify_seconds +rktio_set_file_modify_seconds +rktio_fd_identity +rktio_path_identity +rktio_get_file_or_directory_permissions +rktio_set_file_or_directory_permissions +rktio_directory_list_start +rktio_directory_list_step +rktio_directory_list_stop +rktio_filesystem_roots +rktio_copy_file_start +rktio_copy_file_is_done +rktio_copy_file_step +rktio_copy_file_finish_permissions +rktio_copy_file_stop +rktio_system_path +rktio_expand_user_tilde +rktio_get_signal_handle +rktio_signal_received_at +rktio_signal_received +rktio_wait_until_signal_received +rktio_flush_signals_received +rktio_install_os_signal_handler +rktio_poll_os_signal +rktio_get_milliseconds +rktio_get_inexact_milliseconds +rktio_get_process_milliseconds +rktio_get_process_children_milliseconds +rktio_get_seconds +rktio_seconds_to_date +rktio_shell_execute +rktio_path_to_wide_path +rktio_wide_path_to_path +rktio_syslog +rktio_convert_properties +rktio_converter_open +rktio_converter_close +rktio_convert +rktio_convert_in +rktio_locale_recase +rktio_recase_utf16 +rktio_locale_strcoll +rktio_strcoll_utf16 +rktio_locale_encoding +rktio_set_locale +rktio_push_c_numeric_locale +rktio_pop_c_numeric_locale +rktio_system_language_country +rktio_dll_open +rktio_dll_find_object +rktio_dll_get_error +rktio_get_last_error_kind +rktio_get_last_error +rktio_get_last_error_step +rktio_set_last_error +rktio_set_last_error_step +rktio_remap_last_error +rktio_get_last_error_string +rktio_get_error_string diff -Nru racket-6.12+ppa1/src/rktio/rktio_dll.c racket-7.0+ppa1/src/rktio/rktio_dll.c --- racket-6.12+ppa1/src/rktio/rktio_dll.c 2017-10-12 18:23:27.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_dll.c 2018-07-27 22:12:02.000000000 +0000 @@ -20,10 +20,15 @@ #ifdef RKTIO_SYSTEM_WINDOWS typedef HANDLE dll_handle_t; +static dll_open_proc LoadLibraryHook; +static dll_find_object_proc GetProcAddressHook; #endif struct rktio_dll_t { void *handle; +#ifdef RKTIO_SYSTEM_WINDOWS + int hook_handle; +#endif char *name; rktio_hash_t *objects_by_name; rktio_dll_object_t *all_objects; @@ -38,7 +43,10 @@ intptr_t key; dll_handle_t handle; int null_ok = 0; - +#ifdef RKTIO_SYSTEM_WINDOWS + int hook_handle = 0; +#endif + if (!rktio->dlls_by_name) rktio->dlls_by_name = rktio_hash_new(); @@ -76,13 +84,21 @@ #ifdef RKTIO_SYSTEM_WINDOWS if (!name) { - /* openning the executable is marked by a NULL handle */ + /* opening the executable is marked by a NULL handle */ handle = NULL; null_ok = 1; } else { - handle = LoadLibraryW(WIDE_PATH_temp(name)); - if (!handle) - get_windows_error(); + if (LoadLibraryHook) + handle = LoadLibraryHook(name, as_global); + else + handle = NULL; + if (handle) { + hook_handle = 1; + } else { + handle = LoadLibraryW(WIDE_PATH_temp(name)); + if (!handle) + get_windows_error(); + } } #endif @@ -91,6 +107,9 @@ dll = malloc(sizeof(rktio_dll_t)); dll->handle = handle; +#ifdef RKTIO_SYSTEM_WINDOWS + dll->hook_handle = hook_handle; +#endif dll->name = (name ? MSC_IZE(strdup)(name) : NULL); dll->objects_by_name = rktio_hash_new(); dll->all_objects = NULL; @@ -236,9 +255,12 @@ #endif #ifdef RKTIO_SYSTEM_WINDOWS - if (dll->handle) - address = GetProcAddress(dll->handle, name); - else { + if (dll->handle) { + if (dll->hook_handle) + address = GetProcAddressHook(dll->handle, name); + else + address = GetProcAddress(dll->handle, name); + } else { /* this is for the executable-open case, which was marked by a NULL * handle; deal with it by searching all current modules */ # define NUM_QUICK_MODS 16 @@ -266,6 +288,8 @@ address = NULL; if (mods != quick_mods) free(mods); + if (!address && GetProcAddressHook) + address = GetProcAddressHook(NULL, name); } if (!address) { @@ -320,6 +344,34 @@ } /*========================================================================*/ +/* Windows hooks */ +/*========================================================================*/ + +/* Support in-memory DLLs and similar by allowing the application to + install replacements for LoadLibrary and GetProcAddress. */ + +void rktio_set_dll_procs(dll_open_proc dll_open, dll_find_object_proc dll_find_object) +{ +#ifdef RKTIO_SYSTEM_WINDOWS + LoadLibraryHook = dll_open; + GetProcAddressHook = dll_find_object; +#endif +} + +#ifdef RKTIO_SYSTEM_WINDOWS +HANDLE rktio_load_library(rktio_const_string_t name) +{ + if (!LoadLibraryHook) return NULL; + return (HANDLE)LoadLibraryHook(name, 1); +} + +void *rktio_get_proc_address(HANDLE m, rktio_const_string_t name) +{ + return GetProcAddressHook((void *)m, name); +} +#endif + +/*========================================================================*/ /* Clean up */ /*========================================================================*/ diff -Nru racket-6.12+ppa1/src/rktio/rktio_fd.c racket-7.0+ppa1/src/rktio/rktio_fd.c --- racket-6.12+ppa1/src/rktio/rktio_fd.c 2017-10-20 12:42:03.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_fd.c 2018-07-27 22:12:02.000000000 +0000 @@ -39,9 +39,12 @@ struct Win_FD_Input_Thread *th; /* input mode */ struct Win_FD_Output_Thread *oth; /* output mode */ int unblocked; /* whether non-blocking mode is installed */ + int write_limit; /* non-0 => max on amount to try writing */ char *buffer; /* shared with reading thread */ int has_pending_byte; /* for text-mode input, may be dropped by a following lf */ int pending_byte; /* for text-mode input, either a CR waiting to decode, or byte that didn't fit */ + int leftover_len; /* for bytes that should be written, but that form a UTF-8 encoding prefix */ + char leftover[6]; #endif }; @@ -128,6 +131,11 @@ static const char *adjust_output_text(const char *buffer, intptr_t *towrite); static intptr_t recount_output_text(const char *orig_buffer, const char *buffer, intptr_t wrote); +static wchar_t *convert_output_wtext(const char *buffer, intptr_t *_towrite, + int *_can_leftover, int *_keep_leftover, + int leftover_len, char *leftover); +static intptr_t recount_output_wtext(wchar_t *w_buffer, intptr_t winwrote); + #endif /*========================================================================*/ @@ -1020,15 +1028,21 @@ static long WINAPI WindowsFDReader(Win_FD_Input_Thread *th) { DWORD toget, got; - int perma_eof = 0; + int perma_eof = 0, ft, is_console = 0; HANDLE eof_wait = NULL; +# define CONSOLE_BUFFER_IN_SIZE 16 + wchar_t w_buffer[CONSOLE_BUFFER_IN_SIZE]; + int w_buf_count = 0; - if (GetFileType((HANDLE)th->fd) == FILE_TYPE_PIPE) { + ft = GetFileType((HANDLE)th->fd); + + if (ft == FILE_TYPE_PIPE) { /* Reading from a pipe will return early when data is available. */ toget = RKTIO_FD_BUFFSIZE; } else { /* Non-pipe: get one char at a time: */ toget = 1; + is_console = (ft == FILE_TYPE_CHAR); } while (!perma_eof && !th->err) { @@ -1043,8 +1057,39 @@ /* Spurious wake-up? */ ReleaseSemaphore(th->lock_sema, 1, NULL); } else { + int ok; ReleaseSemaphore(th->lock_sema, 1, NULL); - if (ReadFile(th->fd, th->buffer, toget, &got, NULL)) { + if (!is_console) + ok = ReadFile(th->fd, th->buffer, toget, &got, NULL); + else { + if (w_buf_count) { + ok = 1; + got = w_buf_count; + } else + ok = ReadConsoleW(th->fd, w_buffer, CONSOLE_BUFFER_IN_SIZE, &got, NULL); + if (ok) { + /* check for Ctl-Z, and convert it to an EOF */ + int i, move_start = 0, move_len = 0; + for (i = 0; i < got; i++) { + if (w_buffer[i] == 26 /* ctl-z */) { + move_start = i; + move_len = got - i; + if (i == 0) { + /* report EOF now */ + move_start++; + move_len--; + } + got = i; + break; + } + } + got = WideCharToMultiByte(CP_UTF8, 0, w_buffer, got, th->buffer, RKTIO_FD_BUFFSIZE, NULL, 0); + if (move_len > 0) + memmove(w_buffer, w_buffer + move_start, sizeof(wchar_t) * move_len); + w_buf_count = move_len; + } + } + if (ok) { WaitForSingleObject(th->lock_sema, INFINITE); th->avail = got; th->offset = 0; @@ -1167,23 +1212,46 @@ if (rktio_fd_is_regular_file(rktio, rfd) || rktio_fd_is_terminal(rktio, rfd)) { /* Regular files never block, so this code looks like the Unix - code. */ + code. */ /* If we try to write too much at once, the result is ERROR_NOT_ENOUGH_MEMORY (as opposed to a partial write). */ - int ok; + int ok, to_console, can_leftover = 0, keep_leftover = 0; intptr_t towrite = len; const char *orig_buffer = buffer; + wchar_t *w_buffer = NULL; + DWORD max_winwrote; int err; if (rfd->modes & RKTIO_OPEN_TEXT) buffer = adjust_output_text(buffer, &towrite); + + max_winwrote = towrite; + + to_console = rktio_fd_is_terminal(rktio, rfd); + if (to_console) { + /* Decode UTF-8 and write a chunk on a character boundary. */ + w_buffer = convert_output_wtext(buffer, &towrite, + &can_leftover, &keep_leftover, + rfd->leftover_len, rfd->leftover); + } while (1) { - ok = WriteFile((HANDLE)rfd->fd, buffer, towrite, &winwrote, NULL); + if (!to_console) + ok = WriteFile((HANDLE)rfd->fd, buffer, towrite, &winwrote, NULL); + else { + if (towrite) + ok = WriteConsoleW((HANDLE)rfd->fd, w_buffer, towrite, &winwrote, NULL); + else { + /* can happend if can_leftover is > 0 */ + ok = 1; + winwrote = 0; + } + } + if (!ok) err = GetLastError(); - + if (!ok && (err == ERROR_NOT_ENOUGH_MEMORY)) { towrite = towrite >> 1; if (towrite && (buffer != orig_buffer)) { @@ -1204,6 +1272,30 @@ return RKTIO_WRITE_ERROR; } + if (to_console) { + /* Convert wchar count to byte count, taking into account leftovers */ + int wrote_all = (winwrote == towrite); + if (winwrote) { + /* Recounting only works right if the outptu was well-formed + UTF-8. Weird things happen otherwise... but we guard against + external inconsistency with the `max_winwrote` check below. */ + winwrote = recount_output_wtext(w_buffer, winwrote); + if (winwrote > rfd->leftover_len) + winwrote -= rfd->leftover_len; + else + winwrote = 0; + rfd->leftover_len = 0; + } + if (wrote_all && can_leftover) { + memcpy(rfd->leftover + keep_leftover, buffer + max_winwrote - can_leftover, can_leftover); + rfd->leftover_len = can_leftover + keep_leftover; + winwrote += can_leftover; + } + free(w_buffer); + if (winwrote > max_winwrote) + winwrote = max_winwrote; + } + if (buffer != orig_buffer) { /* Convert converted count back to original count: */ winwrote = recount_output_text(orig_buffer, buffer, winwrote); @@ -1235,7 +1327,6 @@ if (nonblocking) { /* Unless we're still trying to flush old data, write to the pipe and have the other thread start flushing it. */ - DWORD nonblock = PIPE_NOWAIT; int flushed; if (rfd->oth) { @@ -1267,13 +1358,34 @@ write fails. (Yuck.) */ while (1) { if (!rfd->unblocked) { + DWORD nonblock = PIPE_NOWAIT; ok = SetNamedPipeHandleState((HANDLE)rfd->fd, &nonblock, NULL, NULL); if (ok) rfd->unblocked = 1; - else + else { errsaved = GetLastError(); + if (errsaved == ERROR_INVALID_FUNCTION) { + /* The handle (not a pipe?) doesn't support non-blocking mode. But + since we only try to write when the pipe is flushed, we can just + keep each request under the buffer size. */ + DWORD bufsz; + if (GetNamedPipeInfo((HANDLE)rfd->fd, NULL, &bufsz, NULL, NULL) + && (bufsz > 0)) + rfd->write_limit = bufsz; + else { + /* 256 should be small enough? */ + rfd->write_limit = 256; + } + rfd->unblocked = 1; + ok = 1; + } + } } else ok = 1; + + if (rfd->write_limit && (towrite > rfd->write_limit)) + towrite = rfd->write_limit; + if (ok) { ok = WriteFile((HANDLE)rfd->fd, buffer, towrite, &winwrote, NULL); if (!ok) @@ -1463,6 +1575,117 @@ return i; } +static wchar_t *convert_output_wtext(const char *buffer, intptr_t *_towrite, + int *_can_leftover, int *_keep_leftover, + int leftover_len, char *leftover) +{ + /* Figure out how many bytes we can convert to complete wide + characters. To avoid quadratic behavior overall, we'll limit the + number of bytes. + + The given `leftover_len` and `leftover` is a prefix on `buffer`. + If the tail (after writing all other bytes) is an incomplete + UTF-8 prefix, report the prefix length in `_can_leftover`. */ + intptr_t i, count, len = *_towrite; + char *src_buffer; + wchar_t *dest_buffer; + int want, span = 0; + + if (leftover_len) { + /* Assume that leftover is a valid prefix: */ + int v = ((unsigned char *)leftover)[0]; + if ((v & 0xF8) == 0xF0) + span = 4; + else if ((v & 0xF0) == 0xE0) + span = 3; + else + span = 2; + } else + span = 0; + want = span - leftover_len; + + for (i = 0, count = 0; (i < len) && (count < 1024); i++) { + int v = ((unsigned char *)buffer)[i]; + if (want) { + if ((v & 0xC0) == 0x80) { + /* valid continuation byte */ + want--; + if (!want) { + count++; + if (span == 4) + count++; /* surrogate pair */ + } + } else { + /* not a valid continuation byte */ + count++; + want = 0; + --i; /* retry byte */ + } + } else if (!(v & 0x80)) { + count++; + } else if ((v & 0xF8) == 0xF0) { + span = 4; + want = 3; + } else if ((v & 0xF0) == 0xE0) { + span = 3; + want = 2; + } else if ((v & 0xE0) == 0xC0) { + span = 2; + want = 1; + } else { + /* bad continuation byte */ + count++; + } + } + + if ((i == len) && (want > 0)) { + /* consuming all input, so set leftover */ + int keep = span - want; + if (i >= keep) { + *_can_leftover = keep; + i -= keep; + *_keep_leftover = 0; + } else { + *_can_leftover = (keep - leftover_len); + *_keep_leftover = leftover_len; + i = 0; + } + } else { + *_can_leftover = 0; + *_keep_leftover = 0; + } + + if (leftover_len) { + src_buffer = malloc(i + leftover_len); + memcpy(src_buffer, leftover, leftover_len); + memcpy(src_buffer + leftover_len, buffer, i); + i += leftover_len; + } else + src_buffer = (char *)buffer; + + dest_buffer = (wchar_t *)malloc(sizeof(wchar_t) * count); + + if (count > 0) { + count = MultiByteToWideChar(CP_UTF8, 0, src_buffer, i, dest_buffer, count); + if (!count) { + /* force progress */ + src_buffer[0] = 0xFFFD; + count = 1; + } + } + *_towrite = count; + + if (leftover_len) + free(src_buffer); + + return dest_buffer; +} + +static intptr_t recount_output_wtext(wchar_t *w_buffer, intptr_t winwrote) +{ + return WideCharToMultiByte(CP_UTF8, 0, w_buffer, winwrote, NULL, 0, NULL, 0); +} + static void deinit_write_fd(rktio_t *rktio, rktio_fd_t *rfd, int full_close) { if (rfd->oth) { @@ -1535,9 +1758,9 @@ err_no = 0; WaitForSingleObject(oth->lock_sema, INFINITE); - if (!ok) + if (!ok) { oth->err_no = err_no; - else { + } else { oth->buflen -= wrote; if (oth->buflen) memmove(oth->buffer, oth->buffer + wrote, oth->buflen); diff -Nru racket-6.12+ppa1/src/rktio/rktio_fs.c racket-7.0+ppa1/src/rktio/rktio_fs.c --- racket-6.12+ppa1/src/rktio/rktio_fs.c 2017-10-27 02:41:42.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_fs.c 2018-07-27 22:12:02.000000000 +0000 @@ -129,12 +129,12 @@ SYSTEMTIME st; TIME_ZONE_INFORMATION tz; - /* FindFirstFile incorrectly shifts for daylight saving. It + /* GetFileAttributes incorrectly shifts for daylight saving. It subtracts an hour to get to UTC when daylight saving is in effect now, even when daylight saving was not in effect when the file was saved. Counteract the difference. There's a race condition here, because we might cross the daylight-saving boundary between - the time that FindFirstFile runs and GetTimeZoneInformation + the time that GetFileAttributes runs and GetTimeZoneInformation runs. Cross your fingers... */ FileTimeToLocalFileTime(ft, &ft2); FileTimeToSystemTime(&ft2, &st); @@ -143,47 +143,8 @@ if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_DAYLIGHT) { /* Daylight saving is in effect now, so there may be a bad shift. Check the file's date. */ - int start_day_of_month, end_day_of_month, first_day_of_week, diff, end_shift; - - /* Valid only when the months match: */ - first_day_of_week = (st.wDayOfWeek - (st.wDay - 1 - (((st.wDay - 1) / 7) * 7))); - if (first_day_of_week < 0) - first_day_of_week += 7; - - diff = (tz.DaylightDate.wDayOfWeek - first_day_of_week); - if (diff < 0) - diff += 7; - start_day_of_month = 1 + (((tz.DaylightDate.wDay - 1) * 7) - + diff); - - diff = (tz.StandardDate.wDayOfWeek - first_day_of_week); - if (diff < 0) - diff += 7; - end_day_of_month = 1 + (((tz.StandardDate.wDay - 1) * 7) - + diff); - - /* Count ambigious range (when the clock goes back) as - in standard time. We assume that subtracting the - ambiguous range does not go back into the previous day, - and that the shift is a multiple of an hour. */ - end_shift = ((tz.StandardBias - tz.DaylightBias) / 60); - - if ((st.wMonth < tz.DaylightDate.wMonth) - || ((st.wMonth == tz.DaylightDate.wMonth) - && ((st.wDay < start_day_of_month) - || ((st.wDay == start_day_of_month) - && (st.wHour < tz.DaylightDate.wHour))))) { - /* Daylight saving had not yet started. */ - delta = ((tz.StandardBias - tz.DaylightBias) * 60); - } else if ((st.wMonth > tz.StandardDate.wMonth) - || ((st.wMonth == tz.StandardDate.wMonth) - && ((st.wDay > end_day_of_month) - || ((st.wDay == end_day_of_month) - && (st.wHour >= (tz.StandardDate.wHour - - end_shift)))))) { - /* Daylight saving was already over. */ + if (!rktio_system_time_is_dst(&st, NULL)) delta = ((tz.StandardBias - tz.DaylightBias) * 60); - } } l = ((((LONGLONG)ft->dwHighDateTime << 32) | ft->dwLowDateTime) @@ -738,7 +699,7 @@ if (!wp) return 0; fdh = CreateFileW(wp, 0, /* not even read access => just get info */ - FILE_SHARE_READ | FILE_SHARE_WRITE, + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS diff -Nru racket-6.12+ppa1/src/rktio/rktio.h racket-7.0+ppa1/src/rktio/rktio.h --- racket-6.12+ppa1/src/rktio/rktio.h 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio.h 2018-07-27 22:12:02.000000000 +0000 @@ -88,6 +88,7 @@ #define RKTIO_EXTERN_STEP RKTIO_EXTERN #define RKTIO_NULLABLE /* empty */ +#define RKTIO_BLOCKING /* empty */ /*************************************************/ /* Initialization and general datatypes */ @@ -736,7 +737,7 @@ RKTIO_LTPS_HANDLE_FREE }; -RKTIO_EXTERN void rktio_sleep(rktio_t *rktio, float nsecs, rktio_poll_set_t *fds, rktio_ltps_t *lt); +RKTIO_EXTERN RKTIO_BLOCKING void rktio_sleep(rktio_t *rktio, float nsecs, rktio_poll_set_t *fds, rktio_ltps_t *lt); /* Waits up to `nsecs` seconds (or forever if `nsecs` is 0), until something registered with `fds` or `lt` is ready, or until there's some other activity that sometimes causes an early wakeup. */ @@ -1166,6 +1167,12 @@ if no error string is available or has already been returned. See `rktio_dll_open` for more information. */ +typedef void *(*dll_open_proc)(rktio_const_string_t name, rktio_bool_t as_global); +typedef void *(*dll_find_object_proc)(void *h, rktio_const_string_t name); +RKTIO_EXTERN void rktio_set_dll_procs(dll_open_proc dll_open, dll_find_object_proc dll_find_object); +/* Installs procedures that are tried before native mechanisms, + currently only supported for Windows. */ + /*************************************************/ /* Errors */ diff -Nru racket-6.12+ppa1/src/rktio/rktio.inc racket-7.0+ppa1/src/rktio/rktio.inc --- racket-6.12+ppa1/src/rktio/rktio.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,192 @@ +/* Extracted from rktio.h by rktio/parse.rkt */ +Sforeign_symbol("rktio_init", (void *)rktio_init); +Sforeign_symbol("rktio_destroy", (void *)rktio_destroy); +Sforeign_symbol("rktio_free", (void *)rktio_free); +Sforeign_symbol("rktio_set_dll_path", (void *)rktio_set_dll_path); +Sforeign_symbol("rktio_get_dll_path", (void *)rktio_get_dll_path); +Sforeign_symbol("rktio_system_fd", (void *)rktio_system_fd); +Sforeign_symbol("rktio_fd_system_fd", (void *)rktio_fd_system_fd); +Sforeign_symbol("rktio_fd_is_regular_file", (void *)rktio_fd_is_regular_file); +Sforeign_symbol("rktio_fd_is_directory", (void *)rktio_fd_is_directory); +Sforeign_symbol("rktio_fd_is_socket", (void *)rktio_fd_is_socket); +Sforeign_symbol("rktio_fd_is_udp", (void *)rktio_fd_is_udp); +Sforeign_symbol("rktio_fd_is_terminal", (void *)rktio_fd_is_terminal); +Sforeign_symbol("rktio_fd_is_text_converted", (void *)rktio_fd_is_text_converted); +Sforeign_symbol("rktio_fd_modes", (void *)rktio_fd_modes); +Sforeign_symbol("rktio_open", (void *)rktio_open); +Sforeign_symbol("rktio_close", (void *)rktio_close); +Sforeign_symbol("rktio_close_noerr", (void *)rktio_close_noerr); +Sforeign_symbol("rktio_dup", (void *)rktio_dup); +Sforeign_symbol("rktio_forget", (void *)rktio_forget); +Sforeign_symbol("rktio_std_fd", (void *)rktio_std_fd); +Sforeign_symbol("rktio_read", (void *)rktio_read); +Sforeign_symbol("rktio_write", (void *)rktio_write); +Sforeign_symbol("rktio_read_converted", (void *)rktio_read_converted); +Sforeign_symbol("rktio_read_in", (void *)rktio_read_in); +Sforeign_symbol("rktio_write_in", (void *)rktio_write_in); +Sforeign_symbol("rktio_buffered_byte_count", (void *)rktio_buffered_byte_count); +Sforeign_symbol("rktio_poll_read_ready", (void *)rktio_poll_read_ready); +Sforeign_symbol("rktio_poll_write_ready", (void *)rktio_poll_write_ready); +Sforeign_symbol("rktio_poll_write_flushed", (void *)rktio_poll_write_flushed); +Sforeign_symbol("rktio_file_lock_try", (void *)rktio_file_lock_try); +Sforeign_symbol("rktio_file_unlock", (void *)rktio_file_unlock); +Sforeign_symbol("rktio_set_file_position", (void *)rktio_set_file_position); +Sforeign_symbol("rktio_get_file_position", (void *)rktio_get_file_position); +Sforeign_symbol("rktio_set_file_size", (void *)rktio_set_file_size); +Sforeign_symbol("rktio_make_pipe", (void *)rktio_make_pipe); +Sforeign_symbol("rktio_start_addrinfo_lookup", (void *)rktio_start_addrinfo_lookup); +Sforeign_symbol("rktio_get_ipv4_family", (void *)rktio_get_ipv4_family); +Sforeign_symbol("rktio_poll_addrinfo_lookup_ready", (void *)rktio_poll_addrinfo_lookup_ready); +Sforeign_symbol("rktio_addrinfo_lookup_get", (void *)rktio_addrinfo_lookup_get); +Sforeign_symbol("rktio_addrinfo_lookup_stop", (void *)rktio_addrinfo_lookup_stop); +Sforeign_symbol("rktio_addrinfo_free", (void *)rktio_addrinfo_free); +Sforeign_symbol("rktio_listen", (void *)rktio_listen); +Sforeign_symbol("rktio_listen_stop", (void *)rktio_listen_stop); +Sforeign_symbol("rktio_poll_accept_ready", (void *)rktio_poll_accept_ready); +Sforeign_symbol("rktio_accept", (void *)rktio_accept); +Sforeign_symbol("rktio_start_connect", (void *)rktio_start_connect); +Sforeign_symbol("rktio_connect_finish", (void *)rktio_connect_finish); +Sforeign_symbol("rktio_connect_stop", (void *)rktio_connect_stop); +Sforeign_symbol("rktio_poll_connect_ready", (void *)rktio_poll_connect_ready); +Sforeign_symbol("rktio_connect_trying", (void *)rktio_connect_trying); +Sforeign_symbol("rktio_socket_shutdown", (void *)rktio_socket_shutdown); +Sforeign_symbol("rktio_udp_open", (void *)rktio_udp_open); +Sforeign_symbol("rktio_udp_disconnect", (void *)rktio_udp_disconnect); +Sforeign_symbol("rktio_udp_bind", (void *)rktio_udp_bind); +Sforeign_symbol("rktio_udp_connect", (void *)rktio_udp_connect); +Sforeign_symbol("rktio_udp_sendto", (void *)rktio_udp_sendto); +Sforeign_symbol("rktio_udp_sendto_in", (void *)rktio_udp_sendto_in); +Sforeign_symbol("rktio_udp_recvfrom", (void *)rktio_udp_recvfrom); +Sforeign_symbol("rktio_udp_recvfrom_in", (void *)rktio_udp_recvfrom_in); +Sforeign_symbol("rktio_udp_get_multicast_loopback", (void *)rktio_udp_get_multicast_loopback); +Sforeign_symbol("rktio_udp_set_multicast_loopback", (void *)rktio_udp_set_multicast_loopback); +Sforeign_symbol("rktio_udp_get_multicast_ttl", (void *)rktio_udp_get_multicast_ttl); +Sforeign_symbol("rktio_udp_set_multicast_ttl", (void *)rktio_udp_set_multicast_ttl); +Sforeign_symbol("rktio_udp_multicast_interface", (void *)rktio_udp_multicast_interface); +Sforeign_symbol("rktio_udp_set_multicast_interface", (void *)rktio_udp_set_multicast_interface); +Sforeign_symbol("rktio_udp_change_multicast_group", (void *)rktio_udp_change_multicast_group); +Sforeign_symbol("rktio_socket_address", (void *)rktio_socket_address); +Sforeign_symbol("rktio_socket_peer_address", (void *)rktio_socket_peer_address); +Sforeign_symbol("rktio_listener_address", (void *)rktio_listener_address); +Sforeign_symbol("rktio_is_ok_envvar_name", (void *)rktio_is_ok_envvar_name); +Sforeign_symbol("rktio_are_envvar_names_case_insensitive", (void *)rktio_are_envvar_names_case_insensitive); +Sforeign_symbol("rktio_getenv", (void *)rktio_getenv); +Sforeign_symbol("rktio_setenv", (void *)rktio_setenv); +Sforeign_symbol("rktio_envvars", (void *)rktio_envvars); +Sforeign_symbol("rktio_empty_envvars", (void *)rktio_empty_envvars); +Sforeign_symbol("rktio_envvars_copy", (void *)rktio_envvars_copy); +Sforeign_symbol("rktio_envvars_free", (void *)rktio_envvars_free); +Sforeign_symbol("rktio_envvars_get", (void *)rktio_envvars_get); +Sforeign_symbol("rktio_envvars_set", (void *)rktio_envvars_set); +Sforeign_symbol("rktio_envvars_count", (void *)rktio_envvars_count); +Sforeign_symbol("rktio_envvars_name_ref", (void *)rktio_envvars_name_ref); +Sforeign_symbol("rktio_envvars_value_ref", (void *)rktio_envvars_value_ref); +Sforeign_symbol("rktio_process", (void *)rktio_process); +Sforeign_symbol("rktio_process_allowed_flags", (void *)rktio_process_allowed_flags); +Sforeign_symbol("rktio_process_pid", (void *)rktio_process_pid); +Sforeign_symbol("rktio_process_kill", (void *)rktio_process_kill); +Sforeign_symbol("rktio_process_interrupt", (void *)rktio_process_interrupt); +Sforeign_symbol("rktio_process_forget", (void *)rktio_process_forget); +Sforeign_symbol("rktio_poll_process_done", (void *)rktio_poll_process_done); +Sforeign_symbol("rktio_process_status", (void *)rktio_process_status); +Sforeign_symbol("rktio_reap_processes", (void *)rktio_reap_processes); +Sforeign_symbol("rktio_fs_change_properties", (void *)rktio_fs_change_properties); +Sforeign_symbol("rktio_fs_change", (void *)rktio_fs_change); +Sforeign_symbol("rktio_fs_change_forget", (void *)rktio_fs_change_forget); +Sforeign_symbol("rktio_poll_fs_change_ready", (void *)rktio_poll_fs_change_ready); +Sforeign_symbol("rktio_make_poll_set", (void *)rktio_make_poll_set); +Sforeign_symbol("rktio_poll_set_forget", (void *)rktio_poll_set_forget); +Sforeign_symbol("rktio_poll_add", (void *)rktio_poll_add); +Sforeign_symbol("rktio_poll_add_accept", (void *)rktio_poll_add_accept); +Sforeign_symbol("rktio_poll_add_connect", (void *)rktio_poll_add_connect); +Sforeign_symbol("rktio_poll_add_addrinfo_lookup", (void *)rktio_poll_add_addrinfo_lookup); +Sforeign_symbol("rktio_poll_add_process", (void *)rktio_poll_add_process); +Sforeign_symbol("rktio_poll_add_fs_change", (void *)rktio_poll_add_fs_change); +Sforeign_symbol("rktio_poll_set_add_nosleep", (void *)rktio_poll_set_add_nosleep); +Sforeign_symbol("rktio_poll_set_add_handle", (void *)rktio_poll_set_add_handle); +Sforeign_symbol("rktio_poll_set_add_eventmask", (void *)rktio_poll_set_add_eventmask); +Sforeign_symbol("rkio_reset_sleep_backoff", (void *)rkio_reset_sleep_backoff); +Sforeign_symbol("rktio_ltps_open", (void *)rktio_ltps_open); +Sforeign_symbol("rktio_ltps_close", (void *)rktio_ltps_close); +Sforeign_symbol("rktio_ltps_add", (void *)rktio_ltps_add); +Sforeign_symbol("rktio_ltps_handle_set_data", (void *)rktio_ltps_handle_set_data); +Sforeign_symbol("rktio_ltps_handle_get_data", (void *)rktio_ltps_handle_get_data); +Sforeign_symbol("rktio_ltps_remove_all", (void *)rktio_ltps_remove_all); +Sforeign_symbol("rktio_ltps_poll", (void *)rktio_ltps_poll); +Sforeign_symbol("rktio_ltps_get_signaled_handle", (void *)rktio_ltps_get_signaled_handle); +Sforeign_symbol("rktio_ltps_handle_set_auto", (void *)rktio_ltps_handle_set_auto); +Sforeign_symbol("rktio_sleep", (void *)rktio_sleep); +Sforeign_symbol("rktio_start_sleep", (void *)rktio_start_sleep); +Sforeign_symbol("rktio_end_sleep", (void *)rktio_end_sleep); +Sforeign_symbol("rktio_file_exists", (void *)rktio_file_exists); +Sforeign_symbol("rktio_directory_exists", (void *)rktio_directory_exists); +Sforeign_symbol("rktio_link_exists", (void *)rktio_link_exists); +Sforeign_symbol("rktio_is_regular_file", (void *)rktio_is_regular_file); +Sforeign_symbol("rktio_delete_file", (void *)rktio_delete_file); +Sforeign_symbol("rktio_rename_file", (void *)rktio_rename_file); +Sforeign_symbol("rktio_get_current_directory", (void *)rktio_get_current_directory); +Sforeign_symbol("rktio_set_current_directory", (void *)rktio_set_current_directory); +Sforeign_symbol("rktio_make_directory", (void *)rktio_make_directory); +Sforeign_symbol("rktio_delete_directory", (void *)rktio_delete_directory); +Sforeign_symbol("rktio_readlink", (void *)rktio_readlink); +Sforeign_symbol("rktio_make_link", (void *)rktio_make_link); +Sforeign_symbol("rktio_file_size", (void *)rktio_file_size); +Sforeign_symbol("rktio_get_file_modify_seconds", (void *)rktio_get_file_modify_seconds); +Sforeign_symbol("rktio_set_file_modify_seconds", (void *)rktio_set_file_modify_seconds); +Sforeign_symbol("rktio_fd_identity", (void *)rktio_fd_identity); +Sforeign_symbol("rktio_path_identity", (void *)rktio_path_identity); +Sforeign_symbol("rktio_get_file_or_directory_permissions", (void *)rktio_get_file_or_directory_permissions); +Sforeign_symbol("rktio_set_file_or_directory_permissions", (void *)rktio_set_file_or_directory_permissions); +Sforeign_symbol("rktio_directory_list_start", (void *)rktio_directory_list_start); +Sforeign_symbol("rktio_directory_list_step", (void *)rktio_directory_list_step); +Sforeign_symbol("rktio_directory_list_stop", (void *)rktio_directory_list_stop); +Sforeign_symbol("rktio_filesystem_roots", (void *)rktio_filesystem_roots); +Sforeign_symbol("rktio_copy_file_start", (void *)rktio_copy_file_start); +Sforeign_symbol("rktio_copy_file_is_done", (void *)rktio_copy_file_is_done); +Sforeign_symbol("rktio_copy_file_step", (void *)rktio_copy_file_step); +Sforeign_symbol("rktio_copy_file_finish_permissions", (void *)rktio_copy_file_finish_permissions); +Sforeign_symbol("rktio_copy_file_stop", (void *)rktio_copy_file_stop); +Sforeign_symbol("rktio_system_path", (void *)rktio_system_path); +Sforeign_symbol("rktio_expand_user_tilde", (void *)rktio_expand_user_tilde); +Sforeign_symbol("rktio_get_signal_handle", (void *)rktio_get_signal_handle); +Sforeign_symbol("rktio_signal_received_at", (void *)rktio_signal_received_at); +Sforeign_symbol("rktio_signal_received", (void *)rktio_signal_received); +Sforeign_symbol("rktio_wait_until_signal_received", (void *)rktio_wait_until_signal_received); +Sforeign_symbol("rktio_flush_signals_received", (void *)rktio_flush_signals_received); +Sforeign_symbol("rktio_install_os_signal_handler", (void *)rktio_install_os_signal_handler); +Sforeign_symbol("rktio_poll_os_signal", (void *)rktio_poll_os_signal); +Sforeign_symbol("rktio_get_milliseconds", (void *)rktio_get_milliseconds); +Sforeign_symbol("rktio_get_inexact_milliseconds", (void *)rktio_get_inexact_milliseconds); +Sforeign_symbol("rktio_get_process_milliseconds", (void *)rktio_get_process_milliseconds); +Sforeign_symbol("rktio_get_process_children_milliseconds", (void *)rktio_get_process_children_milliseconds); +Sforeign_symbol("rktio_get_seconds", (void *)rktio_get_seconds); +Sforeign_symbol("rktio_seconds_to_date", (void *)rktio_seconds_to_date); +Sforeign_symbol("rktio_shell_execute", (void *)rktio_shell_execute); +Sforeign_symbol("rktio_path_to_wide_path", (void *)rktio_path_to_wide_path); +Sforeign_symbol("rktio_wide_path_to_path", (void *)rktio_wide_path_to_path); +Sforeign_symbol("rktio_syslog", (void *)rktio_syslog); +Sforeign_symbol("rktio_convert_properties", (void *)rktio_convert_properties); +Sforeign_symbol("rktio_converter_open", (void *)rktio_converter_open); +Sforeign_symbol("rktio_converter_close", (void *)rktio_converter_close); +Sforeign_symbol("rktio_convert", (void *)rktio_convert); +Sforeign_symbol("rktio_convert_in", (void *)rktio_convert_in); +Sforeign_symbol("rktio_locale_recase", (void *)rktio_locale_recase); +Sforeign_symbol("rktio_recase_utf16", (void *)rktio_recase_utf16); +Sforeign_symbol("rktio_locale_strcoll", (void *)rktio_locale_strcoll); +Sforeign_symbol("rktio_strcoll_utf16", (void *)rktio_strcoll_utf16); +Sforeign_symbol("rktio_locale_encoding", (void *)rktio_locale_encoding); +Sforeign_symbol("rktio_set_locale", (void *)rktio_set_locale); +Sforeign_symbol("rktio_push_c_numeric_locale", (void *)rktio_push_c_numeric_locale); +Sforeign_symbol("rktio_pop_c_numeric_locale", (void *)rktio_pop_c_numeric_locale); +Sforeign_symbol("rktio_system_language_country", (void *)rktio_system_language_country); +Sforeign_symbol("rktio_dll_open", (void *)rktio_dll_open); +Sforeign_symbol("rktio_dll_find_object", (void *)rktio_dll_find_object); +Sforeign_symbol("rktio_dll_get_error", (void *)rktio_dll_get_error); +Sforeign_symbol("rktio_get_last_error_kind", (void *)rktio_get_last_error_kind); +Sforeign_symbol("rktio_get_last_error", (void *)rktio_get_last_error); +Sforeign_symbol("rktio_get_last_error_step", (void *)rktio_get_last_error_step); +Sforeign_symbol("rktio_set_last_error", (void *)rktio_set_last_error); +Sforeign_symbol("rktio_set_last_error_step", (void *)rktio_set_last_error_step); +Sforeign_symbol("rktio_remap_last_error", (void *)rktio_remap_last_error); +Sforeign_symbol("rktio_get_last_error_string", (void *)rktio_get_last_error_string); +Sforeign_symbol("rktio_get_error_string", (void *)rktio_get_error_string); diff -Nru racket-6.12+ppa1/src/rktio/rktio_private.h racket-7.0+ppa1/src/rktio/rktio_private.h --- racket-6.12+ppa1/src/rktio/rktio_private.h 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_private.h 2018-07-27 22:12:02.000000000 +0000 @@ -298,6 +298,10 @@ void rktio_error_clean(rktio_t *rktio); void rktio_dll_clean(rktio_t *rktio); +#ifdef RKTIO_SYSTEM_WINDOWS +HANDLE rktio_load_library(rktio_const_string_t name); +void *rktio_get_proc_address(HANDLE m, rktio_const_string_t name); +#endif #if defined(USE_FNDELAY_O_NONBLOCK) # define RKTIO_NONBLOCKING FNDELAY @@ -356,3 +360,8 @@ void rktio_set_signal_handler(int sig_id, void (*proc)(int)); #endif void rktio_forget_os_signal_handler(rktio_t *rktio); + +#ifdef RKTIO_SYSTEM_WINDOWS +int rktio_system_time_is_dst(SYSTEMTIME *st, TIME_ZONE_INFORMATION *_tz); +#endif + diff -Nru racket-6.12+ppa1/src/rktio/rktio_process.c racket-7.0+ppa1/src/rktio/rktio_process.c --- racket-6.12+ppa1/src/rktio/rktio_process.c 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_process.c 2018-07-27 22:12:02.000000000 +0000 @@ -99,6 +99,7 @@ static void remove_group_signal_fd(rktio_signal_handle_t *signal_fd); static void do_group_signal_fds(); static int centralized_get_child_status(int pid, int in_group, int can_check_group, int *status); +static int raw_get_child_status(int pid, int *status, int done_only, int do_remove, int do_free); static void add_child_status(int pid, int status) { @@ -129,12 +130,13 @@ if (st->signal_fd && st->in_group) remove_group_signal_fd(st->signal_fd); - pthread_mutex_unlock(&child_status_lock); if (st->signal_fd) rktio_signal_received_at(st->signal_fd); if (st->unneeded) - (void)centralized_get_child_status(st->pid, 0, 0, NULL); + (void)raw_get_child_status(st->pid, NULL, 1, 1, 1); + + pthread_mutex_unlock(&child_status_lock); } static int raw_get_child_status(int pid, int *status, int done_only, int do_remove, int do_free) @@ -390,6 +392,10 @@ void centralized_unblock_child_signal() { + sigset_t set; + sigemptyset(&set); + sigaddset(&set, SIGCHLD); + sigprocmask(SIG_UNBLOCK, &set, NULL); } void centralized_start_child_signal_handler() @@ -818,7 +824,8 @@ get_windows_error(); return NULL; } - } + } else + status = -1; # endif #endif @@ -984,7 +991,7 @@ /*========================================================================*/ #ifdef RKTIO_SYSTEM_WINDOWS -static char *cmdline_protect(char *s) +static char *cmdline_protect(const char *s) { char *naya; int ds; @@ -1290,7 +1297,7 @@ for (i = 0; i < argc; i++) { new_argv[i] = cmdline_protect(argv[i]); } - argv = new_argv; + argv = (rktio_const_string_t *)new_argv; } pid = 0; @@ -1308,7 +1315,7 @@ if (!windows_exact_cmdline) { for (i = 0; i < argc; i++) { - free(argv[i]); + free((char *)argv[i]); } free(argv); } diff -Nru racket-6.12+ppa1/src/rktio/rktio.rktl racket-7.0+ppa1/src/rktio/rktio.rktl --- racket-6.12+ppa1/src/rktio/rktio.rktl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio.rktl 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1323 @@ +;; Extracted from rktio.h by rktio/parse.rkt +(begin +(define-constant RKTIO_OPEN_READ (<< 1 0)) +(define-constant RKTIO_OPEN_WRITE (<< 1 1)) +(define-constant RKTIO_OPEN_TEXT (<< 1 2)) +(define-constant RKTIO_OPEN_TRUNCATE (<< 1 3)) +(define-constant RKTIO_OPEN_APPEND (<< 1 4)) +(define-constant RKTIO_OPEN_MUST_EXIST (<< 1 5)) +(define-constant RKTIO_OPEN_CAN_EXIST (<< 1 6)) +(define-constant RKTIO_OPEN_SOCKET (<< 1 7)) +(define-constant RKTIO_OPEN_UDP (<< 1 8)) +(define-constant RKTIO_OPEN_REGFILE (<< 1 9)) +(define-constant RKTIO_OPEN_NOT_REGFILE (<< 1 10)) +(define-constant RKTIO_OPEN_DIR (<< 1 11)) +(define-constant RKTIO_OPEN_NOT_DIR (<< 1 12)) +(define-constant RKTIO_OPEN_INIT (<< 1 13)) +(define-constant RKTIO_OPEN_OWN (<< 1 14)) +(define-constant RKTIO_STDIN 0) +(define-constant RKTIO_STDOUT 1) +(define-constant RKTIO_STDERR 2) +(define-constant RKTIO_READ_EOF -1) +(define-constant RKTIO_READ_ERROR -2) +(define-constant RKTIO_WRITE_ERROR -2) +(define-constant RKTIO_POLL_NOT_READY 0) +(define-constant RKTIO_POLL_READY 1) +(define-constant RKTIO_POLL_ERROR -2) +(define-constant RKTIO_LOCK_ERROR -2) +(define-constant RKTIO_LOCK_ACQUIRED 1) +(define-constant RKTIO_LOCK_NOT_ACQUIRED 0) +(define-constant RKTIO_POSITION_FROM_START 0) +(define-constant RKTIO_POSITION_FROM_END 1) +(define-constant RKTIO_NO_INHERIT_INPUT (<< 1 0)) +(define-constant RKTIO_NO_INHERIT_OUTPUT (<< 1 1)) +(define-constant RKTIO_FAMILY_ANY -1) +(define-constant RKTIO_SHUTDOWN_READ 0) +(define-constant RKTIO_SHUTDOWN_WRITE 1) +(define-constant RKTIO_PROP_ERROR -2) +(define-constant RKTIO_ADD_MEMBERSHIP 0) +(define-constant RKTIO_DROP_MEMBERSHIP 1) +(define-constant RKTIO_PROCESS_NEW_GROUP (<< 1 0)) +(define-constant RKTIO_PROCESS_STDOUT_AS_STDERR (<< 1 1)) +(define-constant RKTIO_PROCESS_WINDOWS_EXACT_CMDLINE (<< 1 2)) +(define-constant RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION (<< 1 3)) +(define-constant RKTIO_PROCESS_ERROR -2) +(define-constant RKTIO_PROCESS_DONE 1) +(define-constant RKTIO_PROCESS_RUNNING 0) +(define-constant RKTIO_FS_CHANGE_SUPPORTED (<< 1 0)) +(define-constant RKTIO_FS_CHANGE_SCALABLE (<< 1 1)) +(define-constant RKTIO_FS_CHANGE_LOW_LATENCY (<< 1 2)) +(define-constant RKTIO_FS_CHANGE_FILE_LEVEL (<< 1 3)) +(define-constant RKTIO_FS_CHANGE_NEED_LTPS (<< 1 4)) +(define-constant RKTIO_POLL_READ RKTIO_OPEN_READ) +(define-constant RKTIO_POLL_WRITE RKTIO_OPEN_WRITE) +(define-constant RKTIO_POLL_FLUSH (<< RKTIO_OPEN_WRITE 2)) +(define-constant RKTIO_LTPS_CREATE_READ 1) +(define-constant RKTIO_LTPS_CREATE_WRITE 2) +(define-constant RKTIO_LTPS_CHECK_READ 3) +(define-constant RKTIO_LTPS_CHECK_WRITE 4) +(define-constant RKTIO_LTPS_REMOVE 5) +(define-constant RKTIO_LTPS_CREATE_VNODE 6) +(define-constant RKTIO_LTPS_CHECK_VNODE 7) +(define-constant RKTIO_LTPS_REMOVE_VNODE 8) +(define-constant RKTIO_LTPS_HANDLE_NONE 0) +(define-constant RKTIO_LTPS_HANDLE_ZERO 1) +(define-constant RKTIO_LTPS_HANDLE_FREE 2) +(define-constant RKTIO_PERMISSION_READ 4) +(define-constant RKTIO_PERMISSION_WRITE 2) +(define-constant RKTIO_PERMISSION_EXEC 1) +(define-constant RKTIO_PERMISSION_ERROR -1) +(define-constant RKTIO_COPY_STEP_UNKNOWN 0) +(define-constant RKTIO_COPY_STEP_OPEN_SRC 1) +(define-constant RKTIO_COPY_STEP_OPEN_DEST 2) +(define-constant RKTIO_COPY_STEP_READ_SRC_DATA 3) +(define-constant RKTIO_COPY_STEP_WRITE_DEST_DATA 4) +(define-constant RKTIO_COPY_STEP_READ_SRC_METADATA 5) +(define-constant RKTIO_COPY_STEP_WRITE_DEST_METADATA 6) +(define-constant RKTIO_PATH_SYS_DIR 0) +(define-constant RKTIO_PATH_TEMP_DIR 1) +(define-constant RKTIO_PATH_PREF_DIR 2) +(define-constant RKTIO_PATH_PREF_FILE 3) +(define-constant RKTIO_PATH_ADDON_DIR 4) +(define-constant RKTIO_PATH_HOME_DIR 5) +(define-constant RKTIO_PATH_DESK_DIR 6) +(define-constant RKTIO_PATH_DOC_DIR 7) +(define-constant RKTIO_PATH_INIT_DIR 8) +(define-constant RKTIO_PATH_INIT_FILE 9) +(define-constant RKTIO_OS_SIGNAL_NONE -1) +(define-constant RKTIO_OS_SIGNAL_INT 0) +(define-constant RKTIO_OS_SIGNAL_TERM 1) +(define-constant RKTIO_OS_SIGNAL_HUP 2) +(define-constant RKTIO_NUM_OS_SIGNALS 3) +(define-constant RKTIO_SW_HIDE 0) +(define-constant RKTIO_SW_MAXIMIZE 1) +(define-constant RKTIO_SW_MINIMIZE 2) +(define-constant RKTIO_SW_RESTORE 3) +(define-constant RKTIO_SW_SHOW 4) +(define-constant RKTIO_SW_SHOWDEFAULT 5) +(define-constant RKTIO_SW_SHOWMAXIMIZED 6) +(define-constant RKTIO_SW_SHOWMINIMIZED 7) +(define-constant RKTIO_SW_SHOWMINNOACTIVE 8) +(define-constant RKTIO_SW_SHOWNA 9) +(define-constant RKTIO_SW_SHOWNOACTIVATE 10) +(define-constant RKTIO_SW_SHOWNORMAL 11) +(define-constant RKTIO_LOG_FATAL 1) +(define-constant RKTIO_LOG_ERROR 2) +(define-constant RKTIO_LOG_WARNING 3) +(define-constant RKTIO_LOG_INFO 4) +(define-constant RKTIO_LOG_DEBUG 5) +(define-constant RKTIO_CONVERTER_SUPPORTED (<< 1 0)) +(define-constant RKTIO_CONVERT_STRCOLL_UTF16 (<< 1 1)) +(define-constant RKTIO_CONVERT_RECASE_UTF16 (<< 1 2)) +(define-constant RKTIO_CONVERT_ERROR -1) +(define-constant RKTIO_ERROR_KIND_POSIX 0) +(define-constant RKTIO_ERROR_KIND_WINDOWS 1) +(define-constant RKTIO_ERROR_KIND_GAI 2) +(define-constant RKTIO_ERROR_KIND_RACKET 3) +(define-constant RKTIO_ERROR_UNSUPPORTED 1) +(define-constant RKTIO_ERROR_INVALID_PATH 2) +(define-constant RKTIO_ERROR_DOES_NOT_EXIST 3) +(define-constant RKTIO_ERROR_EXISTS 4) +(define-constant RKTIO_ERROR_ACCESS_DENIED 5) +(define-constant RKTIO_ERROR_LINK_FAILED 6) +(define-constant RKTIO_ERROR_NOT_A_LINK 7) +(define-constant RKTIO_ERROR_BAD_PERMISSION 8) +(define-constant RKTIO_ERROR_IS_A_DIRECTORY 9) +(define-constant RKTIO_ERROR_NOT_A_DIRECTORY 10) +(define-constant RKTIO_ERROR_UNSUPPORTED_TEXT_MODE 11) +(define-constant RKTIO_ERROR_CANNOT_FILE_POSITION 12) +(define-constant RKTIO_ERROR_NO_TILDE 13) +(define-constant RKTIO_ERROR_ILL_FORMED_USER 14) +(define-constant RKTIO_ERROR_UNKNOWN_USER 15) +(define-constant RKTIO_ERROR_INIT_FAILED 16) +(define-constant RKTIO_ERROR_LTPS_NOT_FOUND 17) +(define-constant RKTIO_ERROR_LTPS_REMOVED 18) +(define-constant RKTIO_ERROR_CONNECT_TRYING_NEXT 19) +(define-constant RKTIO_ERROR_ACCEPT_NOT_READY 20) +(define-constant RKTIO_ERROR_HOST_AND_PORT_BOTH_UNSPECIFIED 21) +(define-constant RKTIO_ERROR_INFO_TRY_AGAIN 22) +(define-constant RKTIO_ERROR_TRY_AGAIN 23) +(define-constant RKTIO_ERROR_TRY_AGAIN_WITH_IPV4 24) +(define-constant RKTIO_ERROR_TIME_OUT_OF_RANGE 25) +(define-constant RKTIO_ERROR_NO_SUCH_ENVVAR 26) +(define-constant RKTIO_ERROR_SHELL_EXECUTE_FAILED 27) +(define-constant RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE 28) +(define-constant RKTIO_ERROR_CONVERT_BAD_SEQUENCE 29) +(define-constant RKTIO_ERROR_CONVERT_PREMATURE_END 30) +(define-constant RKTIO_ERROR_CONVERT_OTHER 31) +(define-constant RKTIO_ERROR_DLL 32) +(define-type rktio_ok_t int) +(define-type rktio_tri_t int) +(define-type rktio_bool_t int) +(define-type rktio_char16_t unsigned-short) +(define-type rktio_const_string_t (*ref char)) +(define-type rktio_filesize_t rktio_int64_t) +(define-struct-type + rktio_length_and_addrinfo_t + ((intptr_t len) ((ref (ref char)) address))) +(define-struct-type + rktio_process_result_t + (((ref rktio_process_t) process) + ((ref rktio_fd_t) stdin_fd) + ((ref rktio_fd_t) stdout_fd) + ((ref rktio_fd_t) stderr_fd))) +(define-struct-type rktio_status_t ((rktio_bool_t running) (int result))) +(define-type rktio_timestamp_t intptr_t) +(define-struct-type + rktio_identity_t + ((uintptr_t a) + (uintptr_t b) + (uintptr_t c) + (int a_bits) + (int b_bits) + (int c_bits))) +(define-struct-type + rktio_date_t + ((int nanosecond) + (int second) + (int minute) + (int hour) + (int day) + (int month) + (intptr_t year) + (int day_of_week) + (int day_of_year) + (int is_dst) + (int zone_offset) + ((ref char) zone_name))) +(define-struct-type + rktio_convert_result_t + ((intptr_t in_consumed) (intptr_t out_produced) (intptr_t converted))) +(define-function () (ref rktio_t) rktio_init ()) +(define-function () void rktio_destroy (((ref rktio_t) rktio))) +(define-function () void rktio_free (((ref void) p))) +(define-function () void rktio_set_dll_path (((*ref rktio_char16_t) p))) +(define-function/errno + NULL + () + (ref rktio_char16_t) + rktio_get_dll_path + (((*ref rktio_char16_t) p))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_system_fd + (((ref rktio_t) rktio) (intptr_t system_fd) (int modes))) +(define-function + () + intptr_t + rktio_fd_system_fd + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_regular_file + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_directory + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_socket + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_udp + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_terminal + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_text_converted + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + int + rktio_fd_modes + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_open + (((ref rktio_t) rktio) (rktio_const_string_t src) (int modes))) +(define-function/errno + #f + () + rktio_ok_t + rktio_close + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function + () + void + rktio_close_noerr + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_dup + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + void + rktio_forget + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_std_fd + (((ref rktio_t) rktio) (int which))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_write + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read_converted + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len) + ((*ref char) is_converted))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_write_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function + () + intptr_t + rktio_buffered_byte_count + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_read_ready + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_write_ready + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_write_flushed + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_LOCK_ERROR + () + rktio_tri_t + rktio_file_lock_try + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_bool_t excl))) +(define-function/errno + #f + () + rktio_ok_t + rktio_file_unlock + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_position + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + (rktio_filesize_t pos) + (int whence))) +(define-function/errno + NULL + () + (ref rktio_filesize_t) + rktio_get_file_position + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_size + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_filesize_t sz))) +(define-function/errno + NULL + () + (ref (ref rktio_fd_t)) + rktio_make_pipe + (((ref rktio_t) rktio) (int flags))) +(define-function/errno + NULL + () + (ref rktio_addrinfo_lookup_t) + rktio_start_addrinfo_lookup + (((ref rktio_t) rktio) + (rktio_const_string_t hostname) + (int portno) + (int family) + (rktio_bool_t passive) + (rktio_bool_t tcp))) +(define-function () int rktio_get_ipv4_family (((ref rktio_t) rktio))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_addrinfo_lookup_ready + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function/errno + NULL + () + (ref rktio_addrinfo_t) + rktio_addrinfo_lookup_get + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function + () + void + rktio_addrinfo_lookup_stop + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function + () + void + rktio_addrinfo_free + (((ref rktio_t) rktio) ((ref rktio_addrinfo_t) a))) +(define-function/errno + NULL + () + (ref rktio_listener_t) + rktio_listen + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_t) local) + (int backlog) + (rktio_bool_t reuse))) +(define-function + () + void + rktio_listen_stop + (((ref rktio_t) rktio) ((ref rktio_listener_t) l))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_accept_ready + (((ref rktio_t) rktio) ((ref rktio_listener_t) listener))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_accept + (((ref rktio_t) rktio) ((ref rktio_listener_t) listener))) +(define-function/errno + NULL + () + (ref rktio_connect_t) + rktio_start_connect + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_t) remote) + ((ref (nullable rktio_addrinfo_t)) local))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_connect_finish + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function + () + void + rktio_connect_stop + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_connect_ready + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_connect_trying + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + #f + () + rktio_ok_t + rktio_socket_shutdown + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (int mode))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_udp_open + (((ref rktio_t) rktio) ((ref (nullable rktio_addrinfo_t)) addr) (int family))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_disconnect + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_bind + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_addrinfo_t) addr) + (rktio_bool_t reuse))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_connect + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) ((ref rktio_addrinfo_t) addr))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_udp_sendto + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_udp_sendto_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + NULL + () + (ref rktio_length_and_addrinfo_t) + rktio_udp_recvfrom + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + NULL + () + (ref rktio_length_and_addrinfo_t) + rktio_udp_recvfrom_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + RKTIO_PROP_ERROR + () + rktio_tri_t + rktio_udp_get_multicast_loopback + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_loopback + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_bool_t on))) +(define-function/errno + RKTIO_PROP_ERROR + () + rktio_tri_t + rktio_udp_get_multicast_ttl + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_ttl + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (int ttl_val))) +(define-function/errno + NULL + () + (ref char) + rktio_udp_multicast_interface + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_interface + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_change_multicast_group + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_addrinfo_t) group_addr) + ((ref (nullable rktio_addrinfo_t)) intf_addr) + (int action))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_socket_address + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_socket_peer_address + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_listener_address + (((ref rktio_t) rktio) ((ref rktio_listener_t) lnr))) +(define-function + () + rktio_bool_t + rktio_is_ok_envvar_name + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function + () + rktio_bool_t + rktio_are_envvar_names_case_insensitive + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref char) + rktio_getenv + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function/errno + #f + () + rktio_ok_t + rktio_setenv + (((ref rktio_t) rktio) + (rktio_const_string_t name) + (rktio_const_string_t val))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_envvars + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_empty_envvars + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_envvars_copy + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function + () + void + rktio_envvars_free + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_get + (((ref rktio_t) rktio) + ((ref rktio_envvars_t) envvars) + (rktio_const_string_t name))) +(define-function + () + void + rktio_envvars_set + (((ref rktio_t) rktio) + ((ref rktio_envvars_t) envvars) + (rktio_const_string_t name) + (rktio_const_string_t value))) +(define-function + () + intptr_t + rktio_envvars_count + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_name_ref + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars) (intptr_t i))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_value_ref + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars) (intptr_t i))) +(define-function/errno + NULL + () + (ref rktio_process_result_t) + rktio_process + (((ref rktio_t) rktio) + (rktio_const_string_t command) + (int argc) + ((*ref rktio_const_string_t) argv) + ((ref (nullable rktio_fd_t)) stdout_fd) + ((ref (nullable rktio_fd_t)) stdin_fd) + ((ref (nullable rktio_fd_t)) stderr_fd) + ((ref (nullable rktio_process_t)) group_proc) + (rktio_const_string_t current_directory) + ((ref rktio_envvars_t) envvars) + (int flags))) +(define-function () int rktio_process_allowed_flags (((ref rktio_t) rktio))) +(define-function + () + int + rktio_process_pid + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_process_kill + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_process_interrupt + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function + () + void + rktio_process_forget + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + RKTIO_PROCESS_ERROR + () + rktio_tri_t + rktio_poll_process_done + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + NULL + () + (ref rktio_status_t) + rktio_process_status + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function () void rktio_reap_processes (((ref rktio_t) rktio))) +(define-function () int rktio_fs_change_properties (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_fs_change_t) + rktio_fs_change + (((ref rktio_t) rktio) (rktio_const_string_t path) ((ref rktio_ltps_t) ltps))) +(define-function + () + void + rktio_fs_change_forget + (((ref rktio_t) rktio) ((ref rktio_fs_change_t) fc))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_fs_change_ready + (((ref rktio_t) rktio) ((ref rktio_fs_change_t) fc))) +(define-function/errno + NULL + () + (ref rktio_poll_set_t) + rktio_make_poll_set + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_poll_set_forget + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_poll_set_t) fds) + (int modes))) +(define-function + () + void + rktio_poll_add_accept + (((ref rktio_t) rktio) + ((ref rktio_listener_t) listener) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_connect + (((ref rktio_t) rktio) + ((ref rktio_connect_t) conn) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_addrinfo_lookup + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_lookup_t) lookup) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_process + (((ref rktio_t) rktio) + ((ref rktio_process_t) sp) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_fs_change + (((ref rktio_t) rktio) + ((ref rktio_fs_change_t) fc) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_set_add_nosleep + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_set_add_handle + (((ref rktio_t) rktio) + (intptr_t h) + ((ref rktio_poll_set_t) fds) + (int repost))) +(define-function + () + void + rktio_poll_set_add_eventmask + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds) (int mask))) +(define-function () void rkio_reset_sleep_backoff (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_ltps_t) + rktio_ltps_open + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_ltps_close + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + NULL + () + (ref rktio_ltps_handle_t) + rktio_ltps_add + (((ref rktio_t) rktio) + ((ref rktio_ltps_t) lt) + ((ref rktio_fd_t) rfd) + (int mode))) +(define-function + () + void + rktio_ltps_handle_set_data + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) h) ((ref void) data))) +(define-function + () + (ref void) + rktio_ltps_handle_get_data + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) h))) +(define-function + () + void + rktio_ltps_remove_all + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_ltps_poll + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + NULL + () + (ref rktio_ltps_handle_t) + rktio_ltps_get_signaled_handle + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function + () + void + rktio_ltps_handle_set_auto + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) lth) (int auto_mode))) +(define-function + (blocking) + void + rktio_sleep + (((ref rktio_t) rktio) + (float nsecs) + ((ref rktio_poll_set_t) fds) + ((ref rktio_ltps_t) lt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_start_sleep + (((ref rktio_t) rktio) + (float nsecs) + ((ref rktio_poll_set_t) fds) + ((ref rktio_ltps_t) lt) + (int woke_fd))) +(define-function () void rktio_end_sleep (((ref rktio_t) rktio))) +(define-function + () + rktio_bool_t + rktio_file_exists + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + rktio_bool_t + rktio_directory_exists + (((ref rktio_t) rktio) (rktio_const_string_t dirname))) +(define-function + () + rktio_bool_t + rktio_link_exists + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + rktio_bool_t + rktio_is_regular_file + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_delete_file + (((ref rktio_t) rktio) + (rktio_const_string_t fn) + (rktio_bool_t enable_write_on_fail))) +(define-function/errno + #f + () + rktio_ok_t + rktio_rename_file + (((ref rktio_t) rktio) + (rktio_const_string_t dest) + (rktio_const_string_t src) + (rktio_bool_t exists_ok))) +(define-function/errno + NULL + () + (ref char) + rktio_get_current_directory + (((ref rktio_t) rktio))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_current_directory + (((ref rktio_t) rktio) (rktio_const_string_t path))) +(define-function/errno + #f + () + rktio_ok_t + rktio_make_directory + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_delete_directory + (((ref rktio_t) rktio) + (rktio_const_string_t filename) + (rktio_const_string_t current_directory) + (rktio_bool_t enable_write_on_fail))) +(define-function/errno + NULL + () + (ref char) + rktio_readlink + (((ref rktio_t) rktio) (rktio_const_string_t fullfilename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_make_link + (((ref rktio_t) rktio) + (rktio_const_string_t src) + (rktio_const_string_t dest) + (rktio_bool_t dest_is_directory))) +(define-function/errno + NULL + () + (ref rktio_filesize_t) + rktio_file_size + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + NULL + () + (ref rktio_timestamp_t) + rktio_get_file_modify_seconds + (((ref rktio_t) rktio) (rktio_const_string_t file))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_modify_seconds + (((ref rktio_t) rktio) (rktio_const_string_t file) (rktio_timestamp_t secs))) +(define-function/errno + NULL + () + (ref rktio_identity_t) + rktio_fd_identity + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_identity_t) + rktio_path_identity + (((ref rktio_t) rktio) + (rktio_const_string_t path) + (rktio_bool_t follow_links))) +(define-function/errno + RKTIO_PERMISSION_ERROR + () + int + rktio_get_file_or_directory_permissions + (((ref rktio_t) rktio) + (rktio_const_string_t filename) + (rktio_bool_t all_bits))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_or_directory_permissions + (((ref rktio_t) rktio) (rktio_const_string_t filename) (int new_bits))) +(define-function/errno + NULL + () + (ref rktio_directory_list_t) + rktio_directory_list_start + (((ref rktio_t) rktio) (rktio_const_string_t dirname))) +(define-function/errno + NULL + () + (ref char) + rktio_directory_list_step + (((ref rktio_t) rktio) ((ref rktio_directory_list_t) dl))) +(define-function + () + void + rktio_directory_list_stop + (((ref rktio_t) rktio) ((ref rktio_directory_list_t) dl))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_filesystem_roots + (((ref rktio_t) rktio))) +(define-function/errno+step + NULL + () + (ref rktio_file_copy_t) + rktio_copy_file_start + (((ref rktio_t) rktio) + (rktio_const_string_t dest) + (rktio_const_string_t src) + (rktio_bool_t exists_ok))) +(define-function + () + rktio_bool_t + rktio_copy_file_is_done + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno+step + #f + () + rktio_ok_t + rktio_copy_file_step + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno+step + #f + () + rktio_ok_t + rktio_copy_file_finish_permissions + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function + () + void + rktio_copy_file_stop + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno + NULL + () + (ref char) + rktio_system_path + (((ref rktio_t) rktio) (int which))) +(define-function/errno + NULL + () + (ref char) + rktio_expand_user_tilde + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + (ref rktio_signal_handle_t) + rktio_get_signal_handle + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_signal_received_at + (((ref rktio_signal_handle_t) h))) +(define-function () void rktio_signal_received (((ref rktio_t) rktio))) +(define-function + () + void + rktio_wait_until_signal_received + (((ref rktio_t) rktio))) +(define-function () void rktio_flush_signals_received (((ref rktio_t) rktio))) +(define-function + () + void + rktio_install_os_signal_handler + (((ref rktio_t) rktio))) +(define-function () int rktio_poll_os_signal (((ref rktio_t) rktio))) +(define-function () intptr_t rktio_get_milliseconds ()) +(define-function () double rktio_get_inexact_milliseconds ()) +(define-function + () + intptr_t + rktio_get_process_milliseconds + (((ref rktio_t) rktio))) +(define-function + () + intptr_t + rktio_get_process_children_milliseconds + (((ref rktio_t) rktio))) +(define-function + () + rktio_timestamp_t + rktio_get_seconds + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_date_t) + rktio_seconds_to_date + (((ref rktio_t) rktio) + (rktio_timestamp_t seconds) + (int nanoseconds) + (int get_gmt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_shell_execute + (((ref rktio_t) rktio) + (rktio_const_string_t verb) + (rktio_const_string_t target) + (rktio_const_string_t arg) + (rktio_const_string_t dir) + (int show_mode))) +(define-function/errno + NULL + () + (ref rktio_char16_t) + rktio_path_to_wide_path + (((ref rktio_t) rktio) (rktio_const_string_t p))) +(define-function + () + (ref char) + rktio_wide_path_to_path + (((ref rktio_t) rktio) ((*ref rktio_char16_t) wp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_syslog + (((ref rktio_t) rktio) + (int level) + (rktio_const_string_t name) + (rktio_const_string_t msg) + (rktio_const_string_t exec_name))) +(define-function () int rktio_convert_properties (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_converter_t) + rktio_converter_open + (((ref rktio_t) rktio) + (rktio_const_string_t to_enc) + (rktio_const_string_t from_enc))) +(define-function + () + void + rktio_converter_close + (((ref rktio_t) rktio) ((ref rktio_converter_t) cvt))) +(define-function/errno + RKTIO_CONVERT_ERROR + () + intptr_t + rktio_convert + (((ref rktio_t) rktio) + ((ref rktio_converter_t) cvt) + ((*ref (ref char)) in) + ((*ref intptr_t) in_left) + ((*ref (ref char)) out) + ((*ref intptr_t) out_left))) +(define-function/errno + NULL + () + (ref rktio_convert_result_t) + rktio_convert_in + (((ref rktio_t) rktio) + ((ref rktio_converter_t) cvt) + ((*ref char) in) + (intptr_t in_start) + (intptr_t in_end) + ((*ref char) out) + (intptr_t out_start) + (intptr_t out_end))) +(define-function + () + (ref char) + rktio_locale_recase + (((ref rktio_t) rktio) (rktio_bool_t to_up) (rktio_const_string_t in))) +(define-function + () + (ref rktio_char16_t) + rktio_recase_utf16 + (((ref rktio_t) rktio) + (rktio_bool_t to_up) + ((*ref rktio_char16_t) s1) + (intptr_t len) + ((*ref intptr_t) olen))) +(define-function + () + int + rktio_locale_strcoll + (((ref rktio_t) rktio) (rktio_const_string_t s1) (rktio_const_string_t s2))) +(define-function + () + int + rktio_strcoll_utf16 + (((ref rktio_t) rktio) + ((*ref rktio_char16_t) s1) + (intptr_t l1) + ((*ref rktio_char16_t) s2) + (intptr_t l2) + (rktio_bool_t cvt_case))) +(define-function/errno + NULL + () + (ref char) + rktio_locale_encoding + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_set_locale + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function + () + (ref char) + rktio_push_c_numeric_locale + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_pop_c_numeric_locale + (((ref rktio_t) rktio) ((*ref char) prev))) +(define-function/errno + NULL + () + (ref char) + rktio_system_language_country + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_dll_t) + rktio_dll_open + (((ref rktio_t) rktio) (rktio_const_string_t name) (rktio_bool_t as_global))) +(define-function/errno + NULL + () + (ref void) + rktio_dll_find_object + (((ref rktio_t) rktio) ((ref rktio_dll_t) dll) (rktio_const_string_t name))) +(define-function/errno + NULL + () + (ref char) + rktio_dll_get_error + (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error_kind (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error_step (((ref rktio_t) rktio))) +(define-function + () + void + rktio_set_last_error + (((ref rktio_t) rktio) (int kind) (int errid))) +(define-function + () + void + rktio_set_last_error_step + (((ref rktio_t) rktio) (int step))) +(define-function () void rktio_remap_last_error (((ref rktio_t) rktio))) +(define-function + () + (ref char) + rktio_get_last_error_string + (((ref rktio_t) rktio))) +(define-function + () + (ref char) + rktio_get_error_string + (((ref rktio_t) rktio) (int kind) (int errid))) +) diff -Nru racket-6.12+ppa1/src/rktio/rktio_time.c racket-7.0+ppa1/src/rktio/rktio_time.c --- racket-6.12+ppa1/src/rktio/rktio_time.c 2018-01-07 16:24:31.000000000 +0000 +++ racket-7.0+ppa1/src/rktio/rktio_time.c 2018-07-27 22:12:02.000000000 +0000 @@ -258,6 +258,28 @@ return 0; } # undef dtxCOMP + +int rktio_system_time_is_dst(SYSTEMTIME *st, TIME_ZONE_INFORMATION *_tz) +{ + TIME_ZONE_INFORMATION tz; + if (GetTimeZoneInformationForYearProc) + GetTimeZoneInformationForYearProc(st->wYear, NULL, &tz); + else + (void)GetTimeZoneInformation(&tz); + if (_tz) *_tz = tz; + if (tz.StandardDate.wMonth) { + if (is_start_day_before(&tz.DaylightDate, &tz.StandardDate)) { + /* northern hemisphere */ + return (!is_day_before(st, &tz.DaylightDate) + && is_day_before(st, &tz.StandardDate)); + } else { + /* southern hemisphere */ + return (is_day_before(st, &tz.StandardDate) + || !is_day_before(st, &tz.DaylightDate)); + } + } + return 0; +} #endif #if defined(OS_X) && defined(__x86_64__) @@ -378,23 +400,8 @@ tzoffset = 0; tzn = MSC_IZE(strdup)("UTC"); } else { - TIME_ZONE_INFORMATION tz; - if (GetTimeZoneInformationForYearProc) - GetTimeZoneInformationForYearProc(localTime.wYear, NULL, &tz); - else - (void)GetTimeZoneInformation(&tz); - if (tz.StandardDate.wMonth) { - if (is_start_day_before(&tz.DaylightDate, &tz.StandardDate)) { - /* northern hemisphere */ - dst = (!is_day_before(&localTime, &tz.DaylightDate) - && is_day_before(&localTime, &tz.StandardDate)); - } else { - /* southern hemisphere */ - dst = (is_day_before(&localTime, &tz.StandardDate) - || !is_day_before(&localTime, &tz.DaylightDate)); - } - } - if (dst) { + TIME_ZONE_INFORMATION tz; + if (rktio_system_time_is_dst(&localTime, &tz)) { tzoffset = (tz.Bias + tz.DaylightBias) * -60; tzn = NARROW_PATH_copy(tz.DaylightName); } else { diff -Nru racket-6.12+ppa1/src/schemify/equal.rkt racket-7.0+ppa1/src/schemify/equal.rkt --- racket-6.12+ppa1/src/schemify/equal.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/equal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,40 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt") + +;; Since a Racket `equal?` will shadow the host Scheme's `equal?`, +;; its optimizer won't be able to reduce `equal?` to `eq?` or `eqv?` +;; with obvious arguments. So, we perform that conversion in schemify. + +(provide equal-implies-eq? + equal-implies-eqv?) + +(define (equal-implies-eq? e) + (match e + [`(quote ,val) + (let ([val (unwrap val)]) + (or (symbol? val) + (keyword? val) + (null? val) + (boolean-or-fixnum? val)))] + [`,val + (let ([val (unwrap val)]) + ;; Booleans and numbers don't have to be quoted + (boolean-or-fixnum? val))])) + +(define (boolean-or-fixnum? val) + (or (boolean? val) + (and (integer? val) + (exact? val) + ;; Always fixnum? conservatively... + (<= (- (expt 2 24)) val (- (expt 2 24) 1))))) + +(define (equal-implies-eqv? e) + (match e + [`(quote ,val) + (let ([val (unwrap val)]) + (or (number? val) + (char? val)))] + [`,val + (let ([val (unwrap val)]) + (number? val))])) diff -Nru racket-6.12+ppa1/src/schemify/export.rkt racket-7.0+ppa1/src/schemify/export.rkt --- racket-6.12+ppa1/src/schemify/export.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/export.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +#lang racket/base +(provide (struct-out export)) + +(struct export (id ext-id)) diff -Nru racket-6.12+ppa1/src/schemify/find-definition.rkt racket-7.0+ppa1/src/schemify/find-definition.rkt --- racket-6.12+ppa1/src/schemify/find-definition.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/find-definition.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,94 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "struct-type-info.rkt" + "optimize.rkt" + "infer-known.rkt") + +(provide find-definitions) + +;; Record top-level functions and structure types, and returns +;; (values knowns struct-type-info-or-#f) +(define (find-definitions v prim-knowns knowns imports mutated optimize?) + (match v + [`(define-values (,id) ,orig-rhs) + (define rhs (if optimize? + (optimize orig-rhs prim-knowns knowns imports mutated) + orig-rhs)) + (values + (let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated)]) + (if k + (hash-set knowns (unwrap id) k) + knowns)) + #f)] + [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) ; pattern from `struct` or `define-struct` + (let-values (((,struct: ,make ,? ,-ref ,-set!) ,rhs)) + (values ,struct:2 + ,make2 + ,?2 + ,make-acc/muts ...))) + (define info (and (wrap-eq? struct: struct:2) + (wrap-eq? make make2) + (wrap-eq? ? ?2) + (make-struct-type-info rhs prim-knowns knowns imports mutated))) + (cond + [info + (define type (gensym (symbol->string (unwrap make-s)))) + (let* ([knowns (hash-set knowns + (unwrap make-s) + (if (struct-type-info-pure-constructor? info) + (known-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type) + a-known-constant))] + [knowns (hash-set knowns + (unwrap s?) + (known-predicate 2 type))] + [knowns + (for/fold ([knowns knowns]) ([id (in-list acc/muts)] + [maker (in-list make-acc/muts)]) + (cond + [(wrap-eq? (wrap-car maker) -ref) + (hash-set knowns (unwrap id) (known-accessor 2 type))] + [else + (hash-set knowns (unwrap id) (known-mutator 4 type))]))]) + (values (hash-set knowns (unwrap struct:s) (known-struct-type type + (struct-type-info-field-count info) + (struct-type-info-pure-constructor? info))) + info))] + [else (values knowns #f)])] + [`(define-values (,struct:s ,make-s ,s? ,s-ref ,s-set!) ,rhs) ; direct use of `make-struct-type` + (define info (make-struct-type-info rhs prim-knowns knowns imports mutated)) + (cond + [info + (define type (gensym (symbol->string (unwrap make-s)))) + (values + (let* ([knowns (hash-set knowns + (unwrap make-s) + (if (struct-type-info-pure-constructor? info) + (known-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type) + a-known-constant))] + [knowns (hash-set knowns + (unwrap s?) + (known-predicate 2 type))]) + ;; For now, we don't try to track the position-consuming accessor or mutator + (hash-set knowns (unwrap struct:s) (known-struct-type type + (struct-type-info-field-count info) + (struct-type-info-pure-constructor? info)))) + info)] + [else (values knowns #f)])] + [`(define-values (,prop:s ,s? ,s-ref) + (make-struct-type-property ,_ . ,rest)) + (define type (gensym (symbol->string prop:s))) + (values + (let* ([knowns (hash-set knowns (unwrap s-ref) (known-accessor 2 type))] + [knowns (hash-set knowns (unwrap s?) (known-predicate 2 type))]) + ;; Check whether the property type has an immediate (or no) guard: + (cond + [(or (null? (unwrap rest)) + (and (not (wrap-car rest)) + (null? (unwrap (wrap-cdr rest))))) + (hash-set knowns (unwrap prop:s) (known-struct-type-property/immediate-guard))] + [else knowns])) + #f)] + [`,_ (values knowns #f)])) diff -Nru racket-6.12+ppa1/src/schemify/find-known.rkt racket-7.0+ppa1/src/schemify/find-known.rkt --- racket-6.12+ppa1/src/schemify/find-known.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/find-known.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,19 @@ +#lang racket/base +(require "wrap.rkt" + "import.rkt" + "known.rkt" + "mutated-state.rkt") + +(provide find-known) + +(define (find-known key prim-knowns knowns imports mutated) + (cond + [(hash-ref prim-knowns key #f) + => (lambda (k) k)] + [(hash-ref-either knowns imports key) + => (lambda (k) + (and (simple-mutated-state? (hash-ref mutated key #f)) + (if (known-copy? k) + (find-known (unwrap (known-copy-id k)) prim-knowns knowns imports mutated) + k)))] + [else #f])) diff -Nru racket-6.12+ppa1/src/schemify/import.rkt racket-7.0+ppa1/src/schemify/import.rkt --- racket-6.12+ppa1/src/schemify/import.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/import.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,105 @@ +#lang racket/base +(provide (struct-out import) + (struct-out import-group) + + import-group-lookup-ready? + + import-group-lookup + import-lookup + + hash-ref-either + + make-add-import!) + +(struct import (grp id int-id ext-id)) +(struct import-group (index + key + [knowns/proc #:mutable] ; starts as a procedure to get table + [converter #:mutable] ; converts table entries to `known`s (i.e., lazy conversion) + [import-keys #:mutable] ; vector of imports, used for inlining + [imports #:mutable])) ; starts as declared imports, but inlining can grow + +(define (import-group-knowns grp) + (define knowns/proc (import-group-knowns/proc grp)) + (cond + [(procedure? knowns/proc) + (define-values (knowns converter import-keys) (knowns/proc (import-group-key grp))) + (define knowns-or-empty (or knowns (hasheq))) + (set-import-group-knowns/proc! grp knowns-or-empty) + (set-import-group-converter! grp converter) + (set-import-group-import-keys! grp import-keys) + knowns-or-empty] + [else knowns/proc])) + +(define (import-group-lookup-ready? grp) + (define knowns/proc (import-group-knowns/proc grp)) + (not (procedure? knowns/proc))) + +(define (import-group-lookup g id) + (define v (hash-ref (import-group-knowns g) id #f)) + (if v + (let ([converter (import-group-converter g)]) + (if converter + (converter v) + v)) + v)) + +(define (import-lookup im) + (import-group-lookup (import-grp im) (import-ext-id im))) + +(define (hash-ref-either knowns imports key) + (or (hash-ref knowns key #f) + (let ([im (hash-ref imports key #f)]) + (and im + (import-lookup im))))) + +(define (make-add-import! imports grps get-import-knowns add-group!) + (define next-index (length grps)) + (lambda (im ext-id index) + ;; The `im` argument represents an import into the current + ;; linklet. Let L be the linklet for that import. Map `ext-id` as + ;; either defined in L (if `index` is #f) or imported into L from + ;; its `index`th group to a new name in the current module, + ;; potentially adding an import or import group to the current module. + (define grp (import-grp im)) + (cond + [index + (import-group-knowns grp) ; force thunk + (define import-keys (import-group-import-keys grp)) + (define key (and import-keys (vector-ref import-keys index))) + (and key ; no key available => can't inline + (let ([from-grp (find-or-add-import-group! grps key + get-import-knowns + add-group! + next-index + (lambda () (set! next-index (add1 next-index))))]) + (and from-grp + (find-or-add-import-from-group! from-grp ext-id imports))))] + [else + (find-or-add-import-from-group! grp ext-id imports)]))) + +(define (find-or-add-import-from-group! grp ext-id imports) + (or (for/or ([im (in-list (import-group-imports grp))]) + (and (eq? ext-id (import-ext-id im)) + (import-int-id im))) + ;; `ext-id` from the group is not currently imported; add it as an import + (let ([id (gensym ext-id)] + [int-id (gensym ext-id)]) + (define im (import grp id int-id ext-id)) + (set-import-group-imports! grp (cons im (import-group-imports grp))) + (hash-set! imports int-id im) + int-id))) + +(define (find-or-add-import-group! grps key get-import-knowns add-group! next-index inc-index!) + (or (for/or ([grp (in-list grps)]) + (and (eq? key (import-group-key grp)) + grp)) + ;; The current linklet doesn't currently import from the linklet + ;; that supplies an identifier to be inlined; add the linklet + ;; as a new import group + (let ([grp (import-group next-index key + get-import-knowns #f #f + '())]) + (inc-index!) + (add-group! grp) + grp))) diff -Nru racket-6.12+ppa1/src/schemify/infer-known.rkt racket-7.0+ppa1/src/schemify/infer-known.rkt --- racket-6.12+ppa1/src/schemify/infer-known.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/infer-known.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,115 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "simple.rkt" + "pthread-parameter.rkt" + "literal.rkt" + "inline.rkt" + "mutated-state.rkt") + +(provide infer-known + lambda?) + +;; For definitions, it's useful to infer `a-known-constant` to reflect +;; that the variable will get a value without referencing anything +;; too early. +(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated) + (cond + [(lambda? rhs) + (define-values (lam inlinable?) (extract-lambda rhs)) + (define arity-mask (lambda-arity-mask lam)) + (if (and inlinable? + (or (can-inline? lam) + (wrap-property defn 'compiler-hint:cross-module-inline))) + (known-procedure/can-inline arity-mask lam) + (known-procedure arity-mask))] + [(and (literal? rhs) + (not (hash-ref mutated (unwrap id) #f))) + (known-literal (unwrap-literal rhs))] + [(and (symbol? (unwrap rhs)) + (not (hash-ref mutated (unwrap id) #f))) + (define u-rhs (unwrap rhs)) + (cond + [(hash-ref prim-knowns u-rhs #f) + => (lambda (known) (known-copy u-rhs))] + [(not (simple-mutated-state? (hash-ref mutated u-rhs #f))) + ;; referenced variable is mutated, but not necessarily the target + (and defn a-known-constant)] + [(hash-ref-either knowns imports u-rhs) + => (lambda (known) + (cond + [(known-procedure/can-inline/need-imports? known) + ;; can't just return `known`, since that loses the connection to the import; + ;; the `inline-clone` function specially handles an identifier as the + ;; expression to inline + (known-procedure/can-inline (known-procedure-arity-mask known) + rhs)] + [(or (known-procedure/can-inline? known) + (known-literal? known)) + known] + [(not defn) + (known-copy rhs)] + [else known]))] + [defn a-known-constant] + [else (known-copy rhs)])] + [(pthread-parameter? rhs prim-knowns knowns mutated) + (known-procedure 3)] + [(and defn + (simple? rhs prim-knowns knowns imports mutated)) + a-known-constant] + [else #f])) + +;; ---------------------------------------- + +;; Recognize forms that produce plain procedures +(define (lambda? v #:simple? [simple? #f]) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`(let-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) + (lambda? body))] + [`(letrec-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) + (lambda? body))] + [`(let-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(begin ,body) (lambda? body)] + [`(values ,body) (lambda? body)] + [`,_ #f])) + +;; Recognize forms that produce plain procedures +(define (extract-lambda v) + (match v + [`(lambda . ,_) (values v #t)] + [`(case-lambda . ,_) (values v #t)] + [`(let-values ([(,id) ,rhs]) ,body) + (if (wrap-eq? id body) + (extract-lambda rhs) + (extract-lambda* body))] + [`(letrec-values ([(,id) ,rhs]) ,body) + (if (wrap-eq? id body) + (extract-lambda rhs) + (extract-lambda* body))] + [`(let-values ,_ ,body) (extract-lambda* body)] + [`(letrec-values ,_ ,body) (extract-lambda* body)] + [`(begin ,body) (extract-lambda body)] + [`(values ,body) (extract-lambda body)])) + +(define (extract-lambda* v) + (define-values (lam inlinable?) (extract-lambda v)) + (values lam #f)) + +(define (lambda-arity-mask v) + (match v + [`(lambda ,args . ,_) (args-arity-mask args)] + [`(case-lambda [,argss . ,_] ...) + (for/fold ([mask 0]) ([args (in-list argss)]) + (bitwise-ior mask (args-arity-mask args)))])) + +(define (args-arity-mask args) + (cond + [(wrap-null? args) 1] + [(wrap-pair? args) + (arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)] + [else -1])) diff -Nru racket-6.12+ppa1/src/schemify/inline.rkt racket-7.0+ppa1/src/schemify/inline.rkt --- racket-6.12+ppa1/src/schemify/inline.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/inline.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,279 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "export.rkt") + +(provide init-inline-fuel + can-inline? + inline-clone + known-inline->export-known) + +(define inline-base 3) +(define inline-factor 3) +(define init-inline-fuel 8) + +(define (can-inline? v) + (match v + [`(lambda ,args . ,bodys) + (smaller-than? bodys (+ inline-base (* inline-factor (args-size args))))] + [`(case-lambda [,argss . ,bodyss] ...) + (for/and ([args (in-list argss)] + [bodys (in-list bodyss)]) + (smaller-than? bodys (+ inline-base (* inline-factor (args-size args)))))] + [`,_ #f])) + +(define (args-size args) + (cond + [(wrap-pair? args) (+ 1 (args-size (wrap-cdr args)))] + [else 1])) + +(define (smaller-than? v size) + (positive? + (let loop ([v v] [size size]) + (cond + [(zero? size) 0] + [(wrap-pair? v) + (loop (wrap-cdr v) (loop (wrap-car v) size))] + [else (sub1 size)])))) + +;; ---------------------------------------- + +;; All binding identifiers in a clone must be fresh to stay consistent +;; with the unique-variable invariant of expanded/schemified form. + +(define (inline-clone k im add-import! mutated imports reannotate) + (define env (if (known-procedure/can-inline/need-imports? k) + ;; The `needed->env` setup can fail if a needed + ;; import cannot be made available: + (needed->env (known-procedure/can-inline/need-imports-needed k) + add-import! + im) + '())) + (and + env + (match (known-procedure/can-inline-expr k) + [`(lambda ,args . ,bodys) + (define-values (new-args new-env) (clone-args args env mutated)) + `(lambda ,new-args . ,(clone-body bodys new-env mutated reannotate))] + [`(case-lambda [,argss . ,bodyss] ...) + `(case-lambda ,@(for/list ([args (in-list argss)] + [bodys (in-list bodyss)]) + (define-values (new-args new-env) (clone-args args env mutated)) + `[,new-args . ,(clone-body bodys new-env mutated reannotate)]))] + [`,id + ;; We expect `id` to refer to an imported variable, where inlining the + ;; imported variable will need to pull from there + (cond + [(hash-ref imports (unwrap id) #f) + => (lambda (im) + (define i-k (import-lookup im)) + (and (known-procedure/can-inline? i-k) + (inline-clone i-k im add-import! mutated imports reannotate)))] + [else #f])]))) + +;; Build a mapping from ids in the expr to imports into the current +;; linklet, where `add-import!` arranges for the import to exist as +;; needed and if possible. The result is #f if some import cannot be +;; made available. +(define (needed->env needed add-import! im) + (for/fold ([env '()]) ([need (in-list needed)]) + (and env + (let ([id (add-import! im (cadr need) (cddr need))]) + (and id + (cons (cons (car need) id) env)))))) + +(define (clone-args args base-env mutated) + (define env + (let loop ([args args]) + (cond + [(wrap-null? args) base-env] + [(wrap-pair? args) + (define u (unwrap (wrap-car args))) + (define g (gensym u)) + (define m (hash-ref mutated u #f)) + (when m + (hash-set! mutated g m)) + (cons (cons u g) + (loop (wrap-cdr args)))] + [else + (define u (unwrap args)) + (cons (cons u (gensym u)) base-env)]))) + (values (let loop ([args args] [env env]) + (cond + [(wrap-null? args) '()] + [(wrap-pair? args) + (define u (unwrap (wrap-car args))) + (cons (cdr (car env)) + (loop (wrap-cdr args) (cdr env)))] + [else + (cdr (car env))])) + env)) + +(define (clone-body l env mutated reannotate) + (for/list ([e (in-wrap-list l)]) + (clone-expr e env mutated reannotate))) + +(define (clone-let v env mutated reannotate) + (match v + [`(,let-id ([,idss ,rhss] ...) ,bodys ...) + (define-values (rev-new-idss new-env) + (for/fold ([rev-new-idss null] [env env]) ([ids (in-list idss)]) + (define-values (new-ids new-env) (clone-args ids env mutated)) + (values (cons new-ids rev-new-idss) new-env))) + `(,let-id ,(for/list ([ids (in-list (reverse rev-new-idss))] + [rhs (in-list rhss)]) + `[,ids ,(clone-expr rhs new-env mutated reannotate)]) + . ,(clone-body bodys new-env mutated reannotate))])) + +(define (clone-expr v env mutated reannotate) + (reannotate + v + (match v + [`(lambda ,args . ,bodys) + `(lambda ,args . ,(clone-body bodys env mutated reannotate))] + [`(case-lambda [,argss . ,bodyss] ...) + `(case-lambda ,@(for/list ([args (in-list argss)] + [bodys (in-list bodyss)]) + `[,args . ,(clone-body bodys env mutated reannotate)]))] + [`(quote ,_) v] + [`(let-values . ,_) (clone-let v env mutated reannotate)] + [`(letrec-values . ,_) (clone-let v env mutated reannotate)] + [`(if ,tst ,thn ,els) + `(if ,(clone-expr tst env mutated reannotate) + ,(clone-expr thn env mutated reannotate) + ,(clone-expr els env mutated reannotate))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(clone-expr key env mutated reannotate) + ,(clone-expr val env mutated reannotate) + ,(clone-expr body env mutated reannotate))] + [`(begin ,exps ...) + `(begin . ,(clone-body exps env mutated reannotate))] + [`(begin0 ,exps ...) + `(begin0 . ,(clone-body exps env mutated reannotate))] + [`(set! ,id ,rhs) + `(set! ,id ,(clone-expr rhs env mutated reannotate))] + [`(#%variable-reference) v] + [`(#%variable-reference ,id) + `(#%variable-reference ,(clone-expr id env mutated reannotate))] + [`(,rator . ,_) + (clone-body v env mutated reannotate)] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(symbol? u-v) + (lookup env u-v v)] + [else v]))]))) + +(define (lookup env sym default) + (cond + [(null? env) default] + [(eq? (caar env) sym) + (cdar env)] + [else (lookup (cdr env) sym default)])) + +;; ---------------------------------------- + +(define (known-inline->export-known k prim-knowns imports exports) + (cond + [(known-procedure/can-inline? k) + (define needed + (needed-imports (known-procedure/can-inline-expr k) prim-knowns imports exports '() '#hasheq())) + (cond + [(not needed) (known-procedure (known-procedure-arity-mask k))] + [(hash-empty? needed) k] + [else + (known-procedure/can-inline/need-imports + (known-procedure-arity-mask k) + (known-procedure/can-inline-expr k) + (for/list ([(k v) (in-hash needed)]) + (cons k v)))])] + [else k])) + +(define (needed-imports v prim-knowns imports exports env needed) + (and + needed + (match v + [`(lambda ,args . ,bodys) + (body-needed-imports bodys prim-knowns imports exports (add-args env args) needed)] + [`(case-lambda [,argss . ,bodyss] ...) + (for/fold ([needed needed]) ([args (in-list argss)] + [bodys (in-list bodyss)]) + (body-needed-imports bodys prim-knowns imports exports (add-args env args) needed))] + [`(quote ,_) needed] + [`(let-values . ,_) (let-needed-imports v prim-knowns imports exports env needed)] + [`(letrec-values . ,_) (let-needed-imports v prim-knowns imports exports env needed)] + [`(if ,tst ,thn ,els) + (needed-imports tst prim-knowns imports exports env + (needed-imports thn prim-knowns imports exports env + (needed-imports els prim-knowns imports exports env + needed)))] + [`(with-continuation-mark ,key ,val ,body) + (needed-imports key prim-knowns imports exports env + (needed-imports val prim-knowns imports exports env + (needed-imports body prim-knowns imports exports env + needed)))] + [`(begin ,exps ...) + (body-needed-imports exps prim-knowns imports exports env needed)] + [`(begin0 ,exps ...) + (body-needed-imports exps prim-knowns imports exports env needed)] + [`(set! ,id ,rhs) + (define u (unwrap id)) + (cond + [(hash-ref exports id #f) + ;; Cannot inline assignment to an exported variable + #f] + [else + (needed-imports id prim-knowns imports exports env + (needed-imports rhs prim-knowns imports exports env + needed))])] + [`(#%variable-reference . ,_) + ;; Cannot inline a variable reference + #f] + [`(,rator . ,_) + (body-needed-imports v prim-knowns imports exports env needed)] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(symbol? u-v) + (cond + [(or (memq u-v env) + (hash-ref prim-knowns u-v #f) + (hash-ref needed u-v #f)) + needed] + [(hash-ref exports u-v #f) + => (lambda (ex) + (hash-set needed u-v (cons (export-ext-id ex) #f)))] + [(hash-ref imports u-v #f) + => (lambda (im) + (hash-set needed u-v (cons (import-ext-id im) + (import-group-index (import-grp im)))))] + [else + ;; Free variable (possibly defined but not exported) => cannot inline + #f])] + [else needed]))]))) + +(define (body-needed-imports l prim-knowns imports exports env needed) + (for/fold ([needed needed]) ([e (in-wrap-list l)]) + (needed-imports e prim-knowns imports exports env needed))) + +(define (let-needed-imports v prim-knowns imports exports env needed) + (match v + [`(,let-id ([,idss ,rhss] ...) ,bodys ...) + (define new-env (for*/fold ([env env]) ([ids (in-list idss)] + [id (in-list ids)]) + (cons (unwrap id) env))) + (body-needed-imports bodys prim-knowns imports exports new-env + (for/fold ([needed needed]) ([rhs (in-list rhss)]) + (needed-imports rhs prim-knowns imports exports new-env + needed)))])) + +(define (add-args env args) + (cond + [(wrap-null? args) env] + [(wrap-pair? args) + (add-args (cons (unwrap (wrap-car args)) env) + (wrap-cdr args))] + [else + (cons (unwrap args) env)])) diff -Nru racket-6.12+ppa1/src/schemify/interp-match.rkt racket-7.0+ppa1/src/schemify/interp-match.rkt --- racket-6.12+ppa1/src/schemify/interp-match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/interp-match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,41 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/unsafe/ops) + +;; All patterns for an interpreter matcher are vectors, +;; and each vector element is an unquote or a symbol +;; to match literally. + +(provide interp-match) + +(define-syntax interp-match + (syntax-rules () + [(_ e) + (let ([v e]) + (error 'interp-match "no matching clause"))] + [(_ e [pat . rhs] . clauses) + (let ([v e]) + (if (matches? v pat) + (let-vars v pat . rhs) + (interp-match v . clauses)))])) + +(define-syntax (matches? stx) + (syntax-case stx () + [(_ v #(elem ...)) + #`(and #,@(for/list ([e (in-list (syntax->list #'(elem ...)))] + [i (in-naturals)]) + (syntax-case e (unquote) + [,id #'#t] + [s #`(eq? 's (unsafe-vector*-ref v #,i))])))])) + +(define-syntax (let-vars stx) + (syntax-case stx () + [(_ v #(elem ...) . body) + #`(let #,(for/list ([e (in-list (syntax->list #'(elem ...)))] + [i (in-naturals)] + #:when (syntax-case e (unquote) + [,id #t] + [_ #f])) + (syntax-case e (unquote) + [,id #`[id (unsafe-vector*-ref v #,i)]])) + . body)])) diff -Nru racket-6.12+ppa1/src/schemify/interpret.rkt racket-7.0+ppa1/src/schemify/interpret.rkt --- racket-6.12+ppa1/src/schemify/interpret.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/interpret.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,480 @@ +#lang racket/base +(require racket/unsafe/undefined + racket/unsafe/ops + "match.rkt" + "wrap.rkt" + "interp-match.rkt") + +;; Interpreter for the output of "jitify". This little interpreter is +;; useful to avoid going through a more heavyweight `eval` or +;; `interpret`, mainly because we don't need to go through a macro +;; expander. Also, because it's tailored to the shape of a linklet +;; outer layer, it can implement that layer more efficiently and +;; compactly. + +(provide interpretable-jitified-linklet + interpret-linklet) + +(struct indirect (stack element)) +(struct indirect-checked indirect ()) + +(define (interpretable-jitified-linklet linklet-e strip-annotations) + ;; Return a compiled linklet in two parts: a vector expression for + ;; constants to be run once, and a expression for the linklet body. + ;; A compiled expression uses a list as a stack for local variables, + ;; where the coldest element is is a vector of constants, and the + ;; 1th slot is a vector of linklet arguments for imports and + ;; exports, and the 2nd slot is a vector for top-level variables. We + ;; don't have to worry about continuations, because linklet bodies + ;; are constrained. + ;; + ;; Bindings in the environment are represented as positions that + ;; count from the coldest end of the stack; that position relative + ;; to the hottest end can be computed from the current stack depth. + + (define (stack->pos stack-depth i) + (- stack-depth i 1)) + + (define (start linklet-e) + (match linklet-e + [`(lambda . ,_) + ;; No constants: + (define-values (compiled-body num-body-vars) + (compile-linklet-body linklet-e '#hasheq() 0)) + (vector #f + num-body-vars + compiled-body)] + [`(let* ,bindings ,body) + (let loop ([bindings bindings] [pos 0] [env '#hasheq()] [accum '()]) + (cond + [(null? bindings) + (define-values (compiled-body num-body-vars) + (compile-linklet-body body env 1)) + (vector (list->vector (reverse accum)) + num-body-vars + compiled-body)] + [else + (let ([binding (car bindings)]) + (loop (cdr bindings) + (add1 pos) + (hash-set env (car binding) (indirect 0 pos)) + (cons (compile-expr (cadr binding) env 1) + accum)))]))])) + + (define (compile-linklet-body v env stack-depth) + (match v + [`(lambda ,args . ,body) + (define args-env + (for/fold ([env env]) ([arg (in-list args)] + [i (in-naturals)]) + (hash-set env arg (indirect stack-depth i)))) + (define body-vars-index (add1 stack-depth)) + (define-values (body-env num-body-vars) + (for/fold ([env args-env] [num-body-vars 0]) ([e (in-wrap-list body)]) + (let loop ([e e] [env env] [num-body-vars num-body-vars]) + (match e + [`(define ,id . ,_) + (values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars)) + (add1 num-body-vars))] + [`(define-values ,ids . ,_) + (for/fold ([env env] [num-body-vars num-body-vars]) ([id (in-wrap-list ids)]) + (values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars)) + (add1 num-body-vars)))] + [`(begin . ,body) + (for/fold ([env env] [num-body-vars num-body-vars]) ([e (in-wrap-list body)]) + (loop e env num-body-vars))] + [`,_ (values env num-body-vars)])))) + (values (compile-top-body body body-env (+ 2 stack-depth)) + num-body-vars)])) + + ;; Like `compile-body`, but flatten top-level `begin`s + (define (compile-top-body body env stack-depth) + (define bs (let loop ([body body]) + (match body + [`() '()] + [`((begin ,subs ...) . ,rest) + (loop (append subs rest))] + [`(,e . ,rest) + (cons (compile-expr e env stack-depth) + (loop rest))]))) + (cond + [(null? bs) '#(void)] + [(and (pair? bs) (null? (cdr bs))) + (car bs)] + [else + (list->vector (cons 'begin bs))])) + + (define (compile-body body env stack-depth) + (match body + [`(,e) (compile-expr e env stack-depth)] + [`,_ + (list->vector + (cons 'begin + (for/list ([e (in-wrap-list body)]) + (compile-expr e env stack-depth))))])) + + (define (compile-expr e env stack-depth) + (match e + [`(lambda ,ids . ,body) + (define-values (body-env count rest?) + (args->env ids env stack-depth)) + (vector 'lambda (count->mask count rest?) (compile-body body body-env (+ stack-depth count)))] + [`(case-lambda [,idss . ,bodys] ...) + (define lams (for/list ([ids (in-list idss)] + [body (in-list bodys)]) + (compile-expr `(lambda ,ids . ,body) env stack-depth))) + (define mask (for/fold ([mask 0]) ([lam (in-list lams)]) + (bitwise-ior mask (interp-match lam [#(lambda ,mask) mask])))) + (list->vector (list* 'case-lambda mask lams))] + [`(let ([,ids ,rhss] ...) . ,body) + (define len (length ids)) + (define body-env + (for/fold ([env env]) ([id (in-list ids)] + [i (in-naturals)]) + (hash-set env (unwrap id) (+ stack-depth i)))) + (vector 'let + (for/vector #:length len ([rhs (in-list rhss)]) + (compile-expr rhs env stack-depth)) + (compile-body body body-env (+ stack-depth len)))] + [`(letrec . ,_) (compile-letrec e env stack-depth)] + [`(letrec* . ,_) (compile-letrec e env stack-depth)] + [`(begin . ,vs) + (compile-body vs env stack-depth)] + [`(begin0 ,e . ,vs) + (vector 'begin0 (compile-expr e env stack-depth) (compile-body vs env stack-depth))] + [`(pariah ,e) + (compile-expr e env stack-depth)] + [`(if ,tst ,thn ,els) + (vector 'if + (compile-expr tst env stack-depth) + (compile-expr thn env stack-depth) + (compile-expr els env stack-depth))] + [`(with-continuation-mark ,key ,val ,body) + (vector 'wcm + (compile-expr key env stack-depth) + (compile-expr val env stack-depth) + (compile-expr body env stack-depth))] + [`(quote ,v) + (let ([v (strip-annotations v)]) + ;; Protect with `quote` any value that looks like an + ;; interpreter instruction: + (if (or (vector? v) + (pair? v) + (symbol? v) + (number? v)) + (vector 'quote v) + v))] + [`(set! ,id ,rhs) + (compile-assignment id rhs env stack-depth)] + [`(define ,id ,rhs) + (compile-assignment id rhs env stack-depth)] + [`(define-values ,ids ,rhs) + (define gen-ids (for/list ([id (in-list ids)]) + (gensym id))) + (compile-expr `(call-with-values (lambda () ,rhs) + (lambda ,gen-ids + ,@(if (null? ids) + '((void)) + (for/list ([id (in-list ids)] + [gen-id (in-list gen-ids)]) + `(set! ,id ,gen-id))))) + env + stack-depth)] + [`(call-with-values ,proc1 (lambda ,ids . ,body)) + (compile-expr `(call-with-values ,proc1 (case-lambda + [,ids . ,body])) + env + stack-depth)] + [`(call-with-values (lambda () . ,body) (case-lambda [,idss . ,bodys] ...)) + (vector 'cwv + (compile-body body env stack-depth) + (for/list ([ids (in-list idss)] + [body (in-list bodys)]) + (define-values (new-env count rest?) + (args->env ids env stack-depth)) + (vector (count->mask count rest?) + (compile-body body new-env (+ stack-depth count)))))] + [`(variable-set! ,dest-id ,e ',constance) + (define dest-var (hash-ref env (unwrap dest-id))) + (vector 'set-variable! + (stack->pos stack-depth (indirect-stack dest-var)) (indirect-element dest-var) + (compile-expr e env stack-depth) + constance)] + [`(variable-ref ,id) + (define var (hash-ref env (unwrap id))) + (vector 'ref-variable/checked (stack->pos stack-depth (indirect-stack var)) (indirect-element var))] + [`(variable-ref/no-check ,id) + (define var (hash-ref env (unwrap id))) + (vector 'ref-variable (stack->pos stack-depth (indirect-stack var)) (indirect-element var))] + [`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth)] + [`(,rator ,_ ...) (compile-apply e env stack-depth)] + [`,id + (define u (unwrap id)) + (define var (hash-ref env u #f)) + (cond + [(not var) + (if (number? u) + (vector 'quote u) + u)] + [(indirect? var) + (define pos (stack->pos stack-depth (indirect-stack var))) + (define elem (indirect-element var)) + (if (indirect-checked? var) + (vector 'ref-indirect/checked pos elem u) + (cons pos elem))] + [else + (stack->pos stack-depth var)])])) + + (define (compile-letrec e env stack-depth) + (match e + [`(,_ ([,ids ,rhss] ...) . ,body) + (define (make-env indirect) + (for/fold ([env env]) ([id (in-list ids)] + [i (in-naturals)]) + (hash-set env (unwrap id) (indirect stack-depth i)))) + (define rhs-env (make-env indirect-checked)) + (define body-env (make-env indirect)) + (define body-stack-depth (add1 stack-depth)) + (vector 'letrec + (for/vector #:length (length ids) ([rhs (in-list rhss)]) + (compile-expr rhs rhs-env body-stack-depth)) + (compile-body body body-env body-stack-depth))])) + + (define (compile-apply es env stack-depth) + (list->vector (cons 'app + (for/list ([e (in-wrap-list es)]) + (compile-expr e env stack-depth))))) + + (define (compile-assignment id rhs env stack-depth) + (define compiled-rhs (compile-expr rhs env stack-depth)) + (define u (unwrap id)) + (define var (hash-ref env u)) + (cond + [(indirect? var) + (define s (stack->pos stack-depth (indirect-stack var))) + (define e (indirect-element var)) + (if (indirect-checked? var) + (vector 'set!-indirect/checked s e compiled-rhs u) + (vector 'set!-indirect s e compiled-rhs))] + [else (error 'compile "unexpected set!")])) + + (define (args->env ids env stack-depth) + (let loop ([ids ids] [env env] [count 0]) + (cond + [(wrap-null? ids) (values env count #f)] + [(wrap-pair? ids) (loop (wrap-cdr ids) + (hash-set env (unwrap (wrap-car ids)) (+ stack-depth count)) + (add1 count))] + [else + (values (hash-set env (unwrap ids) (+ stack-depth count)) + (add1 count) + #t)]))) + + (start linklet-e)) + +;; ---------------------------------------- + +(define (interpret-linklet b primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (interp-match + b + [#(,consts ,num-body-vars ,b) + (let ([consts (and consts + (let ([vec (make-vector (vector-length consts))]) + (define stack (list vec)) + (for ([b (in-vector consts)] + [i (in-naturals)]) + (vector-set! vec i (interpret-expr b stack primitives void void void void)) + vec) + vec))]) + (lambda args + (define body-vec (make-vector num-body-vars unsafe-undefined)) + (define base-stack (if consts (list consts) null)) + (define stack (list* body-vec (list->vector args) base-stack)) + (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure)))])) + +(define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (define (interpret b stack) + (cond + [(integer? b) (list-ref stack b)] + [(pair? b) (vector-ref (list-ref stack (car b)) (cdr b))] + [(symbol? b) (hash-ref primitives b)] + [(vector? b) + (interp-match + b + [#(app ,rator-b) + (define len (vector-length b)) + (define rator (interpret rator-b stack)) + (cond + [(eq? len 2) + (rator)] + [(eq? len 3) + (rator + (interpret (unsafe-vector*-ref b 2) stack))] + [(eq? len 4) + (rator + (interpret (unsafe-vector*-ref b 2) stack) + (interpret (unsafe-vector*-ref b 3) stack))] + [else + (apply (interpret rator-b stack) + (for/list ([b (in-vector b 2)]) + (interpret b stack)))])] + [#(quote ,v) v] + [#(ref-indirect/checked ,s ,e ,name) + (define v (vector-ref (list-ref stack s) e)) + (check-not-unsafe-undefined v name)] + [#(ref-variable ,s ,e) + (variable-ref/no-check (vector-ref (list-ref stack s) e))] + [#(ref-variable/checked ,s ,e) + (variable-ref (vector-ref (list-ref stack s) e))] + [#(let ,rhss ,b) + (define len (vector-length rhss)) + (let loop ([i 0] [new-stack stack]) + (if (= i len) + (interpret b new-stack) + (loop (add1 i) (cons (interpret (unsafe-vector*-ref rhss i) stack) + new-stack))))] + [#(letrec ,rhss ,b) + (define len (vector-length rhss)) + (define frame-vec (make-vector len unsafe-undefined)) + (define new-stack (cons frame-vec stack)) + (let loop ([i 0]) + (if (= i len) + (interpret b new-stack) + (begin + (vector-set! frame-vec i (interpret (vector-ref rhss i) new-stack)) + (loop (add1 i)))))] + [#(begin) + (define last (sub1 (vector-length b))) + (let loop ([i 1]) + (if (= i last) + (interpret (unsafe-vector*-ref b i) stack) + (begin + (interpret (unsafe-vector*-ref b i) stack) + (loop (add1 i)))))] + [#(begin0 ,b0) + (define last (sub1 (unsafe-vector-length b))) + (begin0 + (interpret b0 stack) + (let loop ([i 2]) + (interpret (unsafe-vector*-ref b i) stack) + (unless (= i last) + (loop (add1 i)))))] + [#(if ,tst ,thn ,els) + (if (interpret tst stack) + (interpret thn stack) + (interpret els stack))] + [#(wcm ,key ,val ,body) + (with-continuation-mark + (interpret key stack) + (interpret val stack) + (interpret body stack))] + [#(cwv ,b ,clauses) + (define vs (call-with-values (lambda () (interpret b stack)) list)) + (define len (length vs)) + (let loop ([clauses clauses]) + (cond + [(null? clauses) (error 'call-with-values "arity error")] + [else + (interp-match + (car clauses) + [#(,mask ,b) + (if (matching-argument-count? mask len) + (interpret b (push-stack stack vs mask)) + (loop (cdr clauses)))])]))] + [#(lambda ,mask ,b) + (make-arity-wrapper-procedure + (lambda args + (if (matching-argument-count? mask (length args)) + (interpret b (push-stack stack args mask)) + (error "arity error"))) + mask + #f)] + [#(case-lambda ,mask) + (define n (vector-length b)) + (make-arity-wrapper-procedure + (lambda args + (define len (length args)) + (let loop ([i 2]) + (cond + [(= i n) (error "arity error")] + [else + (interp-match + (unsafe-vector*-ref b i) + [#(lambda ,mask ,b) + (if (matching-argument-count? mask len) + (interpret b (push-stack stack args mask)) + (loop (add1 i)))])]))) + mask + #f)] + [#(set-variable! ,s ,e ,b ,c) + (variable-set! (vector-ref (list-ref stack s) e) + (interpret b stack) + c)] + [#(set!-indirect ,s ,e ,b) + (unsafe-vector*-set! (list-ref stack s) e (interpret b stack))] + [#(set!-indirect/checked ,s ,e ,b ,name) + (define v (interpret b stack)) + (define vec (list-ref stack s)) + (check-not-unsafe-undefined/assign (unsafe-vector*-ref vec e) name) + (unsafe-vector*-set! vec e v)])] + [else b])) + + (define (matching-argument-count? mask len) + (bitwise-bit-set? mask len)) + + (interpret b stack)) + +;; mask has a single bit set or all bits above some bit +(define (push-stack stack vals mask) + (define rest? (negative? mask)) + (define count (if rest? + (integer-length mask) + (sub1 (integer-length mask)))) + (let loop ([stack stack] [vals vals] [count (if rest? (sub1 count) count)]) + (cond + [(zero? count) + (if rest? (cons vals stack) stack)] + [else + (loop (cons (car vals) stack) (cdr vals) (sub1 count))]))) + +(define (count->mask count rest?) + (arithmetic-shift (if rest? -1 1) count)) + +;; ---------------------------------------- + +(module+ main + (define primitives (hash 'list list + 'vector vector + 'add1 add1 + 'values values + 'continuation-mark-set-first continuation-mark-set-first)) + (define b + (interpretable-jitified-linklet '(let* ([s "string"]) + (lambda (x two-box) + (define other 5) + (begin + (define f (lambda (y) + (vector x y))) + (define g (case-lambda + [() no] + [ys + (vector x ys)]))) + (define-values (one two) (values 100 200)) + (variable-set! two-box two 'constant) + (letrec ([ok 'ok]) + (set! other (call-with-values (lambda () (values 71 (begin0 88 ok))) + (lambda (v q) (list q v)))) + (with-continuation-mark + 'x 'cm/x + (list (if s s #f) x ok other + (f 'vec) (g 'also-vec 'more) + one two (variable-ref two-box) + (continuation-mark-set-first #f 'x 'no)))))) + values)) + (define l (interpret-linklet b primitives unbox unbox (lambda (b v c) + (set-box! b v)) + (lambda (proc mask name) proc))) + (l 'the-x (box #f))) diff -Nru racket-6.12+ppa1/src/schemify/jitify.rkt racket-7.0+ppa1/src/schemify/jitify.rkt --- racket-6.12+ppa1/src/schemify/jitify.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/jitify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,771 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt") + +;; Convert `lambda`s to make them fully closed, which is compatible +;; with JIT compilation of the `lambda` or separate ahead-of-time +;; compilation (as opposed to compiling a whole linklet). + +;; If `convert-size-threashold` is #f, then every `lambda` is +;; converted. If it's a number, then only `lambda`s smaller than the +;; threshold are converted, and and no `lambda` within a converted +;; `lambda` is converted. So, supplying a numerical threshold is +;; useful for drawing a boundary between compiled and non-compiled +;; code, as opposed to a true JIT setup. + +;; An environment maps a variables that needs to be passed into the +;; closed code: +;; +;; * id -> '#:direct --- ready by the time it's needed and immutable +;; +;; * id -> expression --- rewrite access to expression +;; +;; * id -> `(self ,m) --- a reference to the enclosing function; can +;; use directly in rator position, otherwise +;; use m + +(provide jitify-schemified-linklet) + +(define (jitify-schemified-linklet v + need-extract? + convert-size-threshold ; #f or a number; see above + extractable-annotation + reannotate) + + ;; Constucts a closed `lambda` form as wrapped with + ;; `extractable-annotaton` and generates an application of + ;; `extract[-closed]-id` to the wrapped form. + (define (make-jit-on-call free-vars argss v name env) + (define ids (for/list ([id (in-hash-keys free-vars)]) + id)) + (define (extract-id m id) + (match m + [`(variable-ref ,var) var] + [`(unbox ,var) var] + [`(unbox/check-undefined ,var ,_) var] + [`(self ,m ,orig-id) orig-id] + [`(self ,m) (extract-id m id)] + [`,_ id])) + (define captures (hash-keys + ;; `extract-id` for different `id`s can produce the + ;; same `id`, so hash and then convert to a list + (for/hash ([id (in-list ids)]) + (values (extract-id (hash-ref env id) id) #t)))) + (define jitted-proc + (or (match (and name + (hash-ref free-vars (unwrap name) #f) + (hash-ref env (unwrap name) #f)) + [`(self ,m ,orig-name) + (cond + [(eq? orig-name name) + (define self-id (extract-id m name)) + `(let ([,self-id ,orig-name]) + (letrec ([,name ,v]) + ,name))] + [else #f])] + [`,_ #f]) + (match (and name + (hash-ref env (unwrap name) #f)) + [`(self . ,_) + ;; Might have a direct self-call, so use `letrec`: + `(letrec ([,name ,v]) + ,name)] + [`,_ #f]) + (cond + [name + ;; No direct self-reference, but encourage the compiler + ;; to name the procedure: + `(let ([,name ,v]) + ,name)] + [else v]))) + (define arity-mask (argss->arity-mask argss)) + (cond + [(null? captures) + (let ([e (extractable-annotation jitted-proc arity-mask name)]) + (if need-extract? + `(jitified-extract-closed ',e) + `',e))] + [else + (let ([e (extractable-annotation `(lambda ,captures + ,jitted-proc) + arity-mask + name)]) + (if need-extract? + `((jitified-extract ',e) . ,captures) + `(',e . ,captures)))])) + + ;; ---------------------------------------- + + (define (top) + ;; Match outer shape of a linklet produced by `schemify-linklet` + ;; and lift in the linklet body: + (let loop ([v v] [env #hasheq()]) + (match v + [`(lambda ,args . ,body) + (define new-body (jitify-schemified-body body (plain-add-args env args))) + (if (for/and ([old (in-list body)] + [new (in-list new-body)]) + (eq? old new)) + v + (reannotate v `(lambda ,args . ,new-body)))] + [`(let* ,bindings ,body) + (define new-body (loop body (add-bindings env bindings))) + (if (eq? body new-body) + v + (reannotate v `(let* ,bindings ,new-body)))]))) + + (define (jitify-schemified-body body env) + (define top-env + (for/fold ([env env]) ([v (in-list body)]) + (let loop ([v v] [env env]) + (match v + [`(variable-set! ,var-id ,id . ,_) + (hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))] + [`(define ,_ (begin (variable-set! ,var-id ,id . ,_) (void))) + (hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))] + [`(define ,id ,rhs) (plain-add-args env id)] + [`(define-values ,ids ,rhs) (plain-add-args env ids)] + [`(begin . ,vs) + (for/fold ([env env]) ([v (in-wrap-list vs)]) + (loop v env))] + [`,_ env])))) + (let loop ([body body]) + (for/list ([v (in-list body)]) + (match v + [`(variable-set! ,var-id ,id . ,_) v] + [`(define ,_ (begin (variable-set! ,var-id ,id . ,_) (void))) v] + [`(define ,id ,rhs) + ;; If there's a direct reference to `id` in `rhs`, then + ;; `id` must not be mutable + (define self-env (add-self top-env #hasheq() id)) + (reannotate v `(define ,id ,(jitify-top-expr rhs self-env id)))] + [`(define-values ,ids ,rhs) + (reannotate v `(define-values ,ids ,(jitify-top-expr rhs top-env #f)))] + [`(begin . ,vs) + (reannotate v `(begin . ,(loop vs)))] + [`,_ (jitify-top-expr v top-env #f)])))) + + (define (jitify-top-expr v env name) + ;; The `mutables` table doesn't track shadowing on the assumption + ;; that local variable names are sufficiently distinguished to prevent + ;; one mutable variable from polluting another in a different scope + (define mutables (find-mutable #hasheq() v #hasheq())) + (define convert-mode (init-convert-mode v)) + (define-values (new-v free) (jitify-expr v env mutables #hasheq() convert-mode name #f)) + new-v) + + ;; The `name` argument is a name to be given to the expresison `v` + ;; if it's a function. It also corresponds to a name that can be + ;; called directly, as long as it's mapped in `env` to a '(self ...) + ;; value. + ;; The `in-name` argument is the current self `name` that is in effect + ;; for the current expression. It might be mapped to '(self ...) + ;; and need to be unmapped for a more nested function. + (define (jitify-expr v env mutables free convert-mode name in-name) + (match v + [`(lambda ,args . ,body) + (define convert? (convert-mode-convert-lambda? convert-mode v)) + (define body-convert-mode (convert-mode-lambda-body-mode convert-mode convert?)) + (define self-env (if convert? + (activate-self (deactivate-self env in-name) name) + env)) + (define body-env (add-args self-env args mutables body-convert-mode)) + (define body-in-name (if convert? (or name '#:anonymous) in-name)) + (define-values (new-body lam-body-free) + (jitify-body body body-env mutables #hasheq() body-convert-mode #f body-in-name)) + (define lam-free (remove-args lam-body-free args)) + (define new-v (reannotate v `(lambda ,args . ,(mutable-box-bindings args mutables body-convert-mode + new-body)))) + (values (if (not convert?) + new-v + (make-jit-on-call lam-free (list args) new-v name self-env)) + (union-free free lam-free))] + [`(case-lambda [,argss . ,bodys] ...) + (define convert? (convert-mode-convert-lambda? convert-mode v)) + (define body-convert-mode (convert-mode-lambda-body-mode convert-mode convert?)) + (define self-env (if convert? + (activate-self (deactivate-self env in-name) name) + env)) + (define body-in-name (if convert? (or name '#:anonymous) in-name)) + (define-values (rev-new-bodys lam-free) + (for/fold ([rev-new-bodys '()] [lam-free #hasheq()]) ([args (in-list argss)] + [body (in-list bodys)]) + (define body-env (add-args self-env args mutables body-convert-mode)) + (define-values (new-body lam-body-free) + (jitify-body body body-env mutables #hasheq() body-convert-mode #f body-in-name)) + (values (cons new-body rev-new-bodys) + (union-free (remove-args lam-body-free args) + lam-free)))) + (define new-v (reannotate v + `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list (reverse rev-new-bodys))]) + `[,args . ,(mutable-box-bindings args mutables body-convert-mode + body)])))) + (values (if (not convert?) + new-v + (make-jit-on-call lam-free argss new-v name self-env)) + (union-free free lam-free))] + [`(let . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(letrec . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(letrec* . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(begin . ,vs) + (define-values (new-body new-free) (jitify-body vs env mutables free convert-mode name in-name)) + (values (reannotate v `(begin . ,new-body)) + new-free)] + [`(begin0 ,v0 . ,vs) + (define-values (new-v0 v0-free) + (jitify-expr v0 env mutables free (convert-mode-non-tail convert-mode) name in-name)) + (define-values (new-body new-free) + (jitify-body vs env mutables v0-free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(begin0 ,new-v0 . ,new-body)) + new-free)] + [`(pariah ,e) + (define-values (new-e new-free) (jitify-expr e env mutables free convert-mode name in-name)) + (values (reannotate v `(pariah ,new-e)) + new-free)] + [`(if ,tst ,thn ,els) + (define sub-convert-mode (convert-mode-non-tail convert-mode)) + (define-values (new-tst new-free/tst) (jitify-expr tst env mutables free sub-convert-mode #f in-name)) + (define-values (new-thn new-free/thn) (jitify-expr thn env mutables new-free/tst convert-mode name in-name)) + (define-values (new-els new-free/els) (jitify-expr els env mutables new-free/thn convert-mode name in-name)) + (values (reannotate v `(if ,new-tst ,new-thn ,new-els)) + new-free/els)] + [`(with-continuation-mark ,key ,val ,body) + (define sub-convert-mode (convert-mode-non-tail convert-mode)) + (define-values (new-key new-free/key) (jitify-expr key env mutables free sub-convert-mode #f in-name)) + (define-values (new-val new-free/val) (jitify-expr val env mutables new-free/key sub-convert-mode #f in-name)) + (define-values (new-body new-free/body) (jitify-expr body env mutables new-free/val convert-mode name in-name)) + (values (reannotate v `(with-continuation-mark ,new-key ,new-val ,new-body)) + new-free/body)] + [`(quote ,_) (values v free)] + [`(set! ,var ,rhs) + (define-values (new-rhs new-free) (jitify-expr rhs env mutables free (convert-mode-non-tail convert-mode) var in-name)) + (define id (unwrap var)) + (define dest (hash-ref env id #f)) + (cond + [(and (not in-name) + (match dest + [`(variable-ref ,_) #t] + [`,_ #f])) + ;; Not under lambda: don't rewrite references to definitions + (values `(set! ,var ,new-rhs) + new-free)] + [else + (define newer-free (if dest + (hash-set new-free id dest) + new-free)) + (define new-v + (match (hash-ref env id '#:direct) + [`#:direct (reannotate v `(set! ,var ,new-rhs))] + [`(self ,m . ,_) (error 'set! "[internal error] self-referenceable ~s" id)] + [`(variable-ref ,var-id) (reannotate v `(variable-set! ,var-id ,new-rhs '#f))] + [`(unbox ,box-id) (reannotate v `(set-box! ,box-id ,new-rhs))] + [`(unbox/check-undefined ,box-id ,_) (reannotate v `(set-box!/check-undefined ,box-id ,new-rhs ',var))])) + (values new-v newer-free)])] + [`(call-with-values ,proc1 ,proc2) + (define proc-convert-mode (convert-mode-called convert-mode)) + (define-values (new-proc1 new-free1) (jitify-expr proc1 env mutables free proc-convert-mode #f in-name)) + (define-values (new-proc2 new-free2) (jitify-expr proc2 env mutables new-free1 proc-convert-mode #f in-name)) + (define call-with-values-id (if (and (lambda? new-proc1) (lambda? new-proc2)) + 'call-with-values + '#%call-with-values)) + (values (reannotate v `(,call-with-values-id ,new-proc1 ,new-proc2)) + new-free2)] + [`(#%app ,_ ...) + (define-values (new-vs new-free) + (jitify-body (wrap-cdr v) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(#%app . ,new-vs)) + new-free)] + [`(,rator ,_ ...) + (define u (unwrap rator)) + (match (and (symbol? u) (hash-ref env u #f)) + [`(self ,_ ,orig-id) + ;; Keep self call as direct + (define-values (new-vs new-free) + (jitify-body (wrap-cdr v) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(,rator . ,new-vs)) + new-free)] + [`,x + (define-values (new-vs new-free) + (jitify-body v env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v new-vs) + new-free)])] + [`,var + (define id (unwrap var)) + (define dest (hash-ref env id #f)) + (cond + [(and (not in-name) + (match dest + [`(variable-ref ,_) #t] + [`,_ #f])) + ;; Not under lambda: don't rewrite references to definitions + (values var free)] + [else + (define new-var + (match dest + [`#f var] + [`#:direct var] + [`(self ,u . ,_) (reannotate v u)] + [`,u (reannotate v u)])) + (define new-free + (if dest + (hash-set free id dest) + free)) + (values new-var + new-free)])])) + + (define (lambda? v) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`,_ #f])) + + (define (jitify-body vs env mutables free convert-mode name in-name) + (let loop ([vs vs] [free free]) + (cond + [(wrap-null? vs) (values null free)] + [(wrap-null? (wrap-cdr vs)) + (define-values (new-v new-free) + (jitify-expr (wrap-car vs) env mutables free convert-mode name in-name)) + (values (list new-v) new-free)] + [else + (define-values (new-v new-free) + (jitify-expr (wrap-car vs) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (define-values (new-rest newer-free) + (loop (wrap-cdr vs) new-free)) + (values (cons new-v new-rest) + newer-free)]))) + + (define (jitify-let v env mutables free convert-mode name in-name) + (match v + [`(,let-form ([,ids ,rhss] ...) . ,body) + (define rec? + (and (case (unwrap let-form) + [(letrec letrec*) #t] + [else #f]) + ;; Use simpler `let` code if we're not responsible for boxing: + (convert-mode-box-mutables? convert-mode))) + (define rhs-convert-mode (convert-mode-non-tail convert-mode)) + (define rhs-env (if rec? + (add-args/unbox env ids mutables + (lambda (var) #t) + (not (for/and ([rhs (in-list rhss)]) + (lambda? rhs))) + convert-mode) + env)) + (define-values (rev-new-rhss rhs-free) + (for/fold ([rev-new-rhss '()] [free #hasheq()]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define self-env + (if rec? + (add-self rhs-env mutables id) + rhs-env)) + (define-values (new-rhs rhs-free) + (jitify-expr rhs self-env mutables free rhs-convert-mode id in-name)) + (values (cons new-rhs rev-new-rhss) rhs-free))) + (define local-env + (add-args/unbox env ids mutables + (lambda (var) (and rec? (hash-ref rhs-free var #f))) + #f + convert-mode)) + (define-values (new-body new-free) + (jitify-body body local-env mutables (union-free free rhs-free) convert-mode name in-name)) + (define new-v + (cond + [(not rec?) + ;; Wrap boxes around rhs results as needed: + `(,let-form ,(for/list ([id (in-list ids)] + [new-rhs (in-list (reverse rev-new-rhss))]) + `[,id ,(if (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables (unwrap id) #f)) + `(box ,new-rhs) + new-rhs)]) + . ,new-body)] + [else + ;; Allocate boxes first, then fill in + `(let ,(for*/list ([id (in-list ids)] + #:when (hash-ref rhs-free (unwrap id) #f)) + `[,id (box unsafe-undefined)]) + ;; Using nested `let`s to force left-to-right + ,(for/fold ([body (body->expr new-body)]) ([id (in-list (reverse ids))] + [new-rhs (in-list rev-new-rhss)]) + `(let (,(cond + [(hash-ref rhs-free (unwrap id) #f) + `[,(gensym 'ignored) (set-box! ,id ,new-rhs)]] + [(hash-ref mutables (unwrap id) #f) + `[,id (box ,new-rhs)]] + [else `[,id ,new-rhs]])) + ,body)))])) + (values (reannotate v new-v) + (remove-args new-free ids))])) + + (define (mutable-box-bindings args mutables convert-mode body) + (cond + [(convert-mode-box-mutables? convert-mode) + (define bindings + (let loop ([args args]) + (cond + [(wrap-null? args) null] + [(wrap-pair? args) + (define id (wrap-car args)) + (define var (unwrap id)) + (define rest (loop (wrap-cdr args))) + (if (hash-ref mutables var #f) + (cons `[,id (box ,id)] rest) + rest)] + [else (loop (list args))]))) + (if (null? bindings) + body + `((let ,bindings . ,body)))] + [else body])) + + ;; ---------------------------------------- + + ;; When mutables and convert mode are not relevant: + (define (plain-add-args env args) + (define (add-one id) + (hash-set env (unwrap id) '#:direct)) + (match args + [`(,id . ,args) + (plain-add-args (add-one id) args)] + [`() env] + [`,id (add-one id)])) + + ;; Add a binding to an environment, record whether it needs + ;; to be unboxed on reference: + (define (add-args env args mutables convert-mode) + (define (add-one id) + (define u (unwrap id)) + (define val (if (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables u #f)) + `(unbox ,id) + '#:direct)) + (hash-set env u val)) + (match args + [`(,id . ,args) + (add-args (add-one id) args mutables convert-mode)] + [`() env] + [`,id (add-one id)])) + + ;; Further generalization of `add-args` to add undefined-checking + ;; variant of unbox: + (define (add-args/unbox env args mutables var-rec? maybe-undefined? convert-mode) + (define (add-one id) + (define var (unwrap id)) + (cond + [maybe-undefined? (hash-set env var `(unbox/check-undefined ,id ',id))] + [(not (or (var-rec? var) (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables var #f)))) + (hash-set env var '#:direct)] + [else (hash-set env var `(unbox ,id))])) + (match args + [`(,id . ,args) + (add-args/unbox (add-one id) args mutables var-rec? maybe-undefined? convert-mode)] + [`() env] + [`,id (add-one id)])) + + (define (remove-args env args) + (match args + [`(,id . ,args) + (remove-args (hash-remove env (unwrap id)) args)] + [`() env] + [`,id (hash-remove env (unwrap id))])) + + (define (add-bindings env bindings) + (match bindings + [`([,ids ,_] ...) + (for/fold ([env env]) ([id (in-list ids)]) + (plain-add-args env id))])) + + (define (add-self env mutables name) + (define u (unwrap name)) + (cond + [(hash-ref mutables u #f) + env] + [else + (hash-set env u `(self ,(hash-ref env u '#:direct)))])) + + ;; Adjust an environment to indicate that `name` in an application + ;; position is a self-call, which helps preserves the visiblilty of + ;; loops to a later compiler + (define (activate-self env name) + (cond + [name + (define (genself) (gensym 'self)) + (define u (unwrap name)) + (define new-m + (match (hash-ref env u #f) + [`(self #:direct) + `(self ,(genself) ,name)] + [`(self (variable-ref ,orig-id)) + `(self (variable-ref ,orig-id) ,orig-id)] + [`(self (unbox ,orig-id)) + `(self (unbox ,(genself)) ,orig-id)] + [`(self (unbox/check-undefined ,orig-id ,sym)) + `(self (unbox/check-undefined ,(genself) ,sym) ,orig-id)] + [`,_ #f])) + (if new-m + (hash-set env u new-m) + env)] + [else env])) + + ;; Adjust an environment to indicate that applying `name` is no + ;; longer a self call + (define (deactivate-self env name) + (cond + [name + (define u (unwrap name)) + (match (hash-ref env u #f) + [`(self ,m ,_) (hash-set env u m)] + [`,_ env])] + [else env])) + + ;; ---------------------------------------- + + (define (argss->arity-mask argss) + (for/fold ([mask 0]) ([args (in-list argss)]) + (bitwise-ior mask + (let loop ([args args] [count 0]) + (cond + [(wrap-null? args) (arithmetic-shift 1 count)] + [(wrap-pair? args) (loop (wrap-cdr args) (add1 count))] + [else (bitwise-xor -1 (sub1 (arithmetic-shift 1 count)))]))))) + + (define (de-dot args) + (cond + [(wrap-pair? args) (cons (wrap-car args) + (de-dot (wrap-cdr args)))] + [else (list args)])) + + (define (union-free a b) + (cond + [((hash-count b) . < . (hash-count a)) (union-free b a)] + [else + (for/fold ([b b]) ([(k v) (in-hash a)]) + (hash-set b k v))])) + + (define (body->expr body) + (cond + [(and (wrap-pair? body) (wrap-null? (wrap-cdr body))) + (wrap-car body)] + [else `(begin . ,body)])) + + ;; ---------------------------------------- + + (define (find-mutable env v accum) + (match v + [`(lambda ,args . ,body) + (body-find-mutable (plain-add-args env args) body accum)] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([accum accum]) ([args (in-list argss)] + [body (in-list bodys)]) + (body-find-mutable (plain-add-args env args) body accum))] + [`(let . ,_) (find-mutable-in-let env v accum)] + [`(letrec . ,_) (find-mutable-in-let env v accum)] + [`(letrec* . ,_) (find-mutable-in-let env v accum)] + [`(begin . ,vs) (body-find-mutable env vs accum)] + [`(begin0 . ,vs) (body-find-mutable env vs accum)] + [`(if ,tst ,thn ,els) + (find-mutable env tst + (find-mutable env thn + (find-mutable env els accum)))] + [`(with-continuation-mark ,key ,val ,body) + (find-mutable env key + (find-mutable env val + (find-mutable env body accum)))] + [`(quote ,_) accum] + [`(set! ,var ,rhs) + (define id (unwrap var)) + (find-mutable env rhs (if (hash-ref env id #f) + (hash-set accum id #t) + accum))] + [`(,_ ...) (body-find-mutable env v accum)] + [`,_ accum])) + + (define (body-find-mutable env body accum) + (for/fold ([accum accum]) ([v (in-wrap-list body)]) + (find-mutable env v accum))) + + (define (find-mutable-in-let env v accum) + (match v + [`(,let-form ([,ids ,rhss] ...) . ,body) + (define local-env + (for/fold ([env env]) ([id (in-list ids)]) + (plain-add-args env id))) + (define rhs-env + (case (unwrap let-form) + [(letrec letrec* letrec*-values) local-env] + [else env])) + (body-find-mutable local-env + body + (for/fold ([accum accum]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (find-mutable rhs-env rhs accum)))])) + + ;; ---------------------------------------- + ;; Convert mode + ;; + ;; If there's no size threshold for conversion, then convert mode is + ;; simply 'called or 'not-called. + ;; + ;; If there's a size threshold, then a convert mode is a + ;; `convert-mode` instance. + + (struct convert-mode (sizes called? no-more-conversions?)) + + (define (init-convert-mode v) + (cond + [convert-size-threshold + (convert-mode (record-sizes v) #f #f)] + [else 'not-called])) + + (define (convert-mode-convert-lambda? cm v) + (cond + [(eq? cm 'called) #f] + [(eq? cm 'not-called) #t] + [(convert-mode-called? cm) #f] + [(convert-mode-no-more-conversions? cm) #f] + [((hash-ref (convert-mode-sizes cm) v) . >= . convert-size-threshold) #f] + [else #t])) + + (define (convert-mode-lambda-body-mode cm convert?) + (cond + [(convert-mode? cm) + (if convert? + (convert-mode 'not-needed #f #t) + (convert-mode-non-tail cm))] + [else 'not-called])) + + (define (convert-mode-non-tail cm) + (cond + [(convert-mode? cm) + (struct-copy convert-mode cm + [called? #f])] + [else 'not-called])) + + (define (convert-mode-called cm) + (cond + [(convert-mode? cm) + (struct-copy convert-mode cm + [called? #t])] + [else 'called])) + + (define (convert-mode-box-mutables? cm) + (cond + [(convert-mode? cm) + (not (convert-mode-no-more-conversions? cm))] + [else #t])) + + ;; ---------------------------------------- + + (define (record-sizes v) + (let ([sizes (make-hasheq)]) + (record-sizes! v sizes) + sizes)) + + (define (record-size! v sizes size) + (hash-set! sizes v size) + size) + + (define (record-sizes! v sizes) + (match v + [`(lambda ,args . ,body) + (record-size! v sizes (body-record-sizes! body sizes))] + [`(case-lambda [,_ . ,bodys] ...) + (define new-size + (for/sum ([body (in-list bodys)]) + (body-record-sizes! body sizes))) + (record-size! v sizes new-size)] + [`(let . ,_) (record-sizes-in-let! v sizes)] + [`(letrec . ,_) (record-sizes-in-let! v sizes)] + [`(letrec* . ,_) (record-sizes-in-let! v sizes)] + [`(begin . ,vs) (add1 (body-record-sizes! vs sizes))] + [`(begin0 . ,vs) (add1 (body-record-sizes! vs sizes))] + [`(if ,tst ,thn ,els) + (+ 1 + (record-sizes! tst sizes) + (record-sizes! thn sizes) + (record-sizes! els sizes))] + [`(with-continuation-mark ,key ,val ,body) + (+ 1 + (record-sizes! key sizes) + (record-sizes! val sizes) + (record-sizes! body sizes))] + [`(quote ,_) 1] + [`(set! ,_ ,rhs) + (add1 (record-sizes! rhs sizes))] + [`(,_ ...) (body-record-sizes! v sizes)] + [`,_ 1])) + + (define (body-record-sizes! body sizes) + (for/sum ([v (in-wrap-list body)]) + (record-sizes! v sizes))) + + (define (record-sizes-in-let! v sizes) + (match v + [`(,let-form ([,_ ,rhss] ...) . ,body) + (+ 1 + (for/sum ([rhs (in-list rhss)]) + (record-sizes! rhs sizes)) + (body-record-sizes! body sizes))])) + + ;; ---------------------------------------- + + (top)) + +;; ============================================================ + +(module+ main + (require racket/pretty) + (pretty-print + (jitify-schemified-linklet (values ; datum->correlated + '(lambda (iv xv do-immediate) + (define top (letrec ([odd (lambda (x) (even x))] + [even (lambda (x) (odd x))] + [selfx (lambda (x) (selfx x))] + [selfy (lambda (x) (vector (selfy x) selfy))]) + (odd 5))) + (define top-selfx (lambda (x) (top-selfx x))) + (variable-set! top-selfx-var top-selfx 'const) + (define top-selfy (lambda (x) (vector (top-selfy x) top-selfy))) + (variable-set! top-selfy-var top-selfy 'const) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + (lambda (z w) 10)) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + (letrec ([selfz (lambda (z) (selfz (selfz z)))]) + (lambda (z w) (selfz w)))) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + void) + (define y (letrec ([f (lambda (x) (f (cons x x)))] + [g (lambda (q) (set! f g) (f q))]) + (list (lambda (f) (list x))))) + (define x (lambda (j) j)) + (define x2 (lambda () (letrec ([other (lambda () (other iv))]) + other))) + (define whatever (begin (variable-set! xv x 'const) (void))) + (define end (letrec ([w (lambda (x) (let ([proc (lambda (x) x)]) + (proc q)))] + [q q]) + (lambda (j) (set! q j)))) + (define topz (letrec ([helper (lambda (x) + (helper (topz x)))]) + (lambda (y) (helper y)))) + (variable-set! topz-var topz 'const) + (do-immediate topz) + (define sets-arg (lambda (x) + (values (lambda () (set! x (add1 x))) + (lambda () x)))) + (letrec ([outer + (lambda (x) + (letrec ([inner + (lambda (y) + (outer y))]) + (inner x)))]) + (outer 5)) + (lambda () (let ([x 5]) (set! x 6) x)))) + #t + #f ; size threshold + vector + (lambda (v u) u) + values))) diff -Nru racket-6.12+ppa1/src/schemify/known.rkt racket-7.0+ppa1/src/schemify/known.rkt --- racket-6.12+ppa1/src/schemify/known.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/known.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,63 @@ +#lang racket/base + +;; Ths module uses `#:omit-define-syntaxes` and doesn't use +;; `struct-out` so that none of the exports are syntax bindings. + +(provide known-constant known-constant? + known-consistent known-consistent? + known-copy? known-copy known-copy-id + known-literal known-literal? known-literal-expr + known-procedure known-procedure? known-procedure-arity-mask + known-procedure/can-inline known-procedure/can-inline? known-procedure/can-inline-expr + known-procedure/can-inline/need-imports known-procedure/can-inline/need-imports? + known-procedure/can-inline/need-imports-needed + known-procedure/succeeds known-procedure/succeeds? + known-struct-type known-struct-type? known-struct-type-type + known-struct-type-field-count known-struct-type-pure-constructor? + known-constructor known-constructor? known-constructor-type + known-predicate known-predicate? known-predicate-type + known-accessor known-accessor? known-accessor-type + known-mutator known-mutator? known-mutator-type + known-struct-type-property/immediate-guard known-struct-type-property/immediate-guard? + a-known-constant + a-known-consistent) + +;; reflects an immutable variable, but nothing is known about the +;; variable's value +(struct known-constant () #:prefab #:omit-define-syntaxes) + +;; the value at run time always has the same "shape", such as always being +;; a procedure of 1 argument, always being a structure type, or always +;; being a predicate for a structure type +(struct known-consistent () #:prefab #:omit-define-syntaxes #:super struct:known-constant) + +;; copy propagation --- use for local bindings or copies of primitives, only +(struct known-copy (id) #:prefab #:omit-define-syntaxes #:super struct:known-constant) + +;; literal for constant propagation: +(struct known-literal (expr) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +;; procedure with arity mark; the procedure has to be a procedure from the host +;; Scheme's perspective --- not an applicable struct or chaperoned procedure, which +;; means that parameters don't count +(struct known-procedure (arity-mask) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +(struct known-procedure/can-inline (expr) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +(struct known-procedure/can-inline/need-imports (needed) ; (list (cons (cons <#f-or-index>)) ...) + #:prefab #:omit-define-syntaxes #:super struct:known-procedure/can-inline) + +;; procedure that succeeds for all arguments and is functional so that it can be reordered +(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure) + +(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +;; procedures with a known connection to a structure type: +(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) +(struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) +(struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) + +(struct known-struct-type-property/immediate-guard () #:prefab #:omit-define-syntaxes) + +(define a-known-constant (known-constant)) +(define a-known-consistent (known-consistent)) diff -Nru racket-6.12+ppa1/src/schemify/left-to-right.rkt racket-7.0+ppa1/src/schemify/left-to-right.rkt --- racket-6.12+ppa1/src/schemify/left-to-right.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/left-to-right.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,127 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "simple.rkt") + +(provide left-to-right/let + left-to-right/let-values + left-to-right/app + + make-let-values) + +;; Convert a `let` to nested lets to enforce order; we +;; rely on the fact that the Racket expander generates +;; expressions that have no shadowing (and introduce +;; shadowing here) +(define (left-to-right/let ids rhss bodys + prim-knowns knowns imports mutated) + (cond + [(null? (cdr ids)) + `(let ([,(car ids) ,(car rhss)]) . ,bodys)] + [else + (let loop ([ids ids] [rhss rhss] [all-simple? #t] [binds null]) + (cond + [(null? (cdr rhss)) + (define id (car ids)) + (define rhs (car rhss)) + (if (and all-simple? + (simple? rhs prim-knowns knowns imports mutated)) + `(let ([,id ,rhs]) + . ,bodys) + `(let ([,id ,rhs]) + (let ,binds ; <- allocate ids after all `rhs`s are evaluated + . ,bodys)))] + [else + (define id (car ids)) + (define rhs (car rhss)) + `(let ([,id ,rhs]) + ,(loop (cdr ids) + (cdr rhss) + (and all-simple? + (simple? rhs prim-knowns knowns imports mutated)) + (cons `[,id ,id] binds)))]))])) + +;; Convert a `let-values` to nested `let-values`es to +;; enforce order +(define (left-to-right/let-values idss rhss bodys mutated for-cify?) + (cond + [(null? (cdr idss)) + (define e (if (null? (cdr bodys)) + (car bodys) + `(begin . ,bodys))) + (make-let-values (car idss) (car rhss) e for-cify?)] + [else + (let loop ([idss idss] [rhss rhss] [binds null]) + (cond + [(null? (cdr rhss)) + (make-let-values + (car idss) (car rhss) + `(let ,binds + . ,bodys) + for-cify?)] + [else + (define ids (car idss)) + (make-let-values + ids + (car rhss) + (loop (cdr idss) (cdr rhss) (append (for/list ([id (in-wrap-list ids)]) + `[,id ,id]) + binds)) + for-cify?)]))])) + +;; Convert an application to enforce left-to-right +;; evaluation order +(define (left-to-right/app rator rands plain-app? for-cify? + prim-knowns knowns imports mutated) + (cond + [for-cify? (cons rator rands)] + [else + (let loop ([l (cons rator rands)] [accum null] [pending-non-simple #f] [pending-id #f]) + (cond + [(null? l) + (let ([app + (cond + [pending-non-simple + ;; Since the last non-simple was followed only by simples, + ;; we don't need that variable + (let loop ([accum accum] [rev-accum null]) + (cond + [(null? accum) rev-accum] + [(eq? (car accum) pending-id) + (loop (cdr accum) (cons pending-non-simple rev-accum))] + [else + (loop (cdr accum) (cons (car accum) rev-accum))]))] + [else (reverse accum)])]) + (if plain-app? + app + `(|#%app| . ,app)))] + [(simple? (car l) prim-knowns knowns imports mutated) + (loop (cdr l) (cons (car l) accum) pending-non-simple pending-id)] + [pending-non-simple + `(let ([,pending-id ,pending-non-simple]) + ,(loop l accum #f #f))] + [else + (define g (gensym "app_")) + (loop (cdr l) (cons g accum) (car l) g)]))])) + +;; ---------------------------------------- + +(define (make-let-values ids rhs body for-cify?) + (cond + [(and (pair? ids) (null? (cdr ids))) + `(let ([,(car ids) ,rhs]) ,body)] + [else + (match (and (null? ids) rhs) + [`(begin ,rhs (values)) + `(begin ,rhs ,body)] + [`,_ + (cond + [for-cify? + ;; No checking + `(call-with-values (lambda () ,rhs) + (lambda ,ids ,body))] + [else + `(call-with-values (lambda () ,rhs) + (case-lambda + [,ids ,body] + [args (raise-binding-result-arity-error ',ids args)]))])])])) diff -Nru racket-6.12+ppa1/src/schemify/letrec.rkt racket-7.0+ppa1/src/schemify/letrec.rkt --- racket-6.12+ppa1/src/schemify/letrec.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/letrec.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,26 @@ +#lang racket/base +(require "wrap.rkt" + "infer-known.rkt") + +(provide letrec-splitable-values-binding? + letrec-split-values-binding) + +;; Detect binding of lambdas that were probably generated from an +;; R[56]RS program + +(define (letrec-splitable-values-binding? idss rhss) + (and (pair? idss) + (null? (cdr idss)) + (wrap-pair? (car rhss)) + (eq? 'values (wrap-car (car rhss))) + (= (length (wrap-cdr (car rhss))) + (length (car idss))) + (for/and ([rhs (in-list (wrap-cdr (car rhss)))]) + (lambda? rhs #:simple? #t)))) + +(define (letrec-split-values-binding idss rhss bodys) + `(letrec-values ,(for/list ([id (in-list (car idss))] + [rhs (in-list (wrap-cdr (car rhss)))]) + `[(,id) ,rhs]) + . ,bodys)) + diff -Nru racket-6.12+ppa1/src/schemify/let.rkt racket-7.0+ppa1/src/schemify/let.rkt --- racket-6.12+ppa1/src/schemify/let.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/let.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ +#lang racket/base + +(provide make-let*) + +(define (make-let* bindings body) + (if (null? bindings) + body + `(let* ,bindings ,body))) diff -Nru racket-6.12+ppa1/src/schemify/lift.rkt racket-7.0+ppa1/src/schemify/lift.rkt --- racket-6.12+ppa1/src/schemify/lift.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/lift.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,701 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt") + +;; Reduces closure allocation by lifting bindings that are only used +;; in calls that have the right number of arguments. + +;; The output uses `letrec` to bind lifted and closed functions, while +;; `letrec*` is still used for any other recursive binding. + +(provide lift-in-schemified-linklet + lift-in-schemified-body) + +;; An identifier registered in `lifts` is one of +;; +;; * `liftable` - a function binding that is (so far) only referenced +;; in an application position with a correct number of +;; arguments, so each call can supply the free +;; variables of the function and the closure +;; allocation (if any) can be lifted to the top level +;; +;; * `indirected` - a variable that is `set!`ed, which means that it can't be +;; replaced by an argument if it appears as a free +;; variable in a liftable function; instead, the +;; argument must be a box +;; +;; There's nothing analogous to `mutator` and `var-ref` for +;; synthesized accessors, because they're relevant only for the second +;; pass and recorded in an `indirected`. +;; +;; An identifier registered in `locals` maps to either 'ready or 'early, +;; where 'early is used during the right-hand side of a letrec that is +;; not all `lambda`s. + +(struct liftable (expr ; a `lambda` or `case-lambda` RHS of the binding + [frees #:mutable] ; set of variables free in `expr`, plus any lifted bindings + [binds #:mutable])) ; set of variables bound in `expr` + +(struct indirected ([check? #:mutable])) + +(struct mutator (orig)) ; `orig` maps back to the original identifier +(struct var-ref (orig)) ; ditto + +;; As we traverse expressions, we thread through free- and +;; bound-variable sets +(define empty-frees+binds (cons #hasheq() #hasheq())) + +(define (lift-in-schemified-linklet v reannotate) + ;; Match outer shape of a linklet produced by `schemify-linklet` + ;; and lift in the linklet body: + (let loop ([v v]) + (match v + [`(lambda ,args . ,body) + (define new-body (lift-in-schemified-body body reannotate)) + (if (for/and ([old (in-list body)] + [new (in-list new-body)]) + (eq? old new)) + v + `(lambda ,args . ,new-body))] + [`(let* ,bindings ,body) + (define new-body (loop body)) + (if (eq? body new-body) + v + `(let* ,bindings ,new-body))]))) + +(define (lift-in-schemified-body body reannotate) + (for/list ([v (in-list body)]) + (lift-in-schemified v reannotate))) + +(define (lift-in-schemified v reannotate) + ;; Quick pre-check: do any lifts appear to be possible? + (define (lift-in? v) + (match v + [`(define ,_ ,rhs) + (lift-in-expr? rhs)] + [`(define-values ,_ ,rhs) + (lift-in-expr? rhs)] + [`(begin . ,vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in? v))] + [`,_ (lift-in-expr? v)])) + + (define (lift-in-expr? v) + (match v + [`(lambda ,_ . ,body) + (lift?/seq body)] + [`(case-lambda [,_ . ,bodys] ...) + (for/or ([body (in-list bodys)]) + (lift?/seq body))] + [`(let . ,_) (lift-in-let? v)] + [`(letrec . ,_) (lift-in-let? v)] + [`(letrec* . ,_) (lift-in-let? v)] + [`(let-values . ,_) (error 'internal-error "unexpected let-values")] + [`(letrec-values . ,_) (error 'internal-error "unexpected letrec-values")] + [`(begin . ,vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in-expr? v))] + [`(if ,tst ,thn ,els) + (or (lift-in-expr? tst) (lift-in-expr? thn) (lift-in-expr? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (lift-in-expr? key) (lift-in-expr? val) (lift-in-expr? body))] + [`(quote ,_) #f] + [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] + [`(set! ,_ ,rhs) + (lift-in-expr? rhs)] + [`(,_ ...) + (lift-in-seq? v)] + [`,_ #f])) + + (define (lift-in-let? v) + (match v + [`(,_ ([,_ ,rhss] ...) . ,body) + (or (for/or ([rhs (in-list rhss)]) + (lift-in-expr? rhs)) + (lift-in-seq? body))])) + + (define (lift-in-seq? vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in-expr? v))) + + ;; Under a `lambda`; any local bindings to functions? + (define (lift? v) + (match v + [`(let . ,_) (lift?/let v)] + [`(letrec . ,_) (lift?/let v)] + [`(letrec* . ,_) (lift?/let v)] + [`(let-values . ,_) (lift?/let v)] + [`(letrec-values . ,_) (lift?/let v)] + [`(lambda ,_ . ,body) (lift?/seq body)] + [`(case-lambda [,_ . ,bodys] ...) + (for/or ([body (in-list bodys)]) + (lift?/seq body))] + [`(begin . ,vs) (lift?/seq vs)] + [`(begin0 . ,vs) (lift?/seq vs)] + [`(quote . ,_) #f] + [`(if ,tst ,thn ,els) + (or (lift? tst) (lift? thn) (lift? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (lift? key) (lift? val) (lift? body))] + [`(set! ,_ ,rhs) (lift? rhs)] + [`(#%variable-reference) #f] + [`(#%variable-reference ,id) #f] + [`(,rator . ,rands) + (or (lift? rator) (lift?/seq rands))] + [`,_ #f])) + + (define (lift?/let v) + (match v + [`(,_ ([,_ ,rhss] ...) . ,body) + (or (for/or ([rhs (in-list rhss)]) + (or (lambda? rhs) + (lift? rhs))) + (lift?/seq body))])) + + (define (lift?/seq vs) + (for/or ([v (in-wrap-list vs)]) + (lift? v))) + + ;; ---------------------------------------- + + ;; Look for a `lambda` to lift out of: + (define (lift-in v) + (match v + [`(define ,id ,rhs) + (reannotate v `(define ,id ,(lift-in-expr rhs)))] + [`(define-values ,ids ,rhs) + (reannotate v `(define-values ,ids ,(lift-in-expr rhs)))] + [`(begin ,vs ...) + (reannotate v `(begin ,@(for/list ([v (in-wrap-list vs)]) + (lift-in v))))] + [`,_ (lift-in-expr v)])) + + ;; Look for a `lambda` to lift out of: + (define (lift-in-expr v) + (match v + [`(lambda ,args . ,body) + (define lifts (make-hasheq)) + (define locals (add-args args #hasheq())) + (define frees+binds/ignored (compute-seq-lifts! body empty-frees+binds lifts locals)) + (let ([lifts (if (zero? (hash-count lifts)) + lifts + (close-and-convert-lifts lifts))]) + (cond + [(zero? (hash-count lifts)) v] + [else + `(letrec ,(extract-lifted-bindings lifts) + ,(reannotate v `(lambda ,args . ,(convert-lifted-calls-in-seq/box-mutated body args lifts #hasheq()))))]))] + [`(case-lambda [,argss . ,bodys] ...) + ;; Lift each clause separately, then splice results: + (let ([lams (for/list ([args (in-list argss)] + [body (in-list bodys)]) + (lift-in-expr `(lambda ,args . ,body)))]) + (reannotate + v + (let loop ([lams lams] [clauses null] [bindings null]) + (cond + [(null? lams) + (if (null? bindings) + `(case-lambda ,@(reverse clauses)) + `(letrec ,bindings ,(loop null clauses null)))] + [else + (match (car lams) + [`(letrec ,new-bindings ,lam) + (loop (cons lam (cdr lams)) clauses (append (unwrap-list new-bindings) bindings))] + [`(lambda ,args . ,body) + (loop (cdr lams) (cons `[,args . ,body] clauses) bindings)])]))))] + [`(let . ,_) (lift-in-let v)] + [`(letrec . ,_) (lift-in-let v)] + [`(letrec* . ,_) (lift-in-let v)] + [`(let-values . ,_) (error 'internal-error "unexpected let-values")] + [`(letrec-values . ,_) (error 'internal-error "unexpected letrec-values")] + [`(begin . ,vs) + (reannotate v `(begin ,@(for/list ([v (in-wrap-list vs)]) + (lift-in-expr v))))] + [`(if ,tst ,thn ,els) + (reannotate v `(if ,(lift-in-expr tst) + ,(lift-in-expr thn) + ,(lift-in-expr els)))] + [`(with-continuation-mark ,key ,val ,body) + (reannotate v `(with-continuation-mark ,(lift-in-expr key) + ,(lift-in-expr val) + ,(lift-in-expr body)))] + [`(quote ,_) v] + [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] + [`(set! ,id ,rhs) + (reannotate v `(set! ,id ,(lift-in-expr rhs)))] + [`(,_ ...) + (lift-in-seq v)] + [`,_ v])) + + (define (lift-in-let v) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (reannotate v `(,let-id + ,(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `[,id ,(lift-in-expr rhs)]) + . ,(lift-in-seq body)))])) + + (define (lift-in-seq vs) + (reannotate vs (for/list ([v (in-wrap-list vs)]) + (lift-in-expr v)))) + + ;; ---------------------------------------- + ;; Pass 1: figure out which bindings can be lifted, and also record + ;; information about mutated and `#%variable-reference` variables. + ;; We only care about local variables within a top-level `lambda` or + ;; `case-lambda` form. + + ;; Returns a set of free variables and a set of bound variables + ;; (paired together) while potentially mutating `lifts` + (define (compute-lifts! v frees+binds lifts locals) + (match v + [`(let ([,ids ,rhss] ...) . ,body) + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (when (lambda? rhs) + ;; RHS is a candidate for lifting + (hash-set! lifts (unwrap id) (liftable rhs #f #f)))) + (let* ([frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts locals)] + [frees+binds (compute-seq-lifts! body frees+binds lifts (add-args ids locals))]) + (remove-frees/add-binds ids frees+binds lifts))] + [`(letrec . ,_) + (compute-letrec-lifts! v frees+binds lifts locals)] + [`(letrec* . ,_) + (compute-letrec-lifts! v frees+binds lifts locals)] + [`((letrec ([,id ,rhs]) ,rator) ,rands ...) + (compute-lifts! `(letrec ([,id ,rhs]) (,rator . ,rands)) frees+binds lifts locals)] + [`((letrec* ([,id ,rhs]) ,rator) ,rands ...) + (compute-lifts! `(letrec ([,id ,rhs]) (,rator . ,rands)) frees+binds lifts locals)] + [`(lambda ,args . ,body) + (let ([frees+binds (compute-seq-lifts! body frees+binds lifts (add-args args locals))]) + (remove-frees/add-binds args frees+binds lifts))] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([frees+binds frees+binds]) ([args (in-list argss)] + [body (in-list bodys)]) + (let ([frees+binds (compute-seq-lifts! body frees+binds lifts (add-args args locals))]) + (remove-frees/add-binds args frees+binds lifts)))] + [`(begin . ,vs) + (compute-seq-lifts! vs frees+binds lifts locals)] + [`(begin0 . ,vs) + (compute-seq-lifts! vs frees+binds lifts locals)] + [`(quote . ,_) frees+binds] + [`(if ,tst ,thn ,els) + (let* ([frees+binds (compute-lifts! tst frees+binds lifts locals)] + [frees+binds (compute-lifts! thn frees+binds lifts locals)] + [frees+binds (compute-lifts! els frees+binds lifts locals)]) + frees+binds)] + [`(with-continuation-mark ,key ,val ,body) + (let* ([frees+binds (compute-lifts! key frees+binds lifts locals)] + [frees+binds (compute-lifts! val frees+binds lifts locals)] + [frees+binds (compute-lifts! body frees+binds lifts locals)]) + frees+binds)] + [`(set! ,id ,rhs) + (define var (unwrap id)) + (let ([frees+binds (cond + [(hash-ref locals var #f) + => (lambda (status) + (lookup-indirected-variable lifts var (eq? status 'early)) + (add-free frees+binds var))] + [else frees+binds])]) + (compute-lifts! rhs frees+binds lifts locals))] + [`(#%variable-reference . ,_) + (error 'internal-error "lift: unexpected variable reference")] + [`(,rator . ,rands) + (define f (unwrap rator)) + (let ([frees+binds + (cond + [(symbol? f) + (let ([proc (hash-ref lifts f #f)]) + (when (liftable? proc) + (unless (consistent-argument-count? (liftable-expr proc) (length (unwrap-list rands))) + (hash-remove! lifts f)))) + ;; Don't recur on `rator`, because we don't want + ;; to mark `f` as unliftable + (if (hash-ref locals f #f) + (add-free frees+binds f) + frees+binds)] + [else + (compute-lifts! rator frees+binds lifts locals)])]) + (compute-seq-lifts! rands frees+binds lifts locals))] + [`,_ + (define x (unwrap v)) + (cond + [(or (string? x) (bytes? x) (boolean? x) (number? x)) + frees+binds] + [else + (unless (symbol? x) + (error 'lift-in-schemified + "unrecognized expression form: ~e" + v)) + ;; If this identifier is mapped to a liftable, then + ;; the function is not liftable after all, since + ;; the reference isn't in an application position + (let ([proc (hash-ref lifts x #f)]) + (when (liftable? proc) + (hash-remove! lifts x))) + (let ([loc-status (hash-ref locals x #f)]) + (cond + [loc-status + (let ([frees+binds (add-free frees+binds x)]) + (cond + [(eq? loc-status 'early) + (lookup-indirected-variable lifts x #t) + (add-free frees+binds x)] + [else frees+binds]))] + [else frees+binds]))])])) + + ;; Like `compute-lifts!`, but for a sequence of expressions + (define (compute-seq-lifts! vs frees+binds lifts locals) + (for/fold ([frees+binds frees+binds]) ([v (in-wrap-list vs)]) + (compute-lifts! v frees+binds lifts locals))) + + ;; Similar to `compute-seq-lifts!`, but installs free-variable + ;; information in the `lifts` table for each identifier in `ids`: + (define (compute-rhs-lifts! ids rhss frees+binds lifts locals) + (for/fold ([frees+binds frees+binds]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (let ([rhs-frees+binds (compute-lifts! rhs empty-frees+binds lifts locals)] + [f (unwrap id)]) + (let ([proc (hash-ref lifts f #f)]) + (when (liftable? proc) + (set-liftable-frees! proc (car rhs-frees+binds)) + (set-liftable-binds! proc (cdr rhs-frees+binds)))) + (cons (union (car rhs-frees+binds) (car frees+binds)) + (union (cdr rhs-frees+binds) (cdr frees+binds)))))) + + ;; Handle a letrec[*] form + (define (compute-letrec-lifts! v frees+binds lifts locals) + (match v + [`(,_ ([,ids ,rhss] ...) . ,body) + (define all-lambda? + (for/and ([rhs (in-list rhss)]) + (lambda? rhs))) + (when all-lambda? + ;; Each RHS is a candidate for lifting + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (hash-set! lifts (unwrap id) (liftable rhs #f #f)))) + (let* ([rhs-locals (add-args ids locals (if all-lambda? 'ready 'early))] + [frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts rhs-locals)] + [locals (if all-lambda? + rhs-locals + (add-args ids locals))] + [frees+binds (compute-seq-lifts! body frees+binds lifts locals)]) + (remove-frees/add-binds ids frees+binds lifts))])) + + ;; ---------------------------------------- + ;; Bridge between pass 1 and 2: transitive closure of free variables + + ;; Close a liftable's free variables over other variables needed by + ;; other lifted functions that it calls. Also, clear `mutated` and + ;; `var-ref` information from `lifts` in the returned table. + (define (close-and-convert-lifts lifts) + (define new-lifts (make-hash)) + ;; Copy over `liftable`s: + (for ([(f info) (in-hash lifts)]) + (when (liftable? info) + (hash-set! new-lifts f info))) + ;; Compute the closure of free-variable sets, where a function + ;; to be lifted calls another function to be lifted, and also + ;; re-register mutators and variable references that are + ;; used. + (for ([proc (in-list (hash-values new-lifts))]) + (define frees (liftable-frees proc)) + (define binds (liftable-binds proc)) + (define closed-frees + (let loop ([frees frees] [todo (hash-keys frees)]) + (cond + [(null? todo) frees] + [else + (define v (car todo)) + (define info (hash-ref lifts v #f)) + (cond + [(liftable? info) + ;; A liftable function called by ths liftable function, + ;; so we'll need to be able to supply all of its free + ;; variables + (define v-binds (liftable-binds info)) + (let v-loop ([v-frees (hash-keys (liftable-frees info))] + [frees frees] + [todo (cdr todo)]) + (if (null? v-frees) + (loop frees todo) + (let ([g (car v-frees)]) + (cond + [(or (hash-ref frees g #f) ; avoid cycles + (hash-ref binds g #f) ; don't add if bound in this function + (hash-ref v-binds g #f)) ; don't add if local to `v` + (v-loop (cdr v-frees) frees todo)] + [else + (v-loop (cdr v-frees) + (hash-set frees g #t) + (cons g todo))]))))] + [(indirected? info) + ;; Preserve recording of this variable as boxed + (hash-set! new-lifts v info) + (loop frees (cdr todo))] + [else + ;; Normal variable: + (loop frees (cdr todo))])]))) + (set-liftable-frees! proc closed-frees)) + ;; Remove references to lifted from free-variable sets, and also + ;; convert free-variable sets to lists for consistent ordering: + (for ([proc (in-hash-values new-lifts)] + #:when (liftable? proc)) + (set-liftable-frees! proc (sort (for/list ([f (in-hash-keys (liftable-frees proc))] + #:unless (liftable? (hash-ref lifts f #f))) + f) + symbol (lambda (proc) + (reannotate v `(,rator ,@(liftable-frees proc) . ,rands)))] + [else + (reannotate v `(,(convert rator) . ,rands))]))] + [`,_ + (define var (unwrap v)) + (define info (and (symbol? var) + (hash-ref lifts var #f))) + (cond + [(indirected? info) + (reannotate v (if (indirected-check? info) + `(unbox/check-undefined ,v ',v) + `(unbox ,v)))] + [else v])]))) + + (define (convert-lifted-calls-in-seq vs lifts frees) + (reannotate vs (for/list ([v (in-wrap-list vs)]) + (convert-lifted-calls-in-expr v lifts frees)))) + + (define (convert-lifted-calls-in-let v lifts frees) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:unless (liftable? (hash-ref lifts (unwrap id) #f))) + `[,id ,(let ([rhs (convert-lifted-calls-in-expr rhs lifts frees)]) + (if (indirected? (hash-ref lifts (unwrap id) #f)) + `(box ,rhs) + rhs))])) + (define new-body + (convert-lifted-calls-in-seq body lifts frees)) + (reannotate + v + (rebuild-let let-id bindings new-body))])) + + (define (convert-lifted-calls-in-letrec v lifts frees) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define pre-bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:when (indirected? (hash-ref lifts (unwrap id) #f))) + `[,id (box unsafe-undefined)])) + (define bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:unless (liftable? (hash-ref lifts (unwrap id) #f))) + (define new-rhs (convert-lifted-calls-in-expr rhs lifts frees)) + (cond + [(indirected? (hash-ref lifts (unwrap id) #f)) + `[,(gensym) (set-box! ,id ,new-rhs)]] + [else `[,id ,new-rhs]]))) + (define new-bindings + (if (null? bindings) + pre-bindings + (append pre-bindings bindings))) + (define new-body + (convert-lifted-calls-in-seq body lifts frees)) + (reannotate + v + (rebuild-let let-id new-bindings new-body))])) + + (define (convert-lifted-calls-in-seq/box-mutated vs ids lifts frees) + (let loop ([ids ids]) + (cond + [(wrap-null? ids) + (convert-lifted-calls-in-seq vs lifts frees)] + [(wrap-pair? ids) + (define id (wrap-car ids)) + (if (indirected? (hash-ref lifts (unwrap id) #f)) + `((let ([,id (box ,id)]) + . ,(loop (wrap-cdr ids)))) + (loop (wrap-cdr ids)))] + [else (loop (list ids))]))) + + ;; Create bindings for lifted functions, adding new arguments + ;; as the functions are lifted + (define (extract-lifted-bindings lifts) + (for/list ([(f proc) (in-hash lifts)] + #:when (liftable? proc)) + (let* ([new-args (liftable-frees proc)] + [frees (for/hash ([arg (in-list new-args)]) + (values arg #t))] + [rhs (liftable-expr proc)]) + `[,f ,(match rhs + [`(lambda ,args . ,body) + (let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees)]) + (reannotate rhs `(lambda ,(append new-args args) . ,body)))] + [`(case-lambda [,argss . ,bodys] ...) + (reannotate rhs `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + (let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees)]) + `[,(append new-args args) . ,body]))))])]))) + + + ;; ---------------------------------------- + ;; Helpers + + (define (lambda? v) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`,_ #f])) + + (define (consistent-argument-count? proc n) + (define (consistent? args n) + (let loop ([args args] [n n]) + (cond + [(negative? n) #f] + [(wrap-null? args) (zero? n)] + [(wrap-pair? args) + (loop (wrap-cdr args) (sub1 n))] + [else #t]))) + (match proc + [`(lambda ,args . ,_) + (consistent? args n)] + [`(case-lambda [,argss . ,_] ...) + (for/or ([args (in-list argss)]) + (consistent? args n))] + [`,_ #f])) + + ;; Find or create an `indirected` record for a variable + (define (lookup-indirected-variable lifts var need-check?) + (define ind (hash-ref lifts var #f)) + (or (and (indirected? ind) + (begin + (when need-check? + (set-indirected-check?! ind #t)) + ind)) + (let ([ind (indirected need-check?)]) + (hash-set! lifts var ind) + ind))) + + ;; Add a group of arguments (a list or improper list) to a set + (define (add-args args s [mode 'ready]) + (let loop ([args args] [s s]) + (cond + [(wrap-null? args) s] + [(wrap-pair? args) + (loop (wrap-cdr args) + (hash-set s (unwrap (wrap-car args)) mode))] + [else (hash-set s (unwrap args) mode)]))) + + ;; Add a free variable + (define (add-free frees+binds var) + (cons (hash-set (car frees+binds) var #t) + (cdr frees+binds))) + + ;; Remove a group of arguments (a list or improper list) from a set + ;; as the variable go out of scope, including any associated mutator + ;; and variable-reference variables, but keep variables for lifted + ;; functions + (define (remove-frees/add-binds args frees+binds lifts) + (define (remove-free/add-bind frees+binds arg) + (define info (hash-ref lifts arg #f)) + (cond + [(liftable? info) + ;; Since `arg` will be lifted to the top, it + ;; stays in our local set of free variables, + ;; but also add it to binds so that callers + ;; will know that they don't need to chain + (cons (car frees+binds) + (hash-set (cdr frees+binds) arg #t))] + [else (cons (hash-remove (car frees+binds) arg) + (hash-set (cdr frees+binds) arg #t))])) + (let loop ([args args] [frees+binds frees+binds]) + (cond + [(wrap-null? args) frees+binds] + [(wrap-pair? args) + (loop (wrap-cdr args) + (remove-free/add-bind frees+binds (unwrap (wrap-car args))))] + [else (remove-free/add-bind frees+binds (unwrap args))]))) + + ;; Set union + (define (union s1 s2) + (cond + [((hash-count s1) . > . (hash-count s2)) + (union s2 s1)] + [else + (for/fold ([s2 s2]) ([k (in-hash-keys s1)]) + (hash-set s2 k #t))])) + + (define (rebuild-let let-id bindings body) + (cond + [(not (null? bindings)) + `(,let-id ,bindings . ,body)] + [(and (pair? body) (null? (cdr body))) + (car body)] + [else `(begin . ,body)])) + + ;; ---------------------------------------- + ;; Go + + (if (lift-in? v) + (lift-in v) + v)) diff -Nru racket-6.12+ppa1/src/schemify/literal.rkt racket-7.0+ppa1/src/schemify/literal.rkt --- racket-6.12+ppa1/src/schemify/literal.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/literal.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +#lang racket/base +(require "wrap.rkt") + +(provide literal? + unwrap-literal) + +(define (literal? v) + (define u (unwrap v)) + (or (number? u) + (boolean? u) + (and (pair? u) + (eq? (unwrap (car u)) 'quote) + (let ([u (unwrap (wrap-car (cdr u)))]) + (or (symbol? u) + (null? u)))))) + +;; Unwrap a literal so that it can be serialized +(define (unwrap-literal v) + (define u (unwrap v)) + (if (pair? u) + `',(unwrap (wrap-car (cdr u))) + u)) diff -Nru racket-6.12+ppa1/src/schemify/main.rkt racket-7.0+ppa1/src/schemify/main.rkt --- racket-6.12+ppa1/src/schemify/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +#lang racket/base +(require "schemify.rkt" + "known.rkt" + "lift.rkt" + "jitify.rkt" + "interpret.rkt" + "size.rkt") + +(provide schemify-linklet + schemify-body + + (all-from-out "known.rkt") + + lift-in-schemified-linklet + lift-in-schemified-body + + jitify-schemified-linklet + + interpretable-jitified-linklet + interpret-linklet + + linklet-bigger-than?) diff -Nru racket-6.12+ppa1/src/schemify/Makefile racket-7.0+ppa1/src/schemify/Makefile --- racket-6.12+ppa1/src/schemify/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,48 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion. Make annotation references direct to +# improve performance. Declaring "collect.rkt" pure works around a +# limitation of the flattener. +IGNORE = ++knot read - ++direct kernel ++pure ../../collects/racket/private/collect.rkt + +schemify-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) schemify-src-generate + +known-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) known-src-generate + + +S_GENERATE_ARGS = -t main.rkt \ + --check-depends $(BUILDDIR)compiled/schemify-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/schemify-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/schemify.rktl $(BUILDDIR)compiled/schemify.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/schemify.rktl + +schemify-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(S_GENERATE_ARGS) + + +K_GENERATE_ARGS = -t known.rkt \ + --check-depends $(BUILDDIR)compiled/known-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/known-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/known.rktl $(BUILDDIR)compiled/known.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/known.rktl + + +known-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(K_GENERATE_ARGS) + +.PHONY: schemify-src schemify-src-generate known-src known-src-generate diff -Nru racket-6.12+ppa1/src/schemify/match.rkt racket-7.0+ppa1/src/schemify/match.rkt --- racket-6.12+ppa1/src/schemify/match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/match.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,142 @@ +#lang racket/base +(require (for-syntax racket/base) + "wrap.rkt") + +;; One more time, still yet another pattern matching library again... +(provide match) + +(define-for-syntax (extract-pattern-variables pattern) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + null] + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + null + (list #'bind-id))] + [(p1 . p2) (append (extract-pattern-variables #'p1) + (extract-pattern-variables #'p2))] + [else null])) + +(define-for-syntax (check-one id pattern head-id) + (define (check-one/expr e pattern) + (syntax-case pattern (unquote) + [(unquote bind-id) #`#t] + [_ #`(let ([a #,e]) + #,(check-one #'a pattern #f))])) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + #`(pred? #,id)] + [(unquote bind-id) #`#t] + [(pat ellipses) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses (quote-syntax ...))) + (if (syntax-case #'pat (unquote) + [(unquote bind-id) #t] + [_ #f]) + #`(wrap-list? #,id) + #`(and (wrap-list? #,id) + (for/and ([v (in-wrap-list #,id)]) + #,(check-one #'v #'pat #f))))] + [(m-id . p2) + (and head-id (identifier? #'m-id)) + #`(and (eq? 'm-id #,head-id) + #,(check-one/expr #`(cdr (unwrap #,id)) #'p2))] + [(p1 . p2) + #`(let ([p (unwrap #,id)]) + (and (pair? p) + #,(check-one/expr #'(car p) #'p1) + #,(check-one/expr #'(cdr p) #'p2)))] + [_ + (if (or (identifier? pattern) + (let ([v (syntax-e pattern)]) + (or (keyword? v) + (boolean? v) + (null? v)))) + #`(wrap-eq? (quote #,pattern) #,id) + #`(wrap-equal? (quote #,pattern) #,id))])) + +(define-for-syntax (extract-one id pattern) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + #`(values)] + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + #'(values) + id)] + [(pat ellipses) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses (quote-syntax ...))) + (syntax-case #'pat (unquote) + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + #'(values) + #`(unwrap-list #,id))] + [_ + (with-syntax ([pat-ids (extract-pattern-variables #'pat)]) + #`(for/lists pat-ids ([v (in-wrap-list #,id)]) + #,(extract-one #'v #'pat)))])] + [(p1 . p2) + (let ([ids1 (extract-pattern-variables #'p1)] + [ids2 (extract-pattern-variables #'p2)]) + (cond + [(and (null? ids1) (null? ids2)) + #'(values)] + [(null? ids1) + #`(let ([d (cdr (unwrap #,id))]) + #,(extract-one #'d #'p2))] + [(null? ids2) + #`(let ([a (car (unwrap #,id))]) + #,(extract-one #'a #'p1))] + [else + #`(let ([p (unwrap #,id)]) + (let-values ([#,ids1 (let ([a (car p)]) + #,(extract-one #'a #'p1))] + [#,ids2 (let ([d (cdr p)]) + #,(extract-one #'d #'p2))]) + (values #,@ids1 #,@ids2)))]))] + [_ + #'(values)])) + +(define-for-syntax (extract-guard body) + (syntax-case body () + [(#:guard guard-expr . body) + #'guard-expr] + [_ #f])) + +(define-for-syntax (remove-guard body) + (syntax-case body () + [(#:guard guard-expr . body) + #'body] + [_ body])) + +(define-syntax (match stx) + (syntax-case stx (quasiquote) + [(_ expr [`pattern body0 body ...] ...) + #`(let ([v expr]) + #,(let ([patterns (syntax->list #'(pattern ...))]) + (define (build-matches head-id) + (let loop ([patterns patterns] + [bodys (syntax->list #'((body0 body ...) ...))]) + (cond + [(null? patterns) + #'(error 'match "failed ~e" v)] + [else + (define ids (extract-pattern-variables (car patterns))) + (define match? (check-one #'v (car patterns) head-id)) + (define guard (extract-guard (car bodys))) + #`(if #,(if guard + #`(and #,match? #,guard) + match?) + (let-values ([#,ids #,(extract-one #'v (car patterns))]) + . #,(remove-guard (car bodys))) + #,(loop (cdr patterns) (cdr bodys)))]))) + ;; If the first pattern is `( ....)`, then + ;; extract the input head symbol, because we're + ;; likely to want to check it for many pattern cases + (syntax-case (and (pair? patterns) (car patterns)) () + [(id . _) + (identifier? #'id) + #`(let ([hd (let ([p (unwrap v)]) + (and (pair? p) (unwrap (car p))))]) + #,(build-matches #'hd))] + [_ (build-matches #f)])))])) diff -Nru racket-6.12+ppa1/src/schemify/mutated.rkt racket-7.0+ppa1/src/schemify/mutated.rkt --- racket-6.12+ppa1/src/schemify/mutated.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/mutated.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,191 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "simple.rkt" + "find-definition.rkt" + "struct-type-info.rkt" + "mutated-state.rkt" + "find-known.rkt" + "letrec.rkt") + +(provide mutated-in-body) + +;; See "mutated-state.rkt" for information on the content of the +;; `mutated` table. + +;; We don't have to worry about errors or escapes that prevent the +;; definition of an identifier, because that will abort the enclosing +;; linklet. + +(define (mutated-in-body l exports prim-knowns knowns imports) + ;; Find all `set!`ed variables, and also record all bindings + ;; that might be used too early + (define mutated (make-hasheq)) + ;; Defined names start out as 'not-ready; start with `exports`, + ;; because anything exported but not defined is implicitly in an + ;; undefined state and must be accessed through a `variable`: + (for ([id (in-hash-keys exports)]) + (hash-set! mutated id 'undefined)) + ;; Find all defined variables: + (for ([form (in-list l)]) + (match form + [`(define-values (,ids ...) ,rhs) + (for ([id (in-list ids)]) + (hash-set! mutated (unwrap id) 'not-ready))] + [`,_ (void)])) + ;; Walk through the body: + (for/fold ([prev-knowns knowns]) ([form (in-list l)]) + ;; Accumulate known-binding information in this pass, because it's + ;; helpful to know which variables are bound to constructors. + ;; Note that we may tentatively classify a binding as a constructor + ;; before discovering that its mutated via `set!`, but any use of + ;; that information is correct, because it dynamically precedes + ;; the `set!` + (define-values (knowns info) + (find-definitions form prim-knowns prev-knowns imports mutated #f)) + (match form + [`(define-values (,ids ...) ,rhs) + (cond + [info + ;; Look just at the "rest" part: + (for ([e (in-list (struct-type-info-rest info))] + [pos (in-naturals)]) + (unless (and (= pos struct-type-info-rest-properties-list-pos) + (pure-properties-list? e prim-knowns knowns imports mutated)) + (find-mutated! e ids prim-knowns knowns imports mutated)))] + [else + (find-mutated! rhs ids prim-knowns knowns imports mutated)]) + ;; For any among `ids` that didn't get a delay and wasn't used + ;; too early, the variable is now ready, so remove from + ;; `mutated`: + (for ([id (in-list ids)]) + (when (eq? 'not-ready (hash-ref mutated (unwrap id) #f)) + (hash-remove! mutated id)))] + [`,_ + (find-mutated! form #f prim-knowns knowns imports mutated)]) + knowns) + ;; For definitions that are not yet used, force delays: + (for ([form (in-list l)]) + (match form + [`(define-values (,ids ...) ,rhs) + (for ([id (in-list ids)]) + (let ([id (unwrap id)]) + (define state (hash-ref mutated id #f)) + (when (delayed-mutated-state? state) + (hash-remove! mutated id) + (state))))] + [`,_ (void)])) + ;; Everything else in `mutated` is either 'set!ed, 'too-early, + ;; 'undefined, or unreachable: + mutated) + +;; Schemify `let-values` to `let`, etc., and +;; reorganize struct bindings. +(define (find-mutated! v ids prim-knowns knowns imports mutated) + (define (delay! ids thunk) + (define done? #f) + (define force (lambda () (unless done? + (set! done? #t) + (thunk)))) + (for ([id (in-list ids)]) + (let ([id (unwrap id)]) + (define m (hash-ref mutated id 'not-ready)) + (if (eq? 'not-ready m) + (hash-set! mutated id force) + (force))))) + (let find-mutated! ([v v] [ids ids]) + (define (find-mutated!* l ids) + (let loop ([l l]) + (cond + [(null? l) (void)] + [(null? (cdr l)) (find-mutated! (car l) ids)] + [else (find-mutated! (car l) #f) (loop (cdr l))]))) + (match v + [`(lambda ,formals ,body ...) + (if ids + (delay! ids (lambda () (find-mutated!* body #f))) + (find-mutated!* body #f))] + [`(case-lambda [,formalss ,bodys ...] ...) + (if ids + (delay! ids (lambda () (for ([body (in-list bodys)]) (find-mutated!* body #f)))) + (for ([body (in-list bodys)]) (find-mutated!* body #f)))] + [`(quote ,_) (void)] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (for ([ids (in-list idss)] + [rhs (in-list rhss)]) + ;; an `id` in `ids` can't be referenced too early, + ;; but it might usefully be delayed + (find-mutated! rhs ids)) + (find-mutated!* bodys ids)] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (cond + [(letrec-splitable-values-binding? idss rhss) + (find-mutated! (letrec-split-values-binding idss rhss bodys) ids)] + [else + (for* ([ids (in-list idss)] + [id (in-wrap-list ids)]) + (hash-set! mutated (unwrap id) 'not-ready)) + (for ([ids (in-list idss)] + [rhs (in-list rhss)]) + (find-mutated! rhs (unwrap-list ids)) + ;; Each `id` in `ids` is now ready (but might also hold a delay): + (for ([id (in-wrap-list ids)]) + (let ([id (unwrap id)]) + (when (eq? 'not-ready (hash-ref mutated id)) + (hash-remove! mutated id))))) + (find-mutated!* bodys ids)])] + [`(if ,tst ,thn ,els) + (find-mutated! tst #f) + (find-mutated! thn #f) + (find-mutated! els #f)] + [`(with-continuation-mark ,key ,val ,body) + (find-mutated! key #f) + (find-mutated! val #f) + (find-mutated! body ids)] + [`(begin ,exps ...) + (find-mutated!* exps ids)] + [`(begin0 ,exp ,exps ...) + (find-mutated! exp ids) + (find-mutated!* exps #f)] + [`(set! ,id ,rhs) + (let ([id (unwrap id)]) + (define old-state (hash-ref mutated id #f)) + (hash-set! mutated id 'set!ed) + (when (delayed-mutated-state? old-state) + (old-state))) + (find-mutated! rhs #f)] + [`(#%variable-reference . ,_) (void)] + [`(,rator ,exps ...) + (cond + [(and ids + (let ([rator (unwrap rator)]) + (and (symbol? rator) + (let ([v (find-known rator prim-knowns knowns imports mutated)]) + (and (known-constructor? v) + (bitwise-bit-set? (known-procedure-arity-mask v) (length exps)))) + (for/and ([exp (in-list exps)]) + (simple? exp prim-knowns knowns imports mutated))))) + ;; Can delay construction + (delay! ids (lambda () (find-mutated!* exps #f)))] + [else + (find-mutated! rator #f) + (find-mutated!* exps #f)])] + [`,_ + (let ([v (unwrap v)]) + (when (symbol? v) + (define state (hash-ref mutated v #f)) + (cond + [(not-ready-mutated-state? state) + (hash-set! mutated v 'too-early)] + [(delayed-mutated-state? state) + (cond + [ids + ;; Chain delays + (delay! ids (lambda () + (hash-remove! mutated v) + (state)))] + [else + (hash-remove! mutated v) + (state)])])))]))) diff -Nru racket-6.12+ppa1/src/schemify/mutated-state.rkt racket-7.0+ppa1/src/schemify/mutated-state.rkt --- racket-6.12+ppa1/src/schemify/mutated-state.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/mutated-state.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base + +;; During the `mutated-in-body` pass, an identifier is mapped to one +;; of the following: +;; +;; * 'set!ed - the identifier is `set!`ed +;; +;; * 'too-early - the identifier may be referenced before it is +;; defined +;; +;; * 'not-ready - the identifier's value is not yet ready, so a +;; reference transitions to 'too-early +;; +;; * 'undefined - the identifier is "exported" from the linklet, but +;; not defined +;; +;; * a thunk - the identifier is defined, where evaluation of the +;; definition is side-efect-free; force the thunk on a +;; first use, since anything referenced by the thunk +;; might be first used at that point +;; +;; * #f (not mapped) - defined and never `set!`ed +;; +;; By the end of the `mutated-in-body` pass, only 'set!ed, 'too-early, +;; 'not-ready (for exported but not defined) and #f are possible for +;; identifiers that are reachable by evaluation. + +(provide delayed-mutated-state? + simple-mutated-state? + not-ready-mutated-state? + via-variable-mutated-state? + set!ed-mutated-state?) + +(define (delayed-mutated-state? v) (procedure? v)) + +(define (simple-mutated-state? v) + (or (not v) + (delayed-mutated-state? v))) + +(define (not-ready-mutated-state? v) + (eq? v 'not-ready)) + +;; When referecing an exported identifier, we need to consistently go +;; through a `variable` record when it can be `set!`ed. We don't need +;; to go through a `variable` record if the identifier might simply be +;; used too early, because the host Scheme takes care of that issue. +(define (via-variable-mutated-state? v) + (or (eq? v 'set!ed) + (eq? v 'undefined))) + +;; At the end of a linklet, known-value information is reliable unless +;; the identifier is mutated +(define (set!ed-mutated-state? v) + (eq? v 'set!ed)) diff -Nru racket-6.12+ppa1/src/schemify/optimize.rkt racket-7.0+ppa1/src/schemify/optimize.rkt --- racket-6.12+ppa1/src/schemify/optimize.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/optimize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt" + "import.rkt" + "known.rkt" + "find-known.rkt" + "mutated-state.rkt" + "literal.rkt") + +(provide optimize) + +;; Perform shallow optimizations. The `schemify` pass calls `optimize` +;; on each schemified form, which means that subexpressions of the +;; immediate expression have already been optimized. + +(define (optimize v prim-knowns knowns imports mutated) + (match v + [`(if ,t ,e1 ,e2) + (if (literal? t) + (if (unwrap t) e1 e2) + v)] + [`(procedure? ,e) + (define u (unwrap e)) + (cond + [(symbol? u) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (known-procedure? k) + '#t + v)] + [else v])] + [`(procedure-arity-includes? ,e ,n) + (define u (unwrap e)) + (define u-n (unwrap n)) + (cond + [(and (symbol? u) + (exact-integer? n)) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (and (known-procedure? k) + (bitwise-bit-set? (known-procedure-arity-mask k) u-n)) + '#t + v)] + [else v])] + [`,_ + (define u (unwrap v)) + (cond + [(symbol? u) + (define k (hash-ref-either knowns imports u)) + (cond + [(and (known-literal? k) + (simple-mutated-state? (hash-ref mutated u #f))) + (known-literal-expr k)] + ;; Note: we can't do `known-copy?` here, because a copy of + ;; an imported or exported name will need to be schemified + ;; to a different name + [else v])] + [else v])])) diff -Nru racket-6.12+ppa1/src/schemify/pthread-parameter.rkt racket-7.0+ppa1/src/schemify/pthread-parameter.rkt --- racket-6.12+ppa1/src/schemify/pthread-parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/pthread-parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,16 @@ +#lang racket/base +(require "wrap.rkt" + "known.rkt") + +(provide pthread-parameter?) + +(define (pthread-parameter? v prim-knowns knowns mutated) + (and (wrap-pair? v) + (wrap-pair? (wrap-cdr v)) + (wrap-null? (wrap-cdr (wrap-cdr v))) + (let ([u-rator (unwrap (wrap-car v))]) + (or (eq? u-rator 'make-pthread-parameter) + (and (symbol? u-rator) + (let ([k (hash-ref knowns u-rator #f)]) + (and (known-copy? k) + (eq? 'make-pthread-parameter (known-copy-id k))))))))) diff -Nru racket-6.12+ppa1/src/schemify/quoted.rkt racket-7.0+ppa1/src/schemify/quoted.rkt --- racket-6.12+ppa1/src/schemify/quoted.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/quoted.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(require racket/extflonum) + +(provide lift-quoted?) + +;; Check whether a quoted value needs to be lifted to run-time construction +(define (lift-quoted? q for-cify?) + (cond + [for-cify? + (not (or (and (exact-integer? q) + ;; always a fixnum: + (<= (- (expt 2 29)) q (expt 2 29))) + (boolean? q) + (null? q) + (void? q)))] + [(impersonator? q) #t] ; i.e., strip impersonators when serializaing + [(path? q) #t] + [(regexp? q) #t] + [(byte-regexp? q) #t] + [(keyword? q) #t] + [(hash? q) #t] + [(string? q) #t] + [(bytes? q) #t] + [(pair? q) (or (lift-quoted? (car q) for-cify?) + (lift-quoted? (cdr q) for-cify?))] + [(vector? q) (for/or ([e (in-vector q)]) + (lift-quoted? e for-cify?))] + [(box? q) (lift-quoted? (unbox q) for-cify?)] + [(prefab-struct-key q) #t] + [(extflonum? q) #t] + [else #f])) diff -Nru racket-6.12+ppa1/src/schemify/README.txt racket-7.0+ppa1/src/schemify/README.txt --- racket-6.12+ppa1/src/schemify/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +The "schemify" compiler takes a linklet and converts it to a `lambda`. +Converting a linklet with schemify is a step to compiling it either +via Chez Scheme or (via the "cify" compiler) to C code to embed in the +Racket virtual machine. + +See "../cs/README.txt" for more information. diff -Nru racket-6.12+ppa1/src/schemify/schemify-demo.rkt racket-7.0+ppa1/src/schemify/schemify-demo.rkt --- racket-6.12+ppa1/src/schemify/schemify-demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/schemify-demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base +(require racket/pretty + "schemify.rkt" + "known.rkt") + +(define prim-knowns + ;; Register primitives + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require 'racket/unsafe/ops) + (namespace-require 'racket/flonum) + (namespace-require 'racket/fixnum)) + (for/hasheq ([s (in-list (namespace-mapped-symbols ns))] + #:when (with-handlers ([exn:fail? (lambda (x) #f)]) + (procedure? (eval s ns)))) + (values s a-known-procedure)))) + +(define (wrap-everywhere p) + (cond + [(pair? p) + (datum->syntax #f (cons (wrap-everywhere (car p)) + (wrap-everywhere (cdr p))))] + [else + (datum->syntax #f p)])) + +(define-values (schemified importss-abi exports-info) + (schemify-linklet `(linklet + () + (x ,#'y [,#'z ,#'ext-z]) + . + ,(map + wrap-everywhere + '((define-values (struct:s make-s s? s-ref s-set!) + (make-struct-type 's #f 2 0 #f)) + (define-values (y) (make-s (lambda () x) 5)) + (define-values (x) (lambda () y)) + (x) + (letrec-values ([(loop) (lambda () (loop))]) (loop)) + (let-values ([(a) 1] [(b) 2]) (list a b)) + (let-values ([(a b) (values 1 2)]) (list a b)) + (define-values (done) (z))))) + #; + (call-with-input-file "regexp.rktl" read) + (lambda (old-v new-v) + (if (syntax? old-v) + (datum->syntax #f new-v old-v) + new-v)) + (lambda (old-v) (syntax->datum (datum->syntax #f old-v))) + prim-knowns + (lambda args #hasheq()))) + +(pretty-print schemified) +(pretty-print exports-info) + diff -Nru racket-6.12+ppa1/src/schemify/schemify.rkt racket-7.0+ppa1/src/schemify/schemify.rkt --- racket-6.12+ppa1/src/schemify/schemify.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/schemify.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,607 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "export.rkt" + "struct-type-info.rkt" + "simple.rkt" + "find-definition.rkt" + "mutated.rkt" + "mutated-state.rkt" + "left-to-right.rkt" + "serialize.rkt" + "let.rkt" + "equal.rkt" + "optimize.rkt" + "find-known.rkt" + "infer-known.rkt" + "inline.rkt" + "letrec.rkt") + +(provide schemify-linklet + schemify-body) + +;; Convert a linklet to a Scheme `lambda`, dealing with several +;; issues: +;; +;; - imports and exports are represented by `variable` objects that +;; are passed to the function; to avoid obscuring the program to +;; the optimizer, though, refer to the definitions of exported +;; variables instead of going through the `variable`, whenever +;; possible, and accept values instead of `variable`s for constant +;; imports; +;; +;; - wrap expressions in a sequence of definitions plus expressions +;; so that the result body is a sequence of definitions followed +;; by a single expression; +;; +;; - convert function calls and `let` forms to enforce left-to-right +;; evaluation; +;; +;; - convert function calls to support applicable structs, using +;; `#%app` whenever a call might go through something other than a +;; plain function; +;; +;; - convert `make-struct-type` bindings to a pattern that Chez can +;; recognize; +;; +;; - optimize away `variable-reference-constant?` uses, which is +;; important to make keyword-argument function calls work directly +;; without keywords; +;; +;; - simplify `define-values` and `let-values` to `define` and +;; `let`, when possible, and generally avoid `let-values`. + +;; The given linklet can have parts wrapped as annotations. When +;; called from the Racket expander, those annotation will be +;; "correlated" objects that just support source locations. + +;; Returns (values schemified-linklet import-abi export-info) +;; An import ABI is a list of list of booleans, parallel to the +;; linklet imports, where #t to means that a value is expected, and #f +;; means that a variable (which boxes a value) is expected +(define (schemify-linklet lk serializable? for-jitify? allow-set!-undefined? unsafe-mode? + reannotate prim-knowns get-import-knowns import-keys) + (define (im-int-id id) (unwrap (if (pair? id) (cadr id) id))) + (define (im-ext-id id) (unwrap (if (pair? id) (car id) id))) + (define (ex-int-id id) (unwrap (if (pair? id) (car id) id))) + (define (ex-ext-id id) (unwrap (if (pair? id) (cadr id) id))) + ;; Assume no wraps unless the level of an id or expression + (match lk + [`(linklet ,im-idss ,ex-ids . ,bodys) + ;; For imports, map symbols to gensymed `variable` argument names, + ;; keeping `import` records in groups: + (define grps + (for/list ([im-ids (in-list im-idss)] + [index (in-naturals)]) + ;; An import key from `import-keys` lets us get cross-module + ;; information on demand + (import-group index (and import-keys (vector-ref import-keys index)) + get-import-knowns #f #f + '()))) + ;; Record import information in both the `imports` table and within + ;; the import-group record + (define imports + (let ([imports (make-hasheq)]) + (for ([im-ids (in-list im-idss)] + [grp (in-list grps)]) + (set-import-group-imports! + grp + (for/list ([im-id (in-list im-ids)]) + (define id (im-int-id im-id)) + (define ext-id (im-ext-id im-id)) + (define im (import grp (gensym (symbol->string id)) id ext-id)) + (hash-set! imports id im) + im))) + imports)) + ;; Inlining can add new import groups or add imports to an existing group + (define new-grps '()) + (define add-import! + (make-add-import! imports + grps + get-import-knowns + (lambda (new-grp) (set! new-grps (cons new-grp new-grps))))) + ;; For exports, too, map symbols to gensymed `variable` argument names + (define exports + (for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)]) + (define id (ex-int-id ex-id)) + (hash-set exports id (export (gensym (symbol->string id)) (ex-ext-id ex-id))))) + ;; Lift any quoted constants that can't be serialized + (define-values (bodys/constants-lifted lifted-constants) + (if serializable? + (convert-for-serialize bodys #f) + (values bodys null))) + ;; Schemify the body, collecting information about defined names: + (define-values (new-body defn-info mutated) + (schemify-body* bodys/constants-lifted reannotate prim-knowns imports exports + for-jitify? allow-set!-undefined? add-import! #f unsafe-mode?)) + (define all-grps (append grps (reverse new-grps))) + (values + ;; Build `lambda` with schemified body: + (make-let* + lifted-constants + `(lambda (instance-variable-reference + ,@(for*/list ([grp (in-list all-grps)] + [im (in-list (import-group-imports grp))]) + (import-id im)) + ,@(for/list ([ex-id (in-list ex-ids)]) + (export-id (hash-ref exports (ex-int-id ex-id))))) + ,@new-body)) + ;; Imports (external names), possibly extended via inlining: + (for/list ([grp (in-list all-grps)]) + (for/list ([im (in-list (import-group-imports grp))]) + (import-ext-id im))) + ;; Exports (external names): + (for/list ([ex-id (in-list ex-ids)]) + (ex-ext-id ex-id)) + ;; Import keys --- revised if we added any import groups + (if (null? new-grps) + import-keys + (for/vector #:length (length all-grps) ([grp (in-list all-grps)]) + (import-group-key grp))) + ;; Import ABI: request values for constants, `variable`s otherwise + (for/list ([grp (in-list all-grps)]) + (define im-ready? (import-group-lookup-ready? grp)) + (for/list ([im (in-list (import-group-imports grp))]) + (and im-ready? + (known-constant? (import-group-lookup grp (import-ext-id im)))))) + ;; Convert internal to external identifiers + (for/fold ([knowns (hasheq)]) ([ex-id (in-list ex-ids)]) + (define id (ex-int-id ex-id)) + (define v (known-inline->export-known (hash-ref defn-info id #f) + prim-knowns imports exports)) + (cond + [(and v + (not (set!ed-mutated-state? (hash-ref mutated id #f)))) + (define ext-id (ex-ext-id ex-id)) + (hash-set knowns ext-id v)] + [else knowns])))])) + +;; ---------------------------------------- + +(define (schemify-body l reannotate prim-knowns imports exports for-cify? unsafe-mode?) + (define-values (new-body defn-info mutated) + (schemify-body* l reannotate prim-knowns imports exports + #f #f (lambda (im ext-id index) #f) + for-cify? unsafe-mode?)) + new-body) + +(define (schemify-body* l reannotate prim-knowns imports exports + for-jitify? allow-set!-undefined? add-import! + for-cify? unsafe-mode?) + ;; Various conversion steps need information about mutated variables, + ;; where "mutated" here includes visible implicit mutation, such as + ;; a variable that might be used before it is defined: + (define mutated (mutated-in-body l exports prim-knowns (hasheq) imports)) + ;; Make another pass to gather known-binding information: + (define knowns + (for/fold ([knowns (hasheq)]) ([form (in-list l)]) + (define-values (new-knowns info) + (find-definitions form prim-knowns knowns imports mutated #t)) + new-knowns)) + ;; While schemifying, add calls to install exported values in to the + ;; corresponding exported `variable` records, but delay those + ;; installs to the end, if possible + (define schemified + (let loop ([l l] [accum-exprs null] [accum-ids null]) + (cond + [(null? l) + (define set-vars + (for/list ([id (in-list accum-ids)] + #:when (hash-ref exports id #f)) + (make-set-variable id exports knowns mutated))) + (cond + [(null? set-vars) + (cond + [(null? accum-exprs) '((void))] + [else (reverse accum-exprs)])] + [else (append (reverse accum-exprs) + set-vars)])] + [else + (define form (car l)) + (define schemified (schemify form reannotate + prim-knowns knowns mutated imports exports + allow-set!-undefined? + add-import! + for-cify? + unsafe-mode?)) + (match form + [`(define-values ,ids ,_) + (append + (if (or for-jitify? for-cify?) + (reverse accum-exprs) + (make-expr-defns accum-exprs)) + (cons + schemified + (let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids]) + (cond + [(wrap-null? ids) (loop (wrap-cdr l) accum-exprs accum-ids)] + [(or (or for-jitify? for-cify?) + (via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f))) + (define id (unwrap (wrap-car ids))) + (cond + [(hash-ref exports id #f) + (id-loop (wrap-cdr ids) + (cons (make-set-variable id exports knowns mutated) + accum-exprs) + accum-ids)] + [else + (id-loop (wrap-cdr ids) accum-exprs accum-ids)])] + [else + (id-loop (wrap-cdr ids) accum-exprs (cons (unwrap (wrap-car ids)) accum-ids))]))))] + [`,_ + (loop (wrap-cdr l) (cons schemified accum-exprs) accum-ids)])]))) + ;; Return both schemified and known-binding information, where + ;; the later is used for cross-linklet optimization + (values schemified knowns mutated)) + +(define (make-set-variable id exports knowns mutated) + (define int-id (unwrap id)) + (define ex (hash-ref exports int-id)) + `(variable-set! ,(export-id ex) ,id ',(variable-constance int-id knowns mutated))) + +(define (make-expr-defns accum-exprs) + (for/list ([expr (in-list (reverse accum-exprs))]) + `(define ,(gensym) (begin ,expr (void))))) + +(define (variable-constance id knowns mutated) + (cond + [(set!ed-mutated-state? (hash-ref mutated id #f)) + #f] + [(known-consistent? (hash-ref knowns id #f)) + 'consistent] + [else + 'constant])) + +;; ---------------------------------------- + +;; Schemify `let-values` to `let`, etc., and +;; reorganize struct bindings. +(define (schemify v reannotate prim-knowns knowns mutated imports exports allow-set!-undefined? add-import! + for-cify? unsafe-mode?) + (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v]) + (let schemify ([v v]) + (define s-v + (reannotate + v + (match v + [`(lambda ,formals ,body ...) + `(lambda ,formals ,@(map schemify body))] + [`(case-lambda [,formalss ,bodys ...] ...) + `(case-lambda ,@(for/list ([formals (in-list formalss)] + [body (in-list bodys)]) + `[,formals ,@(map schemify body)]))] + [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) + (let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk)) + (values ,struct:2 + ,make2 + ,?2 + ,make-acc/muts ...))) + #:guard (not for-cify?) + ;; Convert a `make-struct-type` binding into a + ;; set of bindings that Chez's cp0 recognizes, + ;; and push the struct-specific extra work into + ;; `struct-type-install-properties!` + (define sti (and (wrap-eq? struct: struct:2) + (wrap-eq? make make2) + (wrap-eq? ?1 ?2) + (make-struct-type-info mk prim-knowns knowns imports mutated))) + (cond + [(and sti + ;; make sure `struct:` isn't used too early, since we're + ;; reordering it's definition with respect to some arguments + ;; of `make-struct-type`: + (simple-mutated-state? (hash-ref mutated (unwrap struct:) #f))) + (define can-impersonate? (not (struct-type-info-authentic? sti))) + (define raw-s? (if can-impersonate? (gensym s?) s?)) + `(begin + (define ,struct:s (make-record-type-descriptor ',(struct-type-info-name sti) + ,(schemify (struct-type-info-parent sti)) + ,(if (not (struct-type-info-prefab-immutables sti)) + #f + `(structure-type-lookup-prefab-uid + ',(struct-type-info-name sti) + ,(schemify (struct-type-info-parent sti)) + ,(struct-type-info-immediate-field-count sti) + 0 #f + ',(struct-type-info-prefab-immutables sti))) + #f + #f + ',(for/vector ([i (in-range (struct-type-info-immediate-field-count sti))]) + `(mutable ,(string->symbol (format "f~a" i)))))) + ,@(if (null? (struct-type-info-rest sti)) + null + `((define ,(gensym) + (struct-type-install-properties! ,struct:s + ',(struct-type-info-name sti) + ,(struct-type-info-immediate-field-count sti) + 0 + ,(schemify (struct-type-info-parent sti)) + ,@(map schemify (struct-type-info-rest sti)))))) + (define ,make-s ,(let ([ctr `(record-constructor + (make-record-constructor-descriptor ,struct:s #f #f))]) + (if (struct-type-info-pure-constructor? sti) + ctr + `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))) + (define ,raw-s? (record-predicate ,struct:s)) + ,@(if can-impersonate? + `((define ,s? (lambda (v) (if (,raw-s? v) #t (pariah (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))) + null) + ,@(for/list ([acc/mut (in-list acc/muts)] + [make-acc/mut (in-list make-acc/muts)]) + (define raw-acc/mut (if can-impersonate? (gensym acc/mut) acc/mut)) + (match make-acc/mut + [`(make-struct-field-accessor ,(? (lambda (v) (wrap-eq? v -ref))) ,pos ,_) + (define raw-def `(define ,raw-acc/mut (record-accessor ,struct:s ,pos))) + (if can-impersonate? + `(begin + ,raw-def + (define ,acc/mut + (lambda (s) (if (,raw-s? s) + (,raw-acc/mut s) + (pariah (impersonate-ref ,raw-acc/mut ,struct:s ,pos s)))))) + raw-def)] + [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ,_) + (define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos))) + (define abs-pos (+ pos (- (struct-type-info-field-count sti) + (struct-type-info-immediate-field-count sti)))) + (if can-impersonate? + `(begin + ,raw-def + (define ,acc/mut + (lambda (s v) (if (,raw-s? s) + (,raw-acc/mut s v) + (pariah (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v)))))) + raw-def)] + [`,_ (error "oops")])) + (define ,(gensym) + (begin + (register-struct-constructor! ,make-s) + (register-struct-predicate! ,s?) + ,@(for/list ([acc/mut (in-list acc/muts)] + [make-acc/mut (in-list make-acc/muts)]) + (match make-acc/mut + [`(make-struct-field-accessor ,_ ,pos ,_) + `(register-struct-field-accessor! ,acc/mut ,struct:s ,pos)] + [`(make-struct-field-mutator ,_ ,pos ,_) + `(register-struct-field-mutator! ,acc/mut ,struct:s ,pos)] + [`,_ (error "oops")])) + (void))))] + [else + (match v + [`(,_ ,ids ,rhs) + `(define-values ,ids ,(schemify rhs))])])] + [`(define-values (,id) ,rhs) + `(define ,id ,(schemify rhs))] + [`(define-values ,ids ,rhs) + `(define-values ,ids ,(schemify rhs))] + [`(quote ,_) v] + [`(let-values () ,body) + (schemify body)] + [`(let-values () ,bodys ...) + (schemify `(begin . ,bodys))] + [`(let-values ([(,ids) ,rhss] ...) ,bodys ...) + (define new-knowns + (for/fold ([knowns knowns]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define k (infer-known rhs #f #f id knowns prim-knowns imports mutated)) + (if k + (hash-set knowns (unwrap id) k) + knowns))) + (left-to-right/let ids + (for/list ([rhs (in-list rhss)]) + (schemify rhs)) + (for/list ([body (in-list bodys)]) + (schemify/knowns new-knowns inline-fuel body)) + prim-knowns knowns imports mutated)] + [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...) + `(begin ,@(map schemify rhss) ,@(map schemify bodys))] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (left-to-right/let-values idss + (for/list ([rhs (in-list rhss)]) + (schemify rhs)) + (map schemify bodys) + mutated + for-cify?)] + [`(letrec-values () ,bodys ...) + (schemify `(begin . ,bodys))] + [`(letrec-values ([() (values)]) ,bodys ...) + (schemify `(begin . ,bodys))] + [`(letrec-values ([(,id) (values ,rhs)]) ,bodys ...) + ;; special case of splitable values: + (schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))] + [`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...) + (define new-knowns + (for/fold ([knowns knowns]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define k (infer-known rhs #f #t id knowns prim-knowns imports mutated)) + (if k + (hash-set knowns (unwrap id) k) + knowns))) + `(letrec* ,(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `[,id ,(schemify/knowns new-knowns inline-fuel rhs)]) + ,@(for/list ([body (in-list bodys)]) + (schemify/knowns new-knowns inline-fuel body)))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (cond + [(letrec-splitable-values-binding? idss rhss) + (schemify + (letrec-split-values-binding idss rhss bodys))] + [else + ;; Convert + ;; (letrec*-values ([(id ...) rhs] ...) ....) + ;; to + ;; (letrec* ([vec (call-with-values rhs vector)] + ;; [id (vector-ref vec 0)] + ;; ... ...) + ;; ....) + `(letrec* ,(apply + append + (for/list ([ids (in-wrap-list idss)] + [rhs (in-list rhss)]) + (let ([rhs (schemify rhs)]) + (cond + [(null? ids) + `([,(gensym "lr") + ,(make-let-values null rhs '(void) for-cify?)])] + [(and (pair? ids) (null? (cdr ids))) + `([,(car ids) ,rhs])] + [else + (define lr (gensym "lr")) + `([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)] + ,@(for/list ([id (in-list ids)] + [pos (in-naturals)]) + `[,id (unsafe-vector*-ref ,lr ,pos)]))])))) + ,@(map schemify bodys))])] + [`(if ,tst ,thn ,els) + `(if ,(schemify tst) ,(schemify thn) ,(schemify els))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(schemify key) ,(schemify val) ,(schemify body))] + [`(begin ,exp) + (schemify exp)] + [`(begin ,exps ...) + `(begin . ,(map schemify exps))] + [`(begin0 ,exps ...) + `(begin0 . ,(map schemify exps))] + [`(set! ,id ,rhs) + (define int-id (unwrap id)) + (define ex (hash-ref exports int-id #f)) + (if ex + `(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,(schemify rhs) '#f) + `(set! ,id ,(schemify rhs)))] + [`(variable-reference-constant? (#%variable-reference ,id)) + (let ([id (unwrap id)]) + (and (not (hash-ref mutated id #f)) + (let ([im (hash-ref imports id #f)]) + (or (not im) + (known-constant? (import-lookup im))))))] + [`(variable-reference-from-unsafe? (#%variable-reference)) + unsafe-mode?] + [`(#%variable-reference) + 'instance-variable-reference] + [`(#%variable-reference ,id) + (define u (unwrap id)) + (define v (or (let ([ex (hash-ref exports u #f)]) + (and ex (export-id ex))) + (let ([im (hash-ref imports u #f)]) + (and im (import-id im))))) + (if v + `(make-instance-variable-reference + instance-variable-reference + ,v) + `(make-instance-variable-reference + instance-variable-reference + ',(if (hash-ref mutated u #f) + 'mutable + 'immutable)))] + [`(equal? ,exp1 ,exp2) + (let ([exp1 (schemify exp1)] + [exp2 (schemify exp2)]) + (cond + [(or (equal-implies-eq? exp1) (equal-implies-eq? exp2)) + `(eq? ,exp1 ,exp2)] + [(or (equal-implies-eqv? exp1) (equal-implies-eqv? exp2)) + `(eqv? ,exp1 ,exp2)] + [else + (left-to-right/app 'equal? + (list exp1 exp2) + #t for-cify? + prim-knowns knowns imports mutated)]))] + [`(call-with-values ,generator ,receiver) + (cond + [(and (lambda? generator) + (lambda? receiver)) + `(call-with-values ,(schemify generator) ,(schemify receiver))] + [else + (left-to-right/app (if for-cify? 'call-with-values '#%call-with-values) + (list (schemify generator) (schemify receiver)) + #t for-cify? + prim-knowns knowns imports mutated)])] + [`((letrec-values ,binds ,rator) ,rands ...) + (schemify `(letrec-values ,binds (,rator . ,rands)))] + [`(,rator ,exps ...) + (define (left-left-lambda-convert rator inline-fuel) + (match rator + [`(lambda ,formal-args ,bodys ...) + ;; Try to line up `formal-args` with `exps` + (let loop ([formal-args formal-args] [args exps] [binds '()]) + (cond + [(wrap-null? formal-args) + (and (wrap-null? args) + (schemify/knowns knowns + inline-fuel + `(let-values ,(reverse binds) . ,bodys)))] + [(null? args) #f] + [(not (wrap-pair? formal-args)) + (loop '() '() (cons (list (list formal-args) + (if (wrap-null? args) + ''() + (cons 'list args))) + binds))] + [else + (loop (wrap-cdr formal-args) + (wrap-cdr args) + (cons (list (list (wrap-car formal-args)) + (wrap-car args)) + binds))]))] + [`(case-lambda [,formal-args ,bodys ...] . ,rest) + (or (left-left-lambda-convert `(lambda ,formal-args . ,bodys) inline-fuel) + (left-left-lambda-convert `(case-lambda . ,rest) inline-fuel))] + [`,_ #f])) + (define (inline-rator) + (define u-rator (unwrap rator)) + (and (symbol? u-rator) + (let ([k (find-known u-rator prim-knowns knowns imports mutated)]) + (and (known-procedure/can-inline? k) + (left-left-lambda-convert + (inline-clone k (hash-ref imports u-rator #f) add-import! mutated imports reannotate) + (sub1 inline-fuel)))))) + (or (left-left-lambda-convert rator inline-fuel) + (and (positive? inline-fuel) + (inline-rator)) + (let ([s-rator (schemify rator)] + [args (map schemify exps)] + [u-rator (unwrap rator)]) + (let ([plain-app? + (or (known-procedure? (find-known u-rator prim-knowns knowns imports mutated)) + (lambda? rator))]) + (left-to-right/app s-rator + args + plain-app? for-cify? + prim-knowns knowns imports mutated))))] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(not (symbol? u-v)) + v] + [(and (via-variable-mutated-state? (hash-ref mutated u-v #f)) + (hash-ref exports u-v #f)) + => (lambda (ex) `(variable-ref ,(export-id ex)))] + [(hash-ref imports u-v #f) + => (lambda (im) + (define k (import-lookup im)) + (if (known-constant? k) + ;; Not boxed: + (cond + [(known-literal? k) + ;; We'd normally leave this to `optimize`, but + ;; need to handle it here before generating a + ;; reference to the renamed identifier + (known-literal-expr k)] + [else + (import-id im)]) + ;; Will be boxed, but won't be undefined (because the + ;; module system won't link to an instance whose + ;; definitions didn't complete): + `(variable-ref/no-check ,(import-id im))))] + [(hash-ref knowns u-v #f) + => (lambda (k) + (cond + [(and (known-copy? k) + (simple-mutated-state? (hash-ref mutated u-v #f))) + (schemify (known-copy-id k))] + [else v]))] + [else v]))]))) + (optimize s-v prim-knowns knowns imports mutated)))) diff -Nru racket-6.12+ppa1/src/schemify/serialize.rkt racket-7.0+ppa1/src/schemify/serialize.rkt --- racket-6.12+ppa1/src/schemify/serialize.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/serialize.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,206 @@ +#lang racket/base +(require racket/extflonum + "match.rkt" + "quoted.rkt") + +(provide convert-for-serialize) + +;; Some quoted Racket values cannot be serialized and deserialized +;; automatically by Scheme: keywords (because they need to be interned +;; when reading code), strings and byte strings (ditto), regexps +;; (because they contain function pointers), etc. +;; +;; For those kinds of values, lift a construction of the quoted value +;; out and replace the use of a quoted value with a variable +;; reference. This lifting can interefere with optimizations, so only +;; lift as a last resort. + +(define (convert-for-serialize bodys for-cify?) + (define lifted-eq-constants (make-hasheq)) + (define lifted-equal-constants (make-hash)) + (define lift-bindings null) + (define lifts-count 0) + (define (add-lifted rhs) + ;; FIXME: make sure these `id`s don't collide with anything + (define id (string->symbol (format "q:~a" lifts-count))) + (set! lifts-count (add1 lifts-count)) + (set! lift-bindings (cons (list id rhs) lift-bindings)) + id) + (define new-bodys + (for/list ([v (in-list bodys)]) + (cond + [(convert-any? v for-cify?) + (define (convert v) + (match v + [`(quote ,q) + (cond + [(lift-quoted? q for-cify?) + (make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?)] + [else v])] + [`(lambda ,formals ,body ...) + `(lambda ,formals ,@(convert-function-body body))] + [`(case-lambda [,formalss ,bodys ...] ...) + `(case-lambda ,@(for/list ([formals (in-list formalss)] + [body (in-list bodys)]) + `[,formals ,@(convert-function-body body)]))] + [`(define-values ,ids ,rhs) + `(define-values ,ids ,(convert rhs))] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + `(let-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(convert rhs)]) + ,@(convert-body bodys))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + `(letrec-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(convert rhs)]) + ,@(convert-body bodys))] + [`(if ,tst ,thn ,els) + `(if ,(convert tst) ,(convert thn) ,(convert els))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(convert key) ,(convert val) ,(convert body))] + [`(begin ,exps ...) + `(begin . ,(convert-body exps))] + [`(begin0 ,exps ...) + `(begin0 . ,(convert-body exps))] + [`(set! ,id ,rhs) + `(set! ,id ,(convert rhs))] + [`(#%variable-reference) v] + [`(#%variable-reference ,_) v] + [`(,rator ,exps ...) + `(,(convert rator) ,@(convert-body exps))] + [`,_ + (cond + [(and for-cify? + (not (symbol? v)) + (lift-quoted? v for-cify?)) + (convert `(quote ,v))] + [else v])])) + (define (convert-body body) + (for/list ([e (in-list body)]) + (convert e))) + (define (convert-function-body body) + (if for-cify? + ;; Detect the function-name pattern and avoid + ;; mangling it: + (match body + [`((begin (quote ,name) ,body . ,bodys)) + `((begin (quote ,name) ,@(convert-body (cons body bodys))))] + [`,_ (convert-body body)]) + (convert-body body))) + (convert v)] + [else v]))) + (values new-bodys + (reverse lift-bindings))) + +;; v is a form or a list of forms +(define (convert-any? v for-cify?) + (let convert-any? ([v v]) + (match v + [`(quote ,q) (lift-quoted? q for-cify?)] + [`(lambda ,formals ,body ...) + (convert-any? body)] + [`(case-lambda [,formalss ,bodys ...] ...) + (convert-any? bodys)] + [`(define-values ,ids ,rhs) + (convert-any? rhs)] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (or (convert-any? rhss) + (convert-any? bodys))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (or (convert-any? rhss) + (convert-any? bodys))] + [`(if ,tst ,thn ,els) + (or (convert-any? tst) + (convert-any? thn) + (convert-any? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (convert-any? key) + (convert-any? val) + (convert-any? body))] + [`(begin ,exps ...) + (convert-any? exps)] + [`(begin0 ,exps ...) + (convert-any? exps)] + [`(set! ,id ,rhs) + (convert-any? rhs)] + [`(#%variable-reference) #f] + [`(#%variable-reference ,_) #f] + [`(,exps ...) + (for/or ([exp (in-list exps)]) + (convert-any? exp))] + [`,_ (and for-cify? + (not (symbol? v)) + (lift-quoted? v for-cify?))]))) + +;; Construct an expression to be lifted +(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?) + (define (quote? e) (and (pair? e) (eq? 'quote (car e)))) + (let make-construct ([q q]) + (define lifted-constants (if (or (string? q) (bytes? q)) + lifted-equal-constants + lifted-eq-constants)) + (cond + [(hash-ref lifted-constants q #f) + => (lambda (id) id)] + [else + (define rhs + (cond + [(path? q) `(bytes->path ,(path->bytes q) + ',(path-convention-type q))] + [(regexp? q) + `(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))] + [(byte-regexp? q) + `(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))] + [(keyword? q) + `(string->keyword ,(keyword->string q))] + [(hash? q) + `(,(cond + [(hash-eq? q) 'hasheq] + [(hash-eqv? q) 'hasheqv] + [else 'hash]) + ,@(apply append + (for/list ([(k v) (in-hash q)]) + (list (make-construct k) + (make-construct v)))))] + [(string? q) `(datum-intern-literal ,q)] + [(bytes? q) `(datum-intern-literal ,q)] + [(pair? q) + (if (list? q) + (let ([args (map make-construct q)]) + (if (andmap quote? args) + `(quote ,q) + `(list ,@(map make-construct q)))) + (let ([a (make-construct (car q))] + [d (make-construct (cdr q))]) + (if (and (quote? a) (quote? d)) + `(quote ,q) + `(cons ,a ,d))))] + [(vector? q) + (let ([args (map make-construct (vector->list q))]) + (if (and (andmap quote? args) + (not (impersonator? q))) + `(quote ,q) + `(vector ,@args)))] + [(box? q) + (let ([arg (make-construct (unbox q))]) + (if (and (quote? arg) + (not (impersonator? q))) + `(quote ,q) + `(box ,arg)))] + [(prefab-struct-key q) + => (lambda (key) + `(make-prefab-struct ',key ,@(map make-construct + (cdr (vector->list (struct->vector q))))))] + [(extflonum? q) + `(string->number ,(format "~a" q) 10 'read)] + [else `(quote ,q)])) + (cond + [(and (quote? rhs) + (or (not for-cify?) + (not (lift-quoted? (cadr rhs) #t)))) + rhs] + [else + (define id (add-lifted rhs)) + (hash-set! lifted-constants q id) + id])]))) diff -Nru racket-6.12+ppa1/src/schemify/simple.rkt racket-7.0+ppa1/src/schemify/simple.rkt --- racket-6.12+ppa1/src/schemify/simple.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/simple.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "mutated-state.rkt") + +(provide simple?) + +;; Check whether an expression is simple in the sense that its order +;; of evaluation isn't detectable. This function receives both +;; schemified and non-schemified expressions. +(define (simple? e prim-knowns knowns imports mutated) + (let simple? ([e e]) + (match e + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`(quote . ,_) #t] + [`(#%variable-reference . ,_) #t] + [`(let-values ([,_ ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(let ([,_ ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(letrec-values ([(,idss ...) ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(letrec* ([,ids ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(,proc . ,args) + (let ([proc (unwrap proc)]) + (and (symbol? proc) + (let ([v (or (hash-ref-either knowns imports proc) + (hash-ref prim-knowns proc #f))]) + (and (known-procedure/succeeds? v) + (bitwise-bit-set? (known-procedure-arity-mask v) (length args)))) + (simple-mutated-state? (hash-ref mutated proc #f)) + (for/and ([arg (in-list args)]) + (simple? arg))))] + [`,_ + (let ([e (unwrap e)]) + (or (and (symbol? e) + (simple-mutated-state? (hash-ref mutated e #f))) + (integer? e) + (boolean? e) + (string? e) + (bytes? e) + (regexp? e)))]))) diff -Nru racket-6.12+ppa1/src/schemify/size.rkt racket-7.0+ppa1/src/schemify/size.rkt --- racket-6.12+ppa1/src/schemify/size.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/size.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,76 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "quoted.rkt") + +;; The `linklet-bigger-than?` function is practically an S-expression +;; counter, but it parses expressions properly so it can stop at +;; `quote`. + +(provide linklet-bigger-than?) + +(define (linklet-bigger-than? e size serializable?) + + (define (leftover-size e size) + (cond + [(size . <= . 0) 0] + [else + (match e + [`(begin . ,body) + (body-leftover-size body (sub1 size))] + [`(define-values ,_ ,rhs) + (leftover-size rhs (sub1 size))] + [`(lambda ,_ . ,body) + (body-leftover-size body (sub1 size))] + [`(case-lambda [,_ . ,bodys] ...) + (body-leftover-size bodys (sub1 size))] + [`(let-values ([,_ ,rhss] ...) + . ,body) + (body-leftover-size (cons rhss body) (sub1 size))] + [`(letrec-values ([,_ ,rhss] ...) + . ,body) + (body-leftover-size (cons rhss body) (sub1 size))] + [`(if ,tst ,thn ,els) + (leftover-size els (leftover-size thn (leftover-size tst (sub1 size))))] + [`(with-continuation-mark ,key ,val ,body) + (leftover-size body (leftover-size val (leftover-size key (sub1 size))))] + [`(begin0 . ,body) + (body-leftover-size body (sub1 size))] + [`(quote ,v) (if (and serializable? + (lift-quoted? v #f)) + ;; pessimistically assume that full + ;; strcuture must be lifted for + ;; serialization: + (s-expr-leftover-size v size) + (sub1 size))] + [`(set! ,id ,rhs) (leftover-size rhs (sub1 size))] + [`(#%variable-reference . ,_) (sub1 size)] + [`(,_ . ,_) (body-leftover-size e size)] + [`,_ (sub1 size)])])) + + (define (body-leftover-size body size) + (for/fold ([size size]) ([e (in-wrap-list body)] + #:break (size . <= . 0)) + (leftover-size e size))) + + (define (s-expr-leftover-size v size) + (cond + [(size . <= . 0) 0] + [(pair? v) (s-expr-leftover-size + (cdr v) + (s-expr-leftover-size (car v) (sub1 size)))] + [(box? v) (s-expr-leftover-size (unbox v) (sub1 size))] + [(vector? v) (for/fold ([size (sub1 size)]) ([v (in-vector v)] + #:break (size . <= . 0)) + (s-expr-leftover-size v size))] + [(prefab-struct-key v) + (s-expr-leftover-size (struct->vector v) size)] + [(hash? v) + (for/fold ([size (sub1 size)]) ([(k v) (in-hash v)] + #:break (size . <= . 0)) + (s-expr-leftover-size v (s-expr-leftover-size k size)))] + [else (sub1 size)])) + + (match e + [`(linklet ,_ ,_ . ,body) + ((body-leftover-size body size) . <= . 0)])) diff -Nru racket-6.12+ppa1/src/schemify/struct-type-info.rkt racket-7.0+ppa1/src/schemify/struct-type-info.rkt --- racket-6.12+ppa1/src/schemify/struct-type-info.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/struct-type-info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,120 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "mutated-state.rkt" + "simple.rkt" + "find-known.rkt") + +(provide (struct-out struct-type-info) + struct-type-info-rest-properties-list-pos + make-struct-type-info + pure-properties-list?) + +(struct struct-type-info (name parent + immediate-field-count + field-count + pure-constructor? + authentic? + prefab-immutables ; #f or immutable expression to be quoted + rest)) ; argument expressions after auto-field value +(define struct-type-info-rest-properties-list-pos 0) + +;; Parse `make-struct-type` forms, returning a `struct-type-info` +;; if the parse succeed: +(define (make-struct-type-info v prim-knowns knowns imports mutated) + (match v + [`(make-struct-type (quote ,name) ,parent ,fields 0 #f . ,rest) + ;; Note: auto-field count must be zero, because a non-zero count involves + ;; an arity-reduced procedure + (let ([u-name (unwrap name)] + [u-parent (let ([u-parent (unwrap parent)]) + (or (extract-struct-typed-from-checked u-parent) + u-parent))]) + (and (symbol? u-name) + (or (not u-parent) + (known-struct-type? + (find-known u-parent prim-knowns knowns imports mutated))) + (exact-nonnegative-integer? fields) + (let ([prefab-imms + ;; The inspector argument needs to be missing or duplicable, + ;; and if it's not known to produce a value other than 'prefab, + ;; the list of immutables must be duplicable: + (match rest + [`() 'non-prefab] + [`(,_) 'non-prefab] + [`(,_ #f . ,_) 'non-prefab] + [`(,_ (current-inspector) . ,_) 'non-prefab] + [`(,_ 'prefab ,_ ',immutables . ,_) immutables] + [`(,_ 'prefab ,_) '()] + [`(,_ 'prefab) '()] + [`,_ #f])] + [parent-sti (and u-parent (find-known u-parent prim-knowns knowns imports mutated))]) + (define (includes-property? name) + (and (pair? rest) + (match (car rest) + [`(list (cons ,props ,vals) ...) + (for/or ([prop (in-list props)]) + (eq? (unwrap prop) name))] + [`,_ #f]))) + (and prefab-imms + (struct-type-info name + parent + fields + (+ fields (if u-parent + (known-struct-type-field-count parent-sti) + 0)) + ;; no guard & no prop:chaperone-unsafe-undefined => pure constructor + (and (or (not u-parent) + (known-struct-type-pure-constructor? parent-sti)) + (or ((length rest) . < . 5) + (not (unwrap (list-ref rest 4)))) + (not (includes-property? 'prop:chaperone-unsafe-undefined))) + (includes-property? 'prop:authentic) + (if (eq? prefab-imms 'non-prefab) + #f + prefab-imms) + rest)))))] + [`(let-values () ,body) + (make-struct-type-info body prim-knowns knowns imports mutated)] + [`,_ #f])) + +;; Check whether `e` has the shape of a property list that uses only +;; properties where the property doesn't have a guard or won't invoke +;; a guarded procedure +(define (pure-properties-list? e prim-knowns knowns imports mutated) + (match e + [`(list (cons ,props ,vals) ...) + (for/and ([prop (in-list props)] + [val (in-list vals)]) + (let ([u-prop (unwrap prop)]) + (and (symbol? u-prop) + (or (known-struct-type-property/immediate-guard? + (find-known u-prop prim-knowns knowns imports mutated))) + (simple? val prim-knowns knowns imports mutated))))] + [`null #t] + [`'() #t] + [`,_ #f])) + +;; Recognide +;; (let (( )) +;; (if (struct-type? +;; ....)) +;; and return . This happens when `#:parent` +;; is used in `struct` instead of specifying a parent +;; name next to the struct name. +(define (extract-struct-typed-from-checked e) + (match e + [`(let-values ([(,tmp1) ,id]) + (if (struct-type? ,tmp2) + ,tmp3 + ,_)) + (define u-tmp1 (unwrap tmp1)) + (and (eq? u-tmp1 (unwrap tmp2)) + (eq? u-tmp1 (unwrap tmp3)) + (let ([u (unwrap id)]) + (and (symbol? u) + u)))] + [`,_ #f])) diff -Nru racket-6.12+ppa1/src/schemify/wrap.rkt racket-7.0+ppa1/src/schemify/wrap.rkt --- racket-6.12+ppa1/src/schemify/wrap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/schemify/wrap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,97 @@ +#lang racket/base +(require racket/private/primitive-table + (for-syntax racket/base)) + +(provide unwrap unwrap-list + wrap-pair? wrap-null? wrap-car wrap-cdr wrap-list? + wrap-eq? wrap-equal? + in-wrap-list + wrap-property) + +(import-from-primitive-table + #%kernel + [syntax? correlated?] + [syntax-e correlated-e] + [syntax-property correlated-property]) + +(define (unwrap v) + (if (correlated? v) + (correlated-e v) + v)) + +(define (unwrap-list v) + (cond + [(null? v) null] + [(pair? v) + (let ([r (unwrap-list (cdr v))]) + (if (eq? r (cdr v)) + v + (cons (car v) r)))] + [(correlated? v) (unwrap-list (correlated-e v))] + [else v])) + +(define (wrap-car v) + (if (correlated? v) + (car (correlated-e v)) + (car v))) + +(define (wrap-cdr v) + (if (correlated? v) + (cdr (correlated-e v)) + (cdr v))) + +(define (wrap-pair? v) + (pair? (unwrap v))) + +(define (wrap-null? v) + (null? (unwrap v))) + +(define (wrap-list? v) + (cond + [(null? v) #t] + [(correlated? v) (wrap-list? (correlated-e v))] + [(pair? v) (wrap-list? (cdr v))] + [else #f])) + +(define (wrap-eq? a b) + (eq? (unwrap a) (unwrap b))) + +(define (wrap-equal? a b) + (let ([b (unwrap b)]) + (or (and (not (pair? a)) + (equal? a b)) + (and (pair? a) + (pair? b) + (wrap-equal? (car a) (car b)) + (wrap-equal? (car a) (car b)))))) + +(define (wrap-property a key) + (and (correlated? a) + (correlated-property a key))) + +(define-sequence-syntax in-wrap-list + (lambda (stx) (raise-argument-error "allowed only in `for` forms" stx)) + (lambda (stx) + (syntax-case stx () + [[(id) (_ lst-expr)] + (for-clause-syntax-protect + #'[(id) + (:do-in + ;;outer bindings + ([(lst) lst-expr]) + ;; outer check + (void) + ;; loop bindings + ([lst lst]) + ;; pos check + (not (wrap-null? lst)) + ;; inner bindings + ([(id) (if (wrap-pair? lst) (wrap-car lst) lst)] + [(rest) (if (wrap-pair? lst) (wrap-cdr lst) null)]) + ;; pre guard + #t + ;; post guard + #t + ;; loop args + (rest))])] + [_ #f]))) diff -Nru racket-6.12+ppa1/src/setup-go.rkt racket-7.0+ppa1/src/setup-go.rkt --- racket-6.12+ppa1/src/setup-go.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/setup-go.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,110 @@ +#lang racket/base +(require compiler/depend + ;; This dependency on `compiler/private/cm-minimal` + ;; ensure that it's compiled so that the next use + ;; of "setup-go.rkt" doesn't have to start from source + compiler/private/cm-minimal) + +;; This module is loaded via `setup/main` with a `--boot` argument +;; that selects this module and sets the compile-file root directory +;; to be within the build directory. +;; +;; Overall arguments: +;; +;; --boot +;; +;; ... +;; +;; where is the file to load (bootstrapping as needed), and +;; the s are made the command-line argument for . The +;; is the output file that generates. The +;; is written as makefile rule for , where +;; a "$" is added to the front of if it's parenthesized. +;; +;; If is `--tag`, then specifies a tag to +;; get stripped form , there the target file is immediately after +;; the tag. In that case, the dependency file name is formed by using +;; just the file name of the target, replacing the suffix with ".d". +;; +;; The point of going through `setup/main` is that the Racket module +;; gets compiled as needed, so that it doesn't have to be loaded from +;; source every time. At the same time `setup/main` detects when files +;; need to be recompiled, either becuase the underlying Racket's +;; version changed or because a dependency changed. + +(provide go) + +(define (go orig-compile-file-paths) + (define SETUP-ARGS 6) + (define prog-args (list-tail (vector->list (current-command-line-arguments)) SETUP-ARGS)) + (define target-file-spec (vector-ref (current-command-line-arguments) 3)) + (define target-tag (and (equal? target-file-spec "--tag") + (vector-ref (current-command-line-arguments) 4))) + (define target-file (if target-tag + (let loop ([l prog-args]) + (cond + [(or (null? l) (null? (cdr l))) + (error 'setup-go "could not find target")] + [(equal? (car l) target-tag) (cadr l)] + [else (loop (cdr l))])) + target-file-spec)) + (define make-dep-file (if target-tag + (let-values ([(base name dir?) (split-path target-file)]) + (path-replace-suffix name #".d")) + (vector-ref (current-command-line-arguments) 4))) + (define mod-file (simplify-path (path->complete-path (vector-ref (current-command-line-arguments) 5)))) + (parameterize ([current-command-line-arguments + ;; Discard `--boot` through arguments to this + ;; module, and also strip `target-tag` (if any). + (list->vector (let loop ([l prog-args]) + (cond + [(null? l) '()] + [(equal? (car l) target-tag) (cdr l)] + [else (cons (car l) (loop (cdr l)))])))]) + ;; In case multiple xforms run in parallel, use a lock file so + ;; that only one is building. + (define lock-file (build-path (car (current-compiled-file-roots)) "SETUP-LOCK")) + (define lock-port (open-output-file #:exists 'truncate/replace lock-file)) + (let loop ([n 0]) + (when (= n 3) + (printf "Waiting on lock: ~a" lock-file)) + (unless (port-try-file-lock? lock-port 'exclusive) + (sleep 0.1) + (loop (add1 n)))) + + (with-handlers ([exn? (lambda (exn) + ;; On any execption, try to delete the target file + (with-handlers ([exn:fail:filesystem? + (lambda (exn) (log-error "~s" exn))]) + (when (file-exists? target-file) + (delete-file target-file))) + (raise exn))]) + (dynamic-wind + void + (lambda () + ;; Load the requested module, but don't instantiate: + (dynamic-require mod-file (void))) + (lambda () + (port-file-unlock lock-port))) + + ;; Record dependencies (before running `mod-file`, in case + ;; it mangles parameters) + (define deps (cons mod-file + (module-recorded-dependencies mod-file))) + (define (quote-if-space s) + ;; We're not handling arbitrary paths, but at least support spaces + (if (regexp-match? #rx" " s) (format "\"~a\"" s) s)) + (call-with-output-file make-dep-file + #:exists 'truncate + (lambda (o) + (fprintf o "~a: " (if (regexp-match? #rx"^[(].*[)]$" target-file) + (string-append "$" target-file) + (quote-if-space target-file))) + (for ([dep (in-list deps)]) + (fprintf o " \\\n ~a" (quote-if-space dep))) + (newline o) + (for ([dep (in-list deps)]) + (fprintf o "\n~a:\n" (quote-if-space dep))))) + + ;; Now that the lock is released, instantiate: + (dynamic-require mod-file #f)))) diff -Nru racket-6.12+ppa1/src/start/config.inc racket-7.0+ppa1/src/start/config.inc --- racket-6.12+ppa1/src/start/config.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/config.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,464 @@ +/* This code fragment embeds strings in an executable that can be + updated with various Racket exe-manipulation tools. */ + +#pragma GCC diagnostic ignored "-Wwrite-strings" + +char * volatile scheme_cmdline_exe_hack = (char *) + ("[Replace me for EXE hack " + " ]"); + +#if defined(MZ_CHEZ_SCHEME) +# define GC_PRECISION_TYPE "s" +#elif defined(MZ_PRECISE_GC) +# define GC_PRECISION_TYPE "3" +#else +# define GC_PRECISION_TYPE "c" +#endif +char * volatile scheme_binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE GC_PRECISION_TYPE; +/* The format of bINARy tYPe is e?[zr]i[3cs]. + e indicates a starter executable + z/r indicates Racket or GRacket + i indicates ??? + 3/c/s indicates 3m or CGC or Chez Scheme */ + +#ifndef INITIAL_COLLECTS_DIRECTORY +# ifdef DOS_FILE_SYSTEM +# define INITIAL_COLLECTS_DIRECTORY "collects" +# else +# define INITIAL_COLLECTS_DIRECTORY "../collects" +# endif +#endif + +char * volatile scheme_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ + INITIAL_COLLECTS_DIRECTORY + "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _coldir_offset = 19; /* Skip permanent tag */ + +#ifndef INITIAL_CONFIG_DIRECTORY +# ifdef DOS_FILE_SYSTEM +# define INITIAL_CONFIG_DIRECTORY "etc" +# else +# define INITIAL_CONFIG_DIRECTORY "../etc" +# endif +#endif + +char * volatile scheme_configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ + INITIAL_CONFIG_DIRECTORY + "\0" + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _configdir_offset = 17; /* Skip permanent tag */ + +#ifndef MZ_XFORM +# define GC_CAN_IGNORE /**/ +#endif + +#ifndef MZ_PRECISE_GC +# define XFORM_OK_PLUS + +#endif + +#ifdef OS_X +# include +# include +# include +#endif + +#ifdef DOS_FILE_SYSTEM +# include + +#ifndef DLL_RELATIVE_PATH +# define DLL_RELATIVE_PATH L"lib" +#endif +#include "delayed.inc" + +static wchar_t *extract_dlldir() +{ + if (_dlldir[_dlldir_offset] != '<') + return _dlldir + _dlldir_offset; + else + return NULL; +} + +# ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +# endif +#endif + +#ifdef OS_X +static long get_segment_offset() +{ +# if defined(__x86_64__) || defined(__arm64__) + const struct segment_command_64 *seg; +# else + const struct segment_command *seg; +#endif + seg = getsegbyname("__PLTSCHEME"); + if (seg) + return seg->fileoff; + else + return 0; +} +#endif + +#ifdef DOS_FILE_SYSTEM +wchar_t *get_self_executable_path() XFORM_SKIP_PROC +{ + wchar_t *path; + DWORD r, sz = 1024; + + while (1) { + path = (wchar_t *)malloc(sz * sizeof(wchar_t)); + r = GetModuleFileNameW(NULL, path, sz); + if ((r == sz) + && (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { + free(path); + sz = 2 * sz; + } else + break; + } + + return path; +} + +static DWORD find_by_id(HANDLE fd, DWORD rsrcs, DWORD pos, int id) XFORM_SKIP_PROC +{ + DWORD got, val; + WORD name_count, id_count; + + SetFilePointer(fd, pos + 12, 0, FILE_BEGIN); + ReadFile(fd, &name_count, 2, &got, NULL); + ReadFile(fd, &id_count, 2, &got, NULL); + + pos += 16 + (name_count * 8); + while (id_count--) { + ReadFile(fd, &val, 4, &got, NULL); + if (val == id) { + ReadFile(fd, &val, 4, &got, NULL); + return rsrcs + (val & 0x7FFFFFF); + } else { + ReadFile(fd, &val, 4, &got, NULL); + } + } + + return 0; +} + +static long find_resource_offset(int id) XFORM_SKIP_PROC +{ + /* Find the resource of type `id` */ + wchar_t *path; + HANDLE fd; + + path = get_self_executable_path(); + fd = CreateFileW(path, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, + OPEN_EXISTING, + 0, + NULL); + free(path); + + if (fd == INVALID_HANDLE_VALUE) + return 0; + else { + DWORD val, got, sec_pos, virtual_addr, rsrcs, pos; + WORD num_sections, head_size; + char name[8]; + + SetFilePointer(fd, 60, 0, FILE_BEGIN); + ReadFile(fd, &val, 4, &got, NULL); + SetFilePointer(fd, val+4+2, 0, FILE_BEGIN); /* Skip "PE\0\0" tag and machine */ + ReadFile(fd, &num_sections, 2, &got, NULL); + SetFilePointer(fd, 12, 0, FILE_CURRENT); /* time stamp + symbol table */ + ReadFile(fd, &head_size, 2, &got, NULL); + + sec_pos = val+4+20+head_size; + while (num_sections--) { + SetFilePointer(fd, sec_pos, 0, FILE_BEGIN); + ReadFile(fd, &name, 8, &got, NULL); + if ((name[0] == '.') + && (name[1] == 'r') + && (name[2] == 's') + && (name[3] == 'r') + && (name[4] == 'c') + && (name[5] == 0)) { + SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip virtual size */ + ReadFile(fd, &virtual_addr, 4, &got, NULL); + SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip file size */ + ReadFile(fd, &rsrcs, 4, &got, NULL); + SetFilePointer(fd, rsrcs, 0, FILE_BEGIN); + + /* We're at the resource table; step through 3 layers */ + pos = find_by_id(fd, rsrcs, rsrcs, id); + if (pos) { + pos = find_by_id(fd, rsrcs, pos, 1); + if (pos) { + pos = find_by_id(fd, rsrcs, pos, 1033); + + if (pos) { + /* pos is the reource data entry */ + SetFilePointer(fd, pos, 0, FILE_BEGIN); + ReadFile(fd, &val, 4, &got, NULL); + pos = val - virtual_addr + rsrcs; + + CloseHandle(fd); + + return pos; + } + } + } + + break; + } + sec_pos += 40; + } + + /* something went wrong */ + CloseHandle(fd); + return 0; + } +} + +static long get_segment_offset() XFORM_SKIP_PROC +{ + return find_resource_offset(257); +} + +#endif + +static void extract_built_in_arguments(char **_prog, char **_sprog, int *_argc, char ***_argv) +{ + GC_CAN_IGNORE char *prog = *_prog; + GC_CAN_IGNORE char *sprog = *_sprog; + +#ifdef DOS_FILE_SYSTEM + { + /* For consistency, strip trailing spaces and dots, and make sure the .exe + extension is present. */ + int l = strlen(prog); + if ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { + char *s; + while ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { + l--; + } + s = (char *)malloc(l + 1); + memcpy(s, prog, l); + s[l] = 0; + prog = s; + } + if (l <= 4 + || (prog[l - 4] != '.') + || (tolower(((unsigned char *)prog)[l - 3]) != 'e') + || (tolower(((unsigned char *)prog)[l - 2]) != 'x') + || (tolower(((unsigned char *)prog)[l - 1]) != 'e')) { + char *s; + s = (char *)malloc(l + 4 + 1); + memcpy(s, prog, l); + memcpy(s + l, ".exe", 5); + prog = s; + } + } +#endif + + /* If scheme_cmdline_exe_hack is changed, then we extract built-in + arguments. */ + if (scheme_cmdline_exe_hack[0] != '[') { + int argc = *_argc; + GC_CAN_IGNORE char **argv = *_argv; + int n, i; + long d; + GC_CAN_IGNORE unsigned char *p; + GC_CAN_IGNORE unsigned char *orig_p; + char **argv2; + + p = NULL; +#ifdef DOS_FILE_SYSTEM + if ((scheme_cmdline_exe_hack[0] == '?') + || (scheme_cmdline_exe_hack[0] == '*')) { + /* This is how we make launchers in Windows. The cmdline is + added as a resource of type 257. The long integer at + scheme_cmdline_exe_hack[4] says where the command line starts + with the source, and scheme_cmdline_exe_hack[8] says how long + the cmdline string is. It might be relative to the + executable. */ + HANDLE fd; + wchar_t *path; + + path = get_self_executable_path(); + fd = CreateFileW(path, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, + OPEN_EXISTING, + 0, + NULL); + if (fd == INVALID_HANDLE_VALUE) + p = (unsigned char *)"\0\0\0"; + else { + long start, len; + DWORD got; + start = *(long *)&scheme_cmdline_exe_hack[4]; + len = *(long *)&scheme_cmdline_exe_hack[8]; + start += get_segment_offset(); + p = (unsigned char *)malloc(len); + SetFilePointer(fd, start, 0, FILE_BEGIN); + ReadFile(fd, p, len, &got, NULL); + CloseHandle(fd); + if (got != len) + p = (unsigned char *)"\0\0\0"; + else if (scheme_cmdline_exe_hack[0] == '*') { + /* "*" means that the first item is argv[0] replacement: */ + sprog = prog; + prog = (char *)p + 4; + + if ((prog[0] == '\\') + || ((((prog[0] >= 'a') && (prog[0] <= 'z')) + || ((prog[0] >= 'A') && (prog[0] <= 'Z'))) + && (prog[1] == ':'))) { + /* Absolute path */ + } else { + /* Make it absolute, relative to this executable */ + int plen = strlen(prog); + int mlen, len; + char *s2, *p2; + + /* UTF-8 encode path: */ + for (len = 0; path[len]; len++) { } + mlen = scheme_utf8_encode((unsigned int *)path, 0, len, + NULL, 0, + 1 /* UTF-16 */); + p2 = (char *)malloc(mlen + 1); + mlen = scheme_utf8_encode((unsigned int *)path, 0, len, + (unsigned char *)p2, 0, + 1 /* UTF-16 */); + + while (mlen && (p2[mlen - 1] != '\\')) { + mlen--; + } + s2 = (char *)malloc(mlen + plen + 1); + memcpy(s2, p2, mlen); + memcpy(s2 + mlen, prog, plen + 1); + prog = s2; + } + + p += (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24) + + 4); + } + } + free(path); + } +#endif +#if defined(OS_X) + if (scheme_cmdline_exe_hack[0] == '?') { + long fileoff, cmdoff, cmdlen; + int fd; + fileoff = get_segment_offset(); + + p = (unsigned char *)scheme_cmdline_exe_hack + 4; + cmdoff = (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24)); + cmdlen = (p[4] + + (((long)p[5]) << 8) + + (((long)p[6]) << 16) + + (((long)p[7]) << 24)); + p = malloc(cmdlen); + + fd = open(_dyld_get_image_name(0), O_RDONLY); + lseek(fd, fileoff + cmdoff, 0); + read(fd, p, cmdlen); + close(fd); + } +#endif + + if (!p) + p = (unsigned char *)scheme_cmdline_exe_hack + 1; + + /* Command line is encoded as a sequence of pascal-style strings; + we use four whole bytes for the length, though, little-endian. */ + + orig_p = p; + + n = 0; + while (p[0] || p[1] || p[2] || p[3]) { + n++; + p += (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24) + + 4); + } + + argv2 = (char **)malloc(sizeof(char *) * (argc + n)); + p = orig_p; + for (i = 0; i < n; i++) { + d = (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24)); + argv2[i] = (char *)p + 4; + p += d + 4; + } + for (; i < n + argc; i++) { + argv2[i] = argv[i - n]; + } + argv = argv2; + argc += n; + + + *_argc = argc; + *_argv = argv; + } + + *_prog = prog; + *_sprog = sprog; +} + +static char *extract_coldir() +{ + return scheme_coldir + _coldir_offset; +} + +static char *extract_configdir() +{ + return scheme_configdir XFORM_OK_PLUS _configdir_offset; +} + +#if !defined(OS_X) && !defined(DOS_FILE_SYSTEM) +# define NO_GET_SEGMENT_OFFSET +#endif diff -Nru racket-6.12+ppa1/src/start/delayed.inc racket-7.0+ppa1/src/start/delayed.inc --- racket-6.12+ppa1/src/start/delayed.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/delayed.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,84 @@ + +/* Extra configuration and support for Windows */ + +# ifdef MZ_PRECISE_GC +# define DLL_3M_SUFFIX "3m" +# else +# define DLL_3M_SUFFIX "" +# endif +static wchar_t *_dlldir = L"dLl dIRECTORy:" /* <- this tag stays, so we can find it again */ + DLL_RELATIVE_PATH L"\0" + /* Pad with 512 characters: */ + L"****************************************************************" + L"****************************************************************" + L"****************************************************************" + L"****************************************************************" + L"****************************************************************" + L"****************************************************************" + L"****************************************************************" + L"****************************************************************"; +static int _dlldir_offset = 14; /* Skip permanent tag */ + +# ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +# endif + +static void load_delayed_dll(HINSTANCE me, const char *lib) +{ + /* Don't use the C library here! */ + const wchar_t *dlldir = _dlldir + _dlldir_offset; + + if (dlldir[0] != '<') { + if ((dlldir[0] == '\\') + || ((((dlldir[0] >= 'a') && (dlldir[0] <= 'z')) + || ((dlldir[0] >= 'A') && (dlldir[0] <= 'Z'))) + && (dlldir[1] == ':'))) { + /* Absolute path */ + } else { + /* Make it absolute, relative to this module */ + wchar_t *name, *s; + int j, i; + name = (wchar_t *)GlobalAlloc(GMEM_FIXED, 1024 * sizeof(wchar_t)); + GetModuleFileNameW(me, name, 1024); + name[1023] = 0; + s = (wchar_t *)GlobalAlloc(GMEM_FIXED, 2048 * sizeof(wchar_t)); + for (i = 0; name[i]; i++) { } + --i; + while (i && (name[i] != '\\')) { + --i; + } + name[i+1] = 0; + for (i = 0; name[i]; i++) { + s[i] = name[i]; + } + for (j = 0; dlldir[j]; j++, i++) { + s[i] = dlldir[j]; + } + s[i] = 0; + dlldir = s; + _dlldir = s; + _dlldir_offset = 0; + } + + { + wchar_t *t; + int j, i; + + t = (wchar_t *)GlobalAlloc(GMEM_FIXED, 2048 * sizeof(wchar_t)); + for (i = 0; dlldir[i]; i++) { + t[i] = dlldir[i]; + } + if (t[i-1] != '\\') + t[i++] = '\\'; + for (j = 0; lib[j]; j++, i++) { + t[i] = lib[j]; + } + t[i] = 0; + + if (!LoadLibraryW(t)) { + MessageBoxW(NULL, t, L"Failure: cannot load DLL", MB_OK); + ExitProcess(1); + } + } + } +} diff -Nru racket-6.12+ppa1/src/start/embedded_dll.inc racket-7.0+ppa1/src/start/embedded_dll.inc --- racket-6.12+ppa1/src/start/embedded_dll.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/embedded_dll.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,243 @@ +#include "MemoryModule.h" + +#define noisy_embedded 0 + +typedef struct embedded_dll_entry_t { + char *name; + long pos; + HMEMORYMODULE loaded_h; +} embedded_dll_entry_t; + +static embedded_dll_entry_t *embedded_dlls; + +void *__pfnDliNotifyHook2 = NULL; +static FARPROC WINAPI delayHook(unsigned dliNotify, void *pdli); +static HCUSTOMMODULE LoadLibraryHook(LPCSTR, void *); +static FARPROC GetProcAddressHook(HCUSTOMMODULE, LPCSTR, void *); + +static HANDLE open_self() +{ + wchar_t *path; + HANDLE fd; + + path = get_self_executable_path(); + + fd = CreateFileW(path, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, + OPEN_EXISTING, + 0, + NULL); + + free(path); + + return fd; +} + +static void parse_embedded_dlls() +{ + long rsrc_pos; + + rsrc_pos = find_resource_offset(258); + if (rsrc_pos) { + HANDLE fd = open_self(); + + if (fd != INVALID_HANDLE_VALUE) { + long pos; + DWORD count, got, i; + short name_len; + char *name; + + SetFilePointer(fd, rsrc_pos, 0, FILE_BEGIN); + ReadFile(fd, &count, sizeof(DWORD), &got, NULL); + + embedded_dlls = malloc(sizeof(embedded_dll_entry_t) * (count + 1)); + for (i = 0; i < count; i++) { + ReadFile(fd, &name_len, sizeof(short), &got, NULL); + name = malloc(name_len + 1); + ReadFile(fd, name, name_len, &got, NULL); + name[name_len] = 0; + embedded_dlls[i].name = name; + if (noisy_embedded) + fprintf(stderr, "embedded %s\n", name); + } + embedded_dlls[count].name = NULL; + + for (i = 0; i < count+1; i++) { + ReadFile(fd, &pos, sizeof(pos), &got, NULL); + embedded_dlls[i].pos = pos + rsrc_pos; + embedded_dlls[i].loaded_h = NULL; + } + + CloseHandle(fd); + + __pfnDliNotifyHook2 = delayHook; + } + } +} + +static void *in_memory_open(const char *name, int as_global) +{ + int i; + + for (i = 0; embedded_dlls[i].name; i++) { + if (!_stricmp(embedded_dlls[i].name, name)) { + HMEMORYMODULE loaded_h = (void *)embedded_dlls[i].loaded_h; + if (!loaded_h) { + HANDLE fd = open_self(); + + if (fd != INVALID_HANDLE_VALUE) { + void *p; + DWORD got; + long len = embedded_dlls[i+1].pos - embedded_dlls[i].pos; + + SetFilePointer(fd, embedded_dlls[i].pos, 0, FILE_BEGIN); + p = malloc(len); + ReadFile(fd, p, len, &got, NULL); + CloseHandle(fd); + + if (got != len) + fprintf(stderr, "partial load %d vs %ld\n", got, len); + + loaded_h = MemoryLoadLibraryEx(p, len, + MemoryDefaultAlloc, MemoryDefaultFree, + LoadLibraryHook, GetProcAddressHook, + MemoryDefaultFreeLibrary, NULL); + if (noisy_embedded) { + if (!loaded_h) { + fprintf(stderr, "failed %s %d\n", name, GetLastError()); + } else + fprintf(stderr, "ok %s\n", name); + } + + free(p); + + embedded_dlls[i].loaded_h = loaded_h; + } + } + return (void *)loaded_h; + } + } + + return NULL; +} + +static void *in_memory_find_object(void *h, const char *name) +{ + if (h) + return MemoryGetProcAddress((HMEMORYMODULE)h, name); + else { + /* Search all loaded DLLs */ + int i; + for (i = 0; embedded_dlls[i].name; i++) { + if (embedded_dlls[i].loaded_h) { + void *v = MemoryGetProcAddress((HMEMORYMODULE)embedded_dlls[i].loaded_h, name); + if (v) + return v; + } + } + return NULL; + } +} + +static void register_embedded_dll_hooks() +{ + if (embedded_dlls) { + scheme_set_dll_procs(in_memory_open, in_memory_find_object); + } +} + +/**************************************************************/ + +typedef struct custom_module_t { + int hooked; + void *h; +} custom_module_t; + +static HCUSTOMMODULE LoadLibraryHook(LPCSTR name, void *data) +{ + void *h; + int hooked = 1; + custom_module_t *m; + + h = (HANDLE)in_memory_open(name, 0); + if (h) + hooked = 1; + else { + h = MemoryDefaultLoadLibrary(name, data); + hooked = 0; + } + + if (!h) + return NULL; + + m = malloc(sizeof(custom_module_t)); + m->hooked = hooked; + m->h = h; + + return (HCUSTOMMODULE)m; +} + +static FARPROC GetProcAddressHook(HCUSTOMMODULE _m, LPCSTR name, void *data) +{ + custom_module_t *m = (custom_module_t *)_m; + + if (m->hooked) + return in_memory_find_object(m->h, name); + else + return MemoryDefaultGetProcAddress(m->h, name, data); +} + +/*************************************************************/ + +/* Set a delay-load hook to potentially redirect to an embedded DLL */ + +/* From Microsoft docs: */ + +typedef struct mz_DelayLoadProc { + BOOL fImportByName; + union { + LPCSTR szProcName; + DWORD dwOrdinal; + }; +} mz_DelayLoadProc; + +typedef struct Mz_DelayLoadInfo { + DWORD cb; // size of structure + void *pidd; // raw form of data (everything is there) + FARPROC * ppfn; // points to address of function to load + LPCSTR szDll; // name of dll + mz_DelayLoadProc dlp; // name or ordinal of procedure + HMODULE hmodCur; // the hInstance of the library we have loaded + FARPROC pfnCur; // the actual function that will be called + DWORD dwLastError;// error received (if an error notification) +} mz_DelayLoadInfo; + +# define mz_dliNotePreLoadLibrary 1 +# define mz_dliNotePreGetProcAddress 2 + +FARPROC WINAPI delayHook(unsigned dliNotify, void *_dli) +{ + mz_DelayLoadInfo *dli = (mz_DelayLoadInfo *)_dli; + + switch (dliNotify) { + case mz_dliNotePreLoadLibrary: + return in_memory_open(dli->szDll, 0); + break; + case mz_dliNotePreGetProcAddress: + { + void *h; + h = in_memory_open(dli->szDll, 0); + if (h) { + if (dli->dlp.fImportByName) + return in_memory_find_object(h, dli->dlp.szProcName); + else + return in_memory_find_object(h, (char *)(intptr_t)dli->dlp.dwOrdinal); + } + } + default: + break; + } + + return NULL; +} diff -Nru racket-6.12+ppa1/src/start/gui_filter.inc racket-7.0+ppa1/src/start/gui_filter.inc --- racket-6.12+ppa1/src/start/gui_filter.inc 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/gui_filter.inc 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,117 @@ +/* + Defines + void pre_filter_cmdline_arguments(int *argc, char ***argv) + and may use + void scheme_register_process_global(const char *key, void *v); +*/ + +#if !defined(MZ_XFORM) && !defined(XFORM_SKIP_PROC) +# define XFORM_SKIP_PROC /**/ +#endif + +/***********************************************************************/ +/* X11 flag handling */ +/***********************************************************************/ + +#ifdef wx_xt + +typedef struct { + char *flag; + int arg_count; +} X_flag_entry; + +#define SINGLE_INSTANCE "-singleInstance" + +X_flag_entry X_flags[] = { + { "-display", 1 }, + { "-geometry", 1 }, + { "-bg", 1 }, + { "-background", 1 }, + { "-fg", 1 }, + { "-foreground", 1 }, + { "-fn", 1 }, + { "-font", 1 }, + { "-iconic", 0 }, + { "-name", 1 }, + { "-rv", 0 }, + { "-reverse", 0 }, + { "+rv", 0 }, + { "-selectionTimeout", 1 }, + { "-synchronous", 0 }, + { "-title", 1 }, + { "-xnllanguage", 1 }, + { "-xrm", 1 }, + { SINGLE_INSTANCE, 0}, + { NULL, 0 } +}; + +static int filter_x_readable(char **argv, int argc) + XFORM_SKIP_PROC +{ + int pos = 1, i; + + while (pos < argc) { + for (i = 0; X_flags[i].flag; i++) { + if (!strcmp(X_flags[i].flag, argv[pos])) + break; + } + + if (!X_flags[i].flag) + return pos; + else { + int newpos = pos + X_flags[i].arg_count + 1; + if (newpos > argc) { + printf("%s: X Window System flag \"%s\" expects %d arguments, %d provided\n", + argv[0], argv[pos], X_flags[i].arg_count, argc - pos - 1); + exit(-1); + } + pos = newpos; + } + } + + return pos; +} + +static void pre_filter_cmdline_arguments(int *argc, char ***argv) + XFORM_SKIP_PROC +{ + int pos; + char **naya; + + pos = filter_x_readable(*argv, *argc); + if (pos > 1) { + scheme_register_process_global("PLT_X11_ARGUMENT_COUNT", (void *)(intptr_t)pos); + scheme_register_process_global("PLT_X11_ARGUMENTS", *argv); + naya = malloc((*argc - (pos - 1)) * sizeof(char *)); + memcpy(naya, *argv + (pos - 1), (*argc - (pos - 1)) * sizeof(char *)); + naya[0] = (*argv)[0]; + *argv = naya; + *argc -= (pos - 1); + } +} + +#endif + +/***********************************************************************/ +/* Mac OS X flag handling */ +/***********************************************************************/ + +#ifdef wx_mac + +static void pre_filter_cmdline_arguments(int *argc, char ***argv) + XFORM_SKIP_PROC +{ + if ((*argc > 1) && !strncmp((*argv)[1], "-psn_", 5)) { + /* Finder adds "-psn_" when you double-click on the application. + Drop it. */ + char **new_argv; + new_argv = (char **)malloc(((*argc) - 1) * sizeof(char *)); + new_argv[0] = (*argv)[0]; + memcpy(new_argv + 1, (*argv) + 2, ((*argc) - 2) * sizeof(char *)); + (*argc)--; + *argv = new_argv; + } + scheme_register_process_global("PLT_IS_FOREGROUND_APP", (void *)(intptr_t)0x1); +} + +#endif diff -Nru racket-6.12+ppa1/src/start/MemoryModule.c racket-7.0+ppa1/src/start/MemoryModule.c --- racket-6.12+ppa1/src/start/MemoryModule.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/MemoryModule.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,1207 @@ +/* + * Memory DLL loading code + * Version 0.0.4 + * + * Copyright (c) 2004-2015 by Joachim Bauch / mail@joachim-bauch.de + * http://www.joachim-bauch.de + * + * The contents of this file are subject to the Mozilla Public License Version + * 2.0 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is MemoryModule.c + * + * The Initial Developer of the Original Code is Joachim Bauch. + * + * Portions created by Joachim Bauch are Copyright (C) 2004-2015 + * Joachim Bauch. All Rights Reserved. + * + * + * THeller: Added binary search in MemoryGetProcAddress function + * (#define USE_BINARY_SEARCH to enable it). This gives a very large + * speedup for libraries that exports lots of functions. + * + * These portions are Copyright (C) 2013 Thomas Heller. + */ + +#include +#include +#include +#include +#ifdef DEBUG_OUTPUT +#include +#endif + +#if _MSC_VER +// Disable warning about data -> function pointer conversion +#pragma warning(disable:4055) + // C4244: conversion from 'uintptr_t' to 'DWORD', possible loss of data. +#pragma warning(error: 4244) +// C4267: conversion from 'size_t' to 'int', possible loss of data. +#pragma warning(error: 4267) + +#define inline __inline +#endif + +#ifndef IMAGE_SIZEOF_BASE_RELOCATION +// Vista SDKs no longer define IMAGE_SIZEOF_BASE_RELOCATION!? +#define IMAGE_SIZEOF_BASE_RELOCATION (sizeof(IMAGE_BASE_RELOCATION)) +#endif + +#ifdef _WIN64 +#define HOST_MACHINE IMAGE_FILE_MACHINE_AMD64 +#else +#define HOST_MACHINE IMAGE_FILE_MACHINE_I386 +#endif + +#include "MemoryModule.h" + +struct ExportNameEntry { + LPCSTR name; + WORD idx; +}; + +typedef BOOL (WINAPI *DllEntryProc)(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpReserved); +typedef int (WINAPI *ExeEntryProc)(void); + +#ifdef _WIN64 +typedef struct POINTER_LIST { + struct POINTER_LIST *next; + void *address; +} POINTER_LIST; +#endif + +typedef struct { + PIMAGE_NT_HEADERS headers; + unsigned char *codeBase; + HCUSTOMMODULE *modules; + int numModules; + BOOL initialized; + BOOL isDLL; + BOOL isRelocated; + CustomAllocFunc alloc; + CustomFreeFunc free; + CustomLoadLibraryFunc loadLibrary; + CustomGetProcAddressFunc getProcAddress; + CustomFreeLibraryFunc freeLibrary; + struct ExportNameEntry *nameExportsTable; + void *userdata; + ExeEntryProc exeEntry; + DWORD pageSize; +#ifdef _WIN64 + POINTER_LIST *blockedMemory; +#endif +} MEMORYMODULE, *PMEMORYMODULE; + +typedef struct { + LPVOID address; + LPVOID alignedAddress; + SIZE_T size; + DWORD characteristics; + BOOL last; +} SECTIONFINALIZEDATA, *PSECTIONFINALIZEDATA; + +#define GET_HEADER_DICTIONARY(module, idx) &(module)->headers->OptionalHeader.DataDirectory[idx] + +static inline uintptr_t +AlignValueDown(uintptr_t value, uintptr_t alignment) { + return value & ~(alignment - 1); +} + +static inline LPVOID +AlignAddressDown(LPVOID address, uintptr_t alignment) { + return (LPVOID) AlignValueDown((uintptr_t) address, alignment); +} + +static inline size_t +AlignValueUp(size_t value, size_t alignment) { + return (value + alignment - 1) & ~(alignment - 1); +} + +static inline void* +OffsetPointer(void* data, ptrdiff_t offset) { + return (void*) ((uintptr_t) data + offset); +} + +static inline void +OutputLastError(const char *msg) +{ +#ifndef DEBUG_OUTPUT + UNREFERENCED_PARAMETER(msg); +#else + LPVOID tmp; + char *tmpmsg; + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&tmp, 0, NULL); + tmpmsg = (char *)LocalAlloc(LPTR, strlen(msg) + strlen(tmp) + 3); + sprintf(tmpmsg, "%s: %s", msg, tmp); + OutputDebugString(tmpmsg); + LocalFree(tmpmsg); + LocalFree(tmp); +#endif +} + +#ifdef _WIN64 +static void +FreePointerList(POINTER_LIST *head, CustomFreeFunc freeMemory, void *userdata) +{ + POINTER_LIST *node = head; + while (node) { + POINTER_LIST *next; + freeMemory(node->address, 0, MEM_RELEASE, userdata); + next = node->next; + free(node); + node = next; + } +} +#endif + +static BOOL +CheckSize(size_t size, size_t expected) { + if (size < expected) { + SetLastError(ERROR_INVALID_DATA); + return FALSE; + } + + return TRUE; +} + +static BOOL +CopySections(const unsigned char *data, size_t size, PIMAGE_NT_HEADERS old_headers, PMEMORYMODULE module) +{ + int i, section_size; + unsigned char *codeBase = module->codeBase; + unsigned char *dest; + PIMAGE_SECTION_HEADER section = IMAGE_FIRST_SECTION(module->headers); + for (i=0; iheaders->FileHeader.NumberOfSections; i++, section++) { + if (section->SizeOfRawData == 0) { + // section doesn't contain data in the dll itself, but may define + // uninitialized data + section_size = old_headers->OptionalHeader.SectionAlignment; + if (section_size > 0) { + dest = (unsigned char *)module->alloc(codeBase + section->VirtualAddress, + section_size, + MEM_COMMIT, + PAGE_READWRITE, + module->userdata); + if (dest == NULL) { + return FALSE; + } + + // Always use position from file to support alignments smaller + // than page size (allocation above will align to page size). + dest = codeBase + section->VirtualAddress; + // NOTE: On 64bit systems we truncate to 32bit here but expand + // again later when "PhysicalAddress" is used. + section->Misc.PhysicalAddress = (DWORD) ((uintptr_t) dest & 0xffffffff); + memset(dest, 0, section_size); + } + + // section is empty + continue; + } + + if (!CheckSize(size, section->PointerToRawData + section->SizeOfRawData)) { + return FALSE; + } + + // commit memory block and copy data from dll + dest = (unsigned char *)module->alloc(codeBase + section->VirtualAddress, + section->SizeOfRawData, + MEM_COMMIT, + PAGE_READWRITE, + module->userdata); + if (dest == NULL) { + return FALSE; + } + + // Always use position from file to support alignments smaller + // than page size (allocation above will align to page size). + dest = codeBase + section->VirtualAddress; + memcpy(dest, data + section->PointerToRawData, section->SizeOfRawData); + // NOTE: On 64bit systems we truncate to 32bit here but expand + // again later when "PhysicalAddress" is used. + section->Misc.PhysicalAddress = (DWORD) ((uintptr_t) dest & 0xffffffff); + } + + return TRUE; +} + +// Protection flags for memory pages (Executable, Readable, Writeable) +static int ProtectionFlags[2][2][2] = { + { + // not executable + {PAGE_NOACCESS, PAGE_WRITECOPY}, + {PAGE_READONLY, PAGE_READWRITE}, + }, { + // executable + {PAGE_EXECUTE, PAGE_EXECUTE_WRITECOPY}, + {PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE}, + }, +}; + +static SIZE_T +GetRealSectionSize(PMEMORYMODULE module, PIMAGE_SECTION_HEADER section) { + DWORD size = section->SizeOfRawData; + if (size == 0) { + if (section->Characteristics & IMAGE_SCN_CNT_INITIALIZED_DATA) { + size = module->headers->OptionalHeader.SizeOfInitializedData; + } else if (section->Characteristics & IMAGE_SCN_CNT_UNINITIALIZED_DATA) { + size = module->headers->OptionalHeader.SizeOfUninitializedData; + } + } + return (SIZE_T) size; +} + +static BOOL +FinalizeSection(PMEMORYMODULE module, PSECTIONFINALIZEDATA sectionData) { + DWORD protect, oldProtect; + BOOL executable; + BOOL readable; + BOOL writeable; + + if (sectionData->size == 0) { + return TRUE; + } + + if (sectionData->characteristics & IMAGE_SCN_MEM_DISCARDABLE) { + // section is not needed any more and can safely be freed + if (sectionData->address == sectionData->alignedAddress && + (sectionData->last || + module->headers->OptionalHeader.SectionAlignment == module->pageSize || + (sectionData->size % module->pageSize) == 0) + ) { + // Only allowed to decommit whole pages + module->free(sectionData->address, sectionData->size, MEM_DECOMMIT, module->userdata); + } + return TRUE; + } + + // determine protection flags based on characteristics + executable = (sectionData->characteristics & IMAGE_SCN_MEM_EXECUTE) != 0; + readable = (sectionData->characteristics & IMAGE_SCN_MEM_READ) != 0; + writeable = (sectionData->characteristics & IMAGE_SCN_MEM_WRITE) != 0; + protect = ProtectionFlags[executable][readable][writeable]; + if (sectionData->characteristics & IMAGE_SCN_MEM_NOT_CACHED) { + protect |= PAGE_NOCACHE; + } + + // change memory access flags + if (VirtualProtect(sectionData->address, sectionData->size, protect, &oldProtect) == 0) { + OutputLastError("Error protecting memory page"); + return FALSE; + } + + return TRUE; +} + +static BOOL +FinalizeSections(PMEMORYMODULE module) +{ + int i; + PIMAGE_SECTION_HEADER section = IMAGE_FIRST_SECTION(module->headers); +#ifdef _WIN64 + // "PhysicalAddress" might have been truncated to 32bit above, expand to + // 64bits again. + uintptr_t imageOffset = ((uintptr_t) module->headers->OptionalHeader.ImageBase & 0xffffffff00000000); +#else + static const uintptr_t imageOffset = 0; +#endif + SECTIONFINALIZEDATA sectionData; + sectionData.address = (LPVOID)((uintptr_t)section->Misc.PhysicalAddress | imageOffset); + sectionData.alignedAddress = AlignAddressDown(sectionData.address, module->pageSize); + sectionData.size = GetRealSectionSize(module, section); + sectionData.characteristics = section->Characteristics; + sectionData.last = FALSE; + section++; + + // loop through all sections and change access flags + for (i=1; iheaders->FileHeader.NumberOfSections; i++, section++) { + LPVOID sectionAddress = (LPVOID)((uintptr_t)section->Misc.PhysicalAddress | imageOffset); + LPVOID alignedAddress = AlignAddressDown(sectionAddress, module->pageSize); + SIZE_T sectionSize = GetRealSectionSize(module, section); + // Combine access flags of all sections that share a page + // TODO(fancycode): We currently share flags of a trailing large section + // with the page of a first small section. This should be optimized. + if (sectionData.alignedAddress == alignedAddress || (uintptr_t) sectionData.address + sectionData.size > (uintptr_t) alignedAddress) { + // Section shares page with previous + if ((section->Characteristics & IMAGE_SCN_MEM_DISCARDABLE) == 0 || (sectionData.characteristics & IMAGE_SCN_MEM_DISCARDABLE) == 0) { + sectionData.characteristics = (sectionData.characteristics | section->Characteristics) & ~IMAGE_SCN_MEM_DISCARDABLE; + } else { + sectionData.characteristics |= section->Characteristics; + } + sectionData.size = (((uintptr_t)sectionAddress) + ((uintptr_t) sectionSize)) - (uintptr_t) sectionData.address; + continue; + } + + if (!FinalizeSection(module, §ionData)) { + return FALSE; + } + sectionData.address = sectionAddress; + sectionData.alignedAddress = alignedAddress; + sectionData.size = sectionSize; + sectionData.characteristics = section->Characteristics; + } + sectionData.last = TRUE; + if (!FinalizeSection(module, §ionData)) { + return FALSE; + } + return TRUE; +} + +static BOOL +ExecuteTLS(PMEMORYMODULE module) +{ + unsigned char *codeBase = module->codeBase; + PIMAGE_TLS_DIRECTORY tls; + PIMAGE_TLS_CALLBACK* callback; + + PIMAGE_DATA_DIRECTORY directory = GET_HEADER_DICTIONARY(module, IMAGE_DIRECTORY_ENTRY_TLS); + if (directory->VirtualAddress == 0) { + return TRUE; + } + + tls = (PIMAGE_TLS_DIRECTORY) (codeBase + directory->VirtualAddress); + callback = (PIMAGE_TLS_CALLBACK *) tls->AddressOfCallBacks; + if (callback) { + while (*callback) { + (*callback)((LPVOID) codeBase, DLL_PROCESS_ATTACH, NULL); + callback++; + } + } + return TRUE; +} + +static BOOL +PerformBaseRelocation(PMEMORYMODULE module, ptrdiff_t delta) +{ + unsigned char *codeBase = module->codeBase; + PIMAGE_BASE_RELOCATION relocation; + + PIMAGE_DATA_DIRECTORY directory = GET_HEADER_DICTIONARY(module, IMAGE_DIRECTORY_ENTRY_BASERELOC); + if (directory->Size == 0) { + return (delta == 0); + } + + relocation = (PIMAGE_BASE_RELOCATION) (codeBase + directory->VirtualAddress); + for (; relocation->VirtualAddress > 0; ) { + DWORD i; + unsigned char *dest = codeBase + relocation->VirtualAddress; + unsigned short *relInfo = (unsigned short*) OffsetPointer(relocation, IMAGE_SIZEOF_BASE_RELOCATION); + for (i=0; i<((relocation->SizeOfBlock-IMAGE_SIZEOF_BASE_RELOCATION) / 2); i++, relInfo++) { + // the upper 4 bits define the type of relocation + int type = *relInfo >> 12; + // the lower 12 bits define the offset + int offset = *relInfo & 0xfff; + + switch (type) + { + case IMAGE_REL_BASED_ABSOLUTE: + // skip relocation + break; + + case IMAGE_REL_BASED_HIGHLOW: + // change complete 32 bit address + { + DWORD *patchAddrHL = (DWORD *) (dest + offset); + *patchAddrHL += (DWORD) delta; + } + break; + +#ifdef _WIN64 + case IMAGE_REL_BASED_DIR64: + { + ULONGLONG *patchAddr64 = (ULONGLONG *) (dest + offset); + *patchAddr64 += (ULONGLONG) delta; + } + break; +#endif + + default: + //printf("Unknown relocation: %d\n", type); + break; + } + } + + // advance to next relocation block + relocation = (PIMAGE_BASE_RELOCATION) OffsetPointer(relocation, relocation->SizeOfBlock); + } + return TRUE; +} + +static BOOL +BuildImportTable(PMEMORYMODULE module) +{ + unsigned char *codeBase = module->codeBase; + PIMAGE_IMPORT_DESCRIPTOR importDesc; + BOOL result = TRUE; + + PIMAGE_DATA_DIRECTORY directory = GET_HEADER_DICTIONARY(module, IMAGE_DIRECTORY_ENTRY_IMPORT); + if (directory->Size == 0) { + return TRUE; + } + + importDesc = (PIMAGE_IMPORT_DESCRIPTOR) (codeBase + directory->VirtualAddress); + for (; !IsBadReadPtr(importDesc, sizeof(IMAGE_IMPORT_DESCRIPTOR)) && importDesc->Name; importDesc++) { + uintptr_t *thunkRef; + FARPROC *funcRef; + HCUSTOMMODULE *tmp; + HCUSTOMMODULE handle = module->loadLibrary((LPCSTR) (codeBase + importDesc->Name), module->userdata); + if (handle == NULL) { + SetLastError(ERROR_MOD_NOT_FOUND); + result = FALSE; + break; + } + + tmp = (HCUSTOMMODULE *) realloc(module->modules, (module->numModules+1)*(sizeof(HCUSTOMMODULE))); + if (tmp == NULL) { + module->freeLibrary(handle, module->userdata); + SetLastError(ERROR_OUTOFMEMORY); + result = FALSE; + break; + } + module->modules = tmp; + + module->modules[module->numModules++] = handle; + if (importDesc->OriginalFirstThunk) { + thunkRef = (uintptr_t *) (codeBase + importDesc->OriginalFirstThunk); + funcRef = (FARPROC *) (codeBase + importDesc->FirstThunk); + } else { + // no hint table + thunkRef = (uintptr_t *) (codeBase + importDesc->FirstThunk); + funcRef = (FARPROC *) (codeBase + importDesc->FirstThunk); + } + for (; *thunkRef; thunkRef++, funcRef++) { + if (IMAGE_SNAP_BY_ORDINAL(*thunkRef)) { + *funcRef = module->getProcAddress(handle, (LPCSTR)IMAGE_ORDINAL(*thunkRef), module->userdata); + } else { + PIMAGE_IMPORT_BY_NAME thunkData = (PIMAGE_IMPORT_BY_NAME) (codeBase + (*thunkRef)); + *funcRef = module->getProcAddress(handle, (LPCSTR)&thunkData->Name, module->userdata); + } + if (*funcRef == 0) { + result = FALSE; + break; + } + } + + if (!result) { + module->freeLibrary(handle, module->userdata); + SetLastError(ERROR_PROC_NOT_FOUND); + break; + } + } + + return result; +} + +LPVOID MemoryDefaultAlloc(LPVOID address, SIZE_T size, DWORD allocationType, DWORD protect, void* userdata) +{ + UNREFERENCED_PARAMETER(userdata); + return VirtualAlloc(address, size, allocationType, protect); +} + +BOOL MemoryDefaultFree(LPVOID lpAddress, SIZE_T dwSize, DWORD dwFreeType, void* userdata) +{ + UNREFERENCED_PARAMETER(userdata); + return VirtualFree(lpAddress, dwSize, dwFreeType); +} + +HCUSTOMMODULE MemoryDefaultLoadLibrary(LPCSTR filename, void *userdata) +{ + HMODULE result; + UNREFERENCED_PARAMETER(userdata); + result = LoadLibraryA(filename); + if (result == NULL) { + return NULL; + } + + return (HCUSTOMMODULE) result; +} + +FARPROC MemoryDefaultGetProcAddress(HCUSTOMMODULE module, LPCSTR name, void *userdata) +{ + UNREFERENCED_PARAMETER(userdata); + return (FARPROC) GetProcAddress((HMODULE) module, name); +} + +void MemoryDefaultFreeLibrary(HCUSTOMMODULE module, void *userdata) +{ + UNREFERENCED_PARAMETER(userdata); + FreeLibrary((HMODULE) module); +} + +HMEMORYMODULE MemoryLoadLibrary(const void *data, size_t size) +{ + return MemoryLoadLibraryEx(data, size, MemoryDefaultAlloc, MemoryDefaultFree, MemoryDefaultLoadLibrary, MemoryDefaultGetProcAddress, MemoryDefaultFreeLibrary, NULL); +} + +HMEMORYMODULE MemoryLoadLibraryEx(const void *data, size_t size, + CustomAllocFunc allocMemory, + CustomFreeFunc freeMemory, + CustomLoadLibraryFunc loadLibrary, + CustomGetProcAddressFunc getProcAddress, + CustomFreeLibraryFunc freeLibrary, + void *userdata) +{ + PMEMORYMODULE result = NULL; + PIMAGE_DOS_HEADER dos_header; + PIMAGE_NT_HEADERS old_header; + unsigned char *code, *headers; + ptrdiff_t locationDelta; + SYSTEM_INFO sysInfo; + PIMAGE_SECTION_HEADER section; + DWORD i; + size_t optionalSectionSize; + size_t lastSectionEnd = 0; + size_t alignedImageSize; +#ifdef _WIN64 + POINTER_LIST *blockedMemory = NULL; +#endif + + if (!CheckSize(size, sizeof(IMAGE_DOS_HEADER))) { + return NULL; + } + dos_header = (PIMAGE_DOS_HEADER)data; + if (dos_header->e_magic != IMAGE_DOS_SIGNATURE) { + SetLastError(ERROR_BAD_EXE_FORMAT); + return NULL; + } + + if (!CheckSize(size, dos_header->e_lfanew + sizeof(IMAGE_NT_HEADERS))) { + return NULL; + } + old_header = (PIMAGE_NT_HEADERS)&((const unsigned char *)(data))[dos_header->e_lfanew]; + if (old_header->Signature != IMAGE_NT_SIGNATURE) { + SetLastError(ERROR_BAD_EXE_FORMAT); + return NULL; + } + + if (old_header->FileHeader.Machine != HOST_MACHINE) { + SetLastError(ERROR_BAD_EXE_FORMAT); + return NULL; + } + + if (old_header->OptionalHeader.SectionAlignment & 1) { + // Only support section alignments that are a multiple of 2 + SetLastError(ERROR_BAD_EXE_FORMAT); + return NULL; + } + + section = IMAGE_FIRST_SECTION(old_header); + optionalSectionSize = old_header->OptionalHeader.SectionAlignment; + for (i=0; iFileHeader.NumberOfSections; i++, section++) { + size_t endOfSection; + if (section->SizeOfRawData == 0) { + // Section without data in the DLL + endOfSection = section->VirtualAddress + optionalSectionSize; + } else { + endOfSection = section->VirtualAddress + section->SizeOfRawData; + } + + if (endOfSection > lastSectionEnd) { + lastSectionEnd = endOfSection; + } + } + + GetNativeSystemInfo(&sysInfo); + alignedImageSize = AlignValueUp(old_header->OptionalHeader.SizeOfImage, sysInfo.dwPageSize); + if (alignedImageSize != AlignValueUp(lastSectionEnd, sysInfo.dwPageSize)) { + SetLastError(ERROR_BAD_EXE_FORMAT); + return NULL; + } + + // reserve memory for image of library + // XXX: is it correct to commit the complete memory region at once? + // calling DllEntry raises an exception if we don't... + code = (unsigned char *)allocMemory((LPVOID)(old_header->OptionalHeader.ImageBase), + alignedImageSize, + MEM_RESERVE | MEM_COMMIT, + PAGE_READWRITE, + userdata); + + if (code == NULL) { + // try to allocate memory at arbitrary position + code = (unsigned char *)allocMemory(NULL, + alignedImageSize, + MEM_RESERVE | MEM_COMMIT, + PAGE_READWRITE, + userdata); + if (code == NULL) { + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + } + +#ifdef _WIN64 + // Memory block may not span 4 GB boundaries. + while ((((uintptr_t) code) >> 32) < (((uintptr_t) (code + alignedImageSize)) >> 32)) { + POINTER_LIST *node = (POINTER_LIST*) malloc(sizeof(POINTER_LIST)); + if (!node) { + freeMemory(code, 0, MEM_RELEASE, userdata); + FreePointerList(blockedMemory, freeMemory, userdata); + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + + node->next = blockedMemory; + node->address = code; + blockedMemory = node; + + code = (unsigned char *)allocMemory(NULL, + alignedImageSize, + MEM_RESERVE | MEM_COMMIT, + PAGE_READWRITE, + userdata); + if (code == NULL) { + FreePointerList(blockedMemory, freeMemory, userdata); + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + } +#endif + + result = (PMEMORYMODULE)HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(MEMORYMODULE)); + if (result == NULL) { + freeMemory(code, 0, MEM_RELEASE, userdata); +#ifdef _WIN64 + FreePointerList(blockedMemory, freeMemory, userdata); +#endif + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + + result->codeBase = code; + result->isDLL = (old_header->FileHeader.Characteristics & IMAGE_FILE_DLL) != 0; + result->alloc = allocMemory; + result->free = freeMemory; + result->loadLibrary = loadLibrary; + result->getProcAddress = getProcAddress; + result->freeLibrary = freeLibrary; + result->userdata = userdata; + result->pageSize = sysInfo.dwPageSize; +#ifdef _WIN64 + result->blockedMemory = blockedMemory; +#endif + + if (!CheckSize(size, old_header->OptionalHeader.SizeOfHeaders)) { + goto error; + } + + // commit memory for headers + headers = (unsigned char *)allocMemory(code, + old_header->OptionalHeader.SizeOfHeaders, + MEM_COMMIT, + PAGE_READWRITE, + userdata); + + // copy PE header to code + memcpy(headers, dos_header, old_header->OptionalHeader.SizeOfHeaders); + result->headers = (PIMAGE_NT_HEADERS)&((const unsigned char *)(headers))[dos_header->e_lfanew]; + + // update position + result->headers->OptionalHeader.ImageBase = (uintptr_t)code; + + // copy sections from DLL file block to new memory location + if (!CopySections((const unsigned char *) data, size, old_header, result)) { + goto error; + } + + // adjust base address of imported data + locationDelta = (ptrdiff_t)(result->headers->OptionalHeader.ImageBase - old_header->OptionalHeader.ImageBase); + if (locationDelta != 0) { + result->isRelocated = PerformBaseRelocation(result, locationDelta); + } else { + result->isRelocated = TRUE; + } + + // load required dlls and adjust function table of imports + if (!BuildImportTable(result)) { + goto error; + } + + // mark memory pages depending on section headers and release + // sections that are marked as "discardable" + if (!FinalizeSections(result)) { + goto error; + } + + // TLS callbacks are executed BEFORE the main loading + if (!ExecuteTLS(result)) { + goto error; + } + + // get entry point of loaded library + if (result->headers->OptionalHeader.AddressOfEntryPoint != 0) { + if (result->isDLL) { + DllEntryProc DllEntry = (DllEntryProc)(LPVOID)(code + result->headers->OptionalHeader.AddressOfEntryPoint); + // notify library about attaching to process + BOOL successfull = (*DllEntry)((HINSTANCE)code, DLL_PROCESS_ATTACH, 0); + if (!successfull) { + // RACKET: try again with NULL as the instanec handle. That allows + // libiconv to work, since it passes the handle to GetModuleName + successfull = (*DllEntry)((HINSTANCE)NULL, DLL_PROCESS_ATTACH, 0); + if (!successfull) { + SetLastError(ERROR_DLL_INIT_FAILED); + goto error; + } + } + result->initialized = TRUE; + } else { + result->exeEntry = (ExeEntryProc)(LPVOID)(code + result->headers->OptionalHeader.AddressOfEntryPoint); + } + } else { + result->exeEntry = NULL; + } + + return (HMEMORYMODULE)result; + +error: + // cleanup + MemoryFreeLibrary(result); + return NULL; +} + +static int _compare(const void *a, const void *b) +{ + const struct ExportNameEntry *p1 = (const struct ExportNameEntry*) a; + const struct ExportNameEntry *p2 = (const struct ExportNameEntry*) b; + return strcmp(p1->name, p2->name); +} + +static int _find(const void *a, const void *b) +{ + LPCSTR *name = (LPCSTR *) a; + const struct ExportNameEntry *p = (const struct ExportNameEntry*) b; + return strcmp(*name, p->name); +} + +FARPROC MemoryGetProcAddress(HMEMORYMODULE mod, LPCSTR name) +{ + PMEMORYMODULE module = (PMEMORYMODULE)mod; + unsigned char *codeBase = module->codeBase; + DWORD idx = 0; + PIMAGE_EXPORT_DIRECTORY exports; + PIMAGE_DATA_DIRECTORY directory = GET_HEADER_DICTIONARY(module, IMAGE_DIRECTORY_ENTRY_EXPORT); + if (directory->Size == 0) { + // no export table found + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } + + exports = (PIMAGE_EXPORT_DIRECTORY) (codeBase + directory->VirtualAddress); + if (exports->NumberOfNames == 0 || exports->NumberOfFunctions == 0) { + // DLL doesn't export anything + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } + + if (HIWORD(name) == 0) { + // load function by ordinal value + if (LOWORD(name) < exports->Base) { + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } + + idx = LOWORD(name) - exports->Base; + } else if (!exports->NumberOfNames) { + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } else { + const struct ExportNameEntry *found; + + // Lazily build name table and sort it by names + if (!module->nameExportsTable) { + DWORD i; + DWORD *nameRef = (DWORD *) (codeBase + exports->AddressOfNames); + WORD *ordinal = (WORD *) (codeBase + exports->AddressOfNameOrdinals); + struct ExportNameEntry *entry = (struct ExportNameEntry*) malloc(exports->NumberOfNames * sizeof(struct ExportNameEntry)); + module->nameExportsTable = entry; + if (!entry) { + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + for (i=0; iNumberOfNames; i++, nameRef++, ordinal++, entry++) { + entry->name = (const char *) (codeBase + (*nameRef)); + entry->idx = *ordinal; + } + qsort(module->nameExportsTable, + exports->NumberOfNames, + sizeof(struct ExportNameEntry), _compare); + } + + // search function name in list of exported names with binary search + found = (const struct ExportNameEntry*) bsearch(&name, + module->nameExportsTable, + exports->NumberOfNames, + sizeof(struct ExportNameEntry), _find); + if (!found) { + // exported symbol not found + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } + + idx = found->idx; + } + + if (idx > exports->NumberOfFunctions) { + // name <-> ordinal number don't match + SetLastError(ERROR_PROC_NOT_FOUND); + return NULL; + } + + // AddressOfFunctions contains the RVAs to the "real" functions + return (FARPROC)(LPVOID)(codeBase + (*(DWORD *) (codeBase + exports->AddressOfFunctions + (idx*4)))); +} + +void MemoryFreeLibrary(HMEMORYMODULE mod) +{ + PMEMORYMODULE module = (PMEMORYMODULE)mod; + + if (module == NULL) { + return; + } + if (module->initialized) { + // notify library about detaching from process + DllEntryProc DllEntry = (DllEntryProc)(LPVOID)(module->codeBase + module->headers->OptionalHeader.AddressOfEntryPoint); + (*DllEntry)((HINSTANCE)module->codeBase, DLL_PROCESS_DETACH, 0); + } + + free(module->nameExportsTable); + if (module->modules != NULL) { + // free previously opened libraries + int i; + for (i=0; inumModules; i++) { + if (module->modules[i] != NULL) { + module->freeLibrary(module->modules[i], module->userdata); + } + } + + free(module->modules); + } + + if (module->codeBase != NULL) { + // release memory of library + module->free(module->codeBase, 0, MEM_RELEASE, module->userdata); + } + +#ifdef _WIN64 + FreePointerList(module->blockedMemory, module->free, module->userdata); +#endif + HeapFree(GetProcessHeap(), 0, module); +} + +int MemoryCallEntryPoint(HMEMORYMODULE mod) +{ + PMEMORYMODULE module = (PMEMORYMODULE)mod; + + if (module == NULL || module->isDLL || module->exeEntry == NULL || !module->isRelocated) { + return -1; + } + + return module->exeEntry(); +} + +#define DEFAULT_LANGUAGE MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL) + +HMEMORYRSRC MemoryFindResource(HMEMORYMODULE module, LPCTSTR name, LPCTSTR type) +{ + return MemoryFindResourceEx(module, name, type, DEFAULT_LANGUAGE); +} + +static PIMAGE_RESOURCE_DIRECTORY_ENTRY _MemorySearchResourceEntry( + void *root, + PIMAGE_RESOURCE_DIRECTORY resources, + LPCTSTR key) +{ + PIMAGE_RESOURCE_DIRECTORY_ENTRY entries = (PIMAGE_RESOURCE_DIRECTORY_ENTRY) (resources + 1); + PIMAGE_RESOURCE_DIRECTORY_ENTRY result = NULL; + DWORD start; + DWORD end; + DWORD middle; + + if (!IS_INTRESOURCE(key) && key[0] == TEXT('#')) { + // special case: resource id given as string + TCHAR *endpos = NULL; + long int tmpkey = (WORD) _tcstol((TCHAR *) &key[1], &endpos, 10); + if (tmpkey <= 0xffff && lstrlen(endpos) == 0) { + key = MAKEINTRESOURCE(tmpkey); + } + } + + // entries are stored as ordered list of named entries, + // followed by an ordered list of id entries - we can do + // a binary search to find faster... + if (IS_INTRESOURCE(key)) { + WORD check = (WORD) (uintptr_t) key; + start = resources->NumberOfNamedEntries; + end = start + resources->NumberOfIdEntries; + + while (end > start) { + WORD entryName; + middle = (start + end) >> 1; + entryName = (WORD) entries[middle].Name; + if (check < entryName) { + end = (end != middle ? middle : middle-1); + } else if (check > entryName) { + start = (start != middle ? middle : middle+1); + } else { + result = &entries[middle]; + break; + } + } + } else { + LPCWSTR searchKey; + size_t searchKeyLen = _tcslen(key); +#if defined(UNICODE) + searchKey = key; +#else + // Resource names are always stored using 16bit characters, need to + // convert string we search for. +#define MAX_LOCAL_KEY_LENGTH 2048 + // In most cases resource names are short, so optimize for that by + // using a pre-allocated array. + wchar_t _searchKeySpace[MAX_LOCAL_KEY_LENGTH+1]; + LPWSTR _searchKey; + if (searchKeyLen > MAX_LOCAL_KEY_LENGTH) { + size_t _searchKeySize = (searchKeyLen + 1) * sizeof(wchar_t); + _searchKey = (LPWSTR) malloc(_searchKeySize); + if (_searchKey == NULL) { + SetLastError(ERROR_OUTOFMEMORY); + return NULL; + } + } else { + _searchKey = &_searchKeySpace[0]; + } + + mbstowcs(_searchKey, key, searchKeyLen); + _searchKey[searchKeyLen] = 0; + searchKey = _searchKey; +#endif + start = 0; + end = resources->NumberOfNamedEntries; + while (end > start) { + int cmp; + PIMAGE_RESOURCE_DIR_STRING_U resourceString; + middle = (start + end) >> 1; + resourceString = (PIMAGE_RESOURCE_DIR_STRING_U) OffsetPointer(root, entries[middle].Name & 0x7FFFFFFF); + cmp = _wcsnicmp(searchKey, resourceString->NameString, resourceString->Length); + if (cmp == 0) { + // Handle partial match + if (searchKeyLen > resourceString->Length) { + cmp = 1; + } else if (searchKeyLen < resourceString->Length) { + cmp = -1; + } + } + if (cmp < 0) { + end = (middle != end ? middle : middle-1); + } else if (cmp > 0) { + start = (middle != start ? middle : middle+1); + } else { + result = &entries[middle]; + break; + } + } +#if !defined(UNICODE) + if (searchKeyLen > MAX_LOCAL_KEY_LENGTH) { + free(_searchKey); + } +#undef MAX_LOCAL_KEY_LENGTH +#endif + } + + return result; +} + +HMEMORYRSRC MemoryFindResourceEx(HMEMORYMODULE module, LPCTSTR name, LPCTSTR type, WORD language) +{ + unsigned char *codeBase = ((PMEMORYMODULE) module)->codeBase; + PIMAGE_DATA_DIRECTORY directory = GET_HEADER_DICTIONARY((PMEMORYMODULE) module, IMAGE_DIRECTORY_ENTRY_RESOURCE); + PIMAGE_RESOURCE_DIRECTORY rootResources; + PIMAGE_RESOURCE_DIRECTORY nameResources; + PIMAGE_RESOURCE_DIRECTORY typeResources; + PIMAGE_RESOURCE_DIRECTORY_ENTRY foundType; + PIMAGE_RESOURCE_DIRECTORY_ENTRY foundName; + PIMAGE_RESOURCE_DIRECTORY_ENTRY foundLanguage; + if (directory->Size == 0) { + // no resource table found + SetLastError(ERROR_RESOURCE_DATA_NOT_FOUND); + return NULL; + } + + if (language == DEFAULT_LANGUAGE) { + // use language from current thread + language = LANGIDFROMLCID(GetThreadLocale()); + } + + // resources are stored as three-level tree + // - first node is the type + // - second node is the name + // - third node is the language + rootResources = (PIMAGE_RESOURCE_DIRECTORY) (codeBase + directory->VirtualAddress); + foundType = _MemorySearchResourceEntry(rootResources, rootResources, type); + if (foundType == NULL) { + SetLastError(ERROR_RESOURCE_TYPE_NOT_FOUND); + return NULL; + } + + typeResources = (PIMAGE_RESOURCE_DIRECTORY) (codeBase + directory->VirtualAddress + (foundType->OffsetToData & 0x7fffffff)); + foundName = _MemorySearchResourceEntry(rootResources, typeResources, name); + if (foundName == NULL) { + SetLastError(ERROR_RESOURCE_NAME_NOT_FOUND); + return NULL; + } + + nameResources = (PIMAGE_RESOURCE_DIRECTORY) (codeBase + directory->VirtualAddress + (foundName->OffsetToData & 0x7fffffff)); + foundLanguage = _MemorySearchResourceEntry(rootResources, nameResources, (LPCTSTR) (uintptr_t) language); + if (foundLanguage == NULL) { + // requested language not found, use first available + if (nameResources->NumberOfIdEntries == 0) { + SetLastError(ERROR_RESOURCE_LANG_NOT_FOUND); + return NULL; + } + + foundLanguage = (PIMAGE_RESOURCE_DIRECTORY_ENTRY) (nameResources + 1); + } + + return (codeBase + directory->VirtualAddress + (foundLanguage->OffsetToData & 0x7fffffff)); +} + +DWORD MemorySizeofResource(HMEMORYMODULE module, HMEMORYRSRC resource) +{ + PIMAGE_RESOURCE_DATA_ENTRY entry; + UNREFERENCED_PARAMETER(module); + entry = (PIMAGE_RESOURCE_DATA_ENTRY) resource; + if (entry == NULL) { + return 0; + } + + return entry->Size; +} + +LPVOID MemoryLoadResource(HMEMORYMODULE module, HMEMORYRSRC resource) +{ + unsigned char *codeBase = ((PMEMORYMODULE) module)->codeBase; + PIMAGE_RESOURCE_DATA_ENTRY entry = (PIMAGE_RESOURCE_DATA_ENTRY) resource; + if (entry == NULL) { + return NULL; + } + + return codeBase + entry->OffsetToData; +} + +int +MemoryLoadString(HMEMORYMODULE module, UINT id, LPTSTR buffer, int maxsize) +{ + return MemoryLoadStringEx(module, id, buffer, maxsize, DEFAULT_LANGUAGE); +} + +int +MemoryLoadStringEx(HMEMORYMODULE module, UINT id, LPTSTR buffer, int maxsize, WORD language) +{ + HMEMORYRSRC resource; + PIMAGE_RESOURCE_DIR_STRING_U data; + DWORD size; + if (maxsize == 0) { + return 0; + } + + resource = MemoryFindResourceEx(module, MAKEINTRESOURCE((id >> 4) + 1), RT_STRING, language); + if (resource == NULL) { + buffer[0] = 0; + return 0; + } + + data = (PIMAGE_RESOURCE_DIR_STRING_U) MemoryLoadResource(module, resource); + id = id & 0x0f; + while (id--) { + data = (PIMAGE_RESOURCE_DIR_STRING_U) OffsetPointer(data, (data->Length + 1) * sizeof(WCHAR)); + } + if (data->Length == 0) { + SetLastError(ERROR_RESOURCE_NAME_NOT_FOUND); + buffer[0] = 0; + return 0; + } + + size = data->Length; + if (size >= (DWORD) maxsize) { + size = maxsize; + } else { + buffer[size] = 0; + } +#if defined(UNICODE) + wcsncpy(buffer, data->NameString, size); +#else + wcstombs(buffer, data->NameString, size); +#endif + return size; +} + +#ifdef TESTSUITE +#include + +#ifndef PRIxPTR +#ifdef _WIN64 +#define PRIxPTR "I64x" +#else +#define PRIxPTR "x" +#endif +#endif + +static const uintptr_t AlignValueDownTests[][3] = { + {16, 16, 16}, + {17, 16, 16}, + {32, 16, 32}, + {33, 16, 32}, +#ifdef _WIN64 + {0x12345678abcd1000, 0x1000, 0x12345678abcd1000}, + {0x12345678abcd101f, 0x1000, 0x12345678abcd1000}, +#endif + {0, 0, 0}, +}; + +static const uintptr_t AlignValueUpTests[][3] = { + {16, 16, 16}, + {17, 16, 32}, + {32, 16, 32}, + {33, 16, 48}, +#ifdef _WIN64 + {0x12345678abcd1000, 0x1000, 0x12345678abcd1000}, + {0x12345678abcd101f, 0x1000, 0x12345678abcd2000}, +#endif + {0, 0, 0}, +}; + +BOOL MemoryModuleTestsuite() { + BOOL success = TRUE; + size_t idx; + for (idx = 0; AlignValueDownTests[idx][0]; ++idx) { + const uintptr_t* tests = AlignValueDownTests[idx]; + uintptr_t value = AlignValueDown(tests[0], tests[1]); + if (value != tests[2]) { + printf("AlignValueDown failed for 0x%" PRIxPTR "/0x%" PRIxPTR ": expected 0x%" PRIxPTR ", got 0x%" PRIxPTR "\n", + tests[0], tests[1], tests[2], value); + success = FALSE; + } + } + for (idx = 0; AlignValueDownTests[idx][0]; ++idx) { + const uintptr_t* tests = AlignValueUpTests[idx]; + uintptr_t value = AlignValueUp(tests[0], tests[1]); + if (value != tests[2]) { + printf("AlignValueUp failed for 0x%" PRIxPTR "/0x%" PRIxPTR ": expected 0x%" PRIxPTR ", got 0x%" PRIxPTR "\n", + tests[0], tests[1], tests[2], value); + success = FALSE; + } + } + if (success) { + printf("OK\n"); + } + return success; +} +#endif diff -Nru racket-6.12+ppa1/src/start/MemoryModule.h racket-7.0+ppa1/src/start/MemoryModule.h --- racket-6.12+ppa1/src/start/MemoryModule.h 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/MemoryModule.h 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,168 @@ +/* + * Memory DLL loading code + * Version 0.0.4 + * + * Copyright (c) 2004-2015 by Joachim Bauch / mail@joachim-bauch.de + * http://www.joachim-bauch.de + * + * The contents of this file are subject to the Mozilla Public License Version + * 2.0 (the "License"); you may not use this file except in compliance with + * the License. You may obtain a copy of the License at + * http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is MemoryModule.h + * + * The Initial Developer of the Original Code is Joachim Bauch. + * + * Portions created by Joachim Bauch are Copyright (C) 2004-2015 + * Joachim Bauch. All Rights Reserved. + * + */ + +#ifndef __MEMORY_MODULE_HEADER +#define __MEMORY_MODULE_HEADER + +#include + +typedef void *HMEMORYMODULE; + +typedef void *HMEMORYRSRC; + +typedef void *HCUSTOMMODULE; + +#ifdef __cplusplus +extern "C" { +#endif + +typedef LPVOID (*CustomAllocFunc)(LPVOID, SIZE_T, DWORD, DWORD, void*); +typedef BOOL (*CustomFreeFunc)(LPVOID, SIZE_T, DWORD, void*); +typedef HCUSTOMMODULE (*CustomLoadLibraryFunc)(LPCSTR, void *); +typedef FARPROC (*CustomGetProcAddressFunc)(HCUSTOMMODULE, LPCSTR, void *); +typedef void (*CustomFreeLibraryFunc)(HCUSTOMMODULE, void *); + +/** + * Load EXE/DLL from memory location with the given size. + * + * All dependencies are resolved using default LoadLibrary/GetProcAddress + * calls through the Windows API. + */ +HMEMORYMODULE MemoryLoadLibrary(const void *, size_t); + +/** + * Load EXE/DLL from memory location with the given size using custom dependency + * resolvers. + * + * Dependencies will be resolved using passed callback methods. + */ +HMEMORYMODULE MemoryLoadLibraryEx(const void *, size_t, + CustomAllocFunc, + CustomFreeFunc, + CustomLoadLibraryFunc, + CustomGetProcAddressFunc, + CustomFreeLibraryFunc, + void *); + +/** + * Get address of exported method. Supports loading both by name and by + * ordinal value. + */ +FARPROC MemoryGetProcAddress(HMEMORYMODULE, LPCSTR); + +/** + * Free previously loaded EXE/DLL. + */ +void MemoryFreeLibrary(HMEMORYMODULE); + +/** + * Execute entry point (EXE only). The entry point can only be executed + * if the EXE has been loaded to the correct base address or it could + * be relocated (i.e. relocation information have not been stripped by + * the linker). + * + * Important: calling this function will not return, i.e. once the loaded + * EXE finished running, the process will terminate. + * + * Returns a negative value if the entry point could not be executed. + */ +int MemoryCallEntryPoint(HMEMORYMODULE); + +/** + * Find the location of a resource with the specified type and name. + */ +HMEMORYRSRC MemoryFindResource(HMEMORYMODULE, LPCTSTR, LPCTSTR); + +/** + * Find the location of a resource with the specified type, name and language. + */ +HMEMORYRSRC MemoryFindResourceEx(HMEMORYMODULE, LPCTSTR, LPCTSTR, WORD); + +/** + * Get the size of the resource in bytes. + */ +DWORD MemorySizeofResource(HMEMORYMODULE, HMEMORYRSRC); + +/** + * Get a pointer to the contents of the resource. + */ +LPVOID MemoryLoadResource(HMEMORYMODULE, HMEMORYRSRC); + +/** + * Load a string resource. + */ +int MemoryLoadString(HMEMORYMODULE, UINT, LPTSTR, int); + +/** + * Load a string resource with a given language. + */ +int MemoryLoadStringEx(HMEMORYMODULE, UINT, LPTSTR, int, WORD); + +/** +* Default implementation of CustomAllocFunc that calls VirtualAlloc +* internally to allocate memory for a library +* +* This is the default as used by MemoryLoadLibrary. +*/ +LPVOID MemoryDefaultAlloc(LPVOID, SIZE_T, DWORD, DWORD, void *); + +/** +* Default implementation of CustomFreeFunc that calls VirtualFree +* internally to free the memory used by a library +* +* This is the default as used by MemoryLoadLibrary. +*/ +BOOL MemoryDefaultFree(LPVOID, SIZE_T, DWORD, void *); + +/** + * Default implementation of CustomLoadLibraryFunc that calls LoadLibraryA + * internally to load an additional libary. + * + * This is the default as used by MemoryLoadLibrary. + */ +HCUSTOMMODULE MemoryDefaultLoadLibrary(LPCSTR, void *); + +/** + * Default implementation of CustomGetProcAddressFunc that calls GetProcAddress + * internally to get the address of an exported function. + * + * This is the default as used by MemoryLoadLibrary. + */ +FARPROC MemoryDefaultGetProcAddress(HCUSTOMMODULE, LPCSTR, void *); + +/** + * Default implementation of CustomFreeLibraryFunc that calls FreeLibrary + * internally to release an additional libary. + * + * This is the default as used by MemoryLoadLibrary. + */ +void MemoryDefaultFreeLibrary(HCUSTOMMODULE, void *); + +#ifdef __cplusplus +} +#endif + +#endif // __MEMORY_MODULE_HEADER diff -Nru racket-6.12+ppa1/src/start/README.txt racket-7.0+ppa1/src/start/README.txt --- racket-6.12+ppa1/src/start/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +This directory constaint source programs and fragments for wrapper +executables used to start/embed Racket. The programs and fragments are +used both for the traditional Racket virtual machine and Racket on +Chez Scheme. diff -Nru racket-6.12+ppa1/src/start/start.c racket-7.0+ppa1/src/start/start.c --- racket-6.12+ppa1/src/start/start.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/start.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,403 @@ +/* Launcher program for Windows. */ +/* Builds a Racket starter if MZSTART is defined. */ +/* Builds a GRacket starter if MRSTART is defined. */ +/* If neither is defined, MZSTART is auto-defined. */ + +#include +#include +#include +#include +#include +#include +#include + +#ifndef MRSTART +# ifndef MZSTART +# define MZSTART +# endif +#endif + +#ifdef MRSTART +# define GOSUBDIR L"\\" +# define GOEXE L"gracket" +# define sGOEXE "gracket" +# define WAITTILDONE 0 +#endif + +#ifdef MZSTART +# define GOSUBDIR L"\\" +# define GOEXE L"racket" +# define sGOEXE "racket" +# define WAITTILDONE 1 +#endif + +#define MAXCOMMANDLEN 1024 +#define MAX_ARGS 100 + +#if defined(_MSC_VER) || defined(__MINGW32__) +# define MSC_IZE(x) _ ## x +#else +# define MSC_IZE(x) x +#endif +#define DUPLICATE_INPUT + +/* Win command lines limited to 1024 chars, so 1024 chars for + command tail is ample */ + +static wchar_t *input = + L""; + +/* Win long filenames limited to 255 chars, so 254 chars for + directory is ample */ + +static wchar_t *exedir = L""; + +static wchar_t *variant = L""; + +static int wc_strlen(const wchar_t *ws) +{ + int l; + for (l = 0; ws[l]; l++) { } + return l; +} + +static void wc_strcpy(wchar_t *dest, const wchar_t *src) +{ + while (*src) { + *dest = *src; + dest++; + src++; + } + *dest = 0; +} + +static void wc_strcat(wchar_t *dest, const wchar_t *src) +{ + while (*dest) + dest++; + wc_strcpy(dest, src); +} + +static wchar_t *protect(wchar_t *s) +{ + wchar_t *naya; + int has_space = 0, has_quote = 0, was_slash = 0; + + for (naya = s; *naya; naya++) { + if (((*naya < 128) && isspace(*naya)) || (*naya == '\'')) { + has_space = 1; + was_slash = 0; + } else if (*naya == '"') { + has_quote += 1 + (2 * was_slash); + was_slash = 0; + } else if (*naya == '\\') { + was_slash++; + } else + was_slash = 0; + } + + if (has_space || has_quote) { + wchar_t *p; + int wrote_slash = 0; + + naya = (wchar_t *)malloc((wc_strlen(s) + 3 + 3*has_quote) * sizeof(wchar_t)); + naya[0] = '"'; + for (p = naya + 1; *s; s++) { + if (*s == '"') { + while (wrote_slash--) + *(p++) = '\\'; + *(p++) = '"'; /* endquote */ + *(p++) = '\\'; + *(p++) = '"'; /* protected */ + *(p++) = '"'; /* start quote again */ + wrote_slash = 0; + } else if (*s == '\\') { + *(p++) = '\\'; + wrote_slash++; + } else { + *(p++) = *s; + wrote_slash = 0; + } + } + *(p++) = '"'; + *p = 0; + + return naya; + } + + return s; +} + +static int parse_command_line(int count, wchar_t **command, + wchar_t *buf, int maxargs, int skip) + +{ + wchar_t *parse, *created, *write; + int findquote = 0; + + parse = created = write = buf; + while (*parse) { + while (*parse && (*parse < 128) && isspace(*parse)) parse++; + while (*parse && ((*parse > 128) || !isspace(*parse) || findquote)) { + if (*parse== '"') { + findquote = !findquote; + } else if (*parse== '\\') { + wchar_t *next; + for (next = parse; *next == '\\'; next++); + if (*next == '"') { + /* Special handling: */ + int count = (next - parse), i; + for (i = 1; i < count; i += 2) + *(write++) = '\\'; + parse += (count - 1); + if (count & 0x1) { + *(write++) = '\"'; + parse++; + } + } else + *(write++) = *parse; + } else + *(write++) = *parse; + parse++; + } + if (*parse) + parse++; + *(write++) = 0; + + if (*created) { + if (skip) { + skip--; + } else { + command[count++] = created; + if (count == maxargs) + return count; + } + } + created = write; + } + + return count; +} + +static wchar_t *make_command_line(int argc, wchar_t **argv) +{ + int i, len = 0; + wchar_t *r; + + for (i = 0; i < argc; i++) { + len += wc_strlen(argv[i]) + 1; + } + r = (wchar_t *)malloc(len * sizeof(wchar_t)); + len = 0; + for (i = 0; i < argc; i++) { + int l = wc_strlen(argv[i]); + if (len) r[len++] = ' '; + memcpy(r + len, argv[i], l * sizeof(wchar_t)); + len += l; + } + + r[len] = 0; + return r; +} + +#ifdef MZSTART +void WriteStr(HANDLE h, const char *s) { + DWORD done; + WriteFile(h, s, strlen(s), &done, NULL); +} +#endif + +#ifdef DUPLICATE_INPUT +static wchar_t *copy_string(wchar_t *s) +{ + int l = wc_strlen(s); + wchar_t *d = (wchar_t *)malloc((l + 1) * sizeof(wchar_t)); + memcpy(d, s, (l + 1) * sizeof(wchar_t)); + return d; +} +#endif + +#if defined(MRSTART) || defined(__MINGW32__) +# define USE_WINMAIN +#endif + +#ifdef USE_WINMAIN +int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, + LPSTR m_lpCmdLine, int nCmdShow) +#else +int wmain(int argc_in, wchar_t **argv_in) +#endif +{ + wchar_t go[MAXCOMMANDLEN * 2]; + wchar_t *args[MAX_ARGS + 1]; + wchar_t *command_line; + int count, i, cl_len; + struct MSC_IZE(stat) st; + STARTUPINFOW si; + PROCESS_INFORMATION pi; +#ifdef MZSTART + HANDLE out; + + out = GetStdHandle(STD_OUTPUT_HANDLE); +#endif + +#ifdef DUPLICATE_INPUT + /* gcc: input is read-only */ + input = copy_string(input); + exedir = copy_string(exedir); +#endif + + count = 1; + count = parse_command_line(count, args, input, MAX_ARGS, 0); + + /* exedir can be relative to the current executable */ + if ((exedir[0] == '\\') + || ((((exedir[0] >= 'a') && (exedir[0] <= 'z')) + || ((exedir[0] >= 'A') && (exedir[0] <= 'Z'))) + && (exedir[1] == ':'))) { + /* Absolute path */ + } else { + /* Make it absolute, relative to this executable */ + int plen; + int mlen; + wchar_t *s2, *path; + + path = (wchar_t *)malloc(1024 * sizeof(wchar_t)); + GetModuleFileNameW(NULL, path, 1024); + + plen = wc_strlen(exedir); + mlen = wc_strlen(path); + + while (mlen && (path[mlen - 1] != '\\')) { + mlen--; + } + s2 = (wchar_t *)malloc((mlen + plen + 1) * sizeof(wchar_t)); + memcpy(s2, path, mlen * sizeof(wchar_t)); + memcpy(s2 + mlen, exedir, (plen + 1) * sizeof(wchar_t)); + exedir = s2; + } + + wc_strcpy(go, exedir); + wc_strcat(go, GOSUBDIR); + wc_strcat(go, GOEXE); + wc_strcat(go, variant); + wc_strcat(go, L".exe"); + + if (_wstat(go, &st)) { +#ifdef USE_WINMAIN + wchar_t errbuff[MAXCOMMANDLEN * 2]; + swprintf(errbuff,sizeof(errbuff),L"Can't find %s",go); + MessageBoxW(NULL,errbuff,L"Error",MB_OK); +#else + char errbuff[MAXCOMMANDLEN * 2]; + sprintf(errbuff,"Can't find %S\n",go); + WriteStr(out,errbuff); +#endif + exit(-1); + } + + args[0] = go; + +#ifdef USE_WINMAIN + { + wchar_t *buf; + LPWSTR m_lpCmdLine; + + m_lpCmdLine = GetCommandLineW(); + + buf = (wchar_t *)malloc((wc_strlen(m_lpCmdLine) + 1) * sizeof(wchar_t)); + memcpy(buf, m_lpCmdLine, (wc_strlen(m_lpCmdLine) + 1) * sizeof(wchar_t)); + count = parse_command_line(count, args, buf, MAX_ARGS, 1); + } +#else + { + int i; + for (i = 1; i < argc_in; i++) + args[count++] = argv_in[i]; + } +#endif + + args[count] = NULL; + + for (i = 0; i < count; i++) { + args[i] = protect(args[i]); + /* MessageBox(NULL, args[i], "Argument", MB_OK); */ + } + + memset(&si, 0, sizeof(si)); + si.cb = sizeof(si); + + command_line = make_command_line(count, args); + + cl_len = wc_strlen(command_line); + if (cl_len > MAXCOMMANDLEN) { +#ifdef MRSTART + wchar_t errbuff[MAXCOMMANDLEN * 2]; + swprintf(errbuff,sizeof(errbuff),L"Command line of %d characters exceeds %d characters: %.1024s", + cl_len, MAXCOMMANDLEN,command_line); + MessageBoxW(NULL,errbuff,L"Error",MB_OK); +#else + char errbuff[MAXCOMMANDLEN * 2]; + sprintf(errbuff,"Command line of %d characters exceeds %d characters: %.1024S\n", + cl_len, MAXCOMMANDLEN,command_line); + WriteStr(out,errbuff); +#endif + exit(-1); + } + + if (!CreateProcessW(go, + command_line, + NULL, NULL, TRUE, + 0, NULL, NULL, &si, &pi)) { + +#ifdef MRSTART + MessageBoxW(NULL, L"Can't start " GOEXE, L"Error", MB_OK); +#else + WriteStr(out, "Can't start " sGOEXE "\n"); +#endif + return -1; + } else { +#if WAITTILDONE + DWORD result; + WaitForSingleObject(pi.hProcess, INFINITE); + GetExitCodeProcess(pi.hProcess, &result); + return result; +#else + return 0; +#endif + } +} diff -Nru racket-6.12+ppa1/src/start/ustart.c racket-7.0+ppa1/src/start/ustart.c --- racket-6.12+ppa1/src/start/ustart.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/start/ustart.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,576 @@ + +/* "Embedding" program for Unix/X11, to be used as + an alternative to embedding in the actual Racket + or GRacket binary. */ + +#include +#include +#include +#include +#include +#include +#include +#include + +/* The config string after : is replaced with ! followed by a sequence + of little-endian 4-byte ints: + start - offset into the binary + prog_end - offset; start to prog_end is the program region + decl_end - offset; prog_end to decl_end is the module-command region + end - offset; prog_end to end is the complete command region + count - number of cmdline args in command region + x11? - non-zero => launches GRacket for X + + In the command region, the format is a sequence of NUL-terminated strings: + exe_path - program to start (relative is w.r.t. executable) + dll_path - DLL directory if non-empty (relative is w.r.t. executable) + cmdline_arg ... + + For ELF binaries, the absolute values of `start', `decl_end', `prog_end', + and `end' are ignored if a ".rackcmdl" (starter) or ".rackprog" + (embedding) section is found. The `start' value is set to match the + section offset, and `decl_end', `prog_end', and `end' are correspondingly + adjusted. Using a seciton offset allows linking tools (such as + `strip') to move the data in the executable. +*/ +char *config = "cOnFiG:[***************************"; + +char *binary_type_hack = "bINARy tYPe:ezic"; + +/* This path list is used instead of the one in the Racket/GRacket + binary. That way, the same Racket/GRacket binary can be shared + among embedding exectuables that have different collection + paths. */ +char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ + "../collects" + "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _coldir_offset = 19; /* Skip permanent tag */ + +char * volatile _configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ + "../etc" + "\0" + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _configdir_offset = 17; /* Skip permanent tag */ + +typedef struct { + char *flag; + int arg_count; +} X_flag_entry; + +static X_flag_entry X_flags[] = { + { "-display", 1 }, + { "-geometry", 1 }, + { "-bg", 1 }, + { "-background", 1 }, + { "-fg", 1 }, + { "-foreground", 1 }, + { "-fn", 1 }, + { "-font", 1 }, + { "-iconic", 0 }, + { "-name", 1 }, + { "-rv", 0 }, + { "-reverse", 0 }, + { "+rv", 0 }, + { "-selectionTimeout", 1 }, + { "-synchronous", 0 }, + { "-title", 1 }, + { "-xnllanguage", 1 }, + { "-xrm", 1 }, + { "-singleInstance", 0 }, + { NULL, 0 } +}; + +static int is_x_flag(char *s) +{ + X_flag_entry *x = X_flags; + + while (x->flag) { + if (!strcmp(x->flag, s)) + return x->arg_count + 1; + x++; + } + + return 0; +} + +static int write_str(int fd, char *s) +{ + return write(fd, s, strlen(s)); +} + +static char *num_to_string(int n) +{ + if (!n) + return "0"; + else { + char *d = (char *)malloc(20) + 19; + *d = 0; + while (n) { + d--; + *d = (n % 10) + '0'; + n = n / 10; + } + return d; + } +} + +static char *string_append(char *s1, char *s2) +{ + int l1, l2; + char *s; + + l1 = strlen(s1); + l2 = strlen(s2); + + s = (char *)malloc(l1 + l2 + 1); + + memcpy(s, s1, l1); + memcpy(s + l1, s2, l2); + s[l1 + l2] = 0; + + return s; +} + +static char *copy_string(char *s1) +{ + int l1; + char *s; + + if (!s1) return NULL; + + l1 = strlen(s1); + + s = (char *)malloc(l1 + 1); + + memcpy(s, s1, l1 + 1); + + return s; +} + +static char *do_path_append(char *s1, int l1, char *s2) +{ + int l2; + char *s; + + l2 = strlen(s2); + + s = (char *)malloc(l1 + l2 + 2); + + memcpy(s, s1, l1); + if (s[l1 - 1] != '/') { + s[l1++] = '/'; + } + + memcpy(s + l1, s2, l2); + s[l1 + l2] = 0; + + return s; +} + +static char *path_append(char *s1, char *s2) +{ + return do_path_append(s1, strlen(s1), s2); +} + +static int executable_exists(char *path) +{ + return (access(path, X_OK) == 0); +} + +static int as_int(char *_c) +{ + unsigned char *c = (unsigned char *)_c; + return c[0] | ((int)c[1] << 8) | ((int)c[2] << 16) | ((int)c[3] << 24); +} + +static int has_slash(char *s) +{ + while (*s) { + if (s[0] == '/') + return 1; + s++; + } + return 0; +} + +char *absolutize(char *p, char *d) +{ + int l1; + + if (!p[0]) + return p; + + if (p[0] == '/') + return p; + + /* Strip filename off d: */ + l1 = strlen(d); + while (l1 && (d[l1- 1] != '/')) { + l1--; + } + if (l1) + return do_path_append(d, l1, p); + else + return p; +} + +static char *next_string(char *s) +{ + return s + strlen(s) + 1; +} + +typedef unsigned short ELF__Half; +typedef unsigned int ELF__Word; +typedef unsigned long ELF__Xword; +typedef unsigned long ELF__Addr; +typedef unsigned long ELF__Off; + +typedef struct { + unsigned char e_ident[16]; + ELF__Half e_type; + ELF__Half e_machine; + ELF__Word e_version; + ELF__Addr e_entry; + ELF__Off e_phoff; + ELF__Off e_shoff; + ELF__Word e_flags; + ELF__Half e_ehsize; + ELF__Half e_phentsize; + ELF__Half e_phnum; + ELF__Half e_shentsize; + ELF__Half e_shnum; + ELF__Half e_shstrndx; +} ELF__Header; + +typedef struct +{ + ELF__Word sh_name; + ELF__Word sh_type; + ELF__Xword sh_flags; + ELF__Addr sh_addr; + ELF__Off sh_offset; + ELF__Xword sh_size; + ELF__Word sh_link; + ELF__Word sh_info; + ELF__Xword sh_addralign; + ELF__Xword sh_entsize; +} Elf__Shdr; + +static int try_elf_section(const char *me, int *_start, int *_decl_end, int *_prog_end, int *_end) +{ + int fd, i; + ELF__Header e; + Elf__Shdr s; + char *strs; + + fd = open(me, O_RDONLY, 0); + if (fd == -1) return 0; + + if (read(fd, &e, sizeof(e)) == sizeof(e)) { + if ((e.e_ident[0] == 0x7F) + && (e.e_ident[1] == 'E') + && (e.e_ident[2] == 'L') + && (e.e_ident[3] == 'F')) { + + lseek(fd, e.e_shoff + (e.e_shstrndx * e.e_shentsize), SEEK_SET); + if (read(fd, &s, sizeof(s)) != sizeof(s)) { + close(fd); + return 0; + } + + strs = (char *)malloc(s.sh_size); + lseek(fd, s.sh_offset, SEEK_SET); + if (read(fd, strs, s.sh_size) != s.sh_size) { + close(fd); + return 0; + } + + for (i = 0; i < e.e_shnum; i++) { + lseek(fd, e.e_shoff + (i * e.e_shentsize), SEEK_SET); + if (read(fd, &s, sizeof(s)) != sizeof(s)) { + close(fd); + return 0; + } + if (!strcmp(strs + s.sh_name, ".rackcmdl") + || !strcmp(strs + s.sh_name, ".rackprog")) { + *_decl_end = (*_decl_end - *_start) + s.sh_offset; + *_prog_end = (*_prog_end - *_start) + s.sh_offset; + *_start = s.sh_offset; + *_end = s.sh_offset + s.sh_size; + close(fd); + return !strcmp(strs + s.sh_name, ".rackprog"); + } + } + } + } + + close(fd); + return 0; +} + +int main(int argc, char **argv) +{ + char *me = argv[0], *data, **new_argv; + char *exe_path, *lib_path, *dll_path; + int start, decl_end, prog_end, end, count, fd, v, en, x11; + int argpos, inpos, collcount = 1, fix_argv; + + if (config[7] == '[') { + write_str(2, argv[0]); + write_str(2, ": this is an unconfigured starter\n"); + return 1; + } + + if (me[0] == '/') { + /* Absolute path */ + } else if (has_slash(me)) { + /* Relative path with a directory: */ + char *buf; + long buflen = 4096; + buf = (char *)malloc(buflen); + me = path_append(getcwd(buf, buflen), me); + } else { + /* We have to find the executable by searching PATH: */ + char *path = copy_string(getenv("PATH")), *p, *m; + int more; + + if (!path) { + path = ""; + } + + while (1) { + /* Try each element of path: */ + for (p = path; *p && (*p != ':'); p++) { } + if (*p) { + *p = 0; + more = 1; + } else + more = 0; + + if (!*path) + break; + + m = path_append(path, me); + + if (executable_exists(m)) { + if (m[0] != '/') + m = path_append(getcwd(NULL, 0), m); + me = m; + break; + } + free(m); + + if (more) + path = p + 1; + else + break; + } + } + + /* me is now an absolute path to the binary */ + + /* resolve soft links */ + while (1) { + int len, bufsize = 127; + char *buf; + buf = (char *)malloc(bufsize + 1); + len = readlink(me, buf, bufsize); + if (len < 0) { + if (errno == ENAMETOOLONG) { + /* Increase buffer size and try again: */ + bufsize *= 2; + buf = (char *)malloc(bufsize + 1); + } else + break; + } else { + /* Resolve buf relative to me: */ + buf[len] = 0; + buf = absolutize(buf, me); + me = buf; + buf = (char *)malloc(bufsize + 1); + } + } + + start = as_int(config + 8); + decl_end = as_int(config + 12); + prog_end = as_int(config + 16); + end = as_int(config + 20); + count = as_int(config + 24); + x11 = as_int(config + 28); + + fix_argv = try_elf_section(me, &start, &decl_end, &prog_end, &end); + + { + int offset, len; + offset = _coldir_offset; + while (1) { + len = strlen(_coldir + offset); + offset += len + 1; + if (!_coldir[offset]) + break; + collcount++; + } + } + + data = (char *)malloc(end - prog_end); + new_argv = (char **)malloc((count + argc + (2 * collcount) + 10) * sizeof(char*)); + + fd = open(me, O_RDONLY, 0); + lseek(fd, prog_end, SEEK_SET); + { + int expected_length = end - prog_end; + if (expected_length != read(fd, data, expected_length)) { + printf("read failed to read all %i bytes from file %s\n", expected_length, me); + abort(); + } + } + close(fd); + + exe_path = data; + data = next_string(data); + + lib_path = data; + data = next_string(data); + + exe_path = absolutize(exe_path, me); + lib_path = absolutize(lib_path, me); + +# ifdef OS_X +# define LD_LIB_PATH "DYLD_LIBRARY_PATH" +# else +# define LD_LIB_PATH "LD_LIBRARY_PATH" +# endif + + if (*lib_path) { + dll_path = getenv(LD_LIB_PATH); + if (!dll_path) { + dll_path = ""; + } + dll_path = string_append(dll_path, ":"); + dll_path = string_append(lib_path, dll_path); + dll_path = string_append(LD_LIB_PATH "=", dll_path); + putenv(dll_path); + } + + new_argv[0] = me; + + argpos = 1; + inpos = 1; + + /* Keep all X11 flags to the front: */ + if (x11) { + int n; + while (inpos < argc) { + n = is_x_flag(argv[inpos]); + if (!n) + break; + if (inpos + n > argc) { + write_str(2, argv[0]); + write_str(2, ": missing an argument for "); + write_str(2, argv[inpos]); + write_str(2, "\n"); + return 1; + } + while (n--) { + new_argv[argpos++] = argv[inpos++]; + } + } + } + + /* Add -X and -S flags */ + { + int offset, len; + offset = _coldir_offset; + new_argv[argpos++] = "-X"; + new_argv[argpos++] = absolutize(_coldir + offset, me); + while (1) { + len = strlen(_coldir + offset); + offset += len + 1; + if (!_coldir[offset]) + break; + new_argv[argpos++] = "-S"; + new_argv[argpos++] = absolutize(_coldir + offset, me); + } + } + + /* Add -G flag */ + new_argv[argpos++] = "-G"; + new_argv[argpos++] = absolutize(_configdir + _configdir_offset, me); + + if (fix_argv) { + /* next three args are "-k" and numbers; fix + the numbers to match start, decl_end, and prog_end */ + fix_argv = argpos + 1; + } + + /* Add built-in flags: */ + while (count--) { + new_argv[argpos++] = data; + data = next_string(data); + } + + /* Propagate new flags (after the X11 flags) */ + while (inpos < argc) { + new_argv[argpos++] = argv[inpos++]; + } + + new_argv[argpos] = NULL; + + if (fix_argv) { + new_argv[fix_argv] = num_to_string(start); + new_argv[fix_argv+1] = num_to_string(decl_end); + new_argv[fix_argv+2] = num_to_string(prog_end); + } + + /* Execute the original binary: */ + + v = execv(exe_path, new_argv); + en = errno; + + write_str(2, argv[0]); + write_str(2, ": failed to start "); + write_str(2, exe_path); + write_str(2, " ("); + write_str(2, strerror(en)); + write_str(2, ")\n"); + if (*lib_path) { + write_str(2, " used library path "); + write_str(2, lib_path); + write_str(2, "\n"); + } + + return v; +} diff -Nru racket-6.12+ppa1/src/thread/alarm.rkt racket-7.0+ppa1/src/thread/alarm.rkt --- racket-6.12+ppa1/src/thread/alarm.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/alarm.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,22 @@ +#lang racket/base +(require "check.rkt" + "evt.rkt" + "schedule-info.rkt") + +(provide (rename-out [create-alarm-evt alarm-evt])) + +(struct alarm-evt (msecs) + #:property + prop:evt + (poller (lambda (e ctx) + (define msecs (alarm-evt-msecs e)) + (if ((current-inexact-milliseconds) . >= . msecs) + (values (list e) #f) + (begin + (schedule-info-add-timeout-at! (poll-ctx-sched-info ctx) + msecs) + (values #f e)))))) + +(define/who (create-alarm-evt msecs) + (check who real? msecs) + (alarm-evt msecs)) diff -Nru racket-6.12+ppa1/src/thread/api.rkt racket-7.0+ppa1/src/thread/api.rkt --- racket-6.12+ppa1/src/thread/api.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/api.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,118 @@ +#lang racket/base +(require "check.rkt" + (rename-in "semaphore.rkt" + [semaphore-peek-evt raw:semaphore-peek-evt]) + (rename-in "evt.rkt" + [wrap-evt raw:wrap-evt] + [handle-evt raw:handle-evt] + [handle-evt? raw:handle-evt?] + [poll-guard-evt raw:poll-guard-evt] + [choice-evt raw:choice-evt]) + (only-in "sync.rkt" + sync/enable-break)) + +(provide wrap-evt + handle-evt + handle-evt? + guard-evt + poll-guard-evt + nack-guard-evt + choice-evt + semaphore-peek-evt + semaphore-wait/enable-break + call-with-semaphore + call-with-semaphore/enable-break) + +(define/who (choice-evt . args) + (for ([arg (in-list args)]) + (check who evt? arg)) + (raw:choice-evt args)) + +(define/who (wrap-evt evt proc) + (check who evt? evt) + (check who procedure? proc) + (raw:wrap-evt evt proc)) + +(define/who (handle-evt evt proc) + (check who evt? evt) + (check who procedure? proc) + (raw:handle-evt evt proc)) + +(define/who (handle-evt? evt) + (check who evt? evt) + (let loop ([evt evt]) + (or (raw:handle-evt? evt) + (and (choice-evt? evt) + (for/or ([evt (in-list (choice-evt-evts evt))]) + (loop evt)))))) + +(define/who (guard-evt proc) + (check who (procedure-arity-includes/c 0) proc) + (raw:poll-guard-evt (lambda (poll?) (proc)))) + +(define/who (poll-guard-evt proc) + (check who(procedure-arity-includes/c 1) proc) + (raw:poll-guard-evt proc)) + +(define/who (nack-guard-evt proc) + (check who (procedure-arity-includes/c 1) proc) + (raw:poll-guard-evt + (lambda (poll?) + (define s (make-semaphore)) + ;; Return control-state-evt to register + ;; the nack semaphore before exposing it to + ;; the `proc` callback: + (control-state-evt + (raw:poll-guard-evt + (lambda (poll?) + (define v (proc (wrap-evt (raw:semaphore-peek-evt s) void))) + (if (evt? v) + v + (wrap-evt always-evt (lambda () v))))) + void + (lambda () (semaphore-post s)) + void)))) + +(define/who (semaphore-peek-evt s) + (check who semaphore? s) + (raw:semaphore-peek-evt s)) + +(define/who (semaphore-wait/enable-break s) + (check who semaphore? s) + (sync/enable-break s) + (void)) + +;; ---------------------------------------- + +(define (do-call-with-semaphore who s proc try-fail args #:enable-break? [enable-break? #f]) + (check who semaphore? s) + (check who procedure? proc) + (check who (procedure-arity-includes/c 0) #:or-false try-fail) + (define breaks-on? (or enable-break? + (break-enabled))) + (define results #t) ; transitions to list of results unless semaphore-try fails + (dynamic-wind + (lambda () + (if try-fail + (set! results (semaphore-try-wait? s)) + (if breaks-on? + (semaphore-wait/enable-break s) + (semaphore-wait s)))) + (lambda () + (when results + (call-with-continuation-barrier + (lambda () + (set! results + (call-with-values (lambda () (apply proc args)) list)))))) + (lambda () + (when results + (semaphore-post s)))) + (if results + (apply values results) + (try-fail))) + +(define (call-with-semaphore s proc [try-fail #f] . args) + (do-call-with-semaphore 'call-with-semaphore s proc try-fail args)) + +(define (call-with-semaphore/enable-break s proc [try-fail #f] . args) + (do-call-with-semaphore 'call-with-semaphore/enable-break s proc try-fail args #:enable-break? #t)) diff -Nru racket-6.12+ppa1/src/thread/atomic.rkt racket-7.0+ppa1/src/thread/atomic.rkt --- racket-6.12+ppa1/src/thread/atomic.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/atomic.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,86 @@ +#lang racket/base +(require "engine.rkt" + "internal-error.rkt" + "debug.rkt") + +(provide atomically + current-atomic + + start-atomic + end-atomic + + start-atomic/no-interrupts + end-atomic/no-interrupts + + set-end-atomic-callback! + + start-implicit-atomic-mode + end-implicit-atomic-mode + assert-atomic-mode) + +;; This definition is specially recognized for Racket on +;; Chez Scheme and converted to use a virtual register: +(define current-atomic (make-pthread-parameter 0)) + +(define-syntax-rule (atomically expr ...) + (begin + (start-atomic) + (begin0 + (let () expr ...) + (end-atomic)))) + +(define (start-atomic) + (current-atomic (add1 (current-atomic)))) + +(define (end-atomic) + (define n (sub1 (current-atomic))) + (cond + [(and end-atomic-callback + (zero? n)) + (define cb end-atomic-callback) + (set! end-atomic-callback #f) + (current-atomic n) + (cb)] + [else + (current-atomic n)])) + +(define (start-atomic/no-interrupts) + (start-atomic) + (host:disable-interrupts)) + +(define (end-atomic/no-interrupts) + (host:enable-interrupts) + (end-atomic)) + +;; ---------------------------------------- + +(define end-atomic-callback #f) + +(define (set-end-atomic-callback! cb) + (set! end-atomic-callback cb)) + + +;; ---------------------------------------- + +(debug-select + #:on + [(define current-implicit-atomic (make-pthread-parameter #t)) + + (define (start-implicit-atomic-mode) + (when (current-implicit-atomic) + (internal-error "already implicitly in atomic mode?")) + (current-implicit-atomic #t)) + + (define (end-implicit-atomic-mode) + (unless (current-implicit-atomic) + (internal-error "not implicitly in atomic mode?")) + (current-implicit-atomic #f)) + + (define-syntax-rule (assert-atomic-mode) + (unless (or (current-implicit-atomic) + (positive? (current-atomic))) + (internal-error "should be in atomic mode")))] + #:off + [(define-syntax-rule (start-implicit-atomic-mode) (begin)) + (define-syntax-rule (end-implicit-atomic-mode) (begin)) + (define-syntax-rule (assert-atomic-mode) (begin))]) diff -Nru racket-6.12+ppa1/src/thread/bootstrap-main.rkt racket-7.0+ppa1/src/thread/bootstrap-main.rkt --- racket-6.12+ppa1/src/thread/bootstrap-main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/bootstrap-main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require "bootstrap.rkt" ; must be before "main.rkt" + "main.rkt") + +(provide (all-from-out "main.rkt")) + diff -Nru racket-6.12+ppa1/src/thread/bootstrap.rkt racket-7.0+ppa1/src/thread/bootstrap.rkt --- racket-6.12+ppa1/src/thread/bootstrap.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/bootstrap.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,190 @@ +#lang racket/base +(require '#%linklet + (only-in '#%foreign + make-stubborn-will-executor) + "../common/queue.rkt") + +;; Simulate engines by using the host system's threads. + +;; This simulation doesn't provide a `dynamic-wind` that cooperates +;; with `break-enabled-key`, and it does not support using an +;; exception handler in an engine. + +(define (make-engine thunk init-break-enabled-cell empty-config?) + (define ready-s (make-semaphore)) + (define s (make-semaphore)) + (define prefix void) + (define results (list (void))) + (define t (thread (lambda () + (define orig (uncaught-exception-handler)) + (define (run-prefix) + (prefix) + (set! prefix void)) + (call-with-exception-handler + (lambda (exn) + (if (and (exn:break? exn) + (not (exn:break/non-engine? exn))) + (with-handlers ([exn:break/non-engine? + (lambda (exn) + ;; Avoid exception-during-exception + ;; error by propagating the original, + ;; even though it's a different kind + ;; of break exn: + exn)]) + (run-prefix) + ((exn:break-continuation exn))) + (abort-current-continuation + the-root-continuation-prompt-tag + exn))) + (lambda () + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + break-enabled-key + init-break-enabled-cell + (begin + (semaphore-post ready-s) + (semaphore-wait s) + (run-prefix) + (set! results + (call-with-values thunk list))))) + the-root-continuation-prompt-tag + (lambda (exn) + ((error-display-handler) (exn-message exn) exn)))))))) + (semaphore-wait ready-s) + (thread-suspend t) + (semaphore-post s) + (define (go ticks next-prefix complete expire) + (set! prefix next-prefix) + (break-thread t) + (thread-resume t) + (define t2 + (thread (lambda () + (sleep (/ ticks 1000000.0)) + (thread-suspend t)))) + ;; Limited break propagation while syncing: + (call-with-exception-handler + (lambda (exn) + (if (and (exn:break? exn) + ctl-c-handler) + (begin + (ctl-c-handler 'break) + ((exn:break-continuation exn))) + exn)) + (lambda () + (sync t t2 (thread-suspend-evt t)))) + (cond + [(thread-dead? t) + (apply complete 0 results)] + [else + (expire go)])) + go) + +(define (engine-block) + (thread-suspend (current-thread))) + +(define ctl-c-handler #f) + +(define (set-ctl-c-handler! proc) + (set! ctl-c-handler proc)) + +(define the-root-continuation-prompt-tag (make-continuation-prompt-tag 'root)) +(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag) +(define break-enabled-key (gensym 'break-enabled)) + +(struct will-executor/notify (we queue notify)) + +(define will-executors null) + +(define (poll-will-executors) + (when (for/or ([w (in-list will-executors)]) + (will-try-execute w)) + (poll-will-executors))) + +(define (do-make-will-executor/notify make-will-executor notify) + (define we (make-will-executor)) + (set! will-executors (cons we will-executors)) + (will-executor/notify we (make-queue) notify)) + +(define (make-will-executor/notify notify) + (do-make-will-executor/notify make-will-executor notify)) + +(define (make-stubborn-will-executor/notify notify) + (do-make-will-executor/notify make-stubborn-will-executor notify)) + +(define (will-register/notify we/n v proc) + (will-register (will-executor/notify-we we/n) + v + (lambda (v) + ((will-executor/notify-notify we/n)) + (queue-add! (will-executor/notify-queue we/n) + (cons proc v))))) + +(define (will-try-execute/notify we/n) + (poll-will-executors) + (queue-remove! (will-executor/notify-queue we/n))) + +(define (will-executor-notification-procedure we [proc #f]) + (error "will-executor-notification-procedure not supported")) + +(struct exn:break/non-engine exn:break ()) +(struct exn:break:hang-up/non-engine exn:break/non-engine ()) +(struct exn:break:terminate/non-engine exn:break/non-engine ()) + +(define (make-pthread-parameter v) + (define x v) + (case-lambda + [() x] + [(v) (set! x v)])) + +(primitive-table '#%pthread + (hash + 'make-pthread-parameter make-pthread-parameter)) +(primitive-table '#%engine + (hash + 'make-engine make-engine + 'engine-block engine-block + 'engine-return (lambda args + (error "engine-return: not ready")) + 'current-process-milliseconds current-process-milliseconds + 'set-ctl-c-handler! set-ctl-c-handler! + 'root-continuation-prompt-tag root-continuation-prompt-tag + 'break-enabled-key break-enabled-key + 'set-break-enabled-transition-hook! void + 'continuation-marks continuation-marks ; doesn't work on engines + 'poll-will-executors poll-will-executors + 'make-will-executor make-will-executor/notify + 'make-stubborn-will-executor make-stubborn-will-executor/notify + 'will-executor? will-executor/notify? + 'will-register will-register/notify + 'will-try-execute will-try-execute/notify + 'exn:break/non-engine exn:break/non-engine + 'exn:break:hang-up/non-engine exn:break:hang-up/non-engine + 'exn:break:terminate/non-engine exn:break:terminate/non-engine + 'poll-async-callbacks (lambda () null) + 'disable-interrupts void + 'enable-interrupts void + 'fork-pthread (lambda args + (error "fork-pthread: not ready")) + 'pthread? (lambda args + (error "thread?: not ready")) + 'get-thread-id (lambda args + (error "get-pthread-id: not ready")) + 'make-condition (lambda () 'condition) + 'condition-wait (lambda args + (error "condition-wait: not ready")) + 'condition-signal (lambda args + (error "condition-signal: not ready")) + 'condition-broadcast (lambda args + (error "condition-broadcast: not ready")) + 'threaded? (lambda () #f) + 'current-engine-state (lambda args + (error "current-engine state: not ready")) + 'make-mutex (lambda () 'mutex) + 'mutex-acquire (lambda args + (error "mutex-acquire: not ready")) + 'mutex-release (lambda args + (error "mutex-release: not ready")))) + +;; add dummy definitions that implement pthreads and conditions etc. +;; dummy definitions that error diff -Nru racket-6.12+ppa1/src/thread/channel.rkt racket-7.0+ppa1/src/thread/channel.rkt --- racket-6.12+ppa1/src/thread/channel.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/channel.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,215 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "parameter.rkt" + "evt.rkt" + "waiter.rkt" + "../common/queue.rkt") + +(provide make-channel + channel? + channel-put + channel-get + + channel-put-evt + channel-put-evt?) + +(module+ for-sync + (provide set-sync-on-channel!)) + +(module+ for-impersonator + (provide impersonator-prop:channel-put + channel-put-impersonator? + channel-put-impersonator-ref)) + +;; ---------------------------------------- + +(struct channel (get-queue + put-queue) + #:property + prop:evt + (poller (lambda (ch poll-ctx) + (channel-get/poll ch poll-ctx)))) + +(struct channel-put-evt* (ch v) + #:property + prop:evt + (poller (lambda (cp poll-ctx) + (channel-put/poll (channel-put-evt*-ch cp) + (channel-put-evt*-v cp) + cp + poll-ctx))) + #:reflection-name 'channel-put-evt) + +;; A channel must not match get and put from the same thread, which is +;; a danger when `sync` queues up multiple events at a time: +(struct channel-select-waiter select-waiter (thread)) + +(define (make-channel) + (channel (make-queue) (make-queue))) + +;; ---------------------------------------- + +(define/who (channel-get ch) + (check who channel? ch) + (cond + [(evt-impersonator? ch) + ;; Use the more general path to get impersonator handling: + (sync-on-channel ch)] + [else + (define b (box #f)) + (let receive () ; loop if a retry is needed + ((atomically + (define pw+v (queue-remove! (channel-put-queue ch))) + (define gw (current-thread)) + (cond + [(not pw+v) + (define gq (channel-get-queue ch)) + (define n (queue-add! gq (cons gw b))) + (waiter-suspend! gw + ;; On break/kill/suspend: + (lambda () (queue-remove-node! gq n)) + ;; On retry after break or resume: + (lambda () (receive)))] + [else + (set-box! b (cdr pw+v)) + (waiter-resume! (car pw+v) (void)) + void])))) + (unbox b)])) + +;; in atomic mode +(define (channel-get/poll ch poll-ctx) + ;; Similar to `channel-get`, but works in terms of a + ;; `select-waiter` instead of a thread + (assert-atomic-mode) + (define pq (channel-put-queue ch)) + (define pw+v (queue-fremove! pq not-matching-select-waiter)) + (cond + [pw+v + (waiter-resume! (car pw+v) (void)) + (values (list (cdr pw+v)) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f never-evt)] + [else + (define b (box #f)) + (define gq (channel-get-queue ch)) + (define gw (channel-select-waiter (poll-ctx-select-proc poll-ctx) + (current-thread))) + (define n (queue-add! gq (cons gw b))) + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () (queue-remove-node! gq n)) + void + (lambda () + ;; Retry: get ready value or requeue + (define pw+v (queue-fremove! pq not-matching-select-waiter)) + (cond + [pw+v + (waiter-resume! (car pw+v) (void)) + (set-box! b (cdr pw+v)) + (values #t #t)] + [else + (set! n (queue-add! gq (cons gw b))) + (values #f #f)]))) + (lambda (v) (unbox b))))])) + +;; ---------------------------------------- + + +(define/who (channel-put ch v) + (check who channel? ch) + (cond + [(channel-put-impersonator? ch) + (channel-impersonator-put ch v channel-put)] + [else + ((atomically + (define gw+b (queue-remove! (channel-get-queue ch))) + (define pw (current-thread)) + (cond + [(not gw+b) + (define pq (channel-put-queue ch)) + (define n (queue-add! pq (cons pw v))) + (waiter-suspend! pw + ;; On break/kill/suspend: + (lambda () (queue-remove-node! pq n)) + ;; On retry after break or resume: + (lambda () (channel-put ch v)))] + [else + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + void])))])) + +;; In atomic mode +(define (channel-put/poll ch v result poll-ctx) + ;; Similar to `channel-put`, but works in terms of a + ;; `select-waiter` instead of a thread + (assert-atomic-mode) + (define gq (channel-get-queue ch)) + (define gw+b (queue-fremove! gq not-matching-select-waiter)) + (cond + [gw+b + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + (values (list result) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f async-evt)] + [else + (define pq (channel-put-queue ch)) + (define pw (channel-select-waiter (poll-ctx-select-proc poll-ctx) + (current-thread))) + (define n (queue-add! pq (cons pw v))) + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () (queue-remove-node! pq n)) + void + (lambda () + ;; Retry: put ready value or requeue + (define gw+b (queue-fremove! gq not-matching-select-waiter)) + (cond + [gw+b + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + (values result #t)] + [else + (set! n (queue-add! pq (cons pw v))) + (values #f #f)]))) + (lambda (v) result)))])) + +(define/who (channel-put-evt ch v) + (check who channel? ch) + (cond + [(channel-put-impersonator? ch) + (channel-impersonator-put ch v channel-put-evt)] + [else + (channel-put-evt* ch v)])) + +(define (channel-put-evt? v) + (channel-put-evt*? v)) + +(define (channel-impersonator-put ch v channel-put) + (define ch+put-proc (channel-put-impersonator-ref ch)) + (define old-ch (car ch+put-proc)) + (define new-v ((cdr ch+put-proc) old-ch v)) + (channel-put old-ch new-v)) + +;; ---------------------------------------- + +(define (not-matching-select-waiter w+b/v) + (define w (car w+b/v)) + (or (not (channel-select-waiter? w)) + (not (eq? (current-thread) + (channel-select-waiter-thread w))))) + +;; ---------------------------------------- + +;; To resolve a mutual dependency: +(define sync-on-channel #f) +(define (set-sync-on-channel! sync) + (set! sync-on-channel sync)) + +;; ---------------------------------------- + +(define-values (impersonator-prop:channel-put channel-put-impersonator? channel-put-impersonator-ref) + (make-impersonator-property 'channel-put-impersonator)) diff -Nru racket-6.12+ppa1/src/thread/check.rkt racket-7.0+ppa1/src/thread/check.rkt --- racket-6.12+ppa1/src/thread/check.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/check.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,4 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide (all-from-out "../common/check.rkt")) diff -Nru racket-6.12+ppa1/src/thread/continuation-mark.rkt racket-7.0+ppa1/src/thread/continuation-mark.rkt --- racket-6.12+ppa1/src/thread/continuation-mark.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/continuation-mark.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,21 @@ +#lang racket/base +(require "check.rkt" + (submod "thread.rkt" scheduling) + "engine.rkt") + +(provide continuation-marks) + +(define/who (continuation-marks k [prompt-tag (default-continuation-prompt-tag)]) + (check who (lambda (k) (or (not k) (continuation? k) (thread? k))) + #:contract "(or/c continuation? thread? #f)" + k) + (check who continuation-prompt-tag? prompt-tag) + (cond + [(thread? k) + (define e (thread-engine k)) + (cond + [(eq? e 'done) (host:continuation-marks #f prompt-tag)] + [(eq? e 'running) (current-continuation-marks)] + [else (host:continuation-marks e prompt-tag)])] + [else + (host:continuation-marks k prompt-tag)])) diff -Nru racket-6.12+ppa1/src/thread/custodian.rkt racket-7.0+ppa1/src/thread/custodian.rkt --- racket-6.12+ppa1/src/thread/custodian.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/custodian.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,206 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "evt.rkt" + "semaphore.rkt") + +(provide current-custodian + make-custodian + custodian? + custodian-shutdown-all + custodian-managed-list + make-custodian-box + custodian-box? + custodian-box-value + custodian-memory-accounting-available? + custodian-require-memory + custodian-limit-memory + custodian-shut-down? + + custodian-subordinate? + custodian-manages-reference? + custodian-reference->custodian + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister + raise-custodian-is-shut-down + set-post-shutdown-action!) + +(struct custodian (children ; weakly maps maps object to callback + [shut-down? #:mutable] + [shutdown-sema #:mutable] + [parent-reference #:mutable]) + #:authentic) + +(struct custodian-box ([v #:mutable] sema) + #:authentic + #:property prop:evt (lambda (cb) + (wrap-evt (custodian-box-sema cb) (lambda (v) cb)))) + +(struct willed-callback (proc will) + #:property prop:procedure (struct-field-index proc) + #:authentic) + +(struct at-exit-callback willed-callback () + #:authentic) + +;; Reporting registration in a custodian through this indirection +;; enables GCing custodians that aren't directly referenced, merging +;; the managed objects into the parent, although that posisbility is +;; not currently implemented +(struct custodian-reference (c) + #:authentic) + +(define (create-custodian) + (custodian (make-weak-hasheq) + #f ; shut-down? + #f ; shutdown semaphore + #f)) + +(define root-custodian (create-custodian)) + +(define/who current-custodian + (make-parameter root-custodian + (lambda (v) + (check who custodian? v) + v))) + +(define/who (make-custodian [parent (current-custodian)]) + (check who custodian? parent) + (define c (create-custodian)) + (define cref (unsafe-custodian-register parent c do-custodian-shutdown-all #f #t)) + (set-custodian-parent-reference! c cref) + (unless cref (raise-custodian-is-shut-down who parent)) + c) + +(define (unsafe-make-custodian-at-root) + (make-custodian root-custodian)) + +;; The given `callback` will be run in atomic mode. +;; Unless `weak?` is true, the given `obj` is registered with an ordered +;; finalizer, so don't supply an `obj` that is exposed to safe code +;; that might see `obj` after finalization through a weak reference +;; (and detect that `obj` is thereafter retained strongly). +(define (unsafe-custodian-register cust obj callback at-exit? weak?) + (atomically + (cond + [(custodian-shut-down? cust) #f] + [else + (define we (and (not weak?) + (host:make-stubborn-will-executor void))) + (hash-set! (custodian-children cust) + obj + (cond + [weak? callback] + [at-exit? (at-exit-callback callback we)] + [else (willed-callback callback we)])) + (when we + ;; Registering with a will executor that we never poll has the + ;; effect of turning a weak reference into a strong one when + ;; there are no other references: + (host:will-register we obj void)) + (custodian-reference cust)]))) + +(define (unsafe-custodian-unregister obj cref) + (when cref + (atomically + (define c (custodian-reference-c cref)) + (unless (custodian-shut-down? c) + (hash-remove! (custodian-children c) obj))))) + +;; Hook for thread scheduling: +(define post-shutdown-action void) +(define (set-post-shutdown-action! proc) + (set! post-shutdown-action proc)) + +(define/who (custodian-shutdown-all c) + (check who custodian? c) + (atomically + (do-custodian-shutdown-all c)) + (post-shutdown-action)) + +;; In atomic mode +(define (do-custodian-shutdown-all c) + (unless (custodian-shut-down? c) + (set-custodian-shut-down?! c #t) + (for ([(child callback) (in-hash (custodian-children c))]) + (if (procedure-arity-includes? callback 2) + (callback child c) + (callback child))) + (hash-clear! (custodian-children c)) + (let ([sema (custodian-shutdown-sema c)]) + (when sema + (semaphore-post-all sema))))) + +(define (custodian-get-shutdown-sema c) + (atomically + (or (custodian-shutdown-sema c) + (let ([sema (make-semaphore)]) + (set-custodian-shutdown-sema! c sema) + (when (custodian-shut-down? c) + (semaphore-post-all sema)) + sema)))) + +(define (custodian-subordinate? c super-c) + (let loop ([p-cref (custodian-parent-reference c)]) + (define p (and p-cref (custodian-reference-c p-cref))) + (cond + [(eq? p super-c) #t] + [(not p) #f] + [else (loop (custodian-parent-reference p))]))) + +(define (custodian-manages-reference? c cref) + (define ref-c (custodian-reference-c cref)) + (or (eq? c ref-c) + (custodian-subordinate? ref-c c))) + +(define (custodian-reference->custodian cref) + (custodian-reference-c cref)) + +(define/who (custodian-managed-list c super-c) + (check who custodian? c) + (check who custodian? super-c) + (unless (custodian-subordinate? c super-c) + (raise-arguments-error who "the second custodian does not manage the first custodian" + "first custodian" c + "second custodian" super-c)) + (hash-keys (custodian-children c))) + +(define (custodian-memory-accounting-available?) + #f) + +(define/who (custodian-require-memory limit-cust need-amt stop-cust) + (check who custodian? limit-cust) + (check who exact-nonnegative-integer? need-amt) + (check who custodian? stop-cust) + (raise (exn:fail:unsupported + "custodian-require-memory: unsupported" + (current-continuation-marks)))) + +(define/who (custodian-limit-memory limit-cust need-amt [stop-cust limit-cust]) + (check who custodian? limit-cust) + (check who exact-nonnegative-integer? need-amt) + (check who custodian? stop-cust) + (raise (exn:fail:unsupported + "custodian-limit-memory: unsupported" + (current-continuation-marks)))) + +;; ---------------------------------------- + +(define/who (make-custodian-box c v) + (check who custodian? c) + (define b (custodian-box v (custodian-get-shutdown-sema c))) + (unless (unsafe-custodian-register c b (lambda (b) (set-custodian-box-v! b #f)) #f #t) + (raise-custodian-is-shut-down who c)) + b) + +(define/who (custodian-box-value cb) + (check who custodian-box? cb) + (custodian-box-v cb)) + +;; ---------------------------------------- + +(define (raise-custodian-is-shut-down who c) + (raise-arguments-error who "the custodian has been shut down" + "custodian" c)) diff -Nru racket-6.12+ppa1/src/thread/debug.rkt racket-7.0+ppa1/src/thread/debug.rkt --- racket-6.12+ppa1/src/thread/debug.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/debug.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,14 @@ +#lang racket/base + +;; Change `debug-select` to enable or disable debugging mode, +;; such as assertions about the current atomicity mode. + +(provide debug-select) + +(define-syntax-rule (debug-select + #:on + [on ...] + #:off + [off ...]) + ;; Select `on` or `off` here: + (begin off ...)) diff -Nru racket-6.12+ppa1/src/thread/demo.rkt racket-7.0+ppa1/src/thread/demo.rkt --- racket-6.12+ppa1/src/thread/demo.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/demo.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,506 @@ +#lang racket/base +(require "bootstrap-main.rkt") + +;; Don't use exception handlers here, because the "bootstrap.rkt" +;; implementation of engines can't support it. + +(define done? #f) + +(call-in-main-thread + (lambda () + (define-syntax-rule (check a b) + (let ([a-v a] + [b-v b]) + (unless (equal? a-v b-v) + (error 'failed "~s: ~e vs. ~e" 'b a-v b-v)))) + + ;; Check semaphores + (check #t (thread? (current-thread))) + (check #t (evt? (current-thread))) + (define s (make-semaphore)) + (define t0 (thread (lambda () (semaphore-wait s) (printf "__\n") (semaphore-post s)))) + (define t1 (thread (lambda () (semaphore-wait s) (printf "hi\n") (semaphore-post s)))) + (define t2 (thread (lambda () (printf "HI\n") (semaphore-post s)))) + (thread-wait t0) + (thread-wait t1) + (thread-wait t2) + + ;; Check channels + (define ch (make-channel)) + (define ct1 (thread (lambda () (printf "1 ~a\n" (channel-get ch))))) + (define ct2 (thread (lambda () (printf "2 ~a\n" (channel-get ch))))) + (channel-put ch 'a) + (channel-put ch 'b) + + (define cpt1 (thread (lambda () (channel-put ch 'c)))) + (define cpt2 (thread (lambda () (channel-put ch 'd)))) + (printf "3 ~a\n" (channel-get ch)) + (printf "4 ~a\n" (channel-get ch)) + + ;; Check timeout + (check #f (sync/timeout 0.1)) + (check #f (sync/timeout 0.1 never-evt)) + + ;; Check semaphore polling + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 s)) + + ;; Check more semaphore polling + (define s2 (make-semaphore 3)) + (check s2 (sync/timeout 0 s s2)) + (check s2 (sync/timeout 0 s2 s)) + (check 'got-s2 (sync s (wrap-evt s2 (lambda (v) (check v s2) 'got-s2)))) + (check #f (sync/timeout 0 s2 s)) + + ;; Choice evts + (define choice1 (choice-evt s s2)) + (semaphore-post s2) + (check s2 (sync choice1)) + (semaphore-post s) + (check s (sync choice1)) + (check #f (sync/timeout 0 choice1)) + + ;; Check channel and `sync` + (void (thread (lambda () (channel-put ch 'c2)))) + (check 'c2 (sync ch)) + + ;; Check channel-put events + (void (thread (lambda () (check 'c3 (channel-get ch))))) + (define pc (channel-put-evt ch 'c3)) + (check pc (sync pc)) + + ;; Check guard event + (define ok-evt (guard-evt + (lambda () + (define ch (make-channel)) + (thread (lambda () (channel-put ch 'ok))) + ch))) + (check 'ok (sync ok-evt)) + + ;; Check semaphore-peek events + (semaphore-post s) + (define sp (semaphore-peek-evt s)) + (check sp (sync/timeout 0 sp)) + (check sp (sync/timeout 0 sp)) + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 sp)) + + ;; Check nacks + (define nack #f) + (check #t (semaphore? (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore 1)))))) + (check #f (sync/timeout 0 nack)) + (set! nack #f) + (let loop () + (check 'ok (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore))) ok-evt)) + (unless nack (loop))) + (check (void) (sync/timeout 0 nack)) + + (semaphore-post s) + (check #f (sync/timeout 0 ch (channel-put-evt ch 'oops))) + (check sp (sync/timeout #f ch (channel-put-evt ch 'oops) sp)) + + (let ([v #f]) + (check #f (sync/timeout 0 + (nack-guard-evt + (lambda (nack) + (set! v nack) + (choice-evt (make-semaphore) (make-semaphore)))))) + (check (void) (sync/timeout 0 v))) + + ;; evt chaperone + (define e1 (make-semaphore 1)) + (check #t (chaperone-of? (chaperone-evt e1 void) e1)) + (check #f (chaperone-of? e1 (chaperone-evt e1 void))) + (let ([hit #f]) + (check e1 (sync (chaperone-evt e1 (lambda (e) + (set! hit e) + (values e values))))) + (check e1 hit)) + (check #t (semaphore? (chaperone-evt e1 void))) + + (check #t (chaperone-of? (chaperone-evt ch void) ch)) + (check #t (channel? (chaperone-evt ch void))) + (check #t (channel? (chaperone-channel ch void void))) + (let ([proc (lambda (arg) arg)]) + (thread (lambda () (channel-put ch proc))) + (let ([proc2 (channel-get (chaperone-evt ch (lambda (ch) + (values ch + (lambda (proc) + (chaperone-procedure proc void))))))]) + (check #f (eq? proc2 proc)) + (check #t (chaperone-of? proc2 proc)))) + (let ([got #f]) + (define th (thread (lambda () (set! got (channel-get ch))))) + (channel-put (chaperone-evt ch void) 'ok) + (check th (sync th)) + (check got 'ok)) + (define (check-chaperone-channel channel-put) + (let ([proc (lambda (arg) arg)] + [got #f]) + (define th (thread (lambda () (set! got (channel-get ch))))) + (channel-put (chaperone-channel ch + (lambda (ch) (values ch values)) + (lambda (ch proc) + (chaperone-procedure proc void))) + proc) + (check #f (eq? got proc)) + (check #t (chaperone-of? got proc)))) + (check-chaperone-channel channel-put) + (check-chaperone-channel (lambda (ch v) (sync (channel-put-evt ch v)))) + + ;; Check sleeping in main thread + (define now1 (current-inexact-milliseconds)) + (sleep 0.1) + (check #t ((current-inexact-milliseconds) . >= . (+ now1 0.1))) + + ;; Check sleeping in other thread + (define now2 (current-inexact-milliseconds)) + (define ts (thread (lambda () (sleep 0.1)))) + (check ts (sync ts)) + (check #t ((current-inexact-milliseconds) . >= . (+ now2 0.1))) + + ;; Check `alarm-evt` + (define now2+ (current-inexact-milliseconds)) + (define alm (alarm-evt (+ 0.1 now2+))) + (check alm (sync alm)) + (check #t ((current-inexact-milliseconds) . >= . (+ now2+ 0.1))) + + ;; Check system-idle event + (define v 0) + (thread (lambda () (set! v (add1 v)))) + (sync (system-idle-evt)) + (check 1 v) + + ;; Check `replace-evt` + (check 5 (sync (replace-evt always-evt (lambda (v) (wrap-evt always-evt (lambda (v) 5)))))) + (check #f (sync/timeout 0 (replace-evt never-evt void))) + (let ([ns null]) + (check #f (sync/timeout 0 (replace-evt (choice-evt + (nack-guard-evt + (lambda (n) + (set! ns (cons n ns)) + never-evt)) + (nack-guard-evt + (lambda (n) + (set! ns (cons n ns)) + never-evt))) + void))) + (check 2 (length ns)) + (check (void) (sync (car ns))) + (check (void) (sync (cadr ns)))) + + ;; Check `thread-send` + (check (void) (thread-send (current-thread) 'sent0)) + (check (void) (thread-send (current-thread) 'sent1)) + (check 'sent0 (thread-receive)) + (check 'sent1 (thread-receive)) + (check #f (thread-try-receive)) + (check (void) (thread-send (current-thread) 'sent2)) + (check 'sent2 (thread-try-receive)) + (let ([t (current-thread)]) + (thread (lambda () + (sync (system-idle-evt)) + (thread-send t 'sent3)))) + (check 'sent3 (thread-receive)) + + (define rcv (thread-receive-evt)) + (check #f (sync/timeout 0 rcv)) + (check (void) (thread-send (current-thread) 'sent4)) + (check rcv (sync/timeout #f rcv)) + (check 'sent4 (thread-receive)) + (check #f (sync/timeout 0 rcv)) + + (let ([r #f]) + (define t (thread (lambda () + (set! r (sync rcv rcv))))) + (sync (system-idle-evt)) + (thread-send t 'ok) + (sync (system-idle-evt)) + (check t (sync/timeout 0 t)) + (check rcv r)) + + (define (check-break/kill #:kill? kill?) + (define stop-thread (if kill? kill-thread break-thread)) + (define (report-expected-exn what) + (unless kill? + (printf "[That ~a was from a thread, and it's expected]\n" what))) + (define (report-expected-break) + (report-expected-exn "break")) + + ;; Check that a loop can be abandoned + (define tinf (thread (lambda () (let loop () (loop))))) + (sleep) + (stop-thread tinf) + (check tinf (sync tinf)) + (report-expected-break) + + ;; Check that a break exception is delayed if disabled + (define now3 (current-inexact-milliseconds)) + (define tdelay (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sleep 0.1) + (with-continuation-mark + break-enabled-key + (make-thread-cell #t) + (begin + ;(check-for-break) + (let loop () (loop)))))))) + (stop-thread tdelay) + (check tdelay (sync tdelay)) + (report-expected-break) + (unless kill? + (check #t ((current-inexact-milliseconds) . >= . (+ now3 0.1)))) + + ;; Check that a semaphore wait can be abandoned + (define tstuck (thread (lambda () (semaphore-wait (make-semaphore))))) + (sync (system-idle-evt)) + (stop-thread tstuck) + (check tstuck (sync tstuck)) + (report-expected-break) + + ;; Check that an externally abanoned `sync` posts nacks + (define nack1 #f) + (define nack2 #f) + (define tstuck2 (thread (lambda () + (sync (nack-guard-evt + (lambda (s) (set! nack1 s) never-evt)) + (nack-guard-evt + (lambda (s) (set! nack2 s) never-evt)))))) + (sync (system-idle-evt)) + (stop-thread tstuck2) + (thread-wait tstuck2) + (report-expected-break) + (check (void) (sync nack1)) + (check (void) (sync nack2)) + + ;; Make sure a `sync` can be abandoned during a guard callback + (define tfail (thread (lambda () + (sync (nack-guard-evt + (lambda (s) + (set! nack1 s) + (if kill? + (kill-thread (current-thread)) + (error "oops")))))))) + (check tfail (sync tfail)) + (report-expected-exn "oops") + (check (void) (sync nack1)) + + ;; Make sure nested abandoned `syncs` are ok + (define tfail2 (thread (lambda () + (sync (nack-guard-evt + (lambda (s) + (set! nack1 s) + (sync (nack-guard-evt + (lambda (s) + (set! nack2 s) + (if kill? + (kill-thread (current-thread)) + (error "oops"))))))))))) + (check tfail2 (sync tfail2)) + (report-expected-exn "oops") + (check (void) (sync nack1)) + (check (void) (sync nack2))) + + (check-break/kill #:kill? #f) + (check-break/kill #:kill? #t) + + ;; Check that an ignored break doesn't interfere with semaphore waiting, etc. + (define (check-ignore-break-retry make-trigger trigger-post trigger-wait) + (define s/nb (make-trigger)) + (define done?/nb #f) + (define t/nb (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (trigger-wait s/nb) + (set! done?/nb #t))))) + (sync (system-idle-evt)) + (break-thread t/nb) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/nb)) + (check #f done?/nb) + (trigger-post s/nb) + (sync (system-idle-evt)) + (check t/nb (sync/timeout 0 t/nb)) + (check #t done?/nb)) + + (check-ignore-break-retry make-semaphore semaphore-post sync) + (check-ignore-break-retry make-semaphore semaphore-post semaphore-wait) + (check-ignore-break-retry make-channel (lambda (c) (channel-put c 'go)) channel-get) + (check-ignore-break-retry make-channel channel-get (lambda (c) (channel-put c 'go))) + (check-ignore-break-retry (lambda () (box #f)) + (lambda (b) (thread-resume (unbox b))) + (lambda (b) (set-box! b (current-thread)) (thread-suspend (current-thread)))) + (check-ignore-break-retry (lambda () (box #f)) + (lambda (b) (thread-send (unbox b) 'ok)) + (lambda (b) (set-box! b (current-thread)) (thread-receive))) + + ;; Check suspending and resuming a thread that is waiting on a semaphore + (check #f (sync/timeout 0 s2)) + (define t/sw (thread + (lambda () + (sync s2)))) + (check t/sw (sync (thread-resume-evt t/sw))) + (define t/sw-s-evt (thread-suspend-evt t/sw)) + (check #f (sync/timeout 0 t/sw-s-evt)) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/sw)) + (thread-suspend t/sw) + (check t/sw (sync/timeout 0 t/sw-s-evt)) + (check #f (sync/timeout 0 t/sw)) + (semaphore-post s2) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/sw)) + (thread-resume t/sw) + (check t/sw (sync t/sw)) + (check #f (sync/timeout 0 s2)) + + ;; Check suspending and resuming a thread that is waiting on a message + (define (check-suspend-thread-receive send-after-resume?) + (define t/sr (thread + (lambda () + (channel-put ch (thread-receive))))) + (sync (system-idle-evt)) + (thread-suspend t/sr) + (unless send-after-resume? + (thread-send t/sr 'ok)) + (check #f (sync/timeout 0 ch)) + (check #f (sync/timeout 0 t/sr)) + (thread-resume t/sr) + (when send-after-resume? + (thread-send t/sr 'ok)) + (check 'ok (sync ch))) + (check-suspend-thread-receive #t) + (check-suspend-thread-receive #f) + + ;; Check sync/enable-break => break + (define tbe (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sync/enable-break (make-semaphore)))))) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 tbe)) + (break-thread tbe) + (sync (system-idle-evt)) + (check tbe (sync/timeout 0 tbe)) + (printf "[That break was from a thread, and it's expected]\n") + + ;; Check sync/enable-break => semaphore + (check #f (sync/timeout 0 s2)) + (define tbe2 (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sync/enable-break s2))))) + (sync (system-idle-evt)) + (semaphore-post s2) ; => chooses `s2` in `sync/enable-break` + (break-thread tbe2) + (sync (system-idle-evt)) + (check tbe2 (sync/timeout 0 tbe2)) + (check #f (sync/timeout 0 s2)) + + ;; Check call-with-semaphore + (semaphore-post s2) + (check #f (call-with-semaphore s2 (lambda () (sync/timeout 0 s2)))) + (check s2 (sync/timeout 0 s2)) + (define t/cws (thread (lambda () (call-with-semaphore s2 (lambda () (error "shouldn't get here")))))) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/cws)) + (break-thread t/cws) + (sync (system-idle-evt)) + (printf "[That break was from a thread, and it's expected]\n") + (check t/cws (sync/timeout 0 t/cws)) + + ;; Check call-in-nested-thread + (check 10 (call-in-nested-thread (lambda () 10))) + (check '(1 2) (call-with-values (lambda () + (call-in-nested-thread (lambda () (values 1 2)))) + list)) + + ;; Custodians + (define c (make-custodian)) + (define cb (make-custodian-box c'running)) + (check 'running (custodian-box-value cb)) + (custodian-shutdown-all c) + (check #f (custodian-box-value cb)) + (custodian-shutdown-all c) + + (define c2 (make-custodian)) + (define t/cust (parameterize ([current-custodian c2]) + (thread (lambda () (sync (make-semaphore)))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/cust)) + (custodian-shutdown-all c2) + (check #f (thread-running? t/cust)) + + (define c3 (make-custodian)) + (define c4 (make-custodian c3)) + (define t/cust2 (parameterize ([current-custodian c4]) + (thread (lambda () (sync (make-semaphore)))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/cust2)) + (custodian-shutdown-all c3) + (check #f (thread-running? t/cust2)) + + (define c5-1 (make-custodian)) + (define c5-2 (make-custodian)) + (define t/custs (parameterize ([current-custodian c5-1]) + (thread (lambda () (sync (make-semaphore)))))) + (thread-resume t/custs c5-2) + (sync (system-idle-evt)) + (check #t (thread-running? t/custs)) + (custodian-shutdown-all c5-1) + (check #t (thread-running? t/custs)) + (custodian-shutdown-all c5-2) + (check #f (thread-running? t/custs)) + + (define c6-1 (make-custodian)) + (define c6-2 (make-custodian)) + (define s6 (make-semaphore)) + (define r6 #f) + (define t/s2k (parameterize ([current-custodian c6-1]) + (thread/suspend-to-kill (lambda () (sync s6) (set! r6 'complete))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/s2k)) + (custodian-shutdown-all c6-1) + (check #f (thread-running? t/s2k)) + (check #f (thread-dead? t/s2k)) + (thread-resume t/s2k c6-2) + (check #t (thread-running? t/s2k)) + (semaphore-post s6) + (sync t/s2k) + (check 'complete r6) + + (define t/r1 (thread (lambda () (sync (make-semaphore))))) + (define t/r2 (thread (lambda () (sync (make-semaphore))))) + (thread-resume t/r2 t/r1) + (thread-suspend t/r2) + (check #f (thread-running? t/r2)) + (check #f (thread-dead? t/r2)) + (thread-resume t/r1) + (check #f (thread-running? t/r2)) ; because `t/r1` was not suspended + (thread-suspend t/r1) + (thread-resume t/r1) + (check #t (thread-running? t/r2)) + (kill-thread t/r1) + (kill-thread t/r2) + + ;; Check will executors + (define we (make-will-executor)) + (check #t (will-executor? we)) + (check #f (will-try-execute we)) + (check (void) (will-register we (gensym) (lambda (s) s))) + (collect-garbage) + (check #t (symbol? (will-try-execute we))) + (check #f (will-try-execute we)) + (check (void) (will-register we (gensym) (lambda (s) s))) + (thread (lambda () (sync (system-idle-evt)) (collect-garbage))) + (check #t (symbol? (will-execute we))) + + (set! done? #t))) + +(unless done? + (error "main thread stopped running due to deadlock?")) diff -Nru racket-6.12+ppa1/src/thread/engine.rkt racket-7.0+ppa1/src/thread/engine.rkt --- racket-6.12+ppa1/src/thread/engine.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/engine.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,75 @@ +#lang racket/base +(require racket/private/primitive-table + "internal-error.rkt" + (only-in '#%linklet primitive-table) + (for-syntax racket/base)) + +(void (unless (primitive-table '#%engine) + (internal-error "engines not provided by host"))) +(void (unless (primitive-table '#%pthread) + (internal-error "pthreads not provided by host"))) + +(define-syntax (bounce stx) + (syntax-case stx () + [(_ table bind ...) + (with-syntax ([([orig-id here-id] ...) + (for/list ([bind (in-list (syntax->list #'(bind ...)))]) + (if (identifier? bind) + (list bind bind) + bind))]) + #'(begin + (provide here-id ...) + (import-from-primitive-table table bind ...)))])) + +;; This `#%pthread` table's entries are linked more directly +;; than `#%engine` entries: +(bounce #%pthread + make-pthread-parameter) + +(bounce #%engine + make-engine + engine-block + engine-return + current-engine-state + current-process-milliseconds + set-ctl-c-handler! + root-continuation-prompt-tag + break-enabled-key + set-break-enabled-transition-hook! + [continuation-marks host:continuation-marks] + + [poll-will-executors host:poll-will-executors] + [make-will-executor host:make-will-executor] + [make-stubborn-will-executor host:make-stubborn-will-executor] + [will-executor? host:will-executor?] + [will-register host:will-register] + [will-try-execute host:will-try-execute] + + ;; Just `exn:break`, etc., but the host may need + ;; to distinguish breaks raised by the thread + ;; implementation: + exn:break/non-engine + exn:break:hang-up/non-engine + exn:break:terminate/non-engine + + ;; Check for async foreign callbacks: + [poll-async-callbacks host:poll-async-callbacks] + + ;; Disabling interrupts prevents a race with interrupt handlers. + ;; For example, if a GC is handled as an interrupt, then disabling + ;; interrupts prevents a race with a GC handler, and aything that + ;; disables interrupts can be used from a GC handler. + [disable-interrupts host:disable-interrupts] + [enable-interrupts host:enable-interrupts] + + fork-pthread + pthread? + [get-thread-id get-pthread-id] + [make-condition chez:make-condition] + [condition-wait chez:condition-wait] + [condition-signal chez:condition-signal] + [condition-broadcast chez:condition-broadcast] + [make-mutex chez:make-mutex] + [mutex-acquire chez:mutex-acquire] + [mutex-release chez:mutex-release] + threaded?) diff -Nru racket-6.12+ppa1/src/thread/evt.rkt racket-7.0+ppa1/src/thread/evt.rkt --- racket-6.12+ppa1/src/thread/evt.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/evt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,189 @@ +#lang racket/base +(require "atomic.rkt") + +(provide prop:evt + evt? + evt-poll + + (rename-out [the-never-evt never-evt] + [the-always-evt always-evt] + [the-async-evt async-evt]) + never-evt? + async-evt? + + (struct-out wrap-evt) + (struct-out handle-evt) + (struct-out control-state-evt) + (struct-out poll-guard-evt) + (struct-out choice-evt) + + (struct-out poller) + (struct-out poll-ctx) + + (struct-out delayed-poll) + + prop:secondary-evt + poller-evt + + evt-impersonator?) + +(module+ for-chaperone + (provide primary-evt? primary-evt-ref + secondary-evt? secondary-evt-ref + impersonator-prop:evt)) + +(define-values (prop:evt primary-evt? primary-evt-ref) + (make-struct-type-property 'evt + (lambda (v info) + (define who '|guard-for-prop:evt|) + (cond + [(poller? v) v] ; part of the internal API, not the safe API + [(evt? v) v] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [(exact-nonnegative-integer? v) + (define init-count (cadr info)) + (unless (v . < . init-count) + (raise-arguments-error who + "index for immutable field >= initialized-field count" + "index" v + "initialized-field count" init-count)) + (unless (memv v (list-ref info 5)) + (raise-arguments-error who "field index not declared immutable" + "field index" v)) + (selector-prop-evt-value + (make-struct-field-accessor (list-ref info 3) v))] + [else + (raise-argument-error who + "(or/c evt? (procedure-arity-includes/c 1) exact-nonnegative-integer?)" + v)])))) + +(struct selector-prop-evt-value (selector) + #:authentic) + +;; `prop:secondary-evt` is for primitive property types that +;; (due to histoical, bad design choices) act like `prop:evt` +;; without implying `prop:evt`. Specifically, it's used for +;; input and output ports. +(define-values (prop:secondary-evt secondary-evt? secondary-evt-ref) + (make-struct-type-property 'secondary-evt)) + +(define (evt? v) + (or (primary-evt? v) + (secondary-evt? v))) + +;; A poller as a `prop:evt` value wraps a procedure that is called +;; in atomic mode +;; evt poll-ctx -> (values results-or-#f replacing-evt-or-#f) +;; where either a list of results is returned, indicating +;; that the event is selected, or a replacement event +;; is returned (possibly unchanged). If the replacement event +;; is a wrapper on `always-evt`, it will certainly be selected. +;; If a poller does any work that can allow some thread to +;; become unblocked, then it must tell the scheduler via +;; `schedule-info-did-work!`. +(struct poller (proc)) + +;; Provided to a `poller` function: +(struct poll-ctx (poll? ; whether events are being polled once (i.e., 0 timeout) + select-proc ; callback to asynchronously select the event being polled + sched-info ; instructions to the scheduler, such as timeouts + [incomplete? #:mutable])) ; #t => getting back the same event does not imply a completed poll +;; If a `poller` callback keeps `select-proc` for asynchronous use, +;; then it should return a `control-state-evt` to ensure that +;; `select-proc` is not called if the event is abandoned. + +(struct never-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self)))) +(define the-never-evt (never-evt)) + +(struct always-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values (list self) #f)))) +(define the-always-evt (always-evt)) + +;; A placeholder for an event that will be selected through a callback +;; instead of polling: +(struct async-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self)))) +(define the-async-evt (async-evt)) + +(struct wrap-evt (evt wrap) + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self))) + #:reflection-name 'evt) +(struct handle-evt wrap-evt ()) + +;; A `control-state-evt` enables (unsafe) cooperation with the +;; scheduler, normally produced by a `poller` callback. The `evt` is +;; typically a wrapper on `async-evt`. If the event is not selected, +;; the `interrupt-proc` plus `abandon-proc` will be called. If a +;; synchronization attempt is interrupted by a break signal, then +;; `interrupt-proc` is called, and then either `abandon-proc` or +;; `retry-proc` --- the latter when the synchronization attempt +;; continues, in which case a value might be ready immediately or the +;; event goes back to some waiting state. For example, a sempahore +;; uses `interrupt-proc` to get out of the semaphore's queue and +;; `rety-proc` gets back in line (or immediately returns if the +;; semaphore was meanwhile posted). As another example, a +;; `nack-guard-evt`'s result uses `abandon-proc` to post to the NACK +;; event. +(struct control-state-evt (evt + interrupt-proc ; thunk for break/kill initiated or otherwise before `abandon-proc` + abandon-proc ; thunk for not selected, including break/kill complete + retry-proc) ; thunk for resume from break; return `(values _val _ready?)` + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self)))) + +(struct poll-guard-evt (proc) + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self))) + #:reflection-name 'evt) + +(struct choice-evt (evts) + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self))) + #:reflection-name 'evt) + +(define-values (impersonator-prop:evt evt-impersonator? evt-impersonator-ref) + (make-impersonator-property 'evt-impersonator)) + +;; Called in atomic mode +;; Checks whether an event is ready; returns the same results +;; as a poller. If getting an event requires going out of atomic mode +;; (to call a `prop:evt` procedure) then return a `delayed-poll` +;; struct. +(define (evt-poll evt poll-ctx) + (assert-atomic-mode) + (let* ([v (cond + [(evt-impersonator? evt) (evt-impersonator-ref evt)] + [(primary-evt? evt) + (primary-evt-ref evt)] + [else + (secondary-evt-ref evt)])] + [v (if (selector-prop-evt-value? v) + ((selector-prop-evt-value-selector v) evt) + v)]) + (cond + [(procedure? v) + (values #f (delayed-poll + ;; out of atomic mode: + (lambda () + (let ([v (call-with-continuation-barrier (lambda () (v evt)))]) + (cond + [(evt? v) v] + [(poller? v) (poller-evt v)] + [else (wrap-evt the-always-evt (lambda (v) evt))])))))] + [(poller? v) ((poller-proc v) evt poll-ctx)] + [(evt? v) (values #f v)] + [else (values #f the-never-evt)]))) + +;; Possible result from `evt-poll`: +(struct delayed-poll (resume)) + +(struct poller-evt (poller) + #:property prop:evt (struct-field-index poller)) diff -Nru racket-6.12+ppa1/src/thread/exit.rkt racket-7.0+ppa1/src/thread/exit.rkt --- racket-6.12+ppa1/src/thread/exit.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/exit.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,29 @@ +#lang racket/base +(require (only-in racket/base + [exit host:exit]) + "../common/check.rkt" + "plumber.rkt") + +(provide exit + force-exit + exit-handler) + +(define/who exit-handler + (make-parameter (let ([root-plumber (current-plumber)]) + (lambda (v) + (plumber-flush-all root-plumber) + (force-exit v))) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define (force-exit v) + (cond + [(byte? v) + (host:exit v)] + [else + (host:exit 0)])) + +(define (exit [v #t]) + ((exit-handler) v) + (void)) diff -Nru racket-6.12+ppa1/src/thread/fsemaphore.rkt racket-7.0+ppa1/src/thread/fsemaphore.rkt --- racket-6.12+ppa1/src/thread/fsemaphore.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/fsemaphore.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,32 @@ +#lang racket/base +(require "check.rkt" + "semaphore.rkt") + +(provide fsemaphore? + make-fsemaphore + fsemaphore-post + fsemaphore-wait + fsemaphore-try-wait? + fsemaphore-count) + +(struct fsemaphore (sema)) + +(define/who (make-fsemaphore init) + (check who exact-nonnegative-integer? init) + (fsemaphore (make-semaphore init))) + +(define/who (fsemaphore-post fsema) + (check who fsemaphore? fsema) + (semaphore-post (fsemaphore-sema fsema))) + +(define/who (fsemaphore-wait fsema) + (check who fsemaphore? fsema) + (semaphore-wait (fsemaphore-sema fsema))) + +(define/who (fsemaphore-try-wait? fsema) + (check who fsemaphore? fsema) + (semaphore-try-wait? (fsemaphore-sema fsema))) + +(define/who (fsemaphore-count fsema) + (check who fsemaphore? fsema) + 0) diff -Nru racket-6.12+ppa1/src/thread/future.rkt racket-7.0+ppa1/src/thread/future.rkt --- racket-6.12+ppa1/src/thread/future.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/future.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,417 @@ +#lang racket/base + +(require "check.rkt" + "internal-error.rkt" + "engine.rkt" + "atomic.rkt" + "parameter.rkt" + "../common/queue.rkt" + "thread.rkt" + "lock.rkt") + +(provide futures-enabled? + processor-count + current-future + future + future? + would-be-future + touch + future-block + future-wait + current-future-prompt + future:condition-broadcast + future:condition-signal + future:condition-wait + future:make-condition + signal-future + reset-future-logs-for-tracing! + mark-future-trace-end!) + +;; not sure of order here... +(define (get-caller) + (cond + [(current-future) + (current-future)] + [(not (= 0 (get-pthread-id))) + (get-pthread-id)] + [else + (current-thread)])) + + +;; ---------------------------- futures ---------------------------------- + + +(define ID (box 1)) + +(define get-next-id + (lambda () + (let ([id (unbox ID)]) + (if (box-cas! ID id (+ 1 id)) + id + (get-next-id))))) + +(define (processor-count) + 1) + +(define futures-enabled? threaded?) + +(struct future* (id cond lock prompt + would-be? [thunk #:mutable] [engine #:mutable] + [cont #:mutable] [result #:mutable] [done? #:mutable] + [blocked? #:mutable][resumed? #:mutable] + [cond-wait? #:mutable])) + +(define (create-future would-be-future?) + (future* (get-next-id) ;; id + (future:make-condition) ;; cond + (make-lock) ;; lock + (make-continuation-prompt-tag 'future) ;; prompt + would-be-future? ;; would-be? + #f ;; thunk + #f ;; engine + #f ;; cont + #f ;; result + #f ;; done? + #f ;; blocked? + #f ;; resumed? + #f)) ;; cond-wait? + +(define future? future*?) + +(define current-future (make-pthread-parameter #f)) + +(define (current-future-prompt) + (if (current-future) + (future*-prompt (current-future)) + (internal-error "Not running in a future."))) + +(define (thunk-wrapper f thunk) + (lambda () + (call-with-continuation-prompt + (lambda () + (let ([result (thunk)]) + (with-lock ((future*-lock f) (current-future)) + (set-future*-result! f result) + (set-future*-done?! f #t) + (future:condition-broadcast (future*-cond f))))) + (future*-prompt f)))) + +(define/who (future thunk) + (check who (procedure-arity-includes/c 0) thunk) + (cond + [(not (futures-enabled?)) + (would-be-future thunk)] + [else + (let ([f (create-future #f)]) + (set-future*-engine! f (make-engine (thunk-wrapper f thunk) #f #t)) + (schedule-future f) + f)])) + +(define/who (would-be-future thunk) + (check who (procedure-arity-includes/c 0) thunk) + (let ([f (create-future #t)]) + (set-future*-thunk! f (thunk-wrapper f thunk)) + f)) + +(define/who (touch f) + (check who future*? f) + (cond + [(future*-done? f) + (future*-result f)] + [(future*-would-be? f) + ((future*-thunk f)) + (future*-result f)] + [(lock-acquire (future*-lock f) (get-caller) #f) ;; got lock + (when (or (and (not (future*-blocked? f)) (not (future*-done? f))) + (and (future*-blocked? f) (not (future*-cont f)))) + (future:condition-wait (future*-cond f) (future*-lock f))) + (future-awoken f)] + [else + (touch f)])) + +(define (future-awoken f) + (cond + [(future*-done? f) ;; someone else ran continuation + (lock-release (future*-lock f) (get-caller)) + (future*-result f)] + [(future*-blocked? f) ;; we need to run continuation + (set-future*-blocked?! f #f) + (set-future*-resumed?! f #t) + (lock-release (future*-lock f) (get-caller)) + ((future*-cont f) '()) + (future*-result f)] + [else + (internal-error "Awoken but future is neither blocked nor done.")])) + +;; called from chez layer. +(define (future-block) + (define f (current-future)) + (when (and f (not (future*-blocked? f)) (not (future*-resumed? f))) + (with-lock ((future*-lock f) f) + (set-future*-blocked?! f #t)) + (engine-block))) + +;; called from chez layer. +;; this should never be called from outside a future. +(define (future-wait) + (define f (current-future)) + (with-lock ((future*-lock f) f) + (future:condition-wait (future*-cond f) (future*-lock f)))) + +;; futures and conditions + +(define (wait-future f m) + (with-lock ((future*-lock f) f) + (set-future*-cond-wait?! f #t)) + (lock-release m (get-caller)) + (engine-block)) + +(define (awaken-future f) + (with-lock ((future*-lock f) (get-caller)) + (set-future*-cond-wait?! f #f))) + +;; --------------------------- conditions ------------------------------------ + +(struct future-condition* (queue lock)) + +(define (future:make-condition) + (future-condition* (make-queue) (make-lock))) + +(define (future:condition-wait c m) + (define caller (get-caller)) + (if (own-lock? m caller) + (begin + (with-lock ((future-condition*-lock c) caller) + (queue-add! (future-condition*-queue c) caller)) + (if (future? caller) + (wait-future caller m) + (thread-condition-wait (lambda () (lock-release m caller)))) + (lock-acquire m (get-caller))) ;; reaquire lock + (internal-error "Caller does not hold lock\n"))) + +(define (signal-future f) + (future:condition-signal (future*-cond f))) + +(define (future:condition-signal c) + (with-lock ((future-condition*-lock c) (get-caller)) + (let ([waitees (future-condition*-queue c)]) + (unless (queue-empty? waitees) + (let ([waitee (queue-remove! waitees)]) + (if (future? waitee) + (awaken-future waitee) + (thread-condition-awaken waitee))))))) + +(define (future:condition-broadcast c) + (with-lock ((future-condition*-lock c) (get-caller)) + (define waitees '()) + (queue-remove-all! (future-condition*-queue c) + (lambda (e) + (set! waitees (cons e waitees)))) + (let loop ([q waitees]) + (unless (null? q) + (let ([waitee (car q)]) + (if (future? waitee) + (awaken-future waitee) + (thread-condition-awaken waitee)) + (loop (cdr q))))))) + +;; ------------------------------------- future scheduler ---------------------------------------- + +(define THREAD-COUNT 2) +(define TICKS 1000000000) + +(define global-scheduler #f) +(define (scheduler-running?) + (not (not global-scheduler))) + +(struct worker (id lock mutex cond + [queue #:mutable] [idle? #:mutable] + [pthread #:mutable #:auto] [die? #:mutable #:auto]) + #:auto-value #f) + +(struct scheduler ([workers #:mutable #:auto]) + #:auto-value #f) + +;; I think this atomically is sufficient to guarantee scheduler is only created once. +(define (maybe-start-scheduler) + (atomically + (unless global-scheduler + (set! global-scheduler (scheduler)) + (let ([workers (create-workers)]) + (set-scheduler-workers! global-scheduler workers) + (start-workers workers))))) + +(define (kill-scheduler) + (when global-scheduler + (for-each (lambda (w) + (with-lock ((worker-lock w) (get-caller)) + (set-worker-die?! w #t))) + (scheduler-workers global-scheduler)))) + +(define (create-workers) + (let loop ([id 1]) + (cond + [(< id (+ 1 THREAD-COUNT)) + (cons (worker id (make-lock) (chez:make-mutex) (chez:make-condition) (make-queue) #t) + (loop (+ id 1)))] + [else + '()]))) + +;; When a new thread is forked it inherits the values of thread parameters from its creator +;; So, if current-atomic is set for the main thread and then new threads are forked, those new +;; threads current-atomic will be set and then never unset because they will not run code that +;; unsets it. +(define (start-workers workers) + (for-each (lambda (w) + (set-worker-pthread! w (fork-pthread (lambda () + (current-atomic 0) + (current-thread #f) + (current-engine-state #f) + (current-future #f) + ((worker-scheduler-func w)))))) + workers)) + +(define (schedule-future f) + (maybe-start-scheduler) + + (let ([w (pick-worker)]) + (with-lock ((worker-lock w) (get-caller)) + (chez:mutex-acquire (worker-mutex w)) + (queue-add! (worker-queue w) f) + (chez:condition-signal (worker-cond w)) + (chez:mutex-release (worker-mutex w))))) + +(define (pick-worker) + (define workers (scheduler-workers global-scheduler)) + (let loop ([workers* (cdr workers)] + [best (car workers)]) + (cond + [(or (null? workers*) + (queue-empty? (worker-queue best))) + best] + [(< (queue-length (worker-queue (car workers*))) + (queue-length (worker-queue best))) + (loop (cdr workers*) + (car workers*))] + [else + (loop (cdr workers*) + best)]))) + +(define (wait-for-work w) + (define m (worker-mutex w)) + (let try () + (cond + [(not (queue-empty? (worker-queue w))) ;; got work in meantime + (void)] + [(chez:mutex-acquire m #f) ;; cannot acquire lock while worker is being given work. + (chez:condition-wait (worker-cond w) m) + (chez:mutex-release m)] + [else ;; try to get lock again. + (try)]))) + +(define (worker-scheduler-func worker) + (lambda () + + (define (loop) + (lock-acquire (worker-lock worker) (get-pthread-id)) ;; block + (cond + [(worker-die? worker) ;; worker was killed + (lock-release (worker-lock worker) (get-pthread-id))] + [(queue-empty? (worker-queue worker)) ;; have lock. no work + (lock-release (worker-lock worker) (get-pthread-id)) + (cond + [(steal-work worker) + (do-work)] + [else + (wait-for-work worker)]) + (loop)] + [else + (do-work) + (loop)])) + + (define (complete ticks args) + (void)) + + (define (expire future worker) + (lambda (new-eng) + (set-future*-engine! future new-eng) + (cond + [(positive? (current-atomic)) + ((future*-engine future) TICKS (prefix future) complete (expire future worker))] + [(future*-resumed? future) ;; run to completion + ((future*-engine future) TICKS void complete (expire future worker))] + [(not (future*-cont future)) ;; don't want to reschedule future with a saved continuation + (with-lock ((worker-lock worker) (get-caller)) + (chez:mutex-acquire (worker-mutex worker)) + (queue-add! (worker-queue worker) future) + (chez:mutex-release (worker-mutex worker)))] + [else + (with-lock ((future*-lock future) (get-caller)) + (future:condition-signal (future*-cond future)))]))) + + (define (prefix f) + (lambda () + (when (future*-blocked? f) + (call-with-composable-continuation + (lambda (k) + (with-lock ((future*-lock f) (current-future)) + (set-future*-cont! f k)) + (engine-block)) + (future*-prompt f))))) + + + ;; need to have lock here. + (define (do-work) + (let ([work (queue-remove! (worker-queue worker))]) + (cond + [(future*-cond-wait? work) + (queue-add! (worker-queue worker) work) + (lock-release (worker-lock worker) (get-pthread-id))] ;; put back on queue + [else + (lock-release (worker-lock worker) (get-pthread-id)) + (current-future work) + ((future*-engine work) TICKS (prefix work) complete (expire work worker)) ;; call engine. + (current-future #f)]))) + + (loop))) + +(define (order-workers w1 w2) + (cond + [(< (worker-id w1) (worker-id w2)) + (values w1 w2)] + [else + (values w2 w1)])) + + ;; Acquire lock of peer with smallest id # first. + ;; worker is attempting to steal work from peers + (define (steal-work worker) + (let loop ([q (scheduler-workers global-scheduler)]) + (cond + [(null? q) #f] ;; failed to steal work. + [(not (eq? (worker-id worker) (worker-id (car q)))) ;; not ourselves + (let*-values ([(peer) (car q)] + [(w1 w2) (order-workers worker peer)]) ;; order them. + (lock-acquire (worker-lock w1) (get-pthread-id)) + (lock-acquire (worker-lock w2) (get-pthread-id)) + (cond + [(> (queue-length (worker-queue peer)) 2) ;; going to steal. Should likely made this # higher. + (do ([i (floor (/ (queue-length (worker-queue peer)) 2)) (- i 1)]) + [(zero? i) (void)] + (let ([work (queue-remove-end! (worker-queue peer))]) + (queue-add! (worker-queue worker) work))) + + (lock-release (worker-lock peer) (get-pthread-id)) ;; don't want to release our own lock. + #t] ;; stole work + [else ;; try a different peer + (lock-release (worker-lock worker) (get-pthread-id)) + (lock-release (worker-lock peer) (get-pthread-id)) + (loop (cdr q))]))] + [else (loop (cdr q))]))) + +;; ---------------------------------------- + +(define (reset-future-logs-for-tracing!) + (void)) + +(define (mark-future-trace-end!) + (void)) diff -Nru racket-6.12+ppa1/src/thread/impersonator.rkt racket-7.0+ppa1/src/thread/impersonator.rkt --- racket-6.12+ppa1/src/thread/impersonator.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/impersonator.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,107 @@ +#lang racket/base +(require "check.rkt" + "internal-error.rkt" + "evt.rkt" + (submod "evt.rkt" for-chaperone) + "channel.rkt" + (submod "channel.rkt" for-impersonator)) + +(provide chaperone-evt + chaperone-channel + impersonate-channel) + +;; ---------------------------------------- + +(define/who (chaperone-evt evt proc . args) + (check who evt? evt) + (check proc (procedure-arity-includes/c 1) proc) + (do-chaperone-evt who "evt" #t evt proc args + (lambda (v) + (unless (evt? v) + (raise-result-error who "evt?" v))))) + +(define (do-chaperone-evt who what chaperone? evt proc args check-evt) + (check-impersonator-properties who args) + (apply chaperone-struct + evt + (cond + [(primary-evt? evt) primary-evt-ref] + [(secondary-evt? evt) secondary-evt-ref] + [else (internal-error "unrecognized evt to impersonate")]) + (lambda (evt v) v) + impersonator-prop:evt + (lambda (also-evt) + (call-with-values (lambda () (proc evt)) + (case-lambda + [(new-evt wrap) + (when chaperone? + (check-chaperone-of what new-evt evt)) + (check-evt new-evt) + (unless (and (procedure? wrap) + (procedure-arity-includes? wrap 1)) + (raise-result-error who "(procedure-arity-includes/c 1)" wrap)) + (handle-evt new-evt + (lambda (r) + (let ([new-r (wrap r)]) + (when chaperone? + (check-chaperone-of what new-r r)) + new-r)))] + [args + (raise + (exn:fail:contract:arity + (string-append + what " " (if chaperone? "chaperone" "impersonator") ": returned wrong number of values\n" + " expected count: 2\n" + " returned count: " (number->string (length args))) + (current-continuation-marks)))]))) + args)) + +;; ---------------------------------------- + +(define/who (chaperone-channel ch get-proc put-proc . args) + (do-impersonate-channel who #t ch get-proc put-proc args)) + +(define/who (impersonate-channel ch get-proc put-proc . args) + (do-impersonate-channel who #f ch get-proc put-proc args)) + +(define (do-impersonate-channel who chaperone? ch get-proc put-proc args) + (check who channel? ch) + (check who (procedure-arity-includes/c 1) get-proc) + (check who (procedure-arity-includes/c 2) put-proc) + (do-chaperone-evt who "channel" chaperone? ch get-proc + (list* impersonator-prop:channel-put + (cons ch (lambda (ch v) + (define new-v (put-proc ch v)) + (when chaperone? + (check-chaperone-of "channel" new-v v)) + new-v)) + args) + (lambda (v) + (unless (channel? v) + (raise-result-error who "channel?" v))))) + +;; ---------------------------------------- + +(define (check-chaperone-of what new-r r) + (unless (chaperone-of? new-r r) + (raise + (exn:fail:contract + (string-append + what " chaperone: non-chaperone result;\n" + " received a value that is not a chaperone of the original value\n" + " value: " ((error-value->string-handler) r) "\n" + " non-chaperone value: " + ((error-value->string-handler) new-r)) + (current-continuation-marks))))) + +(define (check-impersonator-properties who args) + (let loop ([args args]) + (unless (null? args) + (check who impersonator-property? (car args)) + (cond + [(null? args) + (raise-arguments-error who + "missing an argument after an impersonator-property argument" + "impersonator property" (car args))] + [else + (loop (cddr args))])))) diff -Nru racket-6.12+ppa1/src/thread/instance.rkt racket-7.0+ppa1/src/thread/instance.rkt --- racket-6.12+ppa1/src/thread/instance.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/instance.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,51 @@ +#lang racket/base +(require "evt.rkt" + "sync.rkt" + "semaphore.rkt" + "schedule-info.rkt" + "sandman.rkt" + "atomic.rkt" + "custodian.rkt" + "thread.rkt" + "time.rkt") + +;; Unsafe scheduler-cooperation functions are made available to +;; clients through a `#%thread` primitive linklet instance: + +(provide #%thread-instance) + +(define #%thread-instance + (hasheq 'make-semaphore make-semaphore + 'semaphore-post semaphore-post + 'semaphore-wait semaphore-wait + 'semaphore-peek-evt semaphore-peek-evt + 'wrap-evt wrap-evt + 'always-evt always-evt + 'choice-evt choice-evt + 'sync sync + 'sync/timeout sync/timeout + 'evt? evt? + 'sync-atomic-poll-evt? sync-atomic-poll-evt? + 'prop:evt prop:evt + 'prop:secondary-evt prop:secondary-evt + 'poller poller + 'poller-evt poller-evt + 'poll-ctx-poll? poll-ctx-poll? + 'poll-ctx-select-proc poll-ctx-select-proc + 'poll-ctx-sched-info poll-ctx-sched-info + 'set-poll-ctx-incomplete?! set-poll-ctx-incomplete?! + 'control-state-evt control-state-evt + 'async-evt async-evt + 'current-sandman current-sandman + 'schedule-info-current-exts schedule-info-current-exts + 'schedule-info-did-work! schedule-info-did-work! + 'start-atomic start-atomic + 'end-atomic end-atomic + 'start-atomic/no-interrupts start-atomic/no-interrupts + 'end-atomic/no-interrupts end-atomic/no-interrupts + 'current-custodian current-custodian + 'unsafe-custodian-register unsafe-custodian-register + 'unsafe-custodian-unregister unsafe-custodian-unregister + 'thread-push-kill-callback! thread-push-kill-callback! + 'thread-pop-kill-callback! thread-pop-kill-callback! + 'set-get-subprocesses-time! set-get-subprocesses-time!)) diff -Nru racket-6.12+ppa1/src/thread/internal-error.rkt racket-7.0+ppa1/src/thread/internal-error.rkt --- racket-6.12+ppa1/src/thread/internal-error.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/internal-error.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,7 @@ +#lang racket/base + +(provide internal-error) + +(define (internal-error s) + (raise (exn:fail (string-append "internal error: " s) + (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/src/thread/lock.rkt racket-7.0+ppa1/src/thread/lock.rkt --- racket-6.12+ppa1/src/thread/lock.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/lock.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,52 @@ +#lang racket/base + +(require "internal-error.rkt") + +(provide with-lock + make-lock + lock-acquire + lock-release + own-lock?) + +(define-syntax-rule (with-lock (lock caller) expr ...) + (begin + (lock-acquire lock caller) + (begin0 + (let () expr ...) + (lock-release lock caller)))) + +(struct future-lock* (box owner)) + +(define (lock-owner lock) + (unbox (future-lock*-owner lock))) + +(define (make-lock) + (future-lock* (box 0) (box #f))) + +(define (lock-acquire lock caller [block? #t]) + (define box (future-lock*-box lock)) + (let loop () + (cond + [(and (= 0 (unbox box)) (box-cas! box 0 1)) ;; got lock + (unless (box-cas! (future-lock*-owner lock) #f caller) + (internal-error "Lock already has owner.")) + #t] + [block? + (loop)] + [else + #f]))) + +(define (lock-release lock caller) + (when (eq? caller (unbox (future-lock*-owner lock))) + (unless (box-cas! (future-lock*-owner lock) caller #f) + (internal-error "Failed to reset owner\n")) + (unless (box-cas! (future-lock*-box lock) 1 0) + (internal-error "Lock release failed\n")))) + +(define (own-lock? lock caller) + (and (eq? caller (unbox (future-lock*-owner lock))) + (begin0 + #t + (unless (= 1 (unbox (future-lock*-box lock))) + (internal-error "Caller 'owns' lock but lock is free."))))) + diff -Nru racket-6.12+ppa1/src/thread/main.rkt racket-7.0+ppa1/src/thread/main.rkt --- racket-6.12+ppa1/src/thread/main.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/main.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,188 @@ +#lang racket/base +(require "thread.rkt" + "thread-group.rkt" + (only-in "evt.rkt" + evt? prop:evt + always-evt + never-evt) + "impersonator.rkt" + (except-in "semaphore.rkt" + semaphore-peek-evt) + "channel.rkt" + "sync.rkt" + "system-idle-evt.rkt" + "schedule.rkt" + "custodian.rkt" + "alarm.rkt" + "nested-thread.rkt" + "continuation-mark.rkt" + "api.rkt" + "will-executor.rkt" + "exit.rkt" + "plumber.rkt" + "unsafe.rkt" + "instance.rkt" + "time.rkt" + "stats.rkt" + "stack-size.rkt" + "future.rkt" + "fsemaphore.rkt" + "os-thread.rkt") + +(provide call-in-main-thread + + thread + thread/suspend-to-kill + call-in-nested-thread + thread? + current-thread + thread-running? + thread-dead? + thread-wait + thread-suspend + thread-resume + thread-suspend-evt + thread-resume-evt + thread-dead-evt + thread-dead-evt? + break-thread + kill-thread + thread-send + thread-receive + thread-try-receive + thread-rewind-receive + thread-receive-evt + + sleep + + make-thread-group + thread-group? + current-thread-group + + make-semaphore + semaphore-post + semaphore-wait + semaphore-try-wait? + semaphore? + semaphore-wait/enable-break + call-with-semaphore + call-with-semaphore/enable-break + + semaphore-peek-evt + semaphore-peek-evt? + + make-channel + channel? + channel-put + channel-get + channel-put-evt + channel-put-evt? + + sync + sync/timeout + sync/enable-break + sync/timeout/enable-break + current-evt-pseudo-random-generator + + evt? prop:evt + always-evt + never-evt + wrap-evt + handle-evt + handle-evt? + guard-evt + poll-guard-evt + nack-guard-evt + choice-evt + replace-evt + + chaperone-evt + chaperone-channel + impersonate-channel + + system-idle-evt + alarm-evt + + current-custodian + make-custodian + custodian? + custodian-shutdown-all + custodian-managed-list + make-custodian-box + custodian-box? + custodian-box-value + custodian-memory-accounting-available? + custodian-require-memory + custodian-limit-memory + custodian-shut-down? + + make-will-executor + make-stubborn-will-executor + will-executor? + will-register + will-try-execute + will-execute + + exit + exit-handler + + current-plumber + make-plumber + plumber? + plumber-flush-all + plumber-add-flush! + plumber-flush-handle? + plumber-flush-handle-remove! + + current-process-milliseconds + vector-set-performance-stats! + + current-thread-initial-stack-size + + break-enabled + check-for-break + break-enabled-key + + continuation-marks + + unsafe-start-atomic + unsafe-end-atomic + unsafe-start-breakable-atomic + unsafe-end-breakable-atomic + unsafe-in-atomic? + unsafe-set-on-atomic-timeout! + + unsafe-thread-at-root + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister + + futures-enabled? + processor-count + future + future? + touch + would-be-future + current-future + future-block + future-wait + current-future-prompt + reset-future-logs-for-tracing! + mark-future-trace-end! + + fsemaphore? + make-fsemaphore + fsemaphore-post + fsemaphore-wait + fsemaphore-try-wait? + fsemaphore-count + + unsafe-os-thread-enabled? + unsafe-call-in-os-thread + unsafe-make-os-semaphore + unsafe-os-semaphore-post + unsafe-os-semaphore-wait + + #%thread-instance) + +(module main racket/base) diff -Nru racket-6.12+ppa1/src/thread/Makefile racket-7.0+ppa1/src/thread/Makefile --- racket-6.12+ppa1/src/thread/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,33 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++direct pthread ++pure ../../collects/racket/private/collect.rkt + +thread-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) thread-src-generate + +GENERATE_ARGS = -t main.rkt --submod main \ + --check-depends $(BUILDDIR)compiled/thread-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/thread-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/thread.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +thread-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +.PHONY: thread-src thread-src-generate demo diff -Nru racket-6.12+ppa1/src/thread/nested-thread.rkt racket-7.0+ppa1/src/thread/nested-thread.rkt --- racket-6.12+ppa1/src/thread/nested-thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/nested-thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,103 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "thread.rkt" + (except-in (submod "thread.rkt" scheduling) + thread + thread-dead-evt) + "custodian.rkt" + "semaphore.rkt") + +(provide call-in-nested-thread) + +(define/who (call-in-nested-thread thunk [cust (current-custodian)]) + (check who (procedure-arity-includes/c 0) thunk) + (check who custodian? cust) + (define init-break-cell (current-break-enabled-cell)) + (define result #f) + (define result-kind #f) + (define ready-sema (make-semaphore)) + (define t + ;; Disable breaks while we set up the thread + (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (do-make-thread + 'call-in-nested-thread + (lambda () + (semaphore-wait ready-sema) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (set! result-kind 'exn) + (set! result x))]) + (with-continuation-mark + break-enabled-key + init-break-cell + (begin + ;; Breaks can only happen here, and kills + ;; can only happen after here + (set! result (call-with-continuation-barrier + (lambda () + (call-with-values (lambda () + (call-with-continuation-prompt + thunk + (default-continuation-prompt-tag) + (lambda (thunk) + (abort-current-continuation + (default-continuation-prompt-tag) + thunk)))) + list)))) + ;; Atomically decide that we have a value result and + ;; terminate the thread, so that there's not a race between + ;; detecting that the thread was killed versus deciding + ;; that the thread completed with a value + (atomically + (set! result-kind 'value) + (thread-dead! t)) + (engine-block))))) + #:custodian cust))) + (atomically + (set-thread-forward-break-to! (current-thread) t)) + (semaphore-post ready-sema) ; let the nested thread run + + ;; Wait for the nested thread to complete -- and any thread nested + ;; in that one at the time that it finished, and so on + (define pending-break + (let loop ([t t] [pending-break #f]) + (thread-wait t) + (define next-pending-break (break-max pending-break (thread-pending-break t))) + (let ([sub-t (thread-forward-break-to t)]) + (cond + [sub-t (loop sub-t next-pending-break)] + [else next-pending-break])))) + + ;; At this point, if `result-kind` is #f, then `t` was + ;; killed or aborted to the original continuation + + (atomically + (set-thread-forward-break-to! (current-thread) #f)) + + ;; Propagate any leftover break, but give a propagated + ;; exception priority over a break exception: + (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (begin + + (when pending-break + ;; Breaks are disabled at this point, so the break won't be + ;; signaled until `check-for-break` below + (break-thread (current-thread) (if (eq? pending-break 'break) #f pending-break))) + + (when (eq? result-kind 'exn) + (raise result)) + + (unless (eq? result-kind 'value) + (raise + (exn:fail + "call-in-nested-thread: the thread was killed, or it exited via the default error escape handler" + (current-continuation-marks)))))) + + (check-for-break) + (apply values result)) diff -Nru racket-6.12+ppa1/src/thread/os-thread.rkt racket-7.0+ppa1/src/thread/os-thread.rkt --- racket-6.12+ppa1/src/thread/os-thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/os-thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#lang racket/base +(require "check.rkt" + "engine.rkt" + "atomic.rkt") + +(provide unsafe-os-thread-enabled? + unsafe-call-in-os-thread + unsafe-make-os-semaphore + unsafe-os-semaphore-post + unsafe-os-semaphore-wait) + +(define (unsafe-os-thread-enabled?) + (threaded?)) + +(define/who (unsafe-call-in-os-thread proc) + (check who (procedure-arity-includes/c 0) proc) + (unless threaded? (raise-unsupported who)) + (fork-pthread (lambda () + (start-atomic) ; just in case + (proc))) + (void)) + +(struct os-semaphore ([count #:mutable] mutex condition)) + +(define/who (unsafe-make-os-semaphore) + (unless threaded? (raise-unsupported who)) + (os-semaphore 0 (chez:make-mutex) (chez:make-condition))) + +(define/who (unsafe-os-semaphore-post s) + (check who os-semaphore? s) + (chez:mutex-acquire (os-semaphore-mutex s)) + (when (zero? (os-semaphore-count s)) + (chez:condition-signal (os-semaphore-condition s))) + (set-os-semaphore-count! s (add1 (os-semaphore-count s))) + (chez:mutex-release (os-semaphore-mutex s))) + +;; interrupts must be enabled when waiting on a semaphore; otherwise, +;; the wait will block GCs, likely deadlocking this thread and another +;; thread that is working toward posting the semaphore +(define/who (unsafe-os-semaphore-wait s) + (check who os-semaphore? s) + (chez:mutex-acquire (os-semaphore-mutex s)) + (let loop () + (cond + [(zero? (os-semaphore-count s)) + (chez:condition-wait (os-semaphore-condition s) (os-semaphore-mutex s)) + (loop)] + [else + (set-os-semaphore-count! s (sub1 (os-semaphore-count s)))])) + (chez:mutex-release (os-semaphore-mutex s))) + +(define (raise-unsupported who) + (raise + (exn:fail:unsupported + (string-append (symbol->string who) ": unsupported on this platform") + (current-continuation-marks)))) diff -Nru racket-6.12+ppa1/src/thread/parameter.rkt racket-7.0+ppa1/src/thread/parameter.rkt --- racket-6.12+ppa1/src/thread/parameter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/parameter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require "engine.rkt") + +(provide current-thread) + +(define current-thread (make-pthread-parameter #f)) diff -Nru racket-6.12+ppa1/src/thread/plumber.rkt racket-7.0+ppa1/src/thread/plumber.rkt --- racket-6.12+ppa1/src/thread/plumber.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/plumber.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,50 @@ +#lang racket/base +(require "check.rkt") + +(provide current-plumber + make-plumber + plumber? + plumber-flush-all + plumber-add-flush! + plumber-flush-handle? + plumber-flush-handle-remove!) + +(struct plumber (callbacks ; hash table of handles -> callbacks + weak-callbacks) ; same, but weak references + #:authentic) + +(define (make-plumber) + (plumber (make-hasheq) + (make-weak-hasheq))) + +(define/who current-plumber + (make-parameter (make-plumber) + (lambda (v) + (check who plumber? v) + v))) + +(struct plumber-flush-handle (plumber)) + +(define/who (plumber-add-flush! p proc [weak? #f]) + (check who plumber? p) + (check who (procedure-arity-includes/c 1) proc) + (define h (plumber-flush-handle p)) + (hash-set! (if weak? + (plumber-weak-callbacks p) + (plumber-callbacks p)) + h + proc) + h) + +(define/who (plumber-flush-all p) + (check who plumber? p) + (for ([(h proc) (in-hash (plumber-callbacks p))]) + (proc h)) + (for ([(h proc) (in-hash (plumber-weak-callbacks p))]) + (proc h))) + +(define/who (plumber-flush-handle-remove! h) + (check who plumber-flush-handle? h) + (define p (plumber-flush-handle-plumber h)) + (hash-remove! (plumber-callbacks p) h) + (hash-remove! (plumber-weak-callbacks p) h)) diff -Nru racket-6.12+ppa1/src/thread/README.txt racket-7.0+ppa1/src/thread/README.txt --- racket-6.12+ppa1/src/thread/README.txt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/README.txt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,8 @@ +This thread implementation can be run in a host Racket with `make +demo`, but it's meant to be compiled for use in Racket on Chez Scheme; +see "../cs/README.txt". + +Core engine support must be provided by a more primitive layer. The +more primitive layer must also provide `break-enabled-key` and special +handling for looking up a mark with that key so that an egine-specific +default thread cell is produced. diff -Nru racket-6.12+ppa1/src/thread/sandman.rkt racket-7.0+ppa1/src/thread/sandman.rkt --- racket-6.12+ppa1/src/thread/sandman.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/sandman.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,218 @@ +#lang racket/base +(require "check.rkt" + "tree.rkt" + "internal-error.rkt" + "sandman-struct.rkt") + +;; A "sandman" manages the set of all sleeping threads that may need +;; to be awoken in response to an external event, and it implements +;; the process-wide `sleep` that waits for an external event. Timeouts +;; are the only external events recognized by the initial sandman, +;; and that is supported by the host system's `sleep` function. + +;; When a thread is registered with a sandman, the sandman provides a +;; handle representing the registration. The handle can be any value +;; except #f, and it is provided back to the sandman to unregister a +;; thread. A sandman doesn't unregister threads on its own, even when +;; it detects that an external event has happened. + +;; When `sync` determines that a thread should sleep, it accumulates +;; external-event specifications to provide to the sandman along with +;; the thread. For the initial sandman, this information is just a +;; maximum wake-up time, but a more sophisticated sandman might +;; support file-descriptor activity. Event implementations expect a +;; sandman that provides specific functionality, so all sandman +;; implementations need to support time. + +;; All sandman functions are called in atomic mode. + +;; See also "sandman-struct.rkt". + +(provide sandman-merge-timeout + sandman-merge-exts + sandman-add-sleeping-thread! + sandman-remove-sleeping-thread! + sandman-poll + sandman-sleep + sandman-any-sleepers? + sandman-sleepers-external-events + sandman-condition-wait + sandman-condition-poll + sandman-any-waiters? + + current-sandman) + +;; in atomic mode +(define (sandman-merge-timeout exts timeout) + ((sandman-do-merge-timeout the-sandman) exts timeout)) + +;; in atomic mode +(define (sandman-merge-exts a-exts b-exts) + ((sandman-do-merge-external-event-sets the-sandman) a-exts b-exts)) + +;; in atomic mode +(define (sandman-add-sleeping-thread! th exts) + ((sandman-do-add-thread! the-sandman) th exts)) + +;; in atomic mode +(define (sandman-remove-sleeping-thread! th h) + ((sandman-do-remove-thread! the-sandman) th h)) + +;; in atomic mode +(define (sandman-poll mode thread-wakeup) + ((sandman-do-poll the-sandman) mode thread-wakeup)) + +;; in atomic mode +(define (sandman-sleep exts) + ((sandman-do-sleep the-sandman) exts)) + +;; in atomic mode +(define (sandman-any-sleepers?) + ((sandman-do-any-sleepers? the-sandman))) + +;; in atomic mode +(define (sandman-sleepers-external-events) + ((sandman-do-sleepers-external-events the-sandman))) + +;; in atomic mode +(define (sandman-condition-wait thread) + ((sandman-do-condition-wait the-sandman) thread)) + +;; in atomic mode +(define (sandman-condition-poll mode thread-wakeup) + ((sandman-do-condition-poll the-sandman) mode thread-wakeup)) + +;; in atomic mode +(define (sandman-any-waiters?) + ((sandman-do-any-waiters? the-sandman))) + +;; in atomic mode +(define/who current-sandman + (case-lambda + [() the-sandman] + [(sm) + (check who sandman? sm) + (set! the-sandman sm)])) + +;; created simple lock here to avoid cycle in loading from using lock defined in future.rkt +(define (make-lock) + (box 0)) + +(define (lock-acquire box) + (let loop () + (unless (and (= 0 (unbox box)) (box-cas! box 0 1)) + (loop)))) + +(define (lock-release box) + (unless (box-cas! box 1 0) + (internal-error "Failed to release lock\n"))) + +(define waiting-threads '()) +(define awoken-threads '()) + +;; ---------------------------------------- +;; Default sandman implementation + +;; A tree mapping times (in milliseconds) to a hash table of threads +;; to wake up at that time +(define sleeping-threads empty-tree) + +(define (min* a-sleep-until b-sleep-until) + (if (and a-sleep-until b-sleep-until) + (min a-sleep-until b-sleep-until) + (or a-sleep-until b-sleep-until))) + +(define the-sandman + (sandman + ;; sleep + (lambda (timeout-at) + (sleep (/ (- (or timeout-at (distant-future)) (current-inexact-milliseconds)) 1000.0))) + + ;; poll + (lambda (mode wakeup) + ;; This check is fast, so do it in all modes + (unless (tree-empty? sleeping-threads) + (define-values (timeout-at threads) (tree-min sleeping-threads)) + (when (timeout-at . <= . (current-inexact-milliseconds)) + (unless (null? threads) + (for ([t (in-hash-keys threads)]) + (wakeup t)))))) + + ;; any-sleepers? + (lambda () + (not (tree-empty? sleeping-threads))) + + ;; sleepers-external-events + (lambda () + (and (not (tree-empty? sleeping-threads)) + (let-values ([(timeout-at threads) (tree-min sleeping-threads)]) + timeout-at))) + + ;; add-thread! + (lambda (t sleep-until) + (set! sleeping-threads + (tree-set sleeping-threads + sleep-until + (hash-set (or (tree-ref sleeping-threads sleep-until <) + #hasheq()) + t + #t) + <)) + sleep-until) + ;; remove-thread! + (lambda (t sleep-until) + (define threads (tree-ref sleeping-threads sleep-until <)) + (unless threads (internal-error "thread not found among sleeping threads")) + (define new-threads (hash-remove threads t)) + (set! sleeping-threads + (if (zero? (hash-count new-threads)) + (tree-remove sleeping-threads sleep-until <) + (tree-set sleeping-threads sleep-until new-threads <)))) + + ;; merge-exts + (lambda (a-sleep-until b-sleep-until) + (min* a-sleep-until b-sleep-until)) + + ;; merge-timeout + (lambda (sleep-until timeout-at) + (if sleep-until + (min sleep-until timeout-at) + timeout-at)) + ;; extract-timeout + (lambda (sleep-until) sleep-until) + + ;; condition-wait + (lambda (t) + (lock-acquire (sandman-lock the-sandman)) + (set! waiting-threads (cons t waiting-threads)) + (lock-release (sandman-lock the-sandman)) + ;; awoken callback. for when thread is awoken + (lambda (root-thread) + (lock-acquire (sandman-lock the-sandman)) + (if (memq t waiting-threads) + (begin + (set! waiting-threads (remove t waiting-threads eq?)) + (set! awoken-threads (cons t awoken-threads))) + (internal-error "thread is not a member of waiting-threads\n")) + (lock-release (sandman-lock the-sandman)))) + + ;; condition-poll + (lambda (mode wakeup) + (lock-acquire (sandman-lock the-sandman)) + (define at awoken-threads) + (set! awoken-threads '()) + (lock-release (sandman-lock the-sandman)) + (for-each (lambda (t) + (wakeup t)) at)) + + ;; any waiters? + (lambda () + (or (not (null? waiting-threads)) (not (null? awoken-threads)))) + + (make-lock))) + + +;; Compute an approximation to infinity: +(define (distant-future) + (+ (current-inexact-milliseconds) + (* 1000.0 60 60 24 365))) diff -Nru racket-6.12+ppa1/src/thread/sandman-struct.rkt racket-7.0+ppa1/src/thread/sandman-struct.rkt --- racket-6.12+ppa1/src/thread/sandman-struct.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/sandman-struct.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,39 @@ +#lang racket/base + +;; In addition to its use from "sandman.rkt", this module is meant to +;; be used by a layer above the "thread" implementation, such as the +;; "io" layer. + +;; See also "sandman.rkt". + +(provide (struct-out sandman)) + +;; A `sandman` implements several methods, and the sandman implementation +;; gets to pick the representation of and , except +;; that #f is the "empty" external event set and #f cannot be a . +(struct sandman (do-sleep ; -> (void), uses plus registered threads + do-poll ; (thread -> any) -> (void), calls function on any thread to wake up + ; where is 'fast or 'slow + + do-any-sleepers? ; -> boolean + do-sleepers-external-events ; -> for sleepers + + do-add-thread! ; -> + do-remove-thread! ; -> (void) + + do-merge-external-event-sets ; -> + + do-merge-timeout ; -> + do-extract-timeout ; -> + + do-condition-wait ; set a thread to wait on a condition + + do-condition-poll ; reschedule awoken threads + + do-any-waiters? ; -> boolean + + lock + + #;...) ; sandman implementations can add more methods + + #:prefab) diff -Nru racket-6.12+ppa1/src/thread/schedule-info.rkt racket-7.0+ppa1/src/thread/schedule-info.rkt --- racket-6.12+ppa1/src/thread/schedule-info.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/schedule-info.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,35 @@ +#lang racket/base +(require "sandman.rkt") + +(provide make-schedule-info + + schedule-info-did-work? + schedule-info-exts + + schedule-info-current-exts + schedule-info-add-timeout-at! + schedule-info-did-work!) + +;; A `schedule-info` record allows an event poller to communicate +;; extra information to the scheduler when an even is not ready. + +(struct schedule-info (did-work? + exts) ; for the sandman + #:mutable) + +(define (make-schedule-info #:did-work? [did-work? #t]) + (schedule-info did-work? + #f)) + +(define schedule-info-current-exts + (case-lambda + [(sched-info) (schedule-info-exts sched-info)] + [(sched-info exts) (set-schedule-info-exts! sched-info exts)])) + +(define (schedule-info-add-timeout-at! sched-info timeout-at) + (define exts (schedule-info-exts sched-info)) + (set-schedule-info-exts! sched-info + (sandman-merge-timeout exts timeout-at))) + +(define (schedule-info-did-work! sched-info) + (set-schedule-info-did-work?! sched-info #t)) diff -Nru racket-6.12+ppa1/src/thread/schedule.rkt racket-7.0+ppa1/src/thread/schedule.rkt --- racket-6.12+ppa1/src/thread/schedule.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/schedule.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,212 @@ +#lang racket/base +(require "atomic.rkt" + "engine.rkt" + "internal-error.rkt" + "sandman.rkt" + "parameter.rkt" + "thread-group.rkt" + "schedule-info.rkt" + (submod "thread.rkt" scheduling) + "system-idle-evt.rkt" + "exit.rkt" + "future.rkt") + +;; Many scheduler details are implemented in "thread.rkt", but this +;; module handles the thread selection, thread swapping, and +;; process sleeping. + +(provide call-in-main-thread + set-atomic-timeout-callback!) + +(define TICKS 100000) + +(define process-milliseconds 0) + +;; Initializes the thread system: +(define (call-in-main-thread thunk) + (make-initial-thread thunk) + (select-thread!)) + +;; ---------------------------------------- + +(define (select-thread! [pending-callbacks null]) + (let loop ([g root-thread-group] [pending-callbacks pending-callbacks] [none-k maybe-done]) + (define callbacks (if (null? pending-callbacks) + (host:poll-async-callbacks) + pending-callbacks)) + (host:poll-will-executors) + (check-external-events 'fast) + (when (and (null? callbacks) + (all-threads-poll-done?) + (waiting-on-external-or-idle?)) + (or (check-external-events 'slow) + (post-idle) + (process-sleep))) + (define child (thread-group-next! g)) + (cond + [(not child) (none-k callbacks)] + [(thread? child) + (swap-in-thread child callbacks)] + [else + (loop child callbacks (lambda (pending-callbacks) (loop g none-k pending-callbacks)))]))) + +(define (swap-in-thread t callbacks) + (define e (thread-engine t)) + (set-thread-engine! t 'running) + (set-thread-sched-info! t #f) + (current-thread t) + (run-callbacks-in-engine + e callbacks + (lambda (e) + (let loop ([e e]) + (end-implicit-atomic-mode) + (e + TICKS + (lambda () + (check-for-break) + (when atomic-timeout-callback + (when (positive? (current-atomic)) + (atomic-timeout-callback)))) + (lambda args + (start-implicit-atomic-mode) + (accum-cpu-time! t) + (current-thread #f) + (unless (zero? (current-atomic)) + (internal-error "terminated in atomic mode!")) + (thread-dead! t) + (when (eq? root-thread t) + (force-exit 0)) + (thread-did-work!) + (select-thread!)) + (lambda (e) + (start-implicit-atomic-mode) + (cond + [(zero? (current-atomic)) + (accum-cpu-time! t) + (current-thread #f) + (unless (eq? (thread-engine t) 'done) + (set-thread-engine! t e)) + (select-thread!)] + [else + ;; Swap out when the atomic region ends: + (set-end-atomic-callback! engine-block) + (loop e)]))))))) + +(define (maybe-done callbacks) + (cond + [(pair? callbacks) + ;; We have callbacks to run and no thread willing + ;; to run them. Make a new thread. + (do-make-thread 'scheduler-make-thread + void + #:custodian #f) + (select-thread! callbacks)] + [(and (not (sandman-any-sleepers?)) + (not (sandman-any-waiters?)) + (not (any-idle-waiters?))) + ;; all threads done or blocked + (cond + [(thread-running? root-thread) + ;; we shouldn't exit, because the main thread is + ;; blocked, but it's not going to become unblocked; + ;; sleep forever or until a signal changes things + (process-sleep) + (select-thread!)] + [else + (void)])] + [else + ;; try again, which should lead to `process-sleep` + (select-thread!)])) + +;; Check for threads that have been suspended until a particular time, +;; etc., as registered with the sandman +(define (check-external-events mode) + (define did? #f) + (sandman-poll mode + (lambda (t) + (thread-reschedule! t) + (set! did? #t))) + (sandman-condition-poll mode + (lambda (t) + (thread-reschedule! t) + (set! did? #t))) + (when did? + (thread-did-work!)) + did?) + +;; Run callbacks within the thread for `e`, and don't give up until +;; the callbacks are done +(define (run-callbacks-in-engine e callbacks k) + (cond + [(null? callbacks) (k e)] + [else + (define done? #f) + (let loop ([e e]) + (end-implicit-atomic-mode) + (e + TICKS + (lambda () + (run-callbacks callbacks) + (set! done? #t) + (engine-block)) + (lambda args + (internal-error "thread ended while it should run callbacks atomically")) + (lambda (e) + (start-implicit-atomic-mode) + (if done? + (k e) + (loop e)))))])) + +;; Run foreign "async-apply" callbacks, now that we're in some thread +(define (run-callbacks callbacks) + (start-atomic) + (current-break-suspend (add1 (current-break-suspend))) + (for ([callback (in-list callbacks)]) + (callback)) + (current-break-suspend (sub1 (current-break-suspend))) + (end-atomic)) + +;; ---------------------------------------- + +;; Have we tried all threads without since most recently making +;; progress on some thread? +(define (all-threads-poll-done?) + (= (hash-count poll-done-threads) + num-threads-in-groups)) + +(define (waiting-on-external-or-idle?) + (or (positive? num-threads-in-groups) + (sandman-any-sleepers?) + (any-idle-waiters?))) + +;; Stop using the CPU for a while +(define (process-sleep) + (define ts (thread-group-all-threads root-thread-group null)) + (define sleeping-exts + (sandman-sleepers-external-events)) + (define exts + (for/fold ([exts sleeping-exts]) ([t (in-list ts)]) + (define sched-info (thread-sched-info t)) + (define t-exts (and sched-info + (schedule-info-exts sched-info))) + (sandman-merge-exts exts t-exts))) + (sandman-sleep exts) + ;; Maybe some thread can proceed: + (thread-did-work!)) + +;; ---------------------------------------- + +(define (accum-cpu-time! t) + (define start process-milliseconds) + (set! process-milliseconds (current-process-milliseconds)) + (set-thread-cpu-time! t (+ (thread-cpu-time t) + (- process-milliseconds start)))) + +;; ---------------------------------------- + +(define atomic-timeout-callback #f) + +(define (set-atomic-timeout-callback! cb) + (begin0 + atomic-timeout-callback + (set! atomic-timeout-callback cb))) diff -Nru racket-6.12+ppa1/src/thread/semaphore.rkt racket-7.0+ppa1/src/thread/semaphore.rkt --- racket-6.12+ppa1/src/thread/semaphore.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/semaphore.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,173 @@ +#lang racket/base +(require "check.rkt" + "../common/queue.rkt" + "internal-error.rkt" + "atomic.rkt" + "parameter.rkt" + "waiter.rkt" + "evt.rkt") + +(provide make-semaphore + semaphore? + semaphore-post + semaphore-post-all + semaphore-wait + semaphore-try-wait? + + semaphore-peek-evt + semaphore-peek-evt? + + semaphore-any-waiters? + + semaphore-post/atomic + semaphore-wait/atomic) + +(struct semaphore ([count #:mutable] + queue) + #:property + prop:evt + (poller (lambda (s poll-ctx) + (semaphore-wait/poll s poll-ctx)))) + +(struct semaphore-peek-evt (sema) + #:property + prop:evt + (poller (lambda (sp poll-ctx) + (semaphore-wait/poll (semaphore-peek-evt-sema sp) + poll-ctx + #:peek? #t + #:result sp)))) + +(struct semaphore-peek-select-waiter select-waiter ()) + +(define/who (make-semaphore [init 0]) + (check who exact-nonnegative-integer? init) + (unless (fixnum? init) + (raise + (exn:fail (string-append + "make-semaphore: starting value " + (number->string init) + " is too large") + (current-continuation-marks)))) + (semaphore init (make-queue))) + +;; ---------------------------------------- + +(define/who (semaphore-post s) + (check who semaphore? s) + (atomically (semaphore-post/atomic s))) + +;; In atomic mode: +(define (semaphore-post/atomic s) + (assert-atomic-mode) + (let loop () + (define w (queue-remove! (semaphore-queue s))) + (cond + [(not w) + (set-semaphore-count! s (add1 (semaphore-count s)))] + [else + (waiter-resume! w s) + (when (semaphore-peek-select-waiter? w) + ;; Don't consume a post for a peek waiter + (loop))]))) + +(define (semaphore-post-all s) + (atomically + (set-semaphore-count! s +inf.0) + (queue-remove-all! + (semaphore-queue s) + (lambda (w) (waiter-resume! w s))))) + +;; In atomic mode: +(define (semaphore-any-waiters? s) + (assert-atomic-mode) + (not (queue-empty? (semaphore-queue s)))) + +;; ---------------------------------------- + +(define/who (semaphore-try-wait? s) + (check who semaphore? s) + (atomically + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c)) + #t] + [else #f]))) + +(define/who (semaphore-wait s) + (check who semaphore? s) + ((atomically + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c)) + void] + [else + (define w (current-thread)) + (define q (semaphore-queue s)) + (define n (queue-add! q w)) + (waiter-suspend! + w + ;; On break/kill/suspend: + (lambda () (queue-remove-node! q n)) + ;; This callback is used, in addition to the previous one, if + ;; the thread receives a break signal but doesn't escape + ;; (either because breaks are disabled or the handler + ;; continues), if if the interrupt was to suspend and the thread + ;; is resumed: + (lambda () (semaphore-wait s)))])))) + +;; In atomic mode +(define (semaphore-wait/poll s poll-ctx + #:peek? [peek? #f] + #:result [result s]) + ;; Similar to `semaphore-wait, but as called by `sync`, + ;; so use a select waiter instead of the current thread + (assert-atomic-mode) + (define c (semaphore-count s)) + (cond + [(positive? c) + (unless peek? + (set-semaphore-count! s (sub1 c))) + (values (list result) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f never-evt)] + [else + (define w (if peek? + (semaphore-peek-select-waiter (poll-ctx-select-proc poll-ctx)) + (select-waiter (poll-ctx-select-proc poll-ctx)))) + (define q (semaphore-queue s)) + (define n (queue-add! q w)) + ;; Replace with `async-evt`, but the `sema-waiter` can select the + ;; event through a callback. Pair the event with a nack callback + ;; to get back out of line. + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () + (assert-atomic-mode) + (queue-remove-node! q n)) + void + (lambda () + ;; Retry: decrement or requeue + (assert-atomic-mode) + (define c (semaphore-count s)) + (cond + [(positive? c) + (unless peek? + (set-semaphore-count! s (sub1 c))) + (values result #t)] + [else + (set! n (queue-add! q w)) + (values #f #f)]))) + (lambda (v) result)))])) + +;; Called only when it should immediately succeed: +(define (semaphore-wait/atomic s) + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c))] + [else + (internal-error "semaphore-wait/atomic: cannot decrement semaphore")])) diff -Nru racket-6.12+ppa1/src/thread/stack-size.rkt racket-7.0+ppa1/src/thread/stack-size.rkt --- racket-6.12+ppa1/src/thread/stack-size.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/stack-size.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,12 @@ +#lang racket/base +(require "check.rkt") + +(provide current-thread-initial-stack-size) + +;; This parameter doesn't do anything, but it's provided +;; here for compatibility +(define/who current-thread-initial-stack-size + (make-parameter 64 + (lambda (v) + (check who exact-positive-integer? v) + v))) diff -Nru racket-6.12+ppa1/src/thread/stats.rkt racket-7.0+ppa1/src/thread/stats.rkt --- racket-6.12+ppa1/src/thread/stats.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/stats.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,36 @@ +#lang racket/base +(require "check.rkt" + "thread.rkt" + "time.rkt") + +(provide vector-set-performance-stats!) + +(define/who (vector-set-performance-stats! vec [thd #f]) + (check who (lambda (v) (and (vector? v) (not (immutable? v)))) + #:contract "(and/c vector? (not/c immutable?))" + vec) + (check who thread? #:or-false thd) + (define (maybe-set! i v) + (when (< i (vector-length vec)) + (vector-set! vec i v))) + (cond + [(not thd) + (maybe-set! 0 (current-process-milliseconds)) + (maybe-set! 1 (current-milliseconds)) + (maybe-set! 2 (current-gc-milliseconds)) + (maybe-set! 3 0) ; # of GCs + (maybe-set! 4 0) ; # of thread switches + (maybe-set! 5 0) ; # of stack overflows + (maybe-set! 6 0) ; # of threads scheduled for running + (maybe-set! 7 0) ; # of syntax objects read + (maybe-set! 8 0) ; # of hash table searches + (maybe-set! 9 0) ; # of hash table collisions + (maybe-set! 10 0) ; non-GCed memory allocated for machine code + (maybe-set! 11 0) ; peak memory use before a GC + (void)] + [else + (maybe-set! 0 (thread-running? thd)) + (maybe-set! 1 (thread-dead? thd)) + (maybe-set! 2 #f) ; blocked for synchronization? + (maybe-set! 3 #f) ; continuation size in bytes + (void)])) diff -Nru racket-6.12+ppa1/src/thread/sync.rkt racket-7.0+ppa1/src/thread/sync.rkt --- racket-6.12+ppa1/src/thread/sync.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/sync.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,638 @@ +#lang racket/base +(require "check.rkt" + "internal-error.rkt" + "evt.rkt" + "atomic.rkt" + "semaphore.rkt" + "channel.rkt" + (submod "channel.rkt" for-sync) + "thread.rkt" + (only-in (submod "thread.rkt" scheduling) + thread-descheduled?) + "schedule-info.rkt") + +(provide sync + sync/timeout + sync/enable-break + sync/timeout/enable-break + sync-atomic-poll-evt? + current-evt-pseudo-random-generator + replace-evt) + +(struct syncing (selected ; #f or a syncer that has been selected + syncers ; linked list of `syncer`s + wakeup ; a callback for when something is selected + disable-break ; #f or a thunk that disables breaks + need-retry?) ; queued trigger to `syncing-retry!` + #:mutable) + +(struct syncer (evt ; the evt to sync; can get updated in sync loop + wraps ; list of wraps to apply if selected + commits ; list of thunks to run atomically when selected + interrupted? ; kill/break in progress? + interrupts ; list of thunks to run on kill/break initiation + abandons ; list of thunks to run on kill/break completion + retries ; list of thunks to run on retry: returns `(values _val _ready?)` + prev ; previous in linked list + next) ; next in linked list + #:transparent + #:mutable) + +(define (make-syncer evt wraps) + (syncer evt wraps null #f null null null #f #f)) + +(define none-syncer (make-syncer #f null)) + +(define (make-syncing syncers #:disable-break [disable-break #f]) + (syncing #f ; selected + syncers + void ; wakeup + disable-break + #f)) + +;; To support `port-commit-peeked`, the `sync/timeout` function should +;; work for polling in atomic mode for a set of constrained event +;; types: +(define (sync-atomic-poll-evt? evt) + (or (channel-put-evt? evt) + (channel? evt) + (semaphore? evt) + (semaphore-peek-evt? evt) + (eq? always-evt evt) + (eq? never-evt evt))) + +(define (do-sync who timeout args + #:enable-break? [enable-break? #f]) + (check who + (lambda (timeout) (or (not timeout) + (and (real? timeout) (timeout . >= . 0)) + (and (procedure? timeout) + (procedure-arity-includes? timeout 0)))) + #:contract "(or/c #f (and/c real? (not/c negative?)) (-> any))" + timeout) + + (define local-break-cell (and enable-break? + (make-thread-cell #t))) + + (define syncers (evts->syncers who args)) + (define s (make-syncing syncers + #:disable-break + (and local-break-cell + (let ([t (current-thread)]) + (lambda () + (thread-ignore-break-cell! t local-break-cell)))))) + + (define (go) + (dynamic-wind + (lambda () + (atomically + (thread-push-kill-callback! + (lambda () (syncing-abandon! s))) + (thread-push-suspend+resume-callbacks! + (lambda () (syncing-interrupt! s)) + (lambda () (syncing-queue-retry! s))))) + (lambda () + (when enable-break? (check-for-break)) + (cond + [(or (and (real? timeout) (zero? timeout)) + (procedure? timeout)) + (let poll-loop () + (sync-poll s #:fail-k (lambda (sched-info polled-all?) + (cond + [(not polled-all?) + (poll-loop)] + [(procedure? timeout) + timeout] + [else + (lambda () #f)])) + #:just-poll? #t))] + [else + ;; Loop to poll; if all events end up with asynchronous-select + ;; callbacks, then the loop can suspend the current thread + (define timeout-at + (and timeout + (+ (* timeout 1000) (current-inexact-milliseconds)))) + (let loop ([did-work? #t] [polled-all? #f]) + (cond + [(and polled-all? + timeout + (timeout-at . <= . (current-inexact-milliseconds))) + (start-atomic) + (syncing-done! s none-syncer) + (cond + [(syncing-selected s) + ;; Selected after all: + (end-atomic) + (loop #f #f)] + [else + ;; Return result in a thunk: + (lambda () #f)])] + [(and (all-asynchronous? s) + (not (syncing-selected s))) + (suspend-syncing-thread s timeout-at) + (set-syncing-wakeup! s void) + (loop #f #t)] + [else + (sync-poll s + #:did-work? did-work? + #:fail-k (lambda (sched-info now-polled-all?) + (when timeout-at + (schedule-info-add-timeout-at! sched-info timeout-at)) + (thread-yield sched-info) + (loop #f (or polled-all? now-polled-all?))))]))])) + (lambda () + (atomically + (thread-pop-suspend+resume-callbacks!) + (thread-pop-kill-callback!) + (when local-break-cell + (thread-remove-ignored-break-cell! (current-thread) local-break-cell)) + ;; On escape, post nacks, etc.: + (syncing-abandon! s))))) + + ;; Result thunk is called in tail position: + ((cond + [enable-break? + ;; Install a new break cell, and check for breaks at the end: + (begin0 + (with-continuation-mark + break-enabled-key + local-break-cell + (go)) + ;; In case old break cell was meanwhile enabled: + (check-for-break))] + [else + ;; Just `go`: + (go)]))) + +(define (sync . args) + (do-sync 'sync #f args)) + +(define (sync/timeout timeout . args) + (do-sync 'sync/timeout timeout args)) + +(define (sync/enable-break . args) + (do-sync 'sync/enable-break #f args #:enable-break? #t)) + +(define (sync/timeout/enable-break timeout . args) + (do-sync 'sync/timeout/enable-break timeout args #:enable-break? #t)) + +;; Resolve mutual dependency: +(void (set-sync-on-channel! sync)) + +;; ---------------------------------------- + +(define (evts->syncers who evts [wraps null] [commits null] [abandons null]) + (define-values (extended-commits guarded-abandons) + (cross-commits-and-abandons commits abandons)) + (let loop ([evts evts] [first #f] [last #f]) + (cond + [(null? evts) first] + [else + (define arg (car evts)) + (when who + (check who evt? arg)) + (cond + [(choice-evt? arg) + ;; Splice choice events eagerly to improve fairness + ;; of selection + (loop (append (choice-evt-evts arg) (cdr evts)) + first + last)] + [else + (define sr (make-syncer arg wraps)) + (unless (and (null? extended-commits) + (null? guarded-abandons)) + (set-syncer-commits! sr extended-commits) + (set-syncer-abandons! sr guarded-abandons)) + (set-syncer-prev! sr last) + (when last + (set-syncer-next! last sr)) + (loop (cdr evts) + (or first sr) + sr)])]))) + +(define (cross-commits-and-abandons commits abandons) + (cond + [(and (null? commits) (null? abandons)) + (values null null)] + [else + (define selected? #f) + (values (list + ;; in atomic mode + (lambda () + (assert-atomic-mode) + (set! selected? #t) + (for ([commit (in-list commits)]) + (commit)) + (set! commits null))) + (list + ;; in atomic mode + (lambda () + (assert-atomic-mode) + (unless selected? + (for ([abandon (in-list abandons)]) + (abandon))) + (set! abandons null))))])) + +;; in atomic mode +;; remove a syncer from its chain in `s` +(define (syncer-remove! sr s) + (assert-atomic-mode) + (if (syncer-prev sr) + (set-syncer-next! (syncer-prev sr) (syncer-next sr)) + (set-syncing-syncers! s (syncer-next sr))) + (when (syncer-next sr) + (set-syncer-prev! (syncer-next sr) (syncer-prev sr)))) + +;; in atomic mode +;; Replace one syncer with a new, non-empty chain of syncers in `s` +(define (syncer-replace! sr new-syncers s) + (assert-atomic-mode) + (let ([prev (syncer-prev sr)]) + (set-syncer-prev! new-syncers prev) + (if prev + (set-syncer-next! prev new-syncers) + (set-syncing-syncers! s new-syncers))) + (let loop ([new-syncers new-syncers]) + (cond + [(syncer-next new-syncers) + => (lambda (next) (loop next))] + [else + (let ([next (syncer-next sr)]) + (set-syncer-next! new-syncers next) + (when next + (set-syncer-prev! next new-syncers)))]))) + +;; ---------------------------------------- + +(define MAX-SYNC-TRIES-ON-ONE-EVT 10) + +;; Run through the events of a `sync` one time; returns a thunk to +;; call in tail position --- possibly one that calls `none-k`. +(define (sync-poll s + #:fail-k none-k + #:success-k [success-k (lambda (thunk) thunk)] + #:just-poll? [just-poll? #f] + #:done-after-poll? [done-after-poll? #t] + #:did-work? [did-work? #f] + #:schedule-info [sched-info (make-schedule-info #:did-work? did-work?)]) + (random-rotate-syncing! s) + (let loop ([sr (syncing-syncers s)] + [retries 0] ; count retries on `sr`, and advance if it's too many + [polled-all-so-far? #t]) + (when (syncing-need-retry? s) + (syncing-retry! s)) + ((atomically + (cond + [(syncing-selected s) + => (lambda (sr) + ;; Some concurrent synchronization happened + (make-result-thunk sr (list (syncer-evt sr)) success-k))] + [(not sr) + (when (and just-poll? done-after-poll? polled-all-so-far?) + (syncing-done! s none-syncer)) + (lambda () (none-k sched-info polled-all-so-far?))] + [(= retries MAX-SYNC-TRIES-ON-ONE-EVT) + (schedule-info-did-work! sched-info) + (lambda () (loop (syncer-next sr) 0 #f))] + [else + (define ctx (poll-ctx just-poll? + ;; Call back for asynchronous selection, + ;; such as by a semaphore when it's posted + ;; in a different thread; this callback + ;; must be invoked in atomic mode + (lambda () + (assert-atomic-mode) + (syncing-done! s sr)) + ;; Information to propagate to the thread + ;; scheduler + sched-info + ;; Set to #t if getting the same result + ;; back should not be treated as a + ;; completed poll: + #f)) + (define-values (results new-evt) + (evt-poll (syncer-evt sr) ctx)) + (cond + [results + (syncing-done! s sr) + (make-result-thunk sr results success-k)] + [(delayed-poll? new-evt) + ;; Have to go out of atomic mode to continue: + (lambda () + (let ([new-evt ((delayed-poll-resume new-evt))]) + ;; Since we left atomic mode, double-check that we're + ;; still syncing before installing the replacement event: + (atomically + (unless (syncing-selected s) + (set-syncer-evt! sr new-evt))) + (loop sr (add1 retries) polled-all-so-far?)))] + [(choice-evt? new-evt) + (when (or (pair? (syncer-interrupts sr)) + (pair? (syncer-retries sr))) + (internal-error "choice event discovered after interrupt/retry callbacks")) + (define new-syncers (random-rotate + (evts->syncers #f + (choice-evt-evts new-evt) + (syncer-wraps sr) + (syncer-commits sr) + (syncer-abandons sr)))) + (cond + [(not new-syncers) + ;; Empty choice, so drop it: + (syncer-remove! sr s) + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [else + ;; Splice in new syncers, and start there + (syncer-replace! sr new-syncers s) + (lambda () (loop new-syncers (add1 retries) polled-all-so-far?))])] + [(wrap-evt? new-evt) + (set-syncer-wraps! sr (cons (wrap-evt-wrap new-evt) + (let ([l (syncer-wraps sr)]) + (if (and (null? l) + (not (handle-evt? new-evt))) + ;; Prevent wrapper from being in tail position: + (list values) + ;; Allow handler in tail position: + l)))) + (define inner-new-evt (wrap-evt-evt new-evt)) + (set-syncer-evt! sr inner-new-evt) + ;; In support of the `poller` protocol, if the new evt is + ;; `always-evt`, then select it immediately + (cond + [(eq? inner-new-evt always-evt) + (syncing-done! s sr) + (make-result-thunk sr (list always-evt) success-k)] + [else + (lambda () (loop sr (add1 retries) polled-all-so-far?))])] + [(control-state-evt? new-evt) + (set-syncer-interrupts! sr (cons-non-void (control-state-evt-interrupt-proc new-evt) (syncer-interrupts sr))) + (set-syncer-abandons! sr (cons-non-void (control-state-evt-abandon-proc new-evt) (syncer-abandons sr))) + (set-syncer-retries! sr (cons-non-void (control-state-evt-retry-proc new-evt) (syncer-retries sr))) + (set-syncer-evt! sr (control-state-evt-evt new-evt)) + (lambda () (loop sr (add1 retries) polled-all-so-far?))] + [(poll-guard-evt? new-evt) + (lambda () + ;; Out of atomic region: + (define generated ((poll-guard-evt-proc new-evt) just-poll?)) + (set-syncer-evt! sr (if (evt? generated) + generated + (wrap-evt always-evt (lambda (a) generated)))) + (loop sr (add1 retries) polled-all-so-far?))] + [(and (never-evt? new-evt) + (null? (syncer-interrupts sr)) + (null? (syncer-commits sr)) + (null? (syncer-abandons sr))) + ;; Drop this event, since it will never get selected + (syncer-remove! sr s) + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [(and (eq? new-evt (syncer-evt sr)) + (not (poll-ctx-incomplete? ctx))) + ;; No progress on this evt + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [else + (set-syncer-evt! sr new-evt) + (lambda () (loop sr (add1 retries) polled-all-so-far?))])]))))) + +;; Create a thunk that applies wraps immediately, while breaks are +;; potentially still disabled (but not in atomic mode), and then +;; returns another thunk to call a handler (if any) in tail position +(define (make-result-thunk sr results success-k) + (define wraps (syncer-wraps sr)) + (lambda () + (let loop ([wraps wraps] [results results]) + (cond + [(null? wraps) + (success-k + (lambda () + (apply values results)))] + [(null? (cdr wraps)) + ;; Call last one in tail position: + (let ([proc (car wraps)]) + (success-k + (lambda () + (apply proc results))))] + [else + (loop (cdr wraps) + (call-with-values (lambda () (apply (car wraps) results)) list))])))) + +(define (cons-non-void a d) + (if (eq? a void) + d + (cons a d))) + +;; ---------------------------------------- + +;; Called in atomic mode +;; Finalizes a decision for the sychronization, calling +;; interrupt+abandon (or just abandon, if already interrupted) +;; on non-selected events to indicate that they will never be +;; selected for this synchronization +(define (syncing-done! s selected-sr) + (assert-atomic-mode) + (set-syncing-selected! s selected-sr) + (for ([callback (in-list (syncer-commits selected-sr))]) + (callback)) + (let loop ([sr (syncing-syncers s)]) + (when sr + (unless (eq? sr selected-sr) + (unless (syncer-interrupted? sr) + (for ([interrupt (in-list (syncer-interrupts sr))]) + (interrupt))) + (for ([abandon (in-list (syncer-abandons sr))]) + (abandon))) + (loop (syncer-next sr)))) + (when (syncing-disable-break s) + ((syncing-disable-break s))) + ((syncing-wakeup s))) + +;; Called in atomic mode +(define (syncing-abandon! s) + (assert-atomic-mode) + (unless (syncing-selected s) + (syncing-done! s none-syncer))) + +;; Called in atomic mode +;; For each syncer that needs a notification (e.g., to get out of +;; a queue of waiters), call its `interrupt` callback +(define (syncing-interrupt! s) + (assert-atomic-mode) + (let loop ([sr (syncing-syncers s)]) + (when sr + (unless (syncer-interrupted? sr) + (set-syncer-interrupted?! sr #t) + (for ([interrupt (in-list (syncer-interrupts sr))]) + (interrupt))) + (loop (syncer-next sr))))) + +;; Called in atomic mode +;; For each syncer that needs a notification (e.g., to get back into +;; a queue of waiters), call its `retry` callback; a retry might +;; succeed immediately, moving the synchronization into "selected" +;; state +(define (syncing-retry! s) + (assert-atomic-mode) + (set-syncing-need-retry?! s #f) + (let loop ([sr (syncing-syncers s)]) + (when (and sr + (not (syncing-selected s))) + (when (syncer-interrupted? sr) + (set-syncer-interrupted?! sr #f) + ;; Although we keep a list of retries, we expect only + ;; one to be relevant + (for ([retry (in-list (syncer-retries sr))]) + (define-values (result ready?) (retry)) + (when ready? + (set-syncer-wraps! sr (cons (lambda args result) (syncer-wraps sr))) + (syncing-done! s sr)))) + (loop (syncer-next sr))))) + +;; Queue a retry when a check for breaks should happen before a retry +;; that might immediately succeed +(define (syncing-queue-retry! s) + (set-syncing-need-retry?! s #t)) + +;; ---------------------------------------- + +;; If everything we're waiting on is like a semaphore or channel, +;; where an asynchronous selection event is installed, then we can +;; completely suspend this thread +(define (all-asynchronous? s) + (atomically + (let loop ([sr (syncing-syncers s)]) + (cond + [(not sr) #t] + [else + (define e (syncer-evt sr)) + (and (or (async-evt? e) + (never-evt? e)) + (loop (syncer-next sr)))])))) + +;; Install a callback to reschedule the current thread if an +;; asynchronous selection happens, and then deschedule the thread +(define (suspend-syncing-thread s timeout-at) + ((atomically + (let retry () + (cond + [(syncing-selected s) + ;; don't suspend after all + void] + [else + (define t (current-thread)) + (set-syncing-wakeup! + s + (lambda () + (set-syncing-wakeup! s void) + ;; In case this callback is late, where the thread was + ;; already rescheduled for some reason: + (when (thread-descheduled? t) + (thread-reschedule! t)))) + ;; Suspend and resume callbacks will also + ;; interrupt and queue a retry, but it's ok + ;; to have both at this point + (thread-deschedule! t + timeout-at + (lambda () + ;; Interrupt due to break/kill/suspend + (set-syncing-wakeup! s void) + (unless (syncing-selected s) + (syncing-interrupt! s))) + (lambda () + ;; Continue from suspend or ignored break... + ;; In non-atomic mode and tail position: + ((atomically + (unless (syncing-selected s) + (syncing-retry! s)) + (retry)))))]))))) + +;; ---------------------------------------- + +(struct replacing-evt (guard) + #:property prop:evt (poller (lambda (self poll-ctx) ((replacing-evt-guard self)))) + #:reflection-name 'evt) + +(struct nested-sync-evt (s next orig-evt) + #:property prop:evt (poller (lambda (self poll-ctx) (poll-nested-sync self poll-ctx))) + #:reflection-name 'evt) + +(define/who (replace-evt evt next) + (check who evt? evt) + (check who procedure? next) + (define orig-evt + (replacing-evt + ;; called for each `sync`: + (lambda () + (define s (make-syncing (evts->syncers who (list evt)))) + (values + #f + ;; represents the instantited attempt to sync on `evt`: + (control-state-evt + (nested-sync-evt s next orig-evt) + (lambda () (syncing-interrupt! s)) + (lambda () (syncing-abandon! s)) + (lambda () (syncing-retry! s))))))) + orig-evt) + +(define (poll-nested-sync ns poll-ctx) + (sync-poll (nested-sync-evt-s ns) + #:fail-k (lambda (sched-info polled-all?) + (unless polled-all? + (set-poll-ctx-incomplete?! poll-ctx #f)) + (values #f ns)) + #:success-k (lambda (thunk) + ;; `thunk` produces the values of the evt + ;; that was provided to `replace-evt`: + (define next (nested-sync-evt-next ns)) + (define orig-evt (nested-sync-evt-orig-evt ns)) + (values #f + ;; and this is the "replace" step: + (poll-guard-evt + (lambda (poll?) + (define r (call-with-values thunk next)) + (cond + [(evt? r) r] + [else (wrap-evt always-evt (lambda (v) orig-evt))]))))) + #:just-poll? (poll-ctx-poll? poll-ctx) + #:done-after-poll? #f + #:schedule-info (poll-ctx-sched-info poll-ctx))) + +;; ---------------------------------------- + +(define/who current-evt-pseudo-random-generator + (make-parameter (make-pseudo-random-generator) + (lambda (v) + (check who pseudo-random-generator? v) + v))) + +;; rotates the order of syncers in `s` to implement fair selection: +(define (random-rotate-syncing! s) + (set-syncing-syncers! s (random-rotate (syncing-syncers s)))) + +(define (random-rotate first-sr) + (define n (let loop ([sr first-sr] [n 0]) + (cond + [(not sr) n] + [else (loop (syncer-next sr) (add1 n))]))) + (cond + [(n . <= . 1) first-sr] + [else + (define m (random n (current-evt-pseudo-random-generator))) + (cond + [(zero? m) first-sr] + [else + (let loop ([sr first-sr] [m (sub1 m)]) + (cond + [(zero? m) + (define new-first-sr (syncer-next sr)) + (set-syncer-next! sr #f) + (set-syncer-prev! new-first-sr #f) + (let loop ([next-sr new-first-sr]) + (define next-next-sr (syncer-next next-sr)) + (cond + [(not next-next-sr) + (set-syncer-next! next-sr first-sr) + (set-syncer-prev! first-sr next-sr) + new-first-sr] + [else (loop next-next-sr)]))] + [else + (loop (syncer-next sr) (sub1 m))]))])])) diff -Nru racket-6.12+ppa1/src/thread/system-idle-evt.rkt racket-7.0+ppa1/src/thread/system-idle-evt.rkt --- racket-6.12+ppa1/src/thread/system-idle-evt.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/system-idle-evt.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(require "evt.rkt" + "semaphore.rkt") + +(provide (rename-out [get-system-idle-evt system-idle-evt]) + + any-idle-waiters? + post-idle) + +(define idle-sema (make-semaphore)) +(define wrapped-idle-sema (wrap-evt idle-sema void)) +(struct system-idle-evt () + #:property prop:evt (lambda (i) wrapped-idle-sema)) + +(define the-idle-evt (system-idle-evt)) + +(define get-system-idle-evt + (let ([system-idle-evt + (lambda () the-idle-evt)]) + system-idle-evt)) + +;; Called by the scheduler in atomic mode: +(define (any-idle-waiters?) + (semaphore-any-waiters? idle-sema)) + +;; Called by the scheduler in atomic mode: +(define (post-idle) + (and (semaphore-any-waiters? idle-sema) + (begin + (semaphore-post/atomic idle-sema) + #t))) diff -Nru racket-6.12+ppa1/src/thread/thread-group.rkt racket-7.0+ppa1/src/thread/thread-group.rkt --- racket-6.12+ppa1/src/thread/thread-group.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/thread-group.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,127 @@ +#lang racket/base +(require "check.rkt" + "internal-error.rkt" + "atomic.rkt") + +(provide (struct-out node) + + thread-group? + make-thread-group + current-thread-group + + ;; Used by scheduler + root-thread-group + thread-group-next! + + ;; Called by thread creation and termination: + thread-group-add! + thread-group-remove! + + thread-group-all-threads + num-threads-in-groups) + +;; Threads and thread groups subtype `node`: +(struct node ([prev #:mutable] + [next #:mutable])) +(define (child-node child) child) ; a child instantiates a `node` subtype +(define (node-child n) n) + +(struct thread-group node (parent + [chain-start #:mutable] ; all children + [chain #:mutable] ; children remaining to be scheduled round-robin + [chain-end #:mutable])) + +(define root-thread-group (thread-group 'none 'none #f #f #f #f)) + +(define num-threads-in-groups 0) + +(define/who current-thread-group + (make-parameter root-thread-group + (lambda (v) + (check who thread-group? v) + v))) + +(define/who (make-thread-group [parent (current-thread-group)]) + (check who thread-group? parent) + (define tg (thread-group 'none 'none parent #f #f #f)) + tg) + +;; Called atomically in scheduler: +(define (thread-group-next! tg) + (define n (thread-group-chain tg)) + (cond + [(not n) + (define n (thread-group-chain-start tg)) + (cond + [(not n) + ;; No children + #f] + [else + (set-thread-group-chain! tg (node-next n)) + n])] + [else + (set-thread-group-chain! tg (node-next n)) + (node-child n)])) + +(define (thread-group-add! parent child) + (atomically + (let loop ([parent parent] [child child]) + ;; Adding to the start of the group tends to reverse the schedule + ;; order, but it also avoids a problem where two threads that + ;; both loop and `sleep` (which deschedules and reschedules) take + ;; turns and starve everything else. + (define t (thread-group-chain-start parent)) + (define was-empty? (not t)) + (define n (child-node child)) + (unless (and (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-add!: thread or group is added already")) + (set-node-next! n t) + (set-node-prev! n #f) + (if t + (set-node-prev! t n) + (set-thread-group-chain-end! parent n)) + (set-thread-group-chain-start! parent n) + (unless (thread-group? child) + (set! num-threads-in-groups (add1 num-threads-in-groups))) + (when was-empty? + ;; added child to formerly empty parent => add the parent + (define parent-parent (thread-group-parent parent)) + (when parent-parent + (loop parent-parent parent)))))) + +(define (thread-group-remove! parent child) + (atomically + (let loop ([parent parent] [child child]) + (define n (child-node child)) + (when (or (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-remove!: thread or group is removed already")) + (if (node-next n) + (set-node-prev! (node-next n) (node-prev n)) + (set-thread-group-chain-end! parent (node-prev n))) + (if (node-prev n) + (set-node-next! (node-prev n) (node-next n)) + (set-thread-group-chain-start! parent (node-next n))) + (when (eq? n (thread-group-chain parent)) + (set-thread-group-chain! parent (node-next n))) + (set-node-next! n 'none) + (set-node-prev! n 'none) + (unless (thread-group? child) + (set! num-threads-in-groups (sub1 num-threads-in-groups))) + (when (not (thread-group-chain-end parent)) + ;; parent thread group is now empty, so remove it, too + (define parent-parent (thread-group-parent parent)) + (when parent-parent + (loop parent-parent parent)))))) + +(define (thread-group-all-threads parent accum) + (cond + [(not (thread-group? parent)) (cons parent accum)] + [else + (let loop ([n (thread-group-chain-start parent)] [accum accum]) + (cond + [(not n) accum] + [else (loop (node-next n) + (thread-group-all-threads (node-child n) accum))]))])) + diff -Nru racket-6.12+ppa1/src/thread/thread.rkt racket-7.0+ppa1/src/thread/thread.rkt --- racket-6.12+ppa1/src/thread/thread.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/thread.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,979 @@ +#lang racket/base +(require "../common/queue.rkt" + "check.rkt" + "internal-error.rkt" + "engine.rkt" + "sandman.rkt" + "parameter.rkt" + "evt.rkt" + "waiter.rkt" + "semaphore.rkt" + "thread-group.rkt" + "atomic.rkt" + "schedule-info.rkt" + "custodian.rkt" + "exit.rkt") + +(provide (rename-out [make-thread thread]) + thread/suspend-to-kill + unsafe-thread-at-root + thread? + current-thread + + thread-running? + thread-dead? + + thread-wait + thread-suspend + thread-resume + thread-suspend-evt + thread-resume-evt + (rename-out [get-thread-dead-evt thread-dead-evt]) + thread-dead-evt? + + break-thread + kill-thread + + sleep + + break-enabled + check-for-break + break-enabled-key + current-break-suspend + + thread-push-kill-callback! + thread-pop-kill-callback! + thread-push-suspend+resume-callbacks! + thread-pop-suspend+resume-callbacks! + + thread-deschedule! + thread-reschedule! + thread-yield + + thread-ignore-break-cell! + thread-remove-ignored-break-cell! + + thread-send + thread-receive + thread-try-receive + thread-rewind-receive + thread-receive-evt + + thread-condition-awaken + thread-condition-wait) + +;; Exports needed by "schedule.rkt": +(module* scheduling #f + (provide (struct-out thread) + + make-initial-thread + do-make-thread + root-thread + thread-running? + thread-dead! + thread-did-work! + + thread-reschedule! + + poll-done-threads + + current-break-enabled-cell + check-for-break + current-break-suspend + + break-max)) + +;; ---------------------------------------- + +(struct thread node (name + [engine #:mutable] + parent + [sleeping #:mutable] ; #f or sandman sleeper handle + [sched-info #:mutable] + + [custodian-references #:mutable] ; list of custodian references + [transitive-resumes #:mutable] ; a list of `transitive-resume`s + + suspend-to-kill? + [kill-callbacks #:mutable] ; list of callbacks + + [suspend+resume-callbacks #:mutable] ; list of (cons callback callback) + [descheduled? #:mutable] + [interrupt-callback #:mutable] ; non-#f => wake up on kill + + [dead-sema #:mutable] ; created on demand + [dead-evt #:mutable] ; created on demand + [suspended-box #:mutable] ; created on demand; box contains thread if suspended + [suspended-evt #:mutable] + [resumed-evt #:mutable] + + [pending-break #:mutable] ; #f, 'break, 'hang-up, or 'terminate + [ignore-break-cells #:mutable] ; => #f, a single cell, or a set of cells + [forward-break-to #:mutable] ; #f or a thread to receive this thread's breaks + + [mailbox #:mutable] ; a queue of messages from `thread-send` + [mailbox-wakeup #:mutable] ; callback to trigger (in atomic mode) on `thread-send` + + [cpu-time #:mutable] ; accumulates CPU time in milliseconds + + [condition-wakeup #:mutable]) + #:property prop:waiter + (make-waiter-methods + #:suspend! (lambda (t i-cb r-cb) (thread-deschedule! t #f i-cb r-cb)) + #:resume! (lambda (t v) (thread-reschedule! t) v)) + #:property prop:evt (lambda (t) (wrap-evt (get-thread-dead-evt t) + (lambda (v) t)))) + +(define root-thread #f) + +;; ---------------------------------------- +;; Thread creation + +(define (do-make-thread who + proc + #:custodian [c (current-custodian)] ; can be #f + #:at-root? [at-root? #f] + #:initial? [initial? #f] + #:suspend-to-kill? [suspend-to-kill? #f]) + (check who (procedure-arity-includes/c 0) proc) + (define p (if at-root? + root-thread-group + (current-thread-group))) + (define e (make-engine (lambda () + (call-with-continuation-prompt proc)) + (if (or initial? at-root?) + break-enabled-default-cell + (current-break-enabled-cell)) + at-root?)) + (define t (thread 'none ; node prev + 'none ; node next + + (gensym) + e + p + #f ; sleeping + #f ; sched-info + + null ; custodian-references + null ; transitive-resumes + + suspend-to-kill? + null ; kill-callbacks + + null ; suspend+resume-callbacks + #f ; descheduled + #f ; interrupt-callback + + #f ; dead-sema + #f ; dead-evt + #f ; suspended-box + #f ; suspended-evt + #f ; resumed-evt + + #f ; pending-break + #f ; ignore-thread-cells + #f; forward-break-to + + (make-queue) ; mailbox + void ; mailbox-wakeup + + 0 ; cpu-time + + void ; condition-wakeup + )) + ((atomically + (define cref (and c (unsafe-custodian-register c t remove-thread-custodian #f #t))) + (cond + [(or (not c) cref) + (set-thread-custodian-references! t (list cref)) + (thread-group-add! p t) + void] + [else (lambda () (raise-custodian-is-shut-down who c))]))) + t) + +(define make-thread + (let ([thread (lambda (proc) + (do-make-thread 'thread proc))]) + thread)) + +(define (thread/suspend-to-kill proc) + (do-make-thread 'thread/suspend-to-kill proc #:suspend-to-kill? #t)) + +(define (make-initial-thread thunk) + (let ([t (do-make-thread 'thread thunk #:initial? #t)]) + (set! root-thread t) + t)) + +(define (unsafe-thread-at-root proc) + (do-make-thread 'unsafe-thread-at-root proc #:at-root? #t)) + +;; ---------------------------------------- +;; Thread status + +(define (thread-suspended? t) + (define b (thread-suspended-box t)) + (and b (unbox b) #t)) + +;; in atomic mode +(define (set-thread-suspended?! t suspended?) + (assert-atomic-mode) + (define b (or (thread-suspended-box t) + (let ([b (box #f)]) + (set-thread-suspended-box! t b) + b))) + (set-box! b (and suspended? t))) + +(define/who (thread-running? t) + (check who thread? t) + (and (not (eq? 'done (thread-engine t))) + (not (thread-suspended? t)))) + +(define/who (thread-dead? t) + (check who thread? t) + (eq? 'done (thread-engine t))) + +;; In atomic mode +;; Terminating the current thread does not suspend or exit +(define (thread-dead! t) + (assert-atomic-mode) + (set-thread-engine! t 'done) + (when (thread-dead-sema t) + (semaphore-post-all (thread-dead-sema t))) + (run-interrupt-callback t) + (unless (thread-descheduled? t) + (thread-group-remove! (thread-parent t) t)) + (remove-from-sleeping-threads! t) + (run-kill-callbacks! t) + (when (thread-forward-break-to t) + (do-break-thread (thread-forward-break-to t) 'break #f)) + (for ([cr (in-list (thread-custodian-references t))]) + (unsafe-custodian-unregister t cr)) + (set-thread-custodian-references! t null)) + +;; ---------------------------------------- +;; Thread termination + +;; Called in atomic mode: +(define (thread-push-kill-callback! cb) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-kill-callbacks! t (cons cb (thread-kill-callbacks t)))) + +;; Called in atomic mode: +(define (thread-pop-kill-callback!) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-kill-callbacks! t (cdr (thread-kill-callbacks t)))) + +(define/who (kill-thread t) + (check who thread? t) + (unless (for/and ([cr (in-list (thread-custodian-references t))]) + (custodian-manages-reference? (current-custodian) cr)) + (raise-arguments-error who + "the current custodian does not solely manage the specified thread" + "thread" t)) + (cond + [(thread-suspend-to-kill? t) + ((atomically + (do-thread-suspend t)))] + [else + (atomically + (do-kill-thread t)) + (when (eq? t (current-thread)) + (when (eq? t root-thread) + (force-exit 0)) + (engine-block)) + (check-for-break-after-kill)])) + +;; Called in atomic mode: +(define (do-kill-thread t) + (assert-atomic-mode) + (unless (thread-dead? t) + (thread-dead! t))) + +;; Called in atomic mode: +(define (remove-thread-custodian t c) + (assert-atomic-mode) + (define new-crs (for/list ([cref (in-list (thread-custodian-references t))] + #:unless (custodian-manages-reference? c cref)) + cref)) + (set-thread-custodian-references! t new-crs) + (when (null? new-crs) + (cond + [(thread-suspend-to-kill? t) + (do-thread-suspend t)] + [else + (do-kill-thread t)]))) + +;; Called in atomic mode: +(define (run-kill-callbacks! t) + (assert-atomic-mode) + (for ([cb (in-list (thread-kill-callbacks t))]) + (cb)) + (set-thread-kill-callbacks! t null)) + +(define (check-for-break-after-kill) + ;; When a thread is terminated, it might be a nesting thread and + ;; send a break to a nestee --- and the current thread might be the + ;; nestee. + (check-for-break)) + +(void (set-post-shutdown-action! + (lambda () + ;; Check whether the current thread was terminated + (let ([t (current-thread)]) + (when t ; in case custodians used (for testing) without threads + (when (thread-dead? t) + (engine-block)) + (check-for-break-after-kill)))))) + +;; ---------------------------------------- +;; Thread status events + +(define/who (thread-wait t) + (check who thread? t) + (semaphore-wait (get-thread-dead-sema t))) + +(struct dead-evt (sema) + #:property prop:evt (lambda (tde) (wrap-evt (dead-evt-sema tde) + (lambda (s) tde))) + #:reflection-name 'thread-dead-evt) + +(define (thread-dead-evt? v) + (dead-evt? v)) + +(define/who get-thread-dead-evt + (let ([thread-dead-evt + (lambda (t) + (check who thread? t) + (atomically + (unless (thread-dead-evt t) + (set-thread-dead-evt! t (dead-evt (get-thread-dead-sema t))))) + (thread-dead-evt t))]) + thread-dead-evt)) + +(define (get-thread-dead-sema t) + (atomically + (unless (thread-dead-sema t) + (set-thread-dead-sema! t (make-semaphore 0)) + (when (eq? 'done (thread-engine t)) + (semaphore-post-all (thread-dead-sema t))))) + (thread-dead-sema t)) + +;; ---------------------------------------- +;; Thread suspend and resume + +;; in atomic mode +(define (remove-from-sleeping-threads! t) + (assert-atomic-mode) + (define sleeping (thread-sleeping t)) + (when sleeping + (set-thread-sleeping! t #f) + (sandman-remove-sleeping-thread! t sleeping))) + +;; in atomic mode +(define (add-to-sleeping-threads! t ext-events) + (assert-atomic-mode) + (define sleeping (sandman-add-sleeping-thread! t ext-events)) + (set-thread-sleeping! t sleeping)) + +;; in atomic mode +;; Removes a thread from its thread group, so it won't be scheduled; +;; returns a thunk to be called in out of atomic mode to swap out the +;; thread, where the thunk returns `(void)`; +(define (do-thread-deschedule! t timeout-at) + (assert-atomic-mode) + (when (thread-descheduled? t) + (internal-error "tried to deschedule a descheduled thread")) + (set-thread-descheduled?! t #t) + (thread-group-remove! (thread-parent t) t) + (when timeout-at + (add-to-sleeping-threads! t (sandman-merge-timeout #f timeout-at))) + (when (eq? t (current-thread)) + (thread-did-work!)) + (lambda () + (when (eq? t (current-thread)) + (when (positive? (current-atomic)) + (internal-error "attempt to deschedule the current thread in atomic mode")) + (engine-block) + (check-for-break)))) + +;; Extends `do-thread-deschdule!` where `t` is always `(current-thread)`. +;; The `interrupt-callback` is called if the thread receives a break +;; signal, is killed, or is suspended; if the break signal is +;; supressed or resumed, then `retry-callback` is called to try again +;; --- but `retry-callback` will only be used if `interrupt-callback` +;; was previously called, and neither is called if the thread is +;; "internal"-resumed normally instead of by a break signal of a +;; `thread-resume`. +(define (thread-deschedule! t timeout-at interrupt-callback retry-callback) + (define needs-retry? #f) + (atomically + (set-thread-interrupt-callback! t (lambda () + ;; If the interrupt callback gets invoked, + ;; then remember that we need a retry + (set! needs-retry? #t) + (interrupt-callback))) + (define finish (do-thread-deschedule! t timeout-at)) + ;; It's ok if the thread gets interrupted + ;; outside the atomic region, because we'd + ;; swap it out anyway + (lambda () + ;; In non-atomic mode: + (finish) + (when needs-retry? + (retry-callback))))) + +;; in atomic mode +;; Add a thread back to its thread group +(define (thread-reschedule! t) + (assert-atomic-mode) + (when (thread-dead? t) + (internal-error "tried to reschedule a dead thread")) + (unless (thread-descheduled? t) + (internal-error "tried to reschedule a scheduled thread")) + (set-thread-descheduled?! t #f) + (set-thread-interrupt-callback! t #f) + (remove-from-sleeping-threads! t) + (thread-group-add! (thread-parent t) t)) + +(define/who (thread-suspend t) + (check who thread? t) + ((atomically + (do-thread-suspend t)))) + +;; in atomic mode +;; Returns a thunk to call to handle the case that +;; the current thread is suspended +(define (do-thread-suspend t) + (assert-atomic-mode) + (cond + [(thread-dead? t) void] + [else + (unless (thread-suspended? t) + (set-thread-suspended?! t #t) + ;; Suspending a thread is similar to issuing a break; + ;; the thread should get out of any queues where it's + ;; waiting, etc.: + (run-interrupt-callback t) + (run-suspend/resume-callbacks t car) + (define suspended-evt (thread-suspended-evt t)) + (when suspended-evt + (set-suspend-resume-evt-thread! suspended-evt t) + (semaphore-post-all (suspend-resume-evt-sema suspended-evt)) + (set-thread-suspended-evt! t #f))) + (cond + [(not (thread-descheduled? t)) + (do-thread-deschedule! t #f)] + [else + void])])) + +(define/who (thread-resume t [benefactor #f]) + (check who thread? t) + (check who (lambda (p) (or (not p) (thread? p) (custodian? p))) + #:contract "(or/c #f thread? custodian?)" + benefactor) + (when (and (custodian? benefactor) + (custodian-shut-down? benefactor)) + (raise-custodian-is-shut-down who benefactor)) + (atomically + (do-thread-resume t benefactor))) + +;; in atomic mode +(define (do-thread-resume t benefactor) + (assert-atomic-mode) + (unless (thread-dead? t) + (cond + [(thread? benefactor) + (for ([cr (in-list (thread-custodian-references benefactor))]) + (add-custodian-to-thread! t (custodian-reference->custodian cr))) + (add-transitive-resume-to-thread! benefactor t)] + [(custodian? benefactor) + (add-custodian-to-thread! t benefactor)]) + (when (and (thread-suspended? t) + (pair? (thread-custodian-references t))) + (define resumed-evt (thread-resumed-evt t)) + (when resumed-evt + (set-suspend-resume-evt-thread! resumed-evt t) + (semaphore-post-all (suspend-resume-evt-sema resumed-evt)) + (set-thread-resumed-evt! t #f)) + (set-thread-suspended?! t #f) + (run-suspend/resume-callbacks t cdr) + (thread-reschedule! t) + (do-resume-transitive-resumes t #f)))) + +;; in atomic mode +(define (add-custodian-to-thread! t c) + (assert-atomic-mode) + (let loop ([crs (thread-custodian-references t)] + [accum null]) + (cond + [(null? crs) + (define new-crs + (cons (unsafe-custodian-register c t remove-thread-custodian #f #t) + accum)) + (set-thread-custodian-references! t new-crs) + (do-resume-transitive-resumes t c)] + [else + (define old-c (custodian-reference->custodian (car crs))) + (cond + [(or (eq? c old-c) + (custodian-subordinate? c old-c)) + ;; no need to add new + (void)] + [(custodian-subordinate? old-c c) + ;; new one replaces old one; we can simplify forget the + ;; old reference + (loop (cdr crs) accum)] + [else + ;; keep checking + (loop (cdr crs) (cons (car crs) accum))])]))) + +(struct transitive-resume (weak-box ; weak reference to thread + box) ; box is filled as stron reference if thread is suspended + #:authentic) + +;; in atomic mode +(define (add-transitive-resume-to-thread! t b-t) + (assert-atomic-mode) + ;; Look for `b-t` in list, and also prune + ;; terminated threads + (define new-l + (let loop ([l (thread-transitive-resumes t)]) + (cond + [(null? l) + ;; Force creation of `(thread-suspended-box t)`: + (set-thread-suspended?! b-t (thread-suspended? b-t)) + (list (transitive-resume (make-weak-box b-t) + (thread-suspended-box b-t)))] + [else + (let ([o-t (weak-box-value (transitive-resume-weak-box (car l)))]) + (cond + [(not o-t) (loop (cdr l))] + [(thread-dead? o-t) (loop (cdr l))] + [(eq? b-t o-t) l] + [else (cons (car l) (loop (cdr l)))]))]))) + (set-thread-transitive-resumes! t new-l)) + +;; in atomic mode +(define (do-resume-transitive-resumes t c) + (assert-atomic-mode) + (for ([tr (in-list (thread-transitive-resumes t))]) + (define b-t (weak-box-value (transitive-resume-weak-box tr))) + (when b-t + (do-thread-resume b-t c)))) + +;; Called in atomic mode: +;; Given callbacks are also called in atomic mode +(define (thread-push-suspend+resume-callbacks! s-cb r-cb) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-suspend+resume-callbacks! t (cons (cons s-cb r-cb) + (thread-suspend+resume-callbacks t)))) + +;; Called in atomic mode: +(define (thread-pop-suspend+resume-callbacks!) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-suspend+resume-callbacks! t (cdr (thread-suspend+resume-callbacks t)))) + +;; Called in atomic mode: +(define (run-suspend/resume-callbacks t sel) + (assert-atomic-mode) + (for ([cbs (in-list (thread-suspend+resume-callbacks t))]) + ((sel cbs)))) + +;; Called in atomic mode: +(define (run-interrupt-callback t) + (assert-atomic-mode) + (define interrupt-callback (thread-interrupt-callback t)) + (when interrupt-callback + ;; The interrupt callback might remove the thread as + ;; a waiter on a semaphore of channel; if breaks + ;; turn out to be disabled, the wait will be + ;; retried through the retry callback + (set-thread-interrupt-callback! t #f) + (interrupt-callback))) + +;; ---------------------------------------- +;; Suspend and resume events + +(struct suspend-resume-evt (sema ; semaphore, `always-evt`, or `never-evt` + [thread #:mutable]) ; set lazily to avoiding retaining the thread + #:property prop:evt (lambda (se) (wrap-evt (suspend-resume-evt-sema se) + (lambda (s) (suspend-resume-evt-thread se))))) + +(struct suspend-evt suspend-resume-evt () + #:reflection-name 'thread-suspend-evt) + +(struct resume-evt suspend-resume-evt () + #:reflection-name 'thread-resume-evt) + +(define/who (thread-resume-evt t) + (check who thread? t) + (atomically + (cond + [(thread-dead? t) + (resume-evt never-evt #f)] + [(thread-suspended? t) + (or (thread-resumed-evt t) + (let ([r (resume-evt (make-semaphore) #f)]) + (set-thread-resumed-evt! t r) + r))] + [else + (resume-evt always-evt t)]))) + +(define/who (thread-suspend-evt t) + (check who thread? t) + (atomically + (cond + [(thread-dead? t) + (suspend-evt never-evt #f)] + [(thread-suspended? t) + (suspend-evt always-evt t)] + [else + (or (thread-suspended-evt t) + (let ([s (suspend-evt (make-semaphore) #f)]) + (set-thread-suspended-evt! t s) + s))]))) + +;; ---------------------------------------- +;; Thread yielding + +;; Pause the current thread to let other threads run. If all threads +;; are paused, then `sched-info` contains information (such as a +;; timeout for the current thread's sleep) needed for a global sleep +(define (thread-yield sched-info) + (atomically + (cond + [(or (not sched-info) + (schedule-info-did-work? sched-info)) + (thread-did-work!)] + [else (thread-did-no-work!)]) + (set-thread-sched-info! (current-thread) sched-info)) + (engine-block)) + +;; Sleep for a while +(define/who (sleep [secs 0]) + (check who + (lambda (c) (and (real? c) (c . >= . 0))) + #:contract "(>=/c 0)" + secs) + (define until-msecs (+ (* secs 1000.0) + (current-inexact-milliseconds))) + (let loop () + ((thread-deschedule! (current-thread) + until-msecs + void + (lambda () + ;; Woke up due to an ignored break? + ;; Try again: + (loop)))))) + +;; ---------------------------------------- +;; Tracking thread progress + +;; If a thread does work before it is swapped out, then we should poll +;; all threads again. Accumulate a table of threads that we don't need +;; to poll because we've tried them since the most recent thread +;; performed work: +(define poll-done-threads #hasheq()) + +(define (thread-did-no-work!) + (set! poll-done-threads (hash-set poll-done-threads (current-thread) #t))) + +(define (thread-did-work!) + (set! poll-done-threads #hasheq())) + +;; ---------------------------------------- +;; Breaks + +;; The host implementation of `dynamic-wind` is expected to cooperate +;; with the implementation of breaks in terms of `break-enabled-key` +;; and boolean-valued, preserved thread cells. That's cooperattion is +;; awkward, in the sense that it defies the intended layering of +;; subsystems, but it allows the pre and post thunks of `dynamic-wind` +;; to reliably run with breaks disabled (especially during the +;; transition from one thunk to another during a jump). + +;; A continuation-mark key (not made visible to regular Racket code): +(define break-enabled-default-cell (make-thread-cell #t)) + +;; For disabling breaks, such as through `unsafe-start-atomic`: +(define break-suspend 0) +(define current-break-suspend + (case-lambda + [() break-suspend] + [(v) (set! break-suspend v)])) + +(define (current-break-enabled-cell) + (continuation-mark-set-first #f + break-enabled-key + break-enabled-default-cell + (root-continuation-prompt-tag))) + +(define break-enabled + (case-lambda + [() (thread-cell-ref (current-break-enabled-cell))] + [(on?) + (thread-cell-set! (current-break-enabled-cell) on?) + (when on? + (check-for-break))])) + +;; When the continuation-mark mapping to `break-enabled-key` is +;; changed, or when a thread is just swapped in, then +;; `check-for-break` should be called. +(define (check-for-break) + (define t (current-thread)) + (when t ; allow `check-for-break` before threads are running + ((atomically + (cond + [(and (thread-pending-break t) + (break-enabled) + (not (thread-ignore-break-cell? t (current-break-enabled-cell))) + (zero? (current-break-suspend))) + (define exn:break* (case (thread-pending-break t) + [(hang-up) exn:break:hang-up/non-engine] + [(terminate) exn:break:terminate/non-engine] + [else exn:break/non-engine])) + (set-thread-pending-break! t #f) + (lambda () + ;; Out of atomic mode + (call-with-escape-continuation + (lambda (k) + (raise (exn:break* + "user break" + (current-continuation-marks) + k)))))] + [else void]))))) + +;; The break-enabled transition hook is called by the host +;; system when a control transfer (such as a continuation jump) +;; enters a place where the `break-enabled-key` continuation +;; mark has a different value. +(void + (set-break-enabled-transition-hook! check-for-break)) + +(define/who (break-thread t [kind #f]) + (check who thread? t) + (check who (lambda (k) (or (not k) (eq? k 'hang-up) (eq? k 'terminate))) + #:contract "(or/c #f 'hang-up 'terminate)" + kind) + (do-break-thread t (or kind 'break) (current-thread))) + +;; Might be called in atomic mode, but `check-t` is #f in that case +(define (do-break-thread t kind check-t) + ((atomically + (cond + [(thread-forward-break-to t) + => (lambda (other-t) + (lambda () (do-break-thread other-t kind check-t)))] + [else + (when (and (thread-pending-break t) + (break>? kind (thread-pending-break t))) + (set-thread-pending-break! t kind)) + (unless (thread-pending-break t) + (set-thread-pending-break! t kind) + (thread-did-work!) + (when (thread-descheduled? t) + (unless (thread-suspended? t) + (run-interrupt-callback t) + (thread-reschedule! t)))) + void]))) + (when (eq? t check-t) + (check-for-break))) + +(define (break>? k1 k2) + (cond + [(eq? k1 'break) #f] + [(eq? k1 'hang-up) (eq? k2 'break)] + [else (not (eq? k2 'terminate))])) + +(define (break-max k1 k2) + (cond + [(not (and k1 k2)) (or k1 k2)] + [(break>? k1 k2) k1] + [else k2])) + +(void + (set-ctl-c-handler! + (lambda (kind) + (do-break-thread root-thread kind #f)))) + +;; in atomic mode: +(define (thread-ignore-break-cell? t bc) + (assert-atomic-mode) + (let ([ignore (thread-ignore-break-cells t)]) + (or (eq? ignore bc) + (and (hash? ignore) + (hash-ref ignore bc #f))))) + +;; in atomic mode: +(define (thread-ignore-break-cell! t bc) + (assert-atomic-mode) + (let ([ignore (thread-ignore-break-cells t)]) + (set-thread-ignore-break-cells! t (cond + [(not ignore) + ;; Singleton + bc] + [(hash? ignore) + ;; Add to set + (hash-set ignore bc #t)] + [else + ;; Convert to set + (hasheq ignore #t bc #t)])))) + +;; in atomic mode +(define (thread-remove-ignored-break-cell! t bc) + (assert-atomic-mode) + (when (thread-ignore-break-cell? t bc) + (let ([ignore (thread-ignore-break-cells t)]) + (set-thread-ignore-break-cells! t (cond + [(eq? ignore bc) #f] + [else (hash-remove ignore bc)]))))) + +;; ---------------------------------------- +;; Thread mailboxes + +;; in atomic mode +(define (enqueue-mail! thd v) + (assert-atomic-mode) + (queue-add! (thread-mailbox thd) v)) + +;; in atomic mode +(define (dequeue-mail! thd) + (assert-atomic-mode) + (define mbx (thread-mailbox thd)) + (cond + [(queue-empty? mbx) + (internal-error "No Mail!\n")] + [else + (queue-remove! mbx)])) + +;; in atomic mode +(define (is-mail? thd) + (assert-atomic-mode) + (not (queue-empty? (thread-mailbox thd)))) + +;; in atomic mode +(define (push-mail! thd v) + (assert-atomic-mode) + (queue-add-front! (thread-mailbox thd) v)) + +(define/who (thread-send thd v [fail-thunk + (lambda () + (raise-arguments-error 'thread-send "target thread is not running"))]) + (check who thread? thd) + (check who (procedure-arity-includes/c 0) #:or-false fail-thunk) + ((atomically + (cond + [(not (thread-dead? thd)) + (enqueue-mail! thd v) + (define wakeup (thread-mailbox-wakeup thd)) + (set-thread-mailbox-wakeup! thd void) + (wakeup) + void] + [fail-thunk + fail-thunk] + [else + (lambda () #f)])))) + +(define/who (thread-condition-awaken thd) + (check who thread? thd) + ((atomically + (cond + [(not (thread-dead? thd)) + (define wakeup (thread-condition-wakeup thd)) + (set-thread-condition-wakeup! thd void) + wakeup] ;; should be called outside of atomic mode? + [else + (lambda () #f)])))) + +(define (thread-condition-wait lock-release) + ((atomically + (define t (current-thread)) + (set-thread-condition-wakeup! t (sandman-condition-wait t)) + (lock-release) + (define do-yield + (thread-deschedule! t + #f + void + (lambda () + ;; try again? + (do-yield)) + )) + (lambda () + (do-yield))))) + +(define (thread-receive) + ((atomically + (define t (current-thread)) + (cond + [(is-mail? t) + (define v (dequeue-mail! t)) + (lambda () v)] + [else + ;; The current wakeup callback must be `void`, since this thread + ;; can't be in the middle of a `sync` (unless interrupted by a break) + ;; or `thread-receive` + (set-thread-mailbox-wakeup! t (lambda () (thread-reschedule! t))) + (define do-yield + (thread-deschedule! t + #f + ;; Interrupted for break => not waiting for mail + (lambda () + (set-thread-mailbox-wakeup! t void)) + ;; No retry action, because we always retry: + void)) + ;; called out of atomic mode: + (lambda () + (do-yield) + (thread-receive))])))) + +(define (thread-try-receive) + (atomically + (define t (current-thread)) + (if (is-mail? t) + (dequeue-mail! t) + #f))) + +(define/who (thread-rewind-receive lst) + (check who list? lst) + (atomically + (define t (current-thread)) + (for-each (lambda (msg) + (push-mail! t msg)) + lst))) + +;; ---------------------------------------- + +(struct thread-receiver-evt () + #:property prop:evt (poller + ;; in atomic mode: + (lambda (self poll-ctx) + (assert-atomic-mode) + (define t (current-thread)) + (cond + [(is-mail? t) (values (list self) #f)] + [(poll-ctx-poll? poll-ctx) (values #f self)] + [else + (define receive (let ([select-proc (poll-ctx-select-proc poll-ctx)]) + (lambda () + (when (is-mail? t) + (select-proc))))) + (define (add-wakeup-callback!) + (define wakeup (thread-mailbox-wakeup t)) + (set-thread-mailbox-wakeup! t (lambda () (wakeup) (receive)))) + (add-wakeup-callback!) + (values #f (control-state-evt + (wrap-evt async-evt (lambda (v) self)) + ;; interrupt (all must be interrupted, so just install `void`): + (lambda () (set-thread-mailbox-wakeup! t void)) + ;; abandon: + (lambda () (set! receive void)) + ;; retry (was interrupted, but not abandoned): + (lambda () (add-wakeup-callback!))))]))) + #:reflection-name 'thread-receive-evt) + +(define/who (thread-receive-evt) + (thread-receiver-evt)) diff -Nru racket-6.12+ppa1/src/thread/time.rkt racket-7.0+ppa1/src/thread/time.rkt --- racket-6.12+ppa1/src/thread/time.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/time.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base +(require "check.rkt" + (submod "thread.rkt" scheduling) + (prefix-in engine: "engine.rkt")) + +(provide current-process-milliseconds + set-get-subprocesses-time!) + +(define/who (current-process-milliseconds [scope #f]) + (cond + [(not scope) (engine:current-process-milliseconds)] + [(thread? scope) (thread-cpu-time scope)] + [(eq? scope 'subprocesses) (get-subprocesses-time)] + [else + (raise-argument-error who "(or/c #f thread? 'subprocesses)" scope)])) + +(define get-subprocesses-time (lambda () 0)) + +(define (set-get-subprocesses-time! f) + (set! get-subprocesses-time f)) diff -Nru racket-6.12+ppa1/src/thread/tree.rkt racket-7.0+ppa1/src/thread/tree.rkt --- racket-6.12+ppa1/src/thread/tree.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/tree.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,249 @@ +#lang racket/base + +;; Balanced binary tree ---- immutable and parameterized +;; over the less-than function + +(provide empty-tree + (rename-out [is-empty? tree-empty?] + [lookup tree-ref] + [insert tree-set] + [delete tree-remove] + [min-key+value tree-min] + [max-key+value tree-max])) + +(struct node (key val height left right) + #:transparent) + +(define empty-tree #f) + +(define (is-empty? t) (not t)) + +;; ---------------------------------------- + +(define (tree-height t) + (cond + [(not t) 0] + [else (node-height t)])) + +(define (tree-balance t) + (- (tree-height (node-left t)) + (tree-height (node-right t)))) + +(define (combine key val left right) + (node key + val + (add1 (max (tree-height left) (tree-height right))) + left + right)) + +(define (reverse-combine key val right left) + (combine key val left right)) + +;; ---------------------------------------- + +(define (lookup t key bool) -> tree +(define (insert t key val bool) +;; (tree-of-X -> tree-of-X) +;; (tree-of-X -> tree-of-X) +;; (X tree-of-X tree-of-X -> tree-of-X) +;; -> tree +;; Like insert, but inserts to a child, where `node-to' +;; determines the side where the child is added,`node-other' +;; is the other side, and `comb' builds the new tree gven the +;; two new children. +(define (insert-to t new-key new-val string i) string (car l)) (lookup t (car l) <)) + (define new-t (delete t (car l) <)) + (check-equal? #f (lookup new-t (car l) <)) + (check-balance? new-t) + (loop new-t (cdr l))])))) + + "tests passed") diff -Nru racket-6.12+ppa1/src/thread/unsafe.rkt racket-7.0+ppa1/src/thread/unsafe.rkt --- racket-6.12+ppa1/src/thread/unsafe.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/unsafe.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,35 @@ +#lang racket/base +(require "atomic.rkt" + "thread.rkt" + "schedule.rkt" + "evt.rkt") + +(provide unsafe-start-atomic + unsafe-end-atomic + unsafe-start-breakable-atomic + unsafe-end-breakable-atomic + unsafe-in-atomic? + unsafe-set-on-atomic-timeout!) + +(define (unsafe-start-breakable-atomic) + (start-atomic)) + +(define (unsafe-end-breakable-atomic) + (end-atomic)) + +(define (unsafe-start-atomic) + (start-atomic) + (current-break-suspend (add1 (current-break-suspend)))) + +(define (unsafe-end-atomic) + (define bs (sub1 (current-break-suspend))) + (current-break-suspend bs) + (end-atomic) + (when (zero? bs) + (check-for-break))) + +(define (unsafe-in-atomic?) + (positive? (current-atomic))) + +(define (unsafe-set-on-atomic-timeout! proc) + (set-atomic-timeout-callback! proc)) diff -Nru racket-6.12+ppa1/src/thread/waiter.rkt racket-7.0+ppa1/src/thread/waiter.rkt --- racket-6.12+ppa1/src/thread/waiter.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/waiter.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,42 @@ +#lang racket/base +(require "internal-error.rkt") + +(provide prop:waiter + make-waiter-methods + waiter-resume! + waiter-suspend! + + select-waiter) + +;; A waiter can be in the queue for a semaphore or +;; channel +(define-values (prop:waiter waiter? waiter-ref) + (make-struct-type-property 'waiter)) + +(struct waiter-methods (suspend resume)) + +(define (make-waiter-methods #:suspend! suspend + #:resume! resume) + (waiter-methods suspend resume)) + + +(define (waiter-resume! w s) + ((waiter-methods-resume (waiter-ref w)) w s)) + +;; `interrupt-cb` is run if the suspend is interrupted by +;; either a break or kill; `abandon-cb` is called in +;; addition if it's a kill or a bresk escape; +;; `retry-cb` is run, instead, if the suspend +;; should be retired, and it's a thunk that runs in +;; atomic mode and returns a thunk to run in tail position +;; out of atomic mode +(define (waiter-suspend! w interrupt-cb retry-cb) + ((waiter-methods-suspend (waiter-ref w)) w interrupt-cb retry-cb)) + +;; Used for semaphores and channels to run a "just selected" callback +;; when synchronized: +(struct select-waiter (proc) + #:property prop:waiter + (make-waiter-methods #:suspend! (lambda args (internal-error "should not suspend a select-waiter")) + #:resume! (lambda (w s) + ((select-waiter-proc w))))) diff -Nru racket-6.12+ppa1/src/thread/will-executor.rkt racket-7.0+ppa1/src/thread/will-executor.rkt --- racket-6.12+ppa1/src/thread/will-executor.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/thread/will-executor.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,60 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "evt.rkt" + "sync.rkt" + "semaphore.rkt") + +;; The core must provide `will-try-execute`. We implement +;; `will-execute` here, because it has to block when no will is ready. + +(provide make-will-executor + make-stubborn-will-executor + will-executor? + will-register + will-try-execute + will-execute) + +(struct will-executor (host-we sema) + #:authentic + #:property prop:evt (lambda (we) + (wrap-evt (semaphore-peek-evt (will-executor-sema we)) + (lambda (v) we)))) + +(define (do-make-will-executor host:make-will-executor) + (define sema (make-semaphore)) + (will-executor (host:make-will-executor + ;; called in scheduler: + (lambda () (semaphore-post/atomic sema))) + sema)) + +(define (make-will-executor) + (do-make-will-executor host:make-will-executor)) + +(define (make-stubborn-will-executor) + (do-make-will-executor host:make-stubborn-will-executor)) + +(define/who (will-register we v proc) + (check who will-executor? we) + (check who (procedure-arity-includes/c 1) proc) + (host:will-register (will-executor-host-we we) v proc)) + +(define (do-will-execute who we fail-k) + (check who will-executor? we) + ((atomically + (cond + [(host:will-try-execute (will-executor-host-we we)) + => (lambda (p) + (semaphore-wait/atomic (will-executor-sema we)) + (lambda () + ((car p) (cdr p))))] + [else fail-k])))) + +(define/who (will-execute we) + (do-will-execute who we (lambda () + (sync we) + (will-execute we)))) + +(define/who (will-try-execute we [default #f]) + (do-will-execute who we (lambda () default))) diff -Nru racket-6.12+ppa1/src/worksp/build.bat racket-7.0+ppa1/src/worksp/build.bat --- racket-6.12+ppa1/src/worksp/build.bat 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/build.bat 2018-07-27 22:12:02.000000000 +0000 @@ -18,16 +18,28 @@ if not defined BUILD_CONFIG set BUILD_CONFIG=..\..\etc +cl cstartup.c +cstartup.exe ..\racket\src\startup.inc libracket\startup.inc +if errorlevel 1 exit /B 1 +if not exist libracket\cstartup.inc echo #include "startup.inc" > libracket\cstartup.inc + cd racket msbuild racket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% if errorlevel 1 exit /B 1 +..\..\..\racketcgc -cu ..\..\racket\src\compile-startup.rkt ..\libracket\cstartup.inc ..\libracket\cstartup.zo ..\..\racket\src\startup.inc ..\..\racket\src\schvers.h +if errorlevel 1 exit /B 1 +msbuild racket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% + cd ..\gracket msbuild gracket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% if errorlevel 1 exit /B 1 cd .. +REM Assumes that Racket is started in a subdirectory of here: +set BOOT_SETUP=-W "info@compiler/cm error" -l- setup --boot ../../setup-go.rkt ../compiled + cd gc2 -..\..\..\racketcgc -G ..\%BUILD_CONFIG% -cu make.rkt +..\..\..\racketcgc -G ..\%BUILD_CONFIG% %BOOT_SETUP% make.none ../compiled/make.dep make.rkt if errorlevel 1 exit /B 1 cd .. @@ -45,7 +57,7 @@ cd .. cd mzcom -..\..\..\racket -G ..\%BUILD_CONFIG% -cu xform.rkt +..\..\..\racket -G ..\%BUILD_CONFIG% %BOOT_SETUP% mzcom.none ../compiled/mzcom.dep xform.rkt if errorlevel 1 exit /B 1 cd .. diff -Nru racket-6.12+ppa1/src/worksp/cs/Makefile racket-7.0+ppa1/src/worksp/cs/Makefile --- racket-6.12+ppa1/src/worksp/cs/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/cs/Makefile 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,24 @@ + +INCS = /I.. /I..\..\rktio /I..\librktio /I$(SCHEME_DIR)\$(MACHINE)\boot\$(MACHINE) + +RKTIO_LIB = ..\..\build\librktio.lib +BASE_WIN32_LIBS = WS2_32.lib Shell32.lib User32.lib +WIN32_LIBS = $(BASE_WIN32_LIBS) RpCrt4.lib Ole32.lib + +LIBS = $(RKTIO_LIB) \ + $(SCHEME_DIR)\$(MACHINE)\boot\$(MACHINE)\$(SCHEME_LIB) \ + $(WIN32_LIBS) + +DEST = ..\..\build\raw_racketcs.exe +CSDIR = ..\..\cs\c + +$(DEST): $(CSDIR).\main.c $(CSDIR)\boot.c $(RKTIO_LIB) + cl /Fe$(DEST) /Ox /MT $(INCS) $(CSDIR)\main.c $(CSDIR)\boot.c $(LIBS) + + +# Useful for debugging: + +RKTIO_DLL = ..\..\lib\librktio.dll + +rktio-dll: + cl /Fe$(RKTIO_DLL) /LD $(RKTIO_LIB) $(BASE_WIN32_LIBS) ..\..\rktio\rktio.def /link /machine:x64 diff -Nru racket-6.12+ppa1/src/worksp/cs/prep.rkt racket-7.0+ppa1/src/worksp/cs/prep.rkt --- racket-6.12+ppa1/src/worksp/cs/prep.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/cs/prep.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,54 @@ +#lang racket/base + +;; Do the same work that Chez Scheme's `configure` performs +;; to set up build directories for Windows. + +(provide prep-chez-scheme) + +(define (prep-chez-scheme dir machine-name) + (define (not-git? p) + (define-values (base name dir?) (split-path p)) + (not (equal? ".git" (path->string name)))) + + (define (maybe-make-directory p) + (unless (directory-exists? p) (make-directory p))) + + (define (copy-one-dir name) + (define src-dir (build-path dir name)) + (define dest-dir (build-path dir machine-name name)) + (maybe-make-directory dest-dir) + (define paths (parameterize ([current-directory src-dir]) + (for/list ([p (in-directory #f not-git?)]) + p))) + (for ([p (in-list paths)]) + (define src-p (build-path src-dir p)) + (define dest-p (build-path dest-dir p)) + (cond + [(directory-exists? src-p) + (maybe-make-directory dest-p)] + [else + (define src-ts (file-or-directory-modify-seconds src-p)) + (define dest-ts (file-or-directory-modify-seconds dest-p #f (lambda () #f))) + (unless (and dest-ts (dest-ts . >= . src-ts)) + (printf "copying ~a\n" (build-path name p)) + (copy-file src-p dest-p #t))]))) + + (maybe-make-directory (build-path dir machine-name)) + (maybe-make-directory (build-path dir machine-name "boot")) + (maybe-make-directory (build-path dir machine-name "bin")) + (maybe-make-directory (build-path dir machine-name "bin" machine-name)) + + (copy-one-dir "c") + (copy-one-dir "s") + (copy-one-dir "mats") + (copy-one-dir "nanopass") + (copy-one-dir "zlib") + (copy-one-dir (build-path "boot" machine-name)) + + (define config-h (build-path dir machine-name "c" "config.h")) + (unless (file-exists? config-h) + (printf "making ~a\n" config-h) + (call-with-output-file* + config-h + (lambda (o) + (fprintf o "#define SCHEME_SCRIPT \"scheme-script\""))))) diff -Nru racket-6.12+ppa1/src/worksp/csbuild.rkt racket-7.0+ppa1/src/worksp/csbuild.rkt --- racket-6.12+ppa1/src/worksp/csbuild.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/csbuild.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,156 @@ +#lang racket/base +(require racket/cmdline + racket/path + racket/file + racket/runtime-path + compiler/find-exe + racket/system + "cs/prep.rkt") + +(define-runtime-path here ".") + +(define abs-scheme-dir (build-path here 'up "build" "ChezScheme")) +(define machine (if (= 32 (system-type 'word)) + "ti3nt" + "ta6nt")) + +(command-line + #:once-each + [("--scheme-dir") dir "Select the Chez Scheme build directory, unless is \"\"" + (unless (equal? dir "") + (set! abs-scheme-dir (path->complete-path dir)))] + [("--machine") mach "Select the Chez Scheme machine name" + (set! machine mach)] + #:args + () + (void)) + +(current-directory here) + +(define scheme-dir (find-relative-path (current-directory) + (simplify-path abs-scheme-dir))) + +(define (system*! prog . args) + (printf "{in ~a}\n" (current-directory)) + (printf "~a" prog) + (for ([arg (in-list args)]) + (printf " [~a]" arg)) + (newline) + (unless (apply system* + (if (string? prog) + (find-executable-path (path-add-extension prog #".exe")) + prog) + args) + (error 'csbuild "command failed"))) + +(define (system! cmd) + (printf "{in ~a}\n" (current-directory)) + (printf "~a\n" cmd) + (unless (system cmd) + (error 'csbuild "command failed"))) + +;; ---------------------------------------- + +(unless (directory-exists? scheme-dir) + (system*! "git" + "clone" + "git@github.com:mflatt/ChezScheme" + scheme-dir)) + +(unless (file-exists? (build-path scheme-dir "zlib" "Makefile")) + (parameterize ([current-directory scheme-dir]) + (system*! "git" "submodule" "init") + (system*! "git" "submodule" "update"))) + +(prep-chez-scheme scheme-dir machine) + +(parameterize ([current-directory (build-path scheme-dir machine "c")]) + (system*! "nmake" (format "Makefile.~a" machine))) + +;; ---------------------------------------- + +;; Run Racket in directories that reach here with "../worksp". +;; By using a relative path, we avoid problems with spaces in path names. +(define rel-racket (build-path 'up "worksp" (find-relative-path (current-directory) (find-exe)))) + +(define chain-racket + (format "~a -W info@compiler/cm -l- setup --chain ../setup-go.rkt ../build/compiled" + rel-racket)) + +(define build-dir (path->directory-path (build-path 'up "build"))) + +;; ---------------------------------------- + +(define (build-layer name + #:dir [dir name] + #:skip-make? [skip-make? #f]) + (parameterize ([current-directory (build-path 'up dir)]) + (make-directory* (build-path build-dir "compiled")) + (unless skip-make? + (system*! "nmake" + (format "~a-src-generate" name) + (format "BUILDDIR=~a" build-dir) + (format "RACKET=~a ~a ~a" chain-racket "ignored" (build-path build-dir "compiled/ignored.d")))))) + +(build-layer "expander") +(build-layer "thread") +(build-layer "io") +(build-layer "regexp") + +(build-layer "schemify") +(build-layer "known" #:dir "schemify") + +;; ---------------------------------------- + +(define scheme (build-path scheme-dir machine "bin" machine "scheme.exe")) +(define rel-scheme (build-path 'up "worksp" + (if (relative-path? scheme) + scheme + (find-relative-path (current-directory) scheme)))) + +;; Environment variable used by ".sls" files to find ".scm" files +(putenv "COMPILED_SCM_DIR" "../build/compiled/") + +(parameterize ([current-directory (build-path 'up "cs")]) + (define convert.d (build-path build-dir "compiled" "convert.d")) + (unless (file-exists? convert.d) (call-with-output-file convert.d void)) + (system*! "nmake" + (build-path "../build/racket.so") ; need forward slashes + (format "RACKET=~a" rel-racket) + (format "SCHEME=~a" rel-scheme) + (format "BUILDDIR=../build/") ; need forward slashes + (format "CONVERT_RACKET=~a" chain-racket))) + +;; ---------------------------------------- + +(system! "rktio.bat") + +;; ---------------------------------------- + +;; The library name changes with the version: +(define scheme-lib + (parameterize ([current-directory (build-path scheme-dir machine "boot" machine)]) + (for/or ([f (in-list (directory-list))] + #:when (regexp-match? #rx"^csv.*mt.lib$" f)) + f))) + +(define rel2-scheme-dir (build-path 'up + (if (relative-path? scheme-dir) + scheme-dir + (find-relative-path (current-directory) scheme-dir)))) + +(parameterize ([current-directory "cs"]) + (system*! "nmake" + "..\\..\\build\\raw_racketcs.exe" + (format "SCHEME_DIR=~a" rel2-scheme-dir) + (format "MACHINE=~a" machine) + (format "SCHEME_LIB=~a" scheme-lib))) + +;; ---------------------------------------- + +(system*! (find-exe) + "../cs/c/embed-boot.rkt" + "../build/raw_racketcs.exe" + "../../RacketCS.exe" + (build-path scheme-dir machine "boot" machine) + "../build/racket.so") diff -Nru racket-6.12+ppa1/src/worksp/cstartup.c racket-7.0+ppa1/src/worksp/cstartup.c --- racket-6.12+ppa1/src/worksp/cstartup.c 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/cstartup.c 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,56 @@ +#include +#include +#include + +/* 65535 characters should be enough for any string --- or so says + MSVC. Convert "startup.inc" to a character array. */ + +int main(int argc, char **argv) { + struct _stat s1, s2; + FILE *in, *out; + int c, col = 0; + + if (_stat(argv[1], &s1) == 0) { + if (_stat(argv[2], &s2) == 0) { + if (s2.st_mtime > s1.st_mtime) { + printf("Generated file is already newer than source\n"); + return 0; + } + } + } + + in = fopen(argv[1], "r"); + out = fopen(argv[2], "w"); + + fprintf(out, "#define EVAL_STARTUP EVAL_ONE_STR((char *)startup_source)\n"); + fprintf(out, "static unsigned char startup_source[] = {\n"); + + while (1) { + while (1) { + c = fgetc(in); + if (c == '"') + break; + + if (c == EOF) { + fprintf(out, "\n 0 };\n"); + return 0; + } + } + + while (1) { + c = fgetc(in); + if (c == '"') + break; + if (c == '\\') + c = fgetc(in); + fprintf(out, "%d,", c); + col++; + if (col == 20) { + fprintf(out, "\n"); + col = 0; + } + } + } + + return 0; +} diff -Nru racket-6.12+ppa1/src/worksp/gc2/make.rkt racket-7.0+ppa1/src/worksp/gc2/make.rkt --- racket-6.12+ppa1/src/worksp/gc2/make.rkt 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/gc2/make.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,8 +1,6 @@ #lang racket/base - -(use-compiled-file-paths null) - -(require racket/system) +(require racket/system + (for-label "../../racket/gc2/xform-mod.rkt")) (define (system- s) (eprintf "~a\n" s) @@ -34,7 +32,6 @@ '("salloc" "bignum" "bool" - "builtin" "char" "compenv" "compile" @@ -57,9 +54,9 @@ "jitstack" "jitstate" "letrec_check" + "linklet" "list" "marshal" - "module" "mzrt" "network" "numarith" @@ -78,6 +75,8 @@ "sema" "setjmpup" "sfs" + "sort" + "startup" "string" "struct" "symbol" @@ -115,13 +114,10 @@ (sync (thread (lambda () - (parameterize ([use-compiled-file-paths (list "compiled")] - [current-namespace (make-base-namespace)] + (parameterize ([current-namespace (make-base-namespace)] [current-command-line-arguments (list->vector (append - (list "--setup" - ".") (if objdest (if use-precomp (list "--precompiled" use-precomp) @@ -141,7 +137,7 @@ "-o" dest src)))]) - (dynamic-require "../../racket/gc2/xform.rkt" #f) + (dynamic-require "../../racket/gc2/xform-mod.rkt" #f) (set! success? #t))))) (unless success? (when (file-exists? dest) @@ -168,8 +164,7 @@ (unless (system- (format "~a ~a /MT /Zi /GS- ~a /c ~a /Fdxsrc/ /Fo~a" cl.exe flags opt-flags c o)) (error "failed compile")))) -(define common-deps (list "../../racket/gc2/xform.rkt" - "../../racket/gc2/xform-mod.rkt")) +(define common-deps (list "../../racket/gc2/xform-mod.rkt")) (define (find-build-file d f) (define (find-release d2) @@ -193,6 +188,7 @@ (string-append "/I../../racket/include " "/I../../rktio " "/I../librktio " + "/I../libracket " "/I.. ")) (try "precomp.c" (list* "../../racket/src/schvers.h" @@ -367,7 +363,8 @@ (link-exe (list "racket.res" - "xsrc/main.obj") + "xsrc/main.obj" + (find-build-file "racket" "MemoryModule.obj")) null exe "") @@ -398,7 +395,8 @@ (link-exe (list "gracket.res" - "xsrc/grmain.obj") + "xsrc/grmain.obj" + (find-build-file "racket" "MemoryModule.obj")) '("advapi32.lib") "../../../lib/GRacket.exe" " /subsystem:windows") diff -Nru racket-6.12+ppa1/src/worksp/.gitignore racket-7.0+ppa1/src/worksp/.gitignore --- racket-6.12+ppa1/src/worksp/.gitignore 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/.gitignore 2018-07-27 22:12:02.000000000 +0000 @@ -7,6 +7,8 @@ */SGC */*.user +cs/*.obj + # files generated by Visual Studio */*.ncb */*.opensdf @@ -20,9 +22,17 @@ */*X.vcxproj */*X.sln +/libracket/startup.inc +/libracket/cstartup.inc +/libracket/cstartup.zo + checkvs9.obj checkvs9.exe genvsx.obj genvsx.exe rbuildmode.obj rbuildmode.exe +cstartup.obj +cstartup.exe + +/compiled diff -Nru racket-6.12+ppa1/src/worksp/gracket/gracket.vcproj racket-7.0+ppa1/src/worksp/gracket/gracket.vcproj --- racket-6.12+ppa1/src/worksp/gracket/gracket.vcproj 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/gracket/gracket.vcproj 2018-07-27 22:12:02.000000000 +0000 @@ -473,6 +473,10 @@ RelativePath="..\..\gracket\grmain.c" > + + + diff -Nru racket-6.12+ppa1/src/worksp/libracket/libracket.vcproj racket-7.0+ppa1/src/worksp/libracket/libracket.vcproj --- racket-6.12+ppa1/src/worksp/libracket/libracket.vcproj 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/libracket/libracket.vcproj 2018-07-27 22:12:02.000000000 +0000 @@ -30,7 +30,7 @@ - - @@ -488,7 +484,7 @@ > + + + + diff -Nru racket-6.12+ppa1/src/worksp/libracket/libracket.vcxproj racket-7.0+ppa1/src/worksp/libracket/libracket.vcxproj --- racket-6.12+ppa1/src/worksp/libracket/libracket.vcxproj 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/libracket/libracket.vcxproj 2018-07-27 22:12:02.000000000 +0000 @@ -61,7 +61,7 @@ - ..;..\..\racket\include;..\..\racket\src;..\libffi;..\..\foreign\libffi\src\x86;..\..\foreign\libffi\include;..\..\rktio;..\librktio + ..;..\..\racket\include;..\..\racket\src;..\libffi;..\..\foreign\libffi\src\x86;..\..\foreign\libffi\include;..\..\rktio;..\librktio;..\libracket true Level3 @@ -172,7 +172,6 @@ - @@ -198,7 +197,7 @@ - + @@ -220,6 +219,8 @@ + + diff -Nru racket-6.12+ppa1/src/worksp/mrstart/mrstart.vcproj racket-7.0+ppa1/src/worksp/mrstart/mrstart.vcproj --- racket-6.12+ppa1/src/worksp/mrstart/mrstart.vcproj 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/mrstart/mrstart.vcproj 2018-07-27 22:12:02.000000000 +0000 @@ -198,7 +198,7 @@ Filter="cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90" > - + diff -Nru racket-6.12+ppa1/src/worksp/mzcom/xform.rkt racket-7.0+ppa1/src/worksp/mzcom/xform.rkt --- racket-6.12+ppa1/src/worksp/mzcom/xform.rkt 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/mzcom/xform.rkt 2018-07-27 22:12:02.000000000 +0000 @@ -1,16 +1,14 @@ #lang racket/base - +(require (for-label "../../racket/gc2/xform-mod.rkt")) + (define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32 /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0") (define includes "/I ../../racket/include /I . /I .. /I ../../mzcom") (define (xform src dest) - (parameterize ([use-compiled-file-paths (list "compiled")] - [current-command-line-arguments + (parameterize ([current-command-line-arguments (list->vector (append - (list "--setup" - "../gc2" - "--indirect" + (list "--indirect" "--depends") (list "--cpp" @@ -20,6 +18,6 @@ "-o" dest src)))]) - (dynamic-require "../../racket/gc2/xform.rkt" #f))) + (dynamic-require "../../racket/gc2/xform-mod.rkt" #f))) (xform "../../mzcom/mzobj.cxx" "../../mzcom/mzobj3m.cxx") diff -Nru racket-6.12+ppa1/src/worksp/mzstart/mzstart.vcproj racket-7.0+ppa1/src/worksp/mzstart/mzstart.vcproj --- racket-6.12+ppa1/src/worksp/mzstart/mzstart.vcproj 2016-04-15 20:33:56.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/mzstart/mzstart.vcproj 2018-07-27 22:12:02.000000000 +0000 @@ -108,7 +108,7 @@ Filter="cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90" > - + diff -Nru racket-6.12+ppa1/src/worksp/racket/racket.vcproj racket-7.0+ppa1/src/worksp/racket/racket.vcproj --- racket-6.12+ppa1/src/worksp/racket/racket.vcproj 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/racket/racket.vcproj 2018-07-27 22:12:02.000000000 +0000 @@ -467,6 +467,10 @@ > + + diff -Nru racket-6.12+ppa1/src/worksp/racket/racket.vcxproj racket-7.0+ppa1/src/worksp/racket/racket.vcxproj --- racket-6.12+ppa1/src/worksp/racket/racket.vcxproj 2017-07-07 19:13:22.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/racket/racket.vcxproj 2018-07-27 22:12:02.000000000 +0000 @@ -191,6 +191,7 @@ + diff -Nru racket-6.12+ppa1/src/worksp/rktio.bat racket-7.0+ppa1/src/worksp/rktio.bat --- racket-6.12+ppa1/src/worksp/rktio.bat 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.0+ppa1/src/worksp/rktio.bat 2018-07-27 22:12:02.000000000 +0000 @@ -0,0 +1,23 @@ +setlocal + +cl rbuildmode.c +rbuildmode.exe +if errorlevel 1 (set BUILDMODE=win32) else (set BUILDMODE=x64) + +cl checkvs9.c +checkvs9.exe +if errorlevel 1 (set PLTSLNVER=9) + +set VCPROJ=vcproj + +cl genvsx.c +genvsx.exe +if errorlevel 1 (set PLTSLNVER=X) +if errorlevel 1 (set VCPROJ=vcxproj) + +cd librktio +msbuild librktio%PLTSLNVER%.%VCPROJ% /p:Configuration=Release /p:Platform=%BUILDMODE% +if errorlevel 1 exit /B 1 + +copy %BUILDMODE%\Release\librktio.lib ..\..\build\librktio.lib +cd ..